hls-class-plugin - Add placeholders for all class methods

plugins/hls-class-plugin/README.md

@@ -3,7 +3,8 @@
 The class plugin provides handy operations about class, includes:
 
 1. Code action to add minimal class definition methods.
-2. Type lens about missing type signatures for instance methods.
+2. Code action to all missing class methods.
+3. Type lens about missing type signatures for instance methods.
 
 ## Demo
 

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

@@ -77,3 +77,4 @@ test-suite tests
     , hls-test-utils     ^>=1.5
     , lens
     , lsp-types
+    , text

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

@@ -13,8 +13,10 @@ import           Control.Monad.Trans.Class            (lift)
 import           Control.Monad.Trans.Except           (ExceptT, throwE)
 import           Control.Monad.Trans.Maybe
 import           Data.Aeson
+import           Data.Bifunctor                       (second)
 import           Data.Either.Extra                    (rights)
 import           Data.List
+import           Data.List.Extra                      (nubOrdOn)
 import qualified Data.Map.Strict                      as Map
 import           Data.Maybe                           (isNothing, listToMaybe,
                                                        mapMaybe)
@@ -113,30 +115,31 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = pluginRe
             logWith recorder Info (LogImplementedMethods cls implemented)
             pure
                 $ concatMap mkAction
-                $ fmap (filter (\(bind, _) -> bind `notElem` implemented))
-                $ minDefToMethodGroups range sigs
-                $ classMinimalDef cls
+                $ nubOrdOn snd
+                $ filter ((/=) mempty . snd)
+                $ fmap (second (filter (\(bind, _) -> bind `notElem` implemented)))
+                $ mkMethodGroups range sigs cls
             where
                 range = diag ^. J.range
 
-                mkAction :: [(T.Text, T.Text)] -> [Command |? CodeAction]
-                mkAction methodGroup
+                mkMethodGroups :: Range -> [InstanceBindTypeSig] -> Class -> [MethodGroup]
+                mkMethodGroups range sigs cls = minimalDef <> [allClassMethods]
+                    where
+                        minimalDef = minDefToMethodGroups range sigs $ classMinimalDef cls
+                        allClassMethods = ("all missing methods", makeMethodDefinitions range sigs)
+
+                mkAction :: MethodGroup -> [Command |? CodeAction]
+                mkAction (name, methods)
                     = [ mkCodeAction title
                             $ mkLspCommand plId codeActionCommandId title
-                                (Just $ mkCmdParams methodGroup False)
+                                (Just $ mkCmdParams methods False)
                       , mkCodeAction titleWithSig
                             $ mkLspCommand plId codeActionCommandId titleWithSig
-                                (Just $ mkCmdParams methodGroup True)
+                                (Just $ mkCmdParams methods True)
                       ]
                     where
-                        title = mkTitle $ fst <$> methodGroup
-                        titleWithSig = mkTitleWithSig $ fst <$> methodGroup
-
-                mkTitle methodGroup
-                    = "Add placeholders for "
-                        <> mconcat (intersperse ", " (fmap (\m -> "'" <> m <> "'") methodGroup))
-
-                mkTitleWithSig methodGroup = mkTitle methodGroup <> " with signature(s)"
+                        title = "Add placeholders for " <> name
+                        titleWithSig = title <> " with signature(s)"
 
                 mkCmdParams methodGroup withSig =
                     [toJSON (AddMinimalMethodsParams uri range (List methodGroup) withSig)]
@@ -211,15 +214,37 @@ isInstanceValBind :: ContextInfo -> Bool
 isInstanceValBind (ValBind InstanceBind _ _) = True
 isInstanceValBind _                          = False
 
--- Return (name text, signature text)
-minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [[(T.Text, T.Text)]]
-minDefToMethodGroups range sigs = go
+type MethodSignature = T.Text
+type MethodName = T.Text
+type MethodDefinition = (MethodName, MethodSignature)
+type MethodGroup = (T.Text, [MethodDefinition])
+
+makeMethodDefinition :: InstanceBindTypeSig -> MethodDefinition
+makeMethodDefinition sig = (name, signature)
+    where
+        name = T.drop (T.length bindingPrefix) (printOutputable  (bindName sig))
+        signature = bindRendered sig
+
+makeMethodDefinitions :: Range -> [InstanceBindTypeSig] -> [MethodDefinition]
+makeMethodDefinitions range sigs =
+    [ makeMethodDefinition sig
+    | sig <- sigs
+    , inRange range (getSrcSpan $ bindName sig)
+    ]
+
+signatureToName :: InstanceBindTypeSig -> T.Text
+signatureToName sig = T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
+
+-- Return [groupName text, [(methodName text, signature text)]]
+minDefToMethodGroups :: Range -> [InstanceBindTypeSig] -> BooleanFormula Name -> [MethodGroup]
+minDefToMethodGroups range sigs minDef = makeMethodGroup <$> go minDef
     where
-        go (Var mn)   = [[ (T.pack . occNameString . occName $ mn, bindRendered sig)
-                        | sig <- sigs
-                        , inRange range (getSrcSpan $ bindName sig)
-                        , printOutputable mn == T.drop (T.length bindingPrefix) (printOutputable (bindName sig))
-                        ]]
+        makeMethodGroup methodDefinitions =
+            let name = mconcat $ intersperse "," $ (\x -> "'" <> x <> "'") . fst <$> methodDefinitions
+            in  (name, methodDefinitions)
+
+        go (Var mn)   = pure $ makeMethodDefinitions range $ filter ((==) (printOutputable mn) . signatureToName) sigs
         go (Or ms)    = concatMap (go . unLoc) ms
         go (And ms)   = foldr (liftA2 (<>)) [[]] (fmap (go . unLoc) ms)
         go (Parens m) = go (unLoc m)
+

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

@@ -12,6 +12,7 @@ module Main
 import           Control.Lens            (Prism', prism', (^.), (^..), (^?))
 import           Control.Monad           (void)
 import           Data.Maybe
+import qualified Data.Text               as T
 import qualified Ide.Plugin.Class        as Class
 import qualified Language.LSP.Types.Lens as J
 import           System.FilePath
@@ -31,23 +32,21 @@ tests = testGroup
 codeActionTests :: TestTree
 codeActionTests = testGroup
   "code actions"
-  [ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do
-      runSessionWithServer classPlugin testDataDir $ do
-        doc <- openDoc "T1.hs" "haskell"
-        _ <- waitForDiagnosticsFromSource doc "typecheck"
-        caResults <- getAllCodeActions doc
-        liftIO $ map (^? _CACodeAction . J.title) caResults
-          @?=
-          [ Just "Add placeholders for '=='"
-          , Just "Add placeholders for '==' with signature(s)"
-          , Just "Add placeholders for '/='"
-          , Just "Add placeholders for '/=' with signature(s)"
-          ]
+  [ expectCodeActionsAvailable "Produces addMinimalMethodPlaceholders code actions for one instance" "T1"
+      [ "Add placeholders for '=='"
+      , "Add placeholders for '==' with signature(s)"
+      , "Add placeholders for '/='"
+      , "Add placeholders for '/=' with signature(s)"
+      , "Add placeholders for all missing methods"
+      , "Add placeholders for all missing methods with signature(s)"
+      ]
   , goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do
       executeCodeAction eqAction
   , goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:_:neAction:_) -> do
       executeCodeAction neAction
-  , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:fmapAction:_) -> do
+  , goldenWithClass "Creates a placeholder for both '==' and '/='" "T1" "all" $ \(_:_:_:_:allMethodsAction:_) -> do
+      executeCodeAction allMethodsAction
+  , goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:_:_:_:_:fmapAction:_) -> do
       executeCodeAction fmapAction
   , goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do
       executeCodeAction mmAction
@@ -70,6 +69,11 @@ codeActionTests = testGroup
       executeCodeAction eqWithSig
   , goldenWithClass "Only insert pragma once" "InsertPragmaOnce" "" $ \(_:multi:_) -> do
       executeCodeAction multi
+  , expectCodeActionsAvailable "No code action available when minimal requirements meet" "MinimalDefinitionMeet" []
+  , expectCodeActionsAvailable "Add placeholders for all missing methods is unavailable when all methods are required" "AllMethodsRequired"
+      [ "Add placeholders for 'f','g'"
+      , "Add placeholders for 'f','g' with signature(s)"
+      ]
   ]
 
 codeLensTests :: TestTree
@@ -99,7 +103,6 @@ _CACodeAction = prism' InR $ \case
   InR action -> Just action
   _          -> Nothing
 
-
 goldenCodeLens :: TestName -> FilePath -> Int -> TestTree
 goldenCodeLens title path idx =
     goldenWithHaskellDoc classPlugin title testDataDir path "expected" "hs" $ \doc -> do
@@ -115,5 +118,17 @@ goldenWithClass title path desc act =
     act actions
     void $ skipManyTill anyMessage (getDocumentEdit doc)
 
+expectCodeActionsAvailable :: TestName -> FilePath -> [T.Text] -> TestTree
+expectCodeActionsAvailable title path actionTitles =
+  testCase title $ do
+    runSessionWithServer classPlugin testDataDir $ do
+      doc <- openDoc (path <.> "hs") "haskell"
+      _ <- waitForDiagnosticsFromSource doc "typecheck"
+      caResults <- getAllCodeActions doc
+      liftIO $ map (^? _CACodeAction . J.title) caResults
+        @?= expectedActions
+    where
+      expectedActions = Just <$> actionTitles
+
 testDataDir :: FilePath
 testDataDir = "test" </> "testdata"

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

@@ -0,0 +1,9 @@
+module AllMethodsRequired where
+
+class Test a where
+  f :: a
+  g :: a
+  {-# MINIMAL f,g #-}
+
+instance Test [a] where
+

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

@@ -0,0 +1,6 @@
+module MinimalDefinitionMeet where
+
+data X = X
+
+instance Eq X where
+  (==) = _

plugins/hls-class-plugin/test/testdata/T1.all.expected.hs

@@ -0,0 +1,7 @@
+module T1 where
+
+data X = X
+
+instance Eq X where
+  (==) = _
+  (/=) = _