ghc-mod/Language/Haskell/GhcMod/ErrMsg.hs

79 lines
2.3 KiB
Haskell
Raw Normal View History

{-# LANGUAGE BangPatterns #-}
2013-05-17 01:00:01 +00:00
module Language.Haskell.GhcMod.ErrMsg (
2011-08-24 07:50:26 +00:00
LogReader
, setLogger
, handleErrMsg
) where
import Bag
import Control.Applicative
import Data.IORef
2012-02-14 07:09:53 +00:00
import Data.Maybe
2011-08-24 07:50:26 +00:00
import DynFlags
import ErrUtils
import GHC
import HscTypes
2013-05-17 01:00:01 +00:00
import qualified Language.Haskell.GhcMod.Gap as Gap
2011-08-24 07:50:26 +00:00
import Outputable
2013-03-05 06:18:57 +00:00
import System.FilePath (normalise)
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
type LogReader = IO [String]
----------------------------------------------------------------
setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)
setLogger False df = return (newdf, undefined)
where
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
2011-08-24 07:50:26 +00:00
setLogger True df = do
ref <- newIORef [] :: IO (IORef [String])
let newdf = Gap.setLogAction df $ appendLog ref
2011-08-24 07:50:26 +00:00
return (newdf, reverse <$> readIORef ref)
where
appendLog ref _ sev src _ msg = do
let !l = ppMsg src sev df msg
modifyIORef ref (\ls -> l : ls)
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
handleErrMsg :: SourceError -> Ghc [String]
2013-03-13 01:54:50 +00:00
handleErrMsg err = do
dflag <- getSessionDynFlags
return . errBagToStrList dflag . srcErrorMessages $ err
2011-08-24 07:50:26 +00:00
2013-03-13 01:54:50 +00:00
errBagToStrList :: DynFlags -> Bag ErrMsg -> [String]
errBagToStrList dflag = map (ppErrMsg dflag) . reverse . bagToList
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2013-03-13 01:54:50 +00:00
ppErrMsg :: DynFlags -> ErrMsg -> String
ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext
2011-08-24 07:50:26 +00:00
where
spn = head (errMsgSpans err)
msg = errMsgShortDoc err
2013-03-13 01:54:50 +00:00
ext = showMsg dflag (errMsgExtraInfo err)
2011-08-24 07:50:26 +00:00
2013-03-13 01:54:50 +00:00
ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String
ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
2011-08-24 07:50:26 +00:00
where
2013-03-13 01:54:50 +00:00
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
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2013-03-13 01:54:50 +00:00
showMsg :: DynFlags -> SDoc -> String
showMsg dflag sdoc = map toNull $ Gap.showUnqualifiedPage dflag sdoc
2011-08-24 07:50:26 +00:00
where
toNull '\n' = '\0'
toNull x = x