From 1c602ac7fed835cf6e20946c0a24a57fb10623f0 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sat, 25 Aug 2018 02:38:06 +0100 Subject: [PATCH 01/14] Remove dump-logs options from tests --- .circleci/config.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 1948153f4..b394ccca8 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -59,7 +59,7 @@ defaults: &defaults - run: name: Test - command: stack -j 2 --stack-yaml=${STACK_FILE} test --dump-logs + command: stack -j 2 --stack-yaml=${STACK_FILE} test no_output_timeout: 120m - store_artifacts: From 953dd5dd5739dd7544d549a0672c1472b1b9836b Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sat, 25 Aug 2018 02:39:21 +0100 Subject: [PATCH 02/14] Format import code actions with Brittany if needed --- src/Haskell/Ide/Engine/Plugin/Brittany.hs | 5 +- src/Haskell/Ide/Engine/Plugin/HsImport.hs | 59 ++++++++++++++++++-- test/functional/FunctionalCodeActionsSpec.hs | 16 +++++- test/testdata/CodeActionImportBrittany.hs | 3 + 4 files changed, 75 insertions(+), 8 deletions(-) create mode 100644 test/testdata/CodeActionImportBrittany.hs diff --git a/src/Haskell/Ide/Engine/Plugin/Brittany.hs b/src/Haskell/Ide/Engine/Plugin/Brittany.hs index d3a7f0aed..6a81e0998 100644 --- a/src/Haskell/Ide/Engine/Plugin/Brittany.hs +++ b/src/Haskell/Ide/Engine/Plugin/Brittany.hs @@ -46,7 +46,7 @@ brittanyDescriptor plId = PluginDescriptor brittanyCmd :: Int -> Uri -> Maybe Range -> IdeGhcM (IdeResult [J.TextEdit]) brittanyCmd tabSize uri range = pluginGetFile "brittanyCmd: " uri $ \file -> do - confFile <- liftIO $ findLocalConfigPath (takeDirectory file) + confFile <- liftIO $ getConfFile file text <- GM.withMappedFile file $ liftIO . T.readFile case range of Just r -> do @@ -88,6 +88,9 @@ normalize (Range (Position sl _) (Position el _)) = -- Extend to the line below to replace newline character, as above Range (Position sl 0) (Position (el + 1) 0) +getConfFile :: FilePath -> IO (Maybe FilePath) +getConfFile = findLocalConfigPath . takeDirectory + runBrittany :: Int -- ^ tab size -> Maybe FilePath -- ^ local config file -> Text -- ^ text to format diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index fc3353b5a..4b07014fb 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -4,22 +4,30 @@ {-# LANGUAGE TupleSections #-} module Haskell.Ide.Engine.Plugin.HsImport where -import Control.Lens +import Control.Lens.Operators import Control.Monad.IO.Class +import Control.Monad import Data.Aeson import Data.Bitraversable +import Data.Bifunctor +import Data.Either import Data.Foldable +import qualified Data.HashMap.Strict as HM import Data.Maybe -import Data.Monoid ((<>)) +import Data.Monoid ( (<>) ) import qualified Data.Text as T import qualified Data.Text.IO as T import qualified GHC.Generics as Generics import qualified GhcMod.Utils as GM import HsImport import Haskell.Ide.Engine.MonadTypes +import Haskell.Ide.Engine.MonadFunctions import qualified Language.Haskell.LSP.Types as J import Haskell.Ide.Engine.PluginUtils -import qualified Haskell.Ide.Engine.Plugin.Hoogle as Hoogle +import qualified Haskell.Ide.Engine.Plugin.Brittany + as Brittany +import qualified Haskell.Ide.Engine.Plugin.Hoogle + as Hoogle import System.Directory import System.IO @@ -67,8 +75,49 @@ importModule uri modName = Nothing -> do newText <- liftIO $ T.readFile output liftIO $ removeFile output - workspaceEdit <- liftToGhc $ makeDiffResult input newText fileMap - return $ IdeResultOk workspaceEdit + J.WorkspaceEdit mChanges mDocChanges <- liftToGhc $ makeDiffResult input newText fileMap + + shouldFormat <- hasFormattedImports input + if shouldFormat + then do + confFile <- liftIO $ Brittany.getConfFile origInput + -- Format the import with Brittany + newChanges <- forM mChanges $ mapM $ mapM (formatTextEdit confFile) + newDocChanges <- forM mDocChanges $ mapM $ \(J.TextDocumentEdit vDocId tes) -> do + ftes <- forM tes (formatTextEdit confFile) + return (J.TextDocumentEdit vDocId ftes) + + return $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges) + else + return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges) + + where hasFormattedImports fp = do + ls <- T.lines <$> liftIO (T.readFile fp) + debugm (show ls) + return (any isFormattedLine ls) + -- Only use Brittany formatting if it's already formatted + isFormattedLine x + | "import qualified " `T.isPrefixOf` x = True + | "import " `T.isPrefixOf` x = True + | otherwise = False + formatTextEdit confFile (J.TextEdit r t) = do + ft <- fromRight t <$> liftIO (Brittany.runBrittany 2 confFile t) + return (J.TextEdit r ft) + +changedRange :: WorkspaceEdit -> Maybe Range +changedRange (WorkspaceEdit _ (Just (List ((J.TextDocumentEdit _ (List tes)):_)))) + = changedRange' tes +changedRange (WorkspaceEdit (Just changes) _) = + case HM.elems changes of + List tes:_ -> changedRange' tes + _ -> Nothing +changedRange _ = Nothing + +changedRange' :: [J.TextEdit] -> Maybe Range +changedRange' = foldl go Nothing + where go Nothing (J.TextEdit r _) = Just r + go (Just acc) (J.TextEdit r _) = Just (concatRange r acc) + concatRange (Range s1 e1) (Range s2 e2) = Range (min s1 s2) (max e1 e2) codeActionProvider :: CodeActionProvider codeActionProvider plId docId _ _ context = do diff --git a/test/functional/FunctionalCodeActionsSpec.hs b/test/functional/FunctionalCodeActionsSpec.hs index c8cd316c0..34bf0cb14 100644 --- a/test/functional/FunctionalCodeActionsSpec.hs +++ b/test/functional/FunctionalCodeActionsSpec.hs @@ -92,8 +92,8 @@ spec = describe "code actions" $ do _:x:_ <- T.lines <$> documentContents doc liftIO $ x `shouldBe` "foo = putStrLn \"world\"" - it "provides import suggestions and 3.8 code action kinds" $ - runSession hieCommand fullCaps "test/testdata" $ do + describe "import suggetsions" $ do + it "works with 3.8 code action kinds" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "CodeActionImport.hs" "haskell" -- ignore the first empty hlint diagnostic publish @@ -118,7 +118,19 @@ spec = describe "code actions" $ do contents <- getDocumentEdit doc liftIO $ contents `shouldBe` "import Control.Monad\nmain :: IO ()\nmain = when True $ putStrLn \"hello\"" + it "formats with brittany if needed" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "CodeActionImportBrittany.hs" "haskell" + _ <- waitForDiagnosticsSource "ghcmod" + + actionsOrCommands <- getAllCodeActions doc + let action:_ = map fromAction actionsOrCommands + executeCodeAction action + contents <- getDocumentEdit doc + liftIO $ do + let l1:l2:_ = T.lines contents + l1 `shouldBe` "import qualified Data.Maybe" + l2 `shouldBe` "import Control.Monad" describe "add package suggestions" $ do it "adds to .cabal files" $ runSession hieCommand fullCaps "test/testdata/addPackageTest/cabal" $ do diff --git a/test/testdata/CodeActionImportBrittany.hs b/test/testdata/CodeActionImportBrittany.hs new file mode 100644 index 000000000..af9cb0d2d --- /dev/null +++ b/test/testdata/CodeActionImportBrittany.hs @@ -0,0 +1,3 @@ +import qualified Data.Maybe +main :: IO () +main = when True $ putStrLn "hello" \ No newline at end of file From a04c940100cf57cc482407ec83e8fbb536a83caa Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sat, 25 Aug 2018 02:41:50 +0100 Subject: [PATCH 03/14] Remove unused imports/functions --- src/Haskell/Ide/Engine/Plugin/HsImport.hs | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index 4b07014fb..6739e2ed3 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -12,7 +12,6 @@ import Data.Bitraversable import Data.Bifunctor import Data.Either import Data.Foldable -import qualified Data.HashMap.Strict as HM import Data.Maybe import Data.Monoid ( (<>) ) import qualified Data.Text as T @@ -104,21 +103,6 @@ importModule uri modName = ft <- fromRight t <$> liftIO (Brittany.runBrittany 2 confFile t) return (J.TextEdit r ft) -changedRange :: WorkspaceEdit -> Maybe Range -changedRange (WorkspaceEdit _ (Just (List ((J.TextDocumentEdit _ (List tes)):_)))) - = changedRange' tes -changedRange (WorkspaceEdit (Just changes) _) = - case HM.elems changes of - List tes:_ -> changedRange' tes - _ -> Nothing -changedRange _ = Nothing - -changedRange' :: [J.TextEdit] -> Maybe Range -changedRange' = foldl go Nothing - where go Nothing (J.TextEdit r _) = Just r - go (Just acc) (J.TextEdit r _) = Just (concatRange r acc) - concatRange (Range s1 e1) (Range s2 e2) = Range (min s1 s2) (max e1 e2) - codeActionProvider :: CodeActionProvider codeActionProvider plId docId _ _ context = do let J.List diags = context ^. J.diagnostics From e50e99ab21b8d7fde42b9e4768e3a81fa8578ae6 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 28 Aug 2018 18:03:09 +0100 Subject: [PATCH 04/14] Always format hsimport --- src/Haskell/Ide/Engine/Plugin/HsImport.hs | 35 +++++++---------------- 1 file changed, 11 insertions(+), 24 deletions(-) diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index 6739e2ed3..88582f94f 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -76,30 +76,17 @@ importModule uri modName = liftIO $ removeFile output J.WorkspaceEdit mChanges mDocChanges <- liftToGhc $ makeDiffResult input newText fileMap - shouldFormat <- hasFormattedImports input - if shouldFormat - then do - confFile <- liftIO $ Brittany.getConfFile origInput - -- Format the import with Brittany - newChanges <- forM mChanges $ mapM $ mapM (formatTextEdit confFile) - newDocChanges <- forM mDocChanges $ mapM $ \(J.TextDocumentEdit vDocId tes) -> do - ftes <- forM tes (formatTextEdit confFile) - return (J.TextDocumentEdit vDocId ftes) - - return $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges) - else - return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges) - - where hasFormattedImports fp = do - ls <- T.lines <$> liftIO (T.readFile fp) - debugm (show ls) - return (any isFormattedLine ls) - -- Only use Brittany formatting if it's already formatted - isFormattedLine x - | "import qualified " `T.isPrefixOf` x = True - | "import " `T.isPrefixOf` x = True - | otherwise = False - formatTextEdit confFile (J.TextEdit r t) = do + confFile <- liftIO $ Brittany.getConfFile origInput + -- Format the import with Brittany + newChanges <- forM mChanges $ mapM $ mapM (formatTextEdit confFile) + newDocChanges <- forM mDocChanges $ mapM $ \(J.TextDocumentEdit vDocId tes) -> do + ftes <- forM tes (formatTextEdit confFile) + return (J.TextDocumentEdit vDocId ftes) + + return $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges) + + where formatTextEdit confFile (J.TextEdit r t) = do + -- TODO: This tab size of 2 spaces should probably be taken from a config ft <- fromRight t <$> liftIO (Brittany.runBrittany 2 confFile t) return (J.TextEdit r ft) From dbf3eab7f2a3358120b2f5ecb8df24ddf13c4a34 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 28 Aug 2018 18:13:34 +0100 Subject: [PATCH 05/14] Fix tests --- src/Haskell/Ide/Engine/Plugin/HsImport.hs | 1 - test/functional/FunctionalCodeActionsSpec.hs | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index a915644cb..7fdc0bc7f 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -20,7 +20,6 @@ import qualified GHC.Generics as Generics import qualified GhcMod.Utils as GM import HsImport import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.MonadFunctions import qualified Language.Haskell.LSP.Types as J import Haskell.Ide.Engine.PluginUtils import qualified Haskell.Ide.Engine.Plugin.Brittany diff --git a/test/functional/FunctionalCodeActionsSpec.hs b/test/functional/FunctionalCodeActionsSpec.hs index 34bf0cb14..124565327 100644 --- a/test/functional/FunctionalCodeActionsSpec.hs +++ b/test/functional/FunctionalCodeActionsSpec.hs @@ -117,7 +117,7 @@ spec = describe "code actions" $ do executeCodeAction (head actns) contents <- getDocumentEdit doc - liftIO $ contents `shouldBe` "import Control.Monad\nmain :: IO ()\nmain = when True $ putStrLn \"hello\"" + liftIO $ contents `shouldBe` "import Control.Monad\nmain :: IO ()\nmain = when True $ putStrLn \"hello\"" it "formats with brittany if needed" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "CodeActionImportBrittany.hs" "haskell" _ <- waitForDiagnosticsSource "ghcmod" From 6d8f66980224bb0da4ce26a9b66de09f01fbfd9d Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 4 Nov 2018 23:17:51 +0000 Subject: [PATCH 06/14] Integrate LspFuncs into IdeM/IdeGhcM This allows for plugins to now access config options It also streamlines the process of running the monads from Scheduler Should be expanded upon to move VFS into --- haskell-ide-engine.cabal | 1 - .../Haskell/Ide/Engine}/Config.hs | 23 +++++++--- hie-plugin-api/Haskell/Ide/Engine/Monad.hs | 19 -------- .../Haskell/Ide/Engine/PluginUtils.hs | 2 +- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 44 ++++++++++++++++++- hie-plugin-api/hie-plugin-api.cabal | 3 +- src/Haskell/Ide/Engine/LSP/Reactor.hs | 2 +- src/Haskell/Ide/Engine/Plugin/HieExtras.hs | 19 ++++---- src/Haskell/Ide/Engine/Scheduler.hs | 42 +++++++----------- src/Haskell/Ide/Engine/Transport/JsonStdio.hs | 3 +- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 7 ++- 11 files changed, 91 insertions(+), 74 deletions(-) rename {src/Haskell/Ide/Engine/LSP => hie-plugin-api/Haskell/Ide/Engine}/Config.hs (80%) delete mode 100644 hie-plugin-api/Haskell/Ide/Engine/Monad.hs diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 3c8e0245b..44abe2b9c 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -23,7 +23,6 @@ library Haskell.Ide.Engine.Channel Haskell.Ide.Engine.Scheduler Haskell.Ide.Engine.LSP.CodeActions - Haskell.Ide.Engine.LSP.Config Haskell.Ide.Engine.LSP.Reactor Haskell.Ide.Engine.Options Haskell.Ide.Engine.Plugin.ApplyRefact diff --git a/src/Haskell/Ide/Engine/LSP/Config.hs b/hie-plugin-api/Haskell/Ide/Engine/Config.hs similarity index 80% rename from src/Haskell/Ide/Engine/LSP/Config.hs rename to hie-plugin-api/Haskell/Ide/Engine/Config.hs index 2f8c8738e..e5e82a4f5 100644 --- a/src/Haskell/Ide/Engine/LSP/Config.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Config.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -module Haskell.Ide.Engine.LSP.Config where +module Haskell.Ide.Engine.Config where import Data.Aeson +import Data.Default import qualified Data.Map as Map import qualified Data.Text as T -import Haskell.Ide.Engine.PluginsIdeMonads import Language.Haskell.LSP.Types -- --------------------------------------------------------------------- @@ -27,14 +27,23 @@ data Config = , completionSnippetsOn :: Bool } deriving (Show,Eq) +instance Default Config where + def = Config + { hlintOn = True + , maxNumberOfProblems = 100 + , liquidOn = False + , completionSnippetsOn = True + } + +-- TODO: Add API for plugins to expose their own LSP config options instance FromJSON Config where parseJSON = withObject "Config" $ \v -> do s <- v .: "languageServerHaskell" flip (withObject "Config.settings") s $ \o -> Config - <$> o .:? "hlintOn" .!= True - <*> o .:? "maxNumberOfProblems" .!= 100 - <*> o .:? "liquidOn" .!= False - <*> o .:? "completionSnippetsOn" .!= True + <$> o .:? "hlintOn" .!= hlintOn def + <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def + <*> o .:? "liquidOn" .!= liquidOn def + <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def -- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"languageServerHaskell":{"maxNumberOfProblems":100,"hlintOn":true}}}} -- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification: @@ -58,7 +67,7 @@ instance ToJSON Config where -- | For the diagnostic providers in the config, return a map of -- current enabled state, indexed by the plugin id. -getDiagnosticProvidersConfig :: Config -> Map.Map PluginId Bool +getDiagnosticProvidersConfig :: Config -> Map.Map T.Text Bool getDiagnosticProvidersConfig c = Map.fromList [("applyrefact",hlintOn c) ,("liquid", liquidOn c) ] diff --git a/hie-plugin-api/Haskell/Ide/Engine/Monad.hs b/hie-plugin-api/Haskell/Ide/Engine/Monad.hs deleted file mode 100644 index e0d3ba438..000000000 --- a/hie-plugin-api/Haskell/Ide/Engine/Monad.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Haskell.Ide.Engine.Monad where - -import Control.Exception -import Control.Monad.IO.Class -import Control.Monad.Reader -import qualified GhcMod.Monad as GM -import qualified GhcMod.Types as GM -import Haskell.Ide.Engine.MonadTypes -import Language.Haskell.LSP.Types.Capabilities - --- --------------------------------------------------------------------- - --- | runIdeGhcM with Cradle found from the current directory -runIdeGhcM :: GM.Options -> ClientCapabilities -> IdeState -> IdeGhcM a -> IO a -runIdeGhcM ghcModOptions caps s0 f = do - (eres, _) <- flip runMTState s0 $ flip runReaderT caps $ GM.runGhcModT ghcModOptions f - case eres of - Left err -> liftIO $ throwIO err - Right res -> return res diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs index 5b857f3ee..58658611e 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs @@ -232,7 +232,7 @@ fileInfo tfileName = clientSupportsDocumentChanges :: IdeM Bool clientSupportsDocumentChanges = do - ClientCapabilities mwCaps _ _ <- ask + ClientCapabilities mwCaps _ _ <- getClientCapabilities let supports = do wCaps <- mwCaps WorkspaceEditClientCapabilities mDc <- _workspaceEdit wCaps diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 9e46482e5..5e568ce3a 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -37,8 +37,12 @@ module Haskell.Ide.Engine.PluginsIdeMonads -- * The IDE monad , IdeState(..) , IdeGhcM + , runIdeGhcM , IdeM + , runIdeM , IdeDeferM + , getClientCapabilities + , getConfig , iterT , LiftsToGhc(..) -- * IdeResult @@ -64,27 +68,33 @@ module Haskell.Ide.Engine.PluginsIdeMonads ) where import Control.Concurrent.STM +import Control.Exception import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Free import Data.Aeson +import Data.Default import Data.Dynamic (Dynamic) import Data.IORef import qualified Data.Map as Map +import Data.Maybe import Data.Monoid ((<>)) import qualified Data.Set as S import qualified Data.Text as T import Data.Typeable (TypeRep, Typeable) import qualified GhcMod.Monad as GM +import qualified GhcMod.Types as GM import GHC.Generics import GHC (HscEnv) import Haskell.Ide.Engine.Compat +import Haskell.Ide.Engine.Config import Haskell.Ide.Engine.MultiThreadState import Haskell.Ide.Engine.GhcModuleCache +import qualified Language.Haskell.LSP.Core as Core import Language.Haskell.LSP.Types.Capabilities import Language.Haskell.LSP.Types (Command (..), CodeAction (..), @@ -220,12 +230,43 @@ instance ToJSON IdePlugins where -- | IdeM that allows for interaction with the ghc-mod session type IdeGhcM = GM.GhcModT IdeM +-- | Run an IdeGhcM with Cradle found from the current directory +runIdeGhcM :: GM.Options -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a +runIdeGhcM ghcModOptions mlf stateVar f = do + let env = IdeEnv mlf + (eres, _) <- flip runReaderT stateVar $ flip runReaderT env $ GM.runGhcModT ghcModOptions f + case eres of + Left err -> liftIO $ throwIO err + Right res -> return res + -- | A computation that is deferred until the module is cached. -- Note that the module may not typecheck, in which case 'UriCacheFailed' is passed data Defer a = Defer FilePath (UriCacheResult -> a) deriving Functor type IdeDeferM = FreeT Defer IdeM -type IdeM = ReaderT ClientCapabilities (MultiThreadState IdeState) +type IdeM = ReaderT IdeEnv (MultiThreadState IdeState) + +-- | Run an IdeM +runIdeM :: Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeM a -> IO a +runIdeM mlf stateVar f = do + let env = IdeEnv mlf + flip runReaderT stateVar $ flip runReaderT env f + +data IdeEnv = IdeEnv (Maybe (Core.LspFuncs Config)) + +getClientCapabilities :: IdeM ClientCapabilities +getClientCapabilities = do + IdeEnv mlf <- ask + case mlf of + Just lf -> return (Core.clientCapabilities lf) + Nothing -> return def + +getConfig :: IdeM Config +getConfig = do + IdeEnv mlf <- ask + case mlf of + Just lf -> fromMaybe def <$> (liftIO $ Core.config lf) + Nothing -> return def data IdeState = IdeState { moduleCache :: GhcModuleCache @@ -235,6 +276,7 @@ data IdeState = IdeState , extensibleState :: !(Map.Map TypeRep Dynamic) , ghcSession :: Maybe (IORef HscEnv) -- The pid of this instance of hie + -- TODO: Move this to IdeEnv , idePidCache :: Int } diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index d6d3d3228..263735ecd 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -20,11 +20,11 @@ library exposed-modules: Haskell.Ide.Engine.ArtifactMap Haskell.Ide.Engine.Compat + Haskell.Ide.Engine.Config Haskell.Ide.Engine.Context Haskell.Ide.Engine.GhcModuleCache Haskell.Ide.Engine.IdeFunctions Haskell.Ide.Engine.ModuleCache - Haskell.Ide.Engine.Monad Haskell.Ide.Engine.MonadFunctions Haskell.Ide.Engine.MonadTypes Haskell.Ide.Engine.MultiThreadState @@ -36,6 +36,7 @@ library , aeson , constrained-dynamic , containers + , data-default , directory , filepath , fingertree diff --git a/src/Haskell/Ide/Engine/LSP/Reactor.hs b/src/Haskell/Ide/Engine/LSP/Reactor.hs index 169cb7668..b6108b213 100644 --- a/src/Haskell/Ide/Engine/LSP/Reactor.hs +++ b/src/Haskell/Ide/Engine/LSP/Reactor.hs @@ -21,7 +21,7 @@ import qualified Language.Haskell.LSP.Core as Core import qualified Language.Haskell.LSP.Messages as J import qualified Language.Haskell.LSP.Types as J import Haskell.Ide.Engine.Compat -import Haskell.Ide.Engine.LSP.Config +import Haskell.Ide.Engine.Config import Haskell.Ide.Engine.PluginsIdeMonads import qualified Haskell.Ide.Engine.Scheduler as Scheduler import Haskell.Ide.Engine.Types diff --git a/src/Haskell/Ide/Engine/Plugin/HieExtras.hs b/src/Haskell/Ide/Engine/Plugin/HieExtras.hs index c3bc97302..5211aa23c 100644 --- a/src/Haskell/Ide/Engine/Plugin/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Plugin/HieExtras.hs @@ -340,16 +340,15 @@ newtype WithSnippets = WithSnippets Bool getCompletions :: Uri -> PosPrefixInfo -> WithSnippets -> IdeM (IdeResult [J.CompletionItem]) getCompletions uri prefixInfo (WithSnippets withSnippets) = pluginGetFile "getCompletions: " uri $ \file -> do - supportsSnippets <- fromMaybe False <$> asks - (^? J.textDocument - . _Just - . J.completion - . _Just - . J.completionItem - . _Just - . J.snippetSupport - . _Just - ) + let snippetLens = (^? J.textDocument + . _Just + . J.completion + . _Just + . J.completionItem + . _Just + . J.snippetSupport + . _Just) + supportsSnippets <- (fromMaybe False . snippetLens) <$> getClientCapabilities let toggleSnippets x | withSnippets && supportsSnippets = x | otherwise = x { J._insertTextFormat = Just J.PlainText diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index 832457f34..191b35db2 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -20,7 +20,6 @@ module Haskell.Ide.Engine.Scheduler where import Control.Concurrent.Async ( race_ ) -import qualified Control.Concurrent.MVar as MVar import qualified Control.Concurrent.STM as STM import Control.Monad.IO.Class ( liftIO , MonadIO @@ -28,23 +27,21 @@ import Control.Monad.IO.Class ( liftIO import Control.Monad.Reader.Class ( ask , MonadReader ) -import Control.Monad.Reader ( runReaderT ) import Control.Monad.Trans.Class ( lift ) import Control.Monad import qualified Data.Set as Set import qualified Data.Map as Map import qualified Data.Text as T import qualified GhcMod.Types as GM +import qualified Language.Haskell.LSP.Core as Core import qualified Language.Haskell.LSP.Types as J -import qualified Language.Haskell.LSP.Types.Capabilities - as C import Haskell.Ide.Engine.GhcModuleCache import qualified Haskell.Ide.Engine.Compat as Compat +import Haskell.Ide.Engine.Config import qualified Haskell.Ide.Engine.Channel as Channel import Haskell.Ide.Engine.PluginsIdeMonads import Haskell.Ide.Engine.Types -import qualified Haskell.Ide.Engine.Monad as M import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes @@ -139,34 +136,29 @@ runScheduler -- ^ A handler for any errors that the dispatcher may encounter. -> CallbackHandler m -- ^ A handler to run the requests' callback in your monad of choosing. - -> C.ClientCapabilities - -- ^ List of features the IDE client supports or has enabled. + -> Maybe (Core.LspFuncs Config) + -- ^ The LspFuncs provided by haskell-lsp, if using LSP. -> IO () -runScheduler Scheduler {..} errorHandler callbackHandler caps = do +runScheduler Scheduler {..} errorHandler callbackHandler mlf = do let dEnv = DispatcherEnv { cancelReqsTVar = requestsToCancel , wipReqsTVar = requestsInProgress , docVersionTVar = documentVersions } - stateVarVar <- MVar.newEmptyMVar pid <- Compat.getProcessID - let (_, ghcChanOut) = ghcChan (_, ideChanOut) = ideChan - let initialState = - IdeState emptyModuleCache Map.empty plugins Map.empty Nothing pid + let initialState = IdeState emptyModuleCache Map.empty plugins Map.empty Nothing pid - runGhcDisp = M.runIdeGhcM ghcModOptions caps initialState $ do - stateVar <- lift . lift . lift $ ask - liftIO $ MVar.putMVar stateVarVar stateVar - ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut + stateVar <- STM.newTVarIO initialState - runIdeDisp = do - stateVar <- MVar.readMVar stateVarVar - ideDispatcher stateVar caps dEnv errorHandler callbackHandler ideChanOut + let runGhcDisp = runIdeGhcM ghcModOptions mlf stateVar $ + ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut + runIdeDisp = runIdeM mlf stateVar $ + ideDispatcher dEnv errorHandler callbackHandler ideChanOut runGhcDisp `race_` runIdeDisp @@ -258,11 +250,7 @@ data DispatcherEnv = DispatcherEnv -- Meant to be run in a separate thread and be kept alive. ideDispatcher :: forall void m - . STM.TVar IdeState - -- ^ Holds the cached data relative to the current IDE state. - -> C.ClientCapabilities - -- ^ List of features the IDE client supports or has enabled. - -> DispatcherEnv + . DispatcherEnv -- ^ A structure focusing on the mutable variables the dispatcher -- is allowed to modify. -> ErrorHandler @@ -271,10 +259,10 @@ ideDispatcher -- ^ Callback to run for handling the request. -> Channel.OutChan (IdeRequest m) -- ^ Reading end of the channel where the requests are sent to this process. - -> IO void -ideDispatcher stateVar caps env errorHandler callbackHandler pin = + -> IdeM void +ideDispatcher env errorHandler callbackHandler pin = -- TODO: AZ run a single ReaderT, with a composite R. - flip runReaderT stateVar $ flip runReaderT caps $ forever $ do + forever $ do debugm "ideDispatcher: top of loop" (IdeRequest tn lid callback action) <- liftIO $ Channel.readChan pin debugm diff --git a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs index 794d9dbd7..97776d397 100644 --- a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs @@ -21,7 +21,6 @@ import Control.Monad.IO.Class import qualified Data.Aeson as J import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy.Char8 as B -import Data.Default #if __GLASGOW_HASKELL__ < 804 import Data.Monoid #endif @@ -74,7 +73,7 @@ run scheduler = flip E.catches handlers $ do let errorHandler lid _ e = liftIO $ hPutStrLn stderr $ "Got an error for request " ++ show lid ++ ": " ++ T.unpack e callbackHandler callback x = callback x - race3_ (Scheduler.runScheduler scheduler errorHandler callbackHandler def) + race3_ (Scheduler.runScheduler scheduler errorHandler callbackHandler Nothing) (outWriter rout) (reactor rout) diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index d070a4577..fcb6798bc 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -42,6 +42,7 @@ import qualified Data.Text as T import Data.Text.Encoding import qualified GhcModCore as GM import qualified GhcMod.Monad.Types as GM +import Haskell.Ide.Engine.Config import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes @@ -49,7 +50,6 @@ import Haskell.Ide.Engine.PluginUtils import qualified Haskell.Ide.Engine.Scheduler as Scheduler import Haskell.Ide.Engine.Types import Haskell.Ide.Engine.LSP.CodeActions -import Haskell.Ide.Engine.LSP.Config import Haskell.Ide.Engine.LSP.Reactor import qualified Haskell.Ide.Engine.Plugin.HaRe as HaRe import qualified Haskell.Ide.Engine.Plugin.GhcMod as GhcMod @@ -126,8 +126,7 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do let dp lf = do diagIn <- atomically newTChan let react = runReactor lf scheduler diagnosticProviders hps sps - let reactorFunc = react $ reactor rin diagIn - caps = Core.clientCapabilities lf + reactorFunc = react $ reactor rin diagIn let errorHandler :: Scheduler.ErrorHandler errorHandler lid code e = @@ -152,7 +151,7 @@ run scheduler _origDir plugins captureFp = flip E.catches handlers $ do -- haskell lsp sets the current directory to the project root in the InitializeRequest -- We launch the dispatcher after that so that the default cradle is -- recognized properly by ghc-mod - _ <- forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler caps + _ <- forkIO $ Scheduler.runScheduler scheduler errorHandler callbackHandler (Just lf) `race_` reactorFunc `race_` diagnosticsQueue tr return Nothing From e74dcc0b6d2a856e0c7760cc946f33e367ae6cee Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Sun, 4 Nov 2018 23:33:15 +0000 Subject: [PATCH 07/14] Fix tests --- haskell-ide-engine.cabal | 1 + hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs | 2 +- test/functional/FunctionalLiquidSpec.hs | 3 +-- test/unit/JsonSpec.hs | 2 +- test/utils/TestUtils.hs | 7 ++++--- 5 files changed, 8 insertions(+), 7 deletions(-) diff --git a/haskell-ide-engine.cabal b/haskell-ide-engine.cabal index 44abe2b9c..7fc083000 100644 --- a/haskell-ide-engine.cabal +++ b/haskell-ide-engine.cabal @@ -171,6 +171,7 @@ test-suite unit-test , hoogle > 5.0.11 , hspec , quickcheck-instances + , stm , text , unordered-containers diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 5e568ce3a..13ef670c1 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -250,7 +250,7 @@ type IdeM = ReaderT IdeEnv (MultiThreadState IdeState) runIdeM :: Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeM a -> IO a runIdeM mlf stateVar f = do let env = IdeEnv mlf - flip runReaderT stateVar $ flip runReaderT env f + flip runReaderT stateVar $ runReaderT f env data IdeEnv = IdeEnv (Maybe (Core.LspFuncs Config)) diff --git a/test/functional/FunctionalLiquidSpec.hs b/test/functional/FunctionalLiquidSpec.hs index 5bf78009d..7b26de7d6 100644 --- a/test/functional/FunctionalLiquidSpec.hs +++ b/test/functional/FunctionalLiquidSpec.hs @@ -7,10 +7,9 @@ import Control.Monad.IO.Class import Data.Aeson import qualified Data.Text as T import Language.Haskell.LSP.Test hiding (message) --- import Language.Haskell.LSP as LSP import Language.Haskell.LSP.Types as LSP import Language.Haskell.LSP.Types.Lens as LSP hiding (contents, error ) -import Haskell.Ide.Engine.LSP.Config +import Haskell.Ide.Engine.Config import Test.Hspec import TestUtils import Utils diff --git a/test/unit/JsonSpec.hs b/test/unit/JsonSpec.hs index 5b2bc3efc..d4f057abf 100644 --- a/test/unit/JsonSpec.hs +++ b/test/unit/JsonSpec.hs @@ -11,7 +11,7 @@ import Haskell.Ide.Engine.Plugin.ApplyRefact import Haskell.Ide.Engine.Plugin.GhcMod import Haskell.Ide.Engine.Plugin.HaRe import Haskell.Ide.Engine.Plugin.HieExtras -import Haskell.Ide.Engine.LSP.Config +import Haskell.Ide.Engine.Config import Data.Aeson import Test.Hspec diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 3a691d848..654b9be27 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -17,10 +17,10 @@ module TestUtils , hieCommandExamplePlugin ) where +import Control.Concurrent.STM import Control.Exception import Control.Monad import Data.Aeson.Types (typeMismatch) -import Data.Default import Data.Text (pack) import Data.Typeable import Data.Yaml @@ -28,7 +28,6 @@ import qualified Data.Map as Map import qualified GhcMod.Monad as GM import qualified GhcMod.Types as GM import qualified Language.Haskell.LSP.Core as Core -import Haskell.Ide.Engine.Monad import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.PluginDescriptor import System.Directory @@ -79,7 +78,9 @@ dummyVfs :: VirtualFileFunc dummyVfs _ = return Nothing runIGM :: IdePlugins -> IdeGhcM a -> IO a -runIGM testPlugins = runIdeGhcM testOptions def (IdeState emptyModuleCache Map.empty testPlugins Map.empty Nothing 0) +runIGM testPlugins f = do + stateVar <- newTVarIO $ IdeState emptyModuleCache Map.empty testPlugins Map.empty Nothing 0 + runIdeGhcM testOptions Nothing stateVar f withFileLogging :: FilePath -> IO a -> IO a withFileLogging logFile f = do From fc8942038f8d5c122d2ba871db49bfe5fa4b5e5b Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 5 Nov 2018 00:06:34 +0000 Subject: [PATCH 08/14] Add func for VFS in IdeM --- .../Haskell/Ide/Engine/PluginDescriptor.hs | 7 ++--- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 29 +++++++++++++------ src/Haskell/Ide/Engine/LSP/CodeActions.hs | 5 +--- src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs | 8 ++--- src/Haskell/Ide/Engine/Plugin/Base.hs | 8 ++--- src/Haskell/Ide/Engine/Plugin/Brittany.hs | 2 +- src/Haskell/Ide/Engine/Plugin/Build.hs | 16 +++++----- src/Haskell/Ide/Engine/Plugin/Example2.hs | 8 ++--- src/Haskell/Ide/Engine/Plugin/GhcMod.hs | 16 +++++----- src/Haskell/Ide/Engine/Plugin/HaRe.hs | 18 ++++++------ src/Haskell/Ide/Engine/Plugin/HfaAlign.hs | 6 ++-- src/Haskell/Ide/Engine/Plugin/HieExtras.hs | 9 +++--- src/Haskell/Ide/Engine/Plugin/Hoogle.hs | 4 +-- src/Haskell/Ide/Engine/Plugin/HsImport.hs | 4 +-- src/Haskell/Ide/Engine/Plugin/Liquid.hs | 4 +-- src/Haskell/Ide/Engine/Plugin/Package.hs | 11 +++---- src/Haskell/Ide/Engine/Plugin/Pragmas.hs | 4 +-- src/Haskell/Ide/Engine/Transport/JsonStdio.hs | 3 +- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 3 +- test/dispatcher/Main.hs | 2 +- test/unit/ApplyRefactPluginSpec.hs | 8 ++--- test/unit/BrittanySpec.hs | 8 ++--- test/unit/ExtensibleStateSpec.hs | 8 ++--- test/unit/GhcModPluginSpec.hs | 14 ++++----- test/unit/HaRePluginSpec.hs | 18 ++++++------ test/utils/TestUtils.hs | 18 +++++------- 26 files changed, 120 insertions(+), 121 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs index 95a11a9a4..3cd110db6 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs @@ -24,7 +24,6 @@ import qualified Data.ConstrainedDynamic as CD import Data.Typeable import Haskell.Ide.Engine.IdeFunctions import Haskell.Ide.Engine.MonadTypes -import Language.Haskell.LSP.VFS (VirtualFile(..)) -- --------------------------------------------------------------------- @@ -44,9 +43,9 @@ toDynJSON = CD.toDyn -- | Runs a plugin command given a PluginId, CommandName and -- arguments in the form of a JSON object. -runPluginCommand :: PluginId -> CommandName -> (Uri -> IO (Maybe VirtualFile)) -> Value +runPluginCommand :: PluginId -> CommandName -> Value -> IdeGhcM (IdeResult DynamicJSON) -runPluginCommand p com vf arg = do +runPluginCommand p com arg = do (IdePlugins m) <- lift $ lift $ lift getPlugins case Map.lookup p m of Nothing -> return $ @@ -58,5 +57,5 @@ runPluginCommand p com vf arg = do Error err -> return $ IdeResultFail $ IdeError ParameterError ("error while parsing args for " <> com <> " in plugin " <> p <> ": " <> T.pack err) Null Success a -> do - res <- f vf a + res <- f a return $ fmap toDynJSON res diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 13ef670c1..ecf36b66d 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -24,7 +24,6 @@ module Haskell.Ide.Engine.PluginsIdeMonads , CommandFunc(..) , PluginDescriptor(..) , PluginCommand(..) - , VirtualFileFunc , CodeActionProvider , DiagnosticProvider(..) , DiagnosticProviderFunc(..) @@ -43,6 +42,8 @@ module Haskell.Ide.Engine.PluginsIdeMonads , IdeDeferM , getClientCapabilities , getConfig + , getVirtualFile + , getRootPath , iterT , LiftsToGhc(..) -- * IdeResult @@ -123,7 +124,7 @@ import Language.Haskell.LSP.VFS (VirtualFile(..)) type PluginId = T.Text type CommandName = T.Text -newtype CommandFunc a b = CmdSync (VirtualFileFunc -> a -> IdeGhcM (IdeResult b)) +newtype CommandFunc a b = CmdSync (a -> IdeGhcM (IdeResult b)) data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => PluginCommand { commandName :: CommandName @@ -163,12 +164,8 @@ mkLspCmdId plid cn = do -- --------------------------------------------------------------------- -type VirtualFileFunc = Uri -> IO (Maybe VirtualFile) - type CodeActionProvider = PluginId -> VersionedTextDocumentIdentifier - -> VirtualFileFunc - -> Maybe FilePath -- ^ Project root directory -> Range -> CodeActionContext -> IdeM (IdeResult [CodeAction]) @@ -252,8 +249,6 @@ runIdeM mlf stateVar f = do let env = IdeEnv mlf flip runReaderT stateVar $ runReaderT f env -data IdeEnv = IdeEnv (Maybe (Core.LspFuncs Config)) - getClientCapabilities :: IdeM ClientCapabilities getClientCapabilities = do IdeEnv mlf <- ask @@ -265,9 +260,25 @@ getConfig :: IdeM Config getConfig = do IdeEnv mlf <- ask case mlf of - Just lf -> fromMaybe def <$> (liftIO $ Core.config lf) + Just lf -> fromMaybe def <$> liftIO (Core.config lf) Nothing -> return def +getVirtualFile :: Uri -> IdeM (Maybe VirtualFile) +getVirtualFile uri = do + IdeEnv mlf <- ask + case mlf of + Just lf -> liftIO $ Core.getVirtualFileFunc lf uri + Nothing -> return Nothing + +getRootPath :: IdeM (Maybe FilePath) +getRootPath = do + IdeEnv mlf <- ask + case mlf of + Just lf -> return (Core.rootPath lf) + Nothing -> return Nothing + +data IdeEnv = IdeEnv (Maybe (Core.LspFuncs Config)) + data IdeState = IdeState { moduleCache :: GhcModuleCache -- | A queue of requests to be performed once a module is loaded diff --git a/src/Haskell/Ide/Engine/LSP/CodeActions.hs b/src/Haskell/Ide/Engine/LSP/CodeActions.hs index 4b3992a77..54f651f9a 100644 --- a/src/Haskell/Ide/Engine/LSP/CodeActions.hs +++ b/src/Haskell/Ide/Engine/LSP/CodeActions.hs @@ -32,9 +32,6 @@ data FallbackCodeActionParams = handleCodeActionReq :: TrackingNumber -> J.CodeActionRequest -> R () handleCodeActionReq tn req = do - maybeRootDir <- asksLspFuncs Core.rootPath - virtualFileFunc <- asksLspFuncs Core.getVirtualFileFunc - vfsFunc <- asksLspFuncs Core.getVirtualFileFunc docVersion <- fmap _version <$> liftIO (vfsFunc docUri) let docId = J.VersionedTextDocumentIdentifier docUri docVersion @@ -45,7 +42,7 @@ handleCodeActionReq tn req = do return $ IdeResultOk $ mapMaybe getProvider $ toList m providersCb providers = - let reqs = map (\f -> lift (f docId virtualFileFunc maybeRootDir range context)) providers + let reqs = map (\f -> lift (f docId range context)) providers in makeRequests reqs tn (req ^. J.id) (send . concat) makeRequest (IReq tn (req ^. J.id) providersCb getProviders) diff --git a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs b/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs index fd7a11f69..85d4fe922 100644 --- a/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs +++ b/src/Haskell/Ide/Engine/Plugin/ApplyRefact.hs @@ -64,7 +64,7 @@ data OneHint = OneHint } deriving (Eq, Show) applyOneCmd :: CommandFunc ApplyOneParams WorkspaceEdit -applyOneCmd = CmdSync $ \_ (AOP uri pos title) -> do +applyOneCmd = CmdSync $ \(AOP uri pos title) -> do applyOneCmd' uri (OneHint pos title) applyOneCmd' :: Uri -> OneHint -> IdeGhcM (IdeResult WorkspaceEdit) @@ -82,7 +82,7 @@ applyOneCmd' uri oneHint = pluginGetFile "applyOne: " uri $ \fp -> do -- --------------------------------------------------------------------- applyAllCmd :: CommandFunc Uri WorkspaceEdit -applyAllCmd = CmdSync $ \_ uri -> do +applyAllCmd = CmdSync $ \uri -> do applyAllCmd' uri applyAllCmd' :: Uri -> IdeGhcM (IdeResult WorkspaceEdit) @@ -98,7 +98,7 @@ applyAllCmd' uri = pluginGetFile "applyAll: " uri $ \fp -> do -- --------------------------------------------------------------------- lintCmd :: CommandFunc Uri PublishDiagnosticsParams -lintCmd = CmdSync $ \_ uri -> do +lintCmd = CmdSync $ \uri -> do lintCmd' uri -- AZ:TODO: Why is this in IdeGhcM? @@ -278,7 +278,7 @@ showParseError (Hlint.ParseError location message content) = -- --------------------------------------------------------------------- codeActionProvider :: CodeActionProvider -codeActionProvider plId docId _ _ _ context = IdeResultOk <$> hlintActions +codeActionProvider plId docId _ context = IdeResultOk <$> hlintActions where hlintActions :: IdeM [LSP.CodeAction] diff --git a/src/Haskell/Ide/Engine/Plugin/Base.hs b/src/Haskell/Ide/Engine/Plugin/Base.hs index d2c2a85f0..e9498a3ca 100644 --- a/src/Haskell/Ide/Engine/Plugin/Base.hs +++ b/src/Haskell/Ide/Engine/Plugin/Base.hs @@ -50,14 +50,14 @@ baseDescriptor plId = PluginDescriptor -- --------------------------------------------------------------------- versionCmd :: CommandFunc () T.Text -versionCmd = CmdSync $ \_ _ -> return $ IdeResultOk (T.pack version) +versionCmd = CmdSync $ \_ -> return $ IdeResultOk (T.pack version) pluginsCmd :: CommandFunc () IdePlugins -pluginsCmd = CmdSync $ \_ _ -> +pluginsCmd = CmdSync $ \_ -> IdeResultOk <$> getPlugins commandsCmd :: CommandFunc T.Text [CommandName] -commandsCmd = CmdSync $ \_ p -> do +commandsCmd = CmdSync $ \p -> do IdePlugins plugins <- getPlugins case Map.lookup p plugins of Nothing -> return $ IdeResultFail $ IdeError @@ -68,7 +68,7 @@ commandsCmd = CmdSync $ \_ p -> do Just pl -> return $ IdeResultOk $ map commandName $ pluginCommands pl commandDetailCmd :: CommandFunc (T.Text, T.Text) T.Text -commandDetailCmd = CmdSync $ \_ (p,command) -> do +commandDetailCmd = CmdSync $ \(p,command) -> do IdePlugins plugins <- getPlugins case Map.lookup p plugins of Nothing -> return $ IdeResultFail $ IdeError diff --git a/src/Haskell/Ide/Engine/Plugin/Brittany.hs b/src/Haskell/Ide/Engine/Plugin/Brittany.hs index 428cf8089..6a81e0998 100644 --- a/src/Haskell/Ide/Engine/Plugin/Brittany.hs +++ b/src/Haskell/Ide/Engine/Plugin/Brittany.hs @@ -41,7 +41,7 @@ brittanyDescriptor plId = PluginDescriptor where cmd :: CommandFunc FormatParams [J.TextEdit] cmd = - CmdSync $ \_ (FormatParams tabSize uri range) -> brittanyCmd tabSize uri range + CmdSync $ \(FormatParams tabSize uri range) -> brittanyCmd tabSize uri range brittanyCmd :: Int -> Uri -> Maybe Range -> IdeGhcM (IdeResult [J.TextEdit]) brittanyCmd tabSize uri range = diff --git a/src/Haskell/Ide/Engine/Plugin/Build.hs b/src/Haskell/Ide/Engine/Plugin/Build.hs index 0dcc2a71e..2f7697ca1 100644 --- a/src/Haskell/Ide/Engine/Plugin/Build.hs +++ b/src/Haskell/Ide/Engine/Plugin/Build.hs @@ -239,7 +239,7 @@ withCommonArgs req a = do ----------------------------------------------- prepareHelper :: CommandFunc CommonParams () -prepareHelper = CmdSync $ \_ req -> withCommonArgs req $ do +prepareHelper = CmdSync $ \req -> withCommonArgs req $ do ca <- ask liftIO $ case caMode ca of StackMode -> do @@ -255,7 +255,7 @@ prepareHelper' distDir cabalExe dir = ----------------------------------------------- isConfigured :: CommandFunc CommonParams Bool -isConfigured = CmdSync $ \_ req -> withCommonArgs req $ do +isConfigured = CmdSync $ \req -> withCommonArgs req $ do distDir <- asks caDistDir ret <- liftIO $ doesFileExist $ localBuildInfoFile distDir return $ IdeResultOk ret @@ -263,7 +263,7 @@ isConfigured = CmdSync $ \_ req -> withCommonArgs req $ do ----------------------------------------------- configure :: CommandFunc CommonParams () -configure = CmdSync $ \_ req -> withCommonArgs req $ do +configure = CmdSync $ \req -> withCommonArgs req $ do ca <- ask _ <- liftIO $ case caMode ca of StackMode -> configureStack (caStack ca) @@ -291,7 +291,7 @@ instance ToJSON ListFlagsParams where toJSON = J.genericToJSON $ customOptions 2 listFlags :: CommandFunc ListFlagsParams Object -listFlags = CmdSync $ \_ (LF mode) -> do +listFlags = CmdSync $ \(LF mode) -> do cwd <- liftIO $ getCurrentDirectory flags0 <- liftIO $ case mode of "stack" -> listFlagsStack cwd @@ -355,14 +355,14 @@ instance ToJSON BuildParams where toJSON = J.genericToJSON $ customOptions 2 buildDirectory :: CommandFunc BuildParams () -buildDirectory = CmdSync $ \_ (BP m dd c s f mbDir) -> withCommonArgs (CommonParams m dd c s f) $ do +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 + StackMode -> case mbDir of Nothing -> do _ <- readProcess (caStack ca) ["build"] "" @@ -394,7 +394,7 @@ instance ToJSON BuildTargetParams where toJSON = J.genericToJSON $ customOptions 2 buildTarget :: CommandFunc BuildTargetParams () -buildTarget = CmdSync $ \_ (BT m dd c s f component package' compType) -> withCommonArgs (CommonParams m dd c s f) $ do +buildTarget = CmdSync $ \(BT m dd c s f component package' compType) -> withCommonArgs (CommonParams m dd c s f) $ do ca <- ask liftIO $ case caMode ca of CabalMode -> do @@ -424,7 +424,7 @@ data Package = Package { } listTargets :: CommandFunc CommonParams [Value] -listTargets = CmdSync $ \_ req -> withCommonArgs req $ do +listTargets = CmdSync $ \req -> withCommonArgs req $ do ca <- ask targets <- liftIO $ case caMode ca of CabalMode -> (:[]) <$> listCabalTargets (caDistDir ca) "." diff --git a/src/Haskell/Ide/Engine/Plugin/Example2.hs b/src/Haskell/Ide/Engine/Plugin/Example2.hs index df0c8fab2..ad5182752 100644 --- a/src/Haskell/Ide/Engine/Plugin/Example2.hs +++ b/src/Haskell/Ide/Engine/Plugin/Example2.hs @@ -42,10 +42,10 @@ example2Descriptor plId = PluginDescriptor -- --------------------------------------------------------------------- sayHelloCmd :: CommandFunc () T.Text -sayHelloCmd = CmdSync $ \_ _ -> return (IdeResultOk sayHello) +sayHelloCmd = CmdSync $ \_ -> return (IdeResultOk sayHello) sayHelloToCmd :: CommandFunc T.Text T.Text -sayHelloToCmd = CmdSync $ \_ n -> do +sayHelloToCmd = CmdSync $ \n -> do r <- liftIO $ sayHelloTo n return $ IdeResultOk r @@ -81,7 +81,7 @@ data TodoParams = TodoParams deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) todoCmd :: CommandFunc TodoParams J.WorkspaceEdit -todoCmd = CmdSync $ \_ (TodoParams uri r) -> return $ IdeResultOk $ makeTodo uri r +todoCmd = CmdSync $ \(TodoParams uri r) -> return $ IdeResultOk $ makeTodo uri r makeTodo :: J.Uri -> J.Range -> J.WorkspaceEdit makeTodo uri (J.Range (J.Position startLine _) _) = res @@ -99,7 +99,7 @@ makeTodo uri (J.Range (J.Position startLine _) _) = res codeActionProvider :: CodeActionProvider -codeActionProvider plId docId _ _ r _context = do +codeActionProvider plId docId r _context = do cmd <- mkLspCommand plId "todo" title (Just cmdParams) return $ IdeResultOk [codeAction cmd] where diff --git a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs index 8cda4c06d..df1c27606 100644 --- a/src/Haskell/Ide/Engine/Plugin/GhcMod.hs +++ b/src/Haskell/Ide/Engine/Plugin/GhcMod.hs @@ -76,8 +76,7 @@ type Diagnostics = Map.Map Uri (Set.Set Diagnostic) type AdditionalErrs = [T.Text] checkCmd :: CommandFunc Uri (Diagnostics, AdditionalErrs) -checkCmd = CmdSync $ \_ uri -> - setTypecheckedModule uri +checkCmd = CmdSync setTypecheckedModule -- --------------------------------------------------------------------- @@ -219,8 +218,7 @@ setTypecheckedModule uri = -- --------------------------------------------------------------------- lintCmd :: CommandFunc Uri T.Text -lintCmd = CmdSync $ \_ uri -> - lintCmd' uri +lintCmd = CmdSync lintCmd' lintCmd' :: Uri -> IdeGhcM (IdeResult T.Text) lintCmd' uri = @@ -243,7 +241,7 @@ instance ToJSON InfoParams where toJSON = genericToJSON customOptions infoCmd :: CommandFunc InfoParams T.Text -infoCmd = CmdSync $ \_ (IP uri expr) -> +infoCmd = CmdSync $ \(IP uri expr) -> infoCmd' uri expr infoCmd' :: Uri -> T.Text -> IdeGhcM (IdeResult T.Text) @@ -264,7 +262,7 @@ instance ToJSON TypeParams where toJSON = genericToJSON customOptions typeCmd :: CommandFunc TypeParams [(Range,T.Text)] -typeCmd = CmdSync $ \_ (TP _bool uri pos) -> +typeCmd = CmdSync $ \(TP _bool uri pos) -> liftToGhc $ newTypeCmd pos uri newTypeCmd :: Position -> Uri -> IdeM (IdeResult [(Range, T.Text)]) @@ -322,12 +320,12 @@ data TypedHoles = } deriving (Eq, Show) codeActionProvider :: CodeActionProvider -codeActionProvider pid docId vf mfp r ctx = do +codeActionProvider pid docId r ctx = do support <- clientSupportsDocumentChanges - codeActionProvider' support pid docId vf mfp r ctx + codeActionProvider' support pid docId r ctx codeActionProvider' :: Bool -> CodeActionProvider -codeActionProvider' supportsDocChanges _ docId _ _ _ context = +codeActionProvider' supportsDocChanges _ docId _ context = let LSP.List diags = context ^. LSP.diagnostics terms = concatMap getRenamables diags renameActions = map (uncurry mkRenamableAction) terms diff --git a/src/Haskell/Ide/Engine/Plugin/HaRe.hs b/src/Haskell/Ide/Engine/Plugin/HaRe.hs index fe259d01c..4e7ed19e8 100644 --- a/src/Haskell/Ide/Engine/Plugin/HaRe.hs +++ b/src/Haskell/Ide/Engine/Plugin/HaRe.hs @@ -101,7 +101,7 @@ instance ToJSON HareRange where -- --------------------------------------------------------------------- demoteCmd :: CommandFunc Hie.HarePoint WorkspaceEdit -demoteCmd = CmdSync $ \_ (Hie.HP uri pos) -> +demoteCmd = CmdSync $ \(Hie.HP uri pos) -> demoteCmd' uri pos demoteCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) @@ -114,7 +114,7 @@ demoteCmd' uri pos = -- --------------------------------------------------------------------- dupdefCmd :: CommandFunc HarePointWithText WorkspaceEdit -dupdefCmd = CmdSync $ \_ (HPT uri pos name) -> +dupdefCmd = CmdSync $ \(HPT uri pos name) -> dupdefCmd' uri pos name dupdefCmd' :: Uri -> Position -> T.Text -> IdeGhcM (IdeResult WorkspaceEdit) @@ -127,7 +127,7 @@ dupdefCmd' uri pos name = -- --------------------------------------------------------------------- iftocaseCmd :: CommandFunc HareRange WorkspaceEdit -iftocaseCmd = CmdSync $ \_ (HR uri startPos endPos) -> +iftocaseCmd = CmdSync $ \(HR uri startPos endPos) -> iftocaseCmd' uri (Range startPos endPos) iftocaseCmd' :: Uri -> Range -> IdeGhcM (IdeResult WorkspaceEdit) @@ -140,7 +140,7 @@ iftocaseCmd' uri (Range startPos endPos) = -- --------------------------------------------------------------------- liftonelevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit -liftonelevelCmd = CmdSync $ \_ (Hie.HP uri pos) -> +liftonelevelCmd = CmdSync $ \(Hie.HP uri pos) -> liftonelevelCmd' uri pos liftonelevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) @@ -153,7 +153,7 @@ liftonelevelCmd' uri pos = -- --------------------------------------------------------------------- lifttotoplevelCmd :: CommandFunc Hie.HarePoint WorkspaceEdit -lifttotoplevelCmd = CmdSync $ \_ (Hie.HP uri pos) -> +lifttotoplevelCmd = CmdSync $ \(Hie.HP uri pos) -> lifttotoplevelCmd' uri pos lifttotoplevelCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) @@ -166,7 +166,7 @@ lifttotoplevelCmd' uri pos = -- --------------------------------------------------------------------- renameCmd :: CommandFunc HarePointWithText WorkspaceEdit -renameCmd = CmdSync $ \_ (HPT uri pos name) -> +renameCmd = CmdSync $ \(HPT uri pos name) -> renameCmd' uri pos name renameCmd' :: Uri -> Position -> T.Text -> IdeGhcM (IdeResult WorkspaceEdit) @@ -179,7 +179,7 @@ renameCmd' uri pos name = -- --------------------------------------------------------------------- deleteDefCmd :: CommandFunc Hie.HarePoint WorkspaceEdit -deleteDefCmd = CmdSync $ \_ (Hie.HP uri pos) -> +deleteDefCmd = CmdSync $ \(Hie.HP uri pos) -> deleteDefCmd' uri pos deleteDefCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) @@ -192,7 +192,7 @@ deleteDefCmd' uri pos = -- --------------------------------------------------------------------- genApplicativeCommand :: CommandFunc Hie.HarePoint WorkspaceEdit -genApplicativeCommand = CmdSync $ \_ (Hie.HP uri pos) -> +genApplicativeCommand = CmdSync $ \(Hie.HP uri pos) -> genApplicativeCommand' uri pos genApplicativeCommand' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) @@ -282,7 +282,7 @@ hoist f a = -- --------------------------------------------------------------------- codeActionProvider :: CodeActionProvider -codeActionProvider pId docId _ _ (J.Range pos _) _ = +codeActionProvider pId docId (J.Range pos _) _ = pluginGetFile "HaRe codeActionProvider: " (docId ^. J.uri) $ \file -> ifCachedInfo file (IdeResultOk mempty) $ \info -> case getArtifactsAtPos pos (defMap info) of diff --git a/src/Haskell/Ide/Engine/Plugin/HfaAlign.hs b/src/Haskell/Ide/Engine/Plugin/HfaAlign.hs index 563a0599c..405bda720 100644 --- a/src/Haskell/Ide/Engine/Plugin/HfaAlign.hs +++ b/src/Haskell/Ide/Engine/Plugin/HfaAlign.hs @@ -48,8 +48,8 @@ data AlignParams = AlignParams deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) alignCmd :: CommandFunc AlignParams J.WorkspaceEdit -alignCmd = CmdSync $ \vf (AlignParams uri rg) -> do - mtext <- getRangeFromVFS uri vf rg +alignCmd = CmdSync $ \(AlignParams uri rg) -> do + mtext <- liftToGhc $ getRangeFromVFS uri rg case mtext of Nothing -> return $ IdeResultOk $ J.WorkspaceEdit Nothing Nothing Just txt -> do @@ -64,7 +64,7 @@ alignCmd = CmdSync $ \vf (AlignParams uri rg) -> do -- --------------------------------------------------------------------- codeActionProvider :: CodeActionProvider -codeActionProvider plId docId _ _ (Range (Position sl _) (Position el _)) _context = do +codeActionProvider plId docId (Range (Position sl _) (Position el _)) _context = do cmd <- mkLspCommand plId "align" title (Just cmdParams) return $ IdeResultOk [codeAction cmd] where diff --git a/src/Haskell/Ide/Engine/Plugin/HieExtras.hs b/src/Haskell/Ide/Engine/Plugin/HieExtras.hs index 5211aa23c..814646d8f 100644 --- a/src/Haskell/Ide/Engine/Plugin/HieExtras.hs +++ b/src/Haskell/Ide/Engine/Plugin/HieExtras.hs @@ -594,10 +594,9 @@ findDef uri pos = pluginGetFile "findDef: " uri $ \file -> -- --------------------------------------------------------------------- -getRangeFromVFS :: (MonadIO m) - => Uri -> VirtualFileFunc -> Range -> m (Maybe T.Text) -getRangeFromVFS uri vf rg = do - mvf <- liftIO $ vf uri +getRangeFromVFS :: Uri -> Range -> IdeM (Maybe T.Text) +getRangeFromVFS uri rg = do + mvf <- getVirtualFile uri case mvf of Just vfs -> return $ Just $ rangeLinesFromVfs vfs rg Nothing -> return Nothing @@ -638,7 +637,7 @@ runGhcModCommand cmd = -- --------------------------------------------------------------------- splitCaseCmd :: CommandFunc HarePoint WorkspaceEdit -splitCaseCmd = CmdSync $ \_ (HP uri pos) -> splitCaseCmd' uri pos +splitCaseCmd = CmdSync $ \(HP uri pos) -> splitCaseCmd' uri pos splitCaseCmd' :: Uri -> Position -> IdeGhcM (IdeResult WorkspaceEdit) splitCaseCmd' uri newPos = diff --git a/src/Haskell/Ide/Engine/Plugin/Hoogle.hs b/src/Haskell/Ide/Engine/Plugin/Hoogle.hs index b95685df9..23923615e 100644 --- a/src/Haskell/Ide/Engine/Plugin/Hoogle.hs +++ b/src/Haskell/Ide/Engine/Plugin/Hoogle.hs @@ -67,7 +67,7 @@ initializeHoogleDb = do return Nothing infoCmd :: CommandFunc T.Text T.Text -infoCmd = CmdSync $ \_ expr -> do +infoCmd = CmdSync $ \expr -> do res <- liftToGhc $ bimap hoogleErrorToIdeError id <$> infoCmd' expr return $ case res of Left err -> IdeResultFail err @@ -130,7 +130,7 @@ searchTargets f term = do ------------------------------------------------------------------------ lookupCmd :: CommandFunc T.Text [T.Text] -lookupCmd = CmdSync $ \_ term -> do +lookupCmd = CmdSync $ \term -> do res <- liftToGhc $ bimap hoogleErrorToIdeError id <$> lookupCmd' 10 term return $ case res of Left err -> IdeResultFail err diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index 110b0d554..fe24d50d0 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -49,7 +49,7 @@ data ImportParams = ImportParams deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) importCmd :: CommandFunc ImportParams J.WorkspaceEdit -importCmd = CmdSync $ \_ (ImportParams uri modName) -> importModule uri modName +importCmd = CmdSync $ \(ImportParams uri modName) -> importModule uri modName importModule :: Uri -> T.Text -> IdeGhcM (IdeResult J.WorkspaceEdit) importModule uri modName = @@ -91,7 +91,7 @@ importModule uri modName = return (J.TextEdit r ft) codeActionProvider :: CodeActionProvider -codeActionProvider plId docId _ _ _ context = do +codeActionProvider plId docId _ context = do let J.List diags = context ^. J.diagnostics terms = mapMaybe getImportables diags diff --git a/src/Haskell/Ide/Engine/Plugin/Liquid.hs b/src/Haskell/Ide/Engine/Plugin/Liquid.hs index 3664ce9c0..82a5e2f92 100644 --- a/src/Haskell/Ide/Engine/Plugin/Liquid.hs +++ b/src/Haskell/Ide/Engine/Plugin/Liquid.hs @@ -52,10 +52,10 @@ liquidDescriptor plId = PluginDescriptor -- --------------------------------------------------------------------- sayHelloCmd :: CommandFunc () T.Text -sayHelloCmd = CmdSync $ \_ _ -> return (IdeResultOk sayHello) +sayHelloCmd = CmdSync $ \_ -> return (IdeResultOk sayHello) sayHelloToCmd :: CommandFunc T.Text T.Text -sayHelloToCmd = CmdSync $ \_ n -> do +sayHelloToCmd = CmdSync $ \n -> do r <- liftIO $ sayHelloTo n return $ IdeResultOk r diff --git a/src/Haskell/Ide/Engine/Plugin/Package.hs b/src/Haskell/Ide/Engine/Plugin/Package.hs index 72203fdff..2b501f760 100644 --- a/src/Haskell/Ide/Engine/Plugin/Package.hs +++ b/src/Haskell/Ide/Engine/Plugin/Package.hs @@ -72,7 +72,7 @@ data AddParams = AddParams deriving (Eq, Show, Read, Generic, ToJSON, FromJSON) addCmd :: CommandFunc AddParams J.WorkspaceEdit -addCmd = CmdSync $ \_ (AddParams rootDir modulePath pkg) -> do +addCmd = CmdSync $ \(AddParams rootDir modulePath pkg) -> do packageType <- liftIO $ findPackageType rootDir fileMap <- GM.mkRevRedirMapFunc @@ -233,20 +233,21 @@ editCabalPackage file modulePath pkgName fileMap = do newDeps = oldDeps ++ [Dependency (mkPackageName dep) anyVersion] codeActionProvider :: CodeActionProvider -codeActionProvider plId docId _ mRootDir _ context = do +codeActionProvider plId docId _ context = do + mRootDir <- getRootPath let J.List diags = context ^. J.diagnostics pkgs = mapMaybe getAddablePackages diags res <- mapM (bimapM return Hoogle.searchPackages) pkgs - actions <- catMaybes <$> mapM (uncurry mkAddPackageAction) (concatPkgs res) + actions <- catMaybes <$> mapM (uncurry (mkAddPackageAction mRootDir)) (concatPkgs res) return (IdeResultOk actions) where concatPkgs = concatMap (\(d, ts) -> map (d,) ts) - mkAddPackageAction :: J.Diagnostic -> T.Text -> IdeM (Maybe J.CodeAction) - mkAddPackageAction diag pkgName = case (mRootDir, J.uriToFilePath (docId ^. J.uri)) of + mkAddPackageAction :: Maybe FilePath -> J.Diagnostic -> T.Text -> IdeM (Maybe J.CodeAction) + mkAddPackageAction mRootDir diag pkgName = case (mRootDir, J.uriToFilePath (docId ^. J.uri)) of (Just rootDir, Just docFp) -> do let title = "Add " <> pkgName <> " as a dependency" cmdParams = [toJSON (AddParams rootDir docFp pkgName)] diff --git a/src/Haskell/Ide/Engine/Plugin/Pragmas.hs b/src/Haskell/Ide/Engine/Plugin/Pragmas.hs index 0dd5ea4df..f23617759 100644 --- a/src/Haskell/Ide/Engine/Plugin/Pragmas.hs +++ b/src/Haskell/Ide/Engine/Plugin/Pragmas.hs @@ -38,7 +38,7 @@ data AddPragmaParams = AddPragmaParams deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) addPragmaCmd :: CommandFunc AddPragmaParams J.WorkspaceEdit -addPragmaCmd = CmdSync $ \_vf (AddPragmaParams uri pragmaName) -> do +addPragmaCmd = CmdSync $ \(AddPragmaParams uri pragmaName) -> do let pos = (J.Position 0 0) textEdits = J.List @@ -53,7 +53,7 @@ addPragmaCmd = CmdSync $ \_vf (AddPragmaParams uri pragmaName) -> do -- --------------------------------------------------------------------- codeActionProvider :: CodeActionProvider -codeActionProvider plId docId _ _ _ (J.CodeActionContext (J.List diags) _monly) = do +codeActionProvider plId docId _ (J.CodeActionContext (J.List diags) _monly) = do cmds <- mapM mkCommand pragmas return $ IdeResultOk cmds where diff --git a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs index 97776d397..0c4517bad 100644 --- a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs @@ -99,9 +99,8 @@ run scheduler = flip E.catches handlers $ do case mreq of Nothing -> return() Just req -> do - let vfsFunc _ = return Nothing -- TODO: Stub for now, what to do? let preq = GReq 0 (context req) Nothing (Just $ J.IdInt rid) (liftIO . callback) - $ runPluginCommand (plugin req) (command req) vfsFunc (arg req) + $ runPluginCommand (plugin req) (command req) (arg req) rid = reqId req callback = sendResponse rid . dynToJSON Scheduler.sendRequest scheduler Nothing preq diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index fcb6798bc..de94bc1c0 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -588,7 +588,6 @@ reactor inp diagIn = do Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req $ dynToJSON obj execCmd cmdId args = do - vfsFunc <- asksLspFuncs Core.getVirtualFileFunc -- The parameters to the HIE command are always the first element let cmdParams = case args of Just (J.List (x:_)) -> x @@ -623,7 +622,7 @@ reactor inp diagIn = do -- Just an ordinary HIE command Just (plugin, cmd) -> let preq = GReq tn Nothing Nothing (Just $ req ^. J.id) callback - $ runPluginCommand plugin cmd vfsFunc cmdParams + $ runPluginCommand plugin cmd cmdParams in makeRequest preq -- Couldn't parse the command identifier diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index 5c3c0b862..6980afe1f 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -98,7 +98,7 @@ dispatchGhcRequest tn ctx n scheduler lc plugin com arg = do logger x = logToChan lc (ctx, Right x) let req = GReq tn Nothing Nothing (Just (IdInt n)) logger $ - runPluginCommand plugin com dummyVfs (toJSON arg) + runPluginCommand plugin com (toJSON arg) sendRequest scheduler Nothing req diff --git a/test/unit/ApplyRefactPluginSpec.hs b/test/unit/ApplyRefactPluginSpec.hs index c328f0e62..7e6e17a24 100644 --- a/test/unit/ApplyRefactPluginSpec.hs +++ b/test/unit/ApplyRefactPluginSpec.hs @@ -47,7 +47,7 @@ applyRefactSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton applyRefactPath textEdits) Nothing - testCommand testPlugins act "applyrefact" "applyOne" dummyVfs arg res + testCommand testPlugins act "applyrefact" "applyOne" arg res -- --------------------------------- @@ -60,7 +60,7 @@ applyRefactSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton applyRefactPath textEdits) Nothing - testCommand testPlugins act "applyrefact" "applyAll" dummyVfs arg res + testCommand testPlugins act "applyrefact" "applyAll" arg res -- --------------------------------- @@ -85,7 +85,7 @@ applyRefactSpec = do "Redundant bracket\nFound:\n (x + 1)\nWhy not:\n x + 1\n" Nothing ]} - testCommand testPlugins act "applyrefact" "lint" dummyVfs arg res + testCommand testPlugins act "applyrefact" "lint" arg res -- --------------------------------- @@ -105,7 +105,7 @@ applyRefactSpec = do , _source = Just "hlint" , _message = "Parse error: :~:\n import Data.Type.Equality ((:~:) (..), (:~~:) (..))\n \n> data instance Sing (z :: (a :~: b)) where\n SRefl :: Sing Refl\n\n" , _relatedInformation = Nothing }]} - testCommand testPlugins act "applyrefact" "lint" dummyVfs arg res + testCommand testPlugins act "applyrefact" "lint" arg res -- --------------------------------- diff --git a/test/unit/BrittanySpec.hs b/test/unit/BrittanySpec.hs index 6da578ef8..86ead28aa 100644 --- a/test/unit/BrittanySpec.hs +++ b/test/unit/BrittanySpec.hs @@ -39,7 +39,7 @@ brittanySpec = describe "brittany plugin commands" $ do , _newText = "foo :: Int -> String -> IO ()\nfoo x y = do\n print x\n return 42\n" } ] - testCommand testPlugins act "brittany" "format" dummyVfs arg res + testCommand testPlugins act "brittany" "format" arg res it "formats a document with CRLF endings" $ do let @@ -54,7 +54,7 @@ brittanySpec = describe "brittany plugin commands" $ do , _newText = "foo :: Int -> String -> IO ()\nfoo x y = do\n print x\n return 42\n" } ] - testCommand testPlugins act "brittany" "format" dummyVfs arg res + testCommand testPlugins act "brittany" "format" arg res it "formats a range with LF endings" $ do let r = Range (Position 1 0) (Position 2 22) @@ -69,7 +69,7 @@ brittanySpec = describe "brittany plugin commands" $ do , _newText = "foo x y = do\n print x\n return 42\n" } ] - testCommand testPlugins act "brittany" "format" dummyVfs arg res + testCommand testPlugins act "brittany" "format" arg res it "formats a range with CRLF endings" $ do let r = Range (Position 1 0) (Position 2 22) @@ -84,4 +84,4 @@ brittanySpec = describe "brittany plugin commands" $ do , _newText = "foo x y = do\n print x\n return 42\n" } ] - testCommand testPlugins act "brittany" "format" dummyVfs arg res + testCommand testPlugins act "brittany" "format" arg res diff --git a/test/unit/ExtensibleStateSpec.hs b/test/unit/ExtensibleStateSpec.hs index b47bf1fd8..33958dff2 100644 --- a/test/unit/ExtensibleStateSpec.hs +++ b/test/unit/ExtensibleStateSpec.hs @@ -22,8 +22,8 @@ extensibleStateSpec = describe "stores and retrieves in the state" $ it "stores the first one" $ do r <- runIGM testPlugins $ do - r1 <- makeRequest "test" "cmd1" dummyVfs () - r2 <- makeRequest "test" "cmd2" dummyVfs () + r1 <- makeRequest "test" "cmd1" () + r2 <- 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) @@ -51,12 +51,12 @@ testDescriptor plId = PluginDescriptor -- --------------------------------------------------------------------- cmd1 :: CommandFunc () T.Text -cmd1 = CmdSync $ \_ _ -> do +cmd1 = CmdSync $ \_ -> do put (MS1 "foo") return (IdeResultOk (T.pack "result:put foo")) cmd2 :: CommandFunc () T.Text -cmd2 = CmdSync $ \_ _ -> do +cmd2 = CmdSync $ \_ -> do (MS1 v) <- get return (IdeResultOk (T.pack $ "result:got:" ++ show v)) diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 2bc15d38d..1825304c9 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -54,7 +54,7 @@ ghcmodSpec = "Variable not in scope: x" Nothing - testCommand testPlugins act "ghcmod" "check" dummyVfs arg res + testCommand testPlugins act "ghcmod" "check" arg res -- --------------------------------- @@ -68,7 +68,7 @@ ghcmodSpec = #else res = IdeResultOk (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" dummyVfs arg res + testCommand testPlugins act "ghcmod" "lint" arg res -- --------------------------------- @@ -79,7 +79,7 @@ ghcmodSpec = arg = IP uri "main" res = IdeResultOk "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" dummyVfs arg res + testCommand testPlugins act "ghcmod" "info" arg res -- --------------------------------- @@ -95,7 +95,7 @@ ghcmodSpec = ,(Range (toPos (5,9)) (toPos (5,14)), "Int") ,(Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] - testCommand testPlugins act "ghcmod" "type" dummyVfs arg res + testCommand testPlugins act "ghcmod" "type" arg res it "runs the type command with an absolute path from another folder, correct params" $ do fp <- makeAbsolute "./test/testdata/HaReRename.hs" @@ -114,7 +114,7 @@ ghcmodSpec = ,(Range (toPos (5,9)) (toPos (5,14)), "Int") ,(Range (toPos (5,1)) (toPos (5,14)), "Int -> Int") ] - testCommand testPlugins act "ghcmod" "type"dummyVfs arg res + testCommand testPlugins act "ghcmod" "type" arg res -- --------------------------------- @@ -130,7 +130,7 @@ ghcmodSpec = $ List [TextEdit (Range (Position 4 0) (Position 4 10)) "foo Nothing = ()\nfoo (Just x) = ()"]) Nothing - testCommand testPlugins act "ghcmod" "casesplit" dummyVfs arg res + testCommand testPlugins act "ghcmod" "casesplit" arg res it "runs the casesplit command with an absolute path from another folder, correct params" $ do fp <- makeAbsolute "./test/testdata/GhcModCaseSplit.hs" @@ -149,4 +149,4 @@ ghcmodSpec = $ List [TextEdit (Range (Position 4 0) (Position 4 10)) "foo Nothing = ()\nfoo (Just x) = ()"]) Nothing - testCommand testPlugins act "ghcmod" "casesplit" dummyVfs arg res + testCommand testPlugins act "ghcmod" "casesplit" arg res diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index 8b6322f73..12fd3a636 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -64,7 +64,7 @@ hareSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "hare" "rename" dummyVfs arg res + testCommand testPlugins act "hare" "rename" arg res -- --------------------------------- @@ -75,7 +75,7 @@ hareSpec = do res = IdeResultFail IdeError { ideCode = PluginError , ideMessage = "rename: \"Invalid cursor position!\"", ideInfo = Null} - testCommand testPlugins act "hare" "rename" dummyVfs arg res + testCommand testPlugins act "hare" "rename" arg res -- --------------------------------- @@ -87,7 +87,7 @@ hareSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "hare" "demote" dummyVfs arg res + testCommand testPlugins act "hare" "demote" arg res -- --------------------------------- @@ -99,7 +99,7 @@ hareSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "hare" "dupdef" dummyVfs arg res + testCommand testPlugins act "hare" "dupdef" arg res -- --------------------------------- @@ -114,7 +114,7 @@ hareSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "hare" "iftocase" dummyVfs arg res + testCommand testPlugins act "hare" "iftocase" arg res -- --------------------------------- @@ -128,7 +128,7 @@ hareSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "hare" "liftonelevel" dummyVfs arg res + testCommand testPlugins act "hare" "liftonelevel" arg res -- --------------------------------- @@ -144,7 +144,7 @@ hareSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "hare" "lifttotoplevel" dummyVfs arg res + testCommand testPlugins act "hare" "lifttotoplevel" arg res -- --------------------------------- @@ -156,7 +156,7 @@ hareSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "hare" "deletedef" dummyVfs arg res + testCommand testPlugins act "hare" "deletedef" arg res -- --------------------------------- @@ -169,7 +169,7 @@ hareSpec = do res = IdeResultOk $ WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - testCommand testPlugins act "hare" "genapplicative" dummyVfs arg res + testCommand testPlugins act "hare" "genapplicative" arg res -- --------------------------------- diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 654b9be27..4254fdb46 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -8,7 +8,6 @@ module TestUtils , testCommand , runSingleReq , makeRequest - , dummyVfs , runIGM , ghc84 , logFilePath @@ -58,24 +57,21 @@ cdAndDo path fn = do testCommand :: (ToJSON a, Typeable b, ToJSON b, Show b, Eq b) - => IdePlugins -> IdeGhcM (IdeResult b) -> PluginId -> CommandName -> VirtualFileFunc -> a -> IdeResult b -> IO () -testCommand testPlugins act plugin cmd vf arg res = do + => IdePlugins -> IdeGhcM (IdeResult b) -> PluginId -> CommandName -> a -> IdeResult b -> IO () +testCommand testPlugins act plugin cmd arg res = do (newApiRes, oldApiRes) <- runIGM testPlugins $ do new <- act - old <- makeRequest plugin cmd vf arg + old <- makeRequest plugin cmd arg return (new, old) newApiRes `shouldBe` res fmap fromDynJSON oldApiRes `shouldBe` fmap Just res runSingleReq :: ToJSON a - => IdePlugins -> PluginId -> CommandName -> VirtualFileFunc -> a -> IO (IdeResult DynamicJSON) -runSingleReq testPlugins plugin com vf arg = runIGM testPlugins (makeRequest plugin com vf arg) + => IdePlugins -> PluginId -> CommandName -> a -> IO (IdeResult DynamicJSON) +runSingleReq testPlugins plugin com arg = runIGM testPlugins (makeRequest plugin com arg) -makeRequest :: ToJSON a => PluginId -> CommandName -> VirtualFileFunc -> a -> IdeGhcM (IdeResult DynamicJSON) -makeRequest plugin com vf arg = runPluginCommand plugin com vf (toJSON arg) - -dummyVfs :: VirtualFileFunc -dummyVfs _ = return Nothing +makeRequest :: ToJSON a => PluginId -> CommandName -> a -> IdeGhcM (IdeResult DynamicJSON) +makeRequest plugin com arg = runPluginCommand plugin com (toJSON arg) runIGM :: IdePlugins -> IdeGhcM a -> IO a runIGM testPlugins f = do From 82d20f0b98b7bb49e600c17509cad5e300a88eac Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 5 Nov 2018 00:47:09 +0000 Subject: [PATCH 09/14] Add config for formatting on import --- hie-plugin-api/Haskell/Ide/Engine/Config.hs | 14 +++++++++----- src/Haskell/Ide/Engine/Plugin/HsImport.hs | 19 ++++++++++++++----- 2 files changed, 23 insertions(+), 10 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Config.hs b/hie-plugin-api/Haskell/Ide/Engine/Config.hs index e5e82a4f5..49aa90c93 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Config.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Config.hs @@ -25,14 +25,16 @@ data Config = , maxNumberOfProblems :: Int , liquidOn :: Bool , completionSnippetsOn :: Bool + , formatOnImportOn :: Bool } deriving (Show,Eq) instance Default Config where def = Config - { hlintOn = True - , maxNumberOfProblems = 100 - , liquidOn = False - , completionSnippetsOn = True + { hlintOn = True + , maxNumberOfProblems = 100 + , liquidOn = False + , completionSnippetsOn = True + , formatOnImportOn = True } -- TODO: Add API for plugins to expose their own LSP config options @@ -44,6 +46,7 @@ instance FromJSON Config where <*> o .:? "maxNumberOfProblems" .!= maxNumberOfProblems def <*> o .:? "liquidOn" .!= liquidOn def <*> o .:? "completionSnippetsOn" .!= completionSnippetsOn def + <*> o .:? "formatOnImportOn" .!= formatOnImportOn def -- 2017-10-09 23:22:00.710515298 [ThreadId 11] - ---> {"jsonrpc":"2.0","method":"workspace/didChangeConfiguration","params":{"settings":{"languageServerHaskell":{"maxNumberOfProblems":100,"hlintOn":true}}}} -- 2017-10-09 23:22:00.710667381 [ThreadId 15] - reactor:got didChangeConfiguration notification: @@ -55,12 +58,13 @@ instance FromJSON Config where -- ,("maxNumberOfProblems",Number 100.0)]))])}} instance ToJSON Config where - toJSON (Config h m l c) = object [ "languageServerHaskell" .= r ] + toJSON (Config h m l c f) = object [ "languageServerHaskell" .= r ] where r = object [ "hlintOn" .= h , "maxNumberOfProblems" .= m , "liquidOn" .= l , "completionSnippetsOn" .= c + , "completionSnippetsOn" .= f ] -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index fe24d50d0..c6f47199c 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -19,6 +19,7 @@ import qualified Data.Text.IO as T import qualified GHC.Generics as Generics import qualified GhcMod.Utils as GM import HsImport +import Haskell.Ide.Engine.Config import Haskell.Ide.Engine.MonadTypes import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J @@ -54,6 +55,9 @@ 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 + + shouldFormat <- formatOnImportOn <$> liftToGhc getConfig + fileMap <- GM.mkRevRedirMapFunc GM.withMappedFile origInput $ \input -> do @@ -78,12 +82,17 @@ importModule uri modName = confFile <- liftIO $ Brittany.getConfFile origInput -- Format the import with Brittany - newChanges <- forM mChanges $ mapM $ mapM (formatTextEdit confFile) - newDocChanges <- forM mDocChanges $ mapM $ \(J.TextDocumentEdit vDocId tes) -> do - ftes <- forM tes (formatTextEdit confFile) - return (J.TextDocumentEdit vDocId ftes) - return $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges) + if shouldFormat + then do + newChanges <- forM mChanges $ mapM $ mapM (formatTextEdit confFile) + newDocChanges <- forM mDocChanges $ mapM $ \(J.TextDocumentEdit vDocId tes) -> do + ftes <- forM tes (formatTextEdit confFile) + return (J.TextDocumentEdit vDocId ftes) + + return $ IdeResultOk (J.WorkspaceEdit newChanges newDocChanges) + else + return $ IdeResultOk (J.WorkspaceEdit mChanges mDocChanges) where formatTextEdit confFile (J.TextEdit r t) = do -- TODO: This tab size of 2 spaces should probably be taken from a config From 29d369f1cc85b97647bc9f89316a6e86e57c181e Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 5 Nov 2018 00:51:27 +0000 Subject: [PATCH 10/14] Update test description --- test/functional/FunctionalCodeActionsSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/functional/FunctionalCodeActionsSpec.hs b/test/functional/FunctionalCodeActionsSpec.hs index 98547fda9..7eff9ade9 100644 --- a/test/functional/FunctionalCodeActionsSpec.hs +++ b/test/functional/FunctionalCodeActionsSpec.hs @@ -122,7 +122,7 @@ spec = describe "code actions" $ do contents <- getDocumentEdit doc liftIO $ contents `shouldBe` "import Control.Monad\nmain :: IO ()\nmain = when True $ putStrLn \"hello\"" - it "formats with brittany if needed" $ runSession hieCommand fullCaps "test/testdata" $ do + it "formats with brittany" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "CodeActionImportBrittany.hs" "haskell" _ <- waitForDiagnosticsSource "ghcmod" From 8c204cf1325ab1d256819b8c4a9b7b2fde734aeb Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 5 Nov 2018 11:43:40 +0000 Subject: [PATCH 11/14] Fix config and add test --- hie-plugin-api/Haskell/Ide/Engine/Config.hs | 2 +- src/Haskell/Ide/Engine/Plugin/HsImport.hs | 5 ++--- test/functional/FunctionalCodeActionsSpec.hs | 19 ++++++++++++++++++- test/functional/FunctionalLiquidSpec.hs | 9 ++------- test/unit/JsonSpec.hs | 2 +- 5 files changed, 24 insertions(+), 13 deletions(-) diff --git a/hie-plugin-api/Haskell/Ide/Engine/Config.hs b/hie-plugin-api/Haskell/Ide/Engine/Config.hs index 49aa90c93..7a4f01076 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Config.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Config.hs @@ -64,7 +64,7 @@ instance ToJSON Config where , "maxNumberOfProblems" .= m , "liquidOn" .= l , "completionSnippetsOn" .= c - , "completionSnippetsOn" .= f + , "formatOnImportOn" .= f ] -- --------------------------------------------------------------------- diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index c6f47199c..98d0dd2cb 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -80,11 +80,10 @@ importModule uri modName = liftIO $ removeFile output J.WorkspaceEdit mChanges mDocChanges <- liftToGhc $ makeDiffResult input newText fileMap - confFile <- liftIO $ Brittany.getConfFile origInput - -- Format the import with Brittany - if shouldFormat then do + -- Format the import with Brittany + confFile <- liftIO $ Brittany.getConfFile origInput newChanges <- forM mChanges $ mapM $ mapM (formatTextEdit confFile) newDocChanges <- forM mDocChanges $ mapM $ \(J.TextDocumentEdit vDocId tes) -> do ftes <- forM tes (formatTextEdit confFile) diff --git a/test/functional/FunctionalCodeActionsSpec.hs b/test/functional/FunctionalCodeActionsSpec.hs index 7eff9ade9..6555ef164 100644 --- a/test/functional/FunctionalCodeActionsSpec.hs +++ b/test/functional/FunctionalCodeActionsSpec.hs @@ -12,6 +12,7 @@ import qualified Data.HashMap.Strict as HM import Data.Maybe import Data.Monoid ((<>)) import qualified Data.Text as T +import Haskell.Ide.Engine.Config import Language.Haskell.LSP.Test as Test import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types.Lens as L @@ -96,7 +97,7 @@ spec = describe "code actions" $ do _:x:_ <- T.lines <$> documentContents doc liftIO $ x `shouldBe` "foo = putStrLn \"world\"" - describe "import suggetsions" $ do + describe "import suggestions" $ do it "works with 3.8 code action kinds" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "CodeActionImport.hs" "haskell" @@ -135,6 +136,22 @@ spec = describe "code actions" $ do let l1:l2:_ = T.lines contents l1 `shouldBe` "import qualified Data.Maybe" l2 `shouldBe` "import Control.Monad" + it "respects format config" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "CodeActionImportBrittany.hs" "haskell" + _ <- waitForDiagnosticsSource "ghcmod" + + let config = def { formatOnImportOn = False } + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) + + actionsOrCommands <- getAllCodeActions doc + let action:_ = map fromAction actionsOrCommands + executeCodeAction action + + contents <- getDocumentEdit doc + liftIO $ do + let l1:l2:_ = T.lines contents + l1 `shouldBe` "import qualified Data.Maybe" + l2 `shouldBe` "import Control.Monad" describe "add package suggestions" $ do it "adds to .cabal files" $ runSession hieCommand fullCaps "test/testdata/addPackageTest/cabal" $ do diff --git a/test/functional/FunctionalLiquidSpec.hs b/test/functional/FunctionalLiquidSpec.hs index 7b26de7d6..6598072b5 100644 --- a/test/functional/FunctionalLiquidSpec.hs +++ b/test/functional/FunctionalLiquidSpec.hs @@ -5,6 +5,7 @@ module FunctionalLiquidSpec where import Control.Lens hiding (List) import Control.Monad.IO.Class import Data.Aeson +import Data.Default import qualified Data.Text as T import Language.Haskell.LSP.Test hiding (message) import Language.Haskell.LSP.Types as LSP @@ -80,13 +81,7 @@ spec = describe "liquid haskell diagnostics" $ do reduceDiag ^. source `shouldBe` Just "hlint" -- Enable liquid haskell plugin - let config = - Config - { hlintOn = False - , maxNumberOfProblems = 50 - , liquidOn = True - , completionSnippetsOn = True - } + let config = def { liquidOn = True } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) -- docItem <- getDocItem file languageId diff --git a/test/unit/JsonSpec.hs b/test/unit/JsonSpec.hs index d4f057abf..d2d4d5062 100644 --- a/test/unit/JsonSpec.hs +++ b/test/unit/JsonSpec.hs @@ -102,4 +102,4 @@ instance Arbitrary Position where return $ Position l c instance Arbitrary Config where - arbitrary = Config <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = Config <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary From b5c11fd9d2ddd365f240dfb90f5709fcd184f191 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 5 Nov 2018 23:25:29 +0000 Subject: [PATCH 12/14] Re-disable hlint in liquid tests --- test/functional/FunctionalLiquidSpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/functional/FunctionalLiquidSpec.hs b/test/functional/FunctionalLiquidSpec.hs index 6598072b5..03a546fd0 100644 --- a/test/functional/FunctionalLiquidSpec.hs +++ b/test/functional/FunctionalLiquidSpec.hs @@ -80,8 +80,8 @@ spec = describe "liquid haskell diagnostics" $ do reduceDiag ^. code `shouldBe` Just "Use negate" reduceDiag ^. source `shouldBe` Just "hlint" - -- Enable liquid haskell plugin - let config = def { liquidOn = True } + -- Enable liquid haskell plugin and disable hlint + let config = def { liquidOn = True, hlintOn = False } sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (toJSON config)) -- docItem <- getDocItem file languageId From 00827595b8f0a6c4bbc41eabe3a792d4b6ad825e Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Tue, 6 Nov 2018 16:43:01 +0000 Subject: [PATCH 13/14] Move plugins and pidCache into IdeEnv --- .../Haskell/Ide/Engine/IdeFunctions.hs | 13 --- .../Haskell/Ide/Engine/PluginDescriptor.hs | 4 +- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 108 +++++++++++------- hie-plugin-api/hie-plugin-api.cabal | 1 - src/Haskell/Ide/Engine/LSP/CodeActions.hs | 1 - src/Haskell/Ide/Engine/Plugin/Base.hs | 1 - src/Haskell/Ide/Engine/Plugin/HsImport.hs | 2 +- src/Haskell/Ide/Engine/Scheduler.hs | 10 +- test/utils/TestUtils.hs | 4 +- 9 files changed, 71 insertions(+), 73 deletions(-) delete mode 100644 hie-plugin-api/Haskell/Ide/Engine/IdeFunctions.hs 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/PluginDescriptor.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs index 3cd110db6..97b36eab6 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,7 +21,6 @@ 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 -- --------------------------------------------------------------------- @@ -46,7 +44,7 @@ toDynJSON = CD.toDyn runPluginCommand :: PluginId -> CommandName -> Value -> IdeGhcM (IdeResult DynamicJSON) runPluginCommand p com arg = do - (IdePlugins m) <- lift $ lift $ lift getPlugins + IdePlugins m <- getPlugins case Map.lookup p m of Nothing -> return $ IdeResultFail $ IdeError UnknownPlugin ("Plugin " <> p <> " doesn't exist") Null diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index ecf36b66d..8ae8930e3 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -40,10 +40,7 @@ module Haskell.Ide.Engine.PluginsIdeMonads , IdeM , runIdeM , IdeDeferM - , getClientCapabilities - , getConfig - , getVirtualFile - , getRootPath + , MonadIde(..) , iterT , LiftsToGhc(..) -- * IdeResult @@ -138,7 +135,7 @@ class Monad m => HasPidCache m where getPidCache :: m Int instance HasPidCache IdeM where - getPidCache = idePidCache <$> readMTS + getPidCache = asks ideEnvPidCache instance HasPidCache IO where getPidCache = getProcessID @@ -228,9 +225,9 @@ instance ToJSON IdePlugins where type IdeGhcM = GM.GhcModT IdeM -- | Run an IdeGhcM with Cradle found from the current directory -runIdeGhcM :: GM.Options -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a -runIdeGhcM ghcModOptions mlf stateVar f = do - let env = IdeEnv mlf +runIdeGhcM :: GM.Options -> IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeGhcM a -> IO a +runIdeGhcM ghcModOptions plugins mlf stateVar f = do + env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins (eres, _) <- flip runReaderT stateVar $ flip runReaderT env $ GM.runGhcModT ghcModOptions f case eres of Left err -> liftIO $ throwIO err @@ -244,51 +241,74 @@ type IdeDeferM = FreeT Defer IdeM type IdeM = ReaderT IdeEnv (MultiThreadState IdeState) -- | Run an IdeM -runIdeM :: Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeM a -> IO a -runIdeM mlf stateVar f = do - let env = IdeEnv mlf +runIdeM :: IdePlugins -> Maybe (Core.LspFuncs Config) -> TVar IdeState -> IdeM a -> IO a +runIdeM plugins mlf stateVar f = do + env <- IdeEnv <$> pure mlf <*> getProcessID <*> pure plugins + -- TODO: AZ run a single ReaderT, with a composite R. flip runReaderT stateVar $ runReaderT f env -getClientCapabilities :: IdeM ClientCapabilities -getClientCapabilities = do - IdeEnv mlf <- ask - case mlf of - Just lf -> return (Core.clientCapabilities lf) - Nothing -> return def - -getConfig :: IdeM Config -getConfig = do - IdeEnv mlf <- ask - case mlf of - Just lf -> fromMaybe def <$> liftIO (Core.config lf) - Nothing -> return def - -getVirtualFile :: Uri -> IdeM (Maybe VirtualFile) -getVirtualFile uri = do - IdeEnv mlf <- ask - case mlf of - Just lf -> liftIO $ Core.getVirtualFileFunc lf uri - Nothing -> return Nothing - -getRootPath :: IdeM (Maybe FilePath) -getRootPath = do - IdeEnv mlf <- ask - case mlf of - Just lf -> return (Core.rootPath lf) - Nothing -> return Nothing - -data IdeEnv = IdeEnv (Maybe (Core.LspFuncs Config)) +data IdeEnv = IdeEnv + { ideEnvLspFuncs :: Maybe (Core.LspFuncs Config) + -- | The pid of this instance of hie + , ideEnvPidCache :: Int + , idePlugins :: IdePlugins + } +-- | The class of monads that support common IDE functions, namely IdeM/IdeGhcM/IdeDeferM +class Monad m => MonadIde m where + getRootPath :: m (Maybe FilePath) + getVirtualFile :: Uri -> m (Maybe VirtualFile) + getConfig :: m Config + getClientCapabilities :: m ClientCapabilities + getPlugins :: m IdePlugins + +instance MonadIde IdeM where + getRootPath = do + mlf <- asks ideEnvLspFuncs + case mlf of + Just lf -> return (Core.rootPath lf) + Nothing -> return Nothing + + getVirtualFile uri = do + mlf <- asks ideEnvLspFuncs + case mlf of + Just lf -> liftIO $ Core.getVirtualFileFunc lf uri + Nothing -> return Nothing + + getConfig = do + mlf <- asks ideEnvLspFuncs + case mlf of + Just lf -> fromMaybe def <$> liftIO (Core.config lf) + Nothing -> return def + + getClientCapabilities = do + mlf <- asks ideEnvLspFuncs + case mlf of + Just lf -> return (Core.clientCapabilities lf) + Nothing -> return def + + getPlugins = asks idePlugins + +instance MonadIde IdeGhcM where + getRootPath = lift $ lift getRootPath + getVirtualFile = lift . lift . getVirtualFile + getConfig = lift $ lift getConfig + getClientCapabilities = lift $ lift getClientCapabilities + getPlugins = lift $ lift getPlugins + +instance MonadIde IdeDeferM where + getRootPath = lift getRootPath + getVirtualFile = lift . getVirtualFile + getConfig = lift getConfig + getClientCapabilities = lift getClientCapabilities + getPlugins = lift getPlugins + data IdeState = IdeState { moduleCache :: GhcModuleCache -- | A queue of requests to be performed once a module is loaded , requestQueue :: Map.Map FilePath [UriCacheResult -> IdeM ()] - , idePlugins :: IdePlugins , extensibleState :: !(Map.Map TypeRep Dynamic) , ghcSession :: Maybe (IORef HscEnv) - -- The pid of this instance of hie - -- TODO: Move this to IdeEnv - , idePidCache :: Int } instance MonadMTState IdeState IdeGhcM where diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index 263735ecd..b6e2c704f 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -23,7 +23,6 @@ library Haskell.Ide.Engine.Config Haskell.Ide.Engine.Context Haskell.Ide.Engine.GhcModuleCache - Haskell.Ide.Engine.IdeFunctions Haskell.Ide.Engine.ModuleCache Haskell.Ide.Engine.MonadFunctions Haskell.Ide.Engine.MonadTypes diff --git a/src/Haskell/Ide/Engine/LSP/CodeActions.hs b/src/Haskell/Ide/Engine/LSP/CodeActions.hs index 54f651f9a..cf4e6c2b4 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.Lens 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 = diff --git a/src/Haskell/Ide/Engine/Plugin/Base.hs b/src/Haskell/Ide/Engine/Plugin/Base.hs index e9498a3ca..806258c99 100644 --- a/src/Haskell/Ide/Engine/Plugin/Base.hs +++ b/src/Haskell/Ide/Engine/Plugin/Base.hs @@ -18,7 +18,6 @@ import qualified Data.Text as T import Development.GitRev (gitCommitCount) import Distribution.System (buildArch) import Distribution.Text (display) -import Haskell.Ide.Engine.IdeFunctions import Haskell.Ide.Engine.MonadTypes import Options.Applicative.Simple (simpleVersion) import qualified Paths_haskell_ide_engine as Meta diff --git a/src/Haskell/Ide/Engine/Plugin/HsImport.hs b/src/Haskell/Ide/Engine/Plugin/HsImport.hs index 98d0dd2cb..505b197ce 100644 --- a/src/Haskell/Ide/Engine/Plugin/HsImport.hs +++ b/src/Haskell/Ide/Engine/Plugin/HsImport.hs @@ -56,7 +56,7 @@ importModule :: Uri -> T.Text -> IdeGhcM (IdeResult J.WorkspaceEdit) importModule uri modName = pluginGetFile "hsimport cmd: " uri $ \origInput -> do - shouldFormat <- formatOnImportOn <$> liftToGhc getConfig + shouldFormat <- formatOnImportOn <$> getConfig fileMap <- GM.mkRevRedirMapFunc GM.withMappedFile origInput $ \input -> do diff --git a/src/Haskell/Ide/Engine/Scheduler.hs b/src/Haskell/Ide/Engine/Scheduler.hs index 191b35db2..b30b9dad4 100644 --- a/src/Haskell/Ide/Engine/Scheduler.hs +++ b/src/Haskell/Ide/Engine/Scheduler.hs @@ -37,7 +37,6 @@ import qualified Language.Haskell.LSP.Core as Core import qualified Language.Haskell.LSP.Types as J import Haskell.Ide.Engine.GhcModuleCache -import qualified Haskell.Ide.Engine.Compat as Compat import Haskell.Ide.Engine.Config import qualified Haskell.Ide.Engine.Channel as Channel import Haskell.Ide.Engine.PluginsIdeMonads @@ -146,18 +145,16 @@ runScheduler Scheduler {..} errorHandler callbackHandler mlf = do , docVersionTVar = documentVersions } - pid <- Compat.getProcessID - let (_, ghcChanOut) = ghcChan (_, ideChanOut) = ideChan - let initialState = IdeState emptyModuleCache Map.empty plugins Map.empty Nothing pid + let initialState = IdeState emptyModuleCache Map.empty Map.empty Nothing stateVar <- STM.newTVarIO initialState - let runGhcDisp = runIdeGhcM ghcModOptions mlf stateVar $ + let runGhcDisp = runIdeGhcM ghcModOptions plugins mlf stateVar $ ghcDispatcher dEnv errorHandler callbackHandler ghcChanOut - runIdeDisp = runIdeM mlf stateVar $ + runIdeDisp = runIdeM plugins mlf stateVar $ ideDispatcher dEnv errorHandler callbackHandler ideChanOut @@ -261,7 +258,6 @@ ideDispatcher -- ^ Reading end of the channel where the requests are sent to this process. -> IdeM void ideDispatcher env errorHandler callbackHandler pin = - -- TODO: AZ run a single ReaderT, with a composite R. forever $ do debugm "ideDispatcher: top of loop" (IdeRequest tn lid callback action) <- liftIO $ Channel.readChan pin diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 4254fdb46..45ab8f207 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -75,8 +75,8 @@ makeRequest plugin com arg = runPluginCommand plugin com (toJSON arg) runIGM :: IdePlugins -> IdeGhcM a -> IO a runIGM testPlugins f = do - stateVar <- newTVarIO $ IdeState emptyModuleCache Map.empty testPlugins Map.empty Nothing 0 - runIdeGhcM testOptions Nothing stateVar f + stateVar <- newTVarIO $ IdeState emptyModuleCache Map.empty Map.empty Nothing + runIdeGhcM testOptions testPlugins Nothing stateVar f withFileLogging :: FilePath -> IO a -> IO a withFileLogging logFile f = do From f4bdcdaeabf06d7d746d17810f734ce763a30140 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Wed, 7 Nov 2018 15:33:30 +0000 Subject: [PATCH 14/14] Merge PluginDescriptor into PluginsIdeMonads Move getDiagnosticProvidersConfig there too --- app/MainHie.hs | 1 - hie-plugin-api/Haskell/Ide/Engine/Config.hs | 10 -- .../Haskell/Ide/Engine/PluginDescriptor.hs | 59 ------- .../Haskell/Ide/Engine/PluginsIdeMonads.hs | 161 ++++++++++++------ hie-plugin-api/hie-plugin-api.cabal | 1 - src/Haskell/Ide/Engine/Transport/JsonStdio.hs | 2 +- src/Haskell/Ide/Engine/Transport/LspStdio.hs | 1 - test/dispatcher/Main.hs | 1 - test/plugin-dispatcher/Main.hs | 1 - test/unit/ApplyRefactPluginSpec.hs | 1 - test/unit/BrittanySpec.hs | 1 - test/unit/ExtensibleStateSpec.hs | 1 - test/unit/GhcModPluginSpec.hs | 1 - test/unit/HaRePluginSpec.hs | 1 - test/unit/HooglePluginSpec.hs | 1 - test/utils/TestUtils.hs | 1 - 16 files changed, 111 insertions(+), 133 deletions(-) delete mode 100644 hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs diff --git a/app/MainHie.hs b/app/MainHie.hs index bfd133c1a..c5b530920 100644 --- a/app/MainHie.hs +++ b/app/MainHie.hs @@ -9,7 +9,6 @@ import qualified GhcMod.Types as GM import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.Options -import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.Scheduler import Haskell.Ide.Engine.Transport.LspStdio import Haskell.Ide.Engine.Transport.JsonStdio diff --git a/hie-plugin-api/Haskell/Ide/Engine/Config.hs b/hie-plugin-api/Haskell/Ide/Engine/Config.hs index 7a4f01076..481d2b656 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/Config.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/Config.hs @@ -3,7 +3,6 @@ module Haskell.Ide.Engine.Config where import Data.Aeson import Data.Default -import qualified Data.Map as Map import qualified Data.Text as T import Language.Haskell.LSP.Types @@ -66,12 +65,3 @@ instance ToJSON Config where , "completionSnippetsOn" .= c , "formatOnImportOn" .= f ] - --- --------------------------------------------------------------------- - --- | For the diagnostic providers in the config, return a map of --- current enabled state, indexed by the plugin id. -getDiagnosticProvidersConfig :: Config -> Map.Map T.Text Bool -getDiagnosticProvidersConfig c = Map.fromList [("applyrefact",hlintOn c) - ,("liquid", liquidOn c) - ] diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs deleted file mode 100644 index 97b36eab6..000000000 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} --- | A data structure to define a plugin. --- Allows description of a plugin and the commands it provides - -module Haskell.Ide.Engine.PluginDescriptor - ( runPluginCommand - , pluginDescToIdePlugins - , DynamicJSON - , dynToJSON - , fromDynJSON - , toDynJSON - ) where - -import Data.Aeson -import Data.List -import qualified Data.Map as Map -#if __GLASGOW_HASKELL__ < 804 -import Data.Monoid -#endif -import qualified Data.Text as T -import qualified Data.ConstrainedDynamic as CD -import Data.Typeable -import Haskell.Ide.Engine.MonadTypes - --- --------------------------------------------------------------------- - -pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins -pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins - -type DynamicJSON = CD.ConstrainedDynamic ToJSON - -dynToJSON :: DynamicJSON -> Value -dynToJSON x = CD.applyClassFn x toJSON - -fromDynJSON :: (Typeable a, ToJSON a) => DynamicJSON -> Maybe a -fromDynJSON = CD.fromDynamic - -toDynJSON :: (Typeable a, ToJSON a) => a -> DynamicJSON -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 p com arg = do - IdePlugins m <- getPlugins - case Map.lookup p m of - Nothing -> return $ - IdeResultFail $ IdeError UnknownPlugin ("Plugin " <> p <> " doesn't exist") Null - Just (PluginDescriptor { pluginCommands = 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 diff --git a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs index 8ae8930e3..406dbf6c7 100644 --- a/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs +++ b/hie-plugin-api/Haskell/Ide/Engine/PluginsIdeMonads.hs @@ -14,16 +14,23 @@ -- | IdeGhcM and associated types module Haskell.Ide.Engine.PluginsIdeMonads ( - -- * Plugins - PluginId - , CommandName - , HasPidCache(..) + -- * LSP Commands + HasPidCache(..) , mkLspCommand , allLspCmdIds , mkLspCmdId - , CommandFunc(..) + -- * Plugins + , PluginId + , CommandName , PluginDescriptor(..) + , pluginDescToIdePlugins , PluginCommand(..) + , CommandFunc(..) + , runPluginCommand + , DynamicJSON + , dynToJSON + , fromDynJSON + , toDynJSON , CodeActionProvider , DiagnosticProvider(..) , DiagnosticProviderFunc(..) @@ -33,7 +40,8 @@ module Haskell.Ide.Engine.PluginsIdeMonads , HoverProvider , SymbolProvider , IdePlugins(..) - -- * The IDE monad + , getDiagnosticProvidersConfig + -- * IDE monads , IdeState(..) , IdeGhcM , runIdeGhcM @@ -63,7 +71,8 @@ module Haskell.Ide.Engine.PluginsIdeMonads , DiagnosticSeverity(..) , PublishDiagnosticsParams(..) , List(..) - ) where + ) +where import Control.Concurrent.STM import Control.Exception @@ -72,63 +81,57 @@ import Control.Monad.Reader import Control.Monad.Trans.Free import Data.Aeson +import qualified Data.ConstrainedDynamic as CD import Data.Default -import Data.Dynamic (Dynamic) +import qualified Data.List as List +import Data.Dynamic ( Dynamic ) import Data.IORef -import qualified Data.Map as Map +import qualified Data.Map as Map import Data.Maybe -import Data.Monoid ((<>)) -import qualified Data.Set as S -import qualified Data.Text as T -import Data.Typeable (TypeRep, Typeable) - -import qualified GhcMod.Monad as GM +import Data.Monoid ( (<>) ) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Typeable ( TypeRep + , Typeable + ) + +import qualified GhcMod.Monad as GM import qualified GhcMod.Types as GM import GHC.Generics -import GHC (HscEnv) +import GHC ( HscEnv ) import Haskell.Ide.Engine.Compat import Haskell.Ide.Engine.Config import Haskell.Ide.Engine.MultiThreadState import Haskell.Ide.Engine.GhcModuleCache -import qualified Language.Haskell.LSP.Core as Core +import qualified Language.Haskell.LSP.Core as Core import Language.Haskell.LSP.Types.Capabilities -import Language.Haskell.LSP.Types (Command (..), - CodeAction (..), - CodeActionContext (..), - Diagnostic (..), - DiagnosticSeverity (..), - DocumentSymbol (..), - List (..), - Hover (..), - Location (..), - Position (..), - PublishDiagnosticsParams (..), - Range (..), - TextDocumentIdentifier (..), - TextDocumentPositionParams (..), - Uri (..), - VersionedTextDocumentIdentifier(..), - WorkspaceEdit (..), - filePathToUri, - uriToFilePath) - -import Language.Haskell.LSP.VFS (VirtualFile(..)) +import Language.Haskell.LSP.Types ( Command(..) + , CodeAction(..) + , CodeActionContext(..) + , Diagnostic(..) + , DiagnosticSeverity(..) + , DocumentSymbol(..) + , List(..) + , Hover(..) + , Location(..) + , Position(..) + , PublishDiagnosticsParams(..) + , Range(..) + , TextDocumentIdentifier(..) + , TextDocumentPositionParams(..) + , Uri(..) + , VersionedTextDocumentIdentifier(..) + , WorkspaceEdit(..) + , filePathToUri + , uriToFilePath + ) + +import Language.Haskell.LSP.VFS ( VirtualFile(..) ) -- --------------------------------------------------------------------- - -type PluginId = T.Text -type CommandName = T.Text - -newtype CommandFunc a b = CmdSync (a -> IdeGhcM (IdeResult b)) - -data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => - PluginCommand { commandName :: CommandName - , commandDesc :: T.Text - , commandFunc :: CommandFunc a b - } - +-- LSP Commands -- --------------------------------------------------------------------- class Monad m => HasPidCache m where @@ -160,6 +163,8 @@ mkLspCmdId plid cn = do return $ pid <> ":" <> plid <> ":" <> cn -- --------------------------------------------------------------------- +-- Plugins +-- --------------------------------------------------------------------- type CodeActionProvider = PluginId -> VersionedTextDocumentIdentifier @@ -209,6 +214,50 @@ data PluginDescriptor = instance Show PluginCommand where show (PluginCommand name _ _) = "PluginCommand { name = " ++ T.unpack name ++ " }" +type PluginId = T.Text +type CommandName = T.Text + +newtype CommandFunc a b = CmdSync (a -> IdeGhcM (IdeResult b)) + +data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => + PluginCommand { commandName :: CommandName + , commandDesc :: T.Text + , commandFunc :: CommandFunc a b + } + +pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins +pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins + +type DynamicJSON = CD.ConstrainedDynamic ToJSON + +dynToJSON :: DynamicJSON -> Value +dynToJSON x = CD.applyClassFn x toJSON + +fromDynJSON :: (Typeable a, ToJSON a) => DynamicJSON -> Maybe a +fromDynJSON = CD.fromDynamic + +toDynJSON :: (Typeable a, ToJSON a) => a -> DynamicJSON +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 p com arg = do + IdePlugins m <- getPlugins + case Map.lookup p m of + Nothing -> return $ + IdeResultFail $ IdeError UnknownPlugin ("Plugin " <> p <> " doesn't exist") Null + Just (PluginDescriptor { pluginCommands = xs }) -> case List.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 + -- | a Description of the available commands stored in IdeGhcM newtype IdePlugins = IdePlugins { ipMap :: Map.Map PluginId PluginDescriptor @@ -219,6 +268,15 @@ newtype IdePlugins = IdePlugins instance ToJSON IdePlugins where toJSON (IdePlugins m) = toJSON $ fmap (\x -> (commandName x, commandDesc x)) <$> fmap pluginCommands m +-- | For the diagnostic providers in the config, return a map of +-- current enabled state, indexed by the plugin id. +getDiagnosticProvidersConfig :: Config -> Map.Map PluginId Bool +getDiagnosticProvidersConfig c = Map.fromList [("applyrefact",hlintOn c) + ,("liquid", liquidOn c) + ] + +-- --------------------------------------------------------------------- +-- Monads -- --------------------------------------------------------------------- -- | IdeM that allows for interaction with the ghc-mod session @@ -353,7 +411,8 @@ instance HasGhcModuleCache IdeM where liftIO $ atomically $ modifyTVar' tvar (\st -> st { moduleCache = mc }) -- --------------------------------------------------------------------- - +-- Results +-- --------------------------------------------------------------------- -- | The result of a plugin action, containing the result and an error if -- it failed. IdeGhcM usually skips IdeResponse and jumps straight to this. diff --git a/hie-plugin-api/hie-plugin-api.cabal b/hie-plugin-api/hie-plugin-api.cabal index b6e2c704f..b80f6c9ab 100644 --- a/hie-plugin-api/hie-plugin-api.cabal +++ b/hie-plugin-api/hie-plugin-api.cabal @@ -27,7 +27,6 @@ library Haskell.Ide.Engine.MonadFunctions Haskell.Ide.Engine.MonadTypes Haskell.Ide.Engine.MultiThreadState - Haskell.Ide.Engine.PluginDescriptor Haskell.Ide.Engine.PluginsIdeMonads Haskell.Ide.Engine.PluginUtils build-depends: base >= 4.9 && < 5 diff --git a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs index 0c4517bad..c91dc6699 100644 --- a/src/Haskell/Ide/Engine/Transport/JsonStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/JsonStdio.hs @@ -26,8 +26,8 @@ import Data.Monoid #endif import qualified Data.Text as T import GHC.Generics +import Haskell.Ide.Engine.PluginsIdeMonads import qualified Haskell.Ide.Engine.Scheduler as Scheduler -import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.Types import qualified Language.Haskell.LSP.Types as J import System.Exit diff --git a/src/Haskell/Ide/Engine/Transport/LspStdio.hs b/src/Haskell/Ide/Engine/Transport/LspStdio.hs index de94bc1c0..6b5a1e32b 100644 --- a/src/Haskell/Ide/Engine/Transport/LspStdio.hs +++ b/src/Haskell/Ide/Engine/Transport/LspStdio.hs @@ -43,7 +43,6 @@ import Data.Text.Encoding import qualified GhcModCore as GM import qualified GhcMod.Monad.Types as GM import Haskell.Ide.Engine.Config -import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.MonadFunctions import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.PluginUtils diff --git a/test/dispatcher/Main.hs b/test/dispatcher/Main.hs index 6980afe1f..f52827a0b 100644 --- a/test/dispatcher/Main.hs +++ b/test/dispatcher/Main.hs @@ -14,7 +14,6 @@ import Data.Default import GHC ( TypecheckedModule ) import GHC.Generics import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.PluginUtils import Haskell.Ide.Engine.Scheduler import Haskell.Ide.Engine.Types diff --git a/test/plugin-dispatcher/Main.hs b/test/plugin-dispatcher/Main.hs index e226f24e1..81beb3a6c 100644 --- a/test/plugin-dispatcher/Main.hs +++ b/test/plugin-dispatcher/Main.hs @@ -8,7 +8,6 @@ import Control.Monad.STM import qualified Data.Text as T import Data.Default import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.Scheduler import Haskell.Ide.Engine.Types import Language.Haskell.LSP.Types diff --git a/test/unit/ApplyRefactPluginSpec.hs b/test/unit/ApplyRefactPluginSpec.hs index 7e6e17a24..b21e13d0c 100644 --- a/test/unit/ApplyRefactPluginSpec.hs +++ b/test/unit/ApplyRefactPluginSpec.hs @@ -5,7 +5,6 @@ module ApplyRefactPluginSpec where import qualified Data.HashMap.Strict as H import Haskell.Ide.Engine.Plugin.ApplyRefact import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.PluginUtils import Language.Haskell.LSP.Types import System.Directory diff --git a/test/unit/BrittanySpec.hs b/test/unit/BrittanySpec.hs index 86ead28aa..93f6f710f 100644 --- a/test/unit/BrittanySpec.hs +++ b/test/unit/BrittanySpec.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DuplicateRecordFields #-} module BrittanySpec where -import Haskell.Ide.Engine.PluginDescriptor import Language.Haskell.LSP.Types import System.Directory import Haskell.Ide.Engine.Plugin.Brittany diff --git a/test/unit/ExtensibleStateSpec.hs b/test/unit/ExtensibleStateSpec.hs index 33958dff2..a3a9480f0 100644 --- a/test/unit/ExtensibleStateSpec.hs +++ b/test/unit/ExtensibleStateSpec.hs @@ -5,7 +5,6 @@ import qualified Data.Text as T import Data.Typeable import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.MonadFunctions -import Haskell.Ide.Engine.PluginDescriptor import TestUtils import Test.Hspec diff --git a/test/unit/GhcModPluginSpec.hs b/test/unit/GhcModPluginSpec.hs index 1825304c9..d05e2bd0d 100644 --- a/test/unit/GhcModPluginSpec.hs +++ b/test/unit/GhcModPluginSpec.hs @@ -13,7 +13,6 @@ import qualified Data.Text as T import Haskell.Ide.Engine.MonadTypes import Haskell.Ide.Engine.Plugin.GhcMod import Haskell.Ide.Engine.Plugin.HieExtras -import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.PluginUtils import Language.Haskell.LSP.Types (TextEdit (..)) import System.Directory diff --git a/test/unit/HaRePluginSpec.hs b/test/unit/HaRePluginSpec.hs index 12fd3a636..57588d32f 100644 --- a/test/unit/HaRePluginSpec.hs +++ b/test/unit/HaRePluginSpec.hs @@ -11,7 +11,6 @@ import Data.Aeson import qualified Data.Map as M import qualified Data.HashMap.Strict as H 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 diff --git a/test/unit/HooglePluginSpec.hs b/test/unit/HooglePluginSpec.hs index 7aabb5e24..18fcc89fb 100644 --- a/test/unit/HooglePluginSpec.hs +++ b/test/unit/HooglePluginSpec.hs @@ -5,7 +5,6 @@ module HooglePluginSpec where import Control.Monad import Data.Maybe import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.PluginDescriptor import Haskell.Ide.Engine.Plugin.Hoogle import Hoogle import System.Directory diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 45ab8f207..c5c6d8d31 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -28,7 +28,6 @@ import qualified GhcMod.Monad as GM import qualified GhcMod.Types as GM import qualified Language.Haskell.LSP.Core as Core import Haskell.Ide.Engine.MonadTypes -import Haskell.Ide.Engine.PluginDescriptor import System.Directory import System.FilePath import qualified System.Log.Logger as L