Feat: basic record dot completions (#3080)

coltenwebb · web-flow · commit cdbef3e5cb79 · 2022-09-26T16:30:29.000+01:00
* baseline for record completions

* address feedback

* gate ghc version

* add test

* refactor

* fix rope import

* fix plugins from rebase

* gate test by ghc version

* comments, fixes

* fix ghc90 test
diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs
@@ -48,6 +48,9 @@ import qualified Language.LSP.VFS                         as VFS
 import           Numeric.Natural
 import           Text.Fuzzy.Parallel                      (Scored (..))
 
+import qualified GHC.LanguageExtensions                   as LangExt
+import           Language.LSP.Types
+
 data Log = LogShake Shake.Log deriving Show
 
 instance Pretty Log where
@@ -120,7 +123,7 @@ getCompletionsLSP ide plId
     fmap Right $ case (contents, uriToFilePath' uri) of
       (Just cnts, Just path) -> do
         let npath = toNormalizedFilePath' path
-        (ideOpts, compls, moduleExports) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do
+        (ideOpts, compls, moduleExports, astres) <- liftIO $ runIdeAction "Completion" (shakeExtras ide) $ do
             opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
             localCompls <- useWithStaleFast LocalCompletions npath
             nonLocalCompls <- useWithStaleFast NonLocalCompletions npath
@@ -140,18 +143,31 @@ getCompletionsLSP ide plId
                 exportsCompls = mempty{anyQualCompls = exportsCompItems}
             let compls = (fst <$> localCompls) <> (fst <$> nonLocalCompls) <> Just exportsCompls <> Just lModules
 
-            pure (opts, fmap (,pm,binds) compls, moduleExports)
+            -- get HieAst if OverloadedRecordDot is enabled
+#if MIN_VERSION_ghc(9,2,0)
+            let uses_overloaded_record_dot (ms_hspp_opts . msrModSummary -> dflags) = xopt LangExt.OverloadedRecordDot dflags
+#else
+            let uses_overloaded_record_dot _ = False
+#endif
+            ms <- fmap fst <$> useWithStaleFast GetModSummaryWithoutTimestamps npath
+            astres <- case ms of
+              Just ms' | uses_overloaded_record_dot ms'
+                ->  useWithStaleFast GetHieAst npath
+              _ -> return Nothing
+
+            pure (opts, fmap (,pm,binds) compls, moduleExports, astres)
         case compls of
           Just (cci', parsedMod, bindMap) -> do
-            pfix <- VFS.getCompletionPrefix position cnts
+            let pfix = getCompletionPrefix position cnts
             case (pfix, completionContext) of
-              (Just (VFS.PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
+              ((PosPrefixInfo _ "" _ _), Just CompletionContext { _triggerCharacter = Just "."})
                 -> return (InL $ List [])
-              (Just pfix', _) -> do
+              (_, _) -> do
                 let clientCaps = clientCapabilities $ shakeExtras ide
                     plugins = idePlugins $ shakeExtras ide
                 config <- getCompletionsConfig plId
-                allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod bindMap pfix' clientCaps config moduleExports
+
+                allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports
                 pure $ InL (List $ orderedCompletions allCompletions)
               _ -> return (InL $ List [])
           _ -> return (InL $ List [])
diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
@@ -10,16 +10,18 @@ module Development.IDE.Plugin.Completions.Logic (
 , localCompletionsForParsedModule
 , getCompletions
 , fromIdentInfo
+, getCompletionPrefix
 ) where
 
 import           Control.Applicative
-import           Data.Char                                (isUpper)
+import           Data.Char                                (isAlphaNum, isUpper)
 import           Data.Generics
 import           Data.List.Extra                          as List hiding
                                                                   (stripPrefix)
 import qualified Data.Map                                 as Map
 
-import           Data.Maybe                               (fromMaybe, isJust,
+import           Data.Maybe                               (catMaybes, fromMaybe,
+                                                           isJust, listToMaybe,
                                                            mapMaybe)
 import qualified Data.Text                                as T
 import qualified Text.Fuzzy.Parallel                      as Fuzzy
@@ -30,6 +32,7 @@ import           Data.Either                              (fromRight)
 import           Data.Function                            (on)
 import           Data.Functor
 import qualified Data.HashMap.Strict                      as HM
+
 import qualified Data.HashSet                             as HashSet
 import           Data.Monoid                              (First (..))
 import           Data.Ord                                 (Down (Down))
@@ -67,6 +70,11 @@ import qualified Language.LSP.VFS                         as VFS
 import           Text.Fuzzy.Parallel                      (Scored (score),
                                                            original)
 
+import qualified Data.Text.Utf16.Rope                     as Rope
+import           Development.IDE
+
+import           Development.IDE.Spans.AtPoint            (pointCommand)
+
 -- Chunk size used for parallelizing fuzzy matching
 chunkSize :: Int
 chunkSize = 1000
@@ -564,28 +572,29 @@ getCompletions
     -> IdeOptions
     -> CachedCompletions
     -> Maybe (ParsedModule, PositionMapping)
+    -> Maybe (HieAstResult, PositionMapping)
     -> (Bindings, PositionMapping)
-    -> VFS.PosPrefixInfo
+    -> PosPrefixInfo
     -> ClientCapabilities
     -> CompletionsConfig
     -> HM.HashMap T.Text (HashSet.HashSet IdentInfo)
     -> IO [Scored CompletionItem]
 getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls, qualCompls, importableModules}
-               maybe_parsed (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
-  let VFS.PosPrefixInfo { fullLine, prefixModule, prefixText } = prefixInfo
-      enteredQual = if T.null prefixModule then "" else prefixModule <> "."
+               maybe_parsed maybe_ast_res (localBindings, bmapping) prefixInfo caps config moduleExportsMap = do
+  let PosPrefixInfo { fullLine, prefixScope, prefixText } = prefixInfo
+      enteredQual = if T.null prefixScope then "" else prefixScope <> "."
       fullPrefix  = enteredQual <> prefixText
 
       -- Boolean labels to tag suggestions as qualified (or not)
-      qual = not(T.null prefixModule)
+      qual = not(T.null prefixScope)
       notQual = False
 
       {- correct the position by moving 'foo :: Int -> String ->    '
                                                                     ^
           to                             'foo :: Int -> String ->    '
                                                               ^
       -}
-      pos = VFS.cursorPos prefixInfo
+      pos = cursorPos prefixInfo
 
       maxC = maxCompletions config
 
@@ -608,6 +617,42 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
                   hpos = upperRange position'
               in getCContext lpos pm <|> getCContext hpos pm
 
+
+          -- We need the hieast to be "fresh". We can't get types from "stale" hie files, so hasfield won't work,
+          -- since it gets the record fields from the types.
+          -- Perhaps this could be fixed with a refactor to GHC's IfaceTyCon, to have it also contain record fields.
+          -- Requiring fresh hieast is fine for normal workflows, because it is generated while the user edits.
+          recordDotSyntaxCompls :: [(Bool, CompItem)]
+          recordDotSyntaxCompls = case maybe_ast_res of
+            Just (HAR {hieAst = hieast, hieKind = HieFresh},_) -> concat $ pointCommand hieast (completionPrefixPos prefixInfo) nodeCompletions
+            _ -> []
+            where
+              nodeCompletions :: HieAST Type -> [(Bool, CompItem)]
+              nodeCompletions node = concatMap g (nodeType $ nodeInfo node)
+              g :: Type -> [(Bool, CompItem)]
+              g (TyConApp theTyCon _) = map (dotFieldSelectorToCompl (printOutputable $ GHC.tyConName theTyCon)) $ getSels theTyCon
+              g _ = []
+              getSels :: GHC.TyCon -> [T.Text]
+              getSels tycon = let f fieldLabel = printOutputable fieldLabel
+                              in map f $ tyConFieldLabels tycon
+              -- Completions can return more information that just the completion itself, but it will
+              -- require more than what GHC currently gives us in the HieAST, since it only gives the Type
+              -- of the fields, not where they are defined, etc. So for now the extra fields remain empty.
+              -- Also: additionalTextEdits is a todo, since we may want to import the record. It requires a way
+              -- to get the record's module, which isn't included in the type information used to get the fields.
+              dotFieldSelectorToCompl :: T.Text -> T.Text -> (Bool, CompItem)
+              dotFieldSelectorToCompl recname label = (True, CI
+                { compKind = CiField
+                , insertText = label
+                , provenance = DefinedIn recname
+                , typeText = Nothing
+                , label = label
+                , isInfix = Nothing
+                , docs = emptySpanDoc
+                , isTypeCompl = False
+                , additionalTextEdits = Nothing
+                })
+
           -- completions specific to the current context
           ctxCompls' = case mcc of
                         Nothing           -> compls
@@ -618,10 +663,10 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
           ctxCompls = (fmap.fmap) (\comp -> toggleAutoExtend config $ comp { isInfix = infixCompls }) ctxCompls'
 
           infixCompls :: Maybe Backtick
-          infixCompls = isUsedAsInfix fullLine prefixModule prefixText pos
+          infixCompls = isUsedAsInfix fullLine prefixScope prefixText pos
 
           PositionMapping bDelta = bmapping
-          oldPos = fromDelta bDelta $ VFS.cursorPos prefixInfo
+          oldPos = fromDelta bDelta $ cursorPos prefixInfo
           startLoc = lowerRange oldPos
           endLoc = upperRange oldPos
           localCompls = map (uncurry localBindsToCompItem) $ getFuzzyScope localBindings startLoc endLoc
@@ -634,10 +679,14 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
               ty = showForSnippet <$> typ
               thisModName = Local $ nameSrcSpan name
 
-          compls = if T.null prefixModule
-            then map (notQual,) localCompls ++ map (qual,) unqualCompls ++ ((notQual,) . ($Nothing) <$> anyQualCompls)
-            else ((qual,) <$> Map.findWithDefault [] prefixModule (getQualCompls qualCompls))
-                 ++ ((notQual,) . ($ Just prefixModule) <$> anyQualCompls)
+          -- When record-dot-syntax completions are available, we return them exclusively.
+          -- They are only available when we write i.e. `myrecord.` with OverloadedRecordDot enabled.
+          -- Anything that isn't a field is invalid, so those completion don't make sense.
+          compls
+            | T.null prefixScope = map (notQual,) localCompls ++ map (qual,) unqualCompls ++ map (\compl -> (notQual, compl Nothing)) anyQualCompls
+            | not $ null recordDotSyntaxCompls = recordDotSyntaxCompls
+            | otherwise = ((qual,) <$> Map.findWithDefault [] prefixScope (getQualCompls qualCompls))
+                 ++ map (\compl -> (notQual, compl (Just prefixScope))) anyQualCompls
 
       filtListWith f list =
         [ fmap f label
@@ -648,7 +697,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
       filtImportCompls = filtListWith (mkImportCompl enteredQual) importableModules
       filterModuleExports moduleName = filtListWith $ mkModuleFunctionImport moduleName
       filtKeywordCompls
-          | T.null prefixModule = filtListWith mkExtCompl (optKeywords ideOpts)
+          | T.null prefixScope = filtListWith mkExtCompl (optKeywords ideOpts)
           | otherwise = []
 
   if
@@ -696,6 +745,7 @@ getCompletions plugins ideOpts CC {allModNamesAsNS, anyQualCompls, unqualCompls,
 
 
 
+
 uniqueCompl :: CompItem -> CompItem -> Ordering
 uniqueCompl candidate unique =
   case compare (label candidate, compKind candidate)
@@ -892,3 +942,32 @@ mergeListsBy cmp all_lists = merge_lists all_lists
         []     -> []
         [xs]   -> xs
         lists' -> merge_lists lists'
+
+-- |From the given cursor position, gets the prefix module or record for autocompletion
+getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo
+getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =
+      fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad
+        let headMaybe = listToMaybe
+            lastMaybe = headMaybe . reverse
+
+        -- grab the entire line the cursor is at
+        curLine <- headMaybe $ T.lines $ Rope.toText
+                             $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext
+        let beforePos = T.take (fromIntegral c) curLine
+        -- the word getting typed, after previous space and before cursor
+        curWord <-
+            if | T.null beforePos        -> Just ""
+               | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc '
+               | otherwise               -> lastMaybe (T.words beforePos)
+
+        let parts = T.split (=='.')
+                      $ T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'"::String)) curWord
+        case reverse parts of
+          [] -> Nothing
+          (x:xs) -> do
+            let modParts = reverse $ filter (not .T.null) xs
+                modName = T.intercalate "." modParts
+            return $ PosPrefixInfo { fullLine = curLine, prefixScope = modName, prefixText = x, cursorPos = pos }
+
+completionPrefixPos :: PosPrefixInfo -> Position
+completionPrefixPos PosPrefixInfo { cursorPos = Position ln co, prefixText = str} = Position ln (co - (fromInteger . toInteger . T.length $ str) - 1)
diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Types.hs b/ghcide/src/Development/IDE/Plugin/Completions/Types.hs
@@ -26,6 +26,7 @@ import           Ide.PluginUtils              (getClientConfig, usePropertyLsp)
 import           Ide.Types                    (PluginId)
 import           Language.LSP.Server          (MonadLsp)
 import           Language.LSP.Types           (CompletionItemKind (..), Uri)
+import qualified Language.LSP.Types           as J
 
 -- | Produce completions info for a file
 type instance RuleResult LocalCompletions = CachedCompletions
@@ -136,3 +137,24 @@ instance Monoid CachedCompletions where
 instance Semigroup CachedCompletions where
     CC a b c d e <> CC a' b' c' d' e' =
         CC (a<>a') (b<>b') (c<>c') (d<>d') (e<>e')
+
+
+-- | Describes the line at the current cursor position
+data PosPrefixInfo = PosPrefixInfo
+  { fullLine    :: !T.Text
+    -- ^ The full contents of the line the cursor is at
+
+  , prefixScope :: !T.Text
+    -- ^ If any, the module name that was typed right before the cursor position.
+    --  For example, if the user has typed "Data.Maybe.from", then this property
+    --  will be "Data.Maybe"
+    -- If OverloadedRecordDot is enabled, "Shape.rect.width" will be
+    -- "Shape.rect"
+
+  , prefixText  :: !T.Text
+    -- ^ The word right before the cursor position, after removing the module part.
+    -- For example if the user has typed "Data.Maybe.from",
+    -- then this property will be "from"
+  , cursorPos   :: !J.Position
+    -- ^ The cursor position
+  } deriving (Show,Eq)
diff --git a/test/functional/Completion.hs b/test/functional/Completion.hs
@@ -84,6 +84,32 @@ tests = testGroup "completions" [
          compls <- getCompletions doc (Position 5 7)
          liftIO $ assertBool "Expected completions" $ not $ null compls
 
+     , expectFailIfBeforeGhc92 "record dot syntax is introduced in GHC 9.2"
+       $ testGroup "recorddotsyntax"
+        [ testCase "shows field selectors" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
+            doc <- openDoc "RecordDotSyntax.hs" "haskell"
+
+            let te = TextEdit (Range (Position 25 0) (Position 25 5)) "z = x.a"
+            _ <- applyEdit doc te
+
+            compls <- getCompletions doc (Position 25 6)
+            item <- getCompletionByLabel "a" compls
+
+            liftIO $ do
+                item ^. label @?= "a"
+        , testCase "shows field selectors for nested field" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
+            doc <- openDoc "RecordDotSyntax.hs" "haskell"
+
+            let te = TextEdit (Range (Position 27 0) (Position 27 8)) "z2 = x.c.z"
+            _ <- applyEdit doc te
+
+            compls <- getCompletions doc (Position 27 9)
+            item <- getCompletionByLabel "z" compls
+
+            liftIO $ do
+                item ^. label @?= "z"
+        ]
+
      -- See https://github.com/haskell/haskell-ide-engine/issues/903
      , testCase "strips compiler generated stuff from completions" $ runSession hlsCommand fullCaps "test/testdata/completion" $ do
          doc <- openDoc "DupRecFields.hs" "haskell"
@@ -348,3 +374,6 @@ shouldNotContainCompl :: [CompletionItem] -> T.Text -> Assertion
 compls `shouldNotContainCompl` lbl =
     all ((/= lbl) . (^. label)) compls
     @? "Should not contain completion: " ++ show lbl
+
+expectFailIfBeforeGhc92 :: String -> TestTree -> TestTree
+expectFailIfBeforeGhc92 = knownBrokenForGhcVersions [GHC810, GHC88, GHC86, GHC90]
diff --git a/test/testdata/completion/RecordDotSyntax.hs b/test/testdata/completion/RecordDotSyntax.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NoFieldSelectors #-}
+
+module Test where
+
+import qualified Data.Maybe as M
+
+data MyRecord = MyRecord1
+  { a :: String
+  , b :: Integer
+  , c :: MyChild
+  }
+  | MyRecord2 { a2 :: String
+  , b2 :: Integer
+  , c2 :: MyChild
+  } deriving (Eq, Show)
+
+newtype MyChild = MyChild
+  { z :: String
+  } deriving (Eq, Show)
+
+x = MyRecord1 { a = "Hello", b = 12, c = MyChild { z = "there" } }
+
+y = x.a ++ show x.b 
+
+y2 = x.c.z 
+
