hls-class-plugin: Only create placeholders for unimplemented methods

Author: akshaymankar

plugins/hls-class-plugin/src/Ide/Plugin/Class.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeFamilies      #-}
@@ -17,11 +18,12 @@ import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Maybe
 import           Data.Aeson
 import           Data.Char
+import           Data.Either                             (rights)
 import           Data.List
 import qualified Data.Map.Strict                         as Map
 import           Data.Maybe
-import qualified Data.Text                               as T
 import qualified Data.Set                                as Set
+import qualified Data.Text                               as T
 import           Development.IDE                         hiding (pluginHandlers)
 import           Development.IDE.Core.PositionMapping    (fromCurrentRange,
                                                           toCurrentRange)
@@ -40,7 +42,7 @@ import           Language.LSP.Types
 import qualified Language.LSP.Types.Lens                 as J
 
 #if MIN_VERSION_ghc(9,2,0)
-import           GHC.Hs                                  (AnnsModule(AnnsModule))
+import           GHC.Hs                                  (AnnsModule (AnnsModule))
 import           GHC.Parser.Annotation
 #endif
 
@@ -190,9 +192,16 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
     methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags
 
     mkActions docPath diag = do
-      ident <- findClassIdentifier docPath range
+      (HAR {hieAst = ast}, pmap) <-
+          MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath
+      instancePosition <- MaybeT . pure $
+                          fromCurrentRange pmap range ^? _Just . J.start
+                          & fmap (J.character -~ 1)
+
+      ident <- findClassIdentifier ast instancePosition
       cls <- findClassFromIdentifier docPath ident
-      lift . traverse mkAction . minDefToMethodGroups . classMinimalDef $ cls
+      implemented <- findImplementedMethods ast instancePosition
+      lift . traverse (mkAction . (\\ implemented)) . minDefToMethodGroups . classMinimalDef $ cls
       where
         range = diag ^. J.range
 
@@ -212,16 +221,14 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
           = InR
           $ CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing Nothing Nothing (Just cmd) Nothing
 
-    findClassIdentifier docPath range = do
-      (hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath
-      case hieAstResult of
-        HAR {hieAst = hf} ->
-          pure
-            $ head . head
-            $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1)
-              ( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds)
-                <=< nodeChildren
-              )
+    findClassIdentifier :: HieASTs a -> Position -> MaybeT IO (Either ModuleName Name)
+    findClassIdentifier ast instancePosition =
+      pure
+        $ head . head
+        $ pointCommand ast instancePosition
+          ( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds)
+            <=< nodeChildren
+          )
 
     findClassFromIdentifier docPath (Right name) = do
       (hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath
@@ -234,18 +241,36 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
           _ -> panic "Ide.Plugin.Class.findClassFromIdentifier"
     findClassFromIdentifier _ (Left _) = panic "Ide.Plugin.Class.findClassIdentifier"
 
+    findImplementedMethods :: HieASTs a -> Position -> MaybeT IO [T.Text]
+    findImplementedMethods asts instancePosition = do
+        pure
+            $ concat
+            $ pointCommand asts instancePosition
+            $ map (T.pack . getOccString) . rights . findInstanceValBindIdentifiers
+
+    findInstanceValBindIdentifiers :: HieAST a -> [Identifier]
+    findInstanceValBindIdentifiers ast
+      | Map.null (getNodeIds ast) = concatMap findInstanceValBindIdentifiers (nodeChildren ast)
+      | otherwise = Map.keys
+                  . Map.filter (any isInstanceValBind . identInfo)
+                  $ getNodeIds ast
+
 ghostSpan :: RealSrcSpan
 ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<haskell-language-sever>") 1 1
 
 containRange :: Range -> SrcSpan -> Bool
 containRange range x = isInsideSrcSpan (range ^. J.start) x || isInsideSrcSpan (range ^. J.end) x
 
 isClassNodeIdentifier :: IdentifierDetails a -> Bool
-isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` (identInfo ident)
+isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` identInfo ident
 
 isClassMethodWarning :: T.Text -> Bool
 isClassMethodWarning = T.isPrefixOf "• No explicit implementation for"
 
+isInstanceValBind :: ContextInfo -> Bool
+isInstanceValBind (ValBind InstanceBind _ _) = True
+isInstanceValBind _                          = False
+
 minDefToMethodGroups :: BooleanFormula Name -> [[T.Text]]
 minDefToMethodGroups = go
   where

plugins/hls-class-plugin/test/Main.hs

@@ -48,6 +48,10 @@ tests = testGroup
       executeCodeAction _fAction
   , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do
       executeCodeAction eqAction
+  , goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do
+      executeCodeAction gAction
+  , goldenWithClass "Creates a placeholder for other two multiple methods" "T6" "2" $ \(_:ghAction:_) -> do
+      executeCodeAction ghAction
   ]
 
 _CACodeAction :: Prism' (Command |? CodeAction) CodeAction

plugins/hls-class-plugin/test/testdata/T6.1.expected.hs

@@ -0,0 +1,19 @@
+module T6 where
+
+data X = X | Y
+
+class Test a where
+  f :: a -> a
+  f = h
+
+  g :: a
+
+  h :: a -> a
+  h = f
+
+  {-# MINIMAL f, g | g, h #-}
+
+instance Test X where
+  f X = X
+  f Y = Y
+  g = _

plugins/hls-class-plugin/test/testdata/T6.2.expected.hs

@@ -0,0 +1,20 @@
+module T6 where
+
+data X = X | Y
+
+class Test a where
+  f :: a -> a
+  f = h
+
+  g :: a
+
+  h :: a -> a
+  h = f
+
+  {-# MINIMAL f, g | g, h #-}
+
+instance Test X where
+  f X = X
+  f Y = Y
+  g = _
+  h = _

plugins/hls-class-plugin/test/testdata/T6.hs

@@ -0,0 +1,18 @@
+module T6 where
+
+data X = X | Y
+
+class Test a where
+  f :: a -> a
+  f = h
+
+  g :: a
+
+  h :: a -> a
+  h = f
+
+  {-# MINIMAL f, g | g, h #-}
+
+instance Test X where
+  f X = X
+  f Y = Y