1{-# LANGUAGE Safe #-} 2-- | contains a prettyprinter for the 3-- Template Haskell datatypes 4 5module Language.Haskell.TH.Ppr where 6 -- All of the exports from this module should 7 -- be "public" functions. The main module TH 8 -- re-exports them all. 9 10import Text.PrettyPrint (render) 11import Language.Haskell.TH.PprLib 12import Language.Haskell.TH.Syntax 13import Data.Word ( Word8 ) 14import Data.Char ( toLower, chr) 15import GHC.Show ( showMultiLineString ) 16import GHC.Lexeme( startsVarSym ) 17import Data.Ratio ( numerator, denominator ) 18import Prelude hiding ((<>)) 19 20nestDepth :: Int 21nestDepth = 4 22 23type Precedence = Int 24appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence 25appPrec = 4 -- Argument of a function application 26opPrec = 3 -- Argument of an infix operator 27unopPrec = 2 -- Argument of an unresolved infix operator 28sigPrec = 1 -- Argument of an explicit type signature 29noPrec = 0 -- Others 30 31parensIf :: Bool -> Doc -> Doc 32parensIf True d = parens d 33parensIf False d = d 34 35------------------------------ 36 37pprint :: Ppr a => a -> String 38pprint x = render $ to_HPJ_Doc $ ppr x 39 40class Ppr a where 41 ppr :: a -> Doc 42 ppr_list :: [a] -> Doc 43 ppr_list = vcat . map ppr 44 45instance Ppr a => Ppr [a] where 46 ppr x = ppr_list x 47 48------------------------------ 49instance Ppr Name where 50 ppr v = pprName v 51 52------------------------------ 53instance Ppr Info where 54 ppr (TyConI d) = ppr d 55 ppr (ClassI d is) = ppr d $$ vcat (map ppr is) 56 ppr (FamilyI d is) = ppr d $$ vcat (map ppr is) 57 ppr (PrimTyConI name arity is_unlifted) 58 = text "Primitive" 59 <+> (if is_unlifted then text "unlifted" else empty) 60 <+> text "type constructor" <+> quotes (ppr name) 61 <+> parens (text "arity" <+> int arity) 62 ppr (ClassOpI v ty cls) 63 = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty 64 ppr (DataConI v ty tc) 65 = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty 66 ppr (PatSynI nm ty) = pprPatSynSig nm ty 67 ppr (TyVarI v ty) 68 = text "Type variable" <+> ppr v <+> equals <+> ppr ty 69 ppr (VarI v ty mb_d) 70 = vcat [ppr_sig v ty, 71 case mb_d of { Nothing -> empty; Just d -> ppr d }] 72 73ppr_sig :: Name -> Type -> Doc 74ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty 75 76pprFixity :: Name -> Fixity -> Doc 77pprFixity _ f | f == defaultFixity = empty 78pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v 79 where ppr_fix InfixR = text "infixr" 80 ppr_fix InfixL = text "infixl" 81 ppr_fix InfixN = text "infix" 82 83-- | Pretty prints a pattern synonym type signature 84pprPatSynSig :: Name -> PatSynType -> Doc 85pprPatSynSig nm ty 86 = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty 87 88-- | Pretty prints a pattern synonym's type; follows the usual 89-- conventions to print a pattern synonym type compactly, yet 90-- unambiguously. See the note on 'PatSynType' and the section on 91-- pattern synonyms in the GHC user's guide for more information. 92pprPatSynType :: PatSynType -> Doc 93pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty'')) 94 | null exTys, null provs = ppr (ForallT uniTys reqs ty'') 95 | null uniTys, null reqs = noreqs <+> ppr ty' 96 | null reqs = forall uniTys <+> noreqs <+> ppr ty' 97 | otherwise = ppr ty 98 where noreqs = text "() =>" 99 forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "." 100pprPatSynType ty = ppr ty 101 102------------------------------ 103instance Ppr Module where 104 ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m) 105 106instance Ppr ModuleInfo where 107 ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps) 108 109------------------------------ 110instance Ppr Exp where 111 ppr = pprExp noPrec 112 113pprPrefixOcc :: Name -> Doc 114-- Print operators with parens around them 115pprPrefixOcc n = parensIf (isSymOcc n) (ppr n) 116 117isSymOcc :: Name -> Bool 118isSymOcc n 119 = case nameBase n of 120 [] -> True -- Empty name; weird 121 (c:_) -> startsVarSym c 122 -- c.f. OccName.startsVarSym in GHC itself 123 124pprInfixExp :: Exp -> Doc 125pprInfixExp (VarE v) = pprName' Infix v 126pprInfixExp (ConE v) = pprName' Infix v 127pprInfixExp (UnboundVarE v) = pprName' Infix v 128-- This case will only ever be reached in exceptional circumstances. 129-- For example, when printing an error message in case of a malformed expression. 130pprInfixExp e = text "`" <> ppr e <> text "`" 131 132pprExp :: Precedence -> Exp -> Doc 133pprExp _ (VarE v) = pprName' Applied v 134pprExp _ (ConE c) = pprName' Applied c 135pprExp i (LitE l) = pprLit i l 136pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1 137 <+> pprExp appPrec e2 138pprExp i (AppTypeE e t) 139 = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t 140pprExp _ (ParensE e) = parens (pprExp noPrec e) 141pprExp i (UInfixE e1 op e2) 142 = parensIf (i > unopPrec) $ pprExp unopPrec e1 143 <+> pprInfixExp op 144 <+> pprExp unopPrec e2 145pprExp i (InfixE (Just e1) op (Just e2)) 146 = parensIf (i >= opPrec) $ pprExp opPrec e1 147 <+> pprInfixExp op 148 <+> pprExp opPrec e2 149pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1 150 <+> pprInfixExp op 151 <+> pprMaybeExp noPrec me2 152pprExp i (LamE [] e) = pprExp i e -- #13856 153pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps) 154 <+> text "->" <+> ppr e 155pprExp i (LamCaseE ms) = parensIf (i > noPrec) 156 $ text "\\case" $$ nest nestDepth (ppr ms) 157pprExp i (TupE es) 158 | [Just e] <- es 159 = pprExp i (ConE (tupleDataName 1) `AppE` e) 160 | otherwise 161 = parens (commaSepWith (pprMaybeExp noPrec) es) 162pprExp _ (UnboxedTupE es) = hashParens (commaSepWith (pprMaybeExp noPrec) es) 163pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity 164-- Nesting in Cond is to avoid potential problems in do statements 165pprExp i (CondE guard true false) 166 = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard, 167 nest 1 $ text "then" <+> ppr true, 168 nest 1 $ text "else" <+> ppr false] 169pprExp i (MultiIfE alts) 170 = parensIf (i > noPrec) $ vcat $ 171 case alts of 172 [] -> [text "if {}"] 173 (alt : alts') -> text "if" <+> pprGuarded arrow alt 174 : map (nest 3 . pprGuarded arrow) alts' 175pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_ 176 $$ text " in" <+> ppr e 177 where 178 pprDecs [] = empty 179 pprDecs [d] = ppr d 180 pprDecs ds = braces (semiSep ds) 181 182pprExp i (CaseE e ms) 183 = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of" 184 $$ nest nestDepth (ppr ms) 185pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_ 186 where 187 pprStms [] = empty 188 pprStms [s] = ppr s 189 pprStms ss = braces (semiSep ss) 190pprExp i (MDoE ss_) = parensIf (i > noPrec) $ text "mdo" <+> pprStms ss_ 191 where 192 pprStms [] = empty 193 pprStms [s] = ppr s 194 pprStms ss = braces (semiSep ss) 195 196pprExp _ (CompE []) = text "<<Empty CompExp>>" 197-- This will probably break with fixity declarations - would need a ';' 198pprExp _ (CompE ss) = 199 if null ss' 200 -- If there are no statements in a list comprehension besides the last 201 -- one, we simply treat it like a normal list. 202 then text "[" <> ppr s <> text "]" 203 else text "[" <> ppr s 204 <+> bar 205 <+> commaSep ss' 206 <> text "]" 207 where s = last ss 208 ss' = init ss 209pprExp _ (ArithSeqE d) = ppr d 210pprExp _ (ListE es) = brackets (commaSep es) 211pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e 212 <+> dcolon <+> ppr t 213pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) 214pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) 215pprExp i (StaticE e) = parensIf (i >= appPrec) $ 216 text "static"<+> pprExp appPrec e 217pprExp _ (UnboundVarE v) = pprName' Applied v 218pprExp _ (LabelE s) = text "#" <> text s 219pprExp _ (ImplicitParamVarE n) = text ('?' : n) 220 221pprFields :: [(Name,Exp)] -> Doc 222pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) 223 224pprMaybeExp :: Precedence -> Maybe Exp -> Doc 225pprMaybeExp _ Nothing = empty 226pprMaybeExp i (Just e) = pprExp i e 227 228------------------------------ 229instance Ppr Stmt where 230 ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e 231 ppr (LetS ds) = text "let" <+> (braces (semiSep ds)) 232 ppr (NoBindS e) = ppr e 233 ppr (ParS sss) = sep $ punctuate bar 234 $ map commaSep sss 235 ppr (RecS ss) = text "rec" <+> (braces (semiSep ss)) 236 237------------------------------ 238instance Ppr Match where 239 ppr (Match p rhs ds) = pprMatchPat p <+> pprBody False rhs 240 $$ where_clause ds 241 242pprMatchPat :: Pat -> Doc 243-- Everything except pattern signatures bind more tightly than (->) 244pprMatchPat p@(SigP {}) = parens (ppr p) 245pprMatchPat p = ppr p 246 247------------------------------ 248pprGuarded :: Doc -> (Guard, Exp) -> Doc 249pprGuarded eqDoc (guard, expr) = case guard of 250 NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr 251 PatG stmts -> bar <+> vcat (punctuate comma $ map ppr stmts) $$ 252 nest nestDepth (eqDoc <+> ppr expr) 253 254------------------------------ 255pprBody :: Bool -> Body -> Doc 256pprBody eq body = case body of 257 GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs 258 NormalB e -> eqDoc <+> ppr e 259 where eqDoc | eq = equals 260 | otherwise = arrow 261 262------------------------------ 263instance Ppr Lit where 264 ppr = pprLit noPrec 265 266pprLit :: Precedence -> Lit -> Doc 267pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0) 268 (integer x <> char '#') 269pprLit _ (WordPrimL x) = integer x <> text "##" 270pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0) 271 (float (fromRational x) <> char '#') 272pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0) 273 (double (fromRational x) <> text "##") 274pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x) 275pprLit _ (CharL c) = text (show c) 276pprLit _ (CharPrimL c) = text (show c) <> char '#' 277pprLit _ (StringL s) = pprString s 278pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#' 279pprLit _ (BytesPrimL {}) = pprString "<binary data>" 280pprLit i (RationalL rat) = parensIf (i > noPrec) $ 281 integer (numerator rat) <+> char '/' 282 <+> integer (denominator rat) 283 284bytesToString :: [Word8] -> String 285bytesToString = map (chr . fromIntegral) 286 287pprString :: String -> Doc 288-- Print newlines as newlines with Haskell string escape notation, 289-- not as '\n'. For other non-printables use regular escape notation. 290pprString s = vcat (map text (showMultiLineString s)) 291 292------------------------------ 293instance Ppr Pat where 294 ppr = pprPat noPrec 295 296pprPat :: Precedence -> Pat -> Doc 297pprPat i (LitP l) = pprLit i l 298pprPat _ (VarP v) = pprName' Applied v 299pprPat i (TupP ps) 300 | [_] <- ps 301 = pprPat i (ConP (tupleDataName 1) ps) 302 | otherwise 303 = parens (commaSep ps) 304pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps) 305pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity 306pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s 307 <+> sep (map (pprPat appPrec) ps) 308pprPat _ (ParensP p) = parens $ pprPat noPrec p 309pprPat i (UInfixP p1 n p2) 310 = parensIf (i > unopPrec) (pprPat unopPrec p1 <+> 311 pprName' Infix n <+> 312 pprPat unopPrec p2) 313pprPat i (InfixP p1 n p2) 314 = parensIf (i >= opPrec) (pprPat opPrec p1 <+> 315 pprName' Infix n <+> 316 pprPat opPrec p2) 317pprPat i (TildeP p) = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p 318pprPat i (BangP p) = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p 319pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@" 320 <> pprPat appPrec p 321pprPat _ WildP = text "_" 322pprPat _ (RecP nm fs) 323 = parens $ ppr nm 324 <+> braces (sep $ punctuate comma $ 325 map (\(s,p) -> ppr s <+> equals <+> ppr p) fs) 326pprPat _ (ListP ps) = brackets (commaSep ps) 327pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t 328pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p 329 330------------------------------ 331instance Ppr Dec where 332 ppr = ppr_dec True 333 334ppr_dec :: Bool -- declaration on the toplevel? 335 -> Dec 336 -> Doc 337ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs 338ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r 339 $$ where_clause ds 340ppr_dec _ (TySynD t xs rhs) 341 = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs 342ppr_dec _ (DataD ctxt t xs ksig cs decs) 343 = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs 344ppr_dec _ (NewtypeD ctxt t xs ksig c decs) 345 = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs 346ppr_dec _ (ClassD ctxt c xs fds ds) 347 = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds 348 $$ where_clause ds 349ppr_dec _ (InstanceD o ctxt i ds) = 350 text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i 351 $$ where_clause ds 352ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t 353ppr_dec _ (KiSigD f k) = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k 354ppr_dec _ (ForeignD f) = ppr f 355ppr_dec _ (InfixD fx n) = pprFixity n fx 356ppr_dec _ (PragmaD p) = ppr p 357ppr_dec isTop (DataFamilyD tc tvs kind) 358 = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind 359 where 360 maybeFamily | isTop = text "family" 361 | otherwise = empty 362 maybeKind | (Just k') <- kind = dcolon <+> ppr k' 363 | otherwise = empty 364ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs) 365 = ppr_data (maybeInst <+> ppr_bndrs bndrs) 366 ctxt Nothing (ppr ty) ksig cs decs 367 where 368 maybeInst | isTop = text "instance" 369 | otherwise = empty 370ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs) 371 = ppr_newtype (maybeInst <+> ppr_bndrs bndrs) 372 ctxt Nothing (ppr ty) ksig c decs 373 where 374 maybeInst | isTop = text "instance" 375 | otherwise = empty 376ppr_dec isTop (TySynInstD (TySynEqn mb_bndrs ty rhs)) 377 = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs) 378 Nothing (ppr ty) rhs 379 where 380 maybeInst | isTop = text "instance" 381 | otherwise = empty 382ppr_dec isTop (OpenTypeFamilyD tfhead) 383 = text "type" <+> maybeFamily <+> ppr_tf_head tfhead 384 where 385 maybeFamily | isTop = text "family" 386 | otherwise = empty 387ppr_dec _ (ClosedTypeFamilyD tfhead eqns) 388 = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where") 389 nestDepth (vcat (map ppr_eqn eqns)) 390 where 391 ppr_eqn (TySynEqn mb_bndrs lhs rhs) 392 = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs 393ppr_dec _ (RoleAnnotD name roles) 394 = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) 395ppr_dec _ (StandaloneDerivD ds cxt ty) 396 = hsep [ text "deriving" 397 , maybe empty ppr_deriv_strategy ds 398 , text "instance" 399 , pprCxt cxt 400 , ppr ty ] 401ppr_dec _ (DefaultSigD n ty) 402 = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ] 403ppr_dec _ (PatSynD name args dir pat) 404 = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS 405 where 406 pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2 407 | otherwise = ppr name <+> ppr args 408 pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where") 409 nestDepth (ppr name <+> ppr cls) 410 | otherwise = ppr pat 411ppr_dec _ (PatSynSigD name ty) 412 = pprPatSynSig name ty 413ppr_dec _ (ImplicitParamBindD n e) 414 = hsep [text ('?' : n), text "=", ppr e] 415 416ppr_deriv_strategy :: DerivStrategy -> Doc 417ppr_deriv_strategy ds = 418 case ds of 419 StockStrategy -> text "stock" 420 AnyclassStrategy -> text "anyclass" 421 NewtypeStrategy -> text "newtype" 422 ViaStrategy ty -> text "via" <+> pprParendType ty 423 424ppr_overlap :: Overlap -> Doc 425ppr_overlap o = text $ 426 case o of 427 Overlaps -> "{-# OVERLAPS #-}" 428 Overlappable -> "{-# OVERLAPPABLE #-}" 429 Overlapping -> "{-# OVERLAPPING #-}" 430 Incoherent -> "{-# INCOHERENT #-}" 431 432ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] 433 -> Doc 434ppr_data maybeInst ctxt t argsDoc ksig cs decs 435 = sep [text "data" <+> maybeInst 436 <+> pprCxt ctxt 437 <+> case t of 438 Just n -> pprName' Applied n <+> argsDoc 439 Nothing -> argsDoc 440 <+> ksigDoc <+> maybeWhere, 441 nest nestDepth (sep (pref $ map ppr cs)), 442 if null decs 443 then empty 444 else nest nestDepth 445 $ vcat $ map ppr_deriv_clause decs] 446 where 447 pref :: [Doc] -> [Doc] 448 pref xs | isGadtDecl = xs 449 pref [] = [] -- No constructors; can't happen in H98 450 pref (d:ds) = (char '=' <+> d):map (bar <+>) ds 451 452 maybeWhere :: Doc 453 maybeWhere | isGadtDecl = text "where" 454 | otherwise = empty 455 456 isGadtDecl :: Bool 457 isGadtDecl = not (null cs) && all isGadtCon cs 458 where isGadtCon (GadtC _ _ _ ) = True 459 isGadtCon (RecGadtC _ _ _) = True 460 isGadtCon (ForallC _ _ x ) = isGadtCon x 461 isGadtCon _ = False 462 463 ksigDoc = case ksig of 464 Nothing -> empty 465 Just k -> dcolon <+> ppr k 466 467ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause] 468 -> Doc 469ppr_newtype maybeInst ctxt t argsDoc ksig c decs 470 = sep [text "newtype" <+> maybeInst 471 <+> pprCxt ctxt 472 <+> case t of 473 Just n -> ppr n <+> argsDoc 474 Nothing -> argsDoc 475 <+> ksigDoc, 476 nest 2 (char '=' <+> ppr c), 477 if null decs 478 then empty 479 else nest nestDepth 480 $ vcat $ map ppr_deriv_clause decs] 481 where 482 ksigDoc = case ksig of 483 Nothing -> empty 484 Just k -> dcolon <+> ppr k 485 486ppr_deriv_clause :: DerivClause -> Doc 487ppr_deriv_clause (DerivClause ds ctxt) 488 = text "deriving" <+> pp_strat_before 489 <+> ppr_cxt_preds ctxt 490 <+> pp_strat_after 491 where 492 -- @via@ is unique in that in comes /after/ the class being derived, 493 -- so we must special-case it. 494 (pp_strat_before, pp_strat_after) = 495 case ds of 496 Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via) 497 _ -> (maybe empty ppr_deriv_strategy ds, empty) 498 499ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc 500ppr_tySyn maybeInst t argsDoc rhs 501 = text "type" <+> maybeInst 502 <+> case t of 503 Just n -> ppr n <+> argsDoc 504 Nothing -> argsDoc 505 <+> text "=" <+> ppr rhs 506 507ppr_tf_head :: TypeFamilyHead -> Doc 508ppr_tf_head (TypeFamilyHead tc tvs res inj) 509 = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj 510 where 511 maybeInj | (Just inj') <- inj = ppr inj' 512 | otherwise = empty 513 514ppr_bndrs :: Maybe [TyVarBndr] -> Doc 515ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "." 516ppr_bndrs Nothing = empty 517 518------------------------------ 519instance Ppr FunDep where 520 ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys) 521 ppr_list [] = empty 522 ppr_list xs = bar <+> commaSep xs 523 524------------------------------ 525instance Ppr FamilyResultSig where 526 ppr NoSig = empty 527 ppr (KindSig k) = dcolon <+> ppr k 528 ppr (TyVarSig bndr) = text "=" <+> ppr bndr 529 530------------------------------ 531instance Ppr InjectivityAnn where 532 ppr (InjectivityAnn lhs rhs) = 533 bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs) 534 535------------------------------ 536instance Ppr Foreign where 537 ppr (ImportF callconv safety impent as typ) 538 = text "foreign import" 539 <+> showtextl callconv 540 <+> showtextl safety 541 <+> text (show impent) 542 <+> ppr as 543 <+> dcolon <+> ppr typ 544 ppr (ExportF callconv expent as typ) 545 = text "foreign export" 546 <+> showtextl callconv 547 <+> text (show expent) 548 <+> ppr as 549 <+> dcolon <+> ppr typ 550 551------------------------------ 552instance Ppr Pragma where 553 ppr (InlineP n inline rm phases) 554 = text "{-#" 555 <+> ppr inline 556 <+> ppr rm 557 <+> ppr phases 558 <+> ppr n 559 <+> text "#-}" 560 ppr (SpecialiseP n ty inline phases) 561 = text "{-# SPECIALISE" 562 <+> maybe empty ppr inline 563 <+> ppr phases 564 <+> sep [ ppr n <+> dcolon 565 , nest 2 $ ppr ty ] 566 <+> text "#-}" 567 ppr (SpecialiseInstP inst) 568 = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}" 569 ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases) 570 = sep [ text "{-# RULES" <+> pprString n <+> ppr phases 571 , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs 572 <+> ppr lhs 573 , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ] 574 where ppr_ty_forall Nothing = empty 575 ppr_ty_forall (Just bndrs) = text "forall" 576 <+> fsep (map ppr bndrs) 577 <+> char '.' 578 ppr_tm_forall Nothing | null tm_bndrs = empty 579 ppr_tm_forall _ = text "forall" 580 <+> fsep (map ppr tm_bndrs) 581 <+> char '.' 582 ppr (AnnP tgt expr) 583 = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}" 584 where target1 ModuleAnnotation = text "module" 585 target1 (TypeAnnotation t) = text "type" <+> ppr t 586 target1 (ValueAnnotation v) = ppr v 587 ppr (LineP line file) 588 = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}" 589 ppr (CompleteP cls mty) 590 = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls) 591 <+> maybe empty (\ty -> dcolon <+> ppr ty) mty 592 593------------------------------ 594instance Ppr Inline where 595 ppr NoInline = text "NOINLINE" 596 ppr Inline = text "INLINE" 597 ppr Inlinable = text "INLINABLE" 598 599------------------------------ 600instance Ppr RuleMatch where 601 ppr ConLike = text "CONLIKE" 602 ppr FunLike = empty 603 604------------------------------ 605instance Ppr Phases where 606 ppr AllPhases = empty 607 ppr (FromPhase i) = brackets $ int i 608 ppr (BeforePhase i) = brackets $ char '~' <> int i 609 610------------------------------ 611instance Ppr RuleBndr where 612 ppr (RuleVar n) = ppr n 613 ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty 614 615------------------------------ 616instance Ppr Clause where 617 ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs 618 $$ where_clause ds 619 620------------------------------ 621instance Ppr Con where 622 ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts) 623 624 ppr (RecC c vsts) 625 = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts)) 626 627 ppr (InfixC st1 c st2) = pprBangType st1 628 <+> pprName' Infix c 629 <+> pprBangType st2 630 631 ppr (ForallC ns ctxt (GadtC c sts ty)) 632 = commaSepApplied c <+> dcolon <+> pprForall ns ctxt 633 <+> pprGadtRHS sts ty 634 635 ppr (ForallC ns ctxt (RecGadtC c vsts ty)) 636 = commaSepApplied c <+> dcolon <+> pprForall ns ctxt 637 <+> pprRecFields vsts ty 638 639 ppr (ForallC ns ctxt con) 640 = pprForall ns ctxt <+> ppr con 641 642 ppr (GadtC c sts ty) 643 = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty 644 645 ppr (RecGadtC c vsts ty) 646 = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty 647 648instance Ppr PatSynDir where 649 ppr Unidir = text "<-" 650 ppr ImplBidir = text "=" 651 ppr (ExplBidir _) = text "<-" 652 -- the ExplBidir's clauses are pretty printed together with the 653 -- entire pattern synonym; so only print the direction here. 654 655instance Ppr PatSynArgs where 656 ppr (PrefixPatSyn args) = sep $ map ppr args 657 ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2 658 ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels)) 659 660commaSepApplied :: [Name] -> Doc 661commaSepApplied = commaSepWith (pprName' Applied) 662 663pprForall :: [TyVarBndr] -> Cxt -> Doc 664pprForall = pprForall' ForallInvis 665 666pprForallVis :: [TyVarBndr] -> Cxt -> Doc 667pprForallVis = pprForall' ForallVis 668 669pprForall' :: ForallVisFlag -> [TyVarBndr] -> Cxt -> Doc 670pprForall' fvf tvs cxt 671 -- even in the case without any tvs, there could be a non-empty 672 -- context cxt (e.g., in the case of pattern synonyms, where there 673 -- are multiple forall binders and contexts). 674 | [] <- tvs = pprCxt cxt 675 | otherwise = text "forall" <+> hsep (map ppr tvs) 676 <+> separator <+> pprCxt cxt 677 where 678 separator = case fvf of 679 ForallVis -> text "->" 680 ForallInvis -> char '.' 681 682pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc 683pprRecFields vsts ty 684 = braces (sep (punctuate comma $ map pprVarBangType vsts)) 685 <+> arrow <+> ppr ty 686 687pprGadtRHS :: [(Strict, Type)] -> Type -> Doc 688pprGadtRHS [] ty 689 = ppr ty 690pprGadtRHS sts ty 691 = sep (punctuate (space <> arrow) (map pprBangType sts)) 692 <+> arrow <+> ppr ty 693 694------------------------------ 695pprVarBangType :: VarBangType -> Doc 696-- Slight infelicity: with print non-atomic type with parens 697pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t) 698 699------------------------------ 700pprBangType :: BangType -> Doc 701-- Make sure we print 702-- 703-- Con {-# UNPACK #-} a 704-- 705-- rather than 706-- 707-- Con {-# UNPACK #-}a 708-- 709-- when there's no strictness annotation. If there is a strictness annotation, 710-- it's okay to not put a space between it and the type. 711pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t 712pprBangType (bt, t) = ppr bt <> pprParendType t 713 714------------------------------ 715instance Ppr Bang where 716 ppr (Bang su ss) = ppr su <+> ppr ss 717 718------------------------------ 719instance Ppr SourceUnpackedness where 720 ppr NoSourceUnpackedness = empty 721 ppr SourceNoUnpack = text "{-# NOUNPACK #-}" 722 ppr SourceUnpack = text "{-# UNPACK #-}" 723 724------------------------------ 725instance Ppr SourceStrictness where 726 ppr NoSourceStrictness = empty 727 ppr SourceLazy = char '~' 728 ppr SourceStrict = char '!' 729 730------------------------------ 731instance Ppr DecidedStrictness where 732 ppr DecidedLazy = empty 733 ppr DecidedStrict = char '!' 734 ppr DecidedUnpack = text "{-# UNPACK #-} !" 735 736------------------------------ 737{-# DEPRECATED pprVarStrictType 738 "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-} 739pprVarStrictType :: (Name, Strict, Type) -> Doc 740pprVarStrictType = pprVarBangType 741 742------------------------------ 743{-# DEPRECATED pprStrictType 744 "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-} 745pprStrictType :: (Strict, Type) -> Doc 746pprStrictType = pprBangType 747 748------------------------------ 749pprParendType :: Type -> Doc 750pprParendType (VarT v) = pprName' Applied v 751-- `Applied` is used here instead of `ppr` because of infix names (#13887) 752pprParendType (ConT c) = pprName' Applied c 753pprParendType (TupleT 0) = text "()" 754pprParendType (TupleT 1) = pprParendType (ConT (tupleTypeName 1)) 755pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) 756pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma 757pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar 758pprParendType ArrowT = parens (text "->") 759pprParendType ListT = text "[]" 760pprParendType (LitT l) = pprTyLit l 761pprParendType (PromotedT c) = text "'" <> pprName' Applied c 762pprParendType (PromotedTupleT 0) = text "'()" 763pprParendType (PromotedTupleT 1) = pprParendType (PromotedT (tupleDataName 1)) 764pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma)) 765pprParendType PromotedNilT = text "'[]" 766pprParendType PromotedConsT = text "'(:)" 767pprParendType StarT = char '*' 768pprParendType ConstraintT = text "Constraint" 769pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k) 770pprParendType WildCardT = char '_' 771pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y) 772pprParendType t@(UInfixT {}) = parens (pprUInfixT t) 773pprParendType (ParensT t) = ppr t 774pprParendType tuple | (TupleT n, args) <- split tuple 775 , length args == n 776 = parens (commaSep args) 777pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t 778pprParendType EqualityT = text "(~)" 779pprParendType t@(ForallT {}) = parens (ppr t) 780pprParendType t@(ForallVisT {}) = parens (ppr t) 781pprParendType t@(AppT {}) = parens (ppr t) 782pprParendType t@(AppKindT {}) = parens (ppr t) 783 784pprUInfixT :: Type -> Doc 785pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y 786pprUInfixT t = ppr t 787 788instance Ppr Type where 789 ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty] 790 ppr (ForallVisT tvars ty) = sep [pprForallVis tvars [], ppr ty] 791 ppr ty = pprTyApp (split ty) 792 -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind) 793 -- See Note [Pretty-printing kind signatures] 794instance Ppr TypeArg where 795 ppr (TANormal ty) = ppr ty 796 ppr (TyArg ki) = char '@' <> ppr ki 797 798pprParendTypeArg :: TypeArg -> Doc 799pprParendTypeArg (TANormal ty) = pprParendType ty 800pprParendTypeArg (TyArg ki) = char '@' <> pprParendType ki 801{- Note [Pretty-printing kind signatures] 802~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 803GHC's parser only recognises a kind signature in a type when there are 804parens around it. E.g. the parens are required here: 805 f :: (Int :: *) 806 type instance F Int = (Bool :: *) 807So we always print a SigT with parens (see #10050). -} 808 809pprTyApp :: (Type, [TypeArg]) -> Doc 810pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] 811pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) = 812 sep [pprFunArgType arg1 <+> text "~", ppr arg2] 813pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg) 814pprTyApp (TupleT n, args) 815 | length args == n 816 = if n == 1 817 then pprTyApp (ConT (tupleTypeName 1), args) 818 else parens (commaSep args) 819pprTyApp (PromotedTupleT n, args) 820 | length args == n 821 = if n == 1 822 then pprTyApp (PromotedT (tupleDataName 1), args) 823 else quoteParens (commaSep args) 824pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args) 825 826pprFunArgType :: Type -> Doc -- Should really use a precedence argument 827-- Everything except forall and (->) binds more tightly than (->) 828pprFunArgType ty@(ForallT {}) = parens (ppr ty) 829pprFunArgType ty@(ForallVisT {}) = parens (ppr ty) 830pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty) 831pprFunArgType ty@(SigT _ _) = parens (ppr ty) 832pprFunArgType ty = ppr ty 833 834data ForallVisFlag = ForallVis -- forall a -> {...} 835 | ForallInvis -- forall a. {...} 836 deriving Show 837 838data TypeArg = TANormal Type 839 | TyArg Kind 840 841split :: Type -> (Type, [TypeArg]) -- Split into function and args 842split t = go t [] 843 where go (AppT t1 t2) args = go t1 (TANormal t2:args) 844 go (AppKindT ty ki) args = go ty (TyArg ki:args) 845 go ty args = (ty, args) 846 847pprTyLit :: TyLit -> Doc 848pprTyLit (NumTyLit n) = integer n 849pprTyLit (StrTyLit s) = text (show s) 850 851instance Ppr TyLit where 852 ppr = pprTyLit 853 854------------------------------ 855instance Ppr TyVarBndr where 856 ppr (PlainTV nm) = ppr nm 857 ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k) 858 859instance Ppr Role where 860 ppr NominalR = text "nominal" 861 ppr RepresentationalR = text "representational" 862 ppr PhantomR = text "phantom" 863 ppr InferR = text "_" 864 865------------------------------ 866pprCxt :: Cxt -> Doc 867pprCxt [] = empty 868pprCxt ts = ppr_cxt_preds ts <+> text "=>" 869 870ppr_cxt_preds :: Cxt -> Doc 871ppr_cxt_preds [] = empty 872ppr_cxt_preds [t@ImplicitParamT{}] = parens (ppr t) 873ppr_cxt_preds [t@ForallT{}] = parens (ppr t) 874ppr_cxt_preds [t] = ppr t 875ppr_cxt_preds ts = parens (commaSep ts) 876 877------------------------------ 878instance Ppr Range where 879 ppr = brackets . pprRange 880 where pprRange :: Range -> Doc 881 pprRange (FromR e) = ppr e <> text ".." 882 pprRange (FromThenR e1 e2) = ppr e1 <> text "," 883 <> ppr e2 <> text ".." 884 pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2 885 pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text "," 886 <> ppr e2 <> text ".." 887 <> ppr e3 888 889------------------------------ 890where_clause :: [Dec] -> Doc 891where_clause [] = empty 892where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds) 893 894showtextl :: Show a => a -> Doc 895showtextl = text . map toLower . show 896 897hashParens :: Doc -> Doc 898hashParens d = text "(# " <> d <> text " #)" 899 900quoteParens :: Doc -> Doc 901quoteParens d = text "'(" <> d <> text ")" 902 903----------------------------- 904instance Ppr Loc where 905 ppr (Loc { loc_module = md 906 , loc_package = pkg 907 , loc_start = (start_ln, start_col) 908 , loc_end = (end_ln, end_col) }) 909 = hcat [ text pkg, colon, text md, colon 910 , parens $ int start_ln <> comma <> int start_col 911 , text "-" 912 , parens $ int end_ln <> comma <> int end_col ] 913 914-- Takes a list of printable things and prints them separated by commas followed 915-- by space. 916commaSep :: Ppr a => [a] -> Doc 917commaSep = commaSepWith ppr 918 919-- Takes a list of things and prints them with the given pretty-printing 920-- function, separated by commas followed by space. 921commaSepWith :: (a -> Doc) -> [a] -> Doc 922commaSepWith pprFun = sep . punctuate comma . map pprFun 923 924-- Takes a list of printable things and prints them separated by semicolons 925-- followed by space. 926semiSep :: Ppr a => [a] -> Doc 927semiSep = sep . punctuate semi . map ppr 928 929-- Prints out the series of vertical bars that wraps an expression or pattern 930-- used in an unboxed sum. 931unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc 932unboxedSumBars d alt arity = hashParens $ 933 bars (alt-1) <> d <> bars (arity - alt) 934 where 935 bars i = hsep (replicate i bar) 936 937-- Text containing the vertical bar character. 938bar :: Doc 939bar = char '|' 940