{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module GhcDump.Pretty
    ( Pretty(..)
    , module GhcDump.Pretty
    ) where

import GhcDump.Ast
import GhcDump.Util

import Data.Ratio
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as BS
import Text.PrettyPrint.ANSI.Leijen

data PrettyOpts = PrettyOpts { PrettyOpts -> Bool
showUniques    :: Bool
                             , PrettyOpts -> Bool
showIdInfo     :: Bool
                             , PrettyOpts -> Bool
showLetTypes   :: Bool
                             , PrettyOpts -> Bool
showUnfoldings :: Bool
                             }

defaultPrettyOpts :: PrettyOpts
defaultPrettyOpts :: PrettyOpts
defaultPrettyOpts = PrettyOpts :: Bool -> Bool -> Bool -> Bool -> PrettyOpts
PrettyOpts { showUniques :: Bool
showUniques    = Bool
False
                               , showIdInfo :: Bool
showIdInfo     = Bool
False
                               , showLetTypes :: Bool
showLetTypes   = Bool
False
                               , showUnfoldings :: Bool
showUnfoldings = Bool
False
                               }

-- orphan
instance Pretty T.Text where
    pretty :: Text -> Doc
pretty = String -> Doc
text (String -> Doc) -> (Text -> String) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance Pretty ExternalName where
    pretty :: ExternalName -> Doc
pretty n :: ExternalName
n@ExternalName{} = ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty (ExternalName -> ModuleName
externalModuleName ExternalName
n) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"." Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ExternalName -> Text
externalName ExternalName
n)
    pretty ExternalName
ForeignCall = Doc
"<foreign>"

instance Pretty ModuleName where
    pretty :: ModuleName -> Doc
pretty = String -> Doc
text (String -> Doc) -> (ModuleName -> String) -> ModuleName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (ModuleName -> Text) -> ModuleName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text
getModuleName

instance Pretty Unique where
    pretty :: Unique -> Doc
pretty = String -> Doc
text (String -> Doc) -> (Unique -> String) -> Unique -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> String
forall a. Show a => a -> String
show

instance Pretty BinderId where
    pretty :: BinderId -> Doc
pretty (BinderId Unique
b) = Unique -> Doc
forall a. Pretty a => a -> Doc
pretty Unique
b

instance Pretty Binder where
    pretty :: Binder -> Doc
pretty = PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
defaultPrettyOpts

pprBinder :: PrettyOpts -> Binder -> Doc
pprBinder :: PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts Binder
b
  | PrettyOpts -> Bool
showUniques PrettyOpts
opts = Text -> Doc
forall a. Pretty a => a -> Doc
pretty (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ Binder -> Text
binderUniqueName Binder
b
  | Bool
otherwise        = Text -> Doc
forall a. Pretty a => a -> Doc
pretty (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ Binder' Binder Binder -> Text
forall bndr var. Binder' bndr var -> Text
binderName (Binder' Binder Binder -> Text) -> Binder' Binder Binder -> Text
forall a b. (a -> b) -> a -> b
$ Binder -> Binder' Binder Binder
unBndr Binder
b

instance Pretty TyCon where
    pretty :: TyCon -> Doc
pretty (TyCon Text
t Unique
_) = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t

pprRational :: Rational -> Doc
pprRational :: Rational -> Doc
pprRational Rational
r = Integer -> Doc
forall a. Pretty a => a -> Doc
pretty (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"/" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Integer -> Doc
forall a. Pretty a => a -> Doc
pretty (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r)

instance Pretty Lit where
    pretty :: Lit -> Doc
pretty (MachChar Char
x) = Doc
"'" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Char -> Doc
char Char
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"'#"
    pretty (MachStr ByteString
x) = Doc
"\"" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (ByteString -> String
BS.unpack ByteString
x) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\"#"
    pretty Lit
MachNullAddr = Doc
"nullAddr#"
    pretty (MachInt Integer
x) = Integer -> Doc
forall a. Pretty a => a -> Doc
pretty Integer
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"#"
    pretty (MachInt64 Integer
x) = Integer -> Doc
forall a. Pretty a => a -> Doc
pretty Integer
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"#"
    pretty (MachWord Integer
x) = Integer -> Doc
forall a. Pretty a => a -> Doc
pretty Integer
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"#"
    pretty (MachWord64 Integer
x) = Integer -> Doc
forall a. Pretty a => a -> Doc
pretty Integer
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"##"
    pretty (MachFloat Rational
x) = Doc
"FLOAT" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Rational -> Doc
pprRational Rational
x)
    pretty (MachDouble Rational
x) = Doc
"DOUBLE" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Rational -> Doc
pprRational Rational
x)
    pretty (MachLabel Text
x) = Doc
"LABEL"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
parens (Text -> Doc
forall a. Pretty a => a -> Doc
pretty Text
x)
    pretty (LitInteger Integer
x) = Integer -> Doc
forall a. Pretty a => a -> Doc
pretty Integer
x

instance Pretty CoreStats where
    pretty :: CoreStats -> Doc
pretty CoreStats
c =
        Doc
"Core Size"
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Doc -> Doc
braces ([Doc] -> Doc
hsep [ Doc
"terms="Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
int (CoreStats -> Int
csTerms CoreStats
c)
                       , Doc
"types="Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
int (CoreStats -> Int
csTypes CoreStats
c)
                       , Doc
"cos="Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
int (CoreStats -> Int
csCoercions CoreStats
c)
                       , Doc
"vbinds="Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
int (CoreStats -> Int
csValBinds CoreStats
c)
                       , Doc
"jbinds="Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
int (CoreStats -> Int
csJoinBinds CoreStats
c)
                       ])

pprIdInfo :: PrettyOpts -> IdInfo Binder Binder -> IdDetails -> Doc
pprIdInfo :: PrettyOpts -> IdInfo Binder Binder -> IdDetails -> Doc
pprIdInfo PrettyOpts
opts IdInfo Binder Binder
i IdDetails
d
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PrettyOpts -> Bool
showIdInfo PrettyOpts
opts = Doc
empty
  | Bool
otherwise = Doc -> Doc
comment (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"IdInfo:" Doc -> Doc -> Doc
<+> Doc -> Doc
align Doc
doc
  where
    doc :: Doc
doc = [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
", "
          ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [ IdDetails -> Doc
forall a. Pretty a => a -> Doc
pretty IdDetails
d
            , Doc
"arity=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Doc
forall a. Pretty a => a -> Doc
pretty (IdInfo Binder Binder -> Int
forall bndr var. IdInfo bndr var -> Int
idiArity IdInfo Binder Binder
i)
            , Doc
"inline=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
forall a. Pretty a => a -> Doc
pretty (IdInfo Binder Binder -> Text
forall bndr var. IdInfo bndr var -> Text
idiInlinePragma IdInfo Binder Binder
i)
            , Doc
"occ=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> OccInfo -> Doc
forall a. Pretty a => a -> Doc
pretty (IdInfo Binder Binder -> OccInfo
forall bndr var. IdInfo bndr var -> OccInfo
idiOccInfo IdInfo Binder Binder
i)
            , Doc
"str=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
forall a. Pretty a => a -> Doc
pretty (IdInfo Binder Binder -> Text
forall bndr var. IdInfo bndr var -> Text
idiStrictnessSig IdInfo Binder Binder
i)
            , Doc
"dmd=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
forall a. Pretty a => a -> Doc
pretty (IdInfo Binder Binder -> Text
forall bndr var. IdInfo bndr var -> Text
idiDemandSig IdInfo Binder Binder
i)
            , Doc
"call-arity=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int -> Doc
forall a. Pretty a => a -> Doc
pretty (IdInfo Binder Binder -> Int
forall bndr var. IdInfo bndr var -> Int
idiCallArity IdInfo Binder Binder
i)
            , Doc
"unfolding=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrettyOpts -> Unfolding Binder Binder -> Doc
pprUnfolding PrettyOpts
opts (IdInfo Binder Binder -> Unfolding Binder Binder
forall bndr var. IdInfo bndr var -> Unfolding bndr var
idiUnfolding IdInfo Binder Binder
i)
            ] [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ (if IdInfo Binder Binder -> Bool
forall bndr var. IdInfo bndr var -> Bool
idiIsOneShot IdInfo Binder Binder
i then [Doc
"one-shot"] else [])

pprUnfolding :: PrettyOpts -> Unfolding Binder Binder -> Doc
pprUnfolding :: PrettyOpts -> Unfolding Binder Binder -> Doc
pprUnfolding PrettyOpts
_    Unfolding Binder Binder
NoUnfolding = Doc
"NoUnfolding"
pprUnfolding PrettyOpts
_    Unfolding Binder Binder
BootUnfolding = Doc
"BootUnfolding"
pprUnfolding PrettyOpts
_    OtherCon{} = Doc
"OtherCon"
pprUnfolding PrettyOpts
_    Unfolding Binder Binder
DFunUnfolding = Doc
"DFunUnfolding"
pprUnfolding PrettyOpts
opts CoreUnfolding{Bool
Text
Expr' Binder Binder
unfTemplate :: forall bndr var. Unfolding bndr var -> Expr' bndr var
unfIsValue :: forall bndr var. Unfolding bndr var -> Bool
unfIsConLike :: forall bndr var. Unfolding bndr var -> Bool
unfIsWorkFree :: forall bndr var. Unfolding bndr var -> Bool
unfGuidance :: forall bndr var. Unfolding bndr var -> Text
unfGuidance :: Text
unfIsWorkFree :: Bool
unfIsConLike :: Bool
unfIsValue :: Bool
unfTemplate :: Expr' Binder Binder
..}
  | PrettyOpts -> Bool
showUnfoldings PrettyOpts
opts = Doc
"CoreUnf" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
braces
     (Doc -> Doc
align (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [ Doc
"is-value=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Bool -> Doc
forall a. Pretty a => a -> Doc
pretty Bool
unfIsValue
                  , Doc
"con-like=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Bool -> Doc
forall a. Pretty a => a -> Doc
pretty Bool
unfIsConLike
                  , Doc
"work-free=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Bool -> Doc
forall a. Pretty a => a -> Doc
pretty Bool
unfIsWorkFree
                  , Doc
"guidance=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Text -> Doc
forall a. Pretty a => a -> Doc
pretty Text
unfGuidance
                  , Doc
"template=" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrettyOpts -> Expr' Binder Binder -> Doc
pprExpr PrettyOpts
opts Expr' Binder Binder
unfTemplate
                  ])
  | Bool
otherwise = Doc
"CoreUnf{..}"

instance Pretty OccInfo where
    pretty :: OccInfo -> Doc
pretty OccInfo
OccManyOccs = Doc
"Many"
    pretty OccInfo
OccDead = Doc
"Dead"
    pretty OccInfo
OccOneOcc = Doc
"One"
    pretty (OccLoopBreaker Bool
strong) =
        if Bool
strong then Doc
"Strong Loopbrk" else Doc
"Weak Loopbrk"

instance Pretty IdDetails where
    pretty :: IdDetails -> Doc
pretty = String -> Doc
text (String -> Doc) -> (IdDetails -> String) -> IdDetails -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdDetails -> String
forall a. Show a => a -> String
show

data TyPrec   -- See Note [Precedence in types] in TyCoRep.hs
  = TopPrec         -- No parens
  | FunPrec         -- Function args; no parens for tycon apps
  | TyOpPrec        -- Infix operator
  | TyConPrec       -- Tycon args; no parens for atomic
  deriving( TyPrec -> TyPrec -> Bool
(TyPrec -> TyPrec -> Bool)
-> (TyPrec -> TyPrec -> Bool) -> Eq TyPrec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TyPrec -> TyPrec -> Bool
$c/= :: TyPrec -> TyPrec -> Bool
== :: TyPrec -> TyPrec -> Bool
$c== :: TyPrec -> TyPrec -> Bool
Eq, Eq TyPrec
Eq TyPrec
-> (TyPrec -> TyPrec -> Ordering)
-> (TyPrec -> TyPrec -> Bool)
-> (TyPrec -> TyPrec -> Bool)
-> (TyPrec -> TyPrec -> Bool)
-> (TyPrec -> TyPrec -> Bool)
-> (TyPrec -> TyPrec -> TyPrec)
-> (TyPrec -> TyPrec -> TyPrec)
-> Ord TyPrec
TyPrec -> TyPrec -> Bool
TyPrec -> TyPrec -> Ordering
TyPrec -> TyPrec -> TyPrec
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TyPrec -> TyPrec -> TyPrec
$cmin :: TyPrec -> TyPrec -> TyPrec
max :: TyPrec -> TyPrec -> TyPrec
$cmax :: TyPrec -> TyPrec -> TyPrec
>= :: TyPrec -> TyPrec -> Bool
$c>= :: TyPrec -> TyPrec -> Bool
> :: TyPrec -> TyPrec -> Bool
$c> :: TyPrec -> TyPrec -> Bool
<= :: TyPrec -> TyPrec -> Bool
$c<= :: TyPrec -> TyPrec -> Bool
< :: TyPrec -> TyPrec -> Bool
$c< :: TyPrec -> TyPrec -> Bool
compare :: TyPrec -> TyPrec -> Ordering
$ccompare :: TyPrec -> TyPrec -> Ordering
$cp1Ord :: Eq TyPrec
Ord )

pprType :: PrettyOpts -> Type -> Doc
pprType :: PrettyOpts -> Type -> Doc
pprType PrettyOpts
opts = PrettyOpts -> TyPrec -> Type -> Doc
pprType' PrettyOpts
opts TyPrec
TopPrec

pprType' :: PrettyOpts -> TyPrec -> Type -> Doc
pprType' :: PrettyOpts -> TyPrec -> Type -> Doc
pprType' PrettyOpts
opts TyPrec
_ (VarTy Binder
b)         = PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts Binder
b
pprType' PrettyOpts
opts TyPrec
p t :: Type
t@(FunTy Type
_ Type
_)     = Bool -> Doc -> Doc
maybeParens (TyPrec
p TyPrec -> TyPrec -> Bool
forall a. Ord a => a -> a -> Bool
>= TyPrec
FunPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
" ->" ((Type -> Doc) -> [Type] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> TyPrec -> Type -> Doc
pprType' PrettyOpts
opts TyPrec
FunPrec) (Type -> [Type]
forall bndr var. Type' bndr var -> [Type' bndr var]
splitFunTys Type
t))
pprType' PrettyOpts
opts TyPrec
p (TyConApp TyCon
tc [])  = TyCon -> Doc
forall a. Pretty a => a -> Doc
pretty TyCon
tc
pprType' PrettyOpts
opts TyPrec
p (TyConApp TyCon
tc [Type]
tys) = Bool -> Doc -> Doc
maybeParens (TyPrec
p TyPrec -> TyPrec -> Bool
forall a. Ord a => a -> a -> Bool
>= TyPrec
TyConPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ TyCon -> Doc
forall a. Pretty a => a -> Doc
pretty TyCon
tc Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Type -> Doc) -> [Type] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> TyPrec -> Type -> Doc
pprType' PrettyOpts
opts TyPrec
TyConPrec) [Type]
tys)
pprType' PrettyOpts
opts TyPrec
p (AppTy Type
a Type
b)       = Bool -> Doc -> Doc
maybeParens (TyPrec
p TyPrec -> TyPrec -> Bool
forall a. Ord a => a -> a -> Bool
>= TyPrec
TyConPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ PrettyOpts -> TyPrec -> Type -> Doc
pprType' PrettyOpts
opts TyPrec
TyConPrec Type
a Doc -> Doc -> Doc
<+> PrettyOpts -> TyPrec -> Type -> Doc
pprType' PrettyOpts
opts TyPrec
TyConPrec Type
b
pprType' PrettyOpts
opts TyPrec
p t :: Type
t@(ForAllTy Binder
_ Type
_)  = let ([Binder]
bs, Type
t') = Type -> ([Binder], Type)
forall bndr var. Type' bndr var -> ([bndr], Type' bndr var)
splitForAlls Type
t
                                    in Bool -> Doc -> Doc
maybeParens (TyPrec
p TyPrec -> TyPrec -> Bool
forall a. Ord a => a -> a -> Bool
>= TyPrec
TyOpPrec)
                                       (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"forall" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Binder -> Doc) -> [Binder] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts) [Binder]
bs) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"." Doc -> Doc -> Doc
<+> PrettyOpts -> Type -> Doc
pprType PrettyOpts
opts Type
t'
pprType' PrettyOpts
opts TyPrec
_ Type
LitTy             = Doc
"LIT"
pprType' PrettyOpts
opts TyPrec
_ Type
CoercionTy        = Doc
"Co"

maybeParens :: Bool -> Doc -> Doc
maybeParens :: Bool -> Doc -> Doc
maybeParens Bool
True  = Doc -> Doc
parens
maybeParens Bool
False = Doc -> Doc
forall a. a -> a
id

instance Pretty Type where
    pretty :: Type -> Doc
pretty = PrettyOpts -> Type -> Doc
pprType PrettyOpts
defaultPrettyOpts

pprExpr :: PrettyOpts -> Expr -> Doc
pprExpr :: PrettyOpts -> Expr' Binder Binder -> Doc
pprExpr PrettyOpts
opts = PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
False

pprExpr' :: PrettyOpts -> Bool -> Expr -> Doc
pprExpr' :: PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
_parens (EVar Binder
v)         = PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts Binder
v
pprExpr' PrettyOpts
opts Bool
_parens (EVarGlobal ExternalName
v)   = ExternalName -> Doc
forall a. Pretty a => a -> Doc
pretty ExternalName
v
pprExpr' PrettyOpts
opts Bool
_parens (ELit Lit
l)         = Lit -> Doc
forall a. Pretty a => a -> Doc
pretty Lit
l
pprExpr' PrettyOpts
opts Bool
parens  e :: Expr' Binder Binder
e@(EApp{})       = let (Expr' Binder Binder
x, [Expr' Binder Binder]
ys) = Expr' Binder Binder -> (Expr' Binder Binder, [Expr' Binder Binder])
forall bndr var.
Expr' bndr var -> (Expr' bndr var, [Expr' bndr var])
collectArgs Expr' Binder Binder
e
                                         in Bool -> Doc -> Doc
maybeParens Bool
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Int -> Doc -> Doc
hang' (PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
True Expr' Binder Binder
x) Int
2 ([Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Expr' Binder Binder -> Doc) -> [Expr' Binder Binder] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Expr' Binder Binder -> Doc
pprArg [Expr' Binder Binder]
ys)
  where pprArg :: Expr' Binder Binder -> Doc
pprArg (EType Type
t) = Char -> Doc
char Char
'@' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> PrettyOpts -> TyPrec -> Type -> Doc
pprType' PrettyOpts
opts TyPrec
TyConPrec Type
t
        pprArg Expr' Binder Binder
x         = PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
True Expr' Binder Binder
x
pprExpr' PrettyOpts
opts Bool
parens  x :: Expr' Binder Binder
x@(ETyLam Binder
_ Expr' Binder Binder
_)   = let ([Binder]
bs, Expr' Binder Binder
x') = Expr' Binder Binder -> ([Binder], Expr' Binder Binder)
forall bndr var. Expr' bndr var -> ([bndr], Expr' bndr var)
collectTyBinders Expr' Binder Binder
x
                                         in Bool -> Doc -> Doc
maybeParens Bool
parens
                                            (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Int -> Doc -> Doc
hang' (Doc
"Λ" Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((Binder -> Doc) -> [Binder] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts) [Binder]
bs) Doc -> Doc -> Doc
<+> Doc
smallRArrow) Int
2 (PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
False Expr' Binder Binder
x')
pprExpr' PrettyOpts
opts Bool
parens  x :: Expr' Binder Binder
x@(ELam Binder
_ Expr' Binder Binder
_)     = let ([Binder]
bs, Expr' Binder Binder
x') = Expr' Binder Binder -> ([Binder], Expr' Binder Binder)
forall bndr var. Expr' bndr var -> ([bndr], Expr' bndr var)
collectBinders Expr' Binder Binder
x
                                         in Bool -> Doc -> Doc
maybeParens Bool
parens
                                            (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Int -> Doc -> Doc
hang' (Doc
"λ" Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((Binder -> Doc) -> [Binder] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts) [Binder]
bs) Doc -> Doc -> Doc
<+> Doc
smallRArrow) Int
2 (PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
False Expr' Binder Binder
x')
pprExpr' PrettyOpts
opts Bool
parens  (ELet [(Binder, Expr' Binder Binder)]
xs Expr' Binder Binder
y)      = Bool -> Doc -> Doc
maybeParens Bool
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"let" Doc -> Doc -> Doc
<+> (Doc -> Doc
align (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
$ ((Binder, Expr' Binder Binder) -> Doc)
-> [(Binder, Expr' Binder Binder)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Binder -> Expr' Binder Binder -> Doc)
-> (Binder, Expr' Binder Binder) -> Doc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (PrettyOpts -> Binder -> Expr' Binder Binder -> Doc
pprBinding PrettyOpts
opts)) [(Binder, Expr' Binder Binder)]
xs)
                                         Doc -> Doc -> Doc
<$$> Doc
"in" Doc -> Doc -> Doc
<+> Doc -> Doc
align (PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
False Expr' Binder Binder
y)
  where pprBind :: (Binder, Expr' Binder Binder) -> Doc
pprBind (Binder
b, Expr' Binder Binder
rhs) = PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts Binder
b Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Doc -> Doc
align (PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
False Expr' Binder Binder
rhs)
pprExpr' PrettyOpts
opts Bool
parens  (ECase Expr' Binder Binder
x Binder
b [Alt' Binder Binder]
alts) = Bool -> Doc -> Doc
maybeParens Bool
parens
                                         (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [ [Doc] -> Doc
sep [ Doc
"case" Doc -> Doc -> Doc
<+> PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
False Expr' Binder Binder
x
                                                     , Doc
"of" Doc -> Doc -> Doc
<+> PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts Binder
b Doc -> Doc -> Doc
<+> Doc
"{" ]
                                               , Int -> Doc -> Doc
indent Int
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' Binder Binder -> Doc) -> [Alt' Binder Binder] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Alt' Binder Binder -> Doc
pprAlt [Alt' Binder Binder]
alts
                                               , Doc
"}"
                                               ]
  where pprAlt :: Alt' Binder Binder -> Doc
pprAlt (Alt AltCon
con [Binder]
bndrs Expr' Binder Binder
rhs) = Doc -> Int -> Doc -> Doc
hang' ([Doc] -> Doc
hsep (AltCon -> Doc
forall a. Pretty a => a -> Doc
pretty AltCon
con Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Binder -> Doc) -> [Binder] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts) [Binder]
bndrs) Doc -> Doc -> Doc
<+> Doc
smallRArrow) Int
2 (PrettyOpts -> Bool -> Expr' Binder Binder -> Doc
pprExpr' PrettyOpts
opts Bool
False Expr' Binder Binder
rhs)
pprExpr' PrettyOpts
opts Bool
parens  (EType Type
t)        = Bool -> Doc -> Doc
maybeParens Bool
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"TYPE:" Doc -> Doc -> Doc
<+> PrettyOpts -> Type -> Doc
pprType PrettyOpts
opts Type
t
pprExpr' PrettyOpts
opts Bool
parens  Expr' Binder Binder
ECoercion        = Doc
"CO"

instance Pretty AltCon where
    pretty :: AltCon -> Doc
pretty (AltDataCon Text
t) = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
    pretty (AltLit Lit
l) = Lit -> Doc
forall a. Pretty a => a -> Doc
pretty Lit
l
    pretty AltCon
AltDefault = String -> Doc
text String
"DEFAULT"

instance Pretty Expr where
    pretty :: Expr' Binder Binder -> Doc
pretty = PrettyOpts -> Expr' Binder Binder -> Doc
pprExpr PrettyOpts
defaultPrettyOpts

pprTopBinding :: PrettyOpts -> TopBinding -> Doc
pprTopBinding :: PrettyOpts -> TopBinding -> Doc
pprTopBinding PrettyOpts
opts TopBinding
tb =
    case TopBinding
tb of
      NonRecTopBinding Binder
b CoreStats
s Expr' Binder Binder
rhs -> (Binder, CoreStats, Expr' Binder Binder) -> Doc
forall a. Pretty a => (Binder, a, Expr' Binder Binder) -> Doc
pprTopBind (Binder
b,CoreStats
s,Expr' Binder Binder
rhs)
      RecTopBinding [(Binder, CoreStats, Expr' Binder Binder)]
bs -> Doc
"rec" Doc -> Doc -> Doc
<+> Doc -> Doc
braces (Doc
line Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [Doc] -> Doc
vsep (((Binder, CoreStats, Expr' Binder Binder) -> Doc)
-> [(Binder, CoreStats, Expr' Binder Binder)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Binder, CoreStats, Expr' Binder Binder) -> Doc
forall a. Pretty a => (Binder, a, Expr' Binder Binder) -> Doc
pprTopBind [(Binder, CoreStats, Expr' Binder Binder)]
bs))
  where
    pprTopBind :: (Binder, a, Expr' Binder Binder) -> Doc
pprTopBind (b :: Binder
b@(Bndr Binder' Binder Binder
b'),a
s,Expr' Binder Binder
rhs) =
        PrettyOpts -> Binder -> Doc
pprTypeSig PrettyOpts
opts Binder
b
        Doc -> Doc -> Doc
<$$> PrettyOpts -> IdInfo Binder Binder -> IdDetails -> Doc
pprIdInfo PrettyOpts
opts (Binder' Binder Binder -> IdInfo Binder Binder
forall bndr var. Binder' bndr var -> IdInfo bndr var
binderIdInfo Binder' Binder Binder
b') (Binder' Binder Binder -> IdDetails
forall bndr var. Binder' bndr var -> IdDetails
binderIdDetails Binder' Binder Binder
b')
        Doc -> Doc -> Doc
<$$> Doc -> Doc
comment (a -> Doc
forall a. Pretty a => a -> Doc
pretty a
s)
        Doc -> Doc -> Doc
<$$> Doc -> Int -> Doc -> Doc
hang' (PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts Binder
b Doc -> Doc -> Doc
<+> Doc
equals) Int
2 (PrettyOpts -> Expr' Binder Binder -> Doc
pprExpr PrettyOpts
opts Expr' Binder Binder
rhs)
        Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
line

pprTypeSig :: PrettyOpts -> Binder -> Doc
pprTypeSig :: PrettyOpts -> Binder -> Doc
pprTypeSig PrettyOpts
opts b :: Binder
b@(Bndr Binder' Binder Binder
b') =
    PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts Binder
b Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Doc -> Doc
align (PrettyOpts -> Type -> Doc
pprType PrettyOpts
opts (Binder' Binder Binder -> Type
forall bndr var. Binder' bndr var -> Type' bndr var
binderType Binder' Binder Binder
b'))

pprBinding :: PrettyOpts -> Binder -> Expr -> Doc
pprBinding :: PrettyOpts -> Binder -> Expr' Binder Binder -> Doc
pprBinding PrettyOpts
opts b :: Binder
b@(Bndr b' :: Binder' Binder Binder
b'@Binder{}) Expr' Binder Binder
rhs =
    Bool -> Doc -> Doc
ppWhen (PrettyOpts -> Bool
showLetTypes PrettyOpts
opts) (PrettyOpts -> Binder -> Doc
pprTypeSig PrettyOpts
opts Binder
b)
    Doc -> Doc -> Doc
<$$> PrettyOpts -> IdInfo Binder Binder -> IdDetails -> Doc
pprIdInfo PrettyOpts
opts (Binder' Binder Binder -> IdInfo Binder Binder
forall bndr var. Binder' bndr var -> IdInfo bndr var
binderIdInfo Binder' Binder Binder
b') (Binder' Binder Binder -> IdDetails
forall bndr var. Binder' bndr var -> IdDetails
binderIdDetails Binder' Binder Binder
b')
    Doc -> Doc -> Doc
<$$> Doc -> Int -> Doc -> Doc
hang' (PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts Binder
b Doc -> Doc -> Doc
<+> Doc
equals) Int
2 (PrettyOpts -> Expr' Binder Binder -> Doc
pprExpr PrettyOpts
opts Expr' Binder Binder
rhs)
pprBinding PrettyOpts
opts b :: Binder
b@(Bndr TyBinder{}) Expr' Binder Binder
rhs =
    -- let-bound type variables: who knew?
    Doc -> Int -> Doc -> Doc
hang' (PrettyOpts -> Binder -> Doc
pprBinder PrettyOpts
opts Binder
b Doc -> Doc -> Doc
<+> Doc
equals) Int
2 (PrettyOpts -> Expr' Binder Binder -> Doc
pprExpr PrettyOpts
opts Expr' Binder Binder
rhs)

instance Pretty TopBinding where
    pretty :: TopBinding -> Doc
pretty = PrettyOpts -> TopBinding -> Doc
pprTopBinding PrettyOpts
defaultPrettyOpts

pprModule :: PrettyOpts -> Module -> Doc
pprModule :: PrettyOpts -> Module -> Doc
pprModule PrettyOpts
opts Module
m =
    Doc -> Doc
comment (Text -> Doc
forall a. Pretty a => a -> Doc
pretty (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ Module -> Text
forall bndr var. Module' bndr var -> Text
modulePhase Module
m)
    Doc -> Doc -> Doc
<$$> String -> Doc
text String
"module" Doc -> Doc -> Doc
<+> ModuleName -> Doc
forall a. Pretty a => a -> Doc
pretty (Module -> ModuleName
forall bndr var. Module' bndr var -> ModuleName
moduleName Module
m) Doc -> Doc -> Doc
<+> Doc
"where" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
line
    Doc -> Doc -> Doc
<$$> [Doc] -> Doc
vsep ((TopBinding -> Doc) -> [TopBinding] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> TopBinding -> Doc
pprTopBinding PrettyOpts
opts) (Module -> [TopBinding]
forall bndr var. Module' bndr var -> [TopBinding' bndr var]
moduleTopBindings Module
m))

instance Pretty Module where
    pretty :: Module -> Doc
pretty = PrettyOpts -> Module -> Doc
pprModule PrettyOpts
defaultPrettyOpts

comment :: Doc -> Doc
comment :: Doc -> Doc
comment Doc
x = Doc
"{-" Doc -> Doc -> Doc
<+> Doc
x Doc -> Doc -> Doc
<+> Doc
"-}"

dcolon :: Doc
dcolon :: Doc
dcolon = Doc
"::"

smallRArrow :: Doc
smallRArrow :: Doc
smallRArrow = Doc
"→"

hang' :: Doc -> Int -> Doc -> Doc
hang' :: Doc -> Int -> Doc -> Doc
hang' Doc
d1 Int
n Doc
d2 = Int -> Doc -> Doc
hang Int
n (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [Doc
d1, Doc
d2]

ppWhen :: Bool -> Doc -> Doc
ppWhen :: Bool -> Doc -> Doc
ppWhen Bool
True Doc
x = Doc
x
ppWhen Bool
False Doc
_ = Doc
empty