Permalink
Browse files

Wrap GHC's error message and location type.

A GHC error or warning message is now a `Note` of some `NoteKind`.
Accordingly, `CompilationResult` now only contains a multiset (bag) of
`Note`s instead of separate warning and error bags.

GHC's `SrcSpan` is now a `Location`, which adds two more invariants:

  * The source of a location now specifies directly whether it is a
    file or something else.

  * File paths are always normalised to absolute paths.
  • Loading branch information...
1 parent 5fd8549 commit 2c5630e5c9c70fa634872120e7e57d4bd26eb793 @nominolo nominolo committed Mar 12, 2009
Showing with 320 additions and 89 deletions.
  1. +24 −15 emacs/scion.el
  2. +3 −2 scion.cabal
  3. +2 −4 src/Scion/Server/Commands.hs
  4. +30 −32 src/Scion/Server/Protocol.hs
  5. +25 −28 src/Scion/Session.hs
  6. +6 −8 src/Scion/Types.hs
  7. +230 −0 src/Scion/Types/Notes.hs
View
@@ -1657,11 +1657,11 @@ The overlay has several properties:
(:error 'scion-error-face)
(:warning 'scion-warning-face)))
-(defun scion-make-notes (warnings errors &optional keep-existing-notes)
+(defun scion-make-notes (notes0 &optional keep-existing-notes)
(let ((notes (if keep-existing-notes
(scion-compiler-notes)
(scion-makehash #'equal))))
- (loop for note in (nconc errors warnings)
+ (loop for note in notes0
do (progn
(scion-canonicalise-note-location note)
(let* ((fname (scion-note.filename note))
@@ -1926,21 +1926,30 @@ Sets the GHC flags for the library from the current Cabal project and loads it."
(scion-handling-failure (result)
(scion-report-compilation-result result))))
+(defun scion-count-notes (notes)
+ (let ((warns 0)
+ (errs 0))
+ (loop for n in notes
+ when (eq (scion-note.severity n) :warning) do (incf warns)
+ when (eq (scion-note.severity n) :error) do (incf errs))
+ (list warns errs)))
+
+
(defun scion-report-compilation-result (result &optional buf)
- (destructuring-bind (tag successp warns errs duration) result
+ (destructuring-bind (tag successp notes0 duration) result
(assert (eq tag 'compilation-result))
- (let ((nerrors (length errs))
- (nwarnings (length warns))
- (notes (scion-make-notes errs warns)))
- (setq scion-last-compilation-result
- (list tag successp notes duration))
- (scion-highlight-notes notes buf)
- (when (not buf)
- (scion-show-note-counts successp nwarnings nerrors duration)
- (when (< 0 (+ nwarnings nerrors))
- (scion-list-compiler-notes notes)))
- (scion-report-status (format ":%d/%d" nerrors nwarnings))
- nil)))
+ (multiple-value-bind (nwarnings nerrors)
+ (scion-count-notes notes0)
+ (let ((notes (scion-make-notes notes0)))
+ (setq scion-last-compilation-result
+ (list tag successp notes duration))
+ (scion-highlight-notes notes buf)
+ (when (not buf)
+ (scion-show-note-counts successp nwarnings nerrors duration)
+ (when (< 0 (+ nwarnings nerrors))
+ (scion-list-compiler-notes notes)))
+ (scion-report-status (format ":%d/%d" nerrors nwarnings))
+ nil))))
;; ((:ok warns)
;; (setq scion-last-compilation-result
View
@@ -36,7 +36,8 @@ library
Cabal >= 1.5 && < 1.8,
uniplate == 1.2.*,
time == 1.1.*,
- filepath == 1.1.*
+ filepath == 1.1.*,
+ multiset == 0.1.*
hs-source-dirs: src
extensions: CPP, PatternGuards
exposed-modules:
@@ -118,4 +119,4 @@ executable scion_emacs
-- TODO: drop after 6.10.2 is out
if impl(ghc >= 6.11.20081113) || impl(ghc == 6.10.* && >= 6.10.2)
- cpp-options: -DRECOMPILE_BUG_FIXED
+ cpp-options: -DRECOMPILE_BUG_FIXED
@@ -32,7 +32,6 @@ import qualified Outputable as O ( (<+>), ($$) )
import Control.Applicative
import Control.Monad
-import Data.Foldable as F
import Data.List ( nub )
import Text.ParserCombinators.ReadP
import qualified Data.Map as M
@@ -163,12 +162,11 @@ cmdLoadComponent =
loadComponent comp
instance Sexp CompilationResult where
- toSexp (CompilationResult success warns errs time) = toSexp $
+ toSexp (CompilationResult success notes time) = toSexp $
ExactSexp $ parens $
showString "compilation-result" <+>
toSexp success <+>
- toSexp (Lst (map DiagWarning (toList warns))) <+>
- toSexp (Lst (map DiagError (toList errs))) <+>
+ toSexp notes <+>
toSexp (ExactSexp (showString (show
(fromRational (toRational time) :: Float))))
@@ -18,17 +18,13 @@ module Scion.Server.Protocol where
import Prelude hiding ( span )
import Scion.Types
-
-import ErrUtils ( WarnMsg, ErrMsg(..) )
-import Outputable ( showSDoc, showSDocForUser, ppr )
-import SrcLoc ( SrcSpan, isGoodSrcSpan, srcSpanFile, noSrcSpan,
- srcSpanStartLine, srcSpanStartCol,
- srcSpanEndLine, srcSpanEndCol )
+import Scion.Types.Notes
import Data.Char ( isDigit, isSpace )
import Numeric ( showInt )
import Text.ParserCombinators.ReadP
import qualified Data.Map as M
+import qualified Data.MultiSet as MS
------------------------------------------------------------------------------
@@ -83,35 +79,37 @@ instance Sexp Component where
toSexp (File f) =
parens (showString ":file" <+> showString (show f))
-data Diagnostic
- = DiagWarning WarnMsg
- | DiagError ErrMsg
-
-instance Sexp SrcSpan where
- toSexp span
- | isGoodSrcSpan span =
- parens (showString ":loc" <+> showString (show (srcSpanFile span))
- <+> showInt (srcSpanStartLine span)
- <+> showInt (srcSpanStartCol span)
- <+> showInt (srcSpanEndLine span)
- <+> showInt (srcSpanEndCol span))
+instance Sexp a => Sexp (MS.MultiSet a) where
+ toSexp ms = toSexp (Lst (MS.toList ms))
+
+instance Sexp NoteKind where
+ toSexp k = showString $ case k of
+ ErrorNote -> ":error"
+ WarningNote -> ":warning"
+ InfoNote -> ":info"
+ OtherNote -> ":other"
+
+instance Sexp Note where
+ toSexp n =
+ parens (toSexp (noteKind n) <+>
+ toSexp (noteLoc n) <+>
+ putString (noteMessage n) <+>
+ putString "")
+
+instance Sexp Location where
+ toSexp loc
+ | isValidLoc loc,
+ (f, sl, sc, el, ec) <- viewLoc loc =
+ parens (showString ":loc" <+> toSexp f <+>
+ showInt sl <+> showInt sc <+>
+ showInt el <+> showInt ec)
| otherwise =
- parens (showString ":no-loc" <+> showString (showSDoc (ppr span)))
+ parens (showString ":no-loc" <+> showString (show (noLocText loc)))
-instance Sexp Diagnostic where
- toSexp (DiagWarning msg) = toSexp_diag ":warning" msg
- toSexp (DiagError msg) = toSexp_diag ":error" msg
+instance Sexp LocSource where
+ toSexp (FileSrc f) = showString (show f)
+ toSexp (OtherSrc s) = showString s
-toSexp_diag :: String -> ErrMsg -> ShowS
-toSexp_diag diag_type msg =
- parens $ showString diag_type <+> toSexp span
- <+> putString (show_msg (errMsgShortDoc msg))
- <+> putString (show_msg (errMsgExtraInfo msg))
- where
- span | (s:_) <- errMsgSpans msg = s
- | otherwise = noSrcSpan
- unqual = errMsgContext msg
- show_msg = showSDocForUser unqual
------------------------------------------------------------------------------
View
@@ -17,13 +17,12 @@ import Prelude hiding ( mod )
import GHC hiding ( flags, load )
import HscTypes ( srcErrorMessages, SourceError, isBootSummary )
import Exception
-import Bag ( filterBag )
-import FastString ( unpackFS )
-import ErrUtils ( errMsgSpans )
import Scion.Types
+import Scion.Types.Notes
import Scion.Utils()
+import qualified Data.MultiSet as MS
import Control.Monad
import Data.Data
import Data.IORef
@@ -34,7 +33,7 @@ import Data.Time.Clock ( getCurrentTime, diffUTCTime )
import System.Directory ( setCurrentDirectory, getCurrentDirectory,
doesFileExist )
import System.FilePath ( (</>), isRelative, makeRelative, normalise,
- combine, dropFileName )
+ dropFileName )
import Control.Exception
import System.Exit ( ExitCode(..) )
@@ -396,9 +395,11 @@ load how_much = do
end_time <- liftIO $ getCurrentTime
let time_diff = diffUTCTime end_time start_time
(warns, errs) <- liftIO $ readIORef ref
+ base_dir <- projectRootDir
+ let notes = ghcMessagesToNotes base_dir (warns, errs)
let comp_rslt = case res of
- Succeeded -> CompilationResult True warns mempty time_diff
- Failed -> CompilationResult False warns errs time_diff
+ Succeeded -> CompilationResult True notes time_diff
+ Failed -> CompilationResult False notes time_diff
-- TODO: We need to somehow find out which modules were recompiled so we
-- only update the part that we have new information for.
modifySessionState $ \s -> s { lastCompResult = comp_rslt }
@@ -529,14 +530,16 @@ backgroundTypecheckFile fname = do
modsum <- preprocessModule
let finish_up tc_res errs = do
+ base_dir <- projectRootDir
warns <- getWarnings
clearWarnings
+ let notes = ghcMessagesToNotes base_dir (warns, errs)
end_time <- liftIO $ getCurrentTime
let ok = isJust tc_res
- let res = CompilationResult ok warns errs
+ let res = CompilationResult ok notes
(diffUTCTime end_time start_time)
-
- full_comp_rslt <- removeMessagesForFile fname =<< gets lastCompResult
+ let abs_fname = mkAbsFilePath base_dir fname
+ full_comp_rslt <- removeMessagesForFile abs_fname =<< gets lastCompResult
let comp_rslt' = full_comp_rslt `mappend` comp_rslt `mappend` res
modifySessionState (\s -> s { bgTcCache = tc_res
@@ -615,7 +618,9 @@ setContextForBGTC modsum = do
end_time <- liftIO $ getCurrentTime
warns <- getWarnings
clearWarnings
- return (CompilationResult False warns (srcErrorMessages err)
+ base_dir <- projectRootDir
+ let notes = ghcMessagesToNotes base_dir (warns, srcErrorMessages err)
+ return (CompilationResult False notes
(diffUTCTime end_time start_time))
-- | Return the 'ModSummary' that refers to the source file.
@@ -633,24 +638,16 @@ modSummaryForFile fname mod_graph =
++ fname
-removeMessagesForFile :: FilePath -> CompilationResult -> ScionM CompilationResult
-removeMessagesForFile fname0 res = do
- root <- projectRootDir
- let
- norm = normalise . combine root
- fname = norm fname0
- warnings' = stripFileMsgs (compilationWarnings res)
- errors' = stripFileMsgs (compilationErrors res)
- stripFileMsgs = filterBag filterIt
- filterIt msg =
- case errMsgSpans msg of
- s:_ | isGoodSrcSpan s,
- norm (unpackFS (srcSpanFile s)) == fname -> False
- _ -> True
-
- return $
- res { compilationWarnings = warnings'
- , compilationErrors = errors' }
+removeMessagesForFile :: AbsFilePath -> CompilationResult -> ScionM CompilationResult
+removeMessagesForFile fname res = return res'
+ where
+ notes = compilationNotes res
+ res' = res { compilationNotes = notes' }
+ notes' = MS.filter f notes
+ f note
+ | isValidLoc l, FileSrc fn <- locSource l = fname == fn
+ | otherwise = False
+ where l = noteLoc note
-- Local Variables:
-- indent-tabs-mode: nil
View
@@ -16,14 +16,15 @@ module Scion.Types
, liftIO, MonadIO
) where
+import Scion.Types.Notes
import Scion.Types.ExtraInstances()
import GHC
-import ErrUtils ( WarningMessages, ErrorMessages )
import HscTypes
import MonadUtils ( liftIO, MonadIO )
import Exception
+import qualified Data.MultiSet as MS
import Distribution.Simple.LocalBuildInfo
import Control.Monad ( when )
import Data.IORef
@@ -181,21 +182,18 @@ data BgTcCache
data CompilationResult = CompilationResult {
compilationSucceeded :: Bool,
- compilationWarnings :: WarningMessages,
- compilationErrors :: ErrorMessages,
+ compilationNotes :: MS.MultiSet Note,
compilationTime :: NominalDiffTime
}
instance Monoid CompilationResult where
- mempty = CompilationResult True mempty mempty 0
+ mempty = CompilationResult True mempty 0
mappend r1 r2 =
CompilationResult
{ compilationSucceeded =
compilationSucceeded r1 && compilationSucceeded r2
- , compilationWarnings =
- compilationWarnings r1 `mappend` compilationWarnings r2
- , compilationErrors =
- compilationErrors r1 `mappend` compilationErrors r2
+ , compilationNotes =
+ compilationNotes r1 `MS.union` compilationNotes r2
, compilationTime = compilationTime r1 + compilationTime r2
}
Oops, something went wrong.

0 comments on commit 2c5630e

Please sign in to comment.