From 7e4a288397c9448bd764dbb92b785ee214d8d155 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 29 Dec 2019 21:49:08 +0000 Subject: [PATCH 1/2] Change Maybe LspFuncs -> LspFuncs inside IdeEnv Now that its not possible to *not* have LspFuncs since the only transport is LSP --- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 60 ++++++------------- src/Haskell/Ide/Engine/Scheduler.hs | 10 ++-- src/Haskell/Ide/Engine/Server.hs | 2 +- test/dispatcher/Main.hs | 3 +- test/plugin-dispatcher/Main.hs | 3 +- test/utils/TestUtils.hs | 29 +++++++-- 6 files changed, 50 insertions(+), 57 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index a7d293d9d..ce01a0f77 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -344,9 +344,9 @@ getDiagnosticProvidersConfig c = Map.fromList [("applyrefact",hlintOn c) type IdeGhcM = GhcT IdeM -- | Run an IdeGhcM with Cradle found from the current directory -runIdeGhcM :: Maybe FilePath -> IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a -runIdeGhcM mlibdir plugins mlf stateVar f = do - env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins +runIdeGhcM :: Maybe FilePath -> IdePlugins -> Core.LspFuncs Config -> TVar IdeState -> IdeGhcM a -> IO a +runIdeGhcM mlibdir plugins lf stateVar f = do + env <- IdeEnv <$> pure lf <*> getProcessID <*> pure plugins flip runReaderT stateVar $ flip runReaderT env $ runGhcT mlibdir f -- | A computation that is deferred until the module is cached. @@ -357,14 +357,14 @@ type IdeDeferM = FreeT Defer IdeM type IdeM = ReaderT IdeEnv (MultiThreadState IdeState) -- | Run an IdeM -runIdeM :: IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeM a -> IO a -runIdeM plugins mlf stateVar f = do - env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins +runIdeM :: IdePlugins -> Core.LspFuncs Config -> TVar IdeState -> IdeM a -> IO a +runIdeM plugins lf stateVar f = do + env <- IdeEnv <$> pure lf <*> getProcessID <*> pure plugins -- TODO: AZ run a single ReaderT, with a composite R. flip runReaderT stateVar $ runReaderT f env data IdeEnv = IdeEnv - { ideEnvLspFuncs :: Maybe (Core.LspFuncs Config) + { ideEnvLspFuncs :: Core.LspFuncs Config -- | The pid of this instance of hie , ideEnvPidCache :: Int , idePlugins :: IdePlugins @@ -384,18 +384,12 @@ instance MonadIde IdeGhcM where getIdeEnv = lift ask getRootPath :: MonadIde m => m (Maybe FilePath) -getRootPath = do - mlf <- ideEnvLspFuncs <$> getIdeEnv - case mlf of - Just lf -> return (Core.rootPath lf) - Nothing -> return Nothing +getRootPath = Core.rootPath . ideEnvLspFuncs <$> getIdeEnv getVirtualFile :: (MonadIde m, MonadIO m) => Uri -> m (Maybe VirtualFile) getVirtualFile uri = do - mlf <- ideEnvLspFuncs <$> getIdeEnv - case mlf of - Just lf -> liftIO $ Core.getVirtualFileFunc lf (toNormalizedUri uri) - Nothing -> return Nothing + lf <- ideEnvLspFuncs <$> getIdeEnv + liftIO $ Core.getVirtualFileFunc lf (toNormalizedUri uri) -- | Worker function for persistVirtualFile without monad constraints. -- @@ -407,19 +401,15 @@ persistVirtualFile' lf uri = Core.persistVirtualFileFunc lf (toNormalizedUri uri reverseFileMap :: (MonadIde m, MonadIO m) => m (FilePath -> FilePath) reverseFileMap = do - mlf <- ideEnvLspFuncs <$> getIdeEnv - case mlf of - Just lf -> liftIO $ Core.reverseFileMapFunc lf - Nothing -> return id + lf <- ideEnvLspFuncs <$> getIdeEnv + liftIO $ Core.reverseFileMapFunc lf -- | Get the location of the virtual file persisted to the file system associated -- to the given Uri. getPersistedFile :: (MonadIde m, MonadIO m) => Uri -> m (Maybe FilePath) getPersistedFile uri = do - mlf <- ideEnvLspFuncs <$> getIdeEnv - case mlf of - Just lf -> liftIO $ persistVirtualFile' lf uri - Nothing -> return $ uriToFilePath uri + lf <- ideEnvLspFuncs <$> getIdeEnv + liftIO $ persistVirtualFile' lf uri -- | Execute an action on the temporary file associated to the given FilePath. -- If the file is not in the current Virtual File System, the given action is not executed @@ -433,17 +423,11 @@ withMappedFile fp m k = do getConfig :: (MonadIde m, MonadIO m) => m Config getConfig = do - mlf <- ideEnvLspFuncs <$> getIdeEnv - case mlf of - Just lf -> fromMaybe def <$> liftIO (Core.config lf) - Nothing -> return def + lf <- ideEnvLspFuncs <$> getIdeEnv + fromMaybe def <$> liftIO (Core.config lf) getClientCapabilities :: MonadIde m => m ClientCapabilities -getClientCapabilities = do - mlf <- ideEnvLspFuncs <$> getIdeEnv - case mlf of - Just lf -> return (Core.clientCapabilities lf) - Nothing -> return def +getClientCapabilities = Core.clientCapabilities . ideEnvLspFuncs <$> getIdeEnv getPlugins :: MonadIde m => m IdePlugins getPlugins = idePlugins <$> getIdeEnv @@ -456,10 +440,7 @@ withProgress :: (MonadIde m , MonadIO m, MonadBaseControl IO m) -> ((Core.Progress -> IO ()) -> m a) -> m a withProgress t c f = do lf <- ideEnvLspFuncs <$> getIdeEnv - let mWp = Core.withProgress <$> lf - case mWp of - Nothing -> f (const $ return ()) - Just wp -> control $ \run -> wp t c $ \update -> run (f update) + control $ \run -> Core.withProgress lf t c $ \update -> run (f update) -- | 'withIndefiniteProgress' @title cancellable f@ is the same as the 'withProgress' but for tasks @@ -468,10 +449,7 @@ withIndefiniteProgress :: (MonadIde m, MonadBaseControl IO m) => T.Text -> Core.ProgressCancellable -> m a -> m a withIndefiniteProgress t c f = do lf <- ideEnvLspFuncs <$> getIdeEnv - let mWp = Core.withIndefiniteProgress <$> lf - case mWp of - Nothing -> f - Just wp -> control $ \run -> wp t c (run f) + control $ \run -> Core.withIndefiniteProgress lf t c (run f) data IdeState = IdeState { moduleCache :: !GhcModuleCache diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index ec2d59b52..f156e733a 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -143,13 +143,13 @@ runScheduler -- ^ A handler for any errors that the dispatcher may encounter. -> CallbackHandler m -- ^ A handler to run the requests' callback in your monad of choosing. - -> Maybe (Core.LspFuncs Config) + -> Core.LspFuncs Config -- ^ The LspFuncs provided by haskell-lsp, if using LSP. -> Maybe Bios.Cradle -- ^ Context in which the ghc thread is executed. -- Neccessary to obtain the libdir, for example. -> IO () -runScheduler Scheduler {..} errorHandler callbackHandler mlf mcrdl = do +runScheduler Scheduler {..} errorHandler callbackHandler lf mcradle = do let dEnv = DispatcherEnv { cancelReqsTVar = requestsToCancel , wipReqsTVar = requestsInProgress @@ -163,13 +163,13 @@ runScheduler Scheduler {..} errorHandler callbackHandler mlf mcrdl = do stateVar <- STM.newTVarIO initialState - mlibdir <- case mcrdl of + mlibdir <- case mcradle of Nothing -> return Nothing Just crdl -> Bios.getProjectGhcLibDir crdl - let runGhcDisp = runIdeGhcM mlibdir plugins mlf stateVar $ + let runGhcDisp = runIdeGhcM mlibdir plugins lf stateVar $ ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut - runIdeDisp = runIdeM plugins mlf stateVar $ + runIdeDisp = runIdeM plugins lf stateVar $ ideDispatcher dEnv errorHandler callbackHandler ideChanOut diff --git a/src/Haskell/Ide/Engine/Server.hs b/src/Haskell/Ide/Engine/Server.hs index c8f11f8f0..b6407d5f1 100644 --- a/src/Haskell/Ide/Engine/Server.hs +++ b/src/Haskell/Ide/Engine/Server.hs @@ -193,7 +193,7 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do -- recognized properly by ghc-mod flip labelThread "scheduler" =<< (forkIO ( - Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf) mcradle + Scheduler.runScheduler scheduler errorHandler callbackHandler lf mcradle `E.catch` \(e :: E.SomeException) -> (errorm $ "Scheduler thread exited unexpectedly: " ++ show e) )) diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index 712d296c7..bf80d3cbb 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -10,7 +10,6 @@ import Data.Aeson -- import qualified Data.HashMap.Strict as H import Data.Typeable import qualified Data.Text as T -import Data.Default import GHC ( TypecheckedModule ) import GHC.Generics import Haskell.Ide.Engine.Ghc @@ -81,7 +80,7 @@ startServer = do scheduler (\lid errCode e -> logToChan logChan ("received an error", Left (lid, errCode, e))) (\g x -> g x) - def + dummyLspFuncs (Just crdl) return (scheduler, logChan, dispatcher) diff --git a/test/plugin-dispatcher/Main.hs b/test/plugin-dispatcher/Main.hs index 8367c4669..4f725f82b 100644 --- a/test/plugin-dispatcher/Main.hs +++ b/test/plugin-dispatcher/Main.hs @@ -6,7 +6,6 @@ import Control.Concurrent import Control.Concurrent.STM.TChan import Control.Monad.STM import qualified Data.Text as T -import Data.Default import qualified Haskell.Ide.Engine.Cradle as Bios import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.Scheduler @@ -51,7 +50,7 @@ newPluginSpec = do pid <- forkIO $ runScheduler scheduler (\_ _ _ -> return ()) (\f x -> f x) - def + dummyLspFuncs (Just crdl) updateDocument scheduler (filePathToUri "test") 3 diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index cf5f9d6c1..60abd02ee 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -16,21 +16,22 @@ module TestUtils , getHspecFormattedConfig , testOptions , flushStackEnvironment + , dummyLspFuncs ) where import Control.Concurrent.STM import Control.Monad import Data.Aeson.Types (typeMismatch) +import Data.Default import Data.List (intercalate) import Data.Text (pack) import Data.Typeable import Data.Yaml import qualified Data.Map as Map import Data.Maybe --- import qualified GhcMod.Monad as GM --- import qualified GhcMod.Types as GM -import qualified Language.Haskell.LSP.Core as Core -import Haskell.Ide.Engine.MonadTypes +import Language.Haskell.LSP.Core +import Language.Haskell.LSP.Types (LspId(IdInt), fromNormalizedUri) +import Haskell.Ide.Engine.MonadTypes hiding (withProgress, withIndefiniteProgress) import qualified Haskell.Ide.Engine.Cradle as Bios import System.Directory import System.Environment @@ -77,7 +78,7 @@ runIGM testPlugins fp f = do stateVar <- newTVarIO $ IdeState emptyModuleCache Map.empty Map.empty Nothing crdl <- Bios.findLocalCradle fp mlibdir <- Bios.getProjectGhcLibDir crdl - runIdeGhcM mlibdir testPlugins Nothing stateVar f + runIdeGhcM mlibdir testPlugins dummyLspFuncs stateVar f withFileLogging :: FilePath -> IO a -> IO a withFileLogging logFile f = do @@ -90,7 +91,7 @@ withFileLogging logFile f = do exists <- doesFileExist logPath when exists $ removeFile logPath - Core.setupLogger (Just logPath) ["hie"] L.DEBUG + setupLogger (Just logPath) ["hie"] L.DEBUG f @@ -374,3 +375,19 @@ flushStackEnvironment = do unsetEnv "HASKELL_PACKAGE_SANDBOXES" -- --------------------------------------------------------------------- + +dummyLspFuncs :: Default a => LspFuncs a +dummyLspFuncs = LspFuncs { clientCapabilities = def + , config = return (Just def) + , sendFunc = const (return ()) + , getVirtualFileFunc = const (return Nothing) + , persistVirtualFileFunc = \uri -> return (uriToFilePath (fromNormalizedUri uri)) + , reverseFileMapFunc = return id + , publishDiagnosticsFunc = mempty + , flushDiagnosticsBySourceFunc = mempty + , getNextReqId = pure (IdInt 0) + , rootPath = Nothing + , getWorkspaceFolders = return Nothing + , withProgress = \_ _ f -> f (const (return ())) + , withIndefiniteProgress = \_ _ f -> f + } From 2ba1085084a3e0f020ce313a558ea98cf06ad437 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 29 Dec 2019 22:02:03 +0000 Subject: [PATCH 2/2] Fix comment --- src/Haskell/Ide/Engine/Scheduler.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index f156e733a..392d852aa 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -144,7 +144,7 @@ runScheduler -> CallbackHandler m -- ^ A handler to run the requests' callback in your monad of choosing. -> Core.LspFuncs Config - -- ^ The LspFuncs provided by haskell-lsp, if using LSP. + -- ^ The LspFuncs provided by haskell-lsp. -> Maybe Bios.Cradle -- ^ Context in which the ghc thread is executed. -- Neccessary to obtain the libdir, for example.