X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FPprCore.lhs;h=3c4a7ba2e52910b94c215b512468a1e7951dd17f;hb=705f3b64dec2b8d8340b3d370d76a70500833268;hp=ed00cac6202037d8bda50466cbfc896ab043ef51;hpb=f01a8e8c9c53bfb5ab3393ed3457ebf25390efa1;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index ed00cac..3c4a7ba 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -11,32 +11,32 @@ #include "HsVersions.h" module PprCore ( - pprCoreExpr, - pprCoreBinding, + pprCoreExpr, pprIfaceUnfolding, + pprCoreBinding, pprCoreBindings, pprBigCoreBinder, pprTypedCoreBinder -- these are here to make the instances go in 0.26: -#if __GLASGOW_HASKELL__ <= 26 +#if __GLASGOW_HASKELL__ <= 30 , GenCoreBinding, GenCoreExpr, GenCoreCaseAlts , GenCoreCaseDefault, GenCoreArg #endif ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn import CostCentre ( showCostCentre ) import Id ( idType, getIdInfo, getIdStrictness, isTupleCon, - nullIdEnv, DataCon(..), GenId{-instances-} - ) -import IdInfo ( ppIdInfo, StrictnessInfo(..) ) + nullIdEnv, SYN_IE(DataCon), GenId{-instances-}, + SYN_IE(Id) + ) +import IdInfo ( ppIdInfo, ppStrictnessInfo ) import Literal ( Literal{-instances-} ) -import Name ( isSymLexeme ) +import Name ( OccName ) import Outputable -- quite a few things import PprEnv -import PprType ( GenType{-instances-}, GenTyVar{-instance-} ) -import PprStyle ( PprStyle(..) ) +import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} ) import Pretty import PrimOp ( PrimOp{-instances-} ) import TyVar ( GenTyVar{-instances-} ) @@ -57,7 +57,7 @@ function for ``major'' val_bdrs (those next to equal signs :-), usually be called through some intermediary. The binder/occ printers take the default ``homogenized'' (see -@PprEnv@...) @Pretty@ and the binder/occ. They can either use the +@PprEnv@...) @Doc@ and the binder/occ. They can either use the homogenized one, or they can ignore it completely. In other words, the things passed in act as ``hooks'', getting the last word on how to print something. @@ -65,73 +65,99 @@ print something. @pprParendCoreExpr@ puts parens around non-atomic Core expressions. \begin{code} -pprCoreBinding :: PprStyle -> CoreBinding -> Pretty +pprCoreBinding :: PprStyle -> CoreBinding -> Doc +pprCoreBindings :: PprStyle -> [CoreBinding] -> Doc pprGenCoreBinding - :: (Eq tyvar, Outputable tyvar, + :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable bndr, Outputable occ) => PprStyle - -> (bndr -> Pretty) -- to print "major" val_bdrs - -> (bndr -> Pretty) -- to print "minor" val_bdrs - -> (occ -> Pretty) -- to print bindees + -> (bndr -> Doc) -- to print "major" val_bdrs + -> (bndr -> Doc) -- to print "minor" val_bdrs + -> (occ -> Doc) -- to print bindees -> GenCoreBinding bndr occ tyvar uvar - -> Pretty + -> Doc pprGenCoreBinding sty pbdr1 pbdr2 pocc bind - = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind + = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind -init_ppr_env sty pbdr1 pbdr2 pocc +init_ppr_env sty tvbndr pbdr1 pbdr2 pocc = initPprEnv sty (Just (ppr sty)) -- literals - (Just (ppr sty)) -- data cons - (Just (ppr sty)) -- primops - (Just (\ cc -> ppStr (showCostCentre sty True cc))) - (Just (ppr sty)) -- tyvars - (Just (ppr sty)) -- usage vars + (Just ppr_con) -- data cons + (Just ppr_prim) -- primops + (Just (\ cc -> text (showCostCentre sty True cc))) + (Just tvbndr) -- tyvar binders + (Just (ppr sty)) -- tyvar occs + (Just (ppr sty)) -- usage vars (Just pbdr1) (Just pbdr2) (Just pocc) -- value vars - (Just (ppr sty)) -- types - (Just (ppr sty)) -- usages + (Just (pprParendGenType sty)) -- types + (Just (ppr sty)) -- usages + where + + ppr_con con = ppr sty con + +{- [We now use Con {a,b,c} for Con expressions. SLPJ March 97.] + [We can't treat them as ordinary applications because the Con doesn't have + dictionaries in it, whereas the constructor Id does.] + + OLD VERSION: + -- ppr_con is used when printing Con expressions; we add a "!" + -- to distinguish them from ordinary applications. But not when + -- printing for interfaces, where they are treated as ordinary applications + ppr_con con | ifaceStyle sty = ppr sty con + | otherwise = ppr sty con <> char '!' +-} + + -- We add a "!" to distinguish Primitive applications from ordinary applications. + -- But not when printing for interfaces, where they are treated + -- as ordinary applications + ppr_prim prim | ifaceStyle sty = ppr sty prim + | otherwise = ppr sty prim <> char '!' -------------- +pprCoreBindings sty binds = vcat (map (pprCoreBinding sty) binds) + pprCoreBinding sty (NonRec binder expr) - = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) + = hang (hsep [pprBigCoreBinder sty binder, equals]) 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) pprCoreBinding sty (Rec binds) - = ppAboves [ifPprDebug sty (ppStr "{- plain Rec -}"), - ppAboves (map ppr_bind binds), - ifPprDebug sty (ppStr "{- end plain Rec -}")] + = vcat [ptext SLIT("Rec {"), + vcat (map ppr_bind binds), + ptext SLIT("end Rec }")] where ppr_bind (binder, expr) - = ppHang (ppCat [pprBigCoreBinder sty binder, ppEquals]) + = hang (hsep [pprBigCoreBinder sty binder, equals]) 4 (pprCoreExpr sty (pprBigCoreBinder sty) (pprBabyCoreBinder sty) (ppr sty) expr) \end{code} \begin{code} pprCoreExpr :: PprStyle - -> (Id -> Pretty) -- to print "major" val_bdrs - -> (Id -> Pretty) -- to print "minor" val_bdrs - -> (Id -> Pretty) -- to print bindees + -> (Id -> Doc) -- to print "major" val_bdrs + -> (Id -> Doc) -- to print "minor" val_bdrs + -> (Id -> Doc) -- to print bindees -> CoreExpr - -> Pretty + -> Doc pprCoreExpr = pprGenCoreExpr pprGenCoreExpr, pprParendCoreExpr - :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, + :: (Eq tyvar, Outputable tyvar, + Eq uvar, Outputable uvar, Outputable bndr, Outputable occ) => PprStyle - -> (bndr -> Pretty) -- to print "major" val_bdrs - -> (bndr -> Pretty) -- to print "minor" val_bdrs - -> (occ -> Pretty) -- to print bindees + -> (bndr -> Doc) -- to print "major" val_bdrs + -> (bndr -> Doc) -- to print "minor" val_bdrs + -> (occ -> Doc) -- to print bindees -> GenCoreExpr bndr occ tyvar uvar - -> Pretty + -> Doc pprGenCoreExpr sty pbdr1 pbdr2 pocc expr - = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr + = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr pprParendCoreExpr sty pbdr1 pbdr2 pocc expr = let @@ -139,18 +165,27 @@ pprParendCoreExpr sty pbdr1 pbdr2 pocc expr = case expr of Var _ -> id -- leave unchanged Lit _ -> id - _ -> ppParens -- wraps in parens + _ -> parens -- wraps in parens in parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr) +-- Printer for unfoldings in interfaces +pprIfaceUnfolding :: CoreExpr -> Doc +pprIfaceUnfolding = ppr_expr env + where + env = init_ppr_env PprInterface (pprTyVarBndr PprInterface) + (pprTypedCoreBinder PprInterface) + (ppr PprInterface) + (ppr PprInterface) + ppr_core_arg sty pocc arg - = ppr_arg (init_ppr_env sty pocc pocc pocc) arg + = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg ppr_core_alts sty pbdr1 pbdr2 pocc alts - = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts + = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts ppr_core_default sty pbdr1 pbdr2 pocc deflt - = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt + = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt \end{code} %************************************************************************ @@ -165,34 +200,39 @@ instance Eq uvar, Outputable uvar) => Outputable (GenCoreBinding bndr occ tyvar uvar) where - ppr sty bind = pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind + ppr sty bind = pprQuote sty $ \sty -> + pprGenCoreBinding sty (ppr sty) (ppr sty) (ppr sty) bind instance (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (GenCoreExpr bndr occ tyvar uvar) where - ppr sty expr = pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr + ppr sty expr = pprQuote sty $ \sty -> + pprGenCoreExpr sty (ppr sty) (ppr sty) (ppr sty) expr instance (Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (GenCoreArg occ tyvar uvar) where - ppr sty arg = ppr_core_arg sty (ppr sty) arg + ppr sty arg = pprQuote sty $ \sty -> + ppr_core_arg sty (ppr sty) arg instance (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (GenCoreCaseAlts bndr occ tyvar uvar) where - ppr sty alts = ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts + ppr sty alts = pprQuote sty $ \sty -> + ppr_core_alts sty (ppr sty) (ppr sty) (ppr sty) alts instance (Outputable bndr, Outputable occ, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (GenCoreCaseDefault bndr occ tyvar uvar) where - ppr sty deflt = ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt + ppr sty deflt = pprQuote sty $ \sty -> + ppr_core_default sty (ppr sty) (ppr sty) (ppr sty) deflt \end{code} %************************************************************************ @@ -203,17 +243,15 @@ instance \begin{code} ppr_bind pe (NonRec val_bdr expr) - = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) + = hang (hsep [pMajBndr pe val_bdr, equals]) 4 (ppr_expr pe expr) ppr_bind pe (Rec binds) - = ppAboves [ ppStr "{- Rec -}", - ppAboves (map ppr_pair binds), - ppStr "{- end Rec -}" ] + = vcat (map ppr_pair binds) where ppr_pair (val_bdr, expr) - = ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) - 4 (ppr_expr pe expr) + = hang (hsep [pMajBndr pe val_bdr, equals]) + 4 (ppr_expr pe expr <> semi) \end{code} \begin{code} @@ -223,7 +261,7 @@ ppr_parend_expr pe expr = case expr of Var _ -> id -- leave unchanged Lit _ -> id - _ -> ppParens -- wraps in parens + _ -> parens -- wraps in parens in parenify (ppr_expr pe expr) \end{code} @@ -231,118 +269,153 @@ ppr_parend_expr pe expr \begin{code} ppr_expr pe (Var name) = pOcc pe name ppr_expr pe (Lit lit) = pLit pe lit -ppr_expr pe (Con con []) = pCon pe con ppr_expr pe (Con con args) - = ppHang (ppBesides [pCon pe con, ppChar '!']) - 4 (ppSep (map (ppr_arg pe) args)) + = hang (pCon pe con) + 4 (braces $ sep (map (ppr_arg pe) args)) ppr_expr pe (Prim prim args) - = ppHang (ppBesides [pPrim pe prim, ppChar '!']) - 4 (ppSep (map (ppr_arg pe) args)) + = hang (pPrim pe prim) + 4 (sep (map (ppr_arg pe) args)) ppr_expr pe expr@(Lam _ _) = let (uvars, tyvars, vars, body) = collectBinders expr in - ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar pe) uvars, - pp_vars SLIT("_/\\_") (pTyVar pe) tyvars, - pp_vars SLIT("\\") (pMinBndr pe) vars]) + hang (hsep [pp_vars SLIT("/u\\") (pUVar pe) uvars, + pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars, + pp_vars SLIT("\\") (pMajndr pe) vars]) 4 (ppr_expr pe body) where - pp_vars lam pp [] = ppNil + pp_vars lam pp [] = empty pp_vars lam pp vs - = ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"] + = hsep [ptext lam, hsep (map pp vs), ptext SLIT("->")] -ppr_expr pe expr@(App _ _) +ppr_expr pe expr@(App fun arg) = let - (fun, uargs, targs, vargs) = collectArgs expr + (final_fun, final_args) = go fun [arg] + go (App fun arg) args_so_far = go fun (arg:args_so_far) + go fun args_so_far = (fun, args_so_far) in - ppHang (ppr_parend_expr pe fun) - 4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs) - , ppInterleave ppNil (map (pTy pe) targs) - , ppInterleave ppNil (map (ppr_arg pe) vargs) - ]) + hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args)) ppr_expr pe (Case expr alts) - = ppSep - [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"], - ppNest 2 (ppr_alts pe alts), - ppStr "}"] + | only_one_alt alts + -- johan thinks that single case patterns should be on same line as case, + -- and no indent; all sane persons agree with him. + = let + + ppr_alt (AlgAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow + ppr_alt (PrimAlts [] (BindDefault n _)) = (<>) (pMinBndr pe n) ppr_arrow + ppr_alt (PrimAlts ((l, _):[]) NoDefault)= (<>) (pLit pe l) ppr_arrow + ppr_alt (AlgAlts ((con, params, _):[]) NoDefault) + = hsep [pCon pe con, + hsep (map (pMinBndr pe) params), + ppr_arrow] + + ppr_rhs (AlgAlts [] (BindDefault _ expr)) = ppr_expr pe expr + ppr_rhs (AlgAlts ((_,_,expr):[]) NoDefault) = ppr_expr pe expr + ppr_rhs (PrimAlts [] (BindDefault _ expr)) = ppr_expr pe expr + ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr + + + ppr_arrow = ptext SLIT(" ->") + in + sep + [sep [pp_keyword, nest 4 (ppr_expr pe expr), text "of {", ppr_alt alts], + (<>) (ppr_rhs alts) (text ";}")] + + | otherwise -- default "case" printing + = sep + [sep [pp_keyword, nest 4 (ppr_expr pe expr), ptext SLIT("of {")], + nest 2 (ppr_alts pe alts), + text "}"] + where + pp_keyword = case alts of + AlgAlts _ _ -> ptext SLIT("case") + PrimAlts _ _ -> ptext SLIT("case#") -- special cases: let ... in let ... -- ("disgusting" SLPJ) ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) - = ppAboves [ - ppCat [ppStr "let {", pMajBndr pe val_bdr, ppEquals], - ppNest 2 (ppr_expr pe rhs), - ppStr "} in", + = vcat [ + hsep [ptext SLIT("let {"), pMajBndr pe val_bdr, equals], + nest 2 (ppr_expr pe rhs), + ptext SLIT("} in"), ppr_expr pe body ] ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) - = ppAbove - (ppHang (ppStr "let {") - 2 (ppCat [ppHang (ppCat [pMajBndr pe val_bdr, ppEquals]) + = ($$) + (hang (ptext SLIT("let {")) + 2 (hsep [hang (hsep [pMajBndr pe val_bdr, equals]) 4 (ppr_expr pe rhs), - ppStr "} in"])) + ptext SLIT("} in")])) (ppr_expr pe expr) -- general case (recursive case, too) ppr_expr pe (Let bind expr) - = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind), - ppHang (ppStr "} in ") 2 (ppr_expr pe expr)] + = sep [hang (ptext keyword) 2 (ppr_bind pe bind), + hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)] + where + keyword = case bind of + Rec _ -> SLIT("_letrec_ {") + NonRec _ _ -> SLIT("let {") ppr_expr pe (SCC cc expr) - = ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc], + = sep [hsep [ptext SLIT("_scc_"), pSCC pe cc], ppr_parend_expr pe expr ] ppr_expr pe (Coerce c ty expr) - = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c], - pTy pe ty, ppr_parend_expr pe expr ] + = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr] where - pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v) - pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v) + pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr (pStyle pe) v) + pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr (pStyle pe) v) + +only_one_alt (AlgAlts [] (BindDefault _ _)) = True +only_one_alt (AlgAlts (_:[]) NoDefault) = True +only_one_alt (PrimAlts [] (BindDefault _ _)) = True +only_one_alt (PrimAlts (_:[]) NoDefault) = True +only_one_alt _ = False \end{code} \begin{code} ppr_alts pe (AlgAlts alts deflt) - = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] + = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ] where + ppr_arrow = ptext SLIT("->") + ppr_alt (con, params, expr) - = ppHang (if isTupleCon con then - ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)), - ppStr "->"] + = hang (if isTupleCon con then + hsep [parens (hsep (punctuate comma (map (pMinBndr pe) params))), + ppr_arrow] else - ppCat [ppr_con con (pCon pe con), - ppInterleave ppSP (map (pMinBndr pe) params), - ppStr "->"] + hsep [pCon pe con, + hsep (map (pMinBndr pe) params), + ppr_arrow] ) - 4 (ppr_expr pe expr) - where - ppr_con con pp_con - = if isSymLexeme con then ppParens pp_con else pp_con + 4 (ppr_expr pe expr <> semi) ppr_alts pe (PrimAlts alts deflt) - = ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ] + = vcat [ vcat (map ppr_alt alts), ppr_default pe deflt ] where ppr_alt (lit, expr) - = ppHang (ppCat [pLit pe lit, ppStr "->"]) - 4 (ppr_expr pe expr) + = hang (hsep [pLit pe lit, ptext SLIT("->")]) + 4 (ppr_expr pe expr <> semi) \end{code} \begin{code} -ppr_default pe NoDefault = ppNil +ppr_default pe NoDefault = empty ppr_default pe (BindDefault val_bdr expr) - = ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"]) - 4 (ppr_expr pe expr) + = hang (hsep [pMinBndr pe val_bdr, ptext SLIT("->")]) + 4 (ppr_expr pe expr <> semi) \end{code} \begin{code} ppr_arg pe (LitArg lit) = pLit pe lit ppr_arg pe (VarArg v) = pOcc pe v -ppr_arg pe (TyArg ty) = pTy pe ty +ppr_arg pe (TyArg ty) = ptext SLIT("_@_ ") <> pTy pe ty ppr_arg pe (UsageArg use) = pUse pe use \end{code} @@ -350,31 +423,15 @@ Other printing bits-and-bobs used with the general @pprCoreBinding@ and @pprCoreExpr@ functions. \begin{code} -pprBigCoreBinder sty binder - = ppAboves [sig, pragmas, ppr sty binder] - where - sig = ifnotPprShowAll sty ( - ppHang (ppCat [ppr sty binder, ppStr "::"]) - 4 (ppr sty (idType binder))) - - pragmas = - ifnotPprForUser sty - (ppIdInfo sty binder True{-specs, please-} id nullIdEnv - (getIdInfo binder)) +pprBigCoreBinder sty binder = pprTypedCoreBinder sty binder pprBabyCoreBinder sty binder - = ppCat [ppr sty binder, pp_strictness] + = hsep [ppr sty binder, pp_strictness] where - pp_strictness - = case (getIdStrictness binder) of - NoStrictnessInfo -> ppNil - BottomGuaranteed -> ppStr "{- _!_ -}" - StrictnessInfo xx _ -> - panic "PprCore:pp_strictness:StrictnessInfo:ToDo" - -- ppStr ("{- " ++ (showList xx "") ++ " -}") + pp_strictness = ppStrictnessInfo sty (getIdStrictness binder) pprTypedCoreBinder sty binder - = ppBesides [ppLparen, ppCat [ppr sty binder, - ppStr "::", ppr sty (idType binder)], - ppRparen] + = hsep [ppr sty binder, ptext SLIT("::"), pprParendGenType sty (idType binder)] + -- The space before the :: is important; it helps the lexer + -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. \end{code}