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