git.iko.soy/ghcide
on package-debug help sign in
ghcide/src/Development/IDE/Core/Shake.hs
703 lines 28 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
4{-# LANGUAGE ExistentialQuantification #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE ConstraintKinds #-}
8-- | A Shake implementation of the compiler service.
9--
10-- There are two primary locations where data lives, and both of
11-- these contain much the same data:
12--
13-- * The Shake database (inside 'shakeDb') stores a map of shake keys
14-- to shake values. In our case, these are all of type 'Q' to 'A'.
15-- During a single run all the values in the Shake database are consistent
16-- so are used in conjunction with each other, e.g. in 'uses'.
17--
18-- * The 'Values' type stores a map of keys to values. These values are
19-- always stored as real Haskell values, whereas Shake serialises all 'A' values
20-- between runs. To deserialise a Shake value, we just consult Values.
21module Development.IDE.Core.Shake(
22 IdeState,
23 IdeRule, IdeResult, GetModificationTime(..),
24 shakeOpen, shakeShut,
25 shakeRun,
26 shakeProfile,
27 use, useWithStale, useNoFile, uses, usesWithStale,
28 use_, useNoFile_, uses_,
29 define, defineEarlyCutoff,
30 getDiagnostics, unsafeClearDiagnostics,
31 IsIdeGlobal, addIdeGlobal, getIdeGlobalState, getIdeGlobalAction,
32 garbageCollect,
33 setPriority,
34 sendEvent,
35 ideLogger,
36 actionLogger,
37 FileVersion(..),
38 Priority(..),
39 updatePositionMapping
40 ) where
42import Development.Shake hiding (ShakeValue)
43import Development.Shake.Database
44import Development.Shake.Classes
45import Development.Shake.Rule
46import qualified Data.HashMap.Strict as HMap
47import qualified Data.Map.Strict as Map
48import qualified Data.Map.Merge.Strict as Map
49import qualified Data.ByteString.Char8 as BS
50import Data.Dynamic
51import Data.Maybe
52import Data.Map.Strict (Map)
53import Data.List.Extra
54import qualified Data.Set as Set
55import qualified Data.Text as T
56import Data.Tuple.Extra
57import Data.Unique
58import Development.IDE.Core.Debouncer
59import Development.IDE.Core.PositionMapping
60import Development.IDE.Types.Logger hiding (Priority)
61import Language.Haskell.LSP.Diagnostics
62import qualified Data.SortedList as SL
63import Development.IDE.Types.Diagnostics
64import Development.IDE.Types.Location
65import Development.IDE.Types.Options
66import Control.Concurrent.Extra
67import Control.Exception
68import Control.DeepSeq
69import System.Time.Extra
70import Data.Typeable
71import qualified Language.Haskell.LSP.Messages as LSP
72import qualified Language.Haskell.LSP.Types as LSP
73import System.FilePath hiding (makeRelative)
74import qualified Development.Shake as Shake
75import Control.Monad.Extra
76import Data.Time
77import GHC.Generics
78import System.IO.Unsafe
79import Numeric.Extra
80import Language.Haskell.LSP.Types
83-- information we stash inside the shakeExtra field
84data ShakeExtras = ShakeExtras
85 {eventer :: LSP.FromServerMessage -> IO ()
86 ,debouncer :: Debouncer NormalizedUri
87 ,logger :: Logger
88 ,globals :: Var (HMap.HashMap TypeRep Dynamic)
89 ,state :: Var Values
90 ,diagnostics :: Var DiagnosticStore
91 ,publishedDiagnostics :: Var (Map NormalizedUri [Diagnostic])
92 -- ^ This represents the set of diagnostics that we have published.
93 -- Due to debouncing not every change might get published.
94 ,positionMapping :: Var (Map NormalizedUri (Map TextDocumentVersion PositionMapping))
95 -- ^ Map from a text document version to a PositionMapping that describes how to map
96 -- positions in a version of that document to positions in the latest version
97 }
99getShakeExtras :: Action ShakeExtras
100getShakeExtras = do
101 Just x <- getShakeExtra @ShakeExtras
102 return x
104getShakeExtrasRules :: Rules ShakeExtras
105getShakeExtrasRules = do
106 Just x <- getShakeExtraRules @ShakeExtras
107 return x
111class Typeable a => IsIdeGlobal a where
113addIdeGlobal :: IsIdeGlobal a => a -> Rules ()
114addIdeGlobal x@(typeOf -> ty) = do
115 ShakeExtras{globals} <- getShakeExtrasRules
116 liftIO $ modifyVar_ globals $ \mp -> case HMap.lookup ty mp of
117 Just _ -> error $ "Can't addIdeGlobal twice on the same type, got " ++ show ty
118 Nothing -> return $! HMap.insert ty (toDyn x) mp
121getIdeGlobalExtras :: forall a . IsIdeGlobal a => ShakeExtras -> IO a
122getIdeGlobalExtras ShakeExtras{globals} = do
123 Just x <- HMap.lookup (typeRep (Proxy :: Proxy a)) <$> readVar globals
124 return $ fromDyn x $ error "Serious error, corrupt globals"
126getIdeGlobalAction :: forall a . IsIdeGlobal a => Action a
127getIdeGlobalAction = liftIO . getIdeGlobalExtras =<< getShakeExtras
129getIdeGlobalState :: forall a . IsIdeGlobal a => IdeState -> IO a
130getIdeGlobalState = getIdeGlobalExtras . shakeExtras
133-- | The state of the all values.
134type Values = HMap.HashMap (NormalizedFilePath, Key) (Value Dynamic)
136-- | Key type
137data Key = forall k . (Typeable k, Hashable k, Eq k, Show k) => Key k
139instance Show Key where
140 show (Key k) = show k
142instance Eq Key where
143 Key k1 == Key k2 | Just k2' <- cast k2 = k1 == k2'
144 | otherwise = False
146instance Hashable Key where
147 hashWithSalt salt (Key key) = hashWithSalt salt key
149-- | The result of an IDE operation. Warnings and errors are in the Diagnostic,
150-- and a value is in the Maybe. For operations that throw an error you
151-- expect a non-empty list of diagnostics, at least one of which is an error,
152-- and a Nothing. For operations that succeed you expect perhaps some warnings
153-- and a Just. For operations that depend on other failing operations you may
154-- get empty diagnostics and a Nothing, to indicate this phase throws no fresh
155-- errors but still failed.
156--
157-- A rule on a file should only return diagnostics for that given file. It should
158-- not propagate diagnostic errors through multiple phases.
159type IdeResult v = ([FileDiagnostic], Maybe v)
161data Value v
162 = Succeeded TextDocumentVersion v
163 | Stale TextDocumentVersion v
164 | Failed
165 deriving (Functor, Generic, Show)
167instance NFData v => NFData (Value v)
169-- | Convert a Value to a Maybe. This will only return `Just` for
170-- up2date results not for stale values.
171currentValue :: Value v -> Maybe v
172currentValue (Succeeded _ v) = Just v
173currentValue (Stale _ _) = Nothing
174currentValue Failed = Nothing
176-- | Return the most recent, potentially stale, value and a PositionMapping
177-- for the version of that value.
178lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))
179lastValue file v = do
180 ShakeExtras{positionMapping} <- getShakeExtras
181 allMappings <- liftIO $ readVar positionMapping
182 pure $ case v of
183 Succeeded ver v -> Just (v, mappingForVersion allMappings file ver)
184 Stale ver v -> Just (v, mappingForVersion allMappings file ver)
185 Failed -> Nothing
187valueVersion :: Value v -> Maybe TextDocumentVersion
188valueVersion = \case
189 Succeeded ver _ -> Just ver
190 Stale ver _ -> Just ver
191 Failed -> Nothing
193mappingForVersion
194 :: Map NormalizedUri (Map TextDocumentVersion PositionMapping)
195 -> NormalizedFilePath
196 -> TextDocumentVersion
197 -> PositionMapping
198mappingForVersion allMappings file ver =
199 fromMaybe idMapping $
200 Map.lookup ver =<<
201 Map.lookup (filePathToUri' file) allMappings
203type IdeRule k v =
204 ( Shake.RuleResult k ~ v
205 , Show k
206 , Typeable k
207 , NFData k
208 , Hashable k
209 , Eq k
210 , Show v
211 , Typeable v
212 , NFData v
213 )
215-- | A Shake database plus persistent store. Can be thought of as storing
216-- mappings from @(FilePath, k)@ to @RuleResult k@.
217data IdeState = IdeState
218 {shakeDb :: ShakeDatabase
219 ,shakeAbort :: MVar (IO ()) -- close whoever was running last
220 ,shakeClose :: IO ()
221 ,shakeExtras :: ShakeExtras
222 ,shakeProfileDir :: Maybe FilePath
223 }
226-- This is debugging code that generates a series of profiles, if the Boolean is true
227shakeRunDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> [Action a] -> IO [a]
228shakeRunDatabaseProfile mbProfileDir shakeDb acts = do
229 (time, (res,_)) <- duration $ shakeRunDatabase shakeDb acts
230 whenJust mbProfileDir $ \dir -> do
231 count <- modifyVar profileCounter $ \x -> let !y = x+1 in return (y,y)
232 let file = "ide-" ++ profileStartTime ++ "-" ++ takeEnd 5 ("0000" ++ show count) ++ "-" ++ showDP 2 time <.> "html"
233 shakeProfileDatabase shakeDb $ dir </> file
234 return res
235 where
237{-# NOINLINE profileStartTime #-}
238profileStartTime :: String
239profileStartTime = unsafePerformIO $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S" <$> getCurrentTime
241{-# NOINLINE profileCounter #-}
242profileCounter :: Var Int
243profileCounter = unsafePerformIO $ newVar 0
245setValues :: IdeRule k v
246 => Var Values
247 -> k
248 -> NormalizedFilePath
249 -> Value v
250 -> IO ()
251setValues state key file val = modifyVar_ state $ \vals -> do
252 -- Force to make sure the old HashMap is not retained
253 evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals
255-- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
256getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
257getValues state key file = do
258 vs <- readVar state
259 case HMap.lookup (file, Key key) vs of
260 Nothing -> pure Nothing
261 Just v -> do
262 let r = fmap (fromJust . fromDynamic @v) v
263 -- Force to make sure we do not retain a reference to the HashMap
264 -- and we blow up immediately if the fromJust should fail
265 -- (which would be an internal error).
266 evaluate (r `seqValue` Just r)
268-- | Seq the result stored in the Shake value. This only
269-- evaluates the value to WHNF not NF. We take care of the latter
270-- elsewhere and doing it twice is expensive.
271seqValue :: Value v -> b -> b
272seqValue v b = case v of
273 Succeeded ver v -> rnf ver `seq` v `seq` b
274 Stale ver v -> rnf ver `seq` v `seq` b
275 Failed -> b
277-- | Open a 'IdeState', should be shut using 'shakeShut'.
278shakeOpen :: IO LSP.LspId
279 -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
280 -> Logger
281 -> Maybe FilePath
282 -> IdeReportProgress
283 -> ShakeOptions
284 -> Rules ()
285 -> IO IdeState
286shakeOpen getLspId eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
287 shakeExtras <- do
288 globals <- newVar HMap.empty
289 state <- newVar HMap.empty
290 diagnostics <- newVar mempty
291 publishedDiagnostics <- newVar mempty
292 debouncer <- newDebouncer
293 positionMapping <- newVar Map.empty
294 pure ShakeExtras{..}
295 (shakeDb, shakeClose) <-
296 shakeOpenDatabase
297 opts
298 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
299 , shakeProgress = if reportProgress then lspShakeProgress getLspId eventer else const (pure ())
300 }
301 rules
302 shakeAbort <- newMVar $ return ()
303 shakeDb <- shakeDb
304 return IdeState{..}
306lspShakeProgress :: IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()
307lspShakeProgress getLspId sendMsg prog = do
308 lspId <- getLspId
309 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
310 sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
311 lspId $ LSP.WorkDoneProgressCreateParams
312 { _token = u }
313 bracket_ (start u) (stop u) (loop u)
314 where
315 start id = sendMsg $ LSP.NotWorkDoneProgressBegin $ LSP.fmServerWorkDoneProgressBeginNotification
316 LSP.ProgressParams
317 { _token = id
318 , _value = WorkDoneProgressBeginParams
319 { _title = "Processing"
320 , _cancellable = Nothing
321 , _message = Nothing
322 , _percentage = Nothing
323 }
324 }
325 stop id = sendMsg $ LSP.NotWorkDoneProgressEnd $ LSP.fmServerWorkDoneProgressEndNotification
326 LSP.ProgressParams
327 { _token = id
328 , _value = WorkDoneProgressEndParams
329 { _message = Nothing
330 }
331 }
332 sample = 0.1
333 loop id = forever $ do
334 sleep sample
335 p <- prog
336 let done = countSkipped p + countBuilt p
337 let todo = done + countUnknown p + countTodo p
338 sendMsg $ LSP.NotWorkDoneProgressReport $ LSP.fmServerWorkDoneProgressReportNotification
339 LSP.ProgressParams
340 { _token = id
341 , _value = LSP.WorkDoneProgressReportParams
342 { _cancellable = Nothing
343 , _message = Just $ T.pack $ show done <> "/" <> show todo
344 , _percentage = Nothing
345 }
346 }
348shakeProfile :: IdeState -> FilePath -> IO ()
349shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
351shakeShut :: IdeState -> IO ()
352shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
353 -- Shake gets unhappy if you try to close when there is a running
354 -- request so we first abort that.
355 stop
356 shakeClose
358-- | This is a variant of withMVar where the first argument is run unmasked and if it throws
359-- an exception, the previous value is restored while the second argument is executed masked.
360withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
361withMVar' var unmasked masked = mask $ \restore -> do
362 a <- takeMVar var
363 b <- restore (unmasked a) `onException` putMVar var a
364 (a', c) <- masked b
365 putMVar var a'
366 pure c
368-- | Spawn immediately. If you are already inside a call to shakeRun that will be aborted with an exception.
369shakeRun :: IdeState -> [Action a] -> IO (IO [a])
370shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
371 withMVar'
372 shakeAbort
373 (\stop -> do
374 (stopTime,_) <- duration stop
375 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
376 bar <- newBarrier
377 start <- offsetTime
378 pure (start, bar))
379 -- It is crucial to be masked here, otherwise we can get killed
380 -- between spawning the new thread and updating shakeAbort.
381 -- See https://github.com/digital-asset/ghcide/issues/79
382 (\(start, bar) -> do
383 thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
384 runTime <- start
385 let res' = case res of
386 Left e -> "exception: " <> displayException e
387 Right _ -> "completed"
388 logDebug logger $ T.pack $
389 "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"
390 signalBarrier bar res
391 -- important: we send an async exception to the thread, then wait for it to die, before continuing
392 pure (killThread thread >> void (waitBarrier bar), either throwIO return =<< waitBarrier bar))
394getDiagnostics :: IdeState -> IO [FileDiagnostic]
395getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
396 val <- readVar diagnostics
397 return $ getAllDiagnostics val
399-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
400unsafeClearDiagnostics :: IdeState -> IO ()
401unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
402 writeVar diagnostics mempty
404-- | Clear the results for all files that do not match the given predicate.
405garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
406garbageCollect keep = do
407 ShakeExtras{state, diagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
408 liftIO $
409 do newState <- modifyVar state $ \values -> do
410 values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
411 return $! dupe values
412 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
413 modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags
414 let versionsForFile =
415 Map.fromListWith Set.union $
416 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
417 HMap.toList newState
418 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
419define
420 :: IdeRule k v
421 => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
422define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
424use :: IdeRule k v
425 => k -> NormalizedFilePath -> Action (Maybe v)
426use key file = head <$> uses key [file]
428useWithStale :: IdeRule k v
429 => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
430useWithStale key file = head <$> usesWithStale key [file]
432useNoFile :: IdeRule k v => k -> Action (Maybe v)
433useNoFile key = use key ""
435use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
436use_ key file = head <$> uses_ key [file]
438useNoFile_ :: IdeRule k v => k -> Action v
439useNoFile_ key = use_ key ""
441uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
442uses_ key files = do
443 res <- uses key files
444 case sequence res of
445 Nothing -> liftIO $ throwIO BadDependency
446 Just v -> return v
449-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
450-- which short-circuits the rest of the action
451data BadDependency = BadDependency deriving Show
452instance Exception BadDependency
454isBadDependency :: SomeException -> Bool
455isBadDependency x
456 | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
457 | Just (_ :: BadDependency) <- fromException x = True
458 | otherwise = False
460newtype Q k = Q (k, NormalizedFilePath)
461 deriving (Eq,Hashable,NFData)
463-- Using Database we don't need Binary instances for keys
464instance Binary (Q k) where
465 put _ = return ()
466 get = fail "Binary.get not defined for type Development.IDE.Core.Shake.Q"
468instance Show k => Show (Q k) where
469 show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
471-- | Invariant: the 'v' must be in normal form (fully evaluated).
472-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
473-- Note (MK) I am not sure why we need the ShakeValue here, maybe we
474-- can just remove it?
475data A v = A (Value v) ShakeValue
476 deriving Show
478instance NFData (A v) where rnf (A v x) = v `seq` rnf x
480-- In the Shake database we only store one type of key/result pairs,
481-- namely Q (question) / A (answer).
482type instance RuleResult (Q k) = A (RuleResult k)
485-- | Return up2date results. Stale results will be ignored.
486uses :: IdeRule k v
487 => k -> [NormalizedFilePath] -> Action [Maybe v]
488uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)
490-- | Return the last computed result which might be stale.
491usesWithStale :: IdeRule k v
492 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
493usesWithStale key files = do
494 values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
495 mapM (uncurry lastValue) (zip files values)
497defineEarlyCutoff
498 :: IdeRule k v
499 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
500 -> Rules ()
501defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
502 extras@ShakeExtras{state} <- getShakeExtras
503 val <- case old of
504 Just old | mode == RunDependenciesSame -> do
505 v <- liftIO $ getValues state key file
506 case v of
507 -- No changes in the dependencies and we have
508 -- an existing result.
509 Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
510 _ -> return Nothing
511 _ -> return Nothing
512 case val of
513 Just res -> return res
514 Nothing -> do
515 (bs, (diags, res)) <- actionCatch
516 (do v <- op key file; liftIO $ evaluate $ force $ v) $
517 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
518 modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
519 (bs, res) <- case res of
520 Nothing -> do
521 staleV <- liftIO $ getValues state key file
522 pure $ case staleV of
523 Nothing -> (toShakeValue ShakeResult bs, Failed)
524 Just v -> case v of
525 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
526 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
527 Failed -> (toShakeValue ShakeResult bs, Failed)
528 Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
529 liftIO $ setValues state key file res
530 updateFileDiagnostics file (Key key) extras $ map snd diags
531 let eq = case (bs, fmap decodeShakeValue old) of
532 (ShakeResult a, Just (ShakeResult b)) -> a == b
533 (ShakeStale a, Just (ShakeStale b)) -> a == b
534 -- If we do not have a previous result
535 -- or we got ShakeNoCutoff we always return False.
536 _ -> False
537 return $ RunResult
538 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
539 (encodeShakeValue bs) $
540 A res bs
542toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
543toShakeValue = maybe ShakeNoCutoff
545data ShakeValue
546 = ShakeNoCutoff
547 -- ^ This is what we use when we get Nothing from
548 -- a rule.
549 | ShakeResult !BS.ByteString
550 -- ^ This is used both for `Failed`
551 -- as well as `Succeeded`.
552 | ShakeStale !BS.ByteString
553 deriving (Generic, Show)
555instance NFData ShakeValue
557encodeShakeValue :: ShakeValue -> BS.ByteString
558encodeShakeValue = \case
559 ShakeNoCutoff -> BS.empty
560 ShakeResult r -> BS.cons 'r' r
561 ShakeStale r -> BS.cons 's' r
563decodeShakeValue :: BS.ByteString -> ShakeValue
564decodeShakeValue bs = case BS.uncons bs of
565 Nothing -> ShakeNoCutoff
566 Just (x, xs)
567 | x == 'r' -> ShakeResult xs
568 | x == 's' -> ShakeStale xs
569 | otherwise -> error $ "Failed to parse shake value " <> show bs
572updateFileDiagnostics ::
573 NormalizedFilePath
574 -> Key
575 -> ShakeExtras
576 -> [Diagnostic] -- ^ current results
577 -> Action ()
578updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
579 modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
580 mask_ $ do
581 -- Mask async exceptions to ensure that updated diagnostics are always
582 -- published. Otherwise, we might never publish certain diagnostics if
583 -- an exception strikes between modifyVar but before
584 -- publishDiagnosticsNotification.
585 newDiags <- modifyVar diagnostics $ \old -> do
586 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
587 let newDiags = getFileDiagnostics fp newDiagsStore
588 _ <- evaluate newDiagsStore
589 _ <- evaluate newDiags
590 pure $! (newDiagsStore, newDiags)
591 let uri = filePathToUri' fp
592 let delay = if null newDiags then 0.1 else 0
593 registerEvent debouncer delay uri $ do
594 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
595 let lastPublish = Map.findWithDefault [] uri published
596 when (lastPublish /= newDiags) $
597 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
598 pure $! Map.insert uri newDiags published
600publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
601publishDiagnosticsNotification uri diags =
602 LSP.NotPublishDiagnostics $
603 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
604 LSP.PublishDiagnosticsParams uri (List diags)
606newtype Priority = Priority Double
608setPriority :: Priority -> Action ()
609setPriority (Priority p) = deprioritize p
611sendEvent :: LSP.FromServerMessage -> Action ()
612sendEvent e = do
613 ShakeExtras{eventer} <- getShakeExtras
614 liftIO $ eventer e
616ideLogger :: IdeState -> Logger
617ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
619actionLogger :: Action Logger
620actionLogger = do
621 ShakeExtras{logger} <- getShakeExtras
622 return logger
625data GetModificationTime = GetModificationTime
626 deriving (Eq, Show, Generic)
627instance Hashable GetModificationTime
628instance NFData GetModificationTime
630-- | Get the modification time of a file.
631type instance RuleResult GetModificationTime = FileVersion
633-- | We store the modification time as a ByteString since we need
634-- a ByteString anyway for Shake and we do not care about how times
635-- are represented.
636data FileVersion = VFSVersion Int | ModificationTime BS.ByteString
637 deriving (Show, Generic)
639instance NFData FileVersion
641vfsVersion :: FileVersion -> Maybe Int
642vfsVersion (VFSVersion i) = Just i
643vfsVersion (ModificationTime _) = Nothing
647getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
648getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
651-- | Sets the diagnostics for a file and compilation step
652-- if you want to clear the diagnostics call this with an empty list
653setStageDiagnostics
654 :: NormalizedFilePath
655 -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited
656 -> T.Text
657 -> [LSP.Diagnostic]
658 -> DiagnosticStore
659 -> DiagnosticStore
660setStageDiagnostics fp timeM stage diags ds =
661 updateDiagnostics ds uri timeM diagsBySource
662 where
663 diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
664 uri = filePathToUri' fp
666getAllDiagnostics ::
667 DiagnosticStore ->
668 [FileDiagnostic]
669getAllDiagnostics =
670 concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
672getFileDiagnostics ::
673 NormalizedFilePath ->
674 DiagnosticStore ->
675 [LSP.Diagnostic]
676getFileDiagnostics fp ds =
677 maybe [] getDiagnosticsFromStore $
678 Map.lookup (filePathToUri' fp) ds
680filterDiagnostics ::
681 (NormalizedFilePath -> Bool) ->
682 DiagnosticStore ->
683 DiagnosticStore
684filterDiagnostics keep =
685 Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
687filterVersionMap
688 :: Map NormalizedUri (Set.Set TextDocumentVersion)
689 -> Map NormalizedUri (Map TextDocumentVersion a)
690 -> Map NormalizedUri (Map TextDocumentVersion a)
691filterVersionMap =
692 Map.merge Map.dropMissing Map.dropMissing $
693 Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
695updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
696updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do
697 modifyVar_ positionMapping $ \allMappings -> do
698 let uri = toNormalizedUri _uri
699 let mappingForUri = Map.findWithDefault Map.empty uri allMappings
700 let updatedMapping =
701 Map.insert _version idMapping $
702 Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri
703 pure $! Map.insert uri updatedMapping allMappings