Ppr.hs 26.6 KB
Newer Older
aavogt's avatar
aavogt committed
1
-- | contains a prettyprinter for the
2 3 4 5 6 7 8
-- 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.

dterei's avatar
dterei committed
9
import Text.PrettyPrint (render)
10 11
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
reinerp's avatar
reinerp committed
12
import Data.Word ( Word8 )
13
import Data.Char ( toLower, chr, ord, isSymbol )
14
import GHC.Show  ( showMultiLineString )
15
import Data.Ratio ( numerator, denominator )
16 17 18 19 20

nestDepth :: Int
nestDepth = 4

type Precedence = Int
21 22 23 24
appPrec, unopPrec, opPrec, noPrec :: Precedence
appPrec = 3    -- Argument of a function application
opPrec  = 2    -- Argument of an infix operator
unopPrec = 1   -- Argument of an unresolved infix operator
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45
noPrec  = 0    -- Others

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

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

pprint :: Ppr a => a -> String
pprint x = render $ to_HPJ_Doc $ ppr x

class Ppr a where
    ppr :: a -> Doc
    ppr_list :: [a] -> Doc
    ppr_list = vcat . map ppr

instance Ppr a => Ppr [a] where
    ppr x = ppr_list x

------------------------------
instance Ppr Name where
Ian Lynagh's avatar
Ian Lynagh committed
46
    ppr v = pprName v
47 48 49

------------------------------
instance Ppr Info where
50 51 52
    ppr (TyConI d)     = ppr d
    ppr (ClassI d is)  = ppr d $$ vcat (map ppr is)
    ppr (FamilyI d is) = ppr d $$ vcat (map ppr is)
53
    ppr (PrimTyConI name arity is_unlifted)
54
      = text "Primitive"
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
55 56 57
        <+> (if is_unlifted then text "unlifted" else empty)
        <+> text "type constructor" <+> quotes (ppr name)
        <+> parens (text "arity" <+> int arity)
Ryan Scott's avatar
Ryan Scott committed
58 59 60 61
    ppr (ClassOpI v ty cls)
      = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty
    ppr (DataConI v ty tc)
      = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty
62 63
    ppr (TyVarI v ty)
      = text "Type variable" <+> ppr v <+> equals <+> ppr ty
Ryan Scott's avatar
Ryan Scott committed
64 65
    ppr (VarI v ty mb_d)
      = vcat [ppr_sig v ty,
66 67
              case mb_d of { Nothing -> empty; Just d -> ppr d }]

Ian Lynagh's avatar
Ian Lynagh committed
68
ppr_sig :: Name -> Type -> Doc
Jan Stolarek's avatar
Jan Stolarek committed
69
ppr_sig v ty = ppr v <+> dcolon <+> ppr ty
70 71

pprFixity :: Name -> Fixity -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
72
pprFixity _ f | f == defaultFixity = empty
73 74 75 76 77 78
pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
    where ppr_fix InfixR = text "infixr"
          ppr_fix InfixL = text "infixl"
          ppr_fix InfixN = text "infix"


79 80 81 82 83 84 85
------------------------------
instance Ppr Module where
  ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m)

instance Ppr ModuleInfo where
  ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps)

86 87 88 89
------------------------------
instance Ppr Exp where
    ppr = pprExp noPrec

90 91 92 93 94 95
pprPrefixOcc :: Name -> Doc
-- Print operators with parens around them
pprPrefixOcc n = parensIf (isSymOcc n) (ppr n)

isSymOcc :: Name -> Bool
isSymOcc n
96
  = case nameBase n of
97
      []    -> True  -- Empty name; weird
98
      (c:_) -> isSymbolASCII c || (ord c > 0x7f && isSymbol c)
99 100 101 102 103
                   -- c.f. OccName.startsVarSym in GHC itself

isSymbolASCII :: Char -> Bool
isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"

104
pprInfixExp :: Exp -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
105 106
pprInfixExp (VarE v) = pprName' Infix v
pprInfixExp (ConE v) = pprName' Infix v
107
pprInfixExp _        = text "<<Non-variable/constructor in infix context>>"
108

109
pprExp :: Precedence -> Exp -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
110 111
pprExp _ (VarE v)     = pprName' Applied v
pprExp _ (ConE c)     = pprName' Applied c
112 113 114
pprExp i (LitE l)     = pprLit i l
pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
                                              <+> pprExp appPrec e2
115 116 117 118 119
pprExp _ (ParensE e)  = parens (pprExp noPrec e)
pprExp i (UInfixE e1 op e2)
 = parensIf (i > unopPrec) $ pprExp unopPrec e1
                         <+> pprInfixExp op
                         <+> pprExp unopPrec e2
120 121
pprExp i (InfixE (Just e1) op (Just e2))
 = parensIf (i >= opPrec) $ pprExp opPrec e1
122
                        <+> pprInfixExp op
123 124
                        <+> pprExp opPrec e2
pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
125
                                    <+> pprInfixExp op
126
                                    <+> pprMaybeExp noPrec me2
127
pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
128
                                           <+> text "->" <+> ppr e
129 130
pprExp i (LamCaseE ms) = parensIf (i > noPrec)
                       $ text "\\case" $$ nest nestDepth (ppr ms)
131 132
pprExp _ (TupE es) = parens (commaSep es)
pprExp _ (UnboxedTupE es) = hashParens (commaSep es)
133 134 135 136 137
-- Nesting in Cond is to avoid potential problems in do statments
pprExp i (CondE guard true false)
 = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard,
                       nest 1 $ text "then" <+> ppr true,
                       nest 1 $ text "else" <+> ppr false]
138 139 140 141 142 143
pprExp i (MultiIfE alts)
  = parensIf (i > noPrec) $ vcat $
      case alts of
        []            -> [text "if {}"]
        (alt : alts') -> text "if" <+> pprGuarded arrow alt
                         : map (nest 3 . pprGuarded arrow) alts'
144 145 146 147 148
pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_
                                             $$ text " in" <+> ppr e
  where
    pprDecs []  = empty
    pprDecs [d] = ppr d
149
    pprDecs ds  = braces (semiSep ds)
150

151 152 153
pprExp i (CaseE e ms)
 = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
                        $$ nest nestDepth (ppr ms)
154 155 156 157
pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
  where
    pprStms []  = empty
    pprStms [s] = ppr s
158
    pprStms ss  = braces (semiSep ss)
159

160
pprExp _ (CompE []) = text "<<Empty CompExp>>"
161 162 163
-- This will probably break with fixity declarations - would need a ';'
pprExp _ (CompE ss) = text "[" <> ppr s
                  <+> text "|"
164
                  <+> commaSep ss'
165 166 167 168
                   <> text "]"
    where s = last ss
          ss' = init ss
pprExp _ (ArithSeqE d) = ppr d
169
pprExp _ (ListE es) = brackets (commaSep es)
Jan Stolarek's avatar
Jan Stolarek committed
170
pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t
171 172
pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
Facundo Domínguez's avatar
Facundo Domínguez committed
173 174
pprExp i (StaticE e) = parensIf (i >= appPrec) $
                         text "static"<+> pprExp appPrec e
175
pprExp _ (UnboundVarE v) = pprName' Applied v
176 177 178 179 180 181 182 183 184 185 186

pprFields :: [(Name,Exp)] -> Doc
pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)

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

------------------------------
instance Ppr Stmt where
    ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
187
    ppr (LetS ds) = text "let" <+> (braces (semiSep ds))
188 189
    ppr (NoBindS e) = ppr e
    ppr (ParS sss) = sep $ punctuate (text "|")
190
                         $ map commaSep sss
191 192 193 194 195 196

------------------------------
instance Ppr Match where
    ppr (Match p rhs ds) = ppr p <+> pprBody False rhs
                        $$ where_clause ds

197 198 199 200
------------------------------
pprGuarded :: Doc -> (Guard, Exp) -> Doc
pprGuarded eqDoc (guard, expr) = case guard of
  NormalG guardExpr -> char '|' <+> ppr guardExpr <+> eqDoc <+> ppr expr
201
  PatG    stmts     -> char '|' <+> vcat (punctuate comma $ map ppr stmts) $$
202 203
                         nest nestDepth (eqDoc <+> ppr expr)

204 205
------------------------------
pprBody :: Bool -> Body -> Doc
206 207 208 209 210
pprBody eq body = case body of
    GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs
    NormalB  e  -> eqDoc <+> ppr e
  where eqDoc | eq        = equals
              | otherwise = arrow
211 212

------------------------------
213 214 215
instance Ppr Lit where
  ppr = pprLit noPrec

216 217 218
pprLit :: Precedence -> Lit -> Doc
pprLit i (IntPrimL x)    = parensIf (i > noPrec && x < 0)
                                    (integer x <> char '#')
Ian Lynagh's avatar
Ian Lynagh committed
219
pprLit _ (WordPrimL x)    = integer x <> text "##"
220 221 222 223 224 225
pprLit i (FloatPrimL x)  = parensIf (i > noPrec && x < 0)
                                    (float (fromRational x) <> char '#')
pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)
                                    (double (fromRational x) <> text "##")
pprLit i (IntegerL x)    = parensIf (i > noPrec && x < 0) (integer x)
pprLit _ (CharL c)       = text (show c)
226
pprLit _ (CharPrimL c)   = text (show c) <> char '#'
227
pprLit _ (StringL s)     = pprString s
reinerp's avatar
reinerp committed
228
pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'
229
pprLit i (RationalL rat) = parensIf (i > noPrec) $
230
                           integer (numerator rat) <+> char '/'
231
                              <+> integer (denominator rat)
232

reinerp's avatar
reinerp committed
233 234 235
bytesToString :: [Word8] -> String
bytesToString = map (chr . fromIntegral)

236
pprString :: String -> Doc
237
-- Print newlines as newlines with Haskell string escape notation,
238 239 240
-- not as '\n'.  For other non-printables use regular escape notation.
pprString s = vcat (map text (showMultiLineString s))

241 242 243 244 245 246
------------------------------
instance Ppr Pat where
    ppr = pprPat noPrec

pprPat :: Precedence -> Pat -> Doc
pprPat i (LitP l)     = pprLit i l
Ian Lynagh's avatar
Ian Lynagh committed
247
pprPat _ (VarP v)     = pprName' Applied v
248 249
pprPat _ (TupP ps)    = parens (commaSep ps)
pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)
250 251
pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s
                                              <+> sep (map (pprPat appPrec) ps)
252 253 254 255 256
pprPat _ (ParensP p)  = parens $ pprPat noPrec p
pprPat i (UInfixP p1 n p2)
                      = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>
                                                 pprName' Infix n   <+>
                                                 pprPat unopPrec p2)
257
pprPat i (InfixP p1 n p2)
258 259 260
                      = parensIf (i >= opPrec) (pprPat opPrec p1 <+>
                                                pprName' Infix n <+>
                                                pprPat opPrec p2)
Stefan O'Rear's avatar
Stefan O'Rear committed
261
pprPat i (TildeP p)   = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
262
pprPat i (BangP p)    = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p
263 264 265 266 267 268 269
pprPat i (AsP v p)    = parensIf (i > noPrec) $ ppr v <> text "@"
                                                      <> pprPat appPrec p
pprPat _ WildP        = text "_"
pprPat _ (RecP nm fs)
 = parens $     ppr nm
            <+> braces (sep $ punctuate comma $
                        map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
270
pprPat _ (ListP ps) = brackets (commaSep ps)
Jan Stolarek's avatar
Jan Stolarek committed
271
pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t
reinerp's avatar
reinerp committed
272
pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p
273 274 275

------------------------------
instance Ppr Dec where
276 277 278
    ppr = ppr_dec True

ppr_dec :: Bool     -- declaration on the toplevel?
279
        -> Dec
280
        -> Doc
281
ppr_dec _ (FunD f cs)   = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs
282 283
ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r
                          $$ where_clause ds
284
ppr_dec _ (TySynD t xs rhs)
285
  = ppr_tySyn empty t (hsep (map ppr xs)) rhs
286 287 288 289
ppr_dec _ (DataD ctxt t xs ksig cs decs)
  = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs
ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
  = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs
290
ppr_dec _  (ClassD ctxt c xs fds ds)
291 292 293 294
  = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
    $$ where_clause ds
ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
                                  $$ where_clause ds
Jan Stolarek's avatar
Jan Stolarek committed
295
ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t
296 297 298
ppr_dec _ (ForeignD f)  = ppr f
ppr_dec _ (InfixD fx n) = pprFixity n fx
ppr_dec _ (PragmaD p)   = ppr p
Jan Stolarek's avatar
Jan Stolarek committed
299 300
ppr_dec isTop (DataFamilyD tc tvs kind)
  = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
301 302 303
  where
    maybeFamily | isTop     = text "family"
                | otherwise = empty
Jan Stolarek's avatar
Jan Stolarek committed
304 305
    maybeKind | (Just k') <- kind = dcolon <+> ppr k'
              | otherwise = empty
306 307
ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs)
  = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs
308 309 310
  where
    maybeInst | isTop     = text "instance"
              | otherwise = empty
311 312
ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs)
  = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs
313 314 315
  where
    maybeInst | isTop     = text "instance"
              | otherwise = empty
316
ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
317 318 319 320
  = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
  where
    maybeInst | isTop     = text "instance"
              | otherwise = empty
321 322
ppr_dec isTop (OpenTypeFamilyD tfhead)
  = text "type" <+> maybeFamily <+> ppr_tf_head tfhead
Jan Stolarek's avatar
Jan Stolarek committed
323 324 325
  where
    maybeFamily | isTop     = text "family"
                | otherwise = empty
326 327
ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
  = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")
328 329
      nestDepth (vcat (map ppr_eqn eqns))
  where
330 331
    ppr_eqn (TySynEqn lhs rhs)
      = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
332

333 334
ppr_dec _ (RoleAnnotD name roles)
  = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
335

336 337 338
ppr_dec _ (StandaloneDerivD cxt ty)
  = hsep [ text "deriving instance", pprCxt cxt, ppr ty ]

339
ppr_dec _ (DefaultSigD n ty)
Jan Stolarek's avatar
Jan Stolarek committed
340
  = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
341

342 343
ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc
ppr_data maybeInst ctxt t argsDoc ksig cs decs
344
  = sep [text "data" <+> maybeInst
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
345
            <+> pprCxt ctxt
346
            <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere,
347 348 349 350
         nest nestDepth (sep (pref $ map ppr cs)),
         if null decs
           then empty
           else nest nestDepth
351
              $ text "deriving" <+> ppr_cxt_preds decs]
352
  where
353
    pref :: [Doc] -> [Doc]
354 355 356 357 358 359 360 361 362 363
    pref xs | isGadtDecl = xs
    pref []              = []      -- No constructors; can't happen in H98
    pref (d:ds)          = (char '=' <+> d):map (char '|' <+>) ds

    maybeWhere :: Doc
    maybeWhere | isGadtDecl = text "where"
               | otherwise  = empty

    isGadtDecl :: Bool
    isGadtDecl = not (null cs) && all isGadtCon cs
364 365 366 367
        where isGadtCon (GadtC _ _ _   ) = True
              isGadtCon (RecGadtC _ _ _) = True
              isGadtCon (ForallC _ _ x ) = isGadtCon x
              isGadtCon  _               = False
368 369 370 371 372 373 374

    ksigDoc = case ksig of
                Nothing -> empty
                Just k  -> dcolon <+> ppr k

ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> Cxt -> Doc
ppr_newtype maybeInst ctxt t argsDoc ksig c decs
375
  = sep [text "newtype" <+> maybeInst
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
376
            <+> pprCxt ctxt
377
            <+> ppr t <+> argsDoc <+> ksigDoc,
378 379
         nest 2 (char '=' <+> ppr c),
         if null decs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
380 381
           then empty
           else nest nestDepth
382
                $ text "deriving" <+> ppr_cxt_preds decs]
383 384 385 386
  where
    ksigDoc = case ksig of
                Nothing -> empty
                Just k  -> dcolon <+> ppr k
387 388 389 390

ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
ppr_tySyn maybeInst t argsDoc rhs
  = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs
391

392 393 394 395 396 397 398
ppr_tf_head :: TypeFamilyHead -> Doc
ppr_tf_head (TypeFamilyHead tc tvs res inj)
  = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj
  where
    maybeInj | (Just inj') <- inj = ppr inj'
             | otherwise          = empty

399 400 401
------------------------------
instance Ppr FunDep where
    ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
402
    ppr_list [] = empty
403
    ppr_list xs = char '|' <+> commaSep xs
404

405 406 407 408 409
------------------------------
instance Ppr FamFlavour where
    ppr DataFam = text "data"
    ppr TypeFam = text "type"

Jan Stolarek's avatar
Jan Stolarek committed
410 411 412 413 414 415 416 417 418 419 420
------------------------------
instance Ppr FamilyResultSig where
    ppr NoSig           = empty
    ppr (KindSig k)     = dcolon <+> ppr k
    ppr (TyVarSig bndr) = text "=" <+> ppr bndr

------------------------------
instance Ppr InjectivityAnn where
    ppr (InjectivityAnn lhs rhs) =
        char '|' <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)

421 422 423 424 425 426 427 428
------------------------------
instance Ppr Foreign where
    ppr (ImportF callconv safety impent as typ)
       = text "foreign import"
     <+> showtextl callconv
     <+> showtextl safety
     <+> text (show impent)
     <+> ppr as
Jan Stolarek's avatar
Jan Stolarek committed
429
     <+> dcolon <+> ppr typ
430 431 432 433 434
    ppr (ExportF callconv expent as typ)
        = text "foreign export"
      <+> showtextl callconv
      <+> text (show expent)
      <+> ppr as
Jan Stolarek's avatar
Jan Stolarek committed
435
      <+> dcolon <+> ppr typ
436

437 438
------------------------------
instance Ppr Pragma where
439
    ppr (InlineP n inline rm phases)
440
       = text "{-#"
441
     <+> ppr inline
442 443
     <+> ppr rm
     <+> ppr phases
444 445
     <+> ppr n
     <+> text "#-}"
446 447 448 449
    ppr (SpecialiseP n ty inline phases)
       =   text "{-# SPECIALISE"
       <+> maybe empty ppr inline
       <+> ppr phases
Jan Stolarek's avatar
Jan Stolarek committed
450
       <+> sep [ ppr n <+> dcolon
451 452 453 454 455 456 457 458 459 460 461 462
               , nest 2 $ ppr ty ]
       <+> text "#-}"
    ppr (SpecialiseInstP inst)
       = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
    ppr (RuleP n bndrs lhs rhs phases)
       = sep [ text "{-# RULES" <+> pprString n <+> ppr phases
             , nest 4 $ ppr_forall <+> ppr lhs
             , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
      where ppr_forall | null bndrs =   empty
                       | otherwise  =   text "forall"
                                    <+> fsep (map ppr bndrs)
                                    <+> char '.'
463 464 465 466 467
    ppr (AnnP tgt expr)
       = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
      where target1 ModuleAnnotation    = text "module"
            target1 (TypeAnnotation t)  = text "type" <+> ppr t
            target1 (ValueAnnotation v) = ppr v
468 469
    ppr (LineP line file)
       = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"
470

471 472 473 474 475 476
------------------------------
instance Ppr Inline where
    ppr NoInline  = text "NOINLINE"
    ppr Inline    = text "INLINE"
    ppr Inlinable = text "INLINABLE"

477 478 479 480 481 482 483 484 485 486 487 488 489 490
------------------------------
instance Ppr RuleMatch where
    ppr ConLike = text "CONLIKE"
    ppr FunLike = empty

------------------------------
instance Ppr Phases where
    ppr AllPhases       = empty
    ppr (FromPhase i)   = brackets $ int i
    ppr (BeforePhase i) = brackets $ char '~' <> int i

------------------------------
instance Ppr RuleBndr where
    ppr (RuleVar n)         = ppr n
Jan Stolarek's avatar
Jan Stolarek committed
491
    ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty
492

493 494
------------------------------
instance Ppr Clause where
495 496
    ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
                             $$ where_clause ds
497 498 499

------------------------------
instance Ppr Con where
500
    ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts)
501

502
    ppr (RecC c vsts)
503
        = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))
504

505
    ppr (InfixC st1 c st2) = pprBangType st1
Ian Lynagh's avatar
Ian Lynagh committed
506
                         <+> pprName' Infix c
507
                         <+> pprBangType st2
508

509 510
    ppr (ForallC ns ctxt (GadtC c sts ty))
        = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty
511

512
    ppr (ForallC ns ctxt (RecGadtC c vsts ty))
513
        = commaSep c <+> dcolon <+> pprForall ns ctxt
514
      <+> pprRecFields vsts ty
515 516 517 518

    ppr (ForallC ns ctxt con)
        = pprForall ns ctxt <+> ppr con

519 520
    ppr (GadtC c sts ty)
        = commaSep c <+> dcolon <+> pprGadtRHS sts ty
521

522 523
    ppr (RecGadtC c vsts ty)
        = commaSep c <+> dcolon <+> pprRecFields vsts ty
524 525 526 527 528 529

pprForall :: [TyVarBndr] -> Cxt -> Doc
pprForall ns ctxt
    = text "forall" <+> hsep (map ppr ns)
  <+> char '.' <+> pprCxt ctxt

530 531
pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
pprRecFields vsts ty
532
    = braces (sep (punctuate comma $ map pprVarBangType vsts))
533
  <+> arrow <+> ppr ty
534

535 536 537 538
pprGadtRHS :: [(Strict, Type)] -> Type -> Doc
pprGadtRHS [] ty
    = ppr ty
pprGadtRHS sts ty
539
    = sep (punctuate (space <> arrow) (map pprBangType sts))
540
  <+> arrow <+> ppr ty
541 542

------------------------------
543
pprVarBangType :: VarBangType -> Doc
544
-- Slight infelicity: with print non-atomic type with parens
545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588
pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, 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 (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t
pprBangType (bt, t) = ppr bt <> pprParendType t

------------------------------
instance Ppr Bang where
    ppr (Bang su ss) = ppr su <+> ppr ss

------------------------------
instance Ppr SourceUnpackedness where
    ppr NoSourceUnpackedness = empty
    ppr SourceNoUnpack       = text "{-# NOUNPACK #-}"
    ppr SourceUnpack         = text "{-# UNPACK #-}"

------------------------------
instance Ppr SourceStrictness where
    ppr NoSourceStrictness = empty
    ppr SourceLazy         = char '~'
    ppr SourceStrict       = char '!'

------------------------------
instance Ppr DecidedStrictness where
    ppr DecidedLazy   = empty
    ppr DecidedStrict = char '!'
    ppr DecidedUnpack = text "{-# 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 = pprVarBangType
589 590

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

------------------------------
pprParendType :: Type -> Doc
598 599 600 601 602 603 604 605 606 607 608 609 610 611 612
pprParendType (VarT v)            = ppr v
pprParendType (ConT c)            = ppr c
pprParendType (TupleT 0)          = text "()"
pprParendType (TupleT n)          = parens (hcat (replicate (n-1) comma))
pprParendType (UnboxedTupleT n)   = hashParens $ hcat $ replicate (n-1) comma
pprParendType ArrowT              = parens (text "->")
pprParendType ListT               = text "[]"
pprParendType (LitT l)            = pprTyLit l
pprParendType (PromotedT c)       = text "'" <> ppr c
pprParendType (PromotedTupleT 0)  = text "'()"
pprParendType (PromotedTupleT n)  = quoteParens (hcat (replicate (n-1) comma))
pprParendType PromotedNilT        = text "'[]"
pprParendType PromotedConsT       = text "(':)"
pprParendType StarT               = char '*'
pprParendType ConstraintT         = text "Constraint"
613
pprParendType (SigT ty k)         = parens (ppr ty <+> text "::" <+> ppr k)
614
pprParendType WildCardT           = char '_'
615 616 617
pprParendType (InfixT x n y)      = parens (ppr x <+> pprName' Infix n <+> ppr y)
pprParendType t@(UInfixT {})      = parens (pprUInfixT t)
pprParendType (ParensT t)         = ppr t
618 619 620
pprParendType tuple | (TupleT n, args) <- split tuple
                    , length args == n
                    = parens (commaSep args)
621
pprParendType other               = parens (ppr other)
622

623 624 625 626
pprUInfixT :: Type -> Doc
pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
pprUInfixT t               = ppr t

627
instance Ppr Type where
628 629
    ppr (ForallT tvars ctxt ty)
      = text "forall" <+> hsep (map ppr tvars) <+> text "."
630
                      <+> sep [pprCxt ctxt, ppr ty]
631 632 633 634 635 636 637 638 639 640 641 642
    ppr ty = pprTyApp (split ty)
       -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind)
       -- See Note [Pretty-printing kind signatures]

{- 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 Trac #10050). -}

643
pprTyApp :: (Type, [Type]) -> Doc
644
pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
645 646
pprTyApp (EqualityT, [arg1, arg2]) =
    sep [pprFunArgType arg1 <+> text "~", ppr arg2]
647 648
pprTyApp (ListT, [arg]) = brackets (ppr arg)
pprTyApp (TupleT n, args)
649
 | length args == n = parens (commaSep args)
650
pprTyApp (PromotedTupleT n, args)
651
 | length args == n = quoteParens (commaSep args)
652 653
pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
654
pprFunArgType :: Type -> Doc    -- Should really use a precedence argument
655 656 657
-- Everything except forall and (->) binds more tightly than (->)
pprFunArgType ty@(ForallT {})                 = parens (ppr ty)
pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
658
pprFunArgType ty@(SigT _ _)                   = parens (ppr ty)
659 660
pprFunArgType ty                              = ppr ty

661 662 663 664 665
split :: Type -> (Type, [Type])    -- Split into function and args
split t = go t []
    where go (AppT t1 t2) args = go t1 (t2:args)
          go ty           args = (ty, args)

Iavor S. Diatchki's avatar
Iavor S. Diatchki committed
666
pprTyLit :: TyLit -> Doc
667 668
pprTyLit (NumTyLit n) = integer n
pprTyLit (StrTyLit s) = text (show s)
Iavor S. Diatchki's avatar
Iavor S. Diatchki committed
669 670 671 672

instance Ppr TyLit where
  ppr = pprTyLit

673 674 675
------------------------------
instance Ppr TyVarBndr where
    ppr (PlainTV nm)    = ppr nm
Jan Stolarek's avatar
Jan Stolarek committed
676
    ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k)
677 678

instance Ppr Role where
679 680 681 682
    ppr NominalR          = text "nominal"
    ppr RepresentationalR = text "representational"
    ppr PhantomR          = text "phantom"
    ppr InferR            = text "_"
683

684 685 686
------------------------------
pprCxt :: Cxt -> Doc
pprCxt [] = empty
687 688 689 690 691
pprCxt ts = ppr_cxt_preds ts <+> text "=>"

ppr_cxt_preds :: Cxt -> Doc
ppr_cxt_preds [] = empty
ppr_cxt_preds [t] = ppr t
692
ppr_cxt_preds ts = parens (commaSep ts)
693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708

------------------------------
instance Ppr Range where
    ppr = brackets . pprRange
        where pprRange :: Range -> Doc
              pprRange (FromR e) = ppr e <> text ".."
              pprRange (FromThenR e1 e2) = ppr e1 <> text ","
                                        <> ppr e2 <> text ".."
              pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2
              pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","
                                             <> ppr e2 <> text ".."
                                             <> ppr e3

------------------------------
where_clause :: [Dec] -> Doc
where_clause [] = empty
709
where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds)
710 711 712 713

showtextl :: Show a => a -> Doc
showtextl = text . map toLower . show

714 715 716
hashParens :: Doc -> Doc
hashParens d = text "(# " <> d <> text " #)"

717 718
quoteParens :: Doc -> Doc
quoteParens d = text "'(" <> d <> text ")"
719 720 721 722 723 724 725 726 727 728 729

-----------------------------
instance Ppr Loc where
  ppr (Loc { loc_module = md
           , loc_package = pkg
           , loc_start = (start_ln, start_col)
           , loc_end = (end_ln, end_col) })
    = hcat [ text pkg, colon, text md, colon
           , parens $ int start_ln <> comma <> int start_col
           , text "-"
           , parens $ int end_ln <> comma <> int end_col ]
730 731 732 733 734 735 736 737 738 739

-- Takes a list of printable things and prints them separated by commas followed
-- by space.
commaSep :: Ppr a => [a] -> Doc
commaSep = sep . punctuate comma . map ppr

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