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

142 lines
4.5 KiB
Haskell
Raw Normal View History

2014-04-28 12:47:08 +00:00
module Language.Haskell.GhcMod.Logger (
2014-04-28 12:41:29 +00:00
withLogger
, withLogger'
2014-04-25 02:08:29 +00:00
, checkErrorPrefix
2015-04-02 23:15:12 +00:00
, errsToStr
2011-08-24 07:50:26 +00:00
) where
import Control.Arrow
import Control.Applicative ((<$>))
2015-01-02 23:32:32 +00:00
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import System.FilePath (normalise)
import Text.PrettyPrint
2015-01-02 23:32:32 +00:00
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
2014-05-14 16:05:40 +00:00
import GHC (DynFlags, SrcSpan, Severity(SevError))
import HscTypes
import Outputable
2014-03-27 06:32:44 +00:00
import qualified GHC as G
2015-04-11 14:40:27 +00:00
import Bag
2011-08-24 07:50:26 +00:00
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Doc (showPage)
import Language.Haskell.GhcMod.DynFlags (withDynFlags)
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Error
import qualified Language.Haskell.GhcMod.Gap as Gap
2011-08-24 07:50:26 +00:00
2014-03-18 03:38:04 +00:00
type Builder = [String] -> [String]
data Log = Log [String] Builder
newtype LogRef = LogRef (IORef Log)
emptyLog :: Log
emptyLog = Log [] id
2014-03-18 03:38:04 +00:00
newLogRef :: IO LogRef
newLogRef = LogRef <$> newIORef emptyLog
2014-03-18 03:38:04 +00:00
readAndClearLogRef :: LogRef -> IO [String]
2014-05-14 16:05:40 +00:00
readAndClearLogRef (LogRef ref) = do
Log _ b <- readIORef ref
writeIORef ref emptyLog
return $ b []
2014-03-18 03:38:04 +00:00
appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update
where
l = ppMsg src sev df st msg
update lg@(Log ls b)
| l `elem` ls = lg
| otherwise = Log (l:ls) (b . (l:))
2014-03-18 03:38:04 +00:00
----------------------------------------------------------------
2014-04-28 12:51:39 +00:00
-- | Set the session flag (e.g. "-Wall" or "-w:") then
2014-05-14 16:05:40 +00:00
-- executes a body. Logged messages are returned as 'String'.
2014-04-28 12:51:39 +00:00
-- Right is success and Left is failure.
withLogger :: (GmGhc m, GmEnv m)
=> (DynFlags -> DynFlags)
-> m a
-> m (Either String (String, a))
withLogger f action = do
env <- G.getSession
opts <- options
let conv = convert opts
eres <- withLogger' env $ \setDf ->
withDynFlags (f . setDf) action
return $ either (Left . conv) (Right . first conv) eres
withLogger' :: IOish m
=> HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
withLogger' env action = do
logref <- liftIO $ newLogRef
let dflags = hsc_dflags env
pu = icPrintUnqual dflags (hsc_IC env)
st = mkUserStyle pu AllTheWay
fn df = setLogger logref df
a <- gcatches (Right <$> action fn) (handlers dflags st)
ls <- liftIO $ readAndClearLogRef logref
return $ ((,) ls <$> a)
2014-04-28 03:52:09 +00:00
where
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
handlers df st = [
GHandler $ \ex -> return $ Left $ sourceError df st ex,
GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
]
2014-05-14 16:05:40 +00:00
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2014-03-26 03:09:02 +00:00
-- | Converting 'SourceError' to 'String'.
sourceError :: DynFlags -> PprStyle -> SourceError -> [String]
2015-04-02 23:15:12 +00:00
sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err
2014-08-15 07:32:28 +00:00
2015-04-02 23:15:12 +00:00
errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String]
errsToStr df st = map (ppErrMsg df st)
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppErrMsg dflag st err =
ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext)
2014-08-15 07:32:28 +00:00
where
spn = Gap.errorMsgSpan err
msg = errMsgShortDoc err
ext = showPage dflag st (errMsgExtraInfo err)
2014-08-15 07:32:28 +00:00
ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
ppMsg spn sev dflag st msg = prefix ++ cts
2011-08-24 07:50:26 +00:00
where
cts = showPage dflag st msg
prefix = ppMsgPrefix spn sev dflag st cts
ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String
ppMsgPrefix spn sev dflag _st cts =
let defaultPrefix
| Gap.isDumpSplices dflag = ""
| otherwise = checkErrorPrefix
in fromMaybe defaultPrefix $ do
(line,col,_,_) <- Gap.getSrcSpan spn
file <- normalise <$> Gap.getSrcFile spn
let severityCaption = Gap.showSeverityCaption sev
pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
= file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
| otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
return pref0
2014-04-25 02:08:29 +00:00
checkErrorPrefix :: String
checkErrorPrefix = "Dummy:0:0:Error:"
warningAsErrorPrefixes :: [String]
warningAsErrorPrefixes = ["Couldn't match expected type"
, "Couldn't match type"
, "No instance for"]