Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
0fdca5de
Commit
0fdca5de
authored
Jun 12, 2012
by
Ian Lynagh
Browse files
Pass DynFlags down to showPpr
parent
1bb4428c
Changes
7
Hide whitespace changes
Inline
Side-by-side
compiler/main/DynFlags.hs
View file @
0fdca5de
...
...
@@ -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! ("
++
show
Ppr
a
++
", "
++
show
Ppr
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
=
(
show
Ppr
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
View file @
0fdca5de
...
...
@@ -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
View file @
0fdca5de
...
...
@@ -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
: " ++ showP
pr k)
tc_hs_kind k = p
prP
anic "tc_hs_kind
" (p
pr k)
-- Special case for kind application
tc_kind_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
...
...
compiler/utils/Outputable.lhs
View file @
0fdca5de
...
...
@@ -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
View file @
0fdca5de
...
...
@@ -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 "
++
show
SDoc
(
ppr
var
)
++
info
globalScalar
isDFun
vectDecl
++
":"
)
$
;
traceVt
(
"vectTopRhs of "
++
show
Ppr
dflags
var
++
info
globalScalar
isDFun
vectDecl
++
":"
)
$
ppr
expr
;
rhs
globalScalar
isDFun
vectDecl
...
...
compiler/vectorise/Vectorise/Monad/Base.hs
View file @
0fdca5de
...
...
@@ -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
View file @
0fdca5de
...
...
@@ -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
$
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment