Record completions snippets

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+
 #include "ghc-api-version.h"
 -- Mostly taken from "haskell-ide-engine"
 module Development.IDE.Plugin.Completions.Logic (
@@ -14,7 +15,8 @@ import Data.Char (isUpper)
 import Data.Generics
 import Data.List.Extra as List hiding (stripPrefix)
 import qualified Data.Map  as Map
-import Data.Maybe (fromMaybe, mapMaybe)
+
+import Data.Maybe (listToMaybe, fromMaybe, mapMaybe)
 import qualified Data.Text as T
 import qualified Text.Fuzzy as Fuzzy
 
@@ -45,6 +47,11 @@ import Development.IDE.Spans.Common
 import Development.IDE.GHC.Util
 import Outputable (Outputable)
 import qualified Data.Set as Set
+import ConLike
+
+import GhcPlugins (
+    flLabel,
+    unpackFS)
 
 -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
 
@@ -259,27 +266,39 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do
 
       getComplsForOne :: GlobalRdrElt -> IO ([CompItem],QualCompls)
       getComplsForOne (GRE n _ True _) =
-        (\x -> ([x],mempty)) <$> toCompItem curMod curModName n
+          (, mempty) <$> toCompItem curMod curModName n
       getComplsForOne (GRE n _ False prov) =
         flip foldMapM (map is_decl prov) $ \spec -> do
           compItem <- toCompItem curMod (is_mod spec) n
           let unqual
                 | is_qual spec = []
-                | otherwise = [compItem]
+                | otherwise = compItem
               qual
-                | is_qual spec = Map.singleton asMod [compItem]
-                | otherwise = Map.fromList [(asMod,[compItem]),(origMod,[compItem])]
+                | is_qual spec = Map.singleton asMod compItem
+                | otherwise = Map.fromList [(asMod,compItem),(origMod,compItem)]
               asMod = showModName (is_as spec)
               origMod = showModName (is_mod spec)
           return (unqual,QualCompls qual)
 
-      toCompItem :: Module -> ModuleName -> Name -> IO CompItem
+      toCompItem :: Module -> ModuleName -> Name -> IO [CompItem]
       toCompItem m mn n = do
         docs <- getDocumentationTryGhc packageState curMod deps n
         ty <- catchSrcErrors (hsc_dflags packageState) "completion" $ do
                 name' <- lookupName packageState m n
                 return $ name' >>= safeTyThingType
-        return $ mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs
+        -- use the same pass to also capture any Record snippets that we can collect
+        record_ty <- catchSrcErrors (hsc_dflags packageState) "record-completion" $ do
+                name' <- lookupName packageState m n
+                return $ name' >>= safeTyThingForRecord
+
+        let recordCompls = case either (const Nothing) id record_ty of
+                Just (ctxStr, flds) -> case flds of
+                    [] -> []
+                    _ -> [mkRecordSnippetCompItem ctxStr flds (ppr mn) docs]
+                Nothing -> []
+
+        return $ [mkNameCompItem n mn (either (const Nothing) id ty) Nothing docs] ++
+                 recordCompls
 
   (unquals,quals) <- getCompls rdrElts
 
@@ -290,6 +309,7 @@ cacheDataProducer packageState curMod rdrEnv limports deps = do
     , importableModules = moduleNames
     }
 
+
 -- | Produces completions from the top level declarations of a module.
 localCompletionsForParsedModule :: ParsedModule -> CachedCompletions
 localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{hsmodDecls, hsmodName}} =
@@ -323,9 +343,14 @@ localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{
                 | L _ (TypeSig _ ids typ) <- tcdSigs
                 , id <- ids]
             TyClD _ x ->
-                [mkComp id cl Nothing
-                | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x
-                , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]
+                let generalCompls = [mkComp id cl Nothing
+                        | id <- listify (\(_ :: Located(IdP GhcPs)) -> True) x
+                        , let cl = occNameToComKind Nothing (rdrNameOcc $ unLoc id)]
+                    -- here we only have to look at the outermost type
+                    recordCompls = findRecordCompl pm thisModName x
+                in
+                   -- the constructors and snippets will be duplicated here giving the user 2 choices.
+                   generalCompls ++ recordCompls
             ForD _ ForeignImport{fd_name,fd_sig_ty} ->
                 [mkComp fd_name CiVariable (Just $ ppr fd_sig_ty)]
             ForD _ ForeignExport{fd_name,fd_sig_ty} ->
@@ -342,18 +367,45 @@ localCompletionsForParsedModule pm@ParsedModule{pm_parsed_source = L _ HsModule{
 
     thisModName = ppr hsmodName
 
+    --recordCompls = localRecordSnippetProducer pm thisModName
+
+findRecordCompl :: ParsedModule -> T.Text -> TyClDecl GhcPs -> [CompItem]
+findRecordCompl pmod mn DataDecl {tcdLName, tcdDataDefn} = result
+    where
+        result = [mkRecordSnippetCompItem (T.pack . showGhc . unLoc $ con_name) field_labels mn doc
+                 | ConDeclH98{..} <- unLoc <$> dd_cons tcdDataDefn
+                 , Just  con_details <- [getFlds con_args]
+                 , field_names <- [mapMaybe extract con_details]
+                 , field_labels <- [T.pack . showGhc . unLoc <$> field_names]
+                 , (not . List.null) field_labels
+                 ]
+        doc = SpanDocText (getDocumentation [pmod] tcdLName) (SpanDocUris Nothing Nothing)
+
+        getFlds :: HsConDetails arg (Located [LConDeclField GhcPs]) -> Maybe [ConDeclField GhcPs]
+        getFlds conArg = case conArg of
+                             RecCon rec -> Just $ unLoc <$> unLoc rec
+                             PrefixCon _ -> Just []
+                             _ -> Nothing
+
+        extract ConDeclField{..}
+             -- TODO: Why is cd_fld_names a list?
+            | Just fld_name <- rdrNameFieldOcc . unLoc <$> listToMaybe cd_fld_names = Just fld_name
+            | otherwise = Nothing
+        -- XConDeclField
+        extract _ = Nothing
+findRecordCompl _ _ _ = []
+
 ppr :: Outputable a => a -> T.Text
 ppr = T.pack . prettyPrint
 
 newtype WithSnippets = WithSnippets Bool
 
 toggleSnippets :: ClientCapabilities -> WithSnippets -> CompletionItem -> CompletionItem
 toggleSnippets ClientCapabilities { _textDocument } (WithSnippets with) x
-  | with && supported = x
+  | with = x
   | otherwise = x { _insertTextFormat = Just PlainText
-                  , _insertText       = Nothing
-                  }
-  where supported = Just True == (_textDocument >>= _completion >>= _completionItem >>= _snippetSupport)
+                , _insertText       = Nothing
+                }
 
 -- | Returns the cached completions for the given module and position.
 getCompletions
@@ -466,7 +518,6 @@ getCompletions ideOpts CC { allModNamesAsNS, unqualCompls, qualCompls, importabl
           in filtModNameCompls ++ map (toggleSnippets caps withSnippets
                                          . mkCompl ideOpts . stripAutoGenerated) uniqueFiltCompls
                                ++ filtKeywordCompls
-
   return result
 
 
@@ -600,3 +651,33 @@ prefixes =
   , "$c"
   , "$m"
   ]
+
+
+safeTyThingForRecord :: TyThing -> Maybe (T.Text, [T.Text])
+safeTyThingForRecord (AnId _) = Nothing
+safeTyThingForRecord (AConLike dc) =
+    let ctxStr =   T.pack . showGhc . occName . conLikeName $ dc
+        field_names = T.pack . unpackFS . flLabel <$> conLikeFieldLabels dc
+    in
+        Just (ctxStr, field_names)
+safeTyThingForRecord _ = Nothing
+
+mkRecordSnippetCompItem :: T.Text -> [T.Text] -> T.Text -> SpanDoc -> CompItem
+mkRecordSnippetCompItem ctxStr compl mn docs = r
+  where
+      r  = CI {
+            compKind = CiSnippet
+          , insertText = buildSnippet
+          , importedFrom = importedFrom
+          , typeText = Nothing
+          , label = ctxStr
+          , isInfix = Nothing
+          , docs = docs
+          , isTypeCompl = False
+          }
+
+      placeholder_pairs = zip compl ([1..]::[Int])
+      snippet_parts = map (\(x, i) -> x <> "=${" <> T.pack (show i) <> ":_" <> x <> "}") placeholder_pairs
+      snippet = T.intercalate (T.pack ", ") snippet_parts
+      buildSnippet = ctxStr <> " {" <> snippet <> "}"
+      importedFrom = Right mn

test/exe/Main.hs

@@ -2717,15 +2717,16 @@ completionTests
     , testGroup "other" otherCompletionTests
     ]
 
-completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, Bool, Bool)] -> TestTree
+completionTest :: String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool)] -> TestTree
 completionTest name src pos expected = testSessionWait name $ do
     docId <- createDoc "A.hs" "haskell" (T.unlines src)
     _ <- waitForDiagnostics
     compls <- getCompletions docId pos
-    let compls' = [ (_label, _kind) | CompletionItem{..} <- compls]
+    let compls' = [ (_label, _kind, _insertText) | CompletionItem{..} <- compls]
     liftIO $ do
-        compls' @?= [ (l, Just k) | (l,k,_,_) <- expected]
-        forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,expectedSig, expectedDocs)) -> do
+        let emptyToMaybe x = if T.null x then Nothing else Just x
+        compls' @?= [ (l, Just k, emptyToMaybe t) | (l,k,t,_,_) <- expected]
+        forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs)) -> do
             when expectedSig $
                 assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail)
             when expectedDocs $
@@ -2737,42 +2738,43 @@ topLevelCompletionTests = [
         "variable"
         ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
         (Position 0 8)
-        [("xxx", CiFunction, True, True),
-         ("XxxCon", CiConstructor, False, True)
+        [("xxx", CiFunction, "xxx", True, True),
+         ("XxxCon", CiConstructor, "XxxCon", False, True)
         ],
     completionTest
         "constructor"
         ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
         (Position 0 8)
-        [("xxx", CiFunction, True, True),
-         ("XxxCon", CiConstructor, False, True)
+        [("xxx", CiFunction, "xxx", True, True),
+         ("XxxCon", CiConstructor, "XxxCon", False, True)
         ],
     completionTest
         "class method"
         ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"]
         (Position 0 8)
-        [("xxx", CiFunction, True, True)],
+        [("xxx", CiFunction, "xxx", True, True)],
     completionTest
         "type"
         ["bar :: Xx", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"]
         (Position 0 9)
-        [("Xxx", CiStruct, False, True)],
+        [("Xxx", CiStruct, "Xxx", False, True)],
     completionTest
         "class"
         ["bar :: Xx", "xxx = ()", "-- | haddock", "class Xxx a"]
         (Position 0 9)
-        [("Xxx", CiClass, False, True)],
+        [("Xxx", CiClass, "Xxx", False, True)],
     completionTest
         "records"
         ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ]
         (Position 1 19)
-        [("_personName", CiFunction, False, True),
-         ("_personAge", CiFunction, False, True)],
+        [("_personName", CiFunction, "_personName", False, True),
+         ("_personAge", CiFunction, "_personAge", False, True)],
     completionTest
         "recordsConstructor"
         ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ]
         (Position 1 19)
-        [("XyRecord", CiConstructor, False, True)]
+        [("XyRecord", CiConstructor, "XyRecord", False, True),
+         ("XyRecord", CiSnippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True)]
     ]
 
 localCompletionTests :: [TestTree]
@@ -2781,8 +2783,8 @@ localCompletionTests = [
         "argument"
         ["bar (Just abcdef) abcdefg = abcd"]
         (Position 0 32)
-        [("abcdef", CiFunction, True, False),
-         ("abcdefg", CiFunction , True, False)
+        [("abcdef", CiFunction, "abcdef", True, False),
+         ("abcdefg", CiFunction , "abcdefg", True, False)
         ],
     completionTest
         "let"
@@ -2791,8 +2793,8 @@ localCompletionTests = [
         ,"        in abcd"
         ]
         (Position 2 15)
-        [("abcdef", CiFunction, True, False),
-         ("abcdefg", CiFunction , True, False)
+        [("abcdef", CiFunction, "abcdef", True, False),
+         ("abcdefg", CiFunction , "abcdefg", True, False)
         ],
     completionTest
         "where"
@@ -2801,8 +2803,8 @@ localCompletionTests = [
         ,"        abcdefg = let abcd = undefined in undefined"
         ]
         (Position 0 10)
-        [("abcdef", CiFunction, True, False),
-         ("abcdefg", CiFunction , True, False)
+        [("abcdef", CiFunction, "abcdef", True, False),
+         ("abcdefg", CiFunction , "abcdefg", True, False)
         ],
     completionTest
         "do/1"
@@ -2813,7 +2815,7 @@ localCompletionTests = [
         ,"  pure ()"
         ]
         (Position 2 6)
-        [("abcdef", CiFunction, True, False)
+        [("abcdef", CiFunction, "abcdef", True, False)
         ],
     completionTest
         "do/2"
@@ -2827,12 +2829,12 @@ localCompletionTests = [
         ,"    abcdefghij = undefined"
         ]
         (Position 5 8)
-        [("abcde", CiFunction, True, False)
-        ,("abcdefghij", CiFunction, True, False)
-        ,("abcdef", CiFunction, True, False)
-        ,("abcdefg", CiFunction, True, False)
-        ,("abcdefgh", CiFunction, True, False)
-        ,("abcdefghi", CiFunction, True, False)
+        [("abcde", CiFunction, "abcde", True, False)
+        ,("abcdefghij", CiFunction, "abcdefghij", True, False)
+        ,("abcdef", CiFunction, "abcdef", True, False)
+        ,("abcdefg", CiFunction, "abcdefg", True, False)
+        ,("abcdefgh", CiFunction, "abcdefgh", True, False)
+        ,("abcdefghi", CiFunction, "abcdefghi", True, False)
         ]
     ]
 
@@ -2842,32 +2844,41 @@ nonLocalCompletionTests =
       "variable"
       ["module A where", "f = hea"]
       (Position 1 7)
-      [("head", CiFunction, True, True)],
+      [("head", CiFunction, "head ${1:[a]}", True, True)],
     completionTest
       "constructor"
       ["module A where", "f = Tru"]
       (Position 1 7)
-      [ ("True", CiConstructor, True, True),
-        ("truncate", CiFunction, True, True)
+      [ ("True", CiConstructor, "True ", True, True),
+        ("truncate", CiFunction, "truncate ${1:a}", True, True)
       ],
     completionTest
       "type"
       ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Bo", "f = True"]
       (Position 2 7)
-      [ ("Bounded", CiClass, True, True),
-        ("Bool", CiStruct, True, True)
+      [ ("Bounded", CiClass, "Bounded ${1:*}", True, True),
+        ("Bool", CiStruct, "Bool ", True, True)
       ],
     completionTest
       "qualified"
       ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"]
       (Position 2 15)
-      [ ("head", CiFunction, True, True)
+      [ ("head", CiFunction, "head ${1:[a]}", True, True)
       ],
     completionTest
       "duplicate import"
       ["module A where", "import Data.List", "import Data.List", "f = perm"]
       (Position 3 8)
-      [ ("permutations", CiFunction, False, False)
+      [ ("permutations", CiFunction, "permutations ${1:[a]}", False, False)
+      ],
+    completionTest
+      "record snippet on import"
+      ["module A where", "import Text.Printf (FormatParse(FormatParse))", "FormatParse"]
+      (Position 2 10)
+      [("FormatParse", CiStruct, "FormatParse ", False, False),
+       ("FormatParse", CiConstructor, "FormatParse ${1:String} ${2:Char} ${3:String}", False, False),
+       ("FormatParse", CiSnippet,
+           "FormatParse {fpModifiers=${1:_fpModifiers}, fpChar=${2:_fpChar}, fpRest=${3:_fpRest}}", False, False)
       ]
   ]
 
@@ -2877,7 +2888,7 @@ otherCompletionTests = [
       "keyword"
       ["module A where", "f = newty"]
       (Position 1 9)
-      [("newtype", CiKeyword, False, False)],
+      [("newtype", CiKeyword, "", False, False)],
     completionTest
       "type context"
       [ "{-# OPTIONS_GHC -Wunused-binds #-}",
@@ -2889,7 +2900,7 @@ otherCompletionTests = [
       -- This should be sufficient to detect that we are in a
       -- type context and only show the completion to the type.
       (Position 3 11)
-      [("Integer", CiStruct, True, True)]
+      [("Integer", CiStruct, "Integer ", True, True)]
   ]
 
 highlightTests :: TestTree