module Agda.Compiler.MAlonzo.Pretty where
import qualified Agda.Utils.Haskell.Syntax as HS
import Text.PrettyPrint (empty)
import Agda.Compiler.MAlonzo.Encode
import Agda.Utils.Pretty
prettyPrint :: Pretty a => a -> String
prettyPrint :: forall a. Pretty a => a -> String
prettyPrint = Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Pretty a => a -> Doc
pretty
instance Pretty HS.Module where
pretty :: Module -> Doc
pretty (HS.Module ModuleName
m [ModulePragma]
pragmas [ImportDecl]
imps [Decl]
decls) =
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ (ModulePragma -> Doc) -> [ModulePragma] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModulePragma -> Doc
forall a. Pretty a => a -> Doc
pretty [ModulePragma]
pragmas
, [ Doc
"" | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ModulePragma] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModulePragma]
pragmas ]
, [ Doc
"module" Doc -> Doc -> Doc
<+> ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
m Doc -> Doc -> Doc
<+> Doc
"where" ]
, [ Doc
"" ]
, (ImportDecl -> Doc) -> [ImportDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [ImportDecl]
imps
, [ Doc
"" ]
, (Decl -> Doc) -> [Decl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Decl -> Doc
forall a. Pretty a => a -> Doc
pretty [Decl]
decls
]
instance Pretty HS.ModulePragma where
pretty :: ModulePragma -> Doc
pretty (HS.LanguagePragma [Name]
ps) =
Doc
"{-#" Doc -> Doc -> Doc
<+> Doc
"LANGUAGE" Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
pretty [Name]
ps) Doc -> Doc -> Doc
<+> Doc
"#-}"
pretty (HS.OtherPragma String
p) =
String -> Doc
text String
p
instance Pretty HS.ImportDecl where
pretty :: ImportDecl -> Doc
pretty HS.ImportDecl{ importModule :: ImportDecl -> ModuleName
HS.importModule = ModuleName
m
, importQualified :: ImportDecl -> Bool
HS.importQualified = Bool
q
, importSpecs :: ImportDecl -> Maybe (Bool, [ImportSpec])
HS.importSpecs = Maybe (Bool, [ImportSpec])
specs } =
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep [ Doc
"import"
, if Bool
q then Doc
"qualified" else Doc
empty
, ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
m
, Doc
-> ((Bool, [ImportSpec]) -> Doc)
-> Maybe (Bool, [ImportSpec])
-> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (Bool, [ImportSpec]) -> Doc
forall {a}. Pretty a => (Bool, [a]) -> Doc
prSpecs Maybe (Bool, [ImportSpec])
specs ]
where prSpecs :: (Bool, [a]) -> Doc
prSpecs (Bool
hide, [a]
specs) =
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep [ if Bool
hide then Doc
"hiding" else Doc
empty
, Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
pretty [a]
specs ]
instance Pretty HS.ImportSpec where
pretty :: ImportSpec -> Doc
pretty (HS.IVar Name
x) = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
instance Pretty HS.Decl where
pretty :: Decl -> Doc
pretty = \case
HS.TypeDecl Name
f [TyVarBind]
xs Type
t ->
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"type" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
f Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((TyVarBind -> Doc) -> [TyVarBind] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind -> Doc
forall a. Pretty a => a -> Doc
pretty [TyVarBind]
xs) Doc -> Doc -> Doc
<+> Doc
"="
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
HS.DataDecl DataOrNew
newt Name
d [TyVarBind]
xs [ConDecl]
cons [Deriving]
derv ->
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ DataOrNew -> Doc
forall a. Pretty a => a -> Doc
pretty DataOrNew
newt Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
d Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((TyVarBind -> Doc) -> [TyVarBind] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind -> Doc
forall a. Pretty a => a -> Doc
pretty [TyVarBind]
xs)
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ if [ConDecl] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConDecl]
cons then Doc
empty
else Doc
"=" Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
" |" ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (ConDecl -> Doc) -> [ConDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ConDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [ConDecl]
cons)
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Deriving] -> Doc
forall {t :: * -> *}. Foldable t => [(QName, t Type)] -> Doc
prDeriving [Deriving]
derv ]
where
prDeriving :: [(QName, t Type)] -> Doc
prDeriving [] = Doc
empty
prDeriving [(QName, t Type)]
ds = Doc
"deriving" Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ((QName, t Type) -> Doc) -> [(QName, t Type)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (QName, t Type) -> Doc
forall {t :: * -> *}. Foldable t => (QName, t Type) -> Doc
prDer [(QName, t Type)]
ds)
prDer :: (QName, t Type) -> Doc
prDer (QName
d, t Type
ts) = Type -> Doc
forall a. Pretty a => a -> Doc
pretty ((Type -> Type -> Type) -> Type -> t Type -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
HS.TyApp (QName -> Type
HS.TyCon QName
d) t Type
ts)
HS.TypeSig [Name]
fs Type
t ->
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep (Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Pretty a => a -> Doc
pretty [Name]
fs)) Doc -> Doc -> Doc
<+> Doc
"::"
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
HS.FunBind [Match]
ms -> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Match -> Doc) -> [Match] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Match -> Doc
forall a. Pretty a => a -> Doc
pretty [Match]
ms
HS.LocalBind Strictness
s Name
f Rhs
rhs ->
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Strictness -> Doc
forall a. Pretty a => a -> Doc
pretty Strictness
s Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
f
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Rhs -> Doc
prettyRhs String
"=" Rhs
rhs
]
HS.PatSyn Pat
p1 Pat
p2 -> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"pattern" Doc -> Doc -> Doc
<+> Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p1 Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p2 ]
HS.FakeDecl String
s -> String -> Doc
text String
s
HS.Comment String
s -> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc
"--" Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text) (String -> [String]
lines String
s)
instance Pretty HS.ConDecl where
pretty :: ConDecl -> Doc
pretty (HS.ConDecl Name
c [(Maybe Strictness, Type)]
sts) =
Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
c Doc -> Doc -> Doc
<+>
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (((Maybe Strictness, Type) -> Doc)
-> [(Maybe Strictness, Type)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe Strictness
s, Type
t) -> Doc -> (Strictness -> Doc) -> Maybe Strictness -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty Strictness -> Doc
forall a. Pretty a => a -> Doc
pretty Maybe Strictness
s Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10 Type
t) [(Maybe Strictness, Type)]
sts)
instance Pretty HS.Strictness where
pretty :: Strictness -> Doc
pretty Strictness
HS.Strict = Doc
"!"
pretty Strictness
HS.Lazy = Doc
empty
instance Pretty HS.Match where
pretty :: Match -> Doc
pretty (HS.Match Name
f [Pat]
ps Rhs
rhs Maybe Binds
wh) =
Maybe Binds -> Doc -> Doc
prettyWhere Maybe Binds
wh (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
f Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Pat]
ps)
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Rhs -> Doc
prettyRhs String
"=" Rhs
rhs ]
prettyWhere :: Maybe HS.Binds -> Doc -> Doc
prettyWhere :: Maybe Binds -> Doc -> Doc
prettyWhere Maybe Binds
Nothing Doc
doc = Doc
doc
prettyWhere (Just Binds
b) Doc
doc =
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat [ Doc
doc, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"where", Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Binds -> Doc
forall a. Pretty a => a -> Doc
pretty Binds
b ] ]
instance Pretty HS.Pat where
prettyPrec :: Int -> Pat -> Doc
prettyPrec Int
pr Pat
pat =
case Pat
pat of
HS.PVar Name
x -> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
HS.PLit Literal
l -> Int -> Literal -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
pr Literal
l
HS.PAsPat Name
x Pat
p -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
11 Pat
p
Pat
HS.PWildCard -> Doc
"_"
HS.PBangPat Pat
p -> Doc
"!" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
11 Pat
p
HS.PApp QName
c [Pat]
ps -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
c Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Pat]
ps)
HS.PatTypeSig Pat
p Type
t -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p Doc -> Doc -> Doc
<+> Doc
"::", Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
HS.PIrrPat Pat
p -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"~" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
11 Pat
p
prettyRhs :: String -> HS.Rhs -> Doc
prettyRhs :: String -> Rhs -> Doc
prettyRhs String
eq (HS.UnGuardedRhs Exp
e) = String -> Doc
text String
eq Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e
prettyRhs String
eq (HS.GuardedRhss [GuardedRhs]
rhss) = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (GuardedRhs -> Doc) -> [GuardedRhs] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> GuardedRhs -> Doc
prettyGuardedRhs String
eq) [GuardedRhs]
rhss
prettyGuardedRhs :: String -> HS.GuardedRhs -> Doc
prettyGuardedRhs :: String -> GuardedRhs -> Doc
prettyGuardedRhs String
eq (HS.GuardedRhs [Stmt]
ss Exp
e) =
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"|" Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep (Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Stmt -> Doc) -> [Stmt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Stmt -> Doc
forall a. Pretty a => a -> Doc
pretty [Stmt]
ss) Doc -> Doc -> Doc
<+> String -> Doc
text String
eq
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e ]
instance Pretty HS.Binds where
pretty :: Binds -> Doc
pretty (HS.BDecls [Decl]
ds) = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Decl -> Doc) -> [Decl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Decl -> Doc
forall a. Pretty a => a -> Doc
pretty [Decl]
ds
instance Pretty HS.DataOrNew where
pretty :: DataOrNew -> Doc
pretty DataOrNew
HS.DataType = Doc
"data"
pretty DataOrNew
HS.NewType = Doc
"newtype"
instance Pretty HS.TyVarBind where
pretty :: TyVarBind -> Doc
pretty (HS.UnkindedVar Name
x) = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
instance Pretty HS.Type where
prettyPrec :: Int -> Type -> Doc
prettyPrec Int
pr Type
t =
case Type
t of
HS.TyForall [TyVarBind]
xs Type
t ->
Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ (Doc
"forall" Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((TyVarBind -> Doc) -> [TyVarBind] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBind -> Doc
forall a. Pretty a => a -> Doc
pretty [TyVarBind]
xs)) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"."
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
HS.TyFun Type
a Type
b ->
Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
4) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
5 Type
a Doc -> Doc -> Doc
<+> Doc
"->", Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
4 Type
b ]
HS.TyCon QName
c -> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
c
HS.TyVar Name
x -> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
HS.TyApp (HS.TyCon (HS.UnQual (HS.Ident String
"[]"))) Type
t ->
Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t
t :: Type
t@HS.TyApp{} ->
Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
9 Type
f
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Type -> Doc) -> [Type] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Type]
ts ]
where
Type
f : [Type]
ts = Type -> [Type] -> [Type]
appView Type
t []
appView :: Type -> [Type] -> [Type]
appView (HS.TyApp Type
a Type
b) [Type]
as = Type -> [Type] -> [Type]
appView Type
a (Type
b Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
as)
appView Type
t [Type]
as = Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
as
HS.FakeType String
s -> String -> Doc
text String
s
instance Pretty HS.Stmt where
pretty :: Stmt -> Doc
pretty (HS.Qualifier Exp
e) = Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e
pretty (HS.Generator Pat
p Exp
e) = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p Doc -> Doc -> Doc
<+> Doc
"<-", Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e ]
instance Pretty HS.Literal where
prettyPrec :: Int -> Literal -> Doc
prettyPrec Int
pr = \case
HS.Int Integer
n -> Integer -> Doc -> Doc
forall n. (Ord n, Num n) => n -> Doc -> Doc
parensIfNeg Integer
n (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Integer -> Doc
integer Integer
n
HS.Frac Rational
x -> Double -> Doc -> Doc
forall n. (Ord n, Num n) => n -> Doc -> Doc
parensIfNeg Double
d (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Double -> Doc
double Double
d
where
d :: Double
d = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x
HS.Char Char
c -> String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)
HS.String Text
s -> String -> Doc
text (Text -> String
forall a. Show a => a -> String
show Text
s)
where
parensIfNeg :: (Ord n, Num n) => n -> Doc -> Doc
parensIfNeg :: forall n. (Ord n, Num n) => n -> Doc -> Doc
parensIfNeg n
x =
if n
x n -> n -> Bool
forall a. Ord a => a -> a -> Bool
< n
0 then Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) else Doc -> Doc
forall a. a -> a
id
instance Pretty HS.Exp where
prettyPrec :: Int -> Exp -> Doc
prettyPrec Int
pr Exp
e =
case Exp
e of
HS.Var QName
x -> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
x
HS.Con QName
c -> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
c
HS.Lit Literal
l -> Literal -> Doc
forall a. Pretty a => a -> Doc
pretty Literal
l
HS.InfixApp Exp
a QOp
qop Exp
b -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
a
, QOp -> Doc
forall a. Pretty a => a -> Doc
pretty QOp
qop Doc -> Doc -> Doc
<+> Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
b ]
HS.Ann Exp
e Type
ty -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
e
, Doc
"::"
, Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Type
ty
]
HS.App{} -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
9 Exp
f
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Exp -> Doc) -> [Exp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Exp]
es ]
where
Exp
f : [Exp]
es = Exp -> [Exp] -> [Exp]
appView Exp
e []
appView :: Exp -> [Exp] -> [Exp]
appView (HS.App Exp
f Exp
e) [Exp]
es = Exp -> [Exp] -> [Exp]
appView Exp
f (Exp
e Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
es)
appView Exp
f [Exp]
es = Exp
f Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
es
HS.Lambda [Pat]
ps Exp
e -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"\\" Doc -> Doc -> Doc
<+> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Pat]
ps) Doc -> Doc -> Doc
<+> Doc
"->"
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e ]
HS.Let Binds
bs Exp
e -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"let" Doc -> Doc -> Doc
<+> Binds -> Doc
forall a. Pretty a => a -> Doc
pretty Binds
bs Doc -> Doc -> Doc
<+> Doc
"in"
, Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e ]
HS.If Exp
a Exp
b Exp
c -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"if" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
a
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"then" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
b
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"else" Doc -> Doc -> Doc
<+> Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
c ]
HS.Case Exp
e [Alt]
bs -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat [ Doc
"case" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e Doc -> Doc -> Doc
<+> Doc
"of"
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Alt -> Doc) -> [Alt] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Alt -> Doc
forall a. Pretty a => a -> Doc
pretty [Alt]
bs ]
HS.ExpTypeSig Exp
e Type
t -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e Doc -> Doc -> Doc
<+> Doc
"::"
, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Pretty a => a -> Doc
pretty Type
t ]
HS.NegApp Exp
exp -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"-" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
exp
HS.FakeExp String
s -> String -> Doc
text String
s
instance Pretty HS.Alt where
pretty :: Alt -> Doc
pretty (HS.Alt Pat
pat Rhs
rhs Maybe Binds
wh) =
Maybe Binds -> Doc -> Doc
prettyWhere Maybe Binds
wh (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
pat, Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Rhs -> Doc
prettyRhs String
"->" Rhs
rhs ]
instance Pretty HS.ModuleName where
pretty :: ModuleName -> Doc
pretty ModuleName
m = String -> Doc
text String
s
where HS.ModuleName String
s = ModuleName -> ModuleName
encodeModuleName ModuleName
m
instance Pretty HS.QName where
pretty :: QName -> Doc
pretty QName
q = Bool -> Doc -> Doc
mparens (QName -> Bool
isOperator QName
q) (QName -> Doc
prettyQName QName
q)
instance Pretty HS.Name where
pretty :: Name -> Doc
pretty (HS.Ident String
s) = String -> Doc
text String
s
pretty (HS.Symbol String
s) = String -> Doc
text String
s
instance Pretty HS.QOp where
pretty :: QOp -> Doc
pretty (HS.QVarOp QName
x)
| QName -> Bool
isOperator QName
x = QName -> Doc
prettyQName QName
x
| Bool
otherwise = Doc
"`" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> QName -> Doc
prettyQName QName
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"`"
isOperator :: HS.QName -> Bool
isOperator :: QName -> Bool
isOperator QName
q =
case QName
q of
HS.Qual ModuleName
_ Name
x -> Name -> Bool
isOp Name
x
HS.UnQual Name
x -> Name -> Bool
isOp Name
x
where
isOp :: Name -> Bool
isOp HS.Symbol{} = Bool
True
isOp HS.Ident{} = Bool
False
prettyQName :: HS.QName -> Doc
prettyQName :: QName -> Doc
prettyQName (HS.Qual ModuleName
m Name
x) = ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
m Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
prettyQName (HS.UnQual Name
x) = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x