From 4ae60ae8ad804d801e1092dbcbde1c93c0e1e96d Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Mon, 24 Feb 2020 16:58:23 +0100 Subject: [PATCH 1/2] Graceful error handling in `daml repl` MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- .../src/DA/Daml/Compiler/Repl.hs | 93 +++++++++++++------ compiler/damlc/tests/src/DA/Test/Repl.hs | 38 ++++++++ .../client/src/DA/Daml/LF/ReplClient.hs | 1 + 3 files changed, 102 insertions(+), 30 deletions(-) diff --git a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Repl.hs b/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Repl.hs index 408014c5ad59..e090ac162670 100644 --- a/compiler/damlc/daml-compiler/src/DA/Daml/Compiler/Repl.hs +++ b/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,36 +126,18 @@ 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 - - let shadow bind - | Just newBind <- mbBind, bind == newBind = "_" - | otherwise = bind - go moduleNames (i + 1 :: Int) (map (\(bind, ty) -> (shadow bind, ty)) binds <> [(fromMaybe "_" mbBind, ty)]) + 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 + go moduleNames (i + 1 :: Int) (map (\(bind, ty) -> (shadow bind, ty)) binds <> [(fromMaybe "_" mbBind, ty)]) exprTy :: LHsBinds GhcTc -> Maybe Type exprTy binds = listToMaybe diff --git a/compiler/damlc/tests/src/DA/Test/Repl.hs b/compiler/damlc/tests/src/DA/Test/Repl.hs index eff70c0da036..4d0c604daeb7 100644 --- a/compiler/damlc/tests/src/DA/Test/Repl.hs +++ b/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 diff --git a/compiler/repl-service/client/src/DA/Daml/LF/ReplClient.hs b/compiler/repl-service/client/src/DA/Daml/LF/ReplClient.hs index 305712e36ef9..89570b969771 100644 --- a/compiler/repl-service/client/src/DA/Daml/LF/ReplClient.hs +++ b/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 From 524a66b6c50a462424e5d97ecc4ca5c53392d516 Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Mon, 24 Feb 2020 17:46:25 +0100 Subject: [PATCH 2/2] why is windows --- compiler/damlc/tests/src/DA/Test/Repl.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/damlc/tests/src/DA/Test/Repl.hs b/compiler/damlc/tests/src/DA/Test/Repl.hs index 4d0c604daeb7..18f4549fa87d 100644 --- a/compiler/damlc/tests/src/DA/Test/Repl.hs +++ b/compiler/damlc/tests/src/DA/Test/Repl.hs @@ -84,7 +84,7 @@ main = do , matchOutput "^Severity:.*$" , matchOutput "^Message:.*$" , matchOutput "^.*error.*$" - , matchOutput "^.*expected type .Script _. with actual type .Int..*$" + , matchOutput "^.*expected type .*Script _.* with actual type .*Int.*$" , matchOutput "^.*$" , matchOutput "^.*$" , matchOutput "^.*$"