Eval plugin: add exception configuration

Author: xsebek

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

@@ -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,8 +340,8 @@ 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 True e df propSetup
@@ -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 (isProperty test) 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,29 +419,33 @@ 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
-*** Exception: divide by zero
+divide by zero
 
 >>> error "Something went wrong\nbad times" :: E.SomeException
-*** Exception: Something went wrong
+Something went wrong
 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 :: Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text]
-evals property (st, fp) df stmts = do
+evals mark_exception (st, fp) df stmts = do
     er <- gStrictTry $ mapM eval stmts
     return $ case er of
         Left err -> errorLines err
@@ -489,7 +493,7 @@ evals property (st, fp) df stmts = do
                 dbg "{STMT " stmt
                 res <- exec stmt l
                 let r = case res of
-                        Left err -> Just . (if property then errorLines else exceptionLines) $ err
+                        Left err -> Just . (if mark_exception then exceptionLines else errorLines) $ err
                         Right x  -> singleLine <$> x
                 dbg "STMT} -> " r
                 return r

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,8 +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" "-- *** Exception: divide by zero"
-  , goldenWithEval "Evaluates to exception" "TException" "hs"
+      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")
@@ -150,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"
@@ -265,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.hs renamed to plugins/hls-eval-plugin/test/testdata/TException.expected.marked.hs

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