@@ -44,6 +44,7 @@ module Development.IDE.Core.Shake(
44
44
updatePositionMapping ,
45
45
deleteValue ,
46
46
OnDiskRule (.. ),
47
+ WithProgressFunc , WithIndefiniteProgressFunc
47
48
) where
48
49
49
50
import Development.Shake hiding (ShakeValue , doesFileExist )
@@ -78,6 +79,7 @@ import Control.DeepSeq
78
79
import Control.Exception.Extra
79
80
import System.Time.Extra
80
81
import Data.Typeable
82
+ import qualified Language.Haskell.LSP.Core as LSP
81
83
import qualified Language.Haskell.LSP.Messages as LSP
82
84
import qualified Language.Haskell.LSP.Types as LSP
83
85
import System.FilePath hiding (makeRelative )
@@ -117,8 +119,17 @@ data ShakeExtras = ShakeExtras
117
119
-- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
118
120
,restartShakeSession :: [Action () ] -> IO ()
119
121
-- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component
122
+ ,withProgress :: WithProgressFunc
123
+ -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress')
124
+ ,withIndefiniteProgress :: WithIndefiniteProgressFunc
125
+ -- ^ Same as 'withProgress', but for processes that do not report the percentage complete
120
126
}
121
127
128
+ type WithProgressFunc = forall a .
129
+ T. Text -> LSP. ProgressCancellable -> ((LSP. Progress -> IO () ) -> IO a ) -> IO a
130
+ type WithIndefiniteProgressFunc = forall a .
131
+ T. Text -> LSP. ProgressCancellable -> IO a -> IO a
132
+
122
133
getShakeExtras :: Action ShakeExtras
123
134
getShakeExtras = do
124
135
Just x <- getShakeExtra @ ShakeExtras
@@ -311,6 +322,8 @@ seqValue v b = case v of
311
322
-- | Open a 'IdeState', should be shut using 'shakeShut'.
312
323
shakeOpen :: IO LSP. LspId
313
324
-> (LSP. FromServerMessage -> IO () ) -- ^ diagnostic handler
325
+ -> WithProgressFunc
326
+ -> WithIndefiniteProgressFunc
314
327
-> Logger
315
328
-> Debouncer NormalizedUri
316
329
-> Maybe FilePath
@@ -319,7 +332,9 @@ shakeOpen :: IO LSP.LspId
319
332
-> ShakeOptions
320
333
-> Rules ()
321
334
-> IO IdeState
322
- shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting opts rules = mdo
335
+ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
336
+ shakeProfileDir (IdeReportProgress reportProgress) ideTesting opts rules = mdo
337
+
323
338
inProgress <- newVar HMap. empty
324
339
shakeExtras <- do
325
340
globals <- newVar HMap. empty
@@ -624,22 +639,14 @@ usesWithStale key files = do
624
639
zipWithM lastValue files values
625
640
626
641
627
- withProgress :: (Eq a , Hashable a ) => Var (HMap. HashMap a Int ) -> a -> Action b -> Action b
628
- withProgress var file = actionBracket (f succ ) (const $ f pred ) . const
629
- -- This functions are deliberately eta-expanded to avoid space leaks.
630
- -- Do not remove the eta-expansion without profiling a session with at
631
- -- least 1000 modifications.
632
- where f shift = modifyVar_ var $ \ x -> evaluate $ HMap. alter (\ x -> Just $! shift (fromMaybe 0 x)) file x
633
-
634
-
635
642
defineEarlyCutoff
636
643
:: IdeRule k v
637
644
=> (k -> NormalizedFilePath -> Action (Maybe BS. ByteString , IdeResult v ))
638
645
-> Rules ()
639
646
defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \ (Q (key, file)) (old :: Maybe BS. ByteString ) mode -> do
640
647
extras@ ShakeExtras {state, inProgress} <- getShakeExtras
641
648
-- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
642
- (if show key == " GetFileExists" then id else withProgress inProgress file) $ do
649
+ (if show key == " GetFileExists" then id else withProgressVar inProgress file) $ do
643
650
val <- case old of
644
651
Just old | mode == RunDependenciesSame -> do
645
652
v <- liftIO $ getValues state key file
@@ -678,6 +685,15 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
678
685
(if eq then ChangedRecomputeSame else ChangedRecomputeDiff )
679
686
(encodeShakeValue bs) $
680
687
A res
688
+ where
689
+ withProgressVar :: (Eq a , Hashable a ) => Var (HMap. HashMap a Int ) -> a -> Action b -> Action b
690
+ withProgressVar var file = actionBracket (f succ ) (const $ f pred ) . const
691
+ -- This functions are deliberately eta-expanded to avoid space leaks.
692
+ -- Do not remove the eta-expansion without profiling a session with at
693
+ -- least 1000 modifications.
694
+ where f shift = modifyVar_ var $ \ x -> evaluate $ HMap. alter (\ x -> Just $! shift (fromMaybe 0 x)) file x
695
+
696
+
681
697
682
698
683
699
-- | Rule type, input file
0 commit comments