------------------------------------------------------------------------
-- 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 :: 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 m :: ModuleName
m pragmas :: [ModulePragma]
pragmas imps :: [ImportDecl]
imps decls :: [Decl]
decls) =
    [Doc] -> Doc
vcat [ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (ModulePragma -> Doc) -> [ModulePragma] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ModulePragma -> Doc
forall a. Pretty a => a -> Doc
pretty [ModulePragma]
pragmas
         , "module" Doc -> Doc -> Doc
<+> ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty ModuleName
m Doc -> Doc -> Doc
<+> "where"
         , ""
         , [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (ImportDecl -> Doc) -> [ImportDecl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ImportDecl -> Doc
forall a. Pretty a => a -> Doc
pretty [ImportDecl]
imps
         , ""
         , [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]
decls ]

instance Pretty HS.ModulePragma where
  pretty :: ModulePragma -> Doc
pretty (HS.LanguagePragma ps :: [Name]
ps) =
    "{-#" Doc -> Doc -> Doc
<+> "LANGUAGE" Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep (Doc -> [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
<+> "#-}"
  pretty (HS.OtherPragma p :: 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
hsep [ "import"
           , if Bool
q then "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 (hide :: Bool
hide, specs :: [a]
specs) =
            [Doc] -> Doc
hsep [ if Bool
hide then "hiding" else Doc
empty
                 , Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [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 x :: Name
x) = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x

instance Pretty HS.Decl where
  pretty :: Decl -> Doc
pretty d :: Decl
d = case Decl
d of
    HS.TypeDecl f :: Name
f xs :: [TyVarBind]
xs t :: Type
t ->
      [Doc] -> Doc
sep [ "type" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
f Doc -> Doc -> Doc
<+> [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
<+> "="
          , Int -> Doc -> Doc
nest 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 newt :: DataOrNew
newt d :: Name
d xs :: [TyVarBind]
xs cons :: [ConDecl]
cons derv :: [Deriving]
derv ->
      [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
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 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
fsep (Doc -> [Doc] -> [Doc]
punctuate " |" ([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 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 ds :: [(QName, t Type)]
ds = "deriving" Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [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 (d :: QName
d, ts :: 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 fs :: [Name]
fs t :: Type
t ->
      [Doc] -> Doc
sep [ [Doc] -> Doc
hsep (Doc -> [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
<+> "::"
          , Int -> Doc -> Doc
nest 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 ms :: [Match]
ms -> [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.PatSyn p1 :: Pat
p1 p2 :: Pat
p2 -> [Doc] -> Doc
sep [ "pattern" Doc -> Doc -> Doc
<+> Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p1 Doc -> Doc -> Doc
<+> "=" Doc -> Doc -> Doc
<+> Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p2 ]
    HS.FakeDecl s :: String
s -> String -> Doc
text String
s

instance Pretty HS.ConDecl where
  pretty :: ConDecl -> Doc
pretty (HS.ConDecl c :: Name
c sts :: [(Maybe Strictness, Type)]
sts) =
    Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
c Doc -> Doc -> Doc
<+>
    [Doc] -> Doc
fsep (((Maybe Strictness, Type) -> Doc)
-> [(Maybe Strictness, Type)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(s :: Maybe Strictness
s, t :: 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 10 Type
t) [(Maybe Strictness, Type)]
sts)

instance Pretty HS.Strictness where
  pretty :: Strictness -> Doc
pretty HS.Strict = "!"
  pretty HS.Lazy   = Doc
empty

instance Pretty HS.Match where
  pretty :: Match -> Doc
pretty (HS.Match f :: Name
f ps :: [Pat]
ps rhs :: Rhs
rhs wh :: Maybe Binds
wh) =
    Maybe Binds -> Doc -> Doc
prettyWhere Maybe Binds
wh (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      [Doc] -> Doc
sep [ Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
f Doc -> Doc -> Doc
<+> [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 10) [Pat]
ps)
          , Int -> Doc -> Doc
nest 2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Rhs -> Doc
prettyRhs "=" Rhs
rhs ]

prettyWhere :: Maybe HS.Binds -> Doc -> Doc
prettyWhere :: Maybe Binds -> Doc -> Doc
prettyWhere Nothing  doc :: Doc
doc = Doc
doc
prettyWhere (Just b :: Binds
b) doc :: Doc
doc =
  [Doc] -> Doc
vcat [ Doc
doc, Int -> Doc -> Doc
nest 2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [ "where", Int -> Doc -> Doc
nest 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 pr :: Int
pr pat :: Pat
pat =
    case Pat
pat of
      HS.PVar x :: Name
x         -> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
      HS.PLit l :: Literal
l         -> Literal -> Doc
forall a. Pretty a => a -> Doc
pretty Literal
l
      HS.PAsPat x :: Name
x p :: Pat
p     -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
forall a. Semigroup a => a -> a -> a
<> Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 11 Pat
p
      HS.PWildCard      -> "_"
      HS.PBangPat p :: Pat
p     -> "!" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 11 Pat
p
      HS.PApp c :: QName
c ps :: [Pat]
ps      -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
hsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 10) [Pat]
ps)
      HS.PatTypeSig p :: Pat
p t :: Type
t -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [ Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p Doc -> Doc -> Doc
<+> "::", Int -> Doc -> Doc
nest 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 p :: Pat
p      -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 10) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ "~" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Pat -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 11 Pat
p

prettyRhs :: String -> HS.Rhs -> Doc
prettyRhs :: String -> Rhs -> Doc
prettyRhs eq :: String
eq (HS.UnGuardedRhs e :: Exp
e)   = String -> Doc
text String
eq Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e
prettyRhs eq :: String
eq (HS.GuardedRhss rhss :: [GuardedRhs]
rhss) = [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 eq :: String
eq (HS.GuardedRhs ss :: [Stmt]
ss e :: Exp
e) =
    [Doc] -> Doc
sep [ "|" Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep (Doc -> [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 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 ds :: [Decl]
ds) = [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 HS.DataType = "data"
  pretty HS.NewType  = "newtype"

instance Pretty HS.TyVarBind where
  pretty :: TyVarBind -> Doc
pretty (HS.UnkindedVar x :: Name
x) = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x

instance Pretty HS.Type where
  prettyPrec :: Int -> Type -> Doc
prettyPrec pr :: Int
pr t :: Type
t =
    case Type
t of
      HS.TyForall xs :: [TyVarBind]
xs t :: Type
t ->
        Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
          [Doc] -> Doc
sep [ ("forall" Doc -> Doc -> Doc
<+> [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
<> "."
              , Int -> Doc -> Doc
nest 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 a :: Type
a b :: Type
b ->
        Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 4) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
          [Doc] -> Doc
sep [ Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 5 Type
a Doc -> Doc -> Doc
<+> "->", Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 4 Type
b ]
      HS.TyCon c :: QName
c -> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
c
      HS.TyVar x :: Name
x -> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
      HS.TyApp (HS.TyCon (HS.UnQual (HS.Ident "[]"))) t :: 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
> 9) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
          [Doc] -> Doc
sep [ Int -> Type -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 9 Type
f
              , Int -> Doc -> Doc
nest 2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [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 10) [Type]
ts ]
        where
          f :: Type
f : ts :: [Type]
ts = Type -> [Type] -> [Type]
appView Type
t []
          appView :: Type -> [Type] -> [Type]
appView (HS.TyApp a :: Type
a b :: Type
b) as :: [Type]
as = Type -> [Type] -> [Type]
appView Type
a (Type
b Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
as)
          appView t :: Type
t as :: [Type]
as = Type
t Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
as
      HS.FakeType s :: String
s -> String -> Doc
text String
s

instance Pretty HS.Stmt where
  pretty :: Stmt -> Doc
pretty (HS.Qualifier e :: Exp
e) = Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e
  pretty (HS.Generator p :: Pat
p e :: Exp
e) = [Doc] -> Doc
sep [ Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
p Doc -> Doc -> Doc
<+> "<-", Int -> Doc -> Doc
nest 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
  pretty :: Literal -> Doc
pretty (HS.Int n :: Integer
n)    = Integer -> Doc
integer Integer
n
  pretty (HS.Frac x :: Rational
x)   = Double -> Doc
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x)
  pretty (HS.Char c :: Char
c)   = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)
  pretty (HS.String s :: String
s) = String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
s)

instance Pretty HS.Exp where
  prettyPrec :: Int -> Exp -> Doc
prettyPrec pr :: Int
pr e :: Exp
e =
    case Exp
e of
      HS.Var x :: QName
x -> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
x
      HS.Con c :: QName
c -> QName -> Doc
forall a. Pretty a => a -> Doc
pretty QName
c
      HS.Lit l :: Literal
l -> Literal -> Doc
forall a. Pretty a => a -> Doc
pretty Literal
l
      HS.InfixApp a :: Exp
a qop :: QOp
qop b :: Exp
b -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
sep [ Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 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 1 Exp
b ]
      HS.App{} -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 9) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
sep [ Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 9 Exp
f
            , Int -> Doc -> Doc
nest 2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [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 10) [Exp]
es ]
        where
          f :: Exp
f : es :: [Exp]
es = Exp -> [Exp] -> [Exp]
appView Exp
e []
          appView :: Exp -> [Exp] -> [Exp]
appView (HS.App f :: Exp
f e :: Exp
e) es :: [Exp]
es = Exp -> [Exp] -> [Exp]
appView Exp
f (Exp
e Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
es)
          appView f :: Exp
f es :: [Exp]
es = Exp
f Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
es
      HS.Lambda ps :: [Pat]
ps e :: Exp
e -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
sep [ "\\" Doc -> Doc -> Doc
<+> [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 10) [Pat]
ps) Doc -> Doc -> Doc
<+> "->"
            , Int -> Doc -> Doc
nest 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 bs :: Binds
bs e :: Exp
e -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
sep [ "let" Doc -> Doc -> Doc
<+> Binds -> Doc
forall a. Pretty a => a -> Doc
pretty Binds
bs Doc -> Doc -> Doc
<+> "in"
            , Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e ]
      HS.If a :: Exp
a b :: Exp
b c :: Exp
c -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
sep [ "if" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
a
            , Int -> Doc -> Doc
nest 2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ "then" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
b
            , Int -> Doc -> Doc
nest 2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ "else" Doc -> Doc -> Doc
<+> Int -> Exp -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec 1 Exp
c ]
      HS.Case e :: Exp
e bs :: [Alt]
bs -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
vcat [ "case" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e Doc -> Doc -> Doc
<+> "of"
             , Int -> Doc -> Doc
nest 2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [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 e :: Exp
e t :: Type
t -> Bool -> Doc -> Doc
mparens (Int
pr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
        [Doc] -> Doc
sep [ Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
e Doc -> Doc -> Doc
<+> "::"
            , Int -> Doc -> Doc
nest 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
exp -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ "-" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Exp -> Doc
forall a. Pretty a => a -> Doc
pretty Exp
exp
      HS.FakeExp s :: String
s -> String -> Doc
text String
s

instance Pretty HS.Alt where
  pretty :: Alt -> Doc
pretty (HS.Alt pat :: Pat
pat rhs :: Rhs
rhs wh :: Maybe Binds
wh) =
    Maybe Binds -> Doc -> Doc
prettyWhere Maybe Binds
wh (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      [Doc] -> Doc
sep [ Pat -> Doc
forall a. Pretty a => a -> Doc
pretty Pat
pat, Int -> Doc -> Doc
nest 2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Rhs -> Doc
prettyRhs "->" Rhs
rhs ]

instance Pretty HS.ModuleName where
  pretty :: ModuleName -> Doc
pretty m :: ModuleName
m = String -> Doc
text String
s
    where HS.ModuleName s :: String
s = ModuleName -> ModuleName
encodeModuleName ModuleName
m

instance Pretty HS.QName where
  pretty :: QName -> Doc
pretty q :: 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  s :: String
s) = String -> Doc
text String
s
  pretty (HS.Symbol s :: String
s) = String -> Doc
text String
s

instance Pretty HS.QOp where
  pretty :: QOp -> Doc
pretty (HS.QVarOp x :: QName
x)
    | QName -> Bool
isOperator QName
x = QName -> Doc
prettyQName QName
x
    | Bool
otherwise    = "`" 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
<> "`"

isOperator :: HS.QName -> Bool
isOperator :: QName -> Bool
isOperator q :: QName
q =
  case QName
q of
    HS.Qual _ x :: Name
x           -> Name -> Bool
isOp Name
x
    HS.UnQual x :: 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 m :: ModuleName
m x :: 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
forall a. Semigroup a => a -> a -> a
<> Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x
prettyQName (HS.UnQual x :: Name
x)           = Name -> Doc
forall a. Pretty a => a -> Doc
pretty Name
x