{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE LambdaCase #-}
-- | contains a prettyprinter for the
-- Template Haskell datatypes

module GHC.Boot.TH.Ppr where
    -- All of the exports from this module should
    -- be "public" functions.  The main module TH
    -- re-exports them all.

import Text.PrettyPrint (render)
import GHC.Boot.TH.PprLib
import GHC.Boot.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr )
import Data.List ( intersperse )
import GHC.Show  ( showMultiLineString )
import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
import Data.Foldable ( toList )
import qualified Data.List.NonEmpty as NE
import Prelude hiding ((<>))

nestDepth :: Int
nestDepth :: Int
nestDepth = Int
4

type Precedence = Int
appPrec, opPrec, unopPrec, funPrec, qualPrec, sigPrec, noPrec :: Precedence
appPrec :: Int
appPrec  = Int
6    -- Argument of a function or type application
opPrec :: Int
opPrec   = Int
5    -- Argument of an infix operator
unopPrec :: Int
unopPrec = Int
4    -- Argument of an unresolved infix operator
funPrec :: Int
funPrec  = Int
3    -- Argument of a function arrow
qualPrec :: Int
qualPrec = Int
2    -- Forall-qualified type or result of a function arrow
sigPrec :: Int
sigPrec  = Int
1    -- Argument of an explicit type signature
noPrec :: Int
noPrec   = Int
0    -- Others

parensIf :: Bool -> Doc -> Doc
parensIf :: Bool -> Doc -> Doc
parensIf Bool
True Doc
d = Doc -> Doc
parens Doc
d
parensIf Bool
False Doc
d = Doc
d

------------------------------

pprint :: Ppr a => a -> String
pprint :: forall a. Ppr a => a -> [Char]
pprint a
x = Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
to_HPJ_Doc (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ a -> Doc
forall a. Ppr a => a -> Doc
ppr a
x

class Ppr a where
    ppr :: a -> Doc
    ppr_list :: [a] -> Doc
    ppr_list = [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Ppr a => a -> Doc
ppr

instance Ppr a => Ppr [a] where
    ppr :: [a] -> Doc
ppr [a]
x = [a] -> Doc
forall a. Ppr a => [a] -> Doc
ppr_list [a]
x

------------------------------
instance Ppr Name where
    ppr :: Name -> Doc
ppr Name
v = Name -> Doc
pprName Name
v

------------------------------
instance Ppr Info where
    ppr :: Info -> Doc
ppr (TyConI Dec
d)     = Dec -> Doc
forall a. Ppr a => a -> Doc
ppr Dec
d
    ppr (ClassI Dec
d [Dec]
is)  = Dec -> Doc
forall a. Ppr a => a -> Doc
ppr Dec
d Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Dec -> Doc) -> [Dec] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Doc
forall a. Ppr a => a -> Doc
ppr [Dec]
is)
    ppr (FamilyI Dec
d [Dec]
is) = Dec -> Doc
forall a. Ppr a => a -> Doc
ppr Dec
d Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Dec -> Doc) -> [Dec] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Doc
forall a. Ppr a => a -> Doc
ppr [Dec]
is)
    ppr (PrimTyConI Name
name Int
arity Bool
is_unlifted)
      = [Char] -> Doc
text [Char]
"Primitive"
        Doc -> Doc -> Doc
<+> (if Bool
is_unlifted then [Char] -> Doc
text [Char]
"unlifted" else Doc
empty)
        Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"type constructor" Doc -> Doc -> Doc
<+> Doc -> Doc
quotes (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
name)
        Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Char] -> Doc
text [Char]
"arity" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
arity)
    ppr (ClassOpI Name
v Type
ty Name
cls)
      = [Char] -> Doc
text [Char]
"Class op from" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
cls Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<+> Name -> Type -> Doc
ppr_sig Name
v Type
ty
    ppr (DataConI Name
v Type
ty Name
tc)
      = [Char] -> Doc
text [Char]
"Constructor from" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
tc Doc -> Doc -> Doc
<> Doc
colon Doc -> Doc -> Doc
<+> Name -> Type -> Doc
ppr_sig Name
v Type
ty
    ppr (PatSynI Name
nm Type
ty) = Name -> Type -> Doc
pprPatSynSig Name
nm Type
ty
    ppr (TyVarI Name
v Type
ty)
      = [Char] -> Doc
text [Char]
"Type variable" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
v Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty
    ppr (VarI Name
v Type
ty Maybe Dec
mb_d)
      = [Doc] -> Doc
vcat [Name -> Type -> Doc
ppr_sig Name
v Type
ty,
              case Maybe Dec
mb_d of { Maybe Dec
Nothing -> Doc
empty; Just Dec
d -> Dec -> Doc
forall a. Ppr a => a -> Doc
ppr Dec
d }]

ppr_sig :: Name -> Type -> Doc
ppr_sig :: Name -> Type -> Doc
ppr_sig Name
v Type
ty = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
v Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty

pprFixity :: Name -> Fixity -> NamespaceSpecifier -> Doc
pprFixity :: Name -> Fixity -> NamespaceSpecifier -> Doc
pprFixity Name
_ Fixity
f NamespaceSpecifier
_ | Fixity
f Fixity -> Fixity -> Bool
forall a. Eq a => a -> a -> Bool
== Fixity
defaultFixity = Doc
empty
pprFixity Name
v (Fixity Int
i FixityDirection
d) NamespaceSpecifier
ns_spec
  = FixityDirection -> Doc
ppr_fix FixityDirection
d Doc -> Doc -> Doc
<+> Int -> Doc
int Int
i Doc -> Doc -> Doc
<+> NamespaceSpecifier -> Doc
pprNamespaceSpecifier NamespaceSpecifier
ns_spec Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Infix Name
v
    where ppr_fix :: FixityDirection -> Doc
ppr_fix FixityDirection
InfixR = [Char] -> Doc
text [Char]
"infixr"
          ppr_fix FixityDirection
InfixL = [Char] -> Doc
text [Char]
"infixl"
          ppr_fix FixityDirection
InfixN = [Char] -> Doc
text [Char]
"infix"

pprNamespaceSpecifier :: NamespaceSpecifier -> Doc
pprNamespaceSpecifier :: NamespaceSpecifier -> Doc
pprNamespaceSpecifier NamespaceSpecifier
NoNamespaceSpecifier = Doc
empty
pprNamespaceSpecifier NamespaceSpecifier
TypeNamespaceSpecifier = [Char] -> Doc
text [Char]
"type"
pprNamespaceSpecifier NamespaceSpecifier
DataNamespaceSpecifier = [Char] -> Doc
text [Char]
"data"

-- | Pretty prints a pattern synonym type signature
pprPatSynSig :: Name -> PatSynType -> Doc
pprPatSynSig :: Name -> Type -> Doc
pprPatSynSig Name
nm Type
ty
  = [Char] -> Doc
text [Char]
"pattern" Doc -> Doc -> Doc
<+> Name -> Doc
pprPrefixOcc Name
nm Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
pprPatSynType Type
ty

-- | Pretty prints a pattern synonym's type; follows the usual
-- conventions to print a pattern synonym type compactly, yet
-- unambiguously. See the note on 'PatSynType' and the section on
-- pattern synonyms in the GHC user's guide for more information.
pprPatSynType :: PatSynType -> Doc
pprPatSynType :: Type -> Doc
pprPatSynType ty :: Type
ty@(ForallT [TyVarBndr Specificity]
uniTys Cxt
reqs ty' :: Type
ty'@(ForallT [TyVarBndr Specificity]
exTys Cxt
provs Type
ty''))
  | [TyVarBndr Specificity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
exTys,  Cxt -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
provs = Type -> Doc
forall a. Ppr a => a -> Doc
ppr ([TyVarBndr Specificity] -> Cxt -> Type -> Type
ForallT [TyVarBndr Specificity]
uniTys Cxt
reqs Type
ty'')
  | [TyVarBndr Specificity] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBndr Specificity]
uniTys, Cxt -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
reqs  = Doc
noreqs Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty'
  | Cxt -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cxt
reqs               = [TyVarBndr Specificity] -> Doc
forall a. Ppr a => [a] -> Doc
pprForallBndrs [TyVarBndr Specificity]
uniTys Doc -> Doc -> Doc
<+> Doc
noreqs Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty'
  | Bool
otherwise               = Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty
  where noreqs :: Doc
noreqs = [Char] -> Doc
text [Char]
"() =>"
        pprForallBndrs :: [a] -> Doc
pprForallBndrs [a]
tvs = [Char] -> Doc
text [Char]
"forall" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Ppr a => a -> Doc
ppr [a]
tvs) Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"."
pprPatSynType Type
ty            = Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty

------------------------------
instance Ppr Module where
  ppr :: Module -> Doc
ppr (Module PkgName
pkg ModName
m) = [Char] -> Doc
text (PkgName -> [Char]
pkgString PkgName
pkg) Doc -> Doc -> Doc
<+> [Char] -> Doc
text (ModName -> [Char]
modString ModName
m)

instance Ppr ModuleInfo where
  ppr :: ModuleInfo -> Doc
ppr (ModuleInfo [Module]
imps) = [Char] -> Doc
text [Char]
"Module" Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat ((Module -> Doc) -> [Module] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Module -> Doc
forall a. Ppr a => a -> Doc
ppr [Module]
imps)

------------------------------
instance Ppr Exp where
    ppr :: Exp -> Doc
ppr = Int -> Exp -> Doc
pprExp Int
noPrec

pprPrefixOcc :: Name -> Doc
-- Print operators with parens around them
pprPrefixOcc :: Name -> Doc
pprPrefixOcc Name
n = Bool -> Doc -> Doc
parensIf (Name -> Bool
isSymOcc Name
n) (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
n)

isSymOcc :: Name -> Bool
isSymOcc :: Name -> Bool
isSymOcc Name
n
  = case Name -> [Char]
nameBase Name
n of
      []    -> Bool
True  -- Empty name; weird
      (Char
c:[Char]
_) -> Char -> Bool
isVarSymChar Char
c
                   -- c.f. isVarSymChar in GHC itself

pprInfixExp :: Exp -> Doc
pprInfixExp :: Exp -> Doc
pprInfixExp (VarE Name
v) = NameIs -> Name -> Doc
pprName' NameIs
Infix Name
v
pprInfixExp (ConE Name
v) = NameIs -> Name -> Doc
pprName' NameIs
Infix Name
v
pprInfixExp (UnboundVarE Name
v) = NameIs -> Name -> Doc
pprName' NameIs
Infix Name
v
-- This case will only ever be reached in exceptional circumstances.
-- For example, when printing an error message in case of a malformed expression.
pprInfixExp Exp
e = [Char] -> Doc
text [Char]
"`" Doc -> Doc -> Doc
<> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"`"

pprExp :: Precedence -> Exp -> Doc
pprExp :: Int -> Exp -> Doc
pprExp Int
_ (VarE Name
v)     = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
v
pprExp Int
_ (ConE Name
c)     = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
c
pprExp Int
i (LitE Lit
l)     = Int -> Lit -> Doc
pprLit Int
i Lit
l
pprExp Int
i (AppE Exp
e1 Exp
e2) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
appPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Exp -> Doc
pprExp Int
opPrec Exp
e1
                                              Doc -> Doc -> Doc
<+> Int -> Exp -> Doc
pprExp Int
appPrec Exp
e2
pprExp Int
i (AppTypeE Exp
e Type
t)
 = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
appPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Exp -> Doc
pprExp Int
opPrec Exp
e Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'@' Doc -> Doc -> Doc
<> Type -> Doc
pprParendType Type
t
pprExp Int
_ (ParensE Exp
e)  = Doc -> Doc
parens (Int -> Exp -> Doc
pprExp Int
noPrec Exp
e)
pprExp Int
i (UInfixE Exp
e1 Exp
op Exp
e2)
 = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
unopPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Exp -> Doc
pprExp Int
unopPrec Exp
e1
                         Doc -> Doc -> Doc
<+> Exp -> Doc
pprInfixExp Exp
op
                         Doc -> Doc -> Doc
<+> Int -> Exp -> Doc
pprExp Int
unopPrec Exp
e2
pprExp Int
i (InfixE (Just Exp
e1) Exp
op (Just Exp
e2))
 = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
opPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Exp -> Doc
pprExp Int
opPrec Exp
e1
                        Doc -> Doc -> Doc
<+> Exp -> Doc
pprInfixExp Exp
op
                        Doc -> Doc -> Doc
<+> Int -> Exp -> Doc
pprExp Int
opPrec Exp
e2
pprExp Int
_ (InfixE Maybe Exp
me1 Exp
op Maybe Exp
me2) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Exp -> Doc
pprMaybeExp Int
noPrec Maybe Exp
me1
                                    Doc -> Doc -> Doc
<+> Exp -> Doc
pprInfixExp Exp
op
                                    Doc -> Doc -> Doc
<+> Int -> Maybe Exp -> Doc
pprMaybeExp Int
noPrec Maybe Exp
me2
pprExp Int
i (LamE [] Exp
e) = Int -> Exp -> Doc
pprExp Int
i Exp
e -- #13856
pprExp Int
i (LamE [Pat]
ps Exp
e) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
char Char
'\\' Doc -> Doc -> Doc
<> [Doc] -> Doc
hsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
pprPat Int
appPrec) [Pat]
ps)
                                           Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"->" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e
pprExp Int
i (LamCaseE [Match]
ms)
  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"\\case" Doc -> Doc -> Doc
$$ Doc -> Doc
braces ([Match] -> Doc
forall a. Ppr a => [a] -> Doc
semiSep [Match]
ms)
pprExp Int
i (LamCasesE [Clause]
ms)
  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"\\cases" Doc -> Doc -> Doc
$$ Doc -> Doc
braces ([Clause] -> Doc
semi_sep [Clause]
ms)
  where semi_sep :: [Clause] -> Doc
semi_sep = [Doc] -> Doc
sep ([Doc] -> Doc) -> ([Clause] -> [Doc]) -> [Clause] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
semi ([Doc] -> [Doc]) -> ([Clause] -> [Doc]) -> [Clause] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Clause -> Doc) -> [Clause] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Clause -> Doc
pprClause Bool
False)
pprExp Int
i (TupE [Maybe Exp]
es)
  | [Just Exp
e] <- [Maybe Exp]
es
  = Int -> Exp -> Doc
pprExp Int
i (Name -> Exp
ConE (Int -> Name
tupleDataName Int
1) Exp -> Exp -> Exp
`AppE` Exp
e)
  | Bool
otherwise
  = Doc -> Doc
parens ((Maybe Exp -> Doc) -> [Maybe Exp] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaSepWith (Int -> Maybe Exp -> Doc
pprMaybeExp Int
noPrec) [Maybe Exp]
es)
pprExp Int
_ (UnboxedTupE [Maybe Exp]
es) = Doc -> Doc
hashParens ((Maybe Exp -> Doc) -> [Maybe Exp] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaSepWith (Int -> Maybe Exp -> Doc
pprMaybeExp Int
noPrec) [Maybe Exp]
es)
pprExp Int
_ (UnboxedSumE Exp
e Int
alt Int
arity) = Doc -> Int -> Int -> Doc
unboxedSumBars (Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e) Int
alt Int
arity
-- Nesting in Cond is to avoid potential problems in do statements
pprExp Int
i (CondE Exp
guard Exp
true Exp
false)
 = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [[Char] -> Doc
text [Char]
"if"   Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
guard,
                       Int -> Doc -> Doc
nest Int
1 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"then" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
true,
                       Int -> Doc -> Doc
nest Int
1 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"else" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
false]
pprExp Int
i (MultiIfE [(Guard, Exp)]
alts)
  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (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
$
      case [(Guard, Exp)]
alts of
        []            -> [[Char] -> Doc
text [Char]
"if {}"]
        ((Guard, Exp)
alt : [(Guard, Exp)]
alts') -> [Char] -> Doc
text [Char]
"if" Doc -> Doc -> Doc
<+> Doc -> (Guard, Exp) -> Doc
pprGuarded Doc
arrow (Guard, Exp)
alt
                         Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: ((Guard, Exp) -> Doc) -> [(Guard, Exp)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Doc -> Doc
nest Int
3 (Doc -> Doc) -> ((Guard, Exp) -> Doc) -> (Guard, Exp) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> (Guard, Exp) -> Doc
pprGuarded Doc
arrow) [(Guard, Exp)]
alts'
pprExp Int
i (LetE [Dec]
ds_ Exp
e) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"let" Doc -> Doc -> Doc
<+> [Dec] -> Doc
forall a. Ppr a => [a] -> Doc
pprDecs [Dec]
ds_
                                             Doc -> Doc -> Doc
$$ [Char] -> Doc
text [Char]
" in" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e
  where
    pprDecs :: [a] -> Doc
pprDecs []  = Doc
empty
    pprDecs [a
d] = a -> Doc
forall a. Ppr a => a -> Doc
ppr a
d
    pprDecs [a]
ds  = Doc -> Doc
braces ([a] -> Doc
forall a. Ppr a => [a] -> Doc
semiSep [a]
ds)

pprExp Int
i (CaseE Exp
e [Match]
ms)
 = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"case" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"of"
                        Doc -> Doc -> Doc
$$ Doc -> Doc
braces ([Match] -> Doc
forall a. Ppr a => [a] -> Doc
semiSep [Match]
ms)
pprExp Int
i (DoE Maybe ModName
m [Stmt]
ss_) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Maybe ModName -> Doc
pprQualifier Maybe ModName
m Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"do" Doc -> Doc -> Doc
<+> [Stmt] -> Doc
forall a. Ppr a => [a] -> Doc
pprStms [Stmt]
ss_
  where
    pprQualifier :: Maybe ModName -> Doc
pprQualifier Maybe ModName
Nothing = Doc
empty
    pprQualifier (Just ModName
modName) = [Char] -> Doc
text (ModName -> [Char]
modString ModName
modName) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'.'
    pprStms :: [a] -> Doc
pprStms []  = Doc
empty
    pprStms [a
s] = a -> Doc
forall a. Ppr a => a -> Doc
ppr a
s
    pprStms [a]
ss  = Doc -> Doc
braces ([a] -> Doc
forall a. Ppr a => [a] -> Doc
semiSep [a]
ss)
pprExp Int
i (MDoE Maybe ModName
m [Stmt]
ss_) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Maybe ModName -> Doc
pprQualifier Maybe ModName
m Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"mdo" Doc -> Doc -> Doc
<+> [Stmt] -> Doc
forall a. Ppr a => [a] -> Doc
pprStms [Stmt]
ss_
  where
    pprQualifier :: Maybe ModName -> Doc
pprQualifier Maybe ModName
Nothing = Doc
empty
    pprQualifier (Just ModName
modName) = [Char] -> Doc
text (ModName -> [Char]
modString ModName
modName) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'.'
    pprStms :: [a] -> Doc
pprStms []  = Doc
empty
    pprStms [a
s] = a -> Doc
forall a. Ppr a => a -> Doc
ppr a
s
    pprStms [a]
ss  = Doc -> Doc
braces ([a] -> Doc
forall a. Ppr a => [a] -> Doc
semiSep [a]
ss)

pprExp Int
_ (CompE []) = [Char] -> Doc
text [Char]
"<<Empty CompExp>>"
-- This will probably break with fixity declarations - would need a ';'
pprExp Int
_ (CompE [Stmt]
ss) =
    if [Stmt] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Stmt]
ss'
       -- If there are no statements in a list comprehension besides the last
       -- one, we simply treat it like a normal list.
       then [Char] -> Doc
text [Char]
"[" Doc -> Doc -> Doc
<> Stmt -> Doc
forall a. Ppr a => a -> Doc
ppr Stmt
s Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"]"
       else [Char] -> Doc
text [Char]
"[" Doc -> Doc -> Doc
<> Stmt -> Doc
forall a. Ppr a => a -> Doc
ppr Stmt
s
        Doc -> Doc -> Doc
<+> Doc
bar
        Doc -> Doc -> Doc
<+> [Stmt] -> Doc
forall a. Ppr a => [a] -> Doc
commaSep [Stmt]
ss'
         Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"]"
  where s :: Stmt
s = [Stmt] -> Stmt
forall a. HasCallStack => [a] -> a
last [Stmt]
ss
        ss' :: [Stmt]
ss' = [Stmt] -> [Stmt]
forall a. HasCallStack => [a] -> [a]
init [Stmt]
ss
pprExp Int
_ (ArithSeqE Range
d) = Range -> Doc
forall a. Ppr a => a -> Doc
ppr Range
d
pprExp Int
_ (ListE [Exp]
es) = Doc -> Doc
brackets ([Exp] -> Doc
forall a. Ppr a => [a] -> Doc
commaSep [Exp]
es)
pprExp Int
i (SigE Exp
e Type
t) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Exp -> Doc
pprExp Int
sigPrec Exp
e
                                          Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Int -> Type -> Doc
pprType Int
sigPrec Type
t
pprExp Int
_ (RecConE Name
nm [FieldExp]
fs) = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
nm Doc -> Doc -> Doc
<> Doc -> Doc
braces ([FieldExp] -> Doc
pprFields [FieldExp]
fs)
pprExp Int
_ (RecUpdE Exp
e [FieldExp]
fs) = Int -> Exp -> Doc
pprExp Int
appPrec Exp
e Doc -> Doc -> Doc
<> Doc -> Doc
braces ([FieldExp] -> Doc
pprFields [FieldExp]
fs)
pprExp Int
i (StaticE Exp
e) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
appPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
                         [Char] -> Doc
text [Char]
"static"Doc -> Doc -> Doc
<+> Int -> Exp -> Doc
pprExp Int
appPrec Exp
e
pprExp Int
_ (UnboundVarE Name
v) = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
v
pprExp Int
_ (LabelE [Char]
s) = [Char] -> Doc
text [Char]
"#" Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
s
pprExp Int
_ (ImplicitParamVarE [Char]
n) = [Char] -> Doc
text (Char
'?' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
n)
pprExp Int
_ (GetFieldE Exp
e [Char]
f) = Int -> Exp -> Doc
pprExp Int
appPrec Exp
e Doc -> Doc -> Doc
<> [Char] -> Doc
text (Char
'.'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
f)
pprExp Int
_ (ProjectionE NonEmpty [Char]
xs) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Doc
char Char
'.'Doc -> Doc -> Doc
<>) (Doc -> Doc) -> ([Char] -> Doc) -> [Char] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Doc
text) ([[Char]] -> [Doc]) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> a -> b
$ NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty [Char]
xs
pprExp Int
_ (TypedBracketE Exp
e) = [Char] -> Doc
text [Char]
"[||" Doc -> Doc -> Doc
<> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"||]"
pprExp Int
_ (TypedSpliceE Exp
e) = [Char] -> Doc
text [Char]
"$$" Doc -> Doc -> Doc
<> Int -> Exp -> Doc
pprExp Int
appPrec Exp
e
pprExp Int
i (TypeE Type
t) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"type" Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
t
pprExp Int
i (ForallVisE [TyVarBndr ()]
tvars Exp
body) =
  Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
funPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [[TyVarBndr ()] -> Cxt -> Doc
pprForallVis [TyVarBndr ()]
tvars [], Int -> Exp -> Doc
pprExp Int
qualPrec Exp
body]
pprExp Int
i (ForallE [TyVarBndr Specificity]
tvars Exp
body) =
  Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
funPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [[TyVarBndr Specificity] -> Cxt -> Doc
pprForall [TyVarBndr Specificity]
tvars [], Int -> Exp -> Doc
pprExp Int
qualPrec Exp
body]
pprExp Int
i (ConstrainedE [Exp]
ctx Exp
body) =
  Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
funPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [(Int -> Exp -> Doc) -> [Exp] -> Doc
forall a. Ppr a => (Int -> a -> Doc) -> [a] -> Doc
pprCtxWith Int -> Exp -> Doc
pprExp [Exp]
ctx, Int -> Exp -> Doc
pprExp Int
qualPrec Exp
body]

pprFields :: [(Name,Exp)] -> Doc
pprFields :: [FieldExp] -> Doc
pprFields = [Doc] -> Doc
sep ([Doc] -> Doc) -> ([FieldExp] -> [Doc]) -> [FieldExp] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([FieldExp] -> [Doc]) -> [FieldExp] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldExp -> Doc) -> [FieldExp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
s,Exp
e) -> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
s Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e)

pprMaybeExp :: Precedence -> Maybe Exp -> Doc
pprMaybeExp :: Int -> Maybe Exp -> Doc
pprMaybeExp Int
_ Maybe Exp
Nothing = Doc
empty
pprMaybeExp Int
i (Just Exp
e) = Int -> Exp -> Doc
pprExp Int
i Exp
e

------------------------------
instance Ppr Stmt where
    ppr :: Stmt -> Doc
ppr (BindS Pat
p Exp
e) = Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
p Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"<-" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e
    ppr (LetS [Dec]
ds) = [Char] -> Doc
text [Char]
"let" Doc -> Doc -> Doc
<+> (Doc -> Doc
braces ([Dec] -> Doc
forall a. Ppr a => [a] -> Doc
semiSep [Dec]
ds))
    ppr (NoBindS Exp
e) = Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e
    ppr (ParS [[Stmt]]
sss) = [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
bar
                         ([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. Ppr a => [a] -> Doc
commaSep [[Stmt]]
sss
    ppr (RecS [Stmt]
ss) = [Char] -> Doc
text [Char]
"rec" Doc -> Doc -> Doc
<+> (Doc -> Doc
braces ([Stmt] -> Doc
forall a. Ppr a => [a] -> Doc
semiSep [Stmt]
ss))

------------------------------
instance Ppr Match where
    ppr :: Match -> Doc
ppr (Match Pat
p Body
rhs [Dec]
ds) = Pat -> Doc
pprMatchPat Pat
p Doc -> Doc -> Doc
<+> Bool -> Body -> Doc
pprBody Bool
False Body
rhs
                        Doc -> Doc -> Doc
$$ [Dec] -> Doc
where_clause [Dec]
ds

pprMatchPat :: Pat -> Doc
-- Everything except pattern signatures bind more tightly than (->)
pprMatchPat :: Pat -> Doc
pprMatchPat p :: Pat
p@(SigP {}) = Doc -> Doc
parens (Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
p)
pprMatchPat Pat
p           = Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
p

------------------------------
pprGuarded :: Doc -> (Guard, Exp) -> Doc
pprGuarded :: Doc -> (Guard, Exp) -> Doc
pprGuarded Doc
eqDoc (Guard
guard, Exp
expr) = case Guard
guard of
  NormalG Exp
guardExpr -> Doc
bar Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
guardExpr Doc -> Doc -> Doc
<+> Doc
eqDoc Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
expr
  PatG    [Stmt]
stmts     -> Doc
bar Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat (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. Ppr a => a -> Doc
ppr [Stmt]
stmts) Doc -> Doc -> Doc
$$
                         Int -> Doc -> Doc
nest Int
nestDepth (Doc
eqDoc Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
expr)

------------------------------
pprBody :: Bool -> Body -> Doc
pprBody :: Bool -> Body -> Doc
pprBody Bool
eq Body
body = case Body
body of
    GuardedB [(Guard, Exp)]
xs -> Int -> Doc -> Doc
nest Int
nestDepth (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
$ ((Guard, Exp) -> Doc) -> [(Guard, Exp)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> (Guard, Exp) -> Doc
pprGuarded Doc
eqDoc) [(Guard, Exp)]
xs
    NormalB  Exp
e  -> Doc
eqDoc Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e
  where eqDoc :: Doc
eqDoc | Bool
eq        = Doc
equals
              | Bool
otherwise = Doc
arrow

------------------------------
pprClause :: Bool -> Clause -> Doc
pprClause :: Bool -> Clause -> Doc
pprClause Bool
eqDoc (Clause [Pat]
ps Body
rhs [Dec]
ds)
  = [Doc] -> Doc
hsep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
pprPat Int
appPrec) [Pat]
ps) Doc -> Doc -> Doc
<+> Bool -> Body -> Doc
pprBody Bool
eqDoc Body
rhs
    Doc -> Doc -> Doc
$$ [Dec] -> Doc
where_clause [Dec]
ds

------------------------------
instance Ppr Lit where
  ppr :: Lit -> Doc
ppr = Int -> Lit -> Doc
pprLit Int
noPrec

pprLit :: Precedence -> Lit -> Doc
pprLit :: Int -> Lit -> Doc
pprLit Int
i (IntPrimL Integer
x)    = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0)
                                    (Integer -> Doc
integer Integer
x Doc -> Doc -> Doc
<> Char -> Doc
char Char
'#')
pprLit Int
_ (WordPrimL Integer
x)    = Integer -> Doc
integer Integer
x Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"##"
pprLit Int
i (FloatPrimL Ratio Integer
x)  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec Bool -> Bool -> Bool
&& Ratio Integer
x Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Ratio Integer
0)
                                    (Float -> Doc
float (Ratio Integer -> Float
forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
x) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'#')
pprLit Int
i (DoublePrimL Ratio Integer
x) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec Bool -> Bool -> Bool
&& Ratio Integer
x Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Ratio Integer
0)
                                    (Double -> Doc
double (Ratio Integer -> Double
forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
x) Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"##")
pprLit Int
i (IntegerL Integer
x)    = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec Bool -> Bool -> Bool
&& Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Integer -> Doc
integer Integer
x)
pprLit Int
_ (CharL Char
c)       = [Char] -> Doc
text (Char -> [Char]
forall a. Show a => a -> [Char]
show Char
c)
pprLit Int
_ (CharPrimL Char
c)   = [Char] -> Doc
text (Char -> [Char]
forall a. Show a => a -> [Char]
show Char
c) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'#'
pprLit Int
_ (StringL [Char]
s)     = [Char] -> Doc
pprString [Char]
s
pprLit Int
_ (StringPrimL [Word8]
s) = [Char] -> Doc
pprString ([Word8] -> [Char]
bytesToString [Word8]
s) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'#'
pprLit Int
_ (BytesPrimL {}) = [Char] -> Doc
pprString [Char]
"<binary data>"
pprLit Int
i (RationalL Ratio Integer
rat)
  | Integer -> Integer -> Integer
withoutFactor Integer
2 (Integer -> Integer -> Integer
withoutFactor Integer
5 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Ratio Integer -> Integer
forall a. Ratio a -> a
denominator Ratio Integer
rat) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1
  -- if the denominator has prime factors other than 2 and 5
  -- or can't be represented as Double, show as fraction
  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Integer -> Doc
integer (Ratio Integer -> Integer
forall a. Ratio a -> a
numerator Ratio Integer
rat) Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'/' Doc -> Doc -> Doc
<+> Integer -> Doc
integer (Ratio Integer -> Integer
forall a. Ratio a -> a
denominator Ratio Integer
rat)
  | Ratio Integer
rat Ratio Integer -> Ratio Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Ratio Integer
0 Bool -> Bool -> Bool
&& (Integer
zeroes Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< -Integer
2 Bool -> Bool -> Bool
|| Integer
zeroes Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
6),
    let (Integer
n, Ratio Integer
d) = Ratio Integer -> (Integer, Ratio Integer)
forall b. Integral b => Ratio Integer -> (b, Ratio Integer)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (Ratio Integer
rat Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Fractional a => a -> a -> a
/ Ratio Integer
magnitude)
  -- if < 0.01 or >= 100_000_000, use scientific notation
  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec Bool -> Bool -> Bool
&& Ratio Integer
rat Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Ratio Integer
0)
             (Integer -> Doc
integer Integer
n
              Doc -> Doc -> Doc
<> (if Ratio Integer
d Ratio Integer -> Ratio Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Ratio Integer
0 then Doc
empty else Char -> Doc
char Char
'.' Doc -> Doc -> Doc
<> Ratio Integer -> Doc
decimals (Ratio Integer -> Ratio Integer
forall a. Num a => a -> a
abs Ratio Integer
d))
              Doc -> Doc -> Doc
<> Char -> Doc
char Char
'e' Doc -> Doc -> Doc
<> Integer -> Doc
integer Integer
zeroes)
  | let (Integer
n, Ratio Integer
d) = Ratio Integer -> (Integer, Ratio Integer)
forall b. Integral b => Ratio Integer -> (b, Ratio Integer)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Ratio Integer
rat
  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec Bool -> Bool -> Bool
&& Ratio Integer
rat Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Ratio Integer
0)
             (Integer -> Doc
integer Integer
n Doc -> Doc -> Doc
<> Char -> Doc
char Char
'.'
              Doc -> Doc -> Doc
<> if Ratio Integer
d Ratio Integer -> Ratio Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Ratio Integer
0 then Char -> Doc
char Char
'0' else Ratio Integer -> Doc
decimals (Ratio Integer -> Ratio Integer
forall a. Num a => a -> a
abs Ratio Integer
d))
  where zeroes :: Integer
        zeroes :: Integer
zeroes = Ratio Integer -> Integer
log10 (Ratio Integer -> Ratio Integer
forall a. Num a => a -> a
abs Ratio Integer
rat)
        log10 :: Rational -> Integer
        log10 :: Ratio Integer -> Integer
log10 Ratio Integer
x
          | Ratio Integer
x Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Ratio Integer
10 = Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Ratio Integer -> Integer
log10 (Ratio Integer
x Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Fractional a => a -> a -> a
/ Ratio Integer
10)
          | Ratio Integer
x Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Ratio Integer
1 = -Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Ratio Integer -> Integer
log10 (Ratio Integer
x Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
* Ratio Integer
10)
          | Bool
otherwise = Integer
0
        magnitude :: Rational
        magnitude :: Ratio Integer
magnitude = Ratio Integer
10 Ratio Integer -> Integer -> Ratio Integer
forall a b. (Fractional a, Integral b) => a -> b -> a
^^ Integer
zeroes
        withoutFactor :: Integer -> Integer -> Integer
        withoutFactor :: Integer -> Integer -> Integer
withoutFactor Integer
_ Integer
0 = Integer
0
        withoutFactor Integer
p Integer
n
          | (Integer
n', Integer
0) <- Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
divMod Integer
n Integer
p = Integer -> Integer -> Integer
withoutFactor Integer
p Integer
n'
          | Bool
otherwise = Integer
n
        -- | Expects the argument 0 <= x < 1
        decimals :: Rational -> Doc
        decimals :: Ratio Integer -> Doc
decimals Ratio Integer
x
          | Ratio Integer
x Ratio Integer -> Ratio Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Ratio Integer
0 = Doc
empty
          | Bool
otherwise = Integer -> Doc
integer Integer
n Doc -> Doc -> Doc
<> Ratio Integer -> Doc
decimals Ratio Integer
d
          where (Integer
n, Ratio Integer
d) = Ratio Integer -> (Integer, Ratio Integer)
forall b. Integral b => Ratio Integer -> (b, Ratio Integer)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (Ratio Integer
x Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
* Ratio Integer
10)

bytesToString :: [Word8] -> String
bytesToString :: [Word8] -> [Char]
bytesToString = (Word8 -> Char) -> [Word8] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)

pprString :: String -> Doc
-- Print newlines as newlines with Haskell string escape notation,
-- not as '\n'.  For other non-printables use regular escape notation.
pprString :: [Char] -> Doc
pprString [Char]
s = [Doc] -> Doc
vcat (([Char] -> Doc) -> [[Char]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Doc
text ([Char] -> [[Char]]
showMultiLineString [Char]
s))

------------------------------
instance Ppr Pat where
    ppr :: Pat -> Doc
ppr = Int -> Pat -> Doc
pprPat Int
noPrec

pprPat :: Precedence -> Pat -> Doc
pprPat :: Int -> Pat -> Doc
pprPat Int
i (LitP Lit
l)     = Int -> Lit -> Doc
pprLit Int
i Lit
l
pprPat Int
_ (VarP Name
v)     = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
v
pprPat Int
i (TupP [Pat]
ps)
  | [Pat
_] <- [Pat]
ps
  = Int -> Pat -> Doc
pprPat Int
i (Name -> Cxt -> [Pat] -> Pat
ConP (Int -> Name
tupleDataName Int
1) [] [Pat]
ps)
  | Bool
otherwise
  = Doc -> Doc
parens ([Pat] -> Doc
forall a. Ppr a => [a] -> Doc
commaSep [Pat]
ps)
pprPat Int
_ (UnboxedTupP [Pat]
ps) = Doc -> Doc
hashParens ([Pat] -> Doc
forall a. Ppr a => [a] -> Doc
commaSep [Pat]
ps)
pprPat Int
_ (UnboxedSumP Pat
p Int
alt Int
arity) = Doc -> Int -> Int -> Doc
unboxedSumBars (Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
p) Int
alt Int
arity
pprPat Int
i (ConP Name
s Cxt
ts [Pat]
ps)  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
appPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
      NameIs -> Name -> Doc
pprName' NameIs
Applied Name
s
  Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((Type -> Doc) -> Cxt -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\Type
t -> Char -> Doc
char Char
'@' Doc -> Doc -> Doc
<> Type -> Doc
pprParendType Type
t) Cxt
ts)
  Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((Pat -> Doc) -> [Pat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Pat -> Doc
pprPat Int
appPrec) [Pat]
ps)
pprPat Int
_ (ParensP Pat
p)  = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Pat -> Doc
pprPat Int
noPrec Pat
p
pprPat Int
i (UInfixP Pat
p1 Name
n Pat
p2)
                      = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
unopPrec) (Int -> Pat -> Doc
pprPat Int
unopPrec Pat
p1 Doc -> Doc -> Doc
<+>
                                                 NameIs -> Name -> Doc
pprName' NameIs
Infix Name
n   Doc -> Doc -> Doc
<+>
                                                 Int -> Pat -> Doc
pprPat Int
unopPrec Pat
p2)
pprPat Int
i (InfixP Pat
p1 Name
n Pat
p2)
                      = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
opPrec) (Int -> Pat -> Doc
pprPat Int
opPrec Pat
p1 Doc -> Doc -> Doc
<+>
                                                NameIs -> Name -> Doc
pprName' NameIs
Infix Name
n Doc -> Doc -> Doc
<+>
                                                Int -> Pat -> Doc
pprPat Int
opPrec Pat
p2)
pprPat Int
i (TildeP Pat
p)   = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
char Char
'~' Doc -> Doc -> Doc
<> Int -> Pat -> Doc
pprPat Int
appPrec Pat
p
pprPat Int
i (BangP Pat
p)    = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
char Char
'!' Doc -> Doc -> Doc
<> Int -> Pat -> Doc
pprPat Int
appPrec Pat
p
pprPat Int
i (AsP Name
v Pat
p)    = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
v Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"@"
                                                      Doc -> Doc -> Doc
<> Int -> Pat -> Doc
pprPat Int
appPrec Pat
p
pprPat Int
_ Pat
WildP        = [Char] -> Doc
text [Char]
"_"
pprPat Int
_ (RecP Name
nm [FieldPat]
fs)
 = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$     NameIs -> Name -> Doc
pprName' NameIs
Applied Name
nm
            Doc -> Doc -> Doc
<+> Doc -> Doc
braces ([Doc] -> Doc
sep ([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
$
                        (FieldPat -> Doc) -> [FieldPat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
s,Pat
p) -> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
s Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
p) [FieldPat]
fs)
pprPat Int
_ (ListP [Pat]
ps) = Doc -> Doc
brackets ([Pat] -> Doc
forall a. Ppr a => [a] -> Doc
commaSep [Pat]
ps)
pprPat Int
i (SigP Pat
p Type
t) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Pat -> Doc
pprPat Int
sigPrec Pat
p
                                          Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Int -> Type -> Doc
pprType Int
sigPrec Type
t
pprPat Int
_ (ViewP Exp
e Pat
p) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Exp -> Doc
pprExp Int
noPrec Exp
e Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"->" Doc -> Doc -> Doc
<+> Int -> Pat -> Doc
pprPat Int
noPrec Pat
p
pprPat Int
_ (TypeP Type
t) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"type" Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
t
pprPat Int
_ (InvisP Type
t) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"@" Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
t
pprPat Int
_ (OrP NonEmpty Pat
t) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Pat] -> Doc
forall a. Ppr a => [a] -> Doc
semiSep (NonEmpty Pat -> [Pat]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Pat
t)

------------------------------
instance Ppr Dec where
    ppr :: Dec -> Doc
ppr = Bool -> Dec -> Doc
ppr_dec Bool
True

ppr_dec :: Bool     -- ^ declaration on the toplevel?
        -> Dec
        -> Doc
ppr_dec :: Bool -> Dec -> Doc
ppr_dec Bool
isTop (FunD Name
f [Clause]
cs)   = [Doc] -> Doc
layout ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Clause -> Doc) -> [Clause] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\Clause
c -> Name -> Doc
pprPrefixOcc Name
f Doc -> Doc -> Doc
<+> Clause -> Doc
forall a. Ppr a => a -> Doc
ppr Clause
c) [Clause]
cs
  where
    layout :: [Doc] -> Doc
    layout :: [Doc] -> Doc
layout = if Bool
isTop then [Doc] -> Doc
vcat else (Doc -> Doc) -> [Doc] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
semiSepWith Doc -> Doc
forall a. a -> a
id
ppr_dec Bool
_ (ValD Pat
p Body
r [Dec]
ds) = Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
p Doc -> Doc -> Doc
<+> Bool -> Body -> Doc
pprBody Bool
True Body
r
                          Doc -> Doc -> Doc
$$ [Dec] -> Doc
where_clause [Dec]
ds
ppr_dec Bool
_ (TySynD Name
t [TyVarBndr BndrVis]
xs Type
rhs)
  = Doc -> Maybe Name -> Doc -> Type -> Doc
ppr_tySyn Doc
empty (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
t) ([Doc] -> Doc
hsep ((TyVarBndr BndrVis -> Doc) -> [TyVarBndr BndrVis] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr BndrVis]
xs)) Type
rhs
ppr_dec Bool
isTop (DataD Cxt
ctxt Name
t [TyVarBndr BndrVis]
xs Maybe Type
ksig [Con]
cs [DerivClause]
decs)
  = Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Doc
ppr_data Bool
isTop Doc
empty Cxt
ctxt (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
t) ([Doc] -> Doc
hsep ((TyVarBndr BndrVis -> Doc) -> [TyVarBndr BndrVis] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr BndrVis]
xs)) Maybe Type
ksig [Con]
cs [DerivClause]
decs
ppr_dec Bool
isTop (NewtypeD Cxt
ctxt Name
t [TyVarBndr BndrVis]
xs Maybe Type
ksig Con
c [DerivClause]
decs)
  = Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> Con
-> [DerivClause]
-> Doc
ppr_newtype Bool
isTop Doc
empty Cxt
ctxt (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
t) ([Doc] -> Doc
sep ((TyVarBndr BndrVis -> Doc) -> [TyVarBndr BndrVis] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr BndrVis]
xs)) Maybe Type
ksig Con
c [DerivClause]
decs
ppr_dec Bool
isTop (TypeDataD Name
t [TyVarBndr BndrVis]
xs Maybe Type
ksig [Con]
cs)
  = Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Doc
ppr_type_data Bool
isTop Doc
empty [] (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
t) ([Doc] -> Doc
hsep ((TyVarBndr BndrVis -> Doc) -> [TyVarBndr BndrVis] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr BndrVis]
xs)) Maybe Type
ksig [Con]
cs []
ppr_dec Bool
_  (ClassD Cxt
ctxt Name
c [TyVarBndr BndrVis]
xs [FunDep]
fds [Dec]
ds)
  = [Char] -> Doc
text [Char]
"class" Doc -> Doc -> Doc
<+> Cxt -> Doc
pprCxt Cxt
ctxt Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
c Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TyVarBndr BndrVis -> Doc) -> [TyVarBndr BndrVis] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr BndrVis]
xs) Doc -> Doc -> Doc
<+> [FunDep] -> Doc
forall a. Ppr a => a -> Doc
ppr [FunDep]
fds
    Doc -> Doc -> Doc
$$ [Dec] -> Doc
where_clause [Dec]
ds
ppr_dec Bool
_ (InstanceD Maybe Overlap
o Cxt
ctxt Type
i [Dec]
ds) =
        [Char] -> Doc
text [Char]
"instance" Doc -> Doc -> Doc
<+> Doc -> (Overlap -> Doc) -> Maybe Overlap -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty Overlap -> Doc
ppr_overlap Maybe Overlap
o Doc -> Doc -> Doc
<+> Cxt -> Doc
pprCxt Cxt
ctxt Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
i
                                  Doc -> Doc -> Doc
$$ [Dec] -> Doc
where_clause [Dec]
ds
ppr_dec Bool
_ (SigD Name
f Type
t)    = Name -> Doc
pprPrefixOcc Name
f Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
t
ppr_dec Bool
_ (KiSigD Name
f Type
k)  = [Char] -> Doc
text [Char]
"type" Doc -> Doc -> Doc
<+> Name -> Doc
pprPrefixOcc Name
f Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
k
ppr_dec Bool
_ (ForeignD Foreign
f)  = Foreign -> Doc
forall a. Ppr a => a -> Doc
ppr Foreign
f
ppr_dec Bool
_ (InfixD Fixity
fx NamespaceSpecifier
ns_spec Name
n) = Name -> Fixity -> NamespaceSpecifier -> Doc
pprFixity Name
n Fixity
fx NamespaceSpecifier
ns_spec
ppr_dec Bool
_ (DefaultD Cxt
tys) =
        [Char] -> Doc
text [Char]
"default" Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
sep ([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
$ (Type -> Doc) -> Cxt -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Doc
forall a. Ppr a => a -> Doc
ppr Cxt
tys)
ppr_dec Bool
_ (PragmaD Pragma
p)   = Pragma -> Doc
forall a. Ppr a => a -> Doc
ppr Pragma
p
ppr_dec Bool
isTop (DataFamilyD Name
tc [TyVarBndr BndrVis]
tvs Maybe Type
kind)
  = [Char] -> Doc
text [Char]
"data" Doc -> Doc -> Doc
<+> Doc
maybeFamily Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
tc Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TyVarBndr BndrVis -> Doc) -> [TyVarBndr BndrVis] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr BndrVis]
tvs) Doc -> Doc -> Doc
<+> Doc
maybeKind
  where
    maybeFamily :: Doc
maybeFamily | Bool
isTop     = [Char] -> Doc
text [Char]
"family"
                | Bool
otherwise = Doc
empty
    maybeKind :: Doc
maybeKind | (Just Type
k') <- Maybe Type
kind = Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
k'
              | Bool
otherwise = Doc
empty
ppr_dec Bool
isTop (DataInstD Cxt
ctxt Maybe [TyVarBndr ()]
bndrs Type
ty Maybe Type
ksig [Con]
cs [DerivClause]
decs)
  = Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Doc
ppr_data Bool
isTop (Doc
maybeInst Doc -> Doc -> Doc
<+> Maybe [TyVarBndr ()] -> Doc
forall flag. PprFlag flag => Maybe [TyVarBndr flag] -> Doc
ppr_bndrs Maybe [TyVarBndr ()]
bndrs)
             Cxt
ctxt Maybe Name
forall a. Maybe a
Nothing (Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty) Maybe Type
ksig [Con]
cs [DerivClause]
decs
  where
    maybeInst :: Doc
maybeInst | Bool
isTop     = [Char] -> Doc
text [Char]
"instance"
              | Bool
otherwise = Doc
empty
ppr_dec Bool
isTop (NewtypeInstD Cxt
ctxt Maybe [TyVarBndr ()]
bndrs Type
ty Maybe Type
ksig Con
c [DerivClause]
decs)
  = Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> Con
-> [DerivClause]
-> Doc
ppr_newtype Bool
isTop (Doc
maybeInst Doc -> Doc -> Doc
<+> Maybe [TyVarBndr ()] -> Doc
forall flag. PprFlag flag => Maybe [TyVarBndr flag] -> Doc
ppr_bndrs Maybe [TyVarBndr ()]
bndrs)
                Cxt
ctxt Maybe Name
forall a. Maybe a
Nothing (Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty) Maybe Type
ksig Con
c [DerivClause]
decs
  where
    maybeInst :: Doc
maybeInst | Bool
isTop     = [Char] -> Doc
text [Char]
"instance"
              | Bool
otherwise = Doc
empty
ppr_dec Bool
isTop (TySynInstD (TySynEqn Maybe [TyVarBndr ()]
mb_bndrs Type
ty Type
rhs))
  = Doc -> Maybe Name -> Doc -> Type -> Doc
ppr_tySyn (Doc
maybeInst Doc -> Doc -> Doc
<+> Maybe [TyVarBndr ()] -> Doc
forall flag. PprFlag flag => Maybe [TyVarBndr flag] -> Doc
ppr_bndrs Maybe [TyVarBndr ()]
mb_bndrs)
              Maybe Name
forall a. Maybe a
Nothing (Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty) Type
rhs
  where
    maybeInst :: Doc
maybeInst | Bool
isTop     = [Char] -> Doc
text [Char]
"instance"
              | Bool
otherwise = Doc
empty
ppr_dec Bool
isTop (OpenTypeFamilyD TypeFamilyHead
tfhead)
  = [Char] -> Doc
text [Char]
"type" Doc -> Doc -> Doc
<+> Doc
maybeFamily Doc -> Doc -> Doc
<+> TypeFamilyHead -> Doc
ppr_tf_head TypeFamilyHead
tfhead
  where
    maybeFamily :: Doc
maybeFamily | Bool
isTop     = [Char] -> Doc
text [Char]
"family"
                | Bool
otherwise = Doc
empty
ppr_dec Bool
_ (ClosedTypeFamilyD TypeFamilyHead
tfhead [TySynEqn]
eqns)
  = Doc -> Int -> Doc -> Doc
hang ([Char] -> Doc
text [Char]
"type family" Doc -> Doc -> Doc
<+> TypeFamilyHead -> Doc
ppr_tf_head TypeFamilyHead
tfhead Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"where")
      Int
nestDepth ([Doc] -> Doc
vcat ((TySynEqn -> Doc) -> [TySynEqn] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TySynEqn -> Doc
ppr_eqn [TySynEqn]
eqns))
  where
    ppr_eqn :: TySynEqn -> Doc
ppr_eqn (TySynEqn Maybe [TyVarBndr ()]
mb_bndrs Type
lhs Type
rhs)
      = Maybe [TyVarBndr ()] -> Doc
forall flag. PprFlag flag => Maybe [TyVarBndr flag] -> Doc
ppr_bndrs Maybe [TyVarBndr ()]
mb_bndrs Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
lhs Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"=" Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
rhs
ppr_dec Bool
_ (RoleAnnotD Name
name [Role]
roles)
  = [Doc] -> Doc
hsep [ [Char] -> Doc
text [Char]
"type role", NameIs -> Name -> Doc
pprName' NameIs
Applied Name
name ] Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Role -> Doc) -> [Role] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Role -> Doc
forall a. Ppr a => a -> Doc
ppr [Role]
roles)
ppr_dec Bool
_ (StandaloneDerivD Maybe DerivStrategy
ds Cxt
cxt Type
ty)
  = [Doc] -> Doc
hsep [ [Char] -> Doc
text [Char]
"deriving"
         , Doc -> (DerivStrategy -> Doc) -> Maybe DerivStrategy -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty DerivStrategy -> Doc
ppr_deriv_strategy Maybe DerivStrategy
ds
         , [Char] -> Doc
text [Char]
"instance"
         , Cxt -> Doc
pprCxt Cxt
cxt
         , Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty ]
ppr_dec Bool
_ (DefaultSigD Name
n Type
ty)
  = [Doc] -> Doc
hsep [ [Char] -> Doc
text [Char]
"default", Name -> Doc
pprPrefixOcc Name
n, Doc
dcolon, Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty ]
ppr_dec Bool
_ (PatSynD Name
name PatSynArgs
args PatSynDir
dir Pat
pat)
  = [Char] -> Doc
text [Char]
"pattern" Doc -> Doc -> Doc
<+> Doc
pprNameArgs Doc -> Doc -> Doc
<+> PatSynDir -> Doc
forall a. Ppr a => a -> Doc
ppr PatSynDir
dir Doc -> Doc -> Doc
<+> Doc
pprPatRHS
  where
    pprNameArgs :: Doc
pprNameArgs | InfixPatSyn Name
a1 Name
a2 <- PatSynArgs
args = Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
a1 Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Infix Name
name Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
a2
                | Bool
otherwise                 = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
name Doc -> Doc -> Doc
<+> PatSynArgs -> Doc
forall a. Ppr a => a -> Doc
ppr PatSynArgs
args
    pprPatRHS :: Doc
pprPatRHS   | ExplBidir [Clause]
cls <- PatSynDir
dir = Doc -> Int -> Doc -> Doc
hang (Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
pat Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"where")
                                              Int
nestDepth
                                              ([Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (NameIs -> Name -> Doc
pprName' NameIs
Applied Name
name Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> (Clause -> Doc) -> Clause -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clause -> Doc
forall a. Ppr a => a -> Doc
ppr (Clause -> Doc) -> [Clause] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Clause]
cls)
                | Bool
otherwise            = Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
pat
ppr_dec Bool
_ (PatSynSigD Name
name Type
ty)
  = Name -> Type -> Doc
pprPatSynSig Name
name Type
ty
ppr_dec Bool
_ (ImplicitParamBindD [Char]
n Exp
e)
  = [Doc] -> Doc
hsep [[Char] -> Doc
text (Char
'?' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
n), [Char] -> Doc
text [Char]
"=", Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e]

ppr_deriv_strategy :: DerivStrategy -> Doc
ppr_deriv_strategy :: DerivStrategy -> Doc
ppr_deriv_strategy DerivStrategy
ds =
  case DerivStrategy
ds of
    DerivStrategy
StockStrategy    -> [Char] -> Doc
text [Char]
"stock"
    DerivStrategy
AnyclassStrategy -> [Char] -> Doc
text [Char]
"anyclass"
    DerivStrategy
NewtypeStrategy  -> [Char] -> Doc
text [Char]
"newtype"
    ViaStrategy Type
ty   -> [Char] -> Doc
text [Char]
"via" Doc -> Doc -> Doc
<+> Type -> Doc
pprParendType Type
ty

ppr_overlap :: Overlap -> Doc
ppr_overlap :: Overlap -> Doc
ppr_overlap Overlap
o = [Char] -> Doc
text ([Char] -> Doc) -> [Char] -> Doc
forall a b. (a -> b) -> a -> b
$
  case Overlap
o of
    Overlap
Overlaps      -> [Char]
"{-# OVERLAPS #-}"
    Overlap
Overlappable  -> [Char]
"{-# OVERLAPPABLE #-}"
    Overlap
Overlapping   -> [Char]
"{-# OVERLAPPING #-}"
    Overlap
Incoherent    -> [Char]
"{-# INCOHERENT #-}"

ppr_data :: Bool     -- ^ declaration on the toplevel?
         -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
         -> Doc
ppr_data :: Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Doc
ppr_data = [Char]
-> Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Doc
ppr_typedef [Char]
"data"

ppr_newtype :: Bool     -- ^ declaration on the toplevel?
            -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
            -> Doc
ppr_newtype :: Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> Con
-> [DerivClause]
-> Doc
ppr_newtype Bool
isTop Doc
maybeInst Cxt
ctxt Maybe Name
t Doc
argsDoc Maybe Type
ksig Con
c [DerivClause]
decs
  = [Char]
-> Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Doc
ppr_typedef [Char]
"newtype" Bool
isTop Doc
maybeInst Cxt
ctxt Maybe Name
t Doc
argsDoc Maybe Type
ksig [Con
c] [DerivClause]
decs

ppr_type_data :: Bool     -- ^ declaration on the toplevel?
              -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
              -> Doc
ppr_type_data :: Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Doc
ppr_type_data = [Char]
-> Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Doc
ppr_typedef [Char]
"type data"

ppr_typedef :: String -> Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
ppr_typedef :: [Char]
-> Bool
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Doc
ppr_typedef [Char]
data_or_newtype Bool
isTop Doc
maybeInst Cxt
ctxt Maybe Name
t Doc
argsDoc Maybe Type
ksig [Con]
cs [DerivClause]
decs
  = [Doc] -> Doc
sep [[Char] -> Doc
text [Char]
data_or_newtype Doc -> Doc -> Doc
<+> Doc
maybeInst
            Doc -> Doc -> Doc
<+> Cxt -> Doc
pprCxt Cxt
ctxt
            Doc -> Doc -> Doc
<+> case Maybe Name
t of
                 Just Name
n -> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
n Doc -> Doc -> Doc
<+> Doc
argsDoc
                 Maybe Name
Nothing -> Doc
argsDoc
            Doc -> Doc -> Doc
<+> Doc
ksigDoc Doc -> Doc -> Doc
<+> Doc
maybeWhere,
         Int -> Doc -> Doc
nest Int
nestDepth ([Doc] -> Doc
layout ([Doc] -> [Doc]
pref ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Con -> Doc) -> [Con] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Doc
forall a. Ppr a => a -> Doc
ppr [Con]
cs)),
         if [DerivClause] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DerivClause]
decs
           then Doc
empty
           else Int -> Doc -> Doc
nest Int
nestDepth
              (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
$ (DerivClause -> Doc) -> [DerivClause] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map DerivClause -> Doc
ppr_deriv_clause [DerivClause]
decs]
  where
    pref :: [Doc] -> [Doc]
    pref :: [Doc] -> [Doc]
pref [Doc]
xs | Bool
isGadtDecl = [Doc]
xs
    pref []              = []      -- No constructors; can't happen in H98
    pref (Doc
d:[Doc]
ds)          = (Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Doc
d)Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:(Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc
bar Doc -> Doc -> Doc
<+>) [Doc]
ds

    layout :: [Doc] -> Doc
    layout :: [Doc] -> Doc
layout | Bool
isGadtDecl Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isTop = Doc -> Doc
braces (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> Doc) -> [Doc] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
semiSepWith Doc -> Doc
forall a. a -> a
id
           | Bool
otherwise = [Doc] -> Doc
vcat

    maybeWhere :: Doc
    maybeWhere :: Doc
maybeWhere | Bool
isGadtDecl = [Char] -> Doc
text [Char]
"where"
               | Bool
otherwise  = Doc
empty

    isGadtDecl :: Bool
    isGadtDecl :: Bool
isGadtDecl = Bool -> Bool
not ([Con] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Con]
cs) Bool -> Bool -> Bool
&& (Con -> Bool) -> [Con] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Con -> Bool
isGadtCon [Con]
cs
        where isGadtCon :: Con -> Bool
isGadtCon (GadtC [Name]
_ [BangType]
_ Type
_   ) = Bool
True
              isGadtCon (RecGadtC [Name]
_ [VarBangType]
_ Type
_) = Bool
True
              isGadtCon (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
x ) = Con -> Bool
isGadtCon Con
x
              isGadtCon  Con
_               = Bool
False

    ksigDoc :: Doc
ksigDoc = case Maybe Type
ksig of
                Maybe Type
Nothing -> Doc
empty
                Just Type
k  -> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
k


ppr_deriv_clause :: DerivClause -> Doc
ppr_deriv_clause :: DerivClause -> Doc
ppr_deriv_clause (DerivClause Maybe DerivStrategy
ds Cxt
ctxt)
  = [Char] -> Doc
text [Char]
"deriving" Doc -> Doc -> Doc
<+> Doc
pp_strat_before
                    Doc -> Doc -> Doc
<+> Int -> Cxt -> Doc
ppr_cxt_preds Int
appPrec Cxt
ctxt
                    Doc -> Doc -> Doc
<+> Doc
pp_strat_after
  where
    -- @via@ is unique in that in comes /after/ the class being derived,
    -- so we must special-case it.
    (Doc
pp_strat_before, Doc
pp_strat_after) =
      case Maybe DerivStrategy
ds of
        Just (via :: DerivStrategy
via@ViaStrategy{}) -> (Doc
empty, DerivStrategy -> Doc
ppr_deriv_strategy DerivStrategy
via)
        Maybe DerivStrategy
_                        -> (Doc -> (DerivStrategy -> Doc) -> Maybe DerivStrategy -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty DerivStrategy -> Doc
ppr_deriv_strategy Maybe DerivStrategy
ds, Doc
empty)

ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc
ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc
ppr_tySyn Doc
maybeInst Maybe Name
t Doc
argsDoc Type
rhs
  = [Char] -> Doc
text [Char]
"type" Doc -> Doc -> Doc
<+> Doc
maybeInst
    Doc -> Doc -> Doc
<+> case Maybe Name
t of
         Just Name
n -> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
n Doc -> Doc -> Doc
<+> Doc
argsDoc
         Maybe Name
Nothing -> Doc
argsDoc
    Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"=" Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
rhs

ppr_tf_head :: TypeFamilyHead -> Doc
ppr_tf_head :: TypeFamilyHead -> Doc
ppr_tf_head (TypeFamilyHead Name
tc [TyVarBndr BndrVis]
tvs FamilyResultSig
res Maybe InjectivityAnn
inj)
  = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
tc Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TyVarBndr BndrVis -> Doc) -> [TyVarBndr BndrVis] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr BndrVis -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr BndrVis]
tvs) Doc -> Doc -> Doc
<+> FamilyResultSig -> Doc
forall a. Ppr a => a -> Doc
ppr FamilyResultSig
res Doc -> Doc -> Doc
<+> Doc
maybeInj
  where
    maybeInj :: Doc
maybeInj | (Just InjectivityAnn
inj') <- Maybe InjectivityAnn
inj = InjectivityAnn -> Doc
forall a. Ppr a => a -> Doc
ppr InjectivityAnn
inj'
             | Bool
otherwise          = Doc
empty

ppr_bndrs :: PprFlag flag => Maybe [TyVarBndr flag] -> Doc
ppr_bndrs :: forall flag. PprFlag flag => Maybe [TyVarBndr flag] -> Doc
ppr_bndrs (Just [TyVarBndr flag]
bndrs) = [Char] -> Doc
text [Char]
"forall" Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((TyVarBndr flag -> Doc) -> [TyVarBndr flag] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr flag -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr flag]
bndrs) Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
"."
ppr_bndrs Maybe [TyVarBndr flag]
Nothing = Doc
empty

------------------------------
instance Ppr FunDep where
    ppr :: FunDep -> Doc
ppr (FunDep [Name]
xs [Name]
ys) = [Doc] -> Doc
hsep ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Ppr a => a -> Doc
ppr [Name]
xs) Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"->" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Ppr a => a -> Doc
ppr [Name]
ys)
    ppr_list :: [FunDep] -> Doc
ppr_list [] = Doc
empty
    ppr_list [FunDep]
xs = Doc
bar Doc -> Doc -> Doc
<+> [FunDep] -> Doc
forall a. Ppr a => [a] -> Doc
commaSep [FunDep]
xs

------------------------------
instance Ppr FamilyResultSig where
    ppr :: FamilyResultSig -> Doc
ppr FamilyResultSig
NoSig           = Doc
empty
    ppr (KindSig Type
k)     = Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
k
    ppr (TyVarSig TyVarBndr ()
bndr) = [Char] -> Doc
text [Char]
"=" Doc -> Doc -> Doc
<+> TyVarBndr () -> Doc
forall a. Ppr a => a -> Doc
ppr TyVarBndr ()
bndr

------------------------------
instance Ppr InjectivityAnn where
    ppr :: InjectivityAnn -> Doc
ppr (InjectivityAnn Name
lhs [Name]
rhs) =
        Doc
bar Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
lhs Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"->" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
forall a. Ppr a => a -> Doc
ppr [Name]
rhs)

------------------------------
instance Ppr Foreign where
    ppr :: Foreign -> Doc
ppr (ImportF Callconv
callconv Safety
safety [Char]
impent Name
as Type
typ)
       = [Char] -> Doc
text [Char]
"foreign import"
     Doc -> Doc -> Doc
<+> Callconv -> Doc
forall a. Show a => a -> Doc
showtextl Callconv
callconv
     Doc -> Doc -> Doc
<+> Safety -> Doc
forall a. Show a => a -> Doc
showtextl Safety
safety
     Doc -> Doc -> Doc
<+> [Char] -> Doc
text ([Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
impent)
     Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
as
     Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
typ
    ppr (ExportF Callconv
callconv [Char]
expent Name
as Type
typ)
        = [Char] -> Doc
text [Char]
"foreign export"
      Doc -> Doc -> Doc
<+> Callconv -> Doc
forall a. Show a => a -> Doc
showtextl Callconv
callconv
      Doc -> Doc -> Doc
<+> [Char] -> Doc
text ([Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
expent)
      Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
as
      Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
typ

------------------------------
instance Ppr Pragma where
    ppr :: Pragma -> Doc
ppr (InlineP Name
n Inline
inline RuleMatch
rm Phases
phases)
       = [Char] -> Doc
text [Char]
"{-#"
     Doc -> Doc -> Doc
<+> Inline -> Doc
forall a. Ppr a => a -> Doc
ppr Inline
inline
     Doc -> Doc -> Doc
<+> RuleMatch -> Doc
forall a. Ppr a => a -> Doc
ppr RuleMatch
rm
     Doc -> Doc -> Doc
<+> Phases -> Doc
forall a. Ppr a => a -> Doc
ppr Phases
phases
     Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
n
     Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}"
    ppr (OpaqueP Name
n)
       = [Char] -> Doc
text [Char]
"{-# OPAQUE" Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
n Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}"
    ppr (SpecialiseP Name
n Type
ty Maybe Inline
inline Phases
phases)
       =   [Char] -> Doc
text [Char]
"{-# SPECIALISE"
       Doc -> Doc -> Doc
<+> Doc -> (Inline -> Doc) -> Maybe Inline -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty Inline -> Doc
forall a. Ppr a => a -> Doc
ppr Maybe Inline
inline
       Doc -> Doc -> Doc
<+> Phases -> Doc
forall a. Ppr a => a -> Doc
ppr Phases
phases
       Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep [ NameIs -> Name -> Doc
pprName' NameIs
Applied Name
n Doc -> Doc -> Doc
<+> Doc
dcolon
               , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty ]
       Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}"
    ppr (SpecialiseEP Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs Exp
spec_e Maybe Inline
inline Phases
phases)
       = [Doc] -> Doc
sep [ [Char] -> Doc
text [Char]
"{-# SPECIALISE"
                 Doc -> Doc -> Doc
<+> Doc -> (Inline -> Doc) -> Maybe Inline -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty Inline -> Doc
forall a. Ppr a => a -> Doc
ppr Maybe Inline
inline
                 Doc -> Doc -> Doc
<+> Phases -> Doc
forall a. Ppr a => a -> Doc
ppr Phases
phases
             , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [ Maybe [TyVarBndr ()] -> Doc
ppr_ty_forall Maybe [TyVarBndr ()]
ty_bndrs Doc -> Doc -> Doc
<+> Maybe [TyVarBndr ()] -> [RuleBndr] -> Doc
ppr_tm_forall Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs
                            , Int -> Doc -> Doc
nest Int
2 (Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
spec_e) ]
                        Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}" ]
    ppr (SpecialiseInstP Type
inst)
       = [Char] -> Doc
text [Char]
"{-# SPECIALISE instance" Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
inst Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}"
    ppr (RuleP [Char]
n Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs Exp
lhs Exp
rhs Phases
phases)
       = [Doc] -> Doc
sep [ [Char] -> Doc
text [Char]
"{-# RULES" Doc -> Doc -> Doc
<+> [Char] -> Doc
pprString [Char]
n Doc -> Doc -> Doc
<+> Phases -> Doc
forall a. Ppr a => a -> Doc
ppr Phases
phases
             , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Maybe [TyVarBndr ()] -> Doc
ppr_ty_forall Maybe [TyVarBndr ()]
ty_bndrs Doc -> Doc -> Doc
<+> Maybe [TyVarBndr ()] -> [RuleBndr] -> Doc
ppr_tm_forall Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs
                                               Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
lhs
             , Int -> Doc -> Doc
nest Int
4 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
char Char
'=' Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
rhs Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}" ]
    ppr (AnnP AnnTarget
tgt Exp
expr)
       = [Char] -> Doc
text [Char]
"{-# ANN" Doc -> Doc -> Doc
<+> AnnTarget -> Doc
target1 AnnTarget
tgt Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
expr Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}"
      where target1 :: AnnTarget -> Doc
target1 AnnTarget
ModuleAnnotation    = [Char] -> Doc
text [Char]
"module"
            target1 (TypeAnnotation Name
t)  = [Char] -> Doc
text [Char]
"type" Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
t
            target1 (ValueAnnotation Name
v) = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
v
    ppr (LineP Int
line [Char]
file)
       = [Char] -> Doc
text [Char]
"{-# LINE" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
line Doc -> Doc -> Doc
<+> [Char] -> Doc
text ([Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
file) Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}"
    ppr (CompleteP [Name]
cls Maybe Name
mty)
       = [Char] -> Doc
text [Char]
"{-# COMPLETE" Doc -> Doc -> Doc
<+> ([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
$ (Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (NameIs -> Name -> Doc
pprName' NameIs
Applied) [Name]
cls)
                Doc -> Doc -> Doc
<+> Doc -> (Name -> Doc) -> Maybe Name -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (\Name
ty -> Doc
dcolon Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
ty) Maybe Name
mty Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}"
    ppr (SCCP Name
nm Maybe [Char]
str)
       = [Char] -> Doc
text [Char]
"{-# SCC" Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
nm Doc -> Doc -> Doc
<+> Doc -> ([Char] -> Doc) -> Maybe [Char] -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty [Char] -> Doc
pprString Maybe [Char]
str Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"#-}"

ppr_ty_forall :: Maybe [TyVarBndr ()] -> Doc
ppr_ty_forall :: Maybe [TyVarBndr ()] -> Doc
ppr_ty_forall Maybe [TyVarBndr ()]
Nothing      = Doc
empty
ppr_ty_forall (Just [TyVarBndr ()]
bndrs) = [Char] -> Doc
text [Char]
"forall"
                             Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep ((TyVarBndr () -> Doc) -> [TyVarBndr ()] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr ()]
bndrs)
                             Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'.'

ppr_tm_forall :: Maybe [TyVarBndr ()] -> [RuleBndr] -> Doc
ppr_tm_forall :: Maybe [TyVarBndr ()] -> [RuleBndr] -> Doc
ppr_tm_forall Maybe [TyVarBndr ()]
Nothing []       = Doc
empty
ppr_tm_forall Maybe [TyVarBndr ()]
_       [RuleBndr]
tm_bndrs = [Char] -> Doc
text [Char]
"forall"
                                 Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep ((RuleBndr -> Doc) -> [RuleBndr] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map RuleBndr -> Doc
forall a. Ppr a => a -> Doc
ppr [RuleBndr]
tm_bndrs)
                                 Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'.'
------------------------------
instance Ppr Inline where
    ppr :: Inline -> Doc
ppr Inline
NoInline  = [Char] -> Doc
text [Char]
"NOINLINE"
    ppr Inline
Inline    = [Char] -> Doc
text [Char]
"INLINE"
    ppr Inline
Inlinable = [Char] -> Doc
text [Char]
"INLINABLE"

------------------------------
instance Ppr RuleMatch where
    ppr :: RuleMatch -> Doc
ppr RuleMatch
ConLike = [Char] -> Doc
text [Char]
"CONLIKE"
    ppr RuleMatch
FunLike = Doc
empty

------------------------------
instance Ppr Phases where
    ppr :: Phases -> Doc
ppr Phases
AllPhases       = Doc
empty
    ppr (FromPhase Int
i)   = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc
int Int
i
    ppr (BeforePhase Int
i) = Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
char Char
'~' Doc -> Doc -> Doc
<> Int -> Doc
int Int
i

------------------------------
instance Ppr RuleBndr where
    ppr :: RuleBndr -> Doc
ppr (RuleVar Name
n)         = Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
n
    ppr (TypedRuleVar Name
n Type
ty) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
n Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty

------------------------------
instance Ppr Clause where
    ppr :: Clause -> Doc
ppr = Bool -> Clause -> Doc
pprClause Bool
True

------------------------------
instance Ppr Con where
  ppr :: Con -> Doc
ppr = (Doc -> Doc) -> Con -> Doc
ppr_con Doc -> Doc
forall a. a -> a
id
    where
      ppr_con :: (Doc -> Doc) -> Con -> Doc
      ppr_con :: (Doc -> Doc) -> Con -> Doc
ppr_con Doc -> Doc
ppr_foralls (NormalC Name
c [BangType]
sts) =
        Doc -> Doc
ppr_foralls (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ NameIs -> Name -> Doc
pprName' NameIs
Applied Name
c Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((BangType -> Doc) -> [BangType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Doc
pprBangType [BangType]
sts)
      ppr_con Doc -> Doc
ppr_foralls (RecC Name
c [VarBangType]
vsts) =
        Doc -> Doc
ppr_foralls (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ NameIs -> Name -> Doc
pprName' NameIs
Applied Name
c Doc -> Doc -> Doc
<+> [VarBangType] -> Doc
ppr_rec [VarBangType]
vsts
        where
          ppr_rec :: [VarBangType] -> Doc
          ppr_rec :: [VarBangType] -> Doc
ppr_rec = Doc -> Doc
braces (Doc -> Doc) -> ([VarBangType] -> Doc) -> [VarBangType] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
sep ([Doc] -> Doc) -> ([VarBangType] -> [Doc]) -> [VarBangType] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc])
-> ([VarBangType] -> [Doc]) -> [VarBangType] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarBangType -> Doc) -> [VarBangType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Doc
pprVarBangType
      ppr_con Doc -> Doc
ppr_foralls (InfixC BangType
st1 Name
c BangType
st2) =
        Doc -> Doc
ppr_foralls (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
              BangType -> Doc
pprBangType BangType
st1
          Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Infix Name
c
          Doc -> Doc -> Doc
<+> BangType -> Doc
pprBangType BangType
st2
      ppr_con Doc -> Doc
ppr_foralls (ForallC [TyVarBndr Specificity]
ns Cxt
ctxt Con
con)
        = (Doc -> Doc) -> Con -> Doc
ppr_con (\Doc
d -> Doc -> Doc
ppr_foralls (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [[TyVarBndr Specificity] -> Cxt -> Doc
pprForall [TyVarBndr Specificity]
ns Cxt
ctxt, Doc
d]) Con
con
      ppr_con Doc -> Doc
ppr_foralls (GadtC [Name]
cs [BangType]
sts Type
ty)
        = [Name] -> Doc
commaSepApplied [Name]
cs Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Doc -> Doc
ppr_foralls ([BangType] -> Type -> Doc
pprGadtRHS [BangType]
sts Type
ty)
      ppr_con Doc -> Doc
ppr_foralls (RecGadtC [Name]
cs [VarBangType]
vsts Type
ty)
        = [Name] -> Doc
commaSepApplied [Name]
cs Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Doc -> Doc
ppr_foralls ([VarBangType] -> Type -> Doc
pprRecFields [VarBangType]
vsts Type
ty)

instance Ppr PatSynDir where
  ppr :: PatSynDir -> Doc
ppr PatSynDir
Unidir        = [Char] -> Doc
text [Char]
"<-"
  ppr PatSynDir
ImplBidir     = [Char] -> Doc
text [Char]
"="
  ppr (ExplBidir [Clause]
_) = [Char] -> Doc
text [Char]
"<-"
    -- the ExplBidir's clauses are pretty printed together with the
    -- entire pattern synonym; so only print the direction here.

instance Ppr PatSynArgs where
  ppr :: PatSynArgs -> Doc
ppr (PrefixPatSyn [Name]
args) = [Doc] -> Doc
sep ([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. Ppr a => a -> Doc
ppr [Name]
args
  ppr (InfixPatSyn Name
a1 Name
a2) = Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
a1 Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
a2
  ppr (RecordPatSyn [Name]
sels) = Doc -> Doc
braces (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ((Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (NameIs -> Name -> Doc
pprName' NameIs
Applied) [Name]
sels))

commaSepApplied :: [Name] -> Doc
commaSepApplied :: [Name] -> Doc
commaSepApplied = (Name -> Doc) -> [Name] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaSepWith (NameIs -> Name -> Doc
pprName' NameIs
Applied)

pprForall :: [TyVarBndr Specificity] -> Cxt -> Doc
pprForall :: [TyVarBndr Specificity] -> Cxt -> Doc
pprForall = ForallVisFlag -> [TyVarBndr Specificity] -> Cxt -> Doc
forall flag.
PprFlag flag =>
ForallVisFlag -> [TyVarBndr flag] -> Cxt -> Doc
pprForall' ForallVisFlag
ForallInvis

pprForallVis :: [TyVarBndr ()] -> Cxt -> Doc
pprForallVis :: [TyVarBndr ()] -> Cxt -> Doc
pprForallVis = ForallVisFlag -> [TyVarBndr ()] -> Cxt -> Doc
forall flag.
PprFlag flag =>
ForallVisFlag -> [TyVarBndr flag] -> Cxt -> Doc
pprForall' ForallVisFlag
ForallVis

pprForall' :: PprFlag flag => ForallVisFlag -> [TyVarBndr flag] -> Cxt -> Doc
pprForall' :: forall flag.
PprFlag flag =>
ForallVisFlag -> [TyVarBndr flag] -> Cxt -> Doc
pprForall' ForallVisFlag
fvf [TyVarBndr flag]
tvs Cxt
cxt
  -- even in the case without any tvs, there could be a non-empty
  -- context cxt (e.g., in the case of pattern synonyms, where there
  -- are multiple forall binders and contexts).
  | [] <- [TyVarBndr flag]
tvs = Cxt -> Doc
pprCxt Cxt
cxt
  | Bool
otherwise = [Char] -> Doc
text [Char]
"forall" Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TyVarBndr flag -> Doc) -> [TyVarBndr flag] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr flag -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr flag]
tvs)
                              Doc -> Doc -> Doc
<+> Doc
separator Doc -> Doc -> Doc
<+> Cxt -> Doc
pprCxt Cxt
cxt
  where
    separator :: Doc
separator = case ForallVisFlag
fvf of
                  ForallVisFlag
ForallVis   -> [Char] -> Doc
text [Char]
"->"
                  ForallVisFlag
ForallInvis -> Char -> Doc
char Char
'.'

pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
pprRecFields :: [VarBangType] -> Type -> Doc
pprRecFields [VarBangType]
vsts Type
ty
    = Doc -> Doc
braces ([Doc] -> Doc
sep (Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (VarBangType -> Doc) -> [VarBangType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Doc
pprVarBangType [VarBangType]
vsts))
  Doc -> Doc -> Doc
<+> Doc
arrow Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty

pprGadtRHS :: [(Strict, Type)] -> Type -> Doc
pprGadtRHS :: [BangType] -> Type -> Doc
pprGadtRHS [] Type
ty
    = Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty
pprGadtRHS [BangType]
sts Type
ty
    = [Doc] -> Doc
sep (Doc -> [Doc] -> [Doc]
punctuate (Doc
space Doc -> Doc -> Doc
<> Doc
arrow) ((BangType -> Doc) -> [BangType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Doc
pprBangType [BangType]
sts))
  Doc -> Doc -> Doc
<+> Doc
arrow Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty

------------------------------
pprVarBangType :: VarBangType -> Doc
-- Slight infelicity: with print non-atomic type with parens
pprVarBangType :: VarBangType -> Doc
pprVarBangType (Name
v, Bang
bang, Type
t) = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
v Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> BangType -> Doc
pprBangType (Bang
bang, Type
t)

------------------------------
pprBangType :: BangType -> Doc
-- Make sure we print
--
-- Con {-# UNPACK #-} a
--
-- rather than
--
-- Con {-# UNPACK #-}a
--
-- when there's no strictness annotation. If there is a strictness annotation,
-- it's okay to not put a space between it and the type.
pprBangType :: BangType -> Doc
pprBangType (bt :: Bang
bt@(Bang SourceUnpackedness
_ SourceStrictness
NoSourceStrictness), Type
t) = Bang -> Doc
forall a. Ppr a => a -> Doc
ppr Bang
bt Doc -> Doc -> Doc
<+> Type -> Doc
pprParendType Type
t
pprBangType (Bang
bt, Type
t) = Bang -> Doc
forall a. Ppr a => a -> Doc
ppr Bang
bt Doc -> Doc -> Doc
<> Type -> Doc
pprParendType Type
t

------------------------------
instance Ppr Bang where
    ppr :: Bang -> Doc
ppr (Bang SourceUnpackedness
su SourceStrictness
ss) = SourceUnpackedness -> Doc
forall a. Ppr a => a -> Doc
ppr SourceUnpackedness
su Doc -> Doc -> Doc
<+> SourceStrictness -> Doc
forall a. Ppr a => a -> Doc
ppr SourceStrictness
ss

------------------------------
instance Ppr SourceUnpackedness where
    ppr :: SourceUnpackedness -> Doc
ppr SourceUnpackedness
NoSourceUnpackedness = Doc
empty
    ppr SourceUnpackedness
SourceNoUnpack       = [Char] -> Doc
text [Char]
"{-# NOUNPACK #-}"
    ppr SourceUnpackedness
SourceUnpack         = [Char] -> Doc
text [Char]
"{-# UNPACK #-}"

------------------------------
instance Ppr SourceStrictness where
    ppr :: SourceStrictness -> Doc
ppr SourceStrictness
NoSourceStrictness = Doc
empty
    ppr SourceStrictness
SourceLazy         = Char -> Doc
char Char
'~'
    ppr SourceStrictness
SourceStrict       = Char -> Doc
char Char
'!'

------------------------------
instance Ppr DecidedStrictness where
    ppr :: DecidedStrictness -> Doc
ppr DecidedStrictness
DecidedLazy   = Doc
empty
    ppr DecidedStrictness
DecidedStrict = Char -> Doc
char Char
'!'
    ppr DecidedStrictness
DecidedUnpack = [Char] -> Doc
text [Char]
"{-# UNPACK #-} !"

------------------------------
{-# DEPRECATED pprVarStrictType
               "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-}
pprVarStrictType :: (Name, Strict, Type) -> Doc
pprVarStrictType :: VarBangType -> Doc
pprVarStrictType = VarBangType -> Doc
pprVarBangType

------------------------------
{-# DEPRECATED pprStrictType
               "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-}
pprStrictType :: (Strict, Type) -> Doc
pprStrictType :: BangType -> Doc
pprStrictType = BangType -> Doc
pprBangType

------------------------------
pprType :: Precedence -> Type -> Doc
pprType :: Int -> Type -> Doc
pprType Int
_ (VarT Name
v)               = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
v
-- `Applied` is used here instead of `ppr` because of infix names (#13887)
pprType Int
_ (ConT Name
c)               = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
c
pprType Int
_ (TupleT Int
0)             = [Char] -> Doc
text [Char]
"()"
pprType Int
p (TupleT Int
1)             = Int -> Type -> Doc
pprType Int
p (Name -> Type
ConT (Int -> Name
tupleTypeName Int
1))
pprType Int
_ (TupleT Int
n)             = Doc -> Doc
parens ([Doc] -> Doc
hcat (Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Doc
comma))
pprType Int
_ (UnboxedTupleT Int
n)      = Doc -> Doc
hashParens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Doc
comma
pprType Int
_ (UnboxedSumT Int
arity)    = Doc -> Doc
hashParens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate (Int
arityInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Doc
bar
pprType Int
_ Type
ArrowT                 = Doc -> Doc
parens ([Char] -> Doc
text [Char]
"->")
pprType Int
_ Type
MulArrowT              = [Char] -> Doc
text [Char]
"FUN"
pprType Int
_ Type
ListT                  = [Char] -> Doc
text [Char]
"[]"
pprType Int
_ (LitT TyLit
l)               = TyLit -> Doc
pprTyLit TyLit
l
pprType Int
_ (PromotedT Name
c)          = [Char] -> Doc
text [Char]
"'" Doc -> Doc -> Doc
<> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
c
pprType Int
_ (PromotedTupleT Int
0)     = [Char] -> Doc
text [Char]
"'()"
pprType Int
p (PromotedTupleT Int
1)     = Int -> Type -> Doc
pprType Int
p (Name -> Type
PromotedT (Int -> Name
tupleDataName Int
1))
pprType Int
_ (PromotedTupleT Int
n)     = Doc -> Doc
quoteParens ([Doc] -> Doc
hcat (Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Doc
comma))
pprType Int
_ Type
PromotedNilT           = [Char] -> Doc
text [Char]
"'[]"
pprType Int
_ Type
PromotedConsT          = [Char] -> Doc
text [Char]
"'(:)"
pprType Int
_ Type
StarT                  = Char -> Doc
char Char
'*'
pprType Int
_ Type
ConstraintT            = [Char] -> Doc
text [Char]
"Constraint"
pprType Int
_ (SigT Type
ty Type
k)            = Doc -> Doc
parens (Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"::" Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
k)
pprType Int
_ Type
WildCardT              = Char -> Doc
char Char
'_'
pprType Int
p t :: Type
t@(InfixT {})          = Int -> Type -> Doc
pprInfixT Int
p Type
t
pprType Int
p t :: Type
t@(UInfixT {})         = Int -> Type -> Doc
pprInfixT Int
p Type
t
pprType Int
p t :: Type
t@(PromotedInfixT {})  = Int -> Type -> Doc
pprInfixT Int
p Type
t
pprType Int
p t :: Type
t@(PromotedUInfixT {}) = Int -> Type -> Doc
pprInfixT Int
p Type
t
pprType Int
_ (ParensT Type
t)            = Doc -> Doc
parens (Int -> Type -> Doc
pprType Int
noPrec Type
t)
pprType Int
p (ImplicitParamT [Char]
n Type
ty) =
  Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sigPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text (Char
'?'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
n) Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"::" Doc -> Doc -> Doc
<+> Int -> Type -> Doc
pprType Int
sigPrec Type
ty
pprType Int
_ Type
EqualityT              = [Char] -> Doc
text [Char]
"(~)"
pprType Int
p (ForallT [TyVarBndr Specificity]
tvars Cxt
ctxt Type
ty) =
  Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
funPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [[TyVarBndr Specificity] -> Cxt -> Doc
pprForall [TyVarBndr Specificity]
tvars Cxt
ctxt, Int -> Type -> Doc
pprType Int
qualPrec Type
ty]
pprType Int
p (ForallVisT [TyVarBndr ()]
tvars Type
ty) =
  Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
funPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep [[TyVarBndr ()] -> Cxt -> Doc
pprForallVis [TyVarBndr ()]
tvars [], Int -> Type -> Doc
pprType Int
qualPrec Type
ty]
pprType Int
p t :: Type
t@AppT{}               = Int -> (Type, [TypeArg]) -> Doc
pprTyApp Int
p (Type -> (Type, [TypeArg])
split Type
t)
pprType Int
p t :: Type
t@AppKindT{}           = Int -> (Type, [TypeArg]) -> Doc
pprTyApp Int
p (Type -> (Type, [TypeArg])
split Type
t)

------------------------------
pprParendType :: Type -> Doc
pprParendType :: Type -> Doc
pprParendType = Int -> Type -> Doc
pprType Int
appPrec

pprInfixT :: Precedence -> Type -> Doc
pprInfixT :: Int -> Type -> Doc
pprInfixT Int
p = \case
  InfixT Type
x Name
n Type
y          -> Type -> Name -> Type -> [Char] -> Int -> Doc
with Type
x Name
n Type
y [Char]
""  Int
opPrec
  UInfixT Type
x Name
n Type
y         -> Type -> Name -> Type -> [Char] -> Int -> Doc
with Type
x Name
n Type
y [Char]
""  Int
unopPrec
  PromotedInfixT Type
x Name
n Type
y  -> Type -> Name -> Type -> [Char] -> Int -> Doc
with Type
x Name
n Type
y [Char]
"'" Int
opPrec
  PromotedUInfixT Type
x Name
n Type
y -> Type -> Name -> Type -> [Char] -> Int -> Doc
with Type
x Name
n Type
y [Char]
"'" Int
unopPrec
  Type
t                     -> Type -> Doc
pprParendType Type
t
  where
    with :: Type -> Name -> Type -> [Char] -> Int -> Doc
with Type
x Name
n Type
y [Char]
prefix Int
p' =
      Bool -> Doc -> Doc
parensIf
        (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
p')
        (Int -> Type -> Doc
pprType Int
opPrec Type
x Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
prefix Doc -> Doc -> Doc
<> NameIs -> Name -> Doc
pprName' NameIs
Infix Name
n Doc -> Doc -> Doc
<+> Int -> Type -> Doc
pprType Int
opPrec Type
y)

instance Ppr Type where
    ppr :: Type -> Doc
ppr = Int -> Type -> Doc
pprType Int
noPrec
instance Ppr TypeArg where
    ppr :: TypeArg -> Doc
ppr (TANormal Type
ty) = Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ty
    ppr (TyArg Type
ki) = Char -> Doc
char Char
'@' Doc -> Doc -> Doc
<> Bool -> Doc -> Doc
parensIf (Type -> Bool
isStarT Type
ki) (Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
ki)

pprParendTypeArg :: TypeArg -> Doc
pprParendTypeArg :: TypeArg -> Doc
pprParendTypeArg (TANormal Type
ty) = Type -> Doc
pprParendType Type
ty
pprParendTypeArg (TyArg Type
ki) = Char -> Doc
char Char
'@' Doc -> Doc -> Doc
<> Bool -> Doc -> Doc
parensIf (Type -> Bool
isStarT Type
ki) (Type -> Doc
pprParendType Type
ki)

isStarT :: Type -> Bool
isStarT :: Type -> Bool
isStarT Type
StarT = Bool
True
isStarT Type
_ = Bool
False

{- Note [Pretty-printing kind signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC's parser only recognises a kind signature in a type when there are
parens around it.  E.g. the parens are required here:
   f :: (Int :: *)
   type instance F Int = (Bool :: *)
So we always print a SigT with parens (see #10050). -}

pprTyApp :: Precedence -> (Type, [TypeArg]) -> Doc
pprTyApp :: Int -> (Type, [TypeArg]) -> Doc
pprTyApp Int
p app :: (Type, [TypeArg])
app@(Type
MulArrowT, [TANormal (PromotedT Name
c), TANormal Type
arg1, TANormal Type
arg2])
  | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
funPrec  = Doc -> Doc
parens (Int -> (Type, [TypeArg]) -> Doc
pprTyApp Int
noPrec (Type, [TypeArg])
app)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
oneName  = [Doc] -> Doc
sep [Type -> Doc
pprFunArgType Type
arg1 Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"%1 ->", Int -> Type -> Doc
pprType Int
qualPrec Type
arg2]
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
manyName = [Doc] -> Doc
sep [Type -> Doc
pprFunArgType Type
arg1 Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"->", Int -> Type -> Doc
pprType Int
qualPrec Type
arg2]
pprTyApp Int
p (Type
MulArrowT, [TANormal Type
argm, TANormal Type
arg1, TANormal Type
arg2]) =
  Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
funPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
sep [Type -> Doc
pprFunArgType Type
arg1 Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"%" Doc -> Doc -> Doc
<> Int -> Type -> Doc
pprType Int
appPrec Type
argm Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"->",
         Int -> Type -> Doc
pprType Int
qualPrec Type
arg2]
pprTyApp Int
p (Type
ArrowT, [TANormal Type
arg1, TANormal Type
arg2]) =
  Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
funPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
sep [Type -> Doc
pprFunArgType Type
arg1 Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"->", Int -> Type -> Doc
pprType Int
qualPrec Type
arg2]
pprTyApp Int
p (Type
EqualityT, [TANormal Type
arg1, TANormal Type
arg2]) =
  Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
opPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
sep [Int -> Type -> Doc
pprType Int
opPrec Type
arg1 Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"~", Int -> Type -> Doc
pprType Int
opPrec Type
arg2]
pprTyApp Int
_ (Type
ListT, [TANormal Type
arg]) = Doc -> Doc
brackets (Int -> Type -> Doc
pprType Int
noPrec Type
arg)
pprTyApp Int
p (TupleT Int
1, [TypeArg]
args) = Int -> (Type, [TypeArg]) -> Doc
pprTyApp Int
p (Name -> Type
ConT (Int -> Name
tupleTypeName Int
1), [TypeArg]
args)
pprTyApp Int
_ (TupleT Int
n, [TypeArg]
args)
 | [TypeArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeArg]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n, Just Cxt
args' <- (TypeArg -> Maybe Type) -> [TypeArg] -> Maybe Cxt
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TypeArg -> Maybe Type
fromTANormal [TypeArg]
args
 = Doc -> Doc
parens (Cxt -> Doc
forall a. Ppr a => [a] -> Doc
commaSep Cxt
args')
pprTyApp Int
p (PromotedTupleT Int
1, [TypeArg]
args) = Int -> (Type, [TypeArg]) -> Doc
pprTyApp Int
p (Name -> Type
PromotedT (Int -> Name
tupleDataName Int
1), [TypeArg]
args)
pprTyApp Int
_ (PromotedTupleT Int
n, [TypeArg]
args)
 | [TypeArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeArg]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n, Just Cxt
args' <- (TypeArg -> Maybe Type) -> [TypeArg] -> Maybe Cxt
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TypeArg -> Maybe Type
fromTANormal [TypeArg]
args
 = Doc -> Doc
quoteParens (Cxt -> Doc
forall a. Ppr a => [a] -> Doc
commaSep Cxt
args')
pprTyApp Int
_ (UnboxedTupleT Int
n, [TypeArg]
args)
 | [TypeArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeArg]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n, Just Cxt
args' <- (TypeArg -> Maybe Type) -> [TypeArg] -> Maybe Cxt
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TypeArg -> Maybe Type
fromTANormal [TypeArg]
args
 = Doc -> Doc
hashParens (Cxt -> Doc
forall a. Ppr a => [a] -> Doc
commaSep Cxt
args')
pprTyApp Int
_ (UnboxedSumT Int
n, [TypeArg]
args)
 | [TypeArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeArg]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n, Just Cxt
args' <- (TypeArg -> Maybe Type) -> [TypeArg] -> Maybe Cxt
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TypeArg -> Maybe Type
fromTANormal [TypeArg]
args
 = Doc -> Doc
hashParens ([Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
bar ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Type -> Doc) -> Cxt -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Doc
forall a. Ppr a => a -> Doc
ppr Cxt
args')
pprTyApp Int
p (Type
fun, [TypeArg]
args) =
  Bool -> Doc -> Doc
parensIf (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
appPrec) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Type -> Doc
pprParendType Type
fun Doc -> Doc -> Doc
<+> [Doc] -> Doc
sep ((TypeArg -> Doc) -> [TypeArg] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TypeArg -> Doc
pprParendTypeArg [TypeArg]
args)

fromTANormal :: TypeArg -> Maybe Type
fromTANormal :: TypeArg -> Maybe Type
fromTANormal (TANormal Type
arg) = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
arg
fromTANormal (TyArg Type
_) = Maybe Type
forall a. Maybe a
Nothing

-- Print the type to the left of @->@. Everything except forall and (->) binds more tightly than (->).
pprFunArgType :: Type -> Doc
pprFunArgType :: Type -> Doc
pprFunArgType = Int -> Type -> Doc
pprType Int
funPrec

data ForallVisFlag = ForallVis   -- forall a -> {...}
                   | ForallInvis -- forall a.   {...}
  deriving Int -> ForallVisFlag -> [Char] -> [Char]
[ForallVisFlag] -> [Char] -> [Char]
ForallVisFlag -> [Char]
(Int -> ForallVisFlag -> [Char] -> [Char])
-> (ForallVisFlag -> [Char])
-> ([ForallVisFlag] -> [Char] -> [Char])
-> Show ForallVisFlag
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ForallVisFlag -> [Char] -> [Char]
showsPrec :: Int -> ForallVisFlag -> [Char] -> [Char]
$cshow :: ForallVisFlag -> [Char]
show :: ForallVisFlag -> [Char]
$cshowList :: [ForallVisFlag] -> [Char] -> [Char]
showList :: [ForallVisFlag] -> [Char] -> [Char]
Show

data TypeArg = TANormal Type
             | TyArg Kind

split :: Type -> (Type, [TypeArg])    -- Split into function and args
split :: Type -> (Type, [TypeArg])
split Type
t = Type -> [TypeArg] -> (Type, [TypeArg])
go Type
t []
    where go :: Type -> [TypeArg] -> (Type, [TypeArg])
go (AppT Type
t1 Type
t2) [TypeArg]
args = Type -> [TypeArg] -> (Type, [TypeArg])
go Type
t1 (Type -> TypeArg
TANormal Type
t2TypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
args)
          go (AppKindT Type
ty Type
ki) [TypeArg]
args = Type -> [TypeArg] -> (Type, [TypeArg])
go Type
ty (Type -> TypeArg
TyArg Type
kiTypeArg -> [TypeArg] -> [TypeArg]
forall a. a -> [a] -> [a]
:[TypeArg]
args)
          go Type
ty           [TypeArg]
args = (Type
ty, [TypeArg]
args)

pprTyLit :: TyLit -> Doc
pprTyLit :: TyLit -> Doc
pprTyLit (NumTyLit Integer
n) = Integer -> Doc
integer Integer
n
pprTyLit (StrTyLit [Char]
s) = [Char] -> Doc
text ([Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
s)
pprTyLit (CharTyLit Char
c) = [Char] -> Doc
text (Char -> [Char]
forall a. Show a => a -> [Char]
show Char
c)

instance Ppr TyLit where
  ppr :: TyLit -> Doc
ppr = TyLit -> Doc
pprTyLit

------------------------------
class PprFlag flag where
    pprTyVarBndr :: (TyVarBndr flag) -> Doc

instance PprFlag () where
    pprTyVarBndr :: TyVarBndr () -> Doc
pprTyVarBndr (PlainTV Name
nm ())    = Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm
    pprTyVarBndr (KindedTV Name
nm () Type
k) = Doc -> Doc
parens (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
k)

instance PprFlag Specificity where
    pprTyVarBndr :: TyVarBndr Specificity -> Doc
pprTyVarBndr (PlainTV Name
nm Specificity
SpecifiedSpec)    = Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm
    pprTyVarBndr (PlainTV Name
nm Specificity
InferredSpec)     = Doc -> Doc
braces (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm)
    pprTyVarBndr (KindedTV Name
nm Specificity
SpecifiedSpec Type
k) = Doc -> Doc
parens (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
k)
    pprTyVarBndr (KindedTV Name
nm Specificity
InferredSpec  Type
k) = Doc -> Doc
braces (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
k)

instance PprFlag BndrVis where
    pprTyVarBndr :: TyVarBndr BndrVis -> Doc
pprTyVarBndr (PlainTV Name
nm BndrVis
vis)    = BndrVis -> Doc -> Doc
pprBndrVis BndrVis
vis (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm)
    pprTyVarBndr (KindedTV Name
nm BndrVis
vis Type
k) = BndrVis -> Doc -> Doc
pprBndrVis BndrVis
vis (Doc -> Doc
parens (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Type -> Doc
forall a. Ppr a => a -> Doc
ppr Type
k))

pprBndrVis :: BndrVis -> Doc -> Doc
pprBndrVis :: BndrVis -> Doc -> Doc
pprBndrVis BndrVis
BndrReq   Doc
d = Doc
d
pprBndrVis BndrVis
BndrInvis Doc
d = Char -> Doc
char Char
'@' Doc -> Doc -> Doc
<> Doc
d

instance PprFlag flag => Ppr (TyVarBndr flag) where
    ppr :: TyVarBndr flag -> Doc
ppr TyVarBndr flag
bndr = TyVarBndr flag -> Doc
forall flag. PprFlag flag => TyVarBndr flag -> Doc
pprTyVarBndr TyVarBndr flag
bndr

instance Ppr Role where
    ppr :: Role -> Doc
ppr Role
NominalR          = [Char] -> Doc
text [Char]
"nominal"
    ppr Role
RepresentationalR = [Char] -> Doc
text [Char]
"representational"
    ppr Role
PhantomR          = [Char] -> Doc
text [Char]
"phantom"
    ppr Role
InferR            = [Char] -> Doc
text [Char]
"_"

------------------------------
pprCtxWith :: Ppr a => (Precedence -> a -> Doc) -> [a] -> Doc
pprCtxWith :: forall a. Ppr a => (Int -> a -> Doc) -> [a] -> Doc
pprCtxWith Int -> a -> Doc
_ [] = Doc
empty
pprCtxWith Int -> a -> Doc
ppr_fun [a]
ts = (Int -> a -> Doc) -> Int -> [a] -> Doc
forall a. Ppr a => (Int -> a -> Doc) -> Int -> [a] -> Doc
ppr_ctx_preds_with Int -> a -> Doc
ppr_fun Int
funPrec [a]
ts Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
"=>"

pprCxt :: Cxt -> Doc
pprCxt :: Cxt -> Doc
pprCxt = (Int -> Type -> Doc) -> Cxt -> Doc
forall a. Ppr a => (Int -> a -> Doc) -> [a] -> Doc
pprCtxWith Int -> Type -> Doc
pprType

ppr_ctx_preds_with :: Ppr a => (Precedence -> a -> Doc) -> Precedence -> [a] -> Doc
ppr_ctx_preds_with :: forall a. Ppr a => (Int -> a -> Doc) -> Int -> [a] -> Doc
ppr_ctx_preds_with Int -> a -> Doc
_ Int
_ [] = [Char] -> Doc
text [Char]
"()"
ppr_ctx_preds_with Int -> a -> Doc
f Int
p [a
t] = Int -> a -> Doc
f Int
p a
t
ppr_ctx_preds_with Int -> a -> Doc
_ Int
_ [a]
ts = Doc -> Doc
parens ([a] -> Doc
forall a. Ppr a => [a] -> Doc
commaSep [a]
ts)

ppr_cxt_preds :: Precedence -> Cxt -> Doc
ppr_cxt_preds :: Int -> Cxt -> Doc
ppr_cxt_preds = (Int -> Type -> Doc) -> Int -> Cxt -> Doc
forall a. Ppr a => (Int -> a -> Doc) -> Int -> [a] -> Doc
ppr_ctx_preds_with Int -> Type -> Doc
pprType

------------------------------
instance Ppr Range where
    ppr :: Range -> Doc
ppr = Doc -> Doc
brackets (Doc -> Doc) -> (Range -> Doc) -> Range -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> Doc
pprRange
        where pprRange :: Range -> Doc
              pprRange :: Range -> Doc
pprRange (FromR Exp
e) = Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
".."
              pprRange (FromThenR Exp
e1 Exp
e2) = Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e1 Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
","
                                           Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e2 Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
".."
              pprRange (FromToR Exp
e1 Exp
e2) = Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e1 Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
".." Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e2
              pprRange (FromThenToR Exp
e1 Exp
e2 Exp
e3) = Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e1 Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
","
                                             Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e2 Doc -> Doc -> Doc
<+> [Char] -> Doc
text [Char]
".."
                                             Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e3

------------------------------
where_clause :: [Dec] -> Doc
where_clause :: [Dec] -> Doc
where_clause [] = Doc
empty
where_clause [Dec]
ds = Int -> Doc -> Doc
nest Int
nestDepth (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"where" Doc -> Doc -> Doc
<+> Doc -> Doc
braces ((Dec -> Doc) -> [Dec] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
semiSepWith (Bool -> Dec -> Doc
ppr_dec Bool
False) [Dec]
ds)

showtextl :: Show a => a -> Doc
showtextl :: forall a. Show a => a -> Doc
showtextl = [Char] -> Doc
text ([Char] -> Doc) -> (a -> [Char]) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ([Char] -> [Char]) -> (a -> [Char]) -> a -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show

hashParens :: Doc -> Doc
hashParens :: Doc -> Doc
hashParens Doc
d = [Char] -> Doc
text [Char]
"(# " Doc -> Doc -> Doc
<> Doc
d Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
" #)"

quoteParens :: Doc -> Doc
quoteParens :: Doc -> Doc
quoteParens Doc
d = [Char] -> Doc
text [Char]
"'(" Doc -> Doc -> Doc
<> Doc
d Doc -> Doc -> Doc
<> [Char] -> Doc
text [Char]
")"

-----------------------------
instance Ppr Loc where
  ppr :: Loc -> Doc
ppr (Loc { loc_module :: Loc -> [Char]
loc_module = [Char]
md
           , loc_package :: Loc -> [Char]
loc_package = [Char]
pkg
           , loc_start :: Loc -> CharPos
loc_start = (Int
start_ln, Int
start_col)
           , loc_end :: Loc -> CharPos
loc_end = (Int
end_ln, Int
end_col) })
    = [Doc] -> Doc
hcat [ [Char] -> Doc
text [Char]
pkg, Doc
colon, [Char] -> Doc
text [Char]
md, Doc
colon
           , Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc
int Int
start_ln Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<> Int -> Doc
int Int
start_col
           , [Char] -> Doc
text [Char]
"-"
           , Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc
int Int
end_ln Doc -> Doc -> Doc
<> Doc
comma Doc -> Doc -> Doc
<> Int -> Doc
int Int
end_col ]

-- Takes a separator and a pretty-printing function and prints a list of things
-- separated by the separator followed by space.
sepWith :: Doc -> (a -> Doc) -> [a] -> Doc
sepWith :: forall a. Doc -> (a -> Doc) -> [a] -> Doc
sepWith Doc
sepDoc a -> Doc
pprFun = [Doc] -> Doc
sep ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
sepDoc ([Doc] -> [Doc]) -> ([a] -> [Doc]) -> [a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
pprFun

-- Takes a list of printable things and prints them separated by commas followed
-- by space.
commaSep :: Ppr a => [a] -> Doc
commaSep :: forall a. Ppr a => [a] -> Doc
commaSep = (a -> Doc) -> [a] -> Doc
forall a. (a -> Doc) -> [a] -> Doc
commaSepWith a -> Doc
forall a. Ppr a => a -> Doc
ppr

-- Takes a list of things and prints them with the given pretty-printing
-- function, separated by commas followed by space.
commaSepWith :: (a -> Doc) -> [a] -> Doc
commaSepWith :: forall a. (a -> Doc) -> [a] -> Doc
commaSepWith a -> Doc
pprFun = Doc -> (a -> Doc) -> [a] -> Doc
forall a. Doc -> (a -> Doc) -> [a] -> Doc
sepWith Doc
comma a -> Doc
pprFun

-- Takes a list of printable things and prints them separated by semicolons
-- followed by space.
semiSep :: Ppr a => [a] -> Doc
semiSep :: forall a. Ppr a => [a] -> Doc
semiSep = [Doc] -> Doc
sep ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
semi ([Doc] -> [Doc]) -> ([a] -> [Doc]) -> [a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Ppr a => a -> Doc
ppr

-- Takes a list of things and prints them with the given pretty-printing
-- function, separated by semicolons followed by space.
semiSepWith :: (a -> Doc) -> [a] -> Doc
semiSepWith :: forall a. (a -> Doc) -> [a] -> Doc
semiSepWith a -> Doc
pprFun = Doc -> (a -> Doc) -> [a] -> Doc
forall a. Doc -> (a -> Doc) -> [a] -> Doc
sepWith Doc
semi a -> Doc
pprFun

-- Prints out the series of vertical bars that wraps an expression or pattern
-- used in an unboxed sum.
unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc
unboxedSumBars :: Doc -> Int -> Int -> Doc
unboxedSumBars Doc
d Int
alt Int
arity = Doc -> Doc
hashParens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
    Int -> Doc
bars (Int
altInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Doc -> Doc -> Doc
<> Doc
d Doc -> Doc -> Doc
<> Int -> Doc
bars (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
alt)
  where
    bars :: Int -> Doc
bars Int
i = [Doc] -> Doc
hsep (Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate Int
i Doc
bar)

-- Text containing the vertical bar character.
bar :: Doc
bar :: Doc
bar = Char -> Doc
char Char
'|'