Skip to content

Commit 83c649e

Browse files
akshaymankarakshaymankar
committed
hls-class-plugin: Add logs
1 parent 132abfa commit 83c649e

File tree

4 files changed

+51
-30
lines changed

4 files changed

+51
-30
lines changed

‎exe/Plugins.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -160,7 +160,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
160160
CallHierarchy.descriptor :
161161
#endif
162162
#if class
163-
Class.descriptor "class" :
163+
Class.descriptor pluginRecorder "class" :
164164
#endif
165165
#if haddockComments
166166
HaddockComments.descriptor "haddockComments" :

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

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ test-suite tests
5656
build-depends:
5757
, base
5858
, filepath
59+
, ghcide
5960
, hls-class-plugin
6061
, hls-test-utils ^>=1.3
6162
, lens

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

Lines changed: 22 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -6,8 +6,10 @@
66
{-# LANGUAGE RecordWildCards #-}
77
{-# LANGUAGE TypeFamilies #-}
88
{-# LANGUAGE ViewPatterns #-}
9+
{-# LANGUAGE LambdaCase #-}
910
module Ide.Plugin.Class
10-
( descriptor
11+
( descriptor,
12+
Log (..)
1113
) where
1214

1315
import Control.Applicative
@@ -27,7 +29,8 @@ import qualified Data.Set as Set
2729
import Development.IDE hiding (pluginHandlers)
2830
import Development.IDE.Core.PositionMapping (fromCurrentRange,
2931
toCurrentRange)
30-
import Development.IDE.GHC.Compat as Compat hiding (locA)
32+
import Development.IDE.GHC.Compat as Compat hiding (locA,
33+
(<+>))
3134
import Development.IDE.GHC.Compat.Util
3235
import Development.IDE.Spans.AtPoint
3336
import qualified GHC.Generics as Generics
@@ -40,16 +43,27 @@ import Language.Haskell.GHC.ExactPrint.Utils (rs)
4043
import Language.LSP.Server
4144
import Language.LSP.Types
4245
import qualified Language.LSP.Types.Lens as J
46+
import qualified Development.IDE.Core.Shake as Shake
4347

4448
#if MIN_VERSION_ghc(9,2,0)
4549
import GHC.Hs (AnnsModule (AnnsModule))
4650
import GHC.Parser.Annotation
4751
#endif
4852

49-
descriptor :: PluginId -> PluginDescriptor IdeState
50-
descriptor plId = (defaultPluginDescriptor plId)
53+
data Log
54+
= LogImplementedMethods Class [T.Text]
55+
56+
instance Pretty Log where
57+
pretty = \case
58+
LogImplementedMethods cls methods ->
59+
pretty ("Detected implmented methods for class" :: String)
60+
<+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name
61+
<+> pretty methods
62+
63+
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
64+
descriptor recorder plId = (defaultPluginDescriptor plId)
5165
{ pluginCommands = commands
52-
, pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction
66+
, pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeAction recorder)
5367
}
5468

5569
commands :: [PluginCommand IdeState]
@@ -178,8 +192,8 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do
178192
-- |
179193
-- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
180194
-- sensitive to the format of diagnostic messages from GHC.
181-
codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction
182-
codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do
195+
codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction
196+
codeAction recorder state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do
183197
docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri
184198
actions <- join <$> mapM (mkActions docPath) methodDiags
185199
pure . Right . List $ actions
@@ -195,6 +209,7 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
195209
ident <- findClassIdentifier docPath range
196210
cls <- findClassFromIdentifier docPath ident
197211
implemented <- findImplementedMethods docPath range
212+
logWith recorder Info (LogImplementedMethods cls implemented)
198213
lift . traverse (mkAction . (\\ implemented)) . minDefToMethodGroups . classMinimalDef $ cls
199214
where
200215
range = diag ^. J.range

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

Lines changed: 27 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -8,24 +8,29 @@ module Main
88
( main
99
) where
1010

11-
import Control.Lens (Prism', prism', (^..), (^?))
12-
import Control.Monad (void)
13-
import qualified Ide.Plugin.Class as Class
14-
import qualified Language.LSP.Types.Lens as J
11+
import Control.Lens (Prism', prism', (^..), (^?))
12+
import Control.Monad (void)
13+
import Data.Functor.Contravariant (contramap)
14+
import Development.IDE.Types.Logger
15+
import qualified Ide.Plugin.Class as Class
16+
import qualified Language.LSP.Types.Lens as J
1517
import System.FilePath
1618
import Test.Hls
1719

20+
1821
main :: IO ()
19-
main = defaultTestRunner tests
22+
main = do
23+
recorder <- makeDefaultStderrRecorder Nothing Debug
24+
defaultTestRunner . tests $ contramap (fmap pretty) recorder
2025

21-
classPlugin :: PluginDescriptor IdeState
22-
classPlugin = Class.descriptor "class"
26+
classPlugin :: Recorder (WithPriority Class.Log) -> PluginDescriptor IdeState
27+
classPlugin recorder = Class.descriptor recorder "class"
2328

24-
tests :: TestTree
25-
tests = testGroup
29+
tests :: Recorder (WithPriority Class.Log) -> TestTree
30+
tests recorder = testGroup
2631
"class"
2732
[ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do
28-
runSessionWithServer classPlugin testDataDir $ do
33+
runSessionWithServer (classPlugin recorder) testDataDir $ do
2934
doc <- openDoc "T1.hs" "haskell"
3035
_ <- waitForDiagnosticsFromSource doc "typecheck"
3136
caResults <- getAllCodeActions doc
@@ -34,23 +39,23 @@ tests = testGroup
3439
[ Just "Add placeholders for '=='"
3540
, Just "Add placeholders for '/='"
3641
]
37-
, goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do
42+
, goldenWithClass recorder "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do
3843
executeCodeAction eqAction
39-
, goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:neAction:_) -> do
44+
, goldenWithClass recorder "Creates a placeholder for '/='" "T1" "ne" $ \(_:neAction:_) -> do
4045
executeCodeAction neAction
41-
, goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:fmapAction:_) -> do
46+
, goldenWithClass recorder "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:fmapAction:_) -> do
4247
executeCodeAction fmapAction
43-
, goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do
48+
, goldenWithClass recorder "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do
4449
executeCodeAction mmAction
45-
, goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:mmAction:_) -> do
50+
, goldenWithClass recorder "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:mmAction:_) -> do
4651
executeCodeAction mmAction
47-
, goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do
52+
, goldenWithClass recorder "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do
4853
executeCodeAction _fAction
49-
, goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do
54+
, goldenWithClass recorder "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do
5055
executeCodeAction eqAction
51-
, goldenWithClass "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do
56+
, goldenWithClass recorder "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do
5257
executeCodeAction gAction
53-
, goldenWithClass "Creates a placeholder for other two multiple methods" "T6" "2" $ \(_:ghAction:_) -> do
58+
, goldenWithClass recorder "Creates a placeholder for other two methods" "T6" "2" $ \(_:ghAction:_) -> do
5459
executeCodeAction ghAction
5560
]
5661

@@ -59,9 +64,9 @@ _CACodeAction = prism' InR $ \case
5964
InR action -> Just action
6065
_ -> Nothing
6166

62-
goldenWithClass :: TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree
63-
goldenWithClass title path desc act =
64-
goldenWithHaskellDoc classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do
67+
goldenWithClass :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree
68+
goldenWithClass recorder title path desc act =
69+
goldenWithHaskellDoc (classPlugin recorder) title testDataDir path (desc <.> "expected") "hs" $ \doc -> do
6570
_ <- waitForDiagnosticsFromSource doc "typecheck"
6671
actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc
6772
act actions

0 commit comments

Comments
 (0)