Skip to content

Commit 71631d8

Browse files
authored
Report progress when setting up cradle (#644)
To do this we pass in the withProgress and withIndefiniteProgress functions from LspFuncs into ShakeExtras
1 parent 0ddc62f commit 71631d8

File tree

4 files changed

+48
-17
lines changed

4 files changed

+48
-17
lines changed

exe/Main.hs

Lines changed: 12 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -119,7 +119,7 @@ main = do
119119
t <- offsetTime
120120
hPutStrLn stderr "Starting LSP server..."
121121
hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
122-
runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
122+
runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg -> do
123123
t <- t
124124
hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
125125
let options = (defaultIdeOptions $ loadSessionShake dir)
@@ -130,7 +130,7 @@ main = do
130130
}
131131
debouncer <- newAsyncDebouncer
132132
initialise caps (mainRule >> pluginRules plugins)
133-
getLspId event (logger minBound) debouncer options vfs
133+
getLspId event wProg wIndefProg (logger minBound) debouncer options vfs
134134
else do
135135
-- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
136136
hSetEncoding stdout utf8
@@ -153,7 +153,8 @@ main = do
153153
putStrLn "\nStep 3/4: Initializing the IDE"
154154
vfs <- makeVFSHandle
155155
debouncer <- newAsyncDebouncer
156-
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger minBound) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
156+
let dummyWithProg _ _ f = f (const (pure ()))
157+
ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger minBound) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
157158

158159
putStrLn "\nStep 4/4: Type checking the files"
159160
setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
@@ -233,7 +234,7 @@ loadSessionShake fp = do
233234
-- components mapping to the same hie.yaml file are mapped to the same
234235
-- HscEnv which is updated as new components are discovered.
235236
loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))
236-
loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession} dir = do
237+
loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress} dir = do
237238
-- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
238239
hscEnvs <- newVar Map.empty :: IO (Var HieMap)
239240
-- Mapping from a Filepath to HscEnv
@@ -357,8 +358,14 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession} dir = d
357358
consultCradle hieYaml cfp = do
358359
when optTesting $ eventer $ notifyCradleLoaded cfp
359360
logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)
361+
360362
cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
361-
eopts <- cradleToSessionOpts cradle cfp
363+
-- Display a user friendly progress message here: They probably don't know what a
364+
-- cradle is
365+
let progMsg = "Setting up project " <> T.pack (takeBaseName (cradleRootDir cradle))
366+
eopts <- withIndefiniteProgress progMsg LSP.NotCancellable $
367+
cradleToSessionOpts cradle cfp
368+
362369
logDebug logger $ T.pack ("Session loading result: " <> show eopts)
363370
case eopts of
364371
-- The cradle gave us some options so get to work turning them

src/Development/IDE/Core/Service.hs

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@
33

44
{-# LANGUAGE TypeFamilies #-}
55
{-# LANGUAGE FlexibleInstances #-}
6+
{-# LANGUAGE RankNTypes #-}
67

78
-- | A Shake implementation of the compiler service, built
89
-- using the "Shaker" abstraction layer for in-memory use.
@@ -45,15 +46,19 @@ initialise :: LSP.ClientCapabilities
4546
-> Rules ()
4647
-> IO LSP.LspId
4748
-> (LSP.FromServerMessage -> IO ())
49+
-> WithProgressFunc
50+
-> WithIndefiniteProgressFunc
4851
-> Logger
4952
-> Debouncer LSP.NormalizedUri
5053
-> IdeOptions
5154
-> VFSHandle
5255
-> IO IdeState
53-
initialise caps mainRule getLspId toDiags logger debouncer options vfs =
56+
initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs =
5457
shakeOpen
5558
getLspId
5659
toDiags
60+
wProg
61+
wIndefProg
5762
logger
5863
debouncer
5964
(optShakeProfiling options)

src/Development/IDE/Core/Shake.hs

Lines changed: 26 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -44,6 +44,7 @@ module Development.IDE.Core.Shake(
4444
updatePositionMapping,
4545
deleteValue,
4646
OnDiskRule(..),
47+
WithProgressFunc, WithIndefiniteProgressFunc
4748
) where
4849

4950
import Development.Shake hiding (ShakeValue, doesFileExist)
@@ -78,6 +79,7 @@ import Control.DeepSeq
7879
import Control.Exception.Extra
7980
import System.Time.Extra
8081
import Data.Typeable
82+
import qualified Language.Haskell.LSP.Core as LSP
8183
import qualified Language.Haskell.LSP.Messages as LSP
8284
import qualified Language.Haskell.LSP.Types as LSP
8385
import System.FilePath hiding (makeRelative)
@@ -117,8 +119,17 @@ data ShakeExtras = ShakeExtras
117119
-- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
118120
,restartShakeSession :: [Action ()] -> IO ()
119121
-- ^ 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
120126
}
121127

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+
122133
getShakeExtras :: Action ShakeExtras
123134
getShakeExtras = do
124135
Just x <- getShakeExtra @ShakeExtras
@@ -311,6 +322,8 @@ seqValue v b = case v of
311322
-- | Open a 'IdeState', should be shut using 'shakeShut'.
312323
shakeOpen :: IO LSP.LspId
313324
-> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
325+
-> WithProgressFunc
326+
-> WithIndefiniteProgressFunc
314327
-> Logger
315328
-> Debouncer NormalizedUri
316329
-> Maybe FilePath
@@ -319,7 +332,9 @@ shakeOpen :: IO LSP.LspId
319332
-> ShakeOptions
320333
-> Rules ()
321334
-> 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+
323338
inProgress <- newVar HMap.empty
324339
shakeExtras <- do
325340
globals <- newVar HMap.empty
@@ -624,22 +639,14 @@ usesWithStale key files = do
624639
zipWithM lastValue files values
625640

626641

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-
635642
defineEarlyCutoff
636643
:: IdeRule k v
637644
=> (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
638645
-> Rules ()
639646
defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> do
640647
extras@ShakeExtras{state, inProgress} <- getShakeExtras
641648
-- 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
643650
val <- case old of
644651
Just old | mode == RunDependenciesSame -> do
645652
v <- liftIO $ getValues state key file
@@ -678,6 +685,15 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
678685
(if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
679686
(encodeShakeValue bs) $
680687
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+
681697

682698

683699
-- | Rule type, input file

src/Development/IDE/LSP/LanguageServer.hs

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
-- SPDX-License-Identifier: Apache-2.0
33

44
{-# LANGUAGE ExistentialQuantification #-}
5+
{-# LANGUAGE RankNTypes #-}
56

67
-- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync
78
-- This version removes the daml: handling
@@ -44,7 +45,8 @@ runLanguageServer
4445
-> PartialHandlers config
4546
-> (InitializeRequest -> Either T.Text config)
4647
-> (DidChangeConfigurationNotification -> Either T.Text config)
47-
-> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
48+
-> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities
49+
-> WithProgressFunc -> WithIndefiniteProgressFunc -> IO IdeState)
4850
-> IO ()
4951
runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do
5052
-- Move stdout to another file descriptor and duplicate stderr
@@ -131,6 +133,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
131133
handleInit exitClientMsg clearReqId waitForCancel clientMsgChan lspFuncs@LSP.LspFuncs{..} = do
132134

133135
ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
136+
withProgress withIndefiniteProgress
134137

135138
_ <- flip forkFinally (const exitClientMsg) $ forever $ do
136139
msg <- readChan clientMsgChan

0 commit comments

Comments
 (0)