diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 5a5f59d467..dead73452c 100644 --- a/exe/Plugins.hs +++ b/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" : diff --git a/plugins/hls-class-plugin/hls-class-plugin.cabal b/plugins/hls-class-plugin/hls-class-plugin.cabal index b0746ced2d..89b1cdf1e9 100644 --- a/plugins/hls-class-plugin/hls-class-plugin.cabal +++ b/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 diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs index bd7a95bbf6..06315cc748 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/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,6 +254,22 @@ 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 "") 1 1 @@ -241,11 +277,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 ff2ca5a2cc..86399fd1c8 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/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,20 +39,24 @@ 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 @@ -55,9 +64,9 @@ _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 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 0000000000..a1e64f591b --- /dev/null +++ b/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 = _ 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 0000000000..2b7b5454b9 --- /dev/null +++ b/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 = _ 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 0000000000..61d2c6dc62 --- /dev/null +++ b/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