Separate diagnostics from rule results (#1423)

BUILD.bazel

@@ -21,6 +21,7 @@ depends = [
     "mtl",
     "pretty",
     "safe-exceptions",
+    "sorted-list",
     "shake",
     "stm",
     "syb",

src/Development/IDE/State/FileStore.hs

@@ -42,10 +42,6 @@ newtype GlobalDirtyFiles = GlobalDirtyFiles (Var DirtyFiles)
 instance IsIdeGlobal GlobalDirtyFiles
 
 
-
--- | Get the modification time of a file.
-type instance RuleResult GetModificationTime = UTCTime
-
 -- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.
 type instance RuleResult GetFileContents = (UTCTime, StringBuffer)
 
@@ -58,11 +54,6 @@ data GetFileExists = GetFileExists
 instance Hashable GetFileExists
 instance NFData   GetFileExists
 
-data GetModificationTime = GetModificationTime
-    deriving (Eq, Show, Generic)
-instance Hashable GetModificationTime
-instance NFData   GetModificationTime
-
 data GetFileContents = GetFileContents
     deriving (Eq, Show, Generic)
 instance Hashable GetFileContents

src/Development/IDE/State/Shake.hs

@@ -24,7 +24,7 @@
 --   useStale.
 module Development.IDE.State.Shake(
     IdeState,
-    IdeRule, IdeResult,
+    IdeRule, IdeResult, GetModificationTime(..),
     shakeOpen, shakeShut,
     shakeRun,
     shakeProfile,
@@ -55,19 +55,18 @@ import           Data.List.Extra
 import qualified Data.Text as T
 import Development.IDE.Logger as Logger
 import Development.IDE.Types.LSP
-import           Development.IDE.Types.Diagnostics
+import           Development.IDE.Types.Diagnostics hiding (getAllDiagnostics)
+import qualified Development.IDE.Types.Diagnostics as D
 import           Control.Concurrent.Extra
 import           Control.Exception
 import           Control.DeepSeq
 import           System.Time.Extra
 import           Data.Typeable
-import           Data.Tuple.Extra
-import System.Directory
-import           System.FilePath
+import           System.FilePath hiding (makeRelative)
 import qualified Development.Shake as Shake
 import           Control.Monad.Extra
-import qualified Data.Set as Set
 import           Data.Time
+import           GHC.Generics
 import           System.IO.Unsafe
 import           Numeric.Extra
 
@@ -79,6 +78,7 @@ data ShakeExtras = ShakeExtras
     ,logger :: Logger.Handle
     ,globals :: Var (Map.HashMap TypeRep Dynamic)
     ,state :: Var Values
+    ,diagnostics :: Var (ProjectDiagnostics Key)
     }
 
 getShakeExtras :: Action ShakeExtras
@@ -116,12 +116,7 @@ getIdeGlobalState = getIdeGlobalExtras . shakeExtras
 
 
 -- | The state of the all values - nested so you can easily find all errors at a given file.
-type Values =
-    Map.HashMap FilePath
-        (Map.HashMap Key
-            (IdeResult Dynamic)
-        )
-
+type Values = Map.HashMap (FilePath, Key) (Maybe Dynamic)
 
 -- | Key type
 data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
@@ -198,13 +193,10 @@ setValues :: IdeRule k v
           => Var Values
           -> k
           -> FilePath
-          -> IdeResult v
-          -> IO (Maybe [FileDiagnostic], [FileDiagnostic]) -- ^ (before, after)
-setValues state key file val = modifyVar state $ \inVal -> do
-    let k = Key key
-        outVal = Map.insertWith Map.union file (Map.singleton k $ second (fmap toDyn) val) inVal
-        f = concatMap fst . Map.elems
-    return (outVal, (f <$> Map.lookup file inVal, f $ outVal Map.! file))
+          -> Maybe v
+          -> IO ()
+setValues state key file val = modifyVar_ state $
+    pure . Map.insert (file, Key key) (fmap toDyn val)
 
 -- | The outer Maybe is Nothing if this function hasn't been computed before
 --   the inner Maybe is Nothing if the result of the previous computation failed to produce
@@ -213,9 +205,8 @@ getValues :: forall k v. IdeRule k v => Var Values -> k -> FilePath -> IO (Maybe
 getValues state key file = do
     vs <- readVar state
     return $ do
-        f <- Map.lookup file vs
-        v <- Map.lookup (Key key) f
-        pure $ fmap (fromJust . fromDynamic @v) $ snd v
+        v <- Map.lookup (file, Key key) vs
+        pure $ fmap (fromJust . fromDynamic @v) v
 
 -- | Open a 'IdeState', should be shut using 'shakeShut'.
 shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler
@@ -223,8 +214,12 @@ shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler
           -> ShakeOptions
           -> Rules ()
           -> IO IdeState
-shakeOpen diags shakeLogger opts rules = do
-    shakeExtras <- ShakeExtras diags shakeLogger <$> newVar Map.empty <*> newVar Map.empty
+shakeOpen eventer logger opts rules = do
+    shakeExtras <- do
+        globals <- newVar Map.empty
+        state <- newVar Map.empty
+        diagnostics <- newVar emptyDiagnostics
+        pure ShakeExtras{..}
     (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules
     shakeAbort <- newVar $ return ()
     shakeDb <- shakeDb
@@ -263,20 +258,22 @@ useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
 
 
 getAllDiagnostics :: IdeState -> IO [FileDiagnostic]
-getAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = do
-    val <- readVar state
-    return $ concatMap (concatMap fst . Map.elems) $ Map.elems val
+getAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
+    val <- readVar diagnostics
+    return $ D.getAllDiagnostics val
 
 -- | FIXME: This function is temporary! Only required because the files of interest doesn't work
 unsafeClearAllDiagnostics :: IdeState -> IO ()
-unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = modifyVar_ state $
-    return . Map.map (Map.map (\(_, x) -> ([], x)))
+unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
+    writeVar diagnostics emptyDiagnostics
 
 -- | Clear the results for all files that do not match the given predicate.
 garbageCollect :: (FilePath -> Bool) -> Action ()
 garbageCollect keep = do
-    ShakeExtras{state} <- getShakeExtras
-    liftIO $ modifyVar_ state $ return . Map.filterWithKey (\file _ -> keep file)
+    ShakeExtras{state, diagnostics} <- getShakeExtras
+    liftIO $
+        do modifyVar_ state $ return . Map.filterWithKey (\(file, _) _ -> keep file)
+           modifyVar_ diagnostics $ return . filterDiagnostics keep
 
 define
     :: IdeRule k v
@@ -354,7 +351,7 @@ defineEarlyCutoff
     => (k -> FilePath -> Action (Maybe BS.ByteString, IdeResult v))
     -> Rules ()
 defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
-    ShakeExtras{state} <- getShakeExtras
+    extras@ShakeExtras{state} <- getShakeExtras
     val <- case old of
         Just old | mode == RunDependenciesSame -> do
             v <- liftIO $ getValues state key file
@@ -365,46 +362,39 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m
     case val of
         Just res -> return res
         Nothing -> do
-            (bs, res) <- actionCatch
+            (bs, (diags, res)) <- actionCatch
                 (do v <- op key file; liftIO $ evaluate $ force v) $
                 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
-            res <- return $ first (map $ \(_,d) -> (file,d)) res
 
-            (before, after) <- liftIO $ setValues state key file res
-            updateFileDiagnostics file before after
+            liftIO $ setValues state key file res
+            updateFileDiagnostics file (Key key) extras $ map snd diags
             let eq = case (bs, fmap unwrap old) of
                     (Just a, Just (Just b)) -> a == b
                     _ -> False
             return $ RunResult
                 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
                 (wrap bs)
-                $ A (snd res) bs
+                $ A res bs
     where
         wrap = maybe BS.empty (BS.cons '_')
         unwrap x = if BS.null x then Nothing else Just $ BS.tail x
 
-
 updateFileDiagnostics ::
      FilePath
-  -> Maybe [FileDiagnostic] -- ^ previous results for this file
-  -> [FileDiagnostic] -- ^ current results
+  -> Key
+  -> ShakeExtras
+  -> [Diagnostic] -- ^ current results
   -> Action ()
-updateFileDiagnostics afp previousAll currentAll = do
-    -- TODO (MK) We canonicalize to make sure that the two files agree on use of
-    -- / and \ and other shenanigans.
-    -- Once we have finished the migration to haskell-lsp we should make sure that
-    -- this is no longer necessary.
-    afp' <- liftIO $ canonicalizePath afp
-    let filtM diags = do
-            diags' <-
-                filterM
-                    (\x -> fmap (== afp') (canonicalizePath $ fst x))
-                    diags
-            pure (Set.fromList diags')
-    previous <- liftIO $ traverse filtM previousAll
-    current <- liftIO $ filtM currentAll
-    when (Just current /= previous) $
-        sendEvent $ EventFileDiagnostics $ (afp, map snd $ Set.toList current)
+updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do
+    (newDiags, oldDiags) <- liftIO $ do
+        modTime <- join <$> getValues state GetModificationTime fp
+        modifyVar diagnostics $ \old -> do
+            let oldDiags = getFileDiagnostics fp old
+            let newDiagsStore = setStageDiagnostics fp modTime k current old
+            let newDiags = getFileDiagnostics fp newDiagsStore
+            pure (newDiagsStore, (newDiags, oldDiags))
+    when (newDiags /= oldDiags) $
+        sendEvent $ EventFileDiagnostics (fp, newDiags)
 
 
 setPriority :: (Enum a) => a -> Action ()
@@ -424,3 +414,11 @@ logDebug, logSeriousError
     :: IdeState -> T.Text -> IO ()
 logDebug = sl Logger.logDebug
 logSeriousError = sl Logger.logSeriousError
+
+data GetModificationTime = GetModificationTime
+    deriving (Eq, Show, Generic)
+instance Hashable GetModificationTime
+instance NFData   GetModificationTime
+
+-- | Get the modification time of a file.
+type instance RuleResult GetModificationTime = UTCTime

src/Development/IDE/Types/Diagnostics.hs

@@ -27,12 +27,16 @@ module Development.IDE.Types.Diagnostics (
   ideTryIOException,
   showDiagnostics,
   showDiagnosticsColored,
-  prettyDiagnosticStore,
   defDiagnostic,
-  addDiagnostics,
-  filterSeriousErrors,
   filePathToUri,
-  getDiagnosticsFromStore
+  uriToFilePath',
+  ProjectDiagnostics,
+  emptyDiagnostics,
+  setStageDiagnostics,
+  getAllDiagnostics,
+  filterDiagnostics,
+  getFileDiagnostics,
+  prettyDiagnostics
   ) where
 
 import Control.Exception
@@ -40,14 +44,17 @@ import Data.Either.Combinators
 import Data.Maybe as Maybe
 import Data.Foldable
 import qualified Data.Map as Map
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
 import qualified Data.Text as T
 import Data.Text.Prettyprint.Doc.Syntax
+import qualified Data.SortedList as SL
 import qualified Text.PrettyPrint.Annotated.HughesPJClass as Pretty
-import           Language.Haskell.LSP.Types as LSP (
+import qualified Language.Haskell.LSP.Types as LSP
+import Language.Haskell.LSP.Types as LSP (
     DiagnosticSeverity(..)
   , Diagnostic(..)
   , filePathToUri
-  , uriToFilePath
   , List(..)
   , DiagnosticRelatedInformation(..)
   , Uri(..)
@@ -56,6 +63,15 @@ import Language.Haskell.LSP.Diagnostics
 
 import Development.IDE.Types.Location
 
+-- | We use an empty string as a filepath when we don’t have a file.
+-- However, haskell-lsp doesn’t support that in uriToFilePath and given
+-- that it is not a valid filepath it does not make sense to upstream a fix.
+-- So we have our own wrapper here that supports empty filepaths.
+uriToFilePath' :: Uri -> Maybe FilePath
+uriToFilePath' uri
+    | uri == filePathToUri "" = Just ""
+    | otherwise = LSP.uriToFilePath uri
+
 ideErrorText :: FilePath -> T.Text -> FileDiagnostic
 ideErrorText fp = errorDiag fp "Ide Error"
 
@@ -96,28 +112,6 @@ defDiagnostic _range _message = LSP.Diagnostic {
   , _relatedInformation = Nothing
   }
 
-filterSeriousErrors ::
-    FilePath ->
-    [LSP.Diagnostic] ->
-    [LSP.Diagnostic]
-filterSeriousErrors fp =
-    filter (maybe False hasSeriousErrors . LSP._relatedInformation)
-    where
-        hasSeriousErrors :: List DiagnosticRelatedInformation -> Bool
-        hasSeriousErrors (List a) = any ((/=) uri . _uri . _location) a
-        uri = LSP.filePathToUri fp
-
-addDiagnostics ::
-  FilePath ->
-  [LSP.Diagnostic] ->
-  DiagnosticStore -> DiagnosticStore
-addDiagnostics fp diags ds =
-    updateDiagnostics
-    ds
-    (LSP.filePathToUri fp)
-    Nothing $
-    partitionBySource diags
-
 ideTryIOException :: FilePath -> IO a -> IO (Either FileDiagnostic a)
 ideTryIOException fp act =
   mapLeft (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e) <$> try act
@@ -167,20 +161,61 @@ prettyDiagnostic (fp, LSP.Diagnostic{..}) =
     where
         sev = fromMaybe LSP.DsError _severity
 
-prettyDiagnosticStore :: DiagnosticStore -> Doc SyntaxClass
-prettyDiagnosticStore ds =
-    vcat $
-    map (\(uri, diags) -> prettyFileDiagnostics (fromMaybe noFilePath $ uriToFilePath uri, diags)) $
-    Map.assocs $
-    Map.map getDiagnosticsFromStore ds
-
-prettyFileDiagnostics :: FileDiagnostics -> Doc SyntaxClass
-prettyFileDiagnostics (filePath, diags) =
-    slabel_ "Compiler error in" $ vcat
-        [ slabel_ "File:" $ pretty filePath
-        , slabel_ "Errors:" $ vcat $ map (prettyDiagnostic . (filePath,)) diags
-        ]
-
 getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
 getDiagnosticsFromStore (StoreItem _ diags) =
     toList =<< Map.elems diags
+
+-- | This represents every diagnostic in a LSP project, the stage type variable is
+--   the type of the compiler stages, in this project that is always the Key data
+--   type found in Development.IDE.State.Shake
+newtype ProjectDiagnostics stage = ProjectDiagnostics {getStore :: DiagnosticStore}
+    deriving Show
+
+emptyDiagnostics :: ProjectDiagnostics stage
+emptyDiagnostics = ProjectDiagnostics mempty
+
+-- | Sets the diagnostics for a file and compilation step
+--   if you want to clear the diagnostics call this with an empty list
+setStageDiagnostics ::
+  Show stage =>
+  FilePath ->
+  Maybe UTCTime ->
+  -- ^ the time that the file these diagnostics originate from was last edited
+  stage ->
+  [LSP.Diagnostic] ->
+  ProjectDiagnostics stage ->
+  ProjectDiagnostics stage
+setStageDiagnostics fp timeM stage diags (ProjectDiagnostics ds) =
+    ProjectDiagnostics $ updateDiagnostics ds uri posixTime diagsBySource
+    where
+        diagsBySource = Map.singleton (Just $ T.pack $ show stage) (SL.toSortedList diags)
+        posixTime :: Maybe Int
+        posixTime = fmap (fromEnum . utcTimeToPOSIXSeconds) timeM
+        uri = filePathToUri fp
+
+fromUri :: LSP.Uri -> FilePath
+fromUri = fromMaybe noFilePath . uriToFilePath'
+
+getAllDiagnostics ::
+    ProjectDiagnostics stage ->
+    [FileDiagnostic]
+getAllDiagnostics =
+    concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList . getStore
+
+getFileDiagnostics ::
+    FilePath ->
+    ProjectDiagnostics stage ->
+    [LSP.Diagnostic]
+getFileDiagnostics fp ds =
+    maybe [] getDiagnosticsFromStore $
+    Map.lookup (filePathToUri fp) $
+    getStore ds
+
+filterDiagnostics ::
+    (FilePath -> Bool) ->
+    ProjectDiagnostics stage ->
+    ProjectDiagnostics stage
+filterDiagnostics keep =
+    ProjectDiagnostics .
+    Map.filterWithKey (\uri _ -> maybe True keep $ uriToFilePath' uri) .
+    getStore