Pass DynFlags down to showPpr

compiler/main/DynFlags.hs

@@ -377,12 +377,15 @@ data SafeHaskellMode
    | Sf_SafeInfered
    deriving (Eq)
 
+instance Show SafeHaskellMode where
+    show Sf_None        = "None"
+    show Sf_Unsafe      = "Unsafe"
+    show Sf_Trustworthy = "Trustworthy"
+    show Sf_Safe        = "Safe"
+    show Sf_SafeInfered = "Safe-Infered"
+
 instance Outputable SafeHaskellMode where
-    ppr Sf_None        = ptext $ sLit "None"
-    ppr Sf_Unsafe      = ptext $ sLit "Unsafe"
-    ppr Sf_Trustworthy = ptext $ sLit "Trustworthy"
-    ppr Sf_Safe        = ptext $ sLit "Safe"
-    ppr Sf_SafeInfered = ptext $ sLit "Safe-Infered"
+    ppr = text . show
 
 data ExtensionFlag
    = Opt_Cpp
@@ -1181,7 +1184,7 @@ combineSafeFlags a b | a == Sf_SafeInfered = return b
                      | a == b              = return a
                      | otherwise           = addErr errm >> return (panic errm)
     where errm = "Incompatible Safe Haskell flags! ("
-                    ++ showPpr a ++ ", " ++ showPpr b ++ ")"
+                    ++ show a ++ ", " ++ show b ++ ")"
 
 -- | A list of unsafe flags under Safe Haskell. Tuple elements are:
 --     * name of the flag
@@ -2004,7 +2007,7 @@ languageFlags = [
 -- features can be used.
 safeHaskellFlags :: [FlagSpec SafeHaskellMode]
 safeHaskellFlags = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]
-    where mkF flag = (showPpr flag, flag, nop)
+    where mkF flag = (show flag, flag, nop)
 
 -- | These -X<blah> flags can all be reversed with -XNo<blah>
 xFlags :: [FlagSpec ExtensionFlag]

compiler/typecheck/TcGenGenerics.lhs

@@ -67,7 +67,8 @@ gen_Generic_binds :: TyCon -> Module
 gen_Generic_binds tc mod = do
         { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
         ; metaInsts                <- genDtMeta (tc, metaTyCons)
-        ; return ( mkBindsRep tc
+        ; dflags <- getDynFlags
+        ; return ( mkBindsRep dflags tc
                  ,           (DerivFamInst rep0TyInst)
                    `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
                    `unionBags` metaInsts)) }
@@ -132,7 +133,7 @@ genDtMeta (tc,metaDts) =
 
       let
         safeOverlap = safeLanguageOn dflags
-        (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
+        (dBinds,cBinds,sBinds) = mkBindsMetaD dflags fix_env tc
         
         -- Datatype
         d_metaTycon = metaD metaDts
@@ -234,8 +235,8 @@ type US = Int	-- Local unique supply, just a plain Int
 type Alt = (LPat RdrName, LHsExpr RdrName)
 
 -- Bindings for the Generic instance
-mkBindsRep :: TyCon -> LHsBinds RdrName
-mkBindsRep tycon = 
+mkBindsRep :: DynFlags -> TyCon -> LHsBinds RdrName
+mkBindsRep dflags tycon =
     unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
   `unionBags`
     unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
@@ -247,7 +248,7 @@ mkBindsRep tycon =
 
         -- Recurse over the sum first
         from_alts, to_alts :: [Alt]
-        (from_alts, to_alts) = mkSum (1 :: US) tycon datacons
+        (from_alts, to_alts) = mkSum dflags (1 :: US) tycon datacons
         
 --------------------------------------------------------------------------------
 -- The type instance synonym and synonym
@@ -364,11 +365,11 @@ metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
 
 
 -- Bindings for Datatype, Constructor, and Selector instances
-mkBindsMetaD :: FixityEnv -> TyCon 
+mkBindsMetaD :: DynFlags -> FixityEnv -> TyCon 
              -> ( LHsBinds RdrName      -- Datatype instance
                 , [LHsBinds RdrName]    -- Constructor instances
                 , [[LHsBinds RdrName]]) -- Selector instances
-mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
+mkBindsMetaD dflags fix_env tycon = (dtBinds, allConBinds, allSelBinds)
       where
         mkBag l = foldr1 unionBags 
                     [ unitBag (L loc (mkFunBind (L loc name) matches)) 
@@ -400,41 +401,42 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
         datacons      = tyConDataCons tycon
         datasels      = map dataConFieldLabels datacons
 
-        dtName_matches     = mkStringLHS . showPpr . nameOccName . tyConName 
+        dtName_matches     = mkStringLHS . showPpr dflags . nameOccName . tyConName 
                            $ tycon
         moduleName_matches = mkStringLHS . moduleNameString . moduleName 
                            . nameModule . tyConName $ tycon
 
-        conName_matches     c = mkStringLHS . showPpr . nameOccName
+        conName_matches     c = mkStringLHS . showPpr dflags . nameOccName
                               . dataConName $ c
         conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
         conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
 
-        selName_matches     s = mkStringLHS (showPpr (nameOccName s))
+        selName_matches     s = mkStringLHS (showPpr dflags (nameOccName s))
 
 
 --------------------------------------------------------------------------------
 -- Dealing with sums
 --------------------------------------------------------------------------------
 
-mkSum :: US          -- Base for generating unique names
+mkSum :: DynFlags
+      -> US          -- Base for generating unique names
       -> TyCon       -- The type constructor
       -> [DataCon]   -- The data constructors
       -> ([Alt],     -- Alternatives for the T->Trep "from" function
           [Alt])     -- Alternatives for the Trep->T "to" function
 
 -- Datatype without any constructors
-mkSum _us tycon [] = ([from_alt], [to_alt])
+mkSum dflags _us tycon [] = ([from_alt], [to_alt])
   where
     from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
     to_alt   = (mkM1_P nlWildPat, makeError errMsgTo)
                -- These M1s are meta-information for the datatype
     makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
-    errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon
-    errMsgTo = "No values for empty datatype " ++ showPpr tycon
+    errMsgFrom = "No generic representation for empty datatype " ++ showPpr dflags tycon
+    errMsgTo = "No values for empty datatype " ++ showPpr dflags tycon
 
 -- Datatype with at least one constructor
-mkSum us _tycon datacons =
+mkSum _ us _tycon datacons =
   unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
 
 -- Build the sum for a particular constructor

compiler/typecheck/TcHsType.lhs

@@ -1355,7 +1355,7 @@ tc_hs_kind (HsTupleTy _ kis) =
      tycon = promotedTupleTyCon BoxedTuple (length kis)
 
 -- Argument not kind-shaped
-tc_hs_kind k = panic ("tc_hs_kind: " ++ showPpr k)
+tc_hs_kind k = pprPanic "tc_hs_kind" (ppr k)
 
 -- Special case for kind application
 tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind

compiler/utils/Outputable.lhs

@@ -399,8 +399,8 @@ showSDocDumpOneLine d
 showSDocDebug :: SDoc -> String
 showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
 
-showPpr :: Outputable a => a -> String
-showPpr = showSDoc . ppr
+showPpr :: Outputable a => DynFlags -> a -> String
+showPpr _ = showSDoc . ppr
 \end{code}
 
 \begin{code}

compiler/vectorise/Vectorise.hs

@@ -264,10 +264,11 @@ vectTopBinder var inline expr
           Just (vdty, _) 
             | eqType vty vdty -> return ()
             | otherwise       -> 
-              cantVectorise ("Type mismatch in vectorisation pragma for " ++ showSDoc (ppr var)) $
-                (text "Expected type" <+> ppr vty)
-                $$
-                (text "Inferred type" <+> ppr vdty)
+              do dflags <- getDynFlags
+                 cantVectorise ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $
+                   (text "Expected type" <+> ppr vty)
+                   $$
+                   (text "Inferred type" <+> ppr vdty)
 
           -- Make the vectorised version of binding's name, and set the unfolding used for inlining
       ; var' <- liftM (`setIdUnfoldingLazily` unfolding) 
@@ -350,9 +351,10 @@ vectTopRhs recFs var expr
   = closedV
   $ do { globalScalar <- isGlobalScalarVar var
        ; vectDecl     <- lookupVectDecl var
+       ; dflags       <- getDynFlags
        ; let isDFun = isDFunId var
 
-       ; traceVt ("vectTopRhs of " ++ showSDoc (ppr var) ++ info globalScalar isDFun vectDecl ++ ":") $ 
+       ; traceVt ("vectTopRhs of " ++ showPpr dflags var ++ info globalScalar isDFun vectDecl ++ ":") $
            ppr expr
 
        ; rhs globalScalar isDFun vectDecl

compiler/vectorise/Vectorise/Monad/Base.hs

@@ -69,6 +69,8 @@ instance Functor VM where
 instance MonadIO VM where
   liftIO = liftDs . liftIO
 
+instance HasDynFlags VM where
+    getDynFlags = liftDs getDynFlags
 
 -- Lifting --------------------------------------------------------------------
 

ghc/InteractiveUI.hs

@@ -1443,7 +1443,7 @@ isSafeModule m = do
 
     let iface' = fromJust iface
 
-        trust = showPpr $ getSafeMode $ GHC.mi_trust iface'
+        trust = showPpr dflags $ getSafeMode $ GHC.mi_trust iface'
         pkgT  = packageTrusted dflags m
         pkg   = if pkgT then "trusted" else "untrusted"
         (good', bad') = tallyPkgs dflags $