Fixing fly-make warning recognition when ghc-mod compiled against GHC 7.6

This commit is contained in:
Batonius 2012-10-19 23:19:37 +04:00
parent e5a2628dfa
commit 31c2c23c00
2 changed files with 16 additions and 5 deletions

View File

@ -30,7 +30,7 @@ setLogger True df = do
let newdf = Gap.setLogAction df $ appendLog ref let newdf = Gap.setLogAction df $ appendLog ref
return (newdf, reverse <$> readIORef ref) return (newdf, reverse <$> readIORef ref)
where where
appendLog ref _ _ src stl msg = modifyIORef ref (\ls -> ppMsg src msg stl : ls) appendLog ref _ sev src stl msg = modifyIORef ref (\ls -> ppMsg src sev msg stl : ls)
---------------------------------------------------------------- ----------------------------------------------------------------
@ -43,17 +43,19 @@ errBagToStrList = map ppErrMsg . reverse . bagToList
---------------------------------------------------------------- ----------------------------------------------------------------
ppErrMsg :: ErrMsg -> String ppErrMsg :: ErrMsg -> String
ppErrMsg err = ppMsg spn msg defaultUserStyle ++ ext ppErrMsg err = ppMsg spn SevError msg defaultUserStyle ++ ext
where where
spn = head (errMsgSpans err) spn = head (errMsgSpans err)
msg = errMsgShortDoc err msg = errMsgShortDoc err
ext = showMsg (errMsgExtraInfo err) defaultUserStyle ext = showMsg (errMsgExtraInfo err) defaultUserStyle
ppMsg :: SrcSpan -> SDoc -> PprStyle -> String ppMsg :: SrcSpan -> Severity-> SDoc -> PprStyle -> String
ppMsg spn msg stl = fromMaybe def $ do ppMsg spn sev msg stl = fromMaybe def $ do
(line,col,_,_) <- Gap.getSrcSpan spn (line,col,_,_) <- Gap.getSrcSpan spn
file <- Gap.getSrcFile spn file <- Gap.getSrcFile spn
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ cts ++ "\0" let severityCaption = Gap.showSeverityCaption sev
return $ file ++ ":" ++ show line ++ ":"
++ show col ++ ":" ++ severityCaption ++ cts ++ "\0"
where where
def = "ghc-mod:0:0:Probably mutual module import occurred\0" def = "ghc-mod:0:0:Probably mutual module import occurred\0"
cts = showMsg msg stl cts = showMsg msg stl

9
Gap.hs
View File

@ -16,6 +16,7 @@ module Gap (
, toStringBuffer , toStringBuffer
, liftIO , liftIO
, extensionToString , extensionToString
, showSeverityCaption
#if __GLASGOW_HASKELL__ >= 702 #if __GLASGOW_HASKELL__ >= 702
#else #else
, module Pretty , module Pretty
@ -201,6 +202,14 @@ setCtx ms = do
lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True
returnFalse = return False returnFalse = return False
showSeverityCaption :: Severity -> String
#if __GLASGOW_HASKELL__ >= 706
showSeverityCaption SevWarning = "Warning:"
showSeverityCaption _ = ""
#else
showSeverityCaption = const ""
#endif
---------------------------------------------------------------- ----------------------------------------------------------------
-- This is Cabal, not GHC API -- This is Cabal, not GHC API