Eval plugin: mark exceptions (haskell#2775)

Author: xsebek

docs/configuration.md

@@ -63,6 +63,9 @@ Plugins have a generic config to control their behaviour. The schema of such con
     - `haskell.plugin.tactics.config.hole_severity`, default empty: The severity to use when showing hole diagnostics. These are noisy, but some editors don't allow jumping to all severities. One of `error`, `warning`, `info`, `hint`, `none`.
     - `haskell.plugin.tactics.config.max_use_ctor_actions`, default 5: Maximum number of `Use constructor <x>` code actions that can appear.
     - `haskell.plugin.tactics.config.proofstate_styling`, default true: Should Wingman emit styling markup when showing metaprogram proof states?
+  - `eval`:
+    - `haskell.plugin.eval.config.diff`, default true: When reloading haddock test results in changes, mark it with WAS/NOW.
+    - `haskell.plugin.eval.config.exception`, default false: When the command results in an exception, mark it with `*** Exception:`.
   - `ghcide-completions`:
     - `haskell.plugin.ghcide-completions.config.snippetsOn`, default true: Inserts snippets when using code completions.
     - `haskell.plugin.ghcide-completions.config.autoExtendOn`, default true: Extends the import list automatically when completing a out-of-scope identifier.

plugins/hls-eval-plugin/README.md

@@ -242,6 +242,11 @@ On the contrary, if the test were into a plain comment, the result would simply
 -}
 ```
 
+If you find this WAS/NOW behaviour does not fit your needs, you can turn it off with toggling the configuration option:
+```json
+"haskell.plugin.eval.config.diff": false
+```
+
 # Multiline Output
 
 By default, the output of every expression is returned as a single line.
@@ -274,6 +279,8 @@ To display it properly, we can exploit the fact that the output of an error is d
 ]
 ```
 
+This assumes you did not turn on exception marking (see [Marking exceptions](#marking-exceptions) below).
+
 # Differences with doctest
 
 Though the Eval plugin functionality is quite similar to that of [doctest](https://hackage.haskell.org/package/doctest), some doctest's features are not supported.
@@ -287,6 +294,24 @@ Only the value of an IO expression is spliced in, not its output:
 ()
 ```
 
+###  Marking exceptions
+
+When an exception is thrown it is not prefixed:
+
+```
+>>> 1 `div` 0
+divide by zero
+```
+
+If you want to get the doctest/GHCi behaviour, you can toggle the configuration option:
+```json
+"haskell.plugin.eval.config.exception": true
+```
+```
+>>> 1 `div` 0
+*** Exception: divide by zero
+```
+
 ### Pattern Matching
 
 The arbitrary content matcher __...__ is unsupported.

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

@@ -27,7 +27,7 @@ import           Control.Applicative             (Alternative ((<|>)))
 import           Control.Arrow                   (second, (>>>))
 import           Control.Exception               (try)
 import qualified Control.Exception               as E
-import           Control.Lens                    (_1, _3, (%~), (<&>), (^.))
+import           Control.Lens                    (_1, _3, ix, (%~), (<&>), (^.))
 import           Control.Monad                   (guard, join, void, when)
 import           Control.Monad.IO.Class          (MonadIO (liftIO))
 import           Control.Monad.Trans             (lift)
@@ -90,7 +90,7 @@ import           Ide.Plugin.Eval.Code            (Statement, asStatements,
                                                   evalSetup, myExecStmt,
                                                   propSetup, resultRange,
                                                   testCheck, testRanges)
-import           Ide.Plugin.Eval.Config          (getDiffProperty)
+import           Ide.Plugin.Eval.Config          (getEvalConfig, EvalConfig(..))
 import           Ide.Plugin.Eval.GHC             (addImport, addPackages,
                                                   hasPackage, showDynFlags)
 import           Ide.Plugin.Eval.Parse.Comments  (commentsToSections)
@@ -292,13 +292,13 @@ runEvalCmd plId st EvalParams{..} =
                         -- Evaluation takes place 'inside' the module
                         setContext [Compat.IIModule modName]
                         Right <$> getSession
-            diff <- lift $ getDiffProperty plId
+            evalCfg <- lift $ getEvalConfig plId
             edits <-
                 perf "edits" $
                     liftIO $
                         evalGhcEnv hscEnv' $
                             runTests
-                                diff
+                                evalCfg
                                 (st, fp)
                                 tests
 
@@ -340,11 +340,11 @@ testsBySection sections =
 
 type TEnv = (IdeState, String)
 
-runTests :: Bool -> TEnv -> [(Section, Test)] -> Ghc [TextEdit]
-runTests diff e@(_st, _) tests = do
+runTests :: EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit]
+runTests EvalConfig{..} e@(_st, _) tests = do
     df <- getInteractiveDynFlags
     evalSetup
-    when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals e df propSetup
+    when (hasQuickCheck df && needsQuickCheck tests) $ void $ evals True e df propSetup
 
     mapM (processTest e df) tests
   where
@@ -356,7 +356,7 @@ runTests diff e@(_st, _) tests = do
         rs <- runTest e df test
         dbg "TEST RESULTS" rs
 
-        let checkedResult = testCheck diff (section, test) rs
+        let checkedResult = testCheck eval_cfg_diff (section, test) rs
 
         let edit = asEdit (sectionFormat section) test (map pad checkedResult)
         dbg "TEST EDIT" edit
@@ -368,7 +368,7 @@ runTests diff e@(_st, _) tests = do
             return $
                 singleLine
                     "Add QuickCheck to your cabal dependencies to run this test."
-    runTest e df test = evals e df (asStatements test)
+    runTest e df test = evals (eval_cfg_exception && not (isProperty test)) e df (asStatements test)
 
 asEdit :: Format -> Test -> [Text] -> TextEdit
 asEdit (MultiLine commRange) test resultLines
@@ -419,15 +419,19 @@ Nothing is returned for an empty line:
 A, possibly multi line, error is returned for a wrong declaration, directive or value or an exception thrown by the evaluated code:
 
 >>>:set -XNonExistent
-Unknown extension: "NonExistent"
+Some flags have not been recognized: -XNonExistent
 
 >>> cls C
-Variable not in scope: cls :: t0 -> ()
+Variable not in scope: cls :: t0 -> t
 Data constructor not in scope: C
 
 >>> "A
 lexical error in string/character literal 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
+get proper IO support. See #1977
+
 >>> 3 `div` 0
 divide by zero
 
@@ -438,10 +442,10 @@ 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)
+No instance for (Show V) arising from a use of ‘evalPrint’
 -}
-evals :: TEnv -> DynFlags -> [Statement] -> Ghc [Text]
-evals (st, fp) df stmts = do
+evals :: Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text]
+evals mark_exception (st, fp) df stmts = do
     er <- gStrictTry $ mapM eval stmts
     return $ case er of
         Left err -> errorLines err
@@ -488,9 +492,9 @@ evals (st, fp) df stmts = do
             do
                 dbg "{STMT " stmt
                 res <- exec stmt l
-                r <- case res of
-                    Left err -> return . Just . errorLines $ err
-                    Right x  -> return $ singleLine <$> x
+                let r = case res of
+                        Left err -> Just . (if mark_exception then exceptionLines else errorLines) $ err
+                        Right x  -> singleLine <$> x
                 dbg "STMT} -> " r
                 return r
         | -- An import
@@ -556,6 +560,15 @@ errorLines =
         . T.lines
         . T.pack
 
+{- |
+ Convert exception messages to a list of text lines
+ Remove unnecessary information and mark it as exception.
+ We use '*** Exception:' to make it identical to doctest
+ output, see #2353.
+-}
+exceptionLines :: String -> [Text]
+exceptionLines = (ix 0 %~ ("*** Exception: " <>)) . errorLines
+
 {- |
 >>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""])
 ["--2+2","--<BLANKLINE>"]

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

@@ -3,7 +3,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Ide.Plugin.Eval.Config
   ( properties
-  , getDiffProperty
+  , getEvalConfig
+  , EvalConfig(..)
   ) where
 
 import           Ide.Plugin.Config     (Config)
@@ -12,10 +13,25 @@ import           Ide.PluginUtils       (usePropertyLsp)
 import           Ide.Types             (PluginId)
 import           Language.LSP.Server   (MonadLsp)
 
-properties :: Properties '[ 'PropertyKey "diff" 'TBoolean]
+-- | The Eval plugin configuration. (see 'properties')
+data EvalConfig = EvalConfig
+  { eval_cfg_diff       :: Bool
+  , eval_cfg_exception  :: Bool
+  }
+  deriving (Eq, Ord, Show)
+
+properties :: Properties
+    '[ 'PropertyKey "exception" 'TBoolean
+     , 'PropertyKey "diff" 'TBoolean
+     ]
 properties = emptyProperties
   & defineBooleanProperty #diff
     "Enable the diff output (WAS/NOW) of eval lenses" True
+  & defineBooleanProperty #exception
+    "Enable marking exceptions with `*** Exception:` similarly to doctest and GHCi." False
 
-getDiffProperty :: (MonadLsp Config m) => PluginId -> m Bool
-getDiffProperty plId = usePropertyLsp #diff plId properties
+getEvalConfig :: (MonadLsp Config m) => PluginId -> m EvalConfig
+getEvalConfig plId =
+    EvalConfig
+    <$> usePropertyLsp #diff plId properties
+    <*> usePropertyLsp #exception plId properties

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

@@ -12,7 +12,7 @@ import           Control.Lens            (_Just, folded, preview, toListOf,
                                           view, (^..))
 import           Data.Aeson              (Value (Object), fromJSON, object,
                                           toJSON, (.=))
-import           Data.Aeson.Types        (Result (Success))
+import           Data.Aeson.Types        (Result (Success), Pair)
 import           Data.List               (isInfixOf)
 import           Data.List.Extra         (nubOrdOn)
 import qualified Data.Map                as Map
@@ -76,7 +76,7 @@ tests =
            | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’"
            | otherwise -> "-- No instance for (Num [Char]) arising from a use of ‘+’"
       evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input"
-      evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero"
+      evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero" -- The default for marking exceptions is False
   , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs"
   , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
   , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
@@ -133,6 +133,7 @@ tests =
   , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs"
   , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs"
   , goldenWithEval "Property checking" "TProperty" "hs"
+  , goldenWithEval "Property checking with exception" "TPropertyError" "hs"
   , goldenWithEval "Prelude has no special treatment, it is imported as stated in the module" "TPrelude" "hs"
   , goldenWithEval "Don't panic on {-# UNPACK #-} pragma" "TUNPACK" "hs"
   , goldenWithEval "Can handle eval inside nested comment properly" "TNested" "hs"
@@ -148,12 +149,12 @@ tests =
     ]
   , goldenWithEval "Works with NoImplicitPrelude" "TNoImplicitPrelude" "hs"
   , goldenWithEval "Variable 'it' works" "TIt" "hs"
-
-  , goldenWithHaskellDoc evalPlugin "Give 'WAS' by default" testDataDir "TDiff" "expected.default" "hs" executeLensesBackwards
-  , goldenWithHaskellDoc evalPlugin "Give the result only if diff is off" testDataDir "TDiff" "expected.no-diff" "hs" $ \doc -> do
-      sendConfigurationChanged (toJSON diffOffConfig)
-      executeLensesBackwards doc
-
+  , testGroup "configuration"
+    [ goldenWithEval' "Give 'WAS' by default" "TDiff" "hs" "expected.default"
+    , goldenWithEvalConfig' "Give the result only if diff is off" "TDiff" "hs" "expected.no-diff" diffOffConfig
+    , goldenWithEvalConfig' "Evaluates to exception (not marked)" "TException" "hs" "expected.nomark" (exceptionConfig False)
+    , goldenWithEvalConfig' "Evaluates to exception (with mark)" "TException" "hs" "expected.marked" (exceptionConfig True)
+    ]
   , testGroup ":info command"
     [ testCase ":info reports type, constructors and instances" $ do
         [output] <- map (unlines . codeLensTestOutput) <$> evalLenses "TInfo.hs"
@@ -263,16 +264,28 @@ codeLensTestOutput codeLens = do
 testDataDir :: FilePath
 testDataDir = "test" </> "testdata"
 
-diffOffConfig :: Config
-diffOffConfig =
+changeConfig :: [Pair] -> Config
+changeConfig conf =
   def
     { Plugin.plugins = Map.fromList [("eval",
-        def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object ["diff" .= False] }
+        def { Plugin.plcGlobalOn = True, Plugin.plcConfig = unObject $ object conf }
     )] }
   where
     unObject (Object obj) = obj
     unObject _            = undefined
 
+diffOffConfig :: Config
+diffOffConfig = changeConfig ["diff" .= False]
+
+exceptionConfig :: Bool -> Config
+exceptionConfig exCfg = changeConfig ["exception" .= exCfg]
+
+goldenWithEvalConfig' :: TestName -> FilePath -> FilePath -> FilePath -> Config -> TestTree
+goldenWithEvalConfig' title path ext expected cfg =
+    goldenWithHaskellDoc evalPlugin title testDataDir path expected ext $ \doc -> do
+      sendConfigurationChanged (toJSON cfg)
+      executeLensesBackwards doc
+
 evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO ()
 evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do
   doc <- openDoc fp "haskell"

plugins/hls-eval-plugin/test/testdata/TException.expected.marked.hs

@@ -0,0 +1,6 @@
+module TException where
+
+-- >>> exceptionalCode
+-- *** Exception: I am exceptional!
+exceptionalCode :: Int
+exceptionalCode = error "I am exceptional!"

plugins/hls-eval-plugin/test/testdata/TException.expected.nomark.hs

@@ -0,0 +1,6 @@
+module TException where
+
+-- >>> exceptionalCode
+-- I am exceptional!
+exceptionalCode :: Int
+exceptionalCode = error "I am exceptional!"

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

@@ -0,0 +1,5 @@
+module TException where
+
+-- >>> exceptionalCode
+exceptionalCode :: Int
+exceptionalCode = error "I am exceptional!"

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

@@ -0,0 +1,6 @@
+-- Support for property checking
+module TProperty where
+
+-- prop> \(l::[Bool]) -> head l
+-- *** Failed! Exception: 'Prelude.head: empty list' (after 1 test):
+-- []

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

@@ -0,0 +1,4 @@
+-- Support for property checking
+module TProperty where
+
+-- prop> \(l::[Bool]) -> head l