From e974ee858fdd1185ad70b9e8aec23cd4307b1513 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Sun, 13 Dec 2020 06:20:00 -0800 Subject: [PATCH 01/11] Initial version of completions --- plugins/hls-completions-plugin/LICENSE | 201 +++++++++++++++ .../hls-completions-plugin.cabal | 37 +++ .../include/ghc-api-version.h | 10 + .../src/Ide/Plugin/LocalCompletions.hs | 230 ++++++++++++++++++ 4 files changed, 478 insertions(+) create mode 100644 plugins/hls-completions-plugin/LICENSE create mode 100644 plugins/hls-completions-plugin/hls-completions-plugin.cabal create mode 100644 plugins/hls-completions-plugin/include/ghc-api-version.h create mode 100644 plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs diff --git a/plugins/hls-completions-plugin/LICENSE b/plugins/hls-completions-plugin/LICENSE new file mode 100644 index 0000000000..261eeb9e9f --- /dev/null +++ b/plugins/hls-completions-plugin/LICENSE @@ -0,0 +1,201 @@ + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/plugins/hls-completions-plugin/hls-completions-plugin.cabal b/plugins/hls-completions-plugin/hls-completions-plugin.cabal new file mode 100644 index 0000000000..d531b304b0 --- /dev/null +++ b/plugins/hls-completions-plugin/hls-completions-plugin.cabal @@ -0,0 +1,37 @@ +cabal-version: 2.2 +name: hls-completions-plugin +version: 0.1.0.0 +synopsis: Local and Non-local completions for Haskell Language Server +license: Apache-2.0 +license-file: LICENSE +author: Guru Devanla +maintainer: grdvnl@gmail.com +category: Development +build-type: Simple +extra-source-files: + LICENSE + include/ghc-api-version.h + +library + exposed-modules: Ide.Plugin.LocalCompletions + hs-source-dirs: src + build-depends: aeson + , base + , containers + , deepseq + , haskell-lsp-types + , hls-plugin-api + , ghc + , ghcide + , shake + , text + , unordered-containers + -- remove these after testing + , transformers + , binary + , hashable + , regex-tdfa + + + default-language: Haskell2010 + include-dirs: include diff --git a/plugins/hls-completions-plugin/include/ghc-api-version.h b/plugins/hls-completions-plugin/include/ghc-api-version.h new file mode 100644 index 0000000000..11cabb3dc9 --- /dev/null +++ b/plugins/hls-completions-plugin/include/ghc-api-version.h @@ -0,0 +1,10 @@ +#ifndef GHC_API_VERSION_H +#define GHC_API_VERSION_H + +#ifdef GHC_LIB +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc_lib(x,y,z) +#else +#define MIN_GHC_API_VERSION(x,y,z) MIN_VERSION_ghc(x,y,z) +#endif + +#endif diff --git a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs new file mode 100644 index 0000000000..63f31abf77 --- /dev/null +++ b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Ide.Plugin.LocalCompletions + ( + descriptor + ) where + +import Control.DeepSeq ( NFData ) +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Binary +import Data.Functor +import qualified Data.HashMap.Strict as Map +import Data.Hashable +import qualified Data.Text as T +import Data.Typeable +import Development.IDE as D +import Development.IDE.GHC.Compat (ParsedModule(ParsedModule)) +import Development.IDE.Core.Rules (useE) +import Development.IDE.Core.Shake (getDiagnostics, getHiddenDiagnostics) +import GHC.Generics +import Ide.Plugin +import Ide.Types +import Language.Haskell.LSP.Types +import Text.Regex.TDFA.Text() + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = (defaultPluginDescriptor plId) + { pluginRules = exampleRules + , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] + , pluginCodeActionProvider = Just codeAction + , pluginCodeLensProvider = Just codeLens + , pluginHoverProvider = Just hover + , pluginSymbolsProvider = Just symbols + , pluginCompletionProvider = Just completion + } + +-- --------------------------------------------------------------------- + +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 1\n"]) + +-- --------------------------------------------------------------------- +-- Generating Diagnostics via rules +-- --------------------------------------------------------------------- + +data Example = Example + deriving (Eq, Show, Typeable, Generic) +instance Hashable Example +instance NFData Example +instance Binary Example + +type instance RuleResult Example = () + +exampleRules :: Rules () +exampleRules = do + define $ \Example file -> do + _pm <- getParsedModule file + let diag = mkDiag file "example" DsError (Range (Position 0 0) (Position 1 0)) "example diagnostic, hello world" + return ([diag], Just ()) + + action $ do + files <- getFilesOfInterest + void $ uses Example $ Map.keys 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 + , _tags = Nothing + , _relatedInformation = Nothing + } + +-- --------------------------------------------------------------------- +-- code actions +-- --------------------------------------------------------------------- + +-- | Generate code actions. +codeAction :: CodeActionProvider +codeAction _lf state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do + let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri + Just (ParsedModule{},_) <- runIdeAction "example" (shakeExtras state) $ useWithStaleFast GetParsedModule nfp + let + title = "Add TODO Item 1" + 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 + [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] + +-- --------------------------------------------------------------------- + +codeLens :: CodeLensProvider +codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do + logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ + case uriToFilePath' uri of + Just (toNormalizedFilePath -> filePath) -> do + _ <- runIdeAction "Example.codeLens" (shakeExtras ideState) $ runMaybeT $ useE TypeCheck filePath + _diag <- getDiagnostics ideState + _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) + 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 :: CommandFunction AddTodoParams +addTodoCmd _lf _ide (AddTodoParams uri todoText) = do + let + pos = Position 3 0 + textEdits = List + [TextEdit (Range pos pos) + ("-- TODO:" <> 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) +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 "Example" ide $ getResults filePath pos + +-- --------------------------------------------------------------------- + +symbols :: SymbolsProvider +symbols _lf _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 + +-- --------------------------------------------------------------------- + +completion :: CompletionProvider +completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) + = pure $ Right $ Completions $ List [r] + where + r = CompletionItem label kind tags detail documentation deprecated preselect + sortText filterText insertText insertTextFormat + textEdit additionalTextEdits commitCharacters + command xd + label = "New Local Completions" + kind = Nothing + tags = List [] + 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 + +-- --------------------------------------------------------------------- From 9241f1c496dba9dfe3dc8617d82a704600845961 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Sun, 13 Dec 2020 06:29:46 -0800 Subject: [PATCH 02/11] Add LocalCompletions plugin to Main module --- exe/Main.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/exe/Main.hs b/exe/Main.hs index ea5ddb65a0..ce5afef44a 100644 --- a/exe/Main.hs +++ b/exe/Main.hs @@ -19,6 +19,7 @@ import Ide.Plugin.Floskell as Floskell import Ide.Plugin.Fourmolu as Fourmolu import Ide.Plugin.GhcIde as GhcIde import Ide.Plugin.ExplicitImports as ExplicitImports +import Ide.Plugin.LocalCompletions as LocalCompletions import Ide.Plugin.Ormolu as Ormolu import Ide.Plugin.Retrie as Retrie import Ide.Plugin.StylishHaskell as StylishHaskell @@ -61,6 +62,7 @@ idePlugins includeExamples = pluginDescToIdePlugins allPlugins #endif , Eval.descriptor "eval" , ExplicitImports.descriptor "importLens" + , LocalCompletions.descriptor "localCompletions" , ModuleName.descriptor "moduleName" , Hlint.descriptor "hlint" ] From 63d334ac458734e1c90f213ee3f93123c874e9ee Mon Sep 17 00:00:00 2001 From: Guru Devanla Date: Tue, 15 Dec 2020 04:33:07 -0800 Subject: [PATCH 03/11] Update author Co-authored-by: Pepe Iborra --- plugins/hls-completions-plugin/hls-completions-plugin.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-completions-plugin/hls-completions-plugin.cabal b/plugins/hls-completions-plugin/hls-completions-plugin.cabal index d531b304b0..3da1869e31 100644 --- a/plugins/hls-completions-plugin/hls-completions-plugin.cabal +++ b/plugins/hls-completions-plugin/hls-completions-plugin.cabal @@ -4,7 +4,7 @@ version: 0.1.0.0 synopsis: Local and Non-local completions for Haskell Language Server license: Apache-2.0 license-file: LICENSE -author: Guru Devanla +author: Digital Asset and Ghcide contributors 2018-2020 maintainer: grdvnl@gmail.com category: Development build-type: Simple From 7f23febee11f4d2fa0f7a774d1f710ae4cdf5787 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Tue, 15 Dec 2020 05:47:48 -0800 Subject: [PATCH 04/11] Add required packages --- plugins/hls-completions-plugin/hls-completions-plugin.cabal | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/plugins/hls-completions-plugin/hls-completions-plugin.cabal b/plugins/hls-completions-plugin/hls-completions-plugin.cabal index 3da1869e31..98cec58790 100644 --- a/plugins/hls-completions-plugin/hls-completions-plugin.cabal +++ b/plugins/hls-completions-plugin/hls-completions-plugin.cabal @@ -31,6 +31,12 @@ library , binary , hashable , regex-tdfa + , syb + , extra + , fuzzy + , haskell-lsp-types == 0.22.* + , haskell-lsp == 0.22.* + , ghcide default-language: Haskell2010 From f12edb064b384f304ffa5ad2be79dc119491d45d Mon Sep 17 00:00:00 2001 From: grdvnl Date: Tue, 15 Dec 2020 05:48:02 -0800 Subject: [PATCH 05/11] A compiling version of LocalCompletion rules and production on [CompItem] --- .../src/Ide/Plugin/LocalCompletions.hs | 400 +++++++++++------- 1 file changed, 252 insertions(+), 148 deletions(-) diff --git a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs index 63f31abf77..63d9625d29 100644 --- a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs +++ b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -7,6 +8,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} module Ide.Plugin.LocalCompletions ( @@ -18,189 +22,146 @@ import Control.Monad.Trans.Maybe import Data.Aeson import Data.Binary import Data.Functor -import qualified Data.HashMap.Strict as Map import Data.Hashable import qualified Data.Text as T import Data.Typeable import Development.IDE as D import Development.IDE.GHC.Compat (ParsedModule(ParsedModule)) +import Development.IDE.Spans.Common +import Development.IDE.Spans.Documentation import Development.IDE.Core.Rules (useE) import Development.IDE.Core.Shake (getDiagnostics, getHiddenDiagnostics) import GHC.Generics +import GHC.Generics as GG import Ide.Plugin import Ide.Types import Language.Haskell.LSP.Types import Text.Regex.TDFA.Text() +import Control.Applicative +import Data.Char (isAlphaNum, isUpper) +import Data.Generics as G +import Data.List.Extra as List hiding (stripPrefix) +import qualified Data.Map as Map + +import Data.Maybe (listToMaybe, fromMaybe, mapMaybe) +import qualified Data.Text as T +import qualified Text.Fuzzy as Fuzzy + +import HscTypes +import Name +import RdrName +import Type +import Packages +-- #if MIN_GHC_API_VERSION(8,10,0) +-- import Predicate (isDictTy) +-- import Pair +-- import Coercion +-- #endif + +import Language.Haskell.LSP.Types +import Language.Haskell.LSP.Types.Capabilities +-- import qualified Language.Haskell.LSP.VFS as VFS +-- import Development.IDE.Core.Compile +import Development.IDE.Core.PositionMapping +-- import Development.IDE.Plugin.Completions.Types +-- import Development.IDE.Spans.Documentation +import Development.IDE.Spans.LocalBindings +import Development.IDE.GHC.Compat as GHC +import Development.IDE.GHC.Error +import Development.IDE.Types.Options +import Development.IDE.Spans.Common +import Development.IDE.GHC.Util +import Outputable (Outputable) +import qualified Data.Set as Set +import ConLike + +import GhcPlugins ( + flLabel, + unpackFS) +import Control.DeepSeq + -- --------------------------------------------------------------------- descriptor :: PluginId -> PluginDescriptor descriptor plId = (defaultPluginDescriptor plId) - { pluginRules = exampleRules - , pluginCommands = [PluginCommand "codelens.todo" "example adding" addTodoCmd] - , pluginCodeActionProvider = Just codeAction - , pluginCodeLensProvider = Just codeLens - , pluginHoverProvider = Just hover - , pluginSymbolsProvider = Just symbols + { + pluginCommands = [] + , pluginCodeActionProvider = Nothing + , pluginCodeLensProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolsProvider = Nothing , pluginCompletionProvider = Just completion } --- --------------------------------------------------------------------- -hover :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover)) -hover = request "Hover" blah (Right Nothing) foundHover +------------------------ +--- Completion Types +------------------------ -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"]) +data Backtick = Surrounded | LeftSide + deriving (Eq, Ord, Show) --- --------------------------------------------------------------------- --- Generating Diagnostics via rules --- --------------------------------------------------------------------- -data Example = Example - deriving (Eq, Show, Typeable, Generic) -instance Hashable Example -instance NFData Example -instance Binary Example - -type instance RuleResult Example = () - -exampleRules :: Rules () -exampleRules = do - define $ \Example file -> do - _pm <- getParsedModule file - let diag = mkDiag file "example" DsError (Range (Position 0 0) (Position 1 0)) "example diagnostic, hello world" - return ([diag], Just ()) - - action $ do - files <- getFilesOfInterest - void $ uses Example $ Map.keys 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 - , _tags = Nothing - , _relatedInformation = Nothing - } +-- | Intermediate Result of Completions +data CachedCompletions = CC + { + unqualCompls :: [CompItem] -- ^ All Possible completion items + } deriving Show --- --------------------------------------------------------------------- --- code actions --- --------------------------------------------------------------------- +instance NFData CachedCompletions where + rnf = rwhnf --- | Generate code actions. -codeAction :: CodeActionProvider -codeAction _lf state _pid (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List _xs} = do - let Just nfp = uriToNormalizedFilePath $ toNormalizedUri uri - Just (ParsedModule{},_) <- runIdeAction "example" (shakeExtras state) $ useWithStaleFast GetParsedModule nfp - let - title = "Add TODO Item 1" - 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 - [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List []) (Just edit) Nothing ] +instance Monoid CachedCompletions where + mempty = CC mempty --- --------------------------------------------------------------------- +instance Semigroup CachedCompletions where + CC a <> CC a' = + CC (a<>a') -codeLens :: CodeLensProvider -codeLens _lf ideState plId CodeLensParams{_textDocument=TextDocumentIdentifier uri} = do - logInfo (ideLogger ideState) "Example.codeLens entered (ideLogger)" -- AZ - case uriToFilePath' uri of - Just (toNormalizedFilePath -> filePath) -> do - _ <- runIdeAction "Example.codeLens" (shakeExtras ideState) $ runMaybeT $ useE TypeCheck filePath - _diag <- getDiagnostics ideState - _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) - 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 +data CompItem = CI + { compKind :: CompletionItemKind, + -- | Snippet for the completion + insertText :: T.Text, + -- | From where this item is imported from. + importedFrom :: Either SrcSpan T.Text, + -- | Available type information. + typeText :: Maybe T.Text, + -- | Label to display to the user. + label :: T.Text, + -- | Did the completion happen + -- in the context of an infix notation. + isInfix :: Maybe Backtick, + -- | Available documentation. + docs :: SpanDoc, + isTypeCompl :: Bool, + additionalTextEdits :: Maybe [TextEdit] } - deriving (Show, Eq, Generic, ToJSON, FromJSON) - -addTodoCmd :: CommandFunction AddTodoParams -addTodoCmd _lf _ide (AddTodoParams uri todoText) = do - let - pos = Position 3 0 - textEdits = List - [TextEdit (Range pos pos) - ("-- TODO:" <> todoText <> "\n") - ] - res = WorkspaceEdit - (Just $ Map.singleton uri textEdits) - Nothing - return (Right Null, Just (WorkspaceApplyEdit, ApplyWorkspaceEditParams res)) + deriving (Eq, Show) -- --------------------------------------------------------------------- - -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 "Example" ide $ getResults filePath pos - +-- Generating Local Completions via Rules -- --------------------------------------------------------------------- -symbols :: SymbolsProvider -symbols _lf _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 +produceLocalCompletions :: Rules () +produceLocalCompletions = do + define $ \LocalCompletions file -> do + pm <- useWithStale GetParsedModule file + case pm of + Just (pm, _) -> do + let cdata = localCompletionsForParsedModule pm + return ([], Just cdata) + _ -> return ([], Nothing) --- --------------------------------------------------------------------- +-- | Produce completions info for a file +type instance RuleResult LocalCompletions = CachedCompletions + +data LocalCompletions = LocalCompletions + deriving (Eq, Show, Typeable, GG.Generic) +instance Hashable LocalCompletions +instance NFData LocalCompletions +instance Binary LocalCompletions completion :: CompletionProvider completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) @@ -228,3 +189,146 @@ completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) xd = Nothing -- --------------------------------------------------------------------- +-- Supporting code +------------------------------------------------------------------------ + +-- | Produces completions from the top level declarations of a module. +localCompletionsForParsedModule :: ParsedModule -> CachedCompletions +localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} = + CC { unqualCompls = compls } + where + typeSigIds = Set.fromList + [ id + | L _ (SigD _ (TypeSig _ ids _)) <- hsmodDecls + , L _ id <- ids + ] + hasTypeSig = (`Set.member` typeSigIds) . unLoc + + compls = concat + [ case decl of + SigD _ (TypeSig _ ids typ) -> + [mkComp id CiFunction (Just $ ppr typ) | id <- ids] + ValD _ FunBind{fun_id} -> + [ mkComp fun_id CiFunction Nothing + | not (hasTypeSig fun_id) + ] + ValD _ PatBind{pat_lhs} -> + [mkComp id CiVariable Nothing + | VarPat _ id <- listify (\(_ :: Pat GhcPs) -> True) pat_lhs] + TyClD _ ClassDecl{tcdLName, tcdSigs} -> + mkComp tcdLName CiClass Nothing : + [ mkComp id CiFunction (Just $ ppr typ) + | L _ (TypeSig _ ids typ) <- tcdSigs + , id <- ids] + TyClD _ x -> + let generalCompls = [mkComp id cl Nothing + | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x + , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)] + -- here we only have to look at the outermost type + recordCompls = findRecordCompl pm thisModName x + in + -- the constructors and snippets will be duplicated here giving the user 2 choices. + generalCompls ++ recordCompls + ForD _ ForeignImport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + ForD _ ForeignExport{fd_name,fd_sig_ty} -> + [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)] + _ -> [] + | L _ decl <- hsmodDecls + ] + + mkComp n ctyp ty = + CI ctyp pn (Right thisModName) ty pn Nothing doc (ctyp `elem` [CiStruct, CiClass]) Nothing + where + pn = ppr n + doc = SpanDocText (getDocumentation [pm] n) (SpanDocUris Nothing Nothing) + + thisModName = ppr hsmodName + +findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem] +findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result + where + result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc Nothing + | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn + , Just con_details <- [getFlds con_args] + , let field_names = mapMaybe extract con_details + , let field_labels = T.pack . showGhc . unLoc <$> field_names + , (not . List.null) field_labels + ] + doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing) + + getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs] + getFlds conArg = case conArg of + RecCon rec -> Just $ unLoc <$> unLoc rec + PrefixCon _ -> Just [] + _ -> Nothing + + extract ConDeclField{..} + -- TODO: Why is cd_fld_names a list? + | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name + | otherwise = Nothing + -- XConDeclField + extract _ = Nothing +findRecordCompl _ _ _ = [] + + +ppr :: Outputable a => a -> T.Text +ppr = T.pack . prettyPrint + +occNameToComKind :: Maybe T.Text -> OccName -> CompletionItemKind +occNameToComKind ty oc + | isVarOcc oc = case occNameString oc of + i:_ | isUpper i -> CiConstructor + _ -> CiFunction + | isTcOcc oc = case ty of + Just t + | "Constraint" `T.isSuffixOf` t + -> CiClass + _ -> CiStruct + | isDataOcc oc = CiConstructor + | otherwise = CiVariable + + +mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> Maybe (LImportDecl GhcPs) -> CompItem +mkRecordSnippetCompItem ctxStr compl mn docs imp = r + where + r = + CI + { compKind = CiSnippet, + insertText = buildSnippet, + importedFrom = importedFrom, + typeText = Nothing, + label = ctxStr, + isInfix = Nothing, + docs = docs, + isTypeCompl = False, + additionalTextEdits = imp >>= extendImportList (T.unpack ctxStr) + } + + placeholder_pairs = zip compl ([1 ..] :: [Int]) + snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs + snippet = T.intercalate (T.pack ", ") snippet_parts + buildSnippet = ctxStr <> " {" <> snippet <> "}" + importedFrom = Right mn + + +extendImportList :: String -> LImportDecl GhcPs -> Maybe [TextEdit] +extendImportList name lDecl = let + f (Just range) ImportDecl {ideclHiding} = case ideclHiding of + Just (False, x) + | Set.notMember name (Set.fromList [show y| y <- unLoc x]) + -> let + start_pos = _end range + new_start_pos = start_pos {_character = _character start_pos - 1} + -- use to same start_pos to handle situation where we do not have latest edits due to caching of Rules + new_range = Range new_start_pos new_start_pos + -- we cannot wrap mapM_ inside (mapM_) but we need to wrap (<$) + alpha = all isAlphaNum $ filter (\c -> c /= '_') name + result = if alpha then name ++ ", " + else "(" ++ name ++ "), " + in Just [TextEdit new_range (T.pack result)] + | otherwise -> Nothing + _ -> Nothing -- hiding import list and no list + f _ _ = Nothing + src_span = srcSpanToRange . getLoc $ lDecl + in f src_span . unLoc $ lDecl From 07a1ad8692601aa011ae8b3781bfb4de17149890 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Tue, 15 Dec 2020 06:14:45 -0800 Subject: [PATCH 06/11] Compiling shell function for completions Acked-by: grdvnl --- .../src/Ide/Plugin/LocalCompletions.hs | 45 ++++++++++++++++++- 1 file changed, 44 insertions(+), 1 deletion(-) diff --git a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs index 63d9625d29..cbde376a32 100644 --- a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs +++ b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs @@ -30,7 +30,11 @@ import Development.IDE.GHC.Compat (ParsedModule(ParsedModule)) import Development.IDE.Spans.Common import Development.IDE.Spans.Documentation import Development.IDE.Core.Rules (useE) -import Development.IDE.Core.Shake (getDiagnostics, getHiddenDiagnostics) +import Development.IDE.Core.Shake ( + getDiagnostics + , getHiddenDiagnostics + , getIdeOptionsIO + ) import GHC.Generics import GHC.Generics as GG import Ide.Plugin @@ -75,8 +79,11 @@ import Development.IDE.GHC.Util import Outputable (Outputable) import qualified Data.Set as Set import ConLike +import qualified Language.Haskell.LSP.Core as LSP +import qualified Language.Haskell.LSP.VFS as VFS import GhcPlugins ( + liftIO, flLabel, unpackFS) import Control.DeepSeq @@ -163,6 +170,42 @@ instance Hashable LocalCompletions instance NFData LocalCompletions instance Binary LocalCompletions + +-- | Generate code actions. +getCompletionsLSP + :: LSP.LspFuncs cofd + -> IdeState + -> CompletionParams + -> IO (Either ResponseError CompletionResponseResult) +getCompletionsLSP lsp ide + CompletionParams{_textDocument=TextDocumentIdentifier uri + ,_position=position + ,_context=completionContext} = do + contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri + fmap Right $ case (contents, uriToFilePath' uri) of + (Just cnts, Just path) -> do + let npath = toNormalizedFilePath' path + (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do + opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide + compls <- useWithStaleFast LocalCompletions npath + pm <- useWithStaleFast GetParsedModule npath + binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath + pure (opts, fmap (,pm,binds) compls ) + case compls of + Just ((cci', _), parsedMod, bindMap) -> do + pfix <- VFS.getCompletionPrefix position cnts + case (pfix, completionContext) of + (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) + -> return (Completions $ List []) + (Just pfix', _) -> do + -- let clientCaps = clientCapabilities $ shakeExtras ide + -- Completions . List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps (WithSnippets True) + return (Completions $ List []) + _ -> return (Completions $ List []) + _ -> return (Completions $ List []) + _ -> return (Completions $ List []) + + completion :: CompletionProvider completion _lf _ide (CompletionParams _doc _pos _mctxt _mt) = pure $ Right $ Completions $ List [r] From 629b7544e263d2f991487482df0c0947327968b5 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Tue, 15 Dec 2020 06:42:55 -0800 Subject: [PATCH 07/11] Adding in the completion response --- .../src/Ide/Plugin/LocalCompletions.hs | 333 +++++++++++++++++- 1 file changed, 332 insertions(+), 1 deletion(-) diff --git a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs index cbde376a32..7f65dddc67 100644 --- a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs +++ b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs @@ -98,7 +98,7 @@ descriptor plId = (defaultPluginDescriptor plId) , pluginCodeLensProvider = Nothing , pluginHoverProvider = Nothing , pluginSymbolsProvider = Nothing - , pluginCompletionProvider = Just completion + , pluginCompletionProvider = Just getCompletionsLSP } @@ -375,3 +375,334 @@ extendImportList name lDecl = let f _ _ = Nothing src_span = srcSpanToRange . getLoc $ lDecl in f src_span . unLoc $ lDecl + + +--- Completions that are returned and related functions + +-- | A context of a declaration in the program +-- e.g. is the declaration a type declaration or a value declaration +-- Used for determining which code completions to show +data Context = TypeContext + | ValueContext + | ModuleContext String -- ^ module context with module name + | ImportContext String -- ^ import context with module name + | ImportListContext String -- ^ import list context with module name + | ImportHidingContext String -- ^ import hiding context with module name + | ExportContext -- ^ List of exported identifiers from the current module + deriving (Show, Eq) + +-- | Generates a map of where the context is a type and where the context is a value +-- i.e. where are the value decls and the type decls +getCContext :: Position -> ParsedModule -> Maybe Context +getCContext pos pm + | Just (L r modName) <- moduleHeader + , pos `isInsideSrcSpan` r + = Just (ModuleContext (moduleNameString modName)) + + | Just (L r _) <- exportList + , pos `isInsideSrcSpan` r + = Just ExportContext + + | Just ctx <- something (Nothing `mkQ` go `extQ` goInline) decl + = Just ctx + + | Just ctx <- something (Nothing `mkQ` importGo) imports + = Just ctx + + | otherwise + = Nothing + where decl = hsmodDecls $ unLoc $ pm_parsed_source pm + moduleHeader = hsmodName $ unLoc $ pm_parsed_source pm + exportList = hsmodExports $ unLoc $ pm_parsed_source pm + imports = hsmodImports $ unLoc $ pm_parsed_source pm + + go :: LHsDecl GhcPs -> Maybe Context + go (L r SigD {}) + | pos `isInsideSrcSpan` r = Just TypeContext + | otherwise = Nothing + go (L r GHC.ValD {}) + | pos `isInsideSrcSpan` r = Just ValueContext + | otherwise = Nothing + go _ = Nothing + + goInline :: GHC.LHsType GhcPs -> Maybe Context + goInline (GHC.L r _) + | pos `isInsideSrcSpan` r = Just TypeContext + goInline _ = Nothing + + importGo :: GHC.LImportDecl GhcPs -> Maybe Context + importGo (L r impDecl) + | pos `isInsideSrcSpan` r + = importInline importModuleName (ideclHiding impDecl) + <|> Just (ImportContext importModuleName) + + | otherwise = Nothing + where importModuleName = moduleNameString $ unLoc $ ideclName impDecl + + importInline :: String -> Maybe (Bool, GHC.Located [LIE GhcPs]) -> Maybe Context + importInline modName (Just (True, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportHidingContext modName + | otherwise = Nothing + importInline modName (Just (False, L r _)) + | pos `isInsideSrcSpan` r = Just $ ImportListContext modName + | otherwise = Nothing + importInline _ _ = Nothing + + +-- | Returns the cached completions for the given module and position. +getCompletions + :: IdeOptions + -> CachedCompletions + -> Maybe (ParsedModule, PositionMapping) + -> (Bindings, PositionMapping) + -> VFS.PosPrefixInfo + -> ClientCapabilities + -> WithSnippets + -> IO [CompletionItem] +getCompletions ideOpts CC { unqualCompls } + maybe_parsed (localBindings, bmapping) prefixInfo caps withSnippets = do + let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo + enteredQual = if T.null prefixModule then "" else prefixModule <> "." + fullPrefix = enteredQual <> prefixText + + {- correct the position by moving 'foo :: Int -> String -> ' + ^ + to 'foo :: Int -> String -> ' + ^ + -} + pos = VFS.cursorPos prefixInfo + + filtCompls = map Fuzzy.original $ Fuzzy.filter prefixText ctxCompls "" "" label False + where + + mcc = case maybe_parsed of + Nothing -> Nothing + Just (pm, pmapping) -> + let PositionMapping pDelta = pmapping + position' = fromDelta pDelta pos + lpos = lowerRange position' + hpos = upperRange position' + in getCContext lpos pm <|> getCContext hpos pm + + -- completions specific to the current context + ctxCompls' = case mcc of + Nothing -> compls + Just TypeContext -> filter isTypeCompl compls + Just ValueContext -> filter (not . isTypeCompl) compls + Just _ -> filter (not . isTypeCompl) compls + -- Add whether the text to insert has backticks + ctxCompls = map (\comp -> comp { isInfix = infixCompls }) ctxCompls' + + infixCompls :: Maybe Backtick + infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos + + PositionMapping bDelta = bmapping + oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo + startLoc = lowerRange oldPos + endLoc = upperRange oldPos + localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc + localBindsToCompItem :: Name -> Maybe Type -> CompItem + localBindsToCompItem name typ = CI ctyp pn thisModName ty pn Nothing emptySpanDoc (not $ isValOcc occ) Nothing + where + occ = nameOccName name + ctyp = occNameToComKind Nothing occ + pn = ppr name + ty = ppr <$> typ + thisModName = case nameModule_maybe name of + Nothing -> Left $ nameSrcSpan name + Just m -> Right $ ppr m + + compls = if T.null prefixModule + then localCompls + else [] + + filtListWith f list = + [ f label + | label <- Fuzzy.simpleFilter fullPrefix list + , enteredQual `T.isPrefixOf` label + ] + + filtListWithSnippet f list suffix = + [ toggleSnippets caps withSnippets (f label (snippet <> (suffix:: T.Text))) + | (snippet, label) <- list + , Fuzzy.test fullPrefix label + ] + + filtKeywordCompls + | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts) + | otherwise = [] + + stripLeading :: Char -> String -> String + stripLeading _ [] = [] + stripLeading c (s:ss) + | s == c = ss + | otherwise = s:ss + + result + | "import " `T.isPrefixOf` fullLine + = [] + | "{-#" `T.isPrefixOf` T.toLower fullLine + = [] + | otherwise + = let uniqueFiltCompls = nubOrdOn insertText filtCompls + in map (toggleSnippets caps withSnippets + . mkCompl ideOpts . stripAutoGenerated) uniqueFiltCompls + ++ filtKeywordCompls + return result + + +mkCompl :: IdeOptions -> CompItem -> CompletionItem +mkCompl IdeOptions{..} CI{compKind,insertText, importedFrom,typeText,label,docs, additionalTextEdits} = + CompletionItem {_label = label, + _kind = kind, + _tags = List [], + _detail = (colon <>) <$> typeText, + _documentation = documentation, + _deprecated = Nothing, + _preselect = Nothing, + _sortText = Nothing, + _filterText = Nothing, + _insertText = Just insertText, + _insertTextFormat = Just Snippet, + _textEdit = Nothing, + _additionalTextEdits = List <$> additionalTextEdits, + _commitCharacters = Nothing, + _command = Nothing, + _xdata = Nothing} + + where kind = Just compKind + docs' = imported : spanDocToMarkdown docs + imported = case importedFrom of + Left pos -> "*Defined at '" <> ppr pos <> "'*\n'" + Right mod -> "*Defined in '" <> mod <> "'*\n" + colon = if optNewColonConvention then ": " else ":: " + documentation = Just $ CompletionDocMarkup $ + MarkupContent MkMarkdown $ + T.intercalate sectionSeparator docs' + +-- TODO: We probably don't need to this function in this module +mkExtCompl :: T.Text -> CompletionItem +mkExtCompl label = + CompletionItem + label + (Just CiKeyword) + (List []) + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + + +--- helper functions that will be useful for non-local completions as well + +hasTrailingBacktick :: T.Text -> Position -> Bool +hasTrailingBacktick line Position { _character } + | T.length line > _character = (line `T.index` _character) == '`' + | otherwise = False + +isUsedAsInfix :: T.Text -> T.Text -> T.Text -> Position -> Maybe Backtick +isUsedAsInfix line prefixMod prefixText pos + | hasClosingBacktick && hasOpeningBacktick = Just Surrounded + | hasOpeningBacktick = Just LeftSide + | otherwise = Nothing + where + hasOpeningBacktick = openingBacktick line prefixMod prefixText pos + hasClosingBacktick = hasTrailingBacktick line pos + +openingBacktick :: T.Text -> T.Text -> T.Text -> Position -> Bool +openingBacktick line prefixModule prefixText Position { _character } + | backtickIndex < 0 = False + | otherwise = (line `T.index` backtickIndex) == '`' + where + backtickIndex :: Int + backtickIndex = + let + prefixLength = T.length prefixText + moduleLength = if prefixModule == "" + then 0 + else T.length prefixModule + 1 {- Because of "." -} + in + -- Points to the first letter of either the module or prefix text + _character - (prefixLength + moduleLength) - 1 + +toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem +toggleSnippets ClientCapabilities {_textDocument} (WithSnippets with) x + | with && supported = x + | otherwise = + x + { _insertTextFormat = Just PlainText, + _insertText = Nothing + } + where + supported = + Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport) + +-- | Under certain circumstance GHC generates some extra stuff that we +-- don't want in the autocompleted symbols +stripAutoGenerated :: CompItem -> CompItem +stripAutoGenerated ci = + ci {label = stripPrefix (label ci)} + {- When e.g. DuplicateRecordFields is enabled, compiler generates + names like "$sel:accessor:One" and "$sel:accessor:Two" to disambiguate record selectors + https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/DuplicateRecordFields#Implementation + -} + +stripPrefix :: T.Text -> T.Text +stripPrefix name = T.takeWhile (/= ':') $ go prefixes + where + go [] = name + go (p : ps) + | T.isPrefixOf p name = T.drop (T.length p) name + | otherwise = go ps + + +-- | Prefixes that can occur in a GHC OccName +prefixes :: [T.Text] +prefixes = + [ + -- long ones + "$con2tag_" + , "$tag2con_" + , "$maxtag_" + + -- four chars + , "$sel:" + , "$tc'" + + -- three chars + , "$dm" + , "$co" + , "$tc" + , "$cp" + , "$fx" + + -- two chars + , "$W" + , "$w" + , "$m" + , "$b" + , "$c" + , "$d" + , "$i" + , "$s" + , "$f" + , "$r" + , "C:" + , "N:" + , "D:" + , "$p" + , "$L" + , "$f" + , "$t" + , "$c" + , "$m" + ] From 5fa9332c603f765a68cdc69516ce2e1551f6474e Mon Sep 17 00:00:00 2001 From: grdvnl Date: Tue, 15 Dec 2020 07:13:22 -0800 Subject: [PATCH 08/11] Initialize plugin rule --- .../hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs index 7f65dddc67..df7384e97e 100644 --- a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs +++ b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs @@ -93,7 +93,7 @@ import Control.DeepSeq descriptor :: PluginId -> PluginDescriptor descriptor plId = (defaultPluginDescriptor plId) { - pluginCommands = [] + pluginRules = produceLocalCompletions , pluginCodeActionProvider = Nothing , pluginCodeLensProvider = Nothing , pluginHoverProvider = Nothing @@ -170,7 +170,6 @@ instance Hashable LocalCompletions instance NFData LocalCompletions instance Binary LocalCompletions - -- | Generate code actions. getCompletionsLSP :: LSP.LspFuncs cofd From 5391c3344ca0f64cf7518ff6760b7acf74ba9969 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Wed, 16 Dec 2020 06:47:26 -0800 Subject: [PATCH 09/11] Enable call to clientCapabilities --- .../src/Ide/Plugin/LocalCompletions.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs index df7384e97e..3f70fe1338 100644 --- a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs +++ b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs @@ -26,15 +26,12 @@ import Data.Hashable import qualified Data.Text as T import Data.Typeable import Development.IDE as D +import Development.IDE.Core.Shake import Development.IDE.GHC.Compat (ParsedModule(ParsedModule)) import Development.IDE.Spans.Common import Development.IDE.Spans.Documentation import Development.IDE.Core.Rules (useE) -import Development.IDE.Core.Shake ( - getDiagnostics - , getHiddenDiagnostics - , getIdeOptionsIO - ) +import Development.IDE.Core.Shake as S import GHC.Generics import GHC.Generics as GG import Ide.Plugin @@ -197,9 +194,10 @@ getCompletionsLSP lsp ide (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) -> return (Completions $ List []) (Just pfix', _) -> do - -- let clientCaps = clientCapabilities $ shakeExtras ide - -- Completions . List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps (WithSnippets True) - return (Completions $ List []) + let extras = shakeExtras ide + let clientCaps = S.clientCapabilities extras + -- return Completions $ List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps (WithSnippets True) + return (Completions $ List []) _ -> return (Completions $ List []) _ -> return (Completions $ List []) _ -> return (Completions $ List []) From 7a214dcf0c6d011b058e3d34ac823e85898c06d3 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Wed, 16 Dec 2020 06:49:37 -0800 Subject: [PATCH 10/11] Update maintainer value --- plugins/hls-completions-plugin/hls-completions-plugin.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-completions-plugin/hls-completions-plugin.cabal b/plugins/hls-completions-plugin/hls-completions-plugin.cabal index 98cec58790..21196e72f6 100644 --- a/plugins/hls-completions-plugin/hls-completions-plugin.cabal +++ b/plugins/hls-completions-plugin/hls-completions-plugin.cabal @@ -5,7 +5,7 @@ synopsis: Local and Non-local completions for Haskell Language Server license: Apache-2.0 license-file: LICENSE author: Digital Asset and Ghcide contributors 2018-2020 -maintainer: grdvnl@gmail.com +maintainer: Ghcide contributors category: Development build-type: Simple extra-source-files: From edf1e9f5446bc12dbfa8dbe2f2c2d7e4c31903f9 Mon Sep 17 00:00:00 2001 From: grdvnl Date: Thu, 24 Dec 2020 07:57:55 -0800 Subject: [PATCH 11/11] Enable completion and add back unqualCompls --- .../src/Ide/Plugin/LocalCompletions.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs index 3f70fe1338..5f48de0f8f 100644 --- a/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs +++ b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs @@ -195,9 +195,9 @@ getCompletionsLSP lsp ide -> return (Completions $ List []) (Just pfix', _) -> do let extras = shakeExtras ide - let clientCaps = S.clientCapabilities extras - -- return Completions $ List <$> getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps (WithSnippets True) - return (Completions $ List []) + clientCaps = S.clientCapabilities extras + compls = getCompletions ideOpts cci' parsedMod bindMap pfix' clientCaps (WithSnippets True) + Completions . List <$> compls _ -> return (Completions $ List []) _ -> return (Completions $ List []) _ -> return (Completions $ List []) @@ -510,7 +510,7 @@ getCompletions ideOpts CC { unqualCompls } Just m -> Right $ ppr m compls = if T.null prefixModule - then localCompls + then localCompls ++ unqualCompls else [] filtListWith f list =