Ppr.hs 27.2 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
69
ppr_sig v ty = pprName' Applied 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
  = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
    $$ where_clause ds
293 294
ppr_dec _ (InstanceD o ctxt i ds) =
        text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
295
                                  $$ where_clause ds
Jan Stolarek's avatar
Jan Stolarek committed
296
ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t
297 298 299
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
300 301
ppr_dec isTop (DataFamilyD tc tvs kind)
  = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
302 303 304
  where
    maybeFamily | isTop     = text "family"
                | otherwise = empty
Jan Stolarek's avatar
Jan Stolarek committed
305 306
    maybeKind | (Just k') <- kind = dcolon <+> ppr k'
              | otherwise = empty
307 308
ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs)
  = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs
309 310 311
  where
    maybeInst | isTop     = text "instance"
              | otherwise = empty
312 313
ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs)
  = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs
314 315 316
  where
    maybeInst | isTop     = text "instance"
              | otherwise = empty
317
ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
318 319 320 321
  = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
  where
    maybeInst | isTop     = text "instance"
              | otherwise = empty
322 323
ppr_dec isTop (OpenTypeFamilyD tfhead)
  = text "type" <+> maybeFamily <+> ppr_tf_head tfhead
Jan Stolarek's avatar
Jan Stolarek committed
324 325 326
  where
    maybeFamily | isTop     = text "family"
                | otherwise = empty
327 328
ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
  = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")
329 330
      nestDepth (vcat (map ppr_eqn eqns))
  where
331 332
    ppr_eqn (TySynEqn lhs rhs)
      = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
333

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

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

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

343 344 345 346 347 348 349 350 351

ppr_overlap :: Overlap -> Doc
ppr_overlap o = text $
  case o of
    Overlaps      -> "{-# OVERLAPS #-}"
    Overlappable  -> "{-# OVERLAPPABLE #-}"
    Overlapping   -> "{-# OVERLAPPING #-}"
    Incoherent    -> "{-# INCOHERENT #-}"

352 353
ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc
ppr_data maybeInst ctxt t argsDoc ksig cs decs
354
  = sep [text "data" <+> maybeInst
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
355
            <+> pprCxt ctxt
356
            <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere,
357 358 359 360
         nest nestDepth (sep (pref $ map ppr cs)),
         if null decs
           then empty
           else nest nestDepth
361
              $ text "deriving" <+> ppr_cxt_preds decs]
362
  where
363
    pref :: [Doc] -> [Doc]
364 365 366 367 368 369 370 371 372 373
    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
374 375 376 377
        where isGadtCon (GadtC _ _ _   ) = True
              isGadtCon (RecGadtC _ _ _) = True
              isGadtCon (ForallC _ _ x ) = isGadtCon x
              isGadtCon  _               = False
378 379 380 381 382 383 384

    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
385
  = sep [text "newtype" <+> maybeInst
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
386
            <+> pprCxt ctxt
387
            <+> ppr t <+> argsDoc <+> ksigDoc,
388 389
         nest 2 (char '=' <+> ppr c),
         if null decs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
390 391
           then empty
           else nest nestDepth
392
                $ text "deriving" <+> ppr_cxt_preds decs]
393 394 395 396
  where
    ksigDoc = case ksig of
                Nothing -> empty
                Just k  -> dcolon <+> ppr k
397 398 399 400

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

402 403 404 405 406 407 408
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

409 410 411
------------------------------
instance Ppr FunDep where
    ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
412
    ppr_list [] = empty
413
    ppr_list xs = char '|' <+> commaSep xs
414

415 416 417 418 419
------------------------------
instance Ppr FamFlavour where
    ppr DataFam = text "data"
    ppr TypeFam = text "type"

Jan Stolarek's avatar
Jan Stolarek committed
420 421 422 423 424 425 426 427 428 429 430
------------------------------
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)

431 432 433 434 435 436 437 438
------------------------------
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
439
     <+> dcolon <+> ppr typ
440 441 442 443 444
    ppr (ExportF callconv expent as typ)
        = text "foreign export"
      <+> showtextl callconv
      <+> text (show expent)
      <+> ppr as
Jan Stolarek's avatar
Jan Stolarek committed
445
      <+> dcolon <+> ppr typ
446

447 448
------------------------------
instance Ppr Pragma where
449
    ppr (InlineP n inline rm phases)
450
       = text "{-#"
451
     <+> ppr inline
452 453
     <+> ppr rm
     <+> ppr phases
454 455
     <+> ppr n
     <+> text "#-}"
456 457 458 459
    ppr (SpecialiseP n ty inline phases)
       =   text "{-# SPECIALISE"
       <+> maybe empty ppr inline
       <+> ppr phases
Jan Stolarek's avatar
Jan Stolarek committed
460
       <+> sep [ ppr n <+> dcolon
461 462 463 464 465 466 467 468 469 470 471 472
               , 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 '.'
473 474 475 476 477
    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
478 479
    ppr (LineP line file)
       = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"
480

481 482 483 484 485 486
------------------------------
instance Ppr Inline where
    ppr NoInline  = text "NOINLINE"
    ppr Inline    = text "INLINE"
    ppr Inlinable = text "INLINABLE"

487 488 489 490 491 492 493 494 495 496 497 498 499 500
------------------------------
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
501
    ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty
502

503 504
------------------------------
instance Ppr Clause where
505 506
    ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
                             $$ where_clause ds
507 508 509

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

512
    ppr (RecC c vsts)
513
        = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))
514

515
    ppr (InfixC st1 c st2) = pprBangType st1
Ian Lynagh's avatar
Ian Lynagh committed
516
                         <+> pprName' Infix c
517
                         <+> pprBangType st2
518

519
    ppr (ForallC ns ctxt (GadtC c sts ty))
520 521
        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
      <+> pprGadtRHS sts ty
522

523
    ppr (ForallC ns ctxt (RecGadtC c vsts ty))
524
        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
525
      <+> pprRecFields vsts ty
526 527 528 529

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

530
    ppr (GadtC c sts ty)
531
        = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty
532

533
    ppr (RecGadtC c vsts ty)
534 535 536 537
        = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty

commaSepApplied :: [Name] -> Doc
commaSepApplied = commaSepWith (pprName' Applied)
538 539 540 541 542 543

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

544 545
pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
pprRecFields vsts ty
546
    = braces (sep (punctuate comma $ map pprVarBangType vsts))
547
  <+> arrow <+> ppr ty
548

549 550 551 552
pprGadtRHS :: [(Strict, Type)] -> Type -> Doc
pprGadtRHS [] ty
    = ppr ty
pprGadtRHS sts ty
553
    = sep (punctuate (space <> arrow) (map pprBangType sts))
554
  <+> arrow <+> ppr ty
555 556

------------------------------
557
pprVarBangType :: VarBangType -> Doc
558
-- Slight infelicity: with print non-atomic type with parens
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 589 590 591 592 593 594 595 596 597 598 599 600 601 602
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
603 604

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

------------------------------
pprParendType :: Type -> Doc
612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
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"
627
pprParendType (SigT ty k)         = parens (ppr ty <+> text "::" <+> ppr k)
628
pprParendType WildCardT           = char '_'
629 630 631
pprParendType (InfixT x n y)      = parens (ppr x <+> pprName' Infix n <+> ppr y)
pprParendType t@(UInfixT {})      = parens (pprUInfixT t)
pprParendType (ParensT t)         = ppr t
632 633 634
pprParendType tuple | (TupleT n, args) <- split tuple
                    , length args == n
                    = parens (commaSep args)
635
pprParendType other               = parens (ppr other)
636

637 638 639 640
pprUInfixT :: Type -> Doc
pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
pprUInfixT t               = ppr t

641
instance Ppr Type where
642 643
    ppr (ForallT tvars ctxt ty)
      = text "forall" <+> hsep (map ppr tvars) <+> text "."
644
                      <+> sep [pprCxt ctxt, ppr ty]
645 646 647 648 649 650 651 652 653 654 655 656
    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). -}

657
pprTyApp :: (Type, [Type]) -> Doc
658
pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
659 660
pprTyApp (EqualityT, [arg1, arg2]) =
    sep [pprFunArgType arg1 <+> text "~", ppr arg2]
661 662
pprTyApp (ListT, [arg]) = brackets (ppr arg)
pprTyApp (TupleT n, args)
663
 | length args == n = parens (commaSep args)
664
pprTyApp (PromotedTupleT n, args)
665
 | length args == n = quoteParens (commaSep args)
666 667
pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
668
pprFunArgType :: Type -> Doc    -- Should really use a precedence argument
669 670 671
-- Everything except forall and (->) binds more tightly than (->)
pprFunArgType ty@(ForallT {})                 = parens (ppr ty)
pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
672
pprFunArgType ty@(SigT _ _)                   = parens (ppr ty)
673 674
pprFunArgType ty                              = ppr ty

675 676 677 678 679
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
680
pprTyLit :: TyLit -> Doc
681 682
pprTyLit (NumTyLit n) = integer n
pprTyLit (StrTyLit s) = text (show s)
Iavor S. Diatchki's avatar
Iavor S. Diatchki committed
683 684 685 686

instance Ppr TyLit where
  ppr = pprTyLit

687 688 689
------------------------------
instance Ppr TyVarBndr where
    ppr (PlainTV nm)    = ppr nm
Jan Stolarek's avatar
Jan Stolarek committed
690
    ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k)
691 692

instance Ppr Role where
693 694 695 696
    ppr NominalR          = text "nominal"
    ppr RepresentationalR = text "representational"
    ppr PhantomR          = text "phantom"
    ppr InferR            = text "_"
697

698 699 700
------------------------------
pprCxt :: Cxt -> Doc
pprCxt [] = empty
701 702 703 704 705
pprCxt ts = ppr_cxt_preds ts <+> text "=>"

ppr_cxt_preds :: Cxt -> Doc
ppr_cxt_preds [] = empty
ppr_cxt_preds [t] = ppr t
706
ppr_cxt_preds ts = parens (commaSep ts)
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722

------------------------------
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
723
where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds)
724 725 726 727

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

728 729 730
hashParens :: Doc -> Doc
hashParens d = text "(# " <> d <> text " #)"

731 732
quoteParens :: Doc -> Doc
quoteParens d = text "'(" <> d <> text ")"
733 734 735 736 737 738 739 740 741 742 743

-----------------------------
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 ]
744 745 746 747

-- Takes a list of printable things and prints them separated by commas followed
-- by space.
commaSep :: Ppr a => [a] -> Doc
748 749 750 751 752 753
commaSep = commaSepWith 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 pprFun = sep . punctuate comma . map pprFun
754 755 756 757 758

-- 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