Graceful error handling in daml repl (#4673)

* Graceful error handling in `daml repl`

This PR changes `daml repl` to handle errors (parse errors, type
errors, unsupported statement errors, script errors) gracefully
and just emit an error message instead of tearing down the whole
process.

This gets the repl into a state where I think it’s sufficiently
user-friendly to be released (obviously there are tons of potential
improvements). The only thing missing before I’m comfortable
mentioning this in release notes and uninternalizing it are docs.
If you think there is something crucial that needs to be addressed
before, let me know.

changelog_begin
changelog_end

* why is windows

compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Repl.hs

@@ -4,8 +4,10 @@
 module DA.Daml.Compiler.Repl (runRepl) where
 
 import qualified "zip-archive" Codec.Archive.Zip as Zip
-import Control.Exception
+import Control.Exception hiding (TypeError)
 import Control.Monad
+import Control.Monad.Except
+import Control.Monad.Trans.Maybe
 import qualified               DA.Daml.LF.Ast as LF
 import qualified               DA.Daml.LF.Proto3.Archive as LFArchive
 import DA.Daml.LF.Reader (readDalfs, Dalfs(..))
@@ -13,18 +15,19 @@ import qualified               DA.Daml.LF.ReplClient as ReplClient
 import DA.Daml.LFConversion.UtilGHC
 import DA.Daml.Options.Types
 import qualified               Data.ByteString.Lazy as BSL
-import Data.Data (toConstr)
 import Data.Foldable
 import Data.Maybe
 import qualified               Data.NameMap as NM
 import Data.Text (Text)
 import qualified               Data.Text as T
 import Development.IDE.Core.API
+import Development.IDE.Core.Rules
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.RuleTypes.Daml
 import Development.IDE.Core.Shake
 import Development.IDE.GHC.Util
 import Development.IDE.Types.Location
+import ErrUtils
 import GHC
 import HsExpr (Stmt, StmtLR(..), LHsExpr)
 import HsExtension (GhcPs, GhcTc)
@@ -40,6 +43,25 @@ import System.IO.Error
 import System.IO.Extra
 import Type
 
+data Error
+    = ParseError MsgDoc
+    | UnsupportedStatement String -- ^ E.g., pattern on the LHS
+    | TypeError -- ^ The actual error will be in the diagnostics
+    | ScriptError ReplClient.BackendError
+
+renderError :: DynFlags -> Error -> IO ()
+renderError dflags err = case err of
+    ParseError err ->
+        putStrLn (showSDoc dflags err)
+    (UnsupportedStatement str) ->
+        putStrLn ("Unsupported statement: " <> str)
+    TypeError ->
+        -- ^ The error will be displayed via diagnostics.
+        pure ()
+    (ScriptError _err) ->
+        -- ^ The error will be displayed by the script runner.
+        pure ()
+
 -- | Split a statement into the name of the binder (patterns are not supported)
 -- and the body. For unsupported statements we return `Nothing`.
 splitStmt :: Stmt GhcPs (LHsExpr GhcPs) -> Maybe (Maybe Text, LHsExpr GhcPs)
@@ -67,6 +89,35 @@ runRepl opts mainDar replClient ideState = do
             Right _ -> pure ()
     go moduleNames 0 []
   where
+    handleLine
+        :: [LF.ModuleName]
+        -> [(Text, Type)]
+        -> DynFlags
+        -> String
+        -> Int
+        -> IO (Either Error (Maybe Text, Type))
+    handleLine moduleNames binds dflags l i = runExceptT $ do
+        stmt <- case parseStatement l dflags of
+            POk _ lStmt -> pure (unLoc lStmt)
+            PFailed _ _ errMsg -> throwError (ParseError errMsg)
+        (mbBind, expr) <- maybe (throwError (UnsupportedStatement l)) pure (splitStmt stmt)
+        liftIO $ writeFileUTF8 (fromNormalizedFilePath $ lineFilePath i)
+            (renderModule dflags moduleNames i binds expr)
+        -- Useful for debugging, probably best to put it behind a --debug flag
+        -- rendered <- liftIO  $readFileUTF8 (fromNormalizedFilePath $ lineFilePath i)
+        -- liftIO $ for_ (lines rendered) $ \line ->
+        --     hPutStrLn stderr ("> " <> line)
+        (lfMod, tmrModule -> tcMod) <-
+            maybe (throwError TypeError) pure =<< liftIO (runAction ideState $ runMaybeT $
+            (,) <$> useE GenerateDalf (lineFilePath i)
+                <*> useE TypeCheck (lineFilePath i))
+        -- Type of the statement so we can give it a type annotation
+        -- and avoid incurring a typeclass constraint.
+        stmtTy <- maybe (throwError TypeError) pure (exprTy $ tm_typechecked_source tcMod)
+        scriptRes <- liftIO $ ReplClient.runScript replClient (optDamlLfVersion opts) lfMod
+        case scriptRes of
+            Right _ -> pure (mbBind, stmtTy)
+            Left err -> throwError (ScriptError err)
     go :: [LF.ModuleName] -> Int -> [(T.Text, Type)] -> IO ()
     go moduleNames !i !binds = do
          putStr "daml> "
@@ -75,32 +126,14 @@ runRepl opts mainDar replClient ideState = do
          dflags <-
              hsc_dflags . hscEnv <$>
              runAction ideState (use_ GhcSession $ lineFilePath i)
-         POk _ (unLoc -> stmt) <- pure (parseStatement l dflags)
-         let !(mbBind, expr) = fromMaybe (fail ("Unsupported statement type: " <> show (toConstr stmt))) (splitStmt stmt)
-         writeFileUTF8 (fromNormalizedFilePath $ lineFilePath i)
-             (renderModule dflags moduleNames i binds expr)
-         -- Useful for debugging, probably best to put it behind a --debug flag
-         -- rendered <- readFileUTF8 (fromNormalizedFilePath $ lineFilePath i)
-         -- for_ (lines rendered) $ \line ->
-         --     hPutStrLn stderr ("> " <> line)
-
-         -- TODO Handle failures here cracefully instead of
-         -- tearing down the whole process.
-         Just lfMod <- runAction ideState $ use GenerateDalf (lineFilePath i)
-         Just (tmrModule -> tcMod) <- runAction ideState $ use TypeCheck (lineFilePath i)
-         -- We need type annotations to avoid things becoming polymorphic.
-         -- If we end up with a typeclass constraint on `expr` things
-         -- will go wrong.
-         Just ty <- pure $ exprTy $ tm_typechecked_source tcMod
-
-         r <- ReplClient.runScript replClient (optDamlLfVersion opts) lfMod
+         r <- handleLine moduleNames binds dflags l i
          case r of
-             Right _ -> pure ()
              Left err -> do
-                 hPutStrLn stderr ("Script produced an error: " <> show err)
-                 -- TODO don’t kill the whole process
-                 exitFailure
-
+                 renderError dflags err
+                 -- If we get an error we don’t increment i and we
+                 -- do not get a new binding
+                 go moduleNames i binds
+             Right (mbBind, ty) -> do
                  let shadow bind
                        | Just newBind  <- mbBind, bind == newBind = "_"
                        | otherwise = bind

compiler/damlc/tests/src/DA/Test/Repl.hs

@@ -62,6 +62,44 @@ main = do
                   , input "debug x"
                   , matchOutput "^.*: 2$"
                   ]
+            , testInteraction' "parse error"
+                  [ input "eaiu\\1"
+                  , matchOutput "^parse error.*$"
+                  , input "debug 1"
+                  , matchOutput "^.*: 1"
+                  ]
+            , testInteraction' "unsupported statement"
+                  [ input "(x, y) <- pure (1, 2)"
+                  , matchOutput "^Unsupported statement:.*$"
+                  , input "debug 1"
+                  , matchOutput "^.*: 1"
+                  ]
+            , testInteraction' "type error"
+                  [ input "1"
+                  -- TODO Make this less noisy
+                  , matchOutput "^File:.*$"
+                  , matchOutput "^Hidden:.*$"
+                  , matchOutput "^Range:.*$"
+                  , matchOutput "^Source:.*$"
+                  , matchOutput "^Severity:.*$"
+                  , matchOutput "^Message:.*$"
+                  , matchOutput "^.*error.*$"
+                  , matchOutput "^.*expected type .*Script _.* with actual type .*Int.*$"
+                  , matchOutput "^.*$"
+                  , matchOutput "^.*$"
+                  , matchOutput "^.*$"
+                  , matchOutput "^.*$"
+                  , input "debug 1"
+                  , matchOutput "^.*: 1"
+                  ]
+            , testInteraction' "script error"
+                  [ input "alice <- allocateParty \"Alice\""
+                  , input "bob <- allocateParty \"Bob\""
+                  , input "submit alice (createCmd (T alice bob))"
+                  , matchOutput "^.*Submit failed.*requires authorizers.*but only.*were given.*$"
+                  , input "debug 1"
+                  , matchOutput "^.*: 1"
+                  ]
             ]
 
 testInteraction :: FilePath -> Int -> FilePath -> FilePath -> [Step] -> Assertion

compiler/repl-service/client/src/DA/Daml/LF/ReplClient.hs

@@ -10,6 +10,7 @@ module DA.Daml.LF.ReplClient
   , withReplClient
   , loadPackage
   , runScript
+  , BackendError
   ) where
 
 import Control.Concurrent