mirror of
https://github.com/digital-asset/daml.git
synced 2024-09-20 01:07:18 +03:00
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
This commit is contained in:
parent
500fb9a171
commit
2a05611b63
@ -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
|
||||
|
@ -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
|
||||
|
@ -10,6 +10,7 @@ module DA.Daml.LF.ReplClient
|
||||
, withReplClient
|
||||
, loadPackage
|
||||
, runScript
|
||||
, BackendError
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
|
Loading…
Reference in New Issue
Block a user