Skip to content
This repository was archived by the owner on Oct 7, 2020. It is now read-only.

Commit fcbf945

Browse files
alanzalanz
authored
Merge pull request #847 from bubba/completion-contexts
Completion contexts
2 parents 0a5cc68 + 932847a commit fcbf945

File tree

10 files changed

+198
-28
lines changed

10 files changed

+198
-28
lines changed

‎hie-plugin-api/Haskell/Ide/Engine/ArtifactMap.hs

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,16 @@
11
{-# LANGUAGE CPP #-}
22
module Haskell.Ide.Engine.ArtifactMap where
33

4-
import Data.Maybe
4+
import Data.Maybe
55
import qualified Data.IntervalMap.FingerTree as IM
66
import qualified Data.Generics as SYB
77

8-
import GhcMod.SrcUtils
9-
108
import qualified GHC
119
import GHC (TypecheckedModule)
1210
import qualified SrcLoc as GHC
1311
import qualified Var
1412
import qualified GhcMod.Gap as GM
13+
import GhcMod.SrcUtils
1514

1615
import Language.Haskell.LSP.Types
1716

@@ -114,7 +113,7 @@ genImportMap tm = moduleMap
114113
genDefMap :: TypecheckedModule -> DefMap
115114
genDefMap tm = mconcat $ map (go . GHC.unLoc) decls
116115
where
117-
-- go :: GHC.HsDecl GHC.GhcPs -> DefMap
116+
go :: GHC.HsDecl GM.GhcPs -> DefMap
118117
-- Type signatures
119118
go (GHC.SigD (GHC.TypeSig lns _)) =
120119
foldl IM.union mempty $ fmap go' lns

‎hie-plugin-api/Haskell/Ide/Engine/Context.hs

Lines changed: 39 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,39 @@
1+
module Haskell.Ide.Engine.Context where
2+
3+
import Data.Generics
4+
import Language.Haskell.LSP.Types
5+
import GHC
6+
import GhcMod.Gap (GhcPs) -- for GHC 8.2.2
7+
import Haskell.Ide.Engine.PluginUtils
8+
9+
-- | A context of a declaration in the program
10+
-- e.g. is the declaration a type declaration or a value declaration
11+
-- Used for determining which code completions to show
12+
-- TODO: expand this with more contexts like classes or instances for
13+
-- smarter code completion
14+
data Context = TypeContext
15+
| ValueContext
16+
deriving (Show, Eq)
17+
18+
-- | Generates a map of where the context is a type and where the context is a value
19+
-- i.e. where are the value decls and the type decls
20+
getContext :: Position -> ParsedModule -> Maybe Context
21+
getContext pos pm = everything join (Nothing `mkQ` go `extQ` goInline) decl
22+
where decl = hsmodDecls $ unLoc $ pm_parsed_source pm
23+
go :: LHsDecl GhcPs -> Maybe Context
24+
go (L (RealSrcSpan r) (SigD _))
25+
| pos `isInsideRange` r = Just TypeContext
26+
| otherwise = Nothing
27+
go (L (GHC.RealSrcSpan r) (GHC.ValD _))
28+
| pos `isInsideRange` r = Just ValueContext
29+
| otherwise = Nothing
30+
go _ = Nothing
31+
goInline :: GHC.LHsType GhcPs -> Maybe Context
32+
goInline (GHC.L (GHC.RealSrcSpan r) _)
33+
| pos `isInsideRange` r = Just TypeContext
34+
| otherwise = Nothing
35+
goInline _ = Nothing
36+
join Nothing x = x
37+
join (Just x) _ = Just x
38+
p `isInsideRange` r = sp <= p && p <= ep
39+
where (sp, ep) = unpackRealSrcSpan r

‎hie-plugin-api/Haskell/Ide/Engine/GhcModuleCache.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,8 @@ data UriCache = UriCache
2626
{ cachedInfo :: !CachedInfo
2727
, cachedPsMod :: !ParsedModule
2828
, cachedTcMod :: !(Maybe TypecheckedModule)
29+
-- | Data pertaining to the typechecked module,
30+
-- not the parsed module
2931
, cachedData :: !(Map.Map TypeRep Dynamic)
3032
}
3133

‎hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -222,11 +222,13 @@ cacheModule uri modul = do
222222
muc <- getUriCache uri'
223223
let defInfo = CachedInfo mempty mempty mempty mempty rfm return return
224224
return $ case muc of
225-
Just (UriCacheSuccess uc) -> uc { cachedPsMod = pm }
225+
Just (UriCacheSuccess uc) ->
226+
let newCI = (cachedInfo uc) { revMap = rfm }
227+
in uc { cachedPsMod = pm, cachedInfo = newCI }
226228
_ -> UriCache defInfo pm Nothing mempty
227229

228230
Right tm -> do
229-
typm <- GM.unGmlT $ genTypeMap tm
231+
typm <- GM.unGmlT $ genTypeMap tm
230232
let info = CachedInfo (genLocMap tm) typm (genImportMap tm) (genDefMap tm) rfm return return
231233
pm = GHC.tm_parsed_module tm
232234
return $ UriCache info pm (Just tm) mempty

‎hie-plugin-api/Haskell/Ide/Engine/PluginUtils.hs

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@ module Haskell.Ide.Engine.PluginUtils
1515
, diffText'
1616
, srcSpan2Range
1717
, srcSpan2Loc
18+
, unpackRealSrcSpan
1819
, reverseMapFile
1920
, fileInfo
2021
, realSrcSpan2Range

‎hie-plugin-api/hie-plugin-api.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ library
2020
exposed-modules:
2121
Haskell.Ide.Engine.ArtifactMap
2222
Haskell.Ide.Engine.Compat
23+
Haskell.Ide.Engine.Context
2324
Haskell.Ide.Engine.GhcModuleCache
2425
Haskell.Ide.Engine.IdeFunctions
2526
Haskell.Ide.Engine.ModuleCache

‎src/Haskell/Ide/Engine/Plugin/HieExtras.hs

Lines changed: 43 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE NamedFieldPuns #-}
2+
{-# LANGUAGE RecordWildCards #-}
23
{-# LANGUAGE ScopedTypeVariables #-}
34
{-# LANGUAGE OverloadedStrings #-}
45
{-# LANGUAGE TypeFamilies #-}
@@ -23,6 +24,7 @@ import Control.Lens.Operators ( (^?), (?~) )
2324
import Control.Lens.Prism ( _Just )
2425
import Control.Monad.Reader
2526
import Data.Aeson
27+
import Data.Char
2628
import Data.IORef
2729
import qualified Data.List as List
2830
import qualified Data.Map as Map
@@ -34,10 +36,11 @@ import DataCon
3436
import Exception
3537
import FastString
3638
import Finder
37-
import GHC
39+
import GHC hiding (getContext)
3840
import qualified GhcMod.LightGhc as GM
3941
import qualified GhcMod.Gap as GM
4042
import Haskell.Ide.Engine.ArtifactMap
43+
import Haskell.Ide.Engine.Context
4144
import Haskell.Ide.Engine.MonadFunctions
4245
import Haskell.Ide.Engine.MonadTypes
4346
import Haskell.Ide.Engine.PluginUtils
@@ -111,7 +114,7 @@ mkCompl CI{origName,importedFrom,thingType,label} =
111114
J.CompletionItem label kind (Just $ maybe "" (<>"\n") typeText <> importedFrom)
112115
Nothing Nothing Nothing Nothing Nothing (Just insertText) (Just J.Snippet)
113116
Nothing Nothing Nothing Nothing hoogleQuery
114-
where kind = Just $ occNameToComKind $ occName origName
117+
where kind = Just $ occNameToComKind $ occName origName
115118
hoogleQuery = Just $ toJSON $ mkQuery label importedFrom
116119
argTypes = maybe [] getArgs thingType
117120
insertText
@@ -184,6 +187,8 @@ data PosPrefixInfo = PosPrefixInfo
184187
-- ^ The word right before the cursor position, after removing the module part.
185188
-- For example if the user has typed "Data.Maybe.from",
186189
-- then this property will be "from"
190+
, cursorPos :: J.Position
191+
-- ^ The cursor position
187192
}
188193

189194
data CachedCompletions = CC
@@ -342,19 +347,48 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) =
342347
debugm $ "got prefix" ++ show (prefixModule, prefixText)
343348
let enteredQual = if T.null prefixModule then "" else prefixModule <> "."
344349
fullPrefix = enteredQual <> prefixText
350+
345351
ifCachedModuleAndData file (IdeResultOk [])
346-
$ \_ _ CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules, cachedExtensions } ->
352+
$ \tm CachedInfo { newPosToOld } CC { allModNamesAsNS, unqualCompls, qualCompls, importableModules, cachedExtensions } ->
347353
let
354+
-- default to value context if no explicit context
355+
context = fromMaybe ValueContext $ getContext pos (tm_parsed_module tm)
356+
357+
{- correct the position by moving 'foo :: Int -> String -> '
358+
^
359+
to 'foo :: Int -> String -> '
360+
^
361+
-}
362+
pos =
363+
let newPos = cursorPos prefixInfo
364+
Position l c = fromMaybe newPos (newPosToOld newPos)
365+
typeStuff = [isSpace, (`elem` (">-." :: String))]
366+
stripTypeStuff = T.dropWhileEnd (\x -> any (\f -> f x) typeStuff)
367+
-- if oldPos points to
368+
-- foo -> bar -> baz
369+
-- ^
370+
-- Then only take the line up to there, discard '-> bar -> baz'
371+
partialLine = T.take c fullLine
372+
-- drop characters used when writing incomplete type sigs
373+
-- like '-> '
374+
d = T.length fullLine - T.length (stripTypeStuff partialLine)
375+
in Position l (c - d)
376+
348377
filtModNameCompls =
349378
map mkModCompl
350379
$ mapMaybe (T.stripPrefix enteredQual)
351380
$ Fuzzy.simpleFilter fullPrefix allModNamesAsNS
352381

353-
filtCompls = Fuzzy.filterBy label prefixText compls
354-
where
355-
compls = if T.null prefixModule
356-
then unqualCompls
357-
else Map.findWithDefault [] prefixModule qualCompls
382+
filtCompls = Fuzzy.filterBy label prefixText ctxCompls
383+
where
384+
isTypeCompl = isTcOcc . occName . origName
385+
-- completions specific to the current context
386+
ctxCompls = case context of
387+
TypeContext -> filter isTypeCompl compls
388+
ValueContext -> filter (not . isTypeCompl) compls
389+
compls = if T.null prefixModule
390+
then unqualCompls
391+
else Map.findWithDefault [] prefixModule qualCompls
358392

359393
mkImportCompl label = (J.detail ?~ label) . mkModCompl $ fromMaybe
360394
""
@@ -409,6 +443,7 @@ getCompletions uri prefixInfo (WithSnippets withSnippets) =
409443
pragmaSuffix fullLine
410444
| "}" `T.isSuffixOf` fullLine = mempty
411445
| otherwise = " #-}"
446+
412447
-- ---------------------------------------------------------------------
413448

414449
getTypeForName :: Name -> IdeM (Maybe Type)

‎src/Haskell/Ide/Engine/Transport/LspStdio.hs

Lines changed: 65 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -213,18 +213,20 @@ configVal defVal field = do
213213

214214
getPrefixAtPos :: (MonadIO m, MonadReader REnv m)
215215
=> Uri -> Position -> m (Maybe Hie.PosPrefixInfo)
216-
getPrefixAtPos uri (Position l c) = do
216+
getPrefixAtPos uri pos@(Position l c) = do
217217
mvf <- liftIO =<< asksLspFuncs Core.getVirtualFileFunc <*> pure uri
218218
case mvf of
219219
Just (VFS.VirtualFile _ yitext) ->
220-
return $ Just $ fromMaybe (Hie.PosPrefixInfo "" "" "") $ do
220+
return $ Just $ fromMaybe (Hie.PosPrefixInfo "" "" "" pos) $ do
221221
let headMaybe [] = Nothing
222222
headMaybe (x:_) = Just x
223223
lastMaybe [] = Nothing
224224
lastMaybe xs = Just $ last xs
225225
curLine <- headMaybe $ Yi.lines $ snd $ Yi.splitAtLine l yitext
226226
let beforePos = Yi.take c curLine
227-
curWord <- Yi.toText <$> lastMaybe (Yi.words beforePos)
227+
curWord <- case Yi.last beforePos of
228+
Just ' ' -> Just "" -- don't count abc as the curword in 'abc '
229+
_ -> Yi.toText <$> lastMaybe (Yi.words beforePos)
228230
let parts = T.split (=='.')
229231
$ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord
230232
case reverse parts of
@@ -233,7 +235,7 @@ getPrefixAtPos uri (Position l c) = do
233235
let modParts = dropWhile (not . isUpper . T.head)
234236
$ reverse $ filter (not .T.null) xs
235237
modName = T.intercalate "." modParts
236-
return $ Hie.PosPrefixInfo (Yi.toText curLine) modName x
238+
return $ Hie.PosPrefixInfo (Yi.toText curLine) modName x pos
237239
Nothing -> return Nothing
238240

239241
-- ---------------------------------------------------------------------
@@ -292,14 +294,67 @@ updatePositionMap uri changes = pluginGetFile "updatePositionMap: " uri $ \file
292294
cacheInfoNoClear file info'
293295
return $ IdeResultOk ()
294296
where
295-
f (+/-) (J.Range (Position sl _) (Position el _)) txt p@(Position l c)
297+
f (+/-) (J.Range (Position sl sc) (Position el ec)) txt p@(Position l c)
298+
299+
-- pos is before the change - unaffected
296300
| l < sl = Just p
301+
-- pos is somewhere after the changed line,
302+
-- move down the pos to keep it the same
297303
| l > el = Just $ Position l' c
304+
305+
{-
306+
LEGEND:
307+
0-9 char index
308+
x untouched char
309+
I/i inserted/replaced char
310+
. deleted char
311+
^ pos to be converted
312+
-}
313+
314+
{-
315+
012345 67
316+
xxxxxx xx
317+
^
318+
0123456789
319+
xxIIIIiixx
320+
^
321+
322+
pos is unchanged if before the edited range
323+
-}
324+
| l == sl && c <= sc = Just p
325+
326+
{-
327+
01234 56
328+
xxxxx xx
329+
^
330+
012345678
331+
xxIIIiixx
332+
^
333+
If pos is in the affected range move to after the range
334+
-}
335+
| l == sl && l == el && c <= nec && newL == 0 = Just $ Position l ec
336+
337+
{-
338+
01234 56
339+
xxxxx xx
340+
^
341+
012345678
342+
xxIIIiixx
343+
^
344+
If pos is after the affected range, update the char index
345+
to keep it in the same place
346+
-}
347+
| l == sl && l == el && c > nec && newL == 0 = Just $ Position l (c +/- (nec - sc))
348+
349+
-- oh well we tried ¯\_(ツ)_/¯
298350
| otherwise = Nothing
299351
where l' = l +/- dl
300352
dl = newL - oldL
301353
oldL = el-sl
302354
newL = T.count "\n" txt
355+
nec -- new end column
356+
| newL == 0 = sc + T.length txt
357+
| otherwise = T.length $ last $ T.lines txt
303358
oldToNew = f (+)
304359
newToOld = f (-)
305360

@@ -802,23 +857,23 @@ requestDiagnostics DiagnosticsRequest{trigger, file, trackingNumber, documentVer
802857
mc <- liftIO $ Core.config lf
803858
case Map.lookup trigger diagFuncs of
804859
Nothing -> do
805-
logm $ "requestDiagnostics: no diagFunc for:" ++ show trigger
860+
debugm $ "requestDiagnostics: no diagFunc for:" ++ show trigger
806861
return ()
807862
Just dss -> do
808863
dpsEnabled <- configVal (Map.fromList [("liquid",False)]) getDiagnosticProvidersConfig
809-
logm $ "requestDiagnostics: got diagFunc for:" ++ show trigger
864+
debugm $ "requestDiagnostics: got diagFunc for:" ++ show trigger
810865
forM_ dss $ \(pid,ds) -> do
811-
logm $ "requestDiagnostics: calling diagFunc for plugin:" ++ show pid
866+
debugm $ "requestDiagnostics: calling diagFunc for plugin:" ++ show pid
812867
let
813868
enabled = Map.findWithDefault True pid dpsEnabled
814869
publishDiagnosticsIO = Core.publishDiagnosticsFunc lf
815870
maxToSend = maybe 50 maxNumberOfProblems mc
816871
sendOne (fileUri,ds') = do
817-
logm $ "LspStdio.sendone:(fileUri,ds')=" ++ show(fileUri,ds')
872+
debugm $ "LspStdio.sendone:(fileUri,ds')=" ++ show(fileUri,ds')
818873
publishDiagnosticsIO maxToSend fileUri Nothing (Map.fromList [(Just pid,SL.toSortedList ds')])
819874

820875
sendEmpty = do
821-
logm "LspStdio.sendempty"
876+
debugm "LspStdio.sendempty"
822877
publishDiagnosticsIO maxToSend file Nothing (Map.fromList [(Just pid,SL.toSortedList [])])
823878

824879
-- fv = case documentVersion of

0 commit comments

Comments
 (0)