hls-class-plugin: Only create placeholders 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,6 +18,7 @@ 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
@@ -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
 
@@ -192,7 +194,8 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
     mkActions docPath diag = do
       ident <- findClassIdentifier docPath range
       cls <- findClassFromIdentifier docPath ident
-      lift . traverse mkAction . minDefToMethodGroups . classMinimalDef $ cls
+      implemented <- findImplementedMethods docPath range
+      lift . traverse (mkAction . (\\ implemented)) . minDefToMethodGroups . classMinimalDef $ cls
       where
         range = diag ^. J.range
 
@@ -212,6 +215,7 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
           = InR
           $ CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing Nothing Nothing (Just cmd) Nothing
 
+    findClassIdentifier :: NormalizedFilePath -> Range -> MaybeT IO (Either ModuleName Name)
     findClassIdentifier docPath range = do
       (hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath
       case hieAstResult of
@@ -234,18 +238,38 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
           _ -> panic "Ide.Plugin.Class.findClassFromIdentifier"
     findClassFromIdentifier _ (Left _) = panic "Ide.Plugin.Class.findClassIdentifier"
 
+    findImplementedMethods :: NormalizedFilePath -> Range -> MaybeT IO [T.Text]
+    findImplementedMethods docPath range = do
+        (HAR {hieAst = hf}, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath
+        pure
+            $ concat
+            $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1)
+            $ 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 (not . Set.null)
+                  . Map.map (Set.filter 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