module Futhark.Fmt.Printer
  ( fmtToText,
    fmtToDoc,
  )
where

import Data.Bifunctor (second)
import Data.Foldable
import Data.Loc (locStart)
import Data.Text qualified as T
import Futhark.Fmt.Monad
import Futhark.Util (showText)
import Futhark.Util.Pretty
  ( AnsiStyle,
    Doc,
    Pretty,
    docText,
  )
import Language.Futhark
import Language.Futhark.Parser
  ( SyntaxError (..),
    parseFutharkWithComments,
  )

lineIndent :: (Located a) => a -> Fmt -> Fmt -> Fmt
lineIndent :: forall a. Located a => a -> Fmt -> Fmt -> Fmt
lineIndent a
l Fmt
a Fmt
b = a -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
fmtByLayout a
l (Fmt
a Fmt -> Fmt -> Fmt
<+> Fmt
b) (Fmt
a Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
hardStdIndent (Fmt -> Fmt
align Fmt
b))

fmtName :: AnsiStyle -> Name -> Fmt
fmtName :: AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
style = AnsiStyle -> Text -> Fmt
text AnsiStyle
style (Text -> Fmt) -> (Name -> Text) -> Name -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
nameToText

fmtBoundName :: Name -> Fmt
fmtBoundName :: Name -> Fmt
fmtBoundName Name
name
  | Name -> Bool
operatorName Name
name = Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name
  | Bool
otherwise = AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name

fmtPretty :: (Pretty a) => a -> Fmt
fmtPretty :: forall a. Pretty a => a -> Fmt
fmtPretty = AnsiStyle -> Text -> Fmt
text AnsiStyle
forall a. Monoid a => a
mempty (Text -> Fmt) -> (a -> Text) -> a -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. Pretty a => a -> Text
prettyText

class Format a where
  fmt :: a -> Fmt

instance Format DocComment where
  fmt :: DocComment -> Fmt
fmt (DocComment Text
x SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
nil ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ [Text] -> [Fmt]
prefixes (Text -> [Text]
T.lines Text
x)
    where
      prefixes :: [Text] -> [Fmt]
prefixes [] = []
      prefixes (Text
l : [Text]
ls) = Text -> Fmt
comment (Text -> Text -> Text
prefix Text
"-- |" Text
l) Fmt -> [Fmt] -> [Fmt]
forall a. a -> [a] -> [a]
: (Text -> Fmt) -> [Text] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Fmt
comment (Text -> Fmt) -> (Text -> Text) -> Text -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
prefix Text
"--") [Text]
ls
      prefix :: Text -> Text -> Text
prefix Text
p Text
s = if Text -> Bool
T.null Text
s then Text
p else Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s -- Avoid trailing whitespace.

instance Format (Maybe DocComment) where
  fmt :: Maybe DocComment -> Fmt
fmt = Fmt -> (DocComment -> Fmt) -> Maybe DocComment -> Fmt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fmt
nil DocComment -> Fmt
forall a. Format a => a -> Fmt
fmt

fmtParamType :: Maybe Name -> UncheckedTypeExp -> Fmt
fmtParamType :: Maybe Name -> UncheckedTypeExp -> Fmt
fmtParamType (Just Name
n) UncheckedTypeExp
te =
  Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
forall a. Monoid a => a
mempty Name
n Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":" Fmt -> Fmt -> Fmt
<+> UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te
fmtParamType Maybe Name
Nothing UncheckedTypeExp
te = UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te

fmtSumTypeConstr :: (Name, [UncheckedTypeExp]) -> Fmt
fmtSumTypeConstr :: (Name, [UncheckedTypeExp]) -> Fmt
fmtSumTypeConstr (Name
name, []) =
  Fmt
"#" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
forall a. Monoid a => a
mempty Name
name
fmtSumTypeConstr (Name
name, [UncheckedTypeExp]
fs) =
  Fmt
"#" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
forall a. Monoid a => a
mempty Name
name Fmt -> Fmt -> Fmt
<+> Fmt -> [Fmt] -> Fmt
sep Fmt
space ((UncheckedTypeExp -> Fmt) -> [UncheckedTypeExp] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt [UncheckedTypeExp]
fs)

instance Format Name where
  fmt :: Name -> Fmt
fmt = AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
forall a. Monoid a => a
mempty

-- Format a tuple-like thing (expression, pattern, type).
fmtTuple :: (Located a) => [Fmt] -> a -> Fmt
fmtTuple :: forall a. Located a => [Fmt] -> a -> Fmt
fmtTuple [Fmt]
xs a
loc =
  a -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments a
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ a -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
fmtByLayout a
loc Fmt
singleLine Fmt
multiLine
  where
    singleLine :: Fmt
singleLine = Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
", " [Fmt]
xs
    multiLine :: Fmt
multiLine = Fmt -> Fmt
align (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"(" Fmt -> Fmt -> Fmt
<+> Fmt -> [Fmt] -> Fmt
sep (Fmt
line Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"," Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space) [Fmt]
xs Fmt -> Fmt -> Fmt
</> Fmt
")"

-- Format a record-like thing (expression, pattern, type).
fmtRecord :: (Located a) => [Fmt] -> a -> Fmt
fmtRecord :: forall a. Located a => [Fmt] -> a -> Fmt
fmtRecord [Fmt]
xs a
loc =
  a -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments a
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ a -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
fmtByLayout a
loc Fmt
singleLine Fmt
multiLine
  where
    singleLine :: Fmt
singleLine = Fmt -> Fmt
braces (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
", " [Fmt]
xs
    multiLine :: Fmt
multiLine = Fmt -> Fmt
align (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"{" Fmt -> Fmt -> Fmt
<+> Fmt -> [Fmt] -> Fmt
sep (Fmt
line Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"," Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space) [Fmt]
xs Fmt -> Fmt -> Fmt
</> Fmt
"}"

-- Format an array-like thing.
fmtArray :: (Located a) => [Fmt] -> a -> Fmt
fmtArray :: forall a. Located a => [Fmt] -> a -> Fmt
fmtArray [Fmt]
xs a
loc =
  a -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments a
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ a -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
fmtByLayout a
loc Fmt
singleLine Fmt
multiLine
  where
    singleLine :: Fmt
singleLine = Fmt -> Fmt
brackets (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
", " [Fmt]
xs
    multiLine :: Fmt
multiLine =
      Fmt -> Fmt
align (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"[" Fmt -> Fmt -> Fmt
<+> Fmt -> [Fmt] -> Fmt
sep (Fmt
line Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"," Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space) [Fmt]
xs Fmt -> Fmt -> Fmt
</> Fmt
"]"

instance Format UncheckedTypeExp where
  fmt :: UncheckedTypeExp -> Fmt
fmt (TEVar QualName Name
v SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ QualName Name -> Fmt
fmtQualName QualName Name
v
  fmt (TETuple [UncheckedTypeExp]
ts SrcLoc
loc) = [Fmt] -> SrcLoc -> Fmt
forall a. Located a => [Fmt] -> a -> Fmt
fmtTuple ((UncheckedTypeExp -> Fmt) -> [UncheckedTypeExp] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map (Fmt -> Fmt
align (Fmt -> Fmt)
-> (UncheckedTypeExp -> Fmt) -> UncheckedTypeExp -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt) [UncheckedTypeExp]
ts) SrcLoc
loc
  fmt (TEParens UncheckedTypeExp
te SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te
  fmt (TERecord [(L Name, UncheckedTypeExp)]
fs SrcLoc
loc) = [Fmt] -> SrcLoc -> Fmt
forall a. Located a => [Fmt] -> a -> Fmt
fmtRecord (((L Name, UncheckedTypeExp) -> Fmt)
-> [(L Name, UncheckedTypeExp)] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map (L Name, UncheckedTypeExp) -> Fmt
forall {a}. Format a => (L Name, a) -> Fmt
fmtFieldType [(L Name, UncheckedTypeExp)]
fs) SrcLoc
loc
    where
      fmtFieldType :: (L Name, a) -> Fmt
fmtFieldType (L Loc
_ Name
name', a
t) = AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
forall a. Monoid a => a
mempty Name
name' Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":" Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (a -> Fmt
forall a. Format a => a -> Fmt
fmt a
t)
  fmt (TEArray SizeExp UncheckedExp
se UncheckedTypeExp
te SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ SizeExp UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt SizeExp UncheckedExp
se Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te
  fmt (TEUnique UncheckedTypeExp
te SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"*" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te
  fmt (TEApply UncheckedTypeExp
te TypeArgExp UncheckedExp Name
tArgE SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te Fmt -> Fmt -> Fmt
<+> TypeArgExp UncheckedExp Name -> Fmt
forall a. Format a => a -> Fmt
fmt TypeArgExp UncheckedExp Name
tArgE
  fmt (TEArrow Maybe Name
name UncheckedTypeExp
te0 UncheckedTypeExp
te1 SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Maybe Name -> UncheckedTypeExp -> Fmt
fmtParamType Maybe Name
name UncheckedTypeExp
te0 Fmt -> Fmt -> Fmt
</> Fmt
"->" Fmt -> Fmt -> Fmt
<+> case UncheckedTypeExp
te1 of
        TEArrow {} -> UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te1
        UncheckedTypeExp
_ -> Fmt -> Fmt
align (UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te1)
  fmt (TESum [(Name, [UncheckedTypeExp])]
tes SrcLoc
loc) =
    -- Comments can not be inserted correctly here because names do not
    -- have a location.
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ SrcLoc -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
fmtByLayout SrcLoc
loc Fmt
singleLine Fmt
multiLine
    where
      singleLine :: Fmt
singleLine = Fmt -> [Fmt] -> Fmt
sep Fmt
" | " ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ ((Name, [UncheckedTypeExp]) -> Fmt)
-> [(Name, [UncheckedTypeExp])] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [UncheckedTypeExp]) -> Fmt
fmtSumTypeConstr [(Name, [UncheckedTypeExp])]
tes
      multiLine :: Fmt
multiLine = Fmt -> [Fmt] -> Fmt
sep Fmt
line ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (Int -> (Name, [UncheckedTypeExp]) -> Fmt)
-> [Int] -> [(Name, [UncheckedTypeExp])] -> [Fmt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> (Name, [UncheckedTypeExp]) -> Fmt
forall {a}. (Eq a, Num a) => a -> (Name, [UncheckedTypeExp]) -> Fmt
prefix [Int
0 :: Int ..] [(Name, [UncheckedTypeExp])]
tes
      prefix :: a -> (Name, [UncheckedTypeExp]) -> Fmt
prefix a
0 (Name, [UncheckedTypeExp])
te = Fmt
"  " Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> (Name, [UncheckedTypeExp]) -> Fmt
fmtSumTypeConstr (Name, [UncheckedTypeExp])
te
      prefix a
_ (Name, [UncheckedTypeExp])
te = Fmt
"| " Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> (Name, [UncheckedTypeExp]) -> Fmt
fmtSumTypeConstr (Name, [UncheckedTypeExp])
te
  fmt (TEDim [Name]
dims UncheckedTypeExp
te SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"?" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
dims' Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"." Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te
    where
      dims' :: Fmt
dims' = Fmt -> [Fmt] -> Fmt
sep Fmt
nil ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (Name -> Fmt) -> [Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map (Fmt -> Fmt
brackets (Fmt -> Fmt) -> (Name -> Fmt) -> Name -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Fmt
forall a. Format a => a -> Fmt
fmt) [Name]
dims

instance Format (TypeArgExp UncheckedExp Name) where
  fmt :: TypeArgExp UncheckedExp Name -> Fmt
fmt (TypeArgExpSize SizeExp UncheckedExp
se) = SizeExp UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt SizeExp UncheckedExp
se
  fmt (TypeArgExpType UncheckedTypeExp
te) = UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te

instance Format UncheckedTypeBind where
  fmt :: UncheckedTypeBind -> Fmt
fmt (TypeBind Name
name Liftedness
l [TypeParamBase Name]
ps UncheckedTypeExp
e NoInfo StructRetType
NoInfo Maybe DocComment
dc SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Maybe DocComment -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe DocComment
dc
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"type"
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Liftedness -> Fmt
forall a. Format a => a -> Fmt
fmt Liftedness
l
          Fmt -> Fmt -> Fmt
<+> AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> (if [TypeParamBase Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParamBase Name]
ps then Fmt
nil else Fmt
space)
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> [TypeParamBase Name] -> Fmt -> Fmt
forall a b. Located a => [a] -> FmtM b -> FmtM b
localLayoutList [TypeParamBase Name]
ps (Fmt -> Fmt
align (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
line ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (TypeParamBase Name -> Fmt) -> [TypeParamBase Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase Name -> Fmt
forall a. Format a => a -> Fmt
fmt [TypeParamBase Name]
ps)
          Fmt -> Fmt -> Fmt
<+> Fmt
"="
          Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
stdIndent (UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
e)

instance Format (AttrAtom a) where
  fmt :: AttrAtom a -> Fmt
fmt (AtomName Name
name) = Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
name
  fmt (AtomInt Integer
int) = AnsiStyle -> Text -> Fmt
text AnsiStyle
constantStyle (Text -> Fmt) -> Text -> Fmt
forall a b. (a -> b) -> a -> b
$ Integer -> Text
forall a. Pretty a => a -> Text
prettyText Integer
int

instance Format (AttrInfo a) where
  fmt :: AttrInfo a -> Fmt
fmt AttrInfo a
attr = Fmt
"#" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
brackets (AttrInfo a -> Fmt
forall k (a :: k). AttrInfo a -> Fmt
fmtAttrInfo AttrInfo a
attr)
    where
      fmtAttrInfo :: AttrInfo vn -> Fmt
fmtAttrInfo (AttrAtom AttrAtom vn
attr' SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AttrAtom vn -> Fmt
forall a. Format a => a -> Fmt
fmt AttrAtom vn
attr'
      fmtAttrInfo (AttrComp Name
name [AttrInfo vn]
attrs SrcLoc
loc) =
        SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
          Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
name
            Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
parens (Fmt -> [Fmt] -> Fmt
sep Fmt
"," ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (AttrInfo vn -> Fmt) -> [AttrInfo vn] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map AttrInfo vn -> Fmt
fmtAttrInfo [AttrInfo vn]
attrs)

instance Format Liftedness where
  fmt :: Liftedness -> Fmt
fmt Liftedness
Unlifted = Fmt
nil
  fmt Liftedness
SizeLifted = Fmt
"~"
  fmt Liftedness
Lifted = Fmt
"^"

instance Format UncheckedTypeParam where
  fmt :: TypeParamBase Name -> Fmt
fmt (TypeParamDim Name
name SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
brackets (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name
  fmt (TypeParamType Liftedness
l Name
name SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"'" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Liftedness -> Fmt
forall a. Format a => a -> Fmt
fmt Liftedness
l Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name

instance Format (UncheckedPat t) where
  fmt :: UncheckedPat t -> Fmt
fmt (TuplePat [UncheckedPat t]
pats SrcLoc
loc) =
    [Fmt] -> SrcLoc -> Fmt
forall a. Located a => [Fmt] -> a -> Fmt
fmtTuple ((UncheckedPat t -> Fmt) -> [UncheckedPat t] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map UncheckedPat t -> Fmt
forall a. Format a => a -> Fmt
fmt [UncheckedPat t]
pats) SrcLoc
loc
  fmt (RecordPat [(L Name, UncheckedPat t)]
pats SrcLoc
loc) =
    [Fmt] -> SrcLoc -> Fmt
forall a. Located a => [Fmt] -> a -> Fmt
fmtRecord (((L Name, UncheckedPat t) -> Fmt)
-> [(L Name, UncheckedPat t)] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map (L Name, UncheckedPat t) -> Fmt
forall {a} {a}. (Located a, Format a, Format a) => (L a, a) -> Fmt
fmtFieldPat [(L Name, UncheckedPat t)]
pats) SrcLoc
loc
    where
      -- We detect the implicit form by whether the name and the 't'
      -- has the same location.
      fmtFieldPat :: (L a, a) -> Fmt
fmtFieldPat (L Loc
nameloc a
name, a
t)
        | Loc -> Loc
forall a. Located a => a -> Loc
locOf Loc
nameloc Loc -> Loc -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Loc
forall a. Located a => a -> Loc
locOf a
t = a -> Fmt
forall a. Format a => a -> Fmt
fmt a
name
        | Bool
otherwise =
            [Loc] -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
lineIndent [Loc
nameloc, a -> Loc
forall a. Located a => a -> Loc
locOf a
t] (a -> Fmt
forall a. Format a => a -> Fmt
fmt a
name Fmt -> Fmt -> Fmt
<+> Fmt
"=") (a -> Fmt
forall a. Format a => a -> Fmt
fmt a
t)
  fmt (PatParens UncheckedPat t
pat SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"(" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
align (UncheckedPat t -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedPat t
pat) Fmt -> Fmt -> Fmt
<:/> Fmt
")"
  fmt (Id Name
name NoInfo t
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Name -> Fmt
fmtBoundName Name
name
  fmt (Wildcard NoInfo t
_t SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc Fmt
"_"
  fmt (PatAscription UncheckedPat t
pat UncheckedTypeExp
t SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedPat t -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedPat t
pat Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":" Fmt -> Fmt -> Fmt
<+> UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
t
  fmt (PatLit PatLit
_e NoInfo t
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> SrcLoc -> Fmt
forall a. Located a => AnsiStyle -> a -> Fmt
fmtCopyLoc AnsiStyle
constantStyle SrcLoc
loc
  fmt (PatConstr Name
n NoInfo t
_ [] SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"#" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
n
  fmt (PatConstr Name
n NoInfo t
_ [UncheckedPat t]
pats SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"#" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
n Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
align (Fmt -> [Fmt] -> Fmt
sep Fmt
line ((UncheckedPat t -> Fmt) -> [UncheckedPat t] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map UncheckedPat t -> Fmt
forall a. Format a => a -> Fmt
fmt [UncheckedPat t]
pats))
  fmt (PatAttr AttrInfo Name
attr UncheckedPat t
pat SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AttrInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt AttrInfo Name
attr Fmt -> Fmt -> Fmt
<+> UncheckedPat t -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedPat t
pat

instance Format (FieldBase NoInfo Name) where
  fmt :: FieldBase NoInfo Name -> Fmt
fmt (RecordFieldExplicit (L Loc
nameloc Name
name) UncheckedExp
e SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      [Loc] -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
lineIndent [Loc
nameloc, UncheckedExp -> Loc
forall a. Located a => a -> Loc
locOf UncheckedExp
e] (Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
name Fmt -> Fmt -> Fmt
<+> Fmt
"=") (Fmt -> Fmt
stdIndent (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e))
  fmt (RecordFieldImplicit (L Loc
_ Name
name) NoInfo StructType
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
name

instance Format UncheckedDimIndex where
  fmt :: UncheckedDimIndex -> Fmt
fmt (DimFix UncheckedExp
e) = UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e
  fmt (DimSlice Maybe UncheckedExp
i Maybe UncheckedExp
j (Just UncheckedExp
s)) =
    Fmt -> (UncheckedExp -> Fmt) -> Maybe UncheckedExp -> Fmt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fmt
nil UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe UncheckedExp
i
      Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":"
      Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> (UncheckedExp -> Fmt) -> Maybe UncheckedExp -> Fmt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fmt
nil UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe UncheckedExp
j
      Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":"
      Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
s
  fmt (DimSlice Maybe UncheckedExp
i (Just UncheckedExp
j) Maybe UncheckedExp
s) =
    Fmt -> (UncheckedExp -> Fmt) -> Maybe UncheckedExp -> Fmt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fmt
nil UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe UncheckedExp
i
      Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":"
      Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
j
      Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> (UncheckedExp -> Fmt) -> Maybe UncheckedExp -> Fmt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fmt
nil ((Fmt
":" <>) (Fmt -> Fmt) -> (UncheckedExp -> Fmt) -> UncheckedExp -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt) Maybe UncheckedExp
s
  fmt (DimSlice Maybe UncheckedExp
i Maybe UncheckedExp
Nothing Maybe UncheckedExp
Nothing) =
    Fmt -> (UncheckedExp -> Fmt) -> Maybe UncheckedExp -> Fmt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fmt
nil UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe UncheckedExp
i Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":"

operatorName :: Name -> Bool
operatorName :: Name -> Bool
operatorName = (Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
opchars) (Char -> Bool) -> (Name -> Char) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Char
Text -> Char
T.head (Text -> Char) -> (Name -> Text) -> Name -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Text
nameToText
  where
    opchars :: String
    opchars :: [Char]
opchars = [Char]
"+-*/%=!><|&^."

instance Format PrimValue where
  fmt :: PrimValue -> Fmt
fmt PrimValue
pv =
    AnsiStyle -> Text -> Fmt
text AnsiStyle
constantStyle (Text -> Fmt) -> Text -> Fmt
forall a b. (a -> b) -> a -> b
$ case PrimValue
pv of
      UnsignedValue (Int8Value Int8
v) ->
        Word8 -> Text
forall a. Show a => a -> Text
showText (Int8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
v :: Word8) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"u8"
      UnsignedValue (Int16Value Int16
v) ->
        Word16 -> Text
forall a. Show a => a -> Text
showText (Int16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
v :: Word16) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"u16"
      UnsignedValue (Int32Value Int32
v) ->
        Word32 -> Text
forall a. Show a => a -> Text
showText (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
v :: Word32) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"u32"
      UnsignedValue (Int64Value Int64
v) ->
        Word64 -> Text
forall a. Show a => a -> Text
showText (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
v :: Word64) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"u64"
      SignedValue IntValue
v -> IntValue -> Text
forall a. Pretty a => a -> Text
prettyText IntValue
v
      BoolValue Bool
True -> Text
"true"
      BoolValue Bool
False -> Text
"false"
      FloatValue FloatValue
v -> FloatValue -> Text
forall a. Pretty a => a -> Text
prettyText FloatValue
v

updates ::
  UncheckedExp ->
  (UncheckedExp, [(Fmt, Fmt)])
updates :: UncheckedExp -> (UncheckedExp, [(Fmt, Fmt)])
updates (RecordUpdate UncheckedExp
src [Name]
fs UncheckedExp
ve NoInfo StructType
_ SrcLoc
_) = ([(Fmt, Fmt)] -> [(Fmt, Fmt)])
-> (UncheckedExp, [(Fmt, Fmt)]) -> (UncheckedExp, [(Fmt, Fmt)])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([(Fmt, Fmt)] -> [(Fmt, Fmt)] -> [(Fmt, Fmt)]
forall a. [a] -> [a] -> [a]
++ [(Fmt
fs', Fmt
ve')]) ((UncheckedExp, [(Fmt, Fmt)]) -> (UncheckedExp, [(Fmt, Fmt)]))
-> (UncheckedExp, [(Fmt, Fmt)]) -> (UncheckedExp, [(Fmt, Fmt)])
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> (UncheckedExp, [(Fmt, Fmt)])
updates UncheckedExp
src
  where
    fs' :: Fmt
fs' = Fmt -> [Fmt] -> Fmt
sep Fmt
"." ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ Name -> Fmt
forall a. Format a => a -> Fmt
fmt (Name -> Fmt) -> [Name] -> [Fmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fs
    ve' :: Fmt
ve' = UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
ve
updates (Update UncheckedExp
src SliceBase NoInfo Name
is UncheckedExp
ve SrcLoc
_) = ([(Fmt, Fmt)] -> [(Fmt, Fmt)])
-> (UncheckedExp, [(Fmt, Fmt)]) -> (UncheckedExp, [(Fmt, Fmt)])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([(Fmt, Fmt)] -> [(Fmt, Fmt)] -> [(Fmt, Fmt)]
forall a. [a] -> [a] -> [a]
++ [(Fmt
is', Fmt
ve')]) ((UncheckedExp, [(Fmt, Fmt)]) -> (UncheckedExp, [(Fmt, Fmt)]))
-> (UncheckedExp, [(Fmt, Fmt)]) -> (UncheckedExp, [(Fmt, Fmt)])
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> (UncheckedExp, [(Fmt, Fmt)])
updates UncheckedExp
src
  where
    is' :: Fmt
is' = Fmt -> Fmt
brackets (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep (Fmt
"," Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space) ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (UncheckedDimIndex -> Fmt) -> SliceBase NoInfo Name -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map UncheckedDimIndex -> Fmt
forall a. Format a => a -> Fmt
fmt SliceBase NoInfo Name
is
    ve' :: Fmt
ve' = UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
ve
updates UncheckedExp
e = (UncheckedExp
e, [])

fmtUpdate :: UncheckedExp -> Fmt
fmtUpdate :: UncheckedExp -> Fmt
fmtUpdate UncheckedExp
e =
  -- Special case multiple chained Updates/RecordUpdates.
  let (UncheckedExp
root, [(Fmt, Fmt)]
us) = UncheckedExp -> (UncheckedExp, [(Fmt, Fmt)])
updates UncheckedExp
e
      loc :: SrcLoc
loc = UncheckedExp -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf UncheckedExp
e
   in SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> (Fmt -> Fmt) -> Fmt -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> Fmt -> Fmt
forall a b. Located a => a -> FmtM b -> FmtM b
localLayout SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
        UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
root Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (Fmt -> [Fmt] -> Fmt
sep Fmt
line (((Fmt, Fmt) -> Fmt) -> [(Fmt, Fmt)] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map (Fmt, Fmt) -> Fmt
fmtWith [(Fmt, Fmt)]
us))
  where
    fmtWith :: (Fmt, Fmt) -> Fmt
fmtWith (Fmt
fs', Fmt
v) = Fmt
"with" Fmt -> Fmt -> Fmt
<+> Fmt
fs' Fmt -> Fmt -> Fmt
<+> Fmt
"=" Fmt -> Fmt -> Fmt
<+> Fmt
v

instance Format UncheckedExp where
  fmt :: UncheckedExp -> Fmt
fmt (Var QualName Name
name NoInfo StructType
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ QualName Name -> Fmt
fmtQualName QualName Name
name
  fmt (Hole NoInfo StructType
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc Fmt
"???"
  fmt (Parens UncheckedExp
e SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"(" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
align (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e) Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
")"
  fmt (QualParens (QualName Name
v, SrcLoc
_qLoc) UncheckedExp
e SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      QualName Name -> Fmt
fmtQualName QualName Name
v Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"." Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"(" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
align (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e) Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
")"
  fmt (Ascript UncheckedExp
e UncheckedTypeExp
t SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e Fmt -> Fmt -> Fmt
</> Fmt
":" Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
t)
  fmt (Coerce UncheckedExp
e UncheckedTypeExp
t NoInfo StructType
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e Fmt -> Fmt -> Fmt
</> Fmt
":>" Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
t)
  fmt (Literal PrimValue
_v SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> SrcLoc -> Fmt
forall a. Located a => AnsiStyle -> a -> Fmt
fmtCopyLoc AnsiStyle
constantStyle SrcLoc
loc
  fmt (IntLit Integer
_v NoInfo StructType
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> SrcLoc -> Fmt
forall a. Located a => AnsiStyle -> a -> Fmt
fmtCopyLoc AnsiStyle
constantStyle SrcLoc
loc
  fmt (FloatLit Double
_v NoInfo StructType
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> SrcLoc -> Fmt
forall a. Located a => AnsiStyle -> a -> Fmt
fmtCopyLoc AnsiStyle
constantStyle SrcLoc
loc
  fmt (TupLit [UncheckedExp]
es SrcLoc
loc) = [Fmt] -> SrcLoc -> Fmt
forall a. Located a => [Fmt] -> a -> Fmt
fmtTuple ((UncheckedExp -> Fmt) -> [UncheckedExp] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map (Fmt -> Fmt
align (Fmt -> Fmt) -> (UncheckedExp -> Fmt) -> UncheckedExp -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt) [UncheckedExp]
es) SrcLoc
loc
  fmt (RecordLit [FieldBase NoInfo Name]
fs SrcLoc
loc) = [Fmt] -> SrcLoc -> Fmt
forall a. Located a => [Fmt] -> a -> Fmt
fmtRecord ((FieldBase NoInfo Name -> Fmt) -> [FieldBase NoInfo Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map FieldBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt [FieldBase NoInfo Name]
fs) SrcLoc
loc
  fmt (ArrayLit [UncheckedExp]
es NoInfo StructType
_ SrcLoc
loc) = [Fmt] -> SrcLoc -> Fmt
forall a. Located a => [Fmt] -> a -> Fmt
fmtArray ((UncheckedExp -> Fmt) -> [UncheckedExp] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map (Fmt -> Fmt
align (Fmt -> Fmt) -> (UncheckedExp -> Fmt) -> UncheckedExp -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt) [UncheckedExp]
es) SrcLoc
loc
  fmt (StringLit [Word8]
_s SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> SrcLoc -> Fmt
forall a. Located a => AnsiStyle -> a -> Fmt
fmtCopyLoc AnsiStyle
constantStyle SrcLoc
loc
  fmt (Project Name
k UncheckedExp
e NoInfo StructType
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"." Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
k
  fmt (Negate UncheckedExp
e SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"-" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e
  fmt (Not UncheckedExp
e SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"!" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e
  fmt e :: UncheckedExp
e@Update {} = UncheckedExp -> Fmt
fmtUpdate UncheckedExp
e
  fmt e :: UncheckedExp
e@RecordUpdate {} = UncheckedExp -> Fmt
fmtUpdate UncheckedExp
e
  fmt (Assert UncheckedExp
e1 UncheckedExp
e2 NoInfo Text
_ SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"assert" Fmt -> Fmt -> Fmt
<+> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e1 Fmt -> Fmt -> Fmt
<+> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e2
  fmt (Lambda [PatBase NoInfo Name ParamType]
params UncheckedExp
body Maybe UncheckedTypeExp
rettype NoInfo ResRetType
_ SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Fmt
"\\"
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> [Fmt] -> Fmt
sep Fmt
space ((PatBase NoInfo Name ParamType -> Fmt)
-> [PatBase NoInfo Name ParamType] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map PatBase NoInfo Name ParamType -> Fmt
forall a. Format a => a -> Fmt
fmt [PatBase NoInfo Name ParamType]
params)
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> (UncheckedTypeExp -> Fmt) -> Maybe UncheckedTypeExp -> Fmt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fmt
nil (((Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":") <+>) (Fmt -> Fmt)
-> (UncheckedTypeExp -> Fmt) -> UncheckedTypeExp -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt) Maybe UncheckedTypeExp
rettype
          Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
stdNest (Fmt
"->" Fmt -> Fmt -> Fmt
</> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
body)
  fmt (OpSection QualName Name
binop NoInfo StructType
_ SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      if Name -> Bool
operatorName (QualName Name -> Name
forall vn. QualName vn -> vn
qualLeaf QualName Name
binop)
        then QualName Name -> Fmt
fmtQualName QualName Name
binop
        else Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"`" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> QualName Name -> Fmt
fmtQualName QualName Name
binop Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"`"
  fmt (OpSectionLeft QualName Name
binop NoInfo StructType
_ UncheckedExp
x (NoInfo (PName, ParamType, Maybe VName), NoInfo (PName, ParamType))
_ (NoInfo ResRetType, NoInfo [VName])
_ SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
x Fmt -> Fmt -> Fmt
<+> QualName Name -> Fmt
fmtBinOp QualName Name
binop
  fmt (OpSectionRight QualName Name
binop NoInfo StructType
_ UncheckedExp
x (NoInfo (PName, ParamType), NoInfo (PName, ParamType, Maybe VName))
_ NoInfo ResRetType
_ SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ QualName Name -> Fmt
fmtBinOp QualName Name
binop Fmt -> Fmt -> Fmt
<+> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
x
  fmt (ProjectSection [Name]
fields NoInfo StructType
_ SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"." Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> [Fmt] -> Fmt
sep Fmt
"." (Name -> Fmt
forall a. Format a => a -> Fmt
fmt (Name -> Fmt) -> [Name] -> [Fmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name]
fields)
  fmt (IndexSection SliceBase NoInfo Name
idxs NoInfo StructType
_ SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
parens (Fmt
"." Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
idxs')
    where
      idxs' :: Fmt
idxs' = Fmt -> Fmt
brackets (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep (Fmt
"," Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space) ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (UncheckedDimIndex -> Fmt) -> SliceBase NoInfo Name -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map UncheckedDimIndex -> Fmt
forall a. Format a => a -> Fmt
fmt SliceBase NoInfo Name
idxs
  fmt (Constr Name
n [] NoInfo StructType
_ SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"#" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
n
  fmt (Constr Name
n [UncheckedExp]
cs NoInfo StructType
_ SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"#" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
n Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (Fmt -> [Fmt] -> Fmt
sep Fmt
line ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (UncheckedExp -> Fmt) -> [UncheckedExp] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt [UncheckedExp]
cs)
  fmt (Attr AttrInfo Name
attr UncheckedExp
e SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
align (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AttrInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt AttrInfo Name
attr Fmt -> Fmt -> Fmt
</> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e
  fmt (AppExp AppExpBase NoInfo Name
e NoInfo AppRes
_) = AppExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt AppExpBase NoInfo Name
e
  fmt (ArrayVal [PrimValue]
vs PrimType
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ [Fmt] -> SrcLoc -> Fmt
forall a. Located a => [Fmt] -> a -> Fmt
fmtArray ((PrimValue -> Fmt) -> [PrimValue] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map PrimValue -> Fmt
forall a. Format a => a -> Fmt
fmt [PrimValue]
vs) SrcLoc
loc

fmtQualName :: QualName Name -> Fmt
fmtQualName :: QualName Name -> Fmt
fmtQualName (QualName [Name]
names Name
name)
  | Name -> Bool
operatorName Name
name = Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
pre Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
name
  | Bool
otherwise = Fmt
pre Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Name -> Fmt
forall a. Format a => a -> Fmt
fmt Name
name
  where
    pre :: Fmt
pre =
      if [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
names
        then Fmt
nil
        else Fmt -> [Fmt] -> Fmt
sep Fmt
"." ((Name -> Fmt) -> [Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Fmt
forall a. Format a => a -> Fmt
fmt [Name]
names) Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"."

instance Format UncheckedCase where
  fmt :: UncheckedCase -> Fmt
fmt (CasePat PatBase NoInfo Name StructType
p UncheckedExp
e SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"case" Fmt -> Fmt -> Fmt
<+> PatBase NoInfo Name StructType -> Fmt
forall a. Format a => a -> Fmt
fmt PatBase NoInfo Name StructType
p Fmt -> Fmt -> Fmt
<+> Fmt
"->" Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
stdIndent (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e)

instance Format (AppExpBase NoInfo Name) where
  fmt :: AppExpBase NoInfo Name -> Fmt
fmt (BinOp (QualName Name
bop, SrcLoc
_) NoInfo StructType
_ (UncheckedExp
x, NoInfo (Maybe VName)
_) (UncheckedExp
y, NoInfo (Maybe VName)
_) SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
align (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
x) Fmt -> Fmt -> Fmt
</> QualName Name -> Fmt
fmtBinOp QualName Name
bop Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
y)
  fmt (Match UncheckedExp
e NonEmpty UncheckedCase
cs SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"match" Fmt -> Fmt -> Fmt
<+> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e Fmt -> Fmt -> Fmt
</> Fmt -> [Fmt] -> Fmt
sep Fmt
line ((UncheckedCase -> Fmt) -> [UncheckedCase] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map UncheckedCase -> Fmt
forall a. Format a => a -> Fmt
fmt ([UncheckedCase] -> [Fmt]) -> [UncheckedCase] -> [Fmt]
forall a b. (a -> b) -> a -> b
$ NonEmpty UncheckedCase -> [UncheckedCase]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty UncheckedCase
cs)
  -- need some way to omit the inital value expression, when this it's trivial
  fmt (Loop [VName]
sizeparams PatBase NoInfo Name ParamType
pat (LoopInitImplicit NoInfo UncheckedExp
NoInfo) LoopFormBase NoInfo Name
form UncheckedExp
loopbody SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      (Fmt
"loop" Fmt -> Fmt -> Fmt
`op` Fmt
sizeparams')
        Fmt -> Fmt -> Fmt
<+> [Loc] -> Fmt -> Fmt
forall a b. Located a => a -> FmtM b -> FmtM b
localLayout
          [PatBase NoInfo Name ParamType -> Loc
forall a. Located a => a -> Loc
locOf PatBase NoInfo Name ParamType
pat, Loc
formloc]
          (PatBase NoInfo Name ParamType -> Fmt
forall a. Format a => a -> Fmt
fmt PatBase NoInfo Name ParamType
pat Fmt -> Fmt -> Fmt
</> LoopFormBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt LoopFormBase NoInfo Name
form Fmt -> Fmt -> Fmt
<+> Fmt
"do")
        Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
stdIndent (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
loopbody)
    where
      formloc :: Loc
formloc = case LoopFormBase NoInfo Name
form of
        For IdentBase NoInfo Name StructType
i UncheckedExp
_ -> IdentBase NoInfo Name StructType -> Loc
forall a. Located a => a -> Loc
locOf IdentBase NoInfo Name StructType
i
        ForIn PatBase NoInfo Name StructType
fpat UncheckedExp
_ -> PatBase NoInfo Name StructType -> Loc
forall a. Located a => a -> Loc
locOf PatBase NoInfo Name StructType
fpat
        While UncheckedExp
e -> UncheckedExp -> Loc
forall a. Located a => a -> Loc
locOf UncheckedExp
e
      op :: Fmt -> Fmt -> Fmt
op = if [VName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VName]
sizeparams then Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
(<>) else Fmt -> Fmt -> Fmt
(<+>)
      sizeparams' :: Fmt
sizeparams' = Fmt -> [Fmt] -> Fmt
sep Fmt
nil ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
brackets (Fmt -> Fmt) -> (VName -> Fmt) -> VName -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle (Name -> Fmt) -> (VName -> Name) -> VName -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Name
forall v. IsName v => v -> Name
toName (VName -> Fmt) -> [VName] -> [Fmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VName]
sizeparams
  fmt (Loop [VName]
sizeparams PatBase NoInfo Name ParamType
pat (LoopInitExplicit UncheckedExp
initexp) LoopFormBase NoInfo Name
form UncheckedExp
loopbody SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      (Fmt
"loop" Fmt -> Fmt -> Fmt
`op` Fmt
sizeparams')
        Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align
          ( [Loc] -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
lineIndent
              [PatBase NoInfo Name ParamType -> Loc
forall a. Located a => a -> Loc
locOf PatBase NoInfo Name ParamType
pat, UncheckedExp -> Loc
forall a. Located a => a -> Loc
locOf UncheckedExp
initexp]
              (PatBase NoInfo Name ParamType -> Fmt
forall a. Format a => a -> Fmt
fmt PatBase NoInfo Name ParamType
pat Fmt -> Fmt -> Fmt
<+> Fmt
"=")
              (Fmt -> Fmt
align (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
initexp)
          )
        Fmt -> Fmt -> Fmt
</> LoopFormBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt LoopFormBase NoInfo Name
form
        Fmt -> Fmt -> Fmt
<+> Fmt
"do"
        Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
stdIndent (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
loopbody)
    where
      op :: Fmt -> Fmt -> Fmt
op = if [VName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VName]
sizeparams then Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
(<>) else Fmt -> Fmt -> Fmt
(<+>)
      sizeparams' :: Fmt
sizeparams' = Fmt -> [Fmt] -> Fmt
sep Fmt
nil ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
brackets (Fmt -> Fmt) -> (VName -> Fmt) -> VName -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle (Name -> Fmt) -> (VName -> Name) -> VName -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Name
forall v. IsName v => v -> Name
toName (VName -> Fmt) -> [VName] -> [Fmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [VName]
sizeparams
  fmt (Index UncheckedExp
e SliceBase NoInfo Name
idxs SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e <>) (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
brackets (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sepLine Fmt
"," ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (UncheckedDimIndex -> Fmt) -> SliceBase NoInfo Name -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map UncheckedDimIndex -> Fmt
forall a. Format a => a -> Fmt
fmt SliceBase NoInfo Name
idxs
  fmt (LetPat [SizeBinder Name]
sizes PatBase NoInfo Name StructType
pat UncheckedExp
e UncheckedExp
body SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      [Loc] -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
lineIndent [PatBase NoInfo Name StructType -> Loc
forall a. Located a => a -> Loc
locOf PatBase NoInfo Name StructType
pat, UncheckedExp -> Loc
forall a. Located a => a -> Loc
locOf UncheckedExp
e] (Fmt
"let" Fmt -> Fmt -> Fmt
<+> Fmt
sub Fmt -> Fmt -> Fmt
<+> Fmt
"=") (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e)
        Fmt -> Fmt -> Fmt
</> UncheckedExp -> Fmt
letBody UncheckedExp
body
    where
      sizes' :: Fmt
sizes' = Fmt -> [Fmt] -> Fmt
sep Fmt
nil ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (SizeBinder Name -> Fmt) -> [SizeBinder Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map SizeBinder Name -> Fmt
forall a. Format a => a -> Fmt
fmt [SizeBinder Name]
sizes
      sub :: Fmt
sub
        | [SizeBinder Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SizeBinder Name]
sizes = PatBase NoInfo Name StructType -> Fmt
forall a. Format a => a -> Fmt
fmt PatBase NoInfo Name StructType
pat
        | Bool
otherwise = Fmt
sizes' Fmt -> Fmt -> Fmt
<+> PatBase NoInfo Name StructType -> Fmt
forall a. Format a => a -> Fmt
fmt PatBase NoInfo Name StructType
pat
  fmt (LetFun Name
fname ([TypeParamBase Name]
tparams, [PatBase NoInfo Name ParamType]
params, Maybe UncheckedTypeExp
retdecl, NoInfo ResRetType
_, UncheckedExp
e) UncheckedExp
body SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      UncheckedExp -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
lineIndent
        UncheckedExp
e
        ( Fmt
"let"
            Fmt -> Fmt -> Fmt
<+> AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
fname
            Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
sub
            Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
retdecl'
            Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"="
        )
        (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e)
        Fmt -> Fmt -> Fmt
</> UncheckedExp -> Fmt
letBody UncheckedExp
body
    where
      tparams' :: Fmt
tparams' = Fmt -> [Fmt] -> Fmt
sep Fmt
space ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (TypeParamBase Name -> Fmt) -> [TypeParamBase Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase Name -> Fmt
forall a. Format a => a -> Fmt
fmt [TypeParamBase Name]
tparams
      params' :: Fmt
params' = Fmt -> [Fmt] -> Fmt
sep Fmt
space ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (PatBase NoInfo Name ParamType -> Fmt)
-> [PatBase NoInfo Name ParamType] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map PatBase NoInfo Name ParamType -> Fmt
forall a. Format a => a -> Fmt
fmt [PatBase NoInfo Name ParamType]
params
      retdecl' :: Fmt
retdecl' =
        case Maybe UncheckedTypeExp
retdecl of
          Just UncheckedTypeExp
a -> Fmt
":" Fmt -> Fmt -> Fmt
<+> UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
a Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space
          Maybe UncheckedTypeExp
Nothing -> Fmt
space
      sub :: Fmt
sub
        | [TypeParamBase Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParamBase Name]
tparams Bool -> Bool -> Bool
&& [PatBase NoInfo Name ParamType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatBase NoInfo Name ParamType]
params = Fmt
nil
        | [TypeParamBase Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParamBase Name]
tparams = Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
params'
        | [PatBase NoInfo Name ParamType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatBase NoInfo Name ParamType]
params = Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
tparams'
        | Bool
otherwise = Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
tparams' Fmt -> Fmt -> Fmt
<+> Fmt
params'
  fmt (LetWith IdentBase NoInfo Name StructType
dest IdentBase NoInfo Name StructType
src SliceBase NoInfo Name
idxs UncheckedExp
ve UncheckedExp
body SrcLoc
loc)
    | IdentBase NoInfo Name StructType
dest IdentBase NoInfo Name StructType
-> IdentBase NoInfo Name StructType -> Bool
forall a. Eq a => a -> a -> Bool
== IdentBase NoInfo Name StructType
src =
        SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
          UncheckedExp -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
lineIndent
            UncheckedExp
ve
            ( Fmt
"let"
                Fmt -> Fmt -> Fmt
<+> IdentBase NoInfo Name StructType -> Fmt
forall a. Format a => a -> Fmt
fmt IdentBase NoInfo Name StructType
dest
                Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
idxs'
                  Fmt -> Fmt -> Fmt
<+> Fmt
"="
            )
            (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
ve)
            Fmt -> Fmt -> Fmt
</> UncheckedExp -> Fmt
letBody UncheckedExp
body
    | Bool
otherwise =
        SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
          UncheckedExp -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
lineIndent
            UncheckedExp
ve
            ( Fmt
"let"
                Fmt -> Fmt -> Fmt
<+> IdentBase NoInfo Name StructType -> Fmt
forall a. Format a => a -> Fmt
fmt IdentBase NoInfo Name StructType
dest
                Fmt -> Fmt -> Fmt
<+> Fmt
"="
                Fmt -> Fmt -> Fmt
<+> IdentBase NoInfo Name StructType -> Fmt
forall a. Format a => a -> Fmt
fmt IdentBase NoInfo Name StructType
src
                Fmt -> Fmt -> Fmt
<+> Fmt
"with"
                Fmt -> Fmt -> Fmt
<+> Fmt
idxs'
            )
            (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
ve)
            Fmt -> Fmt -> Fmt
</> UncheckedExp -> Fmt
letBody UncheckedExp
body
    where
      idxs' :: Fmt
idxs' = Fmt -> Fmt
brackets (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
", " ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (UncheckedDimIndex -> Fmt) -> SliceBase NoInfo Name -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map UncheckedDimIndex -> Fmt
forall a. Format a => a -> Fmt
fmt SliceBase NoInfo Name
idxs
  fmt (Range UncheckedExp
start Maybe UncheckedExp
maybe_step Inclusiveness UncheckedExp
end SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
start Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
step Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
end'
    where
      end' :: Fmt
end' =
        case Inclusiveness UncheckedExp
end of
          DownToExclusive UncheckedExp
e -> Fmt
"..>" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e
          ToInclusive UncheckedExp
e -> Fmt
"..." Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e
          UpToExclusive UncheckedExp
e -> Fmt
"..<" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e
      step :: Fmt
step = Fmt -> (UncheckedExp -> Fmt) -> Maybe UncheckedExp -> Fmt
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Fmt
nil ((Fmt
".." <>) (Fmt -> Fmt) -> (UncheckedExp -> Fmt) -> UncheckedExp -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt) Maybe UncheckedExp
maybe_step
  fmt (If UncheckedExp
c UncheckedExp
t UncheckedExp
f SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Fmt
"if"
        Fmt -> Fmt -> Fmt
<+> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
c
        Fmt -> Fmt -> Fmt
</> Fmt
"then"
        Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
t)
        Fmt -> Fmt -> Fmt
</> Fmt
"else"
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> case UncheckedExp
f of
          AppExp If {} NoInfo AppRes
_ -> Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
f
          UncheckedExp
_ -> Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
align (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
f)
  fmt (Apply UncheckedExp
f NonEmpty (NoInfo (Maybe VName), UncheckedExp)
args SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
f Fmt -> Fmt -> Fmt
<+> Fmt
fmt_args
    where
      fmt_args :: Fmt
fmt_args = (UncheckedExp -> Fmt) -> NonEmpty UncheckedExp -> Fmt
forall a. Located a => (a -> Fmt) -> NonEmpty a -> Fmt
sepArgs UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt (NonEmpty UncheckedExp -> Fmt) -> NonEmpty UncheckedExp -> Fmt
forall a b. (a -> b) -> a -> b
$ ((NoInfo (Maybe VName), UncheckedExp) -> UncheckedExp)
-> NonEmpty (NoInfo (Maybe VName), UncheckedExp)
-> NonEmpty UncheckedExp
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NoInfo (Maybe VName), UncheckedExp) -> UncheckedExp
forall a b. (a, b) -> b
snd NonEmpty (NoInfo (Maybe VName), UncheckedExp)
args

letBody :: UncheckedExp -> Fmt
letBody :: UncheckedExp -> Fmt
letBody body :: UncheckedExp
body@(AppExp LetPat {} NoInfo AppRes
_) = UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
body
letBody body :: UncheckedExp
body@(AppExp LetFun {} NoInfo AppRes
_) = UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
body
letBody body :: UncheckedExp
body@(AppExp LetWith {} NoInfo AppRes
_) = UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
body
letBody UncheckedExp
body = UncheckedExp -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments UncheckedExp
body (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"in" Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
body)

instance Format (SizeBinder Name) where
  fmt :: SizeBinder Name -> Fmt
fmt (SizeBinder Name
v SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
brackets (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
v

instance Format (IdentBase NoInfo Name t) where
  fmt :: IdentBase NoInfo Name t -> Fmt
fmt = AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle (Name -> Fmt)
-> (IdentBase NoInfo Name t -> Name)
-> IdentBase NoInfo Name t
-> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdentBase NoInfo Name t -> Name
forall {k} (f :: k -> *) vn (t :: k). IdentBase f vn t -> vn
identName

instance Format (LoopFormBase NoInfo Name) where
  fmt :: LoopFormBase NoInfo Name -> Fmt
fmt (For IdentBase NoInfo Name StructType
i UncheckedExp
ubound) = Fmt
"for" Fmt -> Fmt -> Fmt
<+> IdentBase NoInfo Name StructType -> Fmt
forall a. Format a => a -> Fmt
fmt IdentBase NoInfo Name StructType
i Fmt -> Fmt -> Fmt
<+> Fmt
"<" Fmt -> Fmt -> Fmt
<+> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
ubound
  fmt (ForIn PatBase NoInfo Name StructType
x UncheckedExp
e) = Fmt
"for" Fmt -> Fmt -> Fmt
<+> PatBase NoInfo Name StructType -> Fmt
forall a. Format a => a -> Fmt
fmt PatBase NoInfo Name StructType
x Fmt -> Fmt -> Fmt
<+> Fmt
"in" Fmt -> Fmt -> Fmt
<+> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
e
  fmt (While UncheckedExp
cond) = Fmt
"while" Fmt -> Fmt -> Fmt
<+> UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
cond

-- | This should always be simplified by location.
fmtBinOp :: QualName Name -> Fmt
fmtBinOp :: QualName Name -> Fmt
fmtBinOp QualName Name
bop =
  case BinOp
leading of
    BinOp
Backtick -> Fmt
"`" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> QualName Name -> Fmt
fmtQualName QualName Name
bop Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"`"
    BinOp
_ -> AnsiStyle -> Text -> Fmt
text AnsiStyle
infixStyle (QualName Name -> Text
forall a. Pretty a => a -> Text
prettyText QualName Name
bop)
  where
    leading :: BinOp
leading = Name -> BinOp
leadingOperator (Name -> BinOp) -> Name -> BinOp
forall a b. (a -> b) -> a -> b
$ Name -> Name
forall v. IsName v => v -> Name
toName (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ QualName Name -> Name
forall vn. QualName vn -> vn
qualLeaf QualName Name
bop

instance Format UncheckedValBind where
  fmt :: UncheckedValBind -> Fmt
fmt (ValBind Maybe (NoInfo EntryPoint)
entry Name
name Maybe UncheckedTypeExp
retdecl NoInfo ResRetType
_rettype [TypeParamBase Name]
tparams [PatBase NoInfo Name ParamType]
args UncheckedExp
body Maybe DocComment
docs [AttrInfo Name]
attrs SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Maybe DocComment -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe DocComment
docs
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
attrs'
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> (Fmt
fun Fmt -> Fmt -> Fmt
<+> Name -> Fmt
fmtBoundName Name
name)
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
sub
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
retdecl'
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"="
          Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
stdIndent (UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
body)
    where
      attrs' :: Fmt
attrs' = if [AttrInfo Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AttrInfo Name]
attrs then Fmt
nil else Fmt -> [Fmt] -> Fmt
sep Fmt
space ((AttrInfo Name -> Fmt) -> [AttrInfo Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map AttrInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt [AttrInfo Name]
attrs) Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
hardline
      tparams' :: Fmt
tparams' = [TypeParamBase Name] -> Fmt -> Fmt
forall a b. Located a => [a] -> FmtM b -> FmtM b
localLayoutList [TypeParamBase Name]
tparams (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
align (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
line ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (TypeParamBase Name -> Fmt) -> [TypeParamBase Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase Name -> Fmt
forall a. Format a => a -> Fmt
fmt [TypeParamBase Name]
tparams
      args' :: Fmt
args' = [PatBase NoInfo Name ParamType] -> Fmt -> Fmt
forall a b. Located a => [a] -> FmtM b -> FmtM b
localLayoutList [PatBase NoInfo Name ParamType]
args (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
align (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
line ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (PatBase NoInfo Name ParamType -> Fmt)
-> [PatBase NoInfo Name ParamType] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map PatBase NoInfo Name ParamType -> Fmt
forall a. Format a => a -> Fmt
fmt [PatBase NoInfo Name ParamType]
args
      retdecl' :: Fmt
retdecl' =
        case Maybe UncheckedTypeExp
retdecl of
          Just UncheckedTypeExp
a -> Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":" Fmt -> Fmt -> Fmt
<+> UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
a Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space
          Maybe UncheckedTypeExp
Nothing -> Fmt
space
      sub :: Fmt
sub
        | [TypeParamBase Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParamBase Name]
tparams Bool -> Bool -> Bool
&& [PatBase NoInfo Name ParamType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatBase NoInfo Name ParamType]
args = Fmt
nil
        | [TypeParamBase Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParamBase Name]
tparams = Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
args'
        | [PatBase NoInfo Name ParamType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatBase NoInfo Name ParamType]
args = Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
tparams'
        | Bool
otherwise =
            [Loc] -> Fmt -> Fmt
forall a b. Located a => a -> FmtM b -> FmtM b
localLayout [[TypeParamBase Name] -> Loc
forall a. Located a => a -> Loc
locOf [TypeParamBase Name]
tparams, [PatBase NoInfo Name ParamType] -> Loc
forall a. Located a => a -> Loc
locOf [PatBase NoInfo Name ParamType]
args] (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
              Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
align (Fmt
tparams' Fmt -> Fmt -> Fmt
</> Fmt
args')
      fun :: Fmt
fun =
        case Maybe (NoInfo EntryPoint)
entry of
          Just NoInfo EntryPoint
_ -> Fmt
"entry"
          Maybe (NoInfo EntryPoint)
_any -> Fmt
"def"

instance Format (SizeExp UncheckedExp) where
  fmt :: SizeExp UncheckedExp -> Fmt
fmt (SizeExp UncheckedExp
d SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
brackets (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ UncheckedExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedExp
d
  fmt (SizeExpAny SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
brackets Fmt
nil

instance Format UncheckedSpec where
  fmt :: UncheckedSpec -> Fmt
fmt (TypeAbbrSpec UncheckedTypeBind
tpsig) = UncheckedTypeBind -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeBind
tpsig
  fmt (TypeSpec Liftedness
l Name
name [TypeParamBase Name]
ps Maybe DocComment
doc SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Maybe DocComment -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe DocComment
doc Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"type" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Liftedness -> Fmt
forall a. Format a => a -> Fmt
fmt Liftedness
l Fmt -> Fmt -> Fmt
<+> Fmt
sub
    where
      sub :: Fmt
sub
        | [TypeParamBase Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParamBase Name]
ps = AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name
        | Bool
otherwise = AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
align (Fmt -> [Fmt] -> Fmt
sep Fmt
line ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (TypeParamBase Name -> Fmt) -> [TypeParamBase Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase Name -> Fmt
forall a. Format a => a -> Fmt
fmt [TypeParamBase Name]
ps)
  fmt (ValSpec Name
name [TypeParamBase Name]
ps UncheckedTypeExp
te NoInfo StructType
_ Maybe DocComment
doc SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Maybe DocComment -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe DocComment
doc Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"val" Fmt -> Fmt -> Fmt
<+> Fmt
sub Fmt -> Fmt -> Fmt
<+> Fmt
":" Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
stdIndent (UncheckedTypeExp -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeExp
te)
    where
      sub :: Fmt
sub
        | [TypeParamBase Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParamBase Name]
ps = AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name
        | Bool
otherwise = AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (Fmt -> [Fmt] -> Fmt
sep Fmt
space ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (TypeParamBase Name -> Fmt) -> [TypeParamBase Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase Name -> Fmt
forall a. Format a => a -> Fmt
fmt [TypeParamBase Name]
ps)
  fmt (ModSpec Name
name ModTypeExpBase NoInfo Name
mte Maybe DocComment
doc SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Maybe DocComment -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe DocComment
doc Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"module" Fmt -> Fmt -> Fmt
<+> AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":" Fmt -> Fmt -> Fmt
<+> ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
mte
  fmt (IncludeSpec ModTypeExpBase NoInfo Name
mte SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"include" Fmt -> Fmt -> Fmt
<+> ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
mte

typeWiths ::
  UncheckedModTypeExp ->
  (UncheckedModTypeExp, [TypeRefBase NoInfo Name])
typeWiths :: ModTypeExpBase NoInfo Name
-> (ModTypeExpBase NoInfo Name, [TypeRefBase NoInfo Name])
typeWiths (ModTypeWith ModTypeExpBase NoInfo Name
mte TypeRefBase NoInfo Name
tr SrcLoc
_) = ([TypeRefBase NoInfo Name] -> [TypeRefBase NoInfo Name])
-> (ModTypeExpBase NoInfo Name, [TypeRefBase NoInfo Name])
-> (ModTypeExpBase NoInfo Name, [TypeRefBase NoInfo Name])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (TypeRefBase NoInfo Name
tr :) ((ModTypeExpBase NoInfo Name, [TypeRefBase NoInfo Name])
 -> (ModTypeExpBase NoInfo Name, [TypeRefBase NoInfo Name]))
-> (ModTypeExpBase NoInfo Name, [TypeRefBase NoInfo Name])
-> (ModTypeExpBase NoInfo Name, [TypeRefBase NoInfo Name])
forall a b. (a -> b) -> a -> b
$ ModTypeExpBase NoInfo Name
-> (ModTypeExpBase NoInfo Name, [TypeRefBase NoInfo Name])
typeWiths ModTypeExpBase NoInfo Name
mte
typeWiths ModTypeExpBase NoInfo Name
mte = (ModTypeExpBase NoInfo Name
mte, [])

instance Format UncheckedModTypeExp where
  fmt :: ModTypeExpBase NoInfo Name -> Fmt
fmt (ModTypeVar QualName Name
v NoInfo (Map VName VName)
_ SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ QualName Name -> Fmt
forall a. Pretty a => a -> Fmt
fmtPretty QualName Name
v
  fmt (ModTypeParens ModTypeExpBase NoInfo Name
mte SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"(" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
align (ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
mte) Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
")"
  fmt (ModTypeSpecs [UncheckedSpec]
sbs SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"{" Fmt -> Fmt -> Fmt
<:/> Fmt -> Fmt
stdIndent ((UncheckedSpec -> Fmt) -> [UncheckedSpec] -> Fmt
forall a. Located a => (a -> Fmt) -> [a] -> Fmt
sepDecs UncheckedSpec -> Fmt
forall a. Format a => a -> Fmt
fmt [UncheckedSpec]
sbs) Fmt -> Fmt -> Fmt
<:/> Fmt
"}"
  fmt (ModTypeWith ModTypeExpBase NoInfo Name
mte TypeRefBase NoInfo Name
tr SrcLoc
loc) =
    -- Special case multiple chained ModTypeWiths.
    let (ModTypeExpBase NoInfo Name
root, [TypeRefBase NoInfo Name]
withs) = ModTypeExpBase NoInfo Name
-> (ModTypeExpBase NoInfo Name, [TypeRefBase NoInfo Name])
typeWiths ModTypeExpBase NoInfo Name
mte
     in SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> (Fmt -> Fmt) -> Fmt -> Fmt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcLoc -> Fmt -> Fmt
forall a b. Located a => a -> FmtM b -> FmtM b
localLayout SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
          ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
root
            Fmt -> Fmt -> Fmt
</> Fmt -> [Fmt] -> Fmt
sep Fmt
line ((TypeRefBase NoInfo Name -> Fmt)
-> [TypeRefBase NoInfo Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map TypeRefBase NoInfo Name -> Fmt
forall {vn} {f :: * -> *}.
(IsName vn, Format (TypeExp (ExpBase f vn) vn),
 Format (TypeParamBase vn)) =>
TypeRefBase f vn -> Fmt
fmtWith ([TypeRefBase NoInfo Name] -> [TypeRefBase NoInfo Name]
forall a. [a] -> [a]
reverse ([TypeRefBase NoInfo Name] -> [TypeRefBase NoInfo Name])
-> [TypeRefBase NoInfo Name] -> [TypeRefBase NoInfo Name]
forall a b. (a -> b) -> a -> b
$ TypeRefBase NoInfo Name
tr TypeRefBase NoInfo Name
-> [TypeRefBase NoInfo Name] -> [TypeRefBase NoInfo Name]
forall a. a -> [a] -> [a]
: [TypeRefBase NoInfo Name]
withs))
    where
      fmtWith :: TypeRefBase f vn -> Fmt
fmtWith (TypeRef QualName vn
v [TypeParamBase vn]
ps TypeExp (ExpBase f vn) vn
td SrcLoc
_) =
        Fmt
"with"
          Fmt -> Fmt -> Fmt
<+> QualName vn -> Fmt
forall a. Pretty a => a -> Fmt
fmtPretty QualName vn
v
          Fmt -> Fmt -> Fmt
`ps_op` Fmt -> [Fmt] -> Fmt
sep Fmt
space ((TypeParamBase vn -> Fmt) -> [TypeParamBase vn] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map TypeParamBase vn -> Fmt
forall a. Format a => a -> Fmt
fmt [TypeParamBase vn]
ps)
          Fmt -> Fmt -> Fmt
<+> Fmt
"="
          Fmt -> Fmt -> Fmt
<+> TypeExp (ExpBase f vn) vn -> Fmt
forall a. Format a => a -> Fmt
fmt TypeExp (ExpBase f vn) vn
td
        where
          ps_op :: Fmt -> Fmt -> Fmt
ps_op = if [TypeParamBase vn] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParamBase vn]
ps then Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
(<>) else Fmt -> Fmt -> Fmt
(<+>)
  fmt (ModTypeArrow (Just Name
v) ModTypeExpBase NoInfo Name
te0 ModTypeExpBase NoInfo Name
te1 SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Fmt -> Fmt
parens (AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
v Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":" Fmt -> Fmt -> Fmt
<+> ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
te0) Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (Fmt
"->" Fmt -> Fmt -> Fmt
</> ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
te1)
  fmt (ModTypeArrow Maybe Name
Nothing ModTypeExpBase NoInfo Name
te0 ModTypeExpBase NoInfo Name
te1 SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
te0 Fmt -> Fmt -> Fmt
<+> Fmt
"->" Fmt -> Fmt -> Fmt
<+> ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
te1

instance Format UncheckedModTypeBind where
  fmt :: UncheckedModTypeBind -> Fmt
fmt (ModTypeBind Name
pName ModTypeExpBase NoInfo Name
pSig Maybe DocComment
doc SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Maybe DocComment -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe DocComment
doc
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"module"
          Fmt -> Fmt -> Fmt
<+> Fmt
"type"
          Fmt -> Fmt -> Fmt
<+> AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
pName
          Fmt -> Fmt -> Fmt
<+> Fmt
"="
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> case ModTypeExpBase NoInfo Name
pSig of
          ModTypeSpecs {} -> Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
pSig
          ModTypeExpBase NoInfo Name
_ -> Fmt
line Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
stdIndent (ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
pSig)

instance Format (ModParamBase NoInfo Name) where
  fmt :: ModParamBase NoInfo Name -> Fmt
fmt (ModParam Name
pName ModTypeExpBase NoInfo Name
pSig NoInfo [VName]
_f SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
parens (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
pName Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":" Fmt -> Fmt -> Fmt
<+> ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
pSig

instance Format UncheckedModBind where
  fmt :: UncheckedModBind -> Fmt
fmt (ModBind Name
name [ModParamBase NoInfo Name]
ps Maybe (ModTypeExpBase NoInfo Name, NoInfo (Map VName VName))
sig ModExpBase NoInfo Name
me Maybe DocComment
doc SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Maybe DocComment -> Fmt
forall a. Format a => a -> Fmt
fmt Maybe DocComment
doc
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"module"
          Fmt -> Fmt -> Fmt
<+> [Loc] -> Fmt -> Fmt
forall a b. Located a => a -> FmtM b -> FmtM b
localLayout
            [Loc -> Loc
locStart (SrcLoc -> Loc
forall a. Located a => a -> Loc
locOf SrcLoc
loc), [ModParamBase NoInfo Name] -> Loc
forall a. Located a => a -> Loc
locOf [ModParamBase NoInfo Name]
ps]
            (AnsiStyle -> Name -> Fmt
fmtName AnsiStyle
bindingStyle Name
name Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
ps')
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Maybe (ModTypeExpBase NoInfo Name, NoInfo (Map VName VName)) -> Fmt
forall {a} {b}. (Located a, Format a) => Maybe (a, b) -> Fmt
fmtSig Maybe (ModTypeExpBase NoInfo Name, NoInfo (Map VName VName))
sig
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"="
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
me'
    where
      me' :: Fmt
me' = ModExpBase NoInfo Name -> Fmt -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt -> Fmt
fmtByLayout ModExpBase NoInfo Name
me (Fmt
line Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
stdIndent (ModExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModExpBase NoInfo Name
me)) (Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> ModExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModExpBase NoInfo Name
me)
      fmtSig :: Maybe (a, b) -> Fmt
fmtSig Maybe (a, b)
Nothing = Fmt
space
      fmtSig (Just (a
s', b
_f)) =
        [Loc] -> Fmt -> Fmt
forall a b. Located a => a -> FmtM b -> FmtM b
localLayout ((ModParamBase NoInfo Name -> Loc)
-> [ModParamBase NoInfo Name] -> [Loc]
forall a b. (a -> b) -> [a] -> [b]
map ModParamBase NoInfo Name -> Loc
forall a. Located a => a -> Loc
locOf [ModParamBase NoInfo Name]
ps [Loc] -> [Loc] -> [Loc]
forall a. [a] -> [a] -> [a]
++ [a -> Loc
forall a. Located a => a -> Loc
locOf a
s']) (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
          Fmt
line Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
stdIndent (Fmt
":" Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
align (a -> Fmt
forall a. Format a => a -> Fmt
fmt a
s') Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space)
      ps' :: Fmt
ps' =
        case [ModParamBase NoInfo Name]
ps of
          [] -> Fmt
nil
          [ModParamBase NoInfo Name]
_any -> Fmt
line Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt -> Fmt
stdIndent ([ModParamBase NoInfo Name] -> Fmt -> Fmt
forall a b. Located a => [a] -> FmtM b -> FmtM b
localLayoutList [ModParamBase NoInfo Name]
ps (Fmt -> Fmt
align (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
line ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (ModParamBase NoInfo Name -> Fmt)
-> [ModParamBase NoInfo Name] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map ModParamBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt [ModParamBase NoInfo Name]
ps))

-- All of these should probably be "extra" indented
instance Format UncheckedModExp where
  fmt :: ModExpBase NoInfo Name -> Fmt
fmt (ModVar QualName Name
v SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ QualName Name -> Fmt
fmtQualName QualName Name
v
  fmt (ModParens ModExpBase NoInfo Name
f SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"(" Fmt -> Fmt -> Fmt
<:/> Fmt -> Fmt
stdIndent (ModExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModExpBase NoInfo Name
f) Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
")"
  fmt (ModImport [Char]
path NoInfo ImportName
_f SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"import" Fmt -> Fmt -> Fmt
<+> Fmt
"\"" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> [Char] -> Fmt
forall a. Pretty a => a -> Fmt
fmtPretty [Char]
path Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"\""
  fmt (ModDecs [DecBase NoInfo Name]
decs SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Fmt
"{" Fmt -> Fmt -> Fmt
<:/> Fmt -> Fmt
stdIndent ((DecBase NoInfo Name -> Fmt) -> [DecBase NoInfo Name] -> Fmt
forall a. Located a => (a -> Fmt) -> [a] -> Fmt
sepDecs DecBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt [DecBase NoInfo Name]
decs) Fmt -> Fmt -> Fmt
<:/> Fmt
"}"
  fmt (ModApply ModExpBase NoInfo Name
f ModExpBase NoInfo Name
a NoInfo (Map VName VName)
_f0 NoInfo (Map VName VName)
_f1 SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ ModExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModExpBase NoInfo Name
f Fmt -> Fmt -> Fmt
<+> ModExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModExpBase NoInfo Name
a
  fmt (ModAscript ModExpBase NoInfo Name
me ModTypeExpBase NoInfo Name
se NoInfo (Map VName VName)
_f SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
align (ModExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModExpBase NoInfo Name
me Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
":" Fmt -> Fmt -> Fmt
</> ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
se)
  fmt (ModLambda ModParamBase NoInfo Name
param Maybe (ModTypeExpBase NoInfo Name, NoInfo (Map VName VName))
maybe_sig ModExpBase NoInfo Name
body SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$
      Fmt
"\\" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> ModParamBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModParamBase NoInfo Name
param Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
sig Fmt -> Fmt -> Fmt
<+> Fmt
"->" Fmt -> Fmt -> Fmt
</> Fmt -> Fmt
stdIndent (ModExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModExpBase NoInfo Name
body)
    where
      sig :: Fmt
sig =
        case Maybe (ModTypeExpBase NoInfo Name, NoInfo (Map VName VName))
maybe_sig of
          Maybe (ModTypeExpBase NoInfo Name, NoInfo (Map VName VName))
Nothing -> Fmt
nil
          Just (ModTypeExpBase NoInfo Name
sig', NoInfo (Map VName VName)
_) -> Fmt
":" Fmt -> Fmt -> Fmt
<+> Fmt -> Fmt
parens (ModTypeExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModTypeExpBase NoInfo Name
sig')

instance Format UncheckedDec where
  fmt :: DecBase NoInfo Name -> Fmt
fmt (ValDec UncheckedValBind
t) = UncheckedValBind -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedValBind
t
  fmt (TypeDec UncheckedTypeBind
tb) = UncheckedTypeBind -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedTypeBind
tb
  fmt (ModTypeDec UncheckedModTypeBind
tb) = UncheckedModTypeBind -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedModTypeBind
tb
  fmt (ModDec UncheckedModBind
tb) = UncheckedModBind -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedModBind
tb
  fmt (OpenDec ModExpBase NoInfo Name
tb SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"open" Fmt -> Fmt -> Fmt
<+> ModExpBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt ModExpBase NoInfo Name
tb
  fmt (LocalDec DecBase NoInfo Name
tb SrcLoc
loc) = SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"local" Fmt -> Fmt -> Fmt
</> DecBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt DecBase NoInfo Name
tb
  fmt (ImportDec [Char]
path NoInfo ImportName
_tb SrcLoc
loc) =
    SrcLoc -> Fmt -> Fmt
forall a. Located a => a -> Fmt -> Fmt
addComments SrcLoc
loc (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt
"import" Fmt -> Fmt -> Fmt
<+> Fmt
"\"" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> [Char] -> Fmt
forall a. Pretty a => a -> Fmt
fmtPretty [Char]
path Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"\""

instance Format UncheckedProg where
  fmt :: UncheckedProg -> Fmt
fmt (Prog Maybe DocComment
Nothing []) = Fmt
popComments
  fmt (Prog Maybe DocComment
Nothing [DecBase NoInfo Name]
decs) = (DecBase NoInfo Name -> Fmt) -> [DecBase NoInfo Name] -> Fmt
forall a. Located a => (a -> Fmt) -> [a] -> Fmt
sepDecs DecBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt [DecBase NoInfo Name]
decs Fmt -> Fmt -> Fmt
</> Fmt
popComments
  fmt (Prog (Just DocComment
dc) [DecBase NoInfo Name]
decs) = DocComment -> Fmt
forall a. Format a => a -> Fmt
fmt DocComment
dc Fmt -> Fmt -> Fmt
</> (DecBase NoInfo Name -> Fmt) -> [DecBase NoInfo Name] -> Fmt
forall a. Located a => (a -> Fmt) -> [a] -> Fmt
sepDecs DecBase NoInfo Name -> Fmt
forall a. Format a => a -> Fmt
fmt [DecBase NoInfo Name]
decs Fmt -> Fmt -> Fmt
</> Fmt
popComments

-- | Given a filename and a futhark program, formats the program.
fmtToDoc :: String -> T.Text -> Either SyntaxError (Doc AnsiStyle)
fmtToDoc :: [Char] -> Text -> Either SyntaxError (Doc AnsiStyle)
fmtToDoc [Char]
fname Text
fcontent = do
  (UncheckedProg
prog, [Comment]
cs) <- [Char] -> Text -> Either SyntaxError (UncheckedProg, [Comment])
parseFutharkWithComments [Char]
fname Text
fcontent
  Doc AnsiStyle -> Either SyntaxError (Doc AnsiStyle)
forall a. a -> Either SyntaxError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc AnsiStyle -> Either SyntaxError (Doc AnsiStyle))
-> Doc AnsiStyle -> Either SyntaxError (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ Fmt -> [Comment] -> Text -> Doc AnsiStyle
forall a. FmtM a -> [Comment] -> Text -> a
runFormat (UncheckedProg -> Fmt
forall a. Format a => a -> Fmt
fmt UncheckedProg
prog) [Comment]
cs Text
fcontent

-- | Given a filename and a futhark program, formats the program as
-- text.
fmtToText :: String -> T.Text -> Either SyntaxError T.Text
fmtToText :: [Char] -> Text -> Either SyntaxError Text
fmtToText [Char]
fname Text
fcontent = Doc AnsiStyle -> Text
forall a. Doc a -> Text
docText (Doc AnsiStyle -> Text)
-> Either SyntaxError (Doc AnsiStyle) -> Either SyntaxError Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Text -> Either SyntaxError (Doc AnsiStyle)
fmtToDoc [Char]
fname Text
fcontent