eval: update readme; clean code; fix some bugs

- Correctly treat empty output or result when combining both
- Do not handle blank lines in any special way
- Update Readme of `hls-eval-plugin`

Author: dschrempf

plugins/hls-eval-plugin/README.md

@@ -259,41 +259,19 @@ This is a problem if you want, for example, to pretty print a value (in this cas
 "[ 1\n, 2\n, 3\n]"
 ```
 
-We could try to print the pretty-print output, but stdout is not captured so we get just a ():
-
-```
->>> print $ pShowNoColor [1..7]
-()
-```
-
-To display it properly, we can exploit the fact that the output of an error is displayed as a multi-line text:
-
+Instead, we can do
 ```
->>> import qualified Data.Text.Lazy as TL
->>> import Text.Pretty.Simple
->>> prettyPrint v = error (TL.unpack $ pShowNoColor v) :: IO String
->>> prettyPrint [1..3]
-[ 1
-, 2
-, 3
-]
+>>> mapM_ putStrLn $ lines pShowNoColor [1..7]
+-- [ 1
+-- , 2
+-- , 3
+-- ]
 ```
 
-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.
 
-### Capturing Stdout
-
-Only the value of an IO expression is spliced in, not its output:
-
-```
->>> print "foo"
-()
-```
-
 ###  Marking exceptions
 
 When an exception is thrown it is not prefixed:

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

@@ -17,6 +17,7 @@ import           Control.Lens                ((^.))
 import           Control.Monad.Catch         (MonadMask, bracket)
 import           Control.Monad.IO.Class
 import           Data.Algorithm.Diff         (Diff, PolyDiff (..), getDiff)
+import           Data.List                   (dropWhileEnd)
 import qualified Data.List.NonEmpty          as NE
 import           Data.Maybe                  (listToMaybe)
 import           Data.String                 (IsString)
@@ -45,7 +46,6 @@ evalExprRanges tst =
         resLine = startLine + exprLines
      in ( Range
             (Position startLine 0)
-            --(Position (startLine + exprLines + resultLines) 0),
             (Position resLine 0)
         , Range (Position resLine 0) (Position (resLine + resultLines) 0)
         )
@@ -54,16 +54,15 @@ evalExprRanges tst =
 resultRange :: EvalExpr -> Range
 resultRange = snd . evalExprRanges
 
--- TODO: handle BLANKLINE
-{-
->>> showDiffs $  getDiff ["abc","def","ghi","end"] ["abc","def","Z","ZZ","end"]
+{- |
+>>> showDiffs $ getDiff ["abc" :: String,"def","ghi","end"] ["abc","def","Z","ZZ","end"]
 ["abc","def","WAS ghi","NOW Z","NOW ZZ","end"]
 -}
 showDiffs :: (Semigroup a, IsString a) => [Diff a] -> [a]
 showDiffs = map showDiff
 
 showDiff :: (Semigroup a, IsString a) => Diff a -> a
-showDiff (First w)  = "WAS " <> w
+showDiff (First  w) = "WAS " <> w
 showDiff (Second w) = "NOW " <> w
 showDiff (Both w _) = w
 
@@ -78,8 +77,13 @@ showDiff (Both w _) = w
 -- this, identical multi-line results would be reported as entirely changed.
 evalExprCheck :: Bool -> (Section, EvalExpr) -> [T.Text] -> [T.Text]
 evalExprCheck diff (section, evalExpr) out
-    | not diff || null (evalExprOutput evalExpr) || sectionLanguage section == Plain = outLines
-    | otherwise = showDiffs $ getDiff (map T.pack $ evalExprOutput evalExpr) outLines
+    |  not diff
+    || null (evalExprOutput evalExpr)
+    || sectionLanguage section == Plain =
+        outLines
+    | otherwise =
+        showDiffs $
+          getDiff (map T.pack $ evalExprOutput evalExpr) outLines
   where
     outLines = concatMap T.lines out
 
@@ -88,7 +92,7 @@ evalExprLengths :: EvalExpr -> (Int, Int)
 evalExprLengths (Example e r _)  = (NE.length e, length r)
 evalExprLengths (Property _ r _) = (1, length r)
 
--- |A one-line Haskell statement
+-- | A one-line Haskell statement
 type Statement = Loc String
 
 -- | The Haskell statements to feed to GHCi for an 'EvalExpr', each tagged with
@@ -121,14 +125,27 @@ execStmtCaptureResult recorder stmt opts = do
       Right (ExecComplete (Left err) _) ->
         pure $ Left $ show err
       Right (ExecComplete (Right _) _) -> do
-        pure $ Right $ toMaybe (output <> result)
+        pure $ Right $ toMaybe (combine output result)
       Right ExecBreak{} ->
         pure $ Right $ Just "breakpoints are not supported"
   where
     toMaybe :: String -> Maybe String
     toMaybe x | null x    = Nothing
               | otherwise = Just x
 
+    -- Join the captured stdout/stderr output with the result value. GHC
+    -- diagnostics (e.g. warnings) written to stderr end with a trailing blank
+    -- line; drop trailing newlines so output and result are separated by a
+    -- single newline rather than a spurious blank line (which would otherwise
+    -- surface unexpectedly in the rendered result).
+    combine :: String -> String -> String
+    combine output result
+        | null trimmed = result
+        | null result = trimmed
+        | otherwise    = trimmed <> "\n" <> result
+      where
+        trimmed = dropWhileEnd (== '\n') output
+
 -- 'System.IO.Extra.withTempFile' is specialized to 'IO'.
 withTempFile :: (MonadIO m, MonadMask m) => (FilePath -> m b) -> m (String, b)
 withTempFile k = do
@@ -219,10 +236,10 @@ captureTeardown = unwords
 Example:
 
 prop> \(l::[Bool]) -> reverse (reverse l) == l
-+++ OK, passed 100 evalExprs.
++++ OK, passed 100 tests.
 
 prop> \(l::[Bool]) -> reverse l == l
-*** Failed! Falsified (after 6 evalExprs and 2 shrinks):
+*** Failed! Falsified (after 4 tests and 1 shrink):
 [True,False]
 -}
 propSetup :: [Loc [Char]]

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

@@ -30,41 +30,12 @@ import           GHC                             (setTopSessionDynFlags,
 import           GHC.Driver.Env
 import           GHC.Driver.Session              (getDynFlags)
 
-{- $setup
->>> import GHC
->>> import GHC.Paths
->>> run act = runGhc (Just libdir) (getInteractiveDynFlags >>= act)
->>> libdir
-"/Users/titto/.ghcup/ghc/8.8.4/lib/ghc-8.8.4"
--}
-
-{- | True if specified package is present in DynFlags
-
--- >>> hasPackageTst pkg = run $ \df -> return (hasPackage df pkg)
->>> hasPackageTst pkg = run $ \_ -> addPackages [pkg] >>= return . either Left (\df -> Right (hasPackage df pkg))
-
->>> hasPackageTst "base"
-Right True
-
->>> hasPackageTst "ghc"
-Right True
-
->>> hasPackageTst "extra"
-Left "<command line>: cannot satisfy -package extra\n    (use -v for more information)"
-
->>> hasPackageTst "QuickCheck"
-Left "<command line>: cannot satisfy -package QuickCheck\n    (use -v for more information)"
--}
 hasPackage :: DynFlags -> String -> Bool
 hasPackage df = hasPackage_ (packageFlags df)
 
 hasPackage_ :: [PackageFlag] -> [Char] -> Bool
 hasPackage_ pkgFlags name = any (name `isPrefixOf`) (pkgNames_ pkgFlags)
 
-{- |
->>> run (return . pkgNames)
-[]
--}
 pkgNames :: DynFlags -> [String]
 pkgNames = pkgNames_ . packageFlags
 
@@ -77,27 +48,6 @@ pkgNames_ =
             _                                 -> Nothing
         )
 
-{- | Expose a list of packages.
->>> addPackagesTest pkgs = run (\_ -> (packageFlags <$>) <$> addPackages pkgs)
-
->>> addPackagesTest []
-Right []
-
->>> addPackagesTest ["base","base","array"]
-Right [-package base{package base True ([])},-package array{package array True ([])}]
-
->>> addPackagesTest ["Cabal"]
-Right [-package Cabal{package Cabal True ([])}]
-
->>> addPackagesTest ["QuickCheck"]
-Left "<command line>: cannot satisfy -package QuickCheck\n    (use -v for more information)"
-
->>> addPackagesTest ["base","notThere"]
-Left "<command line>: cannot satisfy -package notThere\n    (use -v for more information)"
-
-prop> \(x::Int) -> x + x == 2 * x
-+++ OK, passed 100 tests.
--}
 addPackages :: [String] -> Ghc (Either String DynFlags)
 addPackages pkgNames = gStrictTry $
     modifyFlags $ \df ->
@@ -111,37 +61,15 @@ modifyFlags f = do
     _ <- setSessionDynFlags (f df)
     getSessionDynFlags
 
--- modifyFlags f = do
---         modifyDynFlags f
---         getSessionDynFlags
-
-{- | Add import to evaluation context
-
->>> run $ \_ -> addImport "import Data.Maybe"
-Could not find module ‘Data.Maybe’
-Use -v (or `:set -v` in ghci) to see a list of the files searched for.
-
->>> run $ \df -> addPackages ["base"] >> addImport "import Data.Maybe"
-[import Data.Maybe]
-
->>> run $ \df -> addPackages ["base"] >> addImport "import qualified Data.Maybe as M"
-[import qualified Data.Maybe as M]
--}
+-- | Add import to evaluation context
 addImport :: GhcMonad m => String -> m [InteractiveImport]
 addImport i = do
     ctx <- getContext
-    -- dbgO "CONTEXT" ctx
     idecl <- parseImportDecl i
     setContext $ IIDecl idecl : ctx
-    -- ctx' <- getContext
-    -- dbg "CONTEXT'" ctx'
     getContext
 
-{- | Add extension to interactive evaluation session
->>> import GHC.LanguageExtensions.Type(Extension(..))
->>> run $ \_ -> addExtension DeriveGeneric
-()
--}
+-- | Add extension to interactive evaluation session
 addExtension :: GhcMonad m => Extension -> m ()
 addExtension ext =
     modifySession $ \hsc -> hsc{hsc_IC = setExtension (hsc_IC hsc) ext}
@@ -151,20 +79,16 @@ setExtension ic ext = ic{ic_dflags = xopt_set (ic_dflags ic) ext}
 
 deriving instance Read Extension
 
--- Partial display of DynFlags contents, for testing purposes
+-- | Partial display of DynFlags contents, for testing purposes
 showDynFlags :: DynFlags -> String
 showDynFlags df =
     T.unpack . printOutputable . vcat . map (\(n, d) -> text (n ++ ": ") <+> d) $
         [ ("extensions", ppr . extensions $ df)
         , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df)
         , ("importPaths", vList $ importPaths df)
         , ("generalFlags", pprHsString . fromString . show . EnumSet.toList . generalFlags $ df)
-        , -- , ("includePaths", text . show $ includePaths df)
-          -- ("packageEnv", ppr $ packageEnv df)
-          ("pkgNames", vcat . map text $ pkgNames df)
+        , ("pkgNames", vcat . map text $ pkgNames df)
         , ("packageFlags", vcat . map ppr $ packageFlags df)
-        -- ,("pkgDatabase",(map) (ppr . installedPackageId) . pkgDatabase $ df)
-        -- ("pkgDatabase", text . show <$> pkgDatabase $ df)
         ]
 
 vList :: [String] -> SDoc

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

@@ -372,31 +372,40 @@ type TEnv = String
 -- |GHC declarations required for expression evaluation
 evalSetup :: Ghc ()
 evalSetup = do
-    preludeAsP <- parseImportDecl "import qualified Prelude as P"
+    preludeAsP  <- parseImportDecl "import qualified Prelude as P"
     -- 'myExecStmt' redirects the interpreted @stdout@ and @stderr@ to a temporary
     -- file in order to capture output produced as a side effect of evaluating a
     -- statement. The setup and teardown statements it injects need these modules
     -- in scope.
-    systemIO <- parseImportDecl "import qualified System.IO"
+    systemIO    <- parseImportDecl "import qualified System.IO"
     ghcIOHandle <- parseImportDecl "import qualified GHC.IO.Handle"
-    context <- getContext
+    context     <- getContext
     setContext (IIDecl preludeAsP : IIDecl systemIO : IIDecl ghcIOHandle : context)
 
 -- | Evaluate every 'EvalExpr' and produce the 'TextEdit's that write the results
 -- back into the document, prefixing/padding each result line as the section's
 -- format requires.
-runEvalExprs :: Recorder (WithPriority Log) -> EvalConfig -> TEnv -> [(Section, EvalExpr)] -> Ghc [TextEdit]
+runEvalExprs ::
+     Recorder (WithPriority Log)
+  -> EvalConfig
+  -> TEnv
+  -> [(Section, EvalExpr)]
+  -> Ghc [TextEdit]
 runEvalExprs recorder EvalConfig{..} e evalExprs = do
     df <- getInteractiveDynFlags
     evalSetup
-    when (hasQuickCheck df && needsQuickCheck evalExprs) $ void $ evals recorder True e df propSetup
+    when (hasQuickCheck df && needsQuickCheck evalExprs) $
+      void $ evals recorder True e df propSetup
 
     mapM (processEvalExpr e df) evalExprs
   where
     processEvalExpr :: TEnv -> DynFlags -> (Section, EvalExpr) -> Ghc TextEdit
     processEvalExpr fp df (section, evalExpr) = do
         let dbg = logWith recorder Debug
-        let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section)
+            pre =
+              (if isLiterate fp then ("> " `T.append`) else id) $
+                padPrefix (sectionFormat section)
+            pad = T.append pre
         rs <- runEvalExpr e df evalExpr
         dbg $ LogRunEvalExprResults rs
 
@@ -406,13 +415,19 @@ runEvalExprs recorder EvalConfig{..} e evalExprs = do
         dbg $ LogRunEvalExprEdits edit
         return edit
 
-    -- runEvalExpr :: String -> DynFlags -> Loc EvalExpr -> Ghc [Text]
-    runEvalExpr _ df evalExpr
+    runEvalExpr :: String -> DynFlags -> EvalExpr -> Ghc [Text]
+    runEvalExpr e df evalExpr
         | not (hasQuickCheck df) && isProperty evalExpr =
             return $
                 singleLine
                     "Add QuickCheck to your cabal dependencies to run this property."
-    runEvalExpr e df evalExpr = evals recorder (eval_cfg_exception && not (isProperty evalExpr)) e df (asStatements evalExpr)
+        | otherwise =
+            evals
+              recorder
+              (eval_cfg_exception && not (isProperty evalExpr))
+              e
+              df
+              (asStatements evalExpr)
 
 -- | Build the edit that replaces the old result of an 'EvalExpr' with
 -- @resultLines@. For an 'EvalExpr' that sits on the closing @-}@ line of a
@@ -608,13 +623,6 @@ exceptionLines = (ix 0 %~ ("*** Exception: " <>)) . errorLines
 >>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""])
 ["--2+2","--<BLANKLINE>"]
 -}
-pad_ :: Text -> Text -> Text
-pad_ prefix = (prefix `T.append`) . convertBlank
-
-convertBlank :: Text -> Text
-convertBlank x
-    | T.null x = "<BLANKLINE>"
-    | otherwise = x
 
 padPrefix :: IsString p => Format -> p
 padPrefix SingleLine = "-- "

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

@@ -156,17 +156,17 @@ hasPropertyEvalExpr = any isProperty . sectionEvalExprs
 splitSections :: [Section] -> ([Section], [Section])
 splitSections = partition ((== "setup") . sectionName)
 
-data EvalExpr
-    = Example {
+data EvalExpr =
+      Example {
           evalExprLines  :: NonEmpty Txt
         , evalExprOutput :: [Txt]
         , evalExprRange  :: Range
         }
     | Property {
-        evalExprLine   :: Txt
-      , evalExprOutput :: [Txt]
-      , evalExprRange  :: Range
-      }
+          evalExprLine   :: Txt
+        , evalExprOutput :: [Txt]
+        , evalExprRange  :: Range
+        }
     deriving (Eq, Show, Generic, FromJSON, ToJSON, NFData)
 
 data IsEvaluating = IsEvaluating