Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add CompilationResult type and track compilation times.

  • Loading branch information...
commit 76bc3b880ae61235a8896288f0d8a735c3064452 1 parent ce0b402
Thomas Schilling nominolo authored
55 emacs/scion.el
View
@@ -1258,7 +1258,7 @@ last activated the buffer."
(:conc-name scion-compilation-result.)
(:constructor nil)
(:copier nil))
- tag notes successp duration)
+ tag successp notes duration)
(defvar scion-last-compilation-result nil
"The result of the most recently issued compilation.")
@@ -1462,28 +1462,37 @@ The first argument is dist directory (typically <project-root>/dist/)"
(scion-report-compilation-result result))))
(defun scion-report-compilation-result (result)
- (destructure-case result
- ((:ok warns)
- (setq scion-last-compilation-result
- (list 42 (mapc #'scion-canonicalise-note-location
- warns) t nil))
- (scion-highlight-notes warns)
- (scion-show-note-counts t warns nil))
- ((:error errs warns)
- (let ((notes (mapc #'scion-canonicalise-note-location
- (append errs warns))))
- (setq scion-last-compilation-result
- (list 42 notes nil nil))
- (scion-highlight-notes notes))
- (scion-show-note-counts nil warns errs))))
-
-(defun scion-show-note-counts (successp warns errs)
- (let ((nerrors (length errs))
- (nwarnings (length warns)))
- (message "Compilation %s: %s%s"
- (if successp "finished" "FAILED")
- (scion-note-count-string "error" nerrors)
- (scion-note-count-string "warning" nwarnings))))
+ (destructuring-bind (tag successp warns errs duration) result
+ (assert (eq tag 'compilation-result))
+ (let ((nerrors (length errs))
+ (nwarnings (length warns))
+ (notes (mapc #'scion-canonicalise-note-location
+ (nconc errs warns))))
+ (setq scion-last-compilation-result
+ (list tag successp notes duration))
+ (scion-highlight-notes warns)
+ (scion-show-note-counts successp nwarnings nerrors duration))))
+
+;; ((:ok warns)
+;; (setq scion-last-compilation-result
+;; (list 42 (mapc #'scion-canonicalise-note-location
+;; warns) t nil))
+;; (scion-highlight-notes warns)
+;; (scion-show-note-counts t warns nil))
+;; ((:error errs warns)
+;; (let ((notes (mapc #'scion-canonicalise-note-location
+;; (append errs warns))))
+;; (setq scion-last-compilation-result
+;; (list 42 notes nil nil))
+;; (scion-highlight-notes notes))
+;; (scion-show-note-counts nil warns errs))))
+
+(defun scion-show-note-counts (successp nwarnings nerrors secs)
+ (message "Compilation %s: %s%s%s"
+ (if successp "finished" "FAILED")
+ (scion-note-count-string "error" nerrors)
+ (scion-note-count-string "warning" nwarnings)
+ (if secs (format "[%.2f secs]" secs) "")))
(defun scion-note-count-string (category count &optional suppress-if-zero)
(cond ((and (zerop count) suppress-if-zero)
1  scion.cabal
View
@@ -34,6 +34,7 @@ library
directory == 1.0.*,
Cabal >= 1.5 && < 1.8,
uniplate == 1.2.*,
+ time == 1.1.*,
ghc-uniplate == 0.1.*
hs-source-dirs: src
extensions: CPP, PatternGuards
13 src/Scion/Server/Commands.hs
View
@@ -110,15 +110,14 @@ cmdLoadComponent =
sexpCompilationResult r
sexpCompilationResult :: CompilationResult -> ScionM ExactSexp
-sexpCompilationResult (Left (warns, errs)) =
+sexpCompilationResult (CompilationResult succeeded warns errs time) =
return $ ExactSexp $ parens $
- showString ":error" <+>
+ showString "compilation-result" <+>
+ toSexp succeeded <+>
+ toSexp (Lst (map DiagWarning (toList warns))) <+>
toSexp (Lst (map DiagError (toList errs))) <+>
- toSexp (Lst (map DiagWarning (toList warns)))
-sexpCompilationResult (Right warns) =
- return $ ExactSexp $ parens $
- showString ":ok" <+>
- toSexp (Lst (map DiagWarning (toList warns)))
+ toSexp (ExactSexp (showString (show
+ (fromRational (toRational time) :: Float))))
cmdListSupportedLanguages :: Command
cmdListSupportedLanguages =
41 src/Scion/Session.hs
View
@@ -28,6 +28,7 @@ import Data.IORef
import Data.List ( intercalate )
import Data.Maybe ( isJust )
import Data.Monoid
+import Data.Time.Clock ( getCurrentTime, diffUTCTime, NominalDiffTime )
import System.Directory ( setCurrentDirectory )
import System.FilePath ( (</>) )
import Control.Exception
@@ -205,9 +206,12 @@ setTargetsFromCabal Library = do
setTargetsFromCabal (Executable _) = do
error "unimplemented"
-type CompilationResult
- = (Either (WarningMessages, ErrorMessages)
- WarningMessages)
+data CompilationResult = CompilationResult {
+ compilationSucceeded :: Bool,
+ compilationWarnings :: WarningMessages,
+ compilationErrors :: ErrorMessages,
+ compilationTime :: NominalDiffTime
+ }
-- | Load the specified component from the current Cabal project.
--
@@ -254,13 +258,16 @@ setActiveComponent comp = do
-- | Wrapper for 'GHC.load'.
load :: LoadHowMuch -> ScionM CompilationResult
load how_much = do
+ start_time <- liftIO $ getCurrentTime
ref <- liftIO $ newIORef (mempty, mempty)
res <- loadWithLogger (logWarnErr ref) how_much
`gcatch` (\(e :: SourceError) -> handle_error ref e)
+ end_time <- liftIO $ getCurrentTime
+ let time_diff = diffUTCTime end_time start_time
(warns, errs) <- liftIO $ readIORef ref
case res of
- Succeeded -> return (Right warns)
- Failed -> return (Left (warns, errs))
+ Succeeded -> return (CompilationResult True warns mempty time_diff)
+ Failed -> return (CompilationResult False warns errs time_diff)
where
logWarnErr ref err = do
let errs = case err of
@@ -357,11 +364,12 @@ setContextForBGTC fname = do
True
Nothing
setTargets [target]
+ start_time <- liftIO $ getCurrentTime
-- find out the module name of our target
mb_mod_graph <- gtry $ depanal [] False
case mb_mod_graph of
Left (e :: SourceError) -> do
- r <- srcErrToCompilationResult e
+ r <- srcErrToCompilationResult start_time e
return (Nothing, r)
Right mod_graph -> do
let mod = case [ m | m <- mod_graph
@@ -371,16 +379,23 @@ setContextForBGTC fname = do
[] -> dieHard $ "No ModSummary found for " ++ fname
_ -> dieHard $ "Too many ModSummaries found for " ++ fname
let mod_name = ms_mod_name mod
- r <- load (LoadDependenciesOf mod_name)
- `gcatch` \(e :: SourceError) -> srcErrToCompilationResult e
+ -- load does its own time tracking
+ end_time <- liftIO $ getCurrentTime
+ r0 <- load (LoadDependenciesOf mod_name)
+ `gcatch` \(e :: SourceError) -> srcErrToCompilationResult start_time e
+ let r = r0 { compilationTime = compilationTime r0 +
+ diffUTCTime end_time start_time }
modifySessionState $ \sess ->
- sess { focusedModule = either (const Nothing)
- (const (Just mod_name))
- r }
+ sess { focusedModule = if compilationSucceeded r
+ then Just mod_name
+ else Nothing
+ }
return (Just mod_name, r)
where
- srcErrToCompilationResult err = do
+ srcErrToCompilationResult start_time err = do
+ end_time <- liftIO $ getCurrentTime
warns <- getWarnings
clearWarnings
- return (Left (warns, srcErrorMessages err))
+ return (CompilationResult False warns (srcErrorMessages err)
+ (diffUTCTime end_time start_time))
Please sign in to comment.
Something went wrong with that request. Please try again.