From ae666a19a970531166f21d26fc6988e100d11c8e Mon Sep 17 00:00:00 2001 From: Gurkenglas Date: Tue, 31 Jul 2018 21:40:23 +0200 Subject: [PATCH 1/8] WIP on #725 --- src/Haskell/Ide/Engine/Plugin/GhcMod.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs index c03d8c6c4..559ed415b 100644 --- a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs +++ b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs @@ -388,7 +388,7 @@ codeActionProvider docId _ _ context = renameActions = map (uncurry mkRenamableAction) terms redundantTerms = mapMaybe getRedundantImports diags redundantActions = concatMap (uncurry mkRedundantImportActions) redundantTerms - in return $ IdeResponseOk (renameActions ++ redundantActions) + in return $ IdeResponseOk (renameActions ++ redundantActions ++ mapMaybe topLevelUnsigned diags) where docUri = docId ^. LSP.uri @@ -439,6 +439,16 @@ codeActionProvider docId _ _ context = getRedundantImports diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) = (diag,) <$> extractRedundantImport msg getRedundantImports _ = Nothing + topLevelUnsigned :: LSP.Diagnostic -> Maybe LSP.CodeAction + topLevelUnsigned diag@(LSP.Diagnostic _ _ _ (Just "ghcmod") msg _) + = T.stripPrefix "Top-level binding with no type signature:\n " msg + <&> \line -> LSP.CodeAction "Add type signature to top-level binding" + (Just LSP.CodeActionQuickFix) + (Just (LSP.List [diag])) + (Just $ mkWorkspaceEdit [LSP.TextEdit (views (LSP.range . LSP.start) (\s -> LSP.Range s s) diag) (line <> "\n")]) -- range might be off + Nothing + topLevelUnsigned _ = Nothing + extractRenamableTerms :: T.Text -> [T.Text] extractRenamableTerms msg | "Variable not in scope: " `T.isPrefixOf` head noBullets = mapMaybe extractReplacement replacementLines From 545e6738d920c3b8b76af9efd1bd0d40a951ac4d Mon Sep 17 00:00:00 2001 From: Gurkenglas Date: Mon, 6 Aug 2018 15:02:45 +0200 Subject: [PATCH 2/8] Put ~ExceptT and FreeT everywhere --- docs/Architecture.md | 2 +- haskell-ide-engine.cabal | 7 + .../Haskell/Ide/Engine/IdeFunctions.hs | 13 - .../Haskell/Ide/Engine/ModuleCache.hs | 43 ++- hie-plugin-api/Haskell/Ide/Engine/Monad.hs | 2 +- .../Haskell/Ide/Engine/MonadFunctions.hs | 20 +- .../Haskell/Ide/Engine/MultiThreadState.hs | 47 ++-- .../Haskell/Ide/Engine/PluginDescriptor.hs | 29 +- .../Haskell/Ide/Engine/PluginUtils.hs | 50 +--- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 258 +++++++----------- hie-plugin-api/hie-plugin-api.cabal | 5 +- src/Haskell/Ide/Engine/Dispatcher.hs | 86 +++--- src/Haskell/Ide/Engine/LSP/CodeActions.hs | 9 +- src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs | 59 ++-- src/Haskell/Ide/Engine/Plugin/Base.hs | 36 +-- src/Haskell/Ide/Engine/Plugin/Brittany.hs | 66 +++-- src/Haskell/Ide/Engine/Plugin/Build.hs | 57 ++-- src/Haskell/Ide/Engine/Plugin/Example2.hs | 4 +- src/Haskell/Ide/Engine/Plugin/GhcMod.hs | 159 ++++++----- src/Haskell/Ide/Engine/Plugin/HaRe.hs | 81 +++--- src/Haskell/Ide/Engine/Plugin/Haddock.hs | 3 +- src/Haskell/Ide/Engine/Plugin/HieExtras.hs | 174 ++++++------ src/Haskell/Ide/Engine/Plugin/Hoogle.hs | 36 +-- src/Haskell/Ide/Engine/Plugin/HsImport.hs | 55 ++-- src/Haskell/Ide/Engine/Plugin/Package.hs | 24 +- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 122 ++++----- src/Haskell/Ide/Engine/Types.hs | 8 +- stack.yaml | 1 + test/dispatcher/Main.hs | 20 +- test/unit/ApplyRefactPluginSpec.hs | 26 +- test/unit/BrittanySpec.hs | 8 +- test/unit/ExtensibleStateSpec.hs | 16 +- test/unit/GhcModPluginSpec.hs | 22 +- test/unit/HaRePluginSpec.hs | 96 +++---- test/unit/HooglePluginSpec.hs | 4 +- test/utils/TestUtils.hs | 18 +- 36 files changed, 728 insertions(+), 938 deletions(-) delete mode 100644 hie-plugin-api/Haskell/Ide/Engine/IdeFunctions.hs diff --git a/docs/Architecture.md b/docs/Architecture.md index e5d0572a5..2b9303f42 100644 --- a/docs/Architecture.md +++ b/docs/Architecture.md @@ -139,7 +139,7 @@ data GhcRequest m = forall a. GhcRequest , pinDocVer :: Maybe (J.Uri, Int) , pinLspReqId :: Maybe J.LspId , pinCallback :: RequestCallback m a - , pinReq :: IdeGhcM (IdeResult a) + , pinReq :: IDErring IdeGhcM a } data IdeRequest m = forall a. IdeRequest diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 75ffc0787..7407a3e1a 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -57,6 +57,7 @@ library , data-default , directory , filepath + , free , ghc >= 8.0.1 , ghc-exactprint , ghc-mod >= 5.9.0.0 @@ -72,6 +73,7 @@ library , hsimport , hslogger , lens >= 4.15.2 + , mmorph , monad-control , monoid-subclasses > 0.4 , mtl @@ -159,12 +161,14 @@ test-suite unit-test , containers , directory , filepath + , free , haskell-lsp , haskell-ide-engine -- , hie-test-utils , hie-plugin-api , hoogle > 5.0.11 , hspec + , mtl , quickcheck-instances , text , unordered-containers @@ -174,6 +178,7 @@ test-suite unit-test , hie-plugin-api , ghc-mod-core , hslogger + , mmorph , yaml ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints @@ -207,6 +212,7 @@ test-suite dispatcher-test , hie-plugin-api , ghc-mod-core , hslogger + , mmorph , unordered-containers , yaml ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints @@ -276,6 +282,7 @@ test-suite func-test , hie-plugin-api , ghc-mod-core , hslogger + , mmorph , unordered-containers , yaml , haskell-lsp diff --git a/hie-plugin-api/Haskell/Ide/Engine/IdeFunctions.hs b/hie-plugin-api/Haskell/Ide/Engine/IdeFunctions.hs deleted file mode 100644 index 682eb3f17..000000000 --- a/hie-plugin-api/Haskell/Ide/Engine/IdeFunctions.hs +++ /dev/null @@ -1,13 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} --- | Functions that act within the IdeGhcM monad - -module Haskell.Ide.Engine.IdeFunctions - ( - getPlugins - ) where - -import Haskell.Ide.Engine.MonadTypes - -getPlugins :: (MonadMTState IdeState m) => m IdePlugins -getPlugins = idePlugins <$> readMTS diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index 724184a9d..cd532d23d 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -1,11 +1,12 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TupleSections #-} module Haskell.Ide.Engine.ModuleCache where -import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control +import Control.Monad.State import qualified Data.Aeson as J import Data.Dynamic (toDyn, fromDynamic) import Data.Generics (Proxy(..), typeRep, typeOf) @@ -16,12 +17,13 @@ import Data.Typeable (Typeable) import Exception (ExceptionMonad) import System.Directory import System.FilePath +import Control.Lens +import Data.Foldable import qualified GhcMod.Cradle as GM import qualified GhcMod.Monad as GM import qualified GhcMod.Types as GM -import Haskell.Ide.Engine.MultiThreadState import Haskell.Ide.Engine.PluginsIdeMonads import Haskell.Ide.Engine.GhcModuleCache @@ -87,7 +89,7 @@ data CachedModuleResult = ModuleLoading type IsStale = Bool -- | looks up a CachedModule for a given URI -getCachedModule :: (GM.MonadIO m, HasGhcModuleCache m) +getCachedModule :: (MonadIO m, HasGhcModuleCache m) => FilePath -> m CachedModuleResult getCachedModule uri = do uri' <- liftIO $ canonicalizePath uri @@ -108,22 +110,20 @@ isCached uri = do -- | Version of `withCachedModuleAndData` that doesn't provide -- any extra cached data. -withCachedModule :: FilePath -> (CachedModule -> IdeM (IdeResponse b)) -> IdeM (IdeResponse b) +withCachedModule :: FilePath -> (CachedModule -> IdeResponseT b) -> IdeResponseT b withCachedModule uri callback = withCachedModuleDefault uri Nothing callback -- | Version of `withCachedModuleAndData` that doesn't provide -- any extra cached data. -withCachedModuleDefault :: FilePath -> Maybe (IdeResponse b) - -> (CachedModule -> IdeM (IdeResponse b)) -> IdeM (IdeResponse b) +withCachedModuleDefault :: FilePath -> Maybe (IdeResponseT b) + -> (CachedModule -> IdeResponseT b) -> IdeResponseT b withCachedModuleDefault uri mdef callback = do mcm <- getCachedModule uri uri' <- liftIO $ canonicalizePath uri case mcm of ModuleCached cm _ -> callback cm - ModuleLoading -> return $ IdeResponseDeferred uri' callback - ModuleFailed err -> case mdef of - Nothing -> return $ IdeResponseFail (IdeError NoModuleAvailable err J.Null) - Just def -> return def + ModuleLoading -> defer uri' callback + ModuleFailed err -> flip fromMaybe mdef $ ideError NoModuleAvailable err J.Null -- | Calls its argument with the CachedModule for a given URI -- along with any data that might be stored in the ModuleCache. @@ -134,21 +134,21 @@ withCachedModuleDefault uri mdef callback = do -- If the data doesn't exist in the cache, new data is generated -- using by calling the `cacheDataProducer` function. withCachedModuleAndData :: forall a b. ModuleCache a - => FilePath -> (CachedModule -> a -> IdeM (IdeResponse b)) -> IdeM (IdeResponse b) + => FilePath -> (CachedModule -> a -> IdeResponseT b) -> IdeResponseT b withCachedModuleAndData uri callback = withCachedModuleAndDataDefault uri Nothing callback withCachedModuleAndDataDefault :: forall a b. ModuleCache a - => FilePath -> Maybe (IdeResponse b) - -> (CachedModule -> a -> IdeM (IdeResponse b)) -> IdeM (IdeResponse b) + => FilePath -> Maybe (IdeResponseT b) + -> (CachedModule -> a -> IdeResponseT b) -> IdeResponseT b withCachedModuleAndDataDefault uri mdef callback = do uri' <- liftIO $ canonicalizePath uri mcache <- getModuleCache let mc = (Map.lookup uri' . uriCaches) mcache case mc of - Nothing -> return $ IdeResponseDeferred uri' $ \_ -> withCachedModuleAndData uri callback + Nothing -> defer uri' $ \_ -> withCachedModuleAndData uri callback Just (UriCacheFailed err) -> case mdef of - Nothing -> return $ IdeResponseFail (IdeError NoModuleAvailable err J.Null) - Just def -> return def + Nothing -> ideError NoModuleAvailable err J.Null + Just def -> def Just UriCache{cachedModule = cm, cachedData = dat} -> do let proxy :: Proxy a proxy = Proxy @@ -205,12 +205,9 @@ failModule fp err = do runDeferredActions :: FilePath -> Either T.Text CachedModule -> IdeGhcM () -runDeferredActions uri cached = do - actions <- fmap (fromMaybe [] . Map.lookup uri) (requestQueue <$> readMTS) - liftToGhc $ forM_ actions (\a -> a cached) - - -- remove queued actions - modifyMTS $ \s -> s { requestQueue = Map.delete uri (requestQueue s) } +runDeferredActions uri cached = liftIde $ do + actions <- requestQueue . at uri . non' _Empty %%= \x -> (x, []) + traverse_ (\a -> a cached) actions -- | Saves a module to the cache without clearing the associated cache data - use only if you are -- sure that the cached data associated with the module doesn't change @@ -256,7 +253,7 @@ markCacheStale uri = do -- TODO: this name is confusing, given GhcModuleCache. Change it class Typeable a => ModuleCache a where -- | Defines an initial value for the state extension - cacheDataProducer :: (GM.MonadIO m, MonadMTState IdeState m) + cacheDataProducer :: (GM.MonadIO m, MonadState IdeState m) => CachedModule -> m a instance ModuleCache () where diff --git a/hie-plugin-api/Haskell/Ide/Engine/Monad.hs b/hie-plugin-api/Haskell/Ide/Engine/Monad.hs index 1d1a7b764..2ca22db63 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Monad.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Monad.hs @@ -11,7 +11,7 @@ import Language.Haskell.LSP.Types.Capabilities -- --------------------------------------------------------------------- -- | runIdeGhcM with Cradle found from the current directory -runIdeGhcM :: GM.Options -> ClientCapabilities -> IdeState -> IdeGhcM a -> IO a +runIdeGhcM :: GM.Options -> ClientCapabilities -> IdeState -> GM.GhcModT (ReaderT ClientCapabilities (MultiThreadState IdeState)) a -> IO a runIdeGhcM ghcModOptions caps s0 f = do (eres, _) <- flip runMTState s0 $ flip runReaderT caps $ GM.runGhcModT ghcModOptions f case eres of diff --git a/hie-plugin-api/Haskell/Ide/Engine/MonadFunctions.hs b/hie-plugin-api/Haskell/Ide/Engine/MonadFunctions.hs index 21ab33091..61643f452 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/MonadFunctions.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/MonadFunctions.hs @@ -21,8 +21,9 @@ import System.Log.Logger import Data.Typeable import Data.Dynamic import qualified Data.Map as Map +import qualified Control.Monad.State as MS +import Control.Lens -import Haskell.Ide.Engine.MultiThreadState import Haskell.Ide.Engine.PluginsIdeMonads -- --------------------------------------------------------------------- @@ -104,34 +105,33 @@ class Typeable a => ExtensionClass a where -- -- | Modify the map of state extensions by applying the given function. -modifyStateExts :: MonadMTState IdeState m => (Map.Map TypeRep Dynamic -> Map.Map TypeRep Dynamic) -> m () -modifyStateExts f = modifyMTS $ \st -> st { extensibleState = f (extensibleState st) } +modifyStateExts :: MS.MonadState IdeState m => (Map.Map TypeRep Dynamic -> Map.Map TypeRep Dynamic) -> m () +modifyStateExts f = extensibleState %= f -- | Apply a function to a stored value of the matching type or the initial value if there -- is none. -modify :: (MonadMTState IdeState m, ExtensionClass a) => (a -> a) -> m () +modify :: (MS.MonadState IdeState m, ExtensionClass a) => (a -> a) -> m () modify f = put . f =<< get -- | Add a value to the extensible state field. A previously stored value with the same -- type will be overwritten. (More precisely: A value whose string representation of its type -- is equal to the new one's) -put :: (MonadMTState IdeState m, ExtensionClass a) => a -> m () +put :: (MS.MonadState IdeState m, ExtensionClass a) => a -> m () put v = modifyStateExts . Map.insert (typeOf v) . toDyn $ v -- | Try to retrieve a value of the requested type, return an initial value if there is no such value. -get :: forall a m. (MonadMTState IdeState m, ExtensionClass a) => m a +get :: forall a m. (MS.MonadState IdeState m, ExtensionClass a) => m a get = do - mc <- readMTS - let v = (Map.lookup (typeRep (Proxy :: Proxy a)) . extensibleState) mc + v <- use $ extensibleState . at (typeRep (Proxy :: Proxy a)) case v of Just dyn -> return $ fromDyn dyn initialValue _ -> return initialValue -gets :: (MonadMTState IdeState m, ExtensionClass a) => (a -> b) -> m b +gets :: (MS.MonadState IdeState m, ExtensionClass a) => (a -> b) -> m b gets = flip fmap get -- | Remove the value from the extensible state field that has the same type as the supplied argument -remove :: (MonadMTState IdeState m, ExtensionClass a) => proxy a -> m () +remove :: (MS.MonadState IdeState m, ExtensionClass a) => proxy a -> m () remove wit = modifyStateExts $ Map.delete (typeRep $ wit) -- --------------------------------------------------------------------- diff --git a/hie-plugin-api/Haskell/Ide/Engine/MultiThreadState.hs b/hie-plugin-api/Haskell/Ide/Engine/MultiThreadState.hs index 28bba128a..138c6ad29 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/MultiThreadState.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/MultiThreadState.hs @@ -2,40 +2,41 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Haskell.Ide.Engine.MultiThreadState - ( MultiThreadState - , readMTState - , modifyMTState + ( MultiThreadState(..) , runMTState - , MonadMTState(..) ) where import Control.Concurrent.STM import Control.Monad.Reader +import Control.Monad.State +import qualified GhcMod.Monad as GM +import Control.Monad.Trans.Control +import Control.Monad.Base +import Exception -- --------------------------------------------------------------------- -type MultiThreadState s = ReaderT (TVar s) IO +newtype MultiThreadState s a = MTState { getMTState :: ReaderT (TVar s) IO a } + deriving (Functor, Applicative, Monad, GM.MonadIO, MonadIO, MonadReader (TVar s), MonadBase IO, ExceptionMonad) -readMTState :: MultiThreadState s s -readMTState = ask >>= liftIO . readTVarIO - -modifyMTState :: (s -> s) -> MultiThreadState s () -modifyMTState f = do - tvar <- ask - liftIO $ atomically $ modifyTVar' tvar f +instance MonadBaseControl IO (MultiThreadState s) where + type StM (MultiThreadState s) a = a + liftBaseWith f = MTState $ liftBaseWith $ \q -> f (q . getMTState) + restoreM = MTState . restoreM runMTState :: MultiThreadState s a -> s -> IO a runMTState m s = do tv <- newTVarIO s - runReaderT m tv - -class MonadIO m => MonadMTState s m | m -> s where - readMTS :: m s - modifyMTS :: (s -> s) -> m () - writeMTS :: s -> m () - writeMTS s = modifyMTS (const s) - -instance MonadMTState s (MultiThreadState s) where - readMTS = readMTState - modifyMTS = modifyMTState + runReaderT (getMTState m) tv + +instance MonadState s (MultiThreadState s) where + state f = do + tvar <- ask + liftIO $ atomically $ do + s <- readTVar tvar + let (a, s') = f s + writeTVar tvar s' + return a diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs index 07aa6f06c..65b800e94 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs @@ -12,7 +12,6 @@ module Haskell.Ide.Engine.PluginDescriptor , toDynJSON ) where -import Control.Monad.State.Strict import Data.Aeson import Data.List import qualified Data.Map as Map @@ -22,8 +21,8 @@ import Data.Monoid import qualified Data.Text as T import qualified Data.ConstrainedDynamic as CD import Data.Typeable -import Haskell.Ide.Engine.IdeFunctions import Haskell.Ide.Engine.MonadTypes +import Control.Lens pluginDescToIdePlugins :: [(PluginId,PluginDescriptor)] -> IdePlugins pluginDescToIdePlugins = IdePlugins . foldr (uncurry Map.insert . f) Map.empty @@ -42,18 +41,16 @@ toDynJSON = CD.toDyn -- | Runs a plugin command given a PluginId, CommandName and -- arguments in the form of a JSON object. -runPluginCommand :: PluginId -> CommandName -> Value -> IdeGhcM (IdeResult DynamicJSON) +runPluginCommand :: PluginId -> CommandName -> Value -> IDErring IdeGhcM DynamicJSON runPluginCommand p com arg = do - (IdePlugins m) <- lift . lift $ getPlugins - case Map.lookup p m of - Nothing -> return $ - IdeResultFail $ IdeError UnknownPlugin ("Plugin " <> p <> " doesn't exist") Null - Just (xs, _) -> case find ((com ==) . commandName) xs of - Nothing -> return $ IdeResultFail $ - IdeError UnknownCommand ("Command " <> com <> " isn't defined for plugin " <> p <> ". Legal commands are: " <> T.pack(show $ map commandName xs)) Null - Just (PluginCommand _ _ (CmdSync f)) -> case fromJSON arg of - Error err -> return $ IdeResultFail $ - IdeError ParameterError ("error while parsing args for " <> com <> " in plugin " <> p <> ": " <> T.pack err) Null - Success a -> do - res <- f a - return $ fmap toDynJSON res + IdePlugins m <- liftIde $ use idePlugins + (xs, _) <- case Map.lookup p m of + Nothing -> ideError UnknownPlugin ("Plugin " <> p <> " doesn't exist") Null + Just x -> return x + PluginCommand _ _ (CmdSync f) <- case find ((com ==) . commandName) xs of + Nothing -> ideError UnknownCommand ("Command " <> com <> " isn't defined for plugin " <> p <> ". Legal commands are: " <> T.pack(show $ map commandName xs)) Null + Just x -> return x + a <- case fromJSON arg of + Error err -> ideError ParameterError ("error while parsing args for " <> com <> " in plugin " <> p <> ": " <> T.pack err) Null + Success x -> return x + toDynJSON <$> f a \ No newline at end of file diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs index ae9dff510..6425930e7 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs @@ -4,11 +4,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} module Haskell.Ide.Engine.PluginUtils ( - mapEithers - , pluginGetFile - , pluginGetFileResponse + pluginGetFile , makeDiffResult , WithDeletions(..) , makeAdditiveDiffResult @@ -31,7 +30,7 @@ module Haskell.Ide.Engine.PluginUtils import Control.Monad.IO.Class import Control.Monad.Reader -import Control.Monad.Trans.Except +import Control.Monad.Except import Data.Aeson import Data.Algorithm.Diff import Data.Algorithm.DiffOutput @@ -95,13 +94,9 @@ reverseMapFile rfm fp = do debugm $ "reverseMapFile: Canonicalized original is " ++ orig return orig' -srcSpan2Loc :: (MonadIO m) => (FilePath -> FilePath) -> SrcSpan -> m (Either T.Text Location) +srcSpan2Loc :: MonadIO m => (FilePath -> FilePath) -> SrcSpan -> m (Either T.Text Location) srcSpan2Loc revMapp spn = runExceptT $ do - let - foo :: (Monad m) => Either T.Text RealSrcSpan -> ExceptT T.Text m RealSrcSpan - foo (Left e) = throwE e - foo (Right v) = pure v - rspan <- foo $ getRealSrcSpan spn + rspan <- either throwError pure $ getRealSrcSpan spn let fp = unpackFS $ srcSpanFile rspan debugm $ "srcSpan2Loc: mapped file is " ++ fp file <- reverseMapFile revMapp fp @@ -112,35 +107,12 @@ srcSpan2Loc revMapp spn = runExceptT $ do -- | Helper function that extracts a filepath from a Uri if the Uri -- is well formed (i.e. begins with a file:// ) --- fails with an IdeResultFail otherwise -pluginGetFile - :: Monad m - => T.Text -> Uri -> (FilePath -> m (IdeResult a)) -> m (IdeResult a) -pluginGetFile name uri f = - case uriToFilePath uri of - Just file -> f file - Nothing -> return $ IdeResultFail (IdeError PluginError - (name <> "Couldn't resolve uri" <> getUri uri) Null) - --- | @pluginGetFile but for IdeResponse - use with IdeM -pluginGetFileResponse - :: Monad m - => T.Text -> Uri -> (FilePath -> m (IdeResponse a)) -> m (IdeResponse a) -pluginGetFileResponse name uri f = - case uriToFilePath uri of - Just file -> f file - Nothing -> return $ IdeResponseFail (IdeError PluginError - (name <> "Couldn't resolve uri" <> getUri uri) Null) - --- --------------------------------------------------------------------- --- courtesy of http://stackoverflow.com/questions/19891061/mapeithers-function-in-haskell -mapEithers :: (a -> Either b c) -> [a] -> Either b [c] -mapEithers f (x:xs) = case mapEithers f xs of - Left err -> Left err - Right ys -> case f x of - Left err -> Left err - Right y -> Right (y:ys) -mapEithers _ _ = Right [] +-- fails with an IdeError otherwise +pluginGetFile :: Monad m => T.Text -> Uri -> IDErring m FilePath +pluginGetFile name uri = case uriToFilePath uri of + Just file -> return file + Nothing -> ideError + PluginError (name <> "Couldn't resolve uri" <> getUri uri) Null -- --------------------------------------------------------------------- diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 201335abb..55e4b3d51 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,6 +7,14 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} -- | IdeGhcM and associated types module Haskell.Ide.Engine.PluginsIdeMonads @@ -24,16 +31,14 @@ module Haskell.Ide.Engine.PluginsIdeMonads -- * The IDE monad , IdeGhcM , IdeState(..) + , IDErring(..) + , runIDErring + , MonadIde(..) + , IdeResponseT + , ResponseT +-- , IdeResponse + , IdeDefer(..) , IdeM - , LiftsToGhc(..) - -- * IdeResult and IdeResponse - , IdeResult(..) - , IdeResultT(..) - , pattern IdeResponseOk - , pattern IdeResponseFail - , IdeResponse - , IdeResponse'(..) - , IdeResponseT(..) , IdeError(..) , IdeErrorCode(..) -- * LSP types @@ -50,11 +55,23 @@ module Haskell.Ide.Engine.PluginsIdeMonads , DiagnosticSeverity(..) , PublishDiagnosticsParams(..) , List(..) + , ideError + , defer + , moduleCache, requestQueue, idePlugins, extensibleState, ghcSession ) where import Control.Concurrent.STM import Control.Monad.IO.Class import Control.Monad.Reader +import Control.Monad.Except +import Control.Monad.State +import Control.Monad.Trans.Free +import Control.Monad.Trans.Control +import Control.Monad.Morph +import Control.Monad.Base +import Control.Lens +import Exception +import Data.Functor.Classes import Data.Aeson import Data.Dynamic (Dynamic) @@ -92,7 +109,7 @@ import Language.Haskell.LSP.Types (CodeAction(..), type PluginId = T.Text type CommandName = T.Text -newtype CommandFunc a b = CmdSync (a -> IdeGhcM (IdeResult b)) +newtype CommandFunc a b = CmdSync (a -> IDErring IdeGhcM b) data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => PluginCommand { commandName :: CommandName @@ -104,7 +121,7 @@ type CodeActionProvider = VersionedTextDocumentIdentifier -> Maybe FilePath -- ^ Project root directory -> Range -> CodeActionContext - -> IdeM (IdeResponse [CodeAction]) + -> IdeResponseT [CodeAction] data PluginDescriptor = PluginDescriptor { pluginName :: T.Text @@ -117,7 +134,7 @@ instance Show PluginCommand where show (PluginCommand name _ _) = "PluginCommand { name = " ++ T.unpack name ++ " }" noCodeActions :: CodeActionProvider -noCodeActions _ _ _ _ = return $ IdeResponseOk [] +noCodeActions _ _ _ _ = return [] -- | a Description of the available commands and code action providers stored in IdeGhcM newtype IdePlugins = IdePlugins @@ -131,163 +148,56 @@ instance ToJSON IdePlugins where type IdeGhcM = GM.GhcModT IdeM -instance MonadMTState IdeState IdeGhcM where - readMTS = lift $ lift $ lift readMTS - modifyMTS f = lift $ lift $ lift $ modifyMTS f +newtype IDErring m a = IDErring { getIDErring :: ExceptT IdeError m a } deriving + (Functor, Applicative, Monad, MonadReader r, MonadState s, MonadIO, MonadTrans, MonadBase b, MFunctor) +instance GM.MonadIO m => GM.MonadIO (IDErring m) where liftIO = lift . GM.liftIO +instance GM.GmEnv m => GM.GmEnv (IDErring m) where gmeAsk = lift GM.gmeAsk; gmeLocal f x = liftWith (\run -> GM.gmeLocal f $ run x) >>= restoreT . return +instance GM.GmLog m => GM.GmLog (IDErring m) where gmlJournal = lift . GM.gmlJournal; gmlHistory = lift GM.gmlHistory; gmlClear = lift GM.gmlClear +instance GM.GmOut m => GM.GmOut (IDErring m) where gmoAsk = lift GM.gmoAsk +instance GM.GmState m => GM.GmState (IDErring m) where gmsGet = lift GM.gmsGet; gmsPut = lift . GM.gmsPut; gmsState = lift . GM.gmsState +instance (Functor f, MonadFree f m) => MonadFree f (IDErring m) where wrap x = liftWith (\run -> wrap $ fmap run x) >>= restoreT . return + +runIDErring :: IDErring m a -> m (Either IdeError a) +runIDErring = runExceptT . getIDErring + +instance MonadTransControl IDErring where + type StT IDErring a = StT (ExceptT IdeError) a + liftWith = defaultLiftWith IDErring getIDErring + restoreT = defaultRestoreT IDErring +instance MonadBaseControl b m => MonadBaseControl b (IDErring m) where + type StM (IDErring m) a = ComposeSt IDErring m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM type IdeM = ReaderT ClientCapabilities (MultiThreadState IdeState) -instance MonadMTState IdeState IdeM where - readMTS = lift readMTS - modifyMTS = lift . modifyMTS - -class (Monad m) => LiftsToGhc m where - liftToGhc :: m a -> IdeGhcM a - -instance LiftsToGhc IdeM where - liftToGhc = lift . lift - -instance LiftsToGhc IdeGhcM where - liftToGhc = id +class Monad m => MonadIde m where liftIde :: IdeM a -> m a +instance MonadIde IdeGhcM where liftIde = lift . lift +instance MonadIde m => MonadIde (IDErring m) where liftIde = lift . liftIde +instance MonadIde (ResponseT IdeM) where liftIde = lift data IdeState = IdeState - { moduleCache :: GhcModuleCache + { _moduleCache :: GhcModuleCache -- | A queue of requests to be performed once a module is loaded - , requestQueue :: Map.Map FilePath [Either T.Text CachedModule -> IdeM ()] - , idePlugins :: IdePlugins - , extensibleState :: !(Map.Map TypeRep Dynamic) - , ghcSession :: Maybe (IORef HscEnv) + , _requestQueue :: Map.Map FilePath [Either T.Text CachedModule -> IdeM ()] + , _idePlugins :: IdePlugins + , _extensibleState :: !(Map.Map TypeRep Dynamic) + , _ghcSession :: Maybe (IORef HscEnv) } -instance HasGhcModuleCache IdeM where - getModuleCache = do - tvar <- lift ask - state <- liftIO $ readTVarIO tvar - return (moduleCache state) - setModuleCache mc = do - tvar <- lift ask - liftIO $ atomically $ modifyTVar' tvar (\st -> st { moduleCache = mc }) - -instance HasGhcModuleCache IdeGhcM where - getModuleCache = lift . lift $ getModuleCache - setModuleCache = lift . lift . setModuleCache - - - --- --------------------------------------------------------------------- - - --- | The result of a plugin action, containing the result and an error if --- it failed. IdeGhcM usually skips IdeResponse and jumps straight to this. -data IdeResult a = IdeResultOk a - | IdeResultFail IdeError - deriving (Eq, Show, Generic, ToJSON, FromJSON) - -instance Functor IdeResult where - fmap f (IdeResultOk x) = IdeResultOk (f x) - fmap _ (IdeResultFail err) = IdeResultFail err - -instance Applicative IdeResult where - pure = return - (IdeResultFail err) <*> _ = IdeResultFail err - _ <*> (IdeResultFail err) = IdeResultFail err - (IdeResultOk f) <*> (IdeResultOk x) = IdeResultOk (f x) - -instance Monad IdeResult where - return = IdeResultOk - IdeResultOk x >>= f = f x - IdeResultFail err >>= _ = IdeResultFail err - -newtype IdeResultT m a = IdeResultT { runIdeResultT :: m (IdeResult a) } - -instance Monad m => Functor (IdeResultT m) where - fmap = liftM - -instance Monad m => Applicative (IdeResultT m) where - pure = return - (<*>) = ap - -instance (Monad m) => Monad (IdeResultT m) where - return = IdeResultT . return . IdeResultOk - - m >>= f = IdeResultT $ do - v <- runIdeResultT m - case v of - IdeResultOk x -> runIdeResultT (f x) - IdeResultFail err -> return $ IdeResultFail err - -instance MonadTrans IdeResultT where - lift m = IdeResultT (fmap IdeResultOk m) - --- | The IDE response, which wraps around an IdeResult that may be deferred. +-- | The IDE response, which wraps around an (Either IdeError a) that may be deferred. -- Used mostly in IdeM. -data IdeResponse' m a = IdeResponseDeferred FilePath (CachedModule -> m (IdeResponse' m a)) - | IdeResponseResult (IdeResult a) - -type IdeResponse a = IdeResponse' IdeM a +data IdeDefer a = IdeDefer FilePath (CachedModule -> a) deriving Functor +type ResponseT = FreeT IdeDefer +type IdeResponseT = IDErring (ResponseT IdeM) -- Lightens error messages -pattern IdeResponseOk :: a -> IdeResponse' m a -pattern IdeResponseOk a = IdeResponseResult (IdeResultOk a) -pattern IdeResponseFail :: IdeError -> IdeResponse' m a -pattern IdeResponseFail err = IdeResponseResult (IdeResultFail err) +instance GM.MonadIO m => GM.MonadIO (ResponseT m) where liftIO = lift . GM.liftIO -instance (Show a) => Show (IdeResponse' m a) where - show (IdeResponseResult x) = show x - show (IdeResponseDeferred fp _) = "Deferred response waiting on " ++ fp +defer :: MonadFree IdeDefer m => FilePath -> (CachedModule -> m a) -> m a +defer fp f = wrap $ IdeDefer fp f -instance (Eq a) => Eq (IdeResponse' m a) where - (IdeResponseResult x) == (IdeResponseResult y) = x == y - _ == _ = False - -instance Monad m => Functor (IdeResponse' m) where - fmap f (IdeResponseResult (IdeResultOk x)) = IdeResponseOk (f x) - fmap _ (IdeResponseResult (IdeResultFail err)) = IdeResponseFail err - fmap f (IdeResponseDeferred fp cb) = IdeResponseDeferred fp $ cb >=> (return . fmap f) - -instance Monad m => Applicative (IdeResponse' m) where - pure = return - - (IdeResponseResult (IdeResultFail err)) <*> _ = IdeResponseFail err - _ <*> (IdeResponseResult (IdeResultFail err)) = IdeResponseFail err - - (IdeResponseResult (IdeResultOk f)) <*> (IdeResponseResult (IdeResultOk x)) = IdeResponseOk (f x) - - (IdeResponseResult (IdeResultOk f)) <*> (IdeResponseDeferred fp cb) = IdeResponseDeferred fp $ fmap (fmap f) . cb - - (IdeResponseDeferred fp cb) <*> x = IdeResponseDeferred fp $ \cm -> do - f <- cb cm - pure (f <*> x) - -instance Monad m => Monad (IdeResponse' m) where - (IdeResponseResult (IdeResultOk x)) >>= f = f x - (IdeResponseDeferred fp cb) >>= f = IdeResponseDeferred fp $ \cm -> do - x <- cb cm - return $ x >>= f - (IdeResponseResult (IdeResultFail err)) >>= _ = IdeResponseFail err - return = IdeResponseOk - -newtype IdeResponseT m a = IdeResponseT { runIdeResponseT :: m (IdeResponse' m a) } - -instance Monad m => Functor (IdeResponseT m) where - fmap = liftM - -instance Monad m => Applicative (IdeResponseT m) where - pure = return - (<*>) = ap - -instance (Monad m) => Monad (IdeResponseT m) where - return = IdeResponseT . return . IdeResponseOk - - m >>= f = IdeResponseT $ do - v <- runIdeResponseT m - case v of - IdeResponseResult (IdeResultOk x) -> runIdeResponseT (f x) - IdeResponseResult (IdeResultFail err) -> return $ IdeResponseFail err - IdeResponseDeferred fp cb -> return $ IdeResponseDeferred fp $ \cm -> - runIdeResponseT $ IdeResponseT (cb cm) >>= f - -instance MonadTrans IdeResponseT where - lift m = IdeResponseT (fmap IdeResponseOk m) +instance Show1 IdeDefer where liftShowsPrec _ _ _ (IdeDefer fp _) = (++) $ "Deferred response waiting on " ++ fp +instance Show (IdeDefer a) where show (IdeDefer fp _) = "Deferred response waiting on " ++ fp -- | Error codes. Add as required data IdeErrorCode @@ -315,3 +225,35 @@ data IdeError = IdeError instance ToJSON IdeError instance FromJSON IdeError + +ideError :: Monad m => IdeErrorCode -> T.Text -> Value -> IDErring m a +ideError c m i = IDErring $ throwError $ IdeError c m i + +makeLenses ''IdeState + +instance HasGhcModuleCache IdeM where + getModuleCache = do + tvar <- lift ask + liftIO $ view moduleCache <$> readTVarIO tvar + setModuleCache mc = do + tvar <- lift ask + liftIO $ atomically $ modifyTVar' tvar $ moduleCache .~ mc + +instance HasGhcModuleCache IdeGhcM where + getModuleCache = lift . lift $ getModuleCache + setModuleCache = lift . lift . setModuleCache + +instance HasGhcModuleCache m => HasGhcModuleCache (IDErring m) where + getModuleCache = lift getModuleCache + setModuleCache = lift . setModuleCache + +instance HasGhcModuleCache m => HasGhcModuleCache (ResponseT m) where + getModuleCache = lift getModuleCache + setModuleCache = lift . setModuleCache + +deriving instance (GM.MonadIO m, ExceptionMonad m) => ExceptionMonad (IDErring m) + +instance ExceptionMonad m => ExceptionMonad (ResponseT m) where + gcatch act handler = let levelonecatch act' handler' = FreeT $ runFreeT act' `gcatch` (runFreeT . handler') in + (`levelonecatch` handler) . FreeT . (fmap . fmap) (`gcatch` handler) . runFreeT $ act -- afaic we previously only did one level! + gmask = error "ResponseT hasn't defined gmask!" \ No newline at end of file diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index 1fc77f881..ef3e4f0f0 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -20,7 +20,6 @@ library exposed-modules: Haskell.Ide.Engine.ArtifactMap Haskell.Ide.Engine.GhcModuleCache - Haskell.Ide.Engine.IdeFunctions Haskell.Ide.Engine.ModuleCache Haskell.Ide.Engine.Monad Haskell.Ide.Engine.MonadFunctions @@ -37,11 +36,15 @@ library , directory , filepath , fingertree + , free , ghc , ghc-mod-core >= 5.9.0.0 , haskell-lsp >= 0.5 , hslogger + , mmorph , monad-control + , transformers-base + , lens , mtl , stm , syb diff --git a/src/Haskell/Ide/Engine/Dispatcher.hs b/src/Haskell/Ide/Engine/Dispatcher.hs index e199900c2..fd05a5f31 100644 --- a/src/Haskell/Ide/Engine/Dispatcher.hs +++ b/src/Haskell/Ide/Engine/Dispatcher.hs @@ -20,6 +20,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.STM +import Control.Monad.Trans.Free import qualified Data.Aeson as J import qualified Data.Text as T import qualified Data.Map as Map @@ -31,6 +32,8 @@ import Haskell.Ide.Engine.Types import Haskell.Ide.Engine.Monad import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Capabilities as J +import Control.Lens +import qualified GhcMod.Monad as GM data DispatcherEnv = DispatcherEnv { cancelReqsTVar :: !(TVar (S.Set J.LspId)) @@ -62,7 +65,7 @@ dispatcherP inChan plugins ghcModOptions env errorHandler callbackHandler caps = ghcDispatcher env errorHandler callbackHandler ghcChan runIdeDisp = do stateVar <- readMVar stateVarVar - flip runReaderT stateVar $ flip runReaderT caps $ + flip runReaderT stateVar $ getMTState $ flip runReaderT caps $ ideDispatcher env errorHandler callbackHandler ideChan runMainDisp = mainDispatcher inChan ghcChan ideChan @@ -71,72 +74,55 @@ dispatcherP inChan plugins ghcModOptions env errorHandler callbackHandler caps = mainDispatcher :: forall void m. TChan (PluginRequest m) -> TChan (GhcRequest m) -> TChan (IdeRequest m) -> IO void mainDispatcher inChan ghcChan ideChan = forever $ do req <- atomically $ readTChan inChan - case req of + atomically $ case req of Right r -> - atomically $ writeTChan ghcChan r + writeTChan ghcChan r Left r -> - atomically $ writeTChan ideChan r + writeTChan ideChan r ideDispatcher :: forall void m. DispatcherEnv -> ErrorHandler -> CallbackHandler m -> TChan (IdeRequest m) -> IdeM void ideDispatcher env errorHandler callbackHandler pin = forever $ do debugm "ideDispatcher: top of loop" - (IdeRequest tn lid callback action) <- liftIO $ atomically $ readTChan pin + IdeRequest tn lid callback action <- liftIO $ atomically $ readTChan pin debugm $ "ideDispatcher: got request " ++ show tn ++ " with id: " ++ show lid - checkCancelled env lid errorHandler $ do - response <- action - handleResponse lid callback response - - where handleResponse lid callback response = - -- Need to check cancellation twice since cancellation - -- request might have come in during the action + handleAction lid $ runIDErring $ fmap (callbackHandler callback) action + where handleAction :: J.LspId -> ResponseT IdeM (Either IdeError (IO ())) -> IdeM () + handleAction lid action = checkCancelled env lid errorHandler $ do + response <- runFreeT action checkCancelled env lid errorHandler $ case response of - IdeResponseResult (IdeResultOk x) -> liftIO $ do - completedReq env lid - callbackHandler callback x - IdeResponseResult (IdeResultFail (IdeError code msg _)) -> liftIO $ do - completedReq env lid - case code of - -- TODO: This isn't actually an internal error - NoModuleAvailable -> errorHandler lid J.InternalError msg - _ -> errorHandler lid J.InternalError msg - IdeResponseDeferred fp cacheCb -> handleDeferred lid fp cacheCb callback - - handleDeferred lid fp cacheCb actualCb = queueAction fp $ \case - Right cm -> do - cacheResponse <- cacheCb cm - handleResponse lid actualCb cacheResponse - Left err -> - handleResponse lid actualCb (IdeResponseFail (IdeError NoModuleAvailable err J.Null)) + Pure result -> handleResult lid result + Free (IdeDefer fp cacheCb) -> queueAction fp $ + handleAction lid . either (\err -> pure $ Left $ IdeError NoModuleAvailable err J.Null) cacheCb queueAction :: FilePath -> (Either T.Text CachedModule -> IdeM ()) -> IdeM () - queueAction fp action = - lift $ modifyMTState $ \s -> - let oldQueue = requestQueue s - -- add to existing queue if possible - update Nothing = [action] - update (Just x) = action : x - newQueue = Map.alter (Just . update) fp oldQueue - in s { requestQueue = newQueue } - -ghcDispatcher :: forall void m. DispatcherEnv -> ErrorHandler -> CallbackHandler m -> TChan (GhcRequest m) -> IdeGhcM void + queueAction fp action = requestQueue . at fp . non' _Empty %= (action:) + + handleResult :: J.LspId -> Either IdeError (IO ()) -> IdeM () + handleResult lid = \case + Left (IdeError code msg _) -> liftIO $ do + completedReq env lid + case code of + -- TODO: This isn't actually an internal error + NoModuleAvailable -> errorHandler lid J.InternalError msg + _ -> errorHandler lid J.InternalError msg + Right x -> liftIO x + +ghcDispatcher :: forall void m. DispatcherEnv -> ErrorHandler -> CallbackHandler m -> TChan (GhcRequest m) -> GM.GhcModT IdeM void ghcDispatcher env@DispatcherEnv{docVersionTVar} errorHandler callbackHandler pin = forever $ do debugm "ghcDispatcher: top of loop" - (GhcRequest tn context mver mid callback action) <- liftIO $ atomically $ readTChan pin + GhcRequest tn context mver mid callback action <- liftIO $ atomically $ readTChan pin debugm $ "ghcDispatcher:got request " ++ show tn ++ " with id: " ++ show mid - let runner = case context of - Nothing -> runActionWithContext Nothing - Just uri -> case uriToFilePath uri of - Just fp -> runActionWithContext (Just fp) - Nothing -> \act -> do - debugm "ghcDispatcher:Got malformed uri, running action with default context" - runActionWithContext Nothing act + let runner act = do + let c = uriToFilePath <$> context + when (c == Just Nothing) $ debugm "ghcDispatcher:Got malformed uri, running action with default context" + runActionWithContext (join c) act let runWithCallback = do - result <- runner action + result <- runIDErring $ runner action liftIO $ case result of - IdeResultOk x -> callbackHandler callback x - IdeResultFail err@(IdeError code msg _) -> + Right x -> callbackHandler callback x + Left err@(IdeError code msg _) -> case mid of Just lid -> case code of NoModuleAvailable -> errorHandler lid J.ParseError msg diff --git a/src/Haskell/Ide/Engine/LSP/CodeActions.hs b/src/Haskell/Ide/Engine/LSP/CodeActions.hs index d1870b7ff..0d43a32bb 100644 --- a/src/Haskell/Ide/Engine/LSP/CodeActions.hs +++ b/src/Haskell/Ide/Engine/LSP/CodeActions.hs @@ -19,7 +19,6 @@ import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Capabilities as C import Language.Haskell.LSP.VFS import Language.Haskell.LSP.Messages -import Haskell.Ide.Engine.IdeFunctions import Haskell.Ide.Engine.PluginsIdeMonads data FallbackCodeActionParams = @@ -38,10 +37,10 @@ handleCodeActionReq tn req = do docVersion <- fmap _version <$> liftIO (vfsFunc docUri) let docId = J.VersionedTextDocumentIdentifier docUri docVersion - let getProviders :: IdeM (IdeResponse [CodeActionProvider]) + let getProviders :: IdeResponseT [CodeActionProvider] getProviders = do - IdePlugins m <- lift getPlugins - return $ IdeResponseOk $ map snd $ toList m + IdePlugins m <- use idePlugins + return $ map snd $ toList m providersCb :: [CodeActionProvider] -> R () providersCb providers = @@ -79,7 +78,7 @@ handleCodeActionReq tn req = do reactorSend $ RspCodeAction $ Core.makeResponseMessage req body -- | Execute multiple ide requests sequentially - collectRequests :: [IdeM (IdeResponse a)] -- ^ The requests to make + collectRequests :: [IdeResponseT a] -- ^ The requests to make -> ([a] -> R ()) -- ^ Callback with the request inputs and results -> R () collectRequests = go [] diff --git a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs b/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs index a3de2b552..d4b432aad 100644 --- a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs +++ b/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs @@ -63,16 +63,16 @@ applyOneCmd :: CommandFunc ApplyOneParams WorkspaceEdit applyOneCmd = CmdSync $ \(AOP uri pos title) -> do applyOneCmd' uri (OneHint pos title) -applyOneCmd' :: Uri -> OneHint -> IdeGhcM (IdeResult WorkspaceEdit) -applyOneCmd' uri oneHint = pluginGetFile "applyOne: " uri $ \fp -> do - revMapp <- GM.mkRevRedirMapFunc - res <- GM.withMappedFile fp $ \file' -> liftToGhc $ applyHint file' (Just oneHint) revMapp - logm $ "applyOneCmd:file=" ++ show fp - logm $ "applyOneCmd:res=" ++ show res - case res of - Left err -> return $ IdeResultFail (IdeError PluginError - (T.pack $ "applyOne: " ++ show err) Null) - Right fs -> return (IdeResultOk fs) +applyOneCmd' :: Uri -> OneHint -> IDErring IdeGhcM WorkspaceEdit +applyOneCmd' uri oneHint = do + fp <- pluginGetFile "applyOne: " uri + revMapp <- GM.mkRevRedirMapFunc + res <- GM.withMappedFile fp $ \file' -> liftIde $ applyHint file' (Just oneHint) revMapp + logm $ "applyOneCmd:file=" ++ show fp + logm $ "applyOneCmd:res=" ++ show res + case res of + Left err -> ideError PluginError (T.pack $ "applyOne: " ++ show err) Null + Right fs -> return fs -- --------------------------------------------------------------------- @@ -81,15 +81,15 @@ applyAllCmd :: CommandFunc Uri WorkspaceEdit applyAllCmd = CmdSync $ \uri -> do applyAllCmd' uri -applyAllCmd' :: Uri -> IdeGhcM (IdeResult WorkspaceEdit) -applyAllCmd' uri = pluginGetFile "applyAll: " uri $ \fp -> do - revMapp <- GM.mkRevRedirMapFunc - res <- GM.withMappedFile fp $ \file' -> liftToGhc $ applyHint file' Nothing revMapp - logm $ "applyAllCmd:res=" ++ show res - case res of - Left err -> return $ IdeResultFail (IdeError PluginError - (T.pack $ "applyAll: " ++ show err) Null) - Right fs -> return (IdeResultOk fs) +applyAllCmd' :: Uri -> IDErring IdeGhcM WorkspaceEdit +applyAllCmd' uri = do + fp <- pluginGetFile "applyAll: " uri + revMapp <- GM.mkRevRedirMapFunc + res <- GM.withMappedFile fp $ \file' -> liftIde $ applyHint file' Nothing revMapp + logm $ "applyAllCmd:res=" ++ show res + case res of + Left err -> ideError PluginError (T.pack $ "applyAll: " ++ show err) Null + Right fs -> return fs -- --------------------------------------------------------------------- @@ -97,16 +97,13 @@ lintCmd :: CommandFunc Uri PublishDiagnosticsParams lintCmd = CmdSync $ \uri -> do lintCmd' uri -lintCmd' :: Uri -> IdeGhcM (IdeResult PublishDiagnosticsParams) -lintCmd' uri = pluginGetFile "lintCmd: " uri $ \fp -> do - res <- GM.withMappedFile fp $ \file' -> liftIO $ runExceptT $ runLintCmd file' [] - case res of - Left diags -> - return (IdeResultOk (PublishDiagnosticsParams (filePathToUri fp) $ List diags)) - Right fs -> - return $ IdeResultOk $ - PublishDiagnosticsParams (filePathToUri fp) - $ List (map hintToDiagnostic $ stripIgnores fs) +lintCmd' :: Uri -> IDErring IdeGhcM PublishDiagnosticsParams +lintCmd' uri = do + fp <- pluginGetFile "lintCmd: " uri + res <- GM.withMappedFile fp $ \file' -> liftIO $ runExceptT $ runLintCmd file' [] + return $ PublishDiagnosticsParams (filePathToUri fp) $ List $ case res of + Left diags -> diags + Right fs -> map hintToDiagnostic $ stripIgnores fs runLintCmd :: FilePath -> [String] -> ExceptT [Diagnostic] IO [Idea] runLintCmd fp args = do @@ -273,9 +270,7 @@ showParseError (Hlint.ParseError location message content) = -- --------------------------------------------------------------------- codeActionProvider :: CodeActionProvider -codeActionProvider docId _ _ context = return $ IdeResponseOk hlintActions - where - +codeActionProvider docId _ _ context = return hlintActions where hlintActions = mapMaybe mkHlintAction $ filter validCommand diags -- |Some hints do not have an associated refactoring validCommand (LSP.Diagnostic _ _ (Just code) (Just "hlint") _ _) = diff --git a/src/Haskell/Ide/Engine/Plugin/Base.hs b/src/Haskell/Ide/Engine/Plugin/Base.hs index a4b7e9ebc..1ff1508a4 100644 --- a/src/Haskell/Ide/Engine/Plugin/Base.hs +++ b/src/Haskell/Ide/Engine/Plugin/Base.hs @@ -18,7 +18,7 @@ import qualified Data.Text as T import Development.GitRev (gitCommitCount) import Distribution.System (buildArch) import Distribution.Text (display) -import Haskell.Ide.Engine.IdeFunctions +import Control.Lens import Haskell.Ide.Engine.MonadTypes import Options.Applicative.Simple (simpleVersion) import qualified Paths_haskell_ide_engine as Meta @@ -47,39 +47,23 @@ baseDescriptor = PluginDescriptor -- --------------------------------------------------------------------- versionCmd :: CommandFunc () T.Text -versionCmd = CmdSync $ \_ -> return $ IdeResultOk (T.pack version) +versionCmd = CmdSync $ \_ -> return $ T.pack version pluginsCmd :: CommandFunc () IdePlugins -pluginsCmd = CmdSync $ \_ -> - IdeResultOk <$> getPlugins +pluginsCmd = CmdSync $ \_ -> liftIde $ use idePlugins commandsCmd :: CommandFunc T.Text [CommandName] commandsCmd = CmdSync $ \p -> do - IdePlugins plugins <- getPlugins - case Map.lookup p plugins of - Nothing -> return $ IdeResultFail $ IdeError - { ideCode = UnknownPlugin - , ideMessage = "Can't find plugin:" <> p - , ideInfo = toJSON p - } - Just pl -> return $ IdeResultOk $ map commandName $ fst pl + IdePlugins plugins <- liftIde $ use idePlugins + (cs, _) <- maybe (ideError UnknownPlugin ("Can't find plugin:" <> p ) (toJSON p )) pure $ Map.lookup p plugins + return $ map commandName cs commandDetailCmd :: CommandFunc (T.Text, T.Text) T.Text commandDetailCmd = CmdSync $ \(p,command) -> do - IdePlugins plugins <- getPlugins - case Map.lookup p plugins of - Nothing -> return $ IdeResultFail $ IdeError - { ideCode = UnknownPlugin - , ideMessage = "Can't find plugin:" <> p - , ideInfo = toJSON p - } - Just pl -> case find (\cmd -> command == commandName cmd) (fst pl) of - Nothing -> return $ IdeResultFail $ IdeError - { ideCode = UnknownCommand - , ideMessage = "Can't find command:" <> command - , ideInfo = toJSON command - } - Just detail -> return $ IdeResultOk (commandDesc detail) + IdePlugins plugins <- liftIde $ use idePlugins + (cs, _) <- maybe (ideError UnknownPlugin ("Can't find plugin:" <> p ) (toJSON p )) pure $ Map.lookup p plugins + detail <- maybe (ideError UnknownCommand ("Can't find command:" <> command) (toJSON command)) pure $ find (\cmd -> command == commandName cmd) cs + pure $ commandDesc detail -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Plugin/Brittany.hs b/src/Haskell/Ide/Engine/Plugin/Brittany.hs index 3ca871279..e386bfe44 100644 --- a/src/Haskell/Ide/Engine/Plugin/Brittany.hs +++ b/src/Haskell/Ide/Engine/Plugin/Brittany.hs @@ -39,40 +39,38 @@ brittanyDescriptor = PluginDescriptor cmd = CmdSync $ \(FormatParams tabSize uri range) -> brittanyCmd tabSize uri range -brittanyCmd :: Int -> Uri -> Maybe Range -> IdeGhcM (IdeResult [J.TextEdit]) -brittanyCmd tabSize uri range = - pluginGetFile "brittanyCmd: " uri $ \file -> do - confFile <- liftIO $ findLocalConfigPath (takeDirectory file) - text <- GM.withMappedFile file $ liftIO . T.readFile - case range of - Just r -> do - -- format selection - res <- liftIO $ runBrittany tabSize confFile $ extractRange r text - case res of - Left err -> return $ IdeResultFail (IdeError PluginError - (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) Null) - Right newText -> do - let textEdit = J.TextEdit (normalize r) newText - return $ IdeResultOk [textEdit] - Nothing -> do - -- format document - res <- liftIO $ runBrittany tabSize confFile text - case res of - Left err -> return $ IdeResultFail (IdeError PluginError - (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) Null) - Right newText -> do - let startPos = Position 0 0 - endPos = Position lastLine 0 - {- - In order to replace everything including newline characters, - the end range should extend below the last line. From the specification: - "If you want to specify a range that contains a line including - the line ending character(s) then use an end position denoting - the start of the next line" - -} - lastLine = length $ T.lines text - textEdit = J.TextEdit (Range startPos endPos) newText - return $ IdeResultOk [textEdit] +brittanyCmd :: Int -> Uri -> Maybe Range -> IDErring IdeGhcM [J.TextEdit] +brittanyCmd tabSize uri range = do + file <- pluginGetFile "brittanyCmd: " uri + confFile <- liftIO $ findLocalConfigPath (takeDirectory file) + text <- GM.withMappedFile file $ liftIO . T.readFile + case range of + Just r -> do + -- format selection + res <- liftIO $ runBrittany tabSize confFile $ extractRange r text + case res of + Left err -> ideError PluginError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) Null + Right newText -> do + let textEdit = J.TextEdit (normalize r) newText + return [textEdit] + Nothing -> do + -- format document + res <- liftIO $ runBrittany tabSize confFile text + case res of + Left err -> ideError PluginError (T.pack $ "brittanyCmd: " ++ unlines (map showErr err)) Null + Right newText -> do + let startPos = Position 0 0 + endPos = Position lastLine 0 + {- + In order to replace everything including newline characters, + the end range should extend below the last line. From the specification: + "If you want to specify a range that contains a line including + the line ending character(s) then use an end position denoting + the start of the next line" + -} + lastLine = length $ T.lines text + textEdit = J.TextEdit (Range startPos endPos) newText + return [textEdit] extractRange :: Range -> Text -> Text extractRange (Range (Position sl _) (Position el _)) s = newS diff --git a/src/Haskell/Ide/Engine/Plugin/Build.hs b/src/Haskell/Ide/Engine/Plugin/Build.hs index ad4b64e0b..62aacec33 100644 --- a/src/Haskell/Ide/Engine/Plugin/Build.hs +++ b/src/Haskell/Ide/Engine/Plugin/Build.hs @@ -22,6 +22,8 @@ import Data.Monoid import qualified Control.Exception as Exception import Control.Monad.IO.Class import Control.Monad.Trans.Reader +import Control.Monad.Trans +import Control.Monad import GHC.Generics (Generic) import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.PluginUtils @@ -231,7 +233,7 @@ withCommonArgs req a = do -- isHelperPrepared = CmdSync $ \ctx req -> withCommonArgs ctx req $ do -- distDir <- asks caDistDir -- ret <- liftIO $ isPrepared (defaultQueryEnv "." distDir) --- return $ IdeResultOk ret +-- return ret ----------------------------------------------- @@ -243,7 +245,6 @@ prepareHelper = CmdSync $ \req -> withCommonArgs req $ do slp <- getStackLocalPackages "stack.yaml" mapM_ (prepareHelper' (caDistDir ca) (caCabal ca)) slp CabalMode -> prepareHelper' (caDistDir ca) (caCabal ca) "." - return $ IdeResultOk () prepareHelper' :: MonadIO m => FilePath -> FilePath -> FilePath -> m () prepareHelper' distDir cabalExe dir = @@ -254,18 +255,16 @@ prepareHelper' distDir cabalExe dir = isConfigured :: CommandFunc CommonParams Bool isConfigured = CmdSync $ \req -> withCommonArgs req $ do distDir <- asks caDistDir - ret <- liftIO $ doesFileExist $ localBuildInfoFile distDir - return $ IdeResultOk ret + liftIO $ doesFileExist $ localBuildInfoFile distDir ----------------------------------------------- configure :: CommandFunc CommonParams () configure = CmdSync $ \req -> withCommonArgs req $ do ca <- ask - _ <- liftIO $ case caMode ca of + void $ liftIO $ case caMode ca of StackMode -> configureStack (caStack ca) CabalMode -> configureCabal (caCabal ca) - return $ IdeResultOk () configureStack :: FilePath -> IO String configureStack stackExe = do @@ -296,8 +295,8 @@ listFlags = CmdSync $ \(LF mode) -> do _oops -> return [] let flags' = flip map flags0 $ \(n,f) -> object ["packageName" .= n, "flags" .= map flagToJSON f] - (Object ret) = object ["res" .= toJSON flags'] - return $ IdeResultOk ret + Object ret = object ["res" .= toJSON flags'] + return ret listFlagsStack :: FilePath -> IO [(String,[Flag])] listFlagsStack d = do @@ -354,21 +353,15 @@ instance ToJSON BuildParams where buildDirectory :: CommandFunc BuildParams () buildDirectory = CmdSync $ \(BP m dd c s f mbDir) -> withCommonArgs (CommonParams m dd c s f) $ do ca <- ask - liftIO $ case caMode ca of - CabalMode -> do - -- for cabal specifying directory have no sense - _ <- readProcess (caCabal ca) ["build"] "" - return $ IdeResultOk () - StackMode -> do - case mbDir of - Nothing -> do - _ <- readProcess (caStack ca) ["build"] "" - return $ IdeResultOk () - Just dir0 -> pluginGetFile "buildDirectory" dir0 $ \dir -> do - cwd <- getCurrentDirectory - let relDir = makeRelative cwd $ normalise dir - _ <- readProcess (caStack ca) ["build", relDir] "" - return $ IdeResultOk () + args <- case caMode ca of + CabalMode -> return [] -- for cabal specifying directory have no sense + StackMode -> case mbDir of + Nothing -> return [] + Just dir0 -> do + dir <- lift $ pluginGetFile "buildDirectory" dir0 + cwd <- liftIO $ getCurrentDirectory + return [makeRelative cwd $ normalise dir] + liftIO $ void $ readProcess (caStack ca) ("build":args) "" ----------------------------------------------- @@ -395,22 +388,17 @@ buildTarget = CmdSync $ \(BT m dd c s f component package' compType) -> withComm ca <- ask liftIO $ case caMode ca of CabalMode -> do - _ <- readProcess (caCabal ca) ["build", T.unpack $ maybe "" id component] "" - return $ IdeResultOk () + void $ readProcess (caCabal ca) ["build", T.unpack $ maybe "" id component] "" StackMode -> do case (package', component) of (Just p, Nothing) -> do - _ <- readProcess (caStack ca) ["build", T.unpack $ p `T.append` compType] "" - return $ IdeResultOk () + void $ readProcess (caStack ca) ["build", T.unpack $ p `T.append` compType] "" (Just p, Just c') -> do - _ <- readProcess (caStack ca) ["build", T.unpack $ p `T.append` compType `T.append` (':' `T.cons` c')] "" - return $ IdeResultOk () + void $ readProcess (caStack ca) ["build", T.unpack $ p `T.append` compType `T.append` (':' `T.cons` c')] "" (Nothing, Just c') -> do - _ <- readProcess (caStack ca) ["build", T.unpack $ ':' `T.cons` c'] "" - return $ IdeResultOk () + void $ readProcess (caStack ca) ["build", T.unpack $ ':' `T.cons` c'] "" _ -> do - _ <- readProcess (caStack ca) ["build"] "" - return $ IdeResultOk () + void $ readProcess (caStack ca) ["build"] "" ----------------------------------------------- @@ -426,11 +414,10 @@ listTargets = CmdSync $ \req -> withCommonArgs req $ do targets <- liftIO $ case caMode ca of CabalMode -> (:[]) <$> listCabalTargets (caDistDir ca) "." StackMode -> listStackTargets (caDistDir ca) - let ret = flip map targets $ \t -> object + return $ flip map targets $ \t -> object ["name" .= tPackageName t, "directory" .= tDirectory t, "targets" .= map compToJSON (tTargets t)] - return $ IdeResultOk ret listStackTargets :: FilePath -> IO [Package] listStackTargets distDir = do diff --git a/src/Haskell/Ide/Engine/Plugin/Example2.hs b/src/Haskell/Ide/Engine/Plugin/Example2.hs index 236bdb721..b10cf8c0f 100644 --- a/src/Haskell/Ide/Engine/Plugin/Example2.hs +++ b/src/Haskell/Ide/Engine/Plugin/Example2.hs @@ -26,12 +26,12 @@ example2Descriptor = PluginDescriptor -- --------------------------------------------------------------------- sayHelloCmd :: CommandFunc () T.Text -sayHelloCmd = CmdSync $ \_ -> return (IdeResultOk sayHello) +sayHelloCmd = CmdSync $ \_ -> return sayHello sayHelloToCmd :: CommandFunc T.Text T.Text sayHelloToCmd = CmdSync $ \n -> do r <- liftIO $ sayHelloTo n - return $ IdeResultOk r + return r -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs index 559ed415b..c418bbeb4 100644 --- a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs +++ b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs @@ -4,14 +4,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} module Haskell.Ide.Engine.Plugin.GhcMod where import Bag import Control.Monad.IO.Class import Control.Lens -import Control.Lens.Setter ((%~)) -import Control.Lens.Traversal (traverseOf) -import Data.Aeson +import Data.Aeson hiding ((.=)) #if __GLASGOW_HASKELL__ < 802 import Data.Aeson.Types #endif @@ -52,6 +51,8 @@ import HscTypes import qualified Language.Haskell.LSP.Types as LSP import TcRnTypes import Outputable (renderWithStyle, mkUserStyle, Depth(..)) +import Control.Monad.Trans +import Control.Monad.Morph -- --------------------------------------------------------------------- @@ -178,40 +179,40 @@ errorHandlers ghcErrRes renderSourceError = handlers -- return $ ghcErrRes (show ex) ] -setTypecheckedModule :: Uri -> IdeGhcM (IdeResult (Diagnostics, AdditionalErrs)) -setTypecheckedModule uri = - pluginGetFile "setTypecheckedModule: " uri $ \fp -> do - fileMap <- GM.getMMappedFiles - debugm $ "setTypecheckedModule: file mapping state is: " ++ show fileMap - rfm <- GM.mkRevRedirMapFunc - let - ghcErrRes msg = ((Map.empty, [T.pack msg]),Nothing) - debugm "setTypecheckedModule: before ghc-mod" - ((diags', errs), mtm) <- GM.gcatches - (GM.getTypecheckedModuleGhc' (myLogger rfm) fp) - (errorHandlers ghcErrRes (return . ghcErrRes . show)) - debugm "setTypecheckedModule: after ghc-mod" - canonUri <- canonicalizeUri uri - let diags = Map.insertWith Set.union canonUri Set.empty diags' - case mtm of - Nothing -> do - debugm $ "setTypecheckedModule: Didn't get typechecked module for: " ++ show fp - - failModule fp (T.unlines errs) - - return $ IdeResultOk (diags,errs) - Just tm -> do - debugm $ "setTypecheckedModule: Did get typechecked module for: " ++ show fp - typm <- GM.unGmlT $ genTypeMap tm - sess <- fmap GM.gmgsSession . GM.gmGhcSession <$> GM.gmsGet - let cm = CachedModule tm (genLocMap tm) typm (genImportMap tm) rfm return return - - -- set the session before we cache the module, so that deferred - -- responses triggered by cacheModule can access it - modifyMTS (\s -> s {ghcSession = sess}) - cacheModule fp cm - debugm "setTypecheckedModule: done" - return $ IdeResultOk (diags,errs) +setTypecheckedModule :: Uri -> IDErring IdeGhcM (Diagnostics, AdditionalErrs) +setTypecheckedModule uri = do + fp <- pluginGetFile "setTypecheckedModule: " uri + fileMap <- GM.getMMappedFiles + debugm $ "setTypecheckedModule: file mapping state is: " ++ show fileMap + rfm <- GM.mkRevRedirMapFunc + let + ghcErrRes msg = ((Map.empty, [T.pack msg]),Nothing) + debugm "setTypecheckedModule: before ghc-mod" + ((diags', errs), mtm) <- lift @IDErring $ GM.gcatches + (GM.getTypecheckedModuleGhc' (myLogger rfm) fp) + (errorHandlers ghcErrRes (return . ghcErrRes . show)) + debugm "setTypecheckedModule: after ghc-mod" + canonUri <- canonicalizeUri uri + let diags = Map.insertWith Set.union canonUri Set.empty diags' + lift @IDErring $ case mtm of + Nothing -> do + debugm $ "setTypecheckedModule: Didn't get typechecked module for: " ++ show fp + + failModule fp (T.unlines errs) + + return (diags,errs) + Just tm -> do + debugm $ "setTypecheckedModule: Did get typechecked module for: " ++ show fp + typm <- GM.unGmlT $ genTypeMap tm + sess <- fmap GM.gmgsSession . GM.gmGhcSession <$> GM.gmsGet + let cm = CachedModule tm (genLocMap tm) typm (genImportMap tm) rfm return return + + -- set the session before we cache the module, so that deferred + -- responses triggered by cacheModule can access it + liftIde $ ghcSession .= sess + cacheModule fp cm + debugm "setTypecheckedModule: done" + return (diags,errs) -- --------------------------------------------------------------------- @@ -219,10 +220,10 @@ lintCmd :: CommandFunc Uri T.Text lintCmd = CmdSync $ \ uri -> lintCmd' uri -lintCmd' :: Uri -> IdeGhcM (IdeResult T.Text) -lintCmd' uri = - pluginGetFile "lint: " uri $ \file -> - fmap T.pack <$> runGhcModCommand (GM.lint GM.defaultLintOpts file) +lintCmd' :: Uri -> IDErring IdeGhcM T.Text +lintCmd' uri = do + file <- pluginGetFile "lint: " uri + T.pack <$> runGhcModCommand (GM.lint GM.defaultLintOpts (file :: FilePath)) -- --------------------------------------------------------------------- @@ -243,10 +244,10 @@ infoCmd :: CommandFunc InfoParams T.Text infoCmd = CmdSync $ \(IP uri expr) -> infoCmd' uri expr -infoCmd' :: Uri -> T.Text -> IdeGhcM (IdeResult T.Text) -infoCmd' uri expr = - pluginGetFile "info: " uri $ \file -> - fmap T.pack <$> runGhcModCommand (GM.info file (GM.Expression (T.unpack expr))) +infoCmd' :: Uri -> T.Text -> IDErring IdeGhcM T.Text +infoCmd' uri expr = do + file <- pluginGetFile "info: " uri + T.pack <$> runGhcModCommand (GM.info file (GM.Expression (T.unpack expr))) -- --------------------------------------------------------------------- data TypeParams = @@ -261,16 +262,16 @@ instance ToJSON TypeParams where toJSON = genericToJSON customOptions typeCmd :: CommandFunc TypeParams [(Range,T.Text)] -typeCmd = CmdSync $ \(TP _bool uri pos) -> - liftToGhc $ newTypeCmd pos uri +typeCmd = CmdSync $ \(TP _bool uri pos) -> do + hoist liftIde $ newTypeCmd pos uri -newTypeCmd :: Position -> Uri -> IdeM (IdeResult [(Range, T.Text)]) -newTypeCmd newPos uri = - pluginGetFile "newTypeCmd: " uri $ \fp -> do - mcm <- getCachedModule fp - case mcm of - ModuleCached cm _ -> return $ IdeResultOk $ pureTypeCmd newPos cm - _ -> return $ IdeResultOk [] +newTypeCmd :: Position -> Uri -> IDErring IdeM [(Range, T.Text)] +newTypeCmd newPos uri = do + fp <- pluginGetFile "newTypeCmd: " uri + mcm <- getCachedModule fp + return $ case mcm of + ModuleCached cm _ -> pureTypeCmd newPos cm + _ -> [] pureTypeCmd :: Position -> CachedModule -> [(Range,T.Text)] pureTypeCmd newPos cm = @@ -310,26 +311,26 @@ splitCaseCmd :: CommandFunc HarePoint WorkspaceEdit splitCaseCmd = CmdSync $ \(HP uri pos) -> do splitCaseCmd' uri pos -splitCaseCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) -splitCaseCmd' uri newPos = - pluginGetFile "splitCaseCmd: " uri $ \path -> do - origText <- GM.withMappedFile path $ liftIO . T.readFile - cachedMod <- getCachedModule path - case cachedMod of - ModuleCached checkedModule _ -> - runGhcModCommand $ - case newPosToOld checkedModule newPos of - Just oldPos -> do - let (line, column) = unPos oldPos - splitResult' <- GM.splits' path (tcMod checkedModule) line column - case splitResult' of - Just splitResult -> do - wEdit <- liftToGhc $ splitResultToWorkspaceEdit origText splitResult - return $ oldToNewPositions checkedModule wEdit - Nothing -> return mempty - Nothing -> return mempty - ModuleFailed errText -> return $ IdeResultFail $ IdeError PluginError (T.append "hie-ghc-mod: " errText) Null - ModuleLoading -> return $ IdeResultOk mempty +splitCaseCmd' :: Uri -> Position -> IDErring IdeGhcM WorkspaceEdit +splitCaseCmd' uri newPos = do + path <- pluginGetFile "splitCaseCmd: " uri + origText <- GM.withMappedFile path $ liftIO . T.readFile + cachedMod <- getCachedModule path + case cachedMod of + ModuleCached checkedModule _ -> + runGhcModCommand $ + case newPosToOld checkedModule newPos of + Just oldPos -> do + let (line, column) = unPos oldPos + splitResult' <- GM.splits' path (tcMod checkedModule) line column + liftIde $ case splitResult' of + Just splitResult -> do + wEdit <- splitResultToWorkspaceEdit origText splitResult + return $ oldToNewPositions checkedModule wEdit + Nothing -> return mempty + Nothing -> return mempty + ModuleFailed errText -> ideError PluginError (T.append "hie-ghc-mod: " errText) Null + ModuleLoading -> return mempty where -- | Transform all ranges in a WorkspaceEdit from old to new positions. @@ -371,13 +372,11 @@ splitCaseCmd' uri newPos = -- --------------------------------------------------------------------- runGhcModCommand :: IdeGhcM a - -> IdeGhcM (IdeResult a) + -> IDErring IdeGhcM a runGhcModCommand cmd = - (IdeResultOk <$> cmd) `G.gcatch` + lift cmd `G.gcatch` \(e :: GM.GhcModError) -> - return $ - IdeResultFail $ - IdeError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null + ideError PluginError (T.pack $ "hie-ghc-mod: " ++ show e) Null -- --------------------------------------------------------------------- @@ -388,7 +387,7 @@ codeActionProvider docId _ _ context = renameActions = map (uncurry mkRenamableAction) terms redundantTerms = mapMaybe getRedundantImports diags redundantActions = concatMap (uncurry mkRedundantImportActions) redundantTerms - in return $ IdeResponseOk (renameActions ++ redundantActions ++ mapMaybe topLevelUnsigned diags) + in return $ renameActions ++ redundantActions ++ mapMaybe topLevelUnsigned diags where docUri = docId ^. LSP.uri diff --git a/src/Haskell/Ide/Engine/Plugin/HaRe.hs b/src/Haskell/Ide/Engine/Plugin/HaRe.hs index 0e09664b4..f8d9e2678 100644 --- a/src/Haskell/Ide/Engine/Plugin/HaRe.hs +++ b/src/Haskell/Ide/Engine/Plugin/HaRe.hs @@ -106,10 +106,10 @@ demoteCmd :: CommandFunc HarePoint WorkspaceEdit demoteCmd = CmdSync $ \(HP uri pos) -> demoteCmd' uri pos -demoteCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) -demoteCmd' uri pos = - pluginGetFile "demote: " uri $ \file -> do - runHareCommand "demote" (compDemote file (unPos pos)) +demoteCmd' :: Uri -> Position -> IDErring IdeGhcM WorkspaceEdit +demoteCmd' uri pos = do + file <- pluginGetFile "demote: " uri + runHareCommand "demote" (compDemote file (unPos pos)) -- compDemote :: FilePath -> SimpPos -> IO [FilePath] @@ -119,10 +119,10 @@ dupdefCmd :: CommandFunc HarePointWithText WorkspaceEdit dupdefCmd = CmdSync $ \(HPT uri pos name) -> dupdefCmd' uri pos name -dupdefCmd' :: Uri -> Position -> T.Text -> IdeGhcM (IdeResult WorkspaceEdit) -dupdefCmd' uri pos name = - pluginGetFile "dupdef: " uri $ \file -> do - runHareCommand "dupdef" (compDuplicateDef file (T.unpack name) (unPos pos)) +dupdefCmd' :: Uri -> Position -> T.Text -> IDErring IdeGhcM WorkspaceEdit +dupdefCmd' uri pos name = do + file <- pluginGetFile "dupdef: " uri + runHareCommand "dupdef" (compDuplicateDef file (T.unpack name) (unPos pos)) -- compDuplicateDef :: FilePath -> String -> SimpPos -> IO [FilePath] @@ -132,10 +132,10 @@ iftocaseCmd :: CommandFunc HareRange WorkspaceEdit iftocaseCmd = CmdSync $ \(HR uri startPos endPos) -> iftocaseCmd' uri (Range startPos endPos) -iftocaseCmd' :: Uri -> Range -> IdeGhcM (IdeResult WorkspaceEdit) -iftocaseCmd' uri (Range startPos endPos) = - pluginGetFile "iftocase: " uri $ \file -> do - runHareCommand "iftocase" (compIfToCase file (unPos startPos) (unPos endPos)) +iftocaseCmd' :: Uri -> Range -> IDErring IdeGhcM WorkspaceEdit +iftocaseCmd' uri (Range startPos endPos) = do + file <- pluginGetFile "iftocase: " uri + runHareCommand "iftocase" (compIfToCase file (unPos startPos) (unPos endPos)) -- compIfToCase :: FilePath -> SimpPos -> SimpPos -> IO [FilePath] @@ -145,10 +145,10 @@ liftonelevelCmd :: CommandFunc HarePoint WorkspaceEdit liftonelevelCmd = CmdSync $ \(HP uri pos) -> liftonelevelCmd' uri pos -liftonelevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) -liftonelevelCmd' uri pos = - pluginGetFile "liftonelevelCmd: " uri $ \file -> do - runHareCommand "liftonelevel" (compLiftOneLevel file (unPos pos)) +liftonelevelCmd' :: Uri -> Position -> IDErring IdeGhcM WorkspaceEdit +liftonelevelCmd' uri pos = do + file <- pluginGetFile "liftonelevelCmd: " uri + runHareCommand "liftonelevel" (compLiftOneLevel file (unPos pos)) -- compLiftOneLevel :: FilePath -> SimpPos -> IO [FilePath] @@ -158,10 +158,10 @@ lifttotoplevelCmd :: CommandFunc HarePoint WorkspaceEdit lifttotoplevelCmd = CmdSync $ \(HP uri pos) -> lifttotoplevelCmd' uri pos -lifttotoplevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) -lifttotoplevelCmd' uri pos = - pluginGetFile "lifttotoplevelCmd: " uri $ \file -> do - runHareCommand "lifttotoplevel" (compLiftToTopLevel file (unPos pos)) +lifttotoplevelCmd' :: Uri -> Position -> IDErring IdeGhcM WorkspaceEdit +lifttotoplevelCmd' uri pos = do + file <- pluginGetFile "lifttotoplevelCmd: " uri + runHareCommand "lifttotoplevel" (compLiftToTopLevel file (unPos pos)) -- compLiftToTopLevel :: FilePath -> SimpPos -> IO [FilePath] @@ -171,10 +171,10 @@ renameCmd :: CommandFunc HarePointWithText WorkspaceEdit renameCmd = CmdSync $ \(HPT uri pos name) -> renameCmd' uri pos name -renameCmd' :: Uri -> Position -> T.Text -> IdeGhcM (IdeResult WorkspaceEdit) -renameCmd' uri pos name = - pluginGetFile "rename: " uri $ \file -> do - runHareCommand "rename" (compRename file (T.unpack name) (unPos pos)) +renameCmd' :: Uri -> Position -> T.Text -> IDErring IdeGhcM WorkspaceEdit +renameCmd' uri pos name = do + file <- pluginGetFile "rename: " uri + runHareCommand "rename" (compRename file (T.unpack name) (unPos pos)) -- compRename :: FilePath -> String -> SimpPos -> IO [FilePath] @@ -184,10 +184,10 @@ deleteDefCmd :: CommandFunc HarePoint WorkspaceEdit deleteDefCmd = CmdSync $ \(HP uri pos) -> deleteDefCmd' uri pos -deleteDefCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) -deleteDefCmd' uri pos = - pluginGetFile "deletedef: " uri $ \file -> do - runHareCommand "deltetedef" (compDeleteDef file (unPos pos)) +deleteDefCmd' :: Uri -> Position -> IDErring IdeGhcM WorkspaceEdit +deleteDefCmd' uri pos = do + file <- pluginGetFile "deletedef: " uri + runHareCommand "deltetedef" (compDeleteDef file (unPos pos)) -- compDeleteDef ::FilePath -> SimpPos -> RefactGhc [ApplyRefacResult] @@ -197,10 +197,10 @@ genApplicativeCommand :: CommandFunc HarePoint WorkspaceEdit genApplicativeCommand = CmdSync $ \(HP uri pos) -> genApplicativeCommand' uri pos -genApplicativeCommand' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) -genApplicativeCommand' uri pos = - pluginGetFile "genapplicative: " uri $ \file -> - runHareCommand "genapplicative" (compGenApplicative file (unPos pos)) +genApplicativeCommand' :: Uri -> Position -> IDErring IdeGhcM WorkspaceEdit +genApplicativeCommand' uri pos = do + file <- pluginGetFile "genapplicative: " uri + runHareCommand "genapplicative" (compGenApplicative file (unPos pos)) -- --------------------------------------------------------------------- @@ -219,26 +219,19 @@ makeRefactorResult changedFiles = do -- TODO: remove this logging once we are sure we have a working solution logm $ "makeRefactorResult:groupedDiff = " ++ show (getGroupedDiff (lines $ T.unpack origText) (lines $ T.unpack newText)) logm $ "makeRefactorResult:diffops = " ++ show (diffToLineRanges $ getGroupedDiff (lines $ T.unpack origText) (lines $ T.unpack newText)) - liftToGhc $ diffText (filePathToUri fp, origText) newText IncludeDeletions + liftIde $ diffText (filePathToUri fp, origText) newText IncludeDeletions diffs <- mapM diffOne changedFiles return $ Core.reverseSortEdit $ fold diffs -- --------------------------------------------------------------------- runHareCommand :: String -> RefactGhc [ApplyRefacResult] - -> IdeGhcM (IdeResult WorkspaceEdit) + -> IDErring IdeGhcM WorkspaceEdit runHareCommand name cmd = do - eitherRes <- runHareCommand' cmd + eitherRes <- lift $ runHareCommand' cmd case eitherRes of - Left err -> - pure (IdeResultFail - (IdeError PluginError - (T.pack $ name <> ": \"" <> err <> "\"") - Null)) - Right res -> do - let changes = getRefactorResult res - refactRes <- makeRefactorResult changes - pure (IdeResultOk refactRes) + Left err -> ideError PluginError (T.pack $ name <> ": \"" <> err <> "\"") Null + Right res -> lift $ makeRefactorResult $ getRefactorResult res -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Plugin/Haddock.hs b/src/Haskell/Ide/Engine/Plugin/Haddock.hs index 291ee52b1..8486dacc0 100644 --- a/src/Haskell/Ide/Engine/Plugin/Haddock.hs +++ b/src/Haskell/Ide/Engine/Plugin/Haddock.hs @@ -7,6 +7,7 @@ module Haskell.Ide.Engine.Plugin.Haddock where import Control.Monad.State +import Control.Lens hiding ((<.>)) import Data.Foldable import qualified Data.Map as Map #if __GLASGOW_HASKELL__ < 804 @@ -80,7 +81,7 @@ nameCacheFromGhcMonad = ( read_from_session , write_to_session ) runInLightGhc :: GM.LightGhc a -> IdeM a runInLightGhc a = do - hscEnvRef <- ghcSession <$> readMTS + hscEnvRef <- use ghcSession mhscEnv <- liftIO $ traverse readIORef hscEnvRef case mhscEnv of Nothing -> error "Ghc Session not initialized" diff --git a/src/Haskell/Ide/Engine/Plugin/HieExtras.hs b/src/Haskell/Ide/Engine/Plugin/HieExtras.hs index 9604053f9..5424e7803 100644 --- a/src/Haskell/Ide/Engine/Plugin/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Plugin/HieExtras.hs @@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} module Haskell.Ide.Engine.Plugin.HieExtras ( getDynFlags , getSymbols @@ -17,6 +18,7 @@ module Haskell.Ide.Engine.Plugin.HieExtras import ConLike import Control.Monad.State +import Control.Lens import Data.Aeson import Data.Either import Data.IORef @@ -54,10 +56,10 @@ import SrcLoc import TcEnv import Var -getDynFlags :: Uri -> IdeM (IdeResponse DynFlags) -getDynFlags uri = - pluginGetFileResponse "getDynFlags: " uri $ \fp -> - withCachedModule fp (return . IdeResponseOk . ms_hspp_opts . pm_mod_summary . tm_parsed_module . tcMod) +getDynFlags :: Uri -> IdeResponseT DynFlags +getDynFlags uri = do + fp <- pluginGetFile "getDynFlags: " uri + withCachedModule fp (return . ms_hspp_opts . pm_mod_summary . tm_parsed_module . tcMod) -- --------------------------------------------------------------------- @@ -75,8 +77,8 @@ instance ModuleCache NameMapData where -- --------------------------------------------------------------------- -getSymbols :: Uri -> IdeM (IdeResponse [J.SymbolInformation]) -getSymbols uri = pluginGetFileResponse "getSymbols: " uri $ \file -> withCachedModule file $ \cm -> do +getSymbols :: Uri -> IdeResponseT [J.SymbolInformation] +getSymbols uri = pluginGetFile "getSymbols: " uri >>= \file -> withCachedModule file $ \cm -> do let tm = tcMod cm rfm = revMap cm hsMod = unLoc $ pm_parsed_source $ tm_parsed_module tm @@ -88,8 +90,8 @@ getSymbols uri = pluginGetFileResponse "getSymbols: " uri $ \file -> withCachedM go :: HsDecl GM.GhcPs -> [(J.SymbolKind,Located T.Text,Maybe T.Text)] go (TyClD FamDecl { tcdFam = FamilyDecl { fdLName = n } }) = pure (J.SkClass, s n, Nothing) go (TyClD SynDecl { tcdLName = n }) = pure (J.SkClass, s n, Nothing) - go (TyClD DataDecl { tcdLName = n, tcdDataDefn = HsDataDefn { dd_cons = cons } }) = - (J.SkClass, s n, Nothing) : concatMap (processCon (unLoc $ s n) . unLoc) cons + go (TyClD DataDecl { tcdLName = n, tcdDataDefn = HsDataDefn { dd_cons = ddcons } }) = + (J.SkClass, s n, Nothing) : concatMap (processCon (unLoc $ s n) . unLoc) ddcons go (TyClD ClassDecl { tcdLName = n, tcdSigs = sigs, tcdATs = fams }) = (J.SkInterface, sn, Nothing) : concatMap (processSig (unLoc sn) . unLoc) sigs @@ -150,12 +152,9 @@ getSymbols uri = pluginGetFileResponse "getSymbols: " uri $ \file -> withCachedM declsToSymbolInf :: (J.SymbolKind, Located T.Text, Maybe T.Text) -> IdeM (Either T.Text J.SymbolInformation) declsToSymbolInf (kind, L l nameText, cnt) = do - eloc <- srcSpan2Loc rfm l - case eloc of - Left x -> return $ Left x - Right loc -> return $ Right $ J.SymbolInformation nameText kind loc cnt - symInfs <- mapM declsToSymbolInf (imps ++ decls) - return $ IdeResponseOk $ rights symInfs + (fmap . fmap) (\loc -> J.SymbolInformation nameText kind loc cnt) (srcSpan2Loc rfm l) + symInfs <- liftIde $ mapM declsToSymbolInf (imps ++ decls) + return $ rights symInfs -- --------------------------------------------------------------------- @@ -319,7 +318,7 @@ instance ModuleCache CachedCompletions where return $ T.pack $ showGhc $ varType tyid return $ ci {thingType = typ} - hscEnvRef <- ghcSession <$> readMTS + hscEnvRef <- use ghcSession hscEnv <- liftIO $ traverse readIORef hscEnvRef (unquals, quals) <- maybe (pure ([], Map.empty)) @@ -331,13 +330,11 @@ instance ModuleCache CachedCompletions where , qualCompls = quals } -getCompletions :: Uri -> (T.Text, T.Text) -> IdeM (IdeResponse [J.CompletionItem]) -getCompletions uri (qualifier, ident) = pluginGetFileResponse "getCompletions: " uri $ \file -> +getCompletions :: Uri -> (T.Text, T.Text) -> IdeResponseT [J.CompletionItem] +getCompletions uri (qualifier, ident) = pluginGetFile "getCompletions: " uri >>= \file -> let handlers = [ GM.GHandler $ \(ex :: SomeException) -> - return $ IdeResponseFail $ IdeError PluginError - (T.pack $ "getCompletions" <> ": " <> (show ex)) - Null + ideError PluginError (T.pack $ "getCompletions" <> ": " <> (show ex)) Null ] in flip GM.gcatches handlers $ do -- debugm $ "got prefix" ++ show (qualifier, ident) @@ -355,13 +352,13 @@ getCompletions uri (qualifier, ident) = pluginGetFileResponse "getCompletions: " then unqualCompls else Map.findWithDefault [] qualifier qualCompls - in return $ IdeResponseOk $ filtModNameCompls ++ map mkCompl filtCompls + in return $ filtModNameCompls ++ map mkCompl filtCompls -- --------------------------------------------------------------------- getTypeForName :: Name -> IdeM (Maybe Type) getTypeForName n = do - hscEnvRef <- ghcSession <$> readMTS + hscEnvRef <- use ghcSession mhscEnv <- liftIO $ traverse readIORef hscEnvRef case mhscEnv of Nothing -> return Nothing @@ -372,9 +369,10 @@ getTypeForName n = do -- --------------------------------------------------------------------- -getSymbolsAtPoint :: Uri -> Position -> IdeM (IdeResponse [(Range, Name)]) -getSymbolsAtPoint uri pos = pluginGetFileResponse "getSymbolsAtPoint: " uri $ \file -> - withCachedModule file $ return . IdeResponseOk . getSymbolsAtPointPure pos +getSymbolsAtPoint :: Uri -> Position -> IdeResponseT [(Range, Name)] +getSymbolsAtPoint uri pos = do + file <- pluginGetFile "getSymbolsAtPoint: " uri + withCachedModule file $ return . getSymbolsAtPointPure pos getSymbolsAtPointPure :: Position -> CachedModule -> [(Range,Name)] getSymbolsAtPointPure pos cm = maybe [] (`getArtifactsAtPos` locMap cm) $ newPosToOld cm pos @@ -392,37 +390,30 @@ symbolFromTypecheckedModule lm pos = -- | Find the references in the given doc, provided it has been -- loaded. If not, return the empty list. -getReferencesInDoc :: Uri -> Position -> IdeM (IdeResponse [J.DocumentHighlight]) -getReferencesInDoc uri pos = - pluginGetFileResponse "getReferencesInDoc: " uri $ \file -> - withCachedModuleAndDataDefault file (Just (IdeResponseOk [])) $ - \cm NMD{inverseNameMap} -> do - let lm = locMap cm +getReferencesInDoc :: Uri -> Position -> IdeResponseT [J.DocumentHighlight] +getReferencesInDoc uri pos = do + file <- pluginGetFile "getReferencesInDoc: " uri + withCachedModuleAndDataDefault file (Just $ return []) $ + \cm NMD{inverseNameMap} -> return $ + [ J.DocumentHighlight r' (Just kind) + | let lm = locMap cm pm = tm_parsed_module $ tcMod cm cfile = ml_hs_file $ ms_location $ pm_mod_summary pm mpos = newPosToOld cm pos - case mpos of - Nothing -> return $ IdeResponseOk [] - Just pos' -> return $ fmap concat $ - forM (getArtifactsAtPos pos' lm) $ \(_,name) -> do - let usages = fromMaybe [] $ Map.lookup name inverseNameMap - defn = nameSrcSpan name - defnInSameFile = - (unpackFS <$> srcSpanFileName_maybe defn) == cfile - makeDocHighlight :: SrcSpan -> Maybe J.DocumentHighlight - makeDocHighlight spn = do - let kind = if spn == defn then J.HkWrite else J.HkRead - let - foo (Left _) = Nothing - foo (Right r) = Just r - r <- foo $ srcSpan2Range spn - r' <- oldRangeToNew cm r - return $ J.DocumentHighlight r' (Just kind) - highlights - | isVarOcc (occName name) - && defnInSameFile = mapMaybe makeDocHighlight (defn : usages) - | otherwise = mapMaybe makeDocHighlight usages - return highlights + , pos' <- maybeToList mpos + , (_,name) <- getArtifactsAtPos pos' lm + , let usages = fromMaybe [] $ Map.lookup name inverseNameMap + defn = nameSrcSpan name + defnInSameFile = + (unpackFS <$> srcSpanFileName_maybe defn) == cfile + mdefn + | isVarOcc (occName name) && defnInSameFile = (defn :) + | otherwise = id + , spn <- mdefn usages + , let kind = if spn == defn then J.HkWrite else J.HkRead + , Right r <- [srcSpan2Range spn] + , r' <- maybeToList $ oldRangeToNew cm r + ] -- --------------------------------------------------------------------- @@ -446,45 +437,43 @@ getModule df n = do -- --------------------------------------------------------------------- -- | Return the definition -findDef :: Uri -> Position -> IdeM (IdeResponse [Location]) -findDef uri pos = pluginGetFileResponse "findDef: " uri $ \file -> - withCachedModuleDefault file (Just (IdeResponseOk [])) (\cm -> do - let rfm = revMap cm - lm = locMap cm - mm = moduleMap cm - oldPos = newPosToOld cm pos - - case (\x -> Just $ getArtifactsAtPos x mm) =<< oldPos of - Just ((_,mn):_) -> gotoModule rfm mn - _ -> case symbolFromTypecheckedModule lm =<< oldPos of - Nothing -> return $ IdeResponseOk [] - Just (_, n) -> - case nameSrcSpan n of - UnhelpfulSpan _ -> return $ IdeResponseOk [] - realSpan -> do - res <- srcSpan2Loc rfm realSpan - case res of - Right l@(J.Location luri range) -> - case uriToFilePath luri of - Nothing -> return $ IdeResponseOk [l] - Just fp -> do - mcm' <- getCachedModule fp - case mcm' of - ModuleCached cm' _ -> case oldRangeToNew cm' range of - Just r -> return $ IdeResponseOk [J.Location luri r] - Nothing -> return $ IdeResponseOk [l] - _ -> return $ IdeResponseOk [l] - Left x -> do - debugm "findDef: name srcspan not found/valid" - pure (IdeResponseFail - (IdeError PluginError - ("hare:findDef" <> ": \"" <> x <> "\"") - Null))) +findDef :: Uri -> Position -> IdeResponseT [Location] +findDef uri pos = do + file <- pluginGetFile "findDef: " uri + withCachedModuleDefault file (Just $ return []) $ \cm -> do + let rfm = revMap cm + lm = locMap cm + mm = moduleMap cm + oldPos = newPosToOld cm pos + + case (\x -> Just $ getArtifactsAtPos x mm) =<< oldPos of + Just ((_,mn):_) -> gotoModule rfm mn + _ -> case symbolFromTypecheckedModule lm =<< oldPos of + Nothing -> return [] + Just (_, n) -> + case nameSrcSpan n of + UnhelpfulSpan _ -> return [] + realSpan -> do + res <- srcSpan2Loc rfm realSpan + case res of + Right l@(J.Location luri range) -> + case uriToFilePath luri of + Nothing -> return [l] + Just fp -> do + mcm' <- getCachedModule fp + case mcm' of + ModuleCached cm' _ -> case oldRangeToNew cm' range of + Just r -> return [J.Location luri r] + Nothing -> return [l] + _ -> return [l] + Left x -> do + debugm "findDef: name srcspan not found/valid" + ideError PluginError ("hare:findDef" <> ": \"" <> x <> "\"") Null where - gotoModule :: (FilePath -> FilePath) -> ModuleName -> IdeM (IdeResponse [Location]) + gotoModule :: (FilePath -> FilePath) -> ModuleName -> IdeResponseT [Location] gotoModule rfm mn = do - hscEnvRef <- ghcSession <$> readMTS + hscEnvRef <- use ghcSession mHscEnv <- liftIO $ traverse readIORef hscEnvRef case mHscEnv of @@ -499,8 +488,7 @@ findDef uri pos = pluginGetFileResponse "findDef: " uri $ \file -> let r = Range (Position 0 0) (Position 0 0) loc = Location (filePathToUri fp) r - return (IdeResponseOk [loc]) - _ -> return (IdeResponseOk []) - Nothing -> return $ IdeResponseFail - (IdeError PluginError "Couldn't get hscEnv when finding import" Null) + return [loc] + _ -> return [] + Nothing -> ideError PluginError "Couldn't get hscEnv when finding import" Null diff --git a/src/Haskell/Ide/Engine/Plugin/Hoogle.hs b/src/Haskell/Ide/Engine/Plugin/Hoogle.hs index ce4962989..9b9221dd9 100644 --- a/src/Haskell/Ide/Engine/Plugin/Hoogle.hs +++ b/src/Haskell/Ide/Engine/Plugin/Hoogle.hs @@ -4,19 +4,19 @@ module Haskell.Ide.Engine.Plugin.Hoogle where import Control.Monad.IO.Class import Data.Aeson -import Data.Bifunctor import Data.Maybe #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif -import qualified Data.Text as T -import Data.List +import qualified Data.Text as T +import Data.List import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.MonadFunctions import Hoogle import System.Directory import Text.HTML.TagSoup import Text.HTML.TagSoup.Tree +import Control.Monad.Trans -- --------------------------------------------------------------------- @@ -41,11 +41,11 @@ data HoogleError = NoDb | NoResults deriving (Eq,Ord,Show) newtype HoogleDb = HoogleDb (Maybe FilePath) -hoogleErrorToIdeError :: HoogleError -> IdeError +hoogleErrorToIdeError :: HoogleError -> IDErring IdeGhcM a hoogleErrorToIdeError NoResults = - IdeError PluginError "No results found" Null + ideError PluginError "No results found" Null hoogleErrorToIdeError NoDb = - IdeError PluginError "Hoogle database not found. Run hoogle generate to generate" Null + ideError PluginError "Hoogle database not found. Run hoogle generate to generate" Null instance ExtensionClass HoogleDb where initialValue = HoogleDb Nothing @@ -55,18 +55,15 @@ initializeHoogleDb = do db' <- liftIO $ defaultDatabaseLocation db <- liftIO $ makeAbsolute db' exists <- liftIO $ doesFileExist db - if exists then do + if exists then lift $ lift $ do put $ HoogleDb $ Just db return $ Just db else return Nothing infoCmd :: CommandFunc T.Text T.Text -infoCmd = CmdSync $ \expr -> do - res <- liftToGhc $ bimap hoogleErrorToIdeError id <$> infoCmd' expr - return $ case res of - Left err -> IdeResultFail err - Right x -> IdeResultOk x +infoCmd = CmdSync $ \expr -> + either hoogleErrorToIdeError pure =<< liftIde (infoCmd' expr) infoCmd' :: T.Text -> IdeM (Either HoogleError T.Text) infoCmd' expr = do @@ -108,28 +105,23 @@ renderTarget t = T.intercalate "\n\n" $ ------------------------------------------------------------------------ -searchModules :: T.Text -> IdeM [T.Text] +searchModules :: T.Text -> IDErring IdeM [T.Text] searchModules = fmap (nub . take 5) . searchTargets (fmap (T.pack . fst) . targetModule) -searchPackages :: T.Text -> IdeM [T.Text] +searchPackages :: T.Text -> IDErring IdeM [T.Text] searchPackages = fmap (nub . take 5) . searchTargets (fmap (T.pack . fst) . targetPackage) -searchTargets :: (Target -> Maybe a) -> T.Text -> IdeM [a] +searchTargets :: (Target -> Maybe a) -> T.Text -> IDErring IdeM [a] searchTargets f term = do HoogleDb mdb <- get res <- liftIO $ runHoogleQuery mdb term (Right . mapMaybe f . take 10) - case bimap hoogleErrorToIdeError id res of - Left _ -> return [] - Right xs -> return xs + return $ either (const []) id res -- Discards hoogle errors! ------------------------------------------------------------------------ lookupCmd :: CommandFunc T.Text [T.Text] lookupCmd = CmdSync $ \term -> do - res <- liftToGhc $ bimap hoogleErrorToIdeError id <$> lookupCmd' 10 term - return $ case res of - Left err -> IdeResultFail err - Right x -> IdeResultOk x + either hoogleErrorToIdeError pure =<< liftIde (lookupCmd' 10 term) lookupCmd' :: Int -> T.Text -> IdeM (Either HoogleError [T.Text]) lookupCmd' n term = do diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index 4bef1ab70..9ee42d6f4 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -22,6 +22,8 @@ import Haskell.Ide.Engine.PluginUtils import qualified Haskell.Ide.Engine.Plugin.Hoogle as Hoogle import System.Directory import System.IO +import Control.Monad.Trans +import Control.Monad.Morph hsimportDescriptor :: PluginDescriptor hsimportDescriptor = PluginDescriptor @@ -40,47 +42,46 @@ data ImportParams = ImportParams importCmd :: CommandFunc ImportParams J.WorkspaceEdit importCmd = CmdSync $ \(ImportParams uri modName) -> importModule uri modName -importModule :: Uri -> T.Text -> IdeGhcM (IdeResult J.WorkspaceEdit) -importModule uri modName = - pluginGetFile "hsimport cmd: " uri $ \origInput -> do - fileMap <- GM.mkRevRedirMapFunc - GM.withMappedFile origInput $ \input -> do +importModule :: Uri -> T.Text -> IDErring IdeGhcM J.WorkspaceEdit +importModule uri modName = do + origInput <- pluginGetFile "hsimport cmd: " uri + fileMap <- lift $ GM.mkRevRedirMapFunc + GM.withMappedFile origInput $ \input -> do - tmpDir <- liftIO getTemporaryDirectory - (output, outputH) <- liftIO $ openTempFile tmpDir "hsimportOutput" - liftIO $ hClose outputH + tmpDir <- liftIO getTemporaryDirectory + (output, outputH) <- liftIO $ openTempFile tmpDir "hsimportOutput" + liftIO $ hClose outputH - let args = defaultArgs { moduleName = T.unpack modName - , inputSrcFile = input - , outputSrcFile = output - } - maybeErr <- liftIO $ hsimportWithArgs defaultConfig args - case maybeErr of - Just err -> do - liftIO $ removeFile output - let msg = T.pack $ show err - return $ IdeResultFail (IdeError PluginError msg Null) - Nothing -> do - newText <- liftIO $ T.readFile output - liftIO $ removeFile output - workspaceEdit <- liftToGhc $ makeDiffResult input newText fileMap - return $ IdeResultOk workspaceEdit + let args = defaultArgs { moduleName = T.unpack modName + , inputSrcFile = input + , outputSrcFile = output + } + maybeErr <- liftIO $ hsimportWithArgs defaultConfig args + case maybeErr of + Just err -> do + liftIO $ removeFile output + ideError PluginError (T.pack $ show err) Null + Nothing -> do + newText <- liftIO $ T.readFile output + liftIO $ removeFile output + workspaceEdit <- liftIde $ makeDiffResult input newText fileMap + return workspaceEdit codeActionProvider :: CodeActionProvider codeActionProvider docId _ _ context = do let J.List diags = context ^. J.diagnostics terms = mapMaybe getImportables diags - res <- mapM (bimapM return Hoogle.searchModules) terms + res <- hoist lift $ mapM (bimapM return Hoogle.searchModules) terms let actions = mapMaybe (uncurry mkImportAction) (concatTerms res) if null actions then do let relaxedTerms = map (bimap id (head . T.words)) terms - relaxedRes <- mapM (bimapM return Hoogle.searchModules) relaxedTerms + relaxedRes <- hoist lift $ mapM (bimapM return Hoogle.searchModules) relaxedTerms let relaxedActions = mapMaybe (uncurry mkImportAction) (concatTerms relaxedRes) - return $ IdeResponseOk relaxedActions - else return $ IdeResponseOk actions + return relaxedActions + else return actions where concatTerms = concatMap (\(d, ts) -> map (d,) ts) diff --git a/src/Haskell/Ide/Engine/Plugin/Package.hs b/src/Haskell/Ide/Engine/Plugin/Package.hs index 710802028..6cf814e20 100644 --- a/src/Haskell/Ide/Engine/Plugin/Package.hs +++ b/src/Haskell/Ide/Engine/Plugin/Package.hs @@ -42,6 +42,8 @@ import System.FilePath import Haskell.Ide.Engine.Compat (isExtensionOf) #endif import Control.Monad.IO.Class +import Control.Monad.Trans +import Control.Monad.Morph import System.Directory import qualified GhcMod.Utils as GM import Distribution.Types.GenericPackageDescription @@ -77,12 +79,12 @@ addCmd = CmdSync $ \(AddParams rootDir modulePath pkg) -> do absFp <- liftIO $ canonicalizePath relFp let relModulePath = makeRelative (takeDirectory absFp) modulePath - liftToGhc $ editCabalPackage absFp relModulePath (T.unpack pkg) fileMap + liftIde $ editCabalPackage absFp relModulePath (T.unpack pkg) fileMap HpackPackage relFp -> do absFp <- liftIO $ canonicalizePath relFp let relModulePath = makeRelative (takeDirectory absFp) modulePath - liftToGhc $ editHpackPackage absFp relModulePath pkg - NoPackage -> return $ IdeResultFail (IdeError PluginError "No package.yaml or .cabal found" Null) + editHpackPackage absFp relModulePath pkg + NoPackage -> ideError PluginError "No package.yaml or .cabal found" Null data PackageType = CabalPackage FilePath | HpackPackage FilePath @@ -100,11 +102,11 @@ findPackageType rootDir = do -- Currently does not preserve format. -- Keep an eye out on this other GSOC project! -- https://github.com/wisn/format-preserving-yaml -editHpackPackage :: FilePath -> FilePath -> T.Text -> IdeM (IdeResult WorkspaceEdit) +editHpackPackage :: FilePath -> FilePath -> T.Text -> IDErring IdeGhcM WorkspaceEdit editHpackPackage fp modulePath pkgName = do contents <- liftIO $ B.readFile fp - supportsDocChanges <- clientSupportsDocumentChanges + supportsDocChanges <- liftIde clientSupportsDocumentChanges case Y.decodeThrow contents :: Maybe Object of Just obj -> do @@ -132,8 +134,8 @@ editHpackPackage fp modulePath pkgName = do then J.WorkspaceEdit Nothing (Just (J.List [textDocEdit])) else J.WorkspaceEdit (Just (HM.singleton docUri (J.List [textEdit]))) Nothing - return $ IdeResultOk wsEdit - Nothing -> return $ IdeResultFail (IdeError PluginError "Couldn't parse package.yaml" Null) + return wsEdit + Nothing -> ideError PluginError "Couldn't parse package.yaml" Null where @@ -182,7 +184,7 @@ editHpackPackage fp modulePath pkgName = do -- | Takes a cabal file and a path to a module in the dependency you want to edit. -editCabalPackage :: FilePath -> FilePath -> String -> (FilePath -> FilePath) -> IdeM (IdeResult J.WorkspaceEdit) +editCabalPackage :: FilePath -> FilePath -> String -> (FilePath -> FilePath) -> IdeM J.WorkspaceEdit editCabalPackage file modulePath pkgName fileMap = do package <- liftIO $ readGenericPackageDescription normal file @@ -196,7 +198,7 @@ editCabalPackage file modulePath pkgName fileMap = do let newContents = T.pack $ PP.showGenericPackageDescription newPackage - IdeResultOk <$> makeAdditiveDiffResult file newContents fileMap + makeAdditiveDiffResult file newContents fileMap where @@ -232,10 +234,10 @@ codeActionProvider docId mRootDir _ context = do let J.List diags = context ^. J.diagnostics pkgs = mapMaybe getAddablePackages diags - res <- mapM (bimapM return Hoogle.searchPackages) pkgs + res <- hoist lift $ mapM (bimapM return Hoogle.searchPackages) pkgs let actions = mapMaybe (uncurry mkAddPackageAction) (concatPkgs res) - return $ IdeResponseOk actions + return actions where concatPkgs = concatMap (\(d, ts) -> map (d,) ts) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 38d737e0c..87d907592 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -24,6 +24,8 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM import Control.Monad.Reader +import Control.Monad.Morph +import Control.Applicative import qualified Data.Aeson as J import Data.Aeson ( (.=) ) import qualified Data.ByteString.Lazy as BL @@ -200,38 +202,33 @@ mapFileFromVfs tn vtdi = do ver = fromMaybe 0 (vtdi ^. J.version) vfsFunc <- asksLspFuncs Core.getVirtualFileFunc mvf <- liftIO $ vfsFunc uri - case (mvf, uriToFilePath uri) of - (Just (VFS.VirtualFile _ yitext), Just fp) -> do + for_ mvf $ \(VFS.VirtualFile _ yitext) -> + for_ (uriToFilePath uri) $ \fp -> do let text' = Yi.toString yitext -- text = "{-# LINE 1 \"" ++ fp ++ "\"#-}\n" <> text' - let req = GReq tn (Just uri) Nothing Nothing (const $ return ()) - $ IdeResultOk <$> do - GM.loadMappedFileSource fp text' + let req = GReq tn (Just uri) Nothing Nothing (const $ return ()) $ do + lift $ GM.loadMappedFileSource fp text' fileMap <- GM.getMMappedFiles debugm $ "file mapping state is: " ++ show fileMap liftIO $ atomically $ do modifyTVar' verTVar (Map.insert uri ver) writeTChan cin req - return () - (_, _) -> return () _unmapFileFromVfs :: (MonadIO m, MonadReader REnv m) => TrackingNumber -> J.Uri -> m () _unmapFileFromVfs tn uri = do verTVar <- asks (docVersionTVar . dispatcherEnv) cin <- asks reqChanIn - case J.uriToFilePath uri of - Just fp -> do - let req = GReq tn (Just uri) Nothing Nothing (const $ return ()) - $ IdeResultOk <$> GM.unloadMappedFile fp - liftIO $ atomically $ do - modifyTVar' verTVar (Map.delete uri) - writeTChan cin req - return () - _ -> return () + for_ (J.uriToFilePath uri) $ \fp -> do + let req = GReq tn (Just uri) Nothing Nothing (const $ return ()) + $ lift $ GM.unloadMappedFile fp + liftIO $ atomically $ do + modifyTVar' verTVar (Map.delete uri) + writeTChan cin req -- TODO: generalise this and move it to GhcMod.ModuleLoader -updatePositionMap :: Uri -> [J.TextDocumentContentChangeEvent] -> IdeGhcM (IdeResult ()) -updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file -> do +updatePositionMap :: Uri -> [J.TextDocumentContentChangeEvent] -> IDErring IdeGhcM () +updatePositionMap uri changes = do + file <- pluginGetFile "updatePositionMap: " uri mcm <- getCachedModule file case mcm of ModuleCached cm _ -> do @@ -243,9 +240,7 @@ updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file go _ _ = (const Nothing, const Nothing) let cm' = cm {newPosToOld = n2o, oldPosToNew = o2n} cacheModuleNoClear file cm' - return $ IdeResultOk () - _ -> - return $ IdeResultOk () + _ -> return () where f (+/-) (J.Range (Position sl _) (Position el _)) txt p@(Position l c) | l < sl = Just p @@ -378,7 +373,7 @@ reactor inp = do lf <- ask - let hreq = GReq tn Nothing Nothing Nothing callback $ IdeResultOk <$> Hoogle.initializeHoogleDb + let hreq = GReq tn Nothing Nothing Nothing callback $ lift Hoogle.initializeHoogleDb callback Nothing = flip runReaderT lf $ reactorSend $ NotShowMessage $ fmServerShowMessageNotification J.MtWarning "No hoogle db found. Check the README for instructions to generate one" @@ -421,12 +416,12 @@ reactor inp = do ver = vtdi ^. J.version J.List changes = params ^. J.contentChanges mapFileFromVfs tn vtdi - makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) $ + makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) $ do -- mark this module's cache as stale - pluginGetFile "markCacheStale:" uri $ \fp -> do - markCacheStale fp - -- Important - Call this before requestDiagnostics - updatePositionMap uri changes + fp <- pluginGetFile "markCacheStale:" uri + markCacheStale fp + -- Important - Call this before requestDiagnostics + updatePositionMap uri changes requestDiagnostics tn uri ver NotDidCloseTextDocument notification -> do @@ -434,10 +429,8 @@ reactor inp = do let uri = notification ^. J.params . J.textDocument . J.uri -- unmapFileFromVfs versionTVar cin uri - makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) $ do - forM_ (uriToFilePath uri) - deleteCachedModule - return $ IdeResultOk () + makeRequest $ GReq tn (Just uri) Nothing Nothing (const $ return ()) $ + forM_ (uriToFilePath uri) deleteCachedModule -- ------------------------------- @@ -459,31 +452,20 @@ reactor inp = do liftIO $ U.logs $ "reactor:got HoverRequest:" ++ show req let params = req ^. J.params pos = params ^. J.position - doc = params ^. J.textDocument . J.uri - callback (typ, docs, mrange) = do - let - ht = case mrange of - Nothing -> J.Hover (J.List []) Nothing - Just range -> J.Hover (J.List hovers) - (Just range) - where - hovers = catMaybes [typ] ++ fmap J.PlainString docs - rspMsg = Core.makeResponseMessage req ht - reactorSend $ RspHover rspMsg + doc = params ^. J.textDocument . J.uri :: Uri + callback (typ, docs, mrange) = + reactorSend $ RspHover $ Core.makeResponseMessage req $ flip J.Hover mrange $ J.List $ + if isNothing mrange then [] else catMaybes [typ] ++ fmap J.PlainString docs let - getHoverInfo :: IdeM (IdeResponse (Maybe J.MarkedString, [T.Text], Maybe Range)) - getHoverInfo = runIdeResponseT $ do - info' <- IdeResponseT $ IdeResponseResult <$> GhcMod.newTypeCmd pos doc - names' <- IdeResponseT $ Hie.getSymbolsAtPoint doc pos + getHoverInfo :: IdeResponseT (Maybe J.MarkedString, [T.Text], Maybe Range) + getHoverInfo = do + info' <- hoist lift $ GhcMod.newTypeCmd pos doc + names' <- Hie.getSymbolsAtPoint doc pos let f = (==) `on` (Hie.showName . snd) f' = compare `on` (Hie.showName . snd) names = mapMaybe pickName $ groupBy f $ sortBy f' names' - pickName [] = Nothing - pickName [x] = Just x - pickName xs@(x:_) = case find (isJust . nameModule_maybe . snd) xs of - Nothing -> Just x - Just a -> Just a + pickName xs = find (isJust . nameModule_maybe . snd) xs <|> listToMaybe xs nnames = length names (info,mrange) = case map last $ groupBy ((==) `on` fst) info' of @@ -499,31 +481,31 @@ reactor inp = do [] -> case names of [] -> (Nothing, Nothing) ((r,_):_) -> (Nothing, Just r) - df <- IdeResponseT $ Hie.getDynFlags doc - docs <- forM names $ \(_,name) -> do + df <- Hie.getDynFlags doc + docs <- liftIde $ forM names $ \(_,name) -> do let sname = Hie.showName name case Hie.getModule df name of Nothing -> return $ "`" <> sname <> "` *local*" (Just (pkg,mdl)) -> do let mname = "`"<> sname <> "`\n\n" let minfo = maybe "" (<>" ") pkg <> mdl - mdocu' <- lift $ Haddock.getDocsWithType df name + mdocu' <- Haddock.getDocsWithType df name mdocu <- case mdocu' of Just _ -> return mdocu' -- Hoogle as fallback - Nothing -> lift $ getDocsForName sname pkg mdl - case mdocu of - Nothing -> return $ mname <> minfo - Just docu -> return $ docu <> "\n\n" <> minfo + Nothing -> getDocsForName sname pkg mdl + return $ case mdocu of + Nothing -> mname <> minfo + Just docu -> docu <> "\n\n" <> minfo return (info,docs,mrange) let hreq = IReq tn (req ^. J.id) callback $ do - pluginGetFileResponse "ReqHover:" doc $ \fp -> do - cached <- isCached fp - -- Hover requests need to be instant so don't wait - -- for cached module to be loaded - if cached - then getHoverInfo - else return (IdeResponseOk (Nothing,[],Nothing)) + fp <- pluginGetFile "ReqHover:" doc + cached <- isCached fp + -- Hover requests need to be instant so don't wait + -- for cached module to be loaded + if cached + then getHoverInfo + else return (Nothing,[],Nothing) makeRequest hreq liftIO $ U.logs $ "reactor:HoverRequest done" @@ -639,10 +621,10 @@ reactor inp = do let rspMsg = Core.makeResponseMessage req $ origCompl & J.documentation .~ docs reactorSend $ RspCompletionItemResolve rspMsg - hreq = IReq tn (req ^. J.id) callback $ runIdeResponseT $ case mquery of + hreq = IReq tn (req ^. J.id) callback $ case mquery of Nothing -> return Nothing Just query -> do - result <- lift $ Hoogle.infoCmd' query + result <- liftIde $ Hoogle.infoCmd' query case result of Right x -> return $ Just x _ -> return Nothing @@ -669,18 +651,18 @@ reactor inp = do pos = params ^. J.position callback = reactorSend . RspDefinition . Core.makeResponseMessage req let hreq = IReq tn (req ^. J.id) callback - $ fmap J.MultiLoc <$> Hie.findDef doc pos + $ J.MultiLoc <$> Hie.findDef doc pos makeRequest hreq ReqFindReferences req -> do liftIO $ U.logs $ "reactor:got FindReferences:" ++ show req -- TODO: implement project-wide references let params = req ^. J.params - doc = params ^. (J.textDocument . J.uri) + doc = params ^. J.textDocument . J.uri pos = params ^. J.position callback = reactorSend . RspFindReferences. Core.makeResponseMessage req . J.List let hreq = IReq tn (req ^. J.id) callback - $ fmap (map (J.Location doc . (^. J.range))) + $ map (J.Location doc . (^. J.range)) <$> Hie.getReferencesInDoc doc pos makeRequest hreq diff --git a/src/Haskell/Ide/Engine/Types.hs b/src/Haskell/Ide/Engine/Types.hs index 2b2af90cb..3d86f5778 100644 --- a/src/Haskell/Ide/Engine/Types.hs +++ b/src/Haskell/Ide/Engine/Types.hs @@ -22,11 +22,11 @@ pattern GReq :: TrackingNumber -> Maybe (Uri, Int) -> Maybe J.LspId -> RequestCallback m a1 - -> IdeGhcM (IdeResult a1) + -> IDErring IdeGhcM a1 -> PluginRequest m pattern GReq a b c d e f = Right (GhcRequest a b c d e f) -pattern IReq :: TrackingNumber -> J.LspId -> RequestCallback m a -> IdeM (IdeResponse a) -> Either (IdeRequest m) b +pattern IReq :: TrackingNumber -> J.LspId -> RequestCallback m a -> IdeResponseT a -> Either (IdeRequest m) b pattern IReq a b c d = Left (IdeRequest a b c d) type PluginRequest m = Either (IdeRequest m) (GhcRequest m) @@ -37,14 +37,14 @@ data GhcRequest m = forall a. GhcRequest , pinDocVer :: Maybe (J.Uri, Int) , pinLspReqId :: Maybe J.LspId , pinCallback :: RequestCallback m a - , pinReq :: IdeGhcM (IdeResult a) + , pinReq :: IDErring IdeGhcM a } data IdeRequest m = forall a. IdeRequest { pureMsgNum :: TrackingNumber -- ^ Exists to facilitate logging/tracing , pureReqId :: J.LspId , pureReqCallback :: RequestCallback m a - , pureReq :: IdeM (IdeResponse a) + , pureReq :: IdeResponseT a } -- --------------------------------------------------------------------- diff --git a/stack.yaml b/stack.yaml index af54b371b..8411ae726 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,6 +41,7 @@ extra-deps: - syz-0.2.0.0 - temporary-1.2.1.1 - yaml-0.8.32 +- windns-0.1.0.0@sha256:c76bd0ad129ea694e1e20c5397a9e58232de656dfafc336ecbe9bf5accb2c1a6 flags: haskell-ide-engine: diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index 785f97889..35b756483 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -116,7 +116,7 @@ dispatchGhcRequest tn ctx n cin lc plugin com arg = do dispatchIdeRequest :: (Typeable a, ToJSON a) => TrackingNumber -> String -> TChan (PluginRequest IO) - -> TChan LogVal -> LspId -> IdeM (IdeResponse a) -> IO () + -> TChan LogVal -> LspId -> IdeResponseT a -> IO () dispatchIdeRequest tn ctx cin lc lid f = do let logger :: (Typeable a, ToJSON a) => RequestCallback IO a @@ -144,10 +144,10 @@ newPluginSpec = do cancelTVar <- newTVarIO S.empty wipTVar <- newTVarIO S.empty versionTVar <- newTVarIO $ Map.singleton (filePathToUri "test") 3 - let req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) (atomically . writeTChan outChan) $ return $ IdeResultOk $ T.pack "text1" - req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) (atomically . writeTChan outChan) $ return $ IdeResultOk $ T.pack "text2" - req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing (atomically . writeTChan outChan) $ return $ IdeResultOk $ T.pack "text3" - req4 = GReq 4 Nothing Nothing (Just $ IdInt 3) (atomically . writeTChan outChan) $ return $ IdeResultOk $ T.pack "text4" + let req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) (atomically . writeTChan outChan) $ return $ T.pack "text1" + req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) (atomically . writeTChan outChan) $ return $ T.pack "text2" + req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing (atomically . writeTChan outChan) $ return $ T.pack "text3" + req4 = GReq 4 Nothing Nothing (Just $ IdInt 3) (atomically . writeTChan outChan) $ return $ T.pack "text4" pid <- forkIO $ dispatcherP inChan (pluginDescToIdePlugins []) @@ -180,11 +180,11 @@ funcSpec = describe "functional dispatch" $ do let -- Model a hover request hoverReq tn idVal doc = dispatchIdeRequest tn ("IReq " ++ show idVal) cin logChan idVal $ do - pluginGetFileResponse "hoverReq" doc $ \fp -> do - cached <- isCached fp - if cached - then return (IdeResponseOk Cached) - else return (IdeResponseOk NotCached) + fp <- pluginGetFile "hoverReq" doc + cached <- isCached fp + if cached + then return Cached + else return NotCached unpackRes (r,Right md) = (r, fromDynJSON md) unpackRes r = error $ "unpackRes:" ++ show r diff --git a/test/unit/ApplyRefactPluginSpec.hs b/test/unit/ApplyRefactPluginSpec.hs index ca67daa05..712f51ebc 100644 --- a/test/unit/ApplyRefactPluginSpec.hs +++ b/test/unit/ApplyRefactPluginSpec.hs @@ -44,9 +44,7 @@ applyRefactSpec = do act = applyOneCmd' furi (OneHint (toPos (2,8)) "Redundant bracket") arg = AOP furi (toPos (2,8)) "Redundant bracket" textEdits = List [TextEdit (Range (Position 1 0) (Position 1 25)) "main = putStrLn \"hello\""] - res = IdeResultOk $ WorkspaceEdit - (Just $ H.singleton applyRefactPath textEdits) - Nothing + res = return $ WorkspaceEdit (Just $ H.singleton applyRefactPath textEdits) Nothing testCommand testPlugins act "applyrefact" "applyOne" arg res -- --------------------------------- @@ -57,7 +55,7 @@ applyRefactSpec = do arg = applyRefactPath textEdits = List [ TextEdit (Range (Position 1 0) (Position 1 25)) "main = putStrLn \"hello\"" , TextEdit (Range (Position 3 0) (Position 3 15)) "foo x = x + 1" ] - res = IdeResultOk $ WorkspaceEdit + res = return $ WorkspaceEdit (Just $ H.singleton applyRefactPath textEdits) Nothing testCommand testPlugins act "applyrefact" "applyAll" arg res @@ -68,8 +66,7 @@ applyRefactSpec = do let act = lintCmd' arg arg = applyRefactPath - res = IdeResultOk - PublishDiagnosticsParams + res = return $ PublishDiagnosticsParams { _uri = applyRefactPath , _diagnostics = List $ [ Diagnostic (Range (Position 1 7) (Position 1 25)) @@ -94,8 +91,7 @@ applyRefactSpec = do let act = lintCmd' arg arg = filePath - res = IdeResultOk - PublishDiagnosticsParams + res = return $ PublishDiagnosticsParams { _uri = filePath , _diagnostics = List $ [Diagnostic {_range = Range { _start = Position {_line = 11, _character = 28} @@ -113,9 +109,8 @@ applyRefactSpec = do filePath <- filePathToUri <$> makeAbsolute "./test/testdata/HlintPragma.hs" let req = lintCmd' filePath - r <- runIGM testPlugins req - r `shouldBe` - (IdeResultOk + r <- runIGM testPlugins $ runIDErring req + r `shouldBe` Right (PublishDiagnosticsParams { _uri = filePath , _diagnostics = List @@ -127,7 +122,7 @@ applyRefactSpec = do Nothing ] } - )) + ) -- --------------------------------- @@ -135,13 +130,12 @@ applyRefactSpec = do filePath <- filePathToUri <$> makeAbsolute "./test/testdata/HlintPragma.hs" let req = lintCmd' filePath - r <- cdAndDo "./test/testdata" $ runIGM testPlugins req - r `shouldBe` - (IdeResultOk + r <- cdAndDo "./test/testdata" $ runIGM testPlugins $ runIDErring req + r `shouldBe` Right (PublishDiagnosticsParams -- { _uri = filePathToUri "./HlintPragma.hs" { _uri = filePath , _diagnostics = List [] } - )) + ) diff --git a/test/unit/BrittanySpec.hs b/test/unit/BrittanySpec.hs index 09c5e1426..ff670fc21 100644 --- a/test/unit/BrittanySpec.hs +++ b/test/unit/BrittanySpec.hs @@ -30,7 +30,7 @@ brittanySpec = describe "brittany plugin commands" $ do let act = brittanyCmd 4 lfFile Nothing arg = FormatParams 4 lfFile Nothing - res = IdeResultOk + res = return [ TextEdit { _range = Range { _start = Position {_line = 0, _character = 0} @@ -45,7 +45,7 @@ brittanySpec = describe "brittany plugin commands" $ do let act = brittanyCmd 4 crlfFile Nothing arg = FormatParams 4 crlfFile Nothing - res = IdeResultOk + res = return [ TextEdit { _range = Range { _start = Position {_line = 0, _character = 0} @@ -60,7 +60,7 @@ brittanySpec = describe "brittany plugin commands" $ do let r = Range (Position 1 0) (Position 2 22) act = brittanyCmd 4 lfFile (Just r) arg = FormatParams 4 lfFile (Just r) - res = IdeResultOk + res = return [ TextEdit { _range = Range { _start = Position {_line = 1, _character = 0} @@ -75,7 +75,7 @@ brittanySpec = describe "brittany plugin commands" $ do let r = Range (Position 1 0) (Position 2 22) act = brittanyCmd 4 crlfFile (Just r) arg = FormatParams 4 crlfFile (Just r) - res = IdeResultOk + res = return [ TextEdit { _range = Range { _start = Position {_line = 1, _character = 0} diff --git a/test/unit/ExtensibleStateSpec.hs b/test/unit/ExtensibleStateSpec.hs index 25c22159b..9f7f5a5d8 100644 --- a/test/unit/ExtensibleStateSpec.hs +++ b/test/unit/ExtensibleStateSpec.hs @@ -22,11 +22,11 @@ extensibleStateSpec = describe "stores and retrieves in the state" $ it "stores the first one" $ do r <- runIGM testPlugins $ do - r1 <- makeRequest "test" "cmd1" () - r2 <- makeRequest "test" "cmd2" () + r1 <- runIDErring $ makeRequest "test" "cmd1" () + r2 <- runIDErring $ makeRequest "test" "cmd2" () return (r1,r2) - fmap fromDynJSON (fst r) `shouldBe` IdeResultOk (Just "result:put foo" :: Maybe T.Text) - fmap fromDynJSON (snd r) `shouldBe` IdeResultOk (Just "result:got:\"foo\"" :: Maybe T.Text) + fmap fromDynJSON (fst r) `shouldBe` Right (Just "result:put foo" :: Maybe T.Text) + fmap fromDynJSON (snd r) `shouldBe` Right (Just "result:got:\"foo\"" :: Maybe T.Text) -- --------------------------------------------------------------------- @@ -49,13 +49,13 @@ testDescriptor = PluginDescriptor cmd1 :: CommandFunc () T.Text cmd1 = CmdSync $ \_ -> do - put (MS1 "foo") - return (IdeResultOk (T.pack "result:put foo")) + liftIde $ put $ MS1 "foo" + return $ T.pack "result:put foo" cmd2 :: CommandFunc () T.Text cmd2 = CmdSync $ \_ -> do - (MS1 v) <- get - return (IdeResultOk (T.pack $ "result:got:" ++ show v)) + MS1 v <- liftIde get + return $ T.pack $ "result:got:" ++ show v newtype MyState1 = MS1 T.Text deriving Typeable diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 635bc3ae1..6f915d5a0 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -18,6 +18,7 @@ import Haskell.Ide.Engine.Plugin.HaRe ( HarePoint(..) ) import Language.Haskell.LSP.Types ( TextEdit(..) ) import System.Directory import TestUtils +import Control.Monad.Morph (hoist) import Test.Hspec @@ -44,8 +45,7 @@ ghcmodSpec = fp <- makeAbsolute "./FileWithWarning.hs" let act = setTypecheckedModule arg arg = filePathToUri fp - res = IdeResultOk $ - (Map.singleton arg (S.singleton diag), []) + res = return (Map.singleton arg (S.singleton diag), []) diag = Diagnostic (Range (toPos (4,7)) (toPos (4,8))) (Just DsError) @@ -64,9 +64,9 @@ ghcmodSpec = act = lintCmd' uri arg = uri #if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,2,2,0))) - res = IdeResultOk (T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULPerhaps:\NUL return (3 + x)\n") + res = return $ T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULPerhaps:\NUL return (3 + x)\n" #else - res = IdeResultOk (T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULWhy not:\NUL return (3 + x)\n") + res = return $ T.pack fp <> ":6:9: Warning: Redundant do\NULFound:\NUL do return (3 + x)\NULWhy not:\NUL return (3 + x)\n" #endif testCommand testPlugins act "ghcmod" "lint" arg res @@ -77,7 +77,7 @@ ghcmodSpec = let uri = filePathToUri fp act = infoCmd' uri "main" arg = IP uri "main" - res = IdeResultOk "main :: IO () \t-- Defined at HaReRename.hs:2:1\n" + res = return "main :: IO () \t-- Defined at HaReRename.hs:2:1\n" -- ghc-mod tries to load the test file in the context of the hie project if we do not cd first. testCommand testPlugins act "ghcmod" "info" arg res @@ -88,9 +88,9 @@ ghcmodSpec = let uri = filePathToUri fp act = do _ <- setTypecheckedModule uri - liftToGhc $ newTypeCmd (toPos (5,9)) uri + hoist liftIde $ newTypeCmd (toPos (5,9)) uri arg = TP False uri (toPos (5,9)) - res = IdeResultOk + res = return [(Range (toPos (5,9)) (toPos (5,10)), "Int") ,(Range (toPos (5,9)) (toPos (5,14)), "Int") ,(Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") @@ -107,9 +107,9 @@ ghcmodSpec = let uri = filePathToUri fp let act = do _ <- setTypecheckedModule uri - liftToGhc $ newTypeCmd (toPos (5,9)) uri + hoist liftIde $ newTypeCmd (toPos (5,9)) uri let arg = TP False uri (toPos (5,9)) - let res = IdeResultOk + let res = return [(Range (toPos (5,9)) (toPos (5,10)), "Int") ,(Range (toPos (5,9)) (toPos (5,14)), "Int") ,(Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") @@ -125,7 +125,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri splitCaseCmd' uri (toPos (5,5)) arg = HP uri (toPos (5,5)) - res = IdeResultOk $ WorkspaceEdit + res = return $ WorkspaceEdit (Just $ H.singleton uri $ List [TextEdit (Range (Position 4 0) (Position 4 10)) "foo Nothing = ()\nfoo (Just x) = ()"]) @@ -144,7 +144,7 @@ ghcmodSpec = _ <- setTypecheckedModule uri splitCaseCmd' uri (toPos (5,5)) arg = HP uri (toPos (5,5)) - res = IdeResultOk $ WorkspaceEdit + res = return $ WorkspaceEdit (Just $ H.singleton uri $ List [TextEdit (Range (Position 4 0) (Position 4 10)) "foo Nothing = ()\nfoo (Just x) = ()"]) diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index cb57a649a..f7db9e4d9 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module HaRePluginSpec where import Data.Aeson @@ -8,7 +9,7 @@ import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.PluginUtils import Haskell.Ide.Engine.Plugin.GhcMod -import Haskell.Ide.Engine.Plugin.HaRe +import Haskell.Ide.Engine.Plugin.HaRe hiding (hoist) import Haskell.Ide.Engine.Plugin.HieExtras import Language.Haskell.LSP.Types ( Location(..) , TextEdit(..) @@ -16,6 +17,9 @@ import Language.Haskell.LSP.Types ( Location(..) import System.Directory import System.FilePath import TestUtils +import Control.Monad.Trans.Free +import Control.Monad.Trans +import Control.Monad.Morph import Test.Hspec @@ -36,10 +40,12 @@ spec = do testPlugins :: IdePlugins testPlugins = pluginDescToIdePlugins [("hare",hareDescriptor)] -dispatchRequestPGoto :: IdeGhcM a -> IO a -dispatchRequestPGoto = - cdAndDo "./test/testdata/gototest" - . runIGM testPlugins +shouldRespond :: IDErring (FreeT IdeDefer IdeGhcM) [Location] -> Either IdeError [Location] -> IO () +shouldRespond have should = do + r <- cdAndDo "./test/testdata/gototest" $ runIGM testPlugins $ runFreeT $ runIDErring have + r `shouldSatisfy` \case + Pure x -> x == should + Free _ -> False -- --------------------------------------------------------------------- @@ -55,9 +61,7 @@ hareSpec = do act = renameCmd' uri (toPos (5,1)) "foolong" arg = HPT uri (toPos (5,1)) "foolong" textEdits = List [TextEdit (Range (Position 3 0) (Position 4 13)) "foolong :: Int -> Int\nfoolong x = x + 3"] - res = IdeResultOk $ WorkspaceEdit - (Just $ H.singleton uri textEdits) - Nothing + res = return $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins act "hare" "rename" arg res -- --------------------------------- @@ -66,9 +70,7 @@ hareSpec = do let uri = filePathToUri $ cwd "test/testdata/HaReRename.hs" act = renameCmd' uri (toPos (15,1)) "foolong" arg = HPT uri (toPos (15,1)) "foolong" - res = IdeResultFail - IdeError { ideCode = PluginError - , ideMessage = "rename: \"Invalid cursor position!\"", ideInfo = Null} + res = ideError PluginError "rename: \"Invalid cursor position!\"" Null testCommand testPlugins act "hare" "rename" arg res -- --------------------------------- @@ -78,9 +80,7 @@ hareSpec = do act = demoteCmd' uri (toPos (6,1)) arg = HP uri (toPos (6,1)) textEdits = List [TextEdit (Range (Position 4 0) (Position 5 5)) " where\n y = 7"] - res = IdeResultOk $ WorkspaceEdit - (Just $ H.singleton uri textEdits) - Nothing + res = return $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins act "hare" "demote" arg res -- --------------------------------- @@ -90,9 +90,7 @@ hareSpec = do act = dupdefCmd' uri (toPos (5,1)) "foonew" arg = HPT uri (toPos (5,1)) "foonew" textEdits = List [TextEdit (Range (Position 6 0) (Position 6 0)) "foonew :: Int -> Int\nfoonew x = x + 3\n\n"] - res = IdeResultOk $ WorkspaceEdit - (Just $ H.singleton uri textEdits) - Nothing + res = return $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins act "hare" "dupdef" arg res -- --------------------------------- @@ -105,9 +103,7 @@ hareSpec = do arg = HR uri (toPos (5,9)) (toPos (9,12)) textEdits = List [TextEdit (Range (Position 4 0) (Position 8 11)) "foo x = case odd x of\n True ->\n x + 3\n False ->\n x"] - res = IdeResultOk $ WorkspaceEdit - (Just $ H.singleton uri textEdits) - Nothing + res = return $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins act "hare" "iftocase" arg res -- --------------------------------- @@ -119,9 +115,7 @@ hareSpec = do arg = HP uri (toPos (6,5)) textEdits = List [ TextEdit (Range (Position 6 0) (Position 6 0)) "y = 4\n\n" , TextEdit (Range (Position 4 0) (Position 6 0)) ""] - res = IdeResultOk $ WorkspaceEdit - (Just $ H.singleton uri textEdits) - Nothing + res = return $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins act "hare" "liftonelevel" arg res -- --------------------------------- @@ -135,9 +129,7 @@ hareSpec = do , TextEdit (Range (Position 12 0) (Position 12 0)) "z = 7\n" , TextEdit (Range (Position 10 0) (Position 12 0)) "" ] - res = IdeResultOk $ WorkspaceEdit - (Just $ H.singleton uri textEdits) - Nothing + res = return $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins act "hare" "lifttotoplevel" arg res -- --------------------------------- @@ -147,9 +139,7 @@ hareSpec = do act = deleteDefCmd' uri (toPos (6,1)) arg = HP uri (toPos (6,1)) textEdits = List [TextEdit (Range (Position 4 0) (Position 7 0)) ""] - res = IdeResultOk $ WorkspaceEdit - (Just $ H.singleton uri textEdits) - Nothing + res = return $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins act "hare" "deletedef" arg res -- --------------------------------- @@ -160,9 +150,7 @@ hareSpec = do arg = HP uri (toPos (4,1)) textEdits = List [TextEdit (Range (Position 4 0) (Position 8 12)) "parseStr = char '\"' *> (many1 (noneOf \"\\\"\")) <* char '\"'"] - res = IdeResultOk $ WorkspaceEdit - (Just $ H.singleton uri textEdits) - Nothing + res = return $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing testCommand testPlugins act "hare" "genapplicative" arg res -- --------------------------------- @@ -172,33 +160,25 @@ hareSpec = do it "finds definition across components" $ do let u = filePathToUri $ cwd "test/testdata/gototest/app/Main.hs" - lreq = setTypecheckedModule u - req = liftToGhc $ findDef u (toPos (7,8)) - r <- dispatchRequestPGoto $ lreq >> req - r `shouldBe` IdeResponseOk [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs") - (Range (toPos (6,1)) (toPos (6,9)))] - let req2 = liftToGhc $ findDef u (toPos (7,20)) - r2 <- dispatchRequestPGoto $ lreq >> req2 - r2 `shouldBe` IdeResponseOk [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs") - (Range (toPos (5,1)) (toPos (5,2)))] + lreq = hoist lift $ setTypecheckedModule u + req = hoist (hoistFreeT liftIde) $ findDef u (toPos (7,8)) + (lreq >> req) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs") + (Range (toPos (6,1)) (toPos (6,9)))] + let req2 = hoist (hoistFreeT liftIde) $ findDef u (toPos (7,20)) + (lreq >> req2) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs") + (Range (toPos (5,1)) (toPos (5,2)))] it "finds definition in the same component" $ do let u = filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs" - lreq = setTypecheckedModule u - req = liftToGhc $ findDef u (toPos (6,5)) - r <- dispatchRequestPGoto $ lreq >> req - r `shouldBe` IdeResponseOk [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs") - (Range (toPos (6,1)) (toPos (6,9)))] + lreq = hoist lift $ setTypecheckedModule u + req = hoist (hoistFreeT liftIde) $ findDef u (toPos (6,5)) + (lreq >> req) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs") + (Range (toPos (6,1)) (toPos (6,9)))] it "finds local definitions" $ do let u = filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs" - lreq = setTypecheckedModule u - req = liftToGhc $ findDef u (toPos (7,11)) - r <- dispatchRequestPGoto $ lreq >> req - r `shouldBe` IdeResponseOk [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs") - (Range (toPos (10,9)) (toPos (10,10)))] - let req2 = liftToGhc $ findDef u (toPos (10,13)) - r2 <- dispatchRequestPGoto $ lreq >> req2 - r2 `shouldBe` IdeResponseOk [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs") - (Range (toPos (9,9)) (toPos (9,10)))] - - - -- --------------------------------- + lreq = hoist lift $ setTypecheckedModule u + req = hoist (hoistFreeT liftIde) $ findDef u (toPos (7,11)) + (lreq >> req) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs") + (Range (toPos (10,9)) (toPos (10,10)))] + let req2 = hoist (hoistFreeT liftIde) $ findDef u (toPos (10,13)) + (lreq >> req2) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs") + (Range (toPos (9,9)) (toPos (9,10)))] \ No newline at end of file diff --git a/test/unit/HooglePluginSpec.hs b/test/unit/HooglePluginSpec.hs index a6b9230a1..73fade154 100644 --- a/test/unit/HooglePluginSpec.hs +++ b/test/unit/HooglePluginSpec.hs @@ -47,13 +47,13 @@ hoogleSpec = do describe "hoogle plugin commands(new plugin api)" $ do it "runs the info command" $ do - let req = liftToGhc $ infoCmd' "head" + let req = liftIde $ infoCmd' "head" r <- dispatchRequestP $ initializeHoogleDb >> req r `shouldBe` Right "head :: [a] -> a\nbase Prelude\nExtract the first element of a list, which must be non-empty.\n\n" -- --------------------------------- it "runs the lookup command" $ do - let req = liftToGhc $ lookupCmd' 1 "[a] -> a" + let req = liftIde $ lookupCmd' 1 "[a] -> a" r <- dispatchRequestP $ initializeHoogleDb >> req r `shouldBe` Right ["Prelude head :: [a] -> a"] diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 4b8c38b50..0bd296e9f 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -15,11 +15,13 @@ module TestUtils import Control.Exception import Control.Monad +import Control.Monad.Morph import Data.Aeson.Types (typeMismatch) import Data.Default import Data.Text (pack) import Data.Typeable import Data.Yaml +import Data.Functor.Identity import qualified Data.Map as Map import qualified GhcMod.Monad as GM import qualified GhcMod.Types as GM @@ -54,19 +56,19 @@ cdAndDo path fn = do $ const fn -testCommand :: (ToJSON a, Typeable b, ToJSON b, Show b, Eq b) => IdePlugins -> IdeGhcM (IdeResult b) -> PluginId -> CommandName -> a -> IdeResult b -> IO () +testCommand :: (ToJSON a, Typeable b, ToJSON b, Show b, Eq b) => IdePlugins -> IDErring IdeGhcM b -> PluginId -> CommandName -> a -> IDErring Identity b -> IO () testCommand testPlugins act plugin cmd arg res = do (newApiRes, oldApiRes) <- runIGM testPlugins $ do - new <- act - old <- makeRequest plugin cmd arg + new <- runIDErring act + old <- runIDErring $ makeRequest plugin cmd arg return (new, old) - newApiRes `shouldBe` res - fmap fromDynJSON oldApiRes `shouldBe` fmap Just res + newApiRes `shouldBe` runIdentity (runIDErring res) + fmap fromDynJSON oldApiRes `shouldBe` fmap Just (runIdentity (runIDErring res)) -runSingleReq :: ToJSON a => IdePlugins -> PluginId -> CommandName -> a -> IO (IdeResult DynamicJSON) -runSingleReq testPlugins plugin com arg = runIGM testPlugins (makeRequest plugin com arg) +runSingleReq :: ToJSON a => IdePlugins -> PluginId -> CommandName -> a -> IDErring IO DynamicJSON +runSingleReq testPlugins plugin com arg = hoist (runIGM testPlugins) $ makeRequest plugin com arg -makeRequest :: ToJSON a => PluginId -> CommandName -> a -> IdeGhcM (IdeResult DynamicJSON) +makeRequest :: ToJSON a => PluginId -> CommandName -> a -> IDErring IdeGhcM DynamicJSON makeRequest plugin com arg = runPluginCommand plugin com (toJSON arg) runIGM :: IdePlugins -> IdeGhcM a -> IO a From 101b8a22842f45fa081e2934a47df601e96cc9e1 Mon Sep 17 00:00:00 2001 From: Gurkenglas Date: Tue, 7 Aug 2018 13:38:09 +0200 Subject: [PATCH 3/8] ExceptTize Dispatcher.hs --- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 2 + src/Haskell/Ide/Engine/Dispatcher.hs | 118 ++++++++---------- src/Haskell/Ide/Engine/Transport/JsonStdio.hs | 12 +- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 12 +- test/dispatcher/Main.hs | 12 +- 5 files changed, 68 insertions(+), 88 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 55e4b3d51..b5971f085 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -209,6 +209,8 @@ data IdeErrorCode | UnknownPlugin -- ^ Plugin is not registered | UnknownCommand -- ^ Command is not registered | InvalidContext -- ^ Context invalid for command + | RequestCancelled -- ^ A cancel request fired targeting this one + | VersionMismatch -- ^ The request expected another hie version | OtherError -- ^ An error for which there's no better code deriving (Show,Read,Eq,Ord,Bounded,Enum,Generic) diff --git a/src/Haskell/Ide/Engine/Dispatcher.hs b/src/Haskell/Ide/Engine/Dispatcher.hs index fd05a5f31..afaa6df97 100644 --- a/src/Haskell/Ide/Engine/Dispatcher.hs +++ b/src/Haskell/Ide/Engine/Dispatcher.hs @@ -21,6 +21,8 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.STM import Control.Monad.Trans.Free +import Control.Monad.Except +import Data.Foldable import qualified Data.Aeson as J import qualified Data.Text as T import qualified Data.Map as Map @@ -85,77 +87,65 @@ ideDispatcher env errorHandler callbackHandler pin = forever $ do debugm "ideDispatcher: top of loop" IdeRequest tn lid callback action <- liftIO $ atomically $ readTChan pin debugm $ "ideDispatcher: got request " ++ show tn ++ " with id: " ++ show lid - handleAction lid $ runIDErring $ fmap (callbackHandler callback) action - where handleAction :: J.LspId -> ResponseT IdeM (Either IdeError (IO ())) -> IdeM () - handleAction lid action = checkCancelled env lid errorHandler $ do - response <- runFreeT action - checkCancelled env lid errorHandler $ case response of - Pure result -> handleResult lid result - Free (IdeDefer fp cacheCb) -> queueAction fp $ - handleAction lid . either (\err -> pure $ Left $ IdeError NoModuleAvailable err J.Null) cacheCb + handleAction lid $ fmap (callbackHandler callback) action + where handleAction :: J.LspId -> IdeResponseT (IO ()) -> IdeM () + handleAction lid action = do + response <- runIDErring $ do + checkCancelled env lid + r <- lift $ runFreeT $ runIDErring action + checkCancelled env lid + return r + -- TODO: Refactor the double handleError away. + case response of + Left dispatchererr -> liftIO $ handleError (errorHandler lid) dispatchererr + Right actualresponse -> case actualresponse of + Pure result -> do + completedReq env lid + liftIO $ either (handleError (errorHandler lid)) liftIO result + Free (IdeDefer fp cacheCb) -> queueAction fp $ + handleAction lid . either (\err -> ideError NoModuleAvailable err J.Null) (IDErring . ExceptT . cacheCb) queueAction :: FilePath -> (Either T.Text CachedModule -> IdeM ()) -> IdeM () queueAction fp action = requestQueue . at fp . non' _Empty %= (action:) - handleResult :: J.LspId -> Either IdeError (IO ()) -> IdeM () - handleResult lid = \case - Left (IdeError code msg _) -> liftIO $ do - completedReq env lid - case code of - -- TODO: This isn't actually an internal error - NoModuleAvailable -> errorHandler lid J.InternalError msg - _ -> errorHandler lid J.InternalError msg - Right x -> liftIO x - ghcDispatcher :: forall void m. DispatcherEnv -> ErrorHandler -> CallbackHandler m -> TChan (GhcRequest m) -> GM.GhcModT IdeM void ghcDispatcher env@DispatcherEnv{docVersionTVar} errorHandler callbackHandler pin = forever $ do debugm "ghcDispatcher: top of loop" GhcRequest tn context mver mid callback action <- liftIO $ atomically $ readTChan pin debugm $ "ghcDispatcher:got request " ++ show tn ++ " with id: " ++ show mid - - let runner act = do - let c = uriToFilePath <$> context - when (c == Just Nothing) $ debugm "ghcDispatcher:Got malformed uri, running action with default context" - runActionWithContext (join c) act - - let runWithCallback = do - result <- runIDErring $ runner action - liftIO $ case result of - Right x -> callbackHandler callback x - Left err@(IdeError code msg _) -> - case mid of - Just lid -> case code of - NoModuleAvailable -> errorHandler lid J.ParseError msg - _ -> errorHandler lid J.InternalError msg - Nothing -> debugm $ "ghcDispatcher:Got error for a request: " ++ show err - - let runIfVersionMatch = case mver of - Nothing -> runWithCallback - Just (uri, reqver) -> do - curver <- liftIO $ atomically $ Map.lookup uri <$> readTVar docVersionTVar - if Just reqver /= curver then - debugm "ghcDispatcher:not processing request as it is for old version" - else do - debugm "ghcDispatcher:Processing request as version matches" - runWithCallback - - case mid of - Nothing -> runIfVersionMatch - Just lid -> checkCancelled env lid errorHandler $ do - liftIO $ completedReq env lid - runIfVersionMatch - -checkCancelled :: MonadIO m => DispatcherEnv -> J.LspId -> ErrorHandler -> m () -> m () -checkCancelled env lid errorHandler callback = do - cancelled <- liftIO $ atomically isCancelled - if cancelled - then liftIO $ do - -- remove from cancelled and wip list - atomically $ modifyTVar' (cancelReqsTVar env) (S.delete lid) + result <- runIDErring $ do + for_ mid $ \lid -> do completedReq env lid - errorHandler lid J.RequestCancelled "" - else callback - where isCancelled = S.member lid <$> readTVar (cancelReqsTVar env) - -completedReq :: DispatcherEnv -> J.LspId -> IO () -completedReq env lid = atomically $ modifyTVar' (wipReqsTVar env) (S.delete lid) + checkCancelled env lid + for_ mver $ \(uri, reqver) -> do + curver <- liftIO $ atomically $ Map.lookup uri <$> readTVar docVersionTVar + when (Just reqver /= curver) $ + ideError VersionMismatch "The request expects another version" J.Null + let c = uriToFilePath <$> context + when (c == Just Nothing) $ debugm "ghcDispatcher:Got malformed uri, running action with default context" + runActionWithContext (join c) action + liftIO $ case result of + Right x -> callbackHandler callback x + Left err -> case mid of + Just lid -> handleError (errorHandler lid) err + Nothing -> debugm $ "ghcDispatcher:Got error for a request: " ++ show err + +handleError :: (J.ErrorCode -> T.Text -> a) -> IdeError -> a +handleError handler (IdeError code msg _) = handler (translate code) msg where + translate RequestCancelled = J.RequestCancelled + translate NoModuleAvailable = J.ParseError + -- TODO: Supply an error code. + translate VersionMismatch = J.UnknownErrorCode + translate _ = J.InternalError + +checkCancelled :: MonadIO m => DispatcherEnv -> J.LspId -> IDErring m () +checkCancelled env lid = do + -- attempt to pop a corresponding cancel request + cancelled <- liftIO $ atomically $ do + c <- S.member lid <$> readTVar (cancelReqsTVar env) + when c $ modifyTVar' (cancelReqsTVar env) (S.delete lid) + return c + when cancelled $ ideError RequestCancelled "" J.Null + +completedReq :: MonadIO m => DispatcherEnv -> J.LspId -> m () +completedReq env lid = liftIO $ atomically $ modifyTVar' (wipReqsTVar env) (S.delete lid) diff --git a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs index 9fbd4587b..c789e7d89 100644 --- a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs @@ -73,14 +73,10 @@ run dispatcherProc cin = flip E.catches handlers $ do flip E.finally finalProc $ do rout <- atomically newTChan :: IO (TChan ReactorOutput) - cancelTVar <- atomically $ newTVar S.empty - wipTVar <- atomically $ newTVar S.empty - versionTVar <- atomically $ newTVar Map.empty - let dispatcherEnv = DispatcherEnv - { cancelReqsTVar = cancelTVar - , wipReqsTVar = wipTVar - , docVersionTVar = versionTVar - } + dispatcherEnv <- atomically $ DispatcherEnv + <$> newTVar S.empty + <*> newTVar S.empty + <*> newTVar Map.empty let race3_ a b c = race_ a (race_ b c) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 87d907592..f4f887688 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -109,14 +109,10 @@ run dispatcherProc cin _origDir plugins captureFp = flip E.catches handlers $ do prefix <- cmdPrefixer let dp lf = do - cancelTVar <- atomically $ newTVar S.empty - wipTVar <- atomically $ newTVar S.empty - versionTVar <- atomically $ newTVar Map.empty - let dEnv = DispatcherEnv - { cancelReqsTVar = cancelTVar - , wipReqsTVar = wipTVar - , docVersionTVar = versionTVar - } + dEnv <- atomically $ DispatcherEnv + <$> newTVar S.empty + <*> newTVar S.empty + <*> newTVar Map.empty let reactorFunc = runReactor lf dEnv cin prefix $ reactor rin caps = Core.clientCapabilities lf diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index 35b756483..3900f8ce1 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -75,14 +75,10 @@ startServer = do cin <- newTChanIO logChan <- newTChanIO - cancelTVar <- newTVarIO S.empty - wipTVar <- newTVarIO S.empty - versionTVar <- newTVarIO Map.empty - let dispatcherEnv = DispatcherEnv - { cancelReqsTVar = cancelTVar - , wipReqsTVar = wipTVar - , docVersionTVar = versionTVar - } + dEnv <- atomically $ DispatcherEnv + <$> newTVar S.empty + <*> newTVar S.empty + <*> newTVar Map.empty dispatcher <- forkIO $ dispatcherP cin plugins testOptions dispatcherEnv From 14f31821dfc427bd4fe4902b2c1e5ad1e8548610 Mon Sep 17 00:00:00 2001 From: Gurkenglas Date: Wed, 8 Aug 2018 14:55:58 +0200 Subject: [PATCH 4/8] Untangle handleAction --- .../Haskell/Ide/Engine/ModuleCache.hs | 9 +++--- src/Haskell/Ide/Engine/Dispatcher.hs | 29 +++++++------------ src/Haskell/Ide/Engine/Transport/JsonStdio.hs | 6 ++-- submodules/HaRe | 2 +- submodules/ghc-mod | 2 +- test/dispatcher/Main.hs | 17 ++++++----- 6 files changed, 29 insertions(+), 36 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs index cd532d23d..934188007 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs @@ -1,7 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TupleSections #-} module Haskell.Ide.Engine.ModuleCache where import Control.Monad.IO.Class @@ -96,7 +95,7 @@ getCachedModule uri = do maybeUriCache <- fmap (Map.lookup uri' . uriCaches) getModuleCache return $ case maybeUriCache of Nothing -> ModuleLoading - Just uriCache@(UriCache {}) -> ModuleCached (cachedModule uriCache) (isStale uriCache) + Just uriCache@UriCache {} -> ModuleCached (cachedModule uriCache) (isStale uriCache) Just (UriCacheFailed err) -> ModuleFailed err -- | Returns true if there is a CachedModule for a given URI @@ -111,7 +110,7 @@ isCached uri = do -- | Version of `withCachedModuleAndData` that doesn't provide -- any extra cached data. withCachedModule :: FilePath -> (CachedModule -> IdeResponseT b) -> IdeResponseT b -withCachedModule uri callback = withCachedModuleDefault uri Nothing callback +withCachedModule uri = withCachedModuleDefault uri Nothing -- | Version of `withCachedModuleAndData` that doesn't provide -- any extra cached data. @@ -135,7 +134,7 @@ withCachedModuleDefault uri mdef callback = do -- using by calling the `cacheDataProducer` function. withCachedModuleAndData :: forall a b. ModuleCache a => FilePath -> (CachedModule -> a -> IdeResponseT b) -> IdeResponseT b -withCachedModuleAndData uri callback = withCachedModuleAndDataDefault uri Nothing callback +withCachedModuleAndData uri = withCachedModuleAndDataDefault uri Nothing withCachedModuleAndDataDefault :: forall a b. ModuleCache a => FilePath -> Maybe (IdeResponseT b) @@ -206,7 +205,7 @@ failModule fp err = do runDeferredActions :: FilePath -> Either T.Text CachedModule -> IdeGhcM () runDeferredActions uri cached = liftIde $ do - actions <- requestQueue . at uri . non' _Empty %%= \x -> (x, []) + actions <- requestQueue . at uri . non' _Empty <<.= [] traverse_ (\a -> a cached) actions -- | Saves a module to the cache without clearing the associated cache data - use only if you are diff --git a/src/Haskell/Ide/Engine/Dispatcher.hs b/src/Haskell/Ide/Engine/Dispatcher.hs index afaa6df97..855b664bc 100644 --- a/src/Haskell/Ide/Engine/Dispatcher.hs +++ b/src/Haskell/Ide/Engine/Dispatcher.hs @@ -3,7 +3,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE LambdaCase #-} module Haskell.Ide.Engine.Dispatcher ( dispatcherP @@ -87,23 +86,17 @@ ideDispatcher env errorHandler callbackHandler pin = forever $ do debugm "ideDispatcher: top of loop" IdeRequest tn lid callback action <- liftIO $ atomically $ readTChan pin debugm $ "ideDispatcher: got request " ++ show tn ++ " with id: " ++ show lid - handleAction lid $ fmap (callbackHandler callback) action - where handleAction :: J.LspId -> IdeResponseT (IO ()) -> IdeM () + handleAction lid $ fmap (liftIO . callbackHandler callback) action + where handleAction :: J.LspId -> IdeResponseT (IdeM ()) -> IdeM () handleAction lid action = do - response <- runIDErring $ do - checkCancelled env lid - r <- lift $ runFreeT $ runIDErring action - checkCancelled env lid - return r - -- TODO: Refactor the double handleError away. + response <- runFreeT $ runIDErring $ + checkCancelled env lid *> action <* checkCancelled env lid case response of - Left dispatchererr -> liftIO $ handleError (errorHandler lid) dispatchererr - Right actualresponse -> case actualresponse of - Pure result -> do - completedReq env lid - liftIO $ either (handleError (errorHandler lid)) liftIO result - Free (IdeDefer fp cacheCb) -> queueAction fp $ - handleAction lid . either (\err -> ideError NoModuleAvailable err J.Null) (IDErring . ExceptT . cacheCb) + Pure result -> do + completedReq env lid + either (liftIO . handleError (errorHandler lid)) id result + Free (IdeDefer fp cacheCb) -> queueAction fp $ + handleAction lid . either (\err -> ideError NoModuleAvailable err J.Null) (IDErring . ExceptT . cacheCb) queueAction :: FilePath -> (Either T.Text CachedModule -> IdeM ()) -> IdeM () queueAction fp action = requestQueue . at fp . non' _Empty %= (action:) @@ -133,8 +126,8 @@ ghcDispatcher env@DispatcherEnv{docVersionTVar} errorHandler callbackHandler pin handleError :: (J.ErrorCode -> T.Text -> a) -> IdeError -> a handleError handler (IdeError code msg _) = handler (translate code) msg where translate RequestCancelled = J.RequestCancelled - translate NoModuleAvailable = J.ParseError - -- TODO: Supply an error code. + -- TODO: Ununknow error codes. + translate NoModuleAvailable = J.UnknownErrorCode translate VersionMismatch = J.UnknownErrorCode translate _ = J.InternalError diff --git a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs index c789e7d89..eb1dee70c 100644 --- a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs @@ -74,9 +74,9 @@ run dispatcherProc cin = flip E.catches handlers $ do rout <- atomically newTChan :: IO (TChan ReactorOutput) dispatcherEnv <- atomically $ DispatcherEnv - <$> newTVar S.empty - <*> newTVar S.empty - <*> newTVar Map.empty + <$> newTVar S.empty + <*> newTVar S.empty + <*> newTVar Map.empty let race3_ a b c = race_ a (race_ b c) diff --git a/submodules/HaRe b/submodules/HaRe index a11f797e4..db6d90357 160000 --- a/submodules/HaRe +++ b/submodules/HaRe @@ -1 +1 @@ -Subproject commit a11f797e408fe02c8443cf8ab0f5b4eaab66714c +Subproject commit db6d903573c2b093337f6173182fb7f5c2978810 diff --git a/submodules/ghc-mod b/submodules/ghc-mod index 66fc0980d..4a3f7c92c 160000 --- a/submodules/ghc-mod +++ b/submodules/ghc-mod @@ -1 +1 @@ -Subproject commit 66fc0980d2c731caf36215969a31bff8ef40f3e2 +Subproject commit 4a3f7c92c499eaec9a0d6e88a1301a7d9e68cd86 diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index 3900f8ce1..ce4c4a897 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -75,10 +75,10 @@ startServer = do cin <- newTChanIO logChan <- newTChanIO - dEnv <- atomically $ DispatcherEnv - <$> newTVar S.empty - <*> newTVar S.empty - <*> newTVar Map.empty + dispatcherEnv <- atomically $ DispatcherEnv + <$> newTVar S.empty + <*> newTVar S.empty + <*> newTVar Map.empty dispatcher <- forkIO $ dispatcherP cin plugins testOptions dispatcherEnv @@ -137,9 +137,10 @@ newPluginSpec = do it "dispatches response correctly" $ do inChan <- atomically newTChan outChan <- atomically newTChan - cancelTVar <- newTVarIO S.empty - wipTVar <- newTVarIO S.empty - versionTVar <- newTVarIO $ Map.singleton (filePathToUri "test") 3 + dispatcherEnv <- atomically $ DispatcherEnv + <$> newTVar S.empty + <*> newTVar S.empty + <*> newTVar (Map.singleton (filePathToUri "test") 3) let req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) (atomically . writeTChan outChan) $ return $ T.pack "text1" req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) (atomically . writeTChan outChan) $ return $ T.pack "text2" req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing (atomically . writeTChan outChan) $ return $ T.pack "text3" @@ -148,7 +149,7 @@ newPluginSpec = do pid <- forkIO $ dispatcherP inChan (pluginDescToIdePlugins []) testOptions - (DispatcherEnv cancelTVar wipTVar versionTVar) + dispatcherEnv (\_ _ _ -> return ()) (\f x -> f x) def From aaddd64d1e9199e094aeea12a585a6555a01672b Mon Sep 17 00:00:00 2001 From: Gurkenglas Date: Thu, 9 Aug 2018 10:38:03 +0200 Subject: [PATCH 5/8] Rewhitespace IDErring's boilerplate into 80 chars --- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 28 +++++++++++++------ submodules/ghc-mod | 2 +- 2 files changed, 21 insertions(+), 9 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index b5971f085..89de0604a 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -148,14 +148,26 @@ instance ToJSON IdePlugins where type IdeGhcM = GM.GhcModT IdeM -newtype IDErring m a = IDErring { getIDErring :: ExceptT IdeError m a } deriving - (Functor, Applicative, Monad, MonadReader r, MonadState s, MonadIO, MonadTrans, MonadBase b, MFunctor) -instance GM.MonadIO m => GM.MonadIO (IDErring m) where liftIO = lift . GM.liftIO -instance GM.GmEnv m => GM.GmEnv (IDErring m) where gmeAsk = lift GM.gmeAsk; gmeLocal f x = liftWith (\run -> GM.gmeLocal f $ run x) >>= restoreT . return -instance GM.GmLog m => GM.GmLog (IDErring m) where gmlJournal = lift . GM.gmlJournal; gmlHistory = lift GM.gmlHistory; gmlClear = lift GM.gmlClear -instance GM.GmOut m => GM.GmOut (IDErring m) where gmoAsk = lift GM.gmoAsk -instance GM.GmState m => GM.GmState (IDErring m) where gmsGet = lift GM.gmsGet; gmsPut = lift . GM.gmsPut; gmsState = lift . GM.gmsState -instance (Functor f, MonadFree f m) => MonadFree f (IDErring m) where wrap x = liftWith (\run -> wrap $ fmap run x) >>= restoreT . return +newtype IDErring m a = IDErring { getIDErring :: ExceptT IdeError m a } +deriving (Functor, Applicative, Monad, MonadReader r, MonadState s + , MonadIO, MonadTrans, MonadBase b, MFunctor) +instance GM.MonadIO m => GM.MonadIO (IDErring m) where + liftIO = lift . GM.liftIO +instance GM.GmEnv m => GM.GmEnv (IDErring m) where + gmeAsk = lift GM.gmeAsk + gmeLocal f x = liftWith (\run -> GM.gmeLocal f $ run x) >>= restoreT . return +instance GM.GmLog m => GM.GmLog (IDErring m) where + gmlJournal = lift . GM.gmlJournal + gmlHistory = lift GM.gmlHistory + gmlClear = lift GM.gmlClear +instance GM.GmOut m => GM.GmOut (IDErring m) where + gmoAsk = lift GM.gmoAsk +instance GM.GmState m => GM.GmState (IDErring m) where + gmsGet = lift GM.gmsGet + gmsPut = lift . GM.gmsPut + gmsState = lift . GM.gmsState +instance (Functor f, MonadFree f m) => MonadFree f (IDErring m) where + wrap x = liftWith (\run -> wrap $ fmap run x) >>= restoreT . return runIDErring :: IDErring m a -> m (Either IdeError a) runIDErring = runExceptT . getIDErring diff --git a/submodules/ghc-mod b/submodules/ghc-mod index 4a3f7c92c..d1c1333dd 160000 --- a/submodules/ghc-mod +++ b/submodules/ghc-mod @@ -1 +1 @@ -Subproject commit 4a3f7c92c499eaec9a0d6e88a1301a7d9e68cd86 +Subproject commit d1c1333ddbd8907b5886d992e864f6a2476cf4a3 From 84e0cc3b93679dc86e52e604fbe033547af8a12b Mon Sep 17 00:00:00 2001 From: Gurkenglas Date: Thu, 9 Aug 2018 10:43:01 +0200 Subject: [PATCH 6/8] Indent deriving to fix parse error --- hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 89de0604a..338065b90 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -149,8 +149,8 @@ instance ToJSON IdePlugins where type IdeGhcM = GM.GhcModT IdeM newtype IDErring m a = IDErring { getIDErring :: ExceptT IdeError m a } -deriving (Functor, Applicative, Monad, MonadReader r, MonadState s - , MonadIO, MonadTrans, MonadBase b, MFunctor) + deriving (Functor, Applicative, Monad, MonadReader r, MonadState s + , MonadIO, MonadTrans, MonadBase b, MFunctor) instance GM.MonadIO m => GM.MonadIO (IDErring m) where liftIO = lift . GM.liftIO instance GM.GmEnv m => GM.GmEnv (IDErring m) where From 509c97156ced3bda214cf0c4b80bfb4aca51aaf4 Mon Sep 17 00:00:00 2001 From: Gurkenglas Date: Thu, 9 Aug 2018 12:38:54 +0200 Subject: [PATCH 7/8] Fix silent merge conflicts --- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 8 ++-- src/Haskell/Ide/Engine/LSP/CodeActions.hs | 2 +- src/Haskell/Ide/Engine/LSP/Reactor.hs | 2 +- src/Haskell/Ide/Engine/Plugin/Example2.hs | 4 +- src/Haskell/Ide/Engine/Plugin/GhcMod.hs | 14 +++--- src/Haskell/Ide/Engine/Plugin/Haddock.hs | 11 +++-- src/Haskell/Ide/Engine/Plugin/Liquid.hs | 48 ++++++++----------- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 17 ++++--- submodules/haskell-lsp-test | 1 + test/dispatcher/Main.hs | 9 ++-- 10 files changed, 55 insertions(+), 61 deletions(-) create mode 160000 submodules/haskell-lsp-test diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index f43353ae7..81723982c 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -130,9 +130,9 @@ type CodeActionProvider = VersionedTextDocumentIdentifier -> CodeActionContext -> IdeResponseT [CodeAction] --- type DiagnosticProviderFunc = DiagnosticTrigger -> Uri -> IdeM (IdeResponse (Map.Map Uri (S.Set Diagnostic))) +-- type DiagnosticProviderFunc = DiagnosticTrigger -> Uri -> IdeResponseT (Map.Map Uri (S.Set Diagnostic))) type DiagnosticProviderFunc - = DiagnosticTrigger -> Uri -> IdeGhcM (IdeResult (Map.Map Uri (S.Set Diagnostic))) + = DiagnosticTrigger -> Uri -> IDErring IdeGhcM (Map.Map Uri (S.Set Diagnostic)) data DiagnosticProvider = DiagnosticProvider { dpTrigger :: S.Set DiagnosticTrigger -- AZ:should this be a NonEmptyList? @@ -144,9 +144,9 @@ data DiagnosticTrigger = DiagnosticOnOpen | DiagnosticOnSave deriving (Show,Ord,Eq) -type HoverProvider = Uri -> Position -> IdeM (IdeResponse [Hover]) +type HoverProvider = Uri -> Position -> IdeResponseT [Hover] -type SymbolProvider = Uri -> IdeM (IdeResponse [DocumentSymbol]) +type SymbolProvider = Uri -> IdeResponseT [DocumentSymbol] data PluginDescriptor = PluginDescriptor { pluginName :: T.Text diff --git a/src/Haskell/Ide/Engine/LSP/CodeActions.hs b/src/Haskell/Ide/Engine/LSP/CodeActions.hs index e223c09ba..4c31c8f6e 100644 --- a/src/Haskell/Ide/Engine/LSP/CodeActions.hs +++ b/src/Haskell/Ide/Engine/LSP/CodeActions.hs @@ -40,7 +40,7 @@ handleCodeActionReq tn req = do let getProviders :: IdeResponseT [CodeActionProvider] getProviders = do IdePlugins m <- use idePlugins - return $ map pluginCodeActionProvider $ toList m + return $ mapMaybe pluginCodeActionProvider $ toList m providersCb :: [CodeActionProvider] -> R () providersCb providers = diff --git a/src/Haskell/Ide/Engine/LSP/Reactor.hs b/src/Haskell/Ide/Engine/LSP/Reactor.hs index 36ef2343c..2bb7e4fa0 100644 --- a/src/Haskell/Ide/Engine/LSP/Reactor.hs +++ b/src/Haskell/Ide/Engine/LSP/Reactor.hs @@ -91,7 +91,7 @@ writePluginReq req lid = do writeTChan cin req -- | Execute multiple ide requests sequentially -makeRequests :: [IdeM (IdeResponse a)] -- ^ The requests to make +makeRequests :: [IdeResponseT a] -- ^ The requests to make -> TrackingNumber -> J.LspId -> ([a] -> R ()) -- ^ Callback with the request inputs and results diff --git a/src/Haskell/Ide/Engine/Plugin/Example2.hs b/src/Haskell/Ide/Engine/Plugin/Example2.hs index 5837c7e5f..31fee3910 100644 --- a/src/Haskell/Ide/Engine/Plugin/Example2.hs +++ b/src/Haskell/Ide/Engine/Plugin/Example2.hs @@ -49,7 +49,7 @@ sayHelloTo n = return $ "hello " <> n <> " from ExamplePlugin2" -- --------------------------------------------------------------------- -diagnosticProvider :: DiagnosticTrigger -> Uri -> IdeGhcM (IdeResult (Map.Map Uri (S.Set Diagnostic))) +diagnosticProvider :: DiagnosticTrigger -> Uri -> IDErring IdeGhcM (Map.Map Uri (S.Set Diagnostic)) diagnosticProvider trigger uri = do liftIO $ logm "Example2.diagnosticProvider called" let diag = Diagnostic @@ -60,4 +60,4 @@ diagnosticProvider trigger uri = do , _message = "Example plugin diagnostic, triggered by" <> T.pack (show trigger) , _relatedInformation = Nothing } - return $ IdeResultOk $ Map.fromList [(uri,S.singleton diag)] + return $ Map.fromList [(uri,S.singleton diag)] diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs index 464ac91be..e7f546c8e 100644 --- a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs +++ b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs @@ -481,9 +481,9 @@ extractRedundantImport msg = -- --------------------------------------------------------------------- hoverProvider :: HoverProvider -hoverProvider doc pos = runIdeResponseT $ do - info' <- IdeResponseT $ IdeResponseResult <$> newTypeCmd pos doc - names' <- IdeResponseT $ Hie.getSymbolsAtPoint doc pos +hoverProvider doc pos = do + info' <- hoist lift $ newTypeCmd pos doc + names' <- Hie.getSymbolsAtPoint doc pos let f = (==) `on` (Hie.showName . snd) f' = compare `on` (Hie.showName . snd) @@ -517,8 +517,8 @@ hoverProvider doc pos = runIdeResponseT $ do data Decl = Decl LSP.SymbolKind (Located RdrName) [Decl] | Import LSP.SymbolKind (Located ModuleName) [Decl] -symbolProvider :: Uri -> IdeM (IdeResponse [LSP.DocumentSymbol]) -symbolProvider uri = pluginGetFileResponse "ghc-mod symbolProvider: " uri $ \file -> withCachedModule file $ \cm -> do +symbolProvider :: Uri -> IdeResponseT [LSP.DocumentSymbol] +symbolProvider uri = pluginGetFile "ghc-mod symbolProvider: " uri >>= \file -> withCachedModule file $ \cm -> do let tm = tcMod cm hsMod = unLoc $ pm_parsed_source $ tm_parsed_module tm imports = hsmodImports hsMod @@ -604,6 +604,6 @@ symbolProvider uri = pluginGetFileResponse "ghc-mod symbolProvider: " uri $ \fil LSP.DocumentSymbol name (Just "") kind Nothing r r chList - symInfs <- concat <$> mapM declsToSymbolInf (imps ++ decls) - return $ IdeResponseOk symInfs + symInfs <- concat <$> mapM (liftIde . declsToSymbolInf) (imps ++ decls) + return symInfs diff --git a/src/Haskell/Ide/Engine/Plugin/Haddock.hs b/src/Haskell/Ide/Engine/Plugin/Haddock.hs index 5220d8133..27c267271 100644 --- a/src/Haskell/Ide/Engine/Plugin/Haddock.hs +++ b/src/Haskell/Ide/Engine/Plugin/Haddock.hs @@ -6,6 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} module Haskell.Ide.Engine.Plugin.Haddock where +import Control.Monad.Morph import Control.Monad.State import Control.Lens hiding ((<.>)) import Data.Foldable @@ -217,15 +218,15 @@ renderMarkDown = removeInner x = T.replace "```" "" $ T.replace "```haskell" "" x hoverProvider :: HoverProvider -hoverProvider doc pos = runIdeResponseT $ do - df <- IdeResponseT $ getDynFlags doc - names' <- IdeResponseT $ getSymbolsAtPoint doc pos +hoverProvider doc pos = do + df <- getDynFlags doc + names' <- getSymbolsAtPoint doc pos let names = mapMaybe pickName $ groupBy f $ sortBy f' names' - docs <- forM names $ \(_,name) -> do + docs <- hoist lift $ forM names $ \(_,name) -> do let sname = showName name case getModule df name of Nothing -> return $ "`" <> sname <> "` *local*" - (Just (pkg,mdl)) -> do + Just (pkg,mdl) -> do let mname = "`"<> sname <> "`\n\n" let minfo = maybe "" (<>" ") pkg <> mdl mdocu' <- lift $ getDocsWithType df name diff --git a/src/Haskell/Ide/Engine/Plugin/Liquid.hs b/src/Haskell/Ide/Engine/Plugin/Liquid.hs index 5894305db..a58089462 100644 --- a/src/Haskell/Ide/Engine/Plugin/Liquid.hs +++ b/src/Haskell/Ide/Engine/Plugin/Liquid.hs @@ -44,12 +44,11 @@ liquidDescriptor = PluginDescriptor -- --------------------------------------------------------------------- sayHelloCmd :: CommandFunc () T.Text -sayHelloCmd = CmdSync $ \_ -> return (IdeResultOk sayHello) +sayHelloCmd = CmdSync $ \_ -> return sayHello sayHelloToCmd :: CommandFunc T.Text T.Text -sayHelloToCmd = CmdSync $ \n -> do - r <- liftIO $ sayHelloTo n - return $ IdeResultOk r +sayHelloToCmd = CmdSync $ \n -> + liftIO $ sayHelloTo n -- --------------------------------------------------------------------- @@ -91,14 +90,10 @@ instance ToJSON LiquidError -- --------------------------------------------------------------------- -diagnosticProvider :: DiagnosticTrigger -> Uri -> IdeGhcM (IdeResult (Map.Map Uri (S.Set Diagnostic))) +diagnosticProvider :: DiagnosticTrigger -> Uri -> IDErring IdeGhcM (Map.Map Uri (S.Set Diagnostic)) diagnosticProvider _trigger uri = do me <- liftIO $ readJsonAnnot uri - case me of - Nothing -> return $ IdeResultOk Map.empty - Just es -> return $ IdeResultOk m - where - m = Map.fromList [(uri,S.fromList (map liquidErrorToDiagnostic es))] + return $ Map.fromList [(uri,S.fromList (map liquidErrorToDiagnostic es)) | Just es <- [me]] -- let diag = Diagnostic -- { _range = Range (Position 5 0) (Position 7 0) -- , _severity = Nothing @@ -107,7 +102,7 @@ diagnosticProvider _trigger uri = do -- , _message = "Liquid plugin diagnostic, vim annot in " <> T.pack (vimAnnotFile uri) -- , _relatedInformation = Nothing -- } - -- return $ IdeResultOk $ Map.fromList [(uri,S.singleton diag)] + -- return $ Map.fromList [(uri,S.singleton diag)] -- --------------------------------------------------------------------- @@ -180,24 +175,23 @@ liquidFileFor uri ext = -- --------------------------------------------------------------------- --- type HoverProvider = Uri -> Position -> IdeM (IdeResponse Hover) +-- type HoverProvider = Uri -> Position -> IdeResponseT Hover hoverProvider :: HoverProvider -hoverProvider uri pos = - pluginGetFileResponse "Liquid.hoverProvider: " uri $ \file -> - withCachedModuleAndDataDefault file (Just (IdeResponseOk [])) $ - \cm () -> do - merrs <- liftIO $ readVimAnnot uri - case merrs of - Nothing -> return $ IdeResponseResult (IdeResultOk []) - Just lerrs -> do - let perrs = map (\le@(LE s e _) -> (lpToPos s,lpToPos e,le)) lerrs - ls = getThingsAtPos cm pos perrs - hs <- forM ls $ \(r,LE _s _e msg) -> do - let msgs = T.splitOn "\\n" msg - msg' = J.CodeString (J.LanguageString "haskell" (T.unlines msgs)) - return $ J.Hover (J.List [msg']) (Just r) - return $ IdeResponseResult (IdeResultOk hs) +hoverProvider uri pos = do + file <- pluginGetFile "Liquid.hoverProvider: " uri + withCachedModuleAndDataDefault file (Just (return [])) $ + \cm () -> do + merrs <- liftIO $ readVimAnnot uri + case merrs of + Nothing -> return [] + Just lerrs -> do + let perrs = map (\le@(LE s e _) -> (lpToPos s,lpToPos e,le)) lerrs + ls = getThingsAtPos cm pos perrs + forM ls $ \(r,LE _s _e msg) -> do + let msgs = T.splitOn "\\n" msg + msg' = J.CodeString (J.LanguageString "haskell" (T.unlines msgs)) + return $ J.Hover (J.List [msg']) (Just r) -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index 0565eda03..3868418a4 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -24,8 +24,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM import Control.Monad.Reader -import Control.Monad.Morph -import Control.Applicative import qualified Data.Aeson as J import Data.Aeson ( (.=) ) import qualified Data.ByteString.Lazy as BL @@ -476,7 +474,7 @@ reactor inp = do doc = params ^. J.textDocument . J.uri :: Uri hps <- asks hoverProviders - + let callback :: [[J.Hover]] -> R () callback hhs = -- TODO: We should support ServerCapabilities and declare that @@ -488,16 +486,17 @@ reactor inp = do h = J.Hover (fold (map (^. J.contents) hs)) r r = listToMaybe $ mapMaybe (^. J.range) hs in reactorSend $ RspHover $ Core.makeResponseMessage req h - + hreq :: PluginRequest R - hreq = IReq tn (req ^. J.id) callback $ - fp <- pluginGetFileResponse "ReqHover:" doc + hreq = IReq tn (req ^. J.id) callback $ do + fp <- pluginGetFile "ReqHover:" doc cached <- isCached fp -- Hover requests need to be instant so don't wait -- for cached module to be loaded if cached then sequence <$> mapM (\hp -> hp doc pos) hps else return [] + makeRequest hreq liftIO $ U.logs "reactor:HoverRequest done" @@ -727,9 +726,9 @@ reactor inp = do liftIO $ U.logs $ "reactor:didChangeConfiguration diagsOn:" ++ show diagsOn -- If hlint is off, remove the diags. But make sure they get sent, in -- case maxDiagnosticsToSend has changed. - if diagsOn - then flushDiagnosticsBySource maxDiagnosticsToSend Nothing - else flushDiagnosticsBySource maxDiagnosticsToSend (Just "hlint") + flushDiagnosticsBySource maxDiagnosticsToSend $ if diagsOn + then Nothing + else Just "hlint" -- ------------------------------- om -> do diff --git a/submodules/haskell-lsp-test b/submodules/haskell-lsp-test new file mode 160000 index 000000000..776b8e1a4 --- /dev/null +++ b/submodules/haskell-lsp-test @@ -0,0 +1 @@ +Subproject commit 776b8e1a475e2150797d432f0c13ccf685b1cd4b diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index 2a63f45a9..64865667b 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -137,10 +137,9 @@ newPluginSpec = do it "dispatches response correctly" $ do inChan <- atomically newTChan outChan <- atomically newTChan - dispatcherEnv <- atomically $ DispatcherEnv - <$> newTVar S.empty - <*> newTVar S.empty - <*> newTVar (Map.singleton (filePathToUri "test") 3) + cancelTVar <- newTVarIO S.empty + wipTVar <- newTVarIO S.empty + versionTVar <- newTVarIO $ Map.singleton (filePathToUri "test") 3 let req1 = GReq 1 Nothing Nothing (Just $ IdInt 1) (atomically . writeTChan outChan) $ return $ T.pack "text1" req2 = GReq 2 Nothing Nothing (Just $ IdInt 2) (atomically . writeTChan outChan) $ return $ T.pack "text2" req3 = GReq 3 Nothing (Just (filePathToUri "test", 2)) Nothing (atomically . writeTChan outChan) $ return $ T.pack "text3" @@ -149,7 +148,7 @@ newPluginSpec = do pid <- forkIO $ dispatcherP inChan (pluginDescToIdePlugins []) testOptions - dispatcherEnv + (DispatcherEnv cancelTVar wipTVar versionTVar) (\_ _ _ -> return ()) (\f x -> f x) def From 84d60f4af62fe58402a569d5992e2790ef4e6cbe Mon Sep 17 00:00:00 2001 From: Gurkenglas Date: Sun, 12 Aug 2018 03:42:07 +0200 Subject: [PATCH 8/8] Switch the FreeT and ExceptT layers --- .../Haskell/Ide/Engine/PluginUtils.hs | 2 +- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 32 +++++++++++++------ src/Haskell/Ide/Engine/Dispatcher.hs | 32 ++++++++++--------- src/Haskell/Ide/Engine/Plugin/GhcMod.hs | 12 +++---- src/Haskell/Ide/Engine/Plugin/Haddock.hs | 2 +- src/Haskell/Ide/Engine/Plugin/HsImport.hs | 11 +++---- src/Haskell/Ide/Engine/Plugin/Package.hs | 3 +- submodules/HaRe | 2 +- submodules/ghc-mod | 2 +- test/unit/GhcModPluginSpec.hs | 5 ++- test/unit/HaRePluginSpec.hs | 25 ++++++++------- 11 files changed, 69 insertions(+), 59 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs index 6425930e7..4414eca58 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs @@ -108,7 +108,7 @@ srcSpan2Loc revMapp spn = runExceptT $ do -- | Helper function that extracts a filepath from a Uri if the Uri -- is well formed (i.e. begins with a file:// ) -- fails with an IdeError otherwise -pluginGetFile :: Monad m => T.Text -> Uri -> IDErring m FilePath +pluginGetFile :: IDErrs m => T.Text -> Uri -> m FilePath pluginGetFile name uri = case uriToFilePath uri of Just file -> return file Nothing -> ideError diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 81723982c..47c6a3590 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -15,6 +15,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DefaultSignatures #-} -- | IdeGhcM and associated types module Haskell.Ide.Engine.PluginsIdeMonads @@ -59,7 +60,7 @@ module Haskell.Ide.Engine.PluginsIdeMonads , DiagnosticSeverity(..) , PublishDiagnosticsParams(..) , List(..) - , ideError + , IDErrs(..) , defer , moduleCache, requestQueue, idePlugins, extensibleState, ghcSession ) where @@ -213,7 +214,8 @@ type IdeM = ReaderT ClientCapabilities (MultiThreadState IdeState) class Monad m => MonadIde m where liftIde :: IdeM a -> m a instance MonadIde IdeGhcM where liftIde = lift . lift instance MonadIde m => MonadIde (IDErring m) where liftIde = lift . liftIde -instance MonadIde (ResponseT IdeM) where liftIde = lift +instance MonadIde m => MonadIde (ResponseT m) where liftIde = lift . liftIde +instance MonadIde IdeM where liftIde = id data IdeState = IdeState { _moduleCache :: GhcModuleCache @@ -226,14 +228,14 @@ data IdeState = IdeState -- | The IDE response, which wraps around an (Either IdeError a) that may be deferred. -- Used mostly in IdeM. -data IdeDefer a = IdeDefer FilePath (CachedModule -> a) deriving Functor +data IdeDefer a = IdeDefer FilePath (Either T.Text CachedModule -> a) deriving Functor type ResponseT = FreeT IdeDefer -type IdeResponseT = IDErring (ResponseT IdeM) -- Lightens error messages +type IdeResponseT = ResponseT (IDErring IdeM) -- Lightens error messages instance GM.MonadIO m => GM.MonadIO (ResponseT m) where liftIO = lift . GM.liftIO -defer :: MonadFree IdeDefer m => FilePath -> (CachedModule -> m a) -> m a -defer fp f = wrap $ IdeDefer fp f +defer :: (IDErrs m, MonadFree IdeDefer m) => FilePath -> (CachedModule -> m a) -> m a +defer fp f = wrap $ IdeDefer fp $ either (\err -> ideError NoModuleAvailable err Null) f instance Show1 IdeDefer where liftShowsPrec _ _ _ (IdeDefer fp _) = (++) $ "Deferred response waiting on " ++ fp instance Show (IdeDefer a) where show (IdeDefer fp _) = "Deferred response waiting on " ++ fp @@ -267,8 +269,15 @@ data IdeError = IdeError instance ToJSON IdeError instance FromJSON IdeError -ideError :: Monad m => IdeErrorCode -> T.Text -> Value -> IDErring m a -ideError c m i = IDErring $ throwError $ IdeError c m i +class Monad m => IDErrs m where + ideError :: IdeErrorCode -> T.Text -> Value -> m a + default ideError :: (IDErrs n, MonadTrans t, m ~ t n) => IdeErrorCode -> T.Text -> Value -> m a + ideError c m i = lift $ ideError c m i + +instance Monad m => IDErrs (IDErring m) where + ideError c m i = IDErring $ throwError $ IdeError c m i + +instance IDErrs m => IDErrs (ResponseT m) makeLenses ''IdeState @@ -292,7 +301,12 @@ instance HasGhcModuleCache m => HasGhcModuleCache (ResponseT m) where getModuleCache = lift getModuleCache setModuleCache = lift . setModuleCache -deriving instance (GM.MonadIO m, ExceptionMonad m) => ExceptionMonad (IDErring m) +instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (IDErring m) where + gcatch act handler = control $ \run -> + run act `gcatch` (run . handler) + + gmask = liftBaseOp gmask . liftRestore + where liftRestore f r = f $ liftBaseOp_ r instance ExceptionMonad m => ExceptionMonad (ResponseT m) where gcatch act handler = let levelonecatch act' handler' = FreeT $ runFreeT act' `gcatch` (runFreeT . handler') in diff --git a/src/Haskell/Ide/Engine/Dispatcher.hs b/src/Haskell/Ide/Engine/Dispatcher.hs index 855b664bc..146279acf 100644 --- a/src/Haskell/Ide/Engine/Dispatcher.hs +++ b/src/Haskell/Ide/Engine/Dispatcher.hs @@ -20,7 +20,6 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.STM import Control.Monad.Trans.Free -import Control.Monad.Except import Data.Foldable import qualified Data.Aeson as J import qualified Data.Text as T @@ -86,20 +85,23 @@ ideDispatcher env errorHandler callbackHandler pin = forever $ do debugm "ideDispatcher: top of loop" IdeRequest tn lid callback action <- liftIO $ atomically $ readTChan pin debugm $ "ideDispatcher: got request " ++ show tn ++ " with id: " ++ show lid - handleAction lid $ fmap (liftIO . callbackHandler callback) action - where handleAction :: J.LspId -> IdeResponseT (IdeM ()) -> IdeM () - handleAction lid action = do - response <- runFreeT $ runIDErring $ - checkCancelled env lid *> action <* checkCancelled env lid - case response of - Pure result -> do - completedReq env lid - either (liftIO . handleError (errorHandler lid)) id result - Free (IdeDefer fp cacheCb) -> queueAction fp $ - handleAction lid . either (\err -> ideError NoModuleAvailable err J.Null) (IDErring . ExceptT . cacheCb) + iterT (\(IdeDefer fp cacheCb) -> requestQueue . at fp . non' _Empty %= (:) cacheCb) + $ hoistFreeT' (\layer -> do + result <- runIDErring layer + liftIO $ case result of + Right noerr -> return noerr + Left err -> do + completedReq env lid + Pure <$> handleError (errorHandler lid) err + ) $ do + checkCancelled env lid + success <- action + checkCancelled env lid + completedReq env lid + liftIO $ callbackHandler callback success - queueAction :: FilePath -> (Either T.Text CachedModule -> IdeM ()) -> IdeM () - queueAction fp action = requestQueue . at fp . non' _Empty %= (action:) +hoistFreeT' :: (forall f a. IDErring IdeM (FreeF f () a) -> IdeM (FreeF f () a)) -> IdeResponseT () -> ResponseT IdeM () +hoistFreeT' mh = FreeT . mh . fmap (fmap (hoistFreeT' mh)) . runFreeT ghcDispatcher :: forall void m. DispatcherEnv -> ErrorHandler -> CallbackHandler m -> TChan (GhcRequest m) -> GM.GhcModT IdeM void ghcDispatcher env@DispatcherEnv{docVersionTVar} errorHandler callbackHandler pin = forever $ do @@ -131,7 +133,7 @@ handleError handler (IdeError code msg _) = handler (translate code) msg where translate VersionMismatch = J.UnknownErrorCode translate _ = J.InternalError -checkCancelled :: MonadIO m => DispatcherEnv -> J.LspId -> IDErring m () +checkCancelled :: (IDErrs m, MonadIO m) => DispatcherEnv -> J.LspId -> m () checkCancelled env lid = do -- attempt to pop a corresponding cancel request cancelled <- liftIO $ atomically $ do diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs index e7f546c8e..43f6c4c81 100644 --- a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs +++ b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs @@ -58,7 +58,6 @@ import DataCon import TcRnTypes import Outputable (renderWithStyle, mkUserStyle, Depth(..)) import Control.Monad.Trans -import Control.Monad.Morph -- --------------------------------------------------------------------- @@ -271,10 +270,10 @@ instance ToJSON TypeParams where toJSON = genericToJSON customOptions typeCmd :: CommandFunc TypeParams [(Range,T.Text)] -typeCmd = CmdSync $ \(TP _bool uri pos) -> do - hoist liftIde $ newTypeCmd pos uri +typeCmd = CmdSync $ \(TP _bool uri pos) -> newTypeCmd pos uri -newTypeCmd :: Position -> Uri -> IDErring IdeM [(Range, T.Text)] +newTypeCmd :: (MonadIO m, HasGhcModuleCache m, IDErrs m) + => Position -> Uri -> m [(Range, T.Text)] newTypeCmd newPos uri = do fp <- pluginGetFile "newTypeCmd: " uri mcm <- getCachedModule fp @@ -482,7 +481,7 @@ extractRedundantImport msg = hoverProvider :: HoverProvider hoverProvider doc pos = do - info' <- hoist lift $ newTypeCmd pos doc + info' <- newTypeCmd pos doc names' <- Hie.getSymbolsAtPoint doc pos let f = (==) `on` (Hie.showName . snd) @@ -604,6 +603,5 @@ symbolProvider uri = pluginGetFile "ghc-mod symbolProvider: " uri >>= \file -> w LSP.DocumentSymbol name (Just "") kind Nothing r r chList - symInfs <- concat <$> mapM (liftIde . declsToSymbolInf) (imps ++ decls) - return symInfs + concat <$> mapM (liftIde . declsToSymbolInf) (imps ++ decls) diff --git a/src/Haskell/Ide/Engine/Plugin/Haddock.hs b/src/Haskell/Ide/Engine/Plugin/Haddock.hs index 27c267271..5a959964b 100644 --- a/src/Haskell/Ide/Engine/Plugin/Haddock.hs +++ b/src/Haskell/Ide/Engine/Plugin/Haddock.hs @@ -222,7 +222,7 @@ hoverProvider doc pos = do df <- getDynFlags doc names' <- getSymbolsAtPoint doc pos let names = mapMaybe pickName $ groupBy f $ sortBy f' names' - docs <- hoist lift $ forM names $ \(_,name) -> do + docs <- lift $ forM names $ \(_,name) -> do let sname = showName name case getModule df name of Nothing -> return $ "`" <> sname <> "` *local*" diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index d68e87b1d..18b0a9132 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -23,7 +23,6 @@ import qualified Haskell.Ide.Engine.Plugin.Hoogle as Hoogle import System.Directory import System.IO import Control.Monad.Trans -import Control.Monad.Morph hsimportDescriptor :: PluginDescriptor hsimportDescriptor = PluginDescriptor @@ -67,23 +66,21 @@ importModule uri modName = do Nothing -> do newText <- liftIO $ T.readFile output liftIO $ removeFile output - workspaceEdit <- liftIde $ makeDiffResult input newText fileMap - return workspaceEdit + liftIde $ makeDiffResult input newText fileMap codeActionProvider :: CodeActionProvider codeActionProvider docId _ _ context = do let J.List diags = context ^. J.diagnostics terms = mapMaybe getImportables diags - res <- hoist lift $ mapM (bimapM return Hoogle.searchModules) terms + res <- lift $ mapM (bimapM return Hoogle.searchModules) terms let actions = mapMaybe (uncurry mkImportAction) (concatTerms res) if null actions then do let relaxedTerms = map (bimap id (head . T.words)) terms - relaxedRes <- hoist lift $ mapM (bimapM return Hoogle.searchModules) relaxedTerms - let relaxedActions = mapMaybe (uncurry mkImportAction) (concatTerms relaxedRes) - return relaxedActions + relaxedRes <- lift $ mapM (bimapM return Hoogle.searchModules) relaxedTerms + return $ mapMaybe (uncurry mkImportAction) (concatTerms relaxedRes) else return actions where diff --git a/src/Haskell/Ide/Engine/Plugin/Package.hs b/src/Haskell/Ide/Engine/Plugin/Package.hs index e65a0b520..4ed237b5e 100644 --- a/src/Haskell/Ide/Engine/Plugin/Package.hs +++ b/src/Haskell/Ide/Engine/Plugin/Package.hs @@ -43,7 +43,6 @@ import Haskell.Ide.Engine.Compat (isExtensionOf) #endif import Control.Monad.IO.Class import Control.Monad.Trans -import Control.Monad.Morph import System.Directory import qualified GhcMod.Utils as GM import Distribution.Types.GenericPackageDescription @@ -236,7 +235,7 @@ codeActionProvider docId mRootDir _ context = do let J.List diags = context ^. J.diagnostics pkgs = mapMaybe getAddablePackages diags - res <- hoist lift $ mapM (bimapM return Hoogle.searchPackages) pkgs + res <- lift $ mapM (bimapM return Hoogle.searchPackages) pkgs let actions = mapMaybe (uncurry mkAddPackageAction) (concatPkgs res) return actions diff --git a/submodules/HaRe b/submodules/HaRe index db6d90357..a11f797e4 160000 --- a/submodules/HaRe +++ b/submodules/HaRe @@ -1 +1 @@ -Subproject commit db6d903573c2b093337f6173182fb7f5c2978810 +Subproject commit a11f797e408fe02c8443cf8ab0f5b4eaab66714c diff --git a/submodules/ghc-mod b/submodules/ghc-mod index d1c1333dd..66fc0980d 160000 --- a/submodules/ghc-mod +++ b/submodules/ghc-mod @@ -1 +1 @@ -Subproject commit d1c1333ddbd8907b5886d992e864f6a2476cf4a3 +Subproject commit 66fc0980d2c731caf36215969a31bff8ef40f3e2 diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 6f915d5a0..1fe57308a 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -18,7 +18,6 @@ import Haskell.Ide.Engine.Plugin.HaRe ( HarePoint(..) ) import Language.Haskell.LSP.Types ( TextEdit(..) ) import System.Directory import TestUtils -import Control.Monad.Morph (hoist) import Test.Hspec @@ -88,7 +87,7 @@ ghcmodSpec = let uri = filePathToUri fp act = do _ <- setTypecheckedModule uri - hoist liftIde $ newTypeCmd (toPos (5,9)) uri + newTypeCmd (toPos (5,9)) uri arg = TP False uri (toPos (5,9)) res = return [(Range (toPos (5,9)) (toPos (5,10)), "Int") @@ -107,7 +106,7 @@ ghcmodSpec = let uri = filePathToUri fp let act = do _ <- setTypecheckedModule uri - hoist liftIde $ newTypeCmd (toPos (5,9)) uri + newTypeCmd (toPos (5,9)) uri let arg = TP False uri (toPos (5,9)) let res = return [(Range (toPos (5,9)) (toPos (5,10)), "Int") diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index f7db9e4d9..b25b531c4 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -40,12 +40,13 @@ spec = do testPlugins :: IdePlugins testPlugins = pluginDescToIdePlugins [("hare",hareDescriptor)] -shouldRespond :: IDErring (FreeT IdeDefer IdeGhcM) [Location] -> Either IdeError [Location] -> IO () +shouldRespond :: FreeT IdeDefer (IDErring IdeGhcM) [Location] -> Either IdeError [Location] -> IO () shouldRespond have should = do - r <- cdAndDo "./test/testdata/gototest" $ runIGM testPlugins $ runFreeT $ runIDErring have + r <- cdAndDo "./test/testdata/gototest" $ runIGM testPlugins $ runIDErring $ runFreeT $ have r `shouldSatisfy` \case - Pure x -> x == should - Free _ -> False + Left x -> Left x == should + Right (Pure x) -> Right x == should + Right (Free _) -> False -- --------------------------------------------------------------------- @@ -160,25 +161,25 @@ hareSpec = do it "finds definition across components" $ do let u = filePathToUri $ cwd "test/testdata/gototest/app/Main.hs" - lreq = hoist lift $ setTypecheckedModule u - req = hoist (hoistFreeT liftIde) $ findDef u (toPos (7,8)) + lreq = lift $ setTypecheckedModule u + req = hoistFreeT (hoist liftIde) $ findDef u (toPos (7,8)) (lreq >> req) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs") (Range (toPos (6,1)) (toPos (6,9)))] - let req2 = hoist (hoistFreeT liftIde) $ findDef u (toPos (7,20)) + let req2 = hoistFreeT (hoist liftIde) $ findDef u (toPos (7,20)) (lreq >> req2) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs") (Range (toPos (5,1)) (toPos (5,2)))] it "finds definition in the same component" $ do let u = filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs" - lreq = hoist lift $ setTypecheckedModule u - req = hoist (hoistFreeT liftIde) $ findDef u (toPos (6,5)) + lreq = lift $ setTypecheckedModule u + req = hoistFreeT (hoist liftIde) $ findDef u (toPos (6,5)) (lreq >> req) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib.hs") (Range (toPos (6,1)) (toPos (6,9)))] it "finds local definitions" $ do let u = filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs" - lreq = hoist lift $ setTypecheckedModule u - req = hoist (hoistFreeT liftIde) $ findDef u (toPos (7,11)) + lreq = lift $ setTypecheckedModule u + req = hoistFreeT (hoist liftIde) $ findDef u (toPos (7,11)) (lreq >> req) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs") (Range (toPos (10,9)) (toPos (10,10)))] - let req2 = hoist (hoistFreeT liftIde) $ findDef u (toPos (10,13)) + let req2 = hoistFreeT (hoist liftIde) $ findDef u (toPos (10,13)) (lreq >> req2) `shouldRespond` Right [Location (filePathToUri $ cwd "test/testdata/gototest/src/Lib2.hs") (Range (toPos (9,9)) (toPos (9,10)))] \ No newline at end of file