summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/DynFlags.hs17
-rw-r--r--compiler/typecheck/TcGenGenerics.lhs32
-rw-r--r--compiler/typecheck/TcHsType.lhs2
-rw-r--r--compiler/utils/Outputable.lhs4
-rw-r--r--compiler/vectorise/Vectorise.hs12
-rw-r--r--compiler/vectorise/Vectorise/Monad/Base.hs2
-rw-r--r--ghc/InteractiveUI.hs2
7 files changed, 40 insertions, 31 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 52982c1185..a0feded09d 100644
--- a/compiler/main/DynFlags.hs
+++ b/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]
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index 89444b2b9e..27f21c2e25 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/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
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 80518471a7..2a1f4f3540 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/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
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index c0b77bb9bd..1649bb0059 100644
--- a/compiler/utils/Outputable.lhs
+++ b/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}
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 637897d900..c92ae8073e 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/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
diff --git a/compiler/vectorise/Vectorise/Monad/Base.hs b/compiler/vectorise/Vectorise/Monad/Base.hs
index 8483aa8002..e47015c548 100644
--- a/compiler/vectorise/Vectorise/Monad/Base.hs
+++ b/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 --------------------------------------------------------------------
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 4e8325238e..a57d8e7213 100644
--- a/ghc/InteractiveUI.hs
+++ b/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 $
View Lorry Controller Status