Skip to content

Commit cdbef3e

Browse files
coltenwebbcoltenwebb
authored
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
1 parent e09c005 commit cdbef3e

File tree

5 files changed

+195
-21
lines changed

5 files changed

+195
-21
lines changed

‎ghcide/src/Development/IDE/Plugin/Completions.hs

+22-6
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,9 @@ import qualified Language.LSP.VFS as VFS
4848
import Numeric.Natural
4949
import Text.Fuzzy.Parallel (Scored (..))
5050

51+
import qualified GHC.LanguageExtensions as LangExt
52+
import Language.LSP.Types
53+
5154
data Log = LogShake Shake.Log deriving Show
5255

5356
instance Pretty Log where
@@ -120,7 +123,7 @@ getCompletionsLSP ide plId
120123
fmap Right $ case (contents, uriToFilePath' uri) of
121124
(Just cnts, Just path) -> do
122125
let npath = toNormalizedFilePath' path
123-
(ideOpts, compls, moduleExports) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do
126+
(ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do
124127
opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
125128
localCompls <- useWithStaleFast LocalCompletions npath
126129
nonLocalCompls <- useWithStaleFast NonLocalCompletions npath
@@ -140,18 +143,31 @@ getCompletionsLSP ide plId
140143
exportsCompls = mempty{anyQualCompls = exportsCompItems}
141144
let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules
142145

143-
pure (opts, fmap (,pm,binds) compls, moduleExports)
146+
-- get HieAst if OverloadedRecordDot is enabled
147+
#if MIN_VERSION_ghc(9,2,0)
148+
let uses_overloaded_record_dot (ms_hspp_opts . msrModSummary -> dflags) = xopt LangExt.OverloadedRecordDot dflags
149+
#else
150+
let uses_overloaded_record_dot _ = False
151+
#endif
152+
ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps npath
153+
astres <- case ms of
154+
Just ms' | uses_overloaded_record_dot ms'
155+
-> useWithStaleFast GetHieAst npath
156+
_ -> return Nothing
157+
158+
pure (opts, fmap (,pm,binds) compls, moduleExports, astres)
144159
case compls of
145160
Just (cci', parsedMod, bindMap) -> do
146-
pfix <- VFS.getCompletionPrefix position cnts
161+
let pfix = getCompletionPrefix position cnts
147162
case (pfix, completionContext) of
148-
(Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
163+
((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
149164
-> return (InL $ List [])
150-
(Just pfix', _) -> do
165+
(_, _) -> do
151166
let clientCaps = clientCapabilities $ shakeExtras ide
152167
plugins = idePlugins $ shakeExtras ide
153168
config <- getCompletionsConfig plId
154-
allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports
169+
170+
allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports
155171
pure $ InL (List $ orderedCompletions allCompletions)
156172
_ -> return (InL $ List [])
157173
_ -> return (InL $ List [])

‎ghcide/src/Development/IDE/Plugin/Completions/Logic.hs

+94-15
Original file line numberDiff line numberDiff line change
@@ -10,16 +10,18 @@ module Development.IDE.Plugin.Completions.Logic (
1010
, localCompletionsForParsedModule
1111
, getCompletions
1212
, fromIdentInfo
13+
, getCompletionPrefix
1314
) where
1415

1516
import Control.Applicative
16-
import Data.Char (isUpper)
17+
import Data.Char (isAlphaNum, isUpper)
1718
import Data.Generics
1819
import Data.List.Extra as List hiding
1920
(stripPrefix)
2021
import qualified Data.Map as Map
2122

22-
import Data.Maybe (fromMaybe, isJust,
23+
import Data.Maybe (catMaybes, fromMaybe,
24+
isJust, listToMaybe,
2325
mapMaybe)
2426
import qualified Data.Text as T
2527
import qualified Text.Fuzzy.Parallel as Fuzzy
@@ -30,6 +32,7 @@ import Data.Either (fromRight)
3032
import Data.Function (on)
3133
import Data.Functor
3234
import qualified Data.HashMap.Strict as HM
35+
3336
import qualified Data.HashSet as HashSet
3437
import Data.Monoid (First (..))
3538
import Data.Ord (Down (Down))
@@ -67,6 +70,11 @@ import qualified Language.LSP.VFS as VFS
6770
import Text.Fuzzy.Parallel (Scored (score),
6871
original)
6972

73+
import qualified Data.Text.Utf16.Rope as Rope
74+
import Development.IDE
75+
76+
import Development.IDE.Spans.AtPoint (pointCommand)
77+
7078
-- Chunk size used for parallelizing fuzzy matching
7179
chunkSize :: Int
7280
chunkSize = 1000
@@ -564,28 +572,29 @@ getCompletions
564572
-> IdeOptions
565573
-> CachedCompletions
566574
-> Maybe (ParsedModule, PositionMapping)
575+
-> Maybe (HieAstResult, PositionMapping)
567576
-> (Bindings, PositionMapping)
568-
-> VFS.PosPrefixInfo
577+
-> PosPrefixInfo
569578
-> ClientCapabilities
570579
-> CompletionsConfig
571580
-> HM.HashMap T.Text (HashSet.HashSet IdentInfo)
572581
-> IO [Scored CompletionItem]
573582
getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
574-
maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
575-
let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo
576-
enteredQual = if T.null prefixModule then "" else prefixModule <> "."
583+
maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
584+
let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo
585+
enteredQual = if T.null prefixScope then "" else prefixScope <> "."
577586
fullPrefix = enteredQual <> prefixText
578587

579588
-- Boolean labels to tag suggestions as qualified (or not)
580-
qual = not(T.null prefixModule)
589+
qual = not(T.null prefixScope)
581590
notQual = False
582591

583592
{- correct the position by moving 'foo :: Int -> String -> '
584593
^
585594
to 'foo :: Int -> String -> '
586595
^
587596
-}
588-
pos = VFS.cursorPos prefixInfo
597+
pos = cursorPos prefixInfo
589598

590599
maxC = maxCompletions config
591600

@@ -608,6 +617,42 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
608617
hpos = upperRange position'
609618
in getCContext lpos pm <|> getCContext hpos pm
610619

620+
621+
-- We need the hieast to be "fresh". We can't get types from "stale" hie files, so hasfield won't work,
622+
-- since it gets the record fields from the types.
623+
-- Perhaps this could be fixed with a refactor to GHC's IfaceTyCon, to have it also contain record fields.
624+
-- Requiring fresh hieast is fine for normal workflows, because it is generated while the user edits.
625+
recordDotSyntaxCompls :: [(Bool, CompItem)]
626+
recordDotSyntaxCompls = case maybe_ast_res of
627+
Just (HAR {hieAst = hieast, hieKind = HieFresh},_) -> concat $ pointCommand hieast (completionPrefixPos prefixInfo) nodeCompletions
628+
_ -> []
629+
where
630+
nodeCompletions :: HieAST Type -> [(Bool, CompItem)]
631+
nodeCompletions node = concatMap g (nodeType $ nodeInfo node)
632+
g :: Type -> [(Bool, CompItem)]
633+
g (TyConApp theTyCon _) = map (dotFieldSelectorToCompl (printOutputable $ GHC.tyConName theTyCon)) $ getSels theTyCon
634+
g _ = []
635+
getSels :: GHC.TyCon -> [T.Text]
636+
getSels tycon = let f fieldLabel = printOutputable fieldLabel
637+
in map f $ tyConFieldLabels tycon
638+
-- Completions can return more information that just the completion itself, but it will
639+
-- require more than what GHC currently gives us in the HieAST, since it only gives the Type
640+
-- of the fields, not where they are defined, etc. So for now the extra fields remain empty.
641+
-- Also: additionalTextEdits is a todo, since we may want to import the record. It requires a way
642+
-- to get the record's module, which isn't included in the type information used to get the fields.
643+
dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem)
644+
dotFieldSelectorToCompl recname label = (True, CI
645+
{ compKind = CiField
646+
, insertText = label
647+
, provenance = DefinedIn recname
648+
, typeText = Nothing
649+
, label = label
650+
, isInfix = Nothing
651+
, docs = emptySpanDoc
652+
, isTypeCompl = False
653+
, additionalTextEdits = Nothing
654+
})
655+
611656
-- completions specific to the current context
612657
ctxCompls' = case mcc of
613658
Nothing -> compls
@@ -618,10 +663,10 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
618663
ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'
619664

620665
infixCompls :: Maybe Backtick
621-
infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos
666+
infixCompls = isUsedAsInfix fullLine prefixScope prefixText pos
622667

623668
PositionMapping bDelta = bmapping
624-
oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo
669+
oldPos = fromDelta bDelta $ cursorPos prefixInfo
625670
startLoc = lowerRange oldPos
626671
endLoc = upperRange oldPos
627672
localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc
@@ -634,10 +679,14 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
634679
ty = showForSnippet <$> typ
635680
thisModName = Local $ nameSrcSpan name
636681

637-
compls = if T.null prefixModule
638-
then map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)
639-
else ((qual,) <$> Map.findWithDefault [] prefixModule (getQualCompls qualCompls))
640-
++ ((notQual,) . ($ Just prefixModule) <$> anyQualCompls)
682+
-- When record-dot-syntax completions are available, we return them exclusively.
683+
-- They are only available when we write i.e. `myrecord.` with OverloadedRecordDot enabled.
684+
-- Anything that isn't a field is invalid, so those completion don't make sense.
685+
compls
686+
| T.null prefixScope = map (notQual,) localCompls ++ map (qual,) unqualCompls ++ map (\compl -> (notQual, compl Nothing)) anyQualCompls
687+
| not $ null recordDotSyntaxCompls = recordDotSyntaxCompls
688+
| otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls))
689+
++ map (\compl -> (notQual, compl (Just prefixScope))) anyQualCompls
641690

642691
filtListWith f list =
643692
[ fmap f label
@@ -648,7 +697,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
648697
filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
649698
filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName
650699
filtKeywordCompls
651-
| T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
700+
| T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts)
652701
| otherwise = []
653702

654703
if
@@ -696,6 +745,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
696745

697746

698747

748+
699749
uniqueCompl :: CompItem -> CompItem -> Ordering
700750
uniqueCompl candidate unique =
701751
case compare (label candidate, compKind candidate)
@@ -892,3 +942,32 @@ mergeListsBy cmp all_lists = merge_lists all_lists
892942
[] -> []
893943
[xs] -> xs
894944
lists' -> merge_lists lists'
945+
946+
-- |From the given cursor position, gets the prefix module or record for autocompletion
947+
getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo
948+
getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =
949+
fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad
950+
let headMaybe = listToMaybe
951+
lastMaybe = headMaybe . reverse
952+
953+
-- grab the entire line the cursor is at
954+
curLine <- headMaybe $ T.lines $ Rope.toText
955+
$ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext
956+
let beforePos = T.take (fromIntegral c) curLine
957+
-- the word getting typed, after previous space and before cursor
958+
curWord <-
959+
if | T.null beforePos -> Just ""
960+
| T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc '
961+
| otherwise -> lastMaybe (T.words beforePos)
962+
963+
let parts = T.split (=='.')
964+
$ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord
965+
case reverse parts of
966+
[] -> Nothing
967+
(x:xs) -> do
968+
let modParts = reverse $ filter (not .T.null) xs
969+
modName = T.intercalate "." modParts
970+
return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos }
971+
972+
completionPrefixPos :: PosPrefixInfo -> Position
973+
completionPrefixPos PosPrefixInfo { cursorPos = Position ln co, prefixText = str} = Position ln (co - (fromInteger . toInteger . T.length $ str) - 1)

‎ghcide/src/Development/IDE/Plugin/Completions/Types.hs

+22
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ import Ide.PluginUtils (getClientConfig, usePropertyLsp)
2626
import Ide.Types (PluginId)
2727
import Language.LSP.Server (MonadLsp)
2828
import Language.LSP.Types (CompletionItemKind (..), Uri)
29+
import qualified Language.LSP.Types as J
2930

3031
-- | Produce completions info for a file
3132
type instance RuleResult LocalCompletions = CachedCompletions
@@ -136,3 +137,24 @@ instance Monoid CachedCompletions where
136137
instance Semigroup CachedCompletions where
137138
CC a b c d e <> CC a' b' c' d' e' =
138139
CC (a<>a') (b<>b') (c<>c') (d<>d') (e<>e')
140+
141+
142+
-- | Describes the line at the current cursor position
143+
data PosPrefixInfo = PosPrefixInfo
144+
{ fullLine :: !T.Text
145+
-- ^ The full contents of the line the cursor is at
146+
147+
, prefixScope :: !T.Text
148+
-- ^ If any, the module name that was typed right before the cursor position.
149+
-- For example, if the user has typed "Data.Maybe.from", then this property
150+
-- will be "Data.Maybe"
151+
-- If OverloadedRecordDot is enabled, "Shape.rect.width" will be
152+
-- "Shape.rect"
153+
154+
, prefixText :: !T.Text
155+
-- ^ The word right before the cursor position, after removing the module part.
156+
-- For example if the user has typed "Data.Maybe.from",
157+
-- then this property will be "from"
158+
, cursorPos :: !J.Position
159+
-- ^ The cursor position
160+
} deriving (Show,Eq)

‎test/functional/Completion.hs

+29
Original file line numberDiff line numberDiff line change
@@ -84,6 +84,32 @@ tests = testGroup "completions" [
8484
compls <- getCompletions doc (Position 5 7)
8585
liftIO $ assertBool "Expected completions" $ not $ null compls
8686

87+
, expectFailIfBeforeGhc92 "record dot syntax is introduced in GHC 9.2"
88+
$ testGroup "recorddotsyntax"
89+
[ testCase "shows field selectors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
90+
doc <- openDoc "RecordDotSyntax.hs" "haskell"
91+
92+
let te = TextEdit (Range (Position 25 0) (Position 25 5)) "z = x.a"
93+
_ <- applyEdit doc te
94+
95+
compls <- getCompletions doc (Position 25 6)
96+
item <- getCompletionByLabel "a" compls
97+
98+
liftIO $ do
99+
item ^. label @?= "a"
100+
, testCase "shows field selectors for nested field" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
101+
doc <- openDoc "RecordDotSyntax.hs" "haskell"
102+
103+
let te = TextEdit (Range (Position 27 0) (Position 27 8)) "z2 = x.c.z"
104+
_ <- applyEdit doc te
105+
106+
compls <- getCompletions doc (Position 27 9)
107+
item <- getCompletionByLabel "z" compls
108+
109+
liftIO $ do
110+
item ^. label @?= "z"
111+
]
112+
87113
-- See https://github.com/haskell/haskell-ide-engine/issues/903
88114
, testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
89115
doc <- openDoc "DupRecFields.hs" "haskell"
@@ -348,3 +374,6 @@ shouldNotContainCompl :: [CompletionItem] -> T.Text -> Assertion
348374
compls `shouldNotContainCompl` lbl =
349375
all ((/= lbl) . (^. label)) compls
350376
@? "Should not contain completion: " ++ show lbl
377+
378+
expectFailIfBeforeGhc92 :: String -> TestTree -> TestTree
379+
expectFailIfBeforeGhc92 = knownBrokenForGhcVersions [GHC810, GHC88, GHC86, GHC90]

‎test/testdata/completion/RecordDotSyntax.hs

+28
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
{-# LANGUAGE OverloadedRecordDot #-}
2+
{-# LANGUAGE DuplicateRecordFields #-}
3+
{-# LANGUAGE NoFieldSelectors #-}
4+
5+
module Test where
6+
7+
import qualified Data.Maybe as M
8+
9+
data MyRecord = MyRecord1
10+
{ a :: String
11+
, b :: Integer
12+
, c :: MyChild
13+
}
14+
| MyRecord2 { a2 :: String
15+
, b2 :: Integer
16+
, c2 :: MyChild
17+
} deriving (Eq, Show)
18+
19+
newtype MyChild = MyChild
20+
{ z :: String
21+
} deriving (Eq, Show)
22+
23+
x = MyRecord1 { a = "Hello", b = 12, c = MyChild { z = "there" } }
24+
25+
y = x.a ++ show x.b
26+
27+
y2 = x.c.z
28+

0 commit comments

Comments
 (0)