ghc-mod/Language/Haskell/GhcMod/DebugLogger.hs
2015-09-08 06:19:58 +02:00

63 lines
2.5 KiB
Haskell

module Language.Haskell.GhcMod.DebugLogger where
import GHC
import FastString
import Pretty
import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine)
import qualified Outputable
import ErrUtils
import DynFlags (LogAction)
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Output
import Language.Haskell.GhcMod.Monad.Types
import Prelude
debugLogAction :: (String -> IO ()) -> LogAction
debugLogAction putErr dflags severity srcSpan style msg
= case severity of
SevOutput -> printSDoc msg style
SevDump -> printSDoc (msg Outputable.$$ blankLine) style
SevInteractive -> putStrSDoc msg style
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do putErr "\n"
printErrs (mkLocMessage severity srcSpan msg) style
-- careful (#2302): printErrs prints in UTF-8,
-- whereas converting to string first and using
-- hPutStr would just emit the low 8 bits of
-- each unicode char.
where printSDoc = debugLogActionHPrintDoc dflags putErr
printErrs = debugLogActionHPrintDoc dflags putErr
putStrSDoc = debugLogActionHPutStrDoc dflags putErr
debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()
debugLogActionHPrintDoc dflags put d sty
= debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty
-- Adds a newline
debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()
debugLogActionHPutStrDoc dflags put d sty
= gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc
where -- Don't add a newline at the end, so that successive
-- calls to this log-action can output all on the same line
doc = runSDoc d (initSDocContext dflags sty)
gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()
-- printDoc adds a newline to the end
gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "")
gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()
gmPrintDoc_ mode pprCols putS doc
= fullRender mode pprCols 1.5 put done doc
where
put (Chr c) next = putS [c] >> next
put (Str s) next = putS s >> next
put (PStr s) next = putS (unpackFS s) >> next
put (ZStr s) next = putS (zString s) >> next
put (LStr s _l) next = putS (unpackLitString s) >> next
done = return () -- hPutChar hdl '\n'