Trace aborted rule evaluations

Author: pepeiborra

ghcide/ghcide.cabal

@@ -48,6 +48,7 @@ library
         dependent-map,
         dependent-sum,
         dlist,
+        exceptions,
         extra >= 1.7.4,
         fuzzy,
         filepath,
@@ -245,6 +246,7 @@ benchmark benchHist
         directory,
         extra,
         filepath,
+        lens,
         optparse-applicative,
         shake,
         text,

ghcide/src/Development/IDE/Core/Tracing.hs

@@ -15,13 +15,16 @@ import           Control.Concurrent.Async       (Async, async)
 import           Control.Concurrent.Extra       (Var, modifyVar_, newVar,
                                                  readVar, threadDelay)
 import           Control.Exception              (evaluate)
-import           Control.Exception.Safe         (SomeException, catch)
+import           Control.Exception.Safe         (SomeException, catch,
+                                                 generalBracket)
 import           Control.Monad                  (forM_, forever, unless, void,
                                                  when, (>=>))
+import           Control.Monad.Catch            (ExitCase (..))
 import           Control.Monad.Extra            (whenJust)
 import           Control.Monad.IO.Unlift
 import           Control.Seq                    (r0, seqList, seqTuple2, using)
 import           Data.ByteString                (ByteString)
+import           Data.ByteString.Char8          (pack)
 import           Data.Dynamic                   (Dynamic)
 import qualified Data.HashMap.Strict            as HMap
 import           Data.IORef                     (modifyIORef', newIORef,
@@ -32,7 +35,7 @@ import           Debug.Trace.Flags              (userTracingEnabled)
 import           Development.IDE.Core.RuleTypes (GhcSession (GhcSession),
                                                  GhcSessionDeps (GhcSessionDeps),
                                                  GhcSessionIO (GhcSessionIO))
-import           Development.IDE.Graph          (Action, actionBracket)
+import           Development.IDE.Graph          (Action)
 import           Development.IDE.Graph.Rule
 import           Development.IDE.Types.Location (Uri (..))
 import           Development.IDE.Types.Logger   (Logger, logDebug, logInfo)
@@ -83,21 +86,24 @@ otTracedAction
     -> Action (RunResult a) -- ^ The action
     -> Action (RunResult a)
 otTracedAction key file mode success act
-  | userTracingEnabled =
-    actionBracket
+  | userTracingEnabled = fst <$>
+    generalBracket
         (do
             sp <- beginSpan (fromString (show key))
             setTag sp "File" (fromString $ fromNormalizedFilePath file)
             setTag sp "Mode" (fromString $ show mode)
             return sp
         )
-        endSpan
-        (\sp -> do
-            res <- act
-            unless (success $ runValue res) $ setTag sp "error" "1"
-            setTag sp "changed" $ case res of
-              RunResult x _ _ -> fromString $ show x
-            return res)
+        (\sp ec -> do
+          case ec of
+            ExitCaseAbort -> setTag sp "aborted" "1"
+            ExitCaseException e -> setTag sp "exception" (pack $ show e)
+            ExitCaseSuccess res -> do
+                unless (success $ runValue res) $ setTag sp "error" "1"
+                setTag sp "changed" $ case res of
+                    RunResult x _ _ -> fromString $ show x
+          endSpan sp)
+        (\_ -> act)
   | otherwise = act
 
 #if MIN_VERSION_ghc(8,8,0)

hls-graph/hls-graph.cabal

@@ -61,6 +61,7 @@ library
     , containers
     , deepseq
     , directory
+    , exceptions
     , extra
     , filepath
     , hashable

hls-graph/src/Development/IDE/Graph/Internal/Types.hs

@@ -1,14 +1,15 @@
 
 
+{-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE DeriveFunctor #-}
 
 module Development.IDE.Graph.Internal.Types where
 
 import           Control.Applicative
 import           Control.Concurrent.Extra
+import           Control.Monad.Catch
 import           Control.Monad.Fail
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Reader
@@ -49,7 +50,7 @@ data SRules = SRules {
 -- ACTIONS
 
 newtype Action a = Action {fromAction :: ReaderT SAction IO a}
-    deriving (Monad, Applicative, Functor, MonadIO, MonadFail)
+    deriving (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask)
 
 data SAction = SAction {
     actionDatabase :: !Database,
@@ -95,8 +96,8 @@ data Status
     | Running (IO ()) Result (Maybe Result)
 
 getResult :: Status -> Maybe Result
-getResult (Clean re)       = Just re
-getResult (Dirty m_re)     = m_re
+getResult (Clean re)         = Just re
+getResult (Dirty m_re)       = m_re
 getResult (Running _ _ m_re) = m_re
 
 data Result = Result {