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..18f4549fa87d 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