Commit 330f1541 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Add DynFlags to the SDoc state

parent a12b6bf8
......@@ -50,7 +50,7 @@ llvmCodeGen dflags h us cmms
showPass dflags "LlVM CodeGen"
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader
bufh <- newBufHandle h
Prt.bufLeftRender bufh $ withPprStyleDoc (mkCodeStyle CStyle) pprLlvmHeader
Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader
ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
-- cache llvm version for later use
writeIORef (llvmVersion dflags) ver
......@@ -76,7 +76,7 @@ cmmDataLlvmGens dflags h env [] lmdata
in do
dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc
{-# SCC "llvm_data_out" #-}
Prt.bufLeftRender h $ withPprStyleDoc (mkCodeStyle CStyle) lmdoc
Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc
return env'
cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
......@@ -100,7 +100,7 @@ cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl
cmmProcLlvmGens _ _ _ _ [] _ []
= return ()
cmmProcLlvmGens _ h _ _ [] _ ivars
cmmProcLlvmGens dflags h _ _ [] _ ivars
= let ivars' = concat ivars
cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
ty = (LMArray (length ivars') i8Ptr)
......@@ -108,7 +108,7 @@ cmmProcLlvmGens _ h _ _ [] _ ivars
lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
(Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-}
withPprStyleDoc (mkCodeStyle CStyle) $
withPprStyleDoc dflags (mkCodeStyle CStyle) $
pprLlvmData ([lmUsed], [])
cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
......@@ -121,7 +121,7 @@ cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
(us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
withPprStyleDoc (mkCodeStyle CStyle) $ vcat docs
withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs
cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
......
......@@ -991,8 +991,8 @@ defaultLogAction dflags severity srcSpan style msg
printErrs = defaultLogActionHPrintDoc dflags stderr
defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
defaultLogActionHPrintDoc _ h d sty
= do Pretty.printDoc Pretty.PageMode h (runSDoc d (initSDocContext sty))
defaultLogActionHPrintDoc dflags h d sty
= do Pretty.printDoc Pretty.PageMode h (runSDoc d (initSDocContext dflags sty))
hFlush h
newtype FlushOut = FlushOut (IO ())
......
......@@ -260,7 +260,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
-- write out the imports
Pretty.printDoc Pretty.LeftMode h
$ withPprStyleDoc (mkCodeStyle AsmStyle)
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
$ makeImportsDoc dflags (concat imports)
return ()
......@@ -301,7 +301,7 @@ cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
<- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
{-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
$ withPprStyleDoc (mkCodeStyle AsmStyle)
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
$ vcat $ map (pprNatCmmDecl ncgImpl platform) native
-- carefully evaluate this strictly. Binding it with 'let'
......
......@@ -236,19 +236,21 @@ data SDocContext = SDC
{ sdocStyle :: !PprStyle
, sdocLastColour :: !PprColour
-- ^ The most recently used colour. This allows nesting colours.
, sdocDynFlags :: DynFlags
}
initSDocContext :: PprStyle -> SDocContext
initSDocContext sty = SDC
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags sty = SDC
{ sdocStyle = sty
, sdocLastColour = colReset
, sdocDynFlags = dflags
}
withPprStyle :: PprStyle -> SDoc -> SDoc
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
withPprStyleDoc :: PprStyle -> SDoc -> Doc
withPprStyleDoc sty d = runSDoc d (initSDocContext sty)
withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
pprDeeper :: SDoc -> SDoc
pprDeeper d = SDoc $ \ctx -> case ctx of
......@@ -321,34 +323,34 @@ ifPprDebug d = SDoc $ \ctx ->
\begin{code}
hPrintDump :: DynFlags -> Handle -> SDoc -> IO ()
hPrintDump _ h doc = do
hPrintDump dflags h doc = do
Pretty.printDoc PageMode h
(runSDoc better_doc (initSDocContext defaultDumpStyle))
(runSDoc better_doc (initSDocContext dflags defaultDumpStyle))
hFlush h
where
better_doc = doc $$ blankLine
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser _ handle unqual doc
printForUser dflags handle unqual doc
= Pretty.printDoc PageMode handle
(runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
(runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
-> IO ()
printForUserPartWay _ handle d unqual doc
printForUserPartWay dflags handle d unqual doc
= Pretty.printDoc PageMode handle
(runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d))))
(runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
-- printForC, printForAsm do what they sound like
printForC :: DynFlags -> Handle -> SDoc -> IO ()
printForC _ handle doc =
printForC dflags handle doc =
Pretty.printDoc LeftMode handle
(runSDoc doc (initSDocContext (PprCode CStyle)))
(runSDoc doc (initSDocContext dflags (PprCode CStyle)))
printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
printForAsm _ handle doc =
printForAsm dflags handle doc =
Pretty.printDoc LeftMode handle
(runSDoc doc (initSDocContext (PprCode AsmStyle)))
(runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
......@@ -360,41 +362,41 @@ mkCodeStyle = PprCode
-- However, Doc *is* an instance of Show
-- showSDoc just blasts it out as a string
showSDoc :: DynFlags -> SDoc -> String
showSDoc _ d =
showSDoc dflags d =
Pretty.showDocWith PageMode
(runSDoc d (initSDocContext defaultUserStyle))
(runSDoc d (initSDocContext dflags defaultUserStyle))
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
renderWithStyle _ sdoc sty =
Pretty.render (runSDoc sdoc (initSDocContext sty))
renderWithStyle dflags sdoc sty =
Pretty.render (runSDoc sdoc (initSDocContext dflags sty))
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
showSDocOneLine :: DynFlags -> SDoc -> String
showSDocOneLine _ d
showSDocOneLine dflags d
= Pretty.showDocWith PageMode
(runSDoc d (initSDocContext defaultUserStyle))
(runSDoc d (initSDocContext dflags defaultUserStyle))
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
showSDocForUser _ unqual doc
= show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
showSDocForUser dflags unqual doc
= show (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
showSDocUnqual :: DynFlags -> SDoc -> String
-- Only used in the gruesome isOperator
showSDocUnqual _ d
= show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
showSDocUnqual dflags d
= show (runSDoc d (initSDocContext dflags (mkUserStyle neverQualify AllTheWay)))
showSDocDump :: DynFlags -> SDoc -> String
showSDocDump _ d
= Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultDumpStyle))
showSDocDump dflags d
= Pretty.showDocWith PageMode (runSDoc d (initSDocContext dflags defaultDumpStyle))
showSDocDumpOneLine :: DynFlags -> SDoc -> String
showSDocDumpOneLine _ d
= Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
showSDocDumpOneLine dflags d
= Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext dflags PprDump))
showSDocDebug :: DynFlags -> SDoc -> String
showSDocDebug _ d = show (runSDoc d (initSDocContext PprDebug))
showSDocDebug dflags d = show (runSDoc d (initSDocContext dflags PprDebug))
showPpr :: Outputable a => DynFlags -> a -> String
showPpr dflags = showSDoc dflags . ppr
......@@ -960,8 +962,8 @@ tracingDynFlags :: DynFlags
tracingDynFlags = panic "tracingDynFlags used"
pprDebugAndThen :: DynFlags -> (String -> a) -> String -> SDoc -> a
pprDebugAndThen _ cont heading pretty_msg
= cont (show (runSDoc doc (initSDocContext PprDebug)))
pprDebugAndThen dflags cont heading pretty_msg
= cont (show (runSDoc doc (initSDocContext dflags PprDebug)))
where
doc = sep [text heading, nest 4 pretty_msg]
\end{code}
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment