Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

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

Merged
merged 3 commits into from
Jun 20, 2022
Merged

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

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
d868d80
hls-class-plugin: Only create placeholders for unimplemented methods
akshaymankar Jun 13, 2022
3768251
hls-class-plugin: Add logs
akshaymankar Jun 13, 2022
f52c257
Merge branch 'master' into class-plugin-detect-unimplemented
Ailrun Jun 19, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion exe/Plugins.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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" :
Expand Down
1 change: 1 addition & 0 deletions plugins/hls-class-plugin/hls-class-plugin.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -56,6 +56,7 @@ test-suite tests
build-depends:
, base
, filepath
, ghcide
, hls-class-plugin
, hls-test-utils ^>=1.3
, lens
Expand Down
84 changes: 62 additions & 22 deletions plugins/hls-class-plugin/src/Ide/Plugin/Class.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -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
Expand All @@ -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]
Expand Down Expand Up @@ -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
Expand All @@ -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

Expand All @@ -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
Expand All @@ -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]
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This could do with some haddock and/or explanation. what is it doing and why?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I added an explanation, please let me know if it makes sense.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why can't we just transitively look for all the things that are InstanceValBinds underneath, rather than having to specifically say which things we'll recurse through? I'd have thought that the only InstanceValBinds in a instance declaration would be precisely the already-implemented methods?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Hmm, yeah makes the code much simpler:

    findInstanceValBindIdentifiers :: HieAST a -> [Identifier]
    findInstanceValBindIdentifiers ast =
        let valBindIds = Map.keys
                         . Map.filter (any isInstanceValBind . identInfo)
                         $ getNodeIds ast
        in valBindIds <> concatMap findInstanceValBindIdentifiers (nodeChildren ast)

I guess this will perform worse as this is now traversing more of the AST, but maybe this is not as bad?

Copy link
Contributor Author

@akshaymankar akshaymankar Jun 18, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Actually, this also makes the code compatible with older GHCs, so I am going to commit it.

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
Expand Down
49 changes: 29 additions & 20 deletions plugins/hls-class-plugin/test/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
22 changes: 22 additions & 0 deletions plugins/hls-class-plugin/test/testdata/T6.1.expected.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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 = _
23 changes: 23 additions & 0 deletions plugins/hls-class-plugin/test/testdata/T6.2.expected.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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 = _
21 changes: 21 additions & 0 deletions plugins/hls-class-plugin/test/testdata/T6.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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