From f6d5b6e4328bcda52417d267c7f7d97f1f601aef Mon Sep 17 00:00:00 2001 From: jmcardon Date: Wed, 4 Sep 2024 19:10:45 -0400 Subject: [PATCH] Core: simplify parser further, remove do keyword --- pact-tests/Pact/Core/Test/LexerParserTests.hs | 10 +- pact-tests/Pact/Core/Test/StaticErrorTests.hs | 73 ++++++- .../DesugarError.golden | 21 +- pact-tests/gas-goldens/builtinGas.golden | 2 +- pact-tests/pact-tests/yield.repl | 4 +- pact/Pact/Core/Errors.hs | 4 - pact/Pact/Core/IR/Desugar.hs | 199 +++--------------- pact/Pact/Core/IR/Eval/CEK.hs | 64 +----- pact/Pact/Core/IR/Eval/Direct/Evaluator.hs | 16 -- pact/Pact/Core/Serialise/CBOR_V1.hs | 12 -- pact/Pact/Core/Syntax/LexUtils.hs | 4 +- pact/Pact/Core/Syntax/Lexer.x | 2 +- pact/Pact/Core/Syntax/ParseTree.hs | 56 +---- pact/Pact/Core/Syntax/Parser.y | 77 ++----- 14 files changed, 148 insertions(+), 396 deletions(-) diff --git a/pact-tests/Pact/Core/Test/LexerParserTests.hs b/pact-tests/Pact/Core/Test/LexerParserTests.hs index 20ffe6f90..af753281c 100644 --- a/pact-tests/Pact/Core/Test/LexerParserTests.hs +++ b/pact-tests/Pact/Core/Test/LexerParserTests.hs @@ -135,10 +135,10 @@ exprGen = Gen.recursive Gen.choice [ Gen.subtermM exprGen $ \x -> do xs <- Gen.list (Range.linear 0 8) exprGen pure $ Lisp.App x xs () - , (`Lisp.Block` ()) <$> Gen.nonEmpty (Range.linear 1 8) (Gen.subterm exprGen id) + -- , (`Lisp.Block` ()) <$> Gen.nonEmpty (Range.linear 1 8) (Gen.subterm exprGen id) , (`Lisp.List` ()) <$> Gen.list (Range.linear 1 8) (Gen.subterm exprGen id) , lamGen - , Gen.subtermM exprGen letGen + , letGen ] where lamGen = do @@ -146,11 +146,11 @@ exprGen = Gen.recursive Gen.choice i <- identGen ty <- Gen.maybe typeGen pure (Lisp.MArg i ty ()) - expr <- Gen.subterm exprGen id - pure $ Lisp.Lam par expr () + Lisp.Lam par <$> Gen.nonEmpty (Range.linear 1 8) exprGen <*> pure () - letGen inner = do + letGen = do binders <- Gen.nonEmpty (Range.constant 1 8) binderGen + inner <- Gen.nonEmpty (Range.linear 1 8) exprGen pure $ Lisp.Let LFLetNormal binders inner () typeGen :: Gen Lisp.Type diff --git a/pact-tests/Pact/Core/Test/StaticErrorTests.hs b/pact-tests/Pact/Core/Test/StaticErrorTests.hs index 8388d55dd..b527aa4ab 100644 --- a/pact-tests/Pact/Core/Test/StaticErrorTests.hs +++ b/pact-tests/Pact/Core/Test/StaticErrorTests.hs @@ -83,13 +83,66 @@ desugarTests = ) ) |]) - , ("enforce-one_no_list", isDesugarError _InvalidSyntax, [text| - (module m g (defcap g () true) - (defun enforce-cap () - (enforce-one "foo" 1) - ) - ) + , ("empty_if", isDesugarError _InvalidSyntax, [text| + (if) + |]) + + , ("if_invalid_args", isDesugarError _InvalidSyntax, [text| + (if 1) + |]) + + , ("empty_do", isDesugarError _InvalidSyntax, [text| + (do) + |]) + + , ("empty_with_cap", isDesugarError _InvalidSyntax, [text| + (with-capability) + |]) + + , ("one_arg_with_cap", isDesugarError _InvalidSyntax, [text| + (with-capability 1) + |]) + + , ("empty_enforce_one", isDesugarError _InvalidSyntax, [text| + (enforce-one) + |]) + + , ("one_arg_enforce_one", isDesugarError _InvalidSyntax, [text| + (enforce-one 1) + |]) + + , ("empty_suspend", isDesugarError _InvalidSyntax, [text| + (suspend) + |]) + + , ("n-ary_suspend", isDesugarError _InvalidSyntax, [text| + (suspend 2 3 4 5 6) + |]) + + , ("empty_cond", isDesugarError _InvalidSyntax, [text| + (cond) + |]) + + , ("invalid_cond", isDesugarError _InvalidSyntax, [text| + (cond 1 2 3) + |]) + + , ("empty_create-user-guard", isDesugarError _InvalidSyntax, [text| + (create-user-guard) + |]) + + , ("n-ary_create-user-guard", isDesugarError _InvalidSyntax, [text| + (create-user-guard 2 3 4 5 6) |]) + + , ("empty_try", isDesugarError _InvalidSyntax, [text| + (try) + |]) + + , ("n-ary_try", isDesugarError _InvalidSyntax, [text| + (try 2 3 4 5 6) + |]) + , ("managed_invalid", isDesugarError _InvalidManagedArg, [text| (module mgd-mod G (defcap G () true) @@ -561,6 +614,14 @@ executionTests = (module another ag (defcap ag () true)) |]) + , ("enforce-one_no_list", isExecutionError _NativeExecutionError, [text| + (enforce-one "asdf" 1) + |]) + + , ("user_guard_no_app", isExecutionError _NativeExecutionError, [text| + (create-user-guard 1) + |]) + , ("enforce_ns_install_interface", isExecutionError _NamespaceInstallError, [text| (module m g (defcap g () true) (defun manage (ns guard) true) diff --git a/pact-tests/constructor-tag-goldens/DesugarError.golden b/pact-tests/constructor-tag-goldens/DesugarError.golden index c11bd52d7..1036e4c5f 100644 --- a/pact-tests/constructor-tag-goldens/DesugarError.golden +++ b/pact-tests/constructor-tag-goldens/DesugarError.golden @@ -13,15 +13,14 @@ {"conName":"InvalidDefInTermVariable","conIndex":"c"} {"conName":"InvalidModuleReference","conIndex":"d"} {"conName":"EmptyBindingBody","conIndex":"e"} -{"conName":"EmptyDefPact","conIndex":"f"} -{"conName":"LastStepWithRollback","conIndex":"10"} -{"conName":"ExpectedFreeVariable","conIndex":"11"} -{"conName":"InvalidManagedArg","conIndex":"12"} -{"conName":"InvalidImports","conIndex":"13"} -{"conName":"InvalidImportModuleHash","conIndex":"14"} -{"conName":"InvalidSyntax","conIndex":"15"} -{"conName":"InvalidDefInSchemaPosition","conIndex":"16"} -{"conName":"InvalidDynamicInvoke","conIndex":"17"} -{"conName":"DuplicateDefinition","conIndex":"18"} -{"conName":"InvalidBlessedHash","conIndex":"19"} +{"conName":"LastStepWithRollback","conIndex":"f"} +{"conName":"ExpectedFreeVariable","conIndex":"10"} +{"conName":"InvalidManagedArg","conIndex":"11"} +{"conName":"InvalidImports","conIndex":"12"} +{"conName":"InvalidImportModuleHash","conIndex":"13"} +{"conName":"InvalidSyntax","conIndex":"14"} +{"conName":"InvalidDefInSchemaPosition","conIndex":"15"} +{"conName":"InvalidDynamicInvoke","conIndex":"16"} +{"conName":"DuplicateDefinition","conIndex":"17"} +{"conName":"InvalidBlessedHash","conIndex":"18"} diff --git a/pact-tests/gas-goldens/builtinGas.golden b/pact-tests/gas-goldens/builtinGas.golden index 87731ec5b..d9b7a6261 100644 --- a/pact-tests/gas-goldens/builtinGas.golden +++ b/pact-tests/gas-goldens/builtinGas.golden @@ -81,7 +81,7 @@ not: 139 not?: 139 or?: 139 pact-id: 60000271 -pairing-check: 67003096 +pairing-check: 67003097 parse-time: 2102 point-add: 5425 poseidon-hash-hack-a-chain: 6393700 diff --git a/pact-tests/pact-tests/yield.repl b/pact-tests/pact-tests/yield.repl index 5d93e36dd..2ea9804bf 100644 --- a/pact-tests/pact-tests/yield.repl +++ b/pact-tests/pact-tests/yield.repl @@ -92,7 +92,7 @@ ;; check events (expect "step 0 events" - [{"module-hash": "oKFbzkuEYAFhP-S2mW7hRvRJUPJf2FvMFy1CpxhGs4o" + [{"module-hash": "rmN99MpBmJbapgVRV3GjII6I4UUkl8k5pBF7-k92Lt8" ,"name": "pact.X_YIELD" ,"params": ["1" "yieldtest.cross-chain" ["emily"]]}] (env-events true)) @@ -106,7 +106,7 @@ ;; check events (expect "step 1 events" - [{"module-hash": "oKFbzkuEYAFhP-S2mW7hRvRJUPJf2FvMFy1CpxhGs4o" + [{"module-hash": "rmN99MpBmJbapgVRV3GjII6I4UUkl8k5pBF7-k92Lt8" ,"name": "pact.X_RESUME" ,"params": ["0" "yieldtest.cross-chain" ["emily"]]}] (env-events true)) diff --git a/pact/Pact/Core/Errors.hs b/pact/Pact/Core/Errors.hs index c23dad1e0..377e4f479 100644 --- a/pact/Pact/Core/Errors.hs +++ b/pact/Pact/Core/Errors.hs @@ -75,7 +75,6 @@ module Pact.Core.Errors , _InvalidDefInTermVariable , _InvalidModuleReference , _EmptyBindingBody - , _EmptyDefPact , _LastStepWithRollback , _ExpectedFreeVariable , _InvalidManagedArg @@ -306,8 +305,6 @@ data DesugarError -- ^ Invalid: Interface used as module reference | EmptyBindingBody -- ^ Binding form has no expressions to bind to - | EmptyDefPact Text - -- ^ Defpact without steps | LastStepWithRollback QualifiedName -- ^ Last Step has Rollback error | ExpectedFreeVariable Text @@ -372,7 +369,6 @@ instance Pretty DesugarError where InvalidModuleReference mn -> Pretty.hsep ["Invalid Interface attempted to be used as module reference:", pretty mn] EmptyBindingBody -> "Bind expression lacks an accompanying body" - EmptyDefPact dp -> Pretty.hsep ["Defpact has no steps:", pretty dp] LastStepWithRollback mn -> Pretty.hsep ["rollbacks aren't allowed on the last step in:", pretty mn] ExpectedFreeVariable t -> diff --git a/pact/Pact/Core/IR/Desugar.hs b/pact/Pact/Core/IR/Desugar.hs index 1c658caea..b34c5ee7b 100644 --- a/pact/Pact/Core/IR/Desugar.hs +++ b/pact/Pact/Core/IR/Desugar.hs @@ -138,32 +138,6 @@ class IsBuiltin b => DesugarBuiltin b where instance DesugarBuiltin CoreBuiltin where liftCoreBuiltin = id - -- desugarOperator info = \case - -- -- Manual eta expansion for and as well as Or - -- Lisp.AndOp -> let - -- arg1Name = "#andArg1" - -- arg1 = Arg arg1Name (Just (Lisp.TyPrim PrimBool)) info - -- arg2Name = "#andArg2" - -- arg2 = Arg arg2Name (Just (Lisp.TyPrim PrimBool)) info - -- in Lam (arg1 :| [arg2]) (BuiltinForm (CAnd (Var (BN (BareName arg1Name)) info) (Var (BN (BareName arg2Name)) info)) info) info - -- Lisp.OrOp -> let - -- arg1Name = "#orArg1" - -- arg1 = Arg arg1Name (Just (Lisp.TyPrim PrimBool)) info - -- arg2Name = "#orArg2" - -- arg2 = Arg arg2Name (Just (Lisp.TyPrim PrimBool)) info - -- in Lam (arg1 :| [arg2]) (BuiltinForm (COr (Var (BN (BareName arg1Name)) info) (Var (BN (BareName arg2Name)) info)) info) info - -- Lisp.EnforceOp -> let - -- arg1Name = "#enforceArg1" - -- arg1 = Arg arg1Name (Just (Lisp.TyPrim PrimBool)) info - -- arg2Name = "#enforceArg2" - -- arg2 = Arg arg2Name (Just (Lisp.TyPrim PrimString)) info - -- in Lam (arg1 :| [arg2]) (BuiltinForm (CEnforce (Var (BN (BareName arg1Name)) info) (Var (BN (BareName arg2Name)) info)) info) info - -- Lisp.EnforceOneOp -> let - -- arg1Name = "#enforceOneArg1" - -- arg1 = Arg arg1Name (Just (Lisp.TyPrim PrimString)) info - -- arg2Name = "#enforceOneArg2" - -- arg2 = Arg arg2Name (Just (Lisp.TyList (Lisp.TyPrim PrimBool))) info - -- in Lam (arg1 :| [arg2]) (BuiltinForm (CEnforceOne (Var (BN (BareName arg1Name)) info) [Var (BN (BareName arg2Name)) info]) info) info desugarAppArity = desugarCoreBuiltinArity id -- | Our general function for resolving builtin overloads @@ -174,23 +148,6 @@ desugarCoreBuiltinArity -> CoreBuiltin -> [Term name t builtin info] -> Term name t builtin info --- Todo: this presents a really, _really_ annoying case for the map overload :( --- Jose: I am unsure how to fix this so far, but it does not break any tests. --- that is: --- prod: --- pact> (map (- 1) [1, 2, 3]) --- [0 -1 -2] --- core: --- pact>(map (- 1) [1 2 3]) --- (interactive):1:0: Native evaluation error for native map, received incorrect argument(s) of type(s) [integer] , [list] --- 1 | (map (- 1) [1 2 3]) --- | ^^^^^^^^^^^^^^^^^^^ - --- pact>(map (lambda (x) (- 1 x)) [1 2 3]) --- [0, -1, -2] --- this is because prod simply suspends the static term without figuring out the arity which is being used --- to apply, vs core which does not attempt to do this, and picks an overload eagerly and statically. --- in 99% of cases this is fine, but we overloaded `-` to be completely different functions. desugarCoreBuiltinArity f i CoreSub [e1] = App (Builtin (f CoreNegate) i) ([e1]) i desugarCoreBuiltinArity f i CoreEnumerate [e1, e2, e3] = @@ -297,13 +254,10 @@ data SpecialForm | SFEnforce | SFWithCapability | SFSuspend - -- | SFDo + | SFDo | SFEnforceOne | SFTry | SFMap - | SFFilter - | SFFold - | SFZip | SFCond | SFCreateUserGuard deriving (Eq, Show, Enum, Bounded) @@ -317,23 +271,13 @@ toSpecialForm = \case "with-capability" -> Just SFWithCapability "suspend" -> Just SFSuspend "enforce-one" -> Just SFEnforceOne - -- "do" -> Just SFDo "try" -> Just SFTry "map" -> Just SFMap - -- "fold" -> Just SFFold - -- "filter" -> Just SFFilter - -- "zip" -> Just SFZip + "do" -> Just SFDo "cond" -> Just SFCond "create-user-guard" -> Just SFCreateUserGuard _ -> Nothing --- sfToLam :: SpecialForm -> info -> Term _ _ _ _ --- sfToLam = \case --- SFAnd -> conditionalLam2Arg CAnd --- SFOr -> conditionalLam2Arg COr --- SFEnforce -> conditionalLam2Arg CEnforce --- SFWithCapability -> undefined - conditionalLam2Arg :: (Term ParsedName ty1 builtin1 info -> Term ParsedName ty2 builtin2 info -> BuiltinForm (Term name Lisp.Type builtin3 info)) -> info -> Term name Lisp.Type builtin3 info conditionalLam2Arg c info = let arg1Name = "#condArg1" @@ -342,6 +286,12 @@ conditionalLam2Arg c info = let arg2 = Arg arg2Name (Just (Lisp.TyPrim PrimBool)) info in Lam (arg1 :| [arg2]) (BuiltinForm (c (Var (BN (BareName arg1Name)) info) (Var (BN (BareName arg2Name)) info)) info) info +nelToSequence :: info -> NonEmpty (Term name ty builtin info) -> Term name ty builtin info +nelToSequence info nel = + foldr (\a b -> Sequence a b info) (NE.last nel) (NE.init nel) + +-- | Desugar our special forms, +-- including one special case of eta expansion desugarSpecial :: (DesugarBuiltin b) => (BareName, i) @@ -354,8 +304,6 @@ desugarSpecial (bn@(BareName t), varInfo) dsArgs appInfo = case toSpecialForm t where injectedArg1 = ":ijHO1" injectedArg1Name = BN (BareName injectedArg1) - injectedArg2 = ":ijHO2" - injectedArg2Name = BN (BareName injectedArg2) desugarFn fn a = do fn' <- desugarLispTerm fn desugarArgs fn' a @@ -369,15 +317,7 @@ desugarSpecial (bn@(BareName t), varInfo) dsArgs appInfo = case toSpecialForm t desugar1ArgHOF f args = case args of Lisp.App operand appArgs appI:xs -> do let v = Lisp.Var injectedArg1Name appInfo - newArg = Lisp.Lam [Lisp.MArg injectedArg1 Nothing appI] (Lisp.App operand (appArgs++ [v]) appI) appI - desugarFn (f varInfo) (newArg:xs) - _ -> desugarFn (f varInfo) args - desugar2ArgHOF f args = case args of - Lisp.App operand appArgs appI:xs -> do - let v1 = Lisp.Var injectedArg1Name appInfo - v2 = Lisp.Var injectedArg2Name appInfo - newArg = Lisp.Lam [Lisp.MArg injectedArg1 Nothing appInfo, Lisp.MArg injectedArg2 Nothing appInfo] - (Lisp.App operand (appArgs ++ [v1, v2]) appI) appI + newArg = Lisp.Lam [Lisp.MArg injectedArg1 Nothing appI] (Lisp.App operand (appArgs++ [v]) appI :| []) appI desugarFn (f varInfo) (newArg:xs) _ -> desugarFn (f varInfo) args goSpecial args = \case @@ -397,9 +337,14 @@ desugarSpecial (bn@(BareName t), varInfo) dsArgs appInfo = case toSpecialForm t [e1, e2] -> BuiltinForm <$> (CEnforce <$> desugarLispTerm e1 <*> desugarLispTerm e2) <*> pure appInfo _ -> desugarArgs (conditionalLam2Arg CEnforce varInfo) args + SFDo -> case args of + x:xs -> nelToSequence appInfo <$> traverse desugarLispTerm (x :| xs) + _ -> throwDesugarError (InvalidSyntax "do form must have at least 1 expression") appInfo SFWithCapability -> case args of - e1:e2:xs -> - BuiltinForm <$> (CWithCapability <$> desugarLispTerm e1 <*> desugarLispTerm (Lisp.Block (e2 :| xs) appInfo)) <*> pure appInfo + e1:e2:xs -> do + e1' <- desugarLispTerm e1 + e2' <- nelToSequence appInfo <$> traverse desugarLispTerm (e2 :| xs) + pure $ (`BuiltinForm` appInfo) $ CWithCapability e1' e2' _ -> throwDesugarError (InvalidSyntax "with-capability must take at least 2 expressions") appInfo SFSuspend -> case args of [e1] -> @@ -417,9 +362,6 @@ desugarSpecial (bn@(BareName t), varInfo) dsArgs appInfo = case toSpecialForm t [e] -> BuiltinForm <$> (CCreateUserGuard <$> desugarLispTerm e) <*> pure appInfo _ -> throwDesugarError (InvalidSyntax "create-user-guard must take one argument, which must be an application") appInfo SFMap -> desugar1ArgHOF MapV args - SFFilter -> desugar1ArgHOF FilterV args - SFZip -> desugar2ArgHOF ZipV args - SFFold -> desugar2ArgHOF FoldV args SFCond -> case reverse args of defCase:xs -> do defCase' <- desugarLispTerm defCase @@ -456,20 +398,17 @@ desugarLispTerm = \case cvar1 = "#constantlyA1" cvar2 = "#constantlyA2" Lisp.Var n i -> pure (Var n i) - Lisp.Block nel i -> do - nel' <- traverse desugarLispTerm nel - pure $ foldr (\a b -> Sequence a b i) (NE.last nel') (NE.init nel') Lisp.Let _ binders expr i -> do - expr' <- desugarLispTerm expr + expr' <- nelToSequence i <$> traverse desugarLispTerm expr foldrM (binderToLet i) expr' binders - Lisp.Lam [] body i -> - Nullary <$> desugarLispTerm body <*> pure i - Lisp.Lam (x:xs) body i -> do - let nsts = x :| xs - args = (\(Lisp.MArg n t ai) -> Arg n t ai) <$> nsts - body' <- desugarLispTerm body - pure (Lam args body' i) - -- Lisp.Suspend body i -> desugarLispTerm (Lisp.Lam [] body i) + Lisp.Lam args body i -> do + body' <- nelToSequence i <$> traverse desugarLispTerm body + case args of + [] -> pure (Nullary body' i) + x:xs -> do + let nsts = x :| xs + args' = (\(Lisp.MArg n t ai) -> Arg n t ai) <$> nsts + pure (Lam args' body' i) Lisp.Binding fs hs i -> do hs' <- traverse desugarLispTerm hs body <- bindingBody hs' @@ -486,20 +425,6 @@ desugarLispTerm = \case fieldLit = Constant (LString field) i access = App (Builtin (liftCoreBuiltin CoreAt) i) [fieldLit, objFreshVar] i in Let arg access body i - -- Lisp.If e1 e2 e3 i -> BuiltinForm <$> - -- (CIf <$> desugarLispTerm e1 <*> desugarLispTerm e2 <*> desugarLispTerm e3) <*> pure i - -- Lisp.App (Lisp.Operator o _oi) [e1, e2] i -> case o of - -- Lisp.AndOp -> - -- BuiltinForm <$> (CAnd <$> desugarLispTerm e1 <*> desugarLispTerm e2) <*> pure i - -- Lisp.OrOp -> - -- BuiltinForm <$> (COr <$> desugarLispTerm e1 <*> desugarLispTerm e2) <*> pure i - -- Lisp.EnforceOp -> - -- BuiltinForm <$> (CEnforce <$> desugarLispTerm e1 <*> desugarLispTerm e2) <*> pure i - -- Lisp.EnforceOneOp -> case e2 of - -- Lisp.List e _ -> - -- BuiltinForm <$> (CEnforceOne <$> desugarLispTerm e1 <*> traverse desugarLispTerm e) <*> pure i - -- _ -> - -- throwDesugarError (InvalidSyntax "enforce-one: expected argument list") i Lisp.App (Lisp.Var (BN n) varInfo) hs appInfo -> desugarSpecial (n, varInfo) hs appInfo Lisp.App operator operands i -> do @@ -508,68 +433,12 @@ desugarLispTerm = \case case e' of Builtin b _ -> pure (desugarAppArity i b hs') _ -> pure (App e' hs' i) - -- hs' <- traverse desugarLispTerm hs - -- pure (App e' hs' i) - -- case (e, hs) of - -- (MapV mapI, Lisp.App operand args appI:xs) -> do - -- let v = Lisp.Var injectedArg1Name i - -- newArg = Lisp.Lam [Lisp.MArg injectedArg1 Nothing i] (Lisp.App operand (args ++ [v]) appI) appI - -- commonDesugar (MapV mapI) (newArg:xs) - -- (FilterV filterI, Lisp.App operand args appI:xs) -> do - -- let v = Lisp.Var injectedArg1Name i - -- newArg = Lisp.Lam [Lisp.MArg injectedArg1 Nothing i] (Lisp.App operand (args ++ [v]) appI) appI - -- commonDesugar (FilterV filterI) (newArg:xs) - -- (FoldV foldI, Lisp.App operand args appI:xs) -> do - -- let v1 = Lisp.Var injectedArg1Name i - -- v2 = Lisp.Var injectedArg2Name i - -- newArg = Lisp.Lam [Lisp.MArg injectedArg1 Nothing i, Lisp.MArg injectedArg2 Nothing i] (Lisp.App operand (args ++ [v1, v2]) appI) appI - -- commonDesugar (FoldV foldI) (newArg:xs) - -- (ZipV zipI, Lisp.App operand args appI:xs) -> do - -- let v1 = Lisp.Var injectedArg1Name i - -- v2 = Lisp.Var injectedArg2Name i - -- newArg = Lisp.Lam [Lisp.MArg injectedArg1 Nothing i, Lisp.MArg injectedArg2 Nothing i] (Lisp.App operand (args ++ [v1, v2]) appI) appI - -- commonDesugar (ZipV zipI) (newArg:xs) - -- (CondV condI, l) -> case reverse l of - -- defCase:xs -> do - -- defCase' <- desugarLispTerm defCase - -- body <- foldlM toNestedIf defCase' xs - -- pure $ App (Builtin (liftCoreBuiltin CoreCond) i) [Nullary body condI] condI - -- _ -> throwDesugarError (InvalidSyntax "cond: expected list of conditions with a default case") i - -- where - -- toNestedIf b (Lisp.App cond [body] i') = do - -- cond' <- desugarLispTerm cond - -- body' <- desugarLispTerm body - -- pure $ BuiltinForm (CIf cond' body' b) i' - -- toNestedIf _ _ = - -- throwDesugarError (InvalidSyntax "cond: expected application of conditions") i - -- _ -> commonDesugar e hs - -- where - -- commonDesugar operator operands = do - -- e' <- desugarLispTerm operator - -- hs' <- traverse desugarLispTerm operands - -- case e' of - -- Builtin b _ -> pure (desugarAppArity i b hs') - -- _ -> pure (App e' hs' i) - -- stands for "injected Higher order 1". The name is unimportant, - -- injected names are not meant to be very readable - -- injectedArg1 = ":ijHO1" - -- injectedArg1Name = BN (BareName injectedArg1) - -- injectedArg2 = ":ijHO2" - -- injectedArg2Name = BN (BareName injectedArg2) - -- Lisp.Operator bop i -> pure (desugarOperator i bop) Lisp.List e1 i -> ListLit <$> traverse desugarLispTerm e1 <*> pure i Lisp.Constant l i -> pure (Constant l i) - -- Lisp.Try e1 e2 i -> - -- Try <$> desugarLispTerm e1 <*> desugarLispTerm e2 <*> pure i Lisp.Object fields i -> ObjectLit <$> (traverse._2) desugarLispTerm fields <*> pure i - -- Lisp.CapabilityForm cf i -> (`CapabilityForm` i) <$> case cf of - -- Lisp.WithCapability cap body -> - -- WithCapability <$> desugarLispTerm cap <*> desugarLispTerm body - -- Lisp.CreateUserGuard pn exs -> - -- CreateUserGuard pn <$> traverse desugarLispTerm exs where binderToLet i (Lisp.Binder n mty expr) term = do expr' <- desugarLispTerm expr @@ -577,14 +446,6 @@ desugarLispTerm = \case pattern MapV :: i -> Lisp.Expr i pattern MapV info = Lisp.Var (BN (BareName "map")) info -pattern FilterV :: i -> Lisp.Expr i -pattern FilterV info = Lisp.Var (BN (BareName "filter")) info -pattern FoldV :: i -> Lisp.Expr i -pattern FoldV info = Lisp.Var (BN (BareName "fold")) info -pattern ZipV :: i -> Lisp.Expr i -pattern ZipV info = Lisp.Var (BN (BareName "zip")) info --- pattern CondV :: i -> Lisp.Expr i --- pattern CondV info = Lisp.Var (BN (BareName "cond")) info suspendTerm :: Term n dt builtin info @@ -603,13 +464,13 @@ desugarDefun -> Lisp.Defun i -> RenamerM e b i (Defun ParsedName DesugarType b i) desugarDefun _modWitness (Lisp.Defun spec [] body _ _ i) = do - body' <- desugarLispTerm body + body' <- nelToSequence i <$> traverse desugarLispTerm body let bodyLam = Nullary body' i spec' = toArg spec pure $ Defun spec' [] bodyLam i desugarDefun _modWitness (Lisp.Defun spec (arg:args) body _ _ i) = do let args' = toArg <$> (arg :| args) - body' <- desugarLispTerm body + body' <- nelToSequence i <$> traverse desugarLispTerm body let bodyLam = Lam args' body' i spec' = toArg spec pure $ Defun spec' (NE.toList args') bodyLam i @@ -619,9 +480,7 @@ desugarDefPact => ModuleName -> Lisp.DefPact i -> RenamerM e b i (DefPact ParsedName DesugarType b i) -desugarDefPact _mn (Lisp.DefPact (Lisp.MArg dpname _ _) _ [] _ _ i) = - throwDesugarError (EmptyDefPact dpname) i -desugarDefPact mn (Lisp.DefPact spec@(Lisp.MArg dpname _ _) margs (step:steps) _ _ i) = do +desugarDefPact mn (Lisp.DefPact spec@(Lisp.MArg dpname _ _) margs (step :| steps) _ _ i) = do let args' = toArg <$> margs spec' = toArg spec steps' <- forM (step :| steps) \case @@ -673,7 +532,7 @@ desugarDefCap desugarDefCap _modWitness (Lisp.DefCap spec arglist term _docs _model meta i) = do let arglist' = toArg <$> arglist spec' = toArg spec - term' <- desugarLispTerm term + term' <- nelToSequence i <$> traverse desugarLispTerm term meta' <- fmap FQParsed <$> maybe (pure Unmanaged) (desugarDefMeta i arglist') meta pure (DefCap spec' arglist' term' meta' i) diff --git a/pact/Pact/Core/IR/Eval/CEK.hs b/pact/Pact/Core/IR/Eval/CEK.hs index 180b989d5..7aa62c1a2 100644 --- a/pact/Pact/Core/IR/Eval/CEK.hs +++ b/pact/Pact/Core/IR/Eval/CEK.hs @@ -114,8 +114,6 @@ evaluateTerm -- -- -- Handles free variable lookups as well as module reference dynamic invokes --- Todo: it may not be worthwhile if accessing local variables is fast to charge --- anything but a constant amount of gas, but it would be a worthwhile exercise. evaluateTerm cont handler env (Var n info) = do case _nKind n of NBound i -> do @@ -230,11 +228,16 @@ evaluateTerm cont handler env (BuiltinForm c info) = case c of let env' = sysOnlyEnv env -- chargeGasArgs info (GAConstant constantWorkNodeGas) evalCEK (CondC env' info (EnforceC str) cont) handler env' cond + -- | ------ From --------------- | ------ To ------------------------ | + -- CWithCapability rawCap body -> do enforceNotWithinDefcap info env "with-capability" let capFrame = WithCapC body cont' = CapInvokeC env info capFrame cont evalCEK cont' handler env rawCap + -- | ------ From --------------- | ------ To ------------------------ | + -- + -- CCreateUserGuard term -> case term of App (Var (Name n (NTopLevel mn mh)) _) args _ -> do let fqn = FullyQualifiedName mn n mh @@ -246,6 +249,9 @@ evaluateTerm cont handler env (BuiltinForm c info) = case c of evalCEK cont' handler env x _ -> throwExecutionError info $ NativeExecutionError (NativeName "create-user-guard") $ "create-user-guard: expected function application of a top-level function" + -- | ------ From --------------- | ------ To ------------------------ | + -- + -- _errState - callstack,granted caps,events,gas CTry catchExpr rest -> do chargeGasArgs info (GAConstant tryNodeGas) errState <- evalStateToErrorState <$> get @@ -269,26 +275,6 @@ evaluateTerm cont handler env (BuiltinForm c info) = case c of throwExecutionError info $ NativeExecutionError (NativeName "enforce-one") $ "enforce-one: expected a list of conditions" -- | ------ From --------------- | ------ To ------------------------ | --- --- --- --- evaluateTerm cont handler env (CapabilityForm cf info) = do --- -- chargeGasArgs info (GAConstant constantWorkNodeGas) --- case cf of --- WithCapability rawCap body -> do --- enforceNotWithinDefcap info env "with-capability" --- let capFrame = WithCapC body --- cont' = CapInvokeC env info capFrame cont --- evalCEK cont' handler env rawCap --- CreateUserGuard name args -> do --- fqn <- nameToFQN info env name --- case args of --- [] -> createUserGuard info cont handler fqn [] --- x : xs -> do --- let usrGuardFrame = CreateUserGuardC fqn xs [] --- let cont' = CapInvokeC env info usrGuardFrame cont --- evalCEK cont' handler env x --- | ------ From --------------- | ------ To ------------------------ | -- --- evaluateTerm cont handler env (ListLit ts info) = do @@ -299,15 +285,6 @@ evaluateTerm cont handler env (ListLit ts info) = do -- | ------ From --------------- | ------ To ------------------------ | -- -- _errState - callstack,granted caps,events,gas --- evaluateTerm cont handler env (Try catchExpr rest info) = do --- chargeGasArgs info (GAConstant tryNodeGas) --- errState <- evalStateToErrorState <$> get --- let handler' = CEKHandler env catchExpr cont errState handler --- let env' = readOnlyEnv env --- evalCEK Mt handler' env' rest --- | ------ From --------------- | ------ To ------------------------ | --- --- _errState - callstack,granted caps,events,gas evaluateTerm cont handler env (ObjectLit o info) = do chargeGasArgs info (GConcat (ObjConcat (length o))) case o of @@ -1479,27 +1456,6 @@ applyLam (CT (CapTokenClosure fqn argtys arity i)) args cont handler argLen = length args - - --- instance CEKEval e CEKSmallStep b i where --- returnCEKValue cont handler v = pure (CEKReturn cont handler (EvalValue v)) --- returnCEK cont handler v = pure (CEKReturn cont handler v) --- evalCEK cont handler env term = pure (CEKEvaluateTerm cont handler env term) --- returnFinal v = pure (CEKReturn Mt CEKNoHandler v) --- applyLamUnsafe ca vs lc lh = applyLam ca vs lc lh >>= evalUnsafe - --- evalNormalForm initialEnv initialTerm = evalUnsafe (CEKEvaluateTerm Mt CEKNoHandler initialEnv initialTerm) --- evalUnsafe (CEKReturn Mt CEKNoHandler result) = --- return result --- evalUnsafe (CEKReturn cont handler (EvalValue v)) = --- applyContToValue cont handler v >>= evalUnsafe --- evalUnsafe (CEKReturn cont handler result) = --- applyCont cont handler result >>= evalUnsafe --- evalUnsafe (CEKEvaluateTerm cont handler env term) = --- evaluateTerm cont handler env term >>= evalUnsafe - - --- instance CEKEval e CEKBigStep b i where returnCEKValue :: Cont e b i -> CEKErrorHandler e b i -> CEKValue e b i -> EvalM e b i (EvalResult e b i) returnCEKValue = applyContToValue {-# INLINE returnCEKValue #-} @@ -1520,9 +1476,6 @@ evalNormalForm :: CEKEnv e b i -> EvalTerm b i -> EvalM e b i (EvalResult e b i) evalNormalForm = evaluateTerm Mt CEKNoHandler {-# INLINE evalNormalForm #-} --- evalUnsafe = pure --- {-# INLINE evalUnsafe #-} - -- | The main logic of enforcing a guard. -- -- The main difference to `coreEnforceGuard` is this function's type doesn't need to be a `NativeFunction e b i`, @@ -1549,7 +1502,6 @@ enforceGuard info cont handler env g = case g of md <- getModule info mn let cont' = IgnoreValueC (PBool True) cont acquireModuleAdmin info cont' handler env md - -- returnCEKValue cont handler (VBool True)guard GDefPactGuard (DefPactGuard dpid _) -> do curDpid <- getDefPactId info if curDpid == dpid diff --git a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs index 67a4534d9..10022682f 100644 --- a/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs +++ b/pact/Pact/Core/IR/Eval/Direct/Evaluator.hs @@ -333,26 +333,10 @@ evaluate env = \case CEnforceOne _ _ -> throwExecutionError info $ NativeExecutionError (NativeName "enforce-one") $ "enforce-one: expected a list of conditions" - - -- CapabilityForm cf info -> case cf of - -- WithCapability cap body -> do - -- enforceNotWithinDefcap info env "with-capability" - -- rawCap <- enforceCapToken info =<< evaluate env cap - -- let capModule = view (ctName . fqModule) rawCap - -- guardForModuleCall info capModule $ pure () - -- evalCap info env rawCap PopCapInvoke NormalCapEval body - -- CreateUserGuard n uargs -> do - -- fqn <- nameToFQN info env n - -- args <- traverse (evaluate env >=> enforcePactValue info) uargs - -- createUserGuard info fqn args ListLit ts info -> do chargeGasArgs info (GConcat (ListConcat (GasListLength (length ts)))) args <- traverse (evaluate env >=> enforcePactValue info) ts return (VList (V.fromList args)) - -- Try catchExpr tryExpr info -> do - -- chargeGasArgs info (GAConstant tryNodeGas) - -- let env' = readOnlyEnv env - -- catchRecoverable (evaluate env' tryExpr) (\_ _ -> evaluate env catchExpr) ObjectLit o info -> do chargeGasArgs info (GConcat (ObjConcat (length o))) args <- traverse go o diff --git a/pact/Pact/Core/Serialise/CBOR_V1.hs b/pact/Pact/Core/Serialise/CBOR_V1.hs index 8a54173d8..a5c7a4f40 100644 --- a/pact/Pact/Core/Serialise/CBOR_V1.hs +++ b/pact/Pact/Core/Serialise/CBOR_V1.hs @@ -413,18 +413,6 @@ instance Serialise (SerialiseV1 Field) where decode = SerialiseV1 <$> (Field <$> decode) {-# INLINE decode #-} --- instance (Serialise (SerialiseV1 name), Serialise (SerialiseV1 e)) => Serialise (SerialiseV1 (CapForm name e)) where --- encode (SerialiseV1 cf) = case cf of --- WithCapability e1 e2 -> encodeWord 0 <> encodeS e1 <> encodeS e2 --- CreateUserGuard name es -> encodeWord 1 <> encodeS name <> encodeS es --- {-# INLINE encode #-} - --- decode = decodeWord >>= fmap SerialiseV1 . \case --- 0 -> WithCapability <$> decodeS <*> decodeS --- 1 -> CreateUserGuard <$> decodeS <*> decodeS --- _ -> fail "unexpected decoding" --- {-# INLINE decode #-} - instance (Serialise (SerialiseV1 b), Serialise (SerialiseV1 i)) => Serialise (SerialiseV1 (BuiltinForm (Term Name Type b i))) where encode (SerialiseV1 bf) = case bf of diff --git a/pact/Pact/Core/Syntax/LexUtils.hs b/pact/Pact/Core/Syntax/LexUtils.hs index f0476524b..bb640d232 100644 --- a/pact/Pact/Core/Syntax/LexUtils.hs +++ b/pact/Pact/Core/Syntax/LexUtils.hs @@ -95,7 +95,7 @@ data Token | TokenString !Text | TokenTrue | TokenFalse - | TokenBlockIntro + -- | TokenBlockIntro -- | TokenSuspend | TokenDynAcc | TokenBindAssign @@ -291,7 +291,7 @@ renderTokenText = \case TokenDot -> "." TokenBindAssign -> ":=" TokenDynAcc -> "::" - TokenBlockIntro -> "do" + -- TokenBlockIntro -> "do" -- TokenAnd -> "and" -- TokenOr -> "or" -- TokenEnforce -> "enforce" diff --git a/pact/Pact/Core/Syntax/Lexer.x b/pact/Pact/Core/Syntax/Lexer.x index 1ece9f698..204bb7a81 100644 --- a/pact/Pact/Core/Syntax/Lexer.x +++ b/pact/Pact/Core/Syntax/Lexer.x @@ -74,7 +74,7 @@ tokens :- -- @withcap { token TokenWithCapability } -- @cruserguard { token TokenCreateUserGuard } -- try { token TokenTry } - do { token TokenBlockIntro } + -- do { token TokenBlockIntro } -- suspend { token TokenSuspend } @integer { emit TokenNumber } diff --git a/pact/Pact/Core/Syntax/ParseTree.hs b/pact/Pact/Core/Syntax/ParseTree.hs index 79111c1d9..2e1b2434f 100644 --- a/pact/Pact/Core/Syntax/ParseTree.hs +++ b/pact/Pact/Core/Syntax/ParseTree.hs @@ -145,7 +145,7 @@ data Defun i { _dfunSpec :: MArg i -- ^ 'MArg' contains the name ('_margName') and -- optional return type ('_margType'). The 'i' reflects the name info. , _dfunArgs :: [MArg i] - , _dfunTerm :: Expr i + , _dfunTerm :: NonEmpty (Expr i) , _dfunDocs :: Maybe Text , _dfunModel :: [PropertyExpr i] , _dfunInfo :: i @@ -170,7 +170,7 @@ data DefCap i { _dcapSpec :: MArg i -- ^ 'MArg' contains the name ('_margName') and -- optional return type ('_margType'). The 'i' reflects the name info. , _dcapArgs :: ![MArg i] - , _dcapTerm :: Expr i + , _dcapTerm :: NonEmpty (Expr i) , _dcapDocs :: Maybe Text , _dcapModel :: [PropertyExpr i] , _dcapMeta :: Maybe DCapMeta @@ -204,7 +204,7 @@ data DefPact i { _dpSpec :: MArg i -- ^ 'MArg' contains the name ('_margName') and -- optional return type ('_margType'). The 'i' reflects the name info. , _dpArgs :: [MArg i] - , _dpSteps :: [PactStep i] + , _dpSteps :: NonEmpty (PactStep i) , _dpDocs :: Maybe Text , _dpModel :: [PropertyExpr i] , _dpInfo :: i @@ -300,16 +300,6 @@ data PropKeyword = KwLet | KwLambda | KwDefProperty - | KwDo - -- | KwIf - -- | KwSuspend - -- | KwTry - -- | KwCreateUserGuard - -- | KwWithCapability - -- | KwEnforce - -- | KwEnforceOne - -- | KwAnd - -- | KwOr deriving (Eq, Show, Generic, NFData) data PropDelim @@ -390,13 +380,13 @@ instance NFData LetForm data Expr i = Var ParsedName i - | Let LetForm (NonEmpty (Binder i)) (Expr i) i - | Lam [MArg i] (Expr i) i + | Let LetForm (NonEmpty (Binder i)) (NonEmpty (Expr i)) i + | Lam [MArg i] (NonEmpty (Expr i)) i | App (Expr i) [Expr i] i | List [Expr i] i | Constant Literal i | Object [(Field, Expr i)] i - | Block (NonEmpty (Expr i)) i + -- | Block (NonEmpty (Expr i)) i | Binding [(Field, MArg i)] [Expr i] i deriving (Show, Eq, Functor, Generic, NFData) @@ -426,25 +416,13 @@ termInfo f = \case Let lf bnds e1 <$> f i Lam nel e i -> Lam nel e <$> f i - -- If e1 e2 e3 i -> - -- If e1 e2 e3 <$> f i App e1 args i -> App e1 args <$> f i - Block nel i -> - Block nel <$> f i Object m i -> Object m <$> f i - -- Operator op i -> - -- Operator op <$> f i List nel i -> List nel <$> f i - -- Suspend e i -> - -- Suspend e <$> f i Constant l i -> Constant l <$> f i - -- Try e1 e2 i -> - -- Try e1 e2 <$> f i - -- CapabilityForm e i -> - -- CapabilityForm e <$> f i Binding t e i -> Binding t e <$> f i @@ -452,44 +430,28 @@ instance Pretty (Expr i) where pretty = \case Var n _ -> pretty n Let lf bnds e _ -> - parens ("let" <> lf' <+> parens (hsep (NE.toList (pretty <$> bnds))) <+> pretty e) + parens ("let" <> lf' <+> parens (prettyNEL bnds) <+> prettyNEL e) where lf' = case lf of LFLetNormal -> mempty LFLetStar -> "*" Lam nel e _ -> - parens ("lambda" <+> parens (renderLamTypes nel) <+> pretty e) - -- If cond e1 e2 _ -> - -- parens ("if" <+> pretty cond <+> pretty e1 <+> pretty e2) + parens ("lambda" <+> parens (renderLamTypes nel) <+> prettyNEL e) App e1 [] _ -> parens (pretty e1) App e1 nel _ -> parens (pretty e1 <+> hsep (pretty <$> nel)) - -- Operator b _ -> pretty b - Block nel _ -> - parens ("do" <+> hsep (pretty <$> NE.toList nel)) Constant l _ -> pretty l List nel _ -> "[" <> commaSep nel <> "]" - -- Try e1 e2 _ -> - -- parens ("try" <+> pretty e1 <+> pretty e2) - -- Suspend e _ -> - -- parens ("suspend" <+> pretty e) - -- CapabilityForm c _ -> case c of - -- WithCapability cap body -> - -- parens ("with-capability" <+> pretty cap <+> pretty body) - -- CreateUserGuard pn exs -> - -- parens ("create-user-guard" <> capApp pn exs) - -- where - -- capApp pn exns = - -- parens (pretty pn <+> hsep (pretty <$> exns)) Object m _ -> braces (hsep (punctuate "," (prettyObj m))) Binding binds body _ -> braces (hsep $ punctuate "," $ fmap prettyBind binds) <+> hsep (pretty <$> body) where + prettyNEL nel = hsep (NE.toList (pretty <$> nel)) prettyBind (f, e) = pretty f <+> ":=" <+> pretty e prettyObj = fmap (\(n, k) -> dquotes (pretty n) <> ":" <> pretty k) renderLamPair (MArg n mt _) = case mt of diff --git a/pact/Pact/Core/Syntax/Parser.y b/pact/Pact/Core/Syntax/Parser.y index 401da45e1..88b3f2d39 100644 --- a/pact/Pact/Core/Syntax/Parser.y +++ b/pact/Pact/Core/Syntax/Parser.y @@ -47,7 +47,6 @@ import Pact.Core.Syntax.LexUtils %token let { PosToken TokenLet _ } letstar { PosToken TokenLetStar _ } - -- if { PosToken TokenIf _ } lam { PosToken TokenLambda _ } module { PosToken TokenModule _ } interface { PosToken TokenInterface _ } @@ -62,16 +61,10 @@ import Pact.Core.Syntax.LexUtils implements { PosToken TokenImplements _ } true { PosToken TokenTrue _ } false { PosToken TokenFalse _ } - progn { PosToken TokenBlockIntro _ } - -- try { PosToken TokenTry _ } - -- suspend { PosToken TokenSuspend _ } - -- load { PosToken TokenLoad _ } docAnn { PosToken TokenDocAnn _ } modelAnn { PosToken TokenModelAnn _ } eventAnn { PosToken TokenEventAnn _ } managedAnn { PosToken TokenManagedAnn _ } - -- withcap { PosToken TokenWithCapability _ } - -- c_usr_grd { PosToken TokenCreateUserGuard _} step { PosToken TokenStep _ } steprb { PosToken TokenStepWithRollback _ } '{' { PosToken TokenOpenBrace _ } @@ -85,10 +78,6 @@ import Pact.Core.Syntax.LexUtils ':' { PosToken TokenColon _ } ':=' { PosToken TokenBindAssign _ } '.' { PosToken TokenDot _ } - -- and { PosToken TokenAnd _ } - -- or { PosToken TokenOr _ } - -- enforce { PosToken TokenEnforce _} - -- enforceOne { PosToken TokenEnforceOne _ } IDENT { PosToken (TokenIdent _) _ } NUM { PosToken (TokenNumber _) _ } STR { PosToken (TokenString _) _ } @@ -123,11 +112,6 @@ ReplTopLevel :: { ReplTopLevel SpanInfo } | '(' Defun ')' { RTLDefun ($2 (combineSpan (_ptInfo $1) (_ptInfo $3))) } | '(' DefConst ')' { RTLDefConst ($2 (combineSpan (_ptInfo $1) (_ptInfo $3))) } - --- ReplSpecial :: { SpanInfo -> ReplSpecialForm SpanInfo } --- : load STR BOOLEAN { ReplLoad (getStr $2) $3 } --- | load STR { ReplLoad (getStr $2) False } - Governance :: { Governance ParsedName } : StringRaw { KeyGov (KeySetName $1 Nothing) } | IDENT { CapGov (FQParsed (BN (BareName (getIdent $1)))) } @@ -224,8 +208,11 @@ Defcap :: { SpanInfo -> DefCap SpanInfo } { DefCap (MArg (getIdent $2) $3 (_ptInfo $2)) (reverse $5) $9 (fst $7) (snd $7) $8 } DefPact :: { SpanInfo -> DefPact SpanInfo } - : defpact IDENT MTypeAnn '(' MArgs ')' MDocOrModel Steps - { DefPact (MArg (getIdent $2) $3 (_ptInfo $2)) (reverse $5) (reverse $8) (fst $7) (snd $7) } + : defpact IDENT MTypeAnn '(' MArgs ')' MDocOrModel DefPactSteps + { DefPact (MArg (getIdent $2) $3 (_ptInfo $2)) (reverse $5) $8 (fst $7) (snd $7) } + +DefPactSteps :: { NE.NonEmpty (PactStep SpanInfo) } + : Steps { NE.fromList (reverse $1) } Steps :: { [PactStep SpanInfo] } : Steps Step { $2:$1 } @@ -316,8 +303,8 @@ MTypeAnn :: { Maybe Type } : ':' Type { Just $2 } | {- empty -} { Nothing } -Block :: { ParsedExpr } - : BlockBody { mkBlock (reverse $1) } +Block :: { NE.NonEmpty ParsedExpr } + : BlockBody { NE.fromList (reverse $1) } BlockBody :: { [ParsedExpr] } : BlockBody Expr { $2:$1 } @@ -330,7 +317,7 @@ Expr :: { ParsedExpr } SExpr :: { SpanInfo -> ParsedExpr } : LamExpr { $1 } | LetExpr { $1 } - | ProgNExpr { $1 } + -- | ProgNExpr { $1 } | GenAppExpr { $1 } List :: { ParsedExpr } @@ -347,27 +334,10 @@ MCommaExpr :: { [ParsedExpr] } ExprCommaSep :: { [ParsedExpr] } : ExprCommaSep ',' Expr { $3:$1 } | Expr { [$1] } - -- | {- empty -} { [] } LamExpr :: { SpanInfo -> ParsedExpr } : lam '(' LamArgs ')' Block { Lam (reverse $3) $5 } --- IfExpr :: { SpanInfo -> ParsedExpr } --- : if Expr Expr Expr { If $2 $3 $4 } - --- TryExpr :: { SpanInfo -> ParsedExpr } --- : try Expr Expr { Try $2 $3 } - --- SuspendExpr :: { SpanInfo -> ParsedExpr } --- : suspend Expr { Suspend $2 } - --- CapExpr :: { SpanInfo -> ParsedExpr } --- : CapForm { CapabilityForm $1 } - --- CapForm :: { CapForm SpanInfo } --- : withcap Expr Block { WithCapability $2 $3 } --- | c_usr_grd '(' ParsedName AppList ')' { CreateUserGuard $3 (reverse $4)} - LamArgs :: { [MArg SpanInfo] } : LamArgs IDENT ':' Type { (MArg (getIdent $2) (Just $4) (_ptInfo $2)):$1 } | LamArgs IDENT { (MArg (getIdent $2) Nothing (_ptInfo $2)):$1 } @@ -384,9 +354,6 @@ Binders :: { [Binder SpanInfo] } GenAppExpr :: { SpanInfo -> ParsedExpr } : Expr AppBindList { \i -> App $1 (toAppExprList i (reverse $2)) i } -ProgNExpr :: { SpanInfo -> ParsedExpr } - : progn BlockBody { Block (NE.fromList (reverse $2)) } - AppList :: { [ParsedExpr] } : AppList Expr { $2:$1 } | {- empty -} { [] } @@ -414,15 +381,9 @@ Atom :: { ParsedExpr } | String { $1 } | List { $1 } | Bool { $1 } - -- | Operator { $1 } | Object { $1 } | '(' ')' { Constant LUnit (_ptInfo $1) } --- Operator :: { ParsedExpr } --- : and { Operator AndOp (_ptInfo $1) } --- | or { Operator OrOp (_ptInfo $1) } --- | enforce { Operator EnforceOp (_ptInfo $1)} --- | enforceOne { Operator EnforceOneOp (_ptInfo $1)} Bool :: { ParsedExpr } : true { Constant (LBool True) (_ptInfo $1) } @@ -497,16 +458,6 @@ PropAtom :: { PropertyExpr SpanInfo } FVKeyword :: { PropertyExpr SpanInfo } : let { PropKeyword KwLet (_ptInfo $1) } | lam { PropKeyword KwLambda (_ptInfo $1) } - | progn { PropKeyword KwDo (_ptInfo $1) } - -- | if { PropKeyword KwIf (_ptInfo $1) } - -- | suspend { PropKeyword KwSuspend (_ptInfo $1) } - -- | try { PropKeyword KwTry (_ptInfo $1) } - -- | enforce { PropKeyword KwEnforce (_ptInfo $1) } - -- | enforceOne { PropKeyword KwEnforceOne (_ptInfo $1) } - -- | and { PropKeyword KwAnd (_ptInfo $1) } - -- | or { PropKeyword KwOr (_ptInfo $1) } - -- | c_usr_grd { PropKeyword KwCreateUserGuard (_ptInfo $1) } - -- | withcap { PropKeyword KwWithCapability (_ptInfo $1) } FVDelim :: { PropertyExpr SpanInfo } : '{' { PropDelim DelimLBrace (_ptInfo $1) } @@ -581,12 +532,12 @@ propExprList tokLBracket li tokRBracket = finfo = combineSpan (_ptInfo tokLBracket) (_ptInfo tokRBracket) in PropSequence ((lbracket:li)++[rbracket]) finfo -mkBlock = \case - [x] -> x - li -> let - nel = NE.fromList li - i = combineSpans (NE.head nel) (NE.last nel) - in Block nel i +-- mkBlock = \case +-- [x] -> x +-- li -> let +-- nel = NE.fromList li +-- i = combineSpans (NE.head nel) (NE.last nel) +-- in Block nel i mkBarename tx = BareName tx