Skip to content

Commit 0bb1ffb

Browse files
coltenwebbcoltenwebb
committed
baseline for record completions
1 parent c422cf3 commit 0bb1ffb

File tree

3 files changed

+142
-20
lines changed

3 files changed

+142
-20
lines changed

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

Lines changed: 17 additions & 6 deletions
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
@@ -139,19 +142,27 @@ getCompletionsLSP ide plId
139142
exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap
140143
exportsCompls = mempty{anyQualCompls = exportsCompItems}
141144
let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules
142-
143-
pure (opts, fmap (,pm,binds) compls, moduleExports)
145+
146+
-- get HieAst if OverloadedRecordDot is enabled
147+
let uses_th_qq (ms_hspp_opts -> dflags) = xopt LangExt.OverloadedRecordDot dflags
148+
ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps npath
149+
astres <- case ms of
150+
Just ms' -> if uses_th_qq . msrModSummary $ ms' then useWithStaleFast GetHieAst npath else return Nothing
151+
Nothing -> return Nothing
152+
153+
pure (opts, fmap (,pm,binds) compls, moduleExports, astres)
144154
case compls of
145155
Just (cci', parsedMod, bindMap) -> do
146-
pfix <- VFS.getCompletionPrefix position cnts
156+
pfix <- getCompletionPrefix position cnts
147157
case (pfix, completionContext) of
148-
(Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
158+
(Just (PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
149159
-> return (InL $ List [])
150160
(Just pfix', _) -> do
151161
let clientCaps = clientCapabilities $ shakeExtras ide
152162
plugins = idePlugins $ shakeExtras ide
153163
config <- getCompletionsConfig plId
154-
allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports
164+
165+
allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix' clientCaps config moduleExports
155166
pure $ InL (List $ orderedCompletions allCompletions)
156167
_ -> return (InL $ List [])
157168
_ -> 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))
@@ -67,6 +70,12 @@ import qualified Language.LSP.VFS as VFS
6770
import Text.Fuzzy.Parallel (Scored (score),
6871
original)
6972

73+
import Development.IDE
74+
import Data.Coerce (coerce)
75+
76+
import Data.Char (isAlphaNum)
77+
import qualified Data.Rope.UTF16 as Rope
78+
7079
-- Chunk size used for parallelizing fuzzy matching
7180
chunkSize :: Int
7281
chunkSize = 1000
@@ -564,28 +573,29 @@ getCompletions
564573
-> IdeOptions
565574
-> CachedCompletions
566575
-> Maybe (ParsedModule, PositionMapping)
576+
-> Maybe (HieAstResult, PositionMapping)
567577
-> (Bindings, PositionMapping)
568-
-> VFS.PosPrefixInfo
578+
-> PosPrefixInfo
569579
-> ClientCapabilities
570580
-> CompletionsConfig
571581
-> HM.HashMap T.Text (HashSet.HashSet IdentInfo)
572582
-> IO [Scored CompletionItem]
573583
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 <> "."
584+
maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
585+
let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo
586+
enteredQual = if T.null prefixScope then "" else prefixScope <> "."
577587
fullPrefix = enteredQual <> prefixText
578588

579589
-- Boolean labels to tag suggestions as qualified (or not)
580-
qual = not(T.null prefixModule)
590+
qual = not(T.null prefixScope)
581591
notQual = False
582592

583593
{- correct the position by moving 'foo :: Int -> String -> '
584594
^
585595
to 'foo :: Int -> String -> '
586596
^
587597
-}
588-
pos = VFS.cursorPos prefixInfo
598+
pos = cursorPos prefixInfo
589599

590600
maxC = maxCompletions config
591601

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

611668
-- completions specific to the current context
612669
ctxCompls' = case mcc of
@@ -618,10 +675,10 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
618675
ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'
619676

620677
infixCompls :: Maybe Backtick
621-
infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos
678+
infixCompls = isUsedAsInfix fullLine prefixScope prefixText pos
622679

623680
PositionMapping bDelta = bmapping
624-
oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo
681+
oldPos = fromDelta bDelta $ cursorPos prefixInfo
625682
startLoc = lowerRange oldPos
626683
endLoc = upperRange oldPos
627684
localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc
@@ -634,10 +691,11 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
634691
ty = showForSnippet <$> typ
635692
thisModName = Local $ nameSrcSpan name
636693

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)
694+
compls
695+
| T.null prefixScope = map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)
696+
| not $ null tst = tst
697+
| otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls))
698+
++ ((notQual,) . ($ Just prefixScope) <$> anyQualCompls)
641699

642700
filtListWith f list =
643701
[ fmap f label
@@ -648,7 +706,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
648706
filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
649707
filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName
650708
filtKeywordCompls
651-
| T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
709+
| T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts)
652710
| otherwise = []
653711

654712
if
@@ -892,3 +950,33 @@ mergeListsBy cmp all_lists = merge_lists all_lists
892950
[] -> []
893951
[xs] -> xs
894952
lists' -> merge_lists lists'
953+
954+
955+
getCompletionPrefix :: (Monad m) => Position -> VFS.VirtualFile -> m (Maybe PosPrefixInfo)
956+
getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =
957+
return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad
958+
let headMaybe [] = Nothing
959+
headMaybe (x:_) = Just x
960+
lastMaybe [] = Nothing
961+
lastMaybe xs = Just $ last xs
962+
963+
curLine <- headMaybe $ T.lines $ Rope.toText
964+
$ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext
965+
let beforePos = T.take (fromIntegral c) curLine
966+
curWord <-
967+
if | T.null beforePos -> Just ""
968+
| T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc '
969+
| otherwise -> lastMaybe (T.words beforePos)
970+
971+
let parts = T.split (=='.')
972+
$ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord
973+
case reverse parts of
974+
[] -> Nothing
975+
(x:xs) -> do
976+
let modParts = dropWhile (\_ -> False)
977+
$ reverse $ filter (not .T.null) xs
978+
modName = T.intercalate "." modParts
979+
return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos }
980+
981+
completionPrefixPos :: PosPrefixInfo -> Position
982+
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)