diff --git a/ghcide/src/Development/IDE/GHC/Orphans.hs b/ghcide/src/Development/IDE/GHC/Orphans.hs index ba92091be6..97c38b1d58 100644 --- a/ghcide/src/Development/IDE/GHC/Orphans.hs +++ b/ghcide/src/Development/IDE/GHC/Orphans.hs @@ -21,6 +21,7 @@ import GHC () import GhcPlugins import Retrie.ExactPrint (Annotated) import qualified StringBuffer as SB +import Unique (getKey) -- Orphan instances for types from the GHC API. @@ -50,6 +51,8 @@ instance Hashable GhcPlugins.InstalledUnitId where hashWithSalt salt = hashWithSalt salt . installedUnitIdString #else instance Show InstalledUnitId where show = prettyPrint +deriving instance Ord SrcSpan +deriving instance Ord UnhelpfulSpanReason #endif instance NFData SB.StringBuffer where rnf = rwhnf @@ -162,3 +165,6 @@ instance (NFData HsModule) where instance (NFData (HsModule a)) where #endif rnf = rwhnf + +instance Show OccName where show = prettyPrint +instance Hashable OccName where hashWithSalt s n = hashWithSalt s (getKey $ getUnique n) diff --git a/ghcide/src/Development/IDE/Plugin/CodeAction.hs b/ghcide/src/Development/IDE/Plugin/CodeAction.hs index 9faa7ab4e4..1fda96d75e 100644 --- a/ghcide/src/Development/IDE/Plugin/CodeAction.hs +++ b/ghcide/src/Development/IDE/Plugin/CodeAction.hs @@ -11,7 +11,9 @@ module Development.IDE.Plugin.CodeAction iePluginDescriptor, typeSigsPluginDescriptor, bindingsPluginDescriptor, - fillHolePluginDescriptor + fillHolePluginDescriptor, + newImport, + newImportToEdit -- * For testing , matchRegExMultipleImports ) where @@ -835,7 +837,7 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_ -- fallback to using GHC suggestion even though it is not always correct | otherwise = Just IdentInfo - { name = binding + { name = mkVarOcc $ T.unpack binding , rendered = binding , parent = Nothing , isDatacon = False diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 80fa95239a..05f0b13837 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -13,6 +13,8 @@ import Control.Monad.Extra import Control.Monad.IO.Class import Control.Monad.Trans.Maybe import Data.Aeson +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set import Data.List (find) import Data.Maybe import qualified Data.Text as T @@ -23,16 +25,21 @@ import Development.IDE.Core.Shake import Development.IDE.GHC.Compat import Development.IDE.GHC.Error (rangeToSrcSpan) import Development.IDE.GHC.ExactPrint (Annotated (annsA), - GetAnnotatedParsedSource (GetAnnotatedParsedSource)) + GetAnnotatedParsedSource (GetAnnotatedParsedSource), + astA) import Development.IDE.GHC.Util (prettyPrint) import Development.IDE.Graph import Development.IDE.Graph.Classes +import Development.IDE.Plugin.CodeAction (newImport, + newImportToEdit) import Development.IDE.Plugin.CodeAction.ExactPrint import Development.IDE.Plugin.Completions.Logic import Development.IDE.Plugin.Completions.Types -import Development.IDE.Types.HscEnvEq (hscEnv) +import Development.IDE.Types.Exports +import Development.IDE.Types.HscEnvEq (HscEnvEq (envPackageExports), + hscEnv) import Development.IDE.Types.Location -import GHC.Exts (toList) +import GHC.Exts (fromList, toList) import GHC.Generics import Ide.Plugin.Config (Config) import Ide.Types @@ -130,7 +137,12 @@ getCompletionsLSP ide plId nonLocalCompls <- useWithStaleFast NonLocalCompletions npath pm <- useWithStaleFast GetParsedModule npath binds <- fromMaybe (mempty, zeroMapping) <$> useWithStaleFast GetBindings npath - pure (opts, fmap (,pm,binds) ((fst <$> localCompls) <> (fst <$> nonLocalCompls))) + exportsMapIO <- fmap(envPackageExports . fst) <$> useWithStaleFast GhcSession npath + exportsMap <- mapM liftIO exportsMapIO + let exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap <$> exportsMap + exportsCompls = mempty{anyQualCompls = fromMaybe [] exportsCompItems} + let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls + pure (opts, fmap (,pm,binds) compls) case compls of Just (cci', parsedMod, bindMap) -> do pfix <- VFS.getCompletionPrefix position cnts @@ -185,10 +197,20 @@ extendImportHandler' ideState ExtendImport {..} let df = ms_hspp_opts msrModSummary wantedModule = mkModuleName (T.unpack importName) wantedQual = mkModuleName . T.unpack <$> importQual - imp <- liftMaybe $ find (isWantedModule wantedModule wantedQual) msrImports - fmap (nfp,) $ liftEither $ - rewriteToWEdit df doc (annsA ps) $ - extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp + existingImport = find (isWantedModule wantedModule wantedQual) msrImports + case existingImport of + Just imp -> do + fmap (nfp,) $ liftEither $ + rewriteToWEdit df doc (annsA ps) $ + extendImport (T.unpack <$> thingParent) (T.unpack newThing) imp + Nothing -> do + let n = newImport importName sym importQual False + sym = if isNothing importQual then Just it else Nothing + it = case thingParent of + Nothing -> newThing + Just p -> p <> "(" <> newThing <> ")" + t <- liftMaybe $ snd <$> newImportToEdit n (astA ps) + return (nfp, WorkspaceEdit {_changes=Just (fromList [(doc,List [t])]), _documentChanges=Nothing, _changeAnnotations=Nothing}) | otherwise = mzero diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 9f958f17e0..5371583955 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -9,6 +9,7 @@ module Development.IDE.Plugin.Completions.Logic ( , cacheDataProducer , localCompletionsForParsedModule , getCompletions +, fromIdentInfo ) where import Control.Applicative @@ -19,6 +20,7 @@ import Data.List.Extra as List hiding import qualified Data.Map as Map import Data.Maybe (fromMaybe, isJust, + isNothing, listToMaybe, mapMaybe) import qualified Data.Text as T @@ -49,6 +51,7 @@ import Development.IDE.Plugin.Completions.Types import Development.IDE.Spans.Common import Development.IDE.Spans.Documentation import Development.IDE.Spans.LocalBindings +import Development.IDE.Types.Exports import Development.IDE.Types.HscEnvEq import Development.IDE.Types.Options import GhcPlugins (flLabel, unpackFS) @@ -302,6 +305,25 @@ mkPragmaCompl label insertText = Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just Snippet) Nothing Nothing Nothing Nothing Nothing Nothing +fromIdentInfo :: Uri -> IdentInfo -> Maybe T.Text -> CompItem +fromIdentInfo doc IdentInfo{..} q = CI + { compKind= occNameToComKind Nothing name + , insertText=rendered + , importedFrom=Right moduleNameText + , typeText=Nothing + , label=rendered + , isInfix=Nothing + , docs=emptySpanDoc + , isTypeCompl= not isDatacon && isUpper (T.head rendered) + , additionalTextEdits= Just $ + ExtendImport + { doc, + thingParent = parent, + importName = moduleNameText, + importQual = q, + newThing = rendered + } + } cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> IO CachedCompletions cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do @@ -385,6 +407,7 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports = do { allModNamesAsNS = allModNamesAsNS , unqualCompls = unquals , qualCompls = quals + , anyQualCompls = [] , importableModules = moduleNames } @@ -394,6 +417,7 @@ localCompletionsForParsedModule uri pm@ParsedModule{pm_parsed_source = L _ HsMod CC { allModNamesAsNS = mempty , unqualCompls = compls , qualCompls = mempty + , anyQualCompls = [] , importableModules = mempty } where @@ -507,7 +531,7 @@ getCompletions -> ClientCapabilities -> CompletionsConfig -> IO [CompletionItem] -getCompletions plId ideOpts CC {allModNamesAsNS, unqualCompls, qualCompls, importableModules} +getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} maybe_parsed (localBindings, bmapping) prefixInfo caps config = do let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo enteredQual = if T.null prefixModule then "" else prefixModule <> "." @@ -566,8 +590,9 @@ getCompletions plId ideOpts CC {allModNamesAsNS, unqualCompls, qualCompls, impor Just m -> Right $ ppr m compls = if T.null prefixModule - then localCompls ++ unqualCompls - else Map.findWithDefault [] prefixModule $ getQualCompls qualCompls + then localCompls ++ unqualCompls ++ (($Nothing) <$> anyQualCompls) + else Map.findWithDefault [] prefixModule (getQualCompls qualCompls) + ++ (($ Just prefixModule) <$> anyQualCompls) filtListWith f list = [ f label @@ -606,13 +631,26 @@ getCompletions plId ideOpts CC {allModNamesAsNS, unqualCompls, qualCompls, impor | "{-# " `T.isPrefixOf` fullLine -> return $ filtPragmaCompls (pragmaSuffix fullLine) | otherwise -> do - let uniqueFiltCompls = nubOrdOn insertText filtCompls + -- assumes that nubOrdBy is stable + let uniqueFiltCompls = nubOrdBy uniqueCompl filtCompls compls <- mapM (mkCompl plId ideOpts) uniqueFiltCompls return $ filtModNameCompls ++ filtKeywordCompls ++ map (toggleSnippets caps config) compls - +uniqueCompl :: CompItem -> CompItem -> Ordering +uniqueCompl x y = + case compare (label x, importedFrom x, compKind x) + (label y, importedFrom y, compKind y) of + EQ -> + -- preserve completions for duplicate record fields where the only difference is in the type + -- remove redundant completions with less type info + if typeText x == typeText y + || isNothing (typeText x) + || isNothing (typeText y) + then EQ + else compare (insertText x) (insertText y) + other -> other -- --------------------------------------------------------------------- -- helper functions for pragmas -- --------------------------------------------------------------------- diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index 59ed71bedc..b8660887b6 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -20,7 +20,7 @@ import Ide.Plugin.Properties import Ide.PluginUtils (usePropertyLsp) import Ide.Types (PluginId) import Language.LSP.Server (MonadLsp) -import Language.LSP.Types (CompletionItemKind, Uri) +import Language.LSP.Types (CompletionItemKind (..), Uri) -- From haskell-ide-engine/src/Haskell/Ide/Engine/LSP/Completions.hs @@ -91,18 +91,21 @@ instance Monoid QualCompls where data CachedCompletions = CC { allModNamesAsNS :: [T.Text] -- ^ All module names in scope. -- Prelude is a single module - , unqualCompls :: [CompItem] -- ^ All Possible completion items + , unqualCompls :: [CompItem] -- ^ Unqualified completion items , qualCompls :: QualCompls -- ^ Completion items associated to -- to a specific module name. + , anyQualCompls :: [Maybe T.Text -> CompItem] -- ^ Items associated to any qualifier , importableModules :: [T.Text] -- ^ All modules that may be imported. - } deriving Show + } + +instance Show CachedCompletions where show _ = "" instance NFData CachedCompletions where rnf = rwhnf instance Monoid CachedCompletions where - mempty = CC mempty mempty mempty mempty + mempty = CC mempty mempty mempty mempty mempty instance Semigroup CachedCompletions where - CC a b c d <> CC a' b' c' d' = - CC (a<>a') (b<>b') (c<>c') (d<>d') + CC a b c d e <> CC a' b' c' d' e' = + CC (a<>a') (b<>b') (c<>c') (d<>d') (e<>e') diff --git a/ghcide/src/Development/IDE/Types/Exports.hs b/ghcide/src/Development/IDE/Types/Exports.hs index b155ee9f51..36594d2b56 100644 --- a/ghcide/src/Development/IDE/Types/Exports.hs +++ b/ghcide/src/Development/IDE/Types/Exports.hs @@ -9,24 +9,26 @@ module Development.IDE.Types.Exports createExportsMapTc ,createExportsMapHieDb,size) where -import Avail (AvailInfo (..)) -import Control.DeepSeq (NFData (..)) +import Avail (AvailInfo (..)) +import Control.DeepSeq (NFData (..)) import Control.Monad -import Data.Bifunctor (Bifunctor (second)) -import Data.HashMap.Strict (HashMap, elems) -import qualified Data.HashMap.Strict as Map -import Data.HashSet (HashSet) -import qualified Data.HashSet as Set -import Data.Hashable (Hashable) -import Data.Text (Text, pack) +import Data.Bifunctor (Bifunctor (second)) +import Data.HashMap.Strict (HashMap, elems) +import qualified Data.HashMap.Strict as Map +import Data.HashSet (HashSet) +import qualified Data.HashSet as Set +import Data.Hashable (Hashable) +import Data.List (isSuffixOf) +import Data.Text (Text, pack) import Development.IDE.GHC.Compat +import Development.IDE.GHC.Orphans () import Development.IDE.GHC.Util -import FieldLabel (flSelector) -import GHC.Generics (Generic) -import GhcPlugins (IfaceExport, ModGuts (..)) +import FieldLabel (flSelector) +import GHC.Generics (Generic) +import GhcPlugins (IfaceExport, ModGuts (..)) import HieDb import Name -import TcRnTypes (TcGblEnv (..)) +import TcRnTypes (TcGblEnv (..)) newtype ExportsMap = ExportsMap {getExportsMap :: HashMap IdentifierText (HashSet IdentInfo)} @@ -41,7 +43,7 @@ instance Semigroup ExportsMap where type IdentifierText = Text data IdentInfo = IdentInfo - { name :: !Text + { name :: !OccName , rendered :: Text , parent :: !(Maybe Text) , isDatacon :: !Bool @@ -72,19 +74,19 @@ renderIEWrapped n mkIdentInfos :: Text -> AvailInfo -> [IdentInfo] mkIdentInfos mod (Avail n) = - [IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod] + [IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] mkIdentInfos mod (AvailTC parent (n:nn) flds) -- Following the GHC convention that parent == n if parent is exported | n == parent - = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod + = [ IdentInfo (nameOccName n) (renderIEWrapped n) (Just $! parentP) (isDataConName n) mod | n <- nn ++ map flSelector flds ] ++ - [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod] + [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod] where parentP = pack $ printName parent mkIdentInfos mod (AvailTC _ nn flds) - = [ IdentInfo (pack (prettyPrint n)) (renderIEWrapped n) Nothing (isDataConName n) mod + = [ IdentInfo (nameOccName n) (renderIEWrapped n) Nothing (isDataConName n) mod | n <- nn ++ map flSelector flds ] @@ -109,23 +111,29 @@ createExportsMapTc = ExportsMap . Map.fromListWith (<>) . concatMap doOne where mn = moduleName $ tcg_mod mi +nonInternalModules :: ModuleName -> Bool +nonInternalModules = not . (".Internal" `isSuffixOf`) . moduleNameString + createExportsMapHieDb :: HieDb -> IO ExportsMap createExportsMapHieDb hiedb = do mods <- getAllIndexedMods hiedb - idents <- forM mods $ \m -> do + idents <- forM (filter (nonInternalModules . modInfoName . hieModInfo) mods) $ \m -> do let mn = modInfoName $ hieModInfo m mText = pack $ moduleNameString mn fmap (wrap . unwrap mText) <$> getExportsForModule hiedb mn return $ ExportsMap $ Map.fromListWith (<>) (concat idents) where - wrap identInfo = (name identInfo, Set.fromList [identInfo]) + wrap identInfo = (rendered identInfo, Set.fromList [identInfo]) -- unwrap :: ExportRow -> IdentInfo - unwrap m ExportRow{..} = IdentInfo n n p exportIsDatacon m + unwrap m ExportRow{..} = IdentInfo exportName n p exportIsDatacon m where n = pack (occNameString exportName) p = pack . occNameString <$> exportParent unpackAvail :: ModuleName -> IfaceExport -> [(Text, [IdentInfo])] -unpackAvail !(pack . moduleNameString -> mod) = map f . mkIdentInfos mod +unpackAvail mn + | nonInternalModules mn = map f . mkIdentInfos mod + | otherwise = const [] where - f id@IdentInfo {..} = (name, [id]) + !mod = pack $ moduleNameString mn + f id@IdentInfo {..} = (pack (prettyPrint name), [id]) diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 44358d5a5f..81216debfb 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -3968,6 +3968,7 @@ completionTests [ testGroup "non local" nonLocalCompletionTests , testGroup "topLevel" topLevelCompletionTests , testGroup "local" localCompletionTests + , testGroup "global" globalCompletionTests , testGroup "other" otherCompletionTests ] @@ -3979,8 +3980,9 @@ completionTest name src pos expected = testSessionWait name $ do let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] liftIO $ do let emptyToMaybe x = if T.null x then Nothing else Just x - sortOn (Lens.view Lens._1) compls' @?= - sortOn (Lens.view Lens._1) [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do when expectedSig $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) @@ -4362,7 +4364,7 @@ otherCompletionTests = [ _ <- waitForDiagnostics compls <- getCompletions docA $ Position 2 4 let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] - liftIO $ compls' @?= ["member ${1:Foo}", "member ${1:Bar}"], + liftIO $ take 2 compls' @?= ["member ${1:Foo}", "member ${1:Bar}"], testSessionWait "maxCompletions" $ do doc <- createDoc "A.hs" "haskell" $ T.unlines @@ -4375,6 +4377,105 @@ otherCompletionTests = [ liftIO $ length compls @?= maxCompletions def ] +globalCompletionTests :: [TestTree] +globalCompletionTests = + [ testSessionWait "fromList" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 12) + let compls' = + [T.drop 1 $ T.dropEnd 10 d + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + <- compls + , _label == "fromList" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) + [ "'Data.IntMap" + , "'Data.IntMap.Lazy" + , "'Data.IntMap.Strict" + ] + + , testSessionWait "Map" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a :: Map" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 7) + let compls' = + [T.drop 1 $ T.dropEnd 10 d + | CompletionItem {_documentation = Just (CompletionDocMarkup (MarkupContent MkMarkdown d)), _label} + <- compls + , _label == "Map" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) + [ "'Data.Map" + , "'Data.Map.Lazy" + , "'Data.Map.Strict" + ] + , testSessionWait "no duplicates" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let duplicate = + find + (\case + CompletionItem + { _insertText = Just "fromList" + , _documentation = + Just (CompletionDocMarkup (MarkupContent MkMarkdown d)) + } -> + "GHC.Exts" `T.isInfixOf` d + _ -> False + ) compls + liftIO $ duplicate @?= Nothing + + , testSessionWait "non-local before global" $ do + -- non local completions are more specific + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let compls' = + [_insertText + | CompletionItem {_label, _insertText} <- compls + , _label == "fromList" + ] + liftIO $ take 3 compls' @?= + map Just ["fromList ${1:([Item l])}", "fromList", "fromList"] + , testGroup "auto import snippets" + [ completionCommandTest + "import Data.Sequence" + ["module A where", "foo :: Seq"] + (Position 1 9) + "Seq" + ["module A where", "import Data.Sequence (Seq)", "foo :: Seq"] + + , completionCommandTest + "qualified import" + ["module A where", "foo :: Seq.Seq"] + (Position 1 13) + "Seq" + ["module A where", "import qualified Data.Sequence as Seq", "foo :: Seq.Seq"] + ] + ] + highlightTests :: TestTree highlightTests = testGroup "highlight" [ testSessionWait "value" $ do diff --git a/plugins/hls-tactics-plugin/src/Wingman/Types.hs b/plugins/hls-tactics-plugin/src/Wingman/Types.hs index d15893f3b1..9818967832 100644 --- a/plugins/hls-tactics-plugin/src/Wingman/Types.hs +++ b/plugins/hls-tactics-plugin/src/Wingman/Types.hs @@ -121,9 +121,6 @@ instance Ord CType where instance Show CType where show = unsafeRender . unCType -instance Show OccName where - show = unsafeRender - instance Show Name where show = unsafeRender