mirror of
https://github.com/haskell/ghcide.git
synced 2024-09-11 05:36:09 +03:00
Report progress when setting up cradle (#644)
To do this we pass in the withProgress and withIndefiniteProgress functions from LspFuncs into ShakeExtras
This commit is contained in:
parent
0ddc62fb96
commit
71631d8e8f
17
exe/Main.hs
17
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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
@ -624,14 +639,6 @@ 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))
|
||||
@ -639,7 +646,7 @@ defineEarlyCutoff
|
||||
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
|
||||
@ -678,6 +685,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
|
||||
|
@ -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 lspFuncs@LSP.LspFuncs{..} = do
|
||||
|
||||
ide <- getIdeState getNextReqId sendFunc (makeLSPVFSHandle lspFuncs) clientCapabilities
|
||||
withProgress withIndefiniteProgress
|
||||
|
||||
_ <- flip forkFinally (const exitClientMsg) $ forever $ do
|
||||
msg <- readChan clientMsgChan
|
||||
|
Loading…
Reference in New Issue
Block a user