From 3088e6da0a68ec4fa898bf9af92bacf0b99fe829 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 17 Feb 2020 23:28:22 +0000 Subject: [PATCH 01/25] Starting to sketch out IDE-level plugin modularity Address #25 Currently WIP --- exe/Main.hs | 4 +- haskell-language-server.cabal | 9 +- src/Ide/Plugin.hs | 34 ++++++ src/Ide/Plugin/Example2.hs | 193 ++++++++++++++++++++++++++++++++++ src/Ide/Plugin/Floskell.hs | 1 + src/Ide/Plugin/Formatter.hs | 24 +---- src/Ide/Plugin/Ormolu.hs | 19 ++-- src/Ide/Types.hs | 126 ++++++++++++++++++++++ test/functional/PluginSpec.hs | 55 ++++++++++ 9 files changed, 429 insertions(+), 36 deletions(-) create mode 100644 src/Ide/Plugin.hs create mode 100644 src/Ide/Plugin/Example2.hs create mode 100644 src/Ide/Types.hs create mode 100644 test/functional/PluginSpec.hs diff --git a/exe/Main.hs b/exe/Main.hs index ffc323e113..43ddfcdb17 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -54,6 +54,7 @@ import System.Time.Extra import Development.IDE.Plugin.CodeAction as CodeAction import Development.IDE.Plugin.Completions as Completions import Ide.Plugin.Example as Example +import Ide.Plugin.Example2 as Example2 import Ide.Plugin.Floskell as Floskell import Ide.Plugin.Ormolu as Ormolu @@ -69,7 +70,8 @@ idePlugins includeExample CodeAction.plugin <> formatterPlugins [("ormolu", Ormolu.provider) ,("floskell", Floskell.provider)] <> - if includeExample then Example.plugin else mempty + if includeExample then Example.plugin <> Example2.plugin + else mempty -- --------------------------------------------------------------------- diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index d3847c81af..af2bc4bd45 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -28,11 +28,14 @@ source-repository head library exposed-modules: Ide.Cradle + Ide.Plugin Ide.Plugin.Config Ide.Plugin.Example + Ide.Plugin.Example2 Ide.Plugin.Ormolu Ide.Plugin.Floskell Ide.Plugin.Formatter + Ide.Types Ide.Version other-modules: Paths_haskell_language_server @@ -176,10 +179,13 @@ test-suite func-test base >=4.7 && <5 , aeson , data-default + , haskell-lsp-types , hls-test-utils + , hspec + , lens , lsp-test >= 0.10.0.0 , text - , hspec + , unordered-containers other-modules: -- CompletionSpec -- , CommandSpec @@ -195,6 +201,7 @@ test-suite func-test -- , HieBiosSpec -- , HighlightSpec -- , HoverSpec + , PluginSpec -- , ProgressSpec -- , ReferencesSpec -- , RenameSpec diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs new file mode 100644 index 0000000000..b7ac9df363 --- /dev/null +++ b/src/Ide/Plugin.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ide.Plugin + ( + asGhcIdePlugin + ) where + +import Data.Aeson hiding (defaultOptions) +import qualified Data.Map as Map +import qualified Data.Set as S +import Data.String +import qualified Data.Text as T +import Data.Typeable +import Development.IDE.Core.Rules +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() +import Development.IDE.Plugin +import Ide.Plugin.Config +import Ide.Types + +-- --------------------------------------------------------------------- + +-- | Map a set of plugins to the underlying ghcide engine. Main point is +-- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message +-- category ('Notifaction', 'Request' etc). +asGhcIdePlugin :: IdePlugins -> Plugin Config +asGhcIdePlugin _ = Plugin mempty mempty + +-- First strp will be to bring the machinery from Ide.Plugin.Formatter over. + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs new file mode 100644 index 0000000000..c65ce6ee12 --- /dev/null +++ b/src/Ide/Plugin/Example2.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.Example2 + ( + plugin + ) where + +import Control.DeepSeq ( NFData ) +import Control.Monad.Trans.Maybe +import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) +import Data.Binary +import Data.Functor +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import qualified Data.HashSet as HashSet +import qualified Data.Text as T +import Data.Typeable +import Development.IDE.Core.OfInterest +import Development.IDE.Core.Rules +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.LSP.Server +import Development.IDE.Plugin +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Development.IDE.Types.Logger +import Development.Shake hiding ( Diagnostic ) +import GHC.Generics +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +plugin :: Plugin c +plugin = Plugin exampleRules handlersExample2 + <> codeActionPlugin codeAction + <> Plugin mempty handlersCodeLens + +hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) +hover = request "Hover" blah (Right Nothing) foundHover + +blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) +blah _ (Position line col) + = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover"]) + +handlersExample2 :: PartialHandlers c +handlersExample2 = PartialHandlers $ \WithMessage{..} x -> + return x{LSP.hoverHandler = withResponse RspHover $ const hover} + + +-- --------------------------------------------------------------------- + +data Example2 = Example2 + deriving (Eq, Show, Typeable, Generic) +instance Hashable Example2 +instance NFData Example2 +instance Binary Example2 + +type instance RuleResult Example2 = () + +exampleRules :: Rules () +exampleRules = do + define $ \Example2 file -> do + _pm <- getParsedModule file + let diag = mkDiag file "example2" DsError (Range (Position 0 0) (Position 1 0)) "example2 diagnostic, hello world" + return ([diag], Just ()) + + action $ do + files <- getFilesOfInterest + void $ uses Example2 $ HashSet.toList files + +mkDiag :: NormalizedFilePath + -> DiagnosticSource + -> DiagnosticSeverity + -> Range + -> T.Text + -> FileDiagnostic +mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) + Diagnostic + { _range = loc + , _severity = Just sev + , _source = Just diagSource + , _message = msg + , _code = Nothing + , _relatedInformation = Nothing + } + +-- --------------------------------------------------------------------- + +-- | Generate code actions. +codeAction + :: LSP.LspFuncs c + -> IdeState + -> TextDocumentIdentifier + -> Range + -> CodeActionContext + -> IO (Either ResponseError [CAResult]) +codeAction _lsp _state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do + let + title = "Add TODO2 Item" + tedit = [TextEdit (Range (Position 0 0) (Position 0 0)) + "-- TODO2 added by Example2 Plugin directly\n"] + edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + pure $ Right + [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] + +-- --------------------------------------------------------------------- + +-- | Generate code lenses. +handlersCodeLens :: PartialHandlers c +handlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{ + LSP.codeLensHandler = withResponse RspCodeLens codeLens, + LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand + } + +codeLens + :: LSP.LspFuncs c + -> IdeState + -> CodeLensParams + -> IO (Either ResponseError (List CodeLens)) +codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + case uriToFilePath' uri of + Just (toNormalizedFilePath -> filePath) -> do + _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath + _diag <- getDiagnostics ideState + _hDiag <- getHiddenDiagnostics ideState + let + title = "Add TODO2 Item via Code Lens" + tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) + "-- TODO2 added by Example2 Plugin via code lens action\n"] + edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + range = (Range (Position 3 0) (Position 4 0)) + pure $ Right $ List + -- [ CodeLens range (Just (Command title "codelens.do" (Just $ List [toJSON edit]))) Nothing + [ CodeLens range (Just (Command title "codelens.todo" (Just $ List [toJSON edit]))) Nothing + ] + Nothing -> pure $ Right $ List [] + +-- | Execute the "codelens.todo2" command. +executeAddSignatureCommand + :: LSP.LspFuncs c + -> IdeState + -> ExecuteCommandParams + -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) +executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..} + | _command == "codelens.todo2" + , Just (List [edit]) <- _arguments + , Success wedit <- fromJSON edit + = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) + | otherwise + = return (Null, Nothing) + +-- --------------------------------------------------------------------- + +foundHover :: (Maybe Range, [T.Text]) -> Either ResponseError (Maybe Hover) +foundHover (mbRange, contents) = + Right $ Just $ Hover (HoverContents $ MarkupContent MkMarkdown + $ T.intercalate sectionSeparator contents) mbRange + + +-- | Respond to and log a hover or go-to-definition request +request + :: T.Text + -> (NormalizedFilePath -> Position -> Action (Maybe a)) + -> Either ResponseError b + -> (a -> Either ResponseError b) + -> IdeState + -> TextDocumentPositionParams + -> IO (Either ResponseError b) +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos _) = do + mbResult <- case uriToFilePath' uri of + Just path -> logAndRunRequest label getResults ide pos path + Nothing -> pure Nothing + pure $ maybe notFound found mbResult + +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b +logAndRunRequest label getResults ide pos path = do + let filePath = toNormalizedFilePath path + logInfo (ideLogger ide) $ + label <> " request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack path + runAction ide $ getResults filePath pos diff --git a/src/Ide/Plugin/Floskell.hs b/src/Ide/Plugin/Floskell.hs index e0e535b74d..5531888619 100644 --- a/src/Ide/Plugin/Floskell.hs +++ b/src/Ide/Plugin/Floskell.hs @@ -18,6 +18,7 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Floskell import Ide.Plugin.Formatter +import Ide.Types import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() diff --git a/src/Ide/Plugin/Formatter.hs b/src/Ide/Plugin/Formatter.hs index 127a654f54..7512d998c2 100644 --- a/src/Ide/Plugin/Formatter.hs +++ b/src/Ide/Plugin/Formatter.hs @@ -8,8 +8,6 @@ module Ide.Plugin.Formatter ( formatterPlugins - , FormattingType(..) - , FormattingProvider , responseError , extractRange , fullRange @@ -25,6 +23,7 @@ import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.Shake hiding ( Diagnostic ) +import Ide.Types import Ide.Plugin.Config import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages @@ -89,27 +88,6 @@ doFormatting lf providers ideState ft uri params = do -- --------------------------------------------------------------------- --- | Format the given Text as a whole or only a @Range@ of it. --- Range must be relative to the text to format. --- To format the whole document, read the Text from the file and use 'FormatText' --- as the FormattingType. -data FormattingType = FormatText - | FormatRange Range - - --- | To format a whole document, the 'FormatText' @FormattingType@ can be used. --- It is required to pass in the whole Document Text for that to happen, an empty text --- and file uri, does not suffice. -type FormattingProvider m - = IdeState - -> FormattingType -- ^ How much to format - -> T.Text -- ^ Text to format - -> NormalizedFilePath -- ^ location of the file being formatted - -> FormattingOptions -- ^ Options for the formatter - -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting - --- --------------------------------------------------------------------- - noneProvider :: FormattingProvider IO noneProvider _ _ _ _ _ = return $ Right (List []) diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index a27f5086bf..7343ac1edd 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -11,26 +11,23 @@ module Ide.Plugin.Ormolu ) where -#if __GLASGOW_HASKELL__ >= 806 import Control.Exception -import Data.Char -import qualified Data.Text as T -import GHC -import Ormolu -import qualified DynFlags as D -import qualified EnumSet as S -import qualified HIE.Bios as BIOS -#endif - import Control.Monad +import Data.Char import Data.List import Data.Maybe +import qualified Data.Text as T import Development.IDE.Core.Rules --- import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location +import qualified DynFlags as D +import qualified EnumSet as S +import GHC +import Ide.Types +import qualified HIE.Bios as BIOS import Ide.Plugin.Formatter import Language.Haskell.LSP.Types +import Ormolu import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs new file mode 100644 index 0000000000..f7fc2e3a6d --- /dev/null +++ b/src/Ide/Types.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Ide.Types + ( + IdePlugins(..) + , PluginDescriptor(..) + , PluginCommand(..) + , DiagnosticProvider(..) + , DiagnosticProviderFunc(..) + , FormattingType(..) + , FormattingProvider + ) where + +import Data.Aeson hiding (defaultOptions) +import qualified Data.Map as Map +import qualified Data.Set as S +import Data.String +import qualified Data.Text as T +import Data.Typeable +import Development.IDE.Core.Rules +import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Location +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() +-- import Development.IDE.Plugin +-- import Ide.Plugin.Config + +-- --------------------------------------------------------------------- + +newtype IdePlugins = IdePlugins + { ipMap :: Map.Map PluginId PluginDescriptor + } + +-- --------------------------------------------------------------------- + +data PluginDescriptor = + PluginDescriptor { pluginId :: PluginId + , pluginCommands :: [PluginCommand] + , pluginCodeActionProvider :: Maybe CodeActionProvider + , pluginDiagnosticProvider :: Maybe DiagnosticProvider + , pluginHoverProvider :: Maybe HoverProvider + , pluginSymbolProvider :: Maybe SymbolProvider + , pluginFormattingProvider :: Maybe (FormattingProvider IO) + } + +instance Show PluginCommand where + show (PluginCommand i _ _) = "PluginCommand { name = " ++ show i ++ " }" + +newtype CommandId = CommandId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString CommandId where + fromString = CommandId . T.pack + +data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => + PluginCommand { commandId :: CommandId + , commandDesc :: T.Text + , commandFunc :: a -> IO (Either ResponseError b) + } + +-- --------------------------------------------------------------------- + +type CodeActionProvider = PluginId + -> VersionedTextDocumentIdentifier + -> Range + -> CodeActionContext + -> IO (Either ResponseError [CodeAction]) + +type DiagnosticProviderFuncSync + = DiagnosticTrigger -> Uri + -> IO (Either ResponseError (Map.Map Uri (S.Set Diagnostic))) + +type DiagnosticProviderFuncAsync + = DiagnosticTrigger -> Uri + -> (Map.Map Uri (S.Set Diagnostic) -> IO ()) + -> IO (Either ResponseError ()) + +data DiagnosticProviderFunc + = DiagnosticProviderSync DiagnosticProviderFuncSync + | DiagnosticProviderAsync DiagnosticProviderFuncAsync + + +data DiagnosticProvider = DiagnosticProvider + { dpTrigger :: S.Set DiagnosticTrigger -- AZ:should this be a NonEmptyList? + , dpFunc :: DiagnosticProviderFunc + } + +data DiagnosticTrigger = DiagnosticOnOpen + | DiagnosticOnChange + | DiagnosticOnSave + deriving (Show,Ord,Eq) + +type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) + +type SymbolProvider = Uri -> IO (Either ResponseError [DocumentSymbol]) + +-- --------------------------------------------------------------------- + +newtype PluginId = PluginId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString PluginId where + fromString = PluginId . T.pack + +-- --------------------------------------------------------------------- + + +-- | Format the given Text as a whole or only a @Range@ of it. +-- Range must be relative to the text to format. +-- To format the whole document, read the Text from the file and use 'FormatText' +-- as the FormattingType. +data FormattingType = FormatText + | FormatRange Range + + +-- | To format a whole document, the 'FormatText' @FormattingType@ can be used. +-- It is required to pass in the whole Document Text for that to happen, an empty text +-- and file uri, does not suffice. +type FormattingProvider m + = IdeState + -> FormattingType -- ^ How much to format + -> T.Text -- ^ Text to format + -> NormalizedFilePath -- ^ location of the file being formatted + -> FormattingOptions -- ^ Options for the formatter + -> m (Either ResponseError (List TextEdit)) -- ^ Result of the formatting + +-- --------------------------------------------------------------------- diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs new file mode 100644 index 0000000000..a419396c99 --- /dev/null +++ b/test/functional/PluginSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module PluginSpec where + +-- import Control.Applicative.Combinators +import Control.Lens hiding (List) +-- import Control.Monad +import Control.Monad.IO.Class +-- import Data.Aeson +-- import Data.Default +-- import qualified Data.HashMap.Strict as HM +-- import Data.Maybe +-- import qualified Data.Text as T +-- import Language.Haskell.LSP.Test +import Language.Haskell.LSP.Test as Test +import Language.Haskell.LSP.Types +-- import qualified Language.Haskell.LSP.Types.Capabilities as C +import qualified Language.Haskell.LSP.Types.Lens as L +import Test.Hspec +import TestUtils + +#if __GLASGOW_HASKELL__ < 808 +-- import Data.Monoid ((<>)) +#endif + +-- --------------------------------------------------------------------- + +spec :: Spec +spec = do + describe "composes code actions" $ do + it "provides 3.8 code actions" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do + + doc <- openDoc "Format.hs" "haskell" + diags@(_reduceDiag:_) <- waitForDiagnostics + + liftIO $ putStrLn $ "diags = " ++ show diags -- AZ + -- liftIO $ do + -- length diags `shouldBe` 2 + -- reduceDiag ^. L.range `shouldBe` Range (Position 1 0) (Position 1 12) + -- reduceDiag ^. L.severity `shouldBe` Just DsInfo + -- reduceDiag ^. L.code `shouldBe` Just (StringValue "Eta reduce") + -- reduceDiag ^. L.source `shouldBe` Just "hlint" + + cas@(CACodeAction ca:_) <- getAllCodeActions doc + + liftIO $ putStrLn $ "cas = " ++ show cas -- AZ + + liftIO $ [ca ^. L.title] `shouldContain` ["Apply hint:Redundant id", "Apply hint:Evaluate"] + + executeCodeAction ca + + contents <- getDocumentEdit doc + liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" + + noDiagnostics From 94f800922885e072c7696f6d99e789c2c918145a Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 18 Feb 2020 22:05:38 +0000 Subject: [PATCH 02/25] Break out HoverProvider into separate handler config --- exe/Main.hs | 109 +++++++++++++++++++++++++--------- ghcide | 2 +- haskell-language-server.cabal | 4 ++ src/Ide/Plugin.hs | 77 +++++++++++++++++++++--- src/Ide/Plugin/Example.hs | 9 +-- src/Ide/Plugin/Example2.hs | 8 ++- src/Ide/Plugin/Formatter.hs | 31 +++------- src/Ide/Types.hs | 6 +- 8 files changed, 177 insertions(+), 69 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 43ddfcdb17..d1685a365b 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -1,19 +1,26 @@ -- Copyright (c) 2019 The DAML Authors. All rights reserved. -- SPDX-License-Identifier: Apache-2.0 {-# OPTIONS_GHC -Wno-dodgy-imports #-} -- GHC no longer exports def in GHC 8.6 and above +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} module Main(main) where import Arguments import Control.Concurrent.Extra +import Control.DeepSeq (NFData) import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class +import Data.Binary (Binary) import Data.Default +import Data.Dynamic (Typeable) +import qualified Data.HashSet as HashSet +import Data.Hashable (Hashable) import Data.List.Extra import qualified Data.Map.Strict as Map import Data.Maybe @@ -34,16 +41,21 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options -import Development.Shake (Action, action) +import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need) import GHC hiding (def) +import GHC.Generics (Generic) +-- import qualified GHC.Paths import HIE.Bios -import Ide.Plugin.Formatter +import HIE.Bios.Cradle +import HIE.Bios.Types +import Ide.Plugin import Ide.Plugin.Config +-- import Ide.Plugin.Formatter import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types (LspId(IdInt)) import Linker -import qualified Data.HashSet as HashSet -import System.Directory.Extra as IO +import qualified System.Directory.Extra as IO +-- import System.Environment import System.Exit import System.FilePath import System.IO @@ -70,6 +82,7 @@ idePlugins includeExample CodeAction.plugin <> formatterPlugins [("ormolu", Ormolu.provider) ,("floskell", Floskell.provider)] <> + hoverPlugins [Example.hover, Example2.hover] <> if includeExample then Example.plugin <> Example2.plugin else mempty @@ -89,9 +102,9 @@ main = do let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ T.putStrLn $ T.pack ("[" ++ upper (show pri) ++ "] ") <> msg - whenJust argsCwd setCurrentDirectory + whenJust argsCwd IO.setCurrentDirectory - dir <- getCurrentDirectory + dir <- IO.getCurrentDirectory let plugins = idePlugins argsExamplePlugin @@ -102,14 +115,13 @@ main = do runLanguageServer def (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t - -- very important we only call loadSession once, and it's fast, so just do it before starting - session <- loadSession dir - let options = (defaultIdeOptions $ return session) + let options = (defaultIdeOptions $ loadSession dir) { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling } debouncer <- newAsyncDebouncer - initialise caps (mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) debouncer options vfs + initialise caps (loadGhcSessionIO >> mainRule >> pluginRules plugins >> action kick) + getLspId event (logger minBound) debouncer options vfs else do putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "." putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" @@ -117,7 +129,7 @@ main = do putStrLn $ "\nStep 1/6: Finding files to test in " ++ dir files <- expandFiles (argFiles ++ ["." | null argFiles]) -- LSP works with absolute file paths, so try and behave similarly - files <- nubOrd <$> mapM canonicalizePath files + files <- nubOrd <$> mapM IO.canonicalizePath files putStrLn $ "Found " ++ show (length files) ++ " files" putStrLn "\nStep 2/6: Looking for hie.yaml files that control setup" @@ -131,7 +143,8 @@ main = do cradle <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle x when (isNothing x) $ print cradle putStrLn $ "\nStep 4/6, Cradle " ++ show i ++ "/" ++ show n ++ ": Loading GHC Session" - cradleToSession cradle + opts <- getComponentOptions cradle + createSession opts putStrLn "\nStep 5/6: Initializing the IDE" vfs <- makeVFSHandle @@ -144,7 +157,7 @@ main = do let options = (defaultIdeOptions $ return $ return . grab) { optShakeProfiling = argsShakeProfiling } - ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs + ide <- initialise def (loadGhcSessionIO >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs putStrLn "\nStep 6/6: Type checking the files" setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files @@ -166,7 +179,7 @@ expandFiles = concatMapM $ \x -> do let recurse "." = True recurse x | "." `isPrefixOf` takeFileName x = False -- skip .git etc recurse x = takeFileName x `notElem` ["dist","dist-newstyle"] -- cabal directories - files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> listFilesInside (return . recurse) x + files <- filter (\x -> takeExtension x `elem` [".hs",".lhs"]) <$> IO.listFilesInside (return . recurse) x when (null files) $ fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x return files @@ -185,15 +198,42 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) = showEvent lock e = withLock lock $ print e -cradleToSession :: Cradle a -> IO HscEnvEq -cradleToSession cradle = do - cradleRes <- getCompilerOptions "" cradle - opts <- case cradleRes of +-- Rule type for caching GHC sessions. +type instance RuleResult GetHscEnv = HscEnvEq + +data GetHscEnv = GetHscEnv + { hscenvOptions :: [String] -- componentOptions from hie-bios + , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios + } + deriving (Eq, Show, Typeable, Generic) +instance Hashable GetHscEnv +instance NFData GetHscEnv +instance Binary GetHscEnv + + +loadGhcSessionIO :: Rules () +loadGhcSessionIO = + -- This rule is for caching the GHC session. E.g., even when the cabal file + -- changed, if the resulting flags did not change, we would continue to use + -- the existing session. + defineNoFile $ \(GetHscEnv opts deps) -> + liftIO $ createSession $ ComponentOptions opts deps + + +getComponentOptions :: Cradle a -> IO ComponentOptions +getComponentOptions cradle = do + let showLine s = putStrLn ("> " ++ s) + cradleRes <- runCradle (cradleOptsProg cradle) showLine "" + case cradleRes of CradleSuccess r -> pure r CradleFail err -> throwIO err -- TODO Rather than failing here, we should ignore any files that use this cradle. -- That will require some more changes. CradleNone -> fail "'none' cradle is not yet supported" + + +createSession :: ComponentOptions -> IO HscEnvEq +createSession opts = do libdir <- getLibdir env <- runGhc (Just libdir) $ do _targets <- initSession opts @@ -202,19 +242,34 @@ cradleToSession cradle = do newHscEnvEq env -loadSession :: FilePath -> IO (FilePath -> Action HscEnvEq) -loadSession dir = do +cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq +cradleToSession mbYaml cradle = do + cmpOpts <- liftIO $ getComponentOptions cradle + let opts = componentOptions cmpOpts + deps = componentDependencies cmpOpts + deps' = case mbYaml of + -- For direct cradles, the hie.yaml file itself must be watched. + Just yaml | isDirectCradle cradle -> yaml : deps + _ -> deps + existingDeps <- filterM doesFileExist deps' + need existingDeps + useNoFile_ $ GetHscEnv opts deps + + +loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq) +loadSession dir = liftIO $ do cradleLoc <- memoIO $ \v -> do res <- findCradle v -- Sometimes we get C:, sometimes we get c:, and sometimes we get a relative path -- try and normalise that -- e.g. see https://github.com/digital-asset/ghcide/issues/126 - res' <- traverse makeAbsolute res + res' <- traverse IO.makeAbsolute res return $ normalise <$> res' - session <- memoIO $ \file -> do - c <- maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file - cradleToSession c - return $ \file -> liftIO $ session =<< cradleLoc file + let session :: Maybe FilePath -> Action HscEnvEq + session file = do + c <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file + cradleToSession file c + return $ \file -> session =<< liftIO (cradleLoc file) -- | Memoize an IO function, with the characteristics: diff --git a/ghcide b/ghcide index 286635bac8..5bea92f9d3 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 286635bac84c573ca2fbafc6a65d633302b152d1 +Subproject commit 5bea92f9d3f835098b9aea4109165611e9186eef diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index af2bc4bd45..10986cb845 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -62,6 +62,7 @@ library , haskell-lsp == 0.20.* , hie-bios >= 0.4 , hslogger + , lens , optparse-simple , process , regex-tdfa >= 1.3.1.0 @@ -106,8 +107,10 @@ executable haskell-language-server build-depends: base >=4.7 && <5 + , binary , containers , data-default + , deepseq , extra , filepath -------------------------------------------------------------- @@ -121,6 +124,7 @@ executable haskell-language-server , ghc-paths , ghcide , gitrev + , hashable , haskell-lsp , hie-bios >= 0.4 , haskell-language-server diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs index b7ac9df363..1bcc6a6737 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -1,25 +1,38 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module Ide.Plugin ( asGhcIdePlugin + , formatterPlugins + , hoverPlugins ) where -import Data.Aeson hiding (defaultOptions) +import Control.Lens ( (^.) ) +import Data.Either +import Data.Maybe import qualified Data.Map as Map -import qualified Data.Set as S -import Data.String import qualified Data.Text as T -import Data.Typeable +import Development.IDE.Core.FileStore import Development.IDE.Core.Rules +import Development.IDE.LSP.Server +import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location -import Language.Haskell.LSP.Types -import Text.Regex.TDFA.Text() -import Development.IDE.Plugin +import Development.Shake hiding ( Diagnostic ) import Ide.Plugin.Config +import Ide.Plugin.Formatter import Ide.Types +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages +import Text.Regex.TDFA.Text() + +import qualified Language.Haskell.LSP.Core as LSP +import Language.Haskell.LSP.Messages +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) -- --------------------------------------------------------------------- @@ -32,3 +45,53 @@ asGhcIdePlugin _ = Plugin mempty mempty -- First strp will be to bring the machinery from Ide.Plugin.Formatter over. -- --------------------------------------------------------------------- + +hoverPlugins :: [HoverProvider] -> Plugin Config +hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) + +hoverRules :: Rules () +hoverRules = mempty + +hoverHandlers :: [HoverProvider] -> PartialHandlers Config +hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> + return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} + +makeHover :: [HoverProvider] + -> LSP.LspFuncs Config -> IdeState + -> TextDocumentPositionParams + -> IO (Either ResponseError (Maybe Hover)) +makeHover hps lf ideState params + = do + mhs <- mapM (\p -> p ideState params) hps + -- TODO: We should support ServerCapabilities and declare that + -- we don't support hover requests during initialization if we + -- don't have any hover providers + -- TODO: maybe only have provider give MarkedString and + -- work out range here? + let hs = catMaybes (rights mhs) + r = listToMaybe $ mapMaybe (^. range) hs + h = case mconcat ((map (^. contents) hs) :: [HoverContents]) of + HoverContentsMS (List []) -> Nothing + hh -> Just $ Hover hh r + return $ Right h + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +formatterPlugins :: [(T.Text, FormattingProvider IO)] -> Plugin Config +formatterPlugins providers + = Plugin formatterRules + (formatterHandlers (Map.fromList (("none",noneProvider):providers))) + +formatterRules :: Rules () +formatterRules = mempty + +formatterHandlers :: Map.Map T.Text (FormattingProvider IO) -> PartialHandlers Config +formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.documentFormattingHandler + = withResponse RspDocumentFormatting (formatting providers) + , LSP.documentRangeFormattingHandler + = withResponse RspDocumentRangeFormatting (rangeFormatting providers) + } + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index 2908c865ae..049089a496 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -11,6 +11,7 @@ module Ide.Plugin.Example ( plugin + , hover ) where import Control.DeepSeq ( NFData ) @@ -52,12 +53,12 @@ hover = request "Hover" blah (Right Nothing) foundHover blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) blah _ (Position line col) - = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover"]) + = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 1\n"]) handlersExample :: PartialHandlers c -handlersExample = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.hoverHandler = withResponse RspHover $ const hover} - +handlersExample = mempty +-- handlersExample = PartialHandlers $ \WithMessage{..} x -> +-- return x{LSP.hoverHandler = withResponse RspHover $ const hover} -- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index c65ce6ee12..943a969978 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -11,6 +11,7 @@ module Ide.Plugin.Example2 ( plugin + , hover ) where import Control.DeepSeq ( NFData ) @@ -52,11 +53,12 @@ hover = request "Hover" blah (Right Nothing) foundHover blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) blah _ (Position line col) - = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover"]) + = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 2\n"]) handlersExample2 :: PartialHandlers c -handlersExample2 = PartialHandlers $ \WithMessage{..} x -> - return x{LSP.hoverHandler = withResponse RspHover $ const hover} +handlersExample2 = mempty +-- handlersExample2 = PartialHandlers $ \WithMessage{..} x -> +-- return x{LSP.hoverHandler = withResponse RspHover $ const hover} -- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Formatter.hs b/src/Ide/Plugin/Formatter.hs index 7512d998c2..747d8a4827 100644 --- a/src/Ide/Plugin/Formatter.hs +++ b/src/Ide/Plugin/Formatter.hs @@ -7,7 +7,9 @@ module Ide.Plugin.Formatter ( - formatterPlugins + formatting + , rangeFormatting + , noneProvider , responseError , extractRange , fullRange @@ -18,39 +20,20 @@ import qualified Data.Map as Map import qualified Data.Text as T import Development.IDE.Core.FileStore import Development.IDE.Core.Rules -import Development.IDE.LSP.Server -import Development.IDE.Plugin +-- import Development.IDE.LSP.Server +-- import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location -import Development.Shake hiding ( Diagnostic ) +-- import Development.Shake hiding ( Diagnostic ) import Ide.Types import Ide.Plugin.Config import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages +-- import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -formatterPlugins :: [(T.Text, FormattingProvider IO)] -> Plugin Config -formatterPlugins providers = Plugin rules (handlers (Map.fromList (("none",noneProvider):providers))) - --- --------------------------------------------------------------------- --- New style plugin - -rules :: Rules () -rules = mempty - -handlers :: Map.Map T.Text (FormattingProvider IO) -> PartialHandlers Config -handlers providers = PartialHandlers $ \WithMessage{..} x -> return x - { LSP.documentFormattingHandler - = withResponse RspDocumentFormatting (formatting providers) - , LSP.documentRangeFormattingHandler - = withResponse RspDocumentRangeFormatting (rangeFormatting providers) - } - --- --------------------------------------------------------------------- - formatting :: Map.Map T.Text (FormattingProvider IO) -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams -> IO (Either ResponseError (List TextEdit)) diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs index f7fc2e3a6d..a424df3f72 100644 --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -10,6 +10,7 @@ module Ide.Types , DiagnosticProviderFunc(..) , FormattingType(..) , FormattingProvider + , HoverProvider ) where import Data.Aeson hiding (defaultOptions) @@ -23,8 +24,6 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() --- import Development.IDE.Plugin --- import Ide.Plugin.Config -- --------------------------------------------------------------------- @@ -90,7 +89,8 @@ data DiagnosticTrigger = DiagnosticOnOpen | DiagnosticOnSave deriving (Show,Ord,Eq) -type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) +-- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) +type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) type SymbolProvider = Uri -> IO (Either ResponseError [DocumentSymbol]) From 5c4758e5f2ac8ed31780cf338f5c06eca76a3bc7 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 19 Feb 2020 22:39:21 +0000 Subject: [PATCH 03/25] Break out Code Action providers into their own handler --- exe/Main.hs | 2 + haskell-language-server.cabal | 2 + src/Ide/Compat.hs | 19 ++++++++ src/Ide/Plugin.hs | 90 +++++++++++++++++++++++++++++++---- src/Ide/Plugin/Example.hs | 18 +++---- src/Ide/Plugin/Example2.hs | 14 +++--- src/Ide/Types.hs | 10 ++-- test/functional/PluginSpec.hs | 24 ++++++---- 8 files changed, 144 insertions(+), 35 deletions(-) create mode 100644 src/Ide/Compat.hs diff --git a/exe/Main.hs b/exe/Main.hs index d1685a365b..f1f31e170c 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -82,6 +82,8 @@ idePlugins includeExample CodeAction.plugin <> formatterPlugins [("ormolu", Ormolu.provider) ,("floskell", Floskell.provider)] <> + codeActionPlugins [("eg", Example.codeAction) + ,("eg2", Example2.codeAction)] <> hoverPlugins [Example.hover, Example2.hover] <> if includeExample then Example.plugin <> Example2.plugin else mempty diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 10986cb845..f5b38bfc90 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -27,6 +27,7 @@ source-repository head library exposed-modules: + Ide.Compat Ide.Cradle Ide.Plugin Ide.Plugin.Config @@ -69,6 +70,7 @@ library , shake >= 0.17.5 , text , transformers + , unix , unordered-containers if impl(ghc >= 8.6) build-depends: ormolu >= 0.0.3.1 diff --git a/src/Ide/Compat.hs b/src/Ide/Compat.hs new file mode 100644 index 0000000000..f46ffa3f56 --- /dev/null +++ b/src/Ide/Compat.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE CPP #-} +module Ide.Compat + ( + getProcessID + ) where + +#ifdef mingw32_HOST_OS + +import qualified System.Win32.Process as P (getCurrentProcessId) +getProcessID :: IO Int +getProcessID = fromIntegral <$> P.getCurrentProcessId + +#else + +import qualified System.Posix.Process as P (getProcessID) +getProcessID :: IO Int +getProcessID = fromIntegral <$> P.getProcessID + +#endif diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs index 1bcc6a6737..760c17860c 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,31 +10,33 @@ module Ide.Plugin asGhcIdePlugin , formatterPlugins , hoverPlugins + , codeActionPlugins ) where import Control.Lens ( (^.) ) +import qualified Data.Aeson as J import Data.Either -import Data.Maybe import qualified Data.Map as Map +import Data.Maybe import qualified Data.Text as T -import Development.IDE.Core.FileStore +-- import Development.IDE.Core.FileStore import Development.IDE.Core.Rules import Development.IDE.LSP.Server import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D -import Development.IDE.Types.Location -import Development.Shake hiding ( Diagnostic ) +-- import Development.IDE.Types.Location +import Development.Shake hiding ( Diagnostic, command ) +import GHC.Generics +import Ide.Compat import Ide.Plugin.Config import Ide.Plugin.Formatter import Ide.Types -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages -import Text.Regex.TDFA.Text() - import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types.Capabilities as C import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) +import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- @@ -46,6 +50,74 @@ asGhcIdePlugin _ = Plugin mempty mempty -- --------------------------------------------------------------------- +codeActionPlugins :: [(T.Text, CodeActionProvider)] -> Plugin Config +codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) + +codeActionRules :: Rules () +codeActionRules = mempty + +codeActionHandlers :: [(T.Text, CodeActionProvider)] -> PartialHandlers Config +codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.codeActionHandler + = withResponse RspCodeAction (makeCodeAction cas) + } + +makeCodeAction :: [(T.Text, CodeActionProvider)] + -> LSP.LspFuncs Config -> IdeState + -> CodeActionParams + -> IO (Either ResponseError (List CAResult)) +makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do + let caps = LSP.clientCapabilities lf + unL (List ls) = ls + r <- mapM (\(pid,provider) -> provider ideState (PluginId pid) docId range context) cas + let actions = filter wasRequested . concat $ map unL $ rights r + res <- send caps actions + return $ Right res + where + wasRequested :: CAResult -> Bool + wasRequested (CACommand _) = True + wasRequested (CACodeAction ca) + | Nothing <- only context = True + | Just (List allowed) <- only context + , Just caKind <- ca ^. kind = caKind `elem` allowed + | otherwise = False + + wrapCodeAction :: C.ClientCapabilities -> CAResult -> IO (Maybe CAResult) + wrapCodeAction _ (CACommand cmd) = return $ Just (CACommand cmd) + wrapCodeAction caps (CACodeAction action) = do + + let (C.ClientCapabilities _ textDocCaps _ _) = caps + let literalSupport = textDocCaps >>= C._codeAction >>= C._codeActionLiteralSupport + + case literalSupport of + Nothing -> do + let cmdParams = [J.toJSON (FallbackCodeActionParams (action ^. edit) (action ^. command))] + cmd <- mkLspCommand "hie" "fallbackCodeAction" (action ^. title) (Just cmdParams) + return $ Just (CACommand cmd) + Just _ -> return $ Just (CACodeAction action) + + send :: C.ClientCapabilities -> [CAResult] -> IO (List CAResult) + send caps codeActions = List . catMaybes <$> mapM (wrapCodeAction caps) codeActions + +data FallbackCodeActionParams = + FallbackCodeActionParams + { fallbackWorkspaceEdit :: Maybe WorkspaceEdit + , fallbackCommand :: Maybe Command + } + deriving (Generic, J.ToJSON, J.FromJSON) + +mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command +mkLspCommand plid cn title args' = do + cmdId <- mkLspCmdId plid cn + let args = List <$> args' + return $ Command title cmdId args + +mkLspCmdId :: PluginId -> CommandId -> IO T.Text +mkLspCmdId (PluginId plid) (CommandId cid) = do + pid <- T.pack . show <$> getProcessID + return $ pid <> ":" <> plid <> ":" <> cid +-- --------------------------------------------------------------------- + hoverPlugins :: [HoverProvider] -> Plugin Config hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) @@ -60,7 +132,7 @@ makeHover :: [HoverProvider] -> LSP.LspFuncs Config -> IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -makeHover hps lf ideState params +makeHover hps _lf ideState params = do mhs <- mapM (\p -> p ideState params) hps -- TODO: We should support ServerCapabilities and declare that diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index 049089a496..0d233f7a48 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -12,6 +12,7 @@ module Ide.Plugin.Example ( plugin , hover + , codeAction ) where import Control.DeepSeq ( NFData ) @@ -35,6 +36,7 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.Shake hiding ( Diagnostic ) +import Ide.Types import GHC.Generics import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages @@ -45,7 +47,7 @@ import Text.Regex.TDFA.Text() plugin :: Plugin c plugin = Plugin exampleRules handlersExample - <> codeActionPlugin codeAction + -- <> codeActionPlugin codeAction <> Plugin mempty handlersCodeLens hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) @@ -101,19 +103,19 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) -- | Generate code actions. codeAction - :: LSP.LspFuncs c - -> IdeState + :: IdeState + -> PluginId -> TextDocumentIdentifier -> Range -> CodeActionContext - -> IO (Either ResponseError [CAResult]) -codeAction _lsp _state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do + -> IO (Either ResponseError (List CAResult)) +codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let - title = "Add TODO Item" + title = "Add TODO Item 1" tedit = [TextEdit (Range (Position 0 0) (Position 0 0)) - "-- TODO added by Example Plugin directly\n"] + "-- TODO1 added by Example Plugin directly\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - pure $ Right + pure $ Right $ List [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] -- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index 943a969978..007eeafa92 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -12,6 +12,7 @@ module Ide.Plugin.Example2 ( plugin , hover + , codeAction ) where import Control.DeepSeq ( NFData ) @@ -35,6 +36,7 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.Shake hiding ( Diagnostic ) +import Ide.Types import GHC.Generics import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages @@ -45,7 +47,7 @@ import Text.Regex.TDFA.Text() plugin :: Plugin c plugin = Plugin exampleRules handlersExample2 - <> codeActionPlugin codeAction + -- <> codeActionPlugin codeAction <> Plugin mempty handlersCodeLens hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) @@ -102,19 +104,19 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) -- | Generate code actions. codeAction - :: LSP.LspFuncs c - -> IdeState + :: IdeState + -> PluginId -> TextDocumentIdentifier -> Range -> CodeActionContext - -> IO (Either ResponseError [CAResult]) -codeAction _lsp _state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do + -> IO (Either ResponseError (List CAResult)) +codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let title = "Add TODO2 Item" tedit = [TextEdit (Range (Position 0 0) (Position 0 0)) "-- TODO2 added by Example2 Plugin directly\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - pure $ Right + pure $ Right $ List [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] -- --------------------------------------------------------------------- diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs index a424df3f72..f1a2053e57 100644 --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -6,11 +6,14 @@ module Ide.Types IdePlugins(..) , PluginDescriptor(..) , PluginCommand(..) + , PluginId(..) + , CommandId(..) , DiagnosticProvider(..) , DiagnosticProviderFunc(..) , FormattingType(..) , FormattingProvider , HoverProvider + , CodeActionProvider ) where import Data.Aeson hiding (defaultOptions) @@ -59,11 +62,12 @@ data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => -- --------------------------------------------------------------------- -type CodeActionProvider = PluginId - -> VersionedTextDocumentIdentifier +type CodeActionProvider = IdeState + -> PluginId + -> TextDocumentIdentifier -> Range -> CodeActionContext - -> IO (Either ResponseError [CodeAction]) + -> IO (Either ResponseError (List CAResult)) type DiagnosticProviderFuncSync = DiagnosticTrigger -> Uri diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index a419396c99..6150700550 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -31,25 +31,31 @@ spec = do it "provides 3.8 code actions" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" - diags@(_reduceDiag:_) <- waitForDiagnostics + _diags@(diag1:_) <- waitForDiagnostics - liftIO $ putStrLn $ "diags = " ++ show diags -- AZ - -- liftIO $ do - -- length diags `shouldBe` 2 - -- reduceDiag ^. L.range `shouldBe` Range (Position 1 0) (Position 1 12) - -- reduceDiag ^. L.severity `shouldBe` Just DsInfo - -- reduceDiag ^. L.code `shouldBe` Just (StringValue "Eta reduce") - -- reduceDiag ^. L.source `shouldBe` Just "hlint" + -- liftIO $ putStrLn $ "diags = " ++ show diags -- AZ + liftIO $ do + -- length diags `shouldBe` 1 + diag1 ^. L.range `shouldBe` Range (Position 0 0) (Position 1 0) + diag1 ^. L.severity `shouldBe` Just DsError + diag1 ^. L.code `shouldBe` Nothing + -- diag1 ^. L.source `shouldBe` Just "example2" + + -- diag2 ^. L.source `shouldBe` Just "example" cas@(CACodeAction ca:_) <- getAllCodeActions doc + liftIO $ length cas `shouldBe` 2 liftIO $ putStrLn $ "cas = " ++ show cas -- AZ - liftIO $ [ca ^. L.title] `shouldContain` ["Apply hint:Redundant id", "Apply hint:Evaluate"] + liftIO $ [ca ^. L.title] `shouldContain` ["Add TODO Item 1"] + liftIO $ putStrLn $ "A" -- AZ executeCodeAction ca + liftIO $ putStrLn $ "B" -- AZ contents <- getDocumentEdit doc + liftIO $ putStrLn $ "C" -- AZ liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" noDiagnostics From 1470977ceb7122ce3ec86bfe2a1279a922fb9973 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 3 Mar 2020 22:12:44 +0000 Subject: [PATCH 04/25] Working on Plugin concept. Tests do not pass, but want to rebase, so marking a checkpoint. --- .gitmodules | 4 +- exe/Main.hs | 76 ++++++++++++- ghcide | 2 +- haskell-language-server.cabal | 4 + src/Ide/Plugin.hs | 200 ++++++++++++++++++++++++++++++++-- src/Ide/Plugin/Example.hs | 10 +- src/Ide/Plugin/Example2.hs | 10 +- src/Ide/Plugin/Pragmas.hs | 174 +++++++++++++++++++++++++++++ src/Ide/Types.hs | 30 +++-- 9 files changed, 469 insertions(+), 41 deletions(-) create mode 100644 src/Ide/Plugin/Pragmas.hs diff --git a/.gitmodules b/.gitmodules index f7d6551110..7faeadd5ea 100644 --- a/.gitmodules +++ b/.gitmodules @@ -10,5 +10,5 @@ # rm -rf path_to_submodule [submodule "ghcide"] path = ghcide - url = https://github.com/digital-asset/ghcide.git - # url = https://github.com/alanz/ghcide.git + # url = https://github.com/digital-asset/ghcide.git + url = https://github.com/alanz/ghcide.git diff --git a/exe/Main.hs b/exe/Main.hs index f1f31e170c..f786ab147e 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -16,7 +16,10 @@ import Control.DeepSeq (NFData) import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class +import qualified Crypto.Hash.SHA1 as H import Data.Binary (Binary) +import Data.ByteString.Base16 +import qualified Data.ByteString.Char8 as B import Data.Default import Data.Dynamic (Typeable) import qualified Data.HashSet as HashSet @@ -26,6 +29,8 @@ import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T import qualified Data.Text.IO as T +-- import Data.Version +-- import Development.GitRev import Development.IDE.Core.Debouncer import Development.IDE.Core.FileStore import Development.IDE.Core.OfInterest @@ -42,18 +47,22 @@ import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need) +import DynFlags import GHC hiding (def) import GHC.Generics (Generic) -- import qualified GHC.Paths import HIE.Bios import HIE.Bios.Cradle +import HIE.Bios.Environment import HIE.Bios.Types import Ide.Plugin import Ide.Plugin.Config -- import Ide.Plugin.Formatter import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types (LspId(IdInt)) +import qualified Language.Haskell.LSP.Core as LSP import Linker +-- import Paths_haskell_language_server import qualified System.Directory.Extra as IO -- import System.Environment import System.Exit @@ -69,6 +78,7 @@ import Ide.Plugin.Example as Example import Ide.Plugin.Example2 as Example2 import Ide.Plugin.Floskell as Floskell import Ide.Plugin.Ormolu as Ormolu +import Ide.Plugin.Pragmas as Pragmas -- --------------------------------------------------------------------- @@ -82,13 +92,29 @@ idePlugins includeExample CodeAction.plugin <> formatterPlugins [("ormolu", Ormolu.provider) ,("floskell", Floskell.provider)] <> - codeActionPlugins [("eg", Example.codeAction) - ,("eg2", Example2.codeAction)] <> + codeActionPlugins [("eg", Example.codeAction) + ,("eg2", Example2.codeAction) + ,("pragmas", Pragmas.codeAction)] <> + executeCommandPlugins [("pragmas", Pragmas.commands)] <> hoverPlugins [Example.hover, Example2.hover] <> if includeExample then Example.plugin <> Example2.plugin else mempty +commandIds :: T.Text -> [T.Text] +commandIds pid = "typesignature.add" : allLspCmdIds pid [("pragmas", Pragmas.commands)] + -- --------------------------------------------------------------------- +-- Prefix for the cache path +cacheDir :: String +cacheDir = "ghcide" + +getCacheDir :: [String] -> IO FilePath +getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir opts_hash) + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts) + main :: IO () main = do @@ -108,13 +134,17 @@ main = do dir <- IO.getCurrentDirectory + pid <- getPid let plugins = idePlugins argsExamplePlugin + options = def { LSP.executeCommandCommands = Just (commandIds pid) + , LSP.completionTriggerCharacters = Just "." + } if argLSP then do t <- offsetTime hPutStrLn stderr "Starting (haskell-language-server)LSP server..." hPutStrLn stderr "If you are seeing this in a terminal, you probably should have run ghcide WITHOUT the --lsp option!" - runLanguageServer def (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps -> do + runLanguageServer options (pluginHandler plugins) getInitialConfig getConfigFromNotification $ \getLspId event vfs caps -> do t <- t hPutStrLn stderr $ "Started LSP server in " ++ showDuration t let options = (defaultIdeOptions $ loadSession dir) @@ -235,14 +265,50 @@ getComponentOptions cradle = do createSession :: ComponentOptions -> IO HscEnvEq -createSession opts = do +createSession (ComponentOptions theOpts _) = do libdir <- getLibdir + + cacheDir <- Main.getCacheDir theOpts + env <- runGhc (Just libdir) $ do - _targets <- initSession opts + dflags <- getSessionDynFlags + (dflags', _targets) <- addCmdOpts theOpts dflags + _ <- setSessionDynFlags $ + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setHiDir cacheDir $ + setDefaultHieDir cacheDir $ + setIgnoreInterfacePragmas $ + setLinkerOptions $ + disableOptimisation dflags' getSession initDynLinker env newHscEnvEq env +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscNothing + , ghcMode = CompManager + } + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq cradleToSession mbYaml cradle = do diff --git a/ghcide b/ghcide index 5bea92f9d3..b98b101f87 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 5bea92f9d3f835098b9aea4109165611e9186eef +Subproject commit b98b101f87113f96f360d5eadda1125a16b88a12 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index f5b38bfc90..fc45963dc3 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -34,6 +34,7 @@ library Ide.Plugin.Example Ide.Plugin.Example2 Ide.Plugin.Ormolu + Ide.Plugin.Pragmas Ide.Plugin.Floskell Ide.Plugin.Formatter Ide.Types @@ -109,7 +110,10 @@ executable haskell-language-server build-depends: base >=4.7 && <5 + , base16-bytestring , binary + , bytestring + , cryptohash-sha1 , containers , data-default , deepseq diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs index 760c17860c..670eb9d952 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveGeneric #-} @@ -11,20 +13,24 @@ module Ide.Plugin , formatterPlugins , hoverPlugins , codeActionPlugins + , executeCommandPlugins + , mkLspCommand + , allLspCmdIds + , getPid ) where import Control.Lens ( (^.) ) +import Control.Monad import qualified Data.Aeson as J import Data.Either +import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe import qualified Data.Text as T --- import Development.IDE.Core.FileStore import Development.IDE.Core.Rules import Development.IDE.LSP.Server import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D --- import Development.IDE.Types.Location import Development.Shake hiding ( Diagnostic, command ) import GHC.Generics import Ide.Compat @@ -34,7 +40,9 @@ import Ide.Types import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types +import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Capabilities as C +-- import qualified Language.Haskell.LSP.Types.Lens as J import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) import Text.Regex.TDFA.Text() @@ -44,14 +52,14 @@ import Text.Regex.TDFA.Text() -- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message -- category ('Notifaction', 'Request' etc). asGhcIdePlugin :: IdePlugins -> Plugin Config -asGhcIdePlugin _ = Plugin mempty mempty +asGhcIdePlugin _ = Plugin mempty mempty mempty -- First strp will be to bring the machinery from Ide.Plugin.Formatter over. -- --------------------------------------------------------------------- codeActionPlugins :: [(T.Text, CodeActionProvider)] -> Plugin Config -codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) +codeActionPlugins cas = Plugin mempty codeActionRules (codeActionHandlers cas) codeActionRules :: Rules () codeActionRules = mempty @@ -106,20 +114,189 @@ data FallbackCodeActionParams = } deriving (Generic, J.ToJSON, J.FromJSON) +-- ----------------------------------------------------------- + +executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config +executeCommandPlugins ecs = Plugin mempty mempty (executeCommandHandlers ecs) + +executeCommandHandlers :: [(PluginId, [PluginCommand])] -> PartialHandlers Config +executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ + LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit (makeExecuteCommands ecs) + } + +-- type ExecuteCommandProvider = IdeState +-- -> ExecuteCommandParams +-- -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) +makeExecuteCommands :: [(PluginId, [PluginCommand])] -> LSP.LspFuncs Config -> ExecuteCommandProvider +makeExecuteCommands ecs _lf _params = do + let + pluginMap = Map.fromList ecs + parseCmdId :: T.Text -> Maybe (PluginId, CommandId) + parseCmdId x = case T.splitOn ":" x of + [plugin, command] -> Just (PluginId plugin, CommandId command) + [_, plugin, command] -> Just (PluginId plugin, CommandId command) + _ -> Nothing + + execCmd :: ExecuteCommandParams -> IO (Either ResponseError J.Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + execCmd (ExecuteCommandParams cmdId args _) = do + -- The parameters to the HIE command are always the first element + let cmdParams :: J.Value + cmdParams = case args of + Just (J.List (x:_)) -> x + _ -> J.Null + + case parseCmdId cmdId of + -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions + Just ("hie", "fallbackCodeAction") -> + case J.fromJSON cmdParams of + J.Success (FallbackCodeActionParams mEdit mCmd) -> do + + -- Send off the workspace request if it has one + forM_ mEdit $ \edit -> do + let eParams = J.ApplyWorkspaceEditParams edit + -- TODO: Use lspfuncs to send an applyedit message. Or change + -- the API to allow a list of messages to be returned. + return (Right J.Null, Just(J.WorkspaceApplyEdit, eParams)) + + case mCmd of + -- If we have a command, continue to execute it + Just (J.Command _ innerCmdId innerArgs) + -> execCmd (ExecuteCommandParams innerCmdId innerArgs Nothing) + Nothing -> return (Right J.Null, Nothing) + + J.Error _str -> return (Right J.Null, Nothing) + -- Couldn't parse the fallback command params + -- _ -> liftIO $ + -- LSP.sendErrorResponseS (LSP.sendFunc lf) + -- (J.responseId (req ^. J.id)) + -- J.InvalidParams + -- "Invalid fallbackCodeAction params" + + -- Just an ordinary HIE command + Just (plugin, cmd) -> runPluginCommand pluginMap plugin cmd cmdParams + + -- Couldn't parse the command identifier + _ -> return (Left $ ResponseError InvalidParams "Invalid command identifier" Nothing, Nothing) + + execCmd + +{- + ReqExecuteCommand req -> do + liftIO $ U.logs $ "reactor:got ExecuteCommandRequest:" ++ show req + lf <- asks lspFuncs + + let params = req ^. J.params + + parseCmdId :: T.Text -> Maybe (PluginId, CommandId) + parseCmdId x = case T.splitOn ":" x of + [plugin, command] -> Just (PluginId plugin, CommandId command) + [_, plugin, command] -> Just (PluginId plugin, CommandId command) + _ -> Nothing + + callback obj = do + liftIO $ U.logs $ "ExecuteCommand response got:r=" ++ show obj + case fromDynJSON obj :: Maybe J.WorkspaceEdit of + Just v -> do + lid <- nextLspReqId + reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) + let msg = fmServerApplyWorkspaceEditRequest lid $ J.ApplyWorkspaceEditParams v + liftIO $ U.logs $ "ExecuteCommand sending edit: " ++ show msg + reactorSend $ ReqApplyWorkspaceEdit msg + Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req $ dynToJSON obj + + execCmd cmdId args = do + -- The parameters to the HIE command are always the first element + let cmdParams = case args of + Just (J.List (x:_)) -> x + _ -> A.Null + + case parseCmdId cmdId of + -- Shortcut for immediately applying a applyWorkspaceEdit as a fallback for v3.8 code actions + Just ("hie", "fallbackCodeAction") -> do + case A.fromJSON cmdParams of + A.Success (FallbackCodeActionParams mEdit mCmd) -> do + + -- Send off the workspace request if it has one + forM_ mEdit $ \edit -> do + lid <- nextLspReqId + let eParams = J.ApplyWorkspaceEditParams edit + eReq = fmServerApplyWorkspaceEditRequest lid eParams + reactorSend $ ReqApplyWorkspaceEdit eReq + + case mCmd of + -- If we have a command, continue to execute it + Just (J.Command _ innerCmdId innerArgs) -> execCmd innerCmdId innerArgs + + -- Otherwise we need to send back a response oureslves + Nothing -> reactorSend $ RspExecuteCommand $ Core.makeResponseMessage req (A.Object mempty) + + -- Couldn't parse the fallback command params + _ -> liftIO $ + Core.sendErrorResponseS (Core.sendFunc lf) + (J.responseId (req ^. J.id)) + J.InvalidParams + "Invalid fallbackCodeAction params" + -- Just an ordinary HIE command + Just (plugin, cmd) -> + let preq = GReq tn "plugin" Nothing Nothing (Just $ req ^. J.id) callback (toDynJSON (Nothing :: Maybe J.WorkspaceEdit)) + $ runPluginCommand plugin cmd cmdParams + in makeRequest preq + + -- Couldn't parse the command identifier + _ -> liftIO $ + Core.sendErrorResponseS (Core.sendFunc lf) + (J.responseId (req ^. J.id)) + J.InvalidParams + "Invalid command identifier" + + execCmd (params ^. J.command) (params ^. J.arguments) +-} +-- | Runs a plugin command given a PluginId, CommandId and +-- arguments in the form of a JSON object. +runPluginCommand :: Map.Map PluginId [PluginCommand] -> PluginId -> CommandId -> J.Value + -> IO (Either ResponseError J.Value, + Maybe (ServerMethod, ApplyWorkspaceEditParams)) +runPluginCommand m p@(PluginId p') com@(CommandId com') arg = + case Map.lookup p m of + Nothing -> return + (Left $ ResponseError InvalidRequest ("Plugin " <> p' <> " doesn't exist") Nothing, Nothing) + Just xs -> case List.find ((com ==) . commandId) xs of + Nothing -> return (Left $ + ResponseError InvalidRequest ("Command " <> com' <> " isn't defined for plugin " <> p' <> ". Legal commands are: " <> T.pack(show $ map commandId xs)) Nothing, Nothing) + Just (PluginCommand _ _ f) -> case J.fromJSON arg of + J.Error err -> return (Left $ + ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' <> ": " <> T.pack err) Nothing, Nothing) + J.Success a -> do + res <- f a + case res of + Left e -> return (Left e, Nothing) + Right r -> return (Right $ J.toJSON r, Nothing) + +-- ----------------------------------------------------------- + mkLspCommand :: PluginId -> CommandId -> T.Text -> Maybe [J.Value] -> IO Command mkLspCommand plid cn title args' = do - cmdId <- mkLspCmdId plid cn + pid <- getPid + let cmdId = mkLspCmdId pid plid cn let args = List <$> args' return $ Command title cmdId args -mkLspCmdId :: PluginId -> CommandId -> IO T.Text -mkLspCmdId (PluginId plid) (CommandId cid) = do - pid <- T.pack . show <$> getProcessID - return $ pid <> ":" <> plid <> ":" <> cid +mkLspCmdId :: T.Text -> PluginId -> CommandId -> T.Text +mkLspCmdId pid (PluginId plid) (CommandId cid) + = pid <> ":" <> plid <> ":" <> cid + +getPid :: IO T.Text +getPid = T.pack . show <$> getProcessID + +allLspCmdIds :: T.Text -> [(PluginId, [PluginCommand])] -> [T.Text] +allLspCmdIds pid commands = concat $ map go commands + where + go (plid, cmds) = map (mkLspCmdId pid plid . commandId) cmds + -- --------------------------------------------------------------------- hoverPlugins :: [HoverProvider] -> Plugin Config -hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) +hoverPlugins hs = Plugin mempty hoverRules (hoverHandlers hs) hoverRules :: Rules () hoverRules = mempty @@ -152,7 +329,8 @@ makeHover hps _lf ideState params formatterPlugins :: [(T.Text, FormattingProvider IO)] -> Plugin Config formatterPlugins providers - = Plugin formatterRules + = Plugin mempty + formatterRules (formatterHandlers (Map.fromList (("none",noneProvider):providers))) formatterRules :: Rules () diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index 0d233f7a48..a7ff342085 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -46,9 +46,9 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- plugin :: Plugin c -plugin = Plugin exampleRules handlersExample +plugin = Plugin mempty exampleRules handlersExample -- <> codeActionPlugin codeAction - <> Plugin mempty handlersCodeLens + <> Plugin mempty mempty handlersCodeLens hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) hover = request "Hover" blah (Right Nothing) foundHover @@ -155,14 +155,14 @@ executeAddSignatureCommand :: LSP.LspFuncs c -> IdeState -> ExecuteCommandParams - -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..} | _command == "codelens.todo" , Just (List [edit]) <- _arguments , Success wedit <- fromJSON edit - = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) + = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) | otherwise - = return (Null, Nothing) + = return (Right Null, Nothing) -- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index 007eeafa92..1e873e7d2b 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -46,9 +46,9 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- plugin :: Plugin c -plugin = Plugin exampleRules handlersExample2 +plugin = Plugin mempty exampleRules handlersExample2 -- <> codeActionPlugin codeAction - <> Plugin mempty handlersCodeLens + <> Plugin mempty mempty handlersCodeLens hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) hover = request "Hover" blah (Right Nothing) foundHover @@ -156,14 +156,14 @@ executeAddSignatureCommand :: LSP.LspFuncs c -> IdeState -> ExecuteCommandParams - -> IO (Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..} | _command == "codelens.todo2" , Just (List [edit]) <- _arguments , Success wedit <- fromJSON edit - = return (Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) + = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) | otherwise - = return (Null, Nothing) + = return (Right Null, Nothing) -- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs new file mode 100644 index 0000000000..a390b8f5af --- /dev/null +++ b/src/Ide/Plugin/Pragmas.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides code actions to add missing pragmas (whenever GHC suggests to) +module Ide.Plugin.Pragmas + ( + codeAction + , commands + ) where + +import Control.Lens hiding (List) +import Data.Aeson +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import Ide.Plugin +import Ide.Types +import qualified GHC.Generics as Generics +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Lens as J + +import Development.IDE.Types.Diagnostics as D +import Language.Haskell.LSP.Types + +-- --------------------------------------------------------------------- + +_pragmasDescriptor :: PluginId -> PluginDescriptor +_pragmasDescriptor plId = PluginDescriptor + { pluginId = plId + -- , pluginName = "Add Missing Pragmas" + -- , pluginDesc = "Provide code actions to add missing pragmas when GHC suggests this" + , pluginCommands = + [ PluginCommand "addPragma" "add the given pragma" addPragmaCmd + ] + , pluginCodeActionProvider = Just codeActionProvider + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolProvider = Nothing + , pluginFormattingProvider = Nothing + } + +-- --------------------------------------------------------------------- + +commands :: [PluginCommand] +commands = [ PluginCommand "addPragma" "add the given pragma" addPragmaCmd + ] + +-- --------------------------------------------------------------------- + +-- | Parameters for the addPragma PluginCommand. +data AddPragmaParams = AddPragmaParams + { file :: J.Uri -- ^ Uri of the file to add the pragma to + , pragma :: T.Text -- ^ Name of the Pragma to add + } + deriving (Show, Eq, Generics.Generic, ToJSON, FromJSON) + +-- | Add a Pragma to the given URI at the top of the file. +-- Pragma is added to the first line of the Uri. +-- It is assumed that the pragma name is a valid pragma, +-- thus, not validated. +addPragmaCmd :: AddPragmaParams -> IO (Either ResponseError J.WorkspaceEdit) +addPragmaCmd (AddPragmaParams uri pragmaName) = do + let + pos = J.Position 0 0 + textEdits = J.List + [J.TextEdit (J.Range pos pos) + ("{-# LANGUAGE " <> pragmaName <> " #-}\n") + ] + res = J.WorkspaceEdit + (Just $ H.singleton uri textEdits) + Nothing + return $ Right res + +-- --------------------------------------------------------------------- + +codeAction :: CodeActionProvider +codeAction = codeActionProvider + +-- | Offer to add a missing Language Pragma to the top of a file. +-- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. +codeActionProvider :: CodeActionProvider +codeActionProvider _ plId docId _ (J.CodeActionContext (J.List diags) _monly) = do + cmds <- mapM mkCommand pragmas + return $ Right $ List cmds + where + -- Filter diagnostics that are from ghcmod + ghcDiags = filter (\d -> d ^. J.source == Just "bios") diags + -- Get all potential Pragmas for all diagnostics. + pragmas = concatMap (\d -> findPragma (d ^. J.message)) ghcDiags + mkCommand pragmaName = do + let + -- | Code Action for the given command. + codeAction :: J.Command -> J.CAResult + codeAction cmd = J.CACodeAction $ J.CodeAction title (Just J.CodeActionQuickFix) (Just (J.List [])) Nothing (Just cmd) + title = "Add \"" <> pragmaName <> "\"" + cmdParams = [toJSON (AddPragmaParams (docId ^. J.uri) pragmaName )] + cmd <- mkLspCommand plId "addPragma" title (Just cmdParams) + return $ codeAction cmd + +-- --------------------------------------------------------------------- + +-- | Find all Pragmas are an infix of the search term. +findPragma :: T.Text -> [T.Text] +findPragma str = concatMap check possiblePragmas + where + check p = [p | T.isInfixOf p str] + +-- --------------------------------------------------------------------- + +-- | Possible Pragma names. +-- Is non-exhaustive, and may be extended. +possiblePragmas :: [T.Text] +possiblePragmas = + [ + "ConstraintKinds" + , "DefaultSignatures" + , "DeriveAnyClass" + , "DeriveDataTypeable" + , "DeriveFoldable" + , "DeriveFunctor" + , "DeriveGeneric" + , "DeriveLift" + , "DeriveTraversable" + , "DerivingStrategies" + , "DerivingVia" + , "EmptyCase" + , "EmptyDataDecls" + , "EmptyDataDeriving" + , "FlexibleContexts" + , "FlexibleInstances" + , "GADTs" + , "GHCForeignImportPrim" + , "GeneralizedNewtypeDeriving" + , "IncoherentInstances" + , "InstanceSigs" + , "KindSignatures" + , "MultiParamTypeClasses" + , "MultiWayIf" + , "NamedFieldPuns" + , "NamedWildCards" + , "OverloadedStrings" + , "ParallelListComp" + , "PartialTypeSignatures" + , "PatternGuards" + , "PatternSignatures" + , "PatternSynonyms" + , "QuasiQuotes" + , "Rank2Types" + , "RankNTypes" + , "RecordPuns" + , "RecordWildCards" + , "RecursiveDo" + , "RelaxedPolyRec" + , "RoleAnnotations" + , "ScopedTypeVariables" + , "StandaloneDeriving" + , "StaticPointers" + , "TemplateHaskell" + , "TemplateHaskellQuotes" + , "TransformListComp" + , "TupleSections" + , "TypeApplications" + , "TypeFamilies" + , "TypeFamilyDependencies" + , "TypeInType" + , "TypeOperators" + , "TypeSynonymInstances" + , "UnboxedSums" + , "UndecidableInstances" + , "UndecidableSuperClasses" + , "ViewPatterns" + ] + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs index f1a2053e57..5a1b18f9d7 100644 --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -14,6 +14,7 @@ module Ide.Types , FormattingProvider , HoverProvider , CodeActionProvider + , ExecuteCommandProvider ) where import Data.Aeson hiding (defaultOptions) @@ -21,8 +22,9 @@ import qualified Data.Map as Map import qualified Data.Set as S import Data.String import qualified Data.Text as T -import Data.Typeable +-- import Data.Typeable import Development.IDE.Core.Rules +import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Language.Haskell.LSP.Types @@ -46,19 +48,19 @@ data PluginDescriptor = , pluginFormattingProvider :: Maybe (FormattingProvider IO) } -instance Show PluginCommand where - show (PluginCommand i _ _) = "PluginCommand { name = " ++ show i ++ " }" +-- instance Show PluginCommand where +-- show (PluginCommand i _ _) = "PluginCommand { name = " ++ show i ++ " }" -newtype CommandId = CommandId T.Text - deriving (Show, Read, Eq, Ord) -instance IsString CommandId where - fromString = CommandId . T.pack +-- newtype CommandId = CommandId T.Text +-- deriving (Show, Read, Eq, Ord) +-- instance IsString CommandId where +-- fromString = CommandId . T.pack -data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => - PluginCommand { commandId :: CommandId - , commandDesc :: T.Text - , commandFunc :: a -> IO (Either ResponseError b) - } +-- data PluginCommand = forall a b. (FromJSON a, ToJSON b, Typeable b) => +-- PluginCommand { commandId :: CommandId +-- , commandDesc :: T.Text +-- , commandFunc :: a -> IO (Either ResponseError b) +-- } -- --------------------------------------------------------------------- @@ -98,6 +100,10 @@ type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either Respon type SymbolProvider = Uri -> IO (Either ResponseError [DocumentSymbol]) +type ExecuteCommandProvider = IdeState + -> ExecuteCommandParams + -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + -- --------------------------------------------------------------------- newtype PluginId = PluginId T.Text From 5bae0dd9a2569436d74e812d9d67f81700cfbbd6 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 3 Mar 2020 22:53:28 +0000 Subject: [PATCH 05/25] Rebase ghcide changes, and match in hls branch --- cabal.project | 2 +- exe/Main.hs | 48 ++++++++++++++++------------------- exe/RuleTypes.hs | 34 +++++++++++++++++++++++++ ghcide | 2 +- haskell-language-server.cabal | 1 + 5 files changed, 59 insertions(+), 28 deletions(-) create mode 100644 exe/RuleTypes.hs diff --git a/cabal.project b/cabal.project index 6c5b39f913..92e6aaa60b 100644 --- a/cabal.project +++ b/cabal.project @@ -16,4 +16,4 @@ package ghcide write-ghc-environment-files: never -index-state: 2020-02-09T06:58:05Z +index-state: 2020-03-03T21:14:55Z diff --git a/exe/Main.hs b/exe/Main.hs index f786ab147e..a4ba871001 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -12,18 +12,15 @@ module Main(main) where import Arguments import Control.Concurrent.Extra -import Control.DeepSeq (NFData) import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class import qualified Crypto.Hash.SHA1 as H -import Data.Binary (Binary) import Data.ByteString.Base16 import qualified Data.ByteString.Char8 as B import Data.Default -import Data.Dynamic (Typeable) +import Data.Functor ((<&>)) import qualified Data.HashSet as HashSet -import Data.Hashable (Hashable) import Data.List.Extra import qualified Data.Map.Strict as Map import Data.Maybe @@ -46,10 +43,9 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options -import Development.Shake (Action, RuleResult, Rules, action, doesFileExist, need) +import Development.Shake (Action, Rules, action, doesFileExist, doesDirectoryExist, need) import DynFlags import GHC hiding (def) -import GHC.Generics (Generic) -- import qualified GHC.Paths import HIE.Bios import HIE.Bios.Cradle @@ -63,6 +59,7 @@ import Language.Haskell.LSP.Types (LspId(IdInt)) import qualified Language.Haskell.LSP.Core as LSP import Linker -- import Paths_haskell_language_server +import RuleTypes import qualified System.Directory.Extra as IO -- import System.Environment import System.Exit @@ -152,7 +149,7 @@ main = do , optShakeProfiling = argsShakeProfiling } debouncer <- newAsyncDebouncer - initialise caps (loadGhcSessionIO >> mainRule >> pluginRules plugins >> action kick) + initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick) getLspId event (logger minBound) debouncer options vfs else do putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "." @@ -189,7 +186,7 @@ main = do let options = (defaultIdeOptions $ return $ return . grab) { optShakeProfiling = argsShakeProfiling } - ide <- initialise def (loadGhcSessionIO >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs + ide <- initialise def (cradleRules >> mainRule) (pure $ IdInt 0) (showEvent lock) (logger Info) noopDebouncer options vfs putStrLn "\nStep 6/6: Type checking the files" setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath files @@ -203,6 +200,10 @@ main = do unless (null failed) exitFailure +cradleRules :: Rules () +cradleRules = do + loadGhcSessionIO + cradleToSession expandFiles :: [FilePath] -> IO [FilePath] expandFiles = concatMapM $ \x -> do @@ -230,19 +231,6 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) = showEvent lock e = withLock lock $ print e --- Rule type for caching GHC sessions. -type instance RuleResult GetHscEnv = HscEnvEq - -data GetHscEnv = GetHscEnv - { hscenvOptions :: [String] -- componentOptions from hie-bios - , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios - } - deriving (Eq, Show, Typeable, Generic) -instance Hashable GetHscEnv -instance NFData GetHscEnv -instance Binary GetHscEnv - - loadGhcSessionIO :: Rules () loadGhcSessionIO = -- This rule is for caching the GHC session. E.g., even when the cabal file @@ -255,6 +243,7 @@ loadGhcSessionIO = getComponentOptions :: Cradle a -> IO ComponentOptions getComponentOptions cradle = do let showLine s = putStrLn ("> " ++ s) + -- WARNING 'runCradle is very expensive and must be called as few times as possible cradleRes <- runCradle (cradleOptsProg cradle) showLine "" case cradleRes of CradleSuccess r -> pure r @@ -310,8 +299,14 @@ setHiDir f d = -- override user settings to avoid conflicts leading to recompilation d { hiDir = Just f} -cradleToSession :: Maybe FilePath -> Cradle a -> Action HscEnvEq -cradleToSession mbYaml cradle = do +cradleToSession :: Rules () +cradleToSession = define $ \LoadCradle nfp -> do + let f = fromNormalizedFilePath nfp + + -- If the path points to a directory, load the implicit cradle + mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f + cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml + cmpOpts <- liftIO $ getComponentOptions cradle let opts = componentOptions cmpOpts deps = componentDependencies cmpOpts @@ -321,7 +316,7 @@ cradleToSession mbYaml cradle = do _ -> deps existingDeps <- filterM doesFileExist deps' need existingDeps - useNoFile_ $ GetHscEnv opts deps + ([],) . pure <$> useNoFile_ (GetHscEnv opts deps) loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq) @@ -335,8 +330,9 @@ loadSession dir = liftIO $ do return $ normalise <$> res' let session :: Maybe FilePath -> Action HscEnvEq session file = do - c <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator dir) loadCradle file - cradleToSession file c + -- In the absence of a cradle file, just pass the directory from where to calculate an implicit cradle + let cradle = toNormalizedFilePath $ fromMaybe dir file + use_ LoadCradle cradle return $ \file -> session =<< liftIO (cradleLoc file) diff --git a/exe/RuleTypes.hs b/exe/RuleTypes.hs new file mode 100644 index 0000000000..8520eaa44a --- /dev/null +++ b/exe/RuleTypes.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +module RuleTypes (GetHscEnv(..), LoadCradle(..)) where + +import Control.DeepSeq +import Data.Binary +import Data.Hashable (Hashable) +import Development.Shake +import Development.IDE.GHC.Util +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + +-- Rule type for caching GHC sessions. +type instance RuleResult GetHscEnv = HscEnvEq + +data GetHscEnv = GetHscEnv + { hscenvOptions :: [String] -- componentOptions from hie-bios + , hscenvDependencies :: [FilePath] -- componentDependencies from hie-bios + } + deriving (Eq, Show, Typeable, Generic) + +instance Hashable GetHscEnv +instance NFData GetHscEnv +instance Binary GetHscEnv + +-- Rule type for caching cradle loading +type instance RuleResult LoadCradle = HscEnvEq + +data LoadCradle = LoadCradle + deriving (Eq, Show, Typeable, Generic) + +instance Hashable LoadCradle +instance NFData LoadCradle +instance Binary LoadCradle diff --git a/ghcide b/ghcide index b98b101f87..66900802b9 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit b98b101f87113f96f360d5eadda1125a16b88a12 +Subproject commit 66900802b9e86ad941d863d862683aa5b972425b diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index fc45963dc3..6eb99d7496 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -92,6 +92,7 @@ executable haskell-language-server other-modules: Arguments Paths_haskell_language_server + RuleTypes autogen-modules: Paths_haskell_language_server ghc-options: From 90aae363f13450d6566eef921d78205960ecedd3 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 4 Mar 2020 22:31:56 +0000 Subject: [PATCH 06/25] WIP. Using plugin descriptors, and combining them. Proof of concept, seems to work in big pieces, needs huge amount of cleanup. --- exe/Main.hs | 49 ++++++++++++++++++++++++++++++++----- src/Ide/Plugin.hs | 46 +++++++++++++++++++++++----------- src/Ide/Plugin/Example.hs | 24 +++++++++++++++--- src/Ide/Plugin/Example2.hs | 18 +++++++++++++- src/Ide/Plugin/Floskell.hs | 18 +++++++++++++- src/Ide/Plugin/Formatter.hs | 8 +++--- src/Ide/Plugin/Ormolu.hs | 18 +++++++++++++- src/Ide/Plugin/Pragmas.hs | 4 +-- src/Ide/Types.hs | 26 ++++++++++++++------ 9 files changed, 170 insertions(+), 41 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index a4ba871001..b3cb91757a 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -52,6 +52,7 @@ import HIE.Bios.Cradle import HIE.Bios.Environment import HIE.Bios.Types import Ide.Plugin +-- import Ide.PluginDescriptors import Ide.Plugin.Config -- import Ide.Plugin.Formatter import Language.Haskell.LSP.Messages @@ -79,12 +80,16 @@ import Ide.Plugin.Pragmas as Pragmas -- --------------------------------------------------------------------- --- The plugins configured for use in this instance of the language +-- | TODO: these should come out of something like asGhcIdePlugin +commandIds :: T.Text -> [T.Text] +commandIds pid = "typesignature.add" : allLspCmdIds pid [("pragmas", Pragmas.commands)] + +-- | The plugins configured for use in this instance of the language -- server. -- These can be freely added or removed to tailor the available -- features of the server. -idePlugins :: Bool -> Plugin Config -idePlugins includeExample +_idePlugins :: Bool -> Plugin Config +_idePlugins includeExample = Completions.plugin <> CodeAction.plugin <> formatterPlugins [("ormolu", Ormolu.provider) @@ -93,12 +98,44 @@ idePlugins includeExample ,("eg2", Example2.codeAction) ,("pragmas", Pragmas.codeAction)] <> executeCommandPlugins [("pragmas", Pragmas.commands)] <> - hoverPlugins [Example.hover, Example2.hover] <> + hoverPlugins [("eg", Example.hover) + ,("eg2", Example2.hover)] <> if includeExample then Example.plugin <> Example2.plugin else mempty -commandIds :: T.Text -> [T.Text] -commandIds pid = "typesignature.add" : allLspCmdIds pid [("pragmas", Pragmas.commands)] + +-- | The plugins configured for use in this instance of the language +-- server. +-- These can be freely added or removed to tailor the available +-- features of the server. +idePlugins :: Bool -> Plugin Config +idePlugins includeExamples + = asGhcIdePlugin $ pluginDescToIdePlugins allPlugins + where + allPlugins = if includeExamples + then basePlugins ++ examplePlugins + else basePlugins + basePlugins = + [ + -- applyRefactDescriptor "applyrefact" + -- , brittanyDescriptor "brittany" + -- , haddockDescriptor "haddock" + -- -- , hareDescriptor "hare" + -- , hsimportDescriptor "hsimport" + -- , liquidDescriptor "liquid" + -- , packageDescriptor "package" + -- , pragmasDescriptor "pragmas" + Floskell.descriptor "floskell" + -- , genericDescriptor "generic" + -- , ghcmodDescriptor "ghcmod" + , Ormolu.descriptor "ormolu" + ] + examplePlugins = + [Example.descriptor "eg" + ,Example2.descriptor "eg2" + -- ,hfaAlignDescriptor "hfaa" + ] + -- --------------------------------------------------------------------- -- Prefix for the cache path diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs index 670eb9d952..3ed46eb895 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -10,6 +10,7 @@ module Ide.Plugin ( asGhcIdePlugin + , pluginDescToIdePlugins , formatterPlugins , hoverPlugins , codeActionPlugins @@ -29,7 +30,7 @@ import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.LSP.Server -import Development.IDE.Plugin +import Development.IDE.Plugin hiding (pluginCommands) import Development.IDE.Types.Diagnostics as D import Development.Shake hiding ( Diagnostic, command ) import GHC.Generics @@ -42,7 +43,6 @@ import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Capabilities as C --- import qualified Language.Haskell.LSP.Types.Lens as J import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) import Text.Regex.TDFA.Text() @@ -52,32 +52,50 @@ import Text.Regex.TDFA.Text() -- IdePlugins are arranged by kind of operation, 'Plugin' is arranged by message -- category ('Notifaction', 'Request' etc). asGhcIdePlugin :: IdePlugins -> Plugin Config -asGhcIdePlugin _ = Plugin mempty mempty mempty +asGhcIdePlugin mp = + mkPlugin executeCommandPlugins (Just . pluginCommands) <> + mkPlugin codeActionPlugins pluginCodeActionProvider <> + -- diagnostics from pluginDiagnosticProvider + mkPlugin hoverPlugins pluginHoverProvider <> + -- symbols via pluginSymbolProvider + mkPlugin formatterPlugins pluginFormattingProvider + -- completions + where + justs (p, Just x) = [(p, x)] + justs (_, Nothing) = [] --- First strp will be to bring the machinery from Ide.Plugin.Formatter over. + ls = Map.toList (ipMap mp) + + mkPlugin :: ([(PluginId, b)] -> t) -> (PluginDescriptor -> Maybe b) -> t + mkPlugin maker selector + = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls + + +pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins +pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins -- --------------------------------------------------------------------- -codeActionPlugins :: [(T.Text, CodeActionProvider)] -> Plugin Config +codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config codeActionPlugins cas = Plugin mempty codeActionRules (codeActionHandlers cas) codeActionRules :: Rules () codeActionRules = mempty -codeActionHandlers :: [(T.Text, CodeActionProvider)] -> PartialHandlers Config +codeActionHandlers :: [(PluginId, CodeActionProvider)] -> PartialHandlers Config codeActionHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x { LSP.codeActionHandler = withResponse RspCodeAction (makeCodeAction cas) } -makeCodeAction :: [(T.Text, CodeActionProvider)] +makeCodeAction :: [(PluginId, CodeActionProvider)] -> LSP.LspFuncs Config -> IdeState -> CodeActionParams -> IO (Either ResponseError (List CAResult)) makeCodeAction cas lf ideState (CodeActionParams docId range context _) = do let caps = LSP.clientCapabilities lf unL (List ls) = ls - r <- mapM (\(pid,provider) -> provider ideState (PluginId pid) docId range context) cas + r <- mapM (\(pid,provider) -> provider ideState pid docId range context) cas let actions = filter wasRequested . concat $ map unL $ rights r res <- send caps actions return $ Right res @@ -295,23 +313,23 @@ allLspCmdIds pid commands = concat $ map go commands -- --------------------------------------------------------------------- -hoverPlugins :: [HoverProvider] -> Plugin Config +hoverPlugins :: [(PluginId, HoverProvider)] -> Plugin Config hoverPlugins hs = Plugin mempty hoverRules (hoverHandlers hs) hoverRules :: Rules () hoverRules = mempty -hoverHandlers :: [HoverProvider] -> PartialHandlers Config +hoverHandlers :: [(PluginId, HoverProvider)] -> PartialHandlers Config hoverHandlers hps = PartialHandlers $ \WithMessage{..} x -> return x{LSP.hoverHandler = withResponse RspHover (makeHover hps)} -makeHover :: [HoverProvider] +makeHover :: [(PluginId, HoverProvider)] -> LSP.LspFuncs Config -> IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) makeHover hps _lf ideState params = do - mhs <- mapM (\p -> p ideState params) hps + mhs <- mapM (\(_,p) -> p ideState params) hps -- TODO: We should support ServerCapabilities and declare that -- we don't support hover requests during initialization if we -- don't have any hover providers @@ -327,7 +345,7 @@ makeHover hps _lf ideState params -- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -formatterPlugins :: [(T.Text, FormattingProvider IO)] -> Plugin Config +formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config formatterPlugins providers = Plugin mempty formatterRules @@ -336,7 +354,7 @@ formatterPlugins providers formatterRules :: Rules () formatterRules = mempty -formatterHandlers :: Map.Map T.Text (FormattingProvider IO) -> PartialHandlers Config +formatterHandlers :: Map.Map PluginId (FormattingProvider IO) -> PartialHandlers Config formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x { LSP.documentFormattingHandler = withResponse RspDocumentFormatting (formatting providers) diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index a7ff342085..a4a447ba50 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -10,7 +10,8 @@ module Ide.Plugin.Example ( - plugin + descriptor + , plugin , hover , codeAction ) where @@ -21,13 +22,13 @@ import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) import Data.Binary import Data.Functor import qualified Data.HashMap.Strict as Map -import Data.Hashable import qualified Data.HashSet as HashSet +import Data.Hashable import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.OfInterest -import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.IDE.LSP.Server @@ -36,8 +37,8 @@ import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.Shake hiding ( Diagnostic ) -import Ide.Types import GHC.Generics +import Ide.Types import qualified Language.Haskell.LSP.Core as LSP import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types @@ -45,6 +46,21 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor + { pluginId = plId + , pluginRules = exampleRules + , pluginCommands = [] + , pluginCodeActionProvider = Just codeAction + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Just hover + , pluginSymbolProvider = Nothing + , pluginFormattingProvider = Nothing + , pluginCompletionProvider = Nothing + } + +-- --------------------------------------------------------------------- + plugin :: Plugin c plugin = Plugin mempty exampleRules handlersExample -- <> codeActionPlugin codeAction diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index 1e873e7d2b..987dccdc79 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -10,7 +10,8 @@ module Ide.Plugin.Example2 ( - plugin + descriptor + , plugin , hover , codeAction ) where @@ -45,6 +46,21 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor + { pluginId = plId + , pluginRules = exampleRules + , pluginCommands = [] + , pluginCodeActionProvider = Just codeAction + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Just hover + , pluginSymbolProvider = Nothing + , pluginFormattingProvider = Nothing + , pluginCompletionProvider = Nothing + } + +-- --------------------------------------------------------------------- + plugin :: Plugin c plugin = Plugin mempty exampleRules handlersExample2 -- <> codeActionPlugin codeAction diff --git a/src/Ide/Plugin/Floskell.hs b/src/Ide/Plugin/Floskell.hs index 5531888619..49577742b0 100644 --- a/src/Ide/Plugin/Floskell.hs +++ b/src/Ide/Plugin/Floskell.hs @@ -7,7 +7,8 @@ module Ide.Plugin.Floskell ( - provider + descriptor + , provider ) where @@ -24,6 +25,21 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor + { pluginId = plId + , pluginRules = mempty + , pluginCommands = [] + , pluginCodeActionProvider = Nothing + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolProvider = Nothing + , pluginFormattingProvider = Just provider + , pluginCompletionProvider = Nothing + } + +-- --------------------------------------------------------------------- + -- | Format provider of Floskell. -- Formats the given source in either a given Range or the whole Document. -- If the provider fails an error is returned that can be displayed to the user. diff --git a/src/Ide/Plugin/Formatter.hs b/src/Ide/Plugin/Formatter.hs index 747d8a4827..a5a90f564d 100644 --- a/src/Ide/Plugin/Formatter.hs +++ b/src/Ide/Plugin/Formatter.hs @@ -34,7 +34,7 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- -formatting :: Map.Map T.Text (FormattingProvider IO) +formatting :: Map.Map PluginId (FormattingProvider IO) -> LSP.LspFuncs Config -> IdeState -> DocumentFormattingParams -> IO (Either ResponseError (List TextEdit)) formatting providers lf ideState @@ -43,7 +43,7 @@ formatting providers lf ideState -- --------------------------------------------------------------------- -rangeFormatting :: Map.Map T.Text (FormattingProvider IO) +rangeFormatting :: Map.Map PluginId (FormattingProvider IO) -> LSP.LspFuncs Config -> IdeState -> DocumentRangeFormattingParams -> IO (Either ResponseError (List TextEdit)) rangeFormatting providers lf ideState @@ -52,13 +52,13 @@ rangeFormatting providers lf ideState -- --------------------------------------------------------------------- -doFormatting :: LSP.LspFuncs Config -> Map.Map T.Text (FormattingProvider IO) +doFormatting :: LSP.LspFuncs Config -> Map.Map PluginId (FormattingProvider IO) -> IdeState -> FormattingType -> Uri -> FormattingOptions -> IO (Either ResponseError (List TextEdit)) doFormatting lf providers ideState ft uri params = do mc <- LSP.config lf let mf = maybe "none" formattingProvider mc - case Map.lookup mf providers of + case Map.lookup (PluginId mf) providers of Just provider -> case uriToFilePath uri of Just (toNormalizedFilePath -> fp) -> do diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index 7343ac1edd..304e435e1c 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -7,7 +7,8 @@ module Ide.Plugin.Ormolu ( - provider + descriptor + , provider ) where @@ -32,6 +33,21 @@ import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor + { pluginId = plId + , pluginRules = mempty + , pluginCommands = [] + , pluginCodeActionProvider = Nothing + , pluginDiagnosticProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolProvider = Nothing + , pluginFormattingProvider = Just provider + , pluginCompletionProvider = Nothing + } + +-- --------------------------------------------------------------------- + provider :: FormattingProvider IO #if __GLASGOW_HASKELL__ >= 806 provider ideState typ contents fp _ = do diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs index a390b8f5af..f0972510a9 100644 --- a/src/Ide/Plugin/Pragmas.hs +++ b/src/Ide/Plugin/Pragmas.hs @@ -27,8 +27,7 @@ import Language.Haskell.LSP.Types _pragmasDescriptor :: PluginId -> PluginDescriptor _pragmasDescriptor plId = PluginDescriptor { pluginId = plId - -- , pluginName = "Add Missing Pragmas" - -- , pluginDesc = "Provide code actions to add missing pragmas when GHC suggests this" + , pluginRules = mempty , pluginCommands = [ PluginCommand "addPragma" "add the given pragma" addPragmaCmd ] @@ -37,6 +36,7 @@ _pragmasDescriptor plId = PluginDescriptor , pluginHoverProvider = Nothing , pluginSymbolProvider = Nothing , pluginFormattingProvider = Nothing + , pluginCompletionProvider = Nothing } -- --------------------------------------------------------------------- diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs index 5a1b18f9d7..d718b76af0 100644 --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -15,6 +15,7 @@ module Ide.Types , HoverProvider , CodeActionProvider , ExecuteCommandProvider + , CompletionProvider ) where import Data.Aeson hiding (defaultOptions) @@ -22,11 +23,12 @@ import qualified Data.Map as Map import qualified Data.Set as S import Data.String import qualified Data.Text as T --- import Data.Typeable import Development.IDE.Core.Rules import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location +import Development.Shake +-- import Development.Shake.Classes import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() @@ -39,13 +41,17 @@ newtype IdePlugins = IdePlugins -- --------------------------------------------------------------------- data PluginDescriptor = - PluginDescriptor { pluginId :: PluginId - , pluginCommands :: [PluginCommand] - , pluginCodeActionProvider :: Maybe CodeActionProvider - , pluginDiagnosticProvider :: Maybe DiagnosticProvider - , pluginHoverProvider :: Maybe HoverProvider - , pluginSymbolProvider :: Maybe SymbolProvider - , pluginFormattingProvider :: Maybe (FormattingProvider IO) + PluginDescriptor { pluginId :: !PluginId + , pluginRules :: !(Rules ()) + , pluginCommands :: ![PluginCommand] + , pluginCodeActionProvider :: !(Maybe CodeActionProvider) + , pluginDiagnosticProvider :: !(Maybe DiagnosticProvider) + -- ^ TODO: diagnostics are generally provided via rules, + -- this is probably redundant. + , pluginHoverProvider :: !(Maybe HoverProvider) + , pluginSymbolProvider :: !(Maybe SymbolProvider) + , pluginFormattingProvider :: !(Maybe (FormattingProvider IO)) + , pluginCompletionProvider :: !(Maybe CompletionProvider) } -- instance Show PluginCommand where @@ -104,6 +110,10 @@ type ExecuteCommandProvider = IdeState -> ExecuteCommandParams -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) +type CompletionProvider = IdeState + -> CompletionParams + -> IO (Either ResponseError CompletionResponseResult) + -- --------------------------------------------------------------------- newtype PluginId = PluginId T.Text From 7dbfb9754bf771c9370781bbc9eb48f2e260c839 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 4 Mar 2020 23:41:15 +0000 Subject: [PATCH 07/25] Rebase against ghcide, in the hope of getting it to work. Currently (for me) neither ghcide nor haskell-language-server can resolve a simple project. Assume some sort of underlying hie-bios issue, will wait. --- exe/Arguments.hs | 7 +- exe/Main.hs | 121 ++++---------------------- exe/Rules.hs | 156 ++++++++++++++++++++++++++++++++++ ghcide | 2 +- haskell-language-server.cabal | 2 + 5 files changed, 182 insertions(+), 106 deletions(-) create mode 100644 exe/Rules.hs diff --git a/exe/Arguments.hs b/exe/Arguments.hs index 926b9b7b54..67ff564a54 100644 --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -30,6 +30,7 @@ data Arguments = Arguments ,argFiles :: [FilePath] ,argsVersion :: Bool ,argsShakeProfiling :: Maybe FilePath + ,argsTesting :: Bool ,argsExamplePlugin :: Bool } @@ -45,12 +46,14 @@ arguments :: String -> Parser Arguments arguments exeName = Arguments <$> switch (long "lsp" <> help "Start talking to an LSP server") <*> optional (strOption $ long "cwd" <> metavar "DIR" - <> help "Change to this directory") + <> help "Change to this directory") <*> many (argument str (metavar "FILES/DIRS...")) <*> switch (long "version" <> help ("Show " ++ exeName ++ " and GHC versions")) <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" - <> help "Dump profiling reports to this directory") + <> help "Dump profiling reports to this directory") + <*> switch (long "test" + <> help "Enable additional lsp messages used by the testsuite") <*> switch (long "example" <> help "Include the Example Plugin. For Plugin devs only") diff --git a/exe/Main.hs b/exe/Main.hs index b3cb91757a..251304c77b 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -15,11 +15,11 @@ import Control.Concurrent.Extra import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class -import qualified Crypto.Hash.SHA1 as H -import Data.ByteString.Base16 -import qualified Data.ByteString.Char8 as B +-- import qualified Crypto.Hash.SHA1 as H +-- import Data.ByteString.Base16 +-- import qualified Data.ByteString.Char8 as B import Data.Default -import Data.Functor ((<&>)) +-- import Data.Functor ((<&>)) import qualified Data.HashSet as HashSet import Data.List.Extra import qualified Data.Map.Strict as Map @@ -43,24 +43,26 @@ import Development.IDE.Types.Diagnostics import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options -import Development.Shake (Action, Rules, action, doesFileExist, doesDirectoryExist, need) -import DynFlags -import GHC hiding (def) +import Development.Shake (Action, Rules, action) +-- import DynFlags +-- import GHC hiding (def) -- import qualified GHC.Paths import HIE.Bios -import HIE.Bios.Cradle -import HIE.Bios.Environment -import HIE.Bios.Types +import qualified Language.Haskell.LSP.Core as LSP +-- import HIE.Bios.Cradle +-- import HIE.Bios.Environment +-- import HIE.Bios.Types import Ide.Plugin -- import Ide.PluginDescriptors import Ide.Plugin.Config -- import Ide.Plugin.Formatter import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types (LspId(IdInt)) -import qualified Language.Haskell.LSP.Core as LSP -import Linker +-- import qualified Language.Haskell.LSP.Core as LSP +-- import Linker -- import Paths_haskell_language_server import RuleTypes +import Rules import qualified System.Directory.Extra as IO -- import System.Environment import System.Exit @@ -139,6 +141,7 @@ idePlugins includeExamples -- --------------------------------------------------------------------- -- Prefix for the cache path +{- cacheDir :: String cacheDir = "ghcide" @@ -148,7 +151,7 @@ getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir opts_hash) -- Create a unique folder per set of different GHC options, assuming that each different set of -- GHC options will create incompatible interface files. opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts) - +-} main :: IO () main = do @@ -184,6 +187,7 @@ main = do let options = (defaultIdeOptions $ loadSession dir) { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling + , optTesting = IdeTesting argsTesting } debouncer <- newAsyncDebouncer initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick) @@ -239,7 +243,7 @@ main = do cradleRules :: Rules () cradleRules = do - loadGhcSessionIO + loadGhcSession cradleToSession expandFiles :: [FilePath] -> IO [FilePath] @@ -267,95 +271,6 @@ showEvent lock (EventFileDiagnostics (toNormalizedFilePath -> file) diags) = withLock lock $ T.putStrLn $ showDiagnosticsColored $ map (file,ShowDiag,) diags showEvent lock e = withLock lock $ print e - -loadGhcSessionIO :: Rules () -loadGhcSessionIO = - -- This rule is for caching the GHC session. E.g., even when the cabal file - -- changed, if the resulting flags did not change, we would continue to use - -- the existing session. - defineNoFile $ \(GetHscEnv opts deps) -> - liftIO $ createSession $ ComponentOptions opts deps - - -getComponentOptions :: Cradle a -> IO ComponentOptions -getComponentOptions cradle = do - let showLine s = putStrLn ("> " ++ s) - -- WARNING 'runCradle is very expensive and must be called as few times as possible - cradleRes <- runCradle (cradleOptsProg cradle) showLine "" - case cradleRes of - CradleSuccess r -> pure r - CradleFail err -> throwIO err - -- TODO Rather than failing here, we should ignore any files that use this cradle. - -- That will require some more changes. - CradleNone -> fail "'none' cradle is not yet supported" - - -createSession :: ComponentOptions -> IO HscEnvEq -createSession (ComponentOptions theOpts _) = do - libdir <- getLibdir - - cacheDir <- Main.getCacheDir theOpts - - env <- runGhc (Just libdir) $ do - dflags <- getSessionDynFlags - (dflags', _targets) <- addCmdOpts theOpts dflags - _ <- setSessionDynFlags $ - -- disabled, generated directly by ghcide instead - flip gopt_unset Opt_WriteInterface $ - -- disabled, generated directly by ghcide instead - -- also, it can confuse the interface stale check - dontWriteHieFiles $ - setHiDir cacheDir $ - setDefaultHieDir cacheDir $ - setIgnoreInterfacePragmas $ - setLinkerOptions $ - disableOptimisation dflags' - getSession - initDynLinker env - newHscEnvEq env - --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscNothing - , ghcMode = CompManager - } - -setIgnoreInterfacePragmas :: DynFlags -> DynFlags -setIgnoreInterfacePragmas df = - gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges - -disableOptimisation :: DynFlags -> DynFlags -disableOptimisation df = updOptLevel 0 df - -setHiDir :: FilePath -> DynFlags -> DynFlags -setHiDir f d = - -- override user settings to avoid conflicts leading to recompilation - d { hiDir = Just f} - -cradleToSession :: Rules () -cradleToSession = define $ \LoadCradle nfp -> do - let f = fromNormalizedFilePath nfp - - -- If the path points to a directory, load the implicit cradle - mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f - cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml - - cmpOpts <- liftIO $ getComponentOptions cradle - let opts = componentOptions cmpOpts - deps = componentDependencies cmpOpts - deps' = case mbYaml of - -- For direct cradles, the hie.yaml file itself must be watched. - Just yaml | isDirectCradle cradle -> yaml : deps - _ -> deps - existingDeps <- filterM doesFileExist deps' - need existingDeps - ([],) . pure <$> useNoFile_ (GetHscEnv opts deps) - - loadSession :: FilePath -> Action (FilePath -> Action HscEnvEq) loadSession dir = liftIO $ do cradleLoc <- memoIO $ \v -> do diff --git a/exe/Rules.hs b/exe/Rules.hs new file mode 100644 index 0000000000..3039327867 --- /dev/null +++ b/exe/Rules.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module Rules + ( loadGhcSession + , cradleToSession + , cradleLoadedMethod + , createSession + , getComponentOptions + ) +where + +import Control.Exception +import Control.Monad (filterM, when) +import qualified Crypto.Hash.SHA1 as H +import Data.ByteString.Base16 (encode) +import qualified Data.ByteString.Char8 as B +import Data.Functor ((<&>)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Development.IDE.Core.Rules (defineNoFile) +import Development.IDE.Core.Shake (ShakeExtras(ShakeExtras,isTesting), getShakeExtras, sendEvent, define, useNoFile_) +import Development.IDE.GHC.Util +import Development.IDE.Types.Location (fromNormalizedFilePath) +import Development.Shake +import DynFlags (gopt_set, gopt_unset, + updOptLevel) +import GHC +import qualified GHC.Paths +import HIE.Bios +import HIE.Bios.Cradle +import HIE.Bios.Environment (addCmdOpts) +import HIE.Bios.Types +import Linker (initDynLinker) +import RuleTypes +import qualified System.Directory.Extra as IO +import System.Environment (lookupEnv) +import System.FilePath.Posix (addTrailingPathSeparator, + ()) +import Language.Haskell.LSP.Messages as LSP +import Language.Haskell.LSP.Types as LSP +import Data.Aeson (ToJSON(toJSON)) + +-- Prefix for the cache path +cacheDir :: String +cacheDir = "ghcide" + +notifyCradleLoaded :: FilePath -> LSP.FromServerMessage +notifyCradleLoaded fp = + LSP.NotCustomServer $ + LSP.NotificationMessage "2.0" (LSP.CustomServerMethod cradleLoadedMethod) $ + toJSON fp + +loadGhcSession :: Rules () +loadGhcSession = + -- This rule is for caching the GHC session. E.g., even when the cabal file + -- changed, if the resulting flags did not change, we would continue to use + -- the existing session. + defineNoFile $ \(GetHscEnv opts deps) -> + liftIO $ createSession $ ComponentOptions opts deps + +cradleToSession :: Rules () +cradleToSession = define $ \LoadCradle nfp -> do + let f = fromNormalizedFilePath nfp + + ShakeExtras{isTesting} <- getShakeExtras + + -- If the path points to a directory, load the implicit cradle + mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f + cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml + + when isTesting $ + sendEvent $ notifyCradleLoaded f + + cmpOpts <- liftIO $ getComponentOptions cradle + let opts = componentOptions cmpOpts + deps = componentDependencies cmpOpts + deps' = case mbYaml of + -- For direct cradles, the hie.yaml file itself must be watched. + Just yaml | isDirectCradle cradle -> yaml : deps + _ -> deps + existingDeps <- filterM doesFileExist deps' + need existingDeps + ([],) . pure <$> useNoFile_ (GetHscEnv opts deps) + +cradleLoadedMethod :: Text +cradleLoadedMethod = "ghcide/cradle/loaded" + +getComponentOptions :: Cradle a -> IO ComponentOptions +getComponentOptions cradle = do + let showLine s = putStrLn ("> " ++ s) + -- WARNING 'runCradle is very expensive and must be called as few times as possible + cradleRes <- runCradle (cradleOptsProg cradle) showLine "" + case cradleRes of + CradleSuccess r -> pure r + CradleFail err -> throwIO err + -- TODO Rather than failing here, we should ignore any files that use this cradle. + -- That will require some more changes. + CradleNone -> fail "'none' cradle is not yet supported" + +createSession :: ComponentOptions -> IO HscEnvEq +createSession (ComponentOptions theOpts _) = do + libdir <- getLibdir + + cacheDir <- getCacheDir theOpts + + env <- runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + (dflags', _targets) <- addCmdOpts theOpts dflags + _ <- setSessionDynFlags $ + -- disabled, generated directly by ghcide instead + flip gopt_unset Opt_WriteInterface $ + -- disabled, generated directly by ghcide instead + -- also, it can confuse the interface stale check + dontWriteHieFiles $ + setHiDir cacheDir $ + setDefaultHieDir cacheDir $ + setIgnoreInterfacePragmas $ + setLinkerOptions $ + disableOptimisation dflags' + getSession + initDynLinker env + newHscEnvEq env + +-- Set the GHC libdir to the nix libdir if it's present. +getLibdir :: IO FilePath +getLibdir = fromMaybe GHC.Paths.libdir <$> lookupEnv "NIX_GHC_LIBDIR" + +-- we don't want to generate object code so we compile to bytecode +-- (HscInterpreted) which implies LinkInMemory +-- HscInterpreted +setLinkerOptions :: DynFlags -> DynFlags +setLinkerOptions df = df { + ghcLink = LinkInMemory + , hscTarget = HscNothing + , ghcMode = CompManager + } + +setIgnoreInterfacePragmas :: DynFlags -> DynFlags +setIgnoreInterfacePragmas df = + gopt_set (gopt_set df Opt_IgnoreInterfacePragmas) Opt_IgnoreOptimChanges + +disableOptimisation :: DynFlags -> DynFlags +disableOptimisation df = updOptLevel 0 df + +setHiDir :: FilePath -> DynFlags -> DynFlags +setHiDir f d = + -- override user settings to avoid conflicts leading to recompilation + d { hiDir = Just f} + +getCacheDir :: [String] -> IO FilePath +getCacheDir opts = IO.getXdgDirectory IO.XdgCache (cacheDir opts_hash) + where + -- Create a unique folder per set of different GHC options, assuming that each different set of + -- GHC options will create incompatible interface files. + opts_hash = B.unpack $ encode $ H.finalize $ H.updates H.init (map B.pack opts) diff --git a/ghcide b/ghcide index 66900802b9..a7c6b2fed1 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 66900802b9e86ad941d863d862683aa5b972425b +Subproject commit a7c6b2fed1d2cd434c115dc27a81bd84b5d7b603 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 6eb99d7496..137cc37cbc 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -92,6 +92,7 @@ executable haskell-language-server other-modules: Arguments Paths_haskell_language_server + Rules RuleTypes autogen-modules: Paths_haskell_language_server @@ -111,6 +112,7 @@ executable haskell-language-server build-depends: base >=4.7 && <5 + , aeson , base16-bytestring , binary , bytestring From e27c7c697e377ae12d6fcda95bc6b6f664dab797 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 5 Mar 2020 23:48:49 +0000 Subject: [PATCH 08/25] ExecuteCommand plugins work via pluginDescriptor Demonstrated by adding missing pragmas derived from GHC error messages. --- exe/Main.hs | 22 ++++------------------ ghcide | 2 +- src/Ide/Plugin.hs | 19 ++++++++++++++----- src/Ide/Plugin/Pragmas.hs | 23 ++++++++++++----------- 4 files changed, 31 insertions(+), 35 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index 251304c77b..0caa833059 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -15,11 +15,7 @@ import Control.Concurrent.Extra import Control.Exception import Control.Monad.Extra import Control.Monad.IO.Class --- import qualified Crypto.Hash.SHA1 as H --- import Data.ByteString.Base16 --- import qualified Data.ByteString.Char8 as B import Data.Default --- import Data.Functor ((<&>)) import qualified Data.HashSet as HashSet import Data.List.Extra import qualified Data.Map.Strict as Map @@ -44,23 +40,12 @@ import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.IDE.Types.Options import Development.Shake (Action, Rules, action) --- import DynFlags --- import GHC hiding (def) --- import qualified GHC.Paths import HIE.Bios import qualified Language.Haskell.LSP.Core as LSP --- import HIE.Bios.Cradle --- import HIE.Bios.Environment --- import HIE.Bios.Types import Ide.Plugin --- import Ide.PluginDescriptors import Ide.Plugin.Config --- import Ide.Plugin.Formatter import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types (LspId(IdInt)) --- import qualified Language.Haskell.LSP.Core as LSP --- import Linker --- import Paths_haskell_language_server import RuleTypes import Rules import qualified System.Directory.Extra as IO @@ -126,8 +111,8 @@ idePlugins includeExamples -- , hsimportDescriptor "hsimport" -- , liquidDescriptor "liquid" -- , packageDescriptor "package" - -- , pragmasDescriptor "pragmas" - Floskell.descriptor "floskell" + Pragmas.descriptor "pragmas" + , Floskell.descriptor "floskell" -- , genericDescriptor "generic" -- , ghcmodDescriptor "ghcmod" , Ormolu.descriptor "ormolu" @@ -172,7 +157,8 @@ main = do dir <- IO.getCurrentDirectory pid <- getPid - let plugins = idePlugins argsExamplePlugin + -- let plugins = idePlugins argsExamplePlugin + let plugins = idePlugins True options = def { LSP.executeCommandCommands = Just (commandIds pid) , LSP.completionTriggerCharacters = Just "." } diff --git a/ghcide b/ghcide index a7c6b2fed1..6761f2f116 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit a7c6b2fed1d2cd434c115dc27a81bd84b5d7b603 +Subproject commit 6761f2f11676fdde6013364e8e62f9043e1cc04e diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs index 3ed46eb895..d9763ad397 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -30,7 +30,7 @@ import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.LSP.Server -import Development.IDE.Plugin hiding (pluginCommands) +import Development.IDE.Plugin hiding (pluginCommands, pluginRules) import Development.IDE.Types.Diagnostics as D import Development.Shake hiding ( Diagnostic, command ) import GHC.Generics @@ -53,6 +53,7 @@ import Text.Regex.TDFA.Text() -- category ('Notifaction', 'Request' etc). asGhcIdePlugin :: IdePlugins -> Plugin Config asGhcIdePlugin mp = + mkPlugin rulesPlugins (Just . pluginRules) <> mkPlugin executeCommandPlugins (Just . pluginCommands) <> mkPlugin codeActionPlugins pluginCodeActionProvider <> -- diagnostics from pluginDiagnosticProvider @@ -66,7 +67,7 @@ asGhcIdePlugin mp = ls = Map.toList (ipMap mp) - mkPlugin :: ([(PluginId, b)] -> t) -> (PluginDescriptor -> Maybe b) -> t + mkPlugin :: ([(PluginId, b)] -> Plugin Config) -> (PluginDescriptor -> Maybe b) -> Plugin Config mkPlugin maker selector = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls @@ -76,6 +77,11 @@ pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginI -- --------------------------------------------------------------------- +rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config +rulesPlugins rs = Plugin mempty rules mempty + where + rules = mconcat $ map snd rs + codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config codeActionPlugins cas = Plugin mempty codeActionRules (codeActionHandlers cas) @@ -286,9 +292,12 @@ runPluginCommand m p@(PluginId p') com@(CommandId com') arg = ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' <> ": " <> T.pack err) Nothing, Nothing) J.Success a -> do res <- f a - case res of - Left e -> return (Left e, Nothing) - Right r -> return (Right $ J.toJSON r, Nothing) + return res + -- case res of + -- Left e -> return (Left e, Nothing) + -- -- Right r -> return (Right $ J.toJSON r, Nothing) + -- Right r -> return r + -- -- return (Right J.Null, Just(WorkspaceApplyEdit, _ r)) -- ----------------------------------------------------------- diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs index f0972510a9..12b961da07 100644 --- a/src/Ide/Plugin/Pragmas.hs +++ b/src/Ide/Plugin/Pragmas.hs @@ -5,7 +5,8 @@ -- | Provides code actions to add missing pragmas (whenever GHC suggests to) module Ide.Plugin.Pragmas ( - codeAction + descriptor + , codeAction , commands ) where @@ -18,19 +19,16 @@ import Ide.Types import qualified GHC.Generics as Generics import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Lens as J - import Development.IDE.Types.Diagnostics as D import Language.Haskell.LSP.Types -- --------------------------------------------------------------------- -_pragmasDescriptor :: PluginId -> PluginDescriptor -_pragmasDescriptor plId = PluginDescriptor +descriptor :: PluginId -> PluginDescriptor +descriptor plId = PluginDescriptor { pluginId = plId , pluginRules = mempty - , pluginCommands = - [ PluginCommand "addPragma" "add the given pragma" addPragmaCmd - ] + , pluginCommands = commands , pluginCodeActionProvider = Just codeActionProvider , pluginDiagnosticProvider = Nothing , pluginHoverProvider = Nothing @@ -58,7 +56,9 @@ data AddPragmaParams = AddPragmaParams -- Pragma is added to the first line of the Uri. -- It is assumed that the pragma name is a valid pragma, -- thus, not validated. -addPragmaCmd :: AddPragmaParams -> IO (Either ResponseError J.WorkspaceEdit) +-- addPragmaCmd :: AddPragmaParams -> IO (Either ResponseError J.WorkspaceEdit) +addPragmaCmd :: AddPragmaParams -> IO (Either ResponseError Value, + Maybe (ServerMethod, ApplyWorkspaceEditParams)) addPragmaCmd (AddPragmaParams uri pragmaName) = do let pos = J.Position 0 0 @@ -69,7 +69,7 @@ addPragmaCmd (AddPragmaParams uri pragmaName) = do res = J.WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - return $ Right res + return $ (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) -- --------------------------------------------------------------------- @@ -80,11 +80,12 @@ codeAction = codeActionProvider -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. codeActionProvider :: CodeActionProvider codeActionProvider _ plId docId _ (J.CodeActionContext (J.List diags) _monly) = do - cmds <- mapM mkCommand pragmas + -- cmds <- mapM mkCommand pragmas + cmds <- mapM mkCommand ("FooPragma":pragmas) return $ Right $ List cmds where -- Filter diagnostics that are from ghcmod - ghcDiags = filter (\d -> d ^. J.source == Just "bios") diags + ghcDiags = filter (\d -> d ^. J.source == Just "typecheck") diags -- Get all potential Pragmas for all diagnostics. pragmas = concatMap (\d -> findPragma (d ^. J.message)) ghcDiags mkCommand pragmaName = do From bcc4b966925be482e1183956828c335989b3db5e Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 7 Mar 2020 20:28:40 +0000 Subject: [PATCH 09/25] Add logging It piggy-backs existing args from ghcide, probably a bad idea --- exe/Main.hs | 9 +++++++- exe/Wrapper.hs | 3 ++- ghcide | 2 +- haskell-language-server.cabal | 2 ++ src/Ide/Cradle.hs | 18 ++-------------- src/Ide/Logger.hs | 40 +++++++++++++++++++++++++++++++++++ src/Ide/Plugin/Pragmas.hs | 4 ++-- test/functional/PluginSpec.hs | 10 ++++++--- test/utils/TestUtils.hs | 3 ++- 9 files changed, 66 insertions(+), 25 deletions(-) create mode 100644 src/Ide/Logger.hs diff --git a/exe/Main.hs b/exe/Main.hs index 0caa833059..eaac10961d 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -42,6 +42,7 @@ import Development.IDE.Types.Options import Development.Shake (Action, Rules, action) import HIE.Bios import qualified Language.Haskell.LSP.Core as LSP +import Ide.Logger import Ide.Plugin import Ide.Plugin.Config import Language.Haskell.LSP.Messages @@ -53,6 +54,7 @@ import qualified System.Directory.Extra as IO import System.Exit import System.FilePath import System.IO +import System.Log.Logger as L import System.Time.Extra -- --------------------------------------------------------------------- @@ -147,6 +149,11 @@ main = do if argsVersion then ghcideVersion >>= putStrLn >> exitSuccess else hPutStrLn stderr {- see WARNING above -} =<< ghcideVersion + -- LSP.setupLogger (optLogFile opts) ["hie", "hie-bios"] + -- $ if optDebugOn opts then L.DEBUG else L.INFO + LSP.setupLogger argsShakeProfiling ["hie", "hie-bios"] + $ if argsTesting then L.DEBUG else L.INFO + -- lock to avoid overlapping output on stdout lock <- newLock let logger p = Logger $ \pri msg -> when (pri >= p) $ withLock lock $ @@ -177,7 +184,7 @@ main = do } debouncer <- newAsyncDebouncer initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick) - getLspId event (logger minBound) debouncer options vfs + getLspId event hlsLogger debouncer options vfs else do putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "." putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" diff --git a/exe/Wrapper.hs b/exe/Wrapper.hs index bb73bd7f67..f8dcaccf65 100644 --- a/exe/Wrapper.hs +++ b/exe/Wrapper.hs @@ -18,7 +18,8 @@ import Data.List -- import qualified Data.Text.IO as T -- import Development.IDE.Types.Logger import HIE.Bios -import Ide.Cradle (findLocalCradle, logm) +import Ide.Cradle (findLocalCradle) +import Ide.Logger (logm) import Ide.Version import System.Directory import System.Environment diff --git a/ghcide b/ghcide index 6761f2f116..63aa7a1b08 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 6761f2f11676fdde6013364e8e62f9043e1cc04e +Subproject commit 63aa7a1b08051db4b4814b5976abae6d5f8af4f0 diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 137cc37cbc..78158c1bcc 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -29,6 +29,7 @@ library exposed-modules: Ide.Compat Ide.Cradle + Ide.Logger Ide.Plugin Ide.Plugin.Config Ide.Plugin.Example @@ -137,6 +138,7 @@ executable haskell-language-server , haskell-lsp , hie-bios >= 0.4 , haskell-language-server + , hslogger , optparse-applicative , shake >= 0.17.5 , text diff --git a/src/Ide/Cradle.hs b/src/Ide/Cradle.hs index f6a5a4e1db..660b681a61 100644 --- a/src/Ide/Cradle.hs +++ b/src/Ide/Cradle.hs @@ -6,7 +6,6 @@ module Ide.Cradle where import Control.Exception -import Control.Monad.IO.Class import Data.Foldable (toList) import Data.Function ((&)) import Data.List (isPrefixOf, sortOn, find) @@ -24,6 +23,7 @@ import Distribution.Helper (Package, projectPackages, pUnits, Unit, unitInfo, uiComponents, ChEntrypoint(..), UnitInfo(..)) import Distribution.Helper.Discover (findProjects, getDefaultDistDir) +import Ide.Logger import HIE.Bios as Bios import qualified HIE.Bios.Cradle as Bios import HIE.Bios.Types (CradleAction(..)) @@ -32,7 +32,7 @@ import System.Directory (getCurrentDirectory, canonicalizePath, findEx import System.Exit import System.FilePath import System.Log.Logger -import System.Process (readCreateProcessWithExitCode, shell, CreateProcess(..)) +import System.Process (readCreateProcessWithExitCode, shell) -- --------------------------------------------------------------------- @@ -903,17 +903,3 @@ cradleDisplay cradle = fromString result name = Bios.actionName (Bios.cradleOptsProg cradle) -- --------------------------------------------------------------------- - -logm :: MonadIO m => String -> m () -logm s = liftIO $ infoM "hie" s - -debugm :: MonadIO m => String -> m () -debugm s = liftIO $ debugM "hie" s - -warningm :: MonadIO m => String -> m () -warningm s = liftIO $ warningM "hie" s - -errorm :: MonadIO m => String -> m () -errorm s = liftIO $ errorM "hie" s - --- --------------------------------------------------------------------- diff --git a/src/Ide/Logger.hs b/src/Ide/Logger.hs new file mode 100644 index 0000000000..472ab081fd --- /dev/null +++ b/src/Ide/Logger.hs @@ -0,0 +1,40 @@ +module Ide.Logger + ( + hlsLogger + , logm + , debugm + , warningm + , errorm + ) where + +import Control.Monad.IO.Class +import qualified Data.Text as T +import qualified Development.IDE.Types.Logger as L +import System.Log.Logger + +-- --------------------------------------------------------------------- +-- data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} +hlsLogger :: L.Logger +hlsLogger = L.Logger $ \pri txt -> + case pri of + L.Telemetry -> logm (T.unpack txt) + L.Debug -> debugm (T.unpack txt) + L.Info -> logm (T.unpack txt) + L.Warning -> warningm (T.unpack txt) + L.Error -> errorm (T.unpack txt) + +-- --------------------------------------------------------------------- + +logm :: MonadIO m => String -> m () +logm s = liftIO $ infoM "hie" s + +debugm :: MonadIO m => String -> m () +debugm s = liftIO $ debugM "hie" s + +warningm :: MonadIO m => String -> m () +warningm s = liftIO $ warningM "hie" s + +errorm :: MonadIO m => String -> m () +errorm s = liftIO $ errorM "hie" s + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs index 12b961da07..390042db9d 100644 --- a/src/Ide/Plugin/Pragmas.hs +++ b/src/Ide/Plugin/Pragmas.hs @@ -80,8 +80,8 @@ codeAction = codeActionProvider -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. codeActionProvider :: CodeActionProvider codeActionProvider _ plId docId _ (J.CodeActionContext (J.List diags) _monly) = do - -- cmds <- mapM mkCommand pragmas - cmds <- mapM mkCommand ("FooPragma":pragmas) + cmds <- mapM mkCommand pragmas + -- cmds <- mapM mkCommand ("FooPragma":pragmas) return $ Right $ List cmds where -- Filter diagnostics that are from ghcmod diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index 6150700550..1fbad5404c 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module PluginSpec where --- import Control.Applicative.Combinators +import Control.Applicative.Combinators import Control.Lens hiding (List) -- import Control.Monad import Control.Monad.IO.Class @@ -26,8 +27,8 @@ import TestUtils -- --------------------------------------------------------------------- spec :: Spec -spec = do - describe "composes code actions" $ do +spec = + describe "composes code actions" $ it "provides 3.8 code actions" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" @@ -54,6 +55,9 @@ spec = do executeCodeAction ca liftIO $ putStrLn $ "B" -- AZ + _ <- skipManyTill anyMessage (message @RegisterCapabilityRequest) + liftIO $ putStrLn $ "B2" -- AZ + contents <- getDocumentEdit doc liftIO $ putStrLn $ "C" -- AZ liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 15f6a78cd3..7718ef0919 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -205,7 +205,8 @@ logFilePath = "hie-" ++ stackYaml ++ ".log" -- stack just puts all project executables on PATH. hieCommand :: String -- hieCommand = "hie --lsp --bios-verbose -d -l test-logs/" ++ logFilePath -hieCommand = "haskell-language-server --lsp" +-- hieCommand = "haskell-language-server --lsp" +hieCommand = "haskell-language-server --lsp --test --shake-profiling=test-logs/" ++ logFilePath hieCommandVomit :: String hieCommandVomit = hieCommand ++ " --vomit" From a33c2b481dc819695d146181711ab43fefe85123 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 8 Mar 2020 21:36:36 +0000 Subject: [PATCH 10/25] More plugin refactoring, add codelens support Starting to look pretty solid. --- exe/Main.hs | 40 ++++----------- src/Ide/Logger.hs | 5 +- src/Ide/Plugin.hs | 77 ++++++++++++++++++++++------ src/Ide/Plugin/Example.hs | 95 ++++++++++++++++------------------- src/Ide/Plugin/Example2.hs | 54 +++----------------- src/Ide/Plugin/Floskell.hs | 1 + src/Ide/Plugin/Ormolu.hs | 1 + src/Ide/Plugin/Pragmas.hs | 9 ++-- src/Ide/Types.hs | 8 +++ test/functional/PluginSpec.hs | 2 + 10 files changed, 142 insertions(+), 150 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index eaac10961d..b3041ea76b 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -69,38 +69,15 @@ import Ide.Plugin.Pragmas as Pragmas -- --------------------------------------------------------------------- --- | TODO: these should come out of something like asGhcIdePlugin -commandIds :: T.Text -> [T.Text] -commandIds pid = "typesignature.add" : allLspCmdIds pid [("pragmas", Pragmas.commands)] - --- | The plugins configured for use in this instance of the language --- server. --- These can be freely added or removed to tailor the available --- features of the server. -_idePlugins :: Bool -> Plugin Config -_idePlugins includeExample - = Completions.plugin <> - CodeAction.plugin <> - formatterPlugins [("ormolu", Ormolu.provider) - ,("floskell", Floskell.provider)] <> - codeActionPlugins [("eg", Example.codeAction) - ,("eg2", Example2.codeAction) - ,("pragmas", Pragmas.codeAction)] <> - executeCommandPlugins [("pragmas", Pragmas.commands)] <> - hoverPlugins [("eg", Example.hover) - ,("eg2", Example2.hover)] <> - if includeExample then Example.plugin <> Example2.plugin - else mempty - - -- | The plugins configured for use in this instance of the language -- server. -- These can be freely added or removed to tailor the available -- features of the server. -idePlugins :: Bool -> Plugin Config -idePlugins includeExamples - = asGhcIdePlugin $ pluginDescToIdePlugins allPlugins +idePlugins :: T.Text -> Bool -> (Plugin Config, [T.Text]) +idePlugins pid includeExamples + = (asGhcIdePlugin ps, allLspCmdIds' pid ps) where + ps = pluginDescToIdePlugins allPlugins allPlugins = if includeExamples then basePlugins ++ examplePlugins else basePlugins @@ -164,9 +141,12 @@ main = do dir <- IO.getCurrentDirectory pid <- getPid - -- let plugins = idePlugins argsExamplePlugin - let plugins = idePlugins True - options = def { LSP.executeCommandCommands = Just (commandIds pid) + let + -- (ps, commandIds) = idePlugins pid argsExamplePlugin + (ps, commandIds) = idePlugins pid True + plugins = Completions.plugin <> CodeAction.plugin <> + ps + options = def { LSP.executeCommandCommands = Just commandIds , LSP.completionTriggerCharacters = Just "." } diff --git a/src/Ide/Logger.hs b/src/Ide/Logger.hs index 472ab081fd..9bb8468146 100644 --- a/src/Ide/Logger.hs +++ b/src/Ide/Logger.hs @@ -1,3 +1,6 @@ +{- | Provides an implementation of the ghcide @Logger@ which uses + @System.Log.Logger@ under the hood. +-} module Ide.Logger ( hlsLogger @@ -13,7 +16,7 @@ import qualified Development.IDE.Types.Logger as L import System.Log.Logger -- --------------------------------------------------------------------- --- data Logger = Logger {logPriority :: Priority -> T.Text -> IO ()} + hlsLogger :: L.Logger hlsLogger = L.Logger $ \pri txt -> case pri of diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs index d9763ad397..174b9fc739 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -11,12 +11,9 @@ module Ide.Plugin ( asGhcIdePlugin , pluginDescToIdePlugins - , formatterPlugins - , hoverPlugins - , codeActionPlugins - , executeCommandPlugins , mkLspCommand , allLspCmdIds + , allLspCmdIds' , getPid ) where @@ -29,9 +26,11 @@ import qualified Data.Map as Map import Data.Maybe import qualified Data.Text as T import Development.IDE.Core.Rules +import Development.IDE.Core.Shake import Development.IDE.LSP.Server import Development.IDE.Plugin hiding (pluginCommands, pluginRules) import Development.IDE.Types.Diagnostics as D +import Development.IDE.Types.Logger import Development.Shake hiding ( Diagnostic, command ) import GHC.Generics import Ide.Compat @@ -56,11 +55,12 @@ asGhcIdePlugin mp = mkPlugin rulesPlugins (Just . pluginRules) <> mkPlugin executeCommandPlugins (Just . pluginCommands) <> mkPlugin codeActionPlugins pluginCodeActionProvider <> - -- diagnostics from pluginDiagnosticProvider + mkPlugin codeLensPlugins pluginCodeLensProvider <> + -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider mkPlugin hoverPlugins pluginHoverProvider <> - -- symbols via pluginSymbolProvider + -- TODO: symbols via pluginSymbolProvider mkPlugin formatterPlugins pluginFormattingProvider - -- completions + -- TODO: completions where justs (p, Just x) = [(p, x)] justs (_, Nothing) = [] @@ -75,6 +75,17 @@ asGhcIdePlugin mp = pluginDescToIdePlugins :: [PluginDescriptor] -> IdePlugins pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList $ map (\p -> (pluginId p, p)) plugins +allLspCmdIds' :: T.Text -> IdePlugins -> [T.Text] +allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) + where + justs (p, Just x) = [(p, x)] + justs (_, Nothing) = [] + + ls = Map.toList (ipMap mp) + + mkPlugin maker selector + = maker $ concatMap (\(pid, p) -> justs (pid, selector p)) ls + -- --------------------------------------------------------------------- rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config @@ -140,6 +151,46 @@ data FallbackCodeActionParams = -- ----------------------------------------------------------- +codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config +codeLensPlugins cas = Plugin mempty codeLensRules (codeLensHandlers cas) + +codeLensRules :: Rules () +codeLensRules = mempty + +codeLensHandlers :: [(PluginId, CodeLensProvider)] -> PartialHandlers Config +codeLensHandlers cas = PartialHandlers $ \WithMessage{..} x -> return x + { LSP.codeLensHandler + = withResponse RspCodeLens (makeCodeLens cas) + } + +makeCodeLens :: [(PluginId, CodeLensProvider)] + -> LSP.LspFuncs Config + -> IdeState + -> CodeLensParams + -> IO (Either ResponseError (List CodeLens)) +makeCodeLens cas _lf ideState params = do + logInfo (ideLogger ideState) "Plugin.makeCodeLens (ideLogger)" -- AZ + let + makeLens (pid, provider) = do + r <- provider ideState pid params + return (pid, r) + breakdown :: [(PluginId, Either ResponseError a)] -> ([(PluginId, ResponseError)], [(PluginId, a)]) + breakdown ls = (concatMap doOneLeft ls, concatMap doOneRight ls) + where + doOneLeft (pid, Left err) = [(pid,err)] + doOneLeft (_, Right _) = [] + + doOneRight (pid, Right a) = [(pid,a)] + doOneRight (_, Left _) = [] + + r <- mapM makeLens cas + case breakdown r of + ([],[]) -> return $ Right $ List [] + (es,[]) -> return $ Left $ ResponseError InternalError (T.pack $ "codeLens failed:" ++ show es) Nothing + (_,rs) -> return $ Right $ List (concatMap (\(_,List cs) -> cs) rs) + +-- ----------------------------------------------------------- + executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config executeCommandPlugins ecs = Plugin mempty mempty (executeCommandHandlers ecs) @@ -275,6 +326,9 @@ makeExecuteCommands ecs _lf _params = do execCmd (params ^. J.command) (params ^. J.arguments) -} + +-- ----------------------------------------------------------- + -- | Runs a plugin command given a PluginId, CommandId and -- arguments in the form of a JSON object. runPluginCommand :: Map.Map PluginId [PluginCommand] -> PluginId -> CommandId -> J.Value @@ -290,14 +344,7 @@ runPluginCommand m p@(PluginId p') com@(CommandId com') arg = Just (PluginCommand _ _ f) -> case J.fromJSON arg of J.Error err -> return (Left $ ResponseError InvalidParams ("error while parsing args for " <> com' <> " in plugin " <> p' <> ": " <> T.pack err) Nothing, Nothing) - J.Success a -> do - res <- f a - return res - -- case res of - -- Left e -> return (Left e, Nothing) - -- -- Right r -> return (Right $ J.toJSON r, Nothing) - -- Right r -> return r - -- -- return (Right J.Null, Just(WorkspaceApplyEdit, _ r)) + J.Success a -> f a -- ----------------------------------------------------------- diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index a4a447ba50..cb9077c3dd 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -1,24 +1,21 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Ide.Plugin.Example ( descriptor - , plugin - , hover - , codeAction ) where import Control.DeepSeq ( NFData ) import Control.Monad.Trans.Maybe -import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) +import Data.Aeson import Data.Binary import Data.Functor import qualified Data.HashMap.Strict as Map @@ -31,16 +28,13 @@ import Development.IDE.Core.RuleTypes import Development.IDE.Core.Rules import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.LSP.Server -import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.Shake hiding ( Diagnostic ) import GHC.Generics +import Ide.Plugin import Ide.Types -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() @@ -50,8 +44,9 @@ descriptor :: PluginId -> PluginDescriptor descriptor plId = PluginDescriptor { pluginId = plId , pluginRules = exampleRules - , pluginCommands = [] + , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] , pluginCodeActionProvider = Just codeAction + , pluginCodeLensProvider = Just codeLens , pluginDiagnosticProvider = Nothing , pluginHoverProvider = Just hover , pluginSymbolProvider = Nothing @@ -61,11 +56,6 @@ descriptor plId = PluginDescriptor -- --------------------------------------------------------------------- -plugin :: Plugin c -plugin = Plugin mempty exampleRules handlersExample - -- <> codeActionPlugin codeAction - <> Plugin mempty mempty handlersCodeLens - hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) hover = request "Hover" blah (Right Nothing) foundHover @@ -73,11 +63,8 @@ blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) blah _ (Position line col) = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 1\n"]) -handlersExample :: PartialHandlers c -handlersExample = mempty --- handlersExample = PartialHandlers $ \WithMessage{..} x -> --- return x{LSP.hoverHandler = withResponse RspHover $ const hover} - +-- --------------------------------------------------------------------- +-- Generating Diagnostics via rules -- --------------------------------------------------------------------- data Example = Example @@ -116,6 +103,8 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) } -- --------------------------------------------------------------------- +-- code actions +-- --------------------------------------------------------------------- -- | Generate code actions. codeAction @@ -136,19 +125,13 @@ codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_di -- --------------------------------------------------------------------- --- | Generate code lenses. -handlersCodeLens :: PartialHandlers c -handlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.codeLensHandler = withResponse RspCodeLens codeLens, - LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand - } - codeLens - :: LSP.LspFuncs c - -> IdeState + :: IdeState + -> PluginId -> CodeLensParams -> IO (Either ResponseError (List CodeLens)) -codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do +codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath @@ -156,29 +139,36 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} _hDiag <- getHiddenDiagnostics ideState let title = "Add TODO Item via Code Lens" - tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) - "-- TODO added by Example Plugin via code lens action\n"] - edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - range = (Range (Position 3 0) (Position 4 0)) - pure $ Right $ List - -- [ CodeLens range (Just (Command title "codelens.do" (Just $ List [toJSON edit]))) Nothing - [ CodeLens range (Just (Command title "codelens.todo" (Just $ List [toJSON edit]))) Nothing - ] + -- tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) + -- "-- TODO added by Example Plugin via code lens action\n"] + -- edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing + range = Range (Position 3 0) (Position 4 0) + let cmdParams = AddTodoParams uri "do abc" + cmd <- mkLspCommand plId "codelens.todo" title (Just [(toJSON cmdParams)]) + pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] Nothing -> pure $ Right $ List [] --- | Execute the "codelens.todo" command. -executeAddSignatureCommand - :: LSP.LspFuncs c - -> IdeState - -> ExecuteCommandParams - -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) -executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..} - | _command == "codelens.todo" - , Just (List [edit]) <- _arguments - , Success wedit <- fromJSON edit - = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) - | otherwise - = return (Right Null, Nothing) +-- --------------------------------------------------------------------- +-- | Parameters for the addTodo PluginCommand. +data AddTodoParams = AddTodoParams + { file :: Uri -- ^ Uri of the file to add the pragma to + , todoText :: T.Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +addTodoCmd :: AddTodoParams -> IO (Either ResponseError Value, + Maybe (ServerMethod, ApplyWorkspaceEditParams)) +addTodoCmd (AddTodoParams uri todoText) = do + let + pos = Position 0 0 + textEdits = List + [TextEdit (Range pos pos) + ("-- TODO:" <> todoText) + ] + res = WorkspaceEdit + (Just $ Map.singleton uri textEdits) + Nothing + return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) -- --------------------------------------------------------------------- @@ -203,7 +193,8 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc Nothing -> pure Nothing pure $ maybe notFound found mbResult -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) + -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do let filePath = toNormalizedFilePath path logInfo (ideLogger ide) $ diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index 987dccdc79..0baa03e3a1 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -11,14 +11,11 @@ module Ide.Plugin.Example2 ( descriptor - , plugin - , hover - , codeAction ) where import Control.DeepSeq ( NFData ) import Control.Monad.Trans.Maybe -import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..)) +import Data.Aeson.Types (toJSON) import Data.Binary import Data.Functor import qualified Data.HashMap.Strict as Map @@ -31,16 +28,12 @@ import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes import Development.IDE.Core.Service import Development.IDE.Core.Shake -import Development.IDE.LSP.Server -import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.Shake hiding ( Diagnostic ) import Ide.Types import GHC.Generics -import qualified Language.Haskell.LSP.Core as LSP -import Language.Haskell.LSP.Messages import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() @@ -52,20 +45,16 @@ descriptor plId = PluginDescriptor , pluginRules = exampleRules , pluginCommands = [] , pluginCodeActionProvider = Just codeAction + , pluginCodeLensProvider = Just codeLens , pluginDiagnosticProvider = Nothing - , pluginHoverProvider = Just hover - , pluginSymbolProvider = Nothing + , pluginHoverProvider = Just hover + , pluginSymbolProvider = Nothing , pluginFormattingProvider = Nothing , pluginCompletionProvider = Nothing } -- --------------------------------------------------------------------- -plugin :: Plugin c -plugin = Plugin mempty exampleRules handlersExample2 - -- <> codeActionPlugin codeAction - <> Plugin mempty mempty handlersCodeLens - hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) hover = request "Hover" blah (Right Nothing) foundHover @@ -73,12 +62,6 @@ blah :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text])) blah _ (Position line col) = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 2\n"]) -handlersExample2 :: PartialHandlers c -handlersExample2 = mempty --- handlersExample2 = PartialHandlers $ \WithMessage{..} x -> --- return x{LSP.hoverHandler = withResponse RspHover $ const hover} - - -- --------------------------------------------------------------------- data Example2 = Example2 @@ -137,19 +120,12 @@ codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_di -- --------------------------------------------------------------------- --- | Generate code lenses. -handlersCodeLens :: PartialHandlers c -handlersCodeLens = PartialHandlers $ \WithMessage{..} x -> return x{ - LSP.codeLensHandler = withResponse RspCodeLens codeLens, - LSP.executeCommandHandler = withResponseAndRequest RspExecuteCommand ReqApplyWorkspaceEdit executeAddSignatureCommand - } - codeLens - :: LSP.LspFuncs c - -> IdeState + :: IdeState + -> PluginId -> CodeLensParams -> IO (Either ResponseError (List CodeLens)) -codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do +codeLens ideState _plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath @@ -160,27 +136,13 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri} tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) "-- TODO2 added by Example2 Plugin via code lens action\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing - range = (Range (Position 3 0) (Position 4 0)) + range = Range (Position 3 0) (Position 4 0) pure $ Right $ List -- [ CodeLens range (Just (Command title "codelens.do" (Just $ List [toJSON edit]))) Nothing [ CodeLens range (Just (Command title "codelens.todo" (Just $ List [toJSON edit]))) Nothing ] Nothing -> pure $ Right $ List [] --- | Execute the "codelens.todo2" command. -executeAddSignatureCommand - :: LSP.LspFuncs c - -> IdeState - -> ExecuteCommandParams - -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) -executeAddSignatureCommand _lsp _ideState ExecuteCommandParams{..} - | _command == "codelens.todo2" - , Just (List [edit]) <- _arguments - , Success wedit <- fromJSON edit - = return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams wedit)) - | otherwise - = return (Right Null, Nothing) - -- --------------------------------------------------------------------- foundHover :: (Maybe Range, [T.Text]) -> Either ResponseError (Maybe Hover) diff --git a/src/Ide/Plugin/Floskell.hs b/src/Ide/Plugin/Floskell.hs index 49577742b0..c30a4e8358 100644 --- a/src/Ide/Plugin/Floskell.hs +++ b/src/Ide/Plugin/Floskell.hs @@ -31,6 +31,7 @@ descriptor plId = PluginDescriptor , pluginRules = mempty , pluginCommands = [] , pluginCodeActionProvider = Nothing + , pluginCodeLensProvider = Nothing , pluginDiagnosticProvider = Nothing , pluginHoverProvider = Nothing , pluginSymbolProvider = Nothing diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index 304e435e1c..ba09c7c42f 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -39,6 +39,7 @@ descriptor plId = PluginDescriptor , pluginRules = mempty , pluginCommands = [] , pluginCodeActionProvider = Nothing + , pluginCodeLensProvider = Nothing , pluginDiagnosticProvider = Nothing , pluginHoverProvider = Nothing , pluginSymbolProvider = Nothing diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs index 390042db9d..e61e1f77a5 100644 --- a/src/Ide/Plugin/Pragmas.hs +++ b/src/Ide/Plugin/Pragmas.hs @@ -6,8 +6,7 @@ module Ide.Plugin.Pragmas ( descriptor - , codeAction - , commands + -- , commands -- TODO: get rid of this ) where import Control.Lens hiding (List) @@ -30,6 +29,7 @@ descriptor plId = PluginDescriptor , pluginRules = mempty , pluginCommands = commands , pluginCodeActionProvider = Just codeActionProvider + , pluginCodeLensProvider = Nothing , pluginDiagnosticProvider = Nothing , pluginHoverProvider = Nothing , pluginSymbolProvider = Nothing @@ -69,13 +69,10 @@ addPragmaCmd (AddPragmaParams uri pragmaName) = do res = J.WorkspaceEdit (Just $ H.singleton uri textEdits) Nothing - return $ (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) -- --------------------------------------------------------------------- -codeAction :: CodeActionProvider -codeAction = codeActionProvider - -- | Offer to add a missing Language Pragma to the top of a file. -- Pragmas are defined by a curated list of known pragmas, see 'possiblePragmas'. codeActionProvider :: CodeActionProvider diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs index d718b76af0..035719d5ee 100644 --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -14,6 +14,7 @@ module Ide.Types , FormattingProvider , HoverProvider , CodeActionProvider + , CodeLensProvider , ExecuteCommandProvider , CompletionProvider ) where @@ -45,6 +46,7 @@ data PluginDescriptor = , pluginRules :: !(Rules ()) , pluginCommands :: ![PluginCommand] , pluginCodeActionProvider :: !(Maybe CodeActionProvider) + , pluginCodeLensProvider :: !(Maybe CodeLensProvider) , pluginDiagnosticProvider :: !(Maybe DiagnosticProvider) -- ^ TODO: diagnostics are generally provided via rules, -- this is probably redundant. @@ -77,6 +79,12 @@ type CodeActionProvider = IdeState -> CodeActionContext -> IO (Either ResponseError (List CAResult)) + +type CodeLensProvider = IdeState + -> PluginId + -> CodeLensParams + -> IO (Either ResponseError (List CodeLens)) + type DiagnosticProviderFuncSync = DiagnosticTrigger -> Uri -> IO (Either ResponseError (Map.Map Uri (S.Set Diagnostic))) diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index 1fbad5404c..0b37bc6649 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -58,6 +58,8 @@ spec = _ <- skipManyTill anyMessage (message @RegisterCapabilityRequest) liftIO $ putStrLn $ "B2" -- AZ + -- <- skipManyTill anyMessage $ between (satisfy startPred) (satisfy donePred) $ + contents <- getDocumentEdit doc liftIO $ putStrLn $ "C" -- AZ liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" From 3acb99f05a778e60a06d77a6b53af2e56e8ea418 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 9 Mar 2020 22:02:56 +0000 Subject: [PATCH 11/25] Rebase to current ghcide master --- exe/Main.hs | 6 +++++- exe/Rules.hs | 8 +++++--- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/exe/Main.hs b/exe/Main.hs index b3041ea76b..35fc696c4a 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -160,12 +160,16 @@ main = do let options = (defaultIdeOptions $ loadSession dir) { optReportProgress = clientSupportsProgress caps , optShakeProfiling = argsShakeProfiling - , optTesting = IdeTesting argsTesting + , optTesting = argsTesting } debouncer <- newAsyncDebouncer initialise caps (cradleRules >> mainRule >> pluginRules plugins >> action kick) getLspId event hlsLogger debouncer options vfs else do + -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error + hSetEncoding stdout utf8 + hSetEncoding stderr utf8 + putStrLn $ "(haskell-language-server)Ghcide setup tester in " ++ dir ++ "." putStrLn "Report bugs at https://github.com/haskell/haskell-language-server/issues" diff --git a/exe/Rules.hs b/exe/Rules.hs index 3039327867..987fc0e982 100644 --- a/exe/Rules.hs +++ b/exe/Rules.hs @@ -19,9 +19,11 @@ import Data.Functor ((<&>)) import Data.Maybe (fromMaybe) import Data.Text (Text) import Development.IDE.Core.Rules (defineNoFile) -import Development.IDE.Core.Shake (ShakeExtras(ShakeExtras,isTesting), getShakeExtras, sendEvent, define, useNoFile_) +import Development.IDE.Core.Service (getIdeOptions) +import Development.IDE.Core.Shake (sendEvent, define, useNoFile_) import Development.IDE.GHC.Util import Development.IDE.Types.Location (fromNormalizedFilePath) +import Development.IDE.Types.Options (IdeOptions(IdeOptions, optTesting)) import Development.Shake import DynFlags (gopt_set, gopt_unset, updOptLevel) @@ -63,13 +65,13 @@ cradleToSession :: Rules () cradleToSession = define $ \LoadCradle nfp -> do let f = fromNormalizedFilePath nfp - ShakeExtras{isTesting} <- getShakeExtras + IdeOptions{optTesting} <- getIdeOptions -- If the path points to a directory, load the implicit cradle mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml - when isTesting $ + when optTesting $ sendEvent $ notifyCradleLoaded f cmpOpts <- liftIO $ getComponentOptions cradle From b02bf3323eecc693110720cd2e5ac674129b4cb0 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 10 Mar 2020 21:55:49 +0000 Subject: [PATCH 12/25] Working on tests. Currently suspect the range we get to format the whole file is wrong, second time around. --- src/Ide/Plugin/Example.hs | 2 +- src/Ide/Plugin/Example2.hs | 59 +++++++++---- test/functional/FormatSpec.hs | 30 ++++--- test/functional/PluginSpec.hs | 28 +++--- test/testdata/BrittanyCRLF.hs | 8 +- test/testdata/BrittanyLF.hs | 4 +- test/testdata/Format.hs | 2 +- test/testdata/testdata.cabal | 158 ++++++++++++++++++---------------- test/utils/TestUtils.hs | 65 +++++++------- 9 files changed, 202 insertions(+), 154 deletions(-) diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index cb9077c3dd..113c1b25a0 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -163,7 +163,7 @@ addTodoCmd (AddTodoParams uri todoText) = do pos = Position 0 0 textEdits = List [TextEdit (Range pos pos) - ("-- TODO:" <> todoText) + ("-- TODO:" <> todoText <> "\n") ] res = WorkspaceEdit (Just $ Map.singleton uri textEdits) diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index 0baa03e3a1..0e6098a771 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -1,10 +1,10 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} @@ -15,25 +15,26 @@ module Ide.Plugin.Example2 import Control.DeepSeq ( NFData ) import Control.Monad.Trans.Maybe -import Data.Aeson.Types (toJSON) +import Data.Aeson import Data.Binary import Data.Functor import qualified Data.HashMap.Strict as Map -import Data.Hashable import qualified Data.HashSet as HashSet +import Data.Hashable import qualified Data.Text as T import Data.Typeable import Development.IDE.Core.OfInterest -import Development.IDE.Core.Rules import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Rules import Development.IDE.Core.Service import Development.IDE.Core.Shake import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.IDE.Types.Logger import Development.Shake hiding ( Diagnostic ) -import Ide.Types import GHC.Generics +import Ide.Plugin +import Ide.Types import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() @@ -43,12 +44,12 @@ descriptor :: PluginId -> PluginDescriptor descriptor plId = PluginDescriptor { pluginId = plId , pluginRules = exampleRules - , pluginCommands = [] + , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] , pluginCodeActionProvider = Just codeAction , pluginCodeLensProvider = Just codeLens , pluginDiagnosticProvider = Nothing - , pluginHoverProvider = Just hover - , pluginSymbolProvider = Nothing + , pluginHoverProvider = Just hover + , pluginSymbolProvider = Nothing , pluginFormattingProvider = Nothing , pluginCompletionProvider = Nothing } @@ -63,6 +64,8 @@ blah _ (Position line col) = return $ Just (Just (Range (Position line col) (Position (line+1) 0)), ["example hover 2\n"]) -- --------------------------------------------------------------------- +-- Generating Diagnostics via rules +-- --------------------------------------------------------------------- data Example2 = Example2 deriving (Eq, Show, Typeable, Generic) @@ -100,6 +103,8 @@ mkDiag file diagSource sev loc msg = (file, D.ShowDiag,) } -- --------------------------------------------------------------------- +-- code actions +-- --------------------------------------------------------------------- -- | Generate code actions. codeAction @@ -125,7 +130,8 @@ codeLens -> PluginId -> CodeLensParams -> IO (Either ResponseError (List CodeLens)) -codeLens ideState _plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = +codeLens ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + logInfo (ideLogger ideState) "Example2.codeLens entered (ideLogger)" -- AZ case uriToFilePath' uri of Just (toNormalizedFilePath -> filePath) -> do _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath @@ -133,16 +139,34 @@ codeLens ideState _plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} _hDiag <- getHiddenDiagnostics ideState let title = "Add TODO2 Item via Code Lens" - tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) - "-- TODO2 added by Example2 Plugin via code lens action\n"] - edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing range = Range (Position 3 0) (Position 4 0) - pure $ Right $ List - -- [ CodeLens range (Just (Command title "codelens.do" (Just $ List [toJSON edit]))) Nothing - [ CodeLens range (Just (Command title "codelens.todo" (Just $ List [toJSON edit]))) Nothing - ] + let cmdParams = AddTodoParams uri "do abc" + cmd <- mkLspCommand plId "codelens.todo" title (Just [toJSON cmdParams]) + pure $ Right $ List [ CodeLens range (Just cmd) Nothing ] Nothing -> pure $ Right $ List [] +-- --------------------------------------------------------------------- +-- | Parameters for the addTodo PluginCommand. +data AddTodoParams = AddTodoParams + { file :: Uri -- ^ Uri of the file to add the pragma to + , todoText :: T.Text + } + deriving (Show, Eq, Generic, ToJSON, FromJSON) + +addTodoCmd :: AddTodoParams -> IO (Either ResponseError Value, + Maybe (ServerMethod, ApplyWorkspaceEditParams)) +addTodoCmd (AddTodoParams uri todoText) = do + let + pos = Position 0 0 + textEdits = List + [TextEdit (Range pos pos) + ("-- TODO2:" <> todoText <> "\n") + ] + res = WorkspaceEdit + (Just $ Map.singleton uri textEdits) + Nothing + return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + -- --------------------------------------------------------------------- foundHover :: (Maybe Range, [T.Text]) -> Either ResponseError (Maybe Hover) @@ -166,7 +190,8 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc Nothing -> pure Nothing pure $ maybe notFound found mbResult -logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) + -> IdeState -> Position -> String -> IO b logAndRunRequest label getResults ide pos path = do let filePath = toNormalizedFilePath path logInfo (ideLogger ide) $ diff --git a/test/functional/FormatSpec.hs b/test/functional/FormatSpec.hs index 077a3f4cfc..8293e1ff03 100644 --- a/test/functional/FormatSpec.hs +++ b/test/functional/FormatSpec.hs @@ -26,7 +26,7 @@ spec = do describe "format range" $ do it "works" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" - formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + formatRange doc (FormattingOptions 2 True) (Range (Position 2 0) (Position 4 10)) documentContents doc >>= liftIO . (`shouldBe` formattedRangeTabSize2) it "works with custom tab size" $ do pendingWith "ormolu does not accept parameters" @@ -47,7 +47,7 @@ spec = do formatDoc doc (FormattingOptions 2 True) documentContents doc >>= liftIO . (`shouldBe` orig) - formatRange doc (FormattingOptions 2 True) (Range (Position 1 0) (Position 3 10)) + formatRange doc (FormattingOptions 2 True) (Range (Position 2 0) (Position 4 10)) documentContents doc >>= liftIO . (`shouldBe` orig) it "can change on the fly" $ runSession hieCommand fullCaps "test/testdata" $ do @@ -116,7 +116,8 @@ spec = do formattedDocOrmolu :: T.Text formattedDocOrmolu = - "module Format where\n\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ \foo x = x\n\n\ @@ -149,7 +150,8 @@ formattedDocTabSize5 = formattedRangeTabSize2 :: T.Text formattedRangeTabSize2 = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\ + \module Format where\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ \foo x = x\n\ @@ -157,11 +159,12 @@ formattedRangeTabSize2 = \bar s = do\n\ \ x <- return \"hello\"\n\ \ return \"asdf\"\n\ - \ \n" + \" formattedRangeTabSize5 :: T.Text formattedRangeTabSize5 = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ \foo x = x\n\ @@ -173,7 +176,8 @@ formattedRangeTabSize5 = formattedFloskell :: T.Text formattedFloskell = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ @@ -189,7 +193,8 @@ formattedFloskell = -- (duplicated last line) formattedFloskellPostBrittany :: T.Text formattedFloskellPostBrittany = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ @@ -204,7 +209,8 @@ formattedFloskellPostBrittany = formattedBrittanyPostFloskell :: T.Text formattedBrittanyPostFloskell = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ @@ -217,7 +223,8 @@ formattedBrittanyPostFloskell = formattedOrmolu :: T.Text formattedOrmolu = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ @@ -230,7 +237,8 @@ formattedOrmolu = unchangedOrmolu :: T.Text unchangedOrmolu = - "module Format where\n\ + "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ + \module Format where\n\ \foo :: Int -> Int\n\ \foo 3 = 2\n\ \foo x = x\n\ diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index 0b37bc6649..60233cab98 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeApplications #-} module PluginSpec where -import Control.Applicative.Combinators +-- import Control.Applicative.Combinators import Control.Lens hiding (List) -- import Control.Monad import Control.Monad.IO.Class @@ -44,24 +44,26 @@ spec = -- diag2 ^. L.source `shouldBe` Just "example" - cas@(CACodeAction ca:_) <- getAllCodeActions doc - liftIO $ length cas `shouldBe` 2 + _cas@(CACodeAction ca:_) <- getAllCodeActions doc + -- liftIO $ length cas `shouldBe` 2 - liftIO $ putStrLn $ "cas = " ++ show cas -- AZ + -- liftIO $ putStrLn $ "cas = " ++ show cas -- AZ liftIO $ [ca ^. L.title] `shouldContain` ["Add TODO Item 1"] - liftIO $ putStrLn $ "A" -- AZ + -- liftIO $ putStrLn $ "A" -- AZ executeCodeAction ca - liftIO $ putStrLn $ "B" -- AZ + -- liftIO $ putStrLn $ "B" -- AZ - _ <- skipManyTill anyMessage (message @RegisterCapabilityRequest) - liftIO $ putStrLn $ "B2" -- AZ + -- _ <- skipMany (message @RegisterCapabilityRequest) + -- liftIO $ putStrLn $ "B2" -- AZ - -- <- skipManyTill anyMessage $ between (satisfy startPred) (satisfy donePred) $ + _diags2 <- waitForDiagnostics + -- liftIO $ putStrLn $ "diags2 = " ++ show _diags2 -- AZ - contents <- getDocumentEdit doc - liftIO $ putStrLn $ "C" -- AZ - liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" + -- contents <- getDocumentEdit doc + -- liftIO $ putStrLn $ "C" -- AZ + -- liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" - noDiagnostics + -- noDiagnostics + return () diff --git a/test/testdata/BrittanyCRLF.hs b/test/testdata/BrittanyCRLF.hs index 2ed3293b3d..1bac0322e8 100644 --- a/test/testdata/BrittanyCRLF.hs +++ b/test/testdata/BrittanyCRLF.hs @@ -1,3 +1,5 @@ -foo :: Int -> String-> IO () -foo x y = do print x - return 42 \ No newline at end of file +module BrittanyCRLF where + +foo :: Int -> String-> IO () +foo x y = do print x + return () diff --git a/test/testdata/BrittanyLF.hs b/test/testdata/BrittanyLF.hs index 4662d9b5a8..3f54b9e4f2 100644 --- a/test/testdata/BrittanyLF.hs +++ b/test/testdata/BrittanyLF.hs @@ -1,3 +1,5 @@ +module BrittanyLF where + foo :: Int -> String-> IO () foo x y = do print x - return 42 \ No newline at end of file + return () diff --git a/test/testdata/Format.hs b/test/testdata/Format.hs index 76e40c9816..b3aff40f91 100644 --- a/test/testdata/Format.hs +++ b/test/testdata/Format.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Format where foo :: Int -> Int foo 3 = 2 @@ -6,4 +7,3 @@ bar :: String -> IO String bar s = do x <- return "hello" return "asdf" - diff --git a/test/testdata/testdata.cabal b/test/testdata/testdata.cabal index c191bbd1f1..04dc2a7073 100644 --- a/test/testdata/testdata.cabal +++ b/test/testdata/testdata.cabal @@ -3,80 +3,88 @@ version: 0.1.0.0 cabal-version: >=2.0 build-type: Simple -executable applyrefact +library build-depends: base - main-is: ApplyRefact.hs - default-language: Haskell2010 - -executable applyrefact2 - build-depends: base - main-is: ApplyRefact2.hs - default-language: Haskell2010 - -executable codeactionrename - build-depends: base - main-is: CodeActionRename.hs - default-language: Haskell2010 - -executable hover - build-depends: base - main-is: Hover.hs - default-language: Haskell2010 - -executable symbols - build-depends: base - main-is: Symbols.hs - default-language: Haskell2010 - - -executable applyrefact2 - build-depends: base - main-is: ApplyRefact2.hs - default-language: Haskell2010 - -executable hlintpragma - build-depends: base - main-is: HlintPragma.hs - default-language: Haskell2010 - -executable harecase - build-depends: base - main-is: HaReCase.hs - default-language: Haskell2010 - -executable haredemote - build-depends: base - main-is: HaReDemote.hs - default-language: Haskell2010 - -executable haremovedef - build-depends: base - main-is: HaReMoveDef.hs - default-language: Haskell2010 - -executable harerename - build-depends: base - main-is: HaReRename.hs - default-language: Haskell2010 - -executable haregenapplicative - build-depends: base - , parsec - main-is: HaReGA1.hs - default-language: Haskell2010 - -executable functests - build-depends: base - main-is: FuncTest.hs - default-language: Haskell2010 - -executable evens - build-depends: base - main-is: Evens.hs - hs-source-dirs: liquid - default-language: Haskell2010 - -executable filewithwarning - build-depends: base - main-is: FileWithWarning.hs default-language: Haskell2010 + exposed-modules: + BrittanyCRLF + BrittanyLF + Format + +-- executable applyrefact +-- build-depends: base +-- main-is: ApplyRefact.hs +-- default-language: Haskell2010 + +-- executable applyrefact2 +-- build-depends: base +-- main-is: ApplyRefact2.hs +-- default-language: Haskell2010 + +-- executable codeactionrename +-- build-depends: base +-- main-is: CodeActionRename.hs +-- default-language: Haskell2010 + +-- executable hover +-- build-depends: base +-- main-is: Hover.hs +-- default-language: Haskell2010 + +-- executable symbols +-- build-depends: base +-- main-is: Symbols.hs +-- default-language: Haskell2010 + + +-- executable applyrefact2 +-- build-depends: base +-- main-is: ApplyRefact2.hs +-- default-language: Haskell2010 + +-- executable hlintpragma +-- build-depends: base +-- main-is: HlintPragma.hs +-- default-language: Haskell2010 + +-- executable harecase +-- build-depends: base +-- main-is: HaReCase.hs +-- default-language: Haskell2010 + +-- executable haredemote +-- build-depends: base +-- main-is: HaReDemote.hs +-- default-language: Haskell2010 + +-- executable haremovedef +-- build-depends: base +-- main-is: HaReMoveDef.hs +-- default-language: Haskell2010 + +-- executable harerename +-- build-depends: base +-- main-is: HaReRename.hs +-- default-language: Haskell2010 + +-- executable haregenapplicative +-- build-depends: base +-- , parsec +-- main-is: HaReGA1.hs +-- default-language: Haskell2010 + +-- executable functests +-- build-depends: base +-- main-is: FuncTest.hs +-- default-language: Haskell2010 + +-- executable evens +-- build-depends: base +-- main-is: Evens.hs +-- hs-source-dirs: liquid +-- default-language: Haskell2010 + +-- executable filewithwarning +-- build-depends: base +-- main-is: FileWithWarning.hs +-- default-language: Haskell2010 diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 7718ef0919..32280c1acb 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -138,6 +138,7 @@ setupDirectFilesIn :: FilePath -> IO () setupDirectFilesIn f = writeFile (f ++ "hie.yaml") hieYamlCradleDirectContents + -- --------------------------------------------------------------------- files :: [FilePath] @@ -246,38 +247,38 @@ testdataHieYamlCradleStackContents = unlines [ "# WARNING: THIS FILE IS AUTOGENERATED IN test/utils/TestUtils.hs. IT WILL BE OVERWRITTEN ON EVERY TEST RUN" , "cradle:" , " stack:" - , " - path: \"ApplyRefact.hs\"" - , " component: \"testdata:exe:applyrefact\"" - , " - path: \"ApplyRefact2.hs\"" - , " component: \"testdata:exe:applyrefact2\"" - , " - path: \"CodeActionRename.hs\"" - , " component: \"testdata:exe:codeactionrename\"" - , " - path: \"Hover.hs\"" - , " component: \"testdata:exe:hover\"" - , " - path: \"Symbols.hs\"" - , " component: \"testdata:exe:symbols\"" - , " - path: \"ApplyRefact2.hs\"" - , " component: \"testdata:exe:applyrefact2\"" - , " - path: \"HlintPragma.hs\"" - , " component: \"testdata:exe:hlintpragma\"" - , " - path: \"HaReCase.hs\"" - , " component: \"testdata:exe:harecase\"" - , " - path: \"HaReDemote.hs\"" - , " component: \"testdata:exe:haredemote\"" - , " - path: \"HaReMoveDef.hs\"" - , " component: \"testdata:exe:haremovedef\"" - , " - path: \"HaReRename.hs\"" - , " component: \"testdata:exe:harerename\"" - , " - path: \"HaReGA1.hs\"" - , " component: \"testdata:exe:haregenapplicative\"" - , " - path: \"FuncTest.hs\"" - , " component: \"testdata:exe:functests\"" - , " - path: \"liquid/Evens.hs\"" - , " component: \"testdata:exe:evens\"" - , " - path: \"FileWithWarning.hs\"" - , " component: \"testdata:exe:filewithwarning\"" - , " - path: ." - , " component: \"testdata:exe:filewithwarning\"" + -- , " - path: \"ApplyRefact.hs\"" + -- , " component: \"testdata:exe:applyrefact\"" + -- , " - path: \"ApplyRefact2.hs\"" + -- , " component: \"testdata:exe:applyrefact2\"" + -- , " - path: \"CodeActionRename.hs\"" + -- , " component: \"testdata:exe:codeactionrename\"" + -- , " - path: \"Hover.hs\"" + -- , " component: \"testdata:exe:hover\"" + -- , " - path: \"Symbols.hs\"" + -- , " component: \"testdata:exe:symbols\"" + -- , " - path: \"ApplyRefact2.hs\"" + -- , " component: \"testdata:exe:applyrefact2\"" + -- , " - path: \"HlintPragma.hs\"" + -- , " component: \"testdata:exe:hlintpragma\"" + -- , " - path: \"HaReCase.hs\"" + -- , " component: \"testdata:exe:harecase\"" + -- , " - path: \"HaReDemote.hs\"" + -- , " component: \"testdata:exe:haredemote\"" + -- , " - path: \"HaReMoveDef.hs\"" + -- , " component: \"testdata:exe:haremovedef\"" + -- , " - path: \"HaReRename.hs\"" + -- , " component: \"testdata:exe:harerename\"" + -- , " - path: \"HaReGA1.hs\"" + -- , " component: \"testdata:exe:haregenapplicative\"" + -- , " - path: \"FuncTest.hs\"" + -- , " component: \"testdata:exe:functests\"" + -- , " - path: \"liquid/Evens.hs\"" + -- , " component: \"testdata:exe:evens\"" + -- , " - path: \"FileWithWarning.hs\"" + -- , " component: \"testdata:exe:filewithwarning\"" + -- , " - path: ." + -- , " component: \"testdata:exe:filewithwarning\"" ] From b91e5688148d473c23ecd48e094b63b2abf576b9 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 10 Mar 2020 23:09:55 +0000 Subject: [PATCH 13/25] Match changes to rebased ghcide --- exe/Rules.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/exe/Rules.hs b/exe/Rules.hs index 987fc0e982..00b6e178ca 100644 --- a/exe/Rules.hs +++ b/exe/Rules.hs @@ -17,10 +17,10 @@ import Data.ByteString.Base16 (encode) import qualified Data.ByteString.Char8 as B import Data.Functor ((<&>)) import Data.Maybe (fromMaybe) -import Data.Text (Text) +import Data.Text (pack, Text) import Development.IDE.Core.Rules (defineNoFile) import Development.IDE.Core.Service (getIdeOptions) -import Development.IDE.Core.Shake (sendEvent, define, useNoFile_) +import Development.IDE.Core.Shake (actionLogger, sendEvent, define, useNoFile_) import Development.IDE.GHC.Util import Development.IDE.Types.Location (fromNormalizedFilePath) import Development.IDE.Types.Options (IdeOptions(IdeOptions, optTesting)) @@ -42,6 +42,7 @@ import System.FilePath.Posix (addTrailingPathSeparator, import Language.Haskell.LSP.Messages as LSP import Language.Haskell.LSP.Types as LSP import Data.Aeson (ToJSON(toJSON)) +import Development.IDE.Types.Logger (logDebug) -- Prefix for the cache path cacheDir :: String @@ -63,18 +64,23 @@ loadGhcSession = cradleToSession :: Rules () cradleToSession = define $ \LoadCradle nfp -> do + let f = fromNormalizedFilePath nfp IdeOptions{optTesting} <- getIdeOptions + logger <- actionLogger + liftIO $ logDebug logger $ "Running cradle " <> pack (fromNormalizedFilePath nfp) + -- If the path points to a directory, load the implicit cradle mbYaml <- doesDirectoryExist f <&> \isDir -> if isDir then Nothing else Just f - cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml + cradle <- liftIO $ maybe (loadImplicitCradle $ addTrailingPathSeparator f) loadCradle mbYaml when optTesting $ sendEvent $ notifyCradleLoaded f - cmpOpts <- liftIO $ getComponentOptions cradle + -- Avoid interrupting `getComponentOptions` since it calls external processes + cmpOpts <- liftIO $ mask $ \_ -> getComponentOptions cradle let opts = componentOptions cmpOpts deps = componentDependencies cmpOpts deps' = case mbYaml of From e736ee15556ee4b7e4e14fbc05ea44cbc1865fb1 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 11 Mar 2020 20:58:52 +0000 Subject: [PATCH 14/25] Match changes in ghcide Moving PluginCommand into hls. --- src/Ide/Plugin.hs | 15 +++++++-------- src/Ide/Types.hs | 12 +++++++++++- 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs index 174b9fc739..fc64152842 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -28,7 +28,7 @@ import qualified Data.Text as T import Development.IDE.Core.Rules import Development.IDE.Core.Shake import Development.IDE.LSP.Server -import Development.IDE.Plugin hiding (pluginCommands, pluginRules) +import Development.IDE.Plugin hiding (pluginRules) import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Logger import Development.Shake hiding ( Diagnostic, command ) @@ -89,12 +89,12 @@ allLspCmdIds' pid mp = mkPlugin (allLspCmdIds pid) (Just . pluginCommands) -- --------------------------------------------------------------------- rulesPlugins :: [(PluginId, Rules ())] -> Plugin Config -rulesPlugins rs = Plugin mempty rules mempty +rulesPlugins rs = Plugin rules mempty where rules = mconcat $ map snd rs codeActionPlugins :: [(PluginId, CodeActionProvider)] -> Plugin Config -codeActionPlugins cas = Plugin mempty codeActionRules (codeActionHandlers cas) +codeActionPlugins cas = Plugin codeActionRules (codeActionHandlers cas) codeActionRules :: Rules () codeActionRules = mempty @@ -152,7 +152,7 @@ data FallbackCodeActionParams = -- ----------------------------------------------------------- codeLensPlugins :: [(PluginId, CodeLensProvider)] -> Plugin Config -codeLensPlugins cas = Plugin mempty codeLensRules (codeLensHandlers cas) +codeLensPlugins cas = Plugin codeLensRules (codeLensHandlers cas) codeLensRules :: Rules () codeLensRules = mempty @@ -192,7 +192,7 @@ makeCodeLens cas _lf ideState params = do -- ----------------------------------------------------------- executeCommandPlugins :: [(PluginId, [PluginCommand])] -> Plugin Config -executeCommandPlugins ecs = Plugin mempty mempty (executeCommandHandlers ecs) +executeCommandPlugins ecs = Plugin mempty (executeCommandHandlers ecs) executeCommandHandlers :: [(PluginId, [PluginCommand])] -> PartialHandlers Config executeCommandHandlers ecs = PartialHandlers $ \WithMessage{..} x -> return x{ @@ -370,7 +370,7 @@ allLspCmdIds pid commands = concat $ map go commands -- --------------------------------------------------------------------- hoverPlugins :: [(PluginId, HoverProvider)] -> Plugin Config -hoverPlugins hs = Plugin mempty hoverRules (hoverHandlers hs) +hoverPlugins hs = Plugin hoverRules (hoverHandlers hs) hoverRules :: Rules () hoverRules = mempty @@ -403,8 +403,7 @@ makeHover hps _lf ideState params formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config formatterPlugins providers - = Plugin mempty - formatterRules + = Plugin formatterRules (formatterHandlers (Map.fromList (("none",noneProvider):providers))) formatterRules :: Rules () diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs index 035719d5ee..aa75b76ed8 100644 --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -25,7 +25,7 @@ import qualified Data.Set as S import Data.String import qualified Data.Text as T import Development.IDE.Core.Rules -import Development.IDE.Plugin +-- import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location import Development.Shake @@ -70,6 +70,16 @@ data PluginDescriptor = -- , commandFunc :: a -> IO (Either ResponseError b) -- } +newtype CommandId = CommandId T.Text + deriving (Show, Read, Eq, Ord) +instance IsString CommandId where + fromString = CommandId . T.pack + +data PluginCommand = forall a. (FromJSON a) => + PluginCommand { commandId :: CommandId + , commandDesc :: T.Text + , commandFunc :: a -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) + } -- --------------------------------------------------------------------- type CodeActionProvider = IdeState From 43d63817234e96d6794e292d3ebc3f6fb33fc5e7 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Thu, 12 Mar 2020 21:50:24 +0000 Subject: [PATCH 15/25] Investigating the failing formatter tests. Conclusion is that getDocumentContents is returning junk, doing the idempotent test manually on vscode works as expected, but ends up with junk at the end of the file in the test. 2020-03-12 21:11:05.79062259 [ThreadId 38] - Formatter.doFormatting: contents= "{-# LANGUAGE NoImplicitPrelude #-} module Format where foo :: Int -> Int foo 3 = 2 foo x = x bar :: String -> IO String bar s = do x <- return \"hello\" return \"asdf\" " 2020-03-12 21:11:07.896114974 [ThreadId 7] - <--2--{"result":[{"range":{"start":{"line":0,"character":0},"end":{"line":9,"character":0}},"newText": "{-# LANGUAGE NoImplicitPrelude #-} module Format where foo :: Int -> Int foo 3 = 2 foo x = x bar :: String -> IO String bar s = do x <- return \"hello\" return \"asdf\" "}],"jsonrpc":"2.0","id":1} 2020-03-12 21:11:07.897123428 [ThreadId 5] - ---> {"jsonrpc":"2.0","method":"textDocument/didChange","params":{"textDocument":{"version":0,"uri":"file:///home/alanz/mysrc/github/alanz/haskell-language-server/test/testdata/Format.hs"},"contentChanges":[{"text": "{-# LANGUAGE NoImplicitPrelude #-} module Format where foo :: Int -> Int foo 3 = 2 foo x = x bar :: String -> IO String bar s = do x <- return \"hello\" return \"asdf\" ","range":{"start":{"line":0,"character":0},"end":{"line":9,"character":0}}}]}} ------------------------------------------------------- 2020-03-12 21:11:07.899375044 [ThreadId 213] - Formatter.doFormatting: contents="{-# LANGUAGE NoImplicitPrelude #-} module Format where foo :: Int -> Int foo 3 = 2 foo x = x bar :: String -> IO String bar s = do x <- return \"hello\" return \"asdf\" " 2020-03-12 21:11:07.902320214 [ThreadId 7] - <--2--{"result":[{"range":{"start":{"line":0,"character":0},"end":{"line":9,"character":0}},"newText":"{-# LANGUAGE NoImplicitPrelude #-} module Format where foo :: Int -> Int foo 3 = 2 foo x = x bar :: String -> IO String bar s = do x <- return \"hello\" return \"asdf\" "}],"jsonrpc":"2.0","id":2} 2020-03-12 21:11:07.902812215 [ThreadId 5] - ---> {"jsonrpc":"2.0","method":"textDocument/didChange","params":{"textDocument":{"version":0,"uri":"file:///home/alanz/mysrc/github/alanz/haskell-language-server/test/testdata/Format.hs"},"contentChanges":[{"text": "{-# LANGUAGE NoImplicitPrelude #-} module Format where foo :: Int -> Int foo 3 = 2 foo x = x bar :: String -> IO String bar s = do x <- return \"hello\" return \"asdf\" ","range":{"start":{"line":0,"character":0},"end":{"line":9,"character":0}}}]}} -------------------------------- hieCommand: haskell-language-server --lsp -d -l test-logs/hie-stack-8.6.5.yaml.log HIE cache is warmed up Format formatting provider formatting is idempotent FAILED [1] Failures: test/functional/FormatSpec.hs:64:42: 1) Format, formatting provider, formatting is idempotent expected: "{-# LANGUAGE NoImplicitPrelude #-}\n\nmodule Format where\n\nfoo :: Int -> Int\nfoo 3 = 2\nfoo x = x\n\nbar :: String -> IO String\nbar s = do\n x <- return \"hello\"\n return \"asdf\"\n" but got: "{-# LANGUAGE NoImplicitPrelude #-}\n\nmodule Format where\n\nfoo :: Int -> Int\nfoo 3 = 2\nfoo x = x\n\nbar :: String -> IO String\nbar s = do\n x <- return \"hello\"\n return \"asdf\"\nbar s = do\n x <- return \"hello\"\n return \"asdf\"\n" To rerun use: --match "/Format/formatting provider/formatting is idempotent/" Randomized with seed 1814425400 --- exe/Arguments.hs | 17 +++++++++++++++++ exe/Main.hs | 4 ++-- src/Ide/Plugin/Formatter.hs | 8 +++++++- test/functional/FormatSpec.hs | 19 ++++++++++++++++++- test/utils/TestUtils.hs | 3 ++- 5 files changed, 46 insertions(+), 5 deletions(-) diff --git a/exe/Arguments.hs b/exe/Arguments.hs index 67ff564a54..e495a82565 100644 --- a/exe/Arguments.hs +++ b/exe/Arguments.hs @@ -32,6 +32,11 @@ data Arguments = Arguments ,argsShakeProfiling :: Maybe FilePath ,argsTesting :: Bool ,argsExamplePlugin :: Bool + -- These next two are for compatibility with existing hie clients, allowing + -- them to just change the name of the exe and still work. + , argsDebugOn :: Bool + , argsLogFile :: Maybe String + } getArguments :: String -> IO Arguments @@ -57,6 +62,18 @@ arguments exeName = Arguments <*> switch (long "example" <> help "Include the Example Plugin. For Plugin devs only") + <*> switch + ( long "debug" + <> short 'd' + <> help "Generate debug output" + ) + <*> optional (strOption + ( long "logfile" + <> short 'l' + <> metavar "LOGFILE" + <> help "File to log to, defaults to stdout" + )) + -- --------------------------------------------------------------------- -- Set the GHC libdir to the nix libdir if it's present. getLibdir :: IO FilePath diff --git a/exe/Main.hs b/exe/Main.hs index 35fc696c4a..816c321f2b 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -128,8 +128,8 @@ main = do -- LSP.setupLogger (optLogFile opts) ["hie", "hie-bios"] -- $ if optDebugOn opts then L.DEBUG else L.INFO - LSP.setupLogger argsShakeProfiling ["hie", "hie-bios"] - $ if argsTesting then L.DEBUG else L.INFO + LSP.setupLogger argsLogFile ["hie", "hie-bios"] + $ if argsDebugOn then L.DEBUG else L.INFO -- lock to avoid overlapping output on stdout lock <- newLock diff --git a/src/Ide/Plugin/Formatter.hs b/src/Ide/Plugin/Formatter.hs index a5a90f564d..10bf289c9d 100644 --- a/src/Ide/Plugin/Formatter.hs +++ b/src/Ide/Plugin/Formatter.hs @@ -20,12 +20,15 @@ import qualified Data.Map as Map import qualified Data.Text as T import Development.IDE.Core.FileStore import Development.IDE.Core.Rules +import Development.IDE.Core.Shake -- import Development.IDE.LSP.Server -- import Development.IDE.Plugin import Development.IDE.Types.Diagnostics as D import Development.IDE.Types.Location -- import Development.Shake hiding ( Diagnostic ) +-- import Ide.Logger import Ide.Types +import Development.IDE.Types.Logger import Ide.Plugin.Config import qualified Language.Haskell.LSP.Core as LSP -- import Language.Haskell.LSP.Messages @@ -64,7 +67,10 @@ doFormatting lf providers ideState ft uri params = do Just (toNormalizedFilePath -> fp) -> do (_, mb_contents) <- runAction ideState $ getFileContents fp case mb_contents of - Just contents -> provider ideState ft contents fp params + Just contents -> do + logDebug (ideLogger ideState) $ T.pack $ + "Formatter.doFormatting: contents=" ++ show contents -- AZ + provider ideState ft contents fp params Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: could not get file contents for " ++ show uri Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: uriToFilePath failed for: " ++ show uri Nothing -> return $ Left $ responseError $ T.pack $ "Formatter plugin: no formatter found for:[" ++ T.unpack mf ++ "]" diff --git a/test/functional/FormatSpec.hs b/test/functional/FormatSpec.hs index 8293e1ff03..7bdeb3719a 100644 --- a/test/functional/FormatSpec.hs +++ b/test/functional/FormatSpec.hs @@ -50,6 +50,20 @@ spec = do formatRange doc (FormattingOptions 2 True) (Range (Position 2 0) (Position 4 10)) documentContents doc >>= liftIO . (`shouldBe` orig) + -- --------------------------------- + + it "formatting is idempotent" $ runSession hieCommand fullCaps "test/testdata" $ do + doc <- openDoc "Format.hs" "haskell" + + sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "ormolu")) + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (`shouldBe` formattedDocOrmolu) + + formatDoc doc (FormattingOptions 2 True) + documentContents doc >>= liftIO . (`shouldBe` formattedDocOrmolu) + + -- --------------------------------- + it "can change on the fly" $ runSession hieCommand fullCaps "test/testdata" $ do doc <- openDoc "Format.hs" "haskell" @@ -99,6 +113,8 @@ spec = do -- liftIO $ edits `shouldBe` [TextEdit (Range (Position 1 0) (Position 3 0)) -- "foo x y = do\n print x\n return 42\n"] + -- --------------------------------- + describe "ormolu" $ do let formatLspConfig provider = object [ "languageServerHaskell" .= object ["formattingProvider" .= (provider :: Value)] ] @@ -114,6 +130,8 @@ spec = do GHC86 -> formatted _ -> liftIO $ docContent `shouldBe` unchangedOrmolu +-- --------------------------------------------------------------------- + formattedDocOrmolu :: T.Text formattedDocOrmolu = "{-# LANGUAGE NoImplicitPrelude #-}\n\n\ @@ -204,7 +222,6 @@ formattedFloskellPostBrittany = \bar s = do\n\ \ x <- return \"hello\"\n\ \ return \"asdf\"\n\ - \ return \"asdf\"\n\ \" formattedBrittanyPostFloskell :: T.Text diff --git a/test/utils/TestUtils.hs b/test/utils/TestUtils.hs index 32280c1acb..7cb70cc1e4 100644 --- a/test/utils/TestUtils.hs +++ b/test/utils/TestUtils.hs @@ -207,7 +207,8 @@ logFilePath = "hie-" ++ stackYaml ++ ".log" hieCommand :: String -- hieCommand = "hie --lsp --bios-verbose -d -l test-logs/" ++ logFilePath -- hieCommand = "haskell-language-server --lsp" -hieCommand = "haskell-language-server --lsp --test --shake-profiling=test-logs/" ++ logFilePath +-- hieCommand = "haskell-language-server --lsp --test --shake-profiling=test-logs/" ++ logFilePath +hieCommand = "haskell-language-server --lsp -d -l test-logs/" ++ logFilePath hieCommandVomit :: String hieCommandVomit = hieCommand ++ " --vomit" From fa46f7fc2fb69944943ea8c5610d8802a56cf5a9 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 14 Mar 2020 15:43:29 +0000 Subject: [PATCH 16/25] Add symbols provider to plugin support --- src/Ide/Plugin.hs | 45 +++++++++++++++++++++++++++++++++++ src/Ide/Plugin/Example.hs | 21 ++++++++++++++-- src/Ide/Plugin/Example2.hs | 21 ++++++++++++++-- src/Ide/Plugin/Floskell.hs | 2 +- src/Ide/Plugin/Ormolu.hs | 2 +- src/Ide/Plugin/Pragmas.hs | 2 +- src/Ide/Types.hs | 7 ++++-- test/functional/PluginSpec.hs | 39 ++++++++++++++++++++++++++++-- 8 files changed, 128 insertions(+), 11 deletions(-) diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs index fc64152842..4074fa1458 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -15,6 +15,7 @@ module Ide.Plugin , allLspCmdIds , allLspCmdIds' , getPid + , responseError ) where import Control.Lens ( (^.) ) @@ -59,6 +60,7 @@ asGhcIdePlugin mp = -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider mkPlugin hoverPlugins pluginHoverProvider <> -- TODO: symbols via pluginSymbolProvider + mkPlugin symbolsPlugin pluginSymbolsProvider <> mkPlugin formatterPlugins pluginFormattingProvider -- TODO: completions where @@ -401,6 +403,49 @@ makeHover hps _lf ideState params -- --------------------------------------------------------------------- -- --------------------------------------------------------------------- +symbolsPlugin :: [(PluginId, SymbolsProvider)] -> Plugin Config +symbolsPlugin hs = Plugin symbolsRules (symbolsHandlers hs) + +symbolsRules :: Rules () +symbolsRules = mempty + +symbolsHandlers :: [(PluginId, SymbolsProvider)] -> PartialHandlers Config +symbolsHandlers hps = PartialHandlers $ \WithMessage{..} x -> + return x {LSP.documentSymbolHandler = withResponse RspDocumentSymbols (makeSymbols hps)} + +makeSymbols :: [(PluginId, SymbolsProvider)] + -> LSP.LspFuncs Config + -> IdeState + -> DocumentSymbolParams + -> IO (Either ResponseError DSResult) +makeSymbols sps lf ideState params + = do + let uri' = params ^. textDocument . uri + (C.ClientCapabilities _ tdc _ _) = LSP.clientCapabilities lf + supportsHierarchy = fromMaybe False $ tdc >>= C._documentSymbol + >>= C._hierarchicalDocumentSymbolSupport + convertSymbols :: [DocumentSymbol] -> DSResult + convertSymbols symbs + | supportsHierarchy = DSDocumentSymbols $ List symbs + | otherwise = DSSymbolInformation (List $ concatMap (go Nothing) symbs) + where + go :: Maybe T.Text -> DocumentSymbol -> [SymbolInformation] + go parent ds = + let children' :: [SymbolInformation] + children' = concatMap (go (Just name')) (fromMaybe mempty (ds ^. children)) + loc = Location uri' (ds ^. range) + name' = ds ^. name + si = SymbolInformation name' (ds ^. kind) (ds ^. deprecated) loc parent + in [si] <> children' + + mhs <- mapM (\(_,p) -> p ideState params) sps + case rights mhs of + [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs + hs -> return $ Right $ convertSymbols $ concat hs + +-- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + formatterPlugins :: [(PluginId, FormattingProvider IO)] -> Plugin Config formatterPlugins providers = Plugin formatterRules diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index 113c1b25a0..c8b4e5906c 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -48,8 +48,8 @@ descriptor plId = PluginDescriptor , pluginCodeActionProvider = Just codeAction , pluginCodeLensProvider = Just codeLens , pluginDiagnosticProvider = Nothing - , pluginHoverProvider = Just hover - , pluginSymbolProvider = Nothing + , pluginHoverProvider = Just hover + , pluginSymbolsProvider = Just symbols , pluginFormattingProvider = Nothing , pluginCompletionProvider = Nothing } @@ -201,3 +201,20 @@ logAndRunRequest label getResults ide pos path = do label <> " request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack path runAction ide $ getResults filePath pos + +-- --------------------------------------------------------------------- + +symbols :: SymbolsProvider +symbols _ide (DocumentSymbolParams _doc _mt) + = pure $ Right [r] + where + r = DocumentSymbol name detail kind deprecation range selR chList + name = "Example_symbol_name" + detail = Nothing + kind = SkVariable + deprecation = Nothing + range = Range (Position 2 0) (Position 2 5) + selR = range + chList = Nothing + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index 0e6098a771..32d02a503c 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -48,8 +48,8 @@ descriptor plId = PluginDescriptor , pluginCodeActionProvider = Just codeAction , pluginCodeLensProvider = Just codeLens , pluginDiagnosticProvider = Nothing - , pluginHoverProvider = Just hover - , pluginSymbolProvider = Nothing + , pluginHoverProvider = Just hover + , pluginSymbolsProvider = Just symbols , pluginFormattingProvider = Nothing , pluginCompletionProvider = Nothing } @@ -198,3 +198,20 @@ logAndRunRequest label getResults ide pos path = do label <> " request at position " <> T.pack (showPosition pos) <> " in file: " <> T.pack path runAction ide $ getResults filePath pos + +-- --------------------------------------------------------------------- + +symbols :: SymbolsProvider +symbols _ide (DocumentSymbolParams _doc _mt) + = pure $ Right [r] + where + r = DocumentSymbol name detail kind deprecation range selR chList + name = "Example2_symbol_name" + detail = Nothing + kind = SkVariable + deprecation = Nothing + range = Range (Position 4 1) (Position 4 7) + selR = range + chList = Nothing + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Floskell.hs b/src/Ide/Plugin/Floskell.hs index c30a4e8358..bd8e3f9ea7 100644 --- a/src/Ide/Plugin/Floskell.hs +++ b/src/Ide/Plugin/Floskell.hs @@ -34,7 +34,7 @@ descriptor plId = PluginDescriptor , pluginCodeLensProvider = Nothing , pluginDiagnosticProvider = Nothing , pluginHoverProvider = Nothing - , pluginSymbolProvider = Nothing + , pluginSymbolsProvider = Nothing , pluginFormattingProvider = Just provider , pluginCompletionProvider = Nothing } diff --git a/src/Ide/Plugin/Ormolu.hs b/src/Ide/Plugin/Ormolu.hs index ba09c7c42f..dcf8dcc692 100644 --- a/src/Ide/Plugin/Ormolu.hs +++ b/src/Ide/Plugin/Ormolu.hs @@ -42,7 +42,7 @@ descriptor plId = PluginDescriptor , pluginCodeLensProvider = Nothing , pluginDiagnosticProvider = Nothing , pluginHoverProvider = Nothing - , pluginSymbolProvider = Nothing + , pluginSymbolsProvider = Nothing , pluginFormattingProvider = Just provider , pluginCompletionProvider = Nothing } diff --git a/src/Ide/Plugin/Pragmas.hs b/src/Ide/Plugin/Pragmas.hs index e61e1f77a5..f0a7afce15 100644 --- a/src/Ide/Plugin/Pragmas.hs +++ b/src/Ide/Plugin/Pragmas.hs @@ -32,7 +32,7 @@ descriptor plId = PluginDescriptor , pluginCodeLensProvider = Nothing , pluginDiagnosticProvider = Nothing , pluginHoverProvider = Nothing - , pluginSymbolProvider = Nothing + , pluginSymbolsProvider = Nothing , pluginFormattingProvider = Nothing , pluginCompletionProvider = Nothing } diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs index aa75b76ed8..f3546dd766 100644 --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -10,6 +10,7 @@ module Ide.Types , CommandId(..) , DiagnosticProvider(..) , DiagnosticProviderFunc(..) + , SymbolsProvider , FormattingType(..) , FormattingProvider , HoverProvider @@ -51,7 +52,7 @@ data PluginDescriptor = -- ^ TODO: diagnostics are generally provided via rules, -- this is probably redundant. , pluginHoverProvider :: !(Maybe HoverProvider) - , pluginSymbolProvider :: !(Maybe SymbolProvider) + , pluginSymbolsProvider :: !(Maybe SymbolsProvider) , pluginFormattingProvider :: !(Maybe (FormattingProvider IO)) , pluginCompletionProvider :: !(Maybe CompletionProvider) } @@ -122,7 +123,9 @@ data DiagnosticTrigger = DiagnosticOnOpen -- type HoverProvider = Uri -> Position -> IO (Either ResponseError [Hover]) type HoverProvider = IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -type SymbolProvider = Uri -> IO (Either ResponseError [DocumentSymbol]) +type SymbolsProvider = IdeState + -> DocumentSymbolParams + -> IO (Either ResponseError [DocumentSymbol]) type ExecuteCommandProvider = IdeState -> ExecuteCommandParams diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index 60233cab98..b6f9c6c02b 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeApplications #-} module PluginSpec where --- import Control.Applicative.Combinators +import Control.Applicative.Combinators import Control.Lens hiding (List) -- import Control.Monad import Control.Monad.IO.Class @@ -27,7 +27,7 @@ import TestUtils -- --------------------------------------------------------------------- spec :: Spec -spec = +spec = do describe "composes code actions" $ it "provides 3.8 code actions" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do @@ -67,3 +67,38 @@ spec = -- noDiagnostics return () + + describe "symbol providers" $ + it "combines symbol providers" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do + + doc <- openDoc "Format.hs" "haskell" + + _ <- waitForDiagnostics + + id2 <- sendRequest TextDocumentDocumentSymbol (DocumentSymbolParams doc Nothing) + symbolsRsp <- skipManyTill anyNotification message :: Session DocumentSymbolsResponse + liftIO $ symbolsRsp ^. L.id `shouldBe` responseId id2 + + liftIO $ symbolsRsp ^. L.result `shouldBe` + Just (DSDocumentSymbols + (List [DocumentSymbol + "Example_symbol_name" + Nothing + SkVariable + Nothing + (Range {_start = Position {_line = 2, _character = 0} + , _end = Position {_line = 2, _character = 5}}) + (Range {_start = Position {_line = 2, _character = 0} + , _end = Position {_line = 2, _character = 5}}) + Nothing + ,DocumentSymbol "Example2_symbol_name" + Nothing + SkVariable + Nothing + (Range {_start = Position {_line = 4, _character = 1} + , _end = Position {_line = 4, _character = 7}}) + (Range {_start = Position {_line = 4, _character = 1} + , _end = Position {_line = 4, _character = 7}}) + Nothing])) + + return () From c4db76dc103f6fbe698181a92360d64008a04dfb Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 15 Mar 2020 11:20:57 +0000 Subject: [PATCH 17/25] Add initial support for completion plugins The CompletionProvider handler type should probably be extended to include a WithSnippets parameter, and the prefix. --- src/Ide/Plugin.hs | 95 +++++++++++++++++++++++++++++++++++--- src/Ide/Plugin/Example.hs | 28 ++++++++++- src/Ide/Plugin/Example2.hs | 28 ++++++++++- src/Ide/Types.hs | 3 ++ 4 files changed, 146 insertions(+), 8 deletions(-) diff --git a/src/Ide/Plugin.hs b/src/Ide/Plugin.hs index 4074fa1458..2f1a36498f 100644 --- a/src/Ide/Plugin.hs +++ b/src/Ide/Plugin.hs @@ -21,6 +21,7 @@ module Ide.Plugin import Control.Lens ( (^.) ) import Control.Monad import qualified Data.Aeson as J +import qualified Data.Default import Data.Either import qualified Data.List as List import qualified Data.Map as Map @@ -44,6 +45,7 @@ import Language.Haskell.LSP.Types import qualified Language.Haskell.LSP.Types as J import qualified Language.Haskell.LSP.Types.Capabilities as C import Language.Haskell.LSP.Types.Lens as L hiding (formatting, rangeFormatting) +import qualified Language.Haskell.LSP.VFS as VFS import Text.Regex.TDFA.Text() -- --------------------------------------------------------------------- @@ -59,10 +61,9 @@ asGhcIdePlugin mp = mkPlugin codeLensPlugins pluginCodeLensProvider <> -- Note: diagnostics are provided via Rules from pluginDiagnosticProvider mkPlugin hoverPlugins pluginHoverProvider <> - -- TODO: symbols via pluginSymbolProvider - mkPlugin symbolsPlugin pluginSymbolsProvider <> - mkPlugin formatterPlugins pluginFormattingProvider - -- TODO: completions + mkPlugin symbolsPlugins pluginSymbolsProvider <> + mkPlugin formatterPlugins pluginFormattingProvider <> + mkPlugin completionsPlugins pluginCompletionProvider where justs (p, Just x) = [(p, x)] justs (_, Nothing) = [] @@ -403,8 +404,8 @@ makeHover hps _lf ideState params -- --------------------------------------------------------------------- -- --------------------------------------------------------------------- -symbolsPlugin :: [(PluginId, SymbolsProvider)] -> Plugin Config -symbolsPlugin hs = Plugin symbolsRules (symbolsHandlers hs) +symbolsPlugins :: [(PluginId, SymbolsProvider)] -> Plugin Config +symbolsPlugins hs = Plugin symbolsRules (symbolsHandlers hs) symbolsRules :: Rules () symbolsRules = mempty @@ -463,3 +464,85 @@ formatterHandlers providers = PartialHandlers $ \WithMessage{..} x -> return x } -- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- + +completionsPlugins :: [(PluginId, CompletionProvider)] -> Plugin Config +completionsPlugins cs = Plugin completionsRules (completionsHandlers cs) + +completionsRules :: Rules () +completionsRules = mempty + +completionsHandlers :: [(PluginId, CompletionProvider)] -> PartialHandlers Config +completionsHandlers cps = PartialHandlers $ \WithMessage{..} x -> + return x {LSP.completionHandler = withResponse RspCompletion (makeCompletions cps)} + +makeCompletions :: [(PluginId, CompletionProvider)] + -> LSP.LspFuncs Config + -> IdeState + -> CompletionParams + -> IO (Either ResponseError CompletionResponseResult) +makeCompletions sps lf ideState params@(CompletionParams (TextDocumentIdentifier doc) pos _context _mt) + = do + mprefix <- getPrefixAtPos lf doc pos + _snippets <- WithSnippets <$> completionSnippetsOn <$> (getClientConfig lf) + + let + combine :: [CompletionResponseResult] -> CompletionResponseResult + combine cs = go (Completions $ List []) cs + where + go acc [] = acc + go (Completions (List ls)) (Completions (List ls2):rest) + = go (Completions (List (ls <> ls2))) rest + go (Completions (List ls)) (CompletionList (CompletionListType complete (List ls2)):rest) + = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest + go (CompletionList (CompletionListType complete (List ls))) (CompletionList (CompletionListType complete2 (List ls2)):rest) + = go (CompletionList $ CompletionListType (complete || complete2) (List (ls <> ls2))) rest + go (CompletionList (CompletionListType complete (List ls))) (Completions (List ls2):rest) + = go (CompletionList $ CompletionListType complete (List (ls <> ls2))) rest + + case mprefix of + Nothing -> return $ Right $ Completions $ List [] + Just _prefix -> do + mhs <- mapM (\(_,p) -> p ideState params) sps + case rights mhs of + [] -> return $ Left $ responseError $ T.pack $ show $ lefts mhs + hs -> return $ Right $ combine hs + +{- + ReqCompletion req -> do + liftIO $ U.logs $ "reactor:got CompletionRequest:" ++ show req + let (_, doc, pos) = reqParams req + + mprefix <- getPrefixAtPos doc pos + + let callback compls = do + let rspMsg = Core.makeResponseMessage req + $ J.Completions $ J.List compls + reactorSend $ RspCompletion rspMsg + case mprefix of + Nothing -> callback [] + Just prefix -> do + snippets <- Completions.WithSnippets <$> configVal completionSnippetsOn + let hreq = IReq tn "completion" (req ^. J.id) callback + $ lift $ Completions.getCompletions doc prefix snippets + makeRequest hreq +-} + +getPrefixAtPos :: LSP.LspFuncs Config -> Uri -> Position -> IO (Maybe VFS.PosPrefixInfo) +getPrefixAtPos lf uri pos = do + mvf <- (LSP.getVirtualFileFunc lf) (J.toNormalizedUri uri) + case mvf of + Just vf -> VFS.getCompletionPrefix pos vf + Nothing -> return Nothing + +-- --------------------------------------------------------------------- +-- | Returns the current client configuration. It is not wise to permanently +-- cache the returned value of this function, as clients can at runitime change +-- their configuration. +-- +-- If no custom configuration has been set by the client, this function returns +-- our own defaults. +getClientConfig :: LSP.LspFuncs Config -> IO Config +getClientConfig lf = fromMaybe Data.Default.def <$> LSP.config lf + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index c8b4e5906c..d8ecffadd5 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -51,7 +51,7 @@ descriptor plId = PluginDescriptor , pluginHoverProvider = Just hover , pluginSymbolsProvider = Just symbols , pluginFormattingProvider = Nothing - , pluginCompletionProvider = Nothing + , pluginCompletionProvider = Just completion } -- --------------------------------------------------------------------- @@ -218,3 +218,29 @@ symbols _ide (DocumentSymbolParams _doc _mt) chList = Nothing -- --------------------------------------------------------------------- + +completion :: CompletionProvider +completion _ide (CompletionParams _doc _pos _mctxt _mt) + = pure $ Right $ Completions $ List [r] + where + r = CompletionItem label kind detail documentation deprecated preselect + sortText filterText insertText insertTextFormat + textEdit additionalTextEdits commitCharacters + command xd + label = "Example completion" + kind = Nothing + detail = Nothing + documentation = Nothing + deprecated = Nothing + preselect = Nothing + sortText = Nothing + filterText = Nothing + insertText = Nothing + insertTextFormat = Nothing + textEdit = Nothing + additionalTextEdits = Nothing + commitCharacters = Nothing + command = Nothing + xd = Nothing + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index 32d02a503c..e4ecf8dc6a 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -51,7 +51,7 @@ descriptor plId = PluginDescriptor , pluginHoverProvider = Just hover , pluginSymbolsProvider = Just symbols , pluginFormattingProvider = Nothing - , pluginCompletionProvider = Nothing + , pluginCompletionProvider = Just completion } -- --------------------------------------------------------------------- @@ -215,3 +215,29 @@ symbols _ide (DocumentSymbolParams _doc _mt) chList = Nothing -- --------------------------------------------------------------------- + +completion :: CompletionProvider +completion _ide (CompletionParams _doc _pos _mctxt _mt) + = pure $ Right $ Completions $ List [r] + where + r = CompletionItem label kind detail documentation deprecated preselect + sortText filterText insertText insertTextFormat + textEdit additionalTextEdits commitCharacters + command xd + label = "Example2 completion" + kind = Nothing + detail = Nothing + documentation = Nothing + deprecated = Nothing + preselect = Nothing + sortText = Nothing + filterText = Nothing + insertText = Nothing + insertTextFormat = Nothing + textEdit = Nothing + additionalTextEdits = Nothing + commitCharacters = Nothing + command = Nothing + xd = Nothing + +-- --------------------------------------------------------------------- diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs index f3546dd766..3c1339433c 100644 --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -18,6 +18,7 @@ module Ide.Types , CodeLensProvider , ExecuteCommandProvider , CompletionProvider + , WithSnippets(..) ) where import Data.Aeson hiding (defaultOptions) @@ -131,6 +132,8 @@ type ExecuteCommandProvider = IdeState -> ExecuteCommandParams -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) +newtype WithSnippets = WithSnippets Bool + type CompletionProvider = IdeState -> CompletionParams -> IO (Either ResponseError CompletionResponseResult) From 7552c58c9333ecad972f63dd75ea5e19577da926 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 15 Mar 2020 11:27:32 +0000 Subject: [PATCH 18/25] Mark documentContents failing tests pending It seems lsp-test is not applying edits properly, doing the same sequence in vscode results in the correct result. --- src/Ide/Cradle.hs | 3 +-- test/functional/FormatSpec.hs | 2 ++ 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Ide/Cradle.hs b/src/Ide/Cradle.hs index 660b681a61..b27782544e 100644 --- a/src/Ide/Cradle.hs +++ b/src/Ide/Cradle.hs @@ -31,8 +31,7 @@ import qualified HIE.Bios.Types as Bios import System.Directory (getCurrentDirectory, canonicalizePath, findExecutable) import System.Exit import System.FilePath -import System.Log.Logger -import System.Process (readCreateProcessWithExitCode, shell) +import System.Process (readCreateProcessWithExitCode, shell, CreateProcess(..)) -- --------------------------------------------------------------------- diff --git a/test/functional/FormatSpec.hs b/test/functional/FormatSpec.hs index 7bdeb3719a..66db73c202 100644 --- a/test/functional/FormatSpec.hs +++ b/test/functional/FormatSpec.hs @@ -60,6 +60,7 @@ spec = do documentContents doc >>= liftIO . (`shouldBe` formattedDocOrmolu) formatDoc doc (FormattingOptions 2 True) + liftIO $ pendingWith "documentContents returns junk" documentContents doc >>= liftIO . (`shouldBe` formattedDocOrmolu) -- --------------------------------- @@ -76,6 +77,7 @@ spec = do sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "floskell")) formatDoc doc (FormattingOptions 2 True) + liftIO $ pendingWith "documentContents returns junk" documentContents doc >>= liftIO . (`shouldBe` formattedFloskellPostBrittany) -- sendNotification WorkspaceDidChangeConfiguration (DidChangeConfigurationParams (formatLspConfig "brittany")) From c43790b676c7111f4f2a2b05723b86e77a709f73 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 15 Mar 2020 12:38:07 +0000 Subject: [PATCH 19/25] Make sure the test-logs directory exists Otherwise the tests crash. --- .gitignore | 2 +- test-logs/README.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) create mode 100644 test-logs/README.md diff --git a/.gitignore b/.gitignore index 391cea0db2..f2807263aa 100644 --- a/.gitignore +++ b/.gitignore @@ -13,7 +13,7 @@ stack*.yaml.lock shake.yaml.lock .vscode -/test-logs/ +/test-logs/*.log # stack 2.1 stack.yaml lock files stack*.yaml.lock diff --git a/test-logs/README.md b/test-logs/README.md new file mode 100644 index 0000000000..ab5a8efcca --- /dev/null +++ b/test-logs/README.md @@ -0,0 +1 @@ +## When the tests run, the logs get put here. From 750bb586b02b7ada9655ee091bead486ae3f0432 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sun, 15 Mar 2020 13:46:29 +0000 Subject: [PATCH 20/25] Assist with windows compatibility --- haskell-language-server.cabal | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 78158c1bcc..a3076a8af3 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -72,8 +72,11 @@ library , shake >= 0.17.5 , text , transformers - , unix , unordered-containers + if os(windows) + build-depends: Win32 + else + build-depends: unix if impl(ghc >= 8.6) build-depends: ormolu >= 0.0.3.1 From e95257658635baa96c34e777eaeb097095d2a06f Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 16 Mar 2020 18:18:08 +0000 Subject: [PATCH 21/25] Switch to using ghcide master again --- .gitmodules | 4 ++-- ghcide | 2 +- stack-8.6.4.yaml | 1 + stack-8.6.5.yaml | 1 + stack.yaml | 1 + 5 files changed, 6 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index 7faeadd5ea..f7d6551110 100644 --- a/.gitmodules +++ b/.gitmodules @@ -10,5 +10,5 @@ # rm -rf path_to_submodule [submodule "ghcide"] path = ghcide - # url = https://github.com/digital-asset/ghcide.git - url = https://github.com/alanz/ghcide.git + url = https://github.com/digital-asset/ghcide.git + # url = https://github.com/alanz/ghcide.git diff --git a/ghcide b/ghcide index 63aa7a1b08..8b328bb7c5 160000 --- a/ghcide +++ b/ghcide @@ -1 +1 @@ -Subproject commit 63aa7a1b08051db4b4814b5976abae6d5f8af4f0 +Subproject commit 8b328bb7c5f3e09280788b56abd6fb6d0bfb08ce diff --git a/stack-8.6.4.yaml b/stack-8.6.4.yaml index 9553fedf96..8a423908b4 100644 --- a/stack-8.6.4.yaml +++ b/stack-8.6.4.yaml @@ -40,6 +40,7 @@ extra-deps: - rope-utf16-splay-0.3.1.0 - shake-0.18.5 - syz-0.2.0.0 +- tasty-rerun-1.1.17 - temporary-1.2.1.1 - unix-compat-0.5.2 - unordered-containers-0.2.10.0 diff --git a/stack-8.6.5.yaml b/stack-8.6.5.yaml index 502876e4dc..09e70f6958 100644 --- a/stack-8.6.5.yaml +++ b/stack-8.6.5.yaml @@ -31,6 +31,7 @@ extra-deps: - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - semialign-1.1 +- tasty-rerun-1.1.17 - temporary-1.2.1.1 - topograph-1 diff --git a/stack.yaml b/stack.yaml index dc60f2eaaa..962025b4e5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -31,6 +31,7 @@ extra-deps: - regex-pcre-builtin-0.95.1.1.8.43 - regex-tdfa-1.3.1.0 - semialign-1.1 +- tasty-rerun-1.1.17 - temporary-1.2.1.1 - topograph-1 From 20746cf61f4da33b0469bc60b77a6e2157966919 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 16 Mar 2020 18:37:50 +0000 Subject: [PATCH 22/25] Print some progress on the tests --- test/functional/PluginSpec.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index b6f9c6c02b..88a26473df 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -51,9 +51,9 @@ spec = do liftIO $ [ca ^. L.title] `shouldContain` ["Add TODO Item 1"] - -- liftIO $ putStrLn $ "A" -- AZ + liftIO $ putStrLn $ "A" -- AZ executeCodeAction ca - -- liftIO $ putStrLn $ "B" -- AZ + liftIO $ putStrLn $ "B" -- AZ -- _ <- skipMany (message @RegisterCapabilityRequest) -- liftIO $ putStrLn $ "B2" -- AZ @@ -62,7 +62,7 @@ spec = do -- liftIO $ putStrLn $ "diags2 = " ++ show _diags2 -- AZ -- contents <- getDocumentEdit doc - -- liftIO $ putStrLn $ "C" -- AZ + liftIO $ putStrLn $ "C" -- AZ -- liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" -- noDiagnostics From fd28518c48b86fe50bf25dcf459ef5dcd5420704 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 16 Mar 2020 20:23:05 +0000 Subject: [PATCH 23/25] Put test id in the logs --- test/functional/PluginSpec.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index 88a26473df..28d7297b14 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -11,7 +11,7 @@ import Control.Monad.IO.Class -- import Data.Default -- import qualified Data.HashMap.Strict as HM -- import Data.Maybe --- import qualified Data.Text as T +import qualified Data.Text as T -- import Language.Haskell.LSP.Test import Language.Haskell.LSP.Test as Test import Language.Haskell.LSP.Types @@ -31,6 +31,9 @@ spec = do describe "composes code actions" $ it "provides 3.8 code actions" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do + -- sendNotification (CustomClientMethod "$/progress") (T.pack "provides 3.8 code actions") + sendNotification (CustomClientMethod "$/testid") (T.pack "provides 3.8 code actions") + doc <- openDoc "Format.hs" "haskell" _diags@(diag1:_) <- waitForDiagnostics From 2ebf7ae37069417ffb3b152d30ada641bbb7d5c0 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 16 Mar 2020 20:49:54 +0000 Subject: [PATCH 24/25] Add a "mark" function to write to stdout and the test log For correlating with circleci logs --- test/functional/PluginSpec.hs | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index 28d7297b14..aaa327fed9 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -26,13 +26,20 @@ import TestUtils -- --------------------------------------------------------------------- +-- | Put a text marker on stdout in the client and the server log +mark :: String -> Session () +mark str = do + sendNotification (CustomClientMethod "$/testid") (T.pack str) + liftIO $ putStrLn str + +-- --------------------------------------------------------------------- + spec :: Spec spec = do describe "composes code actions" $ it "provides 3.8 code actions" $ runSession hieCommandExamplePlugin fullCaps "test/testdata" $ do - -- sendNotification (CustomClientMethod "$/progress") (T.pack "provides 3.8 code actions") - sendNotification (CustomClientMethod "$/testid") (T.pack "provides 3.8 code actions") + mark "provides 3.8 code actions" doc <- openDoc "Format.hs" "haskell" _diags@(diag1:_) <- waitForDiagnostics @@ -54,9 +61,9 @@ spec = do liftIO $ [ca ^. L.title] `shouldContain` ["Add TODO Item 1"] - liftIO $ putStrLn $ "A" -- AZ + mark "A" -- AZ executeCodeAction ca - liftIO $ putStrLn $ "B" -- AZ + mark "B" -- AZ -- _ <- skipMany (message @RegisterCapabilityRequest) -- liftIO $ putStrLn $ "B2" -- AZ @@ -65,7 +72,7 @@ spec = do -- liftIO $ putStrLn $ "diags2 = " ++ show _diags2 -- AZ -- contents <- getDocumentEdit doc - liftIO $ putStrLn $ "C" -- AZ + mark "C" -- AZ -- liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" -- noDiagnostics From cebd00fab094e943635fca9dfec7edbe6e40d372 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 16 Mar 2020 22:36:02 +0000 Subject: [PATCH 25/25] Get tests to pass --- src/Ide/Plugin/Example.hs | 4 ++-- src/Ide/Plugin/Example2.hs | 4 ++-- test/functional/PluginSpec.hs | 15 ++++++++------- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Ide/Plugin/Example.hs b/src/Ide/Plugin/Example.hs index d8ecffadd5..0ea345cef3 100644 --- a/src/Ide/Plugin/Example.hs +++ b/src/Ide/Plugin/Example.hs @@ -117,7 +117,7 @@ codeAction codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let title = "Add TODO Item 1" - tedit = [TextEdit (Range (Position 0 0) (Position 0 0)) + tedit = [TextEdit (Range (Position 2 0) (Position 2 0)) "-- TODO1 added by Example Plugin directly\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing pure $ Right $ List @@ -160,7 +160,7 @@ addTodoCmd :: AddTodoParams -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) addTodoCmd (AddTodoParams uri todoText) = do let - pos = Position 0 0 + pos = Position 3 0 textEdits = List [TextEdit (Range pos pos) ("-- TODO:" <> todoText <> "\n") diff --git a/src/Ide/Plugin/Example2.hs b/src/Ide/Plugin/Example2.hs index e4ecf8dc6a..60f8d54d64 100644 --- a/src/Ide/Plugin/Example2.hs +++ b/src/Ide/Plugin/Example2.hs @@ -117,7 +117,7 @@ codeAction codeAction _state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do let title = "Add TODO2 Item" - tedit = [TextEdit (Range (Position 0 0) (Position 0 0)) + tedit = [TextEdit (Range (Position 3 0) (Position 3 0)) "-- TODO2 added by Example2 Plugin directly\n"] edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing pure $ Right $ List @@ -157,7 +157,7 @@ addTodoCmd :: AddTodoParams -> IO (Either ResponseError Value, Maybe (ServerMethod, ApplyWorkspaceEditParams)) addTodoCmd (AddTodoParams uri todoText) = do let - pos = Position 0 0 + pos = Position 5 0 textEdits = List [TextEdit (Range pos pos) ("-- TODO2:" <> todoText <> "\n") diff --git a/test/functional/PluginSpec.hs b/test/functional/PluginSpec.hs index aaa327fed9..09a2d726c7 100644 --- a/test/functional/PluginSpec.hs +++ b/test/functional/PluginSpec.hs @@ -42,16 +42,17 @@ spec = do mark "provides 3.8 code actions" doc <- openDoc "Format.hs" "haskell" - _diags@(diag1:_) <- waitForDiagnostics + diags@(diag1:_) <- waitForDiagnosticsSource "typecheck" -- liftIO $ putStrLn $ "diags = " ++ show diags -- AZ liftIO $ do - -- length diags `shouldBe` 1 - diag1 ^. L.range `shouldBe` Range (Position 0 0) (Position 1 0) + length diags `shouldBe` 5 + diag1 ^. L.range `shouldBe` Range (Position 2 9) (Position 2 12) diag1 ^. L.severity `shouldBe` Just DsError diag1 ^. L.code `shouldBe` Nothing -- diag1 ^. L.source `shouldBe` Just "example2" + diag1 ^. L.source `shouldBe` Just "typecheck" -- diag2 ^. L.source `shouldBe` Just "example" _cas@(CACodeAction ca:_) <- getAllCodeActions doc @@ -61,18 +62,18 @@ spec = do liftIO $ [ca ^. L.title] `shouldContain` ["Add TODO Item 1"] - mark "A" -- AZ + -- mark "A" -- AZ executeCodeAction ca - mark "B" -- AZ + -- mark "B" -- AZ -- _ <- skipMany (message @RegisterCapabilityRequest) -- liftIO $ putStrLn $ "B2" -- AZ - _diags2 <- waitForDiagnostics + -- _diags2 <- waitForDiagnosticsSource "typecheck" -- liftIO $ putStrLn $ "diags2 = " ++ show _diags2 -- AZ -- contents <- getDocumentEdit doc - mark "C" -- AZ + -- mark "C" -- AZ -- liftIO $ contents `shouldBe` "main = undefined\nfoo x = x\n" -- noDiagnostics