Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
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...
commit 2c5630e5c9c70fa634872120e7e57d4bd26eb793 1 parent 5fd8549
@nominolo nominolo authored
View
39 emacs/scion.el
@@ -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
5 scion.cabal
@@ -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
View
6 src/Scion/Server/Commands.hs
@@ -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))))
View
62 src/Scion/Server/Protocol.hs
@@ -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
53 src/Scion/Session.hs
@@ -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
14 src/Scion/Types.hs
@@ -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
}
View
230 src/Scion/Types/Notes.hs
@@ -0,0 +1,230 @@
+{-# LANGUAGE PatternGuards #-}
+-- |
+-- Module : Scion.Types.Notes
+-- Copyright : (c) Thomas Schilling 2009
+-- License : BSD-style
+--
+-- Maintainer : nominolo@googlemail.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Notes, i.e., warnings, errors, etc.
+--
+module Scion.Types.Notes
+ ( Location, LocSource(..), mkLocation, mkNoLoc
+ , locSource, isValidLoc, noLocText, viewLoc
+ , locStartCol, locEndCol, locStartLine, locEndLine
+ , AbsFilePath, mkAbsFilePath
+ , Note(..), NoteKind(..), Notes
+ , ghcSpanToLocation, ghcErrMsgToNote, ghcWarnMsgToNote
+ , ghcMessagesToNotes
+ )
+where
+
+import qualified ErrUtils as GHC ( ErrMsg(..), WarnMsg, Messages )
+import qualified SrcLoc as GHC
+import qualified FastString as GHC ( unpackFS )
+import qualified Outputable as GHC ( showSDoc, ppr, showSDocForUser )
+import qualified Bag ( bagToList )
+
+import qualified Data.MultiSet as MS
+import System.FilePath
+
+infixr 9 `thenCmp`
+
+-- * Notes
+
+-- | A note from the compiler or some other tool.
+data Note
+ = Note { noteKind :: NoteKind
+ , noteLoc :: Location
+ , noteMessage :: String
+ } deriving (Eq, Ord, Show)
+
+data NoteKind
+ = ErrorNote
+ | WarningNote
+ | InfoNote
+ | OtherNote
+ deriving (Eq, Ord, Show)
+
+type Notes = MS.MultiSet Note
+
+-- * Absolute File Paths
+
+newtype AbsFilePath = AFP FilePath deriving (Eq, Ord)
+instance Show AbsFilePath where show (AFP s) = show s
+
+mkAbsFilePath :: FilePath -- ^ base directory (must be absolute)
+ -> FilePath -- ^ absolute or relative
+ -> AbsFilePath
+mkAbsFilePath baseDir dir
+ | isAbsolute baseDir = AFP $ baseDir </> dir
+ | otherwise =
+ error "mkAbsFilePath: first argument must be an absolute path"
+
+-- * Scion's 'Location' data type
+
+-- | Scion's type for source code locations (regions).
+--
+-- We use a custom location type, for two reasons:
+--
+-- 1. We enforce the invariant, that the file path of the location is an
+-- absolute path.
+--
+-- 2. Independent evolution from the GHC API.
+--
+data Location
+ = LocOneLine {
+ locSource :: LocSource,
+ locLine :: {-# UNPACK #-} !Int,
+ locSCol :: {-# UNPACK #-} !Int,
+ locECol :: {-# UNPACK #-} !Int
+ }
+ | LocMultiLine {
+ locSource :: LocSource,
+ locSLine :: {-# UNPACK #-} !Int,
+ locELine :: {-# UNPACK #-} !Int,
+ locSCol :: {-# UNPACK #-} !Int,
+ locECol :: {-# UNPACK #-} !Int
+ }
+ | LocPoint {
+ locSource :: LocSource,
+ locLine :: {-# UNPACK #-} !Int,
+ locCol :: {-# UNPACK #-} !Int
+ }
+ | LocNone { noLocText :: String }
+ deriving (Eq, Show)
+
+data LocSource
+ = FileSrc AbsFilePath
+ | OtherSrc String
+ deriving (Eq, Ord, Show)
+
+instance Ord Location where compare = cmpLoc
+
+-- | Construct a source code location from start and end point.
+--
+-- If the start point is after the end point, they are swapped
+-- automatically.
+mkLocation :: LocSource
+ -> Int -- ^ start line
+ -> Int -- ^ start column
+ -> Int -- ^ end line
+ -> Int -- ^ end column
+ -> Location
+mkLocation file l0 c0 l1 c1
+ | l0 > l1 = mkLocation file l1 c0 l0 c1
+ | l0 == l1 && c0 > c1 = mkLocation file l0 c1 l1 c0
+ | l0 == l1 = if c0 == c1
+ then LocPoint file l0 c0
+ else LocOneLine file l0 c0 c1
+ | otherwise = LocMultiLine file l0 l1 c0 c1
+
+-- | Construct a source location that does not specify a region.
+mkNoLoc :: String -> Location
+mkNoLoc msg = LocNone msg
+
+-- | Test whether a location
+isValidLoc :: Location -> Bool
+isValidLoc (LocNone _) = False
+isValidLoc _ = True
+
+noLocError :: String -> a
+noLocError f = error $ f ++ ": argument must not be a noLoc"
+
+-- | Return the start column. Only defined on valid locations.
+locStartCol :: Location -> Int
+locStartCol l@LocPoint{} = locCol l
+locStartCol LocNone{} = noLocError "locStartCol"
+locStartCol l = locSCol l
+
+-- | Return the end column. Only defined on valid locations.
+locEndCol :: Location -> Int
+locEndCol l@LocPoint{} = locCol l
+locEndCol LocNone{} = noLocError "locEndCol"
+locEndCol l = locECol l
+
+-- | Return the start line. Only defined on valid locations.
+locStartLine :: Location -> Int
+locStartLine l@LocMultiLine{} = locSLine l
+locStartLine LocNone{} = noLocError "locStartLine"
+locStartLine l = locLine l
+
+-- | Return the end line. Only defined on valid locations.
+locEndLine :: Location -> Int
+locEndLine l@LocMultiLine{} = locELine l
+locEndLine LocNone{} = noLocError "locEndLine"
+locEndLine l = locLine l
+
+{-# INLINE viewLoc #-}
+viewLoc :: Location -> (LocSource, Int, Int, Int, Int)
+viewLoc l = (locSource l, locStartLine l, locStartCol l,
+ locEndLine l, locEndLine l)
+
+cmpLoc :: Location -> Location -> Ordering
+cmpLoc LocNone{} _ = LT
+cmpLoc _ LocNone{} = GT
+cmpLoc l1 l2 =
+ (f1 `compare` f2) `thenCmp`
+ (sl1 `compare` sl2) `thenCmp`
+ (sc1 `compare` sc2) `thenCmp`
+ (el1 `compare` el2) `thenCmp`
+ (ec1 `compare` ec2)
+ where
+ (f1, sl1, sc1, el1, ec1) = viewLoc l1
+ (f2, sl2, sc2, el2, ec2) = viewLoc l2
+
+{-# INLINE thenCmp #-}
+thenCmp :: Ordering -> Ordering -> Ordering
+thenCmp EQ x = x
+thenCmp x _ = x
+
+-- * Converting from GHC types.
+
+-- | Convert a 'GHC.SrcSpan' to a 'Location'.
+ghcSpanToLocation :: FilePath -- ^ Base directory
+ -> GHC.SrcSpan
+ -> Location
+ghcSpanToLocation baseDir sp
+ | GHC.isGoodSrcSpan sp =
+ mkLocation mkLocFile
+ (GHC.srcSpanStartLine sp)
+ (GHC.srcSpanStartCol sp)
+ (GHC.srcSpanEndLine sp)
+ (GHC.srcSpanEndCol sp)
+ | otherwise =
+ mkNoLoc (GHC.showSDoc (GHC.ppr sp))
+ where
+ mkLocFile =
+ case GHC.unpackFS (GHC.srcSpanFile sp) of
+ s@('<':_) -> OtherSrc s
+ p -> FileSrc $ mkAbsFilePath baseDir p
+
+ghcErrMsgToNote :: FilePath -> GHC.ErrMsg -> Note
+ghcErrMsgToNote = ghcMsgToNote ErrorNote
+
+ghcWarnMsgToNote :: FilePath -> GHC.WarnMsg -> Note
+ghcWarnMsgToNote = ghcMsgToNote WarningNote
+
+-- Note that we don *not* include the extra info, since that information is
+-- only useful in the case where we don not show the error location directly
+-- in the source.
+ghcMsgToNote :: NoteKind -> FilePath -> GHC.ErrMsg -> Note
+ghcMsgToNote note_kind base_dir msg =
+ Note { noteLoc = ghcSpanToLocation base_dir loc
+ , noteKind = note_kind
+ , noteMessage = show_msg (GHC.errMsgShortDoc msg)
+ }
+ where
+ loc | (s:_) <- GHC.errMsgSpans msg = s
+ | otherwise = GHC.noSrcSpan
+ unqual = GHC.errMsgContext msg
+ show_msg = GHC.showSDocForUser unqual
+
+ghcMessagesToNotes :: FilePath -> GHC.Messages -> Notes
+ghcMessagesToNotes base_dir (warns, errs) =
+ MS.union (map_bag2ms (ghcWarnMsgToNote base_dir) warns)
+ (map_bag2ms (ghcErrMsgToNote base_dir) errs)
+ where
+ map_bag2ms f = MS.fromList . map f . Bag.bagToList
Please sign in to comment.
Something went wrong with that request. Please try again.