From 1314748ec8d5b37a58409114cd673a2208256494 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= <44544735+xsebek@users.noreply.github.com> Date: Sun, 20 Mar 2022 20:35:04 +0100 Subject: [PATCH] Eval plugin: mark exceptions (#2775) --- docs/configuration.md | 3 ++ plugins/hls-eval-plugin/README.md | 25 ++++++++++ .../src/Ide/Plugin/Eval/CodeLens.hs | 47 ++++++++++++------- .../src/Ide/Plugin/Eval/Config.hs | 24 ++++++++-- plugins/hls-eval-plugin/test/Main.hs | 35 +++++++++----- .../testdata/TException.expected.marked.hs | 6 +++ .../testdata/TException.expected.nomark.hs | 6 +++ .../test/testdata/TException.hs | 5 ++ .../test/testdata/TPropertyError.expected.hs | 6 +++ .../test/testdata/TPropertyError.hs | 4 ++ 10 files changed, 129 insertions(+), 32 deletions(-) create mode 100644 plugins/hls-eval-plugin/test/testdata/TException.expected.marked.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TException.expected.nomark.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TException.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs create mode 100644 plugins/hls-eval-plugin/test/testdata/TPropertyError.hs diff --git a/docs/configuration.md b/docs/configuration.md index 76d8623764..5b37f6c290 100644 --- a/docs/configuration.md +++ b/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 ` 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. diff --git a/plugins/hls-eval-plugin/README.md b/plugins/hls-eval-plugin/README.md index b537dd6017..b1a50f0705 100644 --- a/plugins/hls-eval-plugin/README.md +++ b/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. diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 905d6f9197..3ed51b0e29 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/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","--"] diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs index fc3dea26d4..ca7b0cca9b 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Config.hs +++ b/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 diff --git a/plugins/hls-eval-plugin/test/Main.hs b/plugins/hls-eval-plugin/test/Main.hs index 2830815fe7..cd334c2693 100644 --- a/plugins/hls-eval-plugin/test/Main.hs +++ b/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" diff --git a/plugins/hls-eval-plugin/test/testdata/TException.expected.marked.hs b/plugins/hls-eval-plugin/test/testdata/TException.expected.marked.hs new file mode 100644 index 0000000000..3e655416e6 --- /dev/null +++ b/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!" diff --git a/plugins/hls-eval-plugin/test/testdata/TException.expected.nomark.hs b/plugins/hls-eval-plugin/test/testdata/TException.expected.nomark.hs new file mode 100644 index 0000000000..9ac7cd03a3 --- /dev/null +++ b/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!" diff --git a/plugins/hls-eval-plugin/test/testdata/TException.hs b/plugins/hls-eval-plugin/test/testdata/TException.hs new file mode 100644 index 0000000000..5e083ab1dd --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TException.hs @@ -0,0 +1,5 @@ +module TException where + +-- >>> exceptionalCode +exceptionalCode :: Int +exceptionalCode = error "I am exceptional!" diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.expected.hs new file mode 100644 index 0000000000..46359c86ab --- /dev/null +++ b/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): +-- [] diff --git a/plugins/hls-eval-plugin/test/testdata/TPropertyError.hs b/plugins/hls-eval-plugin/test/testdata/TPropertyError.hs new file mode 100644 index 0000000000..4d70e738f3 --- /dev/null +++ b/plugins/hls-eval-plugin/test/testdata/TPropertyError.hs @@ -0,0 +1,4 @@ +-- Support for property checking +module TProperty where + +-- prop> \(l::[Bool]) -> head l