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

233 lines
8.9 KiB
Haskell
Raw Normal View History

2014-07-17 08:16:44 +00:00
{-# LANGUAGE CPP #-}
2014-04-28 12:47:08 +00:00
module Language.Haskell.GhcMod.Logger (
2014-04-28 12:41:29 +00:00
withLogger
, withLoggerTwice
2014-04-25 02:08:29 +00:00
, checkErrorPrefix
2011-08-24 07:50:26 +00:00
) where
2014-08-15 07:32:28 +00:00
import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags)
import Control.Applicative ((<$>))
2014-03-27 06:32:44 +00:00
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
2014-08-15 07:41:02 +00:00
import Data.List (isPrefixOf, find, nub, isInfixOf)
import Data.Maybe (fromMaybe, isJust)
import ErrUtils (ErrMsg, WarnMsg, errMsgShortDoc, errMsgExtraInfo, mkWarnMsg)
2014-04-28 04:52:28 +00:00
import Exception (ghandle)
2014-05-14 16:05:40 +00:00
import GHC (DynFlags, SrcSpan, Severity(SevError))
2014-03-27 06:32:44 +00:00
import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages)
import Language.Haskell.GhcMod.Doc (showPage, getStyle)
import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)
2013-05-17 01:00:01 +00:00
import qualified Language.Haskell.GhcMod.Gap as Gap
2014-05-14 16:05:40 +00:00
import Language.Haskell.GhcMod.Convert (convert')
import Language.Haskell.GhcMod.Monad
2014-07-17 05:30:42 +00:00
import Language.Haskell.GhcMod.Types
import Outputable (PprStyle, SDoc, qualName, qualModule, mkErrStyle, neverQualify)
2013-03-05 06:18:57 +00:00
import System.FilePath (normalise)
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 :: IOish m => LogRef -> GhcModT m String
2014-05-14 16:05:40 +00:00
readAndClearLogRef (LogRef ref) = do
Log _ b <- liftIO $ readIORef ref
liftIO $ writeIORef ref emptyLog
2014-05-14 16:05:40 +00:00
convert' (b [])
2014-03-18 03:38:04 +00:00
appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update
where
l = ppMsg src sev df style 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-08-15 07:32:28 +00:00
data LogBag = LogBag (Bag WarnMsg)
newtype LogBagRef = LogBagRef (IORef LogBag)
emptyLogBag :: LogBag
emptyLogBag = LogBag emptyBag
newLogBagRef :: IO LogBagRef
newLogBagRef = LogBagRef <$> newIORef emptyLogBag
readAndClearLogBagRef :: IOish m => LogBagRef -> GhcModT m (Bag WarnMsg)
readAndClearLogBagRef (LogBagRef ref) = do
LogBag b <- liftIO $ readIORef ref
liftIO $ writeIORef ref emptyLogBag
return b
appendLogBagRef :: DynFlags -> LogBagRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
2014-08-18 06:24:38 +00:00
appendLogBagRef df (LogBagRef ref) _ _ src style msg = modifyIORef ref update
2014-08-15 07:32:28 +00:00
where
qstyle = (qualName style, qualModule style)
2014-08-15 08:46:52 +00:00
#if __GLASGOW_HASKELL__ >= 706
warnMsg = mkWarnMsg df src qstyle msg
2014-08-15 08:46:52 +00:00
#else
warnMsg = mkWarnMsg src qstyle msg
#endif
2014-08-15 07:32:28 +00:00
warnBag = consBag warnMsg emptyBag
2014-08-18 06:24:38 +00:00
update (LogBag b) = let (b1,b2) = mergeErrors df style b warnBag
in LogBag $ b1 `unionBags` b2
2014-08-15 07:32:28 +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 :: IOish m
=> (DynFlags -> DynFlags)
-> GhcModT m ()
-> GhcModT m (Either String String)
2014-05-14 16:05:40 +00:00
withLogger setDF body = ghandle sourceError $ do
2014-07-17 08:16:44 +00:00
logref <- liftIO newLogRef
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
2014-07-17 08:16:44 +00:00
withDynFlags (setLogger logref . setDF) $
withCmdFlags wflags $ do
body
Right <$> readAndClearLogRef logref
2014-04-28 03:52:09 +00:00
where
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
2014-05-14 16:05:40 +00:00
withLoggerTwice :: IOish m
=> (DynFlags -> DynFlags)
-> GhcModT m ()
-> (DynFlags -> DynFlags)
-> GhcModT m ()
-> GhcModT m (Either String String)
withLoggerTwice setDF1 body1 setDF2 body2 = do
err1 <- ghandle sourceErrorBag $ do
2014-08-15 07:32:28 +00:00
logref <- liftIO newLogBagRef
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
withDynFlags (setLogger logref . setDF1) $
withCmdFlags wflags $ do
body1
2014-08-15 07:32:28 +00:00
Right <$> readAndClearLogBagRef logref
err2 <- ghandle sourceErrorBag $ do
2014-08-15 07:32:28 +00:00
logref <- liftIO newLogBagRef
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
withDynFlags (setLogger logref . setDF2) $
withCmdFlags wflags $ do
body2
2014-08-15 07:32:28 +00:00
Right <$> readAndClearLogBagRef logref
-- Merge errors and warnings
dflags <- G.getSessionDynFlags
style <- getStyle
case (err1, err2) of
2014-08-18 06:24:38 +00:00
(Right b1, Right b2) -> do let (warn1,_) = mergeErrors dflags style b1 b2
2014-08-15 07:32:28 +00:00
errAndWarnBagToStr Right emptyBag (warn1 `unionBags` b2)
(Left b1, Right b2) -> do let (err,warn) = mergeErrors dflags style b1 b2
errAndWarnBagToStr Right err warn
(Right b1, Left b2) -> do let (err,warn) = mergeErrors dflags style b2 b1
errAndWarnBagToStr Right err warn
(Left b1, Left b2) -> do let (err1',err2') = mergeErrors dflags style b1 b2
errAndWarnBagToStr Right (err1' `unionBags` err2') emptyBag
where
2014-08-15 07:32:28 +00:00
setLogger logref df = Gap.setLogAction df $ appendLogBagRef df logref
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2014-03-26 03:09:02 +00:00
-- | Converting 'SourceError' to 'String'.
sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
sourceError err = errBagToStr (srcErrorMessages err)
errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)
2014-08-15 07:32:28 +00:00
errBagToStr = errBagToStr' Left
errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a
errBagToStr' f err = do
2014-05-14 16:05:40 +00:00
dflags <- G.getSessionDynFlags
style <- getStyle
ret <- convert' (errBagToStrList dflags style err)
2014-08-15 07:32:28 +00:00
return $ f ret
errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a
errAndWarnBagToStr f err warn = do
dflags <- G.getSessionDynFlags
-- style <- toGhcModT getStyle
2014-08-15 09:00:48 +00:00
#if __GLASGOW_HASKELL__ >= 706
let style = mkErrStyle dflags neverQualify
2014-08-15 09:00:48 +00:00
#else
let style = mkErrStyle neverQualify
#endif
2014-08-15 07:32:28 +00:00
ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn)
return $ f ret
2011-08-24 07:50:26 +00:00
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
2011-08-24 07:50:26 +00:00
2014-08-15 07:32:28 +00:00
warnBagToStrList :: DynFlags -> PprStyle -> Bag WarnMsg -> [String]
warnBagToStrList dflag style = map (ppWarnMsg dflag style) . reverse . bagToList
sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) (Bag WarnMsg))
sourceErrorBag err = return $ Left (srcErrorMessages err)
2014-08-15 07:32:28 +00:00
mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> (Bag ErrMsg, Bag ErrMsg)
mergeErrors dflag style b1 b2 =
2014-08-15 07:41:02 +00:00
let b1Msgs = map (\err1 -> let m = ppWarnMsg dflag style err1 in (m, head $ lines m))
(bagToList b1)
mustBeB2 = \err2 -> let msg2 = ppWarnMsg dflag style err2
line2 = head $ lines msg2
in not . isJust $ find (\(msg1, line1) -> msg1 == msg2 || (line1 == line2 && isHoleMsg line1)) b1Msgs
2014-08-15 07:32:28 +00:00
in (b1, filterBag mustBeB2 b2)
2014-08-15 07:41:02 +00:00
isHoleMsg :: String -> Bool
isHoleMsg = isInfixOf "Found hole"
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
2014-08-15 07:32:28 +00:00
ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext then "" else "\n" ++ ext)
where
spn = Gap.errorMsgSpan err
msg = errMsgShortDoc err
ext = showPage dflag style (errMsgExtraInfo err)
ppWarnMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppWarnMsg dflag style err = ppMsg spn G.SevWarning dflag style msg ++ (if null ext then "" else "\n" ++ ext)
2011-08-24 07:50:26 +00:00
where
2013-11-19 03:28:59 +00:00
spn = Gap.errorMsgSpan err
2013-11-13 00:10:25 +00:00
msg = errMsgShortDoc err
2014-04-21 07:12:30 +00:00
ext = showPage dflag style (errMsgExtraInfo err)
2011-08-24 07:50:26 +00:00
ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
ppMsg spn sev dflag style msg = prefix ++ cts
2011-08-24 07:50:26 +00:00
where
2014-04-21 07:12:30 +00:00
cts = showPage dflag style msg
prefix = ppMsgPrefix spn sev dflag style cts
ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String
ppMsgPrefix spn sev dflag _style 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"]