Merge branch 'refs/heads/vect-avoid' into vect-avoid-merge
[ghc.git] / compiler / coreSyn / PprCore.lhs
index a8ed4b8..fa1cde9 100644 (file)
@@ -25,12 +25,10 @@ import TyCon
 import Type
 import Coercion
 import DynFlags
-import StaticFlags
 import BasicTypes
 import Util
 import Outputable
 import FastString
-import Data.Maybe
 \end{code}
 
 %************************************************************************
@@ -119,9 +117,11 @@ ppr_expr add_par (Cast expr co)
     sep [pprParendExpr expr,
          ptext (sLit "`cast`") <+> pprCo co]
   where
-    pprCo co | opt_SuppressCoercions = ptext (sLit "...")
-             | otherwise = parens
-                         $ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
+    pprCo co = sdocWithDynFlags $ \dflags ->
+               if gopt Opt_SuppressCoercions dflags
+               then ptext (sLit "...")
+               else parens $
+                        sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
 
 
 ppr_expr add_par expr@(Lam _ _)
@@ -156,7 +156,7 @@ ppr_expr add_par expr@(App {})
 
 ppr_expr add_par (Case expr var ty [(con,args,rhs)])
   = sdocWithDynFlags $ \dflags ->
-    if dopt Opt_PprCaseAsLet dflags
+    if gopt Opt_PprCaseAsLet dflags
     then add_par $
          sep [sep    [ ptext (sLit "let")
                              <+> char '{'
@@ -242,7 +242,7 @@ ppr_case_pat (DataAlt dc) args
     tc = dataConTyCon dc
 
 ppr_case_pat con args
-  = ppr con <+> sep (map ppr_bndr args)
+  = ppr con <+> (fsep (map ppr_bndr args))
   where
     ppr_bndr = pprBndr CaseBind
 
@@ -250,8 +250,10 @@ ppr_case_pat con args
 -- | Pretty print the argument in a function application.
 pprArg :: OutputableBndr a => Expr a -> SDoc
 pprArg (Type ty)
- | opt_SuppressTypeApplications = empty
- | otherwise                    = ptext (sLit "@") <+> pprParendType ty
+ = sdocWithDynFlags $ \dflags ->
+   if gopt Opt_SuppressTypeApplications dflags
+   then empty
+   else ptext (sLit "@") <+> pprParendType ty
 pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
 pprArg expr          = pprParendExpr expr
 \end{code}
@@ -284,12 +286,18 @@ pprUntypedBinder binder
 pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
 -- For lambda and case binders, show the unfolding info (usually none)
 pprTypedLamBinder bind_site debug_on var
-  | not debug_on && isDeadBinder var    = char '_'
-  | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
-  | opt_SuppressAll                     = pprUntypedBinder var  -- Suppress the signature
-  | isTyVar var                         = parens (pprKindedTyVarBndr var)
-  | otherwise = parens (hang (pprIdBndr var)
-                           2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
+  = sdocWithDynFlags $ \dflags ->
+    case () of
+    _
+      | not debug_on && isDeadBinder var       -> char '_'
+      | not debug_on, CaseBind <- bind_site    -> -- No parens, no kind info
+                                                  pprUntypedBinder var
+      | gopt Opt_SuppressTypeSignatures dflags -> -- Suppress the signature
+                                                  pprUntypedBinder var
+      | isTyVar var                            -> parens (pprKindedTyVarBndr var)
+      | otherwise ->
+            parens (hang (pprIdBndr var)
+                         2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
   where
     unf_info = unfoldingInfo (idInfo var)
     pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
@@ -298,9 +306,12 @@ pprTypedLamBinder bind_site debug_on var
 pprTypedLetBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
 pprTypedLetBinder binder
-  | isTyVar binder             = pprKindedTyVarBndr binder
-  | opt_SuppressTypeSignatures = pprIdBndr binder
-  | otherwise                  = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
+  = sdocWithDynFlags $ \dflags ->
+    case () of
+    _
+      | isTyVar binder                         -> pprKindedTyVarBndr binder
+      | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder
+      | otherwise                              -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
 pprKindedTyVarBndr :: TyVar -> SDoc
 -- Print a type variable binder with its kind (but not if *)
@@ -314,19 +325,20 @@ pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
 
 pprIdBndrInfo :: IdInfo -> SDoc
 pprIdBndrInfo info
-  | opt_SuppressIdInfo = empty
-  | otherwise
-  = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
+  = sdocWithDynFlags $ \dflags ->
+    if gopt Opt_SuppressIdInfo dflags
+    then empty
+    else megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
   where
     prag_info = inlinePragInfo info
     occ_info  = occInfo info
     dmd_info  = demandInfo info
     lbv_info  = lbvarInfo info
 
-    has_prag = not (isDefaultInlinePragma prag_info)
-    has_occ  = not (isNoOcc occ_info)
-    has_dmd  = case dmd_info of { Nothing -> False; Just d -> not (isTop d) }
-    has_lbv  = not (hasNoLBVarInfo lbv_info)
+    has_prag  = not (isDefaultInlinePragma prag_info)
+    has_occ   = not (isNoOcc occ_info)
+    has_dmd   = not $ isTopDmd dmd_info 
+    has_lbv   = not (hasNoLBVarInfo lbv_info)
 
     doc = showAttributes
           [ (has_prag, ptext (sLit "InlPrag=") <> ppr prag_info)
@@ -344,13 +356,15 @@ pprIdBndrInfo info
 \begin{code}
 ppIdInfo :: Id -> IdInfo -> SDoc
 ppIdInfo id info
-  | opt_SuppressIdInfo  = empty
-  | otherwise
-  = showAttributes
+  = sdocWithDynFlags $ \dflags ->
+    if gopt Opt_SuppressIdInfo dflags
+    then empty
+    else
+    showAttributes
     [ (True, pp_scope <> ppr (idDetails id))
     , (has_arity,      ptext (sLit "Arity=") <> int arity)
     , (has_caf_info,   ptext (sLit "Caf=") <> ppr caf_info)
-    , (has_strictness, ptext (sLit "Str=") <> pprStrictness str_info)
+    , (True,           ptext (sLit "Str=") <> pprStrictness str_info)
     , (has_unf,        ptext (sLit "Unf=") <> ppr unf_info)
     , (not (null rules), ptext (sLit "RULES:") <+> vcat (map pprRule rules))
     ]   -- Inline pragma, occ, demand, lbvar info
@@ -368,7 +382,6 @@ ppIdInfo id info
     has_caf_info = not (mayHaveCafRefs caf_info)
 
     str_info = strictnessInfo info
-    has_strictness = isJust str_info
 
     unf_info = unfoldingInfo info
     has_unf = hasSomeUnfolding unf_info