hls-class-plugin: Only create placeholders for unimplemented methods (#2956)

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

* hls-class-plugin: Add logs

Author: akshaymankar

exe/Plugins.hs

@@ -160,7 +160,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
       CallHierarchy.descriptor :
 #endif
 #if class
-      Class.descriptor "class" :
+      Class.descriptor pluginRecorder "class" :
 #endif
 #if haddockComments
       HaddockComments.descriptor "haddockComments" :

plugins/hls-class-plugin/hls-class-plugin.cabal

@@ -56,6 +56,7 @@ test-suite tests
   build-depends:
     , base
     , filepath
+    , ghcide
     , hls-class-plugin
     , hls-test-utils     ^>=1.3
     , lens

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

@@ -1,12 +1,14 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DeriveAnyClass    #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeFamilies      #-}
 {-# LANGUAGE ViewPatterns      #-}
 module Ide.Plugin.Class
-  ( descriptor
+  ( descriptor,
+    Log (..)
   ) where
 
 import           Control.Applicative
@@ -17,15 +19,17 @@ 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)
-import           Development.IDE.GHC.Compat              as Compat hiding (locA)
+import           Development.IDE.GHC.Compat              as Compat hiding (locA,
+                                                                    (<+>))
 import           Development.IDE.GHC.Compat.Util
 import           Development.IDE.Spans.AtPoint
 import qualified GHC.Generics                            as Generics
@@ -40,14 +44,24 @@ 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
 
-descriptor :: PluginId -> PluginDescriptor IdeState
-descriptor plId = (defaultPluginDescriptor plId)
+data Log
+  = LogImplementedMethods Class [T.Text]
+
+instance Pretty Log where
+  pretty = \case
+    LogImplementedMethods cls methods ->
+      pretty ("Detected implmented methods for class" :: String)
+        <+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name
+        <+> pretty methods
+
+descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
+descriptor recorder plId = (defaultPluginDescriptor plId)
   { pluginCommands = commands
-  , pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction
+  , pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeAction recorder)
   }
 
 commands :: [PluginCommand IdeState]
@@ -176,8 +190,8 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do
 -- |
 -- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
 -- sensitive to the format of diagnostic messages from GHC.
-codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction
-codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do
+codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction
+codeAction recorder state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do
   docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri
   actions <- join <$> mapM (mkActions docPath) methodDiags
   pure . Right . List $ actions
@@ -190,9 +204,17 @@ 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
+      logWith recorder Info (LogImplementedMethods cls implemented)
+      lift . traverse (mkAction . (\\ implemented)) . minDefToMethodGroups . classMinimalDef $ cls
       where
         range = diag ^. J.range
 
@@ -212,16 +234,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 +254,38 @@ 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
+
+    -- | Recurses through the given AST to find identifiers which are
+    -- 'InstanceValBind's.
+    findInstanceValBindIdentifiers :: HieAST a -> [Identifier]
+    findInstanceValBindIdentifiers ast =
+        let valBindIds = Map.keys
+                         . Map.filter (any isInstanceValBind . identInfo)
+                         $ getNodeIds ast
+        in valBindIds <> concatMap findInstanceValBindIdentifiers (nodeChildren 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

@@ -8,24 +8,29 @@ module Main
   ( main
   ) where
 
-import           Control.Lens            (Prism', prism', (^..), (^?))
-import           Control.Monad           (void)
-import qualified Ide.Plugin.Class        as Class
-import qualified Language.LSP.Types.Lens as J
+import           Control.Lens                 (Prism', prism', (^..), (^?))
+import           Control.Monad                (void)
+import           Data.Functor.Contravariant   (contramap)
+import           Development.IDE.Types.Logger
+import qualified Ide.Plugin.Class             as Class
+import qualified Language.LSP.Types.Lens      as J
 import           System.FilePath
 import           Test.Hls
 
+
 main :: IO ()
-main = defaultTestRunner tests
+main = do
+    recorder <- makeDefaultStderrRecorder Nothing Debug
+    defaultTestRunner . tests $ contramap (fmap pretty) recorder
 
-classPlugin :: PluginDescriptor IdeState
-classPlugin = Class.descriptor "class"
+classPlugin :: Recorder (WithPriority Class.Log) -> PluginDescriptor IdeState
+classPlugin recorder = Class.descriptor recorder "class"
 
-tests :: TestTree
-tests = testGroup
+tests :: Recorder (WithPriority Class.Log) -> TestTree
+tests recorder = testGroup
   "class"
   [ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do
-      runSessionWithServer classPlugin testDataDir $ do
+      runSessionWithServer (classPlugin recorder) testDataDir $ do
         doc <- openDoc "T1.hs" "haskell"
         _ <- waitForDiagnosticsFromSource doc "typecheck"
         caResults <- getAllCodeActions doc
@@ -34,30 +39,34 @@ tests = testGroup
           [ Just "Add placeholders for '=='"
           , Just "Add placeholders for '/='"
           ]
-  , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do
+  , goldenWithClass recorder "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do
       executeCodeAction eqAction
-  , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:neAction:_) -> do
+  , goldenWithClass recorder "Creates a placeholder for '/='" "T1" "ne" $ \(_:neAction:_) -> do
       executeCodeAction neAction
-  , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:fmapAction:_) -> do
+  , goldenWithClass recorder "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:fmapAction:_) -> do
       executeCodeAction fmapAction
-  , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do
+  , goldenWithClass recorder "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do
       executeCodeAction mmAction
-  , goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:mmAction:_) -> do
+  , goldenWithClass recorder "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:mmAction:_) -> do
       executeCodeAction mmAction
-  , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do
+  , goldenWithClass recorder "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do
       executeCodeAction _fAction
-  , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do
+  , goldenWithClass recorder "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do
       executeCodeAction eqAction
+  , goldenWithClass recorder "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do
+      executeCodeAction gAction
+  , goldenWithClass recorder "Creates a placeholder for other two methods" "T6" "2" $ \(_:ghAction:_) -> do
+      executeCodeAction ghAction
   ]
 
 _CACodeAction :: Prism' (Command |? CodeAction) CodeAction
 _CACodeAction = prism' InR $ \case
   InR action -> Just action
   _          -> Nothing
 
-goldenWithClass :: TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree
-goldenWithClass title path desc act =
-  goldenWithHaskellDoc classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do
+goldenWithClass :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree
+goldenWithClass recorder title path desc act =
+  goldenWithHaskellDoc (classPlugin recorder) title testDataDir path (desc <.> "expected") "hs" $ \doc -> do
     _ <- waitForDiagnosticsFromSource doc "typecheck"
     actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc
     act actions

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

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

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

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

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

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