diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 4a02d94bf9..a7fea1a075 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -48,6 +48,9 @@ import qualified Language.LSP.VFS as VFS import Numeric.Natural import Text.Fuzzy.Parallel (Scored (..)) +import qualified GHC.LanguageExtensions as LangExt +import Language.LSP.Types + data Log = LogShake Shake.Log deriving Show instance Pretty Log where @@ -120,7 +123,7 @@ getCompletionsLSP ide plId fmap Right $ case (contents, uriToFilePath' uri) of (Just cnts, Just path) -> do let npath = toNormalizedFilePath' path - (ideOpts, compls, moduleExports) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do + (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide localCompls <- useWithStaleFast LocalCompletions npath nonLocalCompls <- useWithStaleFast NonLocalCompletions npath @@ -140,18 +143,31 @@ getCompletionsLSP ide plId exportsCompls = mempty{anyQualCompls = exportsCompItems} let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules - pure (opts, fmap (,pm,binds) compls, moduleExports) + -- get HieAst if OverloadedRecordDot is enabled +#if MIN_VERSION_ghc(9,2,0) + let uses_overloaded_record_dot (ms_hspp_opts . msrModSummary -> dflags) = xopt LangExt.OverloadedRecordDot dflags +#else + let uses_overloaded_record_dot _ = False +#endif + ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps npath + astres <- case ms of + Just ms' | uses_overloaded_record_dot ms' + -> useWithStaleFast GetHieAst npath + _ -> return Nothing + + pure (opts, fmap (,pm,binds) compls, moduleExports, astres) case compls of Just (cci', parsedMod, bindMap) -> do - pfix <- VFS.getCompletionPrefix position cnts + let pfix = getCompletionPrefix position cnts case (pfix, completionContext) of - (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) + ((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."}) -> return (InL $ List []) - (Just pfix', _) -> do + (_, _) -> do let clientCaps = clientCapabilities $ shakeExtras ide plugins = idePlugins $ shakeExtras ide config <- getCompletionsConfig plId - allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports + + allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports pure $ InL (List $ orderedCompletions allCompletions) _ -> return (InL $ List []) _ -> return (InL $ List []) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 6e03a61a22..78a921bec4 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -10,16 +10,18 @@ module Development.IDE.Plugin.Completions.Logic ( , localCompletionsForParsedModule , getCompletions , fromIdentInfo +, getCompletionPrefix ) where import Control.Applicative -import Data.Char (isUpper) +import Data.Char (isAlphaNum, isUpper) import Data.Generics import Data.List.Extra as List hiding (stripPrefix) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, isJust, +import Data.Maybe (catMaybes, fromMaybe, + isJust, listToMaybe, mapMaybe) import qualified Data.Text as T import qualified Text.Fuzzy.Parallel as Fuzzy @@ -30,6 +32,7 @@ import Data.Either (fromRight) import Data.Function (on) import Data.Functor import qualified Data.HashMap.Strict as HM + import qualified Data.HashSet as HashSet import Data.Monoid (First (..)) import Data.Ord (Down (Down)) @@ -67,6 +70,11 @@ import qualified Language.LSP.VFS as VFS import Text.Fuzzy.Parallel (Scored (score), original) +import qualified Data.Text.Utf16.Rope as Rope +import Development.IDE + +import Development.IDE.Spans.AtPoint (pointCommand) + -- Chunk size used for parallelizing fuzzy matching chunkSize :: Int chunkSize = 1000 @@ -564,20 +572,21 @@ getCompletions -> IdeOptions -> CachedCompletions -> Maybe (ParsedModule, PositionMapping) + -> Maybe (HieAstResult, PositionMapping) -> (Bindings, PositionMapping) - -> VFS.PosPrefixInfo + -> PosPrefixInfo -> ClientCapabilities -> CompletionsConfig -> HM.HashMap T.Text (HashSet.HashSet IdentInfo) -> IO [Scored CompletionItem] getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules} - maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do - let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo - enteredQual = if T.null prefixModule then "" else prefixModule <> "." + maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do + let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo + enteredQual = if T.null prefixScope then "" else prefixScope <> "." fullPrefix = enteredQual <> prefixText -- Boolean labels to tag suggestions as qualified (or not) - qual = not(T.null prefixModule) + qual = not(T.null prefixScope) notQual = False {- correct the position by moving 'foo :: Int -> String -> ' @@ -585,7 +594,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, to 'foo :: Int -> String -> ' ^ -} - pos = VFS.cursorPos prefixInfo + pos = cursorPos prefixInfo maxC = maxCompletions config @@ -608,6 +617,42 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, hpos = upperRange position' in getCContext lpos pm <|> getCContext hpos pm + + -- We need the hieast to be "fresh". We can't get types from "stale" hie files, so hasfield won't work, + -- since it gets the record fields from the types. + -- Perhaps this could be fixed with a refactor to GHC's IfaceTyCon, to have it also contain record fields. + -- Requiring fresh hieast is fine for normal workflows, because it is generated while the user edits. + recordDotSyntaxCompls :: [(Bool, CompItem)] + recordDotSyntaxCompls = case maybe_ast_res of + Just (HAR {hieAst = hieast, hieKind = HieFresh},_) -> concat $ pointCommand hieast (completionPrefixPos prefixInfo) nodeCompletions + _ -> [] + where + nodeCompletions :: HieAST Type -> [(Bool, CompItem)] + nodeCompletions node = concatMap g (nodeType $ nodeInfo node) + g :: Type -> [(Bool, CompItem)] + g (TyConApp theTyCon _) = map (dotFieldSelectorToCompl (printOutputable $ GHC.tyConName theTyCon)) $ getSels theTyCon + g _ = [] + getSels :: GHC.TyCon -> [T.Text] + getSels tycon = let f fieldLabel = printOutputable fieldLabel + in map f $ tyConFieldLabels tycon + -- Completions can return more information that just the completion itself, but it will + -- require more than what GHC currently gives us in the HieAST, since it only gives the Type + -- of the fields, not where they are defined, etc. So for now the extra fields remain empty. + -- Also: additionalTextEdits is a todo, since we may want to import the record. It requires a way + -- to get the record's module, which isn't included in the type information used to get the fields. + dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem) + dotFieldSelectorToCompl recname label = (True, CI + { compKind = CiField + , insertText = label + , provenance = DefinedIn recname + , typeText = Nothing + , label = label + , isInfix = Nothing + , docs = emptySpanDoc + , isTypeCompl = False + , additionalTextEdits = Nothing + }) + -- completions specific to the current context ctxCompls' = case mcc of Nothing -> compls @@ -618,10 +663,10 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls' infixCompls :: Maybe Backtick - infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos + infixCompls = isUsedAsInfix fullLine prefixScope prefixText pos PositionMapping bDelta = bmapping - oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo + oldPos = fromDelta bDelta $ cursorPos prefixInfo startLoc = lowerRange oldPos endLoc = upperRange oldPos localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc @@ -634,10 +679,14 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, ty = showForSnippet <$> typ thisModName = Local $ nameSrcSpan name - compls = if T.null prefixModule - then map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls) - else ((qual,) <$> Map.findWithDefault [] prefixModule (getQualCompls qualCompls)) - ++ ((notQual,) . ($ Just prefixModule) <$> anyQualCompls) + -- When record-dot-syntax completions are available, we return them exclusively. + -- They are only available when we write i.e. `myrecord.` with OverloadedRecordDot enabled. + -- Anything that isn't a field is invalid, so those completion don't make sense. + compls + | T.null prefixScope = map (notQual,) localCompls ++ map (qual,) unqualCompls ++ map (\compl -> (notQual, compl Nothing)) anyQualCompls + | not $ null recordDotSyntaxCompls = recordDotSyntaxCompls + | otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls)) + ++ map (\compl -> (notQual, compl (Just prefixScope))) anyQualCompls filtListWith f list = [ fmap f label @@ -648,7 +697,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName filtKeywordCompls - | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts) + | T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts) | otherwise = [] if @@ -696,6 +745,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, + uniqueCompl :: CompItem -> CompItem -> Ordering uniqueCompl candidate unique = case compare (label candidate, compKind candidate) @@ -892,3 +942,32 @@ mergeListsBy cmp all_lists = merge_lists all_lists [] -> [] [xs] -> xs lists' -> merge_lists lists' + +-- |From the given cursor position, gets the prefix module or record for autocompletion +getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo +getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) = + fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad + let headMaybe = listToMaybe + lastMaybe = headMaybe . reverse + + -- grab the entire line the cursor is at + curLine <- headMaybe $ T.lines $ Rope.toText + $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext + let beforePos = T.take (fromIntegral c) curLine + -- the word getting typed, after previous space and before cursor + curWord <- + if | T.null beforePos -> Just "" + | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc ' + | otherwise -> lastMaybe (T.words beforePos) + + let parts = T.split (=='.') + $ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord + case reverse parts of + [] -> Nothing + (x:xs) -> do + let modParts = reverse $ filter (not .T.null) xs + modName = T.intercalate "." modParts + return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos } + +completionPrefixPos :: PosPrefixInfo -> Position +completionPrefixPos PosPrefixInfo { cursorPos = Position ln co, prefixText = str} = Position ln (co - (fromInteger . toInteger . T.length $ str) - 1) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs index 127ba369b3..46129e78ad 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs @@ -26,6 +26,7 @@ import Ide.PluginUtils (getClientConfig, usePropertyLsp) import Ide.Types (PluginId) import Language.LSP.Server (MonadLsp) import Language.LSP.Types (CompletionItemKind (..), Uri) +import qualified Language.LSP.Types as J -- | Produce completions info for a file type instance RuleResult LocalCompletions = CachedCompletions @@ -136,3 +137,24 @@ instance Monoid CachedCompletions where instance Semigroup CachedCompletions where CC a b c d e <> CC a' b' c' d' e' = CC (a<>a') (b<>b') (c<>c') (d<>d') (e<>e') + + +-- | Describes the line at the current cursor position +data PosPrefixInfo = PosPrefixInfo + { fullLine :: !T.Text + -- ^ The full contents of the line the cursor is at + + , prefixScope :: !T.Text + -- ^ If any, the module name that was typed right before the cursor position. + -- For example, if the user has typed "Data.Maybe.from", then this property + -- will be "Data.Maybe" + -- If OverloadedRecordDot is enabled, "Shape.rect.width" will be + -- "Shape.rect" + + , prefixText :: !T.Text + -- ^ The word right before the cursor position, after removing the module part. + -- For example if the user has typed "Data.Maybe.from", + -- then this property will be "from" + , cursorPos :: !J.Position + -- ^ The cursor position + } deriving (Show,Eq) diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs index 820f25ce95..8516051c51 100644 --- a/test/functional/Completion.hs +++ b/test/functional/Completion.hs @@ -84,6 +84,32 @@ tests = testGroup "completions" [ compls <- getCompletions doc (Position 5 7) liftIO $ assertBool "Expected completions" $ not $ null compls + , expectFailIfBeforeGhc92 "record dot syntax is introduced in GHC 9.2" + $ testGroup "recorddotsyntax" + [ testCase "shows field selectors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "RecordDotSyntax.hs" "haskell" + + let te = TextEdit (Range (Position 25 0) (Position 25 5)) "z = x.a" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 25 6) + item <- getCompletionByLabel "a" compls + + liftIO $ do + item ^. label @?= "a" + , testCase "shows field selectors for nested field" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do + doc <- openDoc "RecordDotSyntax.hs" "haskell" + + let te = TextEdit (Range (Position 27 0) (Position 27 8)) "z2 = x.c.z" + _ <- applyEdit doc te + + compls <- getCompletions doc (Position 27 9) + item <- getCompletionByLabel "z" compls + + liftIO $ do + item ^. label @?= "z" + ] + -- See https://github.com/haskell/haskell-ide-engine/issues/903 , testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do doc <- openDoc "DupRecFields.hs" "haskell" @@ -348,3 +374,6 @@ shouldNotContainCompl :: [CompletionItem] -> T.Text -> Assertion compls `shouldNotContainCompl` lbl = all ((/= lbl) . (^. label)) compls @? "Should not contain completion: " ++ show lbl + +expectFailIfBeforeGhc92 :: String -> TestTree -> TestTree +expectFailIfBeforeGhc92 = knownBrokenForGhcVersions [GHC810, GHC88, GHC86, GHC90] diff --git a/test/testdata/completion/RecordDotSyntax.hs b/test/testdata/completion/RecordDotSyntax.hs new file mode 100644 index 0000000000..4ea2f6994b --- /dev/null +++ b/test/testdata/completion/RecordDotSyntax.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} + +module Test where + +import qualified Data.Maybe as M + +data MyRecord = MyRecord1 + { a :: String + , b :: Integer + , c :: MyChild + } + | MyRecord2 { a2 :: String + , b2 :: Integer + , c2 :: MyChild + } deriving (Eq, Show) + +newtype MyChild = MyChild + { z :: String + } deriving (Eq, Show) + +x = MyRecord1 { a = "Hello", b = 12, c = MyChild { z = "there" } } + +y = x.a ++ show x.b + +y2 = x.c.z +