hls-class-plugin: Add logs

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" :

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

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

@@ -6,8 +6,10 @@
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeFamilies      #-}
 {-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE LambdaCase        #-}
 module Ide.Plugin.Class
-  ( descriptor
+  ( descriptor,
+    Log (..)
   ) where
 
 import           Control.Applicative
@@ -27,7 +29,8 @@ import qualified Data.Set                                as Set
 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,16 +43,27 @@ import           Language.Haskell.GHC.ExactPrint.Utils   (rs)
 import           Language.LSP.Server
 import           Language.LSP.Types
 import qualified Language.LSP.Types.Lens                 as J
+import qualified Development.IDE.Core.Shake              as Shake
 
 #if MIN_VERSION_ghc(9,2,0)
 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]
@@ -178,8 +192,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
@@ -195,6 +209,7 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
       ident <- findClassIdentifier docPath range
       cls <- findClassFromIdentifier docPath ident
       implemented <- findImplementedMethods docPath range
+      logWith recorder Info (LogImplementedMethods cls implemented)
       lift . traverse (mkAction . (\\ implemented)) . minDefToMethodGroups . classMinimalDef $ cls
       where
         range = diag ^. J.range

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,23 +39,23 @@ 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 "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do
+  , goldenWithClass recorder "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
+  , goldenWithClass recorder "Creates a placeholder for other two methods" "T6" "2" $ \(_:ghAction:_) -> do
       executeCodeAction ghAction
   ]
 
@@ -59,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