Merge pull request haskell#1523 from bubba/remove-maybe-in-lspfuncs

Change Maybe LspFuncs to LspFuncs inside IdeEnv

Author: lukel97

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

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)
-     -- ^ The LspFuncs provided by haskell-lsp, if using LSP.
+  -> Core.LspFuncs Config
+      -- ^ The LspFuncs provided by haskell-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
 
 

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)
             ))

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)

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

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
+                         }