Eval plugin: mark exceptions

Author: Ondrej Sebek

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)
@@ -344,7 +344,7 @@ runTests :: Bool -> TEnv -> [(Section, Test)] -> Ghc [TextEdit]
 runTests diff 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
@@ -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 (isProperty test) e df (asStatements test)
 
 asEdit :: Format -> Test -> [Text] -> TextEdit
 asEdit (MultiLine commRange) test resultLines
@@ -440,8 +440,8 @@ Or for a value that does not have a Show instance and can therefore not be displ
 >>> V
 No instance for (Show V)
 -}
-evals :: TEnv -> DynFlags -> [Statement] -> Ghc [Text]
-evals (st, fp) df stmts = do
+evals :: Bool -> TEnv -> DynFlags -> [Statement] -> Ghc [Text]
+evals property (st, fp) df stmts = do
     er <- gStrictTry $ mapM eval stmts
     return $ case er of
         Left err -> errorLines err
@@ -488,9 +488,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 property then errorLines else exceptionLines) $ err
+                        Right x  -> singleLine <$> x
                 dbg "STMT} -> " r
                 return r
         | -- An import
@@ -556,6 +556,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/test/Main.hs

@@ -76,7 +76,8 @@ 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" "-- *** Exception: divide by zero"
+  , goldenWithEval "Evaluates to exception" "TException" "hs"
   , 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 +134,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"

plugins/hls-eval-plugin/test/testdata/TException.expected.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.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