Skip to content

Commit 3768251

Browse files
akshaymankarakshaymankar
committed
hls-class-plugin: Add logs
1 parent d868d80 commit 3768251

File tree

4 files changed

+49
-30
lines changed

4 files changed

+49
-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: 20 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,8 @@
77
{-# LANGUAGE TypeFamilies #-}
88
{-# LANGUAGE ViewPatterns #-}
99
module Ide.Plugin.Class
10-
( descriptor
10+
( descriptor,
11+
Log (..)
1112
) where
1213

1314
import Control.Applicative
@@ -27,7 +28,8 @@ import qualified Data.Text as T
2728
import Development.IDE hiding (pluginHandlers)
2829
import Development.IDE.Core.PositionMapping (fromCurrentRange,
2930
toCurrentRange)
30-
import Development.IDE.GHC.Compat as Compat hiding (locA)
31+
import Development.IDE.GHC.Compat as Compat hiding (locA,
32+
(<+>))
3133
import Development.IDE.GHC.Compat.Util
3234
import Development.IDE.Spans.AtPoint
3335
import qualified GHC.Generics as Generics
@@ -46,10 +48,20 @@ import GHC.Hs (AnnsModule (AnnsModule
4648
import GHC.Parser.Annotation
4749
#endif
4850

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

5567
commands :: [PluginCommand IdeState]
@@ -178,8 +190,8 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do
178190
-- |
179191
-- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
180192
-- 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
193+
codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction
194+
codeAction recorder state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do
183195
docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri
184196
actions <- join <$> mapM (mkActions docPath) methodDiags
185197
pure . Right . List $ actions
@@ -201,6 +213,7 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
201213
ident <- findClassIdentifier ast instancePosition
202214
cls <- findClassFromIdentifier docPath ident
203215
implemented <- findImplementedMethods ast instancePosition
216+
logWith recorder Info (LogImplementedMethods cls implemented)
204217
lift . traverse (mkAction . (\\ implemented)) . minDefToMethodGroups . classMinimalDef $ cls
205218
where
206219
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)