Commit 7de2f211 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Pass DynFlags down to showSDocOneLine

parent b3894840
...@@ -1159,15 +1159,17 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later ...@@ -1159,15 +1159,17 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
srcSpanPrimLit :: SrcSpan -> HsExpr Name srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr Name
srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span)))) srcSpanPrimLit dflags span
= HsLit (HsStringPrim (mkFastString (showSDocOneLine dflags (ppr span))))
mkAssertErrorExpr :: RnM (HsExpr Name) mkAssertErrorExpr :: RnM (HsExpr Name)
-- Return an expression for (assertError "Foo.hs:27") -- Return an expression for (assertError "Foo.hs:27")
mkAssertErrorExpr mkAssertErrorExpr
= getSrcSpanM `thenM` \ sloc -> = do sloc <- getSrcSpanM
return (HsApp (L sloc (HsVar assertErrorName)) dflags <- getDynFlags
(L sloc (srcSpanPrimLit sloc))) return (HsApp (L sloc (HsVar assertErrorName))
(L sloc (srcSpanPrimLit dflags sloc)))
\end{code} \end{code}
Note [Adding the implicit parameter to 'assert'] Note [Adding the implicit parameter to 'assert']
......
...@@ -1504,19 +1504,22 @@ genDerivStuff loc fix_env clas name tycon ...@@ -1504,19 +1504,22 @@ genDerivStuff loc fix_env clas name tycon
= gen_Generic_binds tycon (nameModule name) = gen_Generic_binds tycon (nameModule name)
| otherwise -- Non-monadic generators | otherwise -- Non-monadic generators
= case assocMaybe gen_list (getUnique clas) of = do dflags <- getDynFlags
case assocMaybe (gen_list dflags) (getUnique clas) of
Just gen_fn -> return (gen_fn loc tycon) Just gen_fn -> return (gen_fn loc tycon)
Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas) Nothing -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
where where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))] gen_list :: DynFlags
gen_list = [(eqClassKey, gen_Eq_binds) -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
gen_list dflags
= [(eqClassKey, gen_Eq_binds)
,(ordClassKey, gen_Ord_binds) ,(ordClassKey, gen_Ord_binds)
,(enumClassKey, gen_Enum_binds) ,(enumClassKey, gen_Enum_binds)
,(boundedClassKey, gen_Bounded_binds) ,(boundedClassKey, gen_Bounded_binds)
,(ixClassKey, gen_Ix_binds) ,(ixClassKey, gen_Ix_binds)
,(showClassKey, gen_Show_binds fix_env) ,(showClassKey, gen_Show_binds fix_env)
,(readClassKey, gen_Read_binds fix_env) ,(readClassKey, gen_Read_binds fix_env)
,(dataClassKey, gen_Data_binds) ,(dataClassKey, gen_Data_binds dflags)
,(functorClassKey, gen_Functor_binds) ,(functorClassKey, gen_Functor_binds)
,(foldableClassKey, gen_Foldable_binds) ,(foldableClassKey, gen_Foldable_binds)
,(traversableClassKey, gen_Traversable_binds) ,(traversableClassKey, gen_Traversable_binds)
......
...@@ -49,6 +49,7 @@ import BasicTypes ...@@ -49,6 +49,7 @@ import BasicTypes
import DataCon import DataCon
import Name import Name
import DynFlags
import HscTypes import HscTypes
import PrelInfo import PrelInfo
import FamInstEnv( FamInst ) import FamInstEnv( FamInst )
...@@ -1269,11 +1270,12 @@ we generate ...@@ -1269,11 +1270,12 @@ we generate
\begin{code} \begin{code}
gen_Data_binds :: SrcSpan gen_Data_binds :: DynFlags
-> SrcSpan
-> TyCon -> TyCon
-> (LHsBinds RdrName, -- The method bindings -> (LHsBinds RdrName, -- The method bindings
BagDerivStuff) -- Auxiliary bindings BagDerivStuff) -- Auxiliary bindings
gen_Data_binds loc tycon gen_Data_binds dflags loc tycon
= (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind] = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
`unionBags` gcast_binds, `unionBags` gcast_binds,
-- Auxiliary definitions: the data type and constructors -- Auxiliary definitions: the data type and constructors
...@@ -1293,7 +1295,7 @@ gen_Data_binds loc tycon ...@@ -1293,7 +1295,7 @@ gen_Data_binds loc tycon
sig_ty = nlHsTyVar dataType_RDR sig_ty = nlHsTyVar dataType_RDR
constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon] constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
rhs = nlHsVar mkDataType_RDR rhs = nlHsVar mkDataType_RDR
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr tycon)))
`nlHsApp` nlList constrs `nlHsApp` nlList constrs
genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName) genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
......
...@@ -371,8 +371,8 @@ renderWithStyle _ sdoc sty = ...@@ -371,8 +371,8 @@ renderWithStyle _ sdoc sty =
-- This shows an SDoc, but on one line only. It's cheaper than a full -- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar" -- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway. -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
showSDocOneLine :: SDoc -> String showSDocOneLine :: DynFlags -> SDoc -> String
showSDocOneLine d showSDocOneLine _ d
= Pretty.showDocWith PageMode = Pretty.showDocWith PageMode
(runSDoc d (initSDocContext defaultUserStyle)) (runSDoc d (initSDocContext defaultUserStyle))
......
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