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" ] 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..21196e72f6 --- /dev/null +++ b/plugins/hls-completions-plugin/hls-completions-plugin.cabal @@ -0,0 +1,43 @@ +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: Digital Asset and Ghcide contributors 2018-2020 +maintainer: Ghcide contributors +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 + , syb + , extra + , fuzzy + , haskell-lsp-types == 0.22.* + , haskell-lsp == 0.22.* + , ghcide + + + 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..5f48de0f8f --- /dev/null +++ b/plugins/hls-completions-plugin/src/Ide/Plugin/LocalCompletions.hs @@ -0,0 +1,705 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} + +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 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 as S +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 qualified Language.Haskell.LSP.Core as LSP +import qualified Language.Haskell.LSP.VFS as VFS + +import GhcPlugins ( + liftIO, + flLabel, + unpackFS) +import Control.DeepSeq + +-- --------------------------------------------------------------------- + +descriptor :: PluginId -> PluginDescriptor +descriptor plId = (defaultPluginDescriptor plId) + { + pluginRules = produceLocalCompletions + , pluginCodeActionProvider = Nothing + , pluginCodeLensProvider = Nothing + , pluginHoverProvider = Nothing + , pluginSymbolsProvider = Nothing + , pluginCompletionProvider = Just getCompletionsLSP + } + + +------------------------ +--- Completion Types +------------------------ + +data Backtick = Surrounded | LeftSide + deriving (Eq, Ord, Show) + + +-- | Intermediate Result of Completions +data CachedCompletions = CC + { + unqualCompls :: [CompItem] -- ^ All Possible completion items + } deriving Show + +instance NFData CachedCompletions where + rnf = rwhnf + +instance Monoid CachedCompletions where + mempty = CC mempty + +instance Semigroup CachedCompletions where + CC a <> CC a' = + CC (a<>a') + + +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 (Eq, Show) + +-- --------------------------------------------------------------------- +-- Generating Local Completions via Rules +-- --------------------------------------------------------------------- + +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 + +-- | 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 extras = shakeExtras ide + 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 []) + + +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 + +-- --------------------------------------------------------------------- +-- 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 + + +--- 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 ++ unqualCompls + 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" + ]