diff --git a/plugins/hls-class-plugin/README.md b/plugins/hls-class-plugin/README.md index b8adda09ee..e037684db7 100644 --- a/plugins/hls-class-plugin/README.md +++ b/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 diff --git a/plugins/hls-class-plugin/codeactions.gif b/plugins/hls-class-plugin/codeactions.gif index 35eeac78d7..ee0e345b41 100644 Binary files a/plugins/hls-class-plugin/codeactions.gif and b/plugins/hls-class-plugin/codeactions.gif differ diff --git a/plugins/hls-class-plugin/codelens.gif b/plugins/hls-class-plugin/codelens.gif index fbef99281c..ead80cfd98 100644 Binary files a/plugins/hls-class-plugin/codelens.gif and b/plugins/hls-class-plugin/codelens.gif differ diff --git a/plugins/hls-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index 9df55df9bf..1e168cc808 100644 --- a/plugins/hls-class-plugin/hls-class-plugin.cabal +++ b/plugins/hls-class-plugin/hls-class-plugin.cabal @@ -77,3 +77,4 @@ test-suite tests , hls-test-utils ^>=1.5 , lens , lsp-types + , text diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 43fa3a9e99..6b18a8e1df 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/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) + diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index c9c14aa85c..091a7c0fe4 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-class-plugin/test/testdata/AllMethodsRequired.hs b/plugins/hls-class-plugin/test/testdata/AllMethodsRequired.hs new file mode 100644 index 0000000000..3d88e04a7b --- /dev/null +++ b/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 + diff --git a/plugins/hls-class-plugin/test/testdata/MinimalDefinitionMeet.hs b/plugins/hls-class-plugin/test/testdata/MinimalDefinitionMeet.hs new file mode 100644 index 0000000000..39ce1d9c57 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/MinimalDefinitionMeet.hs @@ -0,0 +1,6 @@ +module MinimalDefinitionMeet where + +data X = X + +instance Eq X where + (==) = _ diff --git a/plugins/hls-class-plugin/test/testdata/T1.all.expected.hs b/plugins/hls-class-plugin/test/testdata/T1.all.expected.hs new file mode 100644 index 0000000000..114ae94256 --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/T1.all.expected.hs @@ -0,0 +1,7 @@ +module T1 where + +data X = X + +instance Eq X where + (==) = _ + (/=) = _