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

190 lines
5.8 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP, RankNTypes #-}
2016-02-04 18:54:55 +00:00
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
, errBagToStrList
2011-08-24 07:50:26 +00:00
) where
import Control.Arrow
2015-08-03 01:09:56 +00:00
import Control.Applicative
import Data.Ord
import Data.List
import Data.Maybe
import Data.Function
import Control.Monad.Reader (Reader, ask, runReader)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
2015-07-04 14:49:48 +00:00
import System.FilePath (normalise)
import Text.PrettyPrint
import ErrUtils
import GHC
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
import SrcLoc
import FastString
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
2015-07-04 14:49:48 +00:00
import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc)
import qualified Language.Haskell.GhcMod.Gap as Gap
2015-08-03 01:09:56 +00:00
import Prelude
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)
2015-08-11 15:57:17 +00:00
data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags
, gpeMapFile :: FilePath -> FilePath
}
type GmPprEnvM a = Reader GmPprEnv a
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 :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction
appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do
modifyIORef ref update
where
-- TODO: get rid of ppMsg and just do more or less what ghc's
-- defaultLogAction does
l = ppMsg map_file df st src sev msg
update lg@(Log ls b)
| l `elem` ls = lg
| otherwise = Log (l:ls) (b . (l:))
2014-03-18 03:38:04 +00:00
----------------------------------------------------------------
-- | 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, GmOut m, GmState m)
=> (DynFlags -> DynFlags)
-> m a
-> m (Either String (String, a))
withLogger f action = do
env <- G.getSession
oopts <- outputOpts
let conv = convert oopts
eres <- withLogger' env $ \setDf ->
withDynFlags (f . setDf) action
return $ either (Left . conv) (Right . first conv) eres
withLogger' :: (IOish m, GmState m, GmEnv m)
=> HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
withLogger' env action = do
logref <- liftIO $ newLogRef
2015-07-04 14:49:48 +00:00
rfm <- mkRevRedirMapFunc
let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref
handlers = [
GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe,
GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
]
gpe = GmPprEnv {
gpeDynFlags = hsc_dflags env
, gpeMapFile = rfm
}
a <- gcatches (Right <$> action setLogger) handlers
ls <- liftIO $ readAndClearLogRef logref
return ((,) ls <$> a)
2014-05-14 16:05:40 +00:00
errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]
errBagToStrList env errs = do
rfm <- mkRevRedirMapFunc
return $ runReader
(errsToStr (sortMsgBag errs))
GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm }
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2014-03-26 03:09:02 +00:00
-- | Converting 'SourceError' to 'String'.
sourceError :: SourceError -> GmPprEnvM [String]
sourceError = errsToStr . sortMsgBag . srcErrorMessages
2014-08-15 07:32:28 +00:00
errsToStr :: [ErrMsg] -> GmPprEnvM [String]
errsToStr = mapM ppErrMsg
2011-08-24 07:50:26 +00:00
sortMsgBag :: Bag ErrMsg -> [ErrMsg]
sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
ppErrMsg :: ErrMsg -> GmPprEnvM String
ppErrMsg err = do
GmPprEnv {..} <- ask
let unqual = errMsgContext err
st = Gap.mkErrStyle' gpeDynFlags unqual
err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)
return $ showPage gpeDynFlags st $ pprLocErrMsg err'
mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan
mapSrcSpanFile map_file (RealSrcSpan s) =
RealSrcSpan $ mapRealSrcSpanFile map_file s
mapSrcSpanFile _ (UnhelpfulSpan s) =
UnhelpfulSpan s
mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan
mapRealSrcSpanFile map_file s = let
start = mapRealSrcLocFile map_file $ realSrcSpanStart s
end = mapRealSrcLocFile map_file $ realSrcSpanEnd s
in
mkRealSrcSpan start end
mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc
mapRealSrcLocFile map_file l = let
file = mkFastString $ map_file $ unpackFS $ srcLocFile l
line = srcLocLine l
col = srcLocCol l
in
mkRealSrcLoc file line col
ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String
ppMsg map_file df st spn sev msg = let
cts = showPage df st msg
in
ppMsgPrefix map_file df spn sev cts ++ cts
ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String
ppMsgPrefix map_file df spn sev cts =
let
defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix
in
fromMaybe defaultPrefix $ do
(line,col,_,_) <- Gap.getSrcSpan spn
file <- map_file <$> normalise <$> Gap.getSrcFile spn
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++
if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
then ""
else Gap.showSeverityCaption sev
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"]