------------------------------------------------------------------------
-- Pretty-printing of Haskell modules
------------------------------------------------------------------------

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 = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
    forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [ModulePragma]
pragmas
      , [ Doc
"" | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModulePragma]
pragmas ]
      , [ Doc
"module" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty ModuleName
m Doc -> Doc -> Doc
<+> Doc
"where" ]
      , [ Doc
"" ]
      , forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [ImportDecl]
imps
      , [ Doc
"" ]
      , forall a b. (a -> b) -> [a] -> [b]
map 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
<+> forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 } =
      forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep [ Doc
"import"
           , if Bool
q then Doc
"qualified" else Doc
empty
           , forall a. Pretty a => a -> Doc
pretty ModuleName
m
           , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty forall {a}. Pretty a => (Bool, [a]) -> Doc
prSpecs Maybe (Bool, [ImportSpec])
specs ]
    where prSpecs :: (Bool, [a]) -> Doc
prSpecs (Bool
hide, [a]
specs) =
            forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep [ if Bool
hide then Doc
"hiding" else Doc
empty
                 , Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [a]
specs ]

instance Pretty HS.ImportSpec where
  pretty :: ImportSpec -> Doc
pretty (HS.IVar Name
x) = 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 ->
      forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"type" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty Name
f Doc -> Doc -> Doc
<+> forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [TyVarBind]
xs) Doc -> Doc -> Doc
<+> Doc
"="
          , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Type
t ]
    HS.DataDecl DataOrNew
newt Name
d [TyVarBind]
xs [ConDecl]
cons [Deriving]
derv ->
      forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => a -> Doc
pretty DataOrNew
newt Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty Name
d Doc -> Doc -> Doc
<+> forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [TyVarBind]
xs)
          , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConDecl]
cons then Doc
empty
                     else Doc
"=" Doc -> Doc -> Doc
<+> forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
" |" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [ConDecl]
cons)
          , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ 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 (forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {t :: * -> *}. Foldable t => (QName, t Type) -> Doc
prDer [(QName, t Type)]
ds)
        prDer :: (QName, t Type) -> Doc
prDer (QName
d, t Type
ts) = forall a. Pretty a => a -> Doc
pretty (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 ->
      forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep (forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [Name]
fs)) Doc -> Doc -> Doc
<+> Doc
"::"
          , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Type
t ]
    HS.FunBind [Match]
ms -> forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [Match]
ms
    HS.LocalBind Strictness
s Name
f Rhs
rhs ->
      forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => a -> Doc
pretty Strictness
s forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
pretty Name
f
          , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ String -> Rhs -> Doc
prettyRhs String
"=" Rhs
rhs
          ]
    HS.PatSyn Pat
p1 Pat
p2 -> forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"pattern" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty Pat
p1 Doc -> Doc -> Doc
<+> Doc
"=" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty Pat
p2 ]
    HS.FakeDecl String
s -> String -> Doc
text String
s
    HS.Comment String
s -> forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Doc
"--" Doc -> Doc -> 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) =
    forall a. Pretty a => a -> Doc
pretty Name
c Doc -> Doc -> Doc
<+>
    forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe Strictness
s, Type
t) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty forall a. Pretty a => a -> Doc
pretty Maybe Strictness
s forall a. Semigroup a => a -> a -> a
<> 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 forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => a -> Doc
pretty Name
f Doc -> Doc -> Doc
<+> forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Pat]
ps)
          , Int -> Doc -> Doc
nest Int
2 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 =
  forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat [ Doc
doc, Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"where", Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ 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         -> forall a. Pretty a => a -> Doc
pretty Name
x
      HS.PLit Literal
l         -> forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
pr Literal
l
      HS.PAsPat Name
x Pat
p     -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Name
x forall a. Semigroup a => a -> a -> a
<> Doc
"@" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
11 Pat
p
      Pat
HS.PWildCard      -> Doc
"_"
      HS.PBangPat Pat
p     -> Doc
"!" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
11 Pat
p
      HS.PApp QName
c [Pat]
ps      -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
9) forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty QName
c Doc -> Doc -> Doc
<+> forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Pat]
ps)
      HS.PatTypeSig Pat
p Type
t -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => a -> Doc
pretty Pat
p Doc -> Doc -> Doc
<+> Doc
"::", Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Type
t ]
      HS.PIrrPat Pat
p      -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ Doc
"~" forall a. Semigroup a => a -> a -> a
<> 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
<+> forall a. Pretty a => a -> Doc
pretty Exp
e
prettyRhs String
eq (HS.GuardedRhss [GuardedRhs]
rhss) = forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat forall a b. (a -> b) -> a -> b
$ 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) =
    forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"|" Doc -> Doc -> Doc
<+> forall (t :: * -> *). Foldable t => t Doc -> Doc
sep (forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [Stmt]
ss) Doc -> Doc -> Doc
<+> String -> Doc
text String
eq
        , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Exp
e ]

instance Pretty HS.Binds where
  pretty :: Binds -> Doc
pretty (HS.BDecls [Decl]
ds) = forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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) = 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 forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ (Doc
"forall" Doc -> Doc -> Doc
<+> forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [TyVarBind]
xs)) forall a. Semigroup a => a -> a -> a
<> Doc
"."
              , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Type
t ]
      HS.TyFun Type
a Type
b ->
        Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
4) forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
5 Type
a Doc -> Doc -> Doc
<+> Doc
"->", forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
4 Type
b ]
      HS.TyCon QName
c -> forall a. Pretty a => a -> Doc
pretty QName
c
      HS.TyVar Name
x -> forall a. Pretty a => a -> Doc
pretty Name
x
      HS.TyApp (HS.TyCon (HS.UnQual (HS.Ident String
"[]"))) Type
t ->
        Doc -> Doc
brackets forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Type
t
      t :: Type
t@HS.TyApp{} ->
        Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
9) forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
9 Type
f
              , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 forall a. a -> [a] -> [a]
: [Type]
as)
          appView Type
t [Type]
as = Type
t 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) = forall a. Pretty a => a -> Doc
pretty Exp
e
  pretty (HS.Generator Pat
p Exp
e) = forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => a -> Doc
pretty Pat
p Doc -> Doc -> Doc
<+> Doc
"<-", Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ 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    -> forall n. (Ord n, Num n) => n -> Doc -> Doc
parensIfNeg Integer
n forall a b. (a -> b) -> a -> b
$ Integer -> Doc
integer Integer
n
    HS.Frac Rational
x   -> forall n. (Ord n, Num n) => n -> Doc -> Doc
parensIfNeg Double
d forall a b. (a -> b) -> a -> b
$ Double -> Doc
double Double
d
                   where
                   d :: Double
d = forall a. Fractional a => Rational -> a
fromRational Rational
x
    HS.Char Char
c   -> String -> Doc
text (forall a. Show a => a -> String
show Char
c)
    HS.String Text
s -> String -> Doc
text (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 forall a. Ord a => a -> a -> Bool
< n
0 then Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
10) else 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 -> forall a. Pretty a => a -> Doc
pretty QName
x
      HS.Con QName
c -> forall a. Pretty a => a -> Doc
pretty QName
c
      HS.Lit Literal
l -> forall a. Pretty a => a -> Doc
pretty Literal
l
      HS.InfixApp Exp
a QOp
qop Exp
b -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
a
            , forall a. Pretty a => a -> Doc
pretty QOp
qop Doc -> Doc -> 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 forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Exp
e
            , Doc
"::"
            , forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 Type
ty
            ]
      HS.App{} -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
9) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
9 Exp
f
            , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 forall a. a -> [a] -> [a]
: [Exp]
es)
          appView Exp
f [Exp]
es = Exp
f forall a. a -> [a] -> [a]
: [Exp]
es
      HS.Lambda [Pat]
ps Exp
e -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"\\" Doc -> Doc -> Doc
<+> forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
10) [Pat]
ps) Doc -> Doc -> Doc
<+> Doc
"->"
            , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Exp
e ]
      HS.Let Binds
bs Exp
e -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"let" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty Binds
bs Doc -> Doc -> Doc
<+> Doc
"in"
            , forall a. Pretty a => a -> Doc
pretty Exp
e ]
      HS.If Exp
a Exp
b Exp
c -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Doc
"if" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty Exp
a
            , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ Doc
"then" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty Exp
b
            , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ Doc
"else" Doc -> Doc -> 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 forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat [ Doc
"case" Doc -> Doc -> Doc
<+> forall a. Pretty a => a -> Doc
pretty Exp
e Doc -> Doc -> Doc
<+> Doc
"of"
             , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty [Alt]
bs ]
      HS.ExpTypeSig Exp
e Type
t -> Bool -> Doc -> Doc
mparens (Int
pr forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => a -> Doc
pretty Exp
e Doc -> Doc -> Doc
<+> Doc
"::"
            , Int -> Doc -> Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Type
t ]
      HS.NegApp Exp
exp -> Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ Doc
"-" forall a. Semigroup a => a -> a -> a
<> 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 forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ forall a. Pretty a => a -> Doc
pretty Pat
pat, Int -> Doc -> Doc
nest Int
2 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
"`" forall a. Semigroup a => a -> a -> a
<> QName -> Doc
prettyQName QName
x 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)           = forall a. Pretty a => a -> Doc
pretty ModuleName
m forall a. Semigroup a => a -> a -> a
<> Doc
"." forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Doc
pretty Name
x
prettyQName (HS.UnQual Name
x)           = forall a. Pretty a => a -> Doc
pretty Name
x