hls-eval-plugin: Replicate #4139 (#4140)

* main function eval bug

* hls-eval-plugin: set ghci backend for evaluation

* Fixes #4139

* bench: add hls-eval-plugin experiments

---------

Co-authored-by: Peter Matta <[email protected]>
Co-authored-by: soulomoon <[email protected]>

Author: 3 people

bench/config.yaml

@@ -106,6 +106,8 @@ experiments:
     - "code actions after cradle edit"
     - "documentSymbols after edit"
     - "hole fit suggestions"
+    - "eval execute single-line code lens"
+    - "eval execute multi-line code lens"
 
 # An ordered list of versions to analyze
 versions:

ghcide-bench/src/Experiments.hs

@@ -241,7 +241,7 @@ experiments =
       benchWithSetup
         "hole fit suggestions"
         ( mapM_ $ \DocumentPositions{..} -> do
-            let edit  =TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom
+            let edit = TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom
                                                            .+ #rangeLength .== Nothing
                                                            .+ #text .== t
                 bottom = Position maxBound 0
@@ -266,6 +266,63 @@ experiments =
                 case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of
                     Nothing   -> pure True
                     Just _err -> pure False
+        ),
+      ---------------------------------------------------------------------------------------
+      benchWithSetup
+        "eval execute single-line code lens"
+        ( mapM_ $ \DocumentPositions{..} -> do
+            let edit = TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom
+                                                           .+ #rangeLength .== Nothing
+                                                           .+ #text .== t
+                bottom = Position maxBound 0
+                t = T.unlines
+                    [ ""
+                    , "-- >>> 1 + 2"
+                    ]
+            changeDoc doc [edit]
+        )
+        ( \docs -> do
+            not . null <$> forM docs (\DocumentPositions{..} -> do
+              lenses <- getCodeLenses doc
+              forM_ lenses $ \case
+                CodeLens { _command = Just cmd } -> do
+                  executeCommand cmd
+                  waitForProgressStart
+                  waitForProgressDone
+                _ -> return ()
+              )
+        ),
+      ---------------------------------------------------------------------------------------
+      benchWithSetup
+        "eval execute multi-line code lens"
+        ( mapM_ $ \DocumentPositions{..} -> do
+            let edit = TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom
+                                                           .+ #rangeLength .== Nothing
+                                                           .+ #text .== t
+                bottom = Position maxBound 0
+                t = T.unlines
+                    [ ""
+                    , "data T = A | B | C | D"
+                    , "  deriving (Show, Eq, Ord, Bounded, Enum)"
+                    , ""
+                    , "{-"
+                    , ">>> import Data.List (nub)"
+                    , ">>> xs = ([minBound..maxBound] ++ [minBound..maxBound] :: [T])"
+                    , ">>> nub xs"
+                    , "-}"
+                    ]
+            changeDoc doc [edit]
+        )
+        ( \docs -> do
+            not . null <$> forM docs (\DocumentPositions{..} -> do
+              lenses <- getCodeLenses doc
+              forM_ lenses $ \case
+                CodeLens { _command = Just cmd } -> do
+                  executeCommand cmd
+                  waitForProgressStart
+                  waitForProgressDone
+                _ -> return ()
+              )
         )
     ]
     where hasDefinitions (InL (Definition (InL _)))  = True

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

@@ -277,6 +277,7 @@ initialiseSessionForEval needs_quickcheck st nfp = do
                    . flip xopt_unset  LangExt.MonomorphismRestriction
                    . flip gopt_set    Opt_ImplicitImportQualified
                    . flip gopt_unset  Opt_DiagnosticsShowCaret
+                   . setBackend ghciBackend
                    $ (ms_hspp_opts ms) {
                         useColor = Never
                       , canUseColor = False }

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

@@ -88,6 +88,7 @@ tests =
   , goldenWithEval "Reports an error for an incorrect type with :kind" "T13" "hs"
   , goldenWithEval' "Returns a fully-instantiated type for :type" "T14" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else "expected") -- See https://gitlab.haskell.org/ghc/ghc/-/issues/24069
   , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs"
+  , goldenWithEval "Doesn't break in module containing main function" "T4139" "hs"
   , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs"
   , goldenWithEval ":type reports an error when given with unknown +x option" "T17" "hs"
   , goldenWithEval "Reports an error when given with unknown command" "T18" "hs"

plugins/hls-eval-plugin/test/testdata/T4139.expected.hs

@@ -0,0 +1,7 @@
+module T4139 where
+
+-- >>> 'x'
+-- 'x'
+
+main :: IO ()
+main = putStrLn "Hello World!"

plugins/hls-eval-plugin/test/testdata/T4139.hs

@@ -0,0 +1,6 @@
+module T4139 where
+
+-- >>> 'x'
+
+main :: IO ()
+main = putStrLn "Hello World!"