Skip to content

Commit 8c3bf56

Browse files
gdevanlapepeiborra
gdevanla
and
pepeiborra
authored
Record completions snippets (haskell/ghcide#900)
* Add field for RecordSnippets to CachcedCompletion * Initial version of local record snippets * Supprt record snippet completion for non local declarations. * Better integration of local completions with current implementation * Clean up non-local completions. * Remove commented code. * Switch from String to Text * Remove ununsed definition * Treat only Records and leave other defintions as is. * Differentiate Records from Data constructors for external declaration * Update test to include snippet in local record completions expected list. * Update completionTest to also compare insertText. * Add test for record snippet completion for imported records. * Hlint fixes * Hlint fixes * Hlint suggestions. * Update type. * Consolidate imports * Unpack tuple with explicit names * Idiomatic changes * Remove unused variable * Better variable name * Hlint suggestions * Handle exhaustive pattern warning * Add _ to snippet field name suggestions * Remove type information passed around but not used * Update to list comprehension style * Eliminate intermediate function * HLint suggestions. * Idiomatic list comprehension Co-authored-by: Pepe Iborra <[email protected]>
1 parent f6e73d5 commit 8c3bf56

File tree

2 files changed

+143
-51
lines changed

2 files changed

+143
-51
lines changed

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

+96-15
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
{-# LANGUAGE CPP #-}
2+
23
#include "ghc-api-version.h"
34
-- Mostly taken from "haskell-ide-engine"
45
module Development.IDE.Plugin.Completions.Logic (
@@ -14,7 +15,8 @@ import Data.Char (isUpper)
1415
import Data.Generics
1516
import Data.List.Extra as List hiding (stripPrefix)
1617
import qualified Data.Map as Map
17-
import Data.Maybe (fromMaybe, mapMaybe)
18+
19+
import Data.Maybe (listToMaybe, fromMaybe, mapMaybe)
1820
import qualified Data.Text as T
1921
import qualified Text.Fuzzy as Fuzzy
2022

@@ -45,6 +47,11 @@ import Development.IDE.Spans.Common
4547
import Development.IDE.GHC.Util
4648
import Outputable (Outputable)
4749
import qualified Data.Set as Set
50+
import ConLike
51+
52+
import GhcPlugins (
53+
flLabel,
54+
unpackFS)
4855

4956
-- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
5057

@@ -259,27 +266,39 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do
259266

260267
getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)
261268
getComplsForOne (GRE n _ True _) =
262-
(\x -> ([x],mempty)) <$> toCompItem curMod curModName n
269+
(, mempty) <$> toCompItem curMod curModName n
263270
getComplsForOne (GRE n _ False prov) =
264271
flip foldMapM (map is_decl prov) $ \spec -> do
265272
compItem <- toCompItem curMod (is_mod spec) n
266273
let unqual
267274
| is_qual spec = []
268-
| otherwise = [compItem]
275+
| otherwise = compItem
269276
qual
270-
| is_qual spec = Map.singleton asMod [compItem]
271-
| otherwise = Map.fromList [(asMod,[compItem]),(origMod,[compItem])]
277+
| is_qual spec = Map.singleton asMod compItem
278+
| otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]
272279
asMod = showModName (is_as spec)
273280
origMod = showModName (is_mod spec)
274281
return (unqual,QualCompls qual)
275282

276-
toCompItem :: Module -> ModuleName -> Name -> IO CompItem
283+
toCompItem :: Module -> ModuleName -> Name -> IO [CompItem]
277284
toCompItem m mn n = do
278285
docs <- getDocumentationTryGhc packageState curMod deps n
279286
ty <- catchSrcErrors (hsc_dflags packageState) "completion" $ do
280287
name' <- lookupName packageState m n
281288
return $ name' >>= safeTyThingType
282-
return $ mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs
289+
-- use the same pass to also capture any Record snippets that we can collect
290+
record_ty <- catchSrcErrors (hsc_dflags packageState) "record-completion" $ do
291+
name' <- lookupName packageState m n
292+
return $ name' >>= safeTyThingForRecord
293+
294+
let recordCompls = case either (const Nothing) id record_ty of
295+
Just (ctxStr, flds) -> case flds of
296+
[] -> []
297+
_ -> [mkRecordSnippetCompItem ctxStr flds (ppr mn) docs]
298+
Nothing -> []
299+
300+
return $ [mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs] ++
301+
recordCompls
283302

284303
(unquals,quals) <- getCompls rdrElts
285304

@@ -290,6 +309,7 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do
290309
, importableModules = moduleNames
291310
}
292311

312+
293313
-- | Produces completions from the top level declarations of a module.
294314
localCompletionsForParsedModule :: ParsedModule -> CachedCompletions
295315
localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} =
@@ -323,9 +343,14 @@ localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{
323343
| L _ (TypeSig _ ids typ) <- tcdSigs
324344
, id <- ids]
325345
TyClD _ x ->
326-
[mkComp id cl Nothing
327-
| id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x
328-
, let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]
346+
let generalCompls = [mkComp id cl Nothing
347+
| id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x
348+
, let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]
349+
-- here we only have to look at the outermost type
350+
recordCompls = findRecordCompl pm thisModName x
351+
in
352+
-- the constructors and snippets will be duplicated here giving the user 2 choices.
353+
generalCompls ++ recordCompls
329354
ForD _ ForeignImport{fd_name,fd_sig_ty} ->
330355
[mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]
331356
ForD _ ForeignExport{fd_name,fd_sig_ty} ->
@@ -342,18 +367,45 @@ localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{
342367

343368
thisModName = ppr hsmodName
344369

370+
--recordCompls = localRecordSnippetProducer pm thisModName
371+
372+
findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem]
373+
findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result
374+
where
375+
result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc
376+
| ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn
377+
, Just con_details <- [getFlds con_args]
378+
, let field_names = mapMaybe extract con_details
379+
, let field_labels = T.pack . showGhc . unLoc <$> field_names
380+
, (not . List.null) field_labels
381+
]
382+
doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing)
383+
384+
getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs]
385+
getFlds conArg = case conArg of
386+
RecCon rec -> Just $ unLoc <$> unLoc rec
387+
PrefixCon _ -> Just []
388+
_ -> Nothing
389+
390+
extract ConDeclField{..}
391+
-- TODO: Why is cd_fld_names a list?
392+
| Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name
393+
| otherwise = Nothing
394+
-- XConDeclField
395+
extract _ = Nothing
396+
findRecordCompl _ _ _ = []
397+
345398
ppr :: Outputable a => a -> T.Text
346399
ppr = T.pack . prettyPrint
347400

348401
newtype WithSnippets = WithSnippets Bool
349402

350403
toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem
351404
toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
352-
| with && supported = x
405+
| with = x
353406
| otherwise = x { _insertTextFormat = Just PlainText
354-
, _insertText = Nothing
355-
}
356-
where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
407+
, _insertText = Nothing
408+
}
357409

358410
-- | Returns the cached completions for the given module and position.
359411
getCompletions
@@ -466,7 +518,6 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
466518
in filtModNameCompls ++ map (toggleSnippets caps withSnippets
467519
. mkCompl ideOpts . stripAutoGenerated) uniqueFiltCompls
468520
++ filtKeywordCompls
469-
470521
return result
471522

472523

@@ -600,3 +651,33 @@ prefixes =
600651
, "$c"
601652
, "$m"
602653
]
654+
655+
656+
safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text])
657+
safeTyThingForRecord (AnId _) = Nothing
658+
safeTyThingForRecord (AConLike dc) =
659+
let ctxStr = T.pack . showGhc . occName . conLikeName $ dc
660+
field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc
661+
in
662+
Just (ctxStr, field_names)
663+
safeTyThingForRecord _ = Nothing
664+
665+
mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> CompItem
666+
mkRecordSnippetCompItem ctxStr compl mn docs = r
667+
where
668+
r = CI {
669+
compKind = CiSnippet
670+
, insertText = buildSnippet
671+
, importedFrom = importedFrom
672+
, typeText = Nothing
673+
, label = ctxStr
674+
, isInfix = Nothing
675+
, docs = docs
676+
, isTypeCompl = False
677+
}
678+
679+
placeholder_pairs = zip compl ([1..]::[Int])
680+
snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs
681+
snippet = T.intercalate (T.pack ", ") snippet_parts
682+
buildSnippet = ctxStr <> " {" <> snippet <> "}"
683+
importedFrom = Right mn

‎test/exe/Main.hs

+47-36
Original file line numberDiff line numberDiff line change
@@ -2717,15 +2717,16 @@ completionTests
27172717
, testGroup "other" otherCompletionTests
27182718
]
27192719

2720-
completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, Bool, Bool)] -> TestTree
2720+
completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool)] -> TestTree
27212721
completionTest name src pos expected = testSessionWait name $ do
27222722
docId <- createDoc "A.hs" "haskell" (T.unlines src)
27232723
_ <- waitForDiagnostics
27242724
compls <- getCompletions docId pos
2725-
let compls' = [ (_label, _kind) | CompletionItem{..} <- compls]
2725+
let compls' = [ (_label, _kind, _insertText) | CompletionItem{..} <- compls]
27262726
liftIO $ do
2727-
compls' @?= [ (l, Just k) | (l,k,_,_) <- expected]
2728-
forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,expectedSig, expectedDocs)) -> do
2727+
let emptyToMaybe x = if T.null x then Nothing else Just x
2728+
compls' @?= [ (l, Just k, emptyToMaybe t) | (l,k,t,_,_) <- expected]
2729+
forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs)) -> do
27292730
when expectedSig $
27302731
assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail)
27312732
when expectedDocs $
@@ -2737,42 +2738,43 @@ topLevelCompletionTests = [
27372738
"variable"
27382739
["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
27392740
(Position 0 8)
2740-
[("xxx", CiFunction, True, True),
2741-
("XxxCon", CiConstructor, False, True)
2741+
[("xxx", CiFunction, "xxx", True, True),
2742+
("XxxCon", CiConstructor, "XxxCon", False, True)
27422743
],
27432744
completionTest
27442745
"constructor"
27452746
["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
27462747
(Position 0 8)
2747-
[("xxx", CiFunction, True, True),
2748-
("XxxCon", CiConstructor, False, True)
2748+
[("xxx", CiFunction, "xxx", True, True),
2749+
("XxxCon", CiConstructor, "XxxCon", False, True)
27492750
],
27502751
completionTest
27512752
"class method"
27522753
["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]
27532754
(Position 0 8)
2754-
[("xxx", CiFunction, True, True)],
2755+
[("xxx", CiFunction, "xxx", True, True)],
27552756
completionTest
27562757
"type"
27572758
["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
27582759
(Position 0 9)
2759-
[("Xxx", CiStruct, False, True)],
2760+
[("Xxx", CiStruct, "Xxx", False, True)],
27602761
completionTest
27612762
"class"
27622763
["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"]
27632764
(Position 0 9)
2764-
[("Xxx", CiClass, False, True)],
2765+
[("Xxx", CiClass, "Xxx", False, True)],
27652766
completionTest
27662767
"records"
27672768
["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]
27682769
(Position 1 19)
2769-
[("_personName", CiFunction, False, True),
2770-
("_personAge", CiFunction, False, True)],
2770+
[("_personName", CiFunction, "_personName", False, True),
2771+
("_personAge", CiFunction, "_personAge", False, True)],
27712772
completionTest
27722773
"recordsConstructor"
27732774
["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]
27742775
(Position 1 19)
2775-
[("XyRecord", CiConstructor, False, True)]
2776+
[("XyRecord", CiConstructor, "XyRecord", False, True),
2777+
("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True)]
27762778
]
27772779

27782780
localCompletionTests :: [TestTree]
@@ -2781,8 +2783,8 @@ localCompletionTests = [
27812783
"argument"
27822784
["bar (Just abcdef) abcdefg = abcd"]
27832785
(Position 0 32)
2784-
[("abcdef", CiFunction, True, False),
2785-
("abcdefg", CiFunction , True, False)
2786+
[("abcdef", CiFunction, "abcdef", True, False),
2787+
("abcdefg", CiFunction , "abcdefg", True, False)
27862788
],
27872789
completionTest
27882790
"let"
@@ -2791,8 +2793,8 @@ localCompletionTests = [
27912793
," in abcd"
27922794
]
27932795
(Position 2 15)
2794-
[("abcdef", CiFunction, True, False),
2795-
("abcdefg", CiFunction , True, False)
2796+
[("abcdef", CiFunction, "abcdef", True, False),
2797+
("abcdefg", CiFunction , "abcdefg", True, False)
27962798
],
27972799
completionTest
27982800
"where"
@@ -2801,8 +2803,8 @@ localCompletionTests = [
28012803
," abcdefg = let abcd = undefined in undefined"
28022804
]
28032805
(Position 0 10)
2804-
[("abcdef", CiFunction, True, False),
2805-
("abcdefg", CiFunction , True, False)
2806+
[("abcdef", CiFunction, "abcdef", True, False),
2807+
("abcdefg", CiFunction , "abcdefg", True, False)
28062808
],
28072809
completionTest
28082810
"do/1"
@@ -2813,7 +2815,7 @@ localCompletionTests = [
28132815
," pure ()"
28142816
]
28152817
(Position 2 6)
2816-
[("abcdef", CiFunction, True, False)
2818+
[("abcdef", CiFunction, "abcdef", True, False)
28172819
],
28182820
completionTest
28192821
"do/2"
@@ -2827,12 +2829,12 @@ localCompletionTests = [
28272829
," abcdefghij = undefined"
28282830
]
28292831
(Position 5 8)
2830-
[("abcde", CiFunction, True, False)
2831-
,("abcdefghij", CiFunction, True, False)
2832-
,("abcdef", CiFunction, True, False)
2833-
,("abcdefg", CiFunction, True, False)
2834-
,("abcdefgh", CiFunction, True, False)
2835-
,("abcdefghi", CiFunction, True, False)
2832+
[("abcde", CiFunction, "abcde", True, False)
2833+
,("abcdefghij", CiFunction, "abcdefghij", True, False)
2834+
,("abcdef", CiFunction, "abcdef", True, False)
2835+
,("abcdefg", CiFunction, "abcdefg", True, False)
2836+
,("abcdefgh", CiFunction, "abcdefgh", True, False)
2837+
,("abcdefghi", CiFunction, "abcdefghi", True, False)
28362838
]
28372839
]
28382840

@@ -2842,32 +2844,41 @@ nonLocalCompletionTests =
28422844
"variable"
28432845
["module A where", "f = hea"]
28442846
(Position 1 7)
2845-
[("head", CiFunction, True, True)],
2847+
[("head", CiFunction, "head ${1:[a]}", True, True)],
28462848
completionTest
28472849
"constructor"
28482850
["module A where", "f = Tru"]
28492851
(Position 1 7)
2850-
[ ("True", CiConstructor, True, True),
2851-
("truncate", CiFunction, True, True)
2852+
[ ("True", CiConstructor, "True ", True, True),
2853+
("truncate", CiFunction, "truncate ${1:a}", True, True)
28522854
],
28532855
completionTest
28542856
"type"
28552857
["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]
28562858
(Position 2 7)
2857-
[ ("Bounded", CiClass, True, True),
2858-
("Bool", CiStruct, True, True)
2859+
[ ("Bounded", CiClass, "Bounded ${1:*}", True, True),
2860+
("Bool", CiStruct, "Bool ", True, True)
28592861
],
28602862
completionTest
28612863
"qualified"
28622864
["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]
28632865
(Position 2 15)
2864-
[ ("head", CiFunction, True, True)
2866+
[ ("head", CiFunction, "head ${1:[a]}", True, True)
28652867
],
28662868
completionTest
28672869
"duplicate import"
28682870
["module A where", "import Data.List", "import Data.List", "f = perm"]
28692871
(Position 3 8)
2870-
[ ("permutations", CiFunction, False, False)
2872+
[ ("permutations", CiFunction, "permutations ${1:[a]}", False, False)
2873+
],
2874+
completionTest
2875+
"record snippet on import"
2876+
["module A where", "import Text.Printf (FormatParse(FormatParse))", "FormatParse"]
2877+
(Position 2 10)
2878+
[("FormatParse", CiStruct, "FormatParse ", False, False),
2879+
("FormatParse", CiConstructor, "FormatParse ${1:String} ${2:Char} ${3:String}", False, False),
2880+
("FormatParse", CiSnippet,
2881+
"FormatParse {fpModifiers=${1:_fpModifiers}, fpChar=${2:_fpChar}, fpRest=${3:_fpRest}}", False, False)
28712882
]
28722883
]
28732884

@@ -2877,7 +2888,7 @@ otherCompletionTests = [
28772888
"keyword"
28782889
["module A where", "f = newty"]
28792890
(Position 1 9)
2880-
[("newtype", CiKeyword, False, False)],
2891+
[("newtype", CiKeyword, "", False, False)],
28812892
completionTest
28822893
"type context"
28832894
[ "{-# OPTIONS_GHC -Wunused-binds #-}",
@@ -2889,7 +2900,7 @@ otherCompletionTests = [
28892900
-- This should be sufficient to detect that we are in a
28902901
-- type context and only show the completion to the type.
28912902
(Position 3 11)
2892-
[("Integer", CiStruct, True, True)]
2903+
[("Integer", CiStruct, "Integer ", True, True)]
28932904
]
28942905

28952906
highlightTests :: TestTree

0 commit comments

Comments
 (0)