Skip to content

Commit 1a069dc

Browse files
coltenwebbcoltenwebb
committed
baseline for record completions
1 parent 41b1085 commit 1a069dc

File tree

3 files changed

+141
-20
lines changed

3 files changed

+141
-20
lines changed

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

Lines changed: 16 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -47,10 +47,12 @@ import GHC.Exts (fromList, toList)
4747
import Ide.Plugin.Config (Config)
4848
import Ide.Types
4949
import qualified Language.LSP.Server as LSP
50-
import Language.LSP.Types
5150
import qualified Language.LSP.VFS as VFS
5251
import Text.Fuzzy.Parallel (Scored (..))
5352

53+
import qualified GHC.LanguageExtensions as LangExt
54+
import Language.LSP.Types
55+
5456
data Log = LogShake Shake.Log deriving Show
5557

5658
instance Pretty Log where
@@ -120,7 +122,7 @@ getCompletionsLSP ide plId
120122
fmap Right $ case (contents, uriToFilePath' uri) of
121123
(Just cnts, Just path) -> do
122124
let npath = toNormalizedFilePath' path
123-
(ideOpts, compls, moduleExports) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do
125+
(ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do
124126
opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
125127
localCompls <- useWithStaleFast LocalCompletions npath
126128
nonLocalCompls <- useWithStaleFast NonLocalCompletions npath
@@ -139,18 +141,26 @@ getCompletionsLSP ide plId
139141
exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap
140142
exportsCompls = mempty{anyQualCompls = exportsCompItems}
141143
let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules
144+
145+
-- get HieAst if OverloadedRecordDot is enabled
146+
let uses_th_qq (ms_hspp_opts -> dflags) = xopt LangExt.OverloadedRecordDot dflags
147+
ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps npath
148+
astres <- case ms of
149+
Just ms' -> if uses_th_qq . msrModSummary $ ms' then useWithStaleFast GetHieAst npath else return Nothing
150+
Nothing -> return Nothing
142151

143-
pure (opts, fmap (,pm,binds) compls, moduleExports)
152+
pure (opts, fmap (,pm,binds) compls, moduleExports, astres)
144153
case compls of
145154
Just (cci', parsedMod, bindMap) -> do
146-
pfix <- VFS.getCompletionPrefix position cnts
155+
pfix <- getCompletionPrefix position cnts
147156
case (pfix, completionContext) of
148-
(Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
157+
(Just (PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
149158
-> return (InL $ List [])
150159
(Just pfix', _) -> do
151160
let clientCaps = clientCapabilities $ shakeExtras ide
152161
config <- getCompletionsConfig plId
153-
allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports
162+
163+
allCompletions <- liftIO $ getCompletions plId ideOpts cci' parsedMod astres bindMap pfix' clientCaps config moduleExports
154164
pure $ InL (List $ orderedCompletions allCompletions)
155165
_ -> return (InL $ List [])
156166
_ -> return (InL $ List [])

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

Lines changed: 102 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Development.IDE.Plugin.Completions.Logic (
1010
, localCompletionsForParsedModule
1111
, getCompletions
1212
, fromIdentInfo
13+
, getCompletionPrefix
1314
) where
1415

1516
import Control.Applicative
@@ -20,7 +21,7 @@ import Data.List.Extra as List hiding
2021
import qualified Data.Map as Map
2122

2223
import Data.Maybe (fromMaybe, isJust,
23-
mapMaybe)
24+
mapMaybe, catMaybes)
2425
import qualified Data.Text as T
2526
import qualified Text.Fuzzy.Parallel as Fuzzy
2627

@@ -30,6 +31,8 @@ import Data.Either (fromRight)
3031
import Data.Function (on)
3132
import Data.Functor
3233
import qualified Data.HashMap.Strict as HM
34+
import qualified Data.Map.Strict as M
35+
3336
import qualified Data.HashSet as HashSet
3437
import Data.Monoid (First (..))
3538
import Data.Ord (Down (Down))
@@ -66,6 +69,12 @@ import qualified Language.LSP.VFS as VFS
6669
import Text.Fuzzy.Parallel (Scored (score),
6770
original)
6871

72+
import Development.IDE
73+
import Data.Coerce (coerce)
74+
75+
import Data.Char (isAlphaNum)
76+
import qualified Data.Rope.UTF16 as Rope
77+
6978
-- Chunk size used for parallelizing fuzzy matching
7079
chunkSize :: Int
7180
chunkSize = 1000
@@ -557,28 +566,29 @@ getCompletions
557566
-> IdeOptions
558567
-> CachedCompletions
559568
-> Maybe (ParsedModule, PositionMapping)
569+
-> Maybe (HieAstResult, PositionMapping)
560570
-> (Bindings, PositionMapping)
561-
-> VFS.PosPrefixInfo
571+
-> PosPrefixInfo
562572
-> ClientCapabilities
563573
-> CompletionsConfig
564574
-> HM.HashMap T.Text (HashSet.HashSet IdentInfo)
565575
-> IO [Scored CompletionItem]
566576
getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
567-
maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
568-
let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo
569-
enteredQual = if T.null prefixModule then "" else prefixModule <> "."
577+
maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
578+
let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo
579+
enteredQual = if T.null prefixScope then "" else prefixScope <> "."
570580
fullPrefix = enteredQual <> prefixText
571581

572582
-- Boolean labels to tag suggestions as qualified (or not)
573-
qual = not(T.null prefixModule)
583+
qual = not(T.null prefixScope)
574584
notQual = False
575585

576586
{- correct the position by moving 'foo :: Int -> String -> '
577587
^
578588
to 'foo :: Int -> String -> '
579589
^
580590
-}
581-
pos = VFS.cursorPos prefixInfo
591+
pos = cursorPos prefixInfo
582592

583593
maxC = maxCompletions config
584594

@@ -600,6 +610,53 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
600610
lpos = lowerRange position'
601611
hpos = upperRange position'
602612
in getCContext lpos pm <|> getCContext hpos pm
613+
614+
dotFieldSelectorToCompl :: T.Text -> (Bool, CompItem)
615+
dotFieldSelectorToCompl label = (True, CI CiVariable label (ImportedFrom T.empty) Nothing label Nothing emptySpanDoc False Nothing)
616+
617+
-- we need the hieast to be fresh
618+
-- not fresh, hasfield won't have a chance. it would to another larger change to ghc IfaceTyCon to contain record fields
619+
tst :: [(Bool, CompItem)]
620+
tst = case maybe_ast_res of
621+
Just (HAR {hieAst = hieast, hieKind = HieFresh},_) -> concat $ pointCommand hieast (completionPrefixPos prefixInfo) (theFunc HieFresh)
622+
_ -> []
623+
624+
getSels :: GHC.TyCon -> [T.Text]
625+
getSels tycon = let f fieldLabel = printOutputable fieldLabel
626+
in map f $ tyConFieldLabels tycon
627+
628+
theFunc :: HieKind Type -> HieAST Type -> [(Bool, CompItem)]
629+
theFunc kind node = concatMap g (nodeType $ nodeInfoH kind node)
630+
where
631+
g :: Type -> [(Bool, CompItem)]
632+
g (TyConApp theTyCon _) = map dotFieldSelectorToCompl $ getSels theTyCon
633+
g _ = []
634+
635+
nodeInfoH :: HieKind a -> HieAST a -> NodeInfo a
636+
nodeInfoH (HieFromDisk _) = nodeInfo'
637+
nodeInfoH HieFresh = nodeInfo
638+
639+
pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a]
640+
pointCommand hf pos k =
641+
catMaybes $ M.elems $ flip M.mapWithKey (getAsts hf) $ \fs ast ->
642+
-- Since GHC 9.2:
643+
-- getAsts :: Map HiePath (HieAst a)
644+
-- type HiePath = LexialFastString
645+
--
646+
-- but before:
647+
-- getAsts :: Map HiePath (HieAst a)
648+
-- type HiePath = FastString
649+
--
650+
-- 'coerce' here to avoid an additional function for maintaining
651+
-- backwards compatibility.
652+
case selectSmallestContaining (sp $ coerce fs) ast of
653+
Nothing -> Nothing
654+
Just ast' -> Just $ k ast'
655+
where
656+
sloc fs = mkRealSrcLoc fs (fromIntegral $ line+1) (fromIntegral $ cha+1)
657+
sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
658+
line = _line pos
659+
cha = _character pos
603660

604661
-- completions specific to the current context
605662
ctxCompls' = case mcc of
@@ -611,10 +668,10 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
611668
ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'
612669

613670
infixCompls :: Maybe Backtick
614-
infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos
671+
infixCompls = isUsedAsInfix fullLine prefixScope prefixText pos
615672

616673
PositionMapping bDelta = bmapping
617-
oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo
674+
oldPos = fromDelta bDelta $ cursorPos prefixInfo
618675
startLoc = lowerRange oldPos
619676
endLoc = upperRange oldPos
620677
localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc
@@ -627,10 +684,11 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
627684
ty = showForSnippet <$> typ
628685
thisModName = Local $ nameSrcSpan name
629686

630-
compls = if T.null prefixModule
631-
then map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)
632-
else ((qual,) <$> Map.findWithDefault [] prefixModule (getQualCompls qualCompls))
633-
++ ((notQual,) . ($ Just prefixModule) <$> anyQualCompls)
687+
compls
688+
| T.null prefixScope = map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)
689+
| not $ null tst = tst
690+
| otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls))
691+
++ ((notQual,) . ($ Just prefixScope) <$> anyQualCompls)
634692

635693
filtListWith f list =
636694
[ fmap f label
@@ -641,7 +699,7 @@ getCompletions plId ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qu
641699
filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
642700
filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName
643701
filtKeywordCompls
644-
| T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
702+
| T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts)
645703
| otherwise = []
646704

647705
if
@@ -884,3 +942,33 @@ mergeListsBy cmp all_lists = merge_lists all_lists
884942
[] -> []
885943
[xs] -> xs
886944
lists' -> merge_lists lists'
945+
946+
947+
getCompletionPrefix :: (Monad m) => Position -> VFS.VirtualFile -> m (Maybe PosPrefixInfo)
948+
getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =
949+
return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad
950+
let headMaybe [] = Nothing
951+
headMaybe (x:_) = Just x
952+
lastMaybe [] = Nothing
953+
lastMaybe xs = Just $ last xs
954+
955+
curLine <- headMaybe $ T.lines $ Rope.toText
956+
$ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext
957+
let beforePos = T.take (fromIntegral c) curLine
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 = dropWhile (\_ -> False)
969+
$ reverse $ filter (not .T.null) xs
970+
modName = T.intercalate "." modParts
971+
return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos }
972+
973+
completionPrefixPos :: PosPrefixInfo -> Position
974+
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

Lines changed: 23 additions & 0 deletions
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,25 @@ 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+
-- moved here from Language.LSP.VHS
143+
-- | Describes the line at the current cursor position
144+
data PosPrefixInfo = PosPrefixInfo
145+
{ fullLine :: !T.Text
146+
-- ^ The full contents of the line the cursor is at
147+
148+
, prefixScope :: !T.Text
149+
-- ^ If any, the module name that was typed right before the cursor position.
150+
-- For example, if the user has typed "Data.Maybe.from", then this property
151+
-- will be "Data.Maybe"
152+
-- If OverloadedRecordDot is enabled, "Shape.rect.width" will be
153+
-- "Shape.rect"
154+
155+
, prefixText :: !T.Text
156+
-- ^ The word right before the cursor position, after removing the module part.
157+
-- For example if the user has typed "Data.Maybe.from",
158+
-- then this property will be "from"
159+
, cursorPos :: !J.Position
160+
-- ^ The cursor position
161+
} deriving (Show,Eq)

0 commit comments

Comments
 (0)