Skip to content

Commit e2de534

Browse files
coltenwebbcoltenwebb
committed
baseline for record completions
1 parent 830596e commit e2de534

File tree

3 files changed

+142
-21
lines changed

3 files changed

+142
-21
lines changed

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

Lines changed: 17 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -44,11 +44,13 @@ import GHC.Exts (fromList, toList)
4444
import Ide.Plugin.Config (Config)
4545
import Ide.Types
4646
import qualified Language.LSP.Server as LSP
47-
import Language.LSP.Types
4847
import qualified Language.LSP.VFS as VFS
4948
import Numeric.Natural
5049
import Text.Fuzzy.Parallel (Scored (..))
5150

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

5456
instance Pretty Log where
@@ -121,7 +123,7 @@ getCompletionsLSP ide plId
121123
fmap Right $ case (contents, uriToFilePath' uri) of
122124
(Just cnts, Just path) -> do
123125
let npath = toNormalizedFilePath' path
124-
(ideOpts, compls, moduleExports) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do
126+
(ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do
125127
opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
126128
localCompls <- useWithStaleFast LocalCompletions npath
127129
nonLocalCompls <- useWithStaleFast NonLocalCompletions npath
@@ -140,19 +142,27 @@ getCompletionsLSP ide plId
140142
exportsCompItems = foldMap (map (fromIdentInfo uri) . Set.toList) . Map.elems . getExportsMap $ exportsMap
141143
exportsCompls = mempty{anyQualCompls = exportsCompItems}
142144
let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules
143-
144-
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)
145154
case compls of
146155
Just (cci', parsedMod, bindMap) -> do
147-
pfix <- VFS.getCompletionPrefix position cnts
156+
pfix <- getCompletionPrefix position cnts
148157
case (pfix, completionContext) of
149-
(Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
158+
(Just (PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
150159
-> return (InL $ List [])
151160
(Just pfix', _) -> do
152161
let clientCaps = clientCapabilities $ shakeExtras ide
153162
plugins = idePlugins $ shakeExtras ide
154163
config <- getCompletionsConfig plId
155-
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
156166
pure $ InL (List $ orderedCompletions allCompletions)
157167
_ -> return (InL $ List [])
158168
_ -> 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
@@ -562,28 +571,29 @@ getCompletions
562571
-> IdeOptions
563572
-> CachedCompletions
564573
-> Maybe (ParsedModule, PositionMapping)
574+
-> Maybe (HieAstResult, PositionMapping)
565575
-> (Bindings, PositionMapping)
566-
-> VFS.PosPrefixInfo
576+
-> PosPrefixInfo
567577
-> ClientCapabilities
568578
-> CompletionsConfig
569579
-> HM.HashMap T.Text (HashSet.HashSet IdentInfo)
570580
-> IO [Scored CompletionItem]
571581
getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
572-
maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
573-
let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo
574-
enteredQual = if T.null prefixModule then "" else prefixModule <> "."
582+
maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
583+
let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo
584+
enteredQual = if T.null prefixScope then "" else prefixScope <> "."
575585
fullPrefix = enteredQual <> prefixText
576586

577587
-- Boolean labels to tag suggestions as qualified (or not)
578-
qual = not(T.null prefixModule)
588+
qual = not(T.null prefixScope)
579589
notQual = False
580590

581591
{- correct the position by moving 'foo :: Int -> String -> '
582592
^
583593
to 'foo :: Int -> String -> '
584594
^
585595
-}
586-
pos = VFS.cursorPos prefixInfo
596+
pos = cursorPos prefixInfo
587597

588598
maxC = maxCompletions config
589599

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

609666
-- completions specific to the current context
610667
ctxCompls' = case mcc of
@@ -616,10 +673,10 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
616673
ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'
617674

618675
infixCompls :: Maybe Backtick
619-
infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos
676+
infixCompls = isUsedAsInfix fullLine prefixScope prefixText pos
620677

621678
PositionMapping bDelta = bmapping
622-
oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo
679+
oldPos = fromDelta bDelta $ cursorPos prefixInfo
623680
startLoc = lowerRange oldPos
624681
endLoc = upperRange oldPos
625682
localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc
@@ -632,10 +689,11 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
632689
ty = showForSnippet <$> typ
633690
thisModName = Local $ nameSrcSpan name
634691

635-
compls = if T.null prefixModule
636-
then map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)
637-
else ((qual,) <$> Map.findWithDefault [] prefixModule (getQualCompls qualCompls))
638-
++ ((notQual,) . ($ Just prefixModule) <$> anyQualCompls)
692+
compls
693+
| T.null prefixScope = map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)
694+
| not $ null tst = tst
695+
| otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls))
696+
++ ((notQual,) . ($ Just prefixScope) <$> anyQualCompls)
639697

640698
filtListWith f list =
641699
[ fmap f label
@@ -646,7 +704,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
646704
filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
647705
filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName
648706
filtKeywordCompls
649-
| T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
707+
| T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts)
650708
| otherwise = []
651709

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