git.iko.soy/ghcide
on a58751e help sign in
ghcide/src/Development/IDE/Core/Shake.hs
674 lines 27 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 :: Var (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 :: (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
279 -> Logger
280 -> Maybe FilePath
281 -> IdeReportProgress
282 -> ShakeOptions
283 -> Rules ()
284 -> IO IdeState
285shakeOpen eventer logger shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
286 shakeExtras <- do
287 globals <- newVar HMap.empty
288 state <- newVar HMap.empty
289 diagnostics <- newVar mempty
290 publishedDiagnostics <- newVar mempty
291 debouncer <- newDebouncer
292 positionMapping <- newVar Map.empty
293 pure ShakeExtras{..}
294 (shakeDb, shakeClose) <-
295 shakeOpenDatabase
296 opts
297 { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
298 , shakeProgress = if reportProgress then lspShakeProgress eventer else const (pure ())
299 }
300 rules
301 shakeAbort <- newVar $ return ()
302 shakeDb <- shakeDb
303 return IdeState{..}
305lspShakeProgress :: (LSP.FromServerMessage -> IO ()) -> IO Progress -> IO ()
306lspShakeProgress sendMsg prog = do
307 u <- T.pack . show . hashUnique <$> newUnique
308 bracket_ (start u) (stop u) (loop u)
309 where
310 start id = sendMsg $ LSP.NotProgressStart $ LSP.fmServerProgressStartNotification
311 ProgressStartParams
312 { _id = id
313 , _title = "Processing"
314 , _cancellable = Nothing
315 , _message = Nothing
316 , _percentage = Nothing
317 }
318 stop id = sendMsg $ LSP.NotProgressDone $ LSP.fmServerProgressDoneNotification
319 ProgressDoneParams
320 { _id = id
321 }
322 sample = 0.1
323 loop id = forever $ do
324 sleep sample
325 p <- prog
326 let done = countSkipped p + countBuilt p
327 let todo = done + countUnknown p + countTodo p
328 sendMsg $ LSP.NotProgressReport $ LSP.fmServerProgressReportNotification
329 ProgressReportParams
330 { _id = id
331 , _message = Just $ T.pack $ show done <> "/" <> show todo
332 , _percentage = Nothing
333 }
335shakeProfile :: IdeState -> FilePath -> IO ()
336shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
338shakeShut :: IdeState -> IO ()
339shakeShut IdeState{..} = withVar shakeAbort $ \stop -> do
340 -- Shake gets unhappy if you try to close when there is a running
341 -- request so we first abort that.
342 stop
343 shakeClose
345-- | Spawn immediately. If you are already inside a call to shakeRun that will be aborted with an exception.
346shakeRun :: IdeState -> [Action a] -> IO (IO [a])
347-- FIXME: If there is already a shakeRun queued up and waiting to send me a kill, I should probably
348-- not even start, which would make issues with async exceptions less problematic.
349shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $ \stop -> do
350 (stopTime,_) <- duration stop
351 logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
352 bar <- newBarrier
353 start <- offsetTime
354 thread <- forkFinally (shakeRunDatabaseProfile shakeProfileDir shakeDb acts) $ \res -> do
355 runTime <- start
356 let res' = case res of
357 Left e -> "exception: " <> displayException e
358 Right _ -> "completed"
359 logDebug logger $ T.pack $
360 "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ ")"
361 signalBarrier bar res
362 -- important: we send an async exception to the thread, then wait for it to die, before continuing
363 return (do killThread thread; void $ waitBarrier bar, either throwIO return =<< waitBarrier bar)
365getDiagnostics :: IdeState -> IO [FileDiagnostic]
366getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
367 val <- readVar diagnostics
368 return $ getAllDiagnostics val
370-- | FIXME: This function is temporary! Only required because the files of interest doesn't work
371unsafeClearDiagnostics :: IdeState -> IO ()
372unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
373 writeVar diagnostics mempty
375-- | Clear the results for all files that do not match the given predicate.
376garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
377garbageCollect keep = do
378 ShakeExtras{state, diagnostics,publishedDiagnostics,positionMapping} <- getShakeExtras
379 liftIO $
380 do newState <- modifyVar state $ \values -> do
381 values <- evaluate $ HMap.filterWithKey (\(file, _) _ -> keep file) values
382 return $! dupe values
383 modifyVar_ diagnostics $ \diags -> return $! filterDiagnostics keep diags
384 modifyVar_ publishedDiagnostics $ \diags -> return $! Map.filterWithKey (\uri _ -> keep (fromUri uri)) diags
385 let versionsForFile =
386 Map.fromListWith Set.union $
387 mapMaybe (\((file, _key), v) -> (filePathToUri' file,) . Set.singleton <$> valueVersion v) $
388 HMap.toList newState
389 modifyVar_ positionMapping $ \mappings -> return $! filterVersionMap versionsForFile mappings
390define
391 :: IdeRule k v
392 => (k -> NormalizedFilePath -> Action (IdeResult v)) -> Rules ()
393define op = defineEarlyCutoff $ \k v -> (Nothing,) <$> op k v
395use :: IdeRule k v
396 => k -> NormalizedFilePath -> Action (Maybe v)
397use key file = head <$> uses key [file]
399useWithStale :: IdeRule k v
400 => k -> NormalizedFilePath -> Action (Maybe (v, PositionMapping))
401useWithStale key file = head <$> usesWithStale key [file]
403useNoFile :: IdeRule k v => k -> Action (Maybe v)
404useNoFile key = use key ""
406use_ :: IdeRule k v => k -> NormalizedFilePath -> Action v
407use_ key file = head <$> uses_ key [file]
409useNoFile_ :: IdeRule k v => k -> Action v
410useNoFile_ key = use_ key ""
412uses_ :: IdeRule k v => k -> [NormalizedFilePath] -> Action [v]
413uses_ key files = do
414 res <- uses key files
415 case sequence res of
416 Nothing -> liftIO $ throwIO BadDependency
417 Just v -> return v
420-- | When we depend on something that reported an error, and we fail as a direct result, throw BadDependency
421-- which short-circuits the rest of the action
422data BadDependency = BadDependency deriving Show
423instance Exception BadDependency
425isBadDependency :: SomeException -> Bool
426isBadDependency x
427 | Just (x :: ShakeException) <- fromException x = isBadDependency $ shakeExceptionInner x
428 | Just (_ :: BadDependency) <- fromException x = True
429 | otherwise = False
431newtype Q k = Q (k, NormalizedFilePath)
432 deriving (Eq,Hashable,NFData)
434-- Using Database we don't need Binary instances for keys
435instance Binary (Q k) where
436 put _ = return ()
437 get = fail "Binary.get not defined for type Development.IDE.Core.Shake.Q"
439instance Show k => Show (Q k) where
440 show (Q (k, file)) = show k ++ "; " ++ fromNormalizedFilePath file
442-- | Invariant: the 'v' must be in normal form (fully evaluated).
443-- Otherwise we keep repeatedly 'rnf'ing values taken from the Shake database
444-- Note (MK) I am not sure why we need the ShakeValue here, maybe we
445-- can just remove it?
446data A v = A (Value v) ShakeValue
447 deriving Show
449instance NFData (A v) where rnf (A v x) = v `seq` rnf x
451-- In the Shake database we only store one type of key/result pairs,
452-- namely Q (question) / A (answer).
453type instance RuleResult (Q k) = A (RuleResult k)
456-- | Return up2date results. Stale results will be ignored.
457uses :: IdeRule k v
458 => k -> [NormalizedFilePath] -> Action [Maybe v]
459uses key files = map (\(A value _) -> currentValue value) <$> apply (map (Q . (key,)) files)
461-- | Return the last computed result which might be stale.
462usesWithStale :: IdeRule k v
463 => k -> [NormalizedFilePath] -> Action [Maybe (v, PositionMapping)]
464usesWithStale key files = do
465 values <- map (\(A value _) -> value) <$> apply (map (Q . (key,)) files)
466 mapM (uncurry lastValue) (zip files values)
468defineEarlyCutoff
469 :: IdeRule k v
470 => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
471 -> Rules ()
472defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
473 extras@ShakeExtras{state} <- getShakeExtras
474 val <- case old of
475 Just old | mode == RunDependenciesSame -> do
476 v <- liftIO $ getValues state key file
477 case v of
478 -- No changes in the dependencies and we have
479 -- an existing result.
480 Just v -> return $ Just $ RunResult ChangedNothing old $ A v (decodeShakeValue old)
481 _ -> return Nothing
482 _ -> return Nothing
483 case val of
484 Just res -> return res
485 Nothing -> do
486 (bs, (diags, res)) <- actionCatch
487 (do v <- op key file; liftIO $ evaluate $ force $ v) $
488 \(e :: SomeException) -> pure (Nothing, ([ideErrorText file $ T.pack $ show e | not $ isBadDependency e],Nothing))
489 modTime <- liftIO $ join . fmap currentValue <$> getValues state GetModificationTime file
490 (bs, res) <- case res of
491 Nothing -> do
492 staleV <- liftIO $ getValues state key file
493 pure $ case staleV of
494 Nothing -> (toShakeValue ShakeResult bs, Failed)
495 Just v -> case v of
496 Succeeded ver v -> (toShakeValue ShakeStale bs, Stale ver v)
497 Stale ver v -> (toShakeValue ShakeStale bs, Stale ver v)
498 Failed -> (toShakeValue ShakeResult bs, Failed)
499 Just v -> pure $ (maybe ShakeNoCutoff ShakeResult bs, Succeeded (vfsVersion =<< modTime) v)
500 liftIO $ setValues state key file res
501 updateFileDiagnostics file (Key key) extras $ map snd diags
502 let eq = case (bs, fmap decodeShakeValue old) of
503 (ShakeResult a, Just (ShakeResult b)) -> a == b
504 (ShakeStale a, Just (ShakeStale b)) -> a == b
505 -- If we do not have a previous result
506 -- or we got ShakeNoCutoff we always return False.
507 _ -> False
508 return $ RunResult
509 (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
510 (encodeShakeValue bs) $
511 A res bs
513toShakeValue :: (BS.ByteString -> ShakeValue) -> Maybe BS.ByteString -> ShakeValue
514toShakeValue = maybe ShakeNoCutoff
516data ShakeValue
517 = ShakeNoCutoff
518 -- ^ This is what we use when we get Nothing from
519 -- a rule.
520 | ShakeResult !BS.ByteString
521 -- ^ This is used both for `Failed`
522 -- as well as `Succeeded`.
523 | ShakeStale !BS.ByteString
524 deriving (Generic, Show)
526instance NFData ShakeValue
528encodeShakeValue :: ShakeValue -> BS.ByteString
529encodeShakeValue = \case
530 ShakeNoCutoff -> BS.empty
531 ShakeResult r -> BS.cons 'r' r
532 ShakeStale r -> BS.cons 's' r
534decodeShakeValue :: BS.ByteString -> ShakeValue
535decodeShakeValue bs = case BS.uncons bs of
536 Nothing -> ShakeNoCutoff
537 Just (x, xs)
538 | x == 'r' -> ShakeResult xs
539 | x == 's' -> ShakeStale xs
540 | otherwise -> error $ "Failed to parse shake value " <> show bs
543updateFileDiagnostics ::
544 NormalizedFilePath
545 -> Key
546 -> ShakeExtras
547 -> [Diagnostic] -- ^ current results
548 -> Action ()
549updateFileDiagnostics fp k ShakeExtras{diagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
550 modTime <- join . fmap currentValue <$> getValues state GetModificationTime fp
551 mask_ $ do
552 -- Mask async exceptions to ensure that updated diagnostics are always
553 -- published. Otherwise, we might never publish certain diagnostics if
554 -- an exception strikes between modifyVar but before
555 -- publishDiagnosticsNotification.
556 newDiags <- modifyVar diagnostics $ \old -> do
557 let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) (T.pack $ show k) current old
558 let newDiags = getFileDiagnostics fp newDiagsStore
559 _ <- evaluate newDiagsStore
560 _ <- evaluate newDiags
561 pure $! (newDiagsStore, newDiags)
562 let uri = filePathToUri' fp
563 let delay = if null newDiags then 0.1 else 0
564 registerEvent debouncer delay uri $ do
565 mask_ $ modifyVar_ publishedDiagnostics $ \published -> do
566 let lastPublish = Map.findWithDefault [] uri published
567 when (lastPublish /= newDiags) $
568 eventer $ publishDiagnosticsNotification (fromNormalizedUri uri) newDiags
569 pure $! Map.insert uri newDiags published
571publishDiagnosticsNotification :: Uri -> [Diagnostic] -> LSP.FromServerMessage
572publishDiagnosticsNotification uri diags =
573 LSP.NotPublishDiagnostics $
574 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $
575 LSP.PublishDiagnosticsParams uri (List diags)
577newtype Priority = Priority Double
579setPriority :: Priority -> Action ()
580setPriority (Priority p) = deprioritize p
582sendEvent :: LSP.FromServerMessage -> Action ()
583sendEvent e = do
584 ShakeExtras{eventer} <- getShakeExtras
585 liftIO $ eventer e
587ideLogger :: IdeState -> Logger
588ideLogger IdeState{shakeExtras=ShakeExtras{logger}} = logger
590actionLogger :: Action Logger
591actionLogger = do
592 ShakeExtras{logger} <- getShakeExtras
593 return logger
596data GetModificationTime = GetModificationTime
597 deriving (Eq, Show, Generic)
598instance Hashable GetModificationTime
599instance NFData GetModificationTime
601-- | Get the modification time of a file.
602type instance RuleResult GetModificationTime = FileVersion
604-- | We store the modification time as a ByteString since we need
605-- a ByteString anyway for Shake and we do not care about how times
606-- are represented.
607data FileVersion = VFSVersion Int | ModificationTime BS.ByteString
608 deriving (Show, Generic)
610instance NFData FileVersion
612vfsVersion :: FileVersion -> Maybe Int
613vfsVersion (VFSVersion i) = Just i
614vfsVersion (ModificationTime _) = Nothing
618getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
619getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
622-- | Sets the diagnostics for a file and compilation step
623-- if you want to clear the diagnostics call this with an empty list
624setStageDiagnostics
625 :: NormalizedFilePath
626 -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited
627 -> T.Text
628 -> [LSP.Diagnostic]
629 -> DiagnosticStore
630 -> DiagnosticStore
631setStageDiagnostics fp timeM stage diags ds =
632 updateDiagnostics ds uri timeM diagsBySource
633 where
634 diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
635 uri = filePathToUri' fp
637getAllDiagnostics ::
638 DiagnosticStore ->
639 [FileDiagnostic]
640getAllDiagnostics =
641 concatMap (\(k,v) -> map (fromUri k,) $ getDiagnosticsFromStore v) . Map.toList
643getFileDiagnostics ::
644 NormalizedFilePath ->
645 DiagnosticStore ->
646 [LSP.Diagnostic]
647getFileDiagnostics fp ds =
648 maybe [] getDiagnosticsFromStore $
649 Map.lookup (filePathToUri' fp) ds
651filterDiagnostics ::
652 (NormalizedFilePath -> Bool) ->
653 DiagnosticStore ->
654 DiagnosticStore
655filterDiagnostics keep =
656 Map.filterWithKey (\uri _ -> maybe True (keep . toNormalizedFilePath) $ uriToFilePath' $ fromNormalizedUri uri)
658filterVersionMap
659 :: Map NormalizedUri (Set.Set TextDocumentVersion)
660 -> Map NormalizedUri (Map TextDocumentVersion a)
661 -> Map NormalizedUri (Map TextDocumentVersion a)
662filterVersionMap =
663 Map.merge Map.dropMissing Map.dropMissing $
664 Map.zipWithMatched $ \_ versionsToKeep versionMap -> Map.restrictKeys versionMap versionsToKeep
666updatePositionMapping :: IdeState -> VersionedTextDocumentIdentifier -> List TextDocumentContentChangeEvent -> IO ()
667updatePositionMapping IdeState{shakeExtras = ShakeExtras{positionMapping}} VersionedTextDocumentIdentifier{..} changes = do
668 modifyVar_ positionMapping $ \allMappings -> do
669 let uri = toNormalizedUri _uri
670 let mappingForUri = Map.findWithDefault Map.empty uri allMappings
671 let updatedMapping =
672 Map.insert _version idMapping $
673 Map.map (\oldMapping -> foldl' applyChange oldMapping changes) mappingForUri
674 pure $! Map.insert uri updatedMapping allMappings