Fix ghc<7.10

This commit is contained in:
Daniel Gröber 2015-09-11 04:13:44 +02:00
parent acf78f2500
commit ce1d9d1da1
2 changed files with 49 additions and 14 deletions

View File

@ -1,3 +1,4 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.DebugLogger where
@ -7,28 +8,46 @@ 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.Gap
import Prelude
debugLogAction :: (String -> IO ()) -> LogAction
debugLogAction :: (String -> IO ()) -> GmLogAction
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
SevOutput -> printSDoc putErr msg style
#if __GLASGOW_HASKELL__ >= 706
SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style
#endif
#if __GLASGOW_HASKELL__ >= 708
SevInteractive -> let
putStrSDoc = debugLogActionHPutStrDoc dflags putErr
in
putStrSDoc msg style
#endif
SevInfo -> printErrs putErr msg style
SevFatal -> printErrs putErr msg style
_ -> do putErr "\n"
printErrs (mkLocMessage severity srcSpan msg) style
#if __GLASGOW_HASKELL__ >= 706
printErrs putErr (mkLocMessage severity srcSpan msg) style
#else
printErrs putErr (mkLocMessage srcSpan msg) style
#endif
-- 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
where
#if __GLASGOW_HASKELL__ >= 706
printSDoc put = debugLogActionHPrintDoc dflags put
printErrs put = debugLogActionHPrintDoc dflags put
#endif
#if __GLASGOW_HASKELL__ >= 706
debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()
debugLogActionHPrintDoc dflags put d sty
@ -42,6 +61,15 @@ debugLogActionHPutStrDoc dflags put d sty
-- calls to this log-action can output all on the same line
doc = runSDoc d (initSDocContext dflags sty)
#else
printSDoc = printErrs
printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO ()
printErrs put doc sty = do
gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty))
#endif
gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()
-- printDoc adds a newline to the end
@ -54,7 +82,9 @@ gmPrintDoc_ mode pprCols putS doc
put (Chr c) next = putS [c] >> next
put (Str s) next = putS s >> next
put (PStr s) next = putS (unpackFS s) >> next
#if __GLASGOW_HASKELL__ >= 708
put (ZStr s) next = putS (zString s) >> next
#endif
put (LStr s _l) next = putS (unpackLitString s) >> next
done = return () -- hPutChar hdl '\n'

View File

@ -4,6 +4,7 @@ module Language.Haskell.GhcMod.Gap (
Language.Haskell.GhcMod.Gap.ClsInst
, mkTarget
, withStyle
, GmLogAction
, setLogAction
, getSrcSpan
, getSrcFile
@ -135,9 +136,13 @@ withStyle = withPprStyleDoc
withStyle _ = withPprStyleDoc
#endif
setLogAction :: DynFlags
-> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ())
-> DynFlags
#if __GLASGOW_HASKELL__ >= 706
type GmLogAction = LogAction
#else
type GmLogAction = DynFlags -> LogAction
#endif
setLogAction :: DynFlags -> GmLogAction -> DynFlags
setLogAction df f =
#if __GLASGOW_HASKELL__ >= 706
df { log_action = f }