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
|
2013-03-13 01:54:50 +00:00
|
|
|
import Doc
|
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
|
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
|
2012-10-16 10:27:35 +00:00
|
|
|
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
|
2011-08-24 07:50:26 +00:00
|
|
|
setLogger True df = do
|
|
|
|
ref <- newIORef [] :: IO (IORef [String])
|
2012-10-16 10:27:35 +00:00
|
|
|
let newdf = Gap.setLogAction df $ appendLog ref
|
2011-08-24 07:50:26 +00:00
|
|
|
return (newdf, reverse <$> readIORef ref)
|
|
|
|
where
|
2013-03-13 01:54:50 +00:00
|
|
|
appendLog ref _ sev src _ msg = modifyIORef ref (\ls -> ppMsg src sev df msg : 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 = fromMaybe def $ do
|
2012-02-14 07:09:53 +00:00
|
|
|
(line,col,_,_) <- Gap.getSrcSpan spn
|
2013-03-05 06:18:57 +00:00
|
|
|
file <- normalise <$> Gap.getSrcFile spn
|
2012-10-19 19:19:37 +00:00
|
|
|
let severityCaption = Gap.showSeverityCaption sev
|
|
|
|
return $ file ++ ":" ++ show line ++ ":"
|
2013-03-05 06:18:57 +00:00
|
|
|
++ 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"
|
2013-03-13 01:54:50 +00:00
|
|
|
cts = showMsg dflag msg
|
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 $ showQualifiedPage dflag sdoc
|
2011-08-24 07:50:26 +00:00
|
|
|
where
|
|
|
|
toNull '\n' = '\0'
|
|
|
|
toNull x = x
|