ghc-mod/Language/Haskell/GhcMod/ErrMsg.hs
Daniil Frumin 9eb446e24b Moving all CPP stuff (that depends on GHC version) to Gap
- Moved some functions from Language.Haskell.GhcMod.Doc to Gap
- Moved HasType typeclass and some functions from Info to Gap
- Adjusted all the other modules to use necessary functions from Gap
  instead of the functions from modified modules
2013-07-02 12:48:44 +04:00

80 lines
2.4 KiB
Haskell

{-# LANGUAGE BangPatterns #-}
module Language.Haskell.GhcMod.ErrMsg (
LogReader
, setLogger
, handleErrMsg
) where
import Bag
import Control.Applicative
import Data.IORef
import Data.Maybe
import DynFlags
import ErrUtils
import GHC
import HscTypes
import Language.Haskell.GhcMod.Doc
import qualified Language.Haskell.GhcMod.Gap as Gap
import Outputable
import System.FilePath (normalise)
----------------------------------------------------------------
type LogReader = IO [String]
----------------------------------------------------------------
setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)
setLogger False df = return (newdf, undefined)
where
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
setLogger True df = do
ref <- newIORef [] :: IO (IORef [String])
let newdf = Gap.setLogAction df $ appendLog ref
return (newdf, reverse <$> readIORef ref)
where
appendLog ref _ sev src _ msg = do
let !l = ppMsg src sev df msg
modifyIORef ref (\ls -> l : ls)
----------------------------------------------------------------
handleErrMsg :: SourceError -> Ghc [String]
handleErrMsg err = do
dflag <- getSessionDynFlags
return . errBagToStrList dflag . srcErrorMessages $ err
errBagToStrList :: DynFlags -> Bag ErrMsg -> [String]
errBagToStrList dflag = map (ppErrMsg dflag) . reverse . bagToList
----------------------------------------------------------------
ppErrMsg :: DynFlags -> ErrMsg -> String
ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext
where
spn = head (errMsgSpans err)
msg = errMsgShortDoc err
ext = showMsg dflag (errMsgExtraInfo err)
ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String
ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
where
cts = showMsg dflag msg
defaultPrefix
| dopt Opt_D_dump_splices dflag = ""
| otherwise = "Dummy:0:0:"
prefix = fromMaybe defaultPrefix $ do
(line,col,_,_) <- Gap.getSrcSpan spn
file <- normalise <$> Gap.getSrcFile spn
let severityCaption = Gap.showSeverityCaption sev
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
----------------------------------------------------------------
showMsg :: DynFlags -> SDoc -> String
showMsg dflag sdoc = map toNull $ Gap.showUnqualifiedPage dflag sdoc
where
toNull '\n' = '\0'
toNull x = x