mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-10-26 09:20:16 +03:00
Feat: basic record dot completions (#3080)
* baseline for record completions * address feedback * gate ghc version * add test * refactor * fix rope import * fix plugins from rebase * gate test by ghc version * comments, fixes * fix ghc90 test
This commit is contained in:
Colten Webb
GitHub
parent
e09c00588b
commit
cdbef3e5cb
@ -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 [])
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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]
|
||||
|
||||
28
test/testdata/completion/RecordDotSyntax.hs
vendored
Normal file
28
test/testdata/completion/RecordDotSyntax.hs
vendored
Normal file
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user