Fix ghc<7.10
This commit is contained in:
parent
acf78f2500
commit
ce1d9d1da1
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
module Language.Haskell.GhcMod.DebugLogger where
|
module Language.Haskell.GhcMod.DebugLogger where
|
||||||
|
|
||||||
|
|
||||||
@ -7,28 +8,46 @@ import Pretty
|
|||||||
import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine)
|
import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine)
|
||||||
import qualified Outputable
|
import qualified Outputable
|
||||||
import ErrUtils
|
import ErrUtils
|
||||||
import DynFlags (LogAction)
|
|
||||||
|
|
||||||
import Language.Haskell.GhcMod.Error
|
import Language.Haskell.GhcMod.Error
|
||||||
|
import Language.Haskell.GhcMod.Gap
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
debugLogAction :: (String -> IO ()) -> LogAction
|
debugLogAction :: (String -> IO ()) -> GmLogAction
|
||||||
debugLogAction putErr dflags severity srcSpan style msg
|
debugLogAction putErr dflags severity srcSpan style msg
|
||||||
= case severity of
|
= case severity of
|
||||||
SevOutput -> printSDoc msg style
|
SevOutput -> printSDoc putErr msg style
|
||||||
SevDump -> printSDoc (msg Outputable.$$ blankLine) style
|
|
||||||
SevInteractive -> putStrSDoc msg style
|
#if __GLASGOW_HASKELL__ >= 706
|
||||||
SevInfo -> printErrs msg style
|
SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style
|
||||||
SevFatal -> printErrs msg 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"
|
_ -> 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,
|
-- careful (#2302): printErrs prints in UTF-8,
|
||||||
-- whereas converting to string first and using
|
-- whereas converting to string first and using
|
||||||
-- hPutStr would just emit the low 8 bits of
|
-- hPutStr would just emit the low 8 bits of
|
||||||
-- each unicode char.
|
-- each unicode char.
|
||||||
where printSDoc = debugLogActionHPrintDoc dflags putErr
|
where
|
||||||
printErrs = debugLogActionHPrintDoc dflags putErr
|
#if __GLASGOW_HASKELL__ >= 706
|
||||||
putStrSDoc = debugLogActionHPutStrDoc dflags putErr
|
printSDoc put = debugLogActionHPrintDoc dflags put
|
||||||
|
printErrs put = debugLogActionHPrintDoc dflags put
|
||||||
|
#endif
|
||||||
|
|
||||||
|
|
||||||
|
#if __GLASGOW_HASKELL__ >= 706
|
||||||
|
|
||||||
debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()
|
debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()
|
||||||
debugLogActionHPrintDoc dflags put d sty
|
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
|
-- calls to this log-action can output all on the same line
|
||||||
doc = runSDoc d (initSDocContext dflags sty)
|
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 ()
|
gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()
|
||||||
-- printDoc adds a newline to the end
|
-- printDoc adds a newline to the end
|
||||||
@ -54,7 +82,9 @@ gmPrintDoc_ mode pprCols putS doc
|
|||||||
put (Chr c) next = putS [c] >> next
|
put (Chr c) next = putS [c] >> next
|
||||||
put (Str s) next = putS s >> next
|
put (Str s) next = putS s >> next
|
||||||
put (PStr s) next = putS (unpackFS s) >> next
|
put (PStr s) next = putS (unpackFS s) >> next
|
||||||
|
#if __GLASGOW_HASKELL__ >= 708
|
||||||
put (ZStr s) next = putS (zString s) >> next
|
put (ZStr s) next = putS (zString s) >> next
|
||||||
|
#endif
|
||||||
put (LStr s _l) next = putS (unpackLitString s) >> next
|
put (LStr s _l) next = putS (unpackLitString s) >> next
|
||||||
|
|
||||||
done = return () -- hPutChar hdl '\n'
|
done = return () -- hPutChar hdl '\n'
|
||||||
|
@ -4,6 +4,7 @@ module Language.Haskell.GhcMod.Gap (
|
|||||||
Language.Haskell.GhcMod.Gap.ClsInst
|
Language.Haskell.GhcMod.Gap.ClsInst
|
||||||
, mkTarget
|
, mkTarget
|
||||||
, withStyle
|
, withStyle
|
||||||
|
, GmLogAction
|
||||||
, setLogAction
|
, setLogAction
|
||||||
, getSrcSpan
|
, getSrcSpan
|
||||||
, getSrcFile
|
, getSrcFile
|
||||||
@ -135,9 +136,13 @@ withStyle = withPprStyleDoc
|
|||||||
withStyle _ = withPprStyleDoc
|
withStyle _ = withPprStyleDoc
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
setLogAction :: DynFlags
|
#if __GLASGOW_HASKELL__ >= 706
|
||||||
-> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ())
|
type GmLogAction = LogAction
|
||||||
-> DynFlags
|
#else
|
||||||
|
type GmLogAction = DynFlags -> LogAction
|
||||||
|
#endif
|
||||||
|
|
||||||
|
setLogAction :: DynFlags -> GmLogAction -> DynFlags
|
||||||
setLogAction df f =
|
setLogAction df f =
|
||||||
#if __GLASGOW_HASKELL__ >= 706
|
#if __GLASGOW_HASKELL__ >= 706
|
||||||
df { log_action = f }
|
df { log_action = f }
|
||||||
|
Loading…
Reference in New Issue
Block a user