diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index bd7a95bbf6c..9bc35f57c6c 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/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,6 +238,23 @@ 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 + instanceRange <- MaybeT . pure $ fromCurrentRange pmap range + pure + $ concat + $ pointCommand hf (instanceRange ^. 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 "") 1 1 @@ -241,11 +262,15 @@ 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 diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index ff2ca5a2ccb..ba065f15850 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/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 diff --git a/plugins/hls-class-plugin/test/testdata/T6.1.expected.hs b/plugins/hls-class-plugin/test/testdata/T6.1.expected.hs new file mode 100644 index 00000000000..492264e8d03 --- /dev/null +++ b/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 = _ diff --git a/plugins/hls-class-plugin/test/testdata/T6.2.expected.hs b/plugins/hls-class-plugin/test/testdata/T6.2.expected.hs new file mode 100644 index 00000000000..8245f07dfa8 --- /dev/null +++ b/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 = _ diff --git a/plugins/hls-class-plugin/test/testdata/T6.hs b/plugins/hls-class-plugin/test/testdata/T6.hs new file mode 100644 index 00000000000..47e10261091 --- /dev/null +++ b/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