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

102 lines
3.6 KiB
Haskell
Raw Normal View History

2013-11-12 23:56:45 +00:00
{-# LANGUAGE BangPatterns, CPP #-}
2014-04-28 12:47:08 +00:00
module Language.Haskell.GhcMod.Logger (
2014-04-28 12:41:29 +00:00
withLogger
2014-04-25 02:08:29 +00:00
, checkErrorPrefix
2011-08-24 07:50:26 +00:00
) where
2014-03-27 06:32:44 +00:00
import Bag (Bag, bagToList)
2014-05-14 16:05:40 +00:00
import Control.Applicative ((<$>),(*>))
import CoreMonad (liftIO)
2014-03-27 06:32:44 +00:00
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
2014-05-09 14:45:34 +00:00
import Data.List (isPrefixOf)
2014-03-27 06:32:44 +00:00
import Data.Maybe (fromMaybe)
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
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-05-11 22:40:00 +00:00
import Language.Haskell.GhcMod.Types (Options(..))
import Outputable (PprStyle, SDoc)
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]
newtype LogRef = LogRef (IORef Builder)
newLogRef :: IO LogRef
newLogRef = LogRef <$> newIORef id
2014-05-14 16:05:40 +00:00
readAndClearLogRef :: LogRef -> GhcMod String
readAndClearLogRef (LogRef ref) = do
b <- liftIO $ readIORef ref
liftIO $ writeIORef ref id
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 = do
let !l = ppMsg src sev df style msg
2014-03-18 03:38:04 +00:00
modifyIORef ref (\b -> b . (l:))
----------------------------------------------------------------
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.
2014-05-14 16:05:40 +00:00
withLogger :: (DynFlags -> DynFlags)
-> GhcMod ()
-> GhcMod (Either String String)
withLogger setDF body = ghandle sourceError $ do
logref <- liftIO $ newLogRef
2014-05-14 16:05:40 +00:00
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
2014-04-28 03:52:09 +00:00
withDynFlags (setLogger logref . setDF) $ do
2014-05-14 16:05:40 +00:00
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
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2014-03-26 03:09:02 +00:00
-- | Converting 'SourceError' to 'String'.
2014-05-14 16:05:40 +00:00
sourceError :: SourceError -> GhcMod (Either String String)
sourceError err = do
dflags <- G.getSessionDynFlags
style <- toGhcMod getStyle
ret <- convert' $ (errBagToStrList dflags style . srcErrorMessages $ err)
return $ Left 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
----------------------------------------------------------------
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ 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
defaultPrefix
2014-04-26 04:21:22 +00:00
| Gap.isDumpSplices dflag = ""
| otherwise = checkErrorPrefix
prefix = fromMaybe defaultPrefix $ do
(line,col,_,_) <- Gap.getSrcSpan spn
file <- normalise <$> Gap.getSrcFile spn
let severityCaption = Gap.showSeverityCaption sev
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
2014-04-25 02:08:29 +00:00
checkErrorPrefix :: String
checkErrorPrefix = "Dummy:0:0:Error:"