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

Pass DynFlags down to showPpr

parent 1bb4428c
...@@ -377,12 +377,15 @@ data SafeHaskellMode ...@@ -377,12 +377,15 @@ data SafeHaskellMode
| Sf_SafeInfered | Sf_SafeInfered
deriving (Eq) 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 instance Outputable SafeHaskellMode where
ppr Sf_None = ptext $ sLit "None" ppr = text . show
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"
data ExtensionFlag data ExtensionFlag
= Opt_Cpp = Opt_Cpp
...@@ -1181,7 +1184,7 @@ combineSafeFlags a b | a == Sf_SafeInfered = return b ...@@ -1181,7 +1184,7 @@ combineSafeFlags a b | a == Sf_SafeInfered = return b
| a == b = return a | a == b = return a
| otherwise = addErr errm >> return (panic errm) | otherwise = addErr errm >> return (panic errm)
where errm = "Incompatible Safe Haskell flags! (" 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: -- | A list of unsafe flags under Safe Haskell. Tuple elements are:
-- * name of the flag -- * name of the flag
...@@ -2004,7 +2007,7 @@ languageFlags = [ ...@@ -2004,7 +2007,7 @@ languageFlags = [
-- features can be used. -- features can be used.
safeHaskellFlags :: [FlagSpec SafeHaskellMode] safeHaskellFlags :: [FlagSpec SafeHaskellMode]
safeHaskellFlags = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] 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> -- | These -X<blah> flags can all be reversed with -XNo<blah>
xFlags :: [FlagSpec ExtensionFlag] xFlags :: [FlagSpec ExtensionFlag]
......
...@@ -67,7 +67,8 @@ gen_Generic_binds :: TyCon -> Module ...@@ -67,7 +67,8 @@ gen_Generic_binds :: TyCon -> Module
gen_Generic_binds tc mod = do gen_Generic_binds tc mod = do
{ (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc mod
; metaInsts <- genDtMeta (tc, metaTyCons) ; metaInsts <- genDtMeta (tc, metaTyCons)
; return ( mkBindsRep tc ; dflags <- getDynFlags
; return ( mkBindsRep dflags tc
, (DerivFamInst rep0TyInst) , (DerivFamInst rep0TyInst)
`consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons)) `consBag` ((mapBag DerivTyCon (metaTyCons2TyCons metaTyCons))
`unionBags` metaInsts)) } `unionBags` metaInsts)) }
...@@ -132,7 +133,7 @@ genDtMeta (tc,metaDts) = ...@@ -132,7 +133,7 @@ genDtMeta (tc,metaDts) =
let let
safeOverlap = safeLanguageOn dflags safeOverlap = safeLanguageOn dflags
(dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc (dBinds,cBinds,sBinds) = mkBindsMetaD dflags fix_env tc
-- Datatype -- Datatype
d_metaTycon = metaD metaDts d_metaTycon = metaD metaDts
...@@ -234,8 +235,8 @@ type US = Int -- Local unique supply, just a plain Int ...@@ -234,8 +235,8 @@ type US = Int -- Local unique supply, just a plain Int
type Alt = (LPat RdrName, LHsExpr RdrName) type Alt = (LPat RdrName, LHsExpr RdrName)
-- Bindings for the Generic instance -- Bindings for the Generic instance
mkBindsRep :: TyCon -> LHsBinds RdrName mkBindsRep :: DynFlags -> TyCon -> LHsBinds RdrName
mkBindsRep tycon = mkBindsRep dflags tycon =
unitBag (L loc (mkFunBind (L loc from_RDR) from_matches)) unitBag (L loc (mkFunBind (L loc from_RDR) from_matches))
`unionBags` `unionBags`
unitBag (L loc (mkFunBind (L loc to_RDR) to_matches)) unitBag (L loc (mkFunBind (L loc to_RDR) to_matches))
...@@ -247,7 +248,7 @@ mkBindsRep tycon = ...@@ -247,7 +248,7 @@ mkBindsRep tycon =
-- Recurse over the sum first -- Recurse over the sum first
from_alts, to_alts :: [Alt] 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 -- The type instance synonym and synonym
...@@ -364,11 +365,11 @@ metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s) ...@@ -364,11 +365,11 @@ metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
-- Bindings for Datatype, Constructor, and Selector instances -- Bindings for Datatype, Constructor, and Selector instances
mkBindsMetaD :: FixityEnv -> TyCon mkBindsMetaD :: DynFlags -> FixityEnv -> TyCon
-> ( LHsBinds RdrName -- Datatype instance -> ( LHsBinds RdrName -- Datatype instance
, [LHsBinds RdrName] -- Constructor instances , [LHsBinds RdrName] -- Constructor instances
, [[LHsBinds RdrName]]) -- Selector instances , [[LHsBinds RdrName]]) -- Selector instances
mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) mkBindsMetaD dflags fix_env tycon = (dtBinds, allConBinds, allSelBinds)
where where
mkBag l = foldr1 unionBags mkBag l = foldr1 unionBags
[ unitBag (L loc (mkFunBind (L loc name) matches)) [ unitBag (L loc (mkFunBind (L loc name) matches))
...@@ -400,41 +401,42 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) ...@@ -400,41 +401,42 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
datacons = tyConDataCons tycon datacons = tyConDataCons tycon
datasels = map dataConFieldLabels datacons datasels = map dataConFieldLabels datacons
dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName dtName_matches = mkStringLHS . showPpr dflags . nameOccName . tyConName
$ tycon $ tycon
moduleName_matches = mkStringLHS . moduleNameString . moduleName moduleName_matches = mkStringLHS . moduleNameString . moduleName
. nameModule . tyConName $ tycon . nameModule . tyConName $ tycon
conName_matches c = mkStringLHS . showPpr . nameOccName conName_matches c = mkStringLHS . showPpr dflags . nameOccName
. dataConName $ c . dataConName $ c
conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)]
conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] 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 -- Dealing with sums
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
mkSum :: US -- Base for generating unique names mkSum :: DynFlags
-> US -- Base for generating unique names
-> TyCon -- The type constructor -> TyCon -- The type constructor
-> [DataCon] -- The data constructors -> [DataCon] -- The data constructors
-> ([Alt], -- Alternatives for the T->Trep "from" function -> ([Alt], -- Alternatives for the T->Trep "from" function
[Alt]) -- Alternatives for the Trep->T "to" function [Alt]) -- Alternatives for the Trep->T "to" function
-- Datatype without any constructors -- Datatype without any constructors
mkSum _us tycon [] = ([from_alt], [to_alt]) mkSum dflags _us tycon [] = ([from_alt], [to_alt])
where where
from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom)) from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom))
to_alt = (mkM1_P nlWildPat, makeError errMsgTo) to_alt = (mkM1_P nlWildPat, makeError errMsgTo)
-- These M1s are meta-information for the datatype -- These M1s are meta-information for the datatype
makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s)) makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s))
errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon errMsgFrom = "No generic representation for empty datatype " ++ showPpr dflags tycon
errMsgTo = "No values for empty datatype " ++ showPpr tycon errMsgTo = "No values for empty datatype " ++ showPpr dflags tycon
-- Datatype with at least one constructor -- 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..] ] unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ]
-- Build the sum for a particular constructor -- Build the sum for a particular constructor
......
...@@ -1355,7 +1355,7 @@ tc_hs_kind (HsTupleTy _ kis) = ...@@ -1355,7 +1355,7 @@ tc_hs_kind (HsTupleTy _ kis) =
tycon = promotedTupleTyCon BoxedTuple (length kis) tycon = promotedTupleTyCon BoxedTuple (length kis)
-- Argument not kind-shaped -- 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 -- Special case for kind application
tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
......
...@@ -399,8 +399,8 @@ showSDocDumpOneLine d ...@@ -399,8 +399,8 @@ showSDocDumpOneLine d
showSDocDebug :: SDoc -> String showSDocDebug :: SDoc -> String
showSDocDebug d = show (runSDoc d (initSDocContext PprDebug)) showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
showPpr :: Outputable a => a -> String showPpr :: Outputable a => DynFlags -> a -> String
showPpr = showSDoc . ppr showPpr _ = showSDoc . ppr
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -264,10 +264,11 @@ vectTopBinder var inline expr ...@@ -264,10 +264,11 @@ vectTopBinder var inline expr
Just (vdty, _) Just (vdty, _)
| eqType vty vdty -> return () | eqType vty vdty -> return ()
| otherwise -> | otherwise ->
cantVectorise ("Type mismatch in vectorisation pragma for " ++ showSDoc (ppr var)) $ do dflags <- getDynFlags
(text "Expected type" <+> ppr vty) cantVectorise ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $
$$ (text "Expected type" <+> ppr vty)
(text "Inferred type" <+> ppr vdty) $$
(text "Inferred type" <+> ppr vdty)
-- Make the vectorised version of binding's name, and set the unfolding used for inlining -- Make the vectorised version of binding's name, and set the unfolding used for inlining
; var' <- liftM (`setIdUnfoldingLazily` unfolding) ; var' <- liftM (`setIdUnfoldingLazily` unfolding)
...@@ -350,9 +351,10 @@ vectTopRhs recFs var expr ...@@ -350,9 +351,10 @@ vectTopRhs recFs var expr
= closedV = closedV
$ do { globalScalar <- isGlobalScalarVar var $ do { globalScalar <- isGlobalScalarVar var
; vectDecl <- lookupVectDecl var ; vectDecl <- lookupVectDecl var
; dflags <- getDynFlags
; let isDFun = isDFunId var ; 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 ppr expr
; rhs globalScalar isDFun vectDecl ; rhs globalScalar isDFun vectDecl
......
...@@ -69,6 +69,8 @@ instance Functor VM where ...@@ -69,6 +69,8 @@ instance Functor VM where
instance MonadIO VM where instance MonadIO VM where
liftIO = liftDs . liftIO liftIO = liftDs . liftIO
instance HasDynFlags VM where
getDynFlags = liftDs getDynFlags
-- Lifting -------------------------------------------------------------------- -- Lifting --------------------------------------------------------------------
......
...@@ -1443,7 +1443,7 @@ isSafeModule m = do ...@@ -1443,7 +1443,7 @@ isSafeModule m = do
let iface' = fromJust iface let iface' = fromJust iface
trust = showPpr $ getSafeMode $ GHC.mi_trust iface' trust = showPpr dflags $ getSafeMode $ GHC.mi_trust iface'
pkgT = packageTrusted dflags m pkgT = packageTrusted dflags m
pkg = if pkgT then "trusted" else "untrusted" pkg = if pkgT then "trusted" else "untrusted"
(good', bad') = tallyPkgs dflags $ (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