Provide code action in hls-eval-plugin

Code action and lens are provided at the same time.

In addition, a file is excluded from stylish-haskell pre-commit hook
due to a CPP issue introduced in #4527.

Fix: #496

Author: jian-lin

.pre-commit-config.yaml

@@ -4,7 +4,7 @@ repos:
   - hooks:
       - entry: stylish-haskell --inplace
         exclude: >-
-          (^Setup.hs$|test/testdata/.*$|test/data/.*$|test/manual/lhs/.*$|^hie-compat/.*$|^plugins/hls-tactics-plugin/.*$|^ghcide/src/Development/IDE/GHC/Compat.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs$|^ghcide/src/Development/IDE/GHC/Compat/Core.hs$|^ghcide/src/Development/IDE/Spans/Pragmas.hs$|^ghcide/src/Development/IDE/LSP/Outline.hs$|^plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs$|^ghcide/src/Development/IDE/Core/Rules.hs$|^ghcide/src/Development/IDE/Core/Compile.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs$)
+          (^Setup.hs$|test/testdata/.*$|test/data/.*$|test/manual/lhs/.*$|^hie-compat/.*$|^plugins/hls-tactics-plugin/.*$|^ghcide/src/Development/IDE/GHC/Compat.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs$|^ghcide/src/Development/IDE/GHC/Compat/Core.hs$|^ghcide/src/Development/IDE/Spans/Pragmas.hs$|^ghcide/src/Development/IDE/LSP/Outline.hs$|^plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs$|^ghcide/src/Development/IDE/Core/Rules.hs$|^ghcide/src/Development/IDE/Core/Compile.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs$|^plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs$)
         files: \.l?hs$
         id: stylish-haskell
         language: system

plugins/hls-eval-plugin/src/Ide/Plugin/Eval.hs

@@ -27,8 +27,11 @@ import           Language.LSP.Protocol.Message
 -- |Plugin descriptor
 descriptor :: Recorder (WithPriority Eval.Log) -> PluginId -> PluginDescriptor IdeState
 descriptor recorder plId =
-    (defaultPluginDescriptor plId "Provies a code lens to evaluate expressions in doctest comments")
-        { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens (CL.codeLens recorder)
+    (defaultPluginDescriptor plId "Provies code action and lens to evaluate expressions in doctest comments")
+        { pluginHandlers = mconcat
+            [ mkPluginHandler SMethod_TextDocumentCodeAction (CL.codeAction recorder)
+            , mkPluginHandler SMethod_TextDocumentCodeLens (CL.codeLens recorder)
+            ]
         , pluginCommands = [CL.evalCommand recorder plId]
         , pluginRules = rules recorder
         , pluginConfigDescriptor = defaultConfigDescriptor

plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

@@ -13,6 +13,7 @@ A plugin inspired by the REPLoid feature of <https://github.com/jyp/dante Dante>
 For a full example see the "Ide.Plugin.Eval.Tutorial" module.
 -}
 module Ide.Plugin.Eval.CodeLens (
+    codeAction,
     codeLens,
     evalCommand,
 ) where
@@ -125,17 +126,35 @@ import           Language.LSP.Server
 import           GHC.Unit.Module.ModIface                     (IfaceTopEnv (..))
 #endif
 
+codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeAction
+codeAction recorder st plId CodeActionParams{_textDocument,_range} = do
+    rangeCommands <- mkRangeCommands recorder st plId _textDocument
+    pure
+        $ InL
+            [ InL command
+            | (testRange, command) <- rangeCommands
+            , _range `isSubrangeOf` testRange
+            ]
 
 {- | Code Lens provider
  NOTE: Invoked every time the document is modified, not just when the document is saved.
 -}
 codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState Method_TextDocumentCodeLens
-codeLens recorder st plId CodeLensParams{_textDocument} =
+codeLens recorder st plId CodeLensParams{_textDocument} = do
+    rangeCommands <- mkRangeCommands recorder st plId _textDocument
+    pure
+        $ InL
+            [ CodeLens range (Just command) Nothing
+            | (range, command) <- rangeCommands
+            ]
+
+mkRangeCommands :: Recorder (WithPriority Log) -> IdeState -> PluginId -> TextDocumentIdentifier -> ExceptT PluginError (HandlerM Config) [(Range, Command)]
+mkRangeCommands recorder st plId textDocument =
     let dbg = logWith recorder Debug
         perf = timed (\lbl duration -> dbg $ LogExecutionTime lbl duration)
-     in perf "codeLens" $
+     in perf "evalMkRangeCommands" $
             do
-                let TextDocumentIdentifier uri = _textDocument
+                let TextDocumentIdentifier uri = textDocument
                 fp <- uriToFilePathE uri
                 let nfp = toNormalizedFilePath' fp
                     isLHS = isLiterate fp
@@ -148,11 +167,11 @@ codeLens recorder st plId CodeLensParams{_textDocument} =
                 let Sections{..} = commentsToSections isLHS comments
                     tests = testsBySection nonSetupSections
                     cmd = mkLspCommand plId evalCommandName "Evaluate=..." (Just [])
-                let lenses =
-                        [ CodeLens testRange (Just cmd') Nothing
+                let rangeCommands =
+                        [ (testRange, cmd')
                         | (section, ident, test) <- tests
                         , let (testRange, resultRange) = testRanges test
-                              args = EvalParams (setupSections ++ [section]) _textDocument ident
+                              args = EvalParams (setupSections ++ [section]) textDocument ident
                               cmd' =
                                 (cmd :: Command)
                                     { _arguments = Just [toJSON args]
@@ -168,9 +187,9 @@ codeLens recorder st plId CodeLensParams{_textDocument} =
                             (length tests)
                             (length nonSetupSections)
                             (length setupSections)
-                            (length lenses)
+                            (length rangeCommands)
 
-                return $ InL lenses
+                pure rangeCommands
   where
     trivial (Range p p') = p == p'
 

plugins/hls-eval-plugin/test/Main.hs

@@ -6,13 +6,15 @@ module Main
   ) where
 
 import           Control.Lens               (_Just, folded, preview, view, (^.),
-                                             (^..))
+                                             (^..), (^?))
+import           Control.Monad              (join)
 import           Data.Aeson                 (Value (Object), fromJSON, object,
                                              (.=))
 import           Data.Aeson.Types           (Pair, Result (Success))
 import           Data.List                  (isInfixOf)
 import           Data.List.Extra            (nubOrdOn)
 import qualified Data.Map                   as Map
+import qualified Data.Maybe                 as Maybe
 import qualified Data.Text                  as T
 import           Ide.Plugin.Config          (Config)
 import qualified Ide.Plugin.Config          as Plugin
@@ -59,6 +61,9 @@ tests =
         lenses <- getCodeLenses doc
         liftIO $ map (view range) lenses @?= [Range (Position 4 0) (Position 5 0)]
 
+  , goldenWithEvalForCodeAction "Evaluation of expressions via code action" "T1" "hs"
+  , goldenWithEvalForCodeAction "Reevaluation of expressions via code action" "T2" "hs"
+
   , goldenWithEval "Evaluation of expressions" "T1" "hs"
   , goldenWithEval "Reevaluation of expressions" "T2" "hs"
   , goldenWithEval "Evaluation of expressions w/ imports" "T3" "hs"
@@ -221,6 +226,10 @@ goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree
 goldenWithEval title path ext =
   goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path "expected" ext executeLensesBackwards
 
+goldenWithEvalForCodeAction :: TestName -> FilePath -> FilePath -> TestTree
+goldenWithEvalForCodeAction title path ext =
+  goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs $ FS.directProject (path <.> ext)) path "expected" ext executeCodeActionsBackwards
+
 goldenWithEvalAndFs :: TestName -> [FS.FileTree] -> FilePath -> FilePath -> TestTree
 goldenWithEvalAndFs title tree path ext =
   goldenWithHaskellDocInTmpDir def evalPlugin title (mkFs tree) path  "expected" ext executeLensesBackwards
@@ -239,14 +248,24 @@ goldenWithEvalAndFs' title tree path ext expected =
 -- | Execute lenses backwards, to avoid affecting their position in the source file
 executeLensesBackwards :: TextDocumentIdentifier -> Session ()
 executeLensesBackwards doc = do
-  codeLenses <- reverse <$> getCodeLenses doc
+  codeLenses <- getCodeLenses doc
   -- liftIO $ print codeLenses
+  executeCmdsBackwards [c | CodeLens{_command = Just c} <- codeLenses]
+
+executeCodeActionsBackwards :: TextDocumentIdentifier -> Session ()
+executeCodeActionsBackwards doc = do
+  codeLenses <- getCodeLenses doc
+  let ranges = [_range | CodeLens{_range} <- codeLenses]
+  -- getAllCodeActions cannot get our code actions because they have no diagnostics
+  codeActions <- join <$> traverse (getCodeActions doc) ranges
+  let cmds = Maybe.mapMaybe (^? _L) codeActions
+  executeCmdsBackwards cmds
 
-  -- Execute sequentially, nubbing elements to avoid
-  -- evaluating the same section with multiple tests
-  -- more than twice
-  mapM_ executeCmd $
-    nubOrdOn actSectionId [c | CodeLens{_command = Just c} <- codeLenses]
+-- Execute commands backwards, nubbing elements to avoid
+-- evaluating the same section with multiple tests
+-- more than twice
+executeCmdsBackwards :: [Command] -> Session ()
+executeCmdsBackwards = mapM_ executeCmd . nubOrdOn actSectionId . reverse
 
 actSectionId :: Command -> Int
 actSectionId Command{_arguments = Just [fromJSON -> Success EvalParams{..}]} = evalId