{-# 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 Prettyprinter

(<$$>) :: Doc ann -> Doc ann -> Doc ann
Doc ann
a <$$> :: Doc ann -> Doc ann -> Doc ann
<$$> Doc ann
b = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann
a,Doc ann
b]

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
                               }

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

instance Pretty ModuleName where
    pretty :: ModuleName -> Doc ann
pretty = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> (ModuleName -> String) -> ModuleName -> Doc ann
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 ann
pretty = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> (Unique -> String) -> Unique -> Doc ann
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 ann
pretty (BinderId Unique
b) = Unique -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Unique
b

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

pprBinder :: PrettyOpts -> Binder -> Doc ann
pprBinder :: PrettyOpts -> Binder -> Doc ann
pprBinder PrettyOpts
opts Binder
b
  | PrettyOpts -> Bool
showUniques PrettyOpts
opts = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Binder -> Text
binderUniqueName Binder
b
  | Bool
otherwise        = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
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 ann
pretty (TyCon Text
t Unique
_) = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t

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

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

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

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

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

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

instance Pretty IdDetails where
    pretty :: IdDetails -> Doc ann
pretty = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann)
-> (IdDetails -> String) -> IdDetails -> Doc ann
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 ann
pprType :: PrettyOpts -> Type -> Doc ann
pprType PrettyOpts
opts = PrettyOpts -> TyPrec -> Type -> Doc ann
forall ann. PrettyOpts -> TyPrec -> Type -> Doc ann
pprType' PrettyOpts
opts TyPrec
TopPrec

pprType' :: PrettyOpts -> TyPrec -> Type -> Doc ann
pprType' :: PrettyOpts -> TyPrec -> Type -> Doc ann
pprType' PrettyOpts
opts TyPrec
_ (VarTy Binder
b)         = PrettyOpts -> Binder -> Doc ann
forall ann. PrettyOpts -> Binder -> Doc ann
pprBinder PrettyOpts
opts Binder
b
pprType' PrettyOpts
opts TyPrec
p t :: Type
t@(FunTy Type
_ Type
_)     = Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
maybeParens (TyPrec
p TyPrec -> TyPrec -> Bool
forall a. Ord a => a -> a -> Bool
>= TyPrec
FunPrec) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
" ->" ((Type -> Doc ann) -> [Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> TyPrec -> Type -> Doc ann
forall ann. PrettyOpts -> TyPrec -> Type -> Doc ann
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 ann
forall a ann. Pretty a => a -> Doc ann
pretty TyCon
tc
pprType' PrettyOpts
opts TyPrec
p (TyConApp TyCon
tc [Type]
tys) = Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
maybeParens (TyPrec
p TyPrec -> TyPrec -> Bool
forall a. Ord a => a -> a -> Bool
>= TyPrec
TyConPrec) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ TyCon -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TyCon
tc Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ((Type -> Doc ann) -> [Type] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> TyPrec -> Type -> Doc ann
forall ann. PrettyOpts -> TyPrec -> Type -> Doc ann
pprType' PrettyOpts
opts TyPrec
TyConPrec) [Type]
tys)
pprType' PrettyOpts
opts TyPrec
p (AppTy Type
a Type
b)       = Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
maybeParens (TyPrec
p TyPrec -> TyPrec -> Bool
forall a. Ord a => a -> a -> Bool
>= TyPrec
TyConPrec) (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ PrettyOpts -> TyPrec -> Type -> Doc ann
forall ann. PrettyOpts -> TyPrec -> Type -> Doc ann
pprType' PrettyOpts
opts TyPrec
TyConPrec Type
a Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PrettyOpts -> TyPrec -> Type -> Doc ann
forall ann. PrettyOpts -> TyPrec -> Type -> Doc ann
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 ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
maybeParens (TyPrec
p TyPrec -> TyPrec -> Bool
forall a. Ord a => a -> a -> Bool
>= TyPrec
TyOpPrec)
                                       (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"forall" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ((Binder -> Doc ann) -> [Binder] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (PrettyOpts -> Binder -> Doc ann
forall ann. PrettyOpts -> Binder -> Doc ann
pprBinder PrettyOpts
opts) [Binder]
bs) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"." Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PrettyOpts -> Type -> Doc ann
forall ann. PrettyOpts -> Type -> Doc ann
pprType PrettyOpts
opts Type
t'
pprType' PrettyOpts
opts TyPrec
_ Type
LitTy             = Doc ann
"LIT"
pprType' PrettyOpts
opts TyPrec
_ Type
CoercionTy        = Doc ann
"Co"

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

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

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

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

pprTick :: Tick -> Doc ann
pprTick :: Tick -> Doc ann
pprTick (SourceNote SrcSpan
n) = Doc ann
"srcnote"

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

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

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

pprTypeSig :: PrettyOpts -> Binder -> Doc ann
pprTypeSig :: PrettyOpts -> Binder -> Doc ann
pprTypeSig PrettyOpts
opts b :: Binder
b@(Bndr Binder' Binder Binder
b') =
    PrettyOpts -> Binder -> Doc ann
forall ann. PrettyOpts -> Binder -> Doc ann
pprBinder PrettyOpts
opts Binder
b Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
dcolon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (PrettyOpts -> Type -> Doc ann
forall ann. PrettyOpts -> Type -> Doc ann
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 ann
pprBinding :: PrettyOpts -> Binder -> Expr' Binder Binder -> Doc ann
pprBinding PrettyOpts
opts b :: Binder
b@(Bndr b' :: Binder' Binder Binder
b'@Binder{}) Expr' Binder Binder
rhs =
    Bool -> Doc ann -> Doc ann
forall ann. Bool -> Doc ann -> Doc ann
ppWhen (PrettyOpts -> Bool
showLetTypes PrettyOpts
opts) (PrettyOpts -> Binder -> Doc ann
forall ann. PrettyOpts -> Binder -> Doc ann
pprTypeSig PrettyOpts
opts Binder
b)
    Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<$$> PrettyOpts -> IdInfo Binder Binder -> IdDetails -> Doc ann
forall ann.
PrettyOpts -> IdInfo Binder Binder -> IdDetails -> Doc ann
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 ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<$$> Doc ann -> Int -> Doc ann -> Doc ann
forall ann. Doc ann -> Int -> Doc ann -> Doc ann
hang' (PrettyOpts -> Binder -> Doc ann
forall ann. PrettyOpts -> Binder -> Doc ann
pprBinder PrettyOpts
opts Binder
b Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals) Int
2 (PrettyOpts -> Expr' Binder Binder -> Doc ann
forall ann. PrettyOpts -> Expr' Binder Binder -> Doc ann
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 ann -> Int -> Doc ann -> Doc ann
forall ann. Doc ann -> Int -> Doc ann -> Doc ann
hang' (PrettyOpts -> Binder -> Doc ann
forall ann. PrettyOpts -> Binder -> Doc ann
pprBinder PrettyOpts
opts Binder
b Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
forall ann. Doc ann
equals) Int
2 (PrettyOpts -> Expr' Binder Binder -> Doc ann
forall ann. PrettyOpts -> Expr' Binder Binder -> Doc ann
pprExpr PrettyOpts
opts Expr' Binder Binder
rhs)

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

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

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

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

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

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

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

ppWhen :: Bool -> Doc ann -> Doc ann
ppWhen :: Bool -> Doc ann -> Doc ann
ppWhen Bool
True Doc ann
x = Doc ann
x
ppWhen Bool
False Doc ann
_ = Doc ann
forall a. Monoid a => a
mempty