Report progress when setting up cradle

exe/Main.hs

@@ -119,7 +119,7 @@ main = do
         t <- offsetTime
         hPutStrLn stderr "Starting LSP server..."
         hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!"
-        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps -> do
+        runLanguageServer options (pluginHandler plugins) onInitialConfiguration onConfigurationChange $ \getLspId event vfs caps wProg wIndefProg -> do
             t <- t
             hPutStrLn stderr $ "Started LSP server in " ++ showDuration t
             let options = (defaultIdeOptions $ loadSessionShake dir)
@@ -130,7 +130,7 @@ main = do
                     }
             debouncer <- newAsyncDebouncer
             initialise caps (mainRule >> pluginRules plugins)
-                getLspId event (logger minBound) debouncer options vfs
+                getLspId event wProg wIndefProg (logger minBound) debouncer options vfs
     else do
         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
         hSetEncoding stdout utf8
@@ -153,7 +153,8 @@ main = do
         putStrLn "\nStep 3/4: Initializing the IDE"
         vfs <- makeVFSHandle
         debouncer <- newAsyncDebouncer
-        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger minBound) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
+        let dummyWithProg _ _ f = f (const (pure ()))
+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger minBound) debouncer (defaultIdeOptions $ loadSessionShake dir) vfs
 
         putStrLn "\nStep 4/4: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
@@ -233,7 +234,7 @@ loadSessionShake fp = do
 -- components mapping to the same hie.yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
 loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))
-loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession} dir = do
+loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession, withIndefiniteProgress} dir = do
   -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
   hscEnvs <- newVar Map.empty :: IO (Var HieMap)
   -- Mapping from a Filepath to HscEnv
@@ -357,8 +358,14 @@ loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession} dir = d
           consultCradle hieYaml cfp = do
              when optTesting $ eventer $ notifyCradleLoaded cfp
              logInfo logger $ T.pack ("Consulting the cradle for " <> show cfp)
+
              cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle hieYaml
-             eopts <- cradleToSessionOpts cradle cfp
+             -- Display a user friendly progress message here: They probably don't know what a
+             -- cradle is
+             let progMsg = "Setting up project " <> T.pack (takeBaseName (cradleRootDir cradle))
+             eopts <- withIndefiniteProgress progMsg LSP.NotCancellable $
+               cradleToSessionOpts cradle cfp
+
              logDebug logger $ T.pack ("Session loading result: " <> show eopts)
              case eopts of
                -- The cradle gave us some options so get to work turning them

src/Development/IDE/Core/Service.hs

@@ -3,6 +3,7 @@
 
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
 
 -- | A Shake implementation of the compiler service, built
 --   using the "Shaker" abstraction layer for in-memory use.
@@ -45,15 +46,19 @@ initialise :: LSP.ClientCapabilities
            -> Rules ()
            -> IO LSP.LspId
            -> (LSP.FromServerMessage -> IO ())
+           -> WithProgressFunc
+           -> WithIndefiniteProgressFunc
            -> Logger
            -> Debouncer LSP.NormalizedUri
            -> IdeOptions
            -> VFSHandle
            -> IO IdeState
-initialise caps mainRule getLspId toDiags logger debouncer options vfs =
+initialise caps mainRule getLspId toDiags wProg wIndefProg logger debouncer options vfs =
     shakeOpen
         getLspId
         toDiags
+        wProg
+        wIndefProg
         logger
         debouncer
         (optShakeProfiling options)

src/Development/IDE/Core/Shake.hs

@@ -44,6 +44,7 @@ module Development.IDE.Core.Shake(
     updatePositionMapping,
     deleteValue,
     OnDiskRule(..),
+    WithProgressFunc, WithIndefiniteProgressFunc
     ) where
 
 import           Development.Shake hiding (ShakeValue, doesFileExist)
@@ -78,6 +79,7 @@ import           Control.DeepSeq
 import           Control.Exception.Extra
 import           System.Time.Extra
 import           Data.Typeable
+import qualified Language.Haskell.LSP.Core as LSP
 import qualified Language.Haskell.LSP.Messages as LSP
 import qualified Language.Haskell.LSP.Types as LSP
 import           System.FilePath hiding (makeRelative)
@@ -117,8 +119,17 @@ data ShakeExtras = ShakeExtras
     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
     ,restartShakeSession :: [Action ()] -> IO ()
     -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component
+    ,withProgress           :: WithProgressFunc
+    -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress')
+    ,withIndefiniteProgress :: WithIndefiniteProgressFunc
+    -- ^ Same as 'withProgress', but for processes that do not report the percentage complete
     }
 
+type WithProgressFunc = forall a.
+    T.Text -> LSP.ProgressCancellable -> ((LSP.Progress -> IO ()) -> IO a) -> IO a
+type WithIndefiniteProgressFunc = forall a.
+    T.Text -> LSP.ProgressCancellable -> IO a -> IO a
+
 getShakeExtras :: Action ShakeExtras
 getShakeExtras = do
     Just x <- getShakeExtra @ShakeExtras
@@ -311,6 +322,8 @@ seqValue v b = case v of
 -- | Open a 'IdeState', should be shut using 'shakeShut'.
 shakeOpen :: IO LSP.LspId
           -> (LSP.FromServerMessage -> IO ()) -- ^ diagnostic handler
+          -> WithProgressFunc
+          -> WithIndefiniteProgressFunc
           -> Logger
           -> Debouncer NormalizedUri
           -> Maybe FilePath
@@ -319,7 +332,9 @@ shakeOpen :: IO LSP.LspId
           -> ShakeOptions
           -> Rules ()
           -> IO IdeState
-shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting opts rules = mdo
+shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
+  shakeProfileDir (IdeReportProgress reportProgress) ideTesting opts rules = mdo
+
     inProgress <- newVar HMap.empty
     shakeExtras <- do
         globals <- newVar HMap.empty
@@ -617,22 +632,14 @@ usesWithStale key files = do
     zipWithM lastValue files values
 
 
-withProgress :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
-withProgress var file = actionBracket (f succ) (const $ f pred) . const
-    -- This functions are deliberately eta-expanded to avoid space leaks.
-    -- Do not remove the eta-expansion without profiling a session with at
-    -- least 1000 modifications.
-    where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x
-
-
 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, inProgress} <- getShakeExtras
     -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
-    (if show key == "GetFileExists" then id else withProgress inProgress file) $ do
+    (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do
         val <- case old of
             Just old | mode == RunDependenciesSame -> do
                 v <- liftIO $ getValues state key file
@@ -671,6 +678,15 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
                     (encodeShakeValue bs) $
                     A res
+  where
+    withProgressVar :: (Eq a, Hashable a) => Var (HMap.HashMap a Int) -> a -> Action b -> Action b
+    withProgressVar var file = actionBracket (f succ) (const $ f pred) . const
+        -- This functions are deliberately eta-expanded to avoid space leaks.
+        -- Do not remove the eta-expansion without profiling a session with at
+        -- least 1000 modifications.
+        where f shift = modifyVar_ var $ \x -> evaluate $ HMap.alter (\x -> Just $! shift (fromMaybe 0 x)) file x
+
+
 
 
 -- | Rule type, input file

src/Development/IDE/LSP/LanguageServer.hs

@@ -2,6 +2,7 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE RankNTypes                 #-}
 
 -- WARNING: A copy of DA.Daml.LanguageServer, try to keep them in sync
 -- This version removes the daml: handling
@@ -44,7 +45,8 @@ runLanguageServer
     -> PartialHandlers config
     -> (InitializeRequest -> Either T.Text config)
     -> (DidChangeConfigurationNotification -> Either T.Text config)
-    -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities -> IO IdeState)
+    -> (IO LspId -> (FromServerMessage -> IO ()) -> VFSHandle -> ClientCapabilities
+        -> WithProgressFunc -> WithIndefiniteProgressFunc -> IO IdeState)
     -> IO ()
 runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeState = do
     -- Move stdout to another file descriptor and duplicate stderr
@@ -131,6 +133,7 @@ runLanguageServer options userHandlers onInitialConfig onConfigChange getIdeStat
         handleInit exitClientMsg clearReqId waitForCancel clientMsgChan [email protected]{..} = do
 
             ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
+                               withProgress withIndefiniteProgress
 
             _ <- flip forkFinally (const exitClientMsg) $ forever $ do
                 msg <- readChan clientMsgChan