-- | contains a prettyprinter for the-- Template Haskell datatypesmoduleLanguage.Haskell.TH.Pprwhere-- All of the exports from this module should-- be "public" functions. The main module TH-- re-exports them all.importText.PrettyPrint(render)importLanguage.Haskell.TH.PprLib importLanguage.Haskell.TH.Syntax importData.Word(Word8)importData.Char(toLower,chr)importGHC.Show(showMultiLineString)importGHC.Lexeme(startsVarSym)importData.Ratio(numerator,denominator)nestDepth::IntnestDepth =4typePrecedence =IntappPrec,unopPrec,opPrec,noPrec::Precedence appPrec =3-- Argument of a function applicationopPrec =2-- Argument of an infix operatorunopPrec =1-- Argument of an unresolved infix operatornoPrec =0-- OthersparensIf::Bool->Doc ->Doc parensIf Trued =parens d parensIfFalsed =d ------------------------------pprint::Ppr a =>a ->Stringpprint x =render$to_HPJ_Doc $ppr x classPpr a whereppr::a ->Doc ppr_list::[a ]->Doc ppr_list =vcat .mapppr instancePpr a =>Ppr [a ]whereppr x =ppr_list x ------------------------------instancePpr Name whereppr v =pprName v ------------------------------instancePpr Info whereppr (TyConI d )=ppr d ppr(ClassI d is )=ppr d $$ vcat (mapppr is )ppr(FamilyI d is )=ppr d $$ vcat (mapppr is )ppr(PrimTyConI name arity is_unlifted )=text "Primitive"<+> (ifis_unlifted thentext "unlifted"elseempty )<+> text "type constructor"<+> quotes (ppr name )<+> parens (text "arity"<+> int arity )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 ppr(PatSynI nm ty )=pprPatSynSig nm ty ppr(TyVarI v ty )=text "Type variable"<+> ppr v <+> equals <+> ppr ty ppr(VarI v ty mb_d )=vcat [ppr_sig v ty ,casemb_d of{Nothing->empty ;Justd ->ppr d }]ppr_sig::Name ->Type ->Doc ppr_sig v ty =pprName' Applied v <+> dcolon <+> ppr ty pprFixity::Name ->Fixity ->Doc pprFixity _f |f ==defaultFixity =empty pprFixityv (Fixity i d )=ppr_fix d <+> int i <+> ppr v whereppr_fix InfixR =text "infixr"ppr_fixInfixL =text "infixl"ppr_fixInfixN =text "infix"-- | Pretty prints a pattern synonym type signaturepprPatSynSig::Name ->PatSynType ->Doc pprPatSynSig nm ty =text "pattern"<+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty -- | Pretty prints a pattern synonym's type; follows the usual-- conventions to print a pattern synonym type compactly, yet-- unambiguously. See the note on 'PatSynType' and the section on-- pattern synonyms in the GHC user's guide for more information.pprPatSynType::PatSynType ->Doc pprPatSynType ty @(ForallT uniTys reqs ty' @(ForallT exTys provs ty'' ))|nullexTys ,nullprovs =ppr (ForallT uniTys reqs ty'' )|nulluniTys ,nullreqs =noreqs <+> ppr ty' |nullreqs =foralluniTys <+> noreqs <+> ppr ty' |otherwise=ppr ty wherenoreqs =text "() =>"foralltvs =text "forall"<+> (hsep (mapppr tvs ))<+> text "."pprPatSynTypety =ppr ty ------------------------------instancePpr Module whereppr (Module pkg m )=text (pkgString pkg )<+> text (modString m )instancePpr ModuleInfo whereppr (ModuleInfo imps )=text "Module"<+> vcat (mapppr imps )------------------------------instancePpr Exp whereppr =pprExp noPrec pprPrefixOcc::Name ->Doc -- Print operators with parens around thempprPrefixOcc n =parensIf (isSymOcc n )(ppr n )isSymOcc::Name ->BoolisSymOcc n =casenameBase n of[]->True-- Empty name; weird(c :_)->startsVarSymc -- c.f. OccName.startsVarSym in GHC itselfpprInfixExp::Exp ->Doc pprInfixExp (VarE v )=pprName' Infix v pprInfixExp(ConE v )=pprName' Infix v pprInfixExp_=text "<<Non-variable/constructor in infix context>>"pprExp::Precedence ->Exp ->Doc pprExp _(VarE v )=pprName' Applied v pprExp_(ConE c )=pprName' Applied c pprExpi (LitE l )=pprLit i l pprExpi (AppE e1 e2 )=parensIf (i >=appPrec )$pprExp opPrec e1 <+> pprExp appPrec e2 pprExpi (AppTypeE e t )=parensIf (i >=appPrec )$pprExp opPrec e <+> char '@'<> pprParendType t pprExp_(ParensE e )=parens (pprExp noPrec e )pprExpi (UInfixE e1 op e2 )=parensIf (i >unopPrec )$pprExp unopPrec e1 <+> pprInfixExp op <+> pprExp unopPrec e2 pprExpi (InfixE (Juste1 )op (Juste2 ))=parensIf (i >=opPrec )$pprExp opPrec e1 <+> pprInfixExp op <+> pprExp opPrec e2 pprExp_(InfixE me1 op me2 )=parens $pprMaybeExp noPrec me1 <+> pprInfixExp op <+> pprMaybeExp noPrec me2 pprExpi (LamE ps e )=parensIf (i >noPrec )$char '\\'<> hsep (map(pprPat appPrec )ps )<+> text "->"<+> ppr e pprExpi (LamCaseE ms )=parensIf (i >noPrec )$text "\\case"$$ nest nestDepth (ppr ms )pprExp_(TupE es )=parens (commaSep es )pprExp_(UnboxedTupE es )=hashParens (commaSep es )pprExp_(UnboxedSumE e alt arity )=unboxedSumBars (ppr e )alt arity -- Nesting in Cond is to avoid potential problems in do statmentspprExpi (CondE guard true false )=parensIf (i >noPrec )$sep [text "if"<+> ppr guard ,nest 1$text "then"<+> ppr true ,nest 1$text "else"<+> ppr false ]pprExpi (MultiIfE alts )=parensIf (i >noPrec )$vcat $casealts of[]->[text "if {}"](alt :alts' )->text "if"<+> pprGuarded arrow alt :map(nest 3.pprGuarded arrow )alts' pprExpi (LetE ds_ e )=parensIf (i >noPrec )$text "let"<+> pprDecs ds_ $$ text " in"<+> ppr e wherepprDecs []=empty pprDecs[d ]=ppr d pprDecsds =braces (semiSep ds )pprExpi (CaseE e ms )=parensIf (i >noPrec )$text "case"<+> ppr e <+> text "of"$$ nest nestDepth (ppr ms )pprExpi (DoE ss_ )=parensIf (i >noPrec )$text "do"<+> pprStms ss_ wherepprStms []=empty pprStms[s ]=ppr s pprStmsss =braces (semiSep ss )pprExp_(CompE [])=text "<<Empty CompExp>>"-- This will probably break with fixity declarations - would need a ';'pprExp_(CompE ss )=ifnullss' -- If there are no statements in a list comprehension besides the last-- one, we simply treat it like a normal list.thentext "["<> ppr s <> text "]"elsetext "["<> ppr s <+> bar <+> commaSep ss' <> text "]"wheres =lastss ss' =initss pprExp_(ArithSeqE d )=ppr d pprExp_(ListE es )=brackets (commaSep es )pprExpi (SigE e t )=parensIf (i >noPrec )$ppr e <+> dcolon <+> ppr t pprExp_(RecConE nm fs )=ppr nm <> braces (pprFields fs )pprExp_(RecUpdE e fs )=pprExp appPrec e <> braces (pprFields fs )pprExpi (StaticE e )=parensIf (i >=appPrec )$text "static"<+> pprExp appPrec e pprExp_(UnboundVarE v )=pprName' Applied v pprFields::[(Name ,Exp )]->Doc pprFields =sep .punctuate comma .map(\(s ,e )->ppr s <+> equals <+> ppr e )pprMaybeExp::Precedence ->MaybeExp ->Doc pprMaybeExp _Nothing=empty pprMaybeExpi (Juste )=pprExp i e ------------------------------instancePpr Stmt whereppr (BindS p e )=ppr p <+> text "<-"<+> ppr e ppr(LetS ds )=text "let"<+> (braces (semiSep ds ))ppr(NoBindS e )=ppr e ppr(ParS sss )=sep $punctuate bar $mapcommaSep sss ------------------------------instancePpr Match whereppr (Match p rhs ds )=ppr p <+> pprBody Falserhs $$ where_clause ds ------------------------------pprGuarded::Doc ->(Guard ,Exp )->Doc pprGuarded eqDoc (guard ,expr )=caseguard ofNormalG guardExpr ->bar <+> ppr guardExpr <+> eqDoc <+> ppr expr PatG stmts ->bar <+> vcat (punctuate comma $mapppr stmts )$$ nest nestDepth (eqDoc <+> ppr expr )------------------------------pprBody::Bool->Body ->Doc pprBody eq body =casebody ofGuardedB xs ->nest nestDepth $vcat $map(pprGuarded eqDoc )xs NormalB e ->eqDoc <+> ppr e whereeqDoc |eq =equals |otherwise=arrow ------------------------------instancePpr Lit whereppr =pprLit noPrec pprLit::Precedence ->Lit ->Doc pprLit i (IntPrimL x )=parensIf (i >noPrec &&x <0)(integer x <> char '#')pprLit_(WordPrimL x )=integer x <> text "##"pprLiti (FloatPrimL x )=parensIf (i >noPrec &&x <0)(float (fromRationalx )<> char '#')pprLiti (DoublePrimL x )=parensIf (i >noPrec &&x <0)(double (fromRationalx )<> text "##")pprLiti (IntegerL x )=parensIf (i >noPrec &&x <0)(integer x )pprLit_(CharL c )=text (showc )pprLit_(CharPrimL c )=text (showc )<> char '#'pprLit_(StringL s )=pprString s pprLit_(StringPrimL s )=pprString (bytesToString s )<> char '#'pprLiti (RationalL rat )=parensIf (i >noPrec )$integer (numeratorrat )<+> char '/'<+> integer (denominatorrat )bytesToString::[Word8]->StringbytesToString =map(chr.fromIntegral)pprString::String->Doc -- Print newlines as newlines with Haskell string escape notation,-- not as '\n'. For other non-printables use regular escape notation.pprString s =vcat (maptext (showMultiLineStrings ))------------------------------instancePpr Pat whereppr =pprPat noPrec pprPat::Precedence ->Pat ->Doc pprPat i (LitP l )=pprLit i l pprPat_(VarP v )=pprName' Applied v pprPat_(TupP ps )=parens (commaSep ps )pprPat_(UnboxedTupP ps )=hashParens (commaSep ps )pprPat_(UnboxedSumP p alt arity )=unboxedSumBars (ppr p )alt arity pprPati (ConP s ps )=parensIf (i >=appPrec )$pprName' Applied s <+> sep (map(pprPat appPrec )ps )pprPat_(ParensP p )=parens $pprPat noPrec p pprPati (UInfixP p1 n p2 )=parensIf (i >unopPrec )(pprPat unopPrec p1 <+> pprName' Infix n <+> pprPat unopPrec p2 )pprPati (InfixP p1 n p2 )=parensIf (i >=opPrec )(pprPat opPrec p1 <+> pprName' Infix n <+> pprPat opPrec p2 )pprPati (TildeP p )=parensIf (i >noPrec )$char '~'<> pprPat appPrec p pprPati (BangP p )=parensIf (i >noPrec )$char '!'<> pprPat appPrec p pprPati (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 )pprPat_(ListP ps )=brackets (commaSep ps )pprPati (SigP p t )=parensIf (i >noPrec )$ppr p <+> dcolon <+> ppr t pprPat_(ViewP e p )=parens $pprExp noPrec e <+> text "->"<+> pprPat noPrec p ------------------------------instancePpr Dec whereppr =ppr_dec Trueppr_dec::Bool-- declaration on the toplevel?->Dec ->Doc ppr_dec _(FunD f cs )=vcat $map(\c ->pprPrefixOcc f <+> ppr c )cs ppr_dec_(ValD p r ds )=ppr p <+> pprBody Truer $$ where_clause ds ppr_dec_(TySynD t xs rhs )=ppr_tySyn empty t (hsep (mapppr xs ))rhs ppr_dec_(DataD ctxt t xs ksig cs decs )=ppr_data empty ctxt t (hsep (mapppr xs ))ksig cs decs ppr_dec_(NewtypeD ctxt t xs ksig c decs )=ppr_newtype empty ctxt t (sep (mapppr xs ))ksig c decs ppr_dec_(ClassD ctxt c xs fds ds )=text "class"<+> pprCxt ctxt <+> ppr c <+> hsep (mapppr xs )<+> ppr fds $$ where_clause ds ppr_dec_(InstanceD o ctxt i ds )=text "instance"<+> maybeempty ppr_overlap o <+> pprCxt ctxt <+> ppr i $$ where_clause ds ppr_dec_(SigD f t )=pprPrefixOcc f <+> dcolon <+> ppr t ppr_dec_(ForeignD f )=ppr f ppr_dec_(InfixD fx n )=pprFixity n fx ppr_dec_(PragmaD p )=ppr p ppr_decisTop (DataFamilyD tc tvs kind )=text "data"<+> maybeFamily <+> ppr tc <+> hsep (mapppr tvs )<+> maybeKind wheremaybeFamily |isTop =text "family"|otherwise=empty maybeKind |(Justk' )<-kind =dcolon <+> ppr k' |otherwise=empty ppr_decisTop (DataInstD ctxt tc tys ksig cs decs )=ppr_data maybeInst ctxt tc (sep (mappprParendType tys ))ksig cs decs wheremaybeInst |isTop =text "instance"|otherwise=empty ppr_decisTop (NewtypeInstD ctxt tc tys ksig c decs )=ppr_newtype maybeInst ctxt tc (sep (mappprParendType tys ))ksig c decs wheremaybeInst |isTop =text "instance"|otherwise=empty ppr_decisTop (TySynInstD tc (TySynEqn tys rhs ))=ppr_tySyn maybeInst tc (sep (mappprParendType tys ))rhs wheremaybeInst |isTop =text "instance"|otherwise=empty ppr_decisTop (OpenTypeFamilyD tfhead )=text "type"<+> maybeFamily <+> ppr_tf_head tfhead wheremaybeFamily |isTop =text "family"|otherwise=empty ppr_dec_(ClosedTypeFamilyD tfhead @(TypeFamilyHead tc ___)eqns )=hang (text "type family"<+> ppr_tf_head tfhead <+> text "where")nestDepth (vcat (mapppr_eqn eqns ))whereppr_eqn (TySynEqn lhs rhs )=ppr tc <+> sep (mappprParendType lhs )<+> text "="<+> ppr rhs ppr_dec_(RoleAnnotD name roles )=hsep [text "type role",ppr name ]<+> hsep (mapppr roles )ppr_dec_(StandaloneDerivD ds cxt ty )=hsep [text "deriving",maybeempty ppr_deriv_strategy ds ,text "instance",pprCxt cxt ,ppr ty ]ppr_dec_(DefaultSigD n ty )=hsep [text "default",pprPrefixOcc n ,dcolon ,ppr ty ]ppr_dec_(PatSynD name args dir pat )=text "pattern"<+> pprNameArgs <+> ppr dir <+> pprPatRHS wherepprNameArgs |InfixPatSyn a1 a2 <-args =ppr a1 <+> ppr name <+> ppr a2 |otherwise=ppr name <+> ppr args pprPatRHS |ExplBidir cls <-dir =hang (ppr pat <+> text "where")nestDepth (ppr name <+> ppr cls )|otherwise=ppr pat ppr_dec_(PatSynSigD name ty )=pprPatSynSig name ty ppr_deriv_strategy::DerivStrategy ->Doc ppr_deriv_strategy ds =text $caseds ofStockStrategy ->"stock"AnyclassStrategy ->"anyclass"NewtypeStrategy ->"newtype"ppr_overlap::Overlap ->Doc ppr_overlap o =text $caseo ofOverlaps ->"{-# OVERLAPS #-}"Overlappable ->"{-# OVERLAPPABLE #-}"Overlapping ->"{-# OVERLAPPING #-}"Incoherent ->"{-# INCOHERENT #-}"ppr_data::Doc ->Cxt ->Name ->Doc ->MaybeKind ->[Con ]->[DerivClause ]->Doc ppr_data maybeInst ctxt t argsDoc ksig cs decs =sep [text "data"<+> maybeInst <+> pprCxt ctxt <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere ,nest nestDepth (sep (pref $mapppr cs )),ifnulldecs thenempty elsenest nestDepth $vcat $mapppr_deriv_clause decs ]wherepref::[Doc ]->[Doc ]pref xs |isGadtDecl =xs pref[]=[]-- No constructors; can't happen in H98pref(d :ds )=(char '='<+> d ):map(bar <+> )ds maybeWhere::Doc maybeWhere |isGadtDecl =text "where"|otherwise=empty isGadtDecl::BoolisGadtDecl =not(nullcs )&&allisGadtCon cs whereisGadtCon (GadtC ___)=TrueisGadtCon(RecGadtC ___)=TrueisGadtCon(ForallC __x )=isGadtCon x isGadtCon_=FalseksigDoc =caseksig ofNothing->empty Justk ->dcolon <+> ppr k ppr_newtype::Doc ->Cxt ->Name ->Doc ->MaybeKind ->Con ->[DerivClause ]->Doc ppr_newtype maybeInst ctxt t argsDoc ksig c decs =sep [text "newtype"<+> maybeInst <+> pprCxt ctxt <+> ppr t <+> argsDoc <+> ksigDoc ,nest 2(char '='<+> ppr c ),ifnulldecs thenempty elsenest nestDepth $vcat $mapppr_deriv_clause decs ]whereksigDoc =caseksig ofNothing->empty Justk ->dcolon <+> ppr k ppr_deriv_clause::DerivClause ->Doc ppr_deriv_clause (DerivClause ds ctxt )=text "deriving"<+> maybeempty ppr_deriv_strategy ds <+> ppr_cxt_preds ctxt ppr_tySyn::Doc ->Name ->Doc ->Type ->Doc ppr_tySyn maybeInst t argsDoc rhs =text "type"<+> maybeInst <+> ppr t <+> argsDoc <+> text "="<+> ppr rhs ppr_tf_head::TypeFamilyHead ->Doc ppr_tf_head (TypeFamilyHead tc tvs res inj )=ppr tc <+> hsep (mapppr tvs )<+> ppr res <+> maybeInj wheremaybeInj |(Justinj' )<-inj =ppr inj' |otherwise=empty ------------------------------instancePpr FunDep whereppr (FunDep xs ys )=hsep (mapppr xs )<+> text "->"<+> hsep (mapppr ys )ppr_list []=empty ppr_listxs =bar <+> commaSep xs ------------------------------instancePpr FamFlavour whereppr DataFam =text "data"pprTypeFam =text "type"------------------------------instancePpr FamilyResultSig whereppr NoSig =empty ppr(KindSig k )=dcolon <+> ppr k ppr(TyVarSig bndr )=text "="<+> ppr bndr ------------------------------instancePpr InjectivityAnn whereppr (InjectivityAnn lhs rhs )=bar <+> ppr lhs <+> text "->"<+> hsep (mapppr rhs )------------------------------instancePpr Foreign whereppr (ImportF callconv safety impent astyp )=text "foreign import"<+> showtextl callconv <+> showtextl safety <+> text (showimpent )<+> ppr as<+> dcolon <+> ppr typ ppr(ExportF callconv expent astyp )=text "foreign export"<+> showtextl callconv <+> text (showexpent )<+> ppr as<+> dcolon <+> ppr typ ------------------------------instancePpr Pragma whereppr (InlineP n inline rm phases )=text "{-#"<+> ppr inline <+> ppr rm <+> ppr phases <+> ppr n <+> text "#-}"ppr(SpecialiseP n ty inline phases )=text "{-# SPECIALISE"<+> maybeempty ppr inline <+> ppr phases <+> sep [ppr n <+> dcolon ,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 "#-}"]whereppr_forall |nullbndrs =empty |otherwise=text "forall"<+> fsep (mapppr bndrs )<+> char '.'ppr(AnnP tgt expr )=text "{-# ANN"<+> target1 tgt <+> ppr expr <+> text "#-}"wheretarget1 ModuleAnnotation =text "module"target1(TypeAnnotation t )=text "type"<+> ppr t target1(ValueAnnotation v )=ppr v ppr(LineP line file )=text "{-# LINE"<+> int line <+> text (showfile )<+> text "#-}"ppr(CompleteP cls mty )=text "{-# COMPLETE"<+> (fsep $punctuate comma $mapppr cls )<+> maybeempty (\ty ->dcolon <+> ppr ty )mty ------------------------------instancePpr Inline whereppr NoInline =text "NOINLINE"pprInline =text "INLINE"pprInlinable =text "INLINABLE"------------------------------instancePpr RuleMatch whereppr ConLike =text "CONLIKE"pprFunLike =empty ------------------------------instancePpr Phases whereppr AllPhases =empty ppr(FromPhase i )=brackets $int i ppr(BeforePhase i )=brackets $char '~'<> int i ------------------------------instancePpr RuleBndr whereppr (RuleVar n )=ppr n ppr(TypedRuleVar n ty )=parens $ppr n <+> dcolon <+> ppr ty ------------------------------instancePpr Clause whereppr (Clause ps rhs ds )=hsep (map(pprPat appPrec )ps )<+> pprBody Truerhs $$ where_clause ds ------------------------------instancePpr Con whereppr (NormalC c sts )=ppr c <+> sep (mappprBangType sts )ppr(RecC c vsts )=ppr c <+> braces (sep (punctuate comma $mappprVarBangType vsts ))ppr(InfixC st1 c st2 )=pprBangType st1 <+> pprName' Infix c <+> pprBangType st2 ppr(ForallC ns ctxt (GadtC c sts ty ))=commaSepApplied c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty ppr(ForallC ns ctxt (RecGadtC c vsts ty ))=commaSepApplied c <+> dcolon <+> pprForall ns ctxt <+> pprRecFields vsts ty ppr(ForallC ns ctxt con )=pprForall ns ctxt <+> ppr con ppr(GadtC c sts ty )=commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty ppr(RecGadtC c vsts ty )=commaSepApplied c <+> dcolon <+> pprRecFields vsts ty instancePpr PatSynDir whereppr Unidir =text "<-"pprImplBidir =text "="ppr(ExplBidir _)=text "<-"-- the ExplBidir's clauses are pretty printed together with the-- entire pattern synonym; so only print the direction here.instancePpr PatSynArgs whereppr (PrefixPatSyn args )=sep $mapppr args ppr(InfixPatSyn a1 a2 )=ppr a1 <+> ppr a2 ppr(RecordPatSyn sels )=braces $sep (punctuate comma (mapppr sels ))commaSepApplied::[Name ]->Doc commaSepApplied =commaSepWith (pprName' Applied )pprForall::[TyVarBndr ]->Cxt ->Doc pprForall tvs cxt -- even in the case without any tvs, there could be a non-empty-- context cxt (e.g., in the case of pattern synonyms, where there-- are multiple forall binders and contexts).|[]<-tvs =pprCxt cxt |otherwise=text "forall"<+> hsep (mapppr tvs )<+> char '.'<+> pprCxt cxt pprRecFields::[(Name ,Strict ,Type )]->Type ->Doc pprRecFields vsts ty =braces (sep (punctuate comma $mappprVarBangType vsts ))<+> arrow <+> ppr ty pprGadtRHS::[(Strict ,Type )]->Type ->Doc pprGadtRHS []ty =ppr ty pprGadtRHSsts ty =sep (punctuate (space <> arrow )(mappprBangType sts ))<+> arrow <+> ppr ty ------------------------------pprVarBangType::VarBangType ->Doc -- Slight infelicity: with print non-atomic type with parenspprVarBangType (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 ------------------------------instancePpr Bang whereppr (Bang su ss )=ppr su <+> ppr ss ------------------------------instancePpr SourceUnpackedness whereppr NoSourceUnpackedness =empty pprSourceNoUnpack =text "{-# NOUNPACK #-}"pprSourceUnpack =text "{-# UNPACK #-}"------------------------------instancePpr SourceStrictness whereppr NoSourceStrictness =empty pprSourceLazy =char '~'pprSourceStrict =char '!'------------------------------instancePpr DecidedStrictness whereppr DecidedLazy =empty pprDecidedStrict =char '!'pprDecidedUnpack =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 ------------------------------{-# DEPRECATED pprStrictType
 "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-}pprStrictType::(Strict ,Type )->Doc pprStrictType =pprBangType ------------------------------pprParendType::Type ->Doc 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(UnboxedSumT arity )=hashParens $hcat $replicate(arity -1)bar pprParendTypeArrowT =parens (text "->")pprParendTypeListT =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 ))pprParendTypePromotedNilT =text "'[]"pprParendTypePromotedConsT =text "(':)"pprParendTypeStarT =char '*'pprParendTypeConstraintT =text "Constraint"pprParendType(SigT ty k )=parens (ppr ty <+> text "::"<+> ppr k )pprParendTypeWildCardT =char '_'pprParendType(InfixT x n y )=parens (ppr x <+> pprName' Infix n <+> ppr y )pprParendTypet @(UInfixT {})=parens (pprUInfixT t )pprParendType(ParensT t )=ppr t pprParendTypetuple |(TupleT n ,args )<-split tuple ,lengthargs ==n =parens (commaSep args )pprParendTypeother =parens (ppr other )pprUInfixT::Type ->Doc pprUInfixT (UInfixT x n y )=pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y pprUInfixTt =ppr t instancePpr Type whereppr (ForallT tvars ctxt ty )=sep [pprForall tvars ctxt ,ppr ty ]pprty =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). -}pprTyApp::(Type ,[Type ])->Doc pprTyApp (ArrowT ,[arg1 ,arg2 ])=sep [pprFunArgType arg1 <+> text "->",ppr arg2 ]pprTyApp(EqualityT ,[arg1 ,arg2 ])=sep [pprFunArgType arg1 <+> text "~",ppr arg2 ]pprTyApp(ListT ,[arg ])=brackets (ppr arg )pprTyApp(TupleT n ,args )|lengthargs ==n =parens (commaSep args )pprTyApp(PromotedTupleT n ,args )|lengthargs ==n =quoteParens (commaSep args )pprTyApp(fun ,args )=pprParendType fun <+> sep (mappprParendType args )pprFunArgType::Type ->Doc -- Should really use a precedence argument-- Everything except forall and (->) binds more tightly than (->)pprFunArgType ty @(ForallT {})=parens (ppr ty )pprFunArgTypety @((ArrowT `AppT `_)`AppT `_)=parens (ppr ty )pprFunArgTypety @(SigT __)=parens (ppr ty )pprFunArgTypety =ppr ty split::Type ->(Type ,[Type ])-- Split into function and argssplit t =go t []wherego (AppT t1 t2 )args =go t1 (t2 :args )goty args =(ty ,args )pprTyLit::TyLit ->Doc pprTyLit (NumTyLit n )=integer n pprTyLit(StrTyLit s )=text (shows )instancePpr TyLit whereppr =pprTyLit ------------------------------instancePpr TyVarBndr whereppr (PlainTV nm )=ppr nm ppr(KindedTV nm k )=parens (ppr nm <+> dcolon <+> ppr k )instancePpr Role whereppr NominalR =text "nominal"pprRepresentationalR =text "representational"pprPhantomR =text "phantom"pprInferR =text "_"------------------------------pprCxt::Cxt ->Doc pprCxt []=empty pprCxtts =ppr_cxt_preds ts <+> text "=>"ppr_cxt_preds::Cxt ->Doc ppr_cxt_preds []=empty ppr_cxt_preds[t ]=ppr t ppr_cxt_predsts =parens (commaSep ts )------------------------------instancePpr Range whereppr =brackets .pprRange wherepprRange::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 where_clauseds =nest nestDepth $text "where"<+> vcat (map(ppr_dec False)ds )showtextl::Showa =>a ->Doc showtextl =text .maptoLower.showhashParens::Doc ->Doc hashParens d =text "(# "<> d <> text " #)"quoteParens::Doc ->Doc quoteParens d =text "'("<> d <> text ")"-----------------------------instancePpr Loc whereppr (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 ]-- Takes a list of printable things and prints them separated by commas followed-- by space.commaSep::Ppr a =>[a ]->Doc 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 .mappprFun -- Takes a list of printable things and prints them separated by semicolons-- followed by space.semiSep::Ppr a =>[a ]->Doc semiSep =sep .punctuate semi .mapppr -- Prints out the series of vertical bars that wraps an expression or pattern-- used in an unboxed sum.unboxedSumBars::Doc ->SumAlt ->SumArity ->Doc unboxedSumBars d alt arity =hashParens $bars (alt -1)<> d <> bars (arity -alt )wherebars i =hsep (replicatei bar )-- Text containing the vertical bar character.bar::Doc bar =char '|'