Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

69 lines (55 sloc) 1.955 kb
module ErrMsg (
LogReader
, setLogger
, handleErrMsg
) where
import Bag
import Control.Applicative
import Data.IORef
import Data.Maybe
import DynFlags
import ErrUtils
import GHC
import qualified Gap
import HscTypes
import Outputable
import System.FilePath
----------------------------------------------------------------
type LogReader = IO [String]
----------------------------------------------------------------
setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)
setLogger False df = return (newdf, undefined)
where
newdf = df { log_action = \_ _ _ _ -> return () }
setLogger True df = do
ref <- newIORef [] :: IO (IORef [String])
let newdf = df { log_action = appendLog ref }
return (newdf, reverse <$> readIORef ref)
where
appendLog ref _ src stl msg = modifyIORef ref (\ls -> ppMsg src msg stl : ls)
----------------------------------------------------------------
handleErrMsg :: SourceError -> Ghc [String]
handleErrMsg = return . errBagToStrList . srcErrorMessages
errBagToStrList :: Bag ErrMsg -> [String]
errBagToStrList = map ppErrMsg . reverse . bagToList
----------------------------------------------------------------
ppErrMsg :: ErrMsg -> String
ppErrMsg err = ppMsg spn msg defaultUserStyle ++ ext
where
spn = head (errMsgSpans err)
msg = errMsgShortDoc err
ext = showMsg (errMsgExtraInfo err) defaultUserStyle
ppMsg :: SrcSpan -> Message -> PprStyle -> String
ppMsg spn msg stl = fromMaybe def $ do
(line,col,_,_) <- Gap.getSrcSpan spn
file <- Gap.getSrcFile spn
return $ takeFileName file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ cts ++ "\0"
where
def = "ghc-mod:0:0:Probably mutual module import occurred\0"
cts = showMsg msg stl
----------------------------------------------------------------
showMsg :: SDoc -> PprStyle -> String
showMsg d stl = map toNull $ Gap.renderMsg d stl
where
toNull '\n' = '\0'
toNull x = x
Jump to Line
Something went wrong with that request. Please try again.