Commit 0fdca5de authored by Ian Lynagh's avatar Ian Lynagh

Pass DynFlags down to showPpr

parent 1bb4428c
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -69,6 +69,8 @@ instance Functor VM where
instance MonadIO VM where
liftIO = liftDs . liftIO
instance HasDynFlags VM where
getDynFlags = liftDs getDynFlags
-- Lifting --------------------------------------------------------------------
......
......@@ -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 $
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment