ghc-mod/ErrMsg.hs

70 lines
2.0 KiB
Haskell
Raw Normal View History

2011-08-24 07:50:26 +00:00
module ErrMsg (
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
2012-02-14 07:09:53 +00:00
import qualified Gap
2011-08-24 07:50:26 +00:00
import HscTypes
import Outputable
----------------------------------------------------------------
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 stl msg = modifyIORef ref (\ls -> ppMsg src sev msg stl : ls)
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
handleErrMsg :: SourceError -> Ghc [String]
handleErrMsg = return . errBagToStrList . srcErrorMessages
errBagToStrList :: Bag ErrMsg -> [String]
errBagToStrList = map ppErrMsg . reverse . bagToList
----------------------------------------------------------------
ppErrMsg :: ErrMsg -> String
ppErrMsg err = ppMsg spn SevError msg defaultUserStyle ++ ext
2011-08-24 07:50:26 +00:00
where
spn = head (errMsgSpans err)
msg = errMsgShortDoc err
2012-02-08 07:57:24 +00:00
ext = showMsg (errMsgExtraInfo err) defaultUserStyle
2011-08-24 07:50:26 +00:00
ppMsg :: SrcSpan -> Severity-> SDoc -> PprStyle -> String
ppMsg spn sev msg stl = fromMaybe def $ do
2012-02-14 07:09:53 +00:00
(line,col,_,_) <- Gap.getSrcSpan spn
file <- Gap.getSrcFile spn
let severityCaption = Gap.showSeverityCaption sev
return $ file ++ ":" ++ show line ++ ":"
++ show col ++ ":" ++ severityCaption ++ cts ++ "\0"
2011-08-24 07:50:26 +00:00
where
2012-02-14 07:09:53 +00:00
def = "ghc-mod:0:0:Probably mutual module import occurred\0"
2012-02-08 07:57:24 +00:00
cts = showMsg msg stl
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2012-02-08 07:57:24 +00:00
showMsg :: SDoc -> PprStyle -> String
2012-02-14 07:09:53 +00:00
showMsg d stl = map toNull $ Gap.renderMsg d stl
2011-08-24 07:50:26 +00:00
where
toNull '\n' = '\0'
toNull x = x