[commit: ghc] master: Pass DynFlags down to showSDocOneLine (7de2f21)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/7de2f2110414d7c822f0e1ffb9edc25a5a0b55f3

>---------------------------------------------------------------

commit 7de2f2110414d7c822f0e1ffb9edc25a5a0b55f3
Author: Ian Lynagh <igloo at earth.li>
Date:   Mon Jun 11 23:35:21 2012 +0100

    Pass DynFlags down to showSDocOneLine

>---------------------------------------------------------------

 compiler/rename/RnExpr.lhs        |   12 +++++++-----
 compiler/typecheck/TcDeriv.lhs    |   11 +++++++----
 compiler/typecheck/TcGenDeriv.lhs |    8 +++++---
 compiler/utils/Outputable.lhs     |    4 ++--
 4 files changed, 21 insertions(+), 14 deletions(-)

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 7ff7c7a..625bbf9 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -1159,15 +1159,17 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
 %************************************************************************
 
 \begin{code}
-srcSpanPrimLit :: SrcSpan -> HsExpr Name
-srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
+srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr Name
+srcSpanPrimLit dflags span
+    = HsLit (HsStringPrim (mkFastString (showSDocOneLine dflags (ppr span))))
 
 mkAssertErrorExpr :: RnM (HsExpr Name)
 -- Return an expression for (assertError "Foo.hs:27")
 mkAssertErrorExpr
-  = getSrcSpanM    			`thenM` \ sloc ->
-    return (HsApp (L sloc (HsVar assertErrorName)) 
-		  (L sloc (srcSpanPrimLit sloc)))
+  = do sloc <- getSrcSpanM
+       dflags <- getDynFlags
+       return (HsApp (L sloc (HsVar assertErrorName))
+                     (L sloc (srcSpanPrimLit dflags sloc)))
 \end{code}
 
 Note [Adding the implicit parameter to 'assert']
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 163a581..1dc2d26 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -1504,19 +1504,22 @@ genDerivStuff loc fix_env clas name tycon
   = gen_Generic_binds tycon (nameModule name)
 
   | 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)
         Nothing	    -> pprPanic "genDerivStuff: bad derived class" (ppr clas)
   where
-    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
-    gen_list = [(eqClassKey,            gen_Eq_binds)
+    gen_list :: DynFlags
+             -> [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
+    gen_list dflags
+             = [(eqClassKey,            gen_Eq_binds)
                ,(ordClassKey,           gen_Ord_binds)
                ,(enumClassKey,          gen_Enum_binds)
                ,(boundedClassKey,       gen_Bounded_binds)
                ,(ixClassKey,            gen_Ix_binds)
                ,(showClassKey,          gen_Show_binds fix_env)
                ,(readClassKey,          gen_Read_binds fix_env)
-               ,(dataClassKey,          gen_Data_binds)
+               ,(dataClassKey,          gen_Data_binds dflags)
                ,(functorClassKey,       gen_Functor_binds)
                ,(foldableClassKey,      gen_Foldable_binds)
                ,(traversableClassKey,   gen_Traversable_binds)
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 481c4ed..0566192 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -49,6 +49,7 @@ import BasicTypes
 import DataCon
 import Name
 
+import DynFlags
 import HscTypes
 import PrelInfo
 import FamInstEnv( FamInst )
@@ -1269,11 +1270,12 @@ we generate
 
     
 \begin{code}
-gen_Data_binds :: SrcSpan
+gen_Data_binds :: DynFlags
+                -> SrcSpan
 	       -> TyCon 
 	       -> (LHsBinds RdrName,	-- The method bindings
 		   BagDerivStuff)	-- Auxiliary bindings
-gen_Data_binds loc tycon
+gen_Data_binds dflags loc tycon
   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
      `unionBags` gcast_binds,
 		-- Auxiliary definitions: the data type and constructors
@@ -1293,7 +1295,7 @@ gen_Data_binds loc tycon
         sig_ty   = nlHsTyVar dataType_RDR
         constrs  = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
         rhs = nlHsVar mkDataType_RDR 
-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
+              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr tycon)))
               `nlHsApp` nlList constrs
 
     genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index ff41927..0da4b0f 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -371,8 +371,8 @@ renderWithStyle _ sdoc sty =
 -- 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"
 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
-showSDocOneLine :: SDoc -> String
-showSDocOneLine d 
+showSDocOneLine :: DynFlags -> SDoc -> String
+showSDocOneLine _ d
  = Pretty.showDocWith PageMode
     (runSDoc d (initSDocContext defaultUserStyle))