Pass DynFlags down to showSDoc
authorIan Lynagh <igloo@earth.li>
Tue, 12 Jun 2012 17:52:05 +0000 (18:52 +0100)
committerIan Lynagh <igloo@earth.li>
Tue, 12 Jun 2012 17:52:05 +0000 (18:52 +0100)
48 files changed:
compiler/basicTypes/MkId.lhs
compiler/cmm/CmmOpt.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmProf.hs
compiler/coreSyn/MkExternalCore.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsListComp.lhs
compiler/deSugar/DsUtils.lhs
compiler/ghci/Debugger.hs
compiler/ghci/DebuggerUtils.hs
compiler/ghci/Linker.lhs
compiler/ghci/RtClosureInspect.hs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/CodeOutput.lhs
compiler/main/DriverMkDepend.hs
compiler/main/DriverPipeline.hs
compiler/main/DynamicLoading.hs
compiler/main/ErrUtils.lhs
compiler/main/GHC.hs
compiler/main/HscMain.hs
compiler/main/HscTypes.lhs
compiler/main/InteractiveEval.hs
compiler/main/Packages.lhs
compiler/nativeGen/AsmCodeGen.lhs
compiler/rename/RnEnv.lhs
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/SimplCore.lhs
compiler/specialise/SpecConstr.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/utils/Outputable.lhs
compiler/vectorise/Vectorise.hs
compiler/vectorise/Vectorise/Exp.hs
compiler/vectorise/Vectorise/Generic/PAMethods.hs
compiler/vectorise/Vectorise/Monad.hs
compiler/vectorise/Vectorise/Monad/Base.hs
compiler/vectorise/Vectorise/Monad/Global.hs
compiler/vectorise/Vectorise/Monad/InstEnv.hs
compiler/vectorise/Vectorise/Type/TyConDecl.hs
compiler/vectorise/Vectorise/Utils/PADict.hs
ghc/GhciMonad.hs
ghc/InteractiveUI.hs
ghc/Main.hs

index a7f4b70..3eaa7dc 100644 (file)
@@ -69,6 +69,7 @@ import PrelNames
 import BasicTypes       hiding ( SuccessFlag(..) )
 import Util
 import Pair
+import DynFlags
 import Outputable
 import FastString
 import ListSetOps
@@ -761,14 +762,14 @@ mkPrimOpId prim_op
 -- details of the ccall, type and all.  This means that the interface 
 -- file reader can reconstruct a suitable Id
 
-mkFCallId :: Unique -> ForeignCall -> Type -> Id
-mkFCallId uniq fcall ty
+mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id
+mkFCallId dflags uniq fcall ty
   = ASSERT( isEmptyVarSet (tyVarsOfType ty) )
     -- A CCallOpId should have no free type variables; 
     -- when doing substitutions won't substitute over it
     mkGlobalId (FCallId fcall) name ty info
   where
-    occ_str = showSDoc (braces (ppr fcall <+> ppr ty))
+    occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty))
     -- The "occurrence name" of a ccall is the full info about the
     -- ccall; it is encoded, but may have embedded spaces etc!
 
index e4ad450..d2f0058 100644 (file)
@@ -20,6 +20,7 @@ import OldCmm
 import OldPprCmm
 import CmmNode (wrapRecExp)
 import CmmUtils
+import DynFlags
 import StaticFlags
 
 import UniqFM
@@ -147,46 +148,47 @@ countUses :: UserOfLocalRegs a => a -> UniqFM Int
 countUses a = foldRegsUsed (\m r -> addToUFM m r (count m r + 1)) emptyUFM a
   where count m r = lookupWithDefaultUFM m (0::Int) r
 
-cmmMiniInline :: Platform -> [CmmBasicBlock] -> [CmmBasicBlock]
-cmmMiniInline platform blocks = map do_inline blocks
+cmmMiniInline :: DynFlags -> [CmmBasicBlock] -> [CmmBasicBlock]
+cmmMiniInline dflags blocks = map do_inline blocks
   where do_inline (BasicBlock id stmts)
-          = BasicBlock id (cmmMiniInlineStmts platform (countUses blocks) stmts)
+          = BasicBlock id (cmmMiniInlineStmts dflags (countUses blocks) stmts)
 
-cmmMiniInlineStmts :: Platform -> UniqFM Int -> [CmmStmt] -> [CmmStmt]
-cmmMiniInlineStmts _        _    [] = []
-cmmMiniInlineStmts platform uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
+cmmMiniInlineStmts :: DynFlags -> UniqFM Int -> [CmmStmt] -> [CmmStmt]
+cmmMiniInlineStmts _      _    [] = []
+cmmMiniInlineStmts dflags uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
         -- not used: just discard this assignment
   | Nothing <- lookupUFM uses u
-  = cmmMiniInlineStmts platform uses stmts
+  = cmmMiniInlineStmts dflags uses stmts
 
         -- used (literal): try to inline at all the use sites
   | Just n <- lookupUFM uses u, isLit expr
   =
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
+     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $
      case lookForInlineLit u expr stmts of
          (m, stmts')
-             | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts'
+             | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
              | otherwise ->
-                 stmt : cmmMiniInlineStmts platform (adjustUFM (\x -> x - m) uses u) stmts'
+                 stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts'
 
         -- used (foldable to literal): try to inline at all the use sites
   | Just n <- lookupUFM uses u,
     e@(CmmLit _) <- wrapRecExp foldExp expr
   =
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
+     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $
      case lookForInlineLit u e stmts of
          (m, stmts')
-             | n == m -> cmmMiniInlineStmts platform (delFromUFM uses u) stmts'
+             | n == m -> cmmMiniInlineStmts dflags (delFromUFM uses u) stmts'
              | otherwise ->
-                 stmt : cmmMiniInlineStmts platform (adjustUFM (\x -> x - m) uses u) stmts'
+                 stmt : cmmMiniInlineStmts dflags (adjustUFM (\x -> x - m) uses u) stmts'
 
         -- used once (non-literal): try to inline at the use site
   | Just 1 <- lookupUFM uses u,
     Just stmts' <- lookForInline u expr stmts
   = 
-     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc (pprStmt platform stmt)) $
-     cmmMiniInlineStmts platform uses stmts'
+     ncgDebugTrace ("nativeGen: inlining " ++ showSDoc dflags (pprStmt platform stmt)) $
+     cmmMiniInlineStmts dflags uses stmts'
  where
+  platform = targetPlatform dflags
   foldExp (CmmMachOp op args) = cmmMachOpFold platform op args
   foldExp e = e
 
index c335246..c97c3d4 100644 (file)
@@ -58,7 +58,7 @@ import Constants
 import Util
 import Data.List
 import Outputable
-import FastString      ( mkFastString, FastString, fsLit )
+import FastString
 
 ------------------------------------------------------------------------
 --             Call and return sequences
@@ -179,8 +179,8 @@ slow_call fun args reps
   = do dflags <- getDynFlags
        let platform = targetPlatform dflags
        call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps
-       emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (pprPlatform platform fun) ++
-                                        " with pat " ++ showSDoc (ftext rts_fun))
+       emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc dflags (pprPlatform platform fun) ++
+                                        " with pat " ++ unpackFS rts_fun)
        emit (mkAssign nodeReg fun <*> call)
   where
     (rts_fun, arity) = slowCallPattern reps
index 6d16f01..6a53317 100644 (file)
@@ -218,7 +218,8 @@ emitCostCentreDecl cc = do
   ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS
                                         $ Module.moduleName
                                         $ cc_mod cc)
-  ; loc <- newStringCLit (showSDoc (ppr (costCentreSrcSpan cc)))
+  ; dflags <- getDynFlags
+  ; loc <- newStringCLit (showPpr dflags (costCentreSrcSpan cc))
            -- XXX should UTF-8 encode
                 -- All cost centres will be in the main package, since we
                 -- don't normally use -auto-all or add SCCs to other packages.
index bc14291..b6c682f 100644 (file)
@@ -38,6 +38,7 @@ import DynFlags
 import FastString
 import Exception
 
+import Control.Monad
 import Data.Char
 import System.IO
 
@@ -45,7 +46,7 @@ emitExternalCore :: DynFlags -> CgGuts -> IO ()
 emitExternalCore dflags cg_guts
  | dopt Opt_EmitExternalCore dflags
  = (do handle <- openFile corename WriteMode
-       hPutStrLn handle (show (mkExternalCore cg_guts))
+       hPutStrLn handle (show (mkExternalCore dflags cg_guts))
        hClose handle)
    `catchIO` (\_ -> pprPanic "Failed to open or write external core output file"
                              (text corename))
@@ -56,7 +57,10 @@ emitExternalCore _ _
 
 -- Reinventing the Reader monad; whee.
 newtype CoreM a = CoreM (CoreState -> (CoreState, a))
-type CoreState = Module
+data CoreState = CoreState {
+                     cs_dflags :: DynFlags,
+                     cs_module :: Module
+                 }
 instance Monad CoreM where
   (CoreM m) >>= f = CoreM (\ s -> case m s of
                                     (s',r) -> case f r of
@@ -67,55 +71,62 @@ runCoreM (CoreM f) s = snd $ f s
 ask :: CoreM CoreState
 ask = CoreM (\ s -> (s,s))
 
-mkExternalCore :: CgGuts -> C.Module
+instance HasDynFlags CoreM where
+    getDynFlags = liftM cs_dflags ask
+
+mkExternalCore :: DynFlags -> CgGuts -> C.Module
 -- The ModGuts has been tidied, but the implicit bindings have
 -- not been injected, so we have to add them manually here
 -- We don't include the strange data-con *workers* because they are
 -- implicit in the data type declaration itself
-mkExternalCore (CgGuts {cg_module=this_mod, cg_tycons = tycons, 
-                        cg_binds = binds})
+mkExternalCore dflags (CgGuts {cg_module=this_mod, cg_tycons = tycons,
+                               cg_binds = binds})
 {- Note that modules can be mutually recursive, but even so, we
    print out dependency information within each module. -}
-  = C.Module mname tdefs (runCoreM (mapM (make_vdef True) binds) this_mod)
+  = C.Module (mname dflags) tdefs (runCoreM (mapM (make_vdef True) binds) initialState)
   where
-    mname  = make_mid this_mod
-    tdefs  = foldr collect_tdefs [] tycons
-
-collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef]
-collect_tdefs tcon tdefs 
+    initialState = CoreState {
+                       cs_dflags = dflags,
+                       cs_module = this_mod
+                   }
+    mname dflags = make_mid dflags this_mod
+    tdefs  = foldr (collect_tdefs dflags) [] tycons
+
+collect_tdefs :: DynFlags -> TyCon -> [C.Tdef] -> [C.Tdef]
+collect_tdefs dflags tcon tdefs
   | isAlgTyCon tcon = tdef: tdefs
   where
     tdef | isNewTyCon tcon = 
-                C.Newtype (qtc tcon) 
-                  (qcc (newTyConCo tcon))
+                C.Newtype (qtc dflags tcon) 
+                  (qcc dflags (newTyConCo tcon))
                   (map make_tbind tyvars) 
-                  (make_ty (snd (newTyConRhs tcon)))
+                  (make_ty dflags (snd (newTyConRhs tcon)))
          | otherwise = 
-                C.Data (qtc tcon) (map make_tbind tyvars) 
-                   (map make_cdef (tyConDataCons tcon)) 
+                C.Data (qtc dflags tcon) (map make_tbind tyvars) 
+                   (map (make_cdef dflags) (tyConDataCons tcon)) 
     tyvars = tyConTyVars tcon
 
-collect_tdefs _ tdefs = tdefs
+collect_tdefs _ tdefs = tdefs
 
-qtc :: TyCon -> C.Qual C.Tcon
-qtc = make_con_qid . tyConName
+qtc :: DynFlags -> TyCon -> C.Qual C.Tcon
+qtc dflags = make_con_qid dflags . tyConName
 
-qcc :: CoAxiom -> C.Qual C.Tcon
-qcc = make_con_qid . co_ax_name
+qcc :: DynFlags -> CoAxiom -> C.Qual C.Tcon
+qcc dflags = make_con_qid dflags . co_ax_name
 
-make_cdef :: DataCon -> C.Cdef
-make_cdef dcon =  C.Constr dcon_name existentials tys
+make_cdef :: DynFlags -> DataCon -> C.Cdef
+make_cdef dflags dcon =  C.Constr dcon_name existentials tys
   where 
-    dcon_name    = make_qid False False (dataConName dcon)
+    dcon_name    = make_qid dflags False False (dataConName dcon)
     existentials = map make_tbind ex_tyvars
     ex_tyvars    = dataConExTyVars dcon
-    tys         = map make_ty (dataConRepArgTys dcon)
+    tys         = map (make_ty dflags) (dataConRepArgTys dcon)
 
 make_tbind :: TyVar -> C.Tbind
 make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
     
-make_vbind :: Var -> C.Vbind
-make_vbind v = (make_var_id  (Var.varName v), make_ty (varType v))
+make_vbind :: DynFlags -> Var -> C.Vbind
+make_vbind dflags v = (make_var_id  (Var.varName v), make_ty dflags (varType v))
 
 make_vdef :: Bool -> CoreBind -> CoreM C.Vdefg
 make_vdef topLevel b = 
@@ -129,29 +140,34 @@ make_vdef topLevel b =
           let local = not topLevel || localN
           rhs <- make_exp e
           -- use local flag to determine where to add the module name
-          return (local, make_qid local True vName, make_ty (varType v),rhs)
+          dflags <- getDynFlags
+          return (local, make_qid dflags local True vName, make_ty dflags (varType v),rhs)
        where vName = Var.varName v
 
 make_exp :: CoreExpr -> CoreM C.Exp
 make_exp (Var v) = do
   let vName = Var.varName v
   isLocal <- isALocal vName
+  dflags <- getDynFlags
   return $
      case idDetails v of
        FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _)) 
-           -> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
+           -> C.External (unpackFS nm) (showPpr dflags callconv) (make_ty dflags (varType v))
        FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
            panic "make_exp: FFI values not supported"
        FCallId (CCall (CCallSpec DynamicTarget     callconv _)) 
-           -> C.DynExternal            (showSDoc (ppr callconv)) (make_ty (varType v))
+           -> C.DynExternal            (showPpr dflags callconv) (make_ty dflags (varType v))
        -- Constructors are always exported, so make sure to declare them
        -- with qualified names
-       DataConWorkId _ -> C.Var (make_var_qid False vName)
-       DataConWrapId _ -> C.Var (make_var_qid False vName)
-       _ -> C.Var (make_var_qid isLocal vName)
+       DataConWorkId _ -> C.Var (make_var_qid dflags False vName)
+       DataConWrapId _ -> C.Var (make_var_qid dflags False vName)
+       _ -> C.Var (make_var_qid dflags isLocal vName)
 make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
-make_exp (Lit l) = return $ C.Lit (make_lit l)
-make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
+make_exp (Lit l) = do dflags <- getDynFlags
+                      return $ C.Lit (make_lit dflags l)
+make_exp (App e (Type t)) = do b <- make_exp e
+                               dflags <- getDynFlags
+                               return $ C.Appt b (make_ty dflags t)
 make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))"    -- TODO
 make_exp (App e1 e2) = do
    rator <- make_exp e1
@@ -159,9 +175,12 @@ make_exp (App e1 e2) = do
    return $ C.App rator rand
 make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Tb (make_tbind v)) b)
-make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> 
-                                    return $ C.Lam (C.Vb (make_vbind v)) b)
-make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
+make_exp (Lam v e) | otherwise = do b <- make_exp e
+                                    dflags <- getDynFlags
+                                    return $ C.Lam (C.Vb (make_vbind dflags v)) b
+make_exp (Cast e co) = do b <- make_exp e
+                          dflags <- getDynFlags
+                          return $ C.Cast b (make_co dflags co)
 make_exp (Let b e) = do
   vd   <- make_vdef False b
   body <- make_exp e
@@ -169,19 +188,23 @@ make_exp (Let b e) = do
 make_exp (Case e v ty alts) = do
   scrut <- make_exp e
   newAlts  <- mapM make_alt alts
-  return $ C.Case scrut (make_vbind v) (make_ty ty) newAlts
+  dflags <- getDynFlags
+  return $ C.Case scrut (make_vbind dflags v) (make_ty dflags ty) newAlts
 make_exp (Tick _ e) = make_exp e >>= (return . C.Tick "SCC") -- temporary
 make_exp _ = error "MkExternalCore died: make_exp"
 
 make_alt :: CoreAlt -> CoreM C.Alt
 make_alt (DataAlt dcon, vs, e) = do
     newE <- make_exp e
-    return $ C.Acon (make_con_qid (dataConName dcon))
+    dflags <- getDynFlags
+    return $ C.Acon (make_con_qid dflags (dataConName dcon))
            (map make_tbind tbs)
-           (map make_vbind vbs)
+           (map (make_vbind dflags) vbs)
           newE
        where (tbs,vbs) = span isTyVar vs
-make_alt (LitAlt l,_,e)   = make_exp e >>= (return . (C.Alit (make_lit l)))
+make_alt (LitAlt l,_,e)   = do x <- make_exp e
+                               dflags <- getDynFlags
+                               return $ C.Alit (make_lit dflags l) x
 make_alt (DEFAULT,[],e)   = make_exp e >>= (return . C.Adefault)
 -- This should never happen, as the DEFAULT alternative binds no variables,
 -- but we might as well check for it:
@@ -189,8 +212,8 @@ make_alt a@(DEFAULT,_ ,_) = pprPanic ("MkExternalCore: make_alt: DEFAULT "
              ++ "alternative had a non-empty var list") (ppr a)
 
 
-make_lit :: Literal -> C.Lit
-make_lit l = 
+make_lit :: DynFlags -> Literal -> C.Lit
+make_lit dflags l = 
   case l of
     -- Note that we need to check whether the character is "big".
     -- External Core only allows character literals up to '\xff'.
@@ -208,22 +231,22 @@ make_lit l =
     MachDouble r -> C.Lrational r t
     _ -> error "MkExternalCore died: make_lit"
   where 
-    t = make_ty (literalType l)
+    t = make_ty dflags (literalType l)
 
 -- Expand type synonyms, then convert.
-make_ty :: Type -> C.Ty                 -- Be sure to expand types recursively!
+make_ty :: DynFlags -> Type -> C.Ty     -- Be sure to expand types recursively!
                                         -- example: FilePath ~> String ~> [Char]
-make_ty t | Just expanded <- tcView t = make_ty expanded
-make_ty t = make_ty' t
+make_ty dflags t | Just expanded <- tcView t = make_ty dflags expanded
+make_ty dflags t = make_ty' dflags t
  
 -- note calls to make_ty so as to expand types recursively
-make_ty' :: Type -> C.Ty
-make_ty' (TyVarTy tv)     = C.Tvar (make_var_id (tyVarName tv))
-make_ty' (AppTy t1 t2)           = C.Tapp (make_ty t1) (make_ty t2)
-make_ty' (FunTy t1 t2)           = make_ty (TyConApp funTyCon [t1,t2])
-make_ty' (ForAllTy tv t)  = C.Tforall (make_tbind tv) (make_ty t)
-make_ty' (TyConApp tc ts) = make_tyConApp tc ts
-make_ty' (LitTy {})       = panic "MkExernalCore can't do literal types yet"
+make_ty' :: DynFlags -> Type -> C.Ty
+make_ty' _      (TyVarTy tv)     = C.Tvar (make_var_id (tyVarName tv))
+make_ty' dflags (AppTy t1 t2)    = C.Tapp (make_ty dflags t1) (make_ty dflags t2)
+make_ty' dflags (FunTy t1 t2)    = make_ty dflags (TyConApp funTyCon [t1,t2])
+make_ty' dflags (ForAllTy tv t)  = C.Tforall (make_tbind tv) (make_ty dflags t)
+make_ty' dflags (TyConApp tc ts) = make_tyConApp dflags tc ts
+make_ty' _      (LitTy {})       = panic "MkExernalCore can't do literal types yet"
 
 -- Newtypes are treated just like any other type constructor; not expanded
 -- Reason: predTypeRep does substitution and, while substitution deals
@@ -237,10 +260,10 @@ make_ty' (LitTy {})       = panic "MkExernalCore can't do literal types yet"
 -- expose the representation in interface files, which definitely isn't right.
 -- Maybe CoreTidy should know whether to expand newtypes or not?
 
-make_tyConApp :: TyCon -> [Type] -> C.Ty
-make_tyConApp tc ts =
-  foldl C.Tapp (C.Tcon (qtc tc)) 
-           (map make_ty ts)
+make_tyConApp :: DynFlags -> TyCon -> [Type] -> C.Ty
+make_tyConApp dflags tc ts =
+  foldl C.Tapp (C.Tcon (qtc dflags tc)) 
+           (map (make_ty dflags) ts)
 
 make_kind :: Kind -> C.Kind
 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
@@ -267,52 +290,53 @@ make_var_id = make_id True
 -- because that would just be ugly.)
 -- SIGH.
 -- We encode the package name as well.
-make_mid :: Module -> C.Id
+make_mid :: DynFlags -> Module -> C.Id
 -- Super ugly code, but I can't find anything else that does quite what I
 -- want (encodes the hierarchical module name without encoding the colon
 -- that separates the package name from it.)
-make_mid m = showSDoc $
+make_mid dflags m
+            = showSDoc dflags $
               (text $ zEncodeString $ packageIdString $ modulePackageId m)
               <> text ":"
               <> (pprEncoded $ pprModuleName $ moduleName m)
      where pprEncoded = pprCode CStyle
                
-make_qid :: Bool -> Bool -> Name -> C.Qual C.Id
-make_qid force_unqual is_var n = (mname,make_id is_var n)
+make_qid :: DynFlags -> Bool -> Bool -> Name -> C.Qual C.Id
+make_qid dflags force_unqual is_var n = (mname,make_id is_var n)
     where mname = 
            case nameModule_maybe n of
-            Just m | not force_unqual -> make_mid m
+            Just m | not force_unqual -> make_mid dflags m
             _ -> "" 
 
-make_var_qid :: Bool -> Name -> C.Qual C.Id
-make_var_qid force_unqual = make_qid force_unqual True
-
-make_con_qid :: Name -> C.Qual C.Id
-make_con_qid = make_qid False False
-
-make_co :: Coercion -> C.Ty
-make_co (Refl ty)             = make_ty ty
-make_co (TyConAppCo tc cos)   = make_conAppCo (qtc tc) cos
-make_co (AppCo c1 c2)         = C.Tapp (make_co c1) (make_co c2)
-make_co (ForAllCo tv co)      = C.Tforall (make_tbind tv) (make_co co)
-make_co (CoVarCo cv)          = C.Tvar (make_var_id (coVarName cv))
-make_co (AxiomInstCo cc cos)  = make_conAppCo (qcc cc) cos
-make_co (UnsafeCo t1 t2)      = C.UnsafeCoercion (make_ty t1) (make_ty t2)
-make_co (SymCo co)            = C.SymCoercion (make_co co)
-make_co (TransCo c1 c2)       = C.TransCoercion (make_co c1) (make_co c2)
-make_co (NthCo d co)          = C.NthCoercion d (make_co co)
-make_co (InstCo co ty)        = C.InstCoercion (make_co co) (make_ty ty)
+make_var_qid :: DynFlags -> Bool -> Name -> C.Qual C.Id
+make_var_qid dflags force_unqual = make_qid dflags force_unqual True
+
+make_con_qid :: DynFlags -> Name -> C.Qual C.Id
+make_con_qid dflags = make_qid dflags False False
+
+make_co :: DynFlags -> Coercion -> C.Ty
+make_co dflags (Refl ty)             = make_ty dflags ty
+make_co dflags (TyConAppCo tc cos)   = make_conAppCo dflags (qtc dflags tc) cos
+make_co dflags (AppCo c1 c2)         = C.Tapp (make_co dflags c1) (make_co dflags c2)
+make_co dflags (ForAllCo tv co)      = C.Tforall (make_tbind tv) (make_co dflags co)
+make_co _      (CoVarCo cv)          = C.Tvar (make_var_id (coVarName cv))
+make_co dflags (AxiomInstCo cc cos)  = make_conAppCo dflags (qcc dflags cc) cos
+make_co dflags (UnsafeCo t1 t2)      = C.UnsafeCoercion (make_ty dflags t1) (make_ty dflags t2)
+make_co dflags (SymCo co)            = C.SymCoercion (make_co dflags co)
+make_co dflags (TransCo c1 c2)       = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
+make_co dflags (NthCo d co)          = C.NthCoercion d (make_co dflags co)
+make_co dflags (InstCo co ty)        = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
 
 -- Used for both tycon app coercions and axiom instantiations.
-make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
-make_conAppCo con cos =
+make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty
+make_conAppCo dflags con cos =
   foldl C.Tapp (C.Tcon con) 
-           (map make_co cos)
+           (map (make_co dflags) cos)
 
 -------
 isALocal :: Name -> CoreM Bool
 isALocal vName = do
-  modName <- ask
+  modName <- liftM cs_module ask
   return $ case nameModule_maybe vName of
              -- Not sure whether isInternalName corresponds to "local"ness
              -- in the External Core sense; need to re-read the spec.
index eae9530..8949387 100644 (file)
@@ -451,11 +451,12 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
 
        { (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id)
 
+       ; dflags <- getDynFlags
        ; let spec_id  = mkLocalId spec_name spec_ty 
                            `setInlinePragma` inl_prag
                            `setIdUnfolding`  spec_unf
              rule =  mkRule False {- Not auto -} is_local_id
-                        (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
+                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))
                                rule_act poly_name
                                final_bndrs args
                                (mkVarApps (Var spec_id) bndrs)
@@ -463,7 +464,6 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
        ; spec_rhs <- dsHsWrapper spec_co poly_rhs
        ; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 
-       ; dflags <- getDynFlags
        ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags)
               (warnDs (specOnInline poly_name))
        ; return (Just (spec_pair `consOL` unf_pairs, rule))
index 76bdfb9..a2459f5 100644 (file)
@@ -48,6 +48,7 @@ import Literal
 import PrelNames
 import VarSet
 import Constants
+import DynFlags
 import Outputable
 import Util
 \end{code}
@@ -98,13 +99,14 @@ dsCCall lbl args may_gc result_ty
   = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
        (ccall_result_ty, res_wrapper) <- boxResult result_ty
        uniq <- newUnique
+       dflags <- getDynFlags
        let
            target = StaticTarget lbl Nothing True
            the_fcall    = CCall (CCallSpec target CCallConv may_gc)
-           the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
+           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
        return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
 
-mkFCall :: Unique -> ForeignCall 
+mkFCall :: DynFlags -> Unique -> ForeignCall 
        -> [CoreExpr]   -- Args
        -> Type         -- Result type
        -> CoreExpr
@@ -117,14 +119,14 @@ mkFCall :: Unique -> ForeignCall
 -- Here we build a ccall thus
 --     (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
 --                     a b s x c
-mkFCall uniq the_fcall val_args res_ty
+mkFCall dflags uniq the_fcall val_args res_ty
   = mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
   where
     arg_tys = map exprType val_args
     body_ty = (mkFunTys arg_tys res_ty)
     tyvars  = varSetElems (tyVarsOfType body_ty)
     ty             = mkForAllTys tyvars body_ty
-    the_fcall_id = mkFCallId uniq the_fcall ty
+    the_fcall_id = mkFCallId dflags uniq the_fcall ty
 \end{code}
 
 \begin{code}
index 7fa35e3..a60d3c4 100644 (file)
@@ -765,14 +765,15 @@ handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
 handle_failure pat match fail_op
   | matchCanFail match
   = do { fail_op' <- dsExpr fail_op
-       ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+       ; dflags <- getDynFlags
+       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
        ; extractMatchResult match (App fail_op' fail_msg) }
   | otherwise
   = extractMatchResult match (error "It can't fail")
 
-mk_fail_msg :: Located e -> String
-mk_fail_msg pat = "Pattern match failure in do expression at " ++ 
-                  showSDoc (ppr (getLoc pat))
+mk_fail_msg :: DynFlags -> Located e -> String
+mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++ 
+                         showPpr dflags (getLoc pat)
 \end{code}
 
 
index 93dc627..09afd2f 100644 (file)
@@ -207,12 +207,13 @@ dsFCall fn_id co fcall mDeclHeader = do
     ccall_uniq <- newUnique
     work_uniq  <- newUnique
 
+    dflags <- getDynFlags
     (fcall', cDoc) <-
               case fcall of
               CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) ->
                do fcall_uniq <- newUnique
                   let wrapperName = mkFastString "ghc_wrapper_" `appendFS`
-                                    mkFastString (showSDoc (ppr fcall_uniq)) `appendFS`
+                                    mkFastString (showPpr dflags fcall_uniq) `appendFS`
                                     mkFastString "_" `appendFS`
                                     cName
                       fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety)
@@ -256,7 +257,7 @@ dsFCall fn_id co fcall mDeclHeader = do
     let
         -- Build the worker
         worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
-        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
+        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
         work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
         work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
 
@@ -298,8 +299,9 @@ dsPrimCall fn_id co fcall = do
     args <- newSysLocalsDs arg_tys
 
     ccall_uniq <- newUnique
+    dflags <- getDynFlags
     let
-        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
+        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
         rhs      = mkLams tvs (mkLams args call_app)
         rhs'     = Cast rhs co
     return ([(fn_id, rhs')], empty, empty)
@@ -403,9 +405,10 @@ dsFExportDynamic :: Id
 dsFExportDynamic id co0 cconv = do
     fe_id <-  newSysLocalDs ty
     mod <- getModuleDs
+    dflags <- getDynFlags
     let
         -- hack: need to get at the name of the C stub we're about to generate.
-        fe_nm    = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
+        fe_nm    = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName dflags fe_id)
 
     cback <- newSysLocalDs arg_ty
     newStablePtrId <- dsLookupGlobalId newStablePtrName
@@ -465,8 +468,8 @@ dsFExportDynamic id co0 cconv = do
   Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
         -- Must have an IO type; hence Just
 
-toCName :: Id -> String
-toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
+toCName :: DynFlags -> Id -> String
+toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
 \end{code}
 
 %*
index 74fe642..efe14f2 100644 (file)
@@ -820,14 +820,16 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts
     handle_failure pat match fail_op
       | matchCanFail match
         = do { fail_op' <- dsExpr fail_op
-             ; fail_msg <- mkStringExpr (mk_fail_msg pat)
+             ; dflags <- getDynFlags
+             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
              ; extractMatchResult match (App fail_op' fail_msg) }
       | otherwise
         = extractMatchResult match (error "It can't fail")
 
-    mk_fail_msg :: Located e -> String
-    mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++
-                      showSDoc (ppr (getLoc pat))
+    mk_fail_msg :: DynFlags -> Located e -> String
+    mk_fail_msg dflags pat
+        = "Pattern match failure in monad comprehension at " ++
+          showPpr dflags (getLoc pat)
 
 -- Desugar nested monad comprehensions, for example in `then..` constructs
 --    dsInnerMonadComp quals [a,b,c] ret_op
index 5473edf..52944e8 100644 (file)
@@ -76,6 +76,7 @@ import Outputable
 import SrcLoc
 import Util
 import ListSetOps
+import DynFlags
 import FastString
 
 import Control.Monad    ( zipWithM )
@@ -439,8 +440,9 @@ mkErrorAppDs :: Id          -- The error function
 
 mkErrorAppDs err_id ty msg = do
     src_loc <- getSrcSpanDs
+    dflags <- getDynFlags
     let
-        full_msg = showSDoc (hcat [ppr src_loc, text "|", msg])
+        full_msg = showSDoc dflags (hcat [ppr src_loc, text "|", msg])
         core_msg = Lit (mkMachString full_msg)
         -- mkMachString returns a result of type String#
     return (mkApps (Var err_id) [Type ty, core_msg])
index 0fdc7a2..20b7e13 100644 (file)
@@ -164,7 +164,7 @@ showTerm term = do
                       -- does this still do what it is intended to do
                       -- with the changed error handling and logging?
            let noop_log _ _ _ _ _ = return ()
-               expr = "show " ++ showSDoc (ppr bname)
+               expr = "show " ++ showPpr dflags bname
            _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
            txt_ <- withExtendedLinkEnv [(bname, val)]
                                        (GHC.compileExpr expr)
index f357b97..331c294 100644 (file)
@@ -3,6 +3,7 @@ module DebuggerUtils (
   ) where
 
 import ByteCodeItbls
+import DynFlags
 import FastString
 import TcRnTypes
 import TcRnMonad
@@ -45,7 +46,8 @@ dataConInfoPtrToName x = do
        occFS = mkFastStringByteList occ
        occName = mkOccNameFS OccName.dataName occFS
        modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) 
-   return (Left$ showSDoc$ ppr modName <> dot <> ppr occName ) 
+   dflags <- getDynFlags
+   return (Left $ showSDoc dflags $ ppr modName <> dot <> ppr occName)
     `recoverM` (Right `fmap` lookupOrig modName occName)
 
    where
index 3f36cfd..a16832b 100644 (file)
@@ -442,8 +442,8 @@ linkExpr hsc_env span root_ul_bco
         -- All wired-in names are in the base package, which we link
         -- by default, so we can safely ignore them here.
 
-dieWith :: SrcSpan -> MsgDoc -> IO a
-dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage SevFatal span msg)))
+dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
+dieWith dflags span msg = ghcError (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
 
 
 checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool
@@ -460,14 +460,14 @@ checkNonStdWay dflags srcspan = do
     -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn
     -- whereas we have __stginit_base_Prelude_.
   if (objectSuf dflags == normalObjectSuffix)
-     then failNonStd srcspan
+     then failNonStd dflags srcspan
      else return True
 
 normalObjectSuffix :: String
 normalObjectSuffix = phaseInputExt StopLn
 
-failNonStd :: SrcSpan -> IO Bool
-failNonStd srcspan = dieWith srcspan $
+failNonStd :: DynFlags -> SrcSpan -> IO Bool
+failNonStd dflags srcspan = dieWith dflags srcspan $
   ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
   ptext (sLit "You need to build the program twice: once the normal way, and then") $$
   ptext (sLit "in the desired way using -osuf to set the object file suffix.")
@@ -526,7 +526,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
           mb_iface <- initIfaceCheck hsc_env $
                         loadInterface msg mod (ImportByUser False)
           iface <- case mb_iface of
-                    Maybes.Failed err      -> ghcError (ProgramError (showSDoc err))
+                    Maybes.Failed err      -> ghcError (ProgramError (showSDoc dflags err))
                     Maybes.Succeeded iface -> return iface
 
           when (mi_boot iface) $ link_boot_mod_error mod
@@ -554,12 +554,12 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
 
 
     link_boot_mod_error mod =
-        ghcError (ProgramError (showSDoc (
+        ghcError (ProgramError (showSDoc dflags (
             text "module" <+> ppr mod <+>
             text "cannot be linked; it is only available as a boot module")))
 
     no_obj :: Outputable a => a -> IO b
-    no_obj mod = dieWith span $
+    no_obj mod = dieWith dflags span $
                      ptext (sLit "cannot find object file for module ") <>
                         quotes (ppr mod) $$
                      while_linking_expr
@@ -600,7 +600,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
                                  <.> normalObjectSuffix
                 ok <- doesFileExist new_file
                 if (not ok)
-                   then dieWith span $
+                   then dieWith dflags span $
                           ptext (sLit "cannot find normal object file ")
                                 <> quotes (text new_file) $$ while_linking_expr
                    else return (DotO new_file)
index 4be3d87..f06d120 100644 (file)
@@ -378,7 +378,7 @@ ppr_termM _ _ t = ppr_termM1 t
 
 ppr_termM1 :: Monad m => Term -> m SDoc
 ppr_termM1 Prim{value=words, ty=ty} = 
-    return$ text$ repPrim (tyConAppTyCon ty) words
+    return $ repPrim (tyConAppTyCon ty) words
 ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = 
     return (char '_' <+> ifPprDebug (text "::" <> ppr ty))
 ppr_termM1 Suspension{ty=ty, bound_to=Just n}
@@ -493,33 +493,33 @@ cPprTermBase y =
    ppr_list _ _ = panic "doList"
 
 
-repPrim :: TyCon -> [Word] -> String
-repPrim t = rep where 
+repPrim :: TyCon -> [Word] -> SDoc
+repPrim t = rep where
    rep x
-    | t == charPrimTyCon   = show (build x :: Char)
-    | t == intPrimTyCon    = show (build x :: Int)
-    | t == wordPrimTyCon   = show (build x :: Word)
-    | t == floatPrimTyCon  = show (build x :: Float)
-    | t == doublePrimTyCon = show (build x :: Double)
-    | t == int32PrimTyCon  = show (build x :: Int32)
-    | t == word32PrimTyCon = show (build x :: Word32)
-    | t == int64PrimTyCon  = show (build x :: Int64)
-    | t == word64PrimTyCon = show (build x :: Word64)
-    | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
-    | t == stablePtrPrimTyCon  = "<stablePtr>"
-    | t == stableNamePrimTyCon = "<stableName>"
-    | t == statePrimTyCon      = "<statethread>"
-    | t == realWorldTyCon      = "<realworld>"
-    | t == threadIdPrimTyCon   = "<ThreadId>"
-    | t == weakPrimTyCon       = "<Weak>"
-    | t == arrayPrimTyCon      = "<array>"
-    | t == byteArrayPrimTyCon  = "<bytearray>"
-    | t == mutableArrayPrimTyCon = "<mutableArray>"
-    | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
-    | t == mutVarPrimTyCon= "<mutVar>"
-    | t == mVarPrimTyCon  = "<mVar>"
-    | t == tVarPrimTyCon  = "<tVar>"
-    | otherwise = showSDoc (char '<' <> ppr t <> char '>')
+    | t == charPrimTyCon             = text $ show (build x :: Char)
+    | t == intPrimTyCon              = text $ show (build x :: Int)
+    | t == wordPrimTyCon             = text $ show (build x :: Word)
+    | t == floatPrimTyCon            = text $ show (build x :: Float)
+    | t == doublePrimTyCon           = text $ show (build x :: Double)
+    | t == int32PrimTyCon            = text $ show (build x :: Int32)
+    | t == word32PrimTyCon           = text $ show (build x :: Word32)
+    | t == int64PrimTyCon            = text $ show (build x :: Int64)
+    | t == word64PrimTyCon           = text $ show (build x :: Word64)
+    | t == addrPrimTyCon             = text $ show (nullPtr `plusPtr` build x)
+    | t == stablePtrPrimTyCon        = text "<stablePtr>"
+    | t == stableNamePrimTyCon       = text "<stableName>"
+    | t == statePrimTyCon            = text "<statethread>"
+    | t == realWorldTyCon            = text "<realworld>"
+    | t == threadIdPrimTyCon         = text "<ThreadId>"
+    | t == weakPrimTyCon             = text "<Weak>"
+    | t == arrayPrimTyCon            = text "<array>"
+    | t == byteArrayPrimTyCon        = text "<bytearray>"
+    | t == mutableArrayPrimTyCon     = text "<mutableArray>"
+    | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
+    | t == mutVarPrimTyCon           = text "<mutVar>"
+    | t == mVarPrimTyCon             = text "<mVar>"
+    | t == tVarPrimTyCon             = text "<tVar>"
+    | otherwise                      = char '<' <> ppr t <> char '>'
     where build ww = unsafePerformIO $ withArray ww (peek . castPtr) 
 --   This ^^^ relies on the representation of Haskell heap values being 
 --   the same as in a C array. 
@@ -750,7 +750,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                         --  ignore the unpointed args, and recover the pointeds
                         -- This preserves laziness, and should be safe.
                       traceTR (text "Nothing" <+> ppr dcname)
-                       let tag = showSDoc (ppr dcname)
+                       let dflags = hsc_dflags hsc_env
+                           tag = showPpr dflags dcname
                        vars     <- replicateM (length$ elems$ ptrs clos) 
                                               (newVar liftedTypeKind)
                        subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i 
index eaf8ef5..4430b84 100644 (file)
@@ -162,8 +162,9 @@ loadUserInterface is_boot doc mod_name
 loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
 loadInterfaceWithException doc mod_name where_from
   = do  { mb_iface <- loadInterface doc mod_name where_from
+        ; dflags <- getDynFlags
         ; case mb_iface of 
-            Failed err      -> ghcError (ProgramError (showSDoc err))
+            Failed err      -> ghcError (ProgramError (showSDoc dflags err))
             Succeeded iface -> return iface }
 
 ------------------
index dd87cc7..3df54be 100644 (file)
@@ -1118,8 +1118,9 @@ checkOldIface :: HscEnv
               -> IO (RecompileRequired, Maybe ModIface)
 
 checkOldIface hsc_env mod_summary source_modified maybe_iface
-  = do  showPass (hsc_dflags hsc_env) $
-            "Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary)
+  = do  let dflags = hsc_dflags hsc_env
+        showPass dflags $
+            "Checking old interface for " ++ (showPpr dflags $ ms_mod mod_summary)
         initIfaceCheck hsc_env $
             check_old_iface hsc_env mod_summary source_modified maybe_iface
 
index 6a5e423..8f6ea05 100644 (file)
@@ -1001,7 +1001,8 @@ tcIfaceExpr (IfaceLit lit)
 tcIfaceExpr (IfaceFCall cc ty) = do
     ty' <- tcIfaceType ty
     u <- newUnique
-    return (Var (mkFCallId u cc ty'))
+    dflags <- getDynFlags
+    return (Var (mkFCallId dflags u cc ty'))
 
 tcIfaceExpr (IfaceTuple boxity args)  = do
     args' <- mapM tcIfaceExpr args
index b2c201c..8cac6b0 100644 (file)
@@ -183,11 +183,11 @@ outputForeignStubs dflags mod location stubs
      ForeignStubs h_code c_code -> do
         let
             stub_c_output_d = pprCode CStyle c_code
-            stub_c_output_w = showSDoc stub_c_output_d
+            stub_c_output_w = showSDoc dflags stub_c_output_d
         
             -- Header file protos for "foreign export"ed functions.
             stub_h_output_d = pprCode CStyle h_code
-            stub_h_output_w = showSDoc stub_h_output_d
+            stub_h_output_w = showSDoc dflags stub_h_output_d
         -- in
 
         createDirectoryIfMissing True (takeDirectory stub_h)
index 5db927a..953b2c4 100644 (file)
@@ -176,9 +176,9 @@ processDeps :: DynFlags
 --
 -- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
 
-processDeps _ _ _ _ _ (CyclicSCC nodes)
+processDeps dflags _ _ _ _ (CyclicSCC nodes)
   =     -- There shouldn't be any cycles; report them
-    ghcError (ProgramError (showSDoc $ GHC.cyclicModuleErr nodes))
+    ghcError (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
 
 processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
   = do  { let extra_suffixes = depSuffixes dflags
index 201a38c..be06fbc 100644 (file)
@@ -326,7 +326,7 @@ link' dflags batch_attempt_linking hpt
                    return Succeeded
            else do
 
-        compilationProgressMsg dflags $ showSDoc $
+        compilationProgressMsg dflags $ showSDoc dflags $
             (ptext (sLit "Linking") <+> text exe_file <+> text "...")
 
         -- Don't showPass in Batch mode; doLink will do that for us.
@@ -1497,7 +1497,7 @@ mkExtraObjToLinkIntoBinary dflags = do
           (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
            text "    Call hs_init_ghc() from your main() function to set these options.")
 
-   mkExtraObj dflags "c" (showSDoc main)
+   mkExtraObj dflags "c" (showSDoc dflags main)
 
   where
     main
@@ -1528,7 +1528,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do
    link_info <- getLinkInfo dflags dep_packages
 
    if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
-     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc (link_opts link_info))
+     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
      else return []
 
   where
index cc382a7..84eb261 100644 (file)
@@ -70,9 +70,10 @@ forceLoadTyCon hsc_env con_name = do
     
     mb_con_thing <- lookupTypeHscEnv hsc_env con_name
     case mb_con_thing of
-        Nothing -> throwCmdLineErrorS $ missingTyThingError con_name
+        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
         Just (ATyCon tycon) -> return tycon
-        Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing
+        Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
+  where dflags = hsc_dflags hsc_env
 
 -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
 -- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!
@@ -91,7 +92,7 @@ getValueSafely hsc_env val_name expected_type = do
     -- Now look up the names for the value and type constructor in the type environment
     mb_val_thing <- lookupTypeHscEnv hsc_env val_name
     case mb_val_thing of
-        Nothing -> throwCmdLineErrorS $ missingTyThingError val_name
+        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
         Just (AnId id) -> do
             -- Check the value type in the interface against the type recovered from the type constructor
             -- before finally casting the value to the type we assume corresponds to that constructor
@@ -107,7 +108,8 @@ getValueSafely hsc_env val_name expected_type = do
                 value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval
                 return $ Just value
              else return Nothing
-        Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing
+        Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
+  where dflags = hsc_dflags hsc_env
 
 
 -- | Coerce a value as usual, but:
@@ -149,10 +151,9 @@ lookupRdrNameInModule hsc_env mod_name rdr_name = do
                         []    -> return Nothing
                         _     -> panic "lookupRdrNameInModule"
 
-                Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
-        err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err
-  where
-    dflags = hsc_dflags hsc_env
+                Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
+        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
+  where dflags = hsc_dflags hsc_env
 
 
 wrongTyThingError :: Name -> TyThing -> SDoc
@@ -161,8 +162,8 @@ wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptex
 missingTyThingError :: Name -> SDoc
 missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]
 
-throwCmdLineErrorS :: SDoc -> IO a
-throwCmdLineErrorS = throwCmdLineError . showSDoc
+throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
+throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
 
 throwCmdLineError :: String -> IO a
 throwCmdLineError = throwGhcException . CmdLineError
index 83f57c3..301ed1b 100644 (file)
@@ -109,9 +109,9 @@ makeIntoWarning err = err { errMsgSeverity = SevWarning }
 -- Collecting up messages for later ordering and printing.
 
 mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
-mk_err_msg _ sev locn print_unqual msg extra 
+mk_err_msg  dflags sev locn print_unqual msg extra
  = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
-          , errMsgShortDoc = msg , errMsgShortString = showSDoc msg
+          , errMsgShortDoc = msg , errMsgShortString = showSDoc dflags msg
           , errMsgExtraInfo = extra
           , errMsgSeverity = sev }
 
index dc0730f..bedb300 100644 (file)
@@ -590,8 +590,9 @@ guessTarget str Nothing
         if looksLikeModuleName file
            then return (target (TargetModule (mkModuleName file)))
            else do
+        dflags <- getDynFlags
         throwGhcException
-                 (ProgramError (showSDoc $
+                 (ProgramError (showSDoc dflags $
                  text "target" <+> quotes (text file) <+> 
                  text "is not a module name or a source file"))
      where 
@@ -1291,11 +1292,11 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
            res <- findImportedModule hsc_env mod_name maybe_pkg
            case res of
              Found loc m | modulePackageId m /= this_pkg -> return m
-                         | otherwise -> modNotLoadedError m loc
+                         | otherwise -> modNotLoadedError dflags m loc
              err -> noModError dflags noSrcSpan mod_name err
 
-modNotLoadedError :: Module -> ModLocation -> IO a
-modNotLoadedError m loc = ghcError $ CmdLineError $ showSDoc $
+modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
+modNotLoadedError dflags m loc = ghcError $ CmdLineError $ showSDoc dflags $
    text "module is not loaded:" <+> 
    quotes (ppr (moduleName m)) <+>
    parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
index 0c09603..3941588 100644 (file)
@@ -853,10 +853,11 @@ batchMsg hsc_env mb_mod_index recomp mod_summary =
         RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
         RecompForcedByTH -> showMsg "Compiling " " [TH]"
     where
+        dflags = hsc_dflags hsc_env
         showMsg msg reason =
-            compilationProgressMsg (hsc_dflags hsc_env) $
+            compilationProgressMsg dflags $
             (showModuleIndex mb_mod_index ++
-            msg ++ showModMsg (hscTarget (hsc_dflags hsc_env))
+            msg ++ showModMsg dflags (hscTarget dflags)
                               (recompileRequired recomp) mod_summary)
                 ++ reason
 
index 6298192..aac5ba5 100644 (file)
@@ -182,7 +182,7 @@ srcErrorMessages :: SourceError -> ErrorMessages
 srcErrorMessages (SourceError msgs) = msgs
 
 mkApiErr :: DynFlags -> SDoc -> GhcApiError
-mkApiErr _ msg = GhcApiError (showSDoc msg)
+mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
 
 throwOneError :: MonadIO m => ErrMsg -> m ab
 throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
@@ -1870,9 +1870,9 @@ instance Outputable ModSummary where
              char '}'
             ]
 
-showModMsg :: HscTarget -> Bool -> ModSummary -> String
-showModMsg target recomp mod_summary
-  = showSDoc $
+showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String
+showModMsg dflags target recomp mod_summary
+  = showSDoc dflags $
         hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '),
               char '(', text (normalise $ msHsFilePath mod_summary) <> comma,
               case target of
@@ -1883,7 +1883,7 @@ showModMsg target recomp mod_summary
               char ')']
  where
     mod     = moduleName (ms_mod mod_summary)
-    mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary)
+    mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)
 \end{code}
 
 %************************************************************************
index 5fa0f6b..60681fc 100644 (file)
@@ -814,9 +814,10 @@ fromListBL bound l = BL (length l) bound l []
 setContext :: GhcMonad m => [InteractiveImport] -> m ()
 setContext imports
   = do { hsc_env <- getSession
+       ; let dflags = hsc_dflags hsc_env
        ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
        ; case all_env_err of
-           Left (mod, err) -> ghcError (formatError mod err)
+           Left (mod, err) -> ghcError (formatError dflags mod err)
            Right all_env -> do {
        ; let old_ic        = hsc_IC hsc_env
              final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env
@@ -824,7 +825,7 @@ setContext imports
          hsc_env{ hsc_IC = old_ic { ic_imports    = imports
                                   , ic_rn_gbl_env = final_rdr_env }}}}
   where
-    formatError mod err = ProgramError . showSDoc $
+    formatError dflags mod err = ProgramError . showSDoc dflags $
       text "Cannot add module" <+> ppr mod <+>
       text "to context:" <+> text err
 
@@ -1009,7 +1010,8 @@ showModule :: GhcMonad m => ModSummary -> m String
 showModule mod_summary =
     withSession $ \hsc_env -> do
         interpreted <- isModuleInterpreted mod_summary
-        return (showModMsg (hscTarget(hsc_dflags hsc_env)) interpreted mod_summary)
+        let dflags = hsc_dflags hsc_env
+        return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)
 
 isModuleInterpreted :: GhcMonad m => ModSummary -> m Bool
 isModuleInterpreted mod_summary = withSession $ \hsc_env ->
index 42e5cf5..9831367 100644 (file)
@@ -318,16 +318,17 @@ mungePackagePaths top_dir pkgroot pkg =
 -- (-package, -hide-package, -ignore-package).
 
 applyPackageFlag
-   :: UnusablePackages
+   :: DynFlags
+   -> UnusablePackages
    -> [PackageConfig]           -- Initial database
    -> PackageFlag               -- flag to apply
    -> IO [PackageConfig]        -- new database
 
-applyPackageFlag unusable pkgs flag =
+applyPackageFlag dflags unusable pkgs flag =
   case flag of
     ExposePackage str ->
        case selectPackages (matchingStr str) pkgs unusable of
-         Left ps         -> packageFlagErr flag ps
+         Left ps         -> packageFlagErr dflags flag ps
          Right (p:ps,qs) -> return (p':ps')
           where p' = p {exposed=True}
                 ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
@@ -335,7 +336,7 @@ applyPackageFlag unusable pkgs flag =
 
     ExposePackageId str ->
        case selectPackages (matchingId str) pkgs unusable of
-         Left ps         -> packageFlagErr flag ps
+         Left ps         -> packageFlagErr dflags flag ps
          Right (p:ps,qs) -> return (p':ps')
           where p' = p {exposed=True}
                 ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
@@ -343,7 +344,7 @@ applyPackageFlag unusable pkgs flag =
 
     HidePackage str ->
        case selectPackages (matchingStr str) pkgs unusable of
-         Left ps       -> packageFlagErr flag ps
+         Left ps       -> packageFlagErr dflags flag ps
          Right (ps,qs) -> return (map hide ps ++ qs)
           where hide p = p {exposed=False}
 
@@ -351,13 +352,13 @@ applyPackageFlag unusable pkgs flag =
     -- and leave others the same or set them untrusted
     TrustPackage str ->
        case selectPackages (matchingStr str) pkgs unusable of
-         Left ps       -> packageFlagErr flag ps
+         Left ps       -> packageFlagErr dflags flag ps
          Right (ps,qs) -> return (map trust ps ++ qs)
           where trust p = p {trusted=True}
 
     DistrustPackage str ->
        case selectPackages (matchingStr str) pkgs unusable of
-         Left ps       -> packageFlagErr flag ps
+         Left ps       -> packageFlagErr dflags flag ps
          Right (ps,qs) -> return (map distrust ps ++ qs)
           where distrust p = p {trusted=False}
 
@@ -402,19 +403,20 @@ sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
 comparing :: Ord a => (t -> a) -> t -> t -> Ordering
 comparing f a b = f a `compare` f b
 
-packageFlagErr :: PackageFlag
+packageFlagErr :: DynFlags
+               -> PackageFlag
                -> [(PackageConfig, UnusablePackageReason)]
                -> IO a
 
 -- for missing DPH package we emit a more helpful error message, because
 -- this may be the result of using -fdph-par or -fdph-seq.
-packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg
-  = ghcError (CmdLineError (showSDoc $ dph_err))
+packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg
+  = ghcError (CmdLineError (showSDoc dflags $ dph_err))
   where dph_err = text "the " <> text pkg <> text " package is not installed."
                   $$ text "To install it: \"cabal install dph\"."
         is_dph_package pkg = "dph" `isPrefixOf` pkg
 
-packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err))
+packageFlagErr dflags flag reasons = ghcError (CmdLineError (showSDoc dflags $ err))
   where err = text "cannot satisfy " <> ppr_flag <>
                 (if null reasons then empty else text ": ") $$
               nest 4 (ppr_reasons $$
@@ -754,7 +756,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
   -- Modify the package database according to the command-line flags
   -- (-package, -hide-package, -ignore-package, -hide-all-packages).
   --
-  pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
+  pkgs1 <- foldM (applyPackageFlag dflags unusable) pkgs0_unique other_flags
   let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1
 
   -- Here we build up a set of the packages mentioned in -package
@@ -782,7 +784,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
 
       lookupIPID ipid@(InstalledPackageId str)
          | Just pid <- Map.lookup ipid ipid_map = return pid
-         | otherwise                            = missingPackageErr str
+         | otherwise                            = missingPackageErr dflags str
 
   preload2 <- mapM lookupIPID preload1
 
@@ -799,7 +801,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do
                      $ (basicLinkedPackages ++ preload2)
 
   -- Close the preload packages with their dependencies
-  dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
+  dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing))
   let new_dep_preload = filter (`notElem` preload0) dep_preload
 
   let pstate = PackageState{ preloadPackages     = dep_preload,
@@ -964,20 +966,23 @@ getPreloadPackagesAnd dflags pkgids =
       preload = preloadPackages state
       pairs = zip pkgids (repeat Nothing)
   in do
-  all_pkgs <- throwErr (foldM (add_package pkg_map ipid_map) preload pairs)
+  all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
   return (map (getPackageDetails state) all_pkgs)
 
 -- Takes a list of packages, and returns the list with dependencies included,
 -- in reverse dependency order (a package appears before those it depends on).
-closeDeps :: PackageConfigMap
+closeDeps :: DynFlags
+          -> PackageConfigMap
           -> Map InstalledPackageId PackageId
           -> [(PackageId, Maybe PackageId)]
           -> IO [PackageId]
-closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
+closeDeps dflags pkg_map ipid_map ps
+    = throwErr dflags (closeDepsErr pkg_map ipid_map ps)
 
-throwErr :: MaybeErr MsgDoc a -> IO a
-throwErr m = case m of
-                Failed e    -> ghcError (CmdLineError (showSDoc e))
+throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
+throwErr dflags m
+              = case m of
+                Failed e    -> ghcError (CmdLineError (showSDoc dflags e))
                 Succeeded r -> return r
 
 closeDepsErr :: PackageConfigMap
@@ -1009,8 +1014,9 @@ add_package pkg_db ipid_map ps (p, mb_parent)
               | otherwise
               = Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
 
-missingPackageErr :: String -> IO a
-missingPackageErr p = ghcError (CmdLineError (showSDoc (missingPackageMsg p)))
+missingPackageErr :: DynFlags -> String -> IO a
+missingPackageErr dflags p
+    = ghcError (CmdLineError (showSDoc dflags (missingPackageMsg p)))
 
 missingPackageMsg :: String -> SDoc
 missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
index d624cc1..ddd8775 100644 (file)
@@ -315,7 +315,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
         count' <- return $! count + 1;
 
         -- force evaulation all this stuff to avoid space leaks
-        {-# SCC "seqString" #-} seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return ()
+        {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map (pprPlatform platform) imports) `seq` return ()
 
         cmmNativeGens dflags ncgImpl
             h us' cmms
@@ -818,8 +818,7 @@ Ideas for other things we could do (put these in Hoopl please!):
 cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])
 cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
-  let platform = targetPlatform dflags
-  blocks' <- mapM cmmBlockConFold (cmmMiniInline platform (cmmEliminateDeadBlocks blocks))
+  blocks' <- mapM cmmBlockConFold (cmmMiniInline dflags (cmmEliminateDeadBlocks blocks))
   return $ CmmProc info lbl (ListGraph blocks')
 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
@@ -897,7 +896,7 @@ cmmStmtConFold stmt
                  return $ case test' of
                    CmmLit (CmmInt 0 _) ->
                      CmmComment (mkFastString ("deleted: " ++
-                                        showSDoc (pprStmt platform stmt)))
+                                        showSDoc dflags (pprStmt platform stmt)))
 
                    CmmLit (CmmInt _ _) -> CmmBranch dest
                    _other -> CmmCondBranch test' dest
index 8b8beb9..65b34ac 100644 (file)
@@ -1387,14 +1387,15 @@ unknownNameSuggestErr :: WhereLooking -> RdrName -> RnM SDoc
 unknownNameSuggestErr where_look tried_rdr_name
   = do { local_env <- getLocalRdrEnv
        ; global_env <- getGlobalRdrEnv
+       ; dflags <- getDynFlags
 
        ; let all_possibilities :: [(String, (RdrName, HowInScope))]
              all_possibilities
-                =  [ (showSDoc (ppr r), (r, Left loc))
+                =  [ (showPpr dflags r, (r, Left loc))
                    | (r,loc) <- local_possibilities local_env ]
-                ++ [ (showSDoc (ppr r), rp) | (r,rp) <- global_possibilities global_env ]
+                ++ [ (showPpr dflags r, rp) | (r,rp) <- global_possibilities global_env ]
 
-             suggest = fuzzyLookup (showSDoc (ppr tried_rdr_name)) all_possibilities
+             suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
              perhaps = ptext (sLit "Perhaps you meant")
              extra_err = case suggest of
                            []  -> empty
index 48ff0ee..272bdfb 100644 (file)
@@ -147,7 +147,7 @@ endPass dflags pass binds rules
 
 dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
 dumpIfSet dflags dump_me pass extra_info doc
-  = Err.dumpIfSet dflags dump_me (showSDoc (ppr pass <+> extra_info)) doc
+  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
 
 dumpPassResult :: DynFlags 
                -> Maybe DynFlag                -- Just df => show details in a file whose
@@ -158,7 +158,7 @@ dumpPassResult :: DynFlags
                -> IO ()
 dumpPassResult dflags mb_flag hdr extra_info binds rules
   | Just dflag <- mb_flag
-  = Err.dumpSDoc dflags dflag (showSDoc hdr) dump_doc
+  = Err.dumpSDoc dflags dflag (showSDoc dflags hdr) dump_doc
 
   | otherwise
   = Err.debugTraceMsg dflags 2 size_doc
index a176e6c..c68c900 100644 (file)
@@ -328,9 +328,10 @@ loadPlugins hsc_env
 loadPlugin :: HscEnv -> ModuleName -> IO Plugin
 loadPlugin hsc_env mod_name
   = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin")
+             dflags = hsc_dflags hsc_env
        ; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name
        ; case mb_name of {
-            Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep
+            Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep
                           [ ptext (sLit "The module"), ppr mod_name
                           , ptext (sLit "did not export the plugin name")
                           , ppr plugin_rdr_name ]) ;
@@ -339,7 +340,7 @@ loadPlugin hsc_env mod_name
      do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName
         ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
         ; case mb_plugin of
-            Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep
+            Nothing -> throwGhcException (CmdLineError $ showSDoc dflags $ hsep
                           [ ptext (sLit "The value"), ppr name
                           , ptext (sLit "did not have the type")
                           , ppr pluginTyConName, ptext (sLit "as required")])
index a65d46e..995d621 100644 (file)
@@ -627,7 +627,8 @@ specConstrProgram guts
 %************************************************************************
 
 \begin{code}
-data ScEnv = SCE { sc_size  :: Maybe Int,      -- Size threshold
+data ScEnv = SCE { sc_dflags :: DynFlags,
+                   sc_size  :: Maybe Int,      -- Size threshold
                   sc_count :: Maybe Int,       -- Max # of specialisations for any one fn
                                                -- See Note [Avoiding exponential blowup]
                    sc_force :: Bool,            -- Force specialisation?
@@ -672,7 +673,8 @@ instance Outputable Value where
 ---------------------
 initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
 initScEnv dflags anns
-  = SCE { sc_size = specConstrThreshold dflags,
+  = SCE { sc_dflags = dflags,
+          sc_size = specConstrThreshold dflags,
          sc_count = specConstrCount dflags,
           sc_force = False,
          sc_subst = emptySubst, 
@@ -1384,7 +1386,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
              fn_name    = idName fn
              fn_loc     = nameSrcSpan fn_name
              spec_occ   = mkSpecOcc (nameOccName fn_name)
-             rule_name  = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number))
+             dflags     = sc_dflags env
+             rule_name  = mkFastString ("SC:" ++ showSDoc dflags (ppr fn <> int rule_number))
              spec_name  = mkInternalName spec_uniq spec_occ fn_loc
 --     ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn <+> ppr pats <+> text "-->" <+> ppr spec_name) $ 
 --       return ()
index 781918d..c46d826 100644 (file)
@@ -162,8 +162,9 @@ deferToRuntime ev_binds_var ctxt mk_err_msg ct
   | Wanted { ctev_wloc = loc, ctev_pred = pred, ctev_evar = ev_id } <- cc_ev ct
   = do { err <- setCtLoc loc $
                 mk_err_msg ctxt ct
+       ; dflags <- getDynFlags
        ; let err_msg = pprLocErrMsg err
-             err_fs  = mkFastString $ showSDoc 
+             err_fs  = mkFastString $ showSDoc dflags $
                        err_msg $$ text "(deferred type error)"
 
          -- Create the binding
index 920a702..49c5131 100644 (file)
@@ -1060,14 +1060,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
            ; warnMissingMethodOrAT "method" (idName sel_id)
            ; (meth_id, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
                                          inst_tys sel_id
+           ; dflags <- getDynFlags
            ; return (meth_id, mkVarBind meth_id $
-                              mkLHsWrap lam_wrapper error_rhs) }
+                              mkLHsWrap lam_wrapper (error_rhs dflags)) }
       where
-        error_rhs    = L loc $ HsApp error_fun error_msg
+        error_rhs dflags = L loc $ HsApp error_fun (error_msg dflags)
         error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
-        error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
+        error_msg dflags = L loc (HsLit (HsStringPrim (mkFastString (error_string dflags))))
         meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
-        error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+        error_string dflags = showSDoc dflags (hcat [ppr loc, text "|", ppr sel_id ])
         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
 
     tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method
index 9aff080..3f03d56 100644 (file)
@@ -359,8 +359,8 @@ mkCodeStyle = PprCode
 -- Can't make SDoc an instance of Show because SDoc is just a function type
 -- However, Doc *is* an instance of Show
 -- showSDoc just blasts it out as a string
-showSDoc :: SDoc -> String
-showSDoc d =
+showSDoc :: DynFlags -> SDoc -> String
+showSDoc d =
   Pretty.showDocWith PageMode
     (runSDoc d (initSDocContext defaultUserStyle))
 
@@ -400,7 +400,7 @@ showSDocDebug :: SDoc -> String
 showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
 
 showPpr :: Outputable a => DynFlags -> a -> String
-showPpr _ = showSDoc . ppr
+showPpr dflags = showSDoc dflags . ppr
 \end{code}
 
 \begin{code}
@@ -942,7 +942,7 @@ warnPprTrace False _file _line _msg x = x
 warnPprTrace True   file  line  msg x
   = pprDebugAndThen trace str msg x
   where
-    str = showSDoc (hsep [text "WARNING: file", text file <> comma, text "line", int line])
+    str = showSDoc tracingDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line])
 
 assertPprPanic :: String -> Int -> SDoc -> a
 -- ^ Panic with an assertation failure, recording the given file and line number.
@@ -954,6 +954,14 @@ assertPprPanic file line msg
                      , text "line", int line ]
               , msg ]
 
+-- tracingDynFlags is a hack, necessary because we need to be able to
+-- show SDocs when tracing, but we don't always have DynFlags available.
+-- Do not use it if you can help it. It will not reflect options set
+-- by the commandline flags, it may hav the wrong target platform, etc.
+-- Currently it just panics if you try to use it.
+tracingDynFlags :: DynFlags
+tracingDynFlags = panic "tracingDynFlags used"
+
 pprDebugAndThen :: (String -> a) -> String -> SDoc -> a
 pprDebugAndThen cont heading pretty_msg 
  = cont (show (runSDoc doc (initSDocContext PprDebug)))
index c92ae80..8b7e817 100644 (file)
@@ -210,7 +210,8 @@ vectTopBind b@(Rec bs)
            ; if and hasNoVectDecls 
              then return b                              -- all bindings have 'NOVECTORISE'
              else if or hasNoVectDecls 
-             then cantVectorise noVectoriseErr (ppr b)  -- some (but not all) have 'NOVECTORISE'
+             then do dflags <- getDynFlags
+                     cantVectorise dflags noVectoriseErr (ppr b)  -- some (but not all) have 'NOVECTORISE'
              else vectorise                             -- no binding has a 'NOVECTORISE' decl
            }
     noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group"
@@ -265,7 +266,7 @@ vectTopBinder var inline expr
             | eqType vty vdty -> return ()
             | otherwise       -> 
               do dflags <- getDynFlags
-                 cantVectorise ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $
+                 cantVectorise dflags ("Type mismatch in vectorisation pragma for " ++ showPpr dflags var) $
                    (text "Expected type" <+> ppr vty)
                    $$
                    (text "Inferred type" <+> ppr vdty)
index c984c10..8c5ef00 100644 (file)
@@ -48,7 +48,7 @@ import Control.Applicative
 import Data.Maybe
 import Data.List
 import TcRnMonad (doptM)
-import DynFlags (DynFlag(Opt_AvoidVect))
+import DynFlags
 import Util
 
 
@@ -281,7 +281,8 @@ vectExpr (_, AnnLit lit) _
 
 vectExpr e@(_, AnnLam bndr _) vt
   | isId bndr = (\(_, _, ve) -> ve) <$> vectFnExpr True False [] e vt
-  | otherwise = cantVectorise "Unexpected type lambda (vectExpr)" (ppr (deAnnotate e))
+  | otherwise = do dflags <- getDynFlags
+                   cantVectorise dflags "Unexpected type lambda (vectExpr)" (ppr (deAnnotate e))
 
   -- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty';
   --   its only purpose is to abort the program, but we need to adjust the type to keep CoreLint
@@ -336,7 +337,8 @@ vectExpr (_, AnnCase scrut bndr ty alts)  vt
   | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty
   , isAlgTyCon tycon
   = vectAlgCase tycon ty_args scrut bndr ty alts vt
-  | otherwise = cantVectorise "Can't vectorise expression" (ppr scrut_ty) 
+  | otherwise = do dflags <- getDynFlags
+                   cantVectorise dflags "Can't vectorise expression" (ppr scrut_ty)
   where
     scrut_ty = exprType (deAnnotate scrut)
 
@@ -368,7 +370,8 @@ vectExpr (_, AnnTick tickish expr)  (VITNode _ [vit])
 vectExpr (_, AnnType ty) _
   = liftM vType (vectType ty)
 
-vectExpr e vit = cantVectorise "Can't vectorise expression (vectExpr)" (ppr (deAnnotate e) $$ text ("  " ++ show vit))
+vectExpr e vit = do dflags <- getDynFlags
+                    cantVectorise dflags "Can't vectorise expression (vectExpr)" (ppr (deAnnotate e) $$ text ("  " ++ show vit))
 
 -- |Vectorise an expression that *may* have an outer lambda abstraction.
 --
index ce2d947..7779329 100644 (file)
@@ -23,6 +23,7 @@ import OccName
 import Coercion
 import MkId
 
+import DynFlags
 import FastString
 import MonadUtils
 import Control.Monad
@@ -394,8 +395,10 @@ buildToArrPReprs vect_tc repr_co _ pdatas_tc r
      = case ss of
         -- We can't convert data types with no data.
         -- See Note: [Empty PDatas].
-        EmptySum        -> return ([], errorEmptyPDatas el_ty)
-        UnarySum r      -> to_con (errorEmptyPDatas el_ty) r
+        EmptySum        -> do dflags <- getDynFlags
+                              return ([], errorEmptyPDatas dflags el_ty)
+        UnarySum r      -> do dflags <- getDynFlags
+                              to_con (errorEmptyPDatas dflags el_ty) r
 
         Sum{}
          -> do  let psums_tc     = repr_psums_tc ss
@@ -486,7 +489,8 @@ buildFromArrPReprs vect_tc repr_co _ pdatas_tc r
      = case ss of
         -- We can't convert data types with no data.
         -- See Note: [Empty PDatas].
-        EmptySum        -> return (res, errorEmptyPDatas el_ty)
+        EmptySum        -> do dflags <- getDynFlags
+                              return (res, errorEmptyPDatas dflags el_ty)
         UnarySum r      -> from_con res_ty res expr r
 
         Sum {}
@@ -572,9 +576,9 @@ To fix this we'd need to add an Int field to VPDs:Empty1 as well, but that's
 too much hassle and there's no point running a parallel computation on no
 data anyway.
 -}
-errorEmptyPDatas :: Type -> a
-errorEmptyPDatas tc
-    = cantVectorise "Vectorise.PAMethods"
+errorEmptyPDatas :: DynFlags -> Type -> a
+errorEmptyPDatas dflags tc
+    = cantVectorise dflags "Vectorise.PAMethods"
     $ vcat  [ text "Cannot vectorise data type with no parallel data " <> quotes (ppr tc)
             , text "Data types to be vectorised must contain at least one constructor"
             , text "with at least one field." ]
index 2784868..375b0af 100644 (file)
@@ -151,7 +151,9 @@ lookupVar v
   = do { mb_res <- lookupVar_maybe v
        ; case mb_res of
            Just x  -> return x
-           Nothing -> dumpVar v
+           Nothing ->
+               do dflags <- getDynFlags
+                  dumpVar dflags v
        }
 
 lookupVar_maybe :: Var -> VM (Maybe (Scope Var (Var, Var)))
@@ -162,12 +164,12 @@ lookupVar_maybe v
           Nothing -> fmap Global <$> (readGEnv $ \env -> lookupVarEnv (global_vars env) v)
       }
 
-dumpVar :: Var -> a
-dumpVar var
+dumpVar :: DynFlags -> Var -> a
+dumpVar dflags var
   | Just _    <- isClassOpId_maybe var
-  = cantVectorise "ClassOpId not vectorised:" (ppr var)
+  = cantVectorise dflags "ClassOpId not vectorised:" (ppr var)
   | otherwise
-  = cantVectorise "Variable not vectorised:" (ppr var)
+  = cantVectorise dflags "Variable not vectorised:" (ppr var)
 
 
 -- Global scalars --------------------------------------------------------------
index e47015c..7effd75 100644 (file)
@@ -84,27 +84,30 @@ liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
 
 -- |Throw a `pgmError` saying we can't vectorise something.
 --
-cantVectorise :: String -> SDoc -> a
-cantVectorise s d = pgmError
-                  . showSDoc
+cantVectorise :: DynFlags -> String -> SDoc -> a
+cantVectorise dflags s d = pgmError
+                  . showSDoc dflags
                   $ vcat [text "*** Vectorisation error ***",
                           nest 4 $ sep [text s, nest 4 d]]
 
 -- |Like `fromJust`, but `pgmError` on Nothing.
 --
-maybeCantVectorise :: String -> SDoc -> Maybe a -> a
-maybeCantVectorise s d Nothing  = cantVectorise s d
-maybeCantVectorise _ _ (Just x) = x
+maybeCantVectorise :: DynFlags -> String -> SDoc -> Maybe a -> a
+maybeCantVectorise dflags s d Nothing  = cantVectorise dflags s d
+maybeCantVectorise _ _ (Just x) = x
 
 -- |Like `maybeCantVectorise` but in a `Monad`.
 --
-maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
+maybeCantVectoriseM :: (Monad m, HasDynFlags m)
+                    => String -> SDoc -> m (Maybe a) -> m a
 maybeCantVectoriseM s d p
   = do
       r <- p
       case r of
         Just x  -> return x
-        Nothing -> cantVectorise s d
+        Nothing ->
+            do dflags <- getDynFlags
+               cantVectorise dflags s d
 
 
 -- Debugging ------------------------------------------------------------------
index e728d6a..a5c8449 100644 (file)
@@ -37,6 +37,7 @@ import CoreSyn
 import Type
 import TyCon
 import DataCon
+import DynFlags
 import NameEnv
 import NameSet
 import Name
@@ -76,7 +77,9 @@ defGlobalVar v v'
            -- check for duplicate vectorisation
        ; currentDef <- readGEnv $ \env -> lookupVarEnv (global_vars env) v
        ; case currentDef of
-           Just old_v' -> cantVectorise "Variable is already vectorised:" $
+           Just old_v' ->
+               do dflags <- getDynFlags
+                  cantVectorise dflags "Variable is already vectorised:" $
                             ppr v <+> moduleOf v old_v'
            Nothing     -> return ()
 
@@ -147,7 +150,9 @@ defTyConName tc nameOfTc' tc'
            -- check for duplicate vectorisation
        ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
        ; case currentDef of
-           Just old_tc' -> cantVectorise "Type constructor or class is already vectorised:" $
+           Just old_tc' ->
+               do dflags <- getDynFlags
+                  cantVectorise dflags "Type constructor or class is already vectorised:" $
                             ppr tc <+> moduleOf tc old_tc'
            Nothing     -> return ()
 
index 546da33..34d3d75 100644 (file)
@@ -8,6 +8,7 @@ import Vectorise.Monad.Global
 import Vectorise.Monad.Base
 import Vectorise.Env
 
+import DynFlags
 import FamInstEnv
 import InstEnv
 import Class
@@ -34,7 +35,9 @@ lookupInst cls tys
   = do { instEnv <- readGEnv global_inst_env
        ; case lookupUniqueInstEnv instEnv cls tys of
            Right (inst, inst_tys) -> return (instanceDFunId inst, inst_tys)
-           Left  err              -> cantVectorise "Vectorise.Monad.InstEnv.lookupInst:" err
+           Left  err              ->
+               do dflags <- getDynFlags
+                  cantVectorise dflags "Vectorise.Monad.InstEnv.lookupInst:" err
        }
 
 -- Look up the representation tycon of a family instance.
@@ -61,6 +64,7 @@ lookupFamInst tycon tys
            [(fam_inst, rep_tys)] -> return ( dataFamInstRepTyCon fam_inst
                                            , rep_tys)
            _other                -> 
-             cantVectorise "VectMonad.lookupFamInst: not found: " 
+             do dflags <- getDynFlags
+                cantVectorise dflags "VectMonad.lookupFamInst: not found: "
                            (ppr $ mkTyConApp tycon tys)
        }
index 9f682a8..05b7824 100644 (file)
@@ -11,6 +11,7 @@ import Type
 import TyCon
 import DataCon
 import BasicTypes
+import DynFlags
 import Var
 import Name
 import Outputable
@@ -35,7 +36,8 @@ vectTyConDecl tycon name'
       -- Type constructor representing a type class
   | Just cls <- tyConClass_maybe tycon
   = do { unless (null $ classATs cls) $
-           cantVectorise "Associated types are not yet supported" (ppr cls)
+           do dflags <- getDynFlags
+              cantVectorise dflags "Associated types are not yet supported" (ppr cls)
 
            -- vectorise superclass constraint (types)
        ; theta' <- mapM vectType (classSCTheta cls)
@@ -83,7 +85,8 @@ vectTyConDecl tycon name'
        -- Regular algebraic type constructor — for now, Haskell 2011-style only
   | isAlgTyCon tycon
   = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
-           cantVectorise "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
+           do dflags <- getDynFlags
+              cantVectorise dflags "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
   
            -- vectorise the data constructor of the class tycon
        ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
@@ -106,7 +109,8 @@ vectTyConDecl tycon name'
 
   -- some other crazy thing that we don't handle
   | otherwise
-  = cantVectorise "Can't vectorise exotic type constructor" (ppr tycon)
+  = do dflags <- getDynFlags
+       cantVectorise dflags "Can't vectorise exotic type constructor" (ppr tycon)
 
 -- |Vectorise a class method.  (Don't enter it into the vectorisation map yet.)
 --
@@ -125,7 +129,8 @@ vectMethod id defMeth ty
 --
 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
 vectAlgTyConRhs tc (AbstractTyCon {})
-  = cantVectorise "Can't vectorise imported abstract type" (ppr tc)
+  = do dflags <- getDynFlags
+       cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc)
 vectAlgTyConRhs _tc DataFamilyTyCon
   = return DataFamilyTyCon
 vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
@@ -138,7 +143,8 @@ vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
                             }
        }
 vectAlgTyConRhs tc (NewTyCon {})
-  = cantVectorise noNewtypeErr (ppr tc)
+  = do dflags <- getDynFlags
+       cantVectorise dflags noNewtypeErr (ppr tc)
   where
     noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
 
@@ -147,13 +153,17 @@ vectAlgTyConRhs tc (NewTyCon {})
 vectDataCon :: DataCon -> VM DataCon
 vectDataCon dc
   | not . null $ ex_tvs
-  = cantVectorise "Can't vectorise constructor with existential type variables yet" (ppr dc)
+  = do dflags <- getDynFlags
+       cantVectorise dflags "Can't vectorise constructor with existential type variables yet" (ppr dc)
   | not . null $ eq_spec
-  = cantVectorise "Can't vectorise constructor with equality context yet" (ppr dc)
+  = do dflags <- getDynFlags
+       cantVectorise dflags "Can't vectorise constructor with equality context yet" (ppr dc)
   | not . null $ dataConFieldLabels dc
-  = cantVectorise "Can't vectorise constructor with labelled fields yet" (ppr dc)
+  = do dflags <- getDynFlags
+       cantVectorise dflags "Can't vectorise constructor with labelled fields yet" (ppr dc)
   | not . null $ theta
-  = cantVectorise "Can't vectorise constructor with constraint context yet" (ppr dc)
+  = do dflags <- getDynFlags
+       cantVectorise dflags "Can't vectorise constructor with constraint context yet" (ppr dc)
   | otherwise
   = do { name'   <- mkLocalisedName mkVectDataConOcc name
        ; tycon'  <- vectTyCon tycon
index dfc08bc..de80127 100644 (file)
@@ -18,6 +18,7 @@ import TypeRep
 import TyCon
 import Var
 import Outputable
+import DynFlags
 import FastString
 import Control.Monad
 
@@ -82,9 +83,10 @@ paDictOfType ty
      where
        noPADictErr = "No PA dictionary for type constructor (did you import 'Data.Array.Parallel'?)"
 
-    paDictOfTyApp _ _ = failure
+    paDictOfTyApp _ _ = do dflags <- getDynFlags
+                           failure dflags
 
-    failure = cantVectorise "Can't construct PA dictionary for type" (ppr ty)
+    failure dflags = cantVectorise dflags "Can't construct PA dictionary for type" (ppr ty)
 
 -- |Produce code that refers to a method of the 'PA' class.
 --
@@ -160,8 +162,9 @@ prDictOfReprType ty
 
 prDictOfReprType' :: Type -> VM CoreExpr
 prDictOfReprType' ty = prDictOfReprType ty `orElseV`
-                       cantVectorise "No PR dictionary for representation type"
-                                     (ppr ty)
+                       do dflags <- getDynFlags
+                          cantVectorise dflags "No PR dictionary for representation type"
+                                        (ppr ty)
 
 -- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding
 -- to the argument types.
@@ -175,10 +178,12 @@ prDFunApply dfun tys
   = do
       pa <- builtin paTyCon
       pr <- builtin prTyCon 
-      args <- zipWithM (dictionary pa pr) tys tycons
+      dflags <- getDynFlags
+      args <- zipWithM (dictionary dflags pa pr) tys tycons
       return $ Var dfun `mkTyApps` tys `mkApps` args
 
-  | otherwise = invalid
+  | otherwise = do dflags <- getDynFlags
+                   invalid dflags
   where
     -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then
     -- ctxs is Just [PA, PR]
@@ -191,10 +196,10 @@ prDFunApply dfun tys
          $ splitForAllTys
          $ varType dfun
 
-    dictionary pa pr ty tycon
+    dictionary dflags pa pr ty tycon
       | tycon == pa = paDictOfType ty
       | tycon == pr = prDictOfReprType ty
-      | otherwise   = invalid
+      | otherwise   = invalid dflags
 
-    invalid = cantVectorise "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys)
+    invalid dflags = cantVectorise dflags "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys)
  
index c6eb619..5cc87cf 100644 (file)
@@ -306,18 +306,19 @@ timeIt action
                   a <- action
                   allocs2 <- liftIO $ getAllocations
                   time2   <- liftIO $ getCPUTime
-                  liftIO $ printTimes (fromIntegral (allocs2 - allocs1))
+                  dflags  <- getDynFlags
+                  liftIO $ printTimes dflags (fromIntegral (allocs2 - allocs1))
                                   (time2 - time1)
                   return a
 
 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
         -- defined in ghc/rts/Stats.c
 
-printTimes :: Integer -> Integer -> IO ()
-printTimes allocs psecs
+printTimes :: DynFlags -> Integer -> Integer -> IO ()
+printTimes dflags allocs psecs
    = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
             secs_str = showFFloat (Just 2) secs
-        putStrLn (showSDoc (
+        putStrLn (showSDoc dflags (
                  parens (text (secs_str "") <+> text "secs" <> comma <+>
                          text (show allocs) <+> text "bytes")))
 
index a57d8e7..2cc6f91 100644 (file)
@@ -595,7 +595,8 @@ mkPrompt = do
         f [] = empty
 
   st <- getGHCiState
-  return (showSDoc (f (prompt st)))
+  dflags <- getDynFlags
+  return (showSDoc dflags (f (prompt st)))
 
 
 queryQueue :: GHCi (Maybe String)
@@ -1174,7 +1175,8 @@ checkModule m = do
   let modl = GHC.mkModuleName m
   ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
           r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
-          liftIO $ putStrLn $ showSDoc $
+          dflags <- getDynFlags
+          liftIO $ putStrLn $ showSDoc dflags $
            case GHC.moduleInfo r of
              cm | Just scope <- GHC.modInfoTopLevelScope cm ->
                 let
@@ -1343,9 +1345,9 @@ modulesLoadedMsg ok mods = do
             punctuate comma (map ppr mods)) <> text "."
    case ok of
     Failed ->
-       liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas)
+       liftIO $ putStrLn $ showSDoc dflags (text "Failed, modules loaded: " <> mod_commas)
     Succeeded  ->
-       liftIO $ putStrLn $ showSDoc (text "Ok, modules loaded: " <> mod_commas)
+       liftIO $ putStrLn $ showSDoc dflags (text "Ok, modules loaded: " <> mod_commas)
 
 
 -----------------------------------------------------------------------------
@@ -1860,8 +1862,9 @@ setiCmd str  =
 showOptions :: Bool -> GHCi ()
 showOptions show_all
   = do st <- getGHCiState
+       dflags <- getDynFlags
        let opts = options st
-       liftIO $ putStrLn (showSDoc (
+       liftIO $ putStrLn (showSDoc dflags (
               text "options currently set: " <>
               if null opts
                    then text "none."
@@ -1873,13 +1876,13 @@ showOptions show_all
 showDynFlags :: Bool -> DynFlags -> IO ()
 showDynFlags show_all dflags = do
   showLanguages' show_all dflags
-  putStrLn $ showSDoc $
+  putStrLn $ showSDoc dflags $
      text "GHCi-specific dynamic flag settings:" $$
          nest 2 (vcat (map (setting dopt) ghciFlags))
-  putStrLn $ showSDoc $
+  putStrLn $ showSDoc dflags $
      text "other dynamic, non-language, flag settings:" $$
          nest 2 (vcat (map (setting dopt) others))
-  putStrLn $ showSDoc $
+  putStrLn $ showSDoc dflags $
      text "warning settings:" $$
          nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))
   where
@@ -2101,12 +2104,13 @@ showiCmd str = do
 showImports :: GHCi ()
 showImports = do
   st <- getGHCiState
+  dflags <- getDynFlags
   let rem_ctx   = reverse (remembered_ctx st)
       trans_ctx = transient_ctx st
 
       show_one (IIModule star_m)
           = ":module +*" ++ moduleNameString star_m
-      show_one (IIDecl imp) = showSDoc (ppr imp)
+      show_one (IIDecl imp) = showPpr dflags imp
 
       prel_imp
         | any isPreludeImport (rem_ctx ++ trans_ctx) = []
@@ -2176,8 +2180,9 @@ showContext = do
 
 showPackages :: GHCi ()
 showPackages = do
-  pkg_flags <- fmap packageFlags getDynFlags
-  liftIO $ putStrLn $ showSDoc $ vcat $
+  dflags <- getDynFlags
+  let pkg_flags = packageFlags dflags
+  liftIO $ putStrLn $ showSDoc dflags $ vcat $
     text ("active package flags:"++if null pkg_flags then " none" else "")
     : map showFlag pkg_flags
   where showFlag (ExposePackage   p) = text $ "  -package " ++ p
@@ -2195,7 +2200,7 @@ showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
 
 showLanguages' :: Bool -> DynFlags -> IO ()
 showLanguages' show_all dflags =
-  putStrLn $ showSDoc $ vcat
+  putStrLn $ showSDoc dflags $ vcat
      [ text "base language is: " <>
          case language dflags of
            Nothing          -> text "Haskell2010"
@@ -2260,26 +2265,27 @@ completeMacro = wrapIdentCompleter $ \w -> do
 
 completeIdentifier = wrapIdentCompleter $ \w -> do
   rdrs <- GHC.getRdrNamesInScope
-  return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
+  dflags <- GHC.getSessionDynFlags
+  return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
 
 completeModule = wrapIdentCompleter $ \w -> do
   dflags <- GHC.getSessionDynFlags
   let pkg_mods = allExposedModules dflags
   loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
   return $ filter (w `isPrefixOf`)
-        $ map (showSDoc.ppr) $ loaded_mods ++ pkg_mods
+        $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
 
 completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
+  dflags <- GHC.getSessionDynFlags
   modules <- case m of
     Just '-' -> do
       imports <- GHC.getContext
       return $ map iiModuleName imports
     _ -> do
-      dflags <- GHC.getSessionDynFlags
       let pkg_mods = allExposedModules dflags
       loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
       return $ loaded_mods ++ pkg_mods
-  return $ filter (w `isPrefixOf`) $ map (showSDoc.ppr) modules
+  return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
 
 completeHomeModule = wrapIdentCompleter listHomeModules
 
@@ -2287,8 +2293,9 @@ listHomeModules :: String -> GHCi [String]
 listHomeModules w = do
     g <- GHC.getModuleGraph
     let home_mods = map GHC.ms_mod_name g
+    dflags <- getDynFlags
     return $ sort $ filter (w `isPrefixOf`)
-            $ map (showSDoc.ppr) home_mods
+            $ map (showPpr dflags) home_mods
 
 completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
   return (filter (w `isPrefixOf`) opts)
index 6163090..1f6fb6c 100644 (file)
@@ -770,7 +770,7 @@ abiHash strs = do
          r <- findImportedModule hsc_env modname Nothing
          case r of
            Found _ m -> return m
-           _error    -> ghcError $ CmdLineError $ showSDoc $
+           _error    -> ghcError $ CmdLineError $ showSDoc dflags $
                           cannotFindInterface dflags modname r
 
   mods <- mapM find_it (map fst strs)
@@ -785,7 +785,7 @@ abiHash strs = do
   mapM_ (put_ bh . mi_mod_hash) ifaces
   f <- fingerprintBinMem bh
 
-  putStrLn (showSDoc (ppr f))
+  putStrLn (showPpr dflags f)
 
 -- -----------------------------------------------------------------------------
 -- Util