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

93 lines
3.0 KiB
Haskell
Raw Normal View History

2013-11-12 23:56:45 +00:00
{-# LANGUAGE BangPatterns, CPP #-}
2013-05-17 01:00:01 +00:00
module Language.Haskell.GhcMod.ErrMsg (
2011-08-24 07:50:26 +00:00
LogReader
, setLogger
, handleErrMsg
) where
import Bag
import Control.Applicative
import Data.IORef
2012-02-14 07:09:53 +00:00
import Data.Maybe
2011-08-24 07:50:26 +00:00
import DynFlags
import ErrUtils
import GHC
import HscTypes
2013-07-14 08:07:30 +00:00
import Language.Haskell.GhcMod.Doc (showUnqualifiedPage)
2013-09-03 05:40:51 +00:00
import Language.Haskell.GhcMod.Types (LineSeparator(..))
2013-05-17 01:00:01 +00:00
import qualified Language.Haskell.GhcMod.Gap as Gap
2011-08-24 07:50:26 +00:00
import Outputable
2013-03-05 06:18:57 +00:00
import System.FilePath (normalise)
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2013-09-05 05:35:28 +00:00
-- | A means to read the log.
2011-08-24 07:50:26 +00:00
type LogReader = IO [String]
----------------------------------------------------------------
2013-09-03 05:40:51 +00:00
setLogger :: Bool -> DynFlags -> LineSeparator -> IO (DynFlags, LogReader)
setLogger False df _ = return (newdf, undefined)
2011-08-24 07:50:26 +00:00
where
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
2013-09-03 05:40:51 +00:00
setLogger True df ls = do
2011-08-24 07:50:26 +00:00
ref <- newIORef [] :: IO (IORef [String])
let newdf = Gap.setLogAction df $ appendLog ref
2011-08-24 07:50:26 +00:00
return (newdf, reverse <$> readIORef ref)
where
appendLog ref _ sev src _ msg = do
2013-09-03 05:40:51 +00:00
let !l = ppMsg src sev df ls msg
modifyIORef ref (l:)
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2013-09-03 05:40:51 +00:00
handleErrMsg :: LineSeparator -> SourceError -> Ghc [String]
handleErrMsg ls err = do
2013-03-13 01:54:50 +00:00
dflag <- getSessionDynFlags
2013-09-03 05:40:51 +00:00
return . errBagToStrList dflag ls . srcErrorMessages $ err
2011-08-24 07:50:26 +00:00
2013-09-03 05:40:51 +00:00
errBagToStrList :: DynFlags -> LineSeparator -> Bag ErrMsg -> [String]
errBagToStrList dflag ls = map (ppErrMsg dflag ls) . reverse . bagToList
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2013-09-03 05:40:51 +00:00
ppErrMsg :: DynFlags -> LineSeparator -> ErrMsg -> String
ppErrMsg dflag ls err = ppMsg spn SevError dflag ls msg ++ ext
2011-08-24 07:50:26 +00:00
where
2013-11-12 23:56:45 +00:00
#if __GLASGOW_HASKELL__ >= 707
2013-11-12 23:44:34 +00:00
spn = errMsgSpan err
2013-11-12 23:56:45 +00:00
#else
spn = head (errMsgSpans err)
#endif
2011-08-24 07:50:26 +00:00
msg = errMsgShortDoc err
2013-09-03 05:40:51 +00:00
ext = showMsg dflag ls (errMsgExtraInfo err)
2011-08-24 07:50:26 +00:00
2013-09-03 05:40:51 +00:00
ppMsg :: SrcSpan -> Severity-> DynFlags -> LineSeparator -> SDoc -> String
ppMsg spn sev dflag ls@(LineSeparator lsep) msg = prefix ++ cts ++ lsep
2011-08-24 07:50:26 +00:00
where
2013-09-03 05:40:51 +00:00
cts = showMsg dflag ls msg
defaultPrefix
| dopt Opt_D_dump_splices dflag = ""
| otherwise = "Dummy:0:0:"
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
2011-08-24 07:50:26 +00:00
----------------------------------------------------------------
2013-09-03 05:40:51 +00:00
showMsg :: DynFlags -> LineSeparator -> SDoc -> String
showMsg dflag (LineSeparator [s]) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc
2011-08-24 07:50:26 +00:00
where
2013-09-03 05:40:51 +00:00
replaceNull :: String -> String
replaceNull [] = []
replaceNull ('\n':xs) = s : replaceNull xs
replaceNull (x:xs) = x : replaceNull xs
showMsg dflag (LineSeparator lsep) sdoc = replaceNull $ showUnqualifiedPage dflag sdoc
where
replaceNull [] = []
replaceNull ('\n':xs) = lsep ++ replaceNull xs
replaceNull (x:xs) = x : replaceNull xs