Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : sdoc
http://hackage.haskell.org/trac/ghc/changeset/f8e5710d8dec8a33f5877da7b753fbfca2803fd4 >--------------------------------------------------------------- commit f8e5710d8dec8a33f5877da7b753fbfca2803fd4 Author: Ian Lynagh <[email protected]> Date: Wed May 25 15:00:08 2011 +0100 Start passing DynFlags around inside SDoc >--------------------------------------------------------------- compiler/iface/BinIface.hs | 2 +- compiler/main/DynFlags.hs | 6 +++--- compiler/main/DynFlags.hs-boot | 5 +++++ compiler/main/ErrUtils.lhs | 16 ++++++++-------- compiler/utils/Outputable.lhs | 16 +++++++++++++--- 5 files changed, 30 insertions(+), 15 deletions(-) diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 134dcfa..f01558c 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -67,7 +67,7 @@ readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do let printer :: SDoc -> IO () printer = case traceBinIFaceReading of - TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle + TraceBinIFaceReading -> \sd -> printSDoc dflags sd defaultDumpStyle QuietBinIFaceReading -> \_ -> return () wantedGot :: Outputable a => String -> a -> a -> IO () wantedGot what wanted got diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 01e0cf8..5acc7bb 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -511,7 +511,7 @@ data DynFlags = DynFlags { extensionFlags :: [ExtensionFlag], -- | Message output action: use "ErrUtils" instead of this if you can - log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (), + log_action :: DynFlags -> Severity -> SrcSpan -> PprStyle -> Message -> IO (), haddockOptions :: Maybe String } @@ -826,9 +826,9 @@ defaultDynFlags mySettings = extensions = [], extensionFlags = flattenExtensionFlags Nothing [], - log_action = \severity srcSpan style msg -> + log_action = \dflags severity srcSpan style msg -> case severity of - SevOutput -> printSDoc msg style + SevOutput -> printSDoc dflags msg style SevInfo -> printErrs msg style SevFatal -> printErrs msg style _ -> do diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot new file mode 100644 index 0000000..4c2081f --- /dev/null +++ b/compiler/main/DynFlags.hs-boot @@ -0,0 +1,5 @@ + +module DynFlags (DynFlags) where + +data DynFlags + diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 1c7a389..8cc8e62 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -145,7 +145,7 @@ printBagOfWarnings dflags bag_of_warns = printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO () printMsgBag dflags bag sev = sequence_ [ let style = mkErrStyle unqual - in log_action dflags sev s style (d $$ e) + in log_action dflags dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgExtraInfo = e, @@ -284,30 +284,30 @@ ifVerbose dflags val act | otherwise = return () putMsg :: DynFlags -> Message -> IO () -putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg +putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO () putMsgWith dflags print_unqual msg - = log_action dflags SevInfo noSrcSpan sty msg + = log_action dflags dflags SevInfo noSrcSpan sty msg where sty = mkUserStyle print_unqual AllTheWay errorMsg :: DynFlags -> Message -> IO () -errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg +errorMsg dflags msg = log_action dflags dflags SevError noSrcSpan defaultErrStyle msg fatalErrorMsg :: DynFlags -> Message -> IO () -fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg +fatalErrorMsg dflags msg = log_action dflags dflags SevFatal noSrcSpan defaultErrStyle msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg - = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg)) + = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg)) showPass :: DynFlags -> String -> IO () showPass dflags what - = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) + = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) debugTraceMsg :: DynFlags -> Int -> Message -> IO () debugTraceMsg dflags val msg - = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) + = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg) \end{code} diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index fc4d919..5dd521a 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -70,6 +70,7 @@ module Outputable ( import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) +import {-# SOURCE #-} DynFlags (DynFlags) import StaticFlags import FastString @@ -228,12 +229,21 @@ data SDocContext = SDC { sdocStyle :: !PprStyle , sdocLastColour :: !PprColour -- ^ The most recently used colour. This allows nesting colours. + , sdocDynFlags :: DynFlags -- XXX Strictness? } initSDocContext :: PprStyle -> SDocContext initSDocContext sty = SDC { sdocStyle = sty , sdocLastColour = colReset + , sdocDynFlags = error "XXX" + } + +initSDocContext' :: DynFlags -> PprStyle -> SDocContext +initSDocContext' dflags sty = SDC + { sdocStyle = sty + , sdocLastColour = colReset + , sdocDynFlags = dflags } withPprStyle :: PprStyle -> SDoc -> SDoc @@ -311,9 +321,9 @@ ifPprDebug d = SDoc $ \ctx -> case ctx of \begin{code} -- Unused [7/02 sof] -printSDoc :: SDoc -> PprStyle -> IO () -printSDoc d sty = do - Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty)) +printSDoc :: DynFlags -> SDoc -> PprStyle -> IO () +printSDoc dflags d sty = do + Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext' dflags sty)) hFlush stdout -- I'm not sure whether the direct-IO approach of Pretty.printDoc _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
