Capture output of eval plugin and some girls scout changes

flake.nix

@@ -2,9 +2,7 @@
   description = "haskell-language-server development flake";
 
   inputs = {
-    # Don't use nixpkgs-unstable as aarch64-darwin is currently broken there.
-    # Check again, when https://github.com/NixOS/nixpkgs/pull/414242 is resolved.
-    nixpkgs.url = "github:NixOS/nixpkgs/c742ae7908a82c9bf23ce27bfca92a00e9bcd541";
+    nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
     flake-utils.url = "github:numtide/flake-utils";
     # For default.nix
     flake-compat = {

ghcide/src/Development/IDE/GHC/Compat/Logger.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE CPP #-}
--- | Compat module for GHC 9.2 Logger infrastructure.
+-- | Compat module for logger infrastructure.
 module Development.IDE.GHC.Compat.Logger (
     putLogHook,
     Logger.pushLogHook,

ghcide/src/Development/IDE/Spans/AtPoint.hs

@@ -25,7 +25,8 @@ module Development.IDE.Spans.AtPoint (
   ) where
 
 
-import           GHC.Data.FastString                  (lengthFS)
+import           GHC.Data.FastString                  (LexicalFastString (..),
+                                                       lengthFS)
 import qualified GHC.Utils.Outputable                 as O
 
 import           Development.IDE.GHC.Error
@@ -50,7 +51,6 @@ import           Control.Monad.Extra
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Maybe
-import           Data.Coerce                          (coerce)
 import qualified Data.HashMap.Strict                  as HM
 import qualified Data.Map.Strict                      as M
 import           Data.Maybe
@@ -580,18 +580,8 @@ defRowToSymbolInfo _ = Nothing
 
 pointCommand :: HieASTs t -> Position -> (HieAST t -> a) -> [a]
 pointCommand hf pos k =
-    M.elems $ flip M.mapMaybeWithKey (getAsts hf) $ \fs ast ->
-      -- Since GHC 9.2:
-      -- getAsts :: Map HiePath (HieAst a)
-      -- type HiePath = LexicalFastString
-      --
-      -- but before:
-      -- getAsts :: Map HiePath (HieAst a)
-      -- type HiePath = FastString
-      --
-      -- 'coerce' here to avoid an additional function for maintaining
-      -- backwards compatibility.
-      case selectSmallestContaining (sp $ coerce fs) ast of
+    M.elems $ flip M.mapMaybeWithKey (getAsts hf) $ \(LexicalFastString fs) ast ->
+      case selectSmallestContaining (sp fs) ast of
         Nothing   -> Nothing
         Just ast' -> Just $ k ast'
  where

haskell-language-server.cabal

@@ -494,6 +494,7 @@ library hls-eval-plugin
     , megaparsec            >=9.0
     , mtl
     , parser-combinators    >=1.2
+    , silently
     , text
     , text-rope
     , transformers

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns      #-}
 {-# OPTIONS_GHC -Wwarn #-}
@@ -15,14 +14,17 @@ import qualified Data.Text                   as T
 import           Development.IDE.GHC.Compat
 import           GHC                         (ExecOptions, ExecResult (..),
                                               execStmt)
+import           GHC.Driver.Monad            (reflectGhc, reifyGhc)
 import           Ide.Plugin.Eval.Types       (Language (Plain), Loc,
                                               Located (..),
                                               Section (sectionLanguage),
                                               Test (..), Txt, locate, locate0)
 import qualified Language.LSP.Protocol.Lens  as L
 import           Language.LSP.Protocol.Types (Position (Position),
                                               Range (Range))
+import           System.IO                   (stderr, stdout)
 import           System.IO.Extra             (newTempFile, readFile')
+import           System.IO.Silently          (hCapture)
 
 -- | Return the ranges of the expression and result parts of the given test
 testRanges :: Test -> (Range, Range)
@@ -79,20 +81,31 @@ asStmts (Example e _ _) = NE.toList e
 asStmts (Property t _ _) =
     ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"]
 
-
-
 -- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result
 myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String))
 myExecStmt stmt opts = do
     (temp, purge) <- liftIO newTempFile
     evalPrint <- head <$> runDecls ("evalPrint x = P.writeFile " <> show temp <> " (P.show x)")
     modifySession $ \hsc -> hsc {hsc_IC = setInteractivePrintName (hsc_IC hsc) evalPrint}
-    result <- execStmt stmt opts >>= \case
-              ExecComplete (Left err) _ -> pure $ Left $ show err
-              ExecComplete (Right _) _ -> liftIO $ Right . (\x -> if null x then Nothing else Just x) <$> readFile' temp
-              ExecBreak{} -> pure $ Right $ Just "breakpoints are not supported"
+    -- NB: We capture output to @stdout@ and @stderr@ induced as a possible side
+    -- effect by the statement being evaluated. This is fragile because the
+    -- output may be scrambled in a concurrent setting when HLS is writing to
+    -- one of these file handles from a different thread.
+    (output, execResult) <- reifyGhc $ \session ->
+      hCapture [stdout, stderr] (reflectGhc (execStmt stmt opts) session)
+    evalResult <- case execResult of
+      ExecComplete (Left err) _ ->
+        pure $ Left $ show err
+      ExecComplete (Right _) _ ->
+        liftIO $ Right . fromList . (output <>) <$> readFile' temp
+      ExecBreak{} ->
+        pure $ Right $ Just "breakpoints are not supported"
     liftIO purge
-    pure result
+    pure evalResult
+  where
+    fromList :: String -> Maybe String
+    fromList x | null x    = Nothing
+               | otherwise = Just x
 
 {- |GHC declarations required to execute test properties
 

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

@@ -7,11 +7,10 @@
 {-# LANGUAGE ViewPatterns              #-}
 {-# OPTIONS_GHC -Wno-type-defaults #-}
 
-{- |
-A plugin inspired by the REPLoid feature of <https://github.com/jyp/dante Dante>, <https://www.haskell.org/haddock/doc/html/ch03s08.html#idm140354810775744 Haddock>'s Examples and Properties and <https://hackage.haskell.org/package/doctest Doctest>.
-
-For a full example see the "Ide.Plugin.Eval.Tutorial" module.
--}
+-- | A plugin inspired by the REPLoid feature of
+-- [Dante](https://github.com/jyp/dante),
+-- [Haddock examples and properties](https://haskell-haddock.readthedocs.io/latest/markup.html#examples),
+-- and [Doctest](https://hackage.haskell.org/package/doctest).
 module Ide.Plugin.Eval.Handlers (
     codeAction,
     codeLens,
@@ -397,12 +396,15 @@ The result of evaluating a test line can be:
 A value is returned for a correct expression.
 
 Either a pure value:
->>> 'h' :"askell"
+>>> 'h' : "askell"
 "haskell"
 
-Or an 'IO a' (output on stdout/stderr is ignored):
->>> print "OK" >> return "ABC"
-"ABC"
+Or an 'IO a' (output on stdout/stderr is captured):
+>>> putStrLn "Hello," >> pure "World!"
+Hello,
+"World!"
+
+Note the quotes around @World!@, which are a result of using 'show'.
 
 Nothing is returned for a correct directive:
 
@@ -426,11 +428,15 @@ A, possibly multi line, error is returned for a wrong declaration, directive or
 Some flags have not been recognized: -XNonExistent
 
 >>> cls C
-Variable not in scope: cls :: t0 -> t
-Data constructor not in scope: C
+Illegal term-level use of the class `C'
+  defined at <interactive>:1:2
+In the first argument of `cls', namely `C'
+In the expression: cls C
+In an equation for `it_a1kSJ': it_a1kSJ = cls C
+Variable not in scope: cls :: t0_a1kU9[tau:1] -> t1_a1kUb[tau:1]
 
 >>> "A
-lexical error in string/character literal at end of input
+lexical error at end of input
 
 Exceptions are shown as if printed, but it can be configured to include prefix like
 in GHCi or doctest. This allows it to be used as a hack to simulate print until we
@@ -446,7 +452,8 @@ bad times
 Or for a value that does not have a Show instance and can therefore not be displayed:
 >>> data V = V
 >>> V
-No instance for (Show V) arising from a use of ‘evalPrint’
+No instance for `Show V' arising from a use of `evalPrint'
+In a stmt of an interactive GHCi command: evalPrint it_a1l4V
 -}
 evals :: Recorder (WithPriority Log) -> Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text]
 evals recorder mark_exception fp df stmts = do
@@ -455,7 +462,7 @@ evals recorder mark_exception fp df stmts = do
         Left err -> errorLines err
         Right rs -> concat . catMaybes $ rs
   where
-    dbg = logWith recorder Debug
+    dbg  = logWith recorder Debug
     eval :: Statement -> Ghc (Maybe [Text])
     eval (Located l stmt)
         | -- GHCi flags

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

@@ -143,7 +143,7 @@ tests =
   , goldenWithEval "Test on last line insert results correctly" "TLastLine" "hs"
   , testGroup "with preprocessors"
     [ knownBrokenInEnv [HostOS Windows]
-        "CPP eval on Windows and/or GHC <= 8.6 fails for some reasons" $
+        "CPP eval on Windows fails for some reasons" $
         goldenWithEval "CPP support" "TCPP" "hs"
     , goldenWithEval "Literate Haskell Bird Style" "TLHS" "lhs"
     ]

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

@@ -34,20 +34,19 @@ tests = testGroup "GADT"
     , runTest "ConstructorContext" "ConstructorContext" 2 0 2 38
     , runTest "Context" "Context" 2 0 4 41
     , runTest "Pragma" "Pragma" 2 0 3 29
-    , runTest "SingleDerivingGHC92" "SingleDerivingGHC92" 2 0 3 14
-    , gadtPragmaTest "ghc-9.2 don't need to insert GADTs pragma" False
+    , runTest "SingleDeriving" "SingleDeriving" 2 0 3 14
+    , gadtPragmaTest "no need to insert GADTs pragma"
     ]
 
-gadtPragmaTest :: TestName -> Bool -> TestTree
-gadtPragmaTest title hasGADT = testCase title
+gadtPragmaTest :: TestName -> TestTree
+gadtPragmaTest title = testCase title
     $ withCanonicalTempDir
     $ \dir -> runSessionWithServer def gadtPlugin dir $ do
         doc <- createDoc "A.hs" "haskell" (T.unlines ["module A where", "data Foo = Bar"])
         _ <- waitForProgressDone
         (act:_) <- findGADTAction <$> getCodeActions doc (Range (Position 1 0) (Position 1 1))
         executeCodeAction act
         let expected = T.unlines $
-                ["{-# LANGUAGE GADTs #-}" | hasGADT] ++
                 ["module A where", "data Foo where", "  Bar :: Foo"]
         contents <- skipManyTill anyMessage (getDocumentEdit doc)
         liftIO $ contents @?= expected

plugins/hls-gadt-plugin/test/testdata/SingleDeriving.expected.hs

@@ -2,4 +2,4 @@ module SingleDeriving where
 
 data Foo a b where
   Bar :: b -> a -> Foo a b
-  deriving Eq
+  deriving (Eq)