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

module Language.Haskell.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 Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr)
import GHC.Show  ( showMultiLineString )
import GHC.Lexeme( startsVarSym )
import Data.Ratio ( numerator, denominator )
import Data.Foldable ( toList )
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 -> String
pprint a
x = Doc -> String
render (Doc -> String) -> Doc -> String
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)
      = String -> Doc
text String
"Primitive"
        Doc -> Doc -> Doc
<+> (if Bool
is_unlifted then String -> Doc
text String
"unlifted" else Doc
empty)
        Doc -> Doc -> Doc
<+> String -> Doc
text String
"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 (String -> Doc
text String
"arity" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
arity)
    ppr (ClassOpI Name
v Pred
ty Name
cls)
      = String -> Doc
text String
"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 -> Pred -> Doc
ppr_sig Name
v Pred
ty
    ppr (DataConI Name
v Pred
ty Name
tc)
      = String -> Doc
text String
"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 -> Pred -> Doc
ppr_sig Name
v Pred
ty
    ppr (PatSynI Name
nm Pred
ty) = Name -> Pred -> Doc
pprPatSynSig Name
nm Pred
ty
    ppr (TyVarI Name
v Pred
ty)
      = String -> Doc
text String
"Type variable" Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
v Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty
    ppr (VarI Name
v Pred
ty Maybe Dec
mb_d)
      = [Doc] -> Doc
vcat [Name -> Pred -> Doc
ppr_sig Name
v Pred
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 -> Pred -> Doc
ppr_sig Name
v Pred
ty = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
v Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty

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

-- | Pretty prints a pattern synonym type signature
pprPatSynSig :: Name -> PatSynType -> Doc
pprPatSynSig :: Name -> Pred -> Doc
pprPatSynSig Name
nm Pred
ty
  = String -> Doc
text String
"pattern" Doc -> Doc -> Doc
<+> Name -> Doc
pprPrefixOcc Name
nm Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
pprPatSynType Pred
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 :: Pred -> Doc
pprPatSynType ty :: Pred
ty@(ForallT [TyVarBndr Specificity]
uniTys Cxt
reqs ty' :: Pred
ty'@(ForallT [TyVarBndr Specificity]
exTys Cxt
provs Pred
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 = Pred -> Doc
forall a. Ppr a => a -> Doc
ppr ([TyVarBndr Specificity] -> Cxt -> Pred -> Pred
ForallT [TyVarBndr Specificity]
uniTys Cxt
reqs Pred
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
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
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
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty'
  | Bool
otherwise               = Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty
  where noreqs :: Doc
noreqs = String -> Doc
text String
"() =>"
        pprForallBndrs :: [a] -> Doc
pprForallBndrs [a]
tvs = String -> Doc
text String
"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
<+> String -> Doc
text String
"."
pprPatSynType Pred
ty            = Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty

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

instance Ppr ModuleInfo where
  ppr :: ModuleInfo -> Doc
ppr (ModuleInfo [Module]
imps) = String -> Doc
text String
"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 -> String
nameBase Name
n of
      []    -> Bool
True  -- Empty name; weird
      (Char
c:String
_) -> Char -> Bool
startsVarSym Char
c
                   -- c.f. OccName.startsVarSym 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 = String -> Doc
text String
"`" Doc -> Doc -> Doc
<> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e Doc -> Doc -> Doc
<> String -> Doc
text String
"`"

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 Pred
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
<> Pred -> Doc
pprParendType Pred
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
<+> String -> Doc
text String
"->" 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
$ String -> Doc
text String
"\\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
$ String -> Doc
text String
"\\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 [String -> Doc
text String
"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
$ String -> Doc
text String
"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
$ String -> Doc
text String
"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
        []            -> [String -> Doc
text String
"if {}"]
        ((Guard, Exp)
alt : [(Guard, Exp)]
alts') -> String -> Doc
text String
"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
$ String -> Doc
text String
"let" Doc -> Doc -> Doc
<+> [Dec] -> Doc
forall a. Ppr a => [a] -> Doc
pprDecs [Dec]
ds_
                                             Doc -> Doc -> Doc
$$ String -> Doc
text String
" 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
$ String -> Doc
text String
"case" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e Doc -> Doc -> Doc
<+> String -> Doc
text String
"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
<> String -> Doc
text String
"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) = String -> Doc
text (ModName -> String
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
<> String -> Doc
text String
"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) = String -> Doc
text (ModName -> String
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 []) = String -> Doc
text String
"<<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 String -> Doc
text String
"[" Doc -> Doc -> Doc
<> Stmt -> Doc
forall a. Ppr a => a -> Doc
ppr Stmt
s Doc -> Doc -> Doc
<> String -> Doc
text String
"]"
       else String -> Doc
text String
"[" 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
<> String -> Doc
text String
"]"
  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 Pred
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 -> Pred -> Doc
pprType Int
sigPrec Pred
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
$
                         String -> Doc
text String
"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 String
s) = String -> Doc
text String
"#" Doc -> Doc -> Doc
<> String -> Doc
text String
s
pprExp Int
_ (ImplicitParamVarE String
n) = String -> Doc
text (Char
'?' Char -> String -> String
forall a. a -> [a] -> [a]
: String
n)
pprExp Int
_ (GetFieldE Exp
e String
f) = Int -> Exp -> Doc
pprExp Int
appPrec Exp
e Doc -> Doc -> Doc
<> String -> Doc
text (Char
'.'Char -> String -> String
forall a. a -> [a] -> [a]
: String
f)
pprExp Int
_ (ProjectionE NonEmpty String
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
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Doc
char Char
'.'Doc -> Doc -> Doc
<>) (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text) ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty String
xs

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
<+> String -> Doc
text String
"<-" Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e
    ppr (LetS [Dec]
ds) = String -> Doc
text String
"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) = String -> Doc
text String
"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
<> String -> Doc
text String
"##"
pprLit Int
i (FloatPrimL Rational
x)  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec Bool -> Bool -> Bool
&& Rational
x Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0)
                                    (Float -> Doc
float (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
x) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'#')
pprLit Int
i (DoublePrimL Rational
x) = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec Bool -> Bool -> Bool
&& Rational
x Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0)
                                    (Double -> Doc
double (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x) Doc -> Doc -> Doc
<> String -> Doc
text String
"##")
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)       = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c)
pprLit Int
_ (CharPrimL Char
c)   = String -> Doc
text (Char -> String
forall a. Show a => a -> String
show Char
c) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'#'
pprLit Int
_ (StringL String
s)     = String -> Doc
pprString String
s
pprLit Int
_ (StringPrimL [Word8]
s) = String -> Doc
pprString ([Word8] -> String
bytesToString [Word8]
s) Doc -> Doc -> Doc
<> Char -> Doc
char Char
'#'
pprLit Int
_ (BytesPrimL {}) = String -> Doc
pprString String
"<binary data>"
pprLit Int
i (RationalL Rational
rat)
  | Integer -> Integer -> Integer
withoutFactor Integer
2 (Integer -> Integer -> Integer
withoutFactor Integer
5 (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall a. Ratio a -> a
denominator Rational
rat) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer
1
  -- if the denominator has prime factors other than 2 and 5, 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 (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
rat) Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'/' Doc -> Doc -> Doc
<+> Integer -> Doc
integer (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
rat)
  | Rational
rat Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= Rational
0 Bool -> Bool -> Bool
&& (Integer
zeroes Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< -Integer
1 Bool -> Bool -> Bool
|| Integer
zeroes Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
7),
    let (Integer
n, Rational
d) = Rational -> (Integer, Rational)
forall b. Integral b => Rational -> (b, Rational)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (Rational
rat' Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
magnitude)
        (Rational
rat', Integer
zeroes')
          | Rational -> Rational
forall a. Num a => a -> a
abs Rational
rat Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
1 = (Rational
10 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
rat, Integer
zeroes Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1)
          | Bool
otherwise = (Rational
rat, Integer
zeroes)
  -- 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
&& Rational
rat Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0)
             (Integer -> Doc
integer Integer
n
              Doc -> Doc -> Doc
<> (if Rational
d Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 then Doc
empty else Char -> Doc
char Char
'.' Doc -> Doc -> Doc
<> Rational -> Doc
decimals (Rational -> Rational
forall a. Num a => a -> a
abs Rational
d))
              Doc -> Doc -> Doc
<> Char -> Doc
char Char
'e' Doc -> Doc -> Doc
<> Integer -> Doc
integer Integer
zeroes')
  | let (Integer
n, Rational
d) = Rational -> (Integer, Rational)
forall b. Integral b => Rational -> (b, Rational)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction Rational
rat
  = Bool -> Doc -> Doc
parensIf (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
noPrec Bool -> Bool -> Bool
&& Rational
rat Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0)
             (Integer -> Doc
integer Integer
n Doc -> Doc -> Doc
<> Char -> Doc
char Char
'.'
              Doc -> Doc -> Doc
<> if Rational
d Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 then Char -> Doc
char Char
'0' else Rational -> Doc
decimals (Rational -> Rational
forall a. Num a => a -> a
abs Rational
d))
  where zeroes :: Integer
        zeroes :: Integer
zeroes = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
10 (Double -> Double
forall a. Num a => a -> a
abs (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
rat) :: Double)
                           Double -> Double -> Double
forall a. Num a => a -> a -> a
* (Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
epsilon))
        epsilon :: Double
epsilon = Double
0.0000001
        magnitude :: Rational
        magnitude :: Rational
magnitude = Rational
10 Rational -> Integer -> Rational
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 :: Rational -> Doc
decimals Rational
x
          | Rational
x Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 = Doc
empty
          | Bool
otherwise = Integer -> Doc
integer Integer
n Doc -> Doc -> Doc
<> Rational -> Doc
decimals Rational
d
          where (Integer
n, Rational
d) = Rational -> (Integer, Rational)
forall b. Integral b => Rational -> (b, Rational)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (Rational
x Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
10)

bytesToString :: [Word8] -> String
bytesToString :: [Word8] -> String
bytesToString = (Word8 -> Char) -> [Word8] -> String
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 :: String -> Doc
pprString String
s = [Doc] -> Doc
vcat ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text (String -> [String]
showMultiLineString String
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 ((Pred -> Doc) -> Cxt -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\Pred
t -> Char -> Doc
char Char
'@' Doc -> Doc -> Doc
<> Pred -> Doc
pprParendType Pred
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
<> String -> Doc
text String
"@"
                                                      Doc -> Doc -> Doc
<> Int -> Pat -> Doc
pprPat Int
appPrec Pat
p
pprPat Int
_ Pat
WildP        = String -> Doc
text String
"_"
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 Pred
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
$ Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
p Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
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
<+> String -> Doc
text String
"->" Doc -> Doc -> Doc
<+> Int -> Pat -> Doc
pprPat Int
noPrec Pat
p

------------------------------
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
_ (FunD Name
f [Clause]
cs)   = [Doc] -> Doc
vcat ([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
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 ()]
xs Pred
rhs)
  = Doc -> Maybe Name -> Doc -> Pred -> Doc
ppr_tySyn Doc
empty (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
t) ([Doc] -> Doc
hsep ((TyVarBndr () -> Doc) -> [TyVarBndr ()] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr ()]
xs)) Pred
rhs
ppr_dec Bool
_ (DataD Cxt
ctxt Name
t [TyVarBndr ()]
xs Maybe Pred
ksig [Con]
cs [DerivClause]
decs)
  = Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Doc
ppr_data Doc
empty Cxt
ctxt (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
t) ([Doc] -> Doc
hsep ((TyVarBndr () -> Doc) -> [TyVarBndr ()] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr ()]
xs)) Maybe Pred
ksig [Con]
cs [DerivClause]
decs
ppr_dec Bool
_ (NewtypeD Cxt
ctxt Name
t [TyVarBndr ()]
xs Maybe Pred
ksig Con
c [DerivClause]
decs)
  = Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> Con
-> [DerivClause]
-> Doc
ppr_newtype Doc
empty Cxt
ctxt (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
t) ([Doc] -> Doc
sep ((TyVarBndr () -> Doc) -> [TyVarBndr ()] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr ()]
xs)) Maybe Pred
ksig Con
c [DerivClause]
decs
ppr_dec Bool
_ (TypeDataD Name
t [TyVarBndr ()]
xs Maybe Pred
ksig [Con]
cs)
  = Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Doc
ppr_type_data Doc
empty [] (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
t) ([Doc] -> Doc
hsep ((TyVarBndr () -> Doc) -> [TyVarBndr ()] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr ()]
xs)) Maybe Pred
ksig [Con]
cs []
ppr_dec Bool
_  (ClassD Cxt
ctxt Name
c [TyVarBndr ()]
xs [FunDep]
fds [Dec]
ds)
  = String -> Doc
text String
"class" Doc -> Doc -> Doc
<+> Cxt -> Doc
pprCxt Cxt
ctxt Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
c Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TyVarBndr () -> Doc) -> [TyVarBndr ()] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr ()]
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 Pred
i [Dec]
ds) =
        String -> Doc
text String
"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
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
i
                                  Doc -> Doc -> Doc
$$ [Dec] -> Doc
where_clause [Dec]
ds
ppr_dec Bool
_ (SigD Name
f Pred
t)    = Name -> Doc
pprPrefixOcc Name
f Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
t
ppr_dec Bool
_ (KiSigD Name
f Pred
k)  = String -> Doc
text String
"type" Doc -> Doc -> Doc
<+> Name -> Doc
pprPrefixOcc Name
f Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
k
ppr_dec Bool
_ (ForeignD Foreign
f)  = Foreign -> Doc
forall a. Ppr a => a -> Doc
ppr Foreign
f
ppr_dec Bool
_ (InfixD Fixity
fx Name
n) = Name -> Fixity -> Doc
pprFixity Name
n Fixity
fx
ppr_dec Bool
_ (DefaultD Cxt
tys) =
        String -> Doc
text String
"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
$ (Pred -> Doc) -> Cxt -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Pred -> 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 ()]
tvs Maybe Pred
kind)
  = String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> Doc
maybeFamily Doc -> Doc -> Doc
<+> Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
tc Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TyVarBndr () -> Doc) -> [TyVarBndr ()] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr ()]
tvs) Doc -> Doc -> Doc
<+> Doc
maybeKind
  where
    maybeFamily :: Doc
maybeFamily | Bool
isTop     = String -> Doc
text String
"family"
                | Bool
otherwise = Doc
empty
    maybeKind :: Doc
maybeKind | (Just Pred
k') <- Maybe Pred
kind = Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
k'
              | Bool
otherwise = Doc
empty
ppr_dec Bool
isTop (DataInstD Cxt
ctxt Maybe [TyVarBndr ()]
bndrs Pred
ty Maybe Pred
ksig [Con]
cs [DerivClause]
decs)
  = Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Doc
ppr_data (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 (Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty) Maybe Pred
ksig [Con]
cs [DerivClause]
decs
  where
    maybeInst :: Doc
maybeInst | Bool
isTop     = String -> Doc
text String
"instance"
              | Bool
otherwise = Doc
empty
ppr_dec Bool
isTop (NewtypeInstD Cxt
ctxt Maybe [TyVarBndr ()]
bndrs Pred
ty Maybe Pred
ksig Con
c [DerivClause]
decs)
  = Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> Con
-> [DerivClause]
-> Doc
ppr_newtype (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 (Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty) Maybe Pred
ksig Con
c [DerivClause]
decs
  where
    maybeInst :: Doc
maybeInst | Bool
isTop     = String -> Doc
text String
"instance"
              | Bool
otherwise = Doc
empty
ppr_dec Bool
isTop (TySynInstD (TySynEqn Maybe [TyVarBndr ()]
mb_bndrs Pred
ty Pred
rhs))
  = Doc -> Maybe Name -> Doc -> Pred -> 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 (Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty) Pred
rhs
  where
    maybeInst :: Doc
maybeInst | Bool
isTop     = String -> Doc
text String
"instance"
              | Bool
otherwise = Doc
empty
ppr_dec Bool
isTop (OpenTypeFamilyD TypeFamilyHead
tfhead)
  = String -> Doc
text String
"type" Doc -> Doc -> Doc
<+> Doc
maybeFamily Doc -> Doc -> Doc
<+> TypeFamilyHead -> Doc
ppr_tf_head TypeFamilyHead
tfhead
  where
    maybeFamily :: Doc
maybeFamily | Bool
isTop     = String -> Doc
text String
"family"
                | Bool
otherwise = Doc
empty
ppr_dec Bool
_ (ClosedTypeFamilyD TypeFamilyHead
tfhead [TySynEqn]
eqns)
  = Doc -> Int -> Doc -> Doc
hang (String -> Doc
text String
"type family" Doc -> Doc -> Doc
<+> TypeFamilyHead -> Doc
ppr_tf_head TypeFamilyHead
tfhead Doc -> Doc -> Doc
<+> String -> Doc
text String
"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 Pred
lhs Pred
rhs)
      = Maybe [TyVarBndr ()] -> Doc
forall flag. PprFlag flag => Maybe [TyVarBndr flag] -> Doc
ppr_bndrs Maybe [TyVarBndr ()]
mb_bndrs Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
lhs Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
rhs
ppr_dec Bool
_ (RoleAnnotD Name
name [Role]
roles)
  = [Doc] -> Doc
hsep [ String -> Doc
text String
"type role", Name -> Doc
forall a. Ppr a => a -> Doc
ppr 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 Pred
ty)
  = [Doc] -> Doc
hsep [ String -> Doc
text String
"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
         , String -> Doc
text String
"instance"
         , Cxt -> Doc
pprCxt Cxt
cxt
         , Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty ]
ppr_dec Bool
_ (DefaultSigD Name
n Pred
ty)
  = [Doc] -> Doc
hsep [ String -> Doc
text String
"default", Name -> Doc
pprPrefixOcc Name
n, Doc
dcolon, Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty ]
ppr_dec Bool
_ (PatSynD Name
name PatSynArgs
args PatSynDir
dir Pat
pat)
  = String -> Doc
text String
"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
<+> String -> Doc
text String
"where")
                                           Int
nestDepth (NameIs -> Name -> Doc
pprName' NameIs
Applied Name
name Doc -> Doc -> Doc
<+> [Clause] -> Doc
forall a. Ppr a => a -> Doc
ppr [Clause]
cls)
                | Bool
otherwise            = Pat -> Doc
forall a. Ppr a => a -> Doc
ppr Pat
pat
ppr_dec Bool
_ (PatSynSigD Name
name Pred
ty)
  = Name -> Pred -> Doc
pprPatSynSig Name
name Pred
ty
ppr_dec Bool
_ (ImplicitParamBindD String
n Exp
e)
  = [Doc] -> Doc
hsep [String -> Doc
text (Char
'?' Char -> String -> String
forall a. a -> [a] -> [a]
: String
n), String -> Doc
text String
"=", 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    -> String -> Doc
text String
"stock"
    DerivStrategy
AnyclassStrategy -> String -> Doc
text String
"anyclass"
    DerivStrategy
NewtypeStrategy  -> String -> Doc
text String
"newtype"
    ViaStrategy Pred
ty   -> String -> Doc
text String
"via" Doc -> Doc -> Doc
<+> Pred -> Doc
pprParendType Pred
ty

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

ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
         -> Doc
ppr_data :: Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Doc
ppr_data = String
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Doc
ppr_typedef String
"data"

ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
            -> Doc
ppr_newtype :: Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> Con
-> [DerivClause]
-> Doc
ppr_newtype Doc
maybeInst Cxt
ctxt Maybe Name
t Doc
argsDoc Maybe Pred
ksig Con
c [DerivClause]
decs = String
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Doc
ppr_typedef String
"newtype" Doc
maybeInst Cxt
ctxt Maybe Name
t Doc
argsDoc Maybe Pred
ksig [Con
c] [DerivClause]
decs

ppr_type_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
         -> Doc
ppr_type_data :: Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Doc
ppr_type_data = String
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Doc
ppr_typedef String
"type data"

ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
ppr_typedef :: String
-> Doc
-> Cxt
-> Maybe Name
-> Doc
-> Maybe Pred
-> [Con]
-> [DerivClause]
-> Doc
ppr_typedef String
data_or_newtype Doc
maybeInst Cxt
ctxt Maybe Name
t Doc
argsDoc Maybe Pred
ksig [Con]
cs [DerivClause]
decs
  = [Doc] -> Doc
sep [String -> Doc
text String
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
vcat ([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

    maybeWhere :: Doc
    maybeWhere :: Doc
maybeWhere | Bool
isGadtDecl = String -> Doc
text String
"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]
_ Pred
_   ) = Bool
True
              isGadtCon (RecGadtC [Name]
_ [VarBangType]
_ Pred
_) = Bool
True
              isGadtCon (ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
x ) = Con -> Bool
isGadtCon Con
x
              isGadtCon  Con
_               = Bool
False

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


ppr_deriv_clause :: DerivClause -> Doc
ppr_deriv_clause :: DerivClause -> Doc
ppr_deriv_clause (DerivClause Maybe DerivStrategy
ds Cxt
ctxt)
  = String -> Doc
text String
"deriving" Doc -> Doc -> Doc
<+> Doc
pp_strat_before
                    Doc -> Doc -> Doc
<+> Cxt -> Doc
ppr_cxt_preds 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 -> Pred -> Doc
ppr_tySyn Doc
maybeInst Maybe Name
t Doc
argsDoc Pred
rhs
  = String -> Doc
text String
"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
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
rhs

ppr_tf_head :: TypeFamilyHead -> Doc
ppr_tf_head :: TypeFamilyHead -> Doc
ppr_tf_head (TypeFamilyHead Name
tc [TyVarBndr ()]
tvs FamilyResultSig
res Maybe InjectivityAnn
inj)
  = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
tc Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep ((TyVarBndr () -> Doc) -> [TyVarBndr ()] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr () -> Doc
forall a. Ppr a => a -> Doc
ppr [TyVarBndr ()]
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) = String -> Doc
text String
"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
<> String -> Doc
text String
"."
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
<+> String -> Doc
text String
"->" 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 Pred
k)     = Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
k
    ppr (TyVarSig TyVarBndr ()
bndr) = String -> Doc
text String
"=" 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
<+> String -> Doc
text String
"->" 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 String
impent Name
as Pred
typ)
       = String -> Doc
text String
"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
<+> String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
impent)
     Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
as
     Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
typ
    ppr (ExportF Callconv
callconv String
expent Name
as Pred
typ)
        = String -> Doc
text String
"foreign export"
      Doc -> Doc -> Doc
<+> Callconv -> Doc
forall a. Show a => a -> Doc
showtextl Callconv
callconv
      Doc -> Doc -> Doc
<+> String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
expent)
      Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
as
      Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
typ

------------------------------
instance Ppr Pragma where
    ppr :: Pragma -> Doc
ppr (InlineP Name
n Inline
inline RuleMatch
rm Phases
phases)
       = String -> Doc
text String
"{-#"
     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
<+> String -> Doc
text String
"#-}"
    ppr (OpaqueP Name
n)
       = String -> Doc
text String
"{-# OPAQUE" Doc -> Doc -> Doc
<+> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"#-}"
    ppr (SpecialiseP Name
n Pred
ty Maybe Inline
inline Phases
phases)
       =   String -> Doc
text String
"{-# 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
$ Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty ]
       Doc -> Doc -> Doc
<+> String -> Doc
text String
"#-}"
    ppr (SpecialiseInstP Pred
inst)
       = String -> Doc
text String
"{-# SPECIALISE instance" Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
inst Doc -> Doc -> Doc
<+> String -> Doc
text String
"#-}"
    ppr (RuleP String
n Maybe [TyVarBndr ()]
ty_bndrs [RuleBndr]
tm_bndrs Exp
lhs Exp
rhs Phases
phases)
       = [Doc] -> Doc
sep [ String -> Doc
text String
"{-# RULES" Doc -> Doc -> Doc
<+> String -> Doc
pprString String
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
forall {a}. Ppr a => Maybe [a] -> Doc
ppr_ty_forall Maybe [TyVarBndr ()]
ty_bndrs Doc -> Doc -> Doc
<+> Maybe [TyVarBndr ()] -> Doc
forall {a}. Maybe a -> Doc
ppr_tm_forall Maybe [TyVarBndr ()]
ty_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
<+> String -> Doc
text String
"#-}" ]
      where ppr_ty_forall :: Maybe [a] -> Doc
ppr_ty_forall Maybe [a]
Nothing      = Doc
empty
            ppr_ty_forall (Just [a]
bndrs) = String -> Doc
text String
"forall"
                                         Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Ppr a => a -> Doc
ppr [a]
bndrs)
                                         Doc -> Doc -> Doc
<+> Char -> Doc
char Char
'.'
            ppr_tm_forall :: Maybe a -> Doc
ppr_tm_forall Maybe a
Nothing | [RuleBndr] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RuleBndr]
tm_bndrs = Doc
empty
            ppr_tm_forall Maybe a
_ = String -> Doc
text String
"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
'.'
    ppr (AnnP AnnTarget
tgt Exp
expr)
       = String -> Doc
text String
"{-# 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
<+> String -> Doc
text String
"#-}"
      where target1 :: AnnTarget -> Doc
target1 AnnTarget
ModuleAnnotation    = String -> Doc
text String
"module"
            target1 (TypeAnnotation Name
t)  = String -> Doc
text String
"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 String
file)
       = String -> Doc
text String
"{-# LINE" Doc -> Doc -> Doc
<+> Int -> Doc
int Int
line Doc -> Doc -> Doc
<+> String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
file) Doc -> Doc -> Doc
<+> String -> Doc
text String
"#-}"
    ppr (CompleteP [Name]
cls Maybe Name
mty)
       = String -> Doc
text String
"{-# 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
<+> String -> Doc
text String
"#-}"

------------------------------
instance Ppr Inline where
    ppr :: Inline -> Doc
ppr Inline
NoInline  = String -> Doc
text String
"NOINLINE"
    ppr Inline
Inline    = String -> Doc
text String
"INLINE"
    ppr Inline
Inlinable = String -> Doc
text String
"INLINABLE"

------------------------------
instance Ppr RuleMatch where
    ppr :: RuleMatch -> Doc
ppr RuleMatch
ConLike = String -> Doc
text String
"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 Pred
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
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty

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

------------------------------
instance Ppr Con where
    ppr :: Con -> Doc
ppr (NormalC Name
c [BangType]
sts) = 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 (RecC Name
c [VarBangType]
vsts)
        = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
c Doc -> Doc -> Doc
<+> 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))

    ppr (InfixC BangType
st1 Name
c BangType
st2) = 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 (ForallC [TyVarBndr Specificity]
ns Cxt
ctxt (GadtC [Name]
c [BangType]
sts Pred
ty))
        = [Name] -> Doc
commaSepApplied [Name]
c Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> [TyVarBndr Specificity] -> Cxt -> Doc
pprForall [TyVarBndr Specificity]
ns Cxt
ctxt
      Doc -> Doc -> Doc
<+> [BangType] -> Pred -> Doc
pprGadtRHS [BangType]
sts Pred
ty

    ppr (ForallC [TyVarBndr Specificity]
ns Cxt
ctxt (RecGadtC [Name]
c [VarBangType]
vsts Pred
ty))
        = [Name] -> Doc
commaSepApplied [Name]
c Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> [TyVarBndr Specificity] -> Cxt -> Doc
pprForall [TyVarBndr Specificity]
ns Cxt
ctxt
      Doc -> Doc -> Doc
<+> [VarBangType] -> Pred -> Doc
pprRecFields [VarBangType]
vsts Pred
ty

    ppr (ForallC [TyVarBndr Specificity]
ns Cxt
ctxt Con
con)
        = [TyVarBndr Specificity] -> Cxt -> Doc
pprForall [TyVarBndr Specificity]
ns Cxt
ctxt Doc -> Doc -> Doc
<+> Con -> Doc
forall a. Ppr a => a -> Doc
ppr Con
con

    ppr (GadtC [Name]
c [BangType]
sts Pred
ty)
        = [Name] -> Doc
commaSepApplied [Name]
c Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> [BangType] -> Pred -> Doc
pprGadtRHS [BangType]
sts Pred
ty

    ppr (RecGadtC [Name]
c [VarBangType]
vsts Pred
ty)
        = [Name] -> Doc
commaSepApplied [Name]
c Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> [VarBangType] -> Pred -> Doc
pprRecFields [VarBangType]
vsts Pred
ty

instance Ppr PatSynDir where
  ppr :: PatSynDir -> Doc
ppr PatSynDir
Unidir        = String -> Doc
text String
"<-"
  ppr PatSynDir
ImplBidir     = String -> Doc
text String
"="
  ppr (ExplBidir [Clause]
_) = String -> Doc
text String
"<-"
    -- 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 = String -> Doc
text String
"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   -> String -> Doc
text String
"->"
                  ForallVisFlag
ForallInvis -> Char -> Doc
char Char
'.'

pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
pprRecFields :: [VarBangType] -> Pred -> Doc
pprRecFields [VarBangType]
vsts Pred
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
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty

pprGadtRHS :: [(Strict, Type)] -> Type -> Doc
pprGadtRHS :: [BangType] -> Pred -> Doc
pprGadtRHS [] Pred
ty
    = Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty
pprGadtRHS [BangType]
sts Pred
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
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty

------------------------------
pprVarBangType :: VarBangType -> Doc
-- Slight infelicity: with print non-atomic type with parens
pprVarBangType :: VarBangType -> Doc
pprVarBangType (Name
v, Bang
bang, Pred
t) = NameIs -> Name -> Doc
pprName' NameIs
Applied Name
v Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> BangType -> Doc
pprBangType (Bang
bang, Pred
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), Pred
t) = Bang -> Doc
forall a. Ppr a => a -> Doc
ppr Bang
bt Doc -> Doc -> Doc
<+> Pred -> Doc
pprParendType Pred
t
pprBangType (Bang
bt, Pred
t) = Bang -> Doc
forall a. Ppr a => a -> Doc
ppr Bang
bt Doc -> Doc -> Doc
<> Pred -> Doc
pprParendType Pred
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       = String -> Doc
text String
"{-# NOUNPACK #-}"
    ppr SourceUnpackedness
SourceUnpack         = String -> Doc
text String
"{-# 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 = String -> Doc
text String
"{-# 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 -> Pred -> 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)             = String -> Doc
text String
"()"
pprType Int
p (TupleT Int
1)             = Int -> Pred -> Doc
pprType Int
p (Name -> Pred
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
hcat ([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
_ Pred
ArrowT                 = Doc -> Doc
parens (String -> Doc
text String
"->")
pprType Int
_ Pred
MulArrowT              = String -> Doc
text String
"FUN"
pprType Int
_ Pred
ListT                  = String -> Doc
text String
"[]"
pprType Int
_ (LitT TyLit
l)               = TyLit -> Doc
pprTyLit TyLit
l
pprType Int
_ (PromotedT Name
c)          = String -> Doc
text String
"'" Doc -> Doc -> Doc
<> NameIs -> Name -> Doc
pprName' NameIs
Applied Name
c
pprType Int
_ (PromotedTupleT Int
0)     = String -> Doc
text String
"'()"
pprType Int
p (PromotedTupleT Int
1)     = Int -> Pred -> Doc
pprType Int
p (Name -> Pred
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
_ Pred
PromotedNilT           = String -> Doc
text String
"'[]"
pprType Int
_ Pred
PromotedConsT          = String -> Doc
text String
"'(:)"
pprType Int
_ Pred
StarT                  = Char -> Doc
char Char
'*'
pprType Int
_ Pred
ConstraintT            = String -> Doc
text String
"Constraint"
pprType Int
_ (SigT Pred
ty Pred
k)            = Doc -> Doc
parens (Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
ty Doc -> Doc -> Doc
<+> String -> Doc
text String
"::" Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
k)
pprType Int
_ Pred
WildCardT              = Char -> Doc
char Char
'_'
pprType Int
p t :: Pred
t@(InfixT {})          = Int -> Pred -> Doc
pprInfixT Int
p Pred
t
pprType Int
p t :: Pred
t@(UInfixT {})         = Int -> Pred -> Doc
pprInfixT Int
p Pred
t
pprType Int
p t :: Pred
t@(PromotedInfixT {})  = Int -> Pred -> Doc
pprInfixT Int
p Pred
t
pprType Int
p t :: Pred
t@(PromotedUInfixT {}) = Int -> Pred -> Doc
pprInfixT Int
p Pred
t
pprType Int
_ (ParensT Pred
t)            = Doc -> Doc
parens (Int -> Pred -> Doc
pprType Int
noPrec Pred
t)
pprType Int
p (ImplicitParamT String
n Pred
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
$ String -> Doc
text (Char
'?'Char -> String -> String
forall a. a -> [a] -> [a]
:String
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"::" Doc -> Doc -> Doc
<+> Int -> Pred -> Doc
pprType Int
sigPrec Pred
ty
pprType Int
_ Pred
EqualityT              = String -> Doc
text String
"(~)"
pprType Int
p (ForallT [TyVarBndr Specificity]
tvars Cxt
ctxt Pred
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 -> Pred -> Doc
pprType Int
qualPrec Pred
ty]
pprType Int
p (ForallVisT [TyVarBndr ()]
tvars Pred
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 -> Pred -> Doc
pprType Int
qualPrec Pred
ty]
pprType Int
p t :: Pred
t@AppT{}               = Int -> (Pred, [TypeArg]) -> Doc
pprTyApp Int
p (Pred -> (Pred, [TypeArg])
split Pred
t)
pprType Int
p t :: Pred
t@AppKindT{}           = Int -> (Pred, [TypeArg]) -> Doc
pprTyApp Int
p (Pred -> (Pred, [TypeArg])
split Pred
t)

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

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

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

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

isStarT :: Type -> Bool
isStarT :: Pred -> Bool
isStarT Pred
StarT = Bool
True
isStarT Pred
_ = 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 -> (Pred, [TypeArg]) -> Doc
pprTyApp Int
p app :: (Pred, [TypeArg])
app@(Pred
MulArrowT, [TANormal (PromotedT Name
c), TANormal Pred
arg1, TANormal Pred
arg2])
  | Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
funPrec  = Doc -> Doc
parens (Int -> (Pred, [TypeArg]) -> Doc
pprTyApp Int
noPrec (Pred, [TypeArg])
app)
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
oneName  = [Doc] -> Doc
sep [Pred -> Doc
pprFunArgType Pred
arg1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"%1 ->", Int -> Pred -> Doc
pprType Int
qualPrec Pred
arg2]
  | Name
c Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
manyName = [Doc] -> Doc
sep [Pred -> Doc
pprFunArgType Pred
arg1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"->", Int -> Pred -> Doc
pprType Int
qualPrec Pred
arg2]
pprTyApp Int
p (Pred
MulArrowT, [TANormal Pred
argm, TANormal Pred
arg1, TANormal Pred
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 [Pred -> Doc
pprFunArgType Pred
arg1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"%" Doc -> Doc -> Doc
<> Int -> Pred -> Doc
pprType Int
appPrec Pred
argm Doc -> Doc -> Doc
<+> String -> Doc
text String
"->",
         Int -> Pred -> Doc
pprType Int
qualPrec Pred
arg2]
pprTyApp Int
p (Pred
ArrowT, [TANormal Pred
arg1, TANormal Pred
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 [Pred -> Doc
pprFunArgType Pred
arg1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"->", Int -> Pred -> Doc
pprType Int
qualPrec Pred
arg2]
pprTyApp Int
p (Pred
EqualityT, [TANormal Pred
arg1, TANormal Pred
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 -> Pred -> Doc
pprType Int
opPrec Pred
arg1 Doc -> Doc -> Doc
<+> String -> Doc
text String
"~", Int -> Pred -> Doc
pprType Int
opPrec Pred
arg2]
pprTyApp Int
_ (Pred
ListT, [TANormal Pred
arg]) = Doc -> Doc
brackets (Int -> Pred -> Doc
pprType Int
noPrec Pred
arg)
pprTyApp Int
p (TupleT Int
1, [TypeArg]
args) = Int -> (Pred, [TypeArg]) -> Doc
pprTyApp Int
p (Name -> Pred
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 Pred) -> [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 Pred
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 -> (Pred, [TypeArg]) -> Doc
pprTyApp Int
p (Name -> Pred
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 Pred) -> [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 Pred
fromTANormal [TypeArg]
args
 = Doc -> Doc
quoteParens (Cxt -> Doc
forall a. Ppr a => [a] -> Doc
commaSep Cxt
args')
pprTyApp Int
p (Pred
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
$ Pred -> Doc
pprParendType Pred
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 Pred
fromTANormal (TANormal Pred
arg) = Pred -> Maybe Pred
forall a. a -> Maybe a
Just Pred
arg
fromTANormal (TyArg Pred
_) = Maybe Pred
forall a. Maybe a
Nothing

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

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

data TypeArg = TANormal Type
             | TyArg Kind

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

pprTyLit :: TyLit -> Doc
pprTyLit :: TyLit -> Doc
pprTyLit (NumTyLit Integer
n) = Integer -> Doc
integer Integer
n
pprTyLit (StrTyLit String
s) = String -> Doc
text (String -> String
forall a. Show a => a -> String
show String
s)
pprTyLit (CharTyLit Char
c) = String -> Doc
text (Char -> String
forall a. Show a => a -> String
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 () Pred
k) = Doc -> Doc
parens (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
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 Pred
k) = Doc -> Doc
parens (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
k)
    pprTyVarBndr (KindedTV Name
nm Specificity
InferredSpec  Pred
k) = Doc -> Doc
braces (Name -> Doc
forall a. Ppr a => a -> Doc
ppr Name
nm Doc -> Doc -> Doc
<+> Doc
dcolon Doc -> Doc -> Doc
<+> Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
k)

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          = String -> Doc
text String
"nominal"
    ppr Role
RepresentationalR = String -> Doc
text String
"representational"
    ppr Role
PhantomR          = String -> Doc
text String
"phantom"
    ppr Role
InferR            = String -> Doc
text String
"_"

------------------------------
pprCxt :: Cxt -> Doc
pprCxt :: Cxt -> Doc
pprCxt [] = Doc
empty
pprCxt Cxt
ts = Cxt -> Doc
ppr_cxt_preds Cxt
ts Doc -> Doc -> Doc
<+> String -> Doc
text String
"=>"

ppr_cxt_preds :: Cxt -> Doc
ppr_cxt_preds :: Cxt -> Doc
ppr_cxt_preds [] = Doc
empty
ppr_cxt_preds [t :: Pred
t@ImplicitParamT{}] = Doc -> Doc
parens (Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
t)
ppr_cxt_preds [t :: Pred
t@ForallT{}] = Doc -> Doc
parens (Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
t)
ppr_cxt_preds [Pred
t] = Pred -> Doc
forall a. Ppr a => a -> Doc
ppr Pred
t
ppr_cxt_preds Cxt
ts = Doc -> Doc
parens (Cxt -> Doc
forall a. Ppr a => [a] -> Doc
commaSep Cxt
ts)

------------------------------
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
<+> String -> Doc
text String
".."
              pprRange (FromThenR Exp
e1 Exp
e2) = Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e1 Doc -> Doc -> Doc
<> String -> Doc
text String
","
                                           Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e2 Doc -> Doc -> Doc
<+> String -> Doc
text String
".."
              pprRange (FromToR Exp
e1 Exp
e2) = Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e1 Doc -> Doc -> Doc
<+> String -> Doc
text String
".." 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
<> String -> Doc
text String
","
                                             Doc -> Doc -> Doc
<+> Exp -> Doc
forall a. Ppr a => a -> Doc
ppr Exp
e2 Doc -> Doc -> Doc
<+> String -> Doc
text String
".."
                                             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
$ String -> Doc
text String
"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 = String -> Doc
text (String -> Doc) -> (a -> String) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

hashParens :: Doc -> Doc
hashParens :: Doc -> Doc
hashParens Doc
d = String -> Doc
text String
"(# " Doc -> Doc -> Doc
<> Doc
d Doc -> Doc -> Doc
<> String -> Doc
text String
" #)"

quoteParens :: Doc -> Doc
quoteParens :: Doc -> Doc
quoteParens Doc
d = String -> Doc
text String
"'(" Doc -> Doc -> Doc
<> Doc
d Doc -> Doc -> Doc
<> String -> Doc
text String
")"

-----------------------------
instance Ppr Loc where
  ppr :: Loc -> Doc
ppr (Loc { loc_module :: Loc -> String
loc_module = String
md
           , loc_package :: Loc -> String
loc_package = String
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 [ String -> Doc
text String
pkg, Doc
colon, String -> Doc
text String
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
           , String -> Doc
text String
"-"
           , 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
'|'