hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #321 from serras/master

Browse Source 
Obtain all warnings even in presence of typed holes
This commit is contained in:
Kazu Yamamoto 2014-08-15 16:50:00 +09:00
commit 95cda63ea0
2 changed files with 79 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Language/Haskell/GhcMod/Check.hs
View File

@ -41,7 +41,7 @@ check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
setAllWaringFlags setAllWaringFlags
(do _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags (do _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
setTargetFiles fileNames) setTargetFiles fileNames)
(setAllWaringFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles) (setAllWaringFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors)
(do _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags (do _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
setTargetFiles fileNames) setTargetFiles fileNames)

108
Language/Haskell/GhcMod/Logger.hs
View File

@ -6,12 +6,12 @@ module Language.Haskell.GhcMod.Logger (
, checkErrorPrefix , checkErrorPrefix
) where ) where
import Bag (Bag, bagToList, filterBag, unionBags) import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.List (isPrefixOf, find) import Data.List (isPrefixOf, find, nub, isInfixOf)
import Data.Maybe (fromMaybe, isJust) import Data.Maybe (fromMaybe, isJust)
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo) import ErrUtils (ErrMsg, WarnMsg, errMsgShortDoc, errMsgExtraInfo, mkPlainWarnMsg)
import Exception (ghandle) import Exception (ghandle)
import GHC (DynFlags, SrcSpan, Severity(SevError)) import GHC (DynFlags, SrcSpan, Severity(SevError))
import qualified GHC as G import qualified GHC as G
@ -55,6 +55,31 @@ appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update
---------------------------------------------------------------- ----------------------------------------------------------------
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 ()
appendLogBagRef df (LogBagRef ref) _ sev src style msg = modifyIORef ref update
where
warnMsg = mkPlainWarnMsg df src msg
warnBag = consBag warnMsg emptyBag
update lg@(LogBag b) = let (b1,b2) = mergeErrors df style b warnBag
in LogBag $ b1 `unionBags` b2
----------------------------------------------------------------
-- | Set the session flag (e.g. "-Wall" or "-w:") then -- | Set the session flag (e.g. "-Wall" or "-w:") then
-- executes a body. Logged messages are returned as 'String'. -- executes a body. Logged messages are returned as 'String'.
-- Right is success and Left is failure. -- Right is success and Left is failure.
@ -80,29 +105,33 @@ withLoggerTwice :: IOish m
-> GhcModT m (Either String String) -> GhcModT m (Either String String)
withLoggerTwice setDF1 body1 setDF2 body2 = do withLoggerTwice setDF1 body1 setDF2 body2 = do
err1 <- ghandle sourceErrorBag $ do err1 <- ghandle sourceErrorBag $ do
logref <- liftIO newLogRef logref <- liftIO newLogBagRef
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
withDynFlags (setLogger logref . setDF1) $ withDynFlags (setLogger logref . setDF1) $
withCmdFlags wflags $ do withCmdFlags wflags $ do
body1 body1
Right <$> readAndClearLogRef logref Right <$> readAndClearLogBagRef logref
err2 <- ghandle sourceErrorBag $ do err2 <- ghandle sourceErrorBag $ do
logref <- liftIO newLogRef logref <- liftIO newLogBagRef
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
withDynFlags (setLogger logref . setDF2) $ withDynFlags (setLogger logref . setDF2) $
withCmdFlags wflags $ do withCmdFlags wflags $ do
body2 body2
Right <$> readAndClearLogRef logref Right <$> readAndClearLogBagRef logref
case (err1, err2) of -- Merge errors and warnings
(Right x, Right _) -> return $ Right x dflags <- G.getSessionDynFlags
(Left b1, Right _) -> errBagToStr b1
(Right _, Left b2) -> errBagToStr b2
(Left b1, Left b2) -> do dflags <- G.getSessionDynFlags
style <- toGhcModT getStyle style <- toGhcModT getStyle
let merged = mergeErrors dflags style b1 b2 case (err1, err2) of
errBagToStr merged (Right b1, Right b2) -> do let (warn1,warn2) = mergeErrors dflags style b1 b2
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 where
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref setLogger logref df = Gap.setLogAction df $ appendLogBagRef df logref
---------------------------------------------------------------- ----------------------------------------------------------------
@ -111,35 +140,54 @@ sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
sourceError err = errBagToStr (srcErrorMessages err) sourceError err = errBagToStr (srcErrorMessages err)
errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String) errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)
errBagToStr err = do errBagToStr = errBagToStr' Left
errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a
errBagToStr' f err = do
dflags <- G.getSessionDynFlags dflags <- G.getSessionDynFlags
style <- toGhcModT getStyle style <- toGhcModT getStyle
ret <- convert' (errBagToStrList dflags style err) ret <- convert' (errBagToStrList dflags style err)
return $ Left ret 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
ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn)
return $ f ret
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) String) 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) sourceErrorBag err = return $ Left (srcErrorMessages err)
mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> Bag ErrMsg mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> (Bag ErrMsg, Bag ErrMsg)
mergeErrors dflag style b1 b2 = mergeErrors dflag style b1 b2 =
let b1List = bagToList b1 let b1Msgs = map (\err1 -> let m = ppWarnMsg dflag style err1 in (m, head $ lines m))
findInB1 = \pr2 msg2 err1 -> (bagToList b1)
let pr1 = ppMsgPrefix (Gap.errorMsgSpan err1) G.SevWarning dflag style mustBeB2 = \err2 -> let msg2 = ppWarnMsg dflag style err2
msg1 = showPage dflag style (errMsgExtraInfo err1) line2 = head $ lines msg2
in pr1 == pr2 && msg1 == msg2 in not . isJust $ find (\(msg1, line1) -> msg1 == msg2 || (line1 == line2 && isHoleMsg line1)) b1Msgs
mustBeB2 = \err2 -> in (b1, filterBag mustBeB2 b2)
let pr2 = ppMsgPrefix (Gap.errorMsgSpan err2) G.SevWarning dflag style
msg2 = showPage dflag style (errMsgExtraInfo err2) isHoleMsg :: String -> Bool
in not . isJust $ find (findInB1 pr2 msg2) b1List isHoleMsg = isInfixOf "Found hole"
in b1 `unionBags` filterBag mustBeB2 b2
---------------------------------------------------------------- ----------------------------------------------------------------
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ ext 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)
where where
spn = Gap.errorMsgSpan err spn = Gap.errorMsgSpan err
msg = errMsgShortDoc err msg = errMsgShortDoc err