@@ -24,7 +24,7 @@
2424-- useStale.
2525module Development.IDE.State.Shake(
2626 IdeState,
27− IdeRule, IdeResult,
27+ IdeRule, IdeResult, GetModificationTime(..),
2828 shakeOpen, shakeShut,
2929 shakeRun,
3030 shakeProfile,
@@ -55,19 +55,18 @@ import Data.List.Extra
5555import qualified Data.Text as T
5656import Development.IDE.Logger as Logger
5757import Development.IDE.Types.LSP
58−import Development.IDE.Types.Diagnostics
58+import Development.IDE.Types.Diagnostics hiding (getAllDiagnostics)
59+import qualified Development.IDE.Types.Diagnostics as D
5960import Control.Concurrent.Extra
6061import Control.Exception
6162import Control.DeepSeq
6263import System.Time.Extra
6364import Data.Typeable
64−import Data.Tuple.Extra
65−import System.Directory
66−import System.FilePath
65+import System.FilePath hiding (makeRelative)
6766import qualified Development.Shake as Shake
6867import Control.Monad.Extra
69−import qualified Data.Set as Set
7068import Data.Time
69+import GHC.Generics
7170import System.IO.Unsafe
7271import Numeric.Extra
7372
@@ -79,6 +78,7 @@ data ShakeExtras = ShakeExtras
7978 ,logger :: Logger.Handle
8079 ,globals :: Var (Map.HashMap TypeRep Dynamic)
8180 ,state :: Var Values
81+ ,diagnostics :: Var (ProjectDiagnostics Key)
8282 }
8383
8484getShakeExtras :: Action ShakeExtras
@@ -116,12 +116,7 @@ getIdeGlobalState = getIdeGlobalExtras . shakeExtras
116116
117117
118118-- | The state of the all values - nested so you can easily find all errors at a given file.
119−type Values =
120− Map.HashMap FilePath
121− (Map.HashMap Key
122− (IdeResult Dynamic)
123− )
124−
119+type Values = Map.HashMap (FilePath, Key) (Maybe Dynamic)
125120
126121-- | Key type
127122data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
@@ -198,13 +193,10 @@ setValues :: IdeRule k v
198193 => Var Values
199194 -> k
200195 -> FilePath
201− -> IdeResult v
202− -> IO (Maybe [FileDiagnostic], [FileDiagnostic]) -- ^ (before, after)
203−setValues state key file val = modifyVar state $ \inVal -> do
204− let k = Key key
205− outVal = Map.insertWith Map.union file (Map.singleton k $ second (fmap toDyn) val) inVal
206− f = concatMap fst . Map.elems
207− return (outVal, (f <$> Map.lookup file inVal, f $ outVal Map.! file))
196+ -> Maybe v
197+ -> IO ()
198+setValues state key file val = modifyVar_ state $
199+ pure . Map.insert (file, Key key) (fmap toDyn val)
208200
209201-- | The outer Maybe is Nothing if this function hasn't been computed before
210202-- 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
213205getValues state key file = do
214206 vs <- readVar state
215207 return $ do
216− f <- Map.lookup file vs
217− v <- Map.lookup (Key key) f
218− pure $ fmap (fromJust . fromDynamic @v) $ snd v
208+ v <- Map.lookup (file, Key key) vs
209+ pure $ fmap (fromJust . fromDynamic @v) v
219210
220211-- | Open a 'IdeState', should be shut using 'shakeShut'.
221212shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler
@@ -223,8 +214,12 @@ shakeOpen :: (Event -> IO ()) -- ^ diagnostic handler
223214 -> ShakeOptions
224215 -> Rules ()
225216 -> IO IdeState
226−shakeOpen diags shakeLogger opts rules = do
227− shakeExtras <- ShakeExtras diags shakeLogger <$> newVar Map.empty <*> newVar Map.empty
217+shakeOpen eventer logger opts rules = do
218+ shakeExtras <- do
219+ globals <- newVar Map.empty
220+ state <- newVar Map.empty
221+ diagnostics <- newVar emptyDiagnostics
222+ pure ShakeExtras{..}
228223 (shakeDb, shakeClose) <- shakeOpenDatabase opts{shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts} rules
229224 shakeAbort <- newVar $ return ()
230225 shakeDb <- shakeDb
@@ -263,20 +258,22 @@ useStale IdeState{shakeExtras=ShakeExtras{state}} k fp =
263258
264259
265260getAllDiagnostics :: IdeState -> IO [FileDiagnostic]
266−getAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = do
267− val <- readVar state
268− return $ concatMap (concatMap fst . Map.elems) $ Map.elems val
261+getAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
262+ val <- readVar diagnostics
263+ return $ D.getAllDiagnostics val
269264
270265-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
271266unsafeClearAllDiagnostics :: IdeState -> IO ()
272−unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{state}} = modifyVar_ state $
273− return . Map.map (Map.map (\(_, x) -> ([], x)))
267+unsafeClearAllDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
268+ writeVar diagnostics emptyDiagnostics
274269
275270-- | Clear the results for all files that do not match the given predicate.
276271garbageCollect :: (FilePath -> Bool) -> Action ()
277272garbageCollect keep = do
278− ShakeExtras{state} <- getShakeExtras
279− liftIO $ modifyVar_ state $ return . Map.filterWithKey (\file _ -> keep file)
273+ ShakeExtras{state, diagnostics} <- getShakeExtras
274+ liftIO $
275+ do modifyVar_ state $ return . Map.filterWithKey (\(file, _) _ -> keep file)
276+ modifyVar_ diagnostics $ return . filterDiagnostics keep
280277
281278define
282279 :: IdeRule k v
@@ -354,7 +351,7 @@ defineEarlyCutoff
354351 => (k -> FilePath -> Action (Maybe BS.ByteString, IdeResult v))
355352 -> Rules ()
356353defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old mode -> do
357− ShakeExtras{state} <- getShakeExtras
354+ extras@ShakeExtras{state} <- getShakeExtras
358355 val <- case old of
359356 Just old | mode == RunDependenciesSame -> do
360357 v <- liftIO $ getValues state key file
@@ -365,46 +362,39 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) old m
365362 case val of
366363 Just res -> return res
367364 Nothing -> do
368− (bs, res) <- actionCatch
365+ (bs, (diags, res)) <- actionCatch
369366 (do v <- op key file; liftIO $ evaluate $ force v) $
370367 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
371− res <- return $ first (map $ \(_,d) -> (file,d)) res
372368
373− (before, after) <- liftIO $ setValues state key file res
374− updateFileDiagnostics file before after
369+ liftIO $ setValues state key file res
370+ updateFileDiagnostics file (Key key) extras $ map snd diags
375371 let eq = case (bs, fmap unwrap old) of
376372 (Just a, Just (Just b)) -> a == b
377373 _ -> False
378374 return $ RunResult
379375 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
380376 (wrap bs)
381− $ A (snd res) bs
377+ $ A res bs
382378 where
383379 wrap = maybe BS.empty (BS.cons '_')
384380 unwrap x = if BS.null x then Nothing else Just $ BS.tail x
385381
386−
387382updateFileDiagnostics ::
388383 FilePath
389− -> Maybe [FileDiagnostic] -- ^ previous results for this file
390− -> [FileDiagnostic] -- ^ current results
384+ -> Key
385+ -> ShakeExtras
386+ -> [Diagnostic] -- ^ current results
391387 -> Action ()
392−updateFileDiagnostics afp previousAll currentAll = do
393− -- TODO (MK) We canonicalize to make sure that the two files agree on use of
394− -- / and \ and other shenanigans.
395− -- Once we have finished the migration to haskell-lsp we should make sure that
396− -- this is no longer necessary.
397− afp' <- liftIO $ canonicalizePath afp
398− let filtM diags = do
399− diags' <-
400− filterM
401− (\x -> fmap (== afp') (canonicalizePath $ fst x))
402− diags
403− pure (Set.fromList diags')
404− previous <- liftIO $ traverse filtM previousAll
405− current <- liftIO $ filtM currentAll
406− when (Just current /= previous) $
407− sendEvent $ EventFileDiagnostics $ (afp, map snd $ Set.toList current)
388+updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do
389+ (newDiags, oldDiags) <- liftIO $ do
390+ modTime <- join <$> getValues state GetModificationTime fp
391+ modifyVar diagnostics $ \old -> do
392+ let oldDiags = getFileDiagnostics fp old
393+ let newDiagsStore = setStageDiagnostics fp modTime k current old
394+ let newDiags = getFileDiagnostics fp newDiagsStore
395+ pure (newDiagsStore, (newDiags, oldDiags))
396+ when (newDiags /= oldDiags) $
397+ sendEvent $ EventFileDiagnostics (fp, newDiags)
408398
409399
410400setPriority :: (Enum a) => a -> Action ()
@@ -424,3 +414,11 @@ logDebug, logSeriousError
424414 :: IdeState -> T.Text -> IO ()
425415logDebug = sl Logger.logDebug
426416logSeriousError = sl Logger.logSeriousError
417+
418+data GetModificationTime = GetModificationTime
419+ deriving (Eq, Show, Generic)
420+instance Hashable GetModificationTime
421+instance NFData GetModificationTime
422+
423+-- | Get the modification time of a file.
424+type instance RuleResult GetModificationTime = UTCTime