From 31531259eee4ebe7ec5b9cb04f014658ad1ca5a7 Mon Sep 17 00:00:00 2001 From: Akshay Mankar Date: Mon, 13 Jun 2022 15:24:07 +0200 Subject: [PATCH] hls-class-plugin: Add logs --- exe/Plugins.hs | 2 +- .../hls-class-plugin/hls-class-plugin.cabal | 1 + .../hls-class-plugin/src/Ide/Plugin/Class.hs | 29 ++++++++--- plugins/hls-class-plugin/test/Main.hs | 49 ++++++++++--------- 4 files changed, 51 insertions(+), 30 deletions(-) diff --git a/exe/Plugins.hs b/exe/Plugins.hs index 5e7bb29ca1a..5cda269eaad 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 b0746ced2d7..89b1cdf1e9e 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 9bc35f57c6c..b49e9c8f709 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class.hs +++ b/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 diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index ba065f15850..86399fd1c86 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,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