From f99930396de818b0b414739c927073b34192eecc Mon Sep 17 00:00:00 2001 From: 4ever2 <3417013+4ever2@users.noreply.github.com> Date: Mon, 3 Oct 2022 15:56:09 +0200 Subject: [PATCH] Fix warnings (#198) --- embedding/_CoqProject | 1 - embedding/examples/AcornExamples.v | 117 +-- embedding/examples/Demo.v | 163 ++- embedding/examples/FinMap.v | 14 +- embedding/extraction/Liquidity.v | 18 +- embedding/extraction/PreludeExt.v | 37 +- embedding/extraction/SimpleBlockchainExt.v | 2 +- embedding/theories/Ast.v | 10 +- embedding/theories/CertifyingTranslate.v | 10 +- embedding/theories/EnvSubst.v | 34 +- embedding/theories/EvalE.v | 18 +- embedding/theories/Misc.v | 46 +- embedding/theories/Notations.v | 38 +- embedding/theories/Prelude.v | 32 +- embedding/theories/SimpleBlockchain.v | 4 +- embedding/theories/Tests.v | 54 +- embedding/theories/TranslationUtils.v | 12 +- embedding/theories/Wf.v | 8 +- embedding/theories/pcuic/PCUICCorrectness.v | 392 +++---- .../theories/pcuic/PCUICCorrectnessAux.v | 986 +++++++++--------- embedding/theories/pcuic/PCUICFacts.v | 251 ++--- embedding/theories/pcuic/PCUICTranslate.v | 16 +- embedding/theories/pcuic/PCUICtoTemplate.v | 4 +- examples/_CoqProject | 27 +- examples/bat/BAT.v | 3 +- examples/bat/BATAltFix.v | 1 + examples/bat/BATAltFixCorrect.v | 12 +- examples/bat/BATAltFixTests.v | 24 +- examples/bat/BATCorrect.v | 8 +- examples/bat/BATFixed.v | 3 +- examples/bat/BATFixedCorrect.v | 10 +- examples/bat/BATFixedTests.v | 24 +- examples/bat/BATPrinters.v | 5 + examples/bat/BATTests.v | 66 +- examples/boardroomVoting/BoardroomMath.v | 44 +- examples/boardroomVoting/BoardroomVoting.v | 7 +- .../BoardroomVotingExtractionCameLIGO.v | 23 +- .../BoardroomVotingExtractionLiquidity.v | 30 +- .../boardroomVoting/BoardroomVotingTest.v | 6 +- examples/boardroomVoting/BoardroomVotingZ.v | 7 +- examples/boardroomVoting/Egcd.v | 6 +- examples/boardroomVoting/Euler.v | 1 + examples/cis1/CIS1Spec.v | 185 ++-- examples/cis1/CIS1Utils.v | 47 +- examples/cis1/Cis1wccd.v | 167 ++- examples/congress/Congress.v | 2 +- examples/congress/LocalBlockchainTests.v | 4 +- examples/congress/tests/CongressGens.v | 12 +- examples/congress/tests/CongressPrinters.v | 13 +- examples/congress/tests/CongressTests.v | 6 +- examples/congress/tests/Congress_BuggyGens.v | 12 +- .../congress/tests/Congress_BuggyPrinters.v | 13 +- examples/congress/tests/Congress_BuggyTests.v | 6 +- examples/counter/Counter.v | 40 +- examples/counter/embedding/CounterEmbed.v | 20 +- ...traction.v => CounterCertifiedLiquidity.v} | 10 +- ...ction.v => CounterDepCertifiedLiquidity.v} | 20 +- .../{CameLIGOCounter.v => CounterLIGO.v} | 16 +- ...terRefTypes.v => CounterRefTypesMidlang.v} | 10 +- .../{RustCounter.v => CounterRust.v} | 1 + .../extraction/CounterSubsetTypesLIGO.v | 3 +- .../extraction/CounterSubsetTypesLiquidity.v | 10 +- examples/crowdfunding/Crowdfunding.v | 10 +- examples/crowdfunding/CrowdfundingCameLIGO.v | 7 +- examples/crowdfunding/CrowdfundingCorrect.v | 176 ++-- examples/crowdfunding/CrowdfundingData.v | 10 +- examples/crowdfunding/CrowdfundingDataExt.v | 12 +- examples/crowdfunding/CrowdfundingExt.v | 36 +- examples/crowdfunding/CrowdfundingLiquidity.v | 6 +- .../crowdfunding/ExecFrameworkIntegration.v | 66 +- examples/dexter/Dexter.v | 2 +- examples/dexter/DexterPrinters.v | 5 + examples/dexter/DexterTests.v | 8 +- examples/dexter2/Dexter2CPMM.v | 30 +- examples/dexter2/Dexter2CPMMCorrect.v | 16 +- ...CPMMExtract.v => Dexter2CPMMExtractLIGO.v} | 0 examples/dexter2/Dexter2FA12.v | 28 +- examples/dexter2/Dexter2FA12Correct.v | 34 +- ...FA12Extract.v => Dexter2FA12ExtractLIGO.v} | 0 examples/dexter2/Dexter2Printers.v | 22 +- examples/dexter2/Dexter2Tests.v | 2 +- examples/eip20/EIP20LiquidityExtraction.v | 6 +- examples/eip20/EIP20Token.v | 2 +- examples/eip20/EIP20TokenCorrect.v | 22 +- examples/eip20/EIP20TokenGens.v | 2 +- examples/eip20/EIP20TokenPrinters.v | 5 + examples/eip20/EIP20TokenTests.v | 10 +- examples/escrow/EscrowCorrect.v | 8 +- .../{EscrowExtractLIGO.v => EscrowLIGO.v} | 3 +- ...owExtractLiquidity.v => EscrowLiquidity.v} | 10 +- .../{MidlangEscrow.v => EscrowMidlang.v} | 6 +- .../extraction/{RustEscrow.v => EscrowRust.v} | 1 + examples/escrow/tests/EscrowGens.v | 2 +- examples/escrow/tests/EscrowPrinters.v | 3 + examples/escrow/tests/EscrowTests.v | 16 +- examples/exchangeBuggy/ExchangeBuggy.v | 4 +- examples/exchangeBuggy/ExchangeBuggyGens.v | 2 +- .../exchangeBuggy/ExchangeBuggyPrinters.v | 8 +- examples/exchangeBuggy/ExchangeBuggyTests.v | 1 + examples/fa1_2/FA1_2.v | 22 +- examples/fa1_2/FA1_2Correct.v | 30 +- examples/fa2/FA2Gens.v | 4 +- examples/fa2/FA2LegacyInterface.v | 2 +- examples/fa2/FA2Printers.v | 45 +- examples/fa2/FA2Token.v | 10 +- examples/fa2/FA2TokenTests.v | 1 + examples/iTokenBuggy/iTokenBuggyGens.v | 2 +- examples/iTokenBuggy/iTokenBuggyPrinters.v | 5 + examples/iTokenBuggy/iTokenBuggyTests.v | 1 + examples/stackInterpreter/StackInterpreter.v | 2 +- .../StackInterpreterExtract.v | 22 +- .../StackInterpreterLIGOExtract.v | 3 +- .../StackInterpreterLiquidityExtract.v | 4 +- ...xtract.v => StackInterpreterRustExtract.v} | 1 + execution/README.md | 2 +- execution/_CoqProject | 2 - execution/test/ChainPrinters.v | 43 +- execution/test/LocalBlockchain.v | 4 +- execution/test/TestNotation.v | 2 +- execution/test/TestUtils.v | 20 +- execution/test/TraceGens.v | 10 +- execution/theories/Blockchain.v | 217 ++-- execution/theories/BoundedN.v | 1 + execution/theories/BuildUtils.v | 10 +- execution/theories/ChainedList.v | 1 + execution/theories/ContractCommon.v | 20 +- execution/theories/ContractMonads.v | 2 +- execution/theories/Finite.v | 1 + execution/theories/Monad.v | 2 +- execution/theories/ResultMonad.v | 2 +- execution/theories/Serializable.v | 15 +- extra/resources/coqdocjs/coqdoc.css | 2 +- extraction/Makefile | 10 +- extraction/README.md | 12 +- extraction/_CoqProject | 3 +- extraction/tests/CameLIGOExtractionTests.v | 24 +- extraction/tests/ElmExtractExamples.v | 16 +- extraction/tests/ElmExtractTests.v | 443 ++++---- extraction/tests/ElmForms.v | 82 +- .../tests/RecordExtractionLiquidityTests.v | 246 ++--- extraction/tests/RustExtractTests.v | 608 +++++------ .../escrow-extracted/src/tests.rs | 4 +- extraction/theories/CameLIGOExtract.v | 20 +- extraction/theories/CameLIGOPretty.v | 110 +- extraction/theories/Common.v | 10 +- extraction/theories/ConcordiumExtract.v | 4 +- extraction/theories/ElmExtract.v | 4 +- extraction/theories/ExtractExtraction.v | 14 +- extraction/theories/LiquidityExtract.v | 30 +- .../theories/{LPretty.v => LiquidityPretty.v} | 134 +-- extraction/theories/PluginExtract.v | 4 +- extraction/theories/PrettyPrinterMonad.v | 1 + extraction/theories/Printing.v | 3 +- extraction/theories/RustExtract.v | 2 +- extraction/theories/SpecializeChainBase.v | 4 +- typed-extraction | 2 +- utils/theories/Automation.v | 22 +- utils/theories/Env.v | 61 +- utils/theories/Extras.v | 75 +- utils/theories/RecordSet.v | 13 +- utils/theories/StringExtra.v | 21 +- 161 files changed, 3352 insertions(+), 2892 deletions(-) rename examples/counter/extraction/{CounterCertifiedExtraction.v => CounterCertifiedLiquidity.v} (96%) rename examples/counter/extraction/{CounterDepCertifiedExtraction.v => CounterDepCertifiedLiquidity.v} (93%) rename examples/counter/extraction/{CameLIGOCounter.v => CounterLIGO.v} (89%) rename examples/counter/extraction/{MidlangCounterRefTypes.v => CounterRefTypesMidlang.v} (95%) rename examples/counter/extraction/{RustCounter.v => CounterRust.v} (99%) rename examples/dexter2/{Dexter2CPMMExtract.v => Dexter2CPMMExtractLIGO.v} (100%) rename examples/dexter2/{Dexter2FA12Extract.v => Dexter2FA12ExtractLIGO.v} (100%) rename examples/escrow/extraction/{EscrowExtractLIGO.v => EscrowLIGO.v} (98%) rename examples/escrow/extraction/{EscrowExtractLiquidity.v => EscrowLiquidity.v} (96%) rename examples/escrow/extraction/{MidlangEscrow.v => EscrowMidlang.v} (98%) rename examples/escrow/extraction/{RustEscrow.v => EscrowRust.v} (99%) rename examples/stackInterpreter/{RustInterpExtract.v => StackInterpreterRustExtract.v} (99%) rename extraction/theories/{LPretty.v => LiquidityPretty.v} (94%) diff --git a/embedding/_CoqProject b/embedding/_CoqProject index 8ebd43ac..2da932f3 100644 --- a/embedding/_CoqProject +++ b/embedding/_CoqProject @@ -1,4 +1,3 @@ --arg -w -arg -undeclared-scope -arg -w -arg -notation-overridden -arg -w -arg -non-reversible-notation diff --git a/embedding/examples/AcornExamples.v b/embedding/examples/AcornExamples.v index b688f957..7a71404e 100644 --- a/embedding/examples/AcornExamples.v +++ b/embedding/examples/AcornExamples.v @@ -1,4 +1,4 @@ -(** * Examples of library code and contracts originating from the actual Acorn implementation *) +(** * Examples of library code and contracts originating from the actual Acorn implementation *) From MetaCoq.Template Require Import All. From ConCert.Embedding Require Import Ast. From ConCert.Embedding Require Import Notations. @@ -22,9 +22,9 @@ Open Scope list. Module AcornBool. MetaCoq Run define_mod_prefix. - Definition Data := [gdInd "Bool" 0 [("True_coq", []);("False_coq", [])] false]. + Definition Data := [gdInd "Bool" 0 [("True_coq", []); ("False_coq", [])] false]. (*---------------------*) - Definition Functions := [("not", eLambda "x" ((tyInd "Bool")) (eCase ("Bool", []) ((tyInd "Bool")) (eRel 0) [(pConstr "True_coq" [], eConstr "Bool" "False_coq");(pConstr "False_coq" [], eConstr "Bool" "True_coq")]))]. + Definition Functions := [("not", eLambda "x" ((tyInd "Bool")) (eCase ("Bool", []) ((tyInd "Bool")) (eRel 0) [(pConstr "True_coq" [], eConstr "Bool" "False_coq"); (pConstr "False_coq" [], eConstr "Bool" "True_coq")]))]. MetaCoq Run (translateData [] Data). @@ -36,26 +36,25 @@ End AcornBool. Module AcornMaybe. MetaCoq Run define_mod_prefix. - Definition Data := [gdInd "Maybe" 1 [("Nothing_coq", []);("Just_coq", [(None, tyRel 0)])] false]. + Definition Data := [gdInd "Maybe" 1 [("Nothing_coq", []); ("Just_coq", [(None, tyRel 0)])] false]. (*---------------------*) - Definition Functions := [("isJust", eTyLam "A" (eLambda "x" ((tyApp (tyInd "Maybe") (tyRel 0))) (eCase ("Maybe",[tyRel 0]) ((tyInd "Bool")) (eRel 0) [(pConstr "Nothing_coq" [], eConstr "Bool" "False_coq");(pConstr "Just_coq" ["x0"], eConstr "Bool" "True_coq")])))]. + Definition Functions := [("isJust", eTyLam "A" (eLambda "x" ((tyApp (tyInd "Maybe") (tyRel 0))) (eCase ("Maybe",[tyRel 0]) ((tyInd "Bool")) (eRel 0) [(pConstr "Nothing_coq" [], eConstr "Bool" "False_coq"); (pConstr "Just_coq" ["x0"], eConstr "Bool" "True_coq")])))]. MetaCoq Run (translateData [] Data). -Compute AcornBool.exported. MetaCoq Run (translateDefs AcornBool.exported (Data ++ AcornBool.Data) Functions). End AcornMaybe. Import AcornMaybe. -(** ** Acorn pairs *) +(** ** Acorn pairs *) Module AcornProd. - Definition Data := [gdInd "Pair" 2 [("Pair_coq", [(None, tyRel 1);(None, tyRel 0)])] false]. + Definition Data := [gdInd "Pair" 2 [("Pair_coq", [(None, tyRel 1); (None, tyRel 0)])] false]. (*---------------------*) Definition Functions := - [("fst", eTyLam "A" (eTyLam "A" (eLambda "x" ((tyApp (tyApp (tyInd "Pair") (tyRel 1)) (tyRel 0))) (eCase ("Pair",[(tyRel 1);(tyRel 0)]) (tyRel 1) (eRel 0) [(pConstr "Pair_coq" ["x0";"x1"], eRel 1)]))));("snd", eTyLam "A" (eTyLam "A" (eLambda "x" ((tyApp (tyApp (tyInd "Pair") (tyRel 1)) (tyRel 0))) (eCase ("Pair",[(tyRel 1);(tyRel 0)]) (tyRel 0) (eRel 0) [(pConstr "Pair_coq" ["x0";"x1"], eRel 0)]))))]. + [("fst", eTyLam "A" (eTyLam "A" (eLambda "x" ((tyApp (tyApp (tyInd "Pair") (tyRel 1)) (tyRel 0))) (eCase ("Pair",[(tyRel 1); (tyRel 0)]) (tyRel 1) (eRel 0) [(pConstr "Pair_coq" ["x0"; "x1"], eRel 1)])))); ("snd", eTyLam "A" (eTyLam "A" (eLambda "x" ((tyApp (tyApp (tyInd "Pair") (tyRel 1)) (tyRel 0))) (eCase ("Pair",[(tyRel 1); (tyRel 0)]) (tyRel 0) (eRel 0) [(pConstr "Pair_coq" ["x0"; "x1"], eRel 0)]))))]. MetaCoq Run (translateData [] Data). @@ -126,19 +125,19 @@ Module AcornListBase. Import AcornBool. Import AcornProd. - Definition Data := [gdInd "List" 1 [("Nil_coq", []);("Cons_coq", [(None, tyRel 0);(None, (tyApp (tyInd "List") (tyRel 0)))])] false]. + Definition Data := [gdInd "List" 1 [("Nil_coq", []); ("Cons_coq", [(None, tyRel 0); (None, (tyApp (tyInd "List") (tyRel 0)))])] false]. (*---------------------*) Definition Functions := [("singleton", eTyLam "A" (eLambda "x" (tyRel 0) (eApp (eApp (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0))) (eRel 0)) (eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0)))))) -;("foldr", eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 1) (tyArr (tyRel 0) (tyRel 0))) (eLambda "x" (tyRel 0) (eLetIn "f" (eFix "rec" "x" ((tyApp (tyInd "List") (tyRel 1))) (tyRel 0) (eCase ("List", [tyRel 1]) (tyRel 0) (eRel 0) [(pConstr "Nil_coq" [], eRel 2);(pConstr "Cons_coq" ["x0";"x1"], eApp (eApp (eRel 5) (eRel 1)) (eApp (eRel 3) (eRel 0)))])) (tyArr ((tyApp (tyInd "List") (tyRel 1))) (tyRel 0)) (eRel 0)))))) -;("map", eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 1) (tyRel 0)) (eApp (eApp (eApp (eApp (eConst "foldr") (eTy (tyRel 1))) (eTy ((tyApp (tyInd "List") (tyRel 0))))) (eLambda "x" (tyRel 1) (eApp (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0))) (eApp (eRel 1) (eRel 0))))) (eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0))))))) -;("foldl_alt", eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 0) (tyArr (tyRel 1) (tyRel 0))) (eLetIn "f" (eFix "rec" "x" ((tyApp (tyInd "List") (tyRel 1))) (tyArr (tyRel 0) (tyRel 0)) (eLambda "x" (tyRel 0) (eCase ("List", [tyRel 1]) (tyRel 0) (eRel 1) [(pConstr "Nil_coq" [], eRel 0);(pConstr "Cons_coq" ["x0";"x1"], eApp (eApp (eRel 4) (eRel 0)) (eApp (eApp (eRel 5) (eRel 2)) (eRel 1)))]))) (tyArr ((tyApp (tyInd "List") (tyRel 1))) (tyArr (tyRel 0) (tyRel 0))) (eRel 0))))) -;("foldl", eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 0) (tyArr (tyRel 1) (tyRel 0))) (eLambda "x" (tyRel 0) (eLambda "x" ((tyApp (tyInd "List") (tyRel 1))) (eApp (eApp (eApp (eApp (eApp (eConst "foldl_alt") (eTy (tyRel 1))) (eTy (tyRel 0))) (eRel 2)) (eRel 0)) (eRel 1))))))) -;("concat", eTyLam "A" (eLambda "x" ((tyApp (tyInd "List") (tyRel 0))) (eLambda "x" ((tyApp (tyInd "List") (tyRel 0))) (eApp (eApp (eApp (eApp (eApp (eConst "foldr") (eTy (tyRel 0))) (eTy ((tyApp (tyInd "List") (tyRel 0))))) (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0)))) (eRel 0)) (eRel 1))))) -;("zipWith", eTyLam "A" (eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 2) (tyArr (tyRel 1) (tyRel 0))) (eLetIn "f" (eFix "rec" "x" ((tyApp (tyInd "List") (tyRel 2))) (tyArr ((tyApp (tyInd "List") (tyRel 1))) ((tyApp (tyInd "List") (tyRel 0)))) (eLambda "x" ((tyApp (tyInd "List") (tyRel 1))) (eCase ("List", [tyRel 2]) ((tyApp (tyInd "List") (tyRel 0))) (eRel 1) [(pConstr "Nil_coq" [], eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0)));(pConstr "Cons_coq" ["x0";"x1"], eCase ("List", [tyRel 1]) ((tyApp (tyInd "List") (tyRel 0))) (eRel 2) [(pConstr "Nil_coq" [], eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0)));(pConstr "Cons_coq" ["x0";"x1"], eApp (eApp (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0))) (eApp (eApp (eRel 7) (eRel 3)) (eRel 1))) (eApp (eApp (eRel 6) (eRel 2)) (eRel 0)))])]))) (tyArr ((tyApp (tyInd "List") (tyRel 2))) (tyArr ((tyApp (tyInd "List") (tyRel 1))) ((tyApp (tyInd "List") (tyRel 0))))) (eRel 0)))))) -;("reverse", eTyLam "A" (eApp (eApp (eApp (eApp (eConst "foldl") (eTy (tyRel 0))) (eTy ((tyApp (tyInd "List") (tyRel 0))))) (eLambda "x" ((tyApp (tyInd "List") (tyRel 0))) (eLambda "x" (tyRel 0) (eApp (eApp (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0))) (eRel 0)) (eRel 1))))) (eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0))))) -;("zip", eTyLam "A" (eTyLam "A" (eApp (eApp (eApp (eApp (eConst "zipWith") (eTy (tyRel 1))) (eTy (tyRel 0))) (eTy ((tyApp (tyApp (tyInd "Pair") (tyRel 1)) (tyRel 0))))) (eApp (eApp (eConstr "Pair" "Pair_coq") (eTy (tyRel 1))) (eTy (tyRel 0)))))) -;("filter", eTyLam "A" (eLambda "x" (tyArr (tyRel 0) ((tyInd "Bool"))) (eApp (eApp (eApp (eApp (eConst "foldr") (eTy (tyRel 0))) (eTy ((tyApp (tyInd "List") (tyRel 0))))) (eLambda "x" (tyRel 0) (eLambda "x" ((tyApp (tyInd "List") (tyRel 0))) (eCase ("Bool", []) ((tyApp (tyInd "List") (tyRel 0))) (eApp (eRel 2) (eRel 1)) [(pConstr "True_coq" [], eApp (eApp (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0))) (eRel 1)) (eRel 0));(pConstr "False_coq" [], eRel 0)])))) (eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0))))))]. +; ("foldr", eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 1) (tyArr (tyRel 0) (tyRel 0))) (eLambda "x" (tyRel 0) (eLetIn "f" (eFix "rec" "x" ((tyApp (tyInd "List") (tyRel 1))) (tyRel 0) (eCase ("List", [tyRel 1]) (tyRel 0) (eRel 0) [(pConstr "Nil_coq" [], eRel 2); (pConstr "Cons_coq" ["x0"; "x1"], eApp (eApp (eRel 5) (eRel 1)) (eApp (eRel 3) (eRel 0)))])) (tyArr ((tyApp (tyInd "List") (tyRel 1))) (tyRel 0)) (eRel 0)))))) +; ("map", eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 1) (tyRel 0)) (eApp (eApp (eApp (eApp (eConst "foldr") (eTy (tyRel 1))) (eTy ((tyApp (tyInd "List") (tyRel 0))))) (eLambda "x" (tyRel 1) (eApp (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0))) (eApp (eRel 1) (eRel 0))))) (eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0))))))) +; ("foldl_alt", eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 0) (tyArr (tyRel 1) (tyRel 0))) (eLetIn "f" (eFix "rec" "x" ((tyApp (tyInd "List") (tyRel 1))) (tyArr (tyRel 0) (tyRel 0)) (eLambda "x" (tyRel 0) (eCase ("List", [tyRel 1]) (tyRel 0) (eRel 1) [(pConstr "Nil_coq" [], eRel 0); (pConstr "Cons_coq" ["x0"; "x1"], eApp (eApp (eRel 4) (eRel 0)) (eApp (eApp (eRel 5) (eRel 2)) (eRel 1)))]))) (tyArr ((tyApp (tyInd "List") (tyRel 1))) (tyArr (tyRel 0) (tyRel 0))) (eRel 0))))) +; ("foldl", eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 0) (tyArr (tyRel 1) (tyRel 0))) (eLambda "x" (tyRel 0) (eLambda "x" ((tyApp (tyInd "List") (tyRel 1))) (eApp (eApp (eApp (eApp (eApp (eConst "foldl_alt") (eTy (tyRel 1))) (eTy (tyRel 0))) (eRel 2)) (eRel 0)) (eRel 1))))))) +; ("concat", eTyLam "A" (eLambda "x" ((tyApp (tyInd "List") (tyRel 0))) (eLambda "x" ((tyApp (tyInd "List") (tyRel 0))) (eApp (eApp (eApp (eApp (eApp (eConst "foldr") (eTy (tyRel 0))) (eTy ((tyApp (tyInd "List") (tyRel 0))))) (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0)))) (eRel 0)) (eRel 1))))) +; ("zipWith", eTyLam "A" (eTyLam "A" (eTyLam "A" (eLambda "x" (tyArr (tyRel 2) (tyArr (tyRel 1) (tyRel 0))) (eLetIn "f" (eFix "rec" "x" ((tyApp (tyInd "List") (tyRel 2))) (tyArr ((tyApp (tyInd "List") (tyRel 1))) ((tyApp (tyInd "List") (tyRel 0)))) (eLambda "x" ((tyApp (tyInd "List") (tyRel 1))) (eCase ("List", [tyRel 2]) ((tyApp (tyInd "List") (tyRel 0))) (eRel 1) [(pConstr "Nil_coq" [], eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0))); (pConstr "Cons_coq" ["x0"; "x1"], eCase ("List", [tyRel 1]) ((tyApp (tyInd "List") (tyRel 0))) (eRel 2) [(pConstr "Nil_coq" [], eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0))); (pConstr "Cons_coq" ["x0"; "x1"], eApp (eApp (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0))) (eApp (eApp (eRel 7) (eRel 3)) (eRel 1))) (eApp (eApp (eRel 6) (eRel 2)) (eRel 0)))])]))) (tyArr ((tyApp (tyInd "List") (tyRel 2))) (tyArr ((tyApp (tyInd "List") (tyRel 1))) ((tyApp (tyInd "List") (tyRel 0))))) (eRel 0)))))) +; ("reverse", eTyLam "A" (eApp (eApp (eApp (eApp (eConst "foldl") (eTy (tyRel 0))) (eTy ((tyApp (tyInd "List") (tyRel 0))))) (eLambda "x" ((tyApp (tyInd "List") (tyRel 0))) (eLambda "x" (tyRel 0) (eApp (eApp (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0))) (eRel 0)) (eRel 1))))) (eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0))))) +; ("zip", eTyLam "A" (eTyLam "A" (eApp (eApp (eApp (eApp (eConst "zipWith") (eTy (tyRel 1))) (eTy (tyRel 0))) (eTy ((tyApp (tyApp (tyInd "Pair") (tyRel 1)) (tyRel 0))))) (eApp (eApp (eConstr "Pair" "Pair_coq") (eTy (tyRel 1))) (eTy (tyRel 0)))))) +; ("filter", eTyLam "A" (eLambda "x" (tyArr (tyRel 0) ((tyInd "Bool"))) (eApp (eApp (eApp (eApp (eConst "foldr") (eTy (tyRel 0))) (eTy ((tyApp (tyInd "List") (tyRel 0))))) (eLambda "x" (tyRel 0) (eLambda "x" ((tyApp (tyInd "List") (tyRel 0))) (eCase ("Bool", []) ((tyApp (tyInd "List") (tyRel 0))) (eApp (eRel 2) (eRel 1)) [(pConstr "True_coq" [], eApp (eApp (eApp (eConstr "List" "Cons_coq") (eTy (tyRel 0))) (eRel 1)) (eRel 0)); (pConstr "False_coq" [], eRel 0)])))) (eApp (eConstr "List" "Nil_coq") (eTy (tyRel 0))))))]. MetaCoq Run (translateData [] Data). @@ -148,10 +147,6 @@ Definition Functions := [("singleton", eTyLam "A" (eLambda "x" (tyRel 0) (eApp ( MetaCoq Run (translateDefs dependencies gEnv Functions). - Print List. - Print foldr. - Print zipWith. - Definition AcornList := List. (** We prove that the imported definitions are equivalent to the corresponding definitions from the standard library of Coq *) @@ -169,12 +164,12 @@ Definition Functions := [("singleton", eTyLam "A" (eLambda "x" (tyRel 0) (eApp ( Lemma to_from_acorn (A : Set) (l : AcornList A) : to_acorn (from_acorn l) = l. Proof. - induction l;simpl;congruence. + induction l; simpl; congruence. Qed. Lemma from_to_acorn (A : Set) (l : list A) : from_acorn (to_acorn l) = l. Proof. - induction l;simpl;congruence. + induction l; simpl; congruence. Qed. Arguments foldr {_ _}. @@ -183,7 +178,7 @@ Definition Functions := [("singleton", eTyLam "A" (eLambda "x" (tyRel 0) (eApp ( Lemma acorn_foldr_coq_fold_right (A B : Set) (l : AcornList A) (f : A -> B -> B) a : foldr f a l = fold_right f a (from_acorn l). Proof. - induction l;simpl;auto. + induction l; simpl; auto. f_equal. congruence. Qed. @@ -193,13 +188,14 @@ Definition Functions := [("singleton", eTyLam "A" (eLambda "x" (tyRel 0) (eApp ( concat l1 l2 = to_acorn (from_acorn l1 ++ from_acorn l2). Proof. revert l2. - induction l1;intros l2;destruct l2;simpl;try rewrite to_from_acorn;auto. + induction l1; intros l2; destruct l2; simpl; try rewrite to_from_acorn; auto. f_equal. rewrite app_nil_r. rewrite to_from_acorn. - clear IHl1; induction l1;simpl. congruence. now f_equal. + clear IHl1; induction l1; simpl. congruence. now f_equal. change (a0 :: from_acorn l2) with (from_acorn (Cons_coq _ a0 l2)). now f_equal. Qed. + #[local] Hint Rewrite acorn_foldr_coq_fold_right concat_app from_to_acorn : hints. Lemma concat_assoc : @@ -211,23 +207,23 @@ Definition Functions := [("singleton", eTyLam "A" (eLambda "x" (tyRel 0) (eApp ( Lemma foldr_concat (A B : Set) (f : A -> B -> B) (l l' : AcornList A) (i : B) : foldr f i (concat l l') = foldr f (foldr f i l') l. - Proof. autorewrite with hints;apply fold_right_app. Qed. + Proof. autorewrite with hints; apply fold_right_app. Qed. End AcornListBase. (** ** Acorn blockchain-related data types *) Module AcornBlochain. - Definition ABl_data := [gdInd "Caller" 0 [("CallerContract_coq", [(None, tyInd "nat")]);("CallerAccount_coq", [(None, tyInd "string")])] false;gdInd "ChainContext" 0 [("ChainContext_coq", [(None, tyInd "nat");(None, tyInd "nat");(None, tyInd "nat")])] false;gdInd "InitContext" 0 [("InitContext_coq", [(None, (tyInd "ChainContext"));(None, tyInd "string")])] false;gdInd "ReceiveContext" 0 [("ReceiveContext_coq", [(None, (tyInd "ChainContext"));(None, tyInd "string");(None, tyInd "nat")])] false]. + Definition ABl_data := [gdInd "Caller" 0 [("CallerContract_coq", [(None, tyInd "nat")]); ("CallerAccount_coq", [(None, tyInd "string")])] false; gdInd "ChainContext" 0 [("ChainContext_coq", [(None, tyInd "nat"); (None, tyInd "nat"); (None, tyInd "nat")])] false; gdInd "InitContext" 0 [("InitContext_coq", [(None, (tyInd "ChainContext")); (None, tyInd "string")])] false; gdInd "ReceiveContext" 0 [("ReceiveContext_coq", [(None, (tyInd "ChainContext")); (None, tyInd "string"); (None, tyInd "nat")])] false]. (*---------------------*) - Definition ABl_functions := [("slotNumber", eLambda "x" ((tyInd "ChainContext")) (eCase ("ChainContext", []) (tyInd "nat") (eRel 0) [(pConstr "ChainContext_coq" ["x0";"x1";"x2"], eRel 2)])) -;("blockHeight", eLambda "x" ((tyInd "ChainContext")) (eCase ("ChainContext", []) (tyInd "nat") (eRel 0) [(pConstr "ChainContext_coq" ["x0";"x1";"x2"], eRel 1)])) -;("finalizedHeight", eLambda "x" ((tyInd "ChainContext")) (eCase ("ChainContext", []) (tyInd "nat") (eRel 0) [(pConstr "ChainContext_coq" ["x0";"x1";"x2"], eRel 0)])) -;("initOrigin", eLambda "x" ((tyInd "InitContext")) (eCase ("InitContext", []) (tyInd "string") (eRel 0) [(pConstr "InitContext_coq" ["x0";"x1"], eRel 0)])) -;("initChain", eLambda "x" ((tyInd "InitContext")) (eCase ("InitContext", []) ((tyInd "ChainContext")) (eRel 0) [(pConstr "InitContext_coq" ["x0";"x1"], eRel 1)])) -;("receiveChain", eLambda "x" ((tyInd "ReceiveContext")) (eCase ("ReceiveContext", []) ((tyInd "ChainContext")) (eRel 0) [(pConstr "ReceiveContext_coq" ["x0";"x1";"x2"], eRel 2)])) -;("receiveOrigin", eLambda "x" ((tyInd "ReceiveContext")) (eCase ("ReceiveContext", []) (tyInd "string") (eRel 0) [(pConstr "ReceiveContext_coq" ["x0";"x1";"x2"], eRel 1)])) -;("receiveSelfAddress", eLambda "x" ((tyInd "ReceiveContext")) (eCase ("ReceiveContext", []) (tyInd "nat") (eRel 0) [(pConstr "ReceiveContext_coq" ["x0";"x1";"x2"], eRel 0)]))]. + Definition ABl_functions := [("slotNumber", eLambda "x" ((tyInd "ChainContext")) (eCase ("ChainContext", []) (tyInd "nat") (eRel 0) [(pConstr "ChainContext_coq" ["x0"; "x1"; "x2"], eRel 2)])) +; ("blockHeight", eLambda "x" ((tyInd "ChainContext")) (eCase ("ChainContext", []) (tyInd "nat") (eRel 0) [(pConstr "ChainContext_coq" ["x0"; "x1"; "x2"], eRel 1)])) +; ("finalizedHeight", eLambda "x" ((tyInd "ChainContext")) (eCase ("ChainContext", []) (tyInd "nat") (eRel 0) [(pConstr "ChainContext_coq" ["x0"; "x1"; "x2"], eRel 0)])) +; ("initOrigin", eLambda "x" ((tyInd "InitContext")) (eCase ("InitContext", []) (tyInd "string") (eRel 0) [(pConstr "InitContext_coq" ["x0"; "x1"], eRel 0)])) +; ("initChain", eLambda "x" ((tyInd "InitContext")) (eCase ("InitContext", []) ((tyInd "ChainContext")) (eRel 0) [(pConstr "InitContext_coq" ["x0"; "x1"], eRel 1)])) +; ("receiveChain", eLambda "x" ((tyInd "ReceiveContext")) (eCase ("ReceiveContext", []) ((tyInd "ChainContext")) (eRel 0) [(pConstr "ReceiveContext_coq" ["x0"; "x1"; "x2"], eRel 2)])) +; ("receiveOrigin", eLambda "x" ((tyInd "ReceiveContext")) (eCase ("ReceiveContext", []) (tyInd "string") (eRel 0) [(pConstr "ReceiveContext_coq" ["x0"; "x1"; "x2"], eRel 1)])) +; ("receiveSelfAddress", eLambda "x" ((tyInd "ReceiveContext")) (eCase ("ReceiveContext", []) (tyInd "nat") (eRel 0) [(pConstr "ReceiveContext_coq" ["x0"; "x1"; "x2"], eRel 0)]))]. MetaCoq Run (translateData stdlib_prefixes ABl_data). @@ -265,7 +261,7 @@ definition count (s :: CState) (msg :: Msg) = (** Data type definitions corresponding representation of the module [CoqExamples] above *) Definition acorn_datatypes := -[gdInd "Msg" 0 [("Inc_coq", [(None, tyInd "Z")]);("Dec_coq", [(None, tyInd "Z")])] false;gdInd "CState" 0 [("CState_coq", [(None, tyInd "Z");(None, tyInd "string")])] false]. +[gdInd "Msg" 0 [("Inc_coq", [(None, tyInd "Z")]); ("Dec_coq", [(None, tyInd "Z")])] false; gdInd "CState" 0 [("CState_coq", [(None, tyInd "Z"); (None, tyInd "string")])] false]. MetaCoq Run (translateData [] acorn_datatypes). @@ -282,11 +278,11 @@ End Prim. (** Function definitions corresponding representation of the module [CoqExamples] above *) Definition acorn_module : list (string * expr) := [("owner", eLambda "x" (tyInd "CState") (eCase ("CState", []) (tyInd "string") (eRel 0) [(pConstr "CState_coq" ["x0" -;"x1"], eRel 0)])) -;("balance", eLambda "x" (tyInd "CState") (eCase ("CState", []) (tyInd "Z") (eRel 0) [(pConstr "CState_coq" ["x0" -;"x1"], eRel 1)])) -;("count", eLambda "x" (tyInd "CState") (eLambda "x" (tyInd "Msg") (eCase ("Msg", []) (tyInd "CState") (eRel 0) [(pConstr "Inc_coq" ["x0"], eApp (eApp (eConstr "CState" "CState_coq") (eApp (eApp (eConst "plusInt64") (eApp (eConst "balance") (eRel 2))) (eRel 0))) (eApp (eConst "owner") (eRel 2))) -;(pConstr "Dec_coq" ["x0"], eApp (eApp (eConstr "CState" "CState_coq") (eApp (eApp (eConst "minusInt64") (eApp (eConst "balance") (eRel 2))) (eRel 0))) (eApp (eConst "owner") (eRel 2)))])))]. +; "x1"], eRel 0)])) +; ("balance", eLambda "x" (tyInd "CState") (eCase ("CState", []) (tyInd "Z") (eRel 0) [(pConstr "CState_coq" ["x0" +; "x1"], eRel 1)])) +; ("count", eLambda "x" (tyInd "CState") (eLambda "x" (tyInd "Msg") (eCase ("Msg", []) (tyInd "CState") (eRel 0) [(pConstr "Inc_coq" ["x0"], eApp (eApp (eConstr "CState" "CState_coq") (eApp (eApp (eConst "plusInt64") (eApp (eConst "balance") (eRel 2))) (eRel 0))) (eApp (eConst "owner") (eRel 2))) +; (pConstr "Dec_coq" ["x0"], eApp (eApp (eConstr "CState" "CState_coq") (eApp (eApp (eConst "minusInt64") (eApp (eConst "balance") (eRel 2))) (eRel 0))) (eApp (eConst "owner") (eRel 2)))])))]. MetaCoq Run (translateDefs [] Σ' acorn_module). @@ -334,19 +330,17 @@ End ForPeresentation. Module Recursion. - Definition R_data := [gdInd "Nat" 0 [("Zero_coq", []);("Suc_coq", [(None, (tyInd "Nat"))])] false]. + Definition R_data := [gdInd "Nat" 0 [("Zero_coq", []); ("Suc_coq", [(None, (tyInd "Nat"))])] false]. (*---------------------*) Open Scope nat. - Definition R_functions := [("add", eLetIn "f" (eFix "rec" "x" ((tyInd "Nat")) (tyArr (tyInd "Nat") (tyInd "Nat")) (eLambda "x" ((tyInd "Nat")) (eCase ("Nat", []) ((tyInd "Nat")) (eRel 1) [(pConstr "Zero_coq" [], eRel 0);(pConstr "Suc_coq" ["x0"], eApp (eConstr "Nat" "Suc_coq") (eApp (eApp (eRel 3) (eRel 0)) (eRel 1)))]))) (tyArr ((tyInd "Nat")) (tyArr (tyInd "Nat") (tyInd "Nat"))) (eRel 0))]. + Definition R_functions := [("add", eLetIn "f" (eFix "rec" "x" ((tyInd "Nat")) (tyArr (tyInd "Nat") (tyInd "Nat")) (eLambda "x" ((tyInd "Nat")) (eCase ("Nat", []) ((tyInd "Nat")) (eRel 1) [(pConstr "Zero_coq" [], eRel 0); (pConstr "Suc_coq" ["x0"], eApp (eConstr "Nat" "Suc_coq") (eApp (eApp (eRel 3) (eRel 0)) (eRel 1)))]))) (tyArr ((tyInd "Nat")) (tyArr (tyInd "Nat") (tyInd "Nat"))) (eRel 0))]. MetaCoq Run (translateData [] R_data). MetaCoq Run (translateDefs [] (StdLib.Σ ++ R_data)%list R_functions). - Print add. - Fixpoint Nat_nat (n : Nat) : nat := match n with | Zero_coq => O @@ -360,21 +354,26 @@ Module Recursion. end. Lemma Nat_nat_left n : nat_Nat (Nat_nat n) = n. - Proof. induction n;simpl;f_equal;auto. Qed. + Proof. induction n; simpl; f_equal; auto. Qed. Lemma Nat_nat_right n : Nat_nat (nat_Nat n) = n. - Proof. induction n;simpl;f_equal;auto. Qed. + Proof. induction n; simpl; f_equal; auto. Qed. + #[local] Hint Resolve Nat_nat_left Nat_nat_right : hints. - Local Coercion Nat_nat : Nat >-> nat. - Local Coercion nat_Nat : nat >-> Nat. + #[local] + Set Warnings "-ambiguous-paths". + + #[local] + Coercion Nat_nat : Nat >-> nat. + #[local] + Coercion nat_Nat : nat >-> Nat. Lemma add_correct (n m : Nat) : add n m = n + m. - Proof. induction n;simpl;f_equal;auto with hints. Qed. - + Proof. induction n; simpl; f_equal; auto with hints. Qed. End Recursion. @@ -385,17 +384,15 @@ Definition id := fun (A : Set) (a : A) => a. Definition id_id_syn := eApp (eApp (eConst "id") (eTy (tyForall "A" (tyArr (tyRel 0) (tyRel 0))))) (eConst "id"). -Compute (expr_to_term StdLib.Σ (reindexify 0 id_id_syn)). - -Eval compute in (expr_to_term StdLib.Σ (reindexify 0 id_id_syn)). +(* Eval compute in (expr_to_term StdLib.Σ (reindexify 0 id_id_syn)). *) Definition id_forall := eLambda "x" (tyForall "A" (tyArr (tyRel 0) (tyRel 0))) (eRel 0). -Compute (expr_to_term StdLib.Σ (reindexify 0 id_forall)). +(* Compute (expr_to_term StdLib.Σ (reindexify 0 id_forall)). *) (** Application [id id] fails, since [A] must be [Set], but type of - [id] is [forall A, A -> A], which lives in [Type] *) -Compute (expr_to_tc StdLib.Σ (reindexify 0 id_id_syn)). + [id] is [forall A, A -> A], which lives in [Type] *) +(* Compute (expr_to_tc StdLib.Σ (reindexify 0 id_id_syn)). *) Fail MetaCoq Run (translateDefs [] [] [("id_id", id_id_syn)]). (* Illegal application: The term "id" of type "forall A : Set, A -> A" diff --git a/embedding/examples/Demo.v b/embedding/examples/Demo.v index dc48152f..817f7dba 100644 --- a/embedding/examples/Demo.v +++ b/embedding/examples/Demo.v @@ -1,4 +1,4 @@ -(** * Simple examples on how to use our framework **) +(** * Simple examples on how to use our framework **) From Coq Require Import String. From Coq Require Import Basics. From Coq Require Import List. @@ -20,7 +20,7 @@ Import MCMonadNotation. Import BaseTypes. Import StdLib. -Module MC:=MetaCoq.Template.Ast. +Module MC := MetaCoq.Template.Ast. Import BasicAst. @@ -34,7 +34,7 @@ Section MCDemo. (* Quote *) MetaCoq Quote Definition id_nat_syn := (fun x : nat => x). - Print id_nat_syn. + (* Print id_nat_syn. *) (* Ast.tLambda (nNamed "x") (Ast.tInd {| TC.inductive_mind := "nat"; TC.inductive_ind := 0 |} []) (Ast.tRel 0) : Ast.term *) @@ -63,14 +63,14 @@ Definition negb_app_true := |]. -Unset Printing Notations. - -Set Printing Notations. - (* Execute the program using the interpreter *) -Compute (expr_eval_n Σ 3 nil negb_app_true). +Example eval_negb_app_true : + expr_eval_n Σ 3 nil negb_app_true = Ok (vConstr Bool "false" nil). +Proof. reflexivity. Qed. -Compute (expr_eval_i Σ 3 nil (indexify nil negb_app_true)). +Example eval_negb_app_true' : + expr_eval_i Σ 3 nil (indexify nil negb_app_true) = Ok (vConstr Bool "false" nil). +Proof. reflexivity. Qed. (* Make a Coq function from the AST of the program *) MetaCoq Unquote Definition coq_negb_app_true := @@ -80,7 +80,7 @@ MetaCoq Unquote Definition coq_negb_app_true := Definition my_negb_syn := [| \x : Bool => case x : Bool return Bool of | True -> False - | False -> True |]. + | False -> True |]. MetaCoq Unquote Definition my_negb := (expr_to_tc Σ (indexify nil my_negb_syn)). @@ -89,7 +89,17 @@ Lemma my_negb_coq_negb b : my_negb b = negb b. Proof. reflexivity. Qed. -Compute (expr_eval_n Σ 3 nil my_negb_syn). +Example eval_my_negb_syn : + expr_eval_n Σ 3 nil my_negb_syn = Ok + (vClos [] "x" cmLam [!Bool!] + [!Bool!] + (eCase (Bool, []) + [!Bool!] [|"x"|] + [({| pName := "true"; pVars := [] |}, + [|$ "false" $ Bool|]); + ({| pName := "false"; pVars := [] |}, + [|$ "true" $ Bool|])])). +Proof. reflexivity. Qed. Example eval_my_negb_true : expr_eval_i Σ 4 nil (indexify nil [| {my_negb_syn} True |]) = Ok (vConstr Bool "false" nil). @@ -145,14 +155,20 @@ Inductive blah := Definition Σ' : global_env := [gdInd "blah" 0 [("Bar", [(None,tyInd "blah"); (None,tyInd "blah")]); ("Baz", [])] false; - gdInd Nat 0 [("Z", []); ("Suc", [(None,tyInd Nat)])] false]. + gdInd Nat 0 [("Z", []); ("Suc", [(None,tyInd Nat)])] false]. Notation "'Bar'" := (eConstr "blah" "Bar") (in custom expr). Notation "'Baz'" := (eConstr "blah" "Baz") (in custom expr). Definition prog3 := [| Bar (Bar Baz Baz) Baz |]. -Compute (expr_eval_n Σ' 5 [] prog3). +Example eval_prog3 : + expr_eval_n Σ' 5 [] prog3 = Ok + (vConstr "blah" "Bar" + [vConstr "blah" "Bar" + [vConstr "blah" "Baz" []; vConstr "blah" "Baz" []]; + vConstr "blah" "Baz" []]). +Proof. reflexivity. Qed. (* Examples of a fixpoint *) @@ -180,7 +196,7 @@ MetaCoq Unquote Definition my_plus := (expr_to_tc Σ (indexify [] plus_syn)). Lemma my_plus_correct n m : my_plus n m = n + m. -Proof. induction n;simpl;auto. Qed. +Proof. induction n; simpl; auto. Qed. Definition two := @@ -190,8 +206,10 @@ Definition two := Definition one_plus_one := [| {plus_syn} 1 1 |]. -Compute (expr_eval_n Σ 10 [] [| {plus_syn} 1 1 |]). -(* = Ok (vConstr "nat" "Suc" [vConstr "nat" "Suc" [vConstr "nat" "Z" []]])*) +Example eval_one_plus_one : + expr_eval_n Σ 10 [] one_plus_one = + Ok (vConstr Nat "Suc" [vConstr Nat "Suc" [vConstr Nat "Z" []]]). +Proof. reflexivity. Qed. Definition two_arg_fun_syn := [| \x : Nat => \y : Bool => x |]. @@ -202,11 +220,13 @@ Parameter bbb: bool. MetaCoq Quote Definition two_arg_fun_app_syn' := ((fun (x : nat) (_ : bool) => x) 1 bbb). -Example one_plus_one_two : expr_eval_n Σ 10 [] one_plus_one = Ok two. -Proof. reflexivity. Qed. +Example one_plus_one_two : + expr_eval_n Σ 10 [] one_plus_one = Ok two. +Proof. reflexivity. Qed. -Example one_plus_one_two_i : expr_eval_i Σ 10 [] (indexify [] one_plus_one) = Ok two. -Proof. reflexivity. Qed. +Example one_plus_one_two_i : + expr_eval_i Σ 10 [] (indexify [] one_plus_one) = Ok two. +Proof. reflexivity. Qed. Definition plus_syn' := @@ -222,17 +242,17 @@ MetaCoq Unquote Definition my_plus' := Lemma my_plus'_0 : forall n, my_plus' 0 n = n. Proof. - induction n;simpl;easy. + induction n; simpl; easy. Qed. Lemma my_plus'_Sn : forall n m, my_plus' (S n) m = S (my_plus' n m). Proof. - induction m;simpl;easy. + induction m; simpl; easy. Qed. Lemma my_plus'_comm : forall n m, my_plus' n m = my_plus' m n. Proof. - induction n; intros m;simpl. + induction n; intros m; simpl. + rewrite my_plus'_0. reflexivity. + rewrite my_plus'_Sn. easy. Qed. @@ -241,7 +261,7 @@ Qed. Lemma my_plus'_correct : forall n m, my_plus' n m = n + m. Proof. intros n m. - induction m;simpl;easy. + induction m; simpl; easy. Qed. @@ -252,8 +272,24 @@ Definition id_rec := | Suc z -> Suc ("plus" z)) |]. -Compute (expr_eval_n Σ 20 [] [| {id_rec} (Suc (Suc (Suc 1))) |]). -Compute (expr_eval_i Σ 20 [] (indexify [] [| {id_rec} (Suc (Suc (Suc 1))) |])). +Example eval_id_rec : + expr_eval_n Σ 20 [] [| {id_rec} (Suc (Suc (Suc 1))) |] = + Ok (vConstr Nat "Suc" + [vConstr Nat "Suc" + [vConstr Nat "Suc" + [vConstr Nat "Suc" + [vConstr Nat "Z" []]]]]). +Proof. reflexivity. Qed. + +Example eval_id_rec' : + expr_eval_i Σ 20 [] (indexify [] [| {id_rec} (Suc (Suc (Suc 1))) |]) = + Ok (vConstr Nat "Suc" + [vConstr Nat "Suc" + [vConstr Nat "Suc" + [vConstr Nat "Suc" + [vConstr Nat "Z" []]]]]). +Proof. reflexivity. Qed. + Example id_rec_named_and_indexed : let arg := [| Suc (Suc (Suc 1)) |] in @@ -268,14 +304,77 @@ Example plus_named_and_indexed : expr_eval_i Σ 20 [] (indexify [] [| ({plus_syn} {two}) {three} |]). Proof. reflexivity. Qed. -Compute (expr_eval_i Σ 10 [] (indexify [] [| {plus_syn} 1 |])). +Example eval_plus_syn_one : + expr_eval_i Σ 10 [] (indexify [] [| {plus_syn} 1 |]) = + Ok (vClos + [("x", + vConstr Nat "Suc" + [vConstr Nat "Z" []]); + ("plus", + vClos [] "x" (cmFix "plus") [!Nat!] + (tyArr [!Nat!] + [!Nat!]) + [|\ "y" : Nat => + {eCase (Nat, []) + [!Nat!] (eRel 1) + [({| pName := "Z"; pVars := [] |}, eRel 0); + ({| pName := "Suc"; pVars := ["z"] |}, + eApp [|$ "Suc" $ Nat|] + (eApp (eApp (eRel 3) (eRel 0)) (eRel 1)))]}|])] "y" + cmLam [!Nat!] [!Nat!] + (eCase (Nat, []) + [!Nat!] (eRel 1) + [({| pName := "Z"; pVars := [] |}, eRel 0); + ({| pName := "Suc"; pVars := ["z"] |}, + eApp [|$ "Suc" $ Nat|] + (eApp (eApp (eRel 3) (eRel 0)) (eRel 1)))])). +Proof. reflexivity. Qed. -Compute (indexify [] [| {plus_syn}|]). -Compute (expr_eval_n Σ 10 [] [| {plus_syn} 0 |]). +Example eval_plus_syn : + indexify [] [| {plus_syn}|] = + [|fix "plus" ("x" : Nat) + : Nat -> Nat := + \ "y" : Nat => + {eCase (Nat, []) + [!Nat!] (eRel 1) + [({| pName := "Z"; pVars := [] |}, eRel 0); + ({| pName := "Suc"; pVars := ["z"] |}, + eApp [|$ "Suc" $ Nat|] + (eApp (eApp (eRel 3) (eRel 0)) (eRel 1)))]}|]. +Proof. reflexivity. Qed. + +Example eval_plus_syn_zero : + expr_eval_n Σ 10 [] [| {plus_syn} 0 |] = + Ok (vClos + [("x", vConstr Nat "Z" []); + ("plus", + vClos [] "x" (cmFix "plus") [!Nat!] + (tyArr [!Nat!] + [!Nat!]) + [|\ "y" : Nat => + {eCase (Nat, []) + [!Nat!] [|"x"|] + [({| pName := "Z"; pVars := [] |}, [|"y"|]); + ({| pName := "Suc"; pVars := ["z"] |}, + eApp [|$ "Suc" $ Nat|] + (eApp (eApp [|"plus"|] [|"z"|]) [|"y"|]))]}|])] "y" + cmLam [!Nat!] [!Nat!] + (eCase (Nat, []) + [!Nat!] [|"x"|] + [({| pName := "Z"; pVars := [] |}, [|"y"|]); + ({| pName := "Suc"; pVars := ["z"] |}, + eApp [|$ "Suc" $ Nat|] + (eApp (eApp [|"plus"|] [|"z"|]) [|"y"|]))])). +Proof. reflexivity. Qed. Definition fun_app := [| (\x : Nat => \y : Nat => y + x) Zero |]. -Compute (expr_eval_n Σ' 10 [] fun_app). +Example eval_fun_app : + expr_eval_n Σ' 10 [] fun_app = + Ok (vClos [("x", vConstr Nat "Z" [])] "y" cmLam + [!Nat!] [!Nat!] + (eApp (eApp (eConst "Coq/Init/Nat@add") [|"y"|]) [|"x"|])). +Proof. reflexivity. Qed. Inductive mybool := @@ -331,8 +430,8 @@ Import Template.Ast. Unset Primitive Projections. Definition State_syn := - [\ record "State" := "mkState" { "balance" : Nat ; "day" : Nat } \]. + [\ record "State" := "mkState" { "balance" : Nat ; "day" : Nat } \]. MetaCoq Unquote Inductive (global_to_tc State_syn). -Print State. +(* Print State. *) diff --git a/embedding/examples/FinMap.v b/embedding/examples/FinMap.v index 95513201..05ca7bd9 100644 --- a/embedding/examples/FinMap.v +++ b/embedding/examples/FinMap.v @@ -33,7 +33,7 @@ MetaCoq Run mkNames mp ["Maybe"; "Map"] "Acorn"). (** And constructors (just names, no module path prefix) *) -MetaCoq Run (mkNames "" ["Nothing";"Just"; "MNil"; "MCons"] "Acorn"). +MetaCoq Run (mkNames "" ["Nothing"; "Just"; "MNil"; "MCons"] "Acorn"). (** Now we can use [Maybe] as a name for a data type in our deep embedding. [Maybe] contains a string "MaybeAcorn" *) @@ -44,7 +44,7 @@ MetaCoq Run (mkNames "" ["Nothing";"Just"; "MNil"; "MCons"] "Acorn"). (** Now, we define an AST (a deep embedding) for [MaybeAcorn] data type. [MaybeAcorn] is the same as [option] of Coq and [Maybe] of Haskell. First, we define a new datatype without using notations *) Definition maybe_syn := - gdInd Maybe 1 [(Nothing, []); (Just, [(None,tyRel 0)])] false. + gdInd Maybe 1 [(Nothing, []); (Just, [(None,tyRel 0)])] false. MetaCoq Unquote Inductive (global_to_tc maybe_syn). @@ -52,7 +52,7 @@ MetaCoq Unquote Inductive (global_to_tc maybe_syn). Definition map_syn := [\ data Map # 2 = MNil [_] - | MCons [^1, ^0, (Map ^1 ^0), _] \]. + | MCons [^1, ^0, (Map ^1 ^0), _] \]. MetaCoq Unquote Inductive (global_to_tc map_syn). @@ -70,7 +70,7 @@ Notation " ' x " := (eTy (tyVar x)) (** [if .. then .. else] is just a shortcut for [case] of a boolean expression *) Notation "'if' cond 'then' b1 'else' b2 : ty" := (eCase (Bool,[]) ty cond - [(pConstr true_name [],b1);(pConstr false_name [],b2)]) + [(pConstr true_name [],b1); (pConstr false_name [],b2)]) (in custom expr at level 2, cond custom expr at level 4, ty custom type at level 4, @@ -121,7 +121,7 @@ Module NatMap := FMapWeakList.Make Nat_as_OT. (** Conversion function from our type of finite maps to the one in the standard library *) Fixpoint from_amap {A} (m : MapAcorn nat A) : NatMap.Raw.t A := match m with - | MNilAcorn => [] + | MNilAcorn => [] | MConsAcorn k v m' => (k,v) :: from_amap m' end. @@ -147,7 +147,7 @@ Section MapEval. (** Boolean equality of two natural numbers in Acorn *) Definition eqb_syn : expr := - [| (fix "eqb" (n : Nat) : Nat -> Bool := + [| (fix "eqb" (n : Nat) : Nat -> Bool := case n : Nat return Nat -> Bool of | Zero -> \m : Nat => (case m : Nat return Bool of | Zero -> True @@ -166,7 +166,7 @@ Section MapEval. Lemma nat_eqb_correct n m : nat_eqb n m = Nat.eqb n m. Proof. revert m. - induction n;intros m; now destruct m. + induction n; intros m; now destruct m. Qed. (** The syntactic representation of the following map [1 ~> 1; 0 ~> 0] *) diff --git a/embedding/extraction/Liquidity.v b/embedding/extraction/Liquidity.v index 634eb942..dd0ce6c9 100644 --- a/embedding/extraction/Liquidity.v +++ b/embedding/extraction/Liquidity.v @@ -14,7 +14,7 @@ Open Scope string. Module TCString := bytestring.String. -Coercion TCString.to_string : TCString.t >-> string. +Coercion TCString.to_string : TCString.t >-> string. (* Names for two mandatory argument for the main function. Used when generating code for [wrapper] and for the entry point *) Definition MSG_ARG := "msg". @@ -25,7 +25,7 @@ Record LiquidityModule := storage : type ; message : type ; functions : list (string * expr) ; - (* the [init] function must return [storage] *) + (* the [init] function must return [storage] *) init : expr; (* the [main] function must be of type message * storage -> option (list SimpleActionBody * storage) *) @@ -40,7 +40,7 @@ Definition newLine := String (Ascii.Ascii false true false true false false fals Definition inParens s := "(" ++ s ++ ")". Definition inCurly s := "{" ++ s ++ "}". Definition ofType e ty := e ++ " : " ++ ty. -Definition sep := concat. +Definition sep := concat. Definition look (e : env string) (s : string) : option string := lookup e s. @@ -93,7 +93,7 @@ Definition liquidifyInductive (TT : env string) (gd : global_dec) : string := Extras.with_default "Not a Record!" (head (map (printRecord TT) ctors)) else fold_right - (fun '(nm, ctor_info) s => "| " ++ nm ++ printCtorTy TT ctor_info ++ newLine ++ s) "" ctors + (fun '(nm, ctor_info) s => "| " ++ nm ++ printCtorTy TT ctor_info ++ newLine ++ s) "" ctors end. Definition printPat (p : pat) := @@ -184,7 +184,7 @@ Definition liquidify (TT TTty : env string ) : expr -> string := if cst' =? "fst" then go e2 ++ "." ++ inParens ("0") else (* is it a second projection? *) - if cst' =? "snd" then go e2 ++ "." ++ inParens ("1") + if cst' =? "snd" then go e2 ++ "." ++ inParens ("1") else default_app | _ => default_app end @@ -205,7 +205,7 @@ Definition liquidify (TT TTty : env string ) : expr -> string := Extras.with_default cst' (option_map TCString.of_string (look TT cst)) | eCase (ind,_) _ d bs => match bs with - | [b1;b2] => (* Handling if-then-else *) + | [b1; b2] => (* Handling if-then-else *) (* ignore module path *) let (_, ind') := PCUICTranslate.kername_of_string ind in if (ind' =? "bool") then @@ -288,7 +288,7 @@ Definition printWrapper (TTty: env string) (msgTy : type) (storageTy : type) "let wrapper " ++ mainDomainType ++ " = " - ++ printWrapperBody (contract ++ " " ++ sep " " [MSG_ARG;STORAGE_ARG] + ++ printWrapperBody (contract ++ " " ++ sep " " [MSG_ARG; STORAGE_ARG] ++ " " ++ _extra_args). (* NOTE: Polymoprhic definitions might not behave well in Liquidity *) @@ -310,7 +310,7 @@ Definition printLiqInit (TT TTty: env string) (def_name : string) (e : expr) := let init_params := firstn (List.length args - 1) args in "let%init" ++ " " ++ "storage " ++ sep " " (map (fun p => inParens (ofType (fst p) (liquidifyTy TTty (snd p)))) init_params) - ++ " = " ++ newLine + ++ " = " ++ newLine (* FIXME: this is currently a workaround, since [init] cannot refer to any global definition *) ++ "let eqTez (a : tez ) (b : tez ) = a = b in" ++ newLine @@ -326,7 +326,7 @@ Definition liquidifyModule (TT TTty: env string) (module : LiquidityModule) := ++ inParens (ofType STORAGE_ARG (liquidifyTy TTty module.(storage))) in let wrapper := printWrapper TTty module.(message) module.(storage) module.(main_extra_args) module.(main) in let init := printLiqInit TT TTty "storage" module.(init) in - let main := "let%entry main " ++ mainDomainType ++ " = wrapper " ++ sep " " [MSG_ARG;STORAGE_ARG] in + let main := "let%entry main " ++ mainDomainType ++ " = wrapper " ++ sep " " [MSG_ARG; STORAGE_ARG] in newLine ++ LiquidityPrelude ++ newLine ++ dt ++ newLine diff --git a/embedding/extraction/PreludeExt.v b/embedding/extraction/PreludeExt.v index 2ec335c5..91aa4a51 100644 --- a/embedding/extraction/PreludeExt.v +++ b/embedding/extraction/PreludeExt.v @@ -9,6 +9,7 @@ From ConCert.Embedding Require Import TranslationUtils. From ConCert.Embedding Require Import Prelude. From ConCert.Embedding Require Import Utils. From ConCert.Execution Require Import Blockchain. +From ConCert.Execution Require Import Serializable. From ConCert.Utils Require Import Automation. From Coq Require Import String. From Coq Require Import ZArith. @@ -107,7 +108,7 @@ Notation "'mkCallCtx' now sender sent_am bal " := (** A simple representation of the call context *) (** current_time, sender_add, sent_amount, acc_balance *) -Definition SimpleCallCtx : Set:= time_coq × (address_coq × (Amount × Amount)). +Definition SimpleCallCtx : Set := time_coq × (address_coq × (Amount × Amount)). (** These projections correspond to the notations above *) Definition sc_current_time (ctx : SimpleCallCtx) : time_coq := ctx.1. @@ -138,7 +139,7 @@ Definition decode_addr (addr: nat + nat) : address_coq := Global Program Instance CB : ChainBase := build_chain_base address_coq eqb_addr _ _ _ _ is_contract. Next Obligation. - intros a b. destruct a,b;simpl. + intros a b. destruct a,b; simpl. - destruct (n =? n0)%nat eqn:Heq. * constructor. now rewrite Nat.eqb_eq in *. * constructor. now rewrite NPeano.Nat.eqb_neq in *. @@ -150,7 +151,7 @@ Next Obligation. Qed. Next Obligation. intros ??. unfold base.Decision. - decide equality;apply Nat.eq_dec. + decide equality; apply Nat.eq_dec. Qed. Next Obligation. assert (cnat : countable.Countable (nat + nat)) by typeclasses eauto. @@ -165,7 +166,7 @@ Next Obligation. exact (Some (ContractAddr_coq n)). exact (Some (UserAddr_coq n)). ** exact None. - * cbn;intros addr. + * cbn; intros addr. destruct addr; now rewrite H. Defined. @@ -182,7 +183,7 @@ Next Obligation. exact (Some (ContractAddr_coq n)). exact (Some (UserAddr_coq n)). ** exact None. - * cbn;intros addr. + * cbn; intros addr. destruct addr; now rewrite H. Defined. @@ -239,13 +240,13 @@ Module Maps. Lemma lookup_map_add k v m : lookup_map (add_map k v m) k = Some v. Proof. induction m. - + simpl. destruct k;simpl; now rewrite PeanoNat.Nat.eqb_refl. + + simpl. destruct k; simpl; now rewrite PeanoNat.Nat.eqb_refl. + simpl. destruct (eqb_addr k a) eqn:Heq. - * destruct k;simpl;now rewrite PeanoNat.Nat.eqb_refl. + * destruct k; simpl; now rewrite PeanoNat.Nat.eqb_refl. * simpl. now rewrite Heq. Qed. - Fixpoint to_list (m : addr_map_coq) : list (address_coq * Z)%type:= + Fixpoint to_list (m : addr_map_coq) : list (address_coq * Z)%type := match m with | mnil => nil | mcons k v tl => cons (k,v) (to_list tl) @@ -258,13 +259,13 @@ Module Maps. end. Lemma of_list_to_list m: of_list (to_list m) = m. - Proof. induction m;simpl;congruence. Qed. + Proof. induction m; simpl; congruence. Qed. Lemma to_list_of_list l: to_list (of_list l) = l. - Proof. induction l as [ | x l'];simpl;auto. - destruct x. simpl;congruence. Qed. + Proof. induction l as [ | x l']; simpl; auto. + destruct x. simpl; congruence. Qed. - Fixpoint map_forallb (p : Z -> bool)(m : addr_map_coq) : bool:= + Fixpoint map_forallb (p : Z -> bool)(m : addr_map_coq) : bool := match m with | mnil => true | mcons k v m' => p v && map_forallb p m' @@ -276,9 +277,9 @@ Module Maps. p v = true. Proof. revert k v p. - induction m;intros;try discriminate;simpl in *. - propify. destruct (eqb_addr _ _);auto. - * now inversion H0;subst. + induction m; intros; try discriminate; simpl in *. + propify. destruct (eqb_addr _ _); auto. + * now inversion H0; subst. * easy. Qed. @@ -288,18 +289,18 @@ Module Maps. Notation "'MNil'" := [| {eConstr Map "mnil"} |] (in custom expr at level 0). - Notation "'mfind' a b" := [| {eConst (to_string_name <% lookup_map %>)} {a} {b} |] + Notation "'mfind' a b" := [| {eConst (to_string_name <% lookup_map %>)} {a} {b} |] (in custom expr at level 0, a custom expr at level 1, b custom expr at level 1). - Notation "'madd' a b c" := [| {eConst (to_string_name <% add_map %>)} {a} {b} {c} |] + Notation "'madd' a b c" := [| {eConst (to_string_name <% add_map %>)} {a} {b} {c} |] (in custom expr at level 0, a custom expr at level 1, b custom expr at level 1, c custom expr at level 1). - Notation "'mem' a b" := [| {eConst (to_string_name <% inmap_map %>)} {a} {b} |] + Notation "'mem' a b" := [| {eConst (to_string_name <% inmap_map %>)} {a} {b} |] (in custom expr at level 0, a custom expr at level 1, b custom expr at level 1). diff --git a/embedding/extraction/SimpleBlockchainExt.v b/embedding/extraction/SimpleBlockchainExt.v index 1e8beb75..d3ccba4b 100644 --- a/embedding/extraction/SimpleBlockchainExt.v +++ b/embedding/extraction/SimpleBlockchainExt.v @@ -1,4 +1,4 @@ -(** * A simply-typed version of the blockchain execution environment *) +(** * A simply-typed version of the blockchain execution environment *) (* We develop some blockchain infrastructure relevant for the contract execution. *) From ConCert.Embedding Require Import Ast. From ConCert.Embedding Require Import Notations. diff --git a/embedding/theories/Ast.v b/embedding/theories/Ast.v index 59c41859..8801cedb 100644 --- a/embedding/theories/Ast.v +++ b/embedding/theories/Ast.v @@ -72,7 +72,7 @@ Proof. + apply Hlam. apply ind. + apply HtyLam. apply ind. + apply Hletin; apply ind. - + apply Happ;apply ind. + + apply Happ; apply ind. + apply Hconstr. + apply Hconst. + apply Hcase. apply ind. @@ -108,7 +108,7 @@ Fixpoint iclosed_n (n : nat) (e : expr) : bool := let bs'' := List.forallb (fun x => iclosed_n (length ((fst x).(pVars)) + n) (snd x)) bs in forallb (iclosed_ty n) (snd ii) && iclosed_ty n ty && iclosed_n n e && bs'' - | eFix fixname nm ty1 ty2 e => iclosed_ty n ty1 && iclosed_ty n ty2 && iclosed_n (2+n) e + | eFix fixname nm ty1 ty2 e => iclosed_ty n ty1 && iclosed_ty n ty2 && iclosed_n (2+n) e | eTy ty => iclosed_ty n ty end. @@ -152,7 +152,7 @@ Definition remove_proj (c : constr) := map snd (snd c). (** Resolves the given constructor name to a corresponding position in the list of constructors along with the constructor's arity *) Definition resolve_constr (Σ : global_env) (ind_name constr_name : ename) - : option (nat * nat * list type) := + : option (nat * nat * list type) := match (resolve_inductive Σ ind_name) with | Some n_cs => match lookup_with_ind (map (fun c => (fst c, remove_proj c)) (snd n_cs)) constr_name with @@ -209,8 +209,8 @@ Fixpoint indexify (l : list (ename * nat)) (e : expr) : expr := | Some v => eRel v end | eLambda nm ty b => - eLambda nm (indexify_type l ty) (indexify ((nm,0 ):: bump_indices l 1) b) - | eTyLam nm b => eTyLam nm (indexify ((nm,0 ):: bump_indices l 1) b) + eLambda nm (indexify_type l ty) (indexify ((nm,0 ) :: bump_indices l 1) b) + | eTyLam nm b => eTyLam nm (indexify ((nm,0 ) :: bump_indices l 1) b) | eLetIn nm e1 ty e2 => eLetIn nm (indexify l e1) (indexify_type l ty) (indexify ((nm, 0) :: bump_indices l 1) e2) | eApp e1 e2 => eApp (indexify l e1) (indexify l e2) diff --git a/embedding/theories/CertifyingTranslate.v b/embedding/theories/CertifyingTranslate.v index ade86be5..67e6ae16 100644 --- a/embedding/theories/CertifyingTranslate.v +++ b/embedding/theories/CertifyingTranslate.v @@ -17,7 +17,7 @@ Import NamelessSubst. Import BaseTypes. Import StdLib. -Notation "'eval' ( Σ , n , e )" := (expr_eval_i Σ n [] e) (at level 100). +Notation "'eval' ( Σ , n , e )" := (expr_eval_i Σ n [] e) (at level 100). Definition expr_to_tc Σ := compose trans (expr_to_term Σ). Definition type_to_tc := compose trans type_to_term. @@ -41,19 +41,19 @@ Definition my_negb_syn := | True -> False | False -> True |]. -Compute expr_to_tc Σ (indexify nil my_negb_syn). +(* Compute expr_to_tc Σ (indexify nil my_negb_syn). *) (** We translate and unquote using the ConCert embedding feature *) MetaCoq Unquote Definition my_negb := (expr_to_tc Σ (indexify nil my_negb_syn)). -(** We prove that the running the interpreter with [my_negb_syn] applied to an expression originating from Coq' boolean value computes the same result as the unquoted function [my_negb]. As a result, we do not depend on correctness of [unquote] *) +(** We prove that the running the interpreter with [my_negb_syn] applied to an expression originating from Coq' boolean value computes the same result as the unquoted function [my_negb]. As a result, we do not depend on correctness of [unquote] *) Lemma my_negb_correct b : exists n v, eval(Σ, n, - indexify nil ([| {my_negb_syn} {of_val_i (of_bool b)} |]) ) = Ok v + indexify nil ([| {my_negb_syn} {of_val_i (of_bool b)} |])) = Ok v /\ v = of_bool (negb b). Proof. - destruct b; exists 3;eexists;simpl;eauto. + destruct b; exists 3; eexists; simpl; eauto. Qed. (** One can prove similar results any non-recursive definition. Proofs in this case would require just case analysis and computation. For recursive definitions proofs would require induction and some additional lemmas *) diff --git a/embedding/theories/EnvSubst.v b/embedding/theories/EnvSubst.v index 1849e148..d3cc0d9c 100644 --- a/embedding/theories/EnvSubst.v +++ b/embedding/theories/EnvSubst.v @@ -43,12 +43,12 @@ Module NamelessSubst. end. - (** NOTE: assumes, that expression in [ρ] are closed! *) + (** NOTE: assumes, that expression in [ρ] are closed! *) Fixpoint subst_env_i_aux (k : nat) (ρ : env expr) (e : expr) : expr := match e with | eRel i => if Nat.leb k i then with_default (eRel i) (lookup_i ρ (i-k)) else eRel i - | eVar nm => eVar nm + | eVar nm => eVar nm | eLambda nm ty b => eLambda nm (subst_env_i_ty k ρ ty) (subst_env_i_aux (1+k) ρ b) | eTyLam nm b => eTyLam nm (subst_env_i_aux (1+k) ρ b) | eLetIn nm e1 ty e2 => eLetIn nm (subst_env_i_aux k ρ e1) (subst_env_i_ty k ρ ty) @@ -111,9 +111,9 @@ Module NamelessSubst. lookup_i ρ n = Some v -> lookup_i (exprs ρ) n = Some (of_val_i v). Proof. revert dependent n. - induction ρ;intros n0 Hρ. + induction ρ; intros n0 Hρ. + easy. - + destruct a;simpl in *. + + destruct a; simpl in *. destruct n0. * simpl in *. inversion Hρ. subst. reflexivity. * simpl in *. replace (n0 - 0) with n0 in * by lia. easy. @@ -126,7 +126,7 @@ Module NamelessSubst. Proof. intros Hlt. revert dependent n. - induction ρ;intros n1 Hlt. + induction ρ; intros n1 Hlt. + easy. + destruct (Nat.eqb n1 0) eqn:Hn1. * destruct a. eexists. split. @@ -162,7 +162,7 @@ Module NamedSubst. Fixpoint subst_env (ρ : list (ename * expr)) (e : expr) : expr := match e with | eRel i as e' => e' - | eVar nm => match lookup ρ nm with + | eVar nm => match lookup ρ nm with | Some v => v | None => e end @@ -225,42 +225,49 @@ Module Equivalence. Definition list_val_equiv vs1 vs2 := Forall2 (fun v1 v2 => v1 ≈ v2) vs1 vs2. Notation " vs1 ≈ₗ vs2 " := (list_val_equiv vs1 vs2) (at level 50). + #[export] Instance val_equiv_reflexive : Reflexive val_equiv. Proof. intros v. induction v using val_ind_full. + constructor. - induction l;constructor; inversion H; easy. - + destruct cm;constructor;reflexivity. + induction l; constructor; inversion H; easy. + + destruct cm; constructor; reflexivity. + constructor. reflexivity. + constructor. Defined. - (* TODO: Add the rest to prove that [val_equiv] is indeed an equivalence *) + (* TODO: Add the rest to prove that [val_equiv] is indeed an equivalence *) Axiom val_equiv_symmetric : Symmetric val_equiv. Axiom val_equiv_transitive : Transitive val_equiv. + #[export] Existing Instance val_equiv_symmetric. + #[export] Existing Instance val_equiv_transitive. - (* TODO: Define these *) + (* TODO: Define these *) Axiom list_val_equiv_reflexive : Reflexive list_val_equiv. Axiom list_val_equiv_symmetric : Symmetric list_val_equiv. Axiom list_val_equiv_transitive : Transitive list_val_equiv. + #[export] Existing Instance list_val_equiv_reflexive. + #[export] Existing Instance list_val_equiv_symmetric. + #[export] Existing Instance list_val_equiv_transitive. Lemma list_val_compat v1 v2 vs1 vs2 : v1 ≈ v2 -> vs1 ≈ₗ vs2 -> (v1 :: vs1) ≈ₗ (v2 :: vs2). Proof. intros Heq Heql. - constructor;easy. + constructor; easy. Qed. + #[export] Instance cons_compat : Proper (val_equiv ==> list_val_equiv ==> list_val_equiv) cons. Proof. - cbv;intros;apply list_val_compat;assumption. + cbv; intros; apply list_val_compat; assumption. Defined. Lemma constr_cons_compat (vs1 vs2 : list val) (i : inductive) (nm : ename) : @@ -273,8 +280,9 @@ Module Equivalence. + constructor; assumption. Defined. + #[export] Instance constr_morph i nm : Proper (list_val_equiv ==> val_equiv) (vConstr i nm). Proof. - cbv;intros;apply constr_cons_compat;assumption. + cbv; intros; apply constr_cons_compat; assumption. Defined. End Equivalence. diff --git a/embedding/theories/EvalE.v b/embedding/theories/EvalE.v index f9002808..b7b1eee4 100644 --- a/embedding/theories/EvalE.v +++ b/embedding/theories/EvalE.v @@ -47,7 +47,7 @@ Definition option_to_res {A : Type} (o : option A) (msg : string) := | None => EvalError msg end. -Definition todo {A} := EvalError (A:=A) "Not implemented". +Definition todo {A} := EvalError (A := A) "Not implemented". Import Basics. @@ -78,7 +78,7 @@ Definition val_ind_full AllEnv P ρ -> P (vClos ρ n cm ty1 ty2 e0)) (Htyclos : forall (ρ : env val) (n : ename) (e0 : expr), AllEnv P ρ -> P (vTyClos ρ n e0)) - (Hty : forall (t : type), P (vTy t)) : + (Hty : forall (t : type), P (vTy t)) : forall v : val, P v. refine (fix val_ind_fix (v : val) := _). destruct v. @@ -104,7 +104,7 @@ Definition val_elim_full AllEnv P ρ -> P (vClos ρ n cm ty1 ty2 e0)) (Htyclos : forall (ρ : env val) (n : ename) (e0 : expr), AllEnv P ρ -> P (vTyClos ρ n e0)) - (Hty : forall (t : type), P (vTy t)) : + (Hty : forall (t : type), P (vTy t)) : forall v : val, P v. refine (fix val_ind_fix (v : val) := _). destruct v. @@ -144,7 +144,7 @@ Definition match_pat {A} (cn : ename) (nparam : nat) (arity :list type) else EvalError (cn ++ ": constructor arity does not match") else EvalError (cn ++ ": pattern arity does not match (constructor: " ++ String.to_string (string_of_nat ctr_len) ++ ", - pattern: " ++ String.to_string (string_of_nat pt_len) ++ ")"). + pattern: " ++ String.to_string (string_of_nat pt_len) ++ ")"). Fixpoint inductive_name (ty : type) : option ename := match ty with @@ -164,7 +164,7 @@ Fixpoint eval_type_i (k : nat) (ρ : env val) (ty : type) : option type := ty2' <- eval_type_i k ρ ty2;; ty1' <- eval_type_i k ρ ty1;; match decompose_inductive ty1' with - | Some _ => ret (tyApp ty1' ty2') + | Some _ => ret (tyApp ty1' ty2') | _ => None end | tyVar nm => None @@ -190,7 +190,7 @@ Fixpoint eval_type_n (ρ : env val) (ty : type) : option type := ty2' <- eval_type_n ρ ty2;; ty1' <- eval_type_n ρ ty1;; match decompose_inductive ty1' with - | Some _ => ret (tyApp ty1' ty2') + | Some _ => ret (tyApp ty1' ty2') | _ => None end | tyVar nm => match lookup ρ nm with @@ -221,7 +221,7 @@ Fixpoint print_type (ty : type) : string := Definition is_type_val (v : val) : bool := match v with - | vTy ty => true + | vTy ty => true | _ => false end. @@ -240,11 +240,11 @@ Fixpoint valid_ty_env (n : nat) (ρ : env val) (ty : type): bool := | tyArr ty1 ty2 => valid_ty_env n ρ ty1 && valid_ty_env n ρ ty2 end. -Definition valid_env (ρ : env val) : nat -> expr -> bool:= +Definition valid_env (ρ : env val) : nat -> expr -> bool := fix rec n e := match e with | eRel i => true - | eVar nm => false + | eVar nm => false | eLambda nm ty b => valid_ty_env n ρ ty && rec (1+n) b | eTyLam nm b => rec (1+n) b | eLetIn nm e1 ty e2 => rec n e1 && valid_ty_env n ρ ty && rec (1+n) e2 diff --git a/embedding/theories/Misc.v b/embedding/theories/Misc.v index ff236b3c..7aa300b8 100644 --- a/embedding/theories/Misc.v +++ b/embedding/theories/Misc.v @@ -14,23 +14,23 @@ Lemma forallb_Forall_iff {A} (p : A -> bool) (l : list A): Forall (fun x => p x = true) l <-> forallb p l = true. Proof. split. - + induction l;intros H. + + induction l; intros H. * reflexivity. * simpl. inversion H as [H1 | a1 l1 Heq]. subst. rewrite Heq. simpl. now eapply IHl. - + induction l;intros H. + + induction l; intros H. * constructor. * simpl in *. rewrite Bool.andb_true_iff in *. destruct H. - constructor;auto. + constructor; auto. Qed. Lemma Forall_impl_inner {A} (P Q : A -> Prop) l : Forall P l -> Forall (fun x => P x -> Q x) l -> Forall Q l. Proof. - intros HP. induction HP;intros HQ. + intros HP. induction HP; intros HQ. + constructor. - + constructor;inversion HQ;auto. + + constructor; inversion HQ; auto. Qed. @@ -38,16 +38,16 @@ Lemma All_impl_inner {A} (P Q : A -> Type) l : All P l -> All (fun x => P x -> Q x) l -> All Q l. Proof. - intros HP. induction HP;intros HQ. + intros HP. induction HP; intros HQ. + constructor. - + constructor;inversion HQ;auto. + + constructor; inversion HQ; auto. Qed. Lemma forallb_impl_inner {A} {p q} {l : list A} : forallb p l -> (forall x, p x = true -> q x = true) -> forallb q l. Proof. revert p q. - induction l;simpl;intros p q Hfa H;auto. + induction l; simpl; intros p q Hfa H; auto. now propify. Qed. @@ -57,9 +57,9 @@ Lemma Forall_In {A} x (xs : list A) P : P x. Proof. revert x. - induction xs;intros x Hin Hfa;auto. + induction xs; intros x Hin Hfa; auto. * inversion Hin. - * simpl in *. destruct Hin;subst; inversion Hfa;eauto. + * simpl in *. destruct Hin; subst; inversion Hfa; eauto. Qed. Lemma forallb_In {A} x (xs : list A) p : @@ -68,8 +68,8 @@ Lemma forallb_In {A} x (xs : list A) p : p x. Proof. revert x. - induction xs;intros x Hin Hfa;auto. - simpl in *. propify;intuition;subst;auto. + induction xs; intros x Hin Hfa; auto. + simpl in *. propify; intuition; subst; auto. Qed. @@ -80,9 +80,9 @@ Section CombineProp. combine (l1 ++ l1') (l2 ++ l2') = combine l1 l2 ++ combine l1' l2'. Proof. induction l2. - + simpl. intros l2' l1 l1' Heq. destruct l1;try discriminate;reflexivity. - + simpl. intros l2' l1 l1' Heq. destruct l1;cbn; inversion Heq. - simpl. apply f_equal2;eauto. + + simpl. intros l2' l1 l1' Heq. destruct l1; try discriminate; reflexivity. + + simpl. intros l2' l1 l1' Heq. destruct l1; cbn; inversion Heq. + simpl. apply f_equal2; eauto. Qed. Lemma combine_rev : forall A B (l2 : list B) (l1 : list A), @@ -91,10 +91,10 @@ Section CombineProp. Proof. intros A B. induction l2 using rev_ind. - + simpl. intros l1 Heq. destruct l1;eauto. - simpl;destruct (rev l1 ++ [a]);reflexivity. - + simpl. intros l1 Heq. destruct l1 using rev_ind;auto. - repeat rewrite app_length in Heq;simpl in *. + + simpl. intros l1 Heq. destruct l1; eauto. + simpl; destruct (rev l1 ++ [a]); reflexivity. + + simpl. intros l1 Heq. destruct l1 using rev_ind; auto. + repeat rewrite app_length in Heq; simpl in *. assert (#|l1| = #|l2|) by lia. repeat rewrite rev_unit. simpl. rewrite IHl2 by auto. @@ -107,9 +107,9 @@ Section CombineProp. map snd (combine l1 l2) = l2. Proof. induction l2. - + simpl. intros l1 Heq. destruct l1;reflexivity. - + simpl. intros l1 Heq. destruct l1;cbn. inversion Heq. - simpl. apply f_equal2;eauto. + + simpl. intros l1 Heq. destruct l1; reflexivity. + + simpl. intros l1 Heq. destruct l1; cbn. inversion Heq. + simpl. apply f_equal2; eauto. Qed. @@ -124,7 +124,7 @@ Section CombineProp. forall A B C (f : B -> C) (l1 : list A) (l2 : list B), map (fun_prod id f) (combine l1 l2) = combine l1 (map f l2). Proof. - induction l1;intros. + induction l1; intros. + reflexivity. + destruct l2. * reflexivity. diff --git a/embedding/theories/Notations.v b/embedding/theories/Notations.v index 85421353..e0d78c89 100644 --- a/embedding/theories/Notations.v +++ b/embedding/theories/Notations.v @@ -120,7 +120,7 @@ Notation "'data' ty_nm '=' c1 | c2" := Notation "'data' ty_nm '=' c1 | c2 | c3" := (let (nm, nparams) := ty_nm in - gdInd nm nparams (map unnamed_constr [c1;c2;c3]) false) + gdInd nm nparams (map unnamed_constr [c1; c2; c3]) false) (in custom global_dec at level 1, ty_nm custom data_name at level 2, c1 custom ctor at level 2, @@ -129,7 +129,7 @@ Notation "'data' ty_nm '=' c1 | c2 | c3" := Notation "'data' ty_nm '=' c1 | c2 | c3 | c4" := (let (nm, nparams) := ty_nm in - gdInd nm nparams (map unnamed_constr [c1;c2;c3;c4]) false) + gdInd nm nparams (map unnamed_constr [c1; c2; c3; c4]) false) (in custom global_dec at level 1, ty_nm custom data_name at level 2, c1 custom ctor at level 2, @@ -139,7 +139,7 @@ Notation "'data' ty_nm '=' c1 | c2 | c3 | c4" := Notation "'data' ty_nm '=' c1 | c2 | c3 | c4 | c5" := (let (nm, nparams) := ty_nm in - gdInd nm 0 (map unnamed_constr [c1;c2;c3;c4;c5]) false) + gdInd nm 0 (map unnamed_constr [c1; c2; c3; c4; c5]) false) (in custom global_dec at level 1, ty_nm custom data_name at level 2, c1 custom ctor at level 2, @@ -164,7 +164,7 @@ Notation "'record' rec_nm := rec_ctor { pr1 : ty1 }" := ty1 custom type at level 4). Notation "'record' rec_nm := rec_ctor { pr1 : ty1 ; pr2 : ty2 }" := - (gdInd rec_nm 0 [ rec_constr rec_ctor [(Some pr1,ty1);(Some pr2,ty2)]] true) + (gdInd rec_nm 0 [ rec_constr rec_ctor [(Some pr1,ty1); (Some pr2,ty2)]] true) (in custom global_dec at level 1, rec_nm constr at level 4, rec_ctor constr at level 4, @@ -175,7 +175,7 @@ Notation "'record' rec_nm := rec_ctor { pr1 : ty1 ; pr2 : ty2 }" := Notation "'record' rec_nm := rec_ctor { pr1 : ty1 ; pr2 : ty2 ; pr3 : ty3 }" := (gdInd rec_nm 0 - [ rec_constr rec_ctor [(Some pr1,ty1);(Some pr2,ty2);(Some pr3,ty3)]] true) + [ rec_constr rec_ctor [(Some pr1,ty1); (Some pr2,ty2); (Some pr3,ty3)]] true) (in custom global_dec at level 1, rec_nm constr at level 4, rec_ctor constr at level 4, @@ -188,8 +188,8 @@ Notation "'record' rec_nm := rec_ctor { pr1 : ty1 ; pr2 : ty2 ; pr3 : ty3 }" := Notation "'record' rec_nm # n := rec_ctor { pr1 : ty1 ; pr2 : ty2 ; pr3 : ty3 ; pr4 : ty4 }" := (gdInd rec_nm n - [ rec_constr rec_ctor [(Some pr1,ty1);(Some pr2,ty2); - (Some pr3,ty3);(Some pr4,ty4)]] true) + [ rec_constr rec_ctor [(Some pr1,ty1); (Some pr2,ty2); + (Some pr3,ty3); (Some pr4,ty4)]] true) (in custom global_dec at level 1, rec_nm constr at level 4, rec_ctor constr at level 4, @@ -206,8 +206,8 @@ Notation "'record' rec_nm # n := rec_ctor { pr1 : ty1 ; pr2 : ty2 ; pr3 : ty3 ; Notation "'record' rec_nm := rec_ctor { pr1 : ty1 ; pr2 : ty2 ; pr3 : ty3 ; pr4 : ty4 }" := (gdInd rec_nm 0 - [ rec_constr rec_ctor [(Some pr1,ty1);(Some pr2,ty2); - (Some pr3,ty3);(Some pr4,ty4)]] true) + [ rec_constr rec_ctor [(Some pr1,ty1); (Some pr2,ty2); + (Some pr3,ty3); (Some pr4,ty4)]] true) (in custom global_dec at level 1, rec_nm constr at level 4, rec_ctor constr at level 4, @@ -222,8 +222,8 @@ Notation "'record' rec_nm := rec_ctor { pr1 : ty1 ; pr2 : ty2 ; pr3 : ty3 ; pr4 Notation "'record' rec_nm := rec_ctor { pr1 : ty1 ; pr2 : ty2 ; pr3 : ty3 ; pr4 : ty4 ; pr5 : ty5 }" := (gdInd rec_nm 0 - [ rec_constr rec_ctor [(Some pr1,ty1);(Some pr2,ty2); - (Some pr3,ty3);(Some pr4,ty4); + [ rec_constr rec_ctor [(Some pr1,ty1); (Some pr2,ty2); + (Some pr3,ty3); (Some pr4,ty4); (Some pr5,ty5)]] true) (in custom global_dec at level 1, rec_nm constr at level 4, @@ -241,9 +241,9 @@ Notation "'record' rec_nm := rec_ctor { pr1 : ty1 ; pr2 : ty2 ; pr3 : ty3 ; pr4 Notation "'record' rec_nm := rec_ctor { pr1 : ty1 ; pr2 : ty2 ; pr3 : ty3 ; pr4 : ty4 ; pr5 : ty5 ; pr6 : ty6 }" := (gdInd rec_nm 0 - [ rec_constr rec_ctor [(Some pr1,ty1);(Some pr2,ty2); - (Some pr3,ty3);(Some pr4,ty4); - (Some pr5,ty5);(Some pr6,ty6)]] true) + [ rec_constr rec_ctor [(Some pr1,ty1); (Some pr2,ty2); + (Some pr3,ty3); (Some pr4,ty4); + (Some pr5,ty5); (Some pr6,ty6)]] true) (in custom global_dec at level 1, rec_nm constr at level 4, rec_ctor constr at level 4, @@ -296,7 +296,7 @@ Notation "C" := (pConstr C []) (in custom pat at level 0, C constr at level 4). -(* Notation "'case' x : ty 'of' b1 | .. | bn " := *) +(* Notation "'case' x : ty 'of' b1 | .. | bn " := *) (* (eCase (ty,0) (tyInd "") x (cons b1 .. (cons bn nil) ..)) *) (* (in custom expr at level 1, *) (* b1 custom expr at level 4, *) @@ -316,7 +316,7 @@ Notation "ind ty" := (ciParamInd ind [ty]) (in custom case_info at level 1, ind constr at level 4, ty custom type at level 4). -Notation "ind ty1 , ty2" := (ciParamInd ind [ty1;ty2]) (in custom case_info at level 1, +Notation "ind ty1 , ty2" := (ciParamInd ind [ty1; ty2]) (in custom case_info at level 1, ind constr at level 4, ty1 custom type at level 4, ty2 custom type at level 4). @@ -327,8 +327,8 @@ Definition ci_to_types (ci : case_info ) := | ciParamInd ind tys => (ind, tys) end. -Notation "'case' x : ci 'return' ty2 'of' | p1 -> b1 | p2 -> b2 | p3 -> b3" := - (eCase (ci_to_types ci) ty2 x [(p1,b1);(p2,b2);(p3,b3)]) +Notation "'case' x : ci 'return' ty2 'of' | p1 -> b1 | p2 -> b2 | p3 -> b3" := + (eCase (ci_to_types ci) ty2 x [(p1,b1); (p2,b2); (p3,b3)]) (in custom expr at level 2, p1 custom pat at level 4, p2 custom pat at level 4, @@ -341,7 +341,7 @@ Notation "'case' x : ci 'return' ty2 'of' | p1 -> b1 | p2 -> b2 | p3 -> b3" := Notation "'case' x : ci 'return' ty2 'of' | p1 -> b1 | pn -> bn" := - (eCase (ci_to_types ci) ty2 x [(p1,b1);(pn,bn)]) + (eCase (ci_to_types ci) ty2 x [(p1,b1); (pn,bn)]) (in custom expr at level 2, p1 custom pat at level 4, pn custom pat at level 4, diff --git a/embedding/theories/Prelude.v b/embedding/theories/Prelude.v index 46ca54ca..5b2744d5 100644 --- a/embedding/theories/Prelude.v +++ b/embedding/theories/Prelude.v @@ -66,7 +66,7 @@ Module Maps. * simpl. now rewrite Heq. Qed. - Fixpoint to_list (m : addr_map_coq) : list (nat * Z)%type:= + Fixpoint to_list (m : addr_map_coq) : list (nat * Z)%type := match m with | mnil => nil | mcons k v tl => cons (k,v) (to_list tl) @@ -79,13 +79,13 @@ Module Maps. end. Lemma of_list_to_list m: of_list (to_list m) = m. - Proof. induction m;simpl;congruence. Qed. + Proof. induction m; simpl; congruence. Qed. Lemma to_list_of_list l: to_list (of_list l) = l. - Proof. induction l as [ | x l'];simpl;auto. - destruct x. simpl;congruence. Qed. + Proof. induction l as [ | x l']; simpl; auto. + destruct x. simpl; congruence. Qed. - Fixpoint map_forallb (p : Z -> bool)(m : addr_map_coq) : bool:= + Fixpoint map_forallb (p : Z -> bool)(m : addr_map_coq) : bool := match m with | mnil => true | mcons k v m' => p v && map_forallb p m' @@ -97,9 +97,9 @@ Module Maps. p v = true. Proof. revert k v p. - induction m;intros;try discriminate;simpl in *. - propify. destruct (_ =? _)%nat;auto. - * now inversion H0;subst. + induction m; intros; try discriminate; simpl in *. + propify. destruct (_ =? _)%nat; auto. + * now inversion H0; subst. * easy. Qed. @@ -109,18 +109,18 @@ Module Maps. Notation "'MNil'" := [| {eConstr Map "mnil"} |] (in custom expr at level 0). - Notation "'mfind' a b" := [| {eConst (to_string_name <% lookup_map %>)} {a} {b} |] + Notation "'mfind' a b" := [| {eConst (to_string_name <% lookup_map %>)} {a} {b} |] (in custom expr at level 0, a custom expr at level 1, b custom expr at level 1). - Notation "'madd' a b c" := [| {eConst (to_string_name <% add_map %>)} {a} {b} {c} |] + Notation "'madd' a b c" := [| {eConst (to_string_name <% add_map %>)} {a} {b} {c} |] (in custom expr at level 0, a custom expr at level 1, b custom expr at level 1, c custom expr at level 1). - Notation "'mem' a b" := [| {eConst (to_string_name <% inmap_map %>)} {a} {b} |] + Notation "'mem' a b" := [| {eConst (to_string_name <% inmap_map %>)} {a} {b} |] (in custom expr at level 0, a custom expr at level 1, b custom expr at level 1). @@ -180,7 +180,7 @@ Notation "'True'" := (pConstr true_name []) (in custom pat at level 0). Notation "'False'" := (pConstr false_name []) ( in custom pat at level 0). Notation "'Nil'" := (pConstr "nil" []) (in custom pat at level 0). -Notation "'Cons' y z" := (pConstr "cons" [y;z]) +Notation "'Cons' y z" := (pConstr "cons" [y; z]) (in custom pat at level 0, y constr at level 4, z constr at level 4). @@ -200,7 +200,7 @@ Notation "A × B" := (tyApp (tyApp (tyInd Prod) A) B) Notation "'Pair' b o" := - (pConstr "pair" [b;o]) (in custom pat at level 0, + (pConstr "pair" [b; o]) (in custom pat at level 0, b constr at level 4, o constr at level 4). @@ -245,12 +245,12 @@ Notation "'Cons' A x xs" := Definition Maybe := to_string_name <% option %>. Definition AcornMaybe : global_dec := - gdInd Maybe 1 [("Some", [(None, tyRel 0)]);("None", [])] false. + gdInd Maybe 1 [("Some", [(None, tyRel 0)]); ("None", [])] false. -(** A shortcut for [if .. then .. else ..] *) +(** A shortcut for [if .. then .. else ..] *) Notation "'if' cond 'then' b1 'else' b2 : ty" := (eCase (Bool,[]) ty cond - [(pConstr true_name [],b1);(pConstr false_name [],b2)]) + [(pConstr true_name [],b1); (pConstr false_name [],b2)]) (in custom expr at level 4, cond custom expr at level 4, ty custom type at level 4, diff --git a/embedding/theories/SimpleBlockchain.v b/embedding/theories/SimpleBlockchain.v index 45c8c7b6..0c414e84 100644 --- a/embedding/theories/SimpleBlockchain.v +++ b/embedding/theories/SimpleBlockchain.v @@ -1,4 +1,4 @@ -(** * A simply-typed version of the blockchain execution environment *) +(** * A simply-typed version of the blockchain execution environment *) (* We develop some blockchain infrastructure relevant for the contract execution. *) From ConCert.Embedding Require Import Ast. From ConCert.Embedding Require Import Notations. @@ -49,7 +49,7 @@ Module AcornBlockchain. (* MetaCoq Unquote Inductive (global_to_tc SimpleChainAcorn). *) Record SimpleChain_coq : Set := Build_chain_coq - { Chain_height : nat; Current_slot : nat; Finalized_height : nat }. + { Chain_height : nat; Current_slot : nat; Finalized_height : nat }. Notation "'cur_time' a" := [| {eConst (to_string_name <% Current_slot %>)} {a} |] diff --git a/embedding/theories/Tests.v b/embedding/theories/Tests.v index b786ae39..305b9127 100644 --- a/embedding/theories/Tests.v +++ b/embedding/theories/Tests.v @@ -20,20 +20,24 @@ Definition x := "x". Definition y := "y". Definition z := "z". -Check [| ^0 |]. +Example ex1 : + [| ^0 |] = eRel 0. +Proof. reflexivity. Qed. -Check [| \x : Nat => y |]. - -Definition id_f_syn := [| (\x : Nat => ^0) 1 |]. +Definition id_f_syn := [| (\x : Nat => ^0) 1 |]. MetaCoq Unquote Definition id_f_one := (expr_to_tc Σ id_f_syn). -Example id_f_eq : id_f_one = 1. Proof. reflexivity. Qed. +Example id_f_eq : + id_f_one = 1. +Proof. reflexivity. Qed. (* The same as [id_f_syn], but with named vars *) Definition id_f_with_vars := [| (\x : Nat => x) 1 |]. MetaCoq Unquote Definition id_f_one' := (expr_to_tc Σ (indexify [] id_f_with_vars)). -Example id_f_eq' : id_f_one' = 1. Proof. reflexivity. Qed. +Example id_f_eq' : + id_f_one' = 1. +Proof. reflexivity. Qed. Definition simple_let_syn := [| @@ -42,7 +46,9 @@ Definition simple_let_syn := |]. MetaCoq Unquote Definition simple_let := (expr_to_tc Σ simple_let_syn). -Example simple_let_eq : simple_let 1 = 1. Proof. reflexivity. Qed. +Example simple_let_eq : + simple_let 1 = 1. +Proof. reflexivity. Qed. Definition simple_let_with_vars_syn := [| @@ -51,7 +57,9 @@ Definition simple_let_with_vars_syn := |]. MetaCoq Unquote Definition simple_let' := (expr_to_tc Σ (indexify [] simple_let_with_vars_syn)). -Example simple_let_eq' : simple_let' 0 = 1. Proof. reflexivity. Qed. +Example simple_let_eq' : + simple_let' 0 = 1. +Proof. reflexivity. Qed. Definition negb_syn := @@ -66,7 +74,7 @@ MetaCoq Unquote Definition negb' := (expr_to_tc Σ (indexify [] negb_syn)). Example negb'_correct : forall b, negb' b = negb b. Proof. - destruct b;easy. + destruct b; easy. Qed. Definition myplus_syn := @@ -86,34 +94,42 @@ MetaCoq Quote Recursively Definition q_stupid_case_rec := stupid_case. MetaCoq Quote Definition cons_syn := (fun A : Set => cons A). Definition case_ex := - [| \\y => \x : 'y => \z : List 'y => + [| \\y => \x : 'y => \z : List 'y => case z : List 'y return 'y of | Nil -> x | Cons "hd" "tl" -> x |]. -Compute (expr_to_tc Σ (indexify [] case_ex)). +(* Compute (expr_to_tc Σ (indexify [] case_ex)). *) + +MetaCoq Unquote Definition case_ex_def := (expr_to_tc Σ (indexify [] case_ex)). -MetaCoq Unquote Definition case_ex_def := (expr_to_tc Σ (indexify [] case_ex)). +Example case_ex_def_unquote : + case_ex_def = + fun (y : Set) (x : y) (z : list y) => + match z with + | [] | _ => x + end. +Proof. reflexivity. Qed. Definition case_ex1 := - [| \\y => \"w" : 'y => \x : 'y => \z : List 'y => + [| \\y => \"w" : 'y => \x : 'y => \z : List 'y => case z : List 'y return Prod 'y 'y of | Nil -> {eConstr Prod "pair"} {eTy (tyVar y)} {eTy (tyVar y)} x x | Cons "hd" "tl" -> {eConstr Prod "pair"} {eTy (tyVar y)} {eTy (tyVar y)} "hd" x |]. -Compute (expr_to_tc Σ (indexify [] case_ex1)). +(* Compute (expr_to_tc Σ (indexify [] case_ex1)). *) -MetaCoq Unquote Definition case_ex_def1 := (expr_to_tc Σ (indexify [] case_ex1)). +MetaCoq Unquote Definition case_ex_def1 := (expr_to_tc Σ (indexify [] case_ex1)). Definition case_ex2 := [| \\y => case ({eConstr List "nil"} "y") : List 'y return List 'y of | Nil -> {eConstr List "nil"} "y" | Cons "hd" "tl" -> {eConstr List "nil"} "y" |]. -Compute indexify [] case_ex2. -Compute (expr_to_tc Σ (indexify [] case_ex2)). +(* Compute indexify [] case_ex2. *) +(* Compute (expr_to_tc Σ (indexify [] case_ex2)). *) -MetaCoq Unquote Definition case_ex_def2 := (expr_to_tc Σ (indexify [] case_ex2)). +MetaCoq Unquote Definition case_ex_def2 := (expr_to_tc Σ (indexify [] case_ex2)). Definition example_type := [! ∀ "A", ∀ "B", Prod '"A" '"B" !]. @@ -121,7 +137,7 @@ MetaCoq Unquote Definition ex_type_def := (type_to_tc (indexify_type [] example_ Definition map_syn := gdInd "AMap" 2 [("ANil", []); - ("ACons", [(None,tyRel 1);(None,tyRel 0); + ("ACons", [(None,tyRel 1); (None,tyRel 0); (None,(tyApp (tyApp (tyInd "AMap") (tyRel 1)) (tyRel 0)))])] false. MetaCoq Unquote Inductive (global_to_tc map_syn). diff --git a/embedding/theories/TranslationUtils.v b/embedding/theories/TranslationUtils.v index 34932e89..1f95fefc 100644 --- a/embedding/theories/TranslationUtils.v +++ b/embedding/theories/TranslationUtils.v @@ -50,7 +50,7 @@ Program Definition dec_pair_string (p1 p2 : string × string) : _. Next Obligation. specialize (String.string_dec s1 s) as H1. specialize (String.string_dec s2 s0) as H2. - destruct H1;subst. destruct H2;subst;auto. + destruct H1; subst. destruct H2; subst; auto. right. intro HH. inversion HH. contradiction. right. intro HH. inversion HH. contradiction. Defined. @@ -61,13 +61,13 @@ Definition prefixes_gds (gds : list global_dec) (deps : env string) (p : string) nodup dec_pair_string (concat (map (fun gd => build_prefix_table_gd gd deps p) gds)). -Fixpoint build_prefix_table (e : expr) (deps : env string) (p : string) : env string:= +Fixpoint build_prefix_table (e : expr) (deps : env string) (p : string) : env string := match e with | eRel _ | eVar _ => [] | eLambda nm ty e1 => build_prefix_table_ty ty deps p ++ build_prefix_table e1 deps p | eTyLam nm e1 => build_prefix_table e1 deps p - | eLetIn nm e1 ty e2 => + | eLetIn nm e1 ty e2 => build_prefix_table e1 deps p ++ build_prefix_table_ty ty deps p ++ build_prefix_table e2 deps p @@ -100,15 +100,15 @@ Fixpoint build_prefix_table (e : expr) (deps : env string) (p : string) : env st | eTy ty => build_prefix_table_ty ty deps p end. -Definition prefixes (defs : list (string × expr)) (deps : env string) (p : string) - := nodup dec_pair_string (concat (map (fun def => build_prefix_table def.2 deps p) defs)). +Definition prefixes (defs : list (string × expr)) (deps : env string) (p : string) := + nodup dec_pair_string (concat (map (fun def => build_prefix_table def.2 deps p) defs)). Definition stdlib_prefixes : env string := fold_left (fun l gd => match gd with | gdInd ty_name _ _ _ => let (mp,nm) := kername_of_string ty_name - in ( TCString.to_string nm, (PCUICTranslate.string_of_modpath mp ++ "@")%string) :: l + in ( TCString.to_string nm, (PCUICTranslate.string_of_modpath mp ++ "@")%string) :: l end) StdLib.Σ []. (** We translate and unquote a list of data type declarations in the TemplateMonad *) diff --git a/embedding/theories/Wf.v b/embedding/theories/Wf.v index cc43c8de..1ded19e2 100644 --- a/embedding/theories/Wf.v +++ b/embedding/theories/Wf.v @@ -46,15 +46,15 @@ Definition genv_ok Σ := forallb global_dec_ok Σ. | tyArr ty1 ty2 => ty_env_ok n ρ ty1 && ty_env_ok n ρ ty2 end. - (** ** Well-formedness condition on evaluation environments wrt. an expression (In the paper : (WF.ii) ) *) + (** ** Well-formedness condition on evaluation environments wrt. an expression (In the paper : (WF.ii)) *) (** [ρ] is well-formed wrt. an expression [e] when for any type variables mentioned in [e], if there is a corresponding expression in ρ (starting from the index [n]) it corresponds to a type. *) - Definition ty_expr_env_ok (ρ : env expr) : nat -> expr -> bool:= + Definition ty_expr_env_ok (ρ : env expr) : nat -> expr -> bool := fix rec n e := match e with | eRel i => true - | eVar nm => false + | eVar nm => false | eLambda nm ty b => ty_env_ok n ρ ty && rec (1+n) b | eTyLam nm b => rec (1+n) b | eLetIn nm e1 ty e2 => rec n e1 && ty_env_ok n ρ ty && rec (1+n) e2 @@ -84,7 +84,7 @@ Definition genv_ok Σ := forallb global_dec_ok Σ. ty_val ty2 -> ty_val (tyArr ty1 ty2). - (** Well-formed value (In the paper: (WF.iii) ) *) + (** Well-formed value (In the paper: (WF.iii)) *) Inductive val_ok Σ : val -> Type := | vokClosLam : forall e nm ρ ty1 ty2, AllEnv (val_ok Σ) ρ -> diff --git a/embedding/theories/pcuic/PCUICCorrectness.v b/embedding/theories/pcuic/PCUICCorrectness.v index 82c819d2..a8a57bb2 100644 --- a/embedding/theories/pcuic/PCUICCorrectness.v +++ b/embedding/theories/pcuic/PCUICCorrectness.v @@ -30,9 +30,9 @@ Local Set Keyed Unification. Open Scope nat. #[local] - Hint Resolve assumption_context_subst - assumption_context_map_vass - PCUICSigmaCalculus.context_assumptions_context : hints. +Hint Resolve assumption_context_subst + assumption_context_map_vass + PCUICSigmaCalculus.context_assumptions_context : hints. (** Soundness (In the paper: Theorem 1) *) Theorem expr_to_term_sound (n : nat) (ρ : env val) Σ1 Σ2 @@ -51,85 +51,85 @@ Proof. revert dependent e1. induction n. - now intros. - - intros e1 e2 ρ v Hsync Hgeok Hρ_ok He Henv Hc;destruct e1. + - intros e1 e2 ρ v Hsync Hgeok Hρ_ok He Henv Hc; destruct e1. + (* eRel *) simpl in *. autounfold with facts in *. simpl in *. - destruct (lookup_i ρ n0) as [v1| ] eqn:Hlookup;tryfalse; simpl in He;inversion He;subst. + destruct (lookup_i ρ n0) as [v1| ] eqn:Hlookup; tryfalse; simpl in He; inversion He; subst. destruct (Nat.ltb n0 (length ρ)) eqn:Hn0. * destruct (inst_env_i_in _ _ Hn0) as [v2 HH]. destruct HH as [H1 H2]. assert (v = v2) by congruence. subst. - assert (ge_val_ok Σ1 v2) by (apply val_ok_ge_val_ok;eapply All_lookup_i;eauto). + assert (ge_val_ok Σ1 v2) by (apply val_ok_ge_val_ok; eapply All_lookup_i; eauto). rewrite H2. eapply PcbvCurr.value_final; eapply Wcbv_of_value_value; eauto with hints. - eapply All_lookup_i;eauto. - * specialize (lookup_i_length_false _ _ Hn0) as Hnone;tryfalse. - + (* eVar *) simpl;tryfalse. + eapply All_lookup_i; eauto. + * specialize (lookup_i_length_false _ _ Hn0) as Hnone; tryfalse. + + (* eVar *) simpl; tryfalse. + (* eLambda *) subst. simpl in *. - destruct (eval_type_i 0 ρ t) eqn:Hty;tryfalse;simpl in *. - destruct (valid_env ρ 1 e1) eqn:He1;tryfalse. propify. - inversion He;subst;simpl;eauto with hints. - erewrite eval_type_i_subst_env;eauto. - rewrite subst_env_ty_closed_n_eq with (n:=0) (m:=0);eauto with hints. - + simpl in *. destruct (valid_env ρ 1 e1) eqn:He1;tryfalse. - inversion He. subst;clear He. - simpl. constructor;eauto. + destruct (eval_type_i 0 ρ t) eqn:Hty; tryfalse; simpl in *. + destruct (valid_env ρ 1 e1) eqn:He1; tryfalse. propify. + inversion He; subst; simpl; eauto with hints. + erewrite eval_type_i_subst_env; eauto. + rewrite subst_env_ty_closed_n_eq with (n := 0) (m := 0); eauto with hints. + + simpl in *. destruct (valid_env ρ 1 e1) eqn:He1; tryfalse. + inversion He. subst; clear He. + simpl. constructor; eauto. + (* eLetIn *) - subst;simpl in *. + subst; simpl in *. unfold is_true in *; - repeat rewrite Bool.andb_true_iff in *. + repeat rewrite Bool.andb_true_iff in *. destruct Hc as [[? ?] ?]. - destruct (eval (n, Σ1, ρ, e1_1)) eqn:He1;tryfalse. - destruct (eval_type_i 0 ρ t) eqn:Ht0;tryfalse. inversion He;subst;clear He. - assert (He11 : Σ2 |- t⟦ e1_1 .[ exprs ρ] ⟧ Σ1 ⇓ t⟦ of_val_i v0 ⟧ Σ1) + destruct (eval (n, Σ1, ρ, e1_1)) eqn:He1; tryfalse. + destruct (eval_type_i 0 ρ t) eqn:Ht0; tryfalse. inversion He; subst; clear He. + assert (He11 : Σ2 |- t⟦ e1_1 .[ exprs ρ] ⟧ Σ1 ⇓ t⟦ of_val_i v0 ⟧ Σ1) by (eauto with hints). - assert (ty_expr_env_ok (exprs ρ) 0 e1_1) by (eapply eval_ty_expr_env_ok;eauto with hints). + assert (ty_expr_env_ok (exprs ρ) 0 e1_1) by (eapply eval_ty_expr_env_ok; eauto with hints). assert (iclosed_n #|exprs ρ # [e ~> of_val_i v0]| e1_2 = true). - { simpl. eapply subst_env_iclosed_n_inv with (n:=1);eauto with hints. } + { simpl. eapply subst_env_iclosed_n_inv with (n := 1); eauto with hints. } assert (ty_expr_env_ok (exprs ρ # [e ~> of_val_i v0]) 0 e1_2). { change (exprs ρ # [e ~> of_val_i v0]) with (exprs (ρ # [e ~> v0])). - eapply eval_ty_expr_env_ok;eauto with hints. simpl. + eapply eval_ty_expr_env_ok; eauto with hints. simpl. replace #|ρ| with (#|exprs ρ|) by apply map_length. - eapply subst_env_iclosed_n_inv with (n:=1);eauto with hints. } + eapply subst_env_iclosed_n_inv with (n := 1); eauto with hints. } - assert (val_ok Σ1 v0) by (eapply eval_val_ok;eauto with hints). + assert (val_ok Σ1 v0) by (eapply eval_val_ok; eauto with hints). assert (He12 : Σ2 |- t⟦ e1_2 .[exprs ((e, v0) :: ρ)] ⟧ Σ1 ⇓ t⟦ of_val_i v ⟧ Σ1). - { eapply IHn with (ρ:=((e, v0) :: ρ));simpl;eauto 6 with hints. } + { eapply IHn with (ρ := ((e, v0) :: ρ)); simpl; eauto 6 with hints. } simpl in *. unfold subst_env_i in *. - econstructor;eauto. unfold subst1. + econstructor; eauto. unfold subst1. erewrite <- subst_term_subst_env_par_rec in He12 by eauto with hints. - erewrite <- subst_term_subst_env_par_rec;eauto with hints. - rewrite PCUICCSubst.closed_subst by (apply expr_closed_term_closed;auto;eapply of_value_closed;eauto). + erewrite <- subst_term_subst_env_par_rec; eauto with hints. + rewrite PCUICCSubst.closed_subst by (apply expr_closed_term_closed; auto; eapply of_value_closed; eauto). now rewrite <- subst_app_simpl. - now eapply ty_expr_env_ok_app_rec with (n:=0) (ρ1:=[(e,of_val_i v0)]). + now eapply ty_expr_env_ok_app_rec with (n := 0) (ρ1 := [(e,of_val_i v0)]). + (* eApp *) autounfold with facts in *. subst; cbn in *. - destruct (expr_eval_general _ _ _ _ e1_2) eqn:He2;tryfalse. - destruct (expr_eval_general _ _ _ _ e1_1) eqn:He1;tryfalse. + destruct (expr_eval_general _ _ _ _ e1_2) eqn:He2; tryfalse. + destruct (expr_eval_general _ _ _ _ e1_1) eqn:He1; tryfalse. apply Bool.andb_true_iff in Hc. destruct Hc as [Hce1 Hce2]. assert (Hneq1 : [t⟦ inst_env_i ρ e1_2 ⟧ Σ1] <> []) by easy. - destruct v1;tryfalse. + destruct v1; tryfalse. * (* application evaluates to a constructor *) - destruct (resolve_constr _ _ _) eqn:Hres;tryfalse. - destruct p as [p tys]. destruct p as [nparams n1]. destruct (_ <=? _) eqn:Har;tryfalse. + destruct (resolve_constr _ _ _) eqn:Hres; tryfalse. + destruct p as [p tys]. destruct p as [nparams n1]. destruct (_ <=? _) eqn:Har; tryfalse. unfold genv_sync in *. specialize (Hsync _ _ _ _ _ Hres) as HH. destruct HH as [[[??]?] [Hdctor?]]. inversion_clear He. simpl_vars_to_apps. subst. simpl in *. rename e into n0. - rewrite <- mkApps_vars_to_apps;cbn. - rewrite Hres;cbn. + rewrite <- mkApps_vars_to_apps; cbn. + rewrite Hres; cbn. repeat rewrite tApp_mkApps. rewrite <- mkApps_app. - eapply PcbvCurr.eval_construct;eauto with hints. - assert (Hc : P.mkApps (tConstruct {| inductive_mind := kername_of_string i; inductive_ind := 0 |} n1 []) + eapply PcbvCurr.eval_construct; eauto with hints. + assert (Hc : P.mkApps (tConstruct {| inductive_mind := kername_of_string i; inductive_ind := 0 |} n1 []) (map (expr_to_term Σ1) (map of_val_i l)) = t⟦ of_val_i (vConstr i n0 l) ⟧ Σ1). - { cbn. rewrite <- mkApps_vars_to_apps;cbn. + { cbn. rewrite <- mkApps_vars_to_apps; cbn. now rewrite Hres. } rewrite Hc. - eapply IHn;eauto with hints. + eapply IHn; eauto with hints. repeat rewrite map_length. unfold PcbvCurr.cstr_arity. propify. lia. * destruct c. ** (* the closure corresponds to lambda *) @@ -137,144 +137,144 @@ Proof. simpl in *. assert (Hv0 : Σ2|- t⟦e1_2 .[ exprs ρ]⟧ Σ1 ⇓ t⟦ of_val_i v0 ⟧ Σ1) by eauto. - assert (Hv0_ok : val_ok Σ1 v0) by (eapply eval_val_ok;eauto with hints). + assert (Hv0_ok : val_ok Σ1 v0) by (eapply eval_val_ok; eauto with hints). assert (Hlam_ok : val_ok Σ1 (vClos e n0 cmLam t t0 e1)) by - (eapply eval_val_ok with(e:=e1_1);eauto with hints). - inversion Hlam_ok;subst. + (eapply eval_val_ok with(e := e1_1); eauto with hints). + inversion Hlam_ok; subst. assert (He_ok1 : env_ok Σ1 (e # [n0 ~> v0])) by now constructor. assert (Hlam : Σ2 |- t⟦e1_1 .[ exprs ρ]⟧ Σ1 ⇓ t⟦ of_val_i (vClos e n0 cmLam t t0 e1) ⟧ Σ1) by - (eapply IHn with (ρ:=ρ);eauto). + (eapply IHn with (ρ := ρ); eauto). assert (AllEnv (fun e1 : expr => iclosed_n 0 e1 = true) (exprs e)). { inversion He_ok1. subst. apply All_map. unfold compose. simpl. - eapply (All_impl (P := fun x => val_ok Σ1 (snd x)));eauto. - intros a ?; destruct a; simpl;eauto with hints. } + eapply (All_impl (P := fun x => val_ok Σ1 (snd x))); eauto. + intros a ?; destruct a; simpl; eauto with hints. } assert (iclosed_n 1 (e1 .[ exprs e] 1) = true) by eauto with hints. assert (ty_expr_env_ok [(n0, of_val_i v0)] 0 (e1.[exprs e]1)). - { eapply ty_expr_env_ok_subst_env;eauto;simpl. + { eapply ty_expr_env_ok_subst_env; eauto; simpl. change (exprs e # [n0 ~> of_val_i v0]) with (exprs (e # [n0 ~> v0])). - eapply eval_ty_expr_env_ok;eauto. } + eapply eval_ty_expr_env_ok; eauto. } assert (Hsubst : Σ2 |- (t⟦e1.[exprs e]1⟧Σ1){0 := t⟦of_val_i v0⟧Σ1} ⇓ t⟦of_val_i v⟧ Σ1). - { rewrite subst_term_subst_env with (nm:=n0); eauto 8 with hints. } + { rewrite subst_term_subst_env with (nm := n0); eauto 8 with hints. } simpl in *. - eapply PcbvCurr.eval_beta;eauto. + eapply PcbvCurr.eval_beta; eauto. rewrite PCUICCSubst.closed_subst - by (apply expr_closed_term_closed;auto; - eapply of_value_closed;eauto);eauto. + by (apply expr_closed_term_closed; auto; + eapply of_value_closed; eauto); eauto. ** (* the closure corresponds to fix *) simpl in *. rename e into ρ'. rename e0 into n0. - destruct v0;tryfalse. + destruct v0; tryfalse. simpl in *. remember (t⟦e1_1.[exprs ρ] ⟧ Σ1) as tm1. remember (t⟦ e1_2.[exprs ρ] ⟧ Σ1) as tm2. assert (Hfix : Σ2 |- tm1 ⇓ t⟦ of_val_i (vClos ρ' n0 (cmFix _) t t0 e1) ⟧ Σ1) - by (subst;eauto with hints). + by (subst; eauto with hints). change (tApp tm1 tm2) with (mkApps tm1 [tm2]). simpl in Hfix. assert (Hok_ctor: val_ok Σ1 (vConstr i _ l)) by - (eapply eval_val_ok with (e:=e1_2);eauto 8 with hints). - inversion Hok_ctor as [ | | | ????? HresC |];subst;clear Hok_ctor;eauto. + (eapply eval_val_ok with (e := e1_2); eauto 8 with hints). + inversion Hok_ctor as [ | | | ????? HresC |]; subst; clear Hok_ctor; eauto. assert (Hconstr : is_constructor 0 [t⟦ of_val_i (vConstr i e l) ⟧ Σ1]). { simpl. rewrite <- mkApps_vars_to_apps. cbn. unfold isConstruct_app. rewrite decompose_app_mkApps; now rewrite HresC. } - eapply PcbvCurr.eval_fix with (av:=t⟦of_val_i (vConstr i e l)⟧Σ1) (argsv:=[]); - subst;eauto with hints;try reflexivity. + eapply PcbvCurr.eval_fix with (av := t⟦of_val_i (vConstr i e l)⟧Σ1) (argsv := []); + subst; eauto with hints; try reflexivity. cbn. remember (tFix _ _) as tfix. assert (Hok_ctor: val_ok Σ1 (vConstr i _ l)) by eauto 8 with hints. assert (Hok_fix : val_ok Σ1 ((vClos ρ' n0 (cmFix e2) t t0 e1))) by - (eapply eval_val_ok with (ρ:=ρ)(e:=e1_1);eauto with hints). + (eapply eval_val_ok with (ρ := ρ)(e := e1_1); eauto with hints). assert (tfix = t⟦eFix e2 n0 t t0 (e1.[exprs ρ']2)⟧ Σ1). - { simpl. inversion Hok_fix;subst. subst. - repeat rewrite subst_env_i_ty_closed_eq;eauto with hints. } + { simpl. inversion Hok_fix; subst. subst. + repeat rewrite subst_env_i_ty_closed_eq; eauto with hints. } assert (closed tfix). - { rewrite H0. apply expr_closed_term_closed;auto. - inversion Hok_fix;subst. - simpl. propify;split; eauto with hints. } + { rewrite H0. apply expr_closed_term_closed; auto. + inversion Hok_fix; subst. + simpl. propify; split; eauto with hints. } repeat rewrite PCUICCSubst.closed_subst by auto. rewrite simpl_subst_k by auto. clear Heqtfix. subst tfix. - inversion Hok_fix;subst. + inversion Hok_fix; subst. remember (eFix _ _ _ _ _) as efix. assert (Hexprs : AllEnv (fun e => iclosed_n 0 e = true) (exprs ρ')). { apply All_map. - eapply (All_impl (P := fun v => val_ok Σ1 (snd v)));try assumption; - intros a ?;destruct a;cbv;eauto with hints. } + eapply (All_impl (P := fun v => val_ok Σ1 (snd v))); try assumption; + intros a ?; destruct a; cbv; eauto with hints. } - eapply PcbvCurr.eval_beta;eauto with hints. + eapply PcbvCurr.eval_beta; eauto with hints. eapply PcbvCurr.value_final. - eapply Wcbv_value_vars_to_apps;eauto with hints. + eapply Wcbv_value_vars_to_apps; eauto with hints. now eapply All_value_of_val. assert (All (fun v0 : val => iclosed_n 0 (of_val_i v0) = true) l). { eapply All_impl. apply X. intros. - eapply of_value_closed;eauto with hints. } + eapply of_value_closed; eauto with hints. } remember (vars_to_apps _ _) as args. assert (ty_expr_env_ok (nil # [e2 ~> efix] # [n0 ~> args]) 0 (e1.[ exprs ρ']2)). { subst. eapply ty_expr_env_ok_subst_env. - assert (H0 : ty_expr_env_ok (exprs ((n0, vConstr i e l) :: (e2, vClos ρ' n0 (cmFix e2) t t0 e1) :: ρ')) 0 e1) by (eapply eval_ty_expr_env_ok;eauto). + assert (H0 : ty_expr_env_ok (exprs ((n0, vConstr i e l) :: (e2, vClos ρ' n0 (cmFix e2) t t0 e1) :: ρ')) 0 e1) by (eapply eval_ty_expr_env_ok; eauto). cbn in H0. now repeat rewrite subst_env_i_ty_closed_0_eq in H0 by auto. now eapply closed_exprs. } assert (closed t⟦ args ⟧ Σ1). - {subst;apply expr_closed_term_closed;auto. - apply vars_to_apps_iclosed_n;eauto. } + {subst; apply expr_closed_term_closed; auto. + apply vars_to_apps_iclosed_n; eauto. } rewrite PCUICCSubst.closed_subst by auto. assert (AllEnv (iclosed_n 0) [(n0, args); (e2, efix)]). - { subst;repeat constructor;unfold compose;simpl. - now eapply vars_to_apps_iclosed_n. propify;split;eauto with hints. } + { subst; repeat constructor; unfold compose; simpl. + now eapply vars_to_apps_iclosed_n. propify; split; eauto with hints. } rewrite <- subst_app_simpl. simpl. - erewrite subst_term_subst_env_2 with (nm1:=n0) (nm2:=e2) by eauto with hints. + erewrite subst_term_subst_env_2 with (nm1 := n0) (nm2 := e2) by eauto with hints. remember ((n0,_) :: (e2,_) :: ρ') as ρ''. - eapply IHn with (ρ:=ρ''); subst;eauto with hints. + eapply IHn with (ρ := ρ''); subst; eauto with hints. rewrite <- subst_env_compose_2; (simpl; eauto using vars_to_apps_iclosed_n with hints). cbn. now repeat rewrite subst_env_i_ty_closed_0_eq by auto. - propify;split;eauto with hints. + propify; split; eauto with hints. * rename e0 into n0. assert (Hv0 : Σ2 |- t⟦e1_2 .[ exprs ρ]⟧ Σ1 ⇓ t⟦ of_val_i v0 ⟧ Σ1) by eauto with hints. assert (Hv0_ok : val_ok Σ1 v0) by eauto 8 with hints. assert (Hlam_ok : val_ok Σ1 (vTyClos e n0 e1)) by eauto 8 with hints. - inversion Hlam_ok;subst. + inversion Hlam_ok; subst. assert (He_ok1 : env_ok Σ1 (e # [n0 ~> v0])) by now constructor. assert (Hlam : Σ2 |- t⟦e1_1 .[ exprs ρ]⟧ Σ1 ⇓ t⟦ of_val_i (vTyClos e n0 e1) ⟧ Σ1) by - (eapply IHn with (ρ:=ρ);eauto). + (eapply IHn with (ρ := ρ); eauto). assert (AllEnv (fun e1 : expr => iclosed_n 0 e1 = true) (exprs e)). { inversion He_ok1. subst. apply All_map. unfold compose. simpl. - eapply (All_impl (P := fun x => val_ok Σ1 (snd x)));eauto. - intros a ?; destruct a; simpl;eauto with hints. } + eapply (All_impl (P := fun x => val_ok Σ1 (snd x))); eauto. + intros a ?; destruct a; simpl; eauto with hints. } assert (iclosed_n 1 (e1 .[ exprs e] 1) = true) by eauto with hints. assert (ty_expr_env_ok [(n0, of_val_i v0)] 0 (e1.[exprs e]1)). - { eapply ty_expr_env_ok_subst_env;eauto;simpl. + { eapply ty_expr_env_ok_subst_env; eauto; simpl. change (exprs e # [n0 ~> of_val_i v0]) with (exprs (e # [n0 ~> v0])). - eapply eval_ty_expr_env_ok;eauto. } + eapply eval_ty_expr_env_ok; eauto. } assert (Hsubst : Σ2 |- (t⟦e1.[exprs e]1⟧Σ1){0 := t⟦of_val_i v0⟧Σ1} ⇓ t⟦of_val_i v⟧ Σ1). - { rewrite subst_term_subst_env with (nm:=n0); eauto 8 with hints. } + { rewrite subst_term_subst_env with (nm := n0); eauto 8 with hints. } simpl in *. - eapply PcbvCurr.eval_beta;eauto. - now rewrite PCUICCSubst.closed_subst by (apply expr_closed_term_closed;auto;eapply of_value_closed;eauto). + eapply PcbvCurr.eval_beta; eauto. + now rewrite PCUICCSubst.closed_subst by (apply expr_closed_term_closed; auto; eapply of_value_closed; eauto). + (* eConstr *) rename e into n0. - cbn in He. destruct (resolve_constr Σ1 i n0) eqn:Hres;tryfalse. - inversion He;subst;clear He. + cbn in He. destruct (resolve_constr Σ1 i n0) eqn:Hres; tryfalse. + inversion He; subst; clear He. simpl in *. rewrite Hres in *. eauto with hints. + (* eConst *) (* The traslation does not support constants yet *) @@ -283,24 +283,24 @@ Proof. unfold expr_eval_i in He. destruct p. (* dealing with the interpreter *) - unfold is_true in Hc;subst;simpl in Hc;repeat rewrite Bool.andb_true_iff in *. + unfold is_true in Hc; subst; simpl in Hc; repeat rewrite Bool.andb_true_iff in *. simpl in *. destruct Hc as [[[Hce1 ?] ?] HH]. - destruct (forallb _ l) eqn:Hl;tryfalse. - destruct (eval_type_i _ _ t) eqn:Ht0;tryfalse;simpl in *. - destruct (monad_utils.monad_map) eqn:Hmm;tryfalse. - destruct (expr_eval_general _ _ _ _ e1) eqn:He1;tryfalse. - destruct v0;tryfalse. - destruct (string_dec _ _) eqn:Hi;tryfalse;subst. + destruct (forallb _ l) eqn:Hl; tryfalse. + destruct (eval_type_i _ _ t) eqn:Ht0; tryfalse; simpl in *. + destruct (monad_utils.monad_map) eqn:Hmm; tryfalse. + destruct (expr_eval_general _ _ _ _ e1) eqn:He1; tryfalse. + destruct v0; tryfalse. + destruct (string_dec _ _) eqn:Hi; tryfalse; subst. unfold resolve_constr in *. simpl. - destruct (resolve_inductive _ _) eqn:HresI;tryfalse. - destruct (lookup_with_ind _ _) eqn:Hfind_i;tryfalse. + destruct (resolve_inductive _ _) eqn:HresI; tryfalse. + destruct (lookup_with_ind _ _) eqn:Hfind_i; tryfalse. destruct p as [nparams cs]. destruct p0 as [i ci]. simpl in *. rewrite map_length. - destruct (nparams =? #|l0|)%nat eqn:Hnparams;tryfalse. + destruct (nparams =? #|l0|)%nat eqn:Hnparams; tryfalse. assert (HresC: resolve_constr Σ1 i0 e = Some (nparams,i, ci)). { unfold resolve_constr. rewrite HresI. rewrite Hfind_i. reflexivity. } - destruct (match_pat _ _ _ _) eqn:Hpat;tryfalse. + destruct (match_pat _ _ _ _) eqn:Hpat; tryfalse. (* dealing with the translation and the evaluation in PCUIC *) assert (IH' : Σ2 |- t⟦ e1 .[ exprs ρ] ⟧ Σ1 ⇓ t⟦ of_val_i (vConstr i0 e l2) ⟧ Σ1) by @@ -311,8 +311,8 @@ Proof. erewrite <- mkApps_vars_to_apps_constr in IH' by eauto. simpl in IH'. specialize (lookup_ind_nth_error _ _ _ _ Hfind_i) as Hnth_eq. - rewrite nth_error_map in Hnth_eq. destruct (nth_error cs i) eqn:Nci0;tryfalse. - 2 : { rewrite Nci0 in *;tryfalse. } + rewrite nth_error_map in Hnth_eq. destruct (nth_error cs i) eqn:Nci0; tryfalse. + 2 : { rewrite Nci0 in *; tryfalse. } rewrite Nci0 in Hnth_eq. simpl in Hnth_eq. inversion Hnth_eq. subst e. (* Exploiting the fact that pattern-matching succeeds *) @@ -323,37 +323,37 @@ Proof. (* Constructing PCUIC eval derivation for the pattern-matching case *) specialize Hctor_decl as [H1 H2]. - destruct H2 as [Hdctor?]. - eapply PcbvCurr.eval_iota;eauto. + destruct H2 as [Hdctor?]. + eapply PcbvCurr.eval_iota; eauto. * now eapply map_nth_error. * cbn. rewrite map_length. unfold PcbvCurr.cstr_arity. propify. lia. * cbn. unfold etrans_branch. - unfold fun_prod,id;cbn. + unfold fun_prod,id; cbn. remember (fun (x : pat * expr) => t⟦ x.2.[ exprs ρ] (#|pVars x.1|+0)⟧ Σ1) as f. - specialize (find_some_fst_map_snd (p:=fun (x : pat) => (pName x =? c.1)%string) (f:=f) _ _ Hfnd) as Hv2. - destruct Hv2 as [v2 [Hfindv2 [Heqv2 Hf]]];unfold compose in Hfindv2;subst f;cbn in *. + specialize (find_some_fst_map_snd (p := fun (x : pat) => (pName x =? c.1)%string) (f := f) _ _ Hfnd) as Hv2. + destruct Hv2 as [v2 [Hfindv2 [Heqv2 Hf]]]; unfold compose in Hfindv2; subst f; cbn in *. rewrite Hfindv2. rewrite <- Heqv2. - inversion Hnth_eq;subst;clear Hnth_eq. - assert (Heq : (#|pVars v2.1| =? #|remove_proj c|)%nat) by (propify;lia). - rewrite Heq;cbn. + inversion Hnth_eq; subst; clear Hnth_eq. + assert (Heq : (#|pVars v2.1| =? #|remove_proj c|)%nat) by (propify; lia). + rewrite Heq; cbn. assert (Hvass : forall xs, context_assumptions (map (fun '(nm, ty) => vass (aRelevant (nNamed (TCString.of_string nm))) ty) xs) = #|xs|). - { intros;rewrite PCUICSigmaCalculus.context_assumptions_context by auto with hints. + { intros; rewrite PCUICSigmaCalculus.context_assumptions_context by auto with hints. now rewrite map_length. } rewrite Hvass. rewrite combine_length, map_length. lia. * unfold iota_red in *. simpl in *. - unfold expand_lets,expand_lets_k,inst_case_branch_context,inst_case_context;cbn. + unfold expand_lets,expand_lets_k,inst_case_branch_context,inst_case_context; cbn. rewrite subst_context_length. - unfold etrans_branch;cbn. - unfold fun_prod,id;cbn. + unfold etrans_branch; cbn. + unfold fun_prod,id; cbn. remember (fun (x : pat * expr) => t⟦ x.2.[ exprs ρ] (#|pVars x.1|+0)⟧ Σ1) as f. - specialize (find_some_fst_map_snd (p:=fun (x : pat) => (pName x =? c.1)%string) (f:=f) _ _ Hfnd) as Hv2. - destruct Hv2 as [v2 [Hfindv2 [Heqv2 Hf]]];unfold compose in Hfindv2;subst f;cbn in *. + specialize (find_some_fst_map_snd (p := fun (x : pat) => (pName x =? c.1)%string) (f := f) _ _ Hfnd) as Hv2. + destruct Hv2 as [v2 [Hfindv2 [Heqv2 Hf]]]; unfold compose in Hfindv2; subst f; cbn in *. rewrite Hfindv2. rewrite <- Heqv2. - inversion Hnth_eq;subst;clear Hnth_eq. - assert (Heq : (#|pVars v2.1| =? #|remove_proj c|)%nat) by (propify;lia). - rewrite Heq;cbn. + inversion Hnth_eq; subst; clear Hnth_eq. + assert (Heq : (#|pVars v2.1| =? #|remove_proj c|)%nat) by (propify; lia). + rewrite Heq; cbn. repeat rewrite map_length. rewrite combine_length,map_length. replace (min #|pVars v2.1| #|remove_proj c|) with (#|pVars v2.1|) by lia. rewrite <- map_skipn. @@ -361,15 +361,15 @@ Proof. replace ((#|pVars v2.1| + 0)) with (#|pVars v2.1|) in * by lia. assert (Hok_constr: val_ok Σ1 (vConstr i0 c.1 l2)) by eauto 8 with hints. - inversion Hok_constr;subst;clear Hok_constr. + inversion Hok_constr; subst; clear Hok_constr. remember (map (map_decl (subst_instance [])) _ ) as g. rewrite <- map_combine_snd_funprod in Heqg. rewrite All_map_id in Heqg by - (apply All_subst_instance_type_to_term;eauto with hints; - repeat apply All_map;cbn;eauto using All_refl). + (apply All_subst_instance_type_to_term; eauto with hints; + repeat apply All_map; cbn; eauto using All_refl). - rewrite PCUICSigmaCalculus.subst_extended_subst;cbn. + rewrite PCUICSigmaCalculus.subst_extended_subst; cbn. assert (Hext_subst : forall xs k, assumption_context xs -> @@ -377,16 +377,16 @@ Proof. { intros xs k Hvass. rewrite reln_alt_eq. rewrite app_nil_r. rewrite rev_involutive. revert dependent k. - induction xs;intros k;cbn;auto. - inversion Hvass;subst;cbn. + induction xs; intros k; cbn; auto. + inversion Hvass; subst; cbn. replace (k+1) with (1+k) by lia. - apply f_equal2;auto. + apply f_equal2; auto. } - assert (Hvass_ctx : assumption_context g) by (subst g;auto with hints). + assert (Hvass_ctx : assumption_context g) by (subst g; auto with hints). rewrite Hext_subst by assumption. - rewrite map_rev with (l:=reln _ _ _). + rewrite map_rev with (l := reln _ _ _). assert (Hvass_eq : context_assumptions g = #|g|) by now apply PCUICSigmaCalculus.context_assumptions_context. @@ -394,9 +394,9 @@ Proof. change (reln [] 0 g) with (to_extended_list_k g 0). rewrite <- PCUICSubstitution.to_extended_list_k_map_subst by lia. - specialize (find_forallb_map _ Hfnd HH ) as Hclosed_t2;cbn in Hclosed_t2. + specialize (find_forallb_map _ Hfnd HH ) as Hclosed_t2; cbn in Hclosed_t2. - erewrite PCUICInstConv.subst_id with (s:=rev (_));eauto. + erewrite PCUICInstConv.subst_id with (s := rev (_)); eauto. 2: { rewrite rev_length. rewrite to_extended_list_k_length. rewrite Hvass_eq. subst g. repeat rewrite map_length. rewrite combine_length. replace (min #|pVars v2.1| #|remove_proj c|) with (#|pVars v2.1|) by lia. @@ -407,7 +407,7 @@ Proof. replace (#|pVars v2.1| + 0) with #|pVars v2.1| in * by lia. rewrite <- Hf. assert (closedn (#|pVars v2.1|) t⟦ p_es.[ exprs ρ] #|pVars v2.1| ⟧ Σ1) - by (apply expr_closed_term_closed;auto). + by (apply expr_closed_term_closed; auto). now rewrite lift_closed. * auto with hints. } @@ -416,16 +416,16 @@ Proof. { rewrite PCUICSigmaCalculus.context_assumptions_context by auto with hints. rewrite subst_context_length. subst g. repeat rewrite map_length. rewrite combine_length. - replace #|remove_proj c| with #|pVars v2.1| by (propify;lia). + replace #|remove_proj c| with #|pVars v2.1| by (propify; lia). now replace (min #|pVars v2.1| #|pVars v2.1|) with #|pVars v2.1| by lia. } - assert (#|pVars v2.1| = #|skipn (ind_npars mib) l2|) by (rewrite skipn_length;lia). + assert (#|pVars v2.1| = #|skipn (ind_npars mib) l2|) by (rewrite skipn_length; lia). rewrite Hvass_eq1. replace (#|pVars v2.1| + 0) with #|pVars v2.1| in * by lia. assert (closedn #|pVars v2.1| v2.2). - { rewrite <- Hf. apply expr_closed_term_closed;auto. } + { rewrite <- Hf. apply expr_closed_term_closed; auto. } rewrite lift_closed by auto. rewrite <- Hf. remember (fun x : val => t⟦ _ ⟧ _) as f. @@ -434,62 +434,62 @@ Proof. assert (Hmap : map f (rev (skipn (ind_npars mib) l2)) = map h (map (fun_prod id of_val_i)(rev (combine (pVars v2.1) (skipn (ind_npars mib) l2))))). { rewrite map_map. - subst h;simpl. + subst h; simpl. rewrite <- combine_rev by auto. change (fun x : name * val => t⟦ of_val_i (snd x) ⟧ Σ1) with (fun x : name * val => ((expr_to_pcuic Σ1) ∘ of_val_i) (snd x)). - rewrite <- map_map with (g:=(expr_to_term Σ1) ∘ of_val_i) - (f:=snd). + rewrite <- map_map with (g := (expr_to_term Σ1) ∘ of_val_i) + (f := snd). rewrite map_combine_snd. now subst. now repeat rewrite rev_length. } rewrite Hmap. subst h te3. replace (#|pVars v2.1| + 0) with #|pVars v2.1| in * by lia. apply Nat.eqb_eq in Hnparams. - rewrite subst_term_subst_env_par;eauto with hints. - eapply IHn with (ρ:=(rev (combine (pVars v2.1) (skipn (ind_npars mib) l2)) ++ ρ)%list); + rewrite subst_term_subst_env_par; eauto with hints. + eapply IHn with (ρ := (rev (combine (pVars v2.1) (skipn (ind_npars mib) l2)) ++ ρ)%list); eauto with hints. - ** eapply All_app_inv;eauto. apply All_rev. - eapply All_env_ok;eauto with hints. now apply All_skipn. - ** unfold fun_prod,id. - rewrite map_app. - remember (rev (combine (pVars v2.1) (skipn (ind_npars mib) l2))) as l_rev. - assert (Hlrev : #|pVars v2.1| = #|exprs l_rev|). - { subst. rewrite map_length. - rewrite rev_length. rewrite combine_length. - rewrite skipn_length;lia. } - rewrite Hlrev. - symmetry. eapply subst_env_swap_app with (n:=0); - eauto with hints. - apply All_map. subst. - apply All_rev. unfold compose. simpl. - apply All_snd_combine with (p:=(iclosed_n 0) ∘ of_val_i). - unfold compose. - eapply All_expr_iclosed_of_val;try apply All_skipn;eauto. + ** eapply All_app_inv; eauto. apply All_rev. + eapply All_env_ok; eauto with hints. now apply All_skipn. + ** unfold fun_prod,id. + rewrite map_app. + remember (rev (combine (pVars v2.1) (skipn (ind_npars mib) l2))) as l_rev. + assert (Hlrev : #|pVars v2.1| = #|exprs l_rev|). + { subst. rewrite map_length. + rewrite rev_length. rewrite combine_length. + rewrite skipn_length; lia. } + rewrite Hlrev. + symmetry. eapply subst_env_swap_app with (n := 0); + eauto with hints. + apply All_map. subst. + apply All_rev. unfold compose. simpl. + apply All_snd_combine with (p := (iclosed_n 0) ∘ of_val_i). + unfold compose. + eapply All_expr_iclosed_of_val; try apply All_skipn; eauto. ** rewrite <- combine_rev by auto. rewrite map_combine_snd_funprod. - eapply subst_env_iclosed_0;eauto with hints. + eapply subst_env_iclosed_0; eauto with hints. remember ((combine (rev (pVars v2.1)) (map of_val_i (rev (skipn _ l2))))) as l_comb. assert (Hlen : #|l_comb| = #|pVars v2.1|). { subst. rewrite combine_length. rewrite map_length. - repeat rewrite rev_length. rewrite skipn_length;lia. } + repeat rewrite rev_length. rewrite skipn_length; lia. } rewrite <- Hlen. - eapply ty_expr_env_ok_subst_env with (k:=0). + eapply ty_expr_env_ok_subst_env with (k := 0). assert (Hcomb : exprs (rev (combine (pVars v2.1) (skipn (ind_npars mib) l2))) = l_comb). - { subst. repeat rewrite map_rev. rewrite combine_rev. - apply f_equal. now rewrite map_combine_snd_funprod. - rewrite map_length. rewrite skipn_length;lia. } + { subst. repeat rewrite map_rev. rewrite combine_rev. + apply f_equal. now rewrite map_combine_snd_funprod. + rewrite map_length. rewrite skipn_length; lia. } rewrite <- Hcomb. rewrite <- map_app. - eapply eval_ty_expr_env_ok;eauto with hints. + eapply eval_ty_expr_env_ok; eauto with hints. rewrite app_length. replace (#|rev (combine (pVars v2.1) (skipn (ind_npars mib) l2))|) with #|pVars v2.1| by - (rewrite rev_length, combine_length, skipn_length;lia). + (rewrite rev_length, combine_length, skipn_length; lia). replace #|ρ| with #|exprs ρ| by apply map_length. eauto with hints. - eapply closed_exprs;eauto. + eapply closed_exprs; eauto. - eapply All_snd_combine with (p:=iclosed_n 0);eauto with hints. + eapply All_snd_combine with (p := iclosed_n 0); eauto with hints. apply All_map. apply All_rev. - eapply All_expr_iclosed_of_val;eauto using All_skipn. + eapply All_expr_iclosed_of_val; eauto using All_skipn. rewrite combine_length. rewrite map_length. repeat rewrite rev_length. rewrite skipn_length by lia. @@ -501,46 +501,46 @@ Proof. remember ((combine (rev (pVars v2.1)) (map of_val_i (rev (skipn _ l2))))) as l_comb. assert (Hlen : #|l_comb| = #|pVars v2.1|). { subst. rewrite combine_length. rewrite map_length. - repeat rewrite rev_length. rewrite skipn_length;lia. } + repeat rewrite rev_length. rewrite skipn_length; lia. } rewrite <- Hlen. - eapply ty_expr_env_ok_subst_env with (k:=0). + eapply ty_expr_env_ok_subst_env with (k := 0). remember (ind_npars mib) as nparams. assert (Hcomb : exprs (rev (combine (pVars v2.1) (skipn nparams l2))) = l_comb). - { subst. repeat rewrite map_rev. rewrite combine_rev. - apply f_equal. now rewrite map_combine_snd_funprod. - rewrite map_length. rewrite skipn_length;lia. } + { subst. repeat rewrite map_rev. rewrite combine_rev. + apply f_equal. now rewrite map_combine_snd_funprod. + rewrite map_length. rewrite skipn_length; lia. } rewrite <- Hcomb. rewrite <- map_app. - subst nparams. eapply eval_ty_expr_env_ok;eauto with hints. + subst nparams. eapply eval_ty_expr_env_ok; eauto with hints. rewrite app_length. replace (#|rev (combine (pVars v2.1) (skipn _ l2))|) with #|pVars v2.1| by - (rewrite rev_length, combine_length, skipn_length;lia). + (rewrite rev_length, combine_length, skipn_length; lia). replace #|ρ| with #|exprs ρ| by apply map_length. eauto with hints. - eapply closed_exprs;eauto. + eapply closed_exprs; eauto. ** rewrite map_length. replace (#|rev (combine (pVars v2.1) (skipn _ l2))|) with #|pVars v2.1| by - (rewrite rev_length, combine_length, skipn_length;lia). + (rewrite rev_length, combine_length, skipn_length; lia). eauto with hints. - ** apply All_map. subst. - apply All_rev. unfold compose. simpl. - apply All_snd_combine with (p:=(iclosed_n 0) ∘ of_val_i). - unfold compose. - eapply All_expr_iclosed_of_val;try apply All_skipn;eauto. + ** apply All_map. subst. + apply All_rev. unfold compose. simpl. + apply All_snd_combine with (p := (iclosed_n 0) ∘ of_val_i). + unfold compose. + eapply All_expr_iclosed_of_val; try apply All_skipn; eauto. + (* eFix *) simpl in *. - destruct (valid_env _ _ _);tryfalse. - destruct (eval_type_i 0 ρ t) eqn:Ht0;tryfalse. - destruct (eval_type_i 0 ρ t0) eqn:Ht1;tryfalse. + destruct (valid_env _ _ _); tryfalse. + destruct (eval_type_i 0 ρ t) eqn:Ht0; tryfalse. + destruct (eval_type_i 0 ρ t0) eqn:Ht1; tryfalse. cbn in *. inversion He. - subst;simpl. repeat erewrite eval_type_i_subst_env by eauto. + subst; simpl. repeat erewrite eval_type_i_subst_env by eauto. repeat rewrite subst_env_i_ty_closed_eq by eauto 8 with hints. - constructor;auto. + constructor; auto. + (* eTy *) simpl in *. - destruct (eval_type_i 0 ρ t) eqn:Ht0;tryfalse;simpl in *. - inversion He;subst;clear He. simpl. + destruct (eval_type_i 0 ρ t) eqn:Ht0; tryfalse; simpl in *. + inversion He; subst; clear He. simpl. erewrite eval_type_i_subst_env by eauto. - eapply Wcvb_type_to_term_eval;eauto with hints. - eapply closed_exprs;eauto. + eapply Wcvb_type_to_term_eval; eauto with hints. + eapply closed_exprs; eauto. Qed. (** ** Soundness for closed epxressions (In the paper: Corollary 2)*) @@ -553,7 +553,7 @@ Corollary expr_to_term_sound_closed (n : nat) Σ1 Σ2 Σ2 |- t⟦e⟧Σ1 ⇓ t⟦of_val_i v⟧Σ1. Proof. intros. - eapply expr_to_term_sound;eauto with hints. + eapply expr_to_term_sound; eauto with hints. simpl. symmetry. eapply subst_env_i_empty. Qed. @@ -573,6 +573,6 @@ Proof. intros Hsync Hgok Hterm Hcvb Hclosed. destruct Hterm as (n & v &?). assert (Hcbv1 : Σ2 |- t⟦ e ⟧Σ1 ⇓ t⟦ of_val_i v ⟧ Σ1) - by (eapply expr_to_term_sound_closed;eauto). - exists v. eapply PcbvCurr.eval_deterministic;eauto. + by (eapply expr_to_term_sound_closed; eauto). + exists v. eapply PcbvCurr.eval_deterministic; eauto. Qed. diff --git a/embedding/theories/pcuic/PCUICCorrectnessAux.v b/embedding/theories/pcuic/PCUICCorrectnessAux.v index e02b1b43..1e8094d8 100644 --- a/embedding/theories/pcuic/PCUICCorrectnessAux.v +++ b/embedding/theories/pcuic/PCUICCorrectnessAux.v @@ -23,7 +23,7 @@ From ConCert.Embedding Require Import PCUICTranslate. From ConCert.Embedding Require Import Wf. -Notation "'eval' ( n , Σ , ρ , e )" := (expr_eval_i Σ n ρ e) (at level 100). +Notation "'eval' ( n , Σ , ρ , e )" := (expr_eval_i Σ n ρ e) (at level 100). Notation "M { j := N }" := (subst (N :: nil) j M) (at level 10, right associativity). @@ -62,18 +62,18 @@ Definition genv_sync (Σ1 : list global_dec) (Σ2 : PCUICEnvironment.global_env resolve_constr Σ1 ind_name c = Some (nparams, i, tys) -> { x | let '(mib, oib, cb) := x in declared_constructor Σ2 (mkInd (kername_of_string ind_name) 0, i) mib oib cb - /\ nparams = ind_npars mib /\ #|tys| = context_assumptions (cstr_args cb) (* same arities *) + /\ nparams = ind_npars mib /\ #|tys| = context_assumptions (cstr_args cb) (* same arities *) }. Notation "Σ1 ⋈ Σ2 " := (genv_sync Σ1 Σ2) (at level 20). Tactic Notation "simpl_vars_to_apps" "in" ident(H) := - simpl in H;try rewrite map_app in H; simpl in H; - rewrite vars_to_apps_unfold in H;simpl in H. + simpl in H; try rewrite map_app in H; simpl in H; + rewrite vars_to_apps_unfold in H; simpl in H. Tactic Notation "simpl_vars_to_apps" := - simpl;try rewrite map_app; simpl; rewrite vars_to_apps_unfold;simpl. + simpl; try rewrite map_app; simpl; rewrite vars_to_apps_unfold; simpl. Section WcbvEvalProp. @@ -89,7 +89,7 @@ Section WcbvEvalProp. Lemma All_eq {A} (l1 l2 : list A) : All2 (fun t1 t2 => t1 = t2) l1 l2 -> l1 = l2. Proof. intros H. - induction H;f_equal;auto. + induction H; f_equal; auto. Qed. Lemma All_All2_impl {A} (l1 l2 : list A) P : @@ -98,9 +98,9 @@ Section WcbvEvalProp. All2 (fun t1 t2 => t1 = t2) l1 l2. Proof. intros Hall Hall2. - induction Hall2;auto. - inversion Hall as [a | ty ll HH3 HH4];subst;clear Hall. - constructor;auto. + induction Hall2; auto. + inversion Hall as [a | ty ll HH3 HH4]; subst; clear Hall. + constructor; auto. Qed. Lemma mkApps_unfold t1 ts t2 : @@ -114,9 +114,9 @@ Section WcbvEvalProp. mkApps t1 args = t2 -> False. Proof. intros Hneq Hnapp H. - destruct args using rev_ind;simpl in *;tryfalse. - rewrite mkApps_unfold in H. - destruct t2;tryfalse. + destruct args using rev_ind; simpl in *; tryfalse. + rewrite mkApps_unfold in H. + destruct t2; tryfalse. Qed. Lemma mkApps_tRel_false t args i : @@ -124,7 +124,7 @@ Section WcbvEvalProp. mkApps t args = tRel i -> False. Proof. intros. - eapply mkApps_eq_false;eauto. intros ? ? Hi. tryfalse. + eapply mkApps_eq_false; eauto. intros ? ? Hi. tryfalse. Qed. Hint Resolve mkApps_tRel_false : facts. @@ -143,7 +143,7 @@ Lemma mkApps_vars_to_apps l: forall (Σ : global_env) e, P.mkApps (t⟦e⟧Σ) (map (expr_to_term Σ) l) = t⟦ vars_to_apps e l ⟧ Σ. Proof. - induction l;intros. + induction l; intros. + reflexivity. + simpl. now rewrite <- IHl. Qed. @@ -170,15 +170,15 @@ Lemma Wcbv_value_vars_to_apps Σ1 Σ2 : Proof. intros i n l [[??]?] syncEnv Hres Har Hfa. destruct (syncEnv _ _ _ _ _ Hres) as [[[??]?][?[??]]]. - erewrite <- mkApps_vars_to_apps_constr;eauto. + erewrite <- mkApps_vars_to_apps_constr; eauto. eapply PcbvCurr.value_app. - + econstructor;eauto. rewrite map_length;cbn in *. unfold PcbvCurr.cstr_arity. lia. + + econstructor; eauto. rewrite map_length; cbn in *. unfold PcbvCurr.cstr_arity. lia. + now apply All_map. Qed. Open Scope bool. -Fixpoint ge_val_ok Σ v : bool:= +Fixpoint ge_val_ok Σ v : bool := match v with | vConstr ind ctor args => let res := @@ -199,9 +199,9 @@ Lemma decompose_inductive_mkApps ty ind args : type_to_term ty = mkApps (tInd (mkInd (kername_of_string ind) 0) []) (map type_to_term args). Proof. revert args ind. - induction ty;intros args ind Hdi;inversion Hdi;subst. + induction ty; intros args ind Hdi; inversion Hdi; subst. + easy. - + simpl in *. destruct (decompose_inductive ty1) eqn:Heq;tryfalse. + + simpl in *. destruct (decompose_inductive ty1) eqn:Heq; tryfalse. destruct p. inversion Hdi. subst. rewrite map_app. cbn. @@ -215,18 +215,18 @@ Lemma decompose_inductive_value: All (PcbvCurr.value Σ) (map type_to_term args). Proof. intros Σ t1. - induction t1;intros args ind Hv Hdi;tryfalse. - + inversion Hdi;subst. constructor. + induction t1; intros args ind Hv Hdi; tryfalse. + + inversion Hdi; subst. constructor. + simpl in *. - destruct (decompose_inductive t1_1) eqn:HH;tryfalse. + destruct (decompose_inductive t1_1) eqn:HH; tryfalse. destruct p as [ind' tys]. inversion Hdi. subst. erewrite decompose_inductive_mkApps in Hv by eauto. rewrite <- mkApps_unfold in Hv. remember (tInd _ _) as tind. - assert (Hna : ~~ isApp tind) by (subst;auto). + assert (Hna : ~~ isApp tind) by (subst; auto). specialize (PcbvCurr.value_mkApps_inv _ _ _ Hna Hv). intros W. destruct W as [p | p]. - * inversion p. destruct tys;tryfalse. + * inversion p. destruct tys; tryfalse. * destruct p as [H1 H2]. now rewrite map_app. Qed. @@ -244,9 +244,9 @@ Proof. rewrite <- mkApps_unfold. eapply PcbvCurr.value_app. * apply tInd_value_head. - * apply All_app_inv;eauto. - eapply decompose_inductive_value with (t1:=ty1);eauto. - + constructor;eauto. + * apply All_app_inv; eauto. + eapply decompose_inductive_value with (t1 := ty1); eauto. + + constructor; eauto. Qed. #[export] Hint Constructors ty_val : hints. @@ -258,7 +258,7 @@ Lemma env_ok_lookup_ty_val ty i Σ ρ : Proof. intros. assert (Hok : val_ok Σ (vTy ty)) by now eapply All_lookup_i. - inversion Hok;subst;easy. + inversion Hok; subst; easy. Qed. Lemma env_ok_lookup_closed_ty ty i Σ ρ : @@ -268,33 +268,33 @@ Lemma env_ok_lookup_closed_ty ty i Σ ρ : Proof. intros. assert (Hok : val_ok Σ (vTy ty)) by now eapply All_lookup_i. - inversion Hok;subst;easy. + inversion Hok; subst; easy. Qed. Lemma eval_ty_closed Σ ty ty_v ρ n : - env_ok Σ ρ -> + env_ok Σ ρ -> eval_type_i n ρ ty = Some ty_v -> iclosed_ty n ty_v. Proof. revert ty_v ρ n. - induction ty;intros ??? Hok He. + induction ty; intros ??? Hok He. + simpl in *. inversion He. now subst. + simpl in *. - destruct (eval_type_i (S n) _ _) eqn:Hty;tryfalse. - inversion He;subst. now simpl. + destruct (eval_type_i (S n) _ _) eqn:Hty; tryfalse. + inversion He; subst. now simpl. + simpl in *. - destruct (eval_type_i _ _ ty2) eqn:Hty2;tryfalse. - destruct (eval_type_i _ _ ty1) eqn:Hty1;tryfalse. - destruct (decompose_inductive _) eqn:Hind;tryfalse. - inversion He;subst;clear He. simpl. + destruct (eval_type_i _ _ ty2) eqn:Hty2; tryfalse. + destruct (eval_type_i _ _ ty1) eqn:Hty1; tryfalse. + destruct (decompose_inductive _) eqn:Hind; tryfalse. + inversion He; subst; clear He. simpl. now propify. + tryfalse. - + simpl in *. destruct (n0 <=? n) eqn:Hn0;tryfalse. - destruct (lookup_i ρ (n - n0)) eqn:Hlook;tryfalse. destruct v;tryfalse. - inversion He. subst. eapply iclosed_ty_0;now eapply env_ok_lookup_closed_ty. + + simpl in *. destruct (n0 <=? n) eqn:Hn0; tryfalse. + destruct (lookup_i ρ (n - n0)) eqn:Hlook; tryfalse. destruct v; tryfalse. + inversion He. subst. eapply iclosed_ty_0; now eapply env_ok_lookup_closed_ty. + simpl in *. - destruct (eval_type_i _ _ ty2) eqn:Hty2;tryfalse. - destruct (eval_type_i _ _ ty1) eqn:Hty1;tryfalse. - inversion He;subst. + destruct (eval_type_i _ _ ty2) eqn:Hty2; tryfalse. + destruct (eval_type_i _ _ ty1) eqn:Hty1; tryfalse. + inversion He; subst. simpl. now propify. Qed. @@ -306,52 +306,52 @@ Lemma type_eval_value Σ ρ ty ty_v n : Proof. intros Hok He. revert dependent ty_v. revert n. - induction ty;intros. - + simpl in *. inversion He;eauto with hints. + induction ty; intros. + + simpl in *. inversion He; eauto with hints. + simpl in *. - destruct (eval_type_i (S n) _ _) eqn:Hty;tryfalse. - inversion He;subst. now constructor. + destruct (eval_type_i (S n) _ _) eqn:Hty; tryfalse. + inversion He; subst. now constructor. + simpl in *. simpl in *. - destruct (eval_type_i _ _ ty2) eqn:Hty2;tryfalse. - destruct (eval_type_i _ _ ty1) eqn:Hty1;tryfalse. - destruct (decompose_inductive _) eqn:Hind;tryfalse. - inversion He;subst;clear He. simpl. + destruct (eval_type_i _ _ ty2) eqn:Hty2; tryfalse. + destruct (eval_type_i _ _ ty1) eqn:Hty1; tryfalse. + destruct (decompose_inductive _) eqn:Hind; tryfalse. + inversion He; subst; clear He. simpl. destruct p as [ind0 args]. - econstructor;eauto. + econstructor; eauto. + tryfalse. - + simpl in *. destruct (n0 <=? n);tryfalse. - destruct (lookup_i ρ (n - n0)) eqn:Hlook;tryfalse. destruct v;tryfalse. + + simpl in *. destruct (n0 <=? n); tryfalse. + destruct (lookup_i ρ (n - n0)) eqn:Hlook; tryfalse. destruct v; tryfalse. inversion He. subst. now eapply env_ok_lookup_ty_val. + simpl in *. - destruct (eval_type_i _ _ ty2) eqn:Hty2;tryfalse. - destruct (eval_type_i _ _ ty1) eqn:Hty1;tryfalse. - inversion He;subst. now constructor. + destruct (eval_type_i _ _ ty2) eqn:Hty2; tryfalse. + destruct (eval_type_i _ _ ty1) eqn:Hty1; tryfalse. + inversion He; subst. now constructor. Qed. Lemma type_to_term_eval_value : forall Σ1 Σ2 (ty ty_v : type) ρ, - env_ok Σ1 ρ -> + env_ok Σ1 ρ -> eval_type_i 0 ρ ty = Some ty_v -> PcbvCurr.value Σ2 (type_to_term ty_v). Proof. intros. - eapply type_value_term_value;eauto with hints. - eapply eval_ty_closed;eauto. - eapply type_eval_value;eauto. + eapply type_value_term_value; eauto with hints. + eapply eval_ty_closed; eauto. + eapply type_eval_value; eauto. Qed. Lemma Wcvb_type_to_term_eval : forall (Σ1 : PCUICEnvironment.global_env) Σ2 (ty ty_v : type) ρ, env_ok Σ2 ρ -> - AllEnv (iclosed_n 0) (exprs ρ) -> + AllEnv (iclosed_n 0) (exprs ρ) -> eval_type_i 0 ρ ty = Some ty_v -> Σ1 |- type_to_term ty_v ⇓ type_to_term ty_v. Proof. intros. eapply PcbvCurr.value_final. - eapply type_to_term_eval_value;eauto. + eapply type_to_term_eval_value; eauto. Qed. Lemma Wcbv_of_value_value v Σ1 Σ2 : @@ -362,14 +362,14 @@ Proof. intros Hsync Hok. induction v using val_elim_full. + simpl in *. - inversion Hok;subst. - eapply Wcbv_value_vars_to_apps;eauto. - eapply All_impl_inner;eauto. - + destruct cm. constructor;auto. + inversion Hok; subst. + eapply Wcbv_value_vars_to_apps; eauto. + eapply All_impl_inner; eauto. + + destruct cm. constructor; auto. simpl. now constructor. - + simpl in *. constructor;auto. + + simpl in *. constructor; auto. + simpl in *. - inversion Hok;subst. now eapply type_value_term_value. + inversion Hok; subst. now eapply type_value_term_value. Qed. Lemma lift_1_closed n t : @@ -377,7 +377,7 @@ Lemma lift_1_closed n t : closedn (S n) ((lift0 1) t) = true. Proof. replace (S n) with (n+1) by lia. - now apply closedn_lift with (k:=n) (n:=1). + now apply closedn_lift with (k := n) (n := 1). Qed. @@ -388,7 +388,7 @@ Lemma type_to_term_closed ty n : closedn n (type_to_term ty) = true. Proof. revert n. - induction ty;intros n0 H;simpl in *; + induction ty; intros n0 H; simpl in *; propify; destruct_hyps; auto with hints. Qed. @@ -402,20 +402,20 @@ Lemma type_to_term_subst_par_rec Σ ty k ρ : subst (map (fun x => expr_to_term Σ (snd x)) ρ) k (type_to_term ty) = type_to_term (subst_env_i_ty k ρ ty). Proof. revert k ρ. - induction ty;intros k e0 Hok Hce Hct;simpl in *;propify; - auto with hints;intuition. - + destruct (k <=? n);auto. + induction ty; intros k e0 Hok Hce Hct; simpl in *; propify; + auto with hints; intuition. + + destruct (k <=? n); auto. unfold Extras.with_default, lookup_ty. rewrite lookup_i_nth_error in *. rewrite nth_error_map. - destruct (nth_error _ _) eqn:Hn;cbn in *. - * destruct p eqn:Hp;cbn in *. destruct e;tryfalse;cbn. + destruct (nth_error _ _) eqn:Hn; cbn in *. + * destruct p eqn:Hp; cbn in *. destruct e; tryfalse; cbn. assert (closed T⟦ t ⟧). - { eapply nth_error_all in Hn;eauto; auto with hints. } + { eapply nth_error_all in Hn; eauto; auto with hints. } now rewrite lift_closed by auto with hints. * rewrite map_length. apply f_equal. - apply nth_error_None in Hn;lia. - + f_equal;auto. + apply nth_error_None in Hn; lia. + + f_equal; auto. rewrite <- IHty2 by auto. rewrite commut_lift_subst_rec by lia. now replace (S k) with (k+1) by lia. @@ -425,35 +425,35 @@ Lemma type_to_term_subst Σ ty k e (nm : string) : ty_env_ok k [(nm,e)] ty -> iclosed_n 0 e -> iclosed_ty (1+k) ty -> - (type_to_term ty) {k:=t⟦e⟧Σ} = type_to_term (subst_env_i_ty k ([(nm,e)]) ty). + (type_to_term ty) {k := t⟦e⟧Σ} = type_to_term (subst_env_i_ty k ([(nm,e)]) ty). Proof. intros. - apply type_to_term_subst_par_rec with (ρ:=[(nm,e)]);eauto. - cbn;now replace (k+1) with (1+k) by lia. + apply type_to_term_subst_par_rec with (ρ := [(nm,e)]); eauto. + cbn; now replace (k+1) with (1+k) by lia. Qed. Lemma type_to_term_eval Σ ty k e (nm : string) v: iclosed_ty k ty -> eval_type_i k ([(nm,e)]) ty = Some v -> - (type_to_term ty) {k:=t⟦of_val_i e⟧Σ} = type_to_term v. -Proof. - revert k e v. induction ty;intros k e0 v Hc H;simpl in *;inversion H;subst;auto;clear H. - + destruct (eval_type_i _ _ _) eqn:Heq;tryfalse. inversion H1;subst. - simpl. f_equal;eauto. - + destruct (eval_type_i _ _ ty2) eqn:Heq2;tryfalse. - destruct (eval_type_i _ _ ty1) eqn:Heq1;tryfalse. - destruct (decompose_inductive t0) eqn:Hde;tryfalse. - inversion H1;subst;clear H1. propify. destruct_hyps. - simpl. f_equal;eauto. + (type_to_term ty) {k := t⟦of_val_i e⟧Σ} = type_to_term v. +Proof. + revert k e v. induction ty; intros k e0 v Hc H; simpl in *; inversion H; subst; auto; clear H. + + destruct (eval_type_i _ _ _) eqn:Heq; tryfalse. inversion H1; subst. + simpl. f_equal; eauto. + + destruct (eval_type_i _ _ ty2) eqn:Heq2; tryfalse. + destruct (eval_type_i _ _ ty1) eqn:Heq1; tryfalse. + destruct (decompose_inductive t0) eqn:Hde; tryfalse. + inversion H1; subst; clear H1. propify. destruct_hyps. + simpl. f_equal; eauto. + destruct (k <=? n) eqn:Hkn. - * destruct (n - k) eqn:Hnk;simpl in *;tryfalse. - unfold is_true in *;propify. lia. - * inversion H1;subst;clear H1;auto. - + destruct (eval_type_i _ _ ty2) eqn:Heq2;tryfalse. - destruct (eval_type_i _ _ ty1) eqn:Heq1;tryfalse. - inversion H1;subst;clear H1. + * destruct (n - k) eqn:Hnk; simpl in *; tryfalse. + unfold is_true in *; propify. lia. + * inversion H1; subst; clear H1; auto. + + destruct (eval_type_i _ _ ty2) eqn:Heq2; tryfalse. + destruct (eval_type_i _ _ ty1) eqn:Heq1; tryfalse. + inversion H1; subst; clear H1. propify. destruct_hyps. simpl. - rewrite commut_lift_subst. repeat f_equal;eauto. + rewrite commut_lift_subst. repeat f_equal; eauto. Qed. #[export] Hint Resolve -> length_zero_iff_nil : hints. @@ -466,7 +466,7 @@ Qed. Fixpoint inc_subst (ts : list (string * term)) n (u : term) : list (string * term) := match ts with | [] => [] - | (nm, t0) :: ts0 => (nm, t0 {n:=u}) :: inc_subst ts0 (1+n) u + | (nm, t0) :: ts0 => (nm, t0 {n := u}) :: inc_subst ts0 (1+n) u end. Fixpoint nsubst (ts : list term) (n : nat) (t :term) := @@ -480,25 +480,25 @@ Lemma nsubst_lam xs b nm ty : nsubst xs (#|xs| - 1) (tLambda nm ty b) = (tLambda nm ty (nsubst xs #|xs| b)). Proof. revert b nm ty. - induction xs;intros;auto. + induction xs; intros; auto. simpl. - assert (closedn (#|xs|) ty) by (eapply closed_upwards;eauto;lia). + assert (closedn (#|xs|) ty) by (eapply closed_upwards; eauto; lia). replace (S #|xs| - 1) with #|xs| in * by lia. now rewrite subst_closedn by auto. Qed. Lemma map_lift0 xs : map (lift0 0) xs = xs. Proof. - induction xs;auto. + induction xs; auto. simpl. now rewrite lift0_p. Qed. -Lemma simpl_lift_map xs n m p : map ((lift n p) ∘ (lift m p)) xs = map (lift (n+m) p) xs. +Lemma simpl_lift_map xs n m p : map ((lift n p) ∘ (lift m p)) xs = map (lift (n+m) p) xs. Proof. - induction xs;auto. + induction xs; auto. simpl. unfold compose. rewrite simpl_lift by lia. - f_equal;eauto. + f_equal; eauto. Qed. (* TODO : use this lemma in all places where this inversion is needed *) @@ -519,20 +519,20 @@ Fixpoint nsubst_alt (ts : list term) (t : term) {struct ts} : term := Lemma closed_upwards0 n t : closed t -> closedn n t. Proof. - intros;eapply closed_upwards;eauto;lia. + intros; eapply closed_upwards; eauto; lia. Qed. #[export] Hint Resolve closed_upwards0 subst_closedn : hints. Lemma nsubst_app ts t0 t1 : closed t0 -> - nsubst (ts ++ [t0]) (#|ts|) t1 = nsubst ts (#|ts| - 1) (t1 {0:=t0}). + nsubst (ts ++ [t0]) (#|ts|) t1 = nsubst ts (#|ts| - 1) (t1 {0 := t0}). Proof. revert t0 t1. - induction ts;intros. + induction ts; intros. + simpl. easy. + simpl. replace (S #|ts| - 1) with #|ts| by lia. rewrite IHts by assumption. - rewrite distr_subst. simpl. replace (t0 {#|ts| := a}) with t0 by (symmetry;eauto with hints). + rewrite distr_subst. simpl. replace (t0 {#|ts| := a}) with t0 by (symmetry; eauto with hints). reflexivity. Qed. @@ -541,15 +541,15 @@ Lemma subst_closed_map ts1 ts2 k : map (subst ts1 k) ts2 = ts2. Proof. intros H. revert dependent k. revert ts1. - induction ts2;intros;auto. + induction ts2; intros; auto. simpl in *. propify. destruct_hyps. - f_equal;eauto with hints. + f_equal; eauto with hints. Qed. Ltac destr_args args := let args0 := fresh "args0" in destruct args as [ | ? args0]; - tryfalse;try destruct args0;tryfalse. + tryfalse; try destruct args0; tryfalse. Notation "P <--> Q" := (Logic.BiImpl P Q) (at level 100). @@ -564,7 +564,7 @@ Proof. rewrite Bool.andb_true_r in *. easy. + intros Hc. destruct Hc. - rewrite closedn_mkApps;auto. simpl. rewrite Bool.andb_true_r in *. now rewrite H. + rewrite closedn_mkApps; auto. simpl. rewrite Bool.andb_true_r in *. now rewrite H. Qed. #[export] Hint Resolve <- closed_mkApps : hints. @@ -576,12 +576,12 @@ Lemma genv_ok_constrs_ok Σ ind cs nparam: forallb (constr_ok nparam) cs. Proof. intros Hgeok Hr. unfold resolve_inductive in *. - destruct (lookup_global Σ ind) eqn:Hlg;tryfalse. - destruct g;tryfalse. inversion Hr;subst;clear Hr. + destruct (lookup_global Σ ind) eqn:Hlg; tryfalse. + destruct g; tryfalse. inversion Hr; subst; clear Hr. revert dependent cs. - induction Σ;intros;tryfalse. + induction Σ; intros; tryfalse. cbn in *. destruct a. cbn in *. - destruct (e0 =? ind)%string;now propify. + destruct (e0 =? ind)%string; now propify. Qed. Lemma constrs_ok_in s c (cs : list constr) nparam : @@ -590,7 +590,7 @@ Lemma constrs_ok_in s c (cs : list constr) nparam : forallb (iclosed_ty nparam) (map snd c). Proof. intros Hin Hfa. - assert (constr_ok nparam (s,c)) by (eapply forallb_In;eauto). + assert (constr_ok nparam (s,c)) by (eapply forallb_In; eauto). easy. Qed. @@ -599,11 +599,11 @@ Lemma forallb_type_to_term_closed ts n : forallb (closedn n) (map type_to_term ts). Proof. revert n. - induction ts;intros;auto. + induction ts; intros; auto. cbn in *. propify. destruct_hyps. - split;eauto with hints. + split; eauto with hints. Qed. @@ -619,15 +619,15 @@ Proof. apply forallb_Forall in Htys. apply Forall_map_inv in Htys. revert dependent vs. - induction tys;intros. - - now destruct vs;tryfalse. - - destruct vs;tryfalse;cbn in *. - inversion Hlen as [Hlen0];subst;clear Hlen. - propify;split. - * inversion Htys;subst;apply IHtys;eauto. + induction tys; intros. + - now destruct vs; tryfalse. + - destruct vs; tryfalse; cbn in *. + inversion Hlen as [Hlen0]; subst; clear Hlen. + propify; split. + * inversion Htys; subst; apply IHtys; eauto. * rewrite map_length, combine_length, map_length. rewrite Hlen0. replace (Init.Nat.min #|tys| #|tys|) with #|tys| by lia. - inversion Htys;subst;clear Htys. + inversion Htys; subst; clear Htys. replace (#|tys| + n) with (n + #|tys|) by lia. assert (iclosed_ty (n + #|tys|) a.2) by now apply iclosed_ty_m_n. eauto with hints. @@ -638,16 +638,16 @@ Lemma expr_closed_term_closed e n Σ: iclosed_n n e = true -> closedn n (t⟦e⟧Σ) = true. Proof. revert n. - induction e using expr_ind_case;intros n1 Hgeok Hc;auto. + induction e using expr_ind_case; intros n1 Hgeok Hc; auto. + (* eLambda*) simpl in *. rewrite Bool.andb_true_iff. propify. destruct_hyps. - split;auto with hints. + split; auto with hints. + (* eTyLam *) simpl in *. destruct Hc. auto. + (* eLetIn *) simpl in *. repeat rewrite Bool.andb_true_iff in *. - destruct Hc as [[? ?] ?]. repeat split;simpl;eauto with hints. + destruct Hc as [[? ?] ?]. repeat split; simpl; eauto with hints. + (* eApp *) simpl in Hc. repeat rewrite Bool.andb_true_iff in *. cbn -[mkApps]. eauto with hints. @@ -657,12 +657,12 @@ Proof. + (* eCase *) destruct p. simpl in *. repeat rewrite Bool.andb_true_iff in *. destruct Hc as [[[? ?] ?] ?]. - destruct (resolve_inductive Σ i) eqn:Hres;auto. - destruct ((_ =? _)%nat) eqn:Hnparams;simpl;auto. - propify; repeat split;eauto with hints. - * unfold test_predicate_k;simpl;propify; repeat split;eauto with hints. + destruct (resolve_inductive Σ i) eqn:Hres; auto. + destruct ((_ =? _)%nat) eqn:Hnparams; simpl; auto. + propify; repeat split; eauto with hints. + * unfold test_predicate_k; simpl; propify; repeat split; eauto with hints. ** now apply forallb_type_to_term_closed. - ** cbn. rewrite closedn_mkApps;eauto. cbn. + ** cbn. rewrite closedn_mkApps; eauto. cbn. replace (#|map type_to_term l0|) with (#|map (fun x : type => vass (aRelevant nAnon) T⟦ x ⟧) l0|) by now repeat rewrite map_length. @@ -671,37 +671,37 @@ Proof. rewrite forallb_map. apply forallb_Forall. apply Forall_forall. intros x Hin. destruct x as [nm tys]. unfold fun_prod,id in *. - unfold test_branch_k;cbn. + unfold test_branch_k; cbn. remember (etrans_branch _ _ _) as tb. unfold etrans_branch in Heqtb. destruct (find (fun x => _)) as [ p0 | ] eqn:Hnm. - 2: subst;simpl;auto. + 2: subst; simpl; auto. destruct p0 as [pt e1]. cbn in *. rewrite map_length in *. - destruct (#|pVars pt| =? #|tys|)%nat eqn:Hlen;auto. - 2: subst;simpl;auto. - apply find_some in Hnm. destruct Hnm as [Hin' Heqs];cbn in *. + destruct (#|pVars pt| =? #|tys|)%nat eqn:Hlen; auto. + 2: subst; simpl; auto. + apply find_some in Hnm. destruct Hnm as [Hin' Heqs]; cbn in *. rewrite in_map_iff in Hin'. destruct Hin' as [x Htmp]. destruct x as [pt1 e2]. - destruct Htmp as [He1 Hin'']. inversion He1;subst pt1;subst e1;clear He1. + destruct Htmp as [He1 Hin'']. inversion He1; subst pt1; subst e1; clear He1. assert (Hcs : forallb (constr_ok np) cs) by now eapply genv_ok_constrs_ok. assert (Htys :forallb (iclosed_ty np) (map snd tys)) by now eapply constrs_ok_in. - unfold resolve_inductive in *. destruct (lookup_global _ _);tryfalse. destruct g. - inversion Hres; subst np cs n. clear Hres;cbn in *. - subst;cbn in *. + unfold resolve_inductive in *. destruct (lookup_global _ _); tryfalse. destruct g. + inversion Hres; subst np cs n. clear Hres; cbn in *. + subst; cbn in *. propify; split. ** rewrite map_map. now apply closedn_ctx_branches. ** rewrite map_length,combine_length. rewrite_all map_length. rewrite Hlen. replace (min #|tys| #|tys|) with (#|tys|) by lia. apply forallb_Forall in H3. - eapply Forall_In in H;eauto;cbn in *. - eapply Forall_In in H3;eauto;cbn in *. + eapply Forall_In in H; eauto; cbn in *. + eapply Forall_In in H3; eauto; cbn in *. now apply H. + simpl in *. unfold test_def. simpl. propify. - repeat split;eauto with hints; - try apply type_to_term_closed;intuition. + repeat split; eauto with hints; + try apply type_to_term_closed; intuition. + simpl in *. eauto with hints. Qed. @@ -729,25 +729,25 @@ Qed. #[export] Hint Constructors val_ok Forall : hints. #[export] Hint Unfold snd env_ok AllEnv compose : hints. -#[export] Hint Resolve 1 subst_env_iclosed_n_inv subst_env_iclosed_0_inv: hints. -#[export] Hint Resolve 1 subst_env_iclosed_n subst_env_iclosed_0 : hints. +#[export] Hint Resolve subst_env_iclosed_n_inv subst_env_iclosed_0_inv: hints. +#[export] Hint Resolve subst_env_iclosed_n subst_env_iclosed_0 : hints. Lemma option_to_res_ok {A} (o : option A) s v: option_to_res o s = Ok v -> o = Some v. Proof. - intros H. destruct o. inversion H;auto. tryfalse. + intros H. destruct o. inversion H; auto. tryfalse. Qed. Lemma forall_map_spec' : forall (A B : Type) (P : A -> Prop) (l : list A) (f g : A -> B), Forall P l -> (forall x : A, In x l -> P x -> f x = g x) -> map f l = map g l. Proof. - induction l;intros f g Hfa Heq;simpl;auto. - inversion Hfa;subst;clear Hfa. + induction l; intros f g Hfa Heq; simpl; auto. + inversion Hfa; subst; clear Hfa. f_equal. - + apply Heq;simpl;auto. - + eapply IHl;intros;try apply Heq;simpl;auto. + + apply Heq; simpl; auto. + + eapply IHl; intros; try apply Heq; simpl; auto. Qed. @@ -755,7 +755,7 @@ Lemma forallb_In_snd {A B} (l : list (A * B)) (p : B -> bool) (a : A * B) : forallb (fun x => p (snd x)) l = true -> In a l -> p (snd a) = true. Proof. intros H Hin. - induction l;tryfalse;simpl in *. + induction l; tryfalse; simpl in *. propify. now destruct Hin. Qed. @@ -763,8 +763,8 @@ Lemma forallb_snd {A B} (p : B -> bool) (l1 : list A) (l2 : list B) : forallb p l2 -> forallb (fun x => p (snd x)) (combine l1 l2). Proof. revert l1. - induction l2;intros;destruct l1;auto. - simpl in *;propify. now destruct_and_split. + induction l2; intros; destruct l1; auto. + simpl in *; propify. now destruct_and_split. Qed. Lemma inc_subst_closed ts t n : @@ -772,11 +772,11 @@ Lemma inc_subst_closed ts t n : inc_subst ts n t = ts. Proof. revert t n. - induction ts;intros t n H. + induction ts; intros t n H. + reflexivity. + simpl in *. propify. destruct_hyps. repeat f_equal; eauto with hints. - eapply IHts;eauto. unfold is_true; rewrite forallb_forall in *. - intros. eapply (closed_upwards (k:=n)); eauto with hints. + eapply IHts; eauto. unfold is_true; rewrite forallb_forall in *. + intros. eapply (closed_upwards (k := n)); eauto with hints. Qed. Lemma type_to_term_map_par_rec : @@ -791,7 +791,7 @@ Proof. induction args. + easy. + simpl in *. propify. destruct_hyps. f_equal. - * apply type_to_term_subst_par_rec;eauto using forallb_All. + * apply type_to_term_subst_par_rec; eauto using forallb_All. * eauto. Qed. @@ -805,7 +805,7 @@ Lemma type_to_term_map : Proof. intros e0 Σ n1 nm args Hc Hca Hok. replace (1 + n1) with (n1 + 1) in * by lia. - apply type_to_term_map_par_rec with (ρ:=[(nm,e0)]);cbn;propify;eauto. + apply type_to_term_map_par_rec with (ρ := [(nm,e0)]); cbn; propify; eauto. Qed. Lemma subst_term_subst_env_rec e e0: @@ -814,10 +814,10 @@ Lemma subst_term_subst_env_rec e e0: ty_expr_env_ok (nil # [nm ~> e0]) n e -> iclosed_n (1+n) e = true -> iclosed_n 0 e0 = true -> - (t⟦e⟧ Σ) {n:=t⟦e0⟧ Σ} = + (t⟦e⟧ Σ) {n := t⟦e0⟧ Σ} = (t⟦e.[nil # [nm ~> e0]]n⟧ Σ). Proof. - induction e using expr_ind_case;intros Σ n1 nm Hgeok Hok Hc Hce0. + induction e using expr_ind_case; intros Σ n1 nm Hgeok Hok Hc Hce0. + (* eRel *) cbn. destruct (Nat.compare n1 n) eqn:Hn. @@ -833,7 +833,7 @@ Proof. assert (n < S n1) by auto with facts. exfalso. lia. * simpl in *. - assert (n < S n1) by auto with facts. + assert (n < S n1) by auto with facts. assert (n1 > n) by auto with facts. assert (Hleb : Nat.leb n1 n = false) by auto with facts. rewrite Hleb. reflexivity. @@ -842,14 +842,14 @@ Proof. + (* eLambda *) cbn in *. unfold subst1. propify. destruct_hyps. - erewrite <- type_to_term_subst with (nm:=nm);eauto with hints. - f_equal. eapply IHe;eauto. + erewrite <- type_to_term_subst with (nm := nm); eauto with hints. + f_equal. eapply IHe; eauto. + (* eTyLam *) - cbn in *;f_equal;auto. + cbn in *; f_equal; auto. + (* eLetIn *) cbn in *. unfold is_true in *; propify. - rewrite type_to_term_subst with (nm:=nm);intuition;eauto with hints. + rewrite type_to_term_subst with (nm := nm); intuition; eauto with hints. + (* eApp *) change ((t⟦ eApp e1 e2 ⟧ Σ)) with ((mkApps (t⟦e1⟧Σ) [t⟦e2⟧Σ])) in *. cbn -[mkApps] in *. unfold is_true in *. @@ -858,45 +858,45 @@ Proof. change (tApp t⟦e1.[[(nm, e0)]] n1⟧Σ t⟦e2.[[(nm, e0)]] n1⟧ Σ) with (mkApps t⟦e1.[[(nm, e0)]] n1⟧Σ [t⟦e2.[[(nm, e0)]] n1⟧ Σ]). f_equal. - eapply IHe1;intuition. - simpl;f_equal;eapply IHe2;intuition. + eapply IHe1; intuition. + simpl; f_equal; eapply IHe2; intuition. + (* eConstr *) - simpl. destruct (resolve_constr Σ i n);auto. + simpl. destruct (resolve_constr Σ i n); auto. + (* eConst *) reflexivity. + (* eCase *) - cbn in *. destruct p as [ind tys]. unfold is_true in *;simpl in *. + cbn in *. destruct p as [ind tys]. unfold is_true in *; simpl in *. propify. destruct Hc as [Hce1 Hce2]. - destruct (resolve_inductive Σ ind) eqn:Hres;auto. - rewrite map_length. destruct (_ =? _)%nat eqn:Hnparams;auto. + destruct (resolve_inductive Σ ind) eqn:Hres; auto. + rewrite map_length. destruct (_ =? _)%nat eqn:Hnparams; auto. cbn. repeat f_equal. - * unfold map_predicate_k;cbn. + * unfold map_predicate_k; cbn. rewrite_all map_map. erewrite <- type_to_term_map with (Σ := Σ) by intuition. - rewrite <- map_map with (f:=fun x => T⟦ subst_env_i_ty n1 [(nm, e0)] x⟧). + rewrite <- map_map with (f := fun x => T⟦ subst_env_i_ty n1 [(nm, e0)] x⟧). erewrite <- type_to_term_map with (Σ := Σ) by intuition. rewrite map_map. f_equal. - ** do 3 (apply f_equal2;auto). + ** do 3 (apply f_equal2; auto). unfold to_extended_list, to_extended_list_k. assert (Hreln : forall ys1 ys2 xs n, #|ys1| = #|ys2| -> reln xs n (map (vass (aRelevant nAnon)) ys1) = reln xs n (map (vass (aRelevant nAnon)) ys2)). - { induction ys1;intros ys2 xs n Heq; destruct ys2;cbn in *;inversion Heq;cbn;auto. } - rewrite <- map_map. rewrite <- map_map with (f:=fun x => T⟦ x ⟧ {n1 := t⟦ e0 ⟧ Σ}). + { induction ys1; intros ys2 xs n Heq; destruct ys2; cbn in *; inversion Heq; cbn; auto. } + rewrite <- map_map. rewrite <- map_map with (f := fun x => T⟦ x ⟧ {n1 := t⟦ e0 ⟧ Σ}). apply Hreln. now repeat rewrite map_length. ** rewrite commut_lift_subst. intuition. - * apply IHe;intuition. + * apply IHe; intuition. * rewrite_all map_map. simpl. - unfold on_snd. destruct p as [p cs];simpl in *. + unfold on_snd. destruct p as [p cs]; simpl in *. apply map_ext_in. intros ctor Hin. destruct ctor as [s l0] eqn:Hconsr. unfold on_snd,etrans_branch. - unfold fun_prod,id. cbn. destruct (find _ _) eqn:Hfnd;simpl. + unfold fun_prod,id. cbn. destruct (find _ _) eqn:Hfnd; simpl. ** eapply find_map with (p2 := (fun x => pName (fst x) =? s)%string) - (f:= fun x => ((fst x), (snd x){#|pVars (fst x)|+n1 := t⟦ e0 ⟧ Σ})) in Hfnd;auto. + (f := fun x => ((fst x), (snd x){#|pVars (fst x)|+n1 := t⟦ e0 ⟧ Σ})) in Hfnd; auto. rewrite map_map in Hfnd. simpl in Hfnd. unfold fun_prod,id. simpl. assert ( Hmap : (map (fun x => (id (fst x), (t⟦snd x⟧ Σ) {#|pVars (fst x)|+n1 := t⟦e0⟧ Σ})) l) = @@ -904,27 +904,27 @@ Proof. { eapply forall_map_spec'. apply H. intros a Hin' Ha. f_equal. destruct Hok as [[[? ?] ?] Hty_ok]. assert (iclosed_n (#|pVars (fst a)| + S n1) (snd a) = true) by - now eapply forallb_forall with (x:=a) in Hce2. + now eapply forallb_forall with (x := a) in Hce2. assert (ty_expr_env_ok [(nm, e0)] (#|pVars a.1| + n1) a.2 = true) by - now eapply forallb_forall with (x:=a) in Hty_ok. - apply Ha;auto with hints. + now eapply forallb_forall with (x := a) in Hty_ok. + apply Ha; auto with hints. replace (S (#|pVars (fst a)| + n1)) with (#|pVars (fst a)| + S n1) by lia. assumption. } rewrite <- Hmap. unfold id in *. rewrite Hfnd. simpl. rewrite map_length. - destruct (Nat.eqb #|pVars (fst p0)| #|l0|) eqn:Hlen;simpl;auto. - unfold map_branch_k;cbn. rewrite_all map_length. rewrite combine_length. + destruct (Nat.eqb #|pVars (fst p0)| #|l0|) eqn:Hlen; simpl; auto. + unfold map_branch_k; cbn. rewrite_all map_length. rewrite combine_length. rewrite_all map_length. rewrite PeanoNat.Nat.eqb_eq in Hlen. rewrite Hlen. replace (min _ _) with #|l0| by lia. f_equal. ** change (fun x : pat * term => pName (fst x) =? s)%string with - ((fun x : pat => pName x =? s) ∘ fst (B:=term))%string in *. - erewrite find_none_fst with (l1:=(map (fun x : pat × expr => (x.1, t⟦ x.2 ⟧ Σ)) l));eauto. + ((fun x : pat => pName x =? s) ∘ fst (B := term))%string in *. + erewrite find_none_fst with (l1 := (map (fun x : pat × expr => (x.1, t⟦ x.2 ⟧ Σ)) l)); eauto. now repeat rewrite map_map. + (* eFix *) - cbn in *. unfold is_true in *;repeat rewrite Bool.andb_true_iff in *. - unfold map_def. simpl. repeat f_equal;intuition. + cbn in *. unfold is_true in *; repeat rewrite Bool.andb_true_iff in *. + unfold map_def. simpl. repeat f_equal; intuition. rewrite commut_lift_subst. intuition. rewrite commut_lift_subst. intuition. + (* eTy *) simpl in *. eauto with hints. Qed. @@ -936,10 +936,10 @@ Lemma subst_term_subst_env e : ty_expr_env_ok ρ 0 e -> val_ok Σ v -> iclosed_n 1 e = true -> - (t⟦e⟧ Σ) {0:=t⟦ of_val_i v ⟧ Σ} = + (t⟦e⟧ Σ) {0 := t⟦ of_val_i v ⟧ Σ} = (t⟦e.[ρ]⟧ Σ). Proof. - simpl;intros. + simpl; intros. assert (iclosed_n 0 (of_val_i v) = true) by now eapply of_value_closed. now apply subst_term_subst_env_rec. Qed. @@ -949,9 +949,9 @@ Lemma subst_env_ty_closed_n_eq n m ty ρ : subst_env_i_ty (m + n) ρ ty = ty. Proof. revert n m ρ. - induction ty;intros;simpl in *;unfold is_true in *;propify;intuition;eauto. + induction ty; intros; simpl in *; unfold is_true in *; propify; intuition; eauto. + f_equal. now replace (S (m + n)) with (m + S n) by lia. - + destruct (Nat.leb (m + n0)) eqn:Hmn1; propify;try lia;easy. + + destruct (Nat.leb (m + n0)) eqn:Hmn1; propify; try lia; easy. Qed. #[export] Hint Resolve subst_env_ty_closed_n_eq : hints. @@ -960,7 +960,7 @@ Lemma map_subst_env_ty_closed n m ρ l0 : forallb (iclosed_ty n) l0 -> map (subst_env_i_ty (m + n) ρ) l0 = l0. Proof. - intros H. revert dependent n. revert m ρ. induction l0;intros m ρ n Hc;simpl;auto. + intros H. revert dependent n. revert m ρ. induction l0; intros m ρ n Hc; simpl; auto. simpl in *. propify. destruct_hyps. f_equal; eauto with hints. Qed. @@ -970,18 +970,18 @@ Lemma subst_env_i_closed_n_eq : e.[ρ](m+n) = e. Proof. intros e. - induction e using expr_ind_case;intros n1 m1 ρ Hc;simpl in *; - propify;eauto with hints. - + simpl in *. destruct (Nat.leb (m1 + n1)) eqn:Hmn1; propify;try lia;easy. - + simpl in *. f_equal. eapply subst_env_ty_closed_n_eq;intuition. + induction e using expr_ind_case; intros n1 m1 ρ Hc; simpl in *; + propify; eauto with hints. + + simpl in *. destruct (Nat.leb (m1 + n1)) eqn:Hmn1; propify; try lia; easy. + + simpl in *. f_equal. eapply subst_env_ty_closed_n_eq; intuition. now replace (S (m1 + n1)) with (m1 + S n1) by lia. + simpl in *. f_equal. replace (S (m1 + n1)) with (m1 + S n1) by lia. easy. - + simpl in *. f_equal;replace (S (m1 + n1)) with (m1 + S n1) by lia;intuition;eauto with hints. - + simpl in *. f_equal;replace (S (m1 + n1)) with (m1 + S n1) by lia;easy. + + simpl in *. f_equal; replace (S (m1 + n1)) with (m1 + S n1) by lia; intuition; eauto with hints. + + simpl in *. f_equal; replace (S (m1 + n1)) with (m1 + S n1) by lia; easy. + simpl in *. destruct p. assert (map (fun x : pat × expr => (x.1, x.2 .[ ρ] (#|pVars x.1| + (m1 + n1)))) l = l). { transitivity (map id l). - eapply forall_map_spec';eauto. + eapply forall_map_spec'; eauto. simpl. intros x Hin Hx. destruct x. unfold id. f_equal. simpl in *. replace (#|pVars p| + (m1 + n1)) with (m1 + (#|pVars p| + n1)) by lia. apply Hx. intuition. rewrite forallb_forall in *. @@ -990,9 +990,9 @@ Proof. change p with (fst (p,e0)). easy. apply map_id. } assert (map (subst_env_i_ty (m1 + n1) ρ) l0 = l0) by now eapply map_subst_env_ty_closed. - repeat f_equal;intuition;eauto with hints. - + simpl in *. f_equal;intuition. now replace (S (S (m1 + n1))) with (m1 + S (S n1)) by lia. - + f_equal;auto with hints. + repeat f_equal; intuition; eauto with hints. + + simpl in *. f_equal; intuition. now replace (S (S (m1 + n1))) with (m1 + S (S n1)) by lia. + + f_equal; auto with hints. Qed. Lemma subst_env_i_closed_eq : @@ -1000,7 +1000,7 @@ Lemma subst_env_i_closed_eq : iclosed_n 0 e = true -> e.[ρ]n = e. Proof. - intros;eapply subst_env_i_closed_n_eq with (m:=0);eauto. + intros; eapply subst_env_i_closed_n_eq with (m := 0); eauto. now apply iclosed_n_0. Qed. @@ -1010,7 +1010,7 @@ Lemma subst_env_ty_compose_1 k ρ nm e' ty : subst_env_i_ty k (ρ # [nm ~> e']) ty = subst_env_i_ty k [(nm, e')] (subst_env_i_ty (S k) ρ ty). Proof. revert k ρ nm e'. - induction ty;intros ? ? ? ? Hfa Hc;simpl;try now f_equal. + induction ty; intros ? ? ? ? Hfa Hc; simpl; try now f_equal. destruct n. * reflexivity. * simpl. destruct (k <=? n) eqn:Hkn. @@ -1026,17 +1026,17 @@ Proof. { eapply (All_lookup_i _ _ _ (fun x => iclosed_n 0 x) Hfa Hl). } destruct (expr_to_ty e) as [t0|] eqn:He. **** assert (iclosed_ty 0 t0). - { destruct e;tryfalse. now inversion He;subst. } - symmetry. eapply subst_env_ty_closed_n_eq with (m:=0). now eapply iclosed_ty_0. + { destruct e; tryfalse. now inversion He; subst. } + symmetry. eapply subst_env_ty_closed_n_eq with (m := 0). now eapply iclosed_ty_0. **** simpl. unfold lookup_ty in *. rewrite H0. - destruct k;auto;tryfalse. + destruct k; auto; tryfalse. rewrite Nat.eqb_neq in *. simpl. assert (S n- S k <> 0) by lia. - destruct (S n - S k =? 0)%nat eqn:HH;tryfalse;auto. rewrite Nat.eqb_eq in *. + destruct (S n - S k =? 0)%nat eqn:HH; tryfalse; auto. rewrite Nat.eqb_eq in *. propify. lia. *** remember (S n) as m. simpl. rewrite H0. unfold lookup_ty in *. simpl. now rewrite Hneq. ** propify. - assert (HkSn : S n <= k) by lia. + assert (HkSn : S n <= k) by lia. case HkSn. *** rewrite PeanoNat.Nat.leb_refl. simpl. replace (S n - S n) with 0 by lia. simpl. @@ -1058,11 +1058,11 @@ Lemma subst_env_compose_1 : Proof. intros nm. unfold inst_env_i,subst_env_i in *. simpl in *. - induction e using expr_ind_case;intros e' k ρ Hfc Hc; - simpl in *; propify;try f_equal;auto with hints. + induction e using expr_ind_case; intros e' k ρ Hfc Hc; + simpl in *; propify; try f_equal; auto with hints. + simpl. destruct n. * reflexivity. - * simpl;destruct (Nat.leb k n) eqn:Hkn. + * simpl; destruct (Nat.leb k n) eqn:Hkn. ** propify. assert (k <= S n) by lia. destruct_match eqn:H0; try now propify. @@ -1076,7 +1076,7 @@ Proof. *** remember (S n) as m. simpl. rewrite H0. now rewrite Hneq. ** propify. - assert (HkSn : S n <= k) by lia. + assert (HkSn : S n <= k) by lia. case HkSn. *** rewrite PeanoNat.Nat.leb_refl. simpl. replace (S n - S n) with 0 by lia. simpl. @@ -1085,11 +1085,11 @@ Proof. rewrite <- PeanoNat.Nat.leb_gt in H. rewrite H. remember (S n) as n'. remember (S m) as m'. simpl. now rewrite H. - + destruct p. simpl. rewrite map_map. f_equal;eauto with hints. f_equal. - eapply map_ext. intros;eapply subst_env_ty_compose_1;eauto with hints. + + destruct p. simpl. rewrite map_map. f_equal; eauto with hints. f_equal. + eapply map_ext. intros; eapply subst_env_ty_compose_1; eauto with hints. rewrite map_map. simpl. - eapply forall_map_spec;eauto. - eapply Forall_impl;eauto. + eapply forall_map_spec; eauto. + eapply Forall_impl; eauto. intros a Ha. simpl in *. f_equal. replace (#|pVars (fst a)| + S k) with (S (#|pVars (fst a)| + k)) by lia. now apply Ha. @@ -1102,16 +1102,16 @@ Lemma subst_env_swap_app : (e.[ρ1](n+#|ρ2|)).[ρ2]n = e.[ρ2++ρ1]n. Proof. induction ρ2. - + intros. simpl. symmetry. rewrite <- subst_env_i_empty with (k:=n). + + intros. simpl. symmetry. rewrite <- subst_env_i_empty with (k := n). f_equal. lia. + intros. simpl. destruct a. inversion X0. subst. clear X0. assert (All (fun x => iclosed_n 0 (snd x) = true) (ρ2++ρ1)) by now apply All_app_inv. rewrite subst_env_compose_1 with (ρ := ρ2 ++ ρ1) by auto. - rewrite subst_env_compose_1 with (k:=n) by auto. + rewrite subst_env_compose_1 with (k := n) by auto. simpl. - rewrite <-IHρ2;eauto. + rewrite <-IHρ2; eauto. replace (n + S #|ρ2|) with (S n + #|ρ2|) by lia. reflexivity. Qed. @@ -1125,12 +1125,12 @@ Lemma subst_env_compose_2 : e.[ρ # [nm1 ~> e1] # [nm2 ~> e2]] = (e.[ρ]2).[nil # [nm1 ~> e1] # [nm2 ~> e2]]. Proof. - intros. change ((nm2, e2) :: (nm1, e1) :: ρ) with ([(nm2, e2);(nm1, e1)] ++ ρ). - symmetry. eapply subst_env_swap_app;eauto. + intros. change ((nm2, e2) :: (nm1, e1) :: ρ) with ([(nm2, e2); (nm1, e1)] ++ ρ). + symmetry. eapply subst_env_swap_app; eauto. Qed. -Remove Hints iclosed_n_geq: hints. -Remove Hints Bool.absurd_eq_true : core. +#[local] Remove Hints iclosed_n_geq: hints. +#[local] Remove Hints Bool.absurd_eq_true : core. Open Scope nat. @@ -1139,11 +1139,11 @@ Lemma lookup_i_app {A} (l1 l2 : env A) i : lookup_i (l1 ++ l2) i = lookup_i l2 (i - #|l1|). Proof. revert l2 i. - induction l1;intros. + induction l1; intros. + simpl. now replace (i-0) with i by lia. + simpl. destruct a. simpl in *. destruct i. - * exfalso;lia. + * exfalso; lia. * simpl. now replace (S i-1) with i by lia. Qed. @@ -1152,23 +1152,23 @@ Lemma ty_env_ok_app_rec : ty_env_ok n (ρ1 ++ ρ2) ty -> ty_env_ok (n+#|ρ1|) ρ2 ty. Proof. - induction ty;intros;auto. + induction ty; intros; auto. + simpl in *. now replace (S (n + #|ρ1|)) with (S n + #|ρ1|) by lia. + simpl in *. unfold is_true in *. now propify. + cbn -[lookup_i] in *. destruct (n0 + #|ρ1| <=? n) eqn:Hn. * assert (Hleb : n0 <=? n = true) by (propify; lia). rewrite Hleb in *. replace (n - (n0 + #|ρ1|)) with ((n - n0) - #|ρ1|) by lia. rewrite lookup_i_app in H by (propify; lia). easy. - * destruct (n0 <=? n) eqn:Hn0;auto. + * destruct (n0 <=? n) eqn:Hn0; auto. + simpl in *. unfold is_true in *. now propify. Qed. #[export] Hint Resolve ty_env_ok_app_rec : hints. #[export] Hint Resolve subst_env_compose_1 : hints. -Hint Extern 2 (iclosed_n _ (snd _) = _) => simpl : hints. -Hint Extern 2 (_ .[_] = _)=> simpl;eapply subst_env_compose_1 with (k:=0) : hints. -Hint Extern 2 (iclosed_n ?n _ = _)=> (match n with +#[export] Hint Extern 2 (iclosed_n _ (snd _) = _) => simpl : hints. +#[export] Hint Extern 2 (_ .[_] = _)=> simpl; eapply subst_env_compose_1 with (k := 0) : hints. +#[export] Hint Extern 2 (iclosed_n ?n _ = _)=> (match n with | O => fail | S _ => eapply iclosed_n_0 end) : hints. @@ -1178,8 +1178,8 @@ Lemma ty_expr_env_ok_app_rec : ty_expr_env_ok (ρ1 ++ ρ2) n e -> ty_expr_env_ok ρ2 (n + #|ρ1|) e. Proof. - induction e using expr_ind_case;intros ? ? ? Hok;simpl in *;unfold is_true in *; - propify;eauto with hints. + induction e using expr_ind_case; intros ? ? ? Hok; simpl in *; unfold is_true in *; + propify; eauto with hints. + replace (S (n0 + #|ρ1|)) with (S n0 + #|ρ1|) by lia. intuition. now apply ty_env_ok_app_rec. @@ -1189,7 +1189,7 @@ Proof. now replace (S (n0 + #|ρ1|)) with (S n0 + #|ρ1|) by lia. + intuition. + intuition. - eapply forallb_impl_inner;intros;eauto; now apply ty_env_ok_app_rec. + eapply forallb_impl_inner; intros; eauto; now apply ty_env_ok_app_rec. now apply ty_env_ok_app_rec. cbn. apply forallb_Forall. apply forallb_Forall in H1. eapply Forall_impl_inner. apply H. simpl in *. @@ -1206,22 +1206,22 @@ Lemma iclosed_ty_expr_env_ok : iclosed_n n e -> ty_expr_env_ok ρ n e. Proof. intros. revert dependent n. revert ρ. - induction e using expr_elim_case;intros ?? Hc;eauto. + induction e using expr_elim_case; intros ?? Hc; eauto. + simpl in *. unfold is_true in *. propify. - intuition. eapply iclosed_ty_env_ok;eauto. + intuition. eapply iclosed_ty_env_ok; eauto. + simpl in *. unfold is_true in *. propify. - intuition. eapply iclosed_ty_env_ok;eauto. + intuition. eapply iclosed_ty_env_ok; eauto. + simpl in *. unfold is_true in *. now propify. + simpl in *. unfold is_true in *. propify. - intuition;eauto with hints. - eapply forallb_impl_inner;intros;eauto; now apply iclosed_ty_env_ok. + intuition; eauto with hints. + eapply forallb_impl_inner; intros; eauto; now apply iclosed_ty_env_ok. now apply iclosed_ty_env_ok. apply All_forallb. apply forallb_All in H0. eapply All_impl_inner. apply X. simpl in *. eapply All_impl. apply H0. intros. simpl in *. easy. + simpl in *. unfold is_true in *. propify. - intuition;now apply iclosed_ty_env_ok. + intuition; now apply iclosed_ty_env_ok. + now apply iclosed_ty_env_ok. Qed. @@ -1231,9 +1231,9 @@ Lemma ty_env_ok_subst_env k ρ1 ρ2 (ty : type) : ty_env_ok k ρ1 (subst_env_i_ty (k+#|ρ1|) ρ2 ty). Proof. revert k ρ1 ρ2. - induction ty;intros k ρ1 ρ2 Hok Hall;auto. + induction ty; intros k ρ1 ρ2 Hok Hall; auto. + simpl in *. replace (S (k + #|ρ1|)) with (S k + #|ρ1|) by lia. - eapply IHty;eauto. + eapply IHty; eauto. + simpl in *. unfold is_true in *; now propify. + cbn -[lookup_i] in *. destruct (k + #|ρ1| <=? n) eqn:Hn. * assert (Hleb : k <=? n = true) by (propify; lia). @@ -1242,15 +1242,15 @@ Proof. rewrite lookup_i_app in Hok by assumption. unfold lookup_ty. destruct (lookup_i ρ2 (n - k - #|ρ1|)) eqn:Hlook. - ** destruct e;tryfalse. simpl in *. - eapply All_lookup_i in Hall;eauto. + ** destruct e; tryfalse. simpl in *. + eapply All_lookup_i in Hall; eauto. eapply iclosed_ty_env_ok. now eapply iclosed_ty_0. - ** simpl. destruct (k<=? n);auto. rewrite lookup_i_length_false;auto. - propify;auto. - * simpl in *;destruct (k <=? n) eqn:Hn0;auto. - rewrite lookup_i_nth_error in *. rewrite nth_error_app1 in Hok by (propify;lia). - destruct (nth_error ρ1 (n - k)) eqn:Hnth;auto. + ** simpl. destruct (k<=? n); auto. rewrite lookup_i_length_false; auto. + propify; auto. + * simpl in *; destruct (k <=? n) eqn:Hn0; auto. + rewrite lookup_i_nth_error in *. rewrite nth_error_app1 in Hok by (propify; lia). + destruct (nth_error ρ1 (n - k)) eqn:Hnth; auto. + simpl in *. unfold is_true in *; now propify. Qed. @@ -1260,38 +1260,38 @@ Lemma ty_expr_env_ok_subst_env k ρ1 ρ2 e : ty_expr_env_ok ρ1 k (e.[ρ2](k+#|ρ1|)). Proof. revert k ρ1 ρ2. - induction e using expr_elim_case;intros;eauto with hints. + induction e using expr_elim_case; intros; eauto with hints. + simpl in *. - destruct (k + #|ρ1| <=? n) eqn:Hkn;eauto. - destruct (lookup_i ρ2 (n - (k + #|ρ1|))) eqn:Hl;auto. - eapply All_lookup_i in X;eauto. simpl. + destruct (k + #|ρ1| <=? n) eqn:Hkn; eauto. + destruct (lookup_i ρ2 (n - (k + #|ρ1|))) eqn:Hl; auto. + eapply All_lookup_i in X; eauto. simpl. eapply iclosed_ty_expr_env_ok. now eapply iclosed_n_0. + simpl in *. propify. destruct_hyps. split. now eapply ty_env_ok_subst_env. replace (S (k + #|ρ1|)) with (S k + #|ρ1|) by lia. - eapply IHe;eauto. - + simpl in *. eapply IHe;eauto. + eapply IHe; eauto. + + simpl in *. eapply IHe; eauto. + simpl in *. unfold is_true in *. propify. - intuition. eapply ty_env_ok_subst_env;eauto. + intuition. eapply ty_env_ok_subst_env; eauto. + simpl in *. unfold is_true in *. now propify. + simpl in *. destruct p. simpl in *. unfold is_true in *. propify. - intuition;eauto with hints. - * rewrite forallb_map. eapply forallb_impl_inner;eauto. - intros. eapply ty_env_ok_subst_env;eauto. - * eapply ty_env_ok_subst_env;eauto. + intuition; eauto with hints. + * rewrite forallb_map. eapply forallb_impl_inner; eauto. + intros. eapply ty_env_ok_subst_env; eauto. + * eapply ty_env_ok_subst_env; eauto. * apply All_forallb. apply All_map. intros. unfold compose. simpl in *. eapply forallb_All in H1. eapply (All_impl_inner _ _ _ H1). eapply All_impl. apply X. intros. simpl in *. replace (#|pVars x.1| + (k + #|ρ1|)) with (#|pVars x.1| + k + #|ρ1|) by lia. - eapply H;eauto. + eapply H; eauto. + simpl in *. unfold is_true in *. propify. - intuition;eapply ty_env_ok_subst_env;eauto. - + eapply ty_env_ok_subst_env;eauto. + intuition; eapply ty_env_ok_subst_env; eauto. + + eapply ty_env_ok_subst_env; eauto. Qed. #[export] Hint Resolve ty_expr_env_ok_app_rec : hints. @@ -1306,22 +1306,22 @@ Lemma subst_term_subst_env_par_rec : subst (map (fun x => expr_to_term Σ (snd x)) l) k (t⟦e⟧ Σ) = (t⟦e.[l]k⟧ Σ). Proof. intros until l. - induction l using MCList.rev_ind;intros e k Hgeok Hok Hc Hall. + induction l using MCList.rev_ind; intros e k Hgeok Hok Hc Hall. + simpl in *. unfold subst_env_i. rewrite <- subst_env_i_empty. rewrite subst_empty. reflexivity. + unfold subst_env_i. destruct x as [nm e0]. simpl in *. - apply All_app in Hall as [Hl He0]. inversion He0;subst;clear He0. simpl in *. + apply All_app in Hall as [Hl He0]. inversion He0; subst; clear He0. simpl in *. unfold subst_env_i. rewrite map_app. simpl. rewrite subst_app_simpl. rewrite map_length. simpl. rewrite app_length in *. simpl in *. replace (#|l| + 1) with (1 + #|l|) in Hc by lia. replace (k + (1 + #|l|)) with (1+ k + #|l|) in Hc by lia. - rewrite subst_term_subst_env_rec with (e:=e)(nm:=nm) by eauto with hints. - rewrite <- subst_env_swap_app with (n:=k) by eauto. + rewrite subst_term_subst_env_rec with (e := e)(nm := nm) by eauto with hints. + rewrite <- subst_env_swap_app with (n := k) by eauto. simpl. replace (1 + k + #|l|) with (k + #|l| + 1) in * by lia. - eapply IHl;eauto with hints. - eapply ty_expr_env_ok_subst_env;eauto with hints. + eapply IHl; eauto with hints. + eapply ty_expr_env_ok_subst_env; eauto with hints. Qed. Lemma subst_term_subst_env_par : @@ -1332,7 +1332,7 @@ Lemma subst_term_subst_env_par : All (fun x : string * expr => iclosed_n 0 (snd x) = true) l -> subst (map (fun x => expr_to_term Σ (snd x)) l) 0 (t⟦e⟧ Σ) = (t⟦e.[l]⟧ Σ). Proof. - intros. eapply subst_term_subst_env_par_rec;eauto. + intros. eapply subst_term_subst_env_par_rec; eauto. Qed. Import Basics. @@ -1348,14 +1348,14 @@ Lemma pat_match_succeeds {A : Type } cn arity (vals : list A) brs e Proof. intros Hpm. unfold match_pat in Hpm. simpl in Hpm. - destruct (find (fun x => pName (fst x) =? cn)%string brs) eqn:Hfnd;tryfalse. + destruct (find (fun x => pName (fst x) =? cn)%string brs) eqn:Hfnd; tryfalse. destruct p as [p' e0]. simpl in *. - destruct (Nat.eqb #|vals| (n+#|pVars p'|)) eqn:Hlength;tryfalse. - destruct (Nat.eqb #|vals| (n+#|arity|)) eqn:Hlength';tryfalse. + destruct (Nat.eqb #|vals| (n+#|pVars p'|)) eqn:Hlength; tryfalse. + destruct (Nat.eqb #|vals| (n+#|arity|)) eqn:Hlength'; tryfalse. simpl in *. inversion Hpm. subst. clear Hpm. exists p'. rewrite PeanoNat.Nat.eqb_eq in *. - repeat split;auto. now rewrite Hlength in *. + repeat split; auto. now rewrite Hlength in *. Qed. Lemma Forall_snd_combine {A B} (l1 : list A) (l2 : list B) @@ -1363,9 +1363,9 @@ Lemma Forall_snd_combine {A B} (l1 : list A) (l2 : list B) Proof. revert l1. induction l2; intros ns H. - + destruct ns;simpl;constructor. - + inversion H. subst. destruct ns;unfold compose;simpl. constructor. - constructor; unfold compose;simpl;auto. + + destruct ns; simpl; constructor. + + inversion H. subst. destruct ns; unfold compose; simpl. constructor. + constructor; unfold compose; simpl; auto. Qed. Lemma All_snd_combine {A B} (l1 : list A) (l2 : list B) @@ -1373,9 +1373,9 @@ Lemma All_snd_combine {A B} (l1 : list A) (l2 : list B) Proof. revert l1. induction l2; intros ns H. - + destruct ns;simpl;constructor. - + inversion H. subst. destruct ns;unfold compose;simpl. constructor. - constructor; unfold compose;simpl;auto. + + destruct ns; simpl; constructor. + + inversion H. subst. destruct ns; unfold compose; simpl. constructor. + constructor; unfold compose; simpl; auto. Qed. @@ -1393,37 +1393,37 @@ Lemma eval_ge_val_ok n ρ Σ e v : ge_val_ok Σ v. Proof. revert dependent ρ. revert dependent v. revert dependent e. - induction n;intros e v ρ Hok He;tryfalse. - destruct e;unfold expr_eval_i in *;simpl in *;inversion He;tryfalse. - + destruct (lookup_i ρ n0) eqn:Hlook;simpl in *;inversion He;subst. - now eapply All_lookup_i with (e:=v). - + destruct (eval_type_i 0 ρ _);tryfalse. simpl in *. inversion H0. - simpl. destruct (valid_env _ _ _);tryfalse. + induction n; intros e v ρ Hok He; tryfalse. + destruct e; unfold expr_eval_i in *; simpl in *; inversion He; tryfalse. + + destruct (lookup_i ρ n0) eqn:Hlook; simpl in *; inversion He; subst. + now eapply All_lookup_i with (e := v). + + destruct (eval_type_i 0 ρ _); tryfalse. simpl in *. inversion H0. + simpl. destruct (valid_env _ _ _); tryfalse. inversion He. now apply All_forallb. - + simpl in *. destruct (valid_env _ _ _);tryfalse. inversion He. now apply All_forallb. - + destruct (expr_eval_general _ _ _ _ e2) eqn:He1;tryfalse. - destruct (eval_type_i _ _ _);tryfalse. + + simpl in *. destruct (valid_env _ _ _); tryfalse. inversion He. now apply All_forallb. + + destruct (expr_eval_general _ _ _ _ e2) eqn:He1; tryfalse. + destruct (eval_type_i _ _ _); tryfalse. assert (ge_val_ok Σ v0) by now eapply IHn. - eapply IHn with (e:=e3) (ρ:=(e1, v0) :: ρ);eauto with hints. - + destruct (expr_eval_general _ _ _ _ e1) eqn:He1;tryfalse. - 2 : { try (destruct (expr_eval_general _ _ _ _ e2) eqn:He2);tryfalse. } - destruct v0;try destruct c; - destruct (expr_eval_general _ _ _ _ e2) eqn:He2;tryfalse. - * simpl in *. destruct (resolve_constr Σ i e) eqn:Hc;tryfalse;eauto. + eapply IHn with (e := e3) (ρ := (e1, v0) :: ρ); eauto with hints. + + destruct (expr_eval_general _ _ _ _ e1) eqn:He1; tryfalse. + 2 : { try (destruct (expr_eval_general _ _ _ _ e2) eqn:He2); tryfalse. } + destruct v0; try destruct c; + destruct (expr_eval_general _ _ _ _ e2) eqn:He2; tryfalse. + * simpl in *. destruct (resolve_constr Σ i e) eqn:Hc; tryfalse; eauto. destruct p. destruct p. - destruct (_ <=? _);tryfalse;cbn in *. - inversion He;subst;clear He. simpl. + destruct (_ <=? _); tryfalse; cbn in *. + inversion He; subst; clear He. simpl. assert (ge_val_ok Σ (vConstr i e l)) by eauto. assert (ge_val_ok Σ v0) by eauto. - simpl in *. rewrite Hc in *. rewrite forallb_app. cbn. propify. now split;eauto. + simpl in *. rewrite Hc in *. rewrite forallb_app. cbn. propify. now split; eauto. * assert (ge_val_ok Σ (vClos e _ cmLam t t0 _)) by eauto. assert (ge_val_ok Σ v0) by eauto. simpl in *. - eapply IHn with (ρ:=(e0, v0) :: e);eauto with hints. + eapply IHn with (ρ := (e0, v0) :: e); eauto with hints. apply forallb_All. simpl. now propify. - * destruct v0;tryfalse. + * destruct v0; tryfalse. remember (e # [e4 ~> _] # [ e0 ~> _]) as ρ'. - eapply IHn with (e:=e3) (ρ:=ρ'); try eapply He0;eauto. + eapply IHn with (e := e3) (ρ := ρ'); try eapply He0; eauto. assert (Hok_fix : ge_val_ok Σ (vClos e _ (cmFix _) t t0 _)) by eauto. simpl in Hok_fix. apply forallb_Forall in Hok_fix. subst. unfold AllEnv,compose. apply Forall_All. @@ -1431,40 +1431,40 @@ Proof. * assert (ge_val_ok Σ (vTyClos e e0 e3)) by eauto. assert (ge_val_ok Σ v0) by eauto. simpl in *. - eapply IHn with (ρ:=(e0, v0) :: e);eauto with hints. + eapply IHn with (ρ := (e0, v0) :: e); eauto with hints. apply forallb_All. simpl. now propify. - * destruct (expr_eval_general _ _ _ _ e2) eqn:He2;tryfalse. - + destruct (resolve_constr Σ i e) eqn:Hres;tryfalse. inversion He. + * destruct (expr_eval_general _ _ _ _ e2) eqn:He2; tryfalse. + + destruct (resolve_constr Σ i e) eqn:Hres; tryfalse. inversion He. simpl. now rewrite Hres. + destruct p as [ind e1]. - destruct (forallb _ l);tryfalse. - destruct (eval_type_i _ _ _);tryfalse;simpl in *. - destruct (monad_utils.monad_map _ _) eqn:Hmm;tryfalse. - destruct (expr_eval_general _ _ _ _ e) eqn:He';tryfalse. - destruct v0;tryfalse. - destruct (string_dec _ _);tryfalse;subst. - destruct (resolve_constr Σ i e0) eqn:Hres;tryfalse. + destruct (forallb _ l); tryfalse. + destruct (eval_type_i _ _ _); tryfalse; simpl in *. + destruct (monad_utils.monad_map _ _) eqn:Hmm; tryfalse. + destruct (expr_eval_general _ _ _ _ e) eqn:He'; tryfalse. + destruct v0; tryfalse. + destruct (string_dec _ _); tryfalse; subst. + destruct (resolve_constr Σ i e0) eqn:Hres; tryfalse. destruct p as [n_i tys]. destruct n_i. - destruct ((n0 =? #|e1|)%nat);tryfalse. - destruct (match_pat e0 _ tys _ _) eqn:Hpm;tryfalse. + destruct ((n0 =? #|e1|)%nat); tryfalse. + destruct (match_pat e0 _ tys _ _) eqn:Hpm; tryfalse. destruct p as [assign e2]. apply pat_match_succeeds in Hpm. destruct Hpm as [pt Htmp]. destruct_hyps. subst. assert (Hok_constr : ge_val_ok Σ (vConstr i _ l1)) - by now eapply IHn with (e:=e). - simpl in Hok_constr. destruct (resolve_constr Σ i e0) eqn:Hres';tryfalse. + by now eapply IHn with (e := e). + simpl in Hok_constr. destruct (resolve_constr Σ i e0) eqn:Hres'; tryfalse. assert (Hok_l2 : AllEnv (fun x => ge_val_ok Σ x = true) (rev (combine (pVars pt) (skipn n0 l1)))). { apply All_rev. simpl in Hok_constr. apply forallb_Forall in Hok_constr. simpl in *. apply All_snd_combine. apply Forall_All. now apply Forall_skipn. } - eapply IHn with (ρ := (rev (combine (pVars pt) ((skipn _ l1))) ++ ρ)%list);eauto. - apply All_app_inv;eauto. - + destruct (valid_env _ _ _);tryfalse. - destruct (eval_type_i 0 ρ _);tryfalse;simpl in *. - destruct (eval_type_i 0 ρ _);tryfalse;simpl in *. + eapply IHn with (ρ := (rev (combine (pVars pt) ((skipn _ l1))) ++ ρ)%list); eauto. + apply All_app_inv; eauto. + + destruct (valid_env _ _ _); tryfalse. + destruct (eval_type_i 0 ρ _); tryfalse; simpl in *. + destruct (eval_type_i 0 ρ _); tryfalse; simpl in *. inversion H0. simpl. inversion He. now apply All_forallb. - + destruct (eval_type_i 0 ρ _);tryfalse;simpl in *. + + destruct (eval_type_i 0 ρ _); tryfalse; simpl in *. now inversion He. Qed. @@ -1472,7 +1472,7 @@ Open Scope list. Lemma env_ok_concat Σ ρ1 ρ2 : env_ok Σ ρ1 -> env_ok Σ ρ2 -> env_ok Σ (ρ1 ++ ρ2). Proof. intros Hok1 Hok2. - apply All_app_inv;auto. + apply All_app_inv; auto. Qed. Lemma rev_env_ok ρ Σ : env_ok Σ ρ -> env_ok Σ (rev ρ). @@ -1484,18 +1484,18 @@ Qed. Lemma val_ok_ge_val_ok Σ v: val_ok Σ v -> ge_val_ok Σ v. Proof. - induction v using val_elim_full;intros Hok. - + simpl. inversion Hok;subst;clear Hok. - destruct (resolve_constr Σ i n) eqn:Hres;tryfalse. - inversion H1;subst. simpl in *. - apply All_forallb. eapply All_impl_inner;eauto. + induction v using val_elim_full; intros Hok. + + simpl. inversion Hok; subst; clear Hok. + destruct (resolve_constr Σ i n) eqn:Hres; tryfalse. + inversion H1; subst. simpl in *. + apply All_forallb. eapply All_impl_inner; eauto. + simpl. apply All_forallb. - inversion Hok;subst;clear Hok;eapply All_impl_inner;eauto. - + simpl in *. inversion Hok;subst. + inversion Hok; subst; clear Hok; eapply All_impl_inner; eauto. + + simpl in *. inversion Hok; subst. eapply All_forallb. eapply All_impl_inner. apply X0. unfold compose. eapply All_impl. apply X. - intros;unfold compose in *;cbn in *. easy. - + now inversion Hok;subst. + intros; unfold compose in *; cbn in *. easy. + + now inversion Hok; subst. Qed. Lemma env_ok_ForallEnv_ge_val_ok ρ Σ : @@ -1503,7 +1503,7 @@ Lemma env_ok_ForallEnv_ge_val_ok ρ Σ : Proof. induction ρ. + intros. constructor. - + intros Hok. inversion Hok;subst. + + intros Hok. inversion Hok; subst. constructor. * now apply val_ok_ge_val_ok. * now eapply IHρ. @@ -1515,33 +1515,33 @@ Lemma Forall_monad_map_some {A B} {f} {xs : list A} {ys : list B} : monad_utils.monad_map f xs = Ok ys -> Forall (fun x => exists v, f x = Ok v) xs. Proof. revert ys. - induction xs;intros;simpl in *;auto. - destruct (f _) eqn:Hf;tryfalse. destruct (monad_utils.monad_map _ _) eqn:Hmm;tryfalse. - constructor;eauto. + induction xs; intros; simpl in *; auto. + destruct (f _) eqn:Hf; tryfalse. destruct (monad_utils.monad_map _ _) eqn:Hmm; tryfalse. + constructor; eauto. Qed. Lemma eval_ty_env_ok : forall (ty : type) (ρ : env val) (n : nat) (ty_v : type), eval_type_i n ρ ty = Some ty_v -> ty_env_ok n (exprs ρ) ty = true. Proof. - induction ty;intros. + induction ty; intros. + easy. - + simpl in *. destruct (eval_type_i (S n) ρ ty) eqn:Hty;tryfalse. inversion H. subst. + + simpl in *. destruct (eval_type_i (S n) ρ ty) eqn:Hty; tryfalse. inversion H. subst. eauto. + simpl in *. - destruct (eval_type_i n ρ ty2) eqn:Hty2;tryfalse. - destruct (eval_type_i n ρ ty1) eqn:Hty1;tryfalse. + destruct (eval_type_i n ρ ty2) eqn:Hty2; tryfalse. + destruct (eval_type_i n ρ ty1) eqn:Hty1; tryfalse. now propify. + tryfalse. + simpl in *. - destruct (n0 <=? n) eqn:Hn0;auto. + destruct (n0 <=? n) eqn:Hn0; auto. rewrite lookup_i_nth_error in H. rewrite lookup_i_nth_error. rewrite nth_error_map. - destruct (nth_error ρ (n - n0));simpl in *;auto. destruct (p.2);tryfalse. + destruct (nth_error ρ (n - n0)); simpl in *; auto. destruct (p.2); tryfalse. inversion H. reflexivity. + simpl in *. - destruct (eval_type_i n ρ ty2) eqn:Hty2;tryfalse. - destruct (eval_type_i n ρ ty1) eqn:Hty1;tryfalse. + destruct (eval_type_i n ρ ty2) eqn:Hty2; tryfalse. + destruct (eval_type_i n ρ ty1) eqn:Hty1; tryfalse. now propify. Qed. @@ -1551,65 +1551,65 @@ Lemma eval_ty_expr_env_ok : iclosed_n #|ρ| e = true -> (eval (n, Σ, ρ, e)) = Ok v0 -> ty_expr_env_ok (exprs ρ) 0 e. Proof. - induction n;intros Σ e ρ v0 Hc He;tryfalse. - + destruct e;eauto. - * simpl in *. destruct (eval_type_i 0 _ _) eqn:Ht0;simpl in *;tryfalse. - inversion He;subst;clear He. propify. destruct_and_split. + induction n; intros Σ e ρ v0 Hc He; tryfalse. + + destruct e; eauto. + * simpl in *. destruct (eval_type_i 0 _ _) eqn:Ht0; simpl in *; tryfalse. + inversion He; subst; clear He. propify. destruct_and_split. ** now eapply eval_ty_env_ok. - ** destruct (valid_env ρ 1 e0) eqn:Hve0;tryfalse. + ** destruct (valid_env ρ 1 e0) eqn:Hve0; tryfalse. now eapply valid_env_ty_expr_env_ok. - * simpl in *. destruct (valid_env _ _ _) eqn:Hve0;tryfalse. inversion He;subst;clear He. + * simpl in *. destruct (valid_env _ _ _) eqn:Hve0; tryfalse. inversion He; subst; clear He. now eapply valid_env_ty_expr_env_ok. * simpl in *. - destruct (eval (n, Σ, ρ, e2)) eqn:He2;tryfalse. - destruct (eval_type_i 0 ρ _) eqn:Hty;tryfalse;simpl in *. + destruct (eval (n, Σ, ρ, e2)) eqn:He2; tryfalse. + destruct (eval_type_i 0 ρ _) eqn:Hty; tryfalse; simpl in *. unfold is_true; repeat rewrite Bool.andb_true_iff in *. assert (ty_expr_env_ok (exprs (ρ # [e1 ~> v])) 0 e3 = true) by - (destruct Hc as [[? ?] ?];repeat split;eauto with hints; eapply IHn;eauto ). + (destruct Hc as [[? ?] ?]; repeat split; eauto with hints; eapply IHn; eauto ). simpl in H. destruct Hc as [[? ?] ?]. repeat split. - ** eapply IHn;eauto. - ** eapply eval_ty_env_ok;eauto. - ** now eapply ty_expr_env_ok_app_rec with (n:=0) (ρ1:=[(e1,of_val_i v)]). + ** eapply IHn; eauto. + ** eapply eval_ty_env_ok; eauto. + ** now eapply ty_expr_env_ok_app_rec with (n := 0) (ρ1 := [(e1,of_val_i v)]). * simpl in *. propify. - destruct (eval (n, Σ, ρ, e2)) eqn:He2;tryfalse. - destruct (eval (n, Σ, ρ, e1)) eqn:He1;tryfalse. - destruct v1;inversion He;subst;tryfalse;propify;destruct_and_split; eapply IHn;eauto. + destruct (eval (n, Σ, ρ, e2)) eqn:He2; tryfalse. + destruct (eval (n, Σ, ρ, e1)) eqn:He1; tryfalse. + destruct v1; inversion He; subst; tryfalse; propify; destruct_and_split; eapply IHn; eauto. * simpl in *. destruct p. - destruct (forallb (fun x : pat × expr => valid_env ρ #|pVars x.1| x.2) l) eqn:Hl;tryfalse. - destruct (eval_type_i _ _ _) eqn:Ht0;tryfalse;simpl in *. - destruct (monad_utils.monad_map _ _) eqn:Hind;tryfalse. + destruct (forallb (fun x : pat × expr => valid_env ρ #|pVars x.1| x.2) l) eqn:Hl; tryfalse. + destruct (eval_type_i _ _ _) eqn:Ht0; tryfalse; simpl in *. + destruct (monad_utils.monad_map _ _) eqn:Hind; tryfalse. unfold is_true in *; - repeat rewrite Bool.andb_true_iff in *. - destruct (eval (n, Σ, ρ, e)) eqn:He';tryfalse. - destruct v;tryfalse. - destruct (string_dec _ _);tryfalse. - destruct (resolve_constr Σ _ _);tryfalse. + repeat rewrite Bool.andb_true_iff in *. + destruct (eval (n, Σ, ρ, e)) eqn:He'; tryfalse. + destruct v; tryfalse. + destruct (string_dec _ _); tryfalse. + destruct (resolve_constr Σ _ _); tryfalse. destruct p. destruct p. - destruct ((_ =? _)%nat);tryfalse. - destruct (match_pat e0 _ _ _ _) eqn:Hp;tryfalse. + destruct ((_ =? _)%nat); tryfalse. + destruct (match_pat e0 _ _ _ _) eqn:Hp; tryfalse. destruct p. repeat split. - ** eapply Forall_forallb;eauto. eapply (Forall_monad_map_some Hind);eauto. - intros x H;simpl in *. destruct H. apply option_to_res_ok in H. + ** eapply Forall_forallb; eauto. eapply (Forall_monad_map_some Hind); eauto. + intros x H; simpl in *. destruct H. apply option_to_res_ok in H. now eapply eval_ty_env_ok. ** now eapply eval_ty_env_ok. - ** destruct Hc as [[??]?];eapply IHn;eauto. + ** destruct Hc as [[??]?]; eapply IHn; eauto. ** intuition. - eapply (forallb_impl_inner Hl);intros;eauto. simpl in *. + eapply (forallb_impl_inner Hl); intros; eauto. simpl in *. replace (_ + 0) with #|pVars x.1| by lia. now apply valid_env_ty_expr_env_ok. * simpl in *. - destruct (valid_env ρ 2 _) eqn:Hve1;tryfalse. - destruct (eval_type_i 0 ρ t) eqn:Ht;tryfalse. - destruct (eval_type_i 0 ρ t0) eqn:Ht0;tryfalse. + destruct (valid_env ρ 2 _) eqn:Hve1; tryfalse. + destruct (eval_type_i 0 ρ t) eqn:Ht; tryfalse. + destruct (eval_type_i 0 ρ t0) eqn:Ht0; tryfalse. cbn in *. inversion He. unfold is_true in *; propify. destruct_and_split. now eapply eval_ty_env_ok. now eapply eval_ty_env_ok. now eapply valid_env_ty_expr_env_ok. * simpl in *. - destruct (eval_type_i 0 ρ _) eqn:Ht0;tryfalse. + destruct (eval_type_i 0 ρ _) eqn:Ht0; tryfalse. now eapply eval_ty_env_ok. Qed. @@ -1624,113 +1624,113 @@ Lemma eval_val_ok n ρ Σ e v : val_ok Σ v. Proof. revert dependent ρ. revert dependent v. revert dependent e. - induction n;intros e v ρ Hty_ok Hok Hc He;tryfalse. + induction n; intros e v ρ Hty_ok Hok Hc He; tryfalse. destruct e. + unfold expr_eval_i in *. simpl in *. destruct (lookup_i_length _ _ Hc) as [x Hsome]. - rewrite Hsome in He. simpl in *. inversion He;subst;clear He. + rewrite Hsome in He. simpl in *. inversion He; subst; clear He. now eapply All_lookup_i. + tryfalse. + unfold expr_eval_i in *. simpl. simpl in He. - destruct (eval_type_i 0 ρ _) eqn:He_ty;tryfalse. simpl in *. - destruct (valid_env ρ 1 e0);tryfalse. + destruct (eval_type_i 0 ρ _) eqn:He_ty; tryfalse. simpl in *. + destruct (valid_env ρ 1 e0); tryfalse. inversion He. propify. destruct_hyps. - constructor;eauto with hints;subst. + constructor; eauto with hints; subst. + unfold expr_eval_i in *. simpl. simpl in He,Hc. - destruct (valid_env _ _ _) eqn:Hve;tryfalse. inversion He;subst. constructor;eauto. + destruct (valid_env _ _ _) eqn:Hve; tryfalse. inversion He; subst. constructor; eauto. + unfold expr_eval_i in *. simpl. simpl in He,Hc. - destruct (expr_eval_general _ _ _ _ e2) eqn:He1;tryfalse. - destruct (eval_type_i 0 ρ _) eqn:He_ty;tryfalse. simpl in *. - unfold is_true in *;propify. + destruct (expr_eval_general _ _ _ _ e2) eqn:He1; tryfalse. + destruct (eval_type_i 0 ρ _) eqn:He_ty; tryfalse. simpl in *. + unfold is_true in *; propify. destruct Hc as [[??]?]. destruct Hty_ok as [[??]?]. assert (env_ok Σ ((e1, v0) :: ρ)) by (eauto 6 with hints). assert (ty_expr_env_ok (exprs (ρ # [e1 ~> v0])) 0 e3) by - (eapply eval_ty_expr_env_ok;eauto with hints). - eapply IHn with (ρ:=ρ # [e1 ~> v0]);eauto with hints. + (eapply eval_ty_expr_env_ok; eauto with hints). + eapply IHn with (ρ := ρ # [e1 ~> v0]); eauto with hints. + simpl in Hc. simpl in Hty_ok. propify. destruct_hyps. autounfold with facts in *. simpl in He. - destruct (expr_eval_general _ _ _ _ e2) eqn:He2;tryfalse. - destruct (expr_eval_general _ _ _ _ e1) eqn:He1;tryfalse. - destruct v1;try destruct c;tryfalse. - * destruct (resolve_constr Σ i _) eqn:Hres;tryfalse. - destruct p. destruct p. destruct (_ <=? _) eqn:Har;tryfalse. + destruct (expr_eval_general _ _ _ _ e2) eqn:He2; tryfalse. + destruct (expr_eval_general _ _ _ _ e1) eqn:He1; tryfalse. + destruct v1; try destruct c; tryfalse. + * destruct (resolve_constr Σ i _) eqn:Hres; tryfalse. + destruct p. destruct p. destruct (_ <=? _) eqn:Har; tryfalse. inversion_clear He. assert (Hge_ok : ge_val_ok Σ (vConstr i _ l)) by - (eapply eval_ge_val_ok;[now apply env_ok_ForallEnv_ge_val_ok | eauto]). + (eapply eval_ge_val_ok; [now apply env_ok_ForallEnv_ge_val_ok | eauto]). assert (Hok_constr : val_ok Σ (vConstr i e l)). { cbn in *. propify. destruct_hyps. clear H2. now eapply IHn. } - econstructor;eauto. + econstructor; eauto. simpl in Hge_ok. rewrite Hres in *. inversion Hok_constr. subst. clear Hok_constr. - apply All_app_inv;eauto with hints. - rewrite app_length;cbn. - now propify;cbn in *. - * simpl in *. unfold is_true in *;repeat rewrite Bool.andb_true_iff in *. + apply All_app_inv; eauto with hints. + rewrite app_length; cbn. + now propify; cbn in *. + * simpl in *. unfold is_true in *; repeat rewrite Bool.andb_true_iff in *. assert (Hok_v0 : val_ok Σ v0) by now eapply IHn. - assert (Hok_lam : val_ok Σ (vClos e _ cmLam t t0 _)) by now eapply IHn with (e:=e1). + assert (Hok_lam : val_ok Σ (vClos e _ cmLam t t0 _)) by now eapply IHn with (e := e1). inversion Hok_lam. subst. clear Hok_lam. - eapply IHn with (e:=e3) (ρ:=(e0, v0) :: e);eauto with hints. - eapply eval_ty_expr_env_ok;eauto. - * destruct v0;tryfalse. + eapply IHn with (e := e3) (ρ := (e0, v0) :: e); eauto with hints. + eapply eval_ty_expr_env_ok; eauto. + * destruct v0; tryfalse. assert (Hok_fix : val_ok Σ (vClos e _ (cmFix _) t t0 _)) by - (eapply IHn with (ρ:=ρ) (e:=e1);eauto with hints). - inversion Hok_fix;subst. cbn in *. - eapply IHn with (ρ:=((_, vConstr i _ l) :: (_, vClos e _ (cmFix _) t t0 _) :: e)); + (eapply IHn with (ρ := ρ) (e := e1); eauto with hints). + inversion Hok_fix; subst. cbn in *. + eapply IHn with (ρ := ((_, vConstr i _ l) :: (_, vClos e _ (cmFix _) t t0 _) :: e)); eauto 8 with hints. - eapply eval_ty_expr_env_ok;eauto. - * simpl in *. unfold is_true in *;propify. + eapply eval_ty_expr_env_ok; eauto. + * simpl in *. unfold is_true in *; propify. assert (Hok_v0 : val_ok Σ v0) by now eapply IHn. - assert (Hok_lam : val_ok Σ ((vTyClos _ _ _))) by now eapply IHn with (e:=e1). + assert (Hok_lam : val_ok Σ ((vTyClos _ _ _))) by now eapply IHn with (e := e1). inversion Hok_lam. subst. clear Hok_lam. - eapply IHn with (e:=e3) (ρ:=(_, v0) :: e);eauto with hints. - eapply eval_ty_expr_env_ok;eauto. + eapply IHn with (e := e3) (ρ := (_, v0) :: e); eauto with hints. + eapply eval_ty_expr_env_ok; eauto. + unfold expr_eval_i in *. simpl in *. - destruct (resolve_constr _ _ _) eqn:Hres;inversion He;tryfalse;eauto with hints. - econstructor;eauto;cbn;lia. + destruct (resolve_constr _ _ _) eqn:Hres; inversion He; tryfalse; eauto with hints. + econstructor; eauto; cbn; lia. + tryfalse. + unfold expr_eval_i in *. simpl. simpl in He. - simpl in Hc. unfold is_true in *;propify. + simpl in Hc. unfold is_true in *; propify. destruct p as [ind e1]. - destruct (forallb (fun x : pat × expr => valid_env _ _ _) l) eqn:Hl;tryfalse. - destruct (eval_type_i _ _ _) eqn:Hety;tryfalse. simpl in *. - destruct (monad_utils.monad_map) eqn:Hmm;tryfalse. - destruct (expr_eval_general _ _ _ _ e) eqn:He';tryfalse. - destruct v0;tryfalse. destruct (string_dec ind i);tryfalse;subst. - destruct (resolve_constr _ _ _) eqn:Hres;tryfalse. + destruct (forallb (fun x : pat × expr => valid_env _ _ _) l) eqn:Hl; tryfalse. + destruct (eval_type_i _ _ _) eqn:Hety; tryfalse. simpl in *. + destruct (monad_utils.monad_map) eqn:Hmm; tryfalse. + destruct (expr_eval_general _ _ _ _ e) eqn:He'; tryfalse. + destruct v0; tryfalse. destruct (string_dec ind i); tryfalse; subst. + destruct (resolve_constr _ _ _) eqn:Hres; tryfalse. destruct p as [nn tys]. destruct nn as [n1 n2]. - destruct ((n1 =? #|e1|)%nat) eqn:Hnparams;tryfalse. - destruct (match_pat _ _ _ _) eqn:Hpm;tryfalse. + destruct ((n1 =? #|e1|)%nat) eqn:Hnparams; tryfalse. + destruct (match_pat _ _ _ _) eqn:Hpm; tryfalse. destruct p as [assign e2]. apply pat_match_succeeds in Hpm. destruct Hpm as [pt Htmp]. destruct_hyps. subst. assert (ty_expr_env_ok (exprs ρ) 0 e = true) by now eapply eval_ty_expr_env_ok. - assert (Hok_constr : val_ok Σ (vConstr i e0 l1)) by (eapply IHn with (ρ:=ρ)(e:=e);eauto). - inversion Hok_constr;subst;clear Hok_constr. + assert (Hok_constr : val_ok Σ (vConstr i e0 l1)) by (eapply IHn with (ρ := ρ)(e := e); eauto). + inversion Hok_constr; subst; clear Hok_constr. assert (Hok_l2 : env_ok Σ (rev (combine (pVars pt) (skipn n1 l1)))). - { apply rev_env_ok;apply All_env_ok;eauto;eapply All_skipn;eauto. } + { apply rev_env_ok; apply All_env_ok; eauto; eapply All_skipn; eauto. } assert (iclosed_n #|rev (combine (pVars pt) (skipn n1 l1)) ++ ρ| e2 = true). { rewrite app_length. rewrite rev_length,combine_length,skipn_length. replace (min #|pVars pt| (#|l1| - n1)) with #|pVars pt| by lia. now specialize (find_forallb _ H H4) as Hc. } - eapply IHn with (ρ := (rev (combine (pVars pt) (skipn n1 l1)) ++ ρ));eauto. - eapply eval_ty_expr_env_ok with (ρ := (rev (combine (pVars pt) (skipn n1 l1)) ++ ρ));eauto. - apply env_ok_concat;auto. + eapply IHn with (ρ := (rev (combine (pVars pt) (skipn n1 l1)) ++ ρ)); eauto. + eapply eval_ty_expr_env_ok with (ρ := (rev (combine (pVars pt) (skipn n1 l1)) ++ ρ)); eauto. + apply env_ok_concat; auto. + unfold expr_eval_i in *. simpl in *. - unfold is_true in *;propify. - destruct (valid_env _ _ _);tryfalse. - destruct (eval_type_i _ _ t) eqn:Hty;tryfalse;simpl in *. - destruct (eval_type_i _ _ t0) eqn:Hty0;tryfalse;simpl in *. + unfold is_true in *; propify. + destruct (valid_env _ _ _); tryfalse. + destruct (eval_type_i _ _ t) eqn:Hty; tryfalse; simpl in *. + destruct (eval_type_i _ _ t0) eqn:Hty0; tryfalse; simpl in *. destruct Hc as [[??]?]. destruct Hty_ok as [[??]?]. inversion He; eauto 6 with hints. + simpl in *. - destruct (eval_type_i _ _ _) eqn:Hty0;tryfalse;simpl in *. inversion He;subst. + destruct (eval_type_i _ _ _) eqn:Hty0; tryfalse; simpl in *. inversion He; subst. eauto with hints. Qed. @@ -1741,22 +1741,22 @@ Lemma from_vConstr_not_lambda : Proof. intros Σ i n0 na t0 b l H. induction l using MCList.rev_ind. - + simpl in H. destruct (resolve_constr Σ i n0);tryfalse. + + simpl in H. destruct (resolve_constr Σ i n0); tryfalse. + simpl_vars_to_apps in H. - destruct (t⟦ vars_to_apps (eConstr i n0) (map of_val_i l) ⟧ Σ);tryfalse. + destruct (t⟦ vars_to_apps (eConstr i n0) (map of_val_i l) ⟧ Σ); tryfalse. Qed. Lemma tFix_eq_inv f l Σ e : t⟦e⟧Σ = tFix f l -> exists fixname var ty1 ty2 b, e = eFix fixname var ty1 ty2 b. Proof. - destruct e;intros H1;try easy. + destruct e; intros H1; try easy. + simpl in *. now destruct (resolve_constr Σ i _). - + simpl in *. destruct p as [ty1 i1];tryfalse. - destruct (resolve_inductive Σ _);tryfalse. - destruct ((_ =? _)%nat);tryfalse. - + simpl in *. inversion H1. repeat eexists;eauto. - + simpl in *. inversion H1. destruct t;tryfalse. + + simpl in *. destruct p as [ty1 i1]; tryfalse. + destruct (resolve_inductive Σ _); tryfalse. + destruct ((_ =? _)%nat); tryfalse. + + simpl in *. inversion H1. repeat eexists; eauto. + + simpl in *. inversion H1. destruct t; tryfalse. Qed. Lemma fix_not_constr_of_val {Σ mf m i nm vs} : @@ -1765,7 +1765,7 @@ Proof. intros H. simpl in *. induction vs using MCList.rev_ind. - + simpl in *. destruct (resolve_constr Σ i nm);tryfalse. + + simpl in *. destruct (resolve_constr Σ i nm); tryfalse. + simpl in *. simpl_vars_to_apps in H; tryfalse. Qed. @@ -1785,7 +1785,7 @@ Lemma forall_Forall {A : Type} (P : A -> Prop) (l : list A) : (forall a, P a) -> Forall P l. Proof. intros H. - induction l;constructor;auto. + induction l; constructor; auto. Qed. #[export] Hint Resolve eval_val_ok of_value_closed : hints. @@ -1797,7 +1797,7 @@ Proof. intros H. induction ρ. + constructor. - + destruct a;simpl. constructor. + + destruct a; simpl. constructor. * inversion H. subst. unfold compose in *. simpl in *. eauto with hints. * inversion H. subst. unfold compose in *. simpl in *. @@ -1836,12 +1836,12 @@ Proof. revert dependent t1. revert dependent t2. revert dependent l2. - induction l1 using MCList.rev_ind;intros;destruct l2 using MCList.rev_ind. + induction l1 using MCList.rev_ind; intros; destruct l2 using MCList.rev_ind. + inversion Hmk. easy. - + simpl in *. subst. rewrite mkApps_unfold in *;tryfalse. - + simpl in *. subst. rewrite mkApps_unfold in *;tryfalse. + + simpl in *. subst. rewrite mkApps_unfold in *; tryfalse. + + simpl in *. subst. rewrite mkApps_unfold in *; tryfalse. + simpl in *. repeat rewrite mkApps_unfold in *. - inversion Hmk. specialize (IHl1 _ _ H2 _ H1 H0). intuition;auto. + inversion Hmk. specialize (IHl1 _ _ H2 _ H1 H0). intuition; auto. Qed. Lemma mkApps_constr_inv ind l1 l2 n1 n2 u1 u2: @@ -1859,7 +1859,7 @@ Lemma nth_error_map_exists {A B} (f : A -> B) (l : list A) n p: Proof. intros H. revert dependent l. - induction n;simpl in *;intros l H;destruct l eqn:H1;inversion H;eauto. + induction n; simpl in *; intros l H; destruct l eqn:H1; inversion H; eauto. Qed. #[export] Hint Resolve env_ok_concat All_env_ok rev_env_ok : hints. @@ -1885,7 +1885,7 @@ Lemma mkApps_nonempty_neq args t f : Proof. intros Hargs Hatom. destruct args using MCList.rev_ind. - + simpl in *;lia. + + simpl in *; lia. + rewrite mkApps_unfold. now destruct t. Qed. @@ -1895,10 +1895,10 @@ Proof. intros. now apply closed_exprs_len_iff. Qed. -#[export] Hint Resolve 0 closed_exprs_len_r2l : hints. +#[export] Hint Resolve closed_exprs_len_r2l : hints. -Hint Extern 1 (iclosed_n (#|_|) _ = _) => -eapply closed_exprs_len_iff with (n:=0) : hints. +#[export] Hint Extern 1 (iclosed_n (#|_|) _ = _) => + eapply closed_exprs_len_iff with (n := 0) : hints. Definition not_stuck : term -> bool := fun t => let (f, args) := decompose_app t in @@ -1922,8 +1922,8 @@ Proof. destruct l using MCList.rev_ind. + simpl. now destruct (resolve_constr Σ ind cn). + simpl. rewrite <- mkApps_vars_to_apps. - unfold PcbvCurr.isFixApp,isFix;cbn. - now rewrite PcbvCurr.head_mkApps;destruct (resolve_constr Σ ind cn). + unfold PcbvCurr.isFixApp,isFix; cbn. + now rewrite PcbvCurr.head_mkApps; destruct (resolve_constr Σ ind cn). Qed. Lemma vars_to_apps_constr_not_arity ind cn l Σ: @@ -1941,7 +1941,7 @@ Lemma negb_and_to_orb a b : (~~ a) /\ (~~ b) -> ~~ (a || b). Proof. intros H. unfold is_true in *. - destruct a,b;intuition;auto. + destruct a,b; intuition; auto. Qed. #[export] Hint Resolve negb_and_to_orb : hints. @@ -1955,7 +1955,7 @@ Lemma All_value_of_val: Proof. intros Σ1 Σ2 Hsync l X. eapply All_impl. apply X. - intros. eapply Wcbv_of_value_value;eauto with hints. + intros. eapply Wcbv_of_value_value; eauto with hints. Qed. Lemma All_expr_iclosed_of_val: @@ -1974,34 +1974,34 @@ Lemma All_term_closed_of_val: Proof. intros Σ1 l0 Hgeok X. eapply All_impl. apply X. - intros. eapply expr_closed_term_closed;eauto with hints. + intros. eapply expr_closed_term_closed; eauto with hints. Qed. Lemma eval_type_i_subst_env ty : forall n ρ ty_v, eval_type_i n ρ ty = Some ty_v -> subst_env_i_ty n (exprs ρ) ty = ty_v. Proof. - induction ty;intros ??? He. + induction ty; intros ??? He. + simpl in *. now inversion He. - + simpl in *. destruct (eval_type_i _ _ _) eqn:Heq;tryfalse. inversion He;subst. - f_equal;eauto. + + simpl in *. destruct (eval_type_i _ _ _) eqn:Heq; tryfalse. inversion He; subst. + f_equal; eauto. + simpl in *. - destruct (eval_type_i n ρ ty2) eqn:Hty2;tryfalse. - destruct (eval_type_i n ρ ty1) eqn:Hty1;tryfalse. - destruct (decompose_inductive _);tryfalse. inversion He;subst. - f_equal;auto. + destruct (eval_type_i n ρ ty2) eqn:Hty2; tryfalse. + destruct (eval_type_i n ρ ty1) eqn:Hty1; tryfalse. + destruct (decompose_inductive _); tryfalse. inversion He; subst. + f_equal; auto. + tryfalse. + simpl in *. destruct (n0 <=? n) eqn:Hn0. rewrite lookup_i_nth_error in He. unfold lookup_ty. rewrite lookup_i_nth_error. rewrite nth_error_map. - destruct (nth_error ρ (n - n0));simpl in *;auto. destruct (p.2);tryfalse. + destruct (nth_error ρ (n - n0)); simpl in *; auto. destruct (p.2); tryfalse. inversion He. reflexivity. tryfalse. now inversion He. + simpl in *. - destruct (eval_type_i n ρ ty2) eqn:Hty2;tryfalse. - destruct (eval_type_i n ρ ty1) eqn:Hty1;tryfalse. - inversion He;subst. - f_equal;auto. + destruct (eval_type_i n ρ ty2) eqn:Hty2; tryfalse. + destruct (eval_type_i n ρ ty1) eqn:Hty1; tryfalse. + inversion He; subst. + f_equal; auto. Qed. Open Scope list. @@ -2011,11 +2011,11 @@ Lemma subst_env_i_ty_closed_eq n ρ ty : subst_env_i_ty n ρ ty = ty. Proof. revert n ρ. - induction ty;intros; - unfold is_true in *;simpl in *; - propify;intuition; + induction ty; intros; + unfold is_true in *; simpl in *; + propify; intuition; try (now f_equal). - assert (Hn0 : n0 <=? n = false) by (propify;lia). + assert (Hn0 : n0 <=? n = false) by (propify; lia). now rewrite Hn0. Qed. @@ -2031,16 +2031,16 @@ Qed. Lemma subst_term_subst_env_2 : forall (Σ : global_env) (e e1 e2 : expr) (nm1 nm2 : ename) (k : nat), - let l := [(nm1,e1);(nm2,e2)] in + let l := [(nm1,e1); (nm2,e2)] in genv_ok Σ -> ty_expr_env_ok l 0 e -> iclosed_n #|l| e = true -> All (fun x : string × expr => iclosed_n 0 x.2 = true) l -> - subst0 ([t⟦e1⟧Σ;t⟦e2⟧Σ]) (t⟦e⟧Σ) = t⟦e.[l]⟧ Σ. + subst0 ([t⟦e1⟧Σ; t⟦e2⟧Σ]) (t⟦e⟧Σ) = t⟦e.[l]⟧ Σ. Proof. intros. change ([t⟦ e1 ⟧Σ; t⟦ e2 ⟧Σ]) with (map (fun x => t⟦ x.2 ⟧Σ) [(nm1,e1); (nm2,e2)]). - eapply subst_term_subst_env_par;eauto. + eapply subst_term_subst_env_par; eauto. Qed. #[local] Hint Constructors assumption_context : hints. @@ -2050,10 +2050,10 @@ Lemma assumption_context_subst : assumption_context (subst_context ts n ctx). Proof. intros ctx ts n0 Hctx. - induction Hctx;auto with hints. - * unfold subst_context;cbn. + induction Hctx; auto with hints. + * unfold subst_context; cbn. rewrite mapi_rec_app,rev_app_distr. - apply PCUICClosed.assumption_context_app_inv;cbn;auto. + apply PCUICClosed.assumption_context_app_inv; cbn; auto. constructor; auto with hints. Qed. @@ -2061,14 +2061,14 @@ Lemma assumption_context_map_vass : forall {A} xs (f : A -> aname), assumption_context (map (fun '(nm, t) => vass (f nm) t) xs). Proof. - induction xs as [| x xs0];cbn;try destruct x;auto with hints. + induction xs as [| x xs0]; cbn; try destruct x; auto with hints. Qed. Lemma subst_instance_type_to_term : forall ty, subst_instance [] (type_to_term ty) = type_to_term ty. Proof. intros ty. - induction ty;cbn;auto. + induction ty; cbn; auto. * now rewrite IHty. * now rewrite IHty1,IHty2. * rewrite PCUICUnivSubst.subst_instance_lift. @@ -2081,10 +2081,10 @@ Lemma All_subst_instance_type_to_term ctx : All (fun x => map_decl (subst_instance []) x = x) ctx. Proof. intros Hassump Hall. - induction Hall;eauto with hints. - unfold map_decl;cbn. - constructor;cbn;auto. - + inversion Hassump;subst. + induction Hall; eauto with hints. + unfold map_decl; cbn. + constructor; cbn; auto. + + inversion Hassump; subst. destruct p as [ty Hty]. cbn in *. subst. now rewrite subst_instance_type_to_term. + apply IHHall. now inversion Hassump. diff --git a/embedding/theories/pcuic/PCUICFacts.v b/embedding/theories/pcuic/PCUICFacts.v index fed691b6..f67d2c6f 100644 --- a/embedding/theories/pcuic/PCUICFacts.v +++ b/embedding/theories/pcuic/PCUICFacts.v @@ -22,6 +22,7 @@ Open Scope string_scope. Import ListNotations. Import NamelessSubst. +#[export] Hint Unfold expr_eval_n expr_eval_i : facts. (** An elimination principle that takes into account nested occurrences of expressions @@ -30,7 +31,7 @@ Definition expr_elim_case (P : expr -> Type) (Hrel : forall n : nat, P (eRel n)) (Hvar : forall n : ename, P (eVar n)) (Hlam :forall (n : ename) (t : type) (e : expr), P e -> P (eLambda n t e)) - (HtyLam : forall (n : ename) (e : expr), P e -> P (eTyLam n e)) + (HtyLam : forall (n : ename) (e : expr), P e -> P (eTyLam n e)) (Hletin : forall (n : ename) (e : expr), P e -> forall (t : type) (e0 : expr), P e0 -> P (eLetIn n e t e0)) (Happ :forall e : expr, P e -> forall e0 : expr, P e0 -> P (eApp e e0)) @@ -39,7 +40,7 @@ Definition expr_elim_case (P : expr -> Type) (Hcase : forall p (t : type) (e : expr), P e -> forall l : list (pat * expr), All (fun x => P (snd x)) l ->P (eCase p t e l)) (Hfix :forall (n n0 : ename) (t t0 : type) (e : expr), P e -> P (eFix n n0 t t0 e)) - (Hty : forall t : type, P (eTy t)) : + (Hty : forall t : type, P (eTy t)) : forall e : expr, P e. Proof. refine (fix ind (e : expr) := _ ). @@ -49,7 +50,7 @@ Proof. + apply Hlam. apply ind. + apply HtyLam. apply ind. + apply Hletin; apply ind. - + apply Happ;apply ind. + + apply Happ; apply ind. + apply Hconstr. + apply Hconst. + apply Hcase. apply ind. @@ -67,7 +68,7 @@ Section Values. vars_to_apps acc (vs ++ [v]) = eApp (vars_to_apps acc vs) v. Proof. simpl. - induction vs using rev_ind;intros acc v. + induction vs using rev_ind; intros acc v. + reflexivity. + simpl. unfold vars_to_apps. @@ -94,9 +95,9 @@ Section Values. (* Proof. *) (* intros Hfe Hl. *) (* revert dependent n. *) - (* induction Hfe;intros n Hl. *) + (* induction Hfe; intros n Hl. *) (* + inversion Hl. *) - (* + simpl in *. destruct x; destruct (Nat.eqb n 0);inversion Hl;subst;eauto. *) + (* + simpl in *. destruct x; destruct (Nat.eqb n 0); inversion Hl; subst; eauto. *) (* Qed. *) Lemma All_lookup_i {A} ρ n e (P : A -> Type) : @@ -104,16 +105,16 @@ Section Values. Proof. intros Hfe Hl. revert dependent n. - induction Hfe;intros n Hl. + induction Hfe; intros n Hl. + inversion Hl. - + simpl in *. destruct x; destruct (Nat.eqb n 0);inversion Hl;subst;eauto. + + simpl in *. destruct x; destruct (Nat.eqb n 0); inversion Hl; subst; eauto. Qed. Lemma iclosed_ty_geq ty : forall n m, m >= n -> iclosed_ty n ty = true -> iclosed_ty m ty = true. Proof. - induction ty;intros n1 m1 H Hc;eauto. - + simpl in *. assert (S m1 >= S n1) by lia. eapply IHty;eauto. + induction ty; intros n1 m1 H Hc; eauto. + + simpl in *. assert (S m1 >= S n1) by lia. eapply IHty; eauto. + simpl in *. now propify. + simpl in *. now propify. + simpl in *. now propify. @@ -122,7 +123,7 @@ Section Values. Lemma iclosed_ty_m_n ty : forall n m, iclosed_ty n ty = true -> iclosed_ty (n+m) ty = true. Proof. intros n m H. - eapply iclosed_ty_geq with (n := n);eauto. lia. + eapply iclosed_ty_geq with (n := n); eauto. lia. Qed. Lemma iclosed_ty_0 ty : forall n, iclosed_ty 0 ty = true -> iclosed_ty n ty = true. @@ -130,23 +131,23 @@ Section Values. Lemma iclosed_n_geq e : forall n m, m >= n -> iclosed_n n e = true -> iclosed_n m e = true. Proof. - induction e using expr_elim_case; intros n1 m1 Hgeq H1;try inversion H1;auto. + induction e using expr_elim_case; intros n1 m1 Hgeq H1; try inversion H1; auto. + simpl in *. rewrite H1. now propify. + simpl in *. rewrite H1. propify. destruct_and_split. - apply iclosed_ty_geq with (n:=n1);auto;lia. - eapply IHe with (n:=S n1);auto; lia. + apply iclosed_ty_geq with (n := n1); auto; lia. + eapply IHe with (n := S n1); auto; lia. + simpl in *. rewrite H1. - eapply IHe with (n:=S n1);auto; lia. + eapply IHe with (n := S n1); auto; lia. + simpl in *. propify. clear H0. destruct H1 as [[Ht He1] He2]. rewrite He1, He2, Ht. simpl. propify. destruct_and_split. - * apply iclosed_ty_geq with (n:=n1);auto;lia. - * eapply IHe1;eauto. - * eapply IHe2 with (n:= S n1);eauto;lia. + * apply iclosed_ty_geq with (n := n1); auto; lia. + * eapply IHe1; eauto. + * eapply IHe2 with (n := S n1); eauto; lia. + simpl in *. propify. destruct H1 as [He1 He2]. rewrite He1, He2. simpl. @@ -156,24 +157,24 @@ Section Values. rewrite Hp,Ht,He1,Hforall. cbn. propify. destruct_and_split. - * eapply forallb_impl_inner;try eapply Hp;intros; - apply iclosed_ty_geq with (n:=n1);auto;lia. - * apply iclosed_ty_geq with (n:=n1);auto;lia. - * erewrite IHe;eauto. + * eapply forallb_impl_inner; try eapply Hp; intros; + apply iclosed_ty_geq with (n := n1); auto; lia. + * apply iclosed_ty_geq with (n := n1); auto; lia. + * erewrite IHe; eauto. * apply All_forallb. apply forallb_All in Hforall. - apply All_impl_inner with (P:= fun x => iclosed_n (#|pVars (fst x)|+n1) (snd x) = true). + apply All_impl_inner with (P := fun x => iclosed_n (#|pVars (fst x)|+n1) (snd x) = true). assumption. eapply All_impl. apply X. intros. simpl in *. - now eapply H3 with (n:=#|pVars x.1| + n1). + now eapply H3 with (n := #|pVars x.1| + n1). + simpl in *. rewrite H1. propify. destruct_and_split. - * now eapply iclosed_ty_geq with (n:=n1). - * now eapply iclosed_ty_geq with (n:=n1). - * now eapply IHe with (n:=S (S n1)). + * now eapply iclosed_ty_geq with (n := n1). + * now eapply iclosed_ty_geq with (n := n1). + * now eapply IHe with (n := S (S n1)). + simpl. rewrite H0. - now apply iclosed_ty_geq with (n:=n1). + now apply iclosed_ty_geq with (n := n1). Qed. Lemma iclosed_m_n e : forall n m, iclosed_n n e = true -> iclosed_n (n+m) e = true. @@ -194,7 +195,7 @@ Section Values. Lemma iclosed_ty_env_ok n ρ ty : iclosed_ty n ty -> ty_env_ok n ρ ty. Proof. revert n ρ. - induction ty;intros n0 ρ Hc;eauto. + induction ty; intros n0 ρ Hc; eauto. + simpl in *. now propify. + simpl in *. @@ -211,16 +212,16 @@ Section Values. iclosed_ty (n + #|ρ|) ty = true -> iclosed_ty n (subst_env_i_ty n ρ ty) = true. Proof. intros ty. - induction ty;intros n1 ρ Hok Henv Hc;auto. - + simpl in *. eapply IHty;eauto. + induction ty; intros n1 ρ Hok Henv Hc; auto. + + simpl in *. eapply IHty; eauto. + simpl in *. now propify. + simpl in *. destruct (n1 <=? n) eqn:Hnle. * propify. assert (Hc' : n-n1 < length ρ) by lia. rewrite <- PeanoNat.Nat.ltb_lt in *. unfold lookup_ty. destruct (lookup_i_length _ (n-n1) Hc') as [e0 He0]. - rewrite He0 in *. simpl. destruct e0;tryfalse. - simpl in *. assert (H : iclosed_n 0 (eTy t)) by (eapply (All_lookup_i _ _ _ _ Henv);eauto). + rewrite He0 in *. simpl. destruct e0; tryfalse. + simpl in *. assert (H : iclosed_n 0 (eTy t)) by (eapply (All_lookup_i _ _ _ _ Henv); eauto). simpl in *. eauto with facts. * simpl in *. now propify. + simpl in *. now propify. @@ -233,21 +234,21 @@ Section Values. iclosed_ty (n + #|ρ|) ty = true. Proof. intros ty. - induction ty;intros n1 ρ Henv Hc;auto. + induction ty; intros n1 ρ Henv Hc; auto. + simpl in *. replace (S (n1 + #|ρ|)) with (S n1 + #|ρ|) by lia. - eapply IHty;eauto. + eapply IHty; eauto. + simpl in *. now propify. + simpl in *. destruct (n1 <=? n) eqn:Hnle. - * destruct (n iclosed_n 0 (snd e) = true) ρ -> iclosed_n (n + #|ρ|) e = true -> iclosed_n n (e.[ρ]n) = true. Proof. - induction e using expr_elim_case;intros n1 ρ Hok Hc Hec; - simpl in *;propify;destruct_and_split;tryfalse;auto with facts. + induction e using expr_elim_case; intros n1 ρ Hok Hc Hec; + simpl in *; propify; destruct_and_split; tryfalse; auto with facts. + (* eRel *) unfold subst_env_i. simpl. simpl in *. @@ -273,8 +274,8 @@ Section Values. rewrite <- PeanoNat.Nat.ltb_lt in *. destruct (lookup_i_length _ (n-n1) Hc') as [e0 He0]. rewrite He0. simpl. - eapply All_lookup_i with (ρ := ρ) (P:=fun e1 => iclosed_n n1 e1 = true);eauto. - apply (All_impl (P:=fun e1 => iclosed_n 0 (snd e1) = true));eauto. + eapply All_lookup_i with (ρ := ρ) (P := fun e1 => iclosed_n n1 e1 = true); eauto. + apply (All_impl (P := fun e1 => iclosed_n 0 (snd e1) = true)); eauto. intros a H. unfold compose. change (iclosed_n (0+n1) (snd a) = true); now apply iclosed_m_n. * simpl in *. now propify. @@ -290,7 +291,7 @@ Section Values. eapply All_impl_inner. apply Hall'. simpl in *. apply Forall_All. eapply Forall_forall; - intros;eapply subst_env_i_ty_closed;intuition. + intros; eapply subst_env_i_ty_closed; intuition. * now eapply subst_env_i_ty_closed. * apply All_forallb. apply All_map. unfold compose. simpl. eapply All_impl_inner. apply Hall. simpl in *. @@ -304,31 +305,31 @@ Section Values. All (fun e => iclosed_n 0 (snd e) = true) ρ -> iclosed_n n (e.[ρ]n) = true -> iclosed_n (n + #|ρ|) e = true. Proof. - induction e using expr_ind_case;intros k ρ Hc Hec; - simpl in *;propify;destruct_and_split;auto; - try repeat rewrite <- PeanoNat.Nat.add_succ_l;tryfalse;auto with facts. + induction e using expr_ind_case; intros k ρ Hc Hec; + simpl in *; propify; destruct_and_split; auto; + try repeat rewrite <- PeanoNat.Nat.add_succ_l; tryfalse; auto with facts. + (* eRel *) unfold subst_env_i. simpl. simpl in *. destruct (k <=? n) eqn:Hnle. - * destruct (n @@ -344,7 +345,7 @@ Section Values. All (fun e => iclosed_n 0 (snd e) = true) ρ -> iclosed_n #|ρ| e = true -> iclosed_n 0 (e.[ρ]) = true. Proof. - intros;apply subst_env_iclosed_n with (n:=0);eauto with facts. + intros; apply subst_env_iclosed_n with (n := 0); eauto with facts. Qed. Lemma subst_env_iclosed_0_inv (e : expr) : @@ -352,17 +353,17 @@ Section Values. All (fun e => iclosed_n 0 (snd e) = true) ρ -> iclosed_n 0 (e.[ρ]) = true -> iclosed_n #|ρ| e = true. Proof. - intros;apply subst_env_iclosed_n_inv with (n:=0);eauto. + intros; apply subst_env_iclosed_n_inv with (n := 0); eauto. Qed. Lemma of_value_closed Σ v n : - val_ok Σ v (* this ensures that closures contain closed expressions *) -> + val_ok Σ v (* this ensures that closures contain closed expressions *) -> iclosed_n n (of_val_i v ) = true. Proof. revert n. - induction v using val_elim_full;intros n1 Hv. + induction v using val_elim_full; intros n1 Hv. + simpl. apply vars_to_apps_iclosed_n. - inversion Hv;subst;clear Hv. + inversion Hv; subst; clear Hv. eapply All_impl_inner. apply X0. now eapply (All_impl X). + simpl in *. destruct cm. @@ -373,8 +374,8 @@ Section Values. eapply subst_env_i_ty_closed; auto with facts. eapply All_map. eapply (All_impl_inner _ _ _ X0). - eapply (All_impl X);eauto. - - eapply iclosed_m_n with (n:=1). + eapply (All_impl X); eauto. + - eapply iclosed_m_n with (n := 1). apply subst_env_iclosed_n. ** easy. ** apply All_map. @@ -389,13 +390,13 @@ Section Values. eapply subst_env_i_ty_closed; auto with facts. eapply All_map. eapply (All_impl_inner _ _ _ X0). - eapply (All_impl X);eauto. + eapply (All_impl X); eauto. ** eapply iclosed_ty_0. eapply subst_env_i_ty_closed; auto with facts. eapply All_map. eapply (All_impl_inner _ _ _ X0). - eapply (All_impl X);eauto. - ** eapply iclosed_m_n with (n:=2). + eapply (All_impl X); eauto. + ** eapply iclosed_m_n with (n := 2). eapply subst_env_iclosed_n. *** easy. *** apply All_map. @@ -405,7 +406,7 @@ Section Values. *** now rewrite map_length. + simpl in *. inversion Hv. subst. clear Hv. - eapply iclosed_m_n with (n:=1). + eapply iclosed_m_n with (n := 1). apply subst_env_iclosed_n. ** easy. ** apply All_map. @@ -416,14 +417,14 @@ Section Values. + simpl. inversion Hv. subst. eauto with facts. -Qed. + Qed. Lemma subst_env_i_ty_empty k t : t = subst_env_i_ty k [] t. Proof. revert k. - induction t;intros;simpl;try f_equal;eauto. - destruct (k <=? n);auto. + induction t; intros; simpl; try f_equal; eauto. + destruct (k <=? n); auto. Qed. @@ -433,24 +434,24 @@ Qed. forall (e : expr) (k : nat), e = subst_env_i_aux k [] e. Proof. intros e. - induction e using expr_ind_case;simpl in *;intuition. - + simpl. destruct (Nat.leb k n);eauto. + induction e using expr_ind_case; simpl in *; intuition. + + simpl. destruct (Nat.leb k n); eauto. + simpl. - apply f_equal4;eauto with facts. - rewrite map_id_f;eauto with facts. + apply f_equal4; eauto with facts. + rewrite map_id_f; eauto with facts. rewrite <- map_id at 1. eapply forall_map_spec. - eapply Forall_impl;eauto. - intros p Hp;cbn in *. - destruct p; rewrite <-Hp;eauto. + eapply Forall_impl; eauto. + intros p Hp; cbn in *. + destruct p; rewrite <-Hp; eauto. Qed. Lemma expr_eval_econstr {n nm Σ ρ i v mode} : expr_eval_general mode Σ n ρ (eConstr i nm) = Ok v -> v = vConstr i nm []. Proof. - destruct mode; intros H; destruct n;simpl in *; - destruct (resolve_constr Σ i nm);tryfalse;inversion H;reflexivity. + destruct mode; intros H; destruct n; simpl in *; + destruct (resolve_constr Σ i nm); tryfalse; inversion H; reflexivity. Qed. End Values. @@ -465,7 +466,7 @@ Qed. Lemma map_funprod_id (f : B -> D) (l : list (A * B)) : map fst l = map fst (map (fun_prod id f) l). Proof. - induction l;cbn;f_equal;auto. + induction l; cbn; f_equal; auto. Qed. End MapProperties. @@ -476,15 +477,15 @@ Qed. {C : Type}. Lemma lookup_ind_nth_error_False (ρ : env A) n m a key : - lookup_with_ind_rec (1+n+m) ρ key = Some (n, a) -> False. + lookup_with_ind_rec (1+n+m) ρ key = Some (n, a) -> False. Proof. revert dependent m. revert dependent n. - induction ρ as [ |a0 ρ0];intros n m H;tryfalse. + induction ρ as [ |a0 ρ0]; intros n m H; tryfalse. simpl in *. - destruct a0;destruct (s =? key). - + inversion H;lia. - + replace (S (n + m)) with (n + S m) in * by lia. + destruct a0; destruct (s =? key). + + inversion H; lia. + + replace (S (n + m)) with (n + S m) in * by lia. eauto. Qed. @@ -492,23 +493,23 @@ Qed. lookup_with_ind_rec (1+n) ρ key = Some (1+i, a) <-> lookup_with_ind_rec n ρ key = Some (i, a). Proof. - split;revert dependent i;revert dependent n; - induction ρ;intros i1 n1 H;tryfalse;simpl in *; - destruct a0; destruct ( s =? key); inversion H;eauto. + split; revert dependent i; revert dependent n; + induction ρ; intros i1 n1 H; tryfalse; simpl in *; + destruct a0; destruct ( s =? key); inversion H; eauto. Qed. Lemma lookup_ind_nth_error (ρ : env A) i a key : lookup_with_ind ρ key = Some (i,a) -> nth_error ρ i = Some (key,a). Proof. revert dependent ρ. - induction i;simpl;intros ρ0 H. - + destruct ρ0;tryfalse. unfold lookup_with_ind in H. simpl in *. - destruct p as (nm,a0); destruct (nm =? key) eqn:Heq; try rewrite String.eqb_eq in *;subst. - inversion H;subst;eauto. + induction i; simpl; intros ρ0 H. + + destruct ρ0; tryfalse. unfold lookup_with_ind in H. simpl in *. + destruct p as (nm,a0); destruct (nm =? key) eqn:Heq; try rewrite String.eqb_eq in *; subst. + inversion H; subst; eauto. now apply (lookup_ind_nth_error_False _ 0 0) in H. - + destruct ρ0;tryfalse. unfold lookup_with_ind in H. simpl in *. + + destruct ρ0; tryfalse. unfold lookup_with_ind in H. simpl in *. destruct p as (nm,a0); destruct (nm =? key) eqn:Heq; - try rewrite String.eqb_eq in *;subst;tryfalse. + try rewrite String.eqb_eq in *; subst; tryfalse. apply IHi. now apply lookup_ind_nth_error_shift. Qed. @@ -516,10 +517,10 @@ Qed. lookup_i ρ i = option_map snd (nth_error ρ i). Proof. revert i. - induction ρ;intros. + induction ρ; intros. + simpl. now rewrite nth_error_nil. + simpl. destruct a. simpl in *. - destruct i;simpl;auto. now replace (i-0) with i by lia. + destruct i; simpl; auto. now replace (i-0) with i by lia. Qed. Lemma find_map_eq p1 p2 a (f g : A -> B) (l : list A) : @@ -527,9 +528,9 @@ Qed. (forall a, p1 a = p2 (f a)) -> find p2 (map f l) = Some (g a). Proof. intros Hfind Hfeq Heq. - induction l as [ | a' l'];tryfalse. + induction l as [ | a' l']; tryfalse. simpl in *. rewrite <- Heq. - destruct (p1 a');inversion Hfind;subst;auto. + destruct (p1 a'); inversion Hfind; subst; auto. now rewrite Hfeq. Qed. @@ -542,11 +543,11 @@ Qed. Lemma find_forallb_map {X Y} {xs : list X} {p0 : X -> bool} {p1 : Y -> bool} {f : X -> Y}: forall x : X, find p0 xs = Some x -> forallb p1 (map f xs) = true -> p1 (f x) = true. Proof. - induction xs;intros x Hfnd Hall. + induction xs; intros x Hfnd Hall. + easy. + simpl in *. destruct (p0 a). - * inversion Hfnd;subst. now destruct (p1 (f x));tryfalse. - * destruct (p1 (f a));tryfalse;auto. + * inversion Hfnd; subst. now destruct (p1 (f x)); tryfalse. + * destruct (p1 (f a)); tryfalse; auto. Qed. Lemma find_forallb {xs : list A} {p1 : A -> bool} {p}: @@ -554,7 +555,7 @@ Qed. Proof. intros x Hfnd Hall. replace xs with (map id xs) in Hall by apply map_id. - eapply @find_forallb_map with (f:=id);eauto. + eapply @find_forallb_map with (f := id); eauto. Qed. Lemma find_none_fst {p} (l1 l2 : list (A * B)) : @@ -562,13 +563,13 @@ Qed. find (p ∘ fst) l1 = None -> find (p ∘ fst) l2 = None. Proof. revert dependent l2. - induction l1 as [ | ab l1'];intros l2 Hmap Hfnd. - + destruct l2;simpl in *;easy. - + destruct l2;simpl in *;tryfalse. - unfold compose,id in *;simpl in *. - destruct ab as [a b];simpl in *. - inversion Hmap;subst. - destruct (p (fst p0));simpl in *;eauto;tryfalse. + induction l1 as [ | ab l1']; intros l2 Hmap Hfnd. + + destruct l2; simpl in *; easy. + + destruct l2; simpl in *; tryfalse. + unfold compose,id in *; simpl in *. + destruct ab as [a b]; simpl in *. + inversion Hmap; subst. + destruct (p (fst p0)); simpl in *; eauto; tryfalse. Qed. Lemma find_some_fst_map_snd {p} {f : A * B -> C} (l: list (A * B)) (v1 : A * B): @@ -578,10 +579,10 @@ Qed. × f v1 = snd v2 }. Proof. revert v1. - induction l as [ | ab l'];intros v1 Hfnd. + induction l as [ | ab l']; intros v1 Hfnd. + easy. - + unfold compose,id in *;simpl in *. - destruct (p ab.1);inversion Hfnd;subst;simpl in *;eauto. + + unfold compose,id in *; simpl in *. + destruct (p ab.1); inversion Hfnd; subst; simpl in *; eauto. Qed. Lemma find_some_fst {p} (l1: list (A * B)) ( l2 : list (A * C)) v1: @@ -592,13 +593,13 @@ Qed. Proof. revert dependent l2. revert v1. - induction l1 as [ | ab l1'];intros v1 l2 Hmap Hfnd. - + destruct l2;simpl in *;easy. - + destruct l2;simpl in *;tryfalse. - unfold compose,id in *;simpl in *. - destruct ab as [a b];simpl in *. - inversion Hmap;subst. - destruct (p (fst p0));inversion Hfnd;subst;simpl in *;eauto;tryfalse. + induction l1 as [ | ab l1']; intros v1 l2 Hmap Hfnd. + + destruct l2; simpl in *; easy. + + destruct l2; simpl in *; tryfalse. + unfold compose,id in *; simpl in *. + destruct ab as [a b]; simpl in *. + inversion Hmap; subst. + destruct (p (fst p0)); inversion Hfnd; subst; simpl in *; eauto; tryfalse. Qed. End FindLookupProperties. @@ -612,14 +613,14 @@ Section Validate. valid_ty_env n ρ ty -> ty_env_ok n (exprs ρ) ty. Proof. revert n ρ. - induction ty;intros;simpl in *;unfold is_true in *; - propify;intuition;eauto. + induction ty; intros; simpl in *; unfold is_true in *; + propify; intuition; eauto. rewrite lookup_i_nth_error. rewrite lookup_i_nth_error in H. - destruct (n0 <=? n);auto. + destruct (n0 <=? n); auto. rewrite nth_error_map. - destruct (nth_error ρ (n - n0));simpl in *;auto. - destruct p.2;simpl;auto. + destruct (nth_error ρ (n - n0)); simpl in *; auto. + destruct p.2; simpl; auto. Qed. Hint Resolve valid_ty_env_ty_env_ok : facts. @@ -628,9 +629,9 @@ Section Validate. valid_env ρ n e -> ty_expr_env_ok (exprs ρ) n e. Proof. revert n ρ. - induction e using expr_elim_case;intros; - simpl in *;unfold is_true in *;propify;intuition; - try eapply valid_ty_env_ty_env_ok;eauto. + induction e using expr_elim_case; intros; + simpl in *; unfold is_true in *; propify; intuition; + try eapply valid_ty_env_ty_env_ok; eauto. + destruct p as [ind tys]. simpl in *. eapply forallb_impl_inner. eapply H0. intros. @@ -639,6 +640,6 @@ Section Validate. apply forallb_All in H1. eapply All_impl_inner. apply H1. simpl. - eapply (All_impl X);eauto. + eapply (All_impl X); eauto. Qed. End Validate. diff --git a/embedding/theories/pcuic/PCUICTranslate.v b/embedding/theories/pcuic/PCUICTranslate.v index aa4c565c..d77023a2 100644 --- a/embedding/theories/pcuic/PCUICTranslate.v +++ b/embedding/theories/pcuic/PCUICTranslate.v @@ -95,7 +95,7 @@ where "T⟦ ty ⟧ " := (type_to_term ty). (** Translating branches of the [eCase] construct. Note that MetaCoq uses indices to represent constructors. Indices are corresponding positions in the list of constructors for a particular inductive type *) Definition etrans_branch (params : list type)(bs : list (pat * term)) (c : constr) : branch term := - let nm := fst c in + let nm := fst c in let tys := remove_proj c in let tparams := map type_to_term params in let o_pt_e := find (fun x =>(fst x).(pName) =? nm) bs in @@ -113,7 +113,7 @@ Definition etrans_branch (params : list type)(bs : list (pat * term)) {| bcontext := []; bbody := tVar (TCString.of_string (nm ++ ": arity does not match"))%string |} | None => {| bcontext := [] ; - bbody:= dummy |} + bbody := dummy |} end. Open Scope list. @@ -187,7 +187,7 @@ Definition of_ename (e : option ename) : aname := (** Translation of constructors of parameterised inductive types requires non-trivial manipulation of De Bruijn indices. *) -Definition mkArrows_rec (ind_name : ename) (nparam : nat) := +Definition mkArrows_rec (ind_name : ename) (nparam : nat) := fix rec (n : nat) (proj_tys : list (option ename * type)) := match proj_tys with | [] => (* this is a return type of the constructor *) @@ -241,7 +241,7 @@ Definition trans_global_dec (gd : global_dec) : mutual_inductive_entry := mind_entry_params := gen_params nparam; mind_entry_inds := [oie]; mind_entry_universes := Monomorphic_ctx; - mind_entry_private := None;|} in + mind_entry_private := None; |} in mie end. @@ -279,7 +279,7 @@ Fixpoint add_prefix (e : expr) (ps : env string) := | eRel _ | eVar _ => e | eLambda nm ty e1 => eLambda nm (add_prefix_ty ty ps) (add_prefix e1 ps) | eTyLam nm e1 => eTyLam nm (add_prefix e1 ps) - | eLetIn nm e1 ty e2 => eLetIn nm (add_prefix e1 ps) + | eLetIn nm e1 ty e2 => eLetIn nm (add_prefix e1 ps) (add_prefix_ty ty ps) (add_prefix e2 ps) | eApp e1 e2 => eApp (add_prefix e1 ps) (add_prefix e2 ps) @@ -351,10 +351,10 @@ Module StdLib. gdInd Bool 0 [("true", []); ("false", [])] false; gdInd Nat 0 [("Z", []); ("Suc", [(None,tyInd Nat)])] false; gdInd Int 0 [("Z0", [])] false ; (* we ommit other construtors for now, since in general integer literals are not supported yet *) - gdInd String 0 [] false; (* just for remapping string to Coq string, construtors are not necessary *) + gdInd String 0 [] false; (* just for remapping string to Coq string, construtors are not necessary *) gdInd List 1 [("nil", []); ("cons", [(None,tyRel 0); (None,tyApp (tyInd List) (tyRel 0))])] false; - gdInd Prod 2 [("pair", [(None,tyRel 1);(None,tyRel 0)])] false]. + gdInd Prod 2 [("pair", [(None,tyRel 1); (None,tyRel 0)])] false]. Notation "a + b" := [| {eConst (to_string_name <% Nat.add %>)} {a} {b} |] (in custom expr at level 0). @@ -391,7 +391,7 @@ Module StdLib. Notation "'False'" := (pConstr false_name []) ( in custom pat at level 0). Notation "'Nil'" := (pConstr "nil" []) (in custom pat at level 0). - Notation "'Cons' y z" := (pConstr "cons" [y;z]) + Notation "'Cons' y z" := (pConstr "cons" [y; z]) (in custom pat at level 0, y constr at level 4, z constr at level 4). diff --git a/embedding/theories/pcuic/PCUICtoTemplate.v b/embedding/theories/pcuic/PCUICtoTemplate.v index 87ca5cf8..d1fe5a6e 100644 --- a/embedding/theories/pcuic/PCUICtoTemplate.v +++ b/embedding/theories/pcuic/PCUICtoTemplate.v @@ -39,10 +39,10 @@ Definition trans_universes_decl (ud : universes_decl) : universes_entry := | Polymorphic_ctx (ln, cst) => Polymorphic_entry (AUContext.repr (ln,cst)) end. -Definition trans_minductive_entry (e : P.mutual_inductive_entry) : TC.mutual_inductive_entry := +Definition trans_minductive_entry (e : P.mutual_inductive_entry) : TC.mutual_inductive_entry := {| TC.mind_entry_record := e.(P.mind_entry_record); TC.mind_entry_finite := e.(P.mind_entry_finite); - TC.mind_entry_params := List.map trans_local_entry e.(P.mind_entry_params); + TC.mind_entry_params := List.map trans_local_entry e.(P.mind_entry_params); TC.mind_entry_inds := List.map trans_one_ind_entry e.(P.mind_entry_inds); TC.mind_entry_universes := trans_universes_decl e.(P.mind_entry_universes); TC.mind_entry_variance := None; diff --git a/examples/_CoqProject b/examples/_CoqProject index 0c836426..4b983c64 100644 --- a/examples/_CoqProject +++ b/examples/_CoqProject @@ -1,3 +1,6 @@ +-arg -w -arg -notation-overridden +-arg -w -arg -non-reversible-notation + -R ../utils/theories ConCert.Utils -R ../execution/theories ConCert.Execution -R ../execution/test ConCert.Execution.Test @@ -56,8 +59,8 @@ dexter2/Dexter2CPMM.v dexter2/Dexter2FA12Correct.v dexter2/Dexter2CPMMCorrect.v dexter2/Dexter2CommonExtract.v -dexter2/Dexter2FA12Extract.v -dexter2/Dexter2CPMMExtract.v +dexter2/Dexter2FA12ExtractLIGO.v +dexter2/Dexter2CPMMExtractLIGO.v dexter2/Dexter2Printers.v dexter2/Dexter2Gens.v dexter2/Dexter2Tests.v @@ -81,7 +84,7 @@ cis1/Cis1wccd.v -Q stackInterpreter ConCert.Examples.StackInterpreter stackInterpreter/StackInterpreter.v -stackInterpreter/RustInterpExtract.v +stackInterpreter/StackInterpreterRustExtract.v stackInterpreter/StackInterpreterExtract.v stackInterpreter/StackInterpreterLiquidityExtract.v stackInterpreter/StackInterpreterLIGOExtract.v @@ -104,10 +107,10 @@ escrow/EscrowCorrect.v escrow/tests/EscrowGens.v escrow/tests/EscrowPrinters.v escrow/tests/EscrowTests.v -escrow/extraction/EscrowExtractLIGO.v -escrow/extraction/EscrowExtractLiquidity.v -escrow/extraction/MidlangEscrow.v -escrow/extraction/RustEscrow.v +escrow/extraction/EscrowLIGO.v +escrow/extraction/EscrowLiquidity.v +escrow/extraction/EscrowMidlang.v +escrow/extraction/EscrowRust.v -Q boardroomVoting ConCert.Examples.BoardroomVoting boardroomVoting/Egcd.v @@ -122,13 +125,13 @@ boardroomVoting/BoardroomVotingExtractionLiquidity.v -Q counter ConCert.Examples.Counter counter/Counter.v counter/embedding/CounterEmbed.v -counter/extraction/CounterCertifiedExtraction.v -counter/extraction/CounterDepCertifiedExtraction.v +counter/extraction/CounterCertifiedLiquidity.v +counter/extraction/CounterDepCertifiedLiquidity.v counter/extraction/CounterSubsetTypesLIGO.v counter/extraction/CounterSubsetTypesLiquidity.v -counter/extraction/MidlangCounterRefTypes.v -counter/extraction/RustCounter.v -counter/extraction/CameLIGOCounter.v +counter/extraction/CounterRefTypesMidlang.v +counter/extraction/CounterRust.v +counter/extraction/CounterLIGO.v -Q crowdfunding ConCert.Examples.Crowdfunding crowdfunding/CrowdfundingData.v diff --git a/examples/bat/BAT.v b/examples/bat/BAT.v index 52a57bc3..8eeaad7d 100644 --- a/examples/bat/BAT.v +++ b/examples/bat/BAT.v @@ -16,6 +16,7 @@ From ConCert.Utils Require Import RecordUpdate. From ConCert.Execution Require Import Blockchain. From ConCert.Execution Require Import Containers. From ConCert.Execution Require Import Monad. +From ConCert.Execution Require Import Serializable. From ConCert.Execution Require Import ResultMonad. From ConCert.Execution Require Import ContractCommon. From ConCert.Examples.BAT Require Import BATCommon. @@ -79,7 +80,7 @@ Section BAT. do _ <- throwIf (state.(tokenCreationCap) + EIP20Token.balances := FMap.partial_alter (fun balance => Some (with_default 0 balance + tokens)) sender (balances state); EIP20Token.allowances := allowances state; |} in diff --git a/examples/bat/BATAltFix.v b/examples/bat/BATAltFix.v index 07c06701..8e3dfda7 100644 --- a/examples/bat/BATAltFix.v +++ b/examples/bat/BATAltFix.v @@ -17,6 +17,7 @@ From ConCert.Utils Require Import RecordUpdate. From ConCert.Execution Require Import Blockchain. From ConCert.Execution Require Import Containers. From ConCert.Execution Require Import Monad. +From ConCert.Execution Require Import Serializable. From ConCert.Execution Require Import ResultMonad. From ConCert.Execution Require Import ContractCommon. From ConCert.Examples.BAT Require Import BATCommon. diff --git a/examples/bat/BATAltFixCorrect.v b/examples/bat/BATAltFixCorrect.v index e116e276..e0c50237 100644 --- a/examples/bat/BATAltFixCorrect.v +++ b/examples/bat/BATAltFixCorrect.v @@ -908,7 +908,7 @@ Section Theories. apply receive_total_supply_increasing in receive_some as total_supply_increasing; try (cbn; lia). apply receive_preserves_constants in receive_some as (? & ? & ? & ? & ? & ? & ? & ?). repeat match goal with - | H : _ prev_state' = _ new_state' |- _=> rewrite H in *; clear H + | H : _ prev_state' = _ new_state' |- _=> rewrite H in *; clear H end. exists new_state'. rewrite_environment_equiv; cbn; repeat split; eauto; @@ -947,7 +947,7 @@ Section Theories. + cbn in *. clear contract_state slot_hit creation_min. update_all; - [rewrite queue0; do 3 f_equal;repeat (rewrite_environment_equiv; cbn; destruct_address_eq; try easy)|]. + [rewrite queue0; do 3 f_equal; repeat (rewrite_environment_equiv; cbn; destruct_address_eq; try easy)|]. (* Finally we need to evaluate the new transfer action that finalize produced *) evaluate_transfer; try easy. * (* Prove that the transfer is nonnegative *) @@ -1021,7 +1021,7 @@ Section Theories. apply receive_total_supply_increasing in receive_some as total_supply_increasing; try (cbn; lia). apply receive_preserves_constants in receive_some as (? & ? & ? & ? & ? & ? & ? & ?). repeat match goal with - | H : _ prev_state' = _ new_state' |- _=> rewrite H in *; clear H + | H : _ prev_state' = _ new_state' |- _=> rewrite H in *; clear H end. eexists new_state'. repeat split; eauto; @@ -1290,7 +1290,7 @@ Section Theories. inversion deploy_info'. subst dep_info. clear deploy_info'. cbn in *. repeat match goal with - | H : _ cstate = _ setup |- _=> rewrite <- H in *; clear H + | H : _ cstate = _ setup |- _=> rewrite <- H in *; clear H end. update bstate0 with bstate in enough_balance_to_fund by (eapply N.le_trans; [apply enough_balance_to_fund | apply N.mul_le_mono_r, Z2N.inj_le; try now apply spendable_balance_positive]; @@ -1481,7 +1481,7 @@ Section Theories. + apply try_create_tokens_only_change_token_state in receive_some as finalized_unchanged. apply try_create_tokens_acts_correct in receive_some as no_new_acts. specialize try_create_tokens_is_some as (_ & (_ & _ & _ & funding_active & _)); eauto. - rewrite <- finalized_unchanged in not_finalized. + rewrite <- finalized_unchanged in not_finalized. destruct not_finalized as [not_finalized _]. rewrite no_new_acts, IH; auto. + apply try_finalize_isFinalized_correct in receive_some as finalized. @@ -1610,7 +1610,7 @@ Section Theories. specialize N_sub_mod_le as ?. rewrite H, <- N2Z.inj_sub, N2Z.inj_add, (N2Z.inj_sub _ t); auto. rewrite <- Z.sub_sub_distr, <- N2Z.inj_sub, <- N2Z.inj_sub; auto. - all: now eapply N.le_trans. + all: now eapply N.le_trans. + now contract_simpl. - now destruct facts. - now erewrite sumZ_permutation in IH_finalized, IH_funding by eauto. diff --git a/examples/bat/BATAltFixTests.v b/examples/bat/BATAltFixTests.v index 55a7eb9c..22643b9b 100644 --- a/examples/bat/BATAltFixTests.v +++ b/examples/bat/BATAltFixTests.v @@ -7,7 +7,7 @@ From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.BAT Require Import BATCommon. From ConCert.Examples.BAT Require Import BATAltFix. From ConCert.Examples.BAT Require Import BATGens. -From ConCert.Examples.BAT Require Import BATPrinters. +From ConCert.Examples.BAT Require Export BATPrinters. From ConCert.Examples.BAT Require Import BATTestCommon. From Coq Require Import List. From Coq Require Import ZArith_base. @@ -196,7 +196,7 @@ Definition constants_unchanged (chain : Chain) (cctx : ContractCallContext) (old (* Funding start block and end block should be constants *) let funding_start_check := Nat.eqb old_state.(fundingStart) new_state.(fundingStart) in let funding_end_check := Nat.eqb old_state.(fundingEnd) new_state.(fundingEnd) in - (* Token exchange rate and initSupply should be constants *) + (* Token exchange rate and initSupply should be constants *) let exchange_rate_check := N.eqb old_state.(tokenExchangeRate) new_state.(tokenExchangeRate) in let init_supply_check := N.eqb old_state.(initSupply) new_state.(initSupply) in (* Minimum and maximum token limits should be constants *) @@ -507,9 +507,9 @@ Definition post_transfer_update_correct (chain : Chain) (cctx : ContractCallCont else (from_balance_before =? from_balance_after + tokens) in (* Transfer must add the transfered tokens from the "to" address if the "from <> to" otherwise the balance should remain the same *) - let to_balance_correct := if from_to_same - then (to_balance_before =? to_balance_after) - else (to_balance_before + tokens =? to_balance_after) in + let to_balance_correct := if from_to_same + then (to_balance_before =? to_balance_after) + else (to_balance_before + tokens =? to_balance_after) in whenFail (show old_state ++ nl ++ show result_opt) (checker (from_balance_correct && to_balance_correct)) @@ -598,9 +598,9 @@ Definition post_transfer_from_update_correct (chain : Chain) (cctx : ContractCal else (from_balance_before =? from_balance_after + tokens) in (* Transfer_from must add the transfered tokens to the "to" address if the "from <> to" otherwise the balance should remain the same *) - let to_balance_correct := if from_to_same - then (to_balance_before =? to_balance_after) - else (to_balance_before + tokens =? to_balance_after) in + let to_balance_correct := if from_to_same + then (to_balance_before =? to_balance_after) + else (to_balance_before + tokens =? to_balance_after) in (* Transfer_from must subtract the number of transfered tokens from the delegates allowance *) let delefate_allowance_correct := delegate_allowance_before =? delegate_allowance_after + tokens in @@ -819,7 +819,7 @@ Action{act_from: 11%256, act_body: (act_call 128%256, 3, create_tokens)}; Action{act_from: 12%256, act_body: (act_call 128%256, 2, create_tokens)}]; Block 6 [ Action{act_from: 11%256, act_body: (act_call 128%256, 0, refund)}; -Action{act_from: 12%256, act_body: (act_call 128%256, 0, refund)}];|} +Action{act_from: 12%256, act_body: (act_call 128%256, 0, refund)}]; |} Success - found witness satisfying the predicate! +++ Failed (as expected) after 13 tests and 0 shrinks. (0 discards) @@ -881,7 +881,7 @@ Block 5 [ Action{act_from: 17%256, act_body: (act_call 128%256, 2, create_tokens)}; Action{act_from: 17%256, act_body: (act_call 128%256, 0, transfer_from 16%256 17%256 0)}]; Block 6 [ -Action{act_from: 16%256, act_body: (act_call 128%256, 0, finalize)}];|} +Action{act_from: 16%256, act_body: (act_call 128%256, 0, finalize)}]; |} Success - found witness satisfying the predicate! +++ Failed (as expected) after 6 tests and 0 shrinks. (0 discards) @@ -907,9 +907,9 @@ Definition can_always_finalize check_setup := always possible to successfully fund the token for any setup used when deploying the token *) (* -Extract Constant defNumTests => "100". +Extract Constant defNumTests => "100". QuickChick (expectFailure (can_always_finalize (fun _ _ => true))). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". *) Definition final_is_final := diff --git a/examples/bat/BATCorrect.v b/examples/bat/BATCorrect.v index a6eff86c..65e599b7 100644 --- a/examples/bat/BATCorrect.v +++ b/examples/bat/BATCorrect.v @@ -845,7 +845,7 @@ Section Theories. apply receive_total_supply_increasing in receive_some as total_supply_increasing; try (cbn; lia). apply receive_preserves_constants in receive_some as (? & ? & ? & ? & ? & ? & ? & ?). repeat match goal with - | H : _ prev_state' = _ new_state' |- _=> try rewrite H in *; clear H + | H : _ prev_state' = _ new_state' |- _=> try rewrite H in *; clear H end. exists new_state'. rewrite_environment_equiv; cbn; repeat split; eauto; @@ -884,7 +884,7 @@ Section Theories. + cbn in *. clear contract_state slot_hit creation_min. update_all; - [rewrite queue0; do 3 f_equal;repeat (rewrite_environment_equiv; cbn; destruct_address_eq; try easy)|]. + [rewrite queue0; do 3 f_equal; repeat (rewrite_environment_equiv; cbn; destruct_address_eq; try easy)|]. (* Finally we need to evaluate the new transfer action that finalize produced *) evaluate_transfer; try easy. * (* Prove that the transfer is nonnegative *) @@ -963,7 +963,7 @@ Section Theories. apply receive_total_supply_increasing in receive_some as total_supply_increasing; try (cbn; lia). apply receive_preserves_constants in receive_some as (? & ? & ? & ? & ? & ? & ? & ?). repeat match goal with - | H : _ prev_state' = _ new_state' |- _=> try rewrite H in *; clear H + | H : _ prev_state' = _ new_state' |- _=> try rewrite H in *; clear H end. eexists new_state'. repeat split; eauto; @@ -1205,7 +1205,7 @@ Section Theories. inversion deploy_info'. subst dep_info. clear deploy_info'. cbn in *. repeat match goal with - | H : _ cstate = _ setup |- _=> rewrite <- H in *; clear H + | H : _ cstate = _ setup |- _=> rewrite <- H in *; clear H end. update (initSupply cstate) with (total_supply cstate) in enough_balance_to_fund by (eapply N.le_trans; [apply N.sub_le_mono_l, N.eq_le_incl | apply enough_balance_to_fund]; now rewrite Heqcstate). diff --git a/examples/bat/BATFixed.v b/examples/bat/BATFixed.v index 6283379d..2d57b870 100644 --- a/examples/bat/BATFixed.v +++ b/examples/bat/BATFixed.v @@ -17,6 +17,7 @@ From ConCert.Utils Require Import RecordUpdate. From ConCert.Execution Require Import Blockchain. From ConCert.Execution Require Import Containers. From ConCert.Execution Require Import Monad. +From ConCert.Execution Require Import Serializable. From ConCert.Execution Require Import ResultMonad. From ConCert.Execution Require Import ContractCommon. From ConCert.Examples.BAT Require Import BATCommon. @@ -112,7 +113,7 @@ Section BATFixed. (current_slot : nat) (state : State) : result (State * list ActionBody) Error := - (** Early return if funding is finalized, or funding period is NOT over, + (** Early return if funding is finalized, or funding period is NOT over, or if total supply exceeds or is equal to the minimum fund tokens. *) do _ <- throwIf (state.(isFinalized) || (Nat.leb current_slot state.(fundingEnd)) diff --git a/examples/bat/BATFixedCorrect.v b/examples/bat/BATFixedCorrect.v index 723acc3f..4602fb4b 100644 --- a/examples/bat/BATFixedCorrect.v +++ b/examples/bat/BATFixedCorrect.v @@ -889,7 +889,7 @@ Section Theories. apply receive_total_supply_increasing in receive_some as total_supply_increasing; try (cbn; lia). apply receive_preserves_constants in receive_some as (? & ? & ? & ? & ? & ? & ? & ?). repeat match goal with - | H : _ prev_state' = _ new_state' |- _=> rewrite H in *; clear H + | H : _ prev_state' = _ new_state' |- _=> rewrite H in *; clear H end. exists new_state'. rewrite_environment_equiv; cbn; repeat split; eauto; @@ -928,7 +928,7 @@ Section Theories. + cbn in *. clear contract_state slot_hit creation_min. update_all; - [rewrite queue0; do 3 f_equal;repeat (rewrite_environment_equiv; cbn; destruct_address_eq; try easy)|]. + [rewrite queue0; do 3 f_equal; repeat (rewrite_environment_equiv; cbn; destruct_address_eq; try easy)|]. (* Finally we need to evaluate the new transfer action that finalize produced *) evaluate_transfer; try easy. * (* Prove that the transfer is nonnegative *) @@ -1004,7 +1004,7 @@ Section Theories. apply receive_total_supply_increasing in receive_some as total_supply_increasing; try (cbn; lia). apply receive_preserves_constants in receive_some as (? & ? & ? & ? & ? & ? & ? & ?). repeat match goal with - | H : _ prev_state' = _ new_state' |- _=> rewrite H in *; clear H + | H : _ prev_state' = _ new_state' |- _=> rewrite H in *; clear H end. eexists new_state'. repeat split; eauto; @@ -1283,7 +1283,7 @@ Section Theories. inversion deploy_info'. subst dep_info. clear deploy_info'. cbn in *. repeat match goal with - | H : _ cstate = _ setup |- _=> rewrite <- H in *; clear H + | H : _ cstate = _ setup |- _=> rewrite <- H in *; clear H end. update (initSupply cstate) with (total_supply cstate) in enough_balance_to_fund by (eapply N.le_trans; [apply N.sub_le_mono_l, N.eq_le_incl | apply enough_balance_to_fund]; now rewrite Heqcstate). @@ -1656,7 +1656,7 @@ Section Theories. - (** ** Contract balance bound *) + (** ** Contract balance bound *) Lemma contract_balance_bound : forall bstate caddr (trace : ChainTrace empty_state bstate), let effective_balance := (env_account_balances bstate caddr - (sumZ (fun act => act_body_amount act) (outgoing_acts bstate caddr)))%Z in diff --git a/examples/bat/BATFixedTests.v b/examples/bat/BATFixedTests.v index 1cba9f5c..6049a4f0 100644 --- a/examples/bat/BATFixedTests.v +++ b/examples/bat/BATFixedTests.v @@ -7,7 +7,7 @@ From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.BAT Require Import BATCommon. From ConCert.Examples.BAT Require Import BATFixed. From ConCert.Examples.BAT Require Import BATGens. -From ConCert.Examples.BAT Require Import BATPrinters. +From ConCert.Examples.BAT Require Export BATPrinters. From ConCert.Examples.BAT Require Import BATTestCommon. From Coq Require Import List. From Coq Require Import ZArith_base. @@ -184,7 +184,7 @@ Definition constants_unchanged (chain : Chain) (cctx : ContractCallContext) (old (* Funding start block and end block should be constants *) let funding_start_check := Nat.eqb old_state.(fundingStart) new_state.(fundingStart) in let funding_end_check := Nat.eqb old_state.(fundingEnd) new_state.(fundingEnd) in - (* Token exchange rate and initSupply should be constants *) + (* Token exchange rate and initSupply should be constants *) let exchange_rate_check := N.eqb old_state.(tokenExchangeRate) new_state.(tokenExchangeRate) in let init_supply_check := N.eqb old_state.(initSupply) new_state.(initSupply) in (* Minimum and maximum token limits should be constants *) @@ -506,9 +506,9 @@ Definition post_transfer_update_correct (chain : Chain) (cctx : ContractCallCont else (from_balance_before =? from_balance_after + tokens) in (* Transfer must add the transfered tokens from the "to" address if the "from <> to" otherwise the balance should remain the same *) - let to_balance_correct := if from_to_same - then (to_balance_before =? to_balance_after) - else (to_balance_before + tokens =? to_balance_after) in + let to_balance_correct := if from_to_same + then (to_balance_before =? to_balance_after) + else (to_balance_before + tokens =? to_balance_after) in whenFail (show old_state ++ nl ++ show result_opt) (checker (from_balance_correct && to_balance_correct)) @@ -597,9 +597,9 @@ Definition post_transfer_from_update_correct (chain : Chain) (cctx : ContractCal else (from_balance_before =? from_balance_after + tokens) in (* Transfer_from must add the transfered tokens to the "to" address if the "from <> to" otherwise the balance should remain the same *) - let to_balance_correct := if from_to_same - then (to_balance_before =? to_balance_after) - else (to_balance_before + tokens =? to_balance_after) in + let to_balance_correct := if from_to_same + then (to_balance_before =? to_balance_after) + else (to_balance_before + tokens =? to_balance_after) in (* Transfer_from must subtract the number of transfered tokens from the delegates allowance *) let delefate_allowance_correct := delegate_allowance_before =? delegate_allowance_after + tokens in @@ -847,7 +847,7 @@ Action{act_from: 13%256, act_body: (act_call 128%256, 0, refund)}; Action{act_from: 12%256, act_body: (act_call 128%256, 0, refund)}]; Block 7 [ Action{act_from: 14%256, act_body: (act_call 128%256, 0, refund)}; -Action{act_from: 11%256, act_body: (act_call 128%256, 0, refund)}];|} +Action{act_from: 11%256, act_body: (act_call 128%256, 0, refund)}]; |} Success - found witness satisfying the predicate! +++ Failed (as expected) after 42 tests and 0 shrinks. (0 discards) @@ -911,7 +911,7 @@ Block 5 [ Action{act_from: 12%256, act_body: (act_call 128%256, 2, create_tokens)}; Action{act_from: 11%256, act_body: (act_call 128%256, 2, create_tokens)}]; Block 6 [ -Action{act_from: 16%256, act_body: (act_call 128%256, 0, finalize)}];|} +Action{act_from: 16%256, act_body: (act_call 128%256, 0, finalize)}]; |} Success - found witness satisfying the predicate! +++ Failed (as expected) after 6 tests and 0 shrinks. (0 discards) @@ -937,9 +937,9 @@ Definition can_always_finalize check_setup := always possible to successfully fund the token for any setup used when deploying the token *) (* -Extract Constant defNumTests => "100". +Extract Constant defNumTests => "100". QuickChick (expectFailure (can_always_finalize (fun _ _ => true))). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". *) Definition final_is_final := diff --git a/examples/bat/BATPrinters.v b/examples/bat/BATPrinters.v index 582c02be..ca9e4d22 100644 --- a/examples/bat/BATPrinters.v +++ b/examples/bat/BATPrinters.v @@ -6,11 +6,13 @@ From ConCert.Examples.EIP20 Require Import EIP20TokenPrinters. Local Open Scope string_scope. +#[export] Instance showTokenValue : Show TokenValue := {| show v := show v |}. +#[export] Instance showMsg : Show BATCommon.Msg := {| show m := match m with @@ -21,6 +23,7 @@ Instance showMsg : Show BATCommon.Msg := end |}. +#[export] Instance showBATSetup : Show BATCommon.Setup := {| show setup := "Setup{" ++ @@ -34,6 +37,7 @@ Instance showBATSetup : Show BATCommon.Setup := "tokenCreationMin: " ++ show setup.(_tokenCreationMin) ++ "}" |}. +#[export] Instance showBATState : Show BATCommon.State := {| show s := "State{" ++ @@ -49,5 +53,6 @@ Instance showBATState : Show BATCommon.State := "tokenCreationMin: " ++ show s.(tokenCreationMin) ++ "}" |}. +#[export] Instance showSerializedMsg : Show SerializedValue := Derive Show Msg < BATCommon.Msg, BATCommon.Setup >. diff --git a/examples/bat/BATTests.v b/examples/bat/BATTests.v index 9e913825..2fab773f 100644 --- a/examples/bat/BATTests.v +++ b/examples/bat/BATTests.v @@ -7,7 +7,7 @@ From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.BAT Require Import BATCommon. From ConCert.Examples.BAT Require Import BAT. From ConCert.Examples.BAT Require Import BATGens. -From ConCert.Examples.BAT Require Import BATPrinters. +From ConCert.Examples.BAT Require Export BATPrinters. From ConCert.Examples.BAT Require Import BATTestCommon. From Coq Require Import List. From Coq Require Import ZArith_base. @@ -214,7 +214,7 @@ Definition constants_unchanged (chain : Chain) (cctx : ContractCallContext) (old (* Funding start block and end block should be constants *) let funding_start_check := Nat.eqb old_state.(fundingStart) new_state.(fundingStart) in let funding_end_check := Nat.eqb old_state.(fundingEnd) new_state.(fundingEnd) in - (* Token exchange rate and initSupply should be constants *) + (* Token exchange rate and initSupply should be constants *) let exchange_rate_check := N.eqb old_state.(tokenExchangeRate) new_state.(tokenExchangeRate) in let init_supply_check := N.eqb old_state.(initSupply) new_state.(initSupply) in (* Minimum and maximum token limits should be constants *) @@ -524,9 +524,9 @@ Definition post_transfer_update_correct (chain : Chain) (cctx : ContractCallCont else (from_balance_before =? from_balance_after + tokens) in (* Transfer must add the transfered tokens from the "to" address if the "from <> to" otherwise the balance should remain the same *) - let to_balance_correct := if from_to_same - then (to_balance_before =? to_balance_after) - else (to_balance_before + tokens =? to_balance_after) in + let to_balance_correct := if from_to_same + then (to_balance_before =? to_balance_after) + else (to_balance_before + tokens =? to_balance_after) in whenFail (show old_state ++ nl ++ show result_opt) (checker (from_balance_correct && to_balance_correct)) @@ -615,9 +615,9 @@ Definition post_transfer_from_update_correct (chain : Chain) (cctx : ContractCal else (from_balance_before =? from_balance_after + tokens) in (* Transfer_from must add the transfered tokens to the "to" address if the "from <> to" otherwise the balance should remain the same *) - let to_balance_correct := if from_to_same - then (to_balance_before =? to_balance_after) - else (to_balance_before + tokens =? to_balance_after) in + let to_balance_correct := if from_to_same + then (to_balance_before =? to_balance_after) + else (to_balance_before + tokens =? to_balance_after) in (* Transfer_from must subtract the number of transfered tokens from the delegates allowance *) let delefate_allowance_correct := delegate_allowance_before =? delegate_allowance_after + tokens in @@ -823,7 +823,7 @@ Chain{| Block 1 [ Action{act_from: 10%256, act_body: (act_deploy 0, transfer 19%256 17)}]; Block 6 [ -Action{act_from: 17%256, act_body: (act_call 128%256, 0, transfer 16%256 14)}];|} +Action{act_from: 17%256, act_body: (act_call 128%256, 0, transfer 16%256 14)}]; |} ChainState{ env: Environment{ @@ -848,10 +848,10 @@ ChainState{ We now test if the above property holds when no such transfers occur *) (* -Extract Constant defNumTests => "3000". +Extract Constant defNumTests => "3000". Extract Constant defNumDiscards => "20000". QuickChick ({{no_transfers_from_bat_fund}} ==> {{contract_balance_lower_bound'}}). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". Extract Constant defNumDiscards => "(2 * defNumTests)". *) (* +++ Passed 3000 tests (7170 discards) *) @@ -897,7 +897,7 @@ Action{act_from: 11%256, act_body: (act_call 128%256, 3, create_tokens)}; Action{act_from: 12%256, act_body: (act_call 128%256, 2, create_tokens)}]; Block 6 [ Action{act_from: 11%256, act_body: (act_call 128%256, 0, refund)}; -Action{act_from: 12%256, act_body: (act_call 128%256, 0, refund)}];|} +Action{act_from: 12%256, act_body: (act_call 128%256, 0, refund)}]; |} Success - found witness satisfying the predicate! +++ Failed (as expected) after 13 tests and 0 shrinks. (0 discards) @@ -949,7 +949,7 @@ Block 1 [ Action{act_from: 10%256, act_body: (act_transfer 17%256, 2)}; Action{act_from: 10%256, act_body: (act_deploy 0, transfer 19%256 17)}]; Block 3 [ -Action{act_from: 17%256, act_body: (act_call 128%256, 2, create_tokens)}];|} +Action{act_from: 17%256, act_body: (act_call 128%256, 2, create_tokens)}]; |} ChainState{ env: Environment{chain: Chain{height: 2, current slot: 3, final height: 0}, contract states:...}, @@ -975,7 +975,7 @@ Action{act_from: 10%256, act_body: (act_transfer 16%256, 2)}; Action{act_from: 10%256, act_body: (act_deploy 0, transfer 19%256 17)}]; Block 3 [ Action{act_from: 16%256, act_body: (act_call 128%256, 1, create_tokens)}; -Action{act_from: 16%256, act_body: (act_call 128%256, 0, transfer 17%256 2)}];|} +Action{act_from: 16%256, act_body: (act_call 128%256, 0, transfer 17%256 2)}]; |} ChainState{ env: Environment{chain: Chain{height: 2, current slot: 3, final height: 0}, contract states:...}, @@ -1006,7 +1006,7 @@ Block 5 [ Action{act_from: 11%256, act_body: (act_call 128%256, 2, create_tokens)}]; Block 7 [ Action{act_from: 11%256, act_body: (act_call 128%256, 0, transfer 12%256 4)}; -Action{act_from: 11%256, act_body: (act_call 128%256, 0, refund)}];|} +Action{act_from: 11%256, act_body: (act_call 128%256, 0, refund)}]; |} ChainState{ env: Environment{ @@ -1043,13 +1043,13 @@ ChainState{ We now test if it is possible when no such transfers occur *) (* -Extract Constant defNumTests => "1000". +Extract Constant defNumTests => "1000". Extract Constant defNumDiscards => "45000". QuickChick ({{no_batfund_create_tokens &&& no_transfers_to_batfund &&& only_transfers_modulo_exhange_rate}} ==> {{can_always_fully_refund}}). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". Extract Constant defNumDiscards => "(2 * defNumTests)". *) (* +++ Passed 1000 tests (34031 discards) *) @@ -1082,7 +1082,7 @@ Block 5 [ Action{act_from: 17%256, act_body: (act_call 128%256, 2, create_tokens)}; Action{act_from: 17%256, act_body: (act_call 128%256, 0, transfer_from 16%256 17%256 0)}]; Block 6 [ -Action{act_from: 16%256, act_body: (act_call 128%256, 0, finalize)}];|} +Action{act_from: 16%256, act_body: (act_call 128%256, 0, finalize)}]; |} Success - found witness satisfying the predicate! +++ Failed (as expected) after 6 tests and 0 shrinks. (0 discards) @@ -1114,9 +1114,9 @@ Definition can_always_finalize check_setup := always possible to successfully fund the token for any setup used when deploying the token *) (* -Extract Constant defNumTests => "100". +Extract Constant defNumTests => "100". QuickChick (expectFailure (forAll gBATSetup (build_init_cb (fun cb => cb ~~> is_finalized)))). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". *) (* Setup{ @@ -1140,9 +1140,9 @@ Setup{ *) (* -Extract Constant defNumTests => "100". +Extract Constant defNumTests => "100". QuickChick (expectFailure (can_always_finalize funding_period_not_over)). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". *) (* Setup{ @@ -1164,11 +1164,11 @@ Setup{ *) (* -Extract Constant defNumTests => "200". +Extract Constant defNumTests => "200". QuickChick (expectFailure (can_always_finalize (fun setup cb => (funding_period_not_over setup cb) && (funding_period_non_empty setup)))). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". *) (* Setup{ @@ -1190,12 +1190,12 @@ Setup{ *) (* -Extract Constant defNumTests => "200". +Extract Constant defNumTests => "200". QuickChick (expectFailure (can_always_finalize (fun setup cb => (funding_period_not_over setup cb) && (funding_period_non_empty setup) && (initial_supply_le_cap setup)))). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". *) (* Setup{ @@ -1217,13 +1217,13 @@ Setup{ *) (* -Extract Constant defNumTests => "200". +Extract Constant defNumTests => "200". QuickChick (expectFailure (can_always_finalize (fun setup cb => (funding_period_not_over setup cb) && (funding_period_non_empty setup) && (initial_supply_le_cap setup) && (exchange_rate_non_zero setup)))). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". *) (* Setup{ @@ -1342,7 +1342,7 @@ Block 6 [ Action{act_from: 13%256, act_body: (act_call 128%256, 0, transfer 15%256 3)}]; Block 7 [ Action{act_from: 15%256, act_body: (act_call 128%256, 0, refund)}; -Action{act_from: 13%256, act_body: (act_call 128%256, 0, refund)}];|} +Action{act_from: 13%256, act_body: (act_call 128%256, 0, refund)}]; |} ChainState{ env: Environment{ @@ -1398,19 +1398,19 @@ ChainState{ we now test if it holds when either batFund makes no transfers or no transfers are of an amount such that "amount % exchange_rate != 0". *) (* -Extract Constant defNumTests => "5000". +Extract Constant defNumTests => "5000". Extract Constant defNumDiscards => "30000". QuickChick ({{no_transfers_from_bat_fund}} ==> {{total_supply_bounds}}). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". Extract Constant defNumDiscards => "(2 * defNumTests)". *) (* +++ Passed 5000 tests (11879 discards) *) (* -Extract Constant defNumTests => "1000". +Extract Constant defNumTests => "1000". Extract Constant defNumDiscards => "30000". QuickChick ({{only_transfers_modulo_exhange_rate}} ==> {{total_supply_bounds}}). -Extract Constant defNumTests => "10000". +Extract Constant defNumTests => "10000". Extract Constant defNumDiscards => "(2 * defNumTests)". *) (* +++ Passed 1000 tests (11862 discards) *) diff --git a/examples/boardroomVoting/BoardroomMath.v b/examples/boardroomVoting/BoardroomMath.v index e8e8ddca..af6c94fb 100644 --- a/examples/boardroomVoting/BoardroomMath.v +++ b/examples/boardroomVoting/BoardroomMath.v @@ -812,7 +812,7 @@ Module Zp. | x~1%positive => mod_pow_pos_aux (a * a mod m) x m (r * a mod m) | _ => r * a mod m end. - + Definition mod_pow_pos (a : Z) (x : positive) (m : Z) : Z := mod_pow_pos_aux a x m 1. @@ -1051,6 +1051,7 @@ Module Zp. destruct onediv as [div|div]; apply Z.mod_divide in div; lia. Qed. + #[local] Hint Resolve mul_mod_nonzero : core. Lemma mod_mod_nonzero a p : @@ -1062,6 +1063,7 @@ Module Zp. auto. Qed. + #[local] Hint Resolve mod_mod_nonzero : core. Lemma mod_pow_pos_aux_nonzero a x p r : @@ -1076,6 +1078,7 @@ Module Zp. induction x; intros a r ap0 rp0; cbn; auto. Qed. + #[local] Hint Resolve mod_pow_pos_aux_nonzero : core. Lemma mod_pow_pos_nonzero a x p : @@ -1089,6 +1092,7 @@ Module Zp. now rewrite Z.mod_1_l by lia. Qed. + #[local] Hint Resolve mod_pow_pos_nonzero : core. Lemma mod_inv_nonzero a p : @@ -1105,6 +1109,7 @@ Module Zp. rewrite Z.mul_0_r, Z.mod_0_l in iszero; easy. Qed. + #[local] Hint Resolve mod_inv_nonzero : core. Lemma mod_pow_nonzero a x p : @@ -1120,6 +1125,7 @@ Module Zp. rewrite mod_pow_pos_mod; auto. Qed. + #[local] Hint Resolve mod_pow_nonzero : core. Lemma mod_pow_pos_mod_nonzero a x p : @@ -1143,6 +1149,7 @@ Module Zp. now rewrite Z.mod_1_l by lia. Qed. + #[local] Hint Resolve mod_pow_pos_mod_nonzero mod_inv_mod_nonzero mod_pow_mod_nonzero one_nonzero : core. Lemma mod_inv_mod_idemp a p : @@ -1213,7 +1220,7 @@ Module Zp. apply IHx. + now rewrite Z.mul_1_r. Qed. - + Lemma mod_pow_pos_1_l x p : mod_pow_pos 1 x p = 1 mod p. Proof. apply mod_pow_pos_aux_1_l. Qed. @@ -1599,7 +1606,9 @@ Module BigZp. | Zneg x => mod_inv (mod_pow_pos a x p) p end. + #[local] Hint Rewrite BigZ.square_spec BigZ.spec_pow_pos : zsimpl. + #[local] Hint Rewrite BigN.spec_of_pos : nsimpl. Lemma spec_mod_pow_pos_aux a x p r : @@ -1613,11 +1622,15 @@ Module BigZp. now autorewrite with zsimpl. - now autorewrite with zsimpl. Qed. + + #[local] Hint Rewrite spec_mod_pow_pos_aux : zsimpl. Lemma spec_mod_pow_pos a x p : [mod_pow_pos a x p] = Zp.mod_pow_pos [a] x [p]. Proof. apply spec_mod_pow_pos_aux. Qed. + + #[local] Hint Rewrite spec_mod_pow_pos : zsimpl. Lemma spec_egcd_aux n r0 a0 b0 r1 a1 b1 : @@ -1638,7 +1651,9 @@ Module BigZp. apply IH. Qed. + #[local] Hint Rewrite BigZ.spec_abs : zsimpl. + Lemma spec_egcd a b : let (x, y) := egcd a b in ([x], [y]) = Egcd.egcd [a] [b]. @@ -1673,6 +1688,8 @@ Module BigZp. inversion H. now autorewrite with zsimpl. Qed. + + #[local] Hint Rewrite spec_mod_inv : zsimpl. Lemma spec_mod_pow a x p : @@ -1681,9 +1698,19 @@ Module BigZp. unfold mod_pow, Zp.mod_pow. now destruct x; autorewrite with zsimpl. Qed. - Hint Rewrite spec_mod_pow : zsimpl. + #[local] + Hint Rewrite spec_mod_pow : zsimpl. + #[local] Hint Rewrite BigZ.spec_modulo : zsimpl. + #[local] + Hint Resolve Zp.mod_inv_nonzero : core. + #[local] + Hint Resolve Zp.mod_pow_nonzero : core. + #[local] + Hint Resolve Zp.mod_inv_mod_nonzero : core. + #[local] + Hint Resolve Zp.mod_pow_mod_nonzero : core. Local Open Scope Z. Definition boardroom_axioms (p : Z) : @@ -1808,6 +1835,17 @@ End BoardroomAxiomsZParams. Module BoardroomAxiomsZ (Params : BoardroomAxiomsZParams). Import Params. Local Open Scope Z_scope. + + #[local] + Hint Resolve Zp.mod_inv_nonzero : core. + #[local] + Hint Resolve Zp.mod_pow_nonzero : core. + #[local] + Hint Resolve Zp.mod_inv_mod_nonzero : core. + #[local] + Hint Resolve Zp.mod_pow_mod_nonzero : core. + + #[export] Instance boardroom_axioms_Z : BoardroomAxioms Z. Proof. (* pose proof (prime_ge_2). *) diff --git a/examples/boardroomVoting/BoardroomVoting.v b/examples/boardroomVoting/BoardroomVoting.v index ef6fc413..5b7ea53c 100644 --- a/examples/boardroomVoting/BoardroomVoting.v +++ b/examples/boardroomVoting/BoardroomVoting.v @@ -29,10 +29,15 @@ End BoardroomParams. Module BoardroomVoting (Params : BoardroomParams). Import Params. + #[local] Existing Instance ser. + #[local] Existing Instance axioms. + #[local] Existing Instance gen. + #[local] Existing Instance discr_log. + #[local] Existing Instance Base. (* Allow us to automatically derive Serializable instances *) @@ -670,7 +675,7 @@ Module BoardroomVoting (Params : BoardroomParams). split; [tauto|]. split. unfold AddressMap.add. - { rewrite FMap.size_add_existing by congruence; tauto. } + { rewrite FMap.size_add_existing by congruence; tauto. } split; [tauto|]. split; [tauto|]. intros [_ msg_assum] order_assum num_signups_assum. diff --git a/examples/boardroomVoting/BoardroomVotingExtractionCameLIGO.v b/examples/boardroomVoting/BoardroomVotingExtractionCameLIGO.v index ce721dab..6d33e81e 100644 --- a/examples/boardroomVoting/BoardroomVotingExtractionCameLIGO.v +++ b/examples/boardroomVoting/BoardroomVotingExtractionCameLIGO.v @@ -22,6 +22,7 @@ From Coq Require Import ZArith. Local Open Scope string_scope. Open Scope Z. +#[local] Existing Instance PrintConfShortNames.PrintWithShortNames. Definition PREFIX := "". @@ -85,8 +86,8 @@ Definition receive_wrapper (c : Chain) Definition storage_alias := "type storage = state". Definition bruteforce_tally_def := - "(fun (votes : (a) list) -> - let rec bruteforce_tally_aux (n, votes_product : nat * a) : (nat, nat) result = + "(fun (votes : (a) list) -> + let rec bruteforce_tally_aux (n, votes_product : nat * a) : (nat, nat) result = if elmeqb (pow_p generator (int n)) votes_product then Ok (n) else if n = 0n then @@ -102,12 +103,12 @@ Definition extra_ops := let mod_pow (a : int) (e : int) (p : int) : int = failwith (""unimplemented"") let egcd (a : int) (p : int) : int * int = failwith (""unimplemented"") - let nth = let rec nth (n, l, default : nat * int list * int) : int = + let nth = let rec nth (n, l, default : nat * int list * int) : int = if n = 0n then (match l with - [] -> default + [] -> default | x :: r -> x) else let m = predN n in (match l with - [] -> default + [] -> default | x :: t -> (nth (m, t, default))) in fun (n:nat) (l:int list) (default:int) -> nth (n, l, default) @@ -121,22 +122,22 @@ Definition extra_ops := else (predN n, b :: a)) (n,([] : int list)) l in r - let skipn = let rec skipn (n, l : nat * int list) : int list = + let skipn = let rec skipn (n, l : nat * int list) : int list = if n = 0n then l else let n0 = predN n in (match l with - | [] -> ([]:int list) + | [] -> ([]:int list) | a :: l0 -> (skipn (n0, l0 : nat * int list))) in fun (n : nat) (l : int list) -> skipn (n, l : nat * int list)". Definition existsb_def := - "(let existsb (f : voterInfo -> bool) = let rec existsb (l: voterInfo list) : bool = + "(let existsb (f : voterInfo -> bool) = let rec existsb (l: voterInfo list) : bool = match l with - [] -> false + [] -> false | a :: l0 -> (if (f a) then true else (existsb (l0))) in fun (l: voterInfo list) -> existsb (l) in existsb)". -Definition hash_func_def := "let hash_func (l : (nat) list) = addN 1n (List.fold_left (fun (a, p : nat * nat) -> Bitwise.xor p a) 1n l)". +Definition hash_func_def := "let hash_func (l : (nat) list) = addN 1n (List.fold_left (fun (a, p : nat * nat) -> Bitwise.xor p a) 1n l)". Definition callctx := "(Tezos.sender,(Tezos.self_address,(Tezos.amount,Tezos.balance)))". @@ -301,7 +302,7 @@ Definition TT_rename : list (string * string) := ; ("true", "true") ; ("false", "false") ; ("hash", "hash_") - ; (String.to_string (string_of_kername <%% BV.State %%>), "state") (* we add [storage] so it is printed without the prefix *) + ; (String.to_string (string_of_kername <%% BV.State %%>), "state") (* we add [storage] so it is printed without the prefix *) ; ("tt", "()") ]. diff --git a/examples/boardroomVoting/BoardroomVotingExtractionLiquidity.v b/examples/boardroomVoting/BoardroomVotingExtractionLiquidity.v index d8a094d9..e8ab425e 100644 --- a/examples/boardroomVoting/BoardroomVotingExtractionLiquidity.v +++ b/examples/boardroomVoting/BoardroomVotingExtractionLiquidity.v @@ -3,7 +3,7 @@ (** NOTE: Currently does not compile due to some restrictions on closures in Liquidity. Moreover, the printing of literals might need adjustments. *) From MetaCoq.Template Require Import All. -From ConCert.Extraction Require Import LPretty. +From ConCert.Extraction Require Import LiquidityPretty. From ConCert.Extraction Require Import LiquidityExtract. From ConCert.Extraction Require Import Common. From ConCert.Execution Require Import Blockchain. @@ -42,6 +42,8 @@ Definition hash_func (l : list positive) : positive := N.succ_pos (fold_left (fun a p => N.lxor (Npos p) a) l oneN). Definition AddrSize := (2^128)%N. + +#[local] Instance Base : ChainBase := LocalBlockchain.LocalChainBase AddrSize. Module Params <: BoardroomParams. @@ -94,15 +96,15 @@ Definition receive_wrapper (msg : msg) Definition dummy_init : init_ctx -> BV.Setup -> result BV.State Error := fun _ _ => Err default_error. Definition dummy_receive : msg -> BV.State -> result (list ActionBody × BV.State) Error := - fun m s => - let x := handle_signup 0 (0, 0) s s.(owner) 0%nat in + fun m s => + let x := handle_signup 0 (0, 0) s s.(owner) 0%nat in Err default_error. Definition storage_alias := "type storage = state". Definition bruteforce_tally_def := - "let bruteforce_tally_aux = - let rec bruteforce_tally_aux (n, votes_product) = + "let bruteforce_tally_aux = + let rec bruteforce_tally_aux (n, votes_product) = if elmeqb (pow_p generator (int n)) votes_product then Some (n) else if n = 0p then @@ -120,12 +122,12 @@ Definition extra_ops := n let predN (n : nat) = unsafe_int_to_nat (n - 1p) - let nth = let rec nth (n, l, default) = + let nth = let rec nth (n, l, default) = if n = 0p then (match l with - [] -> default + [] -> default | x :: l' -> x) else let m = predN n in (match l with - [] -> default + [] -> default | x :: t -> (nth (m, t, default))) in fun n l default -> nth (n, l, default) @@ -138,20 +140,20 @@ Definition extra_ops := else (predN n, b :: a)) l (n,[]) in List.rev r - let skipn = let rec skipn (n, l) = + let skipn = let rec skipn (n, l) = if n = 0p then l else let n0 = predN n in (match l with - [] -> [] + [] -> [] | a :: l0 -> (skipn (n0, l0))) in fun n l -> skipn (n, l) - let existsb (f : 'a -> bool) = let rec existsb (l) = + let existsb (f : 'a -> bool) = let rec existsb (l) = match l with - [] -> false + [] -> false | a :: l0 -> (if (f a) then true else (existsb (l0))) in fun l -> existsb (l)". -Definition hash_func_def := "let hash_func (l : ( (nat) list)) = addNat 1p (List.fold (fun (p,a) -> lxorNat p a) l 1p)". +Definition hash_func_def := "let hash_func (l : ((nat) list)) = addNat 1p (List.fold (fun (p,a) -> lxorNat p a) l 1p)". Definition BV_MODULE : LiquidityMod msg init_ctx BV.Setup BV.State ActionBody Error := @@ -343,7 +345,7 @@ Definition TT_rename : list (string * string) := ; ("nil", "[]") ; ("true", "true") ; ("false", "false") - ; (String.to_string (string_of_kername <%% BV.State %%>), "state") (* we add [storage] so it is printed without the prefix *) + ; (String.to_string (string_of_kername <%% BV.State %%>), "state") (* we add [storage] so it is printed without the prefix *) ; ("tt", "()") ]. diff --git a/examples/boardroomVoting/BoardroomVotingTest.v b/examples/boardroomVoting/BoardroomVotingTest.v index 7be93a0f..ec16eeac 100644 --- a/examples/boardroomVoting/BoardroomVotingTest.v +++ b/examples/boardroomVoting/BoardroomVotingTest.v @@ -44,6 +44,7 @@ Module ZAxiomParams <: BoardroomAxiomsZParams. End ZAxiomParams. Module BVZAxioms := BoardroomAxiomsZ ZAxiomParams. Import BVZAxioms. +#[local] Existing Instance boardroom_axioms_Z. Lemma generator_nonzero : generator !== 0. @@ -54,6 +55,7 @@ Axiom generator_is_generator : ~(z == 0) -> exists! (e : Z), (0 <= e < order - 1)%Z /\ pow generator e == z. +#[local] Instance generator_instance : Generator boardroom_axioms_Z := {| BoardroomMath.generator := generator; BoardroomMath.generator_nonzero := generator_nonzero; @@ -91,7 +93,9 @@ Definition hash_func (l : list positive) : positive := Definition AddrSize := (2^128)%N. +#[local] Instance Base : ChainBase := LocalChainBase AddrSize. +#[local] Instance ChainBuilder : ChainBuilderType := LocalChainBuilderImpl AddrSize true. Module Params <: BoardroomParams. @@ -180,4 +184,4 @@ Definition boardroom_example : option nat := do state <- contract_state (lcb_lc chain) caddr; BV.tally state. -Check (@eq_refl (option nat) (Some votes_for)) <<: boardroom_example = Some votes_for. +Check (@eq_refl (option nat) (Some votes_for)) <: boardroom_example = Some votes_for. diff --git a/examples/boardroomVoting/BoardroomVotingZ.v b/examples/boardroomVoting/BoardroomVotingZ.v index a26b7765..b9c5696b 100644 --- a/examples/boardroomVoting/BoardroomVotingZ.v +++ b/examples/boardroomVoting/BoardroomVotingZ.v @@ -28,6 +28,7 @@ End BoardroomParams. Module BoardroomVoting (Params : BoardroomParams). Import Params. + #[export] Existing Instance Base. Definition A := Z. @@ -250,7 +251,7 @@ Module BoardroomVoting (Params : BoardroomParams). do assert_some (AddressMap.find caller (eligible_voters (setup state))); do assert_none (AddressMap.find caller (registered_voters state)); do amt <- lift call_amount; - do assert_true (amount_eqb amt (registration_deposit (setup state)))%Z; + do assert_true (amount_eqb amt (registration_deposit (setup state)))%Z; do assert_true (Z.of_nat (length (public_keys state)) if elmeqb (public_vote vi) 0 then true else false) voters); let votes := map public_vote voters in - do res <- @lift _ (fun T => result T Error) _ _ (bruteforce_tally votes); + do res <- @lift _ (fun T => result T Error) _ _ (bruteforce_tally votes); accept_call (state<|tally := Some res|>). Definition receive : ContractReceiverStateMsgState := @@ -346,7 +347,7 @@ Module BoardroomVoting (Params : BoardroomParams). (* Chosen random d for vote proof *) svi_sv_d : Z; }. - + (* begin hide *) MetaCoq Run (make_setters SecretVoterInfo). (* end hide *) diff --git a/examples/boardroomVoting/Egcd.v b/examples/boardroomVoting/Egcd.v index 97477d5e..f1d19ee3 100644 --- a/examples/boardroomVoting/Egcd.v +++ b/examples/boardroomVoting/Egcd.v @@ -153,14 +153,14 @@ Lemma mul_fst_egcd a n : Proof. pose proof (egcd_spec a n). destruct (Z.eqb_spec n 0) as [->|?]. - { intros. cbn in *. rewrite !Zmod_0_r. + { intros. cbn in *. rewrite !Zmod_0_r. rewrite <- Zgcd_1_rel_prime in *. rewrite Z.gcd_0_r in *. - unfold egcd. destruct (Z.eqb_spec a 0) as [->|?];cbn;lia. } + unfold egcd. destruct (Z.eqb_spec a 0) as [->|?]; cbn; lia. } intros relprime. destruct (egcd a n) as [x y]; cbn. rewrite (proj2 (Zgcd_1_rel_prime _ _) relprime) in H. - replace (a * x) with (1 + (-y)*n) by lia. + replace (a * x) with (1 + (-y)*n) by lia. rewrite <- Z.add_mod_idemp_r by lia. now rewrite Z.mod_mul, Z.add_0_r by lia. Qed. diff --git a/examples/boardroomVoting/Euler.v b/examples/boardroomVoting/Euler.v index 45dacebf..c68490d3 100644 --- a/examples/boardroomVoting/Euler.v +++ b/examples/boardroomVoting/Euler.v @@ -87,6 +87,7 @@ Fixpoint prod (l : list Z) : Z := | x :: xs => x * prod xs end. +#[local] Instance prod_perm_proper : Proper (@Permutation Z ==> eq) prod. Proof. intros l l' perm. diff --git a/examples/cis1/CIS1Spec.v b/examples/cis1/CIS1Spec.v index 8aa90098..bbec0c57 100644 --- a/examples/cis1/CIS1Spec.v +++ b/examples/cis1/CIS1Spec.v @@ -89,6 +89,7 @@ Module ReceiveHook (cis1_types : CIS1Types). Import cis1_types. + #[export] Existing Instance serializable_token_id. (** NOTE: there is no notion of the contract name in ConCert; [AdditionalData] is not @@ -114,7 +115,7 @@ End ReceiveHook. (** * Views *) (** A module type that defines a view interface. The interface specifies functions for - observing the contract's state. These functions are used to define the specification. *) + observing the contract's state. These functions are used to define the specification. *) Module Type CIS1View (cis1_types : CIS1Types). Import cis1_types. @@ -127,7 +128,7 @@ Module Type CIS1View (cis1_types : CIS1Types). Parameter get_operators : Storage -> Address -> list Address. - Parameter get_owners : Storage -> TokenID -> list Address. + Parameter get_owners : Storage -> TokenID -> list Address. Axiom get_owners_no_dup : forall st token_id, NoDup (get_owners st token_id). @@ -165,8 +166,8 @@ Module CIS1ViewExtra (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). match o as o' return (o' = o -> _) with | Some bal => fun _ => bal | None => fun heq => - False_rect _ (ltac:(intros;subst o; unfold get_balance in *;rewrite p in *; - destruct (get_balance_opt st token_id addr);congruence)) + False_rect _ (ltac:(intros; subst o; unfold get_balance in *; rewrite p in *; + destruct (get_balance_opt st token_id addr); congruence)) end eq_refl. End CIS1ViewExtra. @@ -185,7 +186,7 @@ Module CIS1Axioms (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). (** * Contract functions *) - (** First, we specify data types that represent input parameters for all entry points *) + (** First, we specify data types that represent input parameters for all entry points *) (** NOTE: not handling additional data at the moment *) Record CIS1_transfer_data `{ChainBase} := @@ -267,7 +268,7 @@ Module CIS1Axioms (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). get_balance_opt next_st other_token_id addr = get_balance_opt prev_st other_token_id addr) /\ (** Token ids are preserved by a single transfer *) (forall token_id, - token_id_exists prev_st token_id = token_id_exists next_st token_id) /\ + token_id_exists prev_st token_id = token_id_exists next_st token_id) /\ (** CIS1: Let operator be an operator of the address owner. A transfer of any amount of a token type from an address owner sent by an address operator MUST be executed as if the transfer was sent by owner. *) @@ -347,7 +348,7 @@ the given token type between balances. *) (** *** Requirements *) (** A specification for the update of a single operator *) - Definition updateOperator_single_spec `{ChainBase} (ctx : ContractCallContext) (prev_st next_st : Storage) (p : CIS1_updateOperator_update) : Prop := + Definition updateOperator_single_spec `{ChainBase} (ctx : ContractCallContext) (prev_st next_st : Storage) (p : CIS1_updateOperator_update) : Prop := match p.(cis1_ou_update_kind) with | cis1_ou_remove_operator => let addr := p.(cis1_ou_operator_address) in @@ -383,7 +384,7 @@ the given token type between balances. *) (ret_ops : list ActionBody) := { updateOperator_token_ids_preserved : forall token_id, - token_id_exists prev_st token_id = token_id_exists next_st token_id; + token_id_exists prev_st token_id = token_id_exists next_st token_id; updateOperator_balances_preserved : forall addr token_id, get_balance_opt prev_st token_id addr = get_balance_opt next_st token_id addr; @@ -427,7 +428,7 @@ the given token type between balances. *) balanceOf_token_ids_preserved : forall token_id, - token_id_exists prev_st token_id = token_id_exists next_st token_id; + token_id_exists prev_st token_id = token_id_exists next_st token_id; balanceOf_balances_preserved : forall token_id addr, get_balance_opt next_st token_id addr = get_balance_opt prev_st token_id addr; @@ -460,7 +461,7 @@ Module Type CIS1ReceiveSpec (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_ Parameter get_contract_msg : forall `{ChainBase}, CIS1_entry_points -> Msg. (** This axiom captures the intuition that a contact that implements CIS1 can handle _at least_ - [CIS1_entry_points]. *) + [CIS1_entry_points]. *) Axiom left_inverse_get_CIS1_entry_point : forall `{ChainBase} (entry_point : CIS1_entry_points), get_CIS1_entry_point (get_contract_msg entry_point) = Some entry_point. @@ -489,7 +490,7 @@ Module Type CIS1ReceiveSpec (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_ End CIS1ReceiveSpec. -(** * CIS1 properties *) +(** * CIS1 properties *) (** ** Operator updates *) @@ -519,8 +520,8 @@ Module CIS1Operators (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). intros ? ? ? ? ? ? ? ? H. simpl in *. destruct H as [st1 [Hst1 [st2 [Hst2 Heq]]]]. subst. cbn in *. destruct Hst1. destruct Hst2 as [H2 ?]. - destruct (address_eqb_spec addr1 addr2);subst;auto. - apply H2;auto. + destruct (address_eqb_spec addr1 addr2); subst; auto. + apply H2; auto. Qed. Lemma compose_updateOperator_add_remove_same : @@ -596,7 +597,7 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). end. - (** We sum up all the balances for a given [token_id] for a list of [owners] *) + (** We sum up all the balances for a given [token_id] for a list of [owners] *) Definition sum_balances `{ChainBase} (st : Storage) (token_id : TokenID) (owners : list Address) := fold_right (fun addr s => get_balance_default st token_id addr + s) 0 owners. @@ -610,38 +611,38 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). intros Hin. destruct Hin as [Hin | Hbal]. revert dependent owner. - -induction owners;intros owner Hin Hnodup. + -induction owners; intros owner Hin Hnodup. + inversion Hin. - + inversion Hin;subst;clear Hin. + + inversion Hin; subst; clear Hin. * simpl. - destruct (addr_eq_dec owner owner);try congruence. - inversion Hnodup;subst;clear Hnodup. + destruct (addr_eq_dec owner owner); try congruence. + inversion Hnodup; subst; clear Hnodup. now rewrite not_in_remove_same. - * inversion Hnodup;subst;clear Hnodup. + * inversion Hnodup; subst; clear Hnodup. simpl. destruct (addr_eq_dec owner a). ** easy. - ** simpl. rewrite (IHowners owner);auto;lia. - - rewrite Hbal;cbn. - induction owners; intros Hnodup;auto;inversion Hnodup;subst;clear Hnodup. - simpl. destruct (addr_eq_dec owner a);subst;simpl;easy. + ** simpl. rewrite (IHowners owner); auto; lia. + - rewrite Hbal; cbn. + induction owners; intros Hnodup; auto; inversion Hnodup; subst; clear Hnodup. + simpl. destruct (addr_eq_dec owner a); subst; simpl; easy. Qed. (* begin hide *) - (** An auxiliary lemma. *) Lemma sum_of_balances_eq `{ChainBase} addrs prev_st next_st token_id : (forall addr, In addr addrs ->get_balance_default next_st token_id addr = get_balance_default prev_st token_id addr) -> sum_balances next_st token_id addrs = sum_balances prev_st token_id addrs. Proof. intros Hbal. - induction addrs;simpl in *;intuition;auto. + induction addrs; simpl in *; intuition; auto. Qed. (* end hide *) - + #[export] Hint Resolve remove_In not_in_remove_same not_in_remove remove_remove neq_not_removed : hints. - Hint Resolve remove_extensional : hints. + #[export] + Hint Resolve remove_extensional NoDup_remove In_remove : hints. (* begin hide *) (** A technical lemma: the sum of balances is the same for two lists of owners containing the @@ -654,24 +655,24 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). Proof. intros Hnodup1 Hnodup2 Hiff. revert dependent owners2. - induction owners1;intros. - + cbn in *. destruct owners2;auto. - destruct (Hiff a);cbn in *;intuition. + induction owners1; intros. + + cbn in *. destruct owners2; auto. + destruct (Hiff a); cbn in *; intuition. + simpl. - destruct (Hiff a) as [H1 H2];cbn in *. + destruct (Hiff a) as [H1 H2]; cbn in *. specialize (H1 (or_introl eq_refl)) as HH. - rewrite remove_owner with (st := st) (owner := a) (owners:=owners2);auto with hints. - inversion Hnodup1;subst. - rewrite IHowners1 with (owners2 := (remove addr_eq_dec a owners2));eauto with hints. + rewrite remove_owner with (st := st) (owner := a) (owners := owners2); auto with hints. + inversion Hnodup1; subst. + rewrite IHowners1 with (owners2 := (remove addr_eq_dec a owners2)); eauto with hints. intros. split. * intros Hin. - destruct (Hiff addr) as [HH1 HH2];cbn in *. + destruct (Hiff addr) as [HH1 HH2]; cbn in *. specialize (HH1 (or_intror Hin)) as HH1. destruct (address_eqb_spec a addr). ** now subst. ** auto with hints. * intros Hin. - destruct (Hiff addr);cbn in *. + destruct (Hiff addr); cbn in *. destruct (address_eqb_spec a addr). ** assert (~ In addr (remove addr_eq_dec a owners2)). { intros Hin0. subst. apply (remove_In _ _ _ Hin0). } @@ -692,7 +693,7 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). Proof. intros. erewrite sum_of_balances_eq by eauto. - apply sum_balances_extensional;auto. + apply sum_balances_extensional; auto. Qed. Lemma get_balance_opt_default `{ChainBase} next_st prev_st token_id addr : @@ -703,14 +704,14 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). intros Hids Hopt. unfold get_balance_default,get_balance. rewrite Hids. - destruct (token_id_exists next_st token_id);auto. + destruct (token_id_exists next_st token_id); auto. destruct (get_balance_opt next_st token_id addr) eqn:Heq1; - destruct (get_balance_opt prev_st token_id addr) eqn:Heq2;auto; - inversion H;try congruence. + destruct (get_balance_opt prev_st token_id addr) eqn:Heq2; auto; + inversion H; try congruence. Qed. - (** The owners are the same in two states if the balances agree. We generalise the statement to cover the case when we ignore certain addresses given by [ignore_addrs]. *) - Lemma same_owners_remove_all `{ChainBase} token_id ignore_addrs next_st prev_st : + (** The owners are the same in two states if the balances agree. We generalise the statement to cover the case when we ignore certain addresses given by [ignore_addrs]. *) + Lemma same_owners_remove_all `{ChainBase} token_id ignore_addrs next_st prev_st : (forall addr1, ~ In addr1 ignore_addrs -> get_balance_opt next_st token_id addr1 = get_balance_opt prev_st token_id addr1) -> (forall addr1, In addr1 (remove_all addr_eq_dec ignore_addrs (get_owners next_st token_id)) @@ -718,47 +719,48 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). Proof. intros H0 addr1. assert (Hdec : forall (a1 a2 : Address), a1 = a2 \/ a1 <> a2). - { intros. destruct (addr_eq_dec a1 a2);auto. } + { intros. destruct (addr_eq_dec a1 a2); auto. } split. + intros Hin. - destruct (ListDec.In_decidable Hdec addr1 ignore_addrs) as [Hin_addrs | Hnotin_addrs];subst. + destruct (ListDec.In_decidable Hdec addr1 ignore_addrs) as [Hin_addrs | Hnotin_addrs]; subst. * exfalso. assert (Hall : Forall (fun x =>~In x (remove_all addr_eq_dec ignore_addrs ((get_owners next_st token_id)))) ignore_addrs) by apply remove_all_In. - rewrite Forall_forall in Hall;easy. + rewrite Forall_forall in Hall; easy. * specialize (H0 _ Hnotin_addrs). - destruct (get_balance_opt next_st token_id addr1) eqn:Hnext;inversion Hnext. - ** apply remove_all_not_in_to_remove;auto. apply get_owners_balances;eauto. - ** apply In_remove_all in Hin;auto. - apply get_owners_balances in Hin;destruct Hin;congruence. + destruct (get_balance_opt next_st token_id addr1) eqn:Hnext; inversion Hnext. + ** apply remove_all_not_in_to_remove; auto. apply get_owners_balances; eauto. + ** apply In_remove_all in Hin; auto. + apply get_owners_balances in Hin; destruct Hin; congruence. + intros Hin. - destruct (ListDec.In_decidable Hdec addr1 ignore_addrs) as [Hin_addrs | Hnotin_addrs];subst. + destruct (ListDec.In_decidable Hdec addr1 ignore_addrs) as [Hin_addrs | Hnotin_addrs]; subst. * exfalso. assert (Hall : Forall (fun x =>~In x (remove_all addr_eq_dec ignore_addrs ((get_owners prev_st token_id)))) ignore_addrs) by apply remove_all_In. - rewrite Forall_forall in Hall;easy. + rewrite Forall_forall in Hall; easy. * specialize (H0 _ Hnotin_addrs). - destruct (get_balance_opt next_st token_id addr1) eqn:Hnext;inversion Hnext. - ** apply remove_all_not_in_to_remove;auto. apply get_owners_balances;eauto. - ** apply In_remove_all in Hin;auto. - apply get_owners_balances in Hin;destruct Hin;congruence. + destruct (get_balance_opt next_st token_id addr1) eqn:Hnext; inversion Hnext. + ** apply remove_all_not_in_to_remove; auto. apply get_owners_balances; eauto. + ** apply In_remove_all in Hin; auto. + apply get_owners_balances in Hin; destruct Hin; congruence. Qed. (** Any address either in the list of owners, or owns zero tokens. *) - Lemma in_owners_or_zero_balance_default `{ChainBase} st token_id owner : + Lemma in_owners_or_zero_balance_default `{ChainBase} st token_id owner : In owner (get_owners st token_id) \/ get_balance_default st token_id owner = 0. Proof. assert (Hdec : forall (a1 a2 : Address), a1 = a2 \/ a1 <> a2). - { intros. destruct (addr_eq_dec a1 a2);auto. } - destruct (ListDec.In_decidable Hdec owner (get_owners st token_id)) as [Hin_addrs | Hnotin_addrs];subst;auto. + { intros. destruct (addr_eq_dec a1 a2); auto. } + destruct (ListDec.In_decidable Hdec owner (get_owners st token_id)) as [Hin_addrs | Hnotin_addrs]; subst; auto. right. unfold get_balance_default,get_balance. - destruct (token_id_exists st token_id);auto. + destruct (token_id_exists st token_id); auto. cbn. - destruct (get_balance_opt st token_id owner) eqn:Heq;auto. - assert (In owner (get_owners st token_id)) by (apply get_owners_balances;eauto). + destruct (get_balance_opt st token_id owner) eqn:Heq; auto. + assert (In owner (get_owners st token_id)) by (apply get_owners_balances; eauto). easy. Qed. + #[export] Hint Resolve in_owners_or_zero_balance_default get_owners_no_dup : hints. Lemma get_balance_total_get_balance_default `{ChainBase} st token_id p owner: @@ -768,6 +770,7 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). now destruct (get_balance_opt st token_id _). Qed. + #[export] Hint Constructors transfer_spec : hints. (** We can recover a statement for the whole "batch" of transfers from the transfers spec where @@ -776,23 +779,23 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). let params := Build_CIS1_transfer_params _ transfers in transfer_spec ctx params prev_st next_st ops -> forall token_id, - token_id_exists prev_st token_id = token_id_exists next_st token_id. + token_id_exists prev_st token_id = token_id_exists next_st token_id. Proof. revert dependent prev_st. revert dependent ops. cbn. induction transfers. - intros ops prev_st spec token_id. - destruct spec. cbn in *;now subst. + destruct spec. cbn in *; now subst. - intros ops prev_st spec token_id. destruct spec as [Htrans Hcalls]. cbn in *. destruct Htrans as [st [? [? [Hsingle ?]]]]. transitivity (token_id_exists st token_id). * now destruct Hsingle. * destruct (address_is_contract (cis1_td_to a)). - ** inversion Hcalls;subst. - eapply IHtransfers;eauto with hints. - ** eapply IHtransfers;eauto with hints. + ** inversion Hcalls; subst. + eapply IHtransfers; eauto with hints. + ** eapply IHtransfers; eauto with hints. Qed. (** The balances of all token-address pairs NOT mentioned in the transfer batch remain unchanged @@ -802,15 +805,15 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). transfer_spec ctx params prev_st next_st ops -> forall addr token_id, ~ In (token_id, addr) (transfer_from params) -> - ~ In (token_id, addr) (transfer_to params) -> + ~ In (token_id, addr) (transfer_to params) -> get_balance_opt prev_st token_id addr = get_balance_opt next_st token_id addr. Proof. revert dependent next_st. revert dependent prev_st. revert dependent ops. induction transfers. - - cbn;intros ops prev_st next_st spec addr token_id. - destruct spec. cbn in *;now subst. + - cbn; intros ops prev_st next_st spec addr token_id. + destruct spec. cbn in *; now subst. - intros ops prev_st next_st ? spec addr token_id Hfrom Hto. destruct spec as [Htr Hcalls]. destruct Htr as [st [p [q [Hsingle Htrs]]]]. @@ -828,7 +831,7 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). + cbn in *. destruct (address_is_contract (cis1_td_to a)); inversion Hcalls; - eapply IHtransfers;now subst;firstorder. + eapply IHtransfers; now subst; firstorder. Qed. (** If the properties of the single transfer holds (the transfer succeeds), then @@ -865,43 +868,43 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). destruct (address_eqb_spec from to) as [Haddr | Haddr]. + subst. rewrite remove_owner with (st := prev_st) (owner := to) - by (subst owners1;auto with hints). + by (subst owners1; auto with hints). rewrite remove_owner with (st := next_st) (owner := to) - by (subst owners2;auto with hints). + by (subst owners2; auto with hints). assert (HH : sum_balances next_st token_id (remove addr_eq_dec to owners2) = sum_balances prev_st token_id (remove addr_eq_dec to owners1)). - { apply sum_of_balances_eq_extensional;subst owners2;subst owners1;eauto with hints. + { apply sum_of_balances_eq_extensional; subst owners2; subst owners1; eauto with hints. intros addr. - apply same_owners_remove_all with (ignore_addrs:=[to]);intros;cbn in *;intuition;eauto. + apply same_owners_remove_all with (ignore_addrs := [to]); intros; cbn in *; intuition; eauto. intros addr Haddr. unfold is_true in *. - apply get_balance_opt_default;try congruence. - destruct (address_eqb_spec addr to);subst. exfalso;apply (remove_In _ _ _ Haddr). + apply get_balance_opt_default; try congruence. + destruct (address_eqb_spec addr to); subst. exfalso; apply (remove_In _ _ _ Haddr). eauto. } repeat rewrite get_balance_total_get_balance_default in Htransfer, Hself_transfer. specialize (Hself_transfer eq_refl). lia. + rewrite remove_owner with (st := prev_st) (owner := from) - by (subst owners1;auto with hints). + by (subst owners1; auto with hints). rewrite remove_owner with (st := prev_st) (owner := to) - by (assert (In to owners1 \/ get_balance_default prev_st token_id to = 0); subst owners1;auto with hints;intuition;auto with hints). + by (assert (In to owners1 \/ get_balance_default prev_st token_id to = 0); subst owners1; auto with hints; intuition; auto with hints). rewrite remove_owner with (st := next_st) (owner := from) - by (subst owners2;auto with hints). + by (subst owners2; auto with hints). rewrite remove_owner with (st := next_st) (owner := to) by (assert (In to owners2 \/ get_balance_default next_st token_id to = 0); - subst owners2;auto with hints;intuition;auto with hints). + subst owners2; auto with hints; intuition; auto with hints). specialize (Htransfer Haddr). destruct Htransfer as [Hfrom Hto]. repeat rewrite get_balance_total_get_balance_default in Hfrom,Hto. rewrite Hfrom. rewrite Hto. assert (HH : sum_balances next_st token_id (remove addr_eq_dec to (remove addr_eq_dec from owners2)) = sum_balances prev_st token_id (remove addr_eq_dec to (remove addr_eq_dec from owners1))). - { apply sum_of_balances_eq_extensional;subst owners2;subst owners1;eauto with hints. - apply same_owners_remove_all with (ignore_addrs:=[to;from]);intros;cbn in *;intuition;eauto. + { apply sum_of_balances_eq_extensional; subst owners2; subst owners1; eauto with hints. + apply same_owners_remove_all with (ignore_addrs := [to; from]); intros; cbn in *; intuition; eauto. intros addr Haddr0. unfold is_true in *. - apply get_balance_opt_default;try congruence. - destruct (address_eqb_spec addr to);subst. exfalso;apply (remove_In _ _ _ Haddr0). - destruct (address_eqb_spec addr from);subst. apply In_remove in Haddr0; auto. exfalso;apply (remove_In _ _ _ Haddr0). + apply get_balance_opt_default; try congruence. + destruct (address_eqb_spec addr to); subst. exfalso; apply (remove_In _ _ _ Haddr0). + destruct (address_eqb_spec addr from); subst. apply In_remove in Haddr0; auto. exfalso; apply (remove_In _ _ _ Haddr0). eauto. } lia. Qed. @@ -923,7 +926,7 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). revert dependent prev_st. revert dependent next_st. revert dependent ops. - induction transfers;intros ops ? next_st prev_st Htr ? ?. + induction transfers; intros ops ? next_st prev_st Htr ? ?. - cbn in *. now subst. - cbn in *. destruct Htr as [st [p [q [Hsingle Htrs]]]]. @@ -932,15 +935,15 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). * subst. symmetry. now eapply transfer_single_spec_preserves_balances with (next_st := st). * destruct Hsingle as [? [HH [? ?]]]. - apply sum_of_balances_eq_extensional;subst owners2;subst owners1;eauto with hints. + apply sum_of_balances_eq_extensional; subst owners2; subst owners1; eauto with hints. ** intros. repeat rewrite get_owners_balances. now rewrite HH. ** intros. - apply get_balance_opt_default;symmetry;auto. + apply get_balance_opt_default; symmetry; auto. + cbn in *. destruct (address_is_contract (cis1_td_to a)); inversion Hcalls; - eapply IHtransfers;now subst;firstorder. + eapply IHtransfers; now subst; firstorder. Qed. Lemma balanceOf_preserves_sum_of_balances `{ChainBase} params prev_st next_st token_id ops @@ -952,7 +955,7 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). Proof. intros ??. destruct spec as [H1 H2 H3 H4]. clear H4. - apply sum_of_balances_eq_extensional;subst owners1 owners2;auto with hints. + apply sum_of_balances_eq_extensional; subst owners1 owners2; auto with hints. intros. now apply same_owners_remove_all with (ignore_addrs := []). intros. now apply get_balance_opt_default. Qed. @@ -966,7 +969,7 @@ Module CIS1Balances (cis1_types : CIS1Types) (cis1_view : CIS1View cis1_types). Proof. intros ??. destruct spec as [H1 H2 H3]. - apply sum_of_balances_eq_extensional;subst owners1 owners2;auto with hints. + apply sum_of_balances_eq_extensional; subst owners1 owners2; auto with hints. intros. now apply same_owners_remove_all with (ignore_addrs := []). intros. now apply get_balance_opt_default. Qed. diff --git a/examples/cis1/CIS1Utils.v b/examples/cis1/CIS1Utils.v index e2714ec2..deb7df79 100644 --- a/examples/cis1/CIS1Utils.v +++ b/examples/cis1/CIS1Utils.v @@ -10,7 +10,7 @@ Module RemoveProperties. induction l. + auto. + intros Hnotin. cbn in *. - destruct (eq_dec x a);intuition;congruence. + destruct (eq_dec x a); intuition; congruence. Qed. Lemma not_in_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x y : A): @@ -19,35 +19,37 @@ Module RemoveProperties. induction l. + auto. + intros Hnotin. cbn in *. - destruct (eq_dec y a);cbn in *;intuition;auto. + destruct (eq_dec y a); cbn in *; intuition; auto. Qed. Lemma remove_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x y : A) : ~ In x (remove eq_dec y (remove eq_dec x l)). Proof. - induction l;auto;simpl in *. - destruct (eq_dec x a);subst;intuition;simpl in *. - destruct (eq_dec y a);subst;intuition;simpl in *. - intuition;simpl in *. + induction l; auto; simpl in *. + destruct (eq_dec x a); subst; intuition; simpl in *. + destruct (eq_dec y a); subst; intuition; simpl in *. + intuition; simpl in *. Qed. Lemma In_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x y : A) : x <> y -> In x (remove eq_dec y l) -> In x l. Proof. - induction l;intros Hneq Hin; auto;simpl in *. - subst. destruct (eq_dec y a);subst;cbn in *; auto;intuition;auto. + induction l; intros Hneq Hin; auto; simpl in *. + subst. destruct (eq_dec y a); subst; cbn in *; auto; intuition; auto. Qed. Lemma neq_not_removed {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x y : A) : x <> y -> In x l -> In x (remove eq_dec y l). Proof. - induction l;intros Hneq Hin; auto;simpl in *. + induction l; intros Hneq Hin; auto; simpl in *. destruct Hin. - + subst. destruct (eq_dec y x);subst;cbn;auto;try congruence. - + destruct (eq_dec y a);cbn;auto. + + subst. destruct (eq_dec y x); subst; cbn; auto; try congruence. + + destruct (eq_dec y a); cbn; auto. Qed. + #[local] Hint Constructors NoDup : hints. + #[local] Hint Resolve In_remove remove_In not_in_remove_same not_in_remove remove_remove neq_not_removed : hints. Fixpoint remove_all {A} (eq_dec : forall x y : A, {x = y} + {x <> y}) (to_remove : list A) (xs : list A) := @@ -60,8 +62,8 @@ Module RemoveProperties. Forall (fun x => ~ In x (remove_all eq_dec to_remove xs)) to_remove. Proof. revert dependent xs. - induction to_remove;simpl;auto. - constructor;eauto with hints. + induction to_remove; simpl; auto. + constructor; eauto with hints. unshelve eapply (@Forall_impl _ _ _ _ _ (IHto_remove xs)). intros x H HH. apply (not_in_remove _ _ _ _ H HH). @@ -70,25 +72,26 @@ Module RemoveProperties. Lemma In_remove_all {A} (eq_dec : forall x y : A, {x = y} + {x <> y}) (to_remove : list A) (xs : list A) (x : A): ~ (In x to_remove) -> In x (remove_all eq_dec to_remove xs) -> In x xs. Proof. - induction to_remove;cbn in *;intuition;eauto with hints. + induction to_remove; cbn in *; intuition; eauto with hints. Qed. Lemma remove_all_not_in_to_remove {A} (eq_dec : forall x y : A, {x = y} + {x <> y}) (to_remove : list A) (xs : list A) (x : A): ~ (In x to_remove) -> In x xs -> In x (remove_all eq_dec to_remove xs). Proof. intros H1 H2. - induction to_remove;cbn in *;intuition;eauto with hints. + induction to_remove; cbn in *; intuition; eauto with hints. Qed. Lemma NoDup_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x : A) : NoDup l -> NoDup (remove eq_dec x l). Proof. - induction l;intros H0;auto;simpl. - inversion H0; destruct (eq_dec x a);subst;intuition;simpl in *;eauto with hints. + induction l; intros H0; auto; simpl. + inversion H0; destruct (eq_dec x a); subst; intuition; simpl in *; eauto with hints. Qed. + #[local] Hint Resolve NoDup_remove : hints. - + #[local] Hint Resolve In_remove : hints. Lemma remove_extensional {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l1 l2 : list A) (y : A) : @@ -97,13 +100,13 @@ Module RemoveProperties. intros H x. split. + intros Hin. - destruct (eq_dec x y);subst. + destruct (eq_dec x y); subst. * exfalso. apply (remove_In _ _ _ Hin). - * destruct (H x);intuition;eauto with hints. + * destruct (H x); intuition; eauto with hints. + intros Hin. - destruct (eq_dec x y);subst. + destruct (eq_dec x y); subst. * exfalso. apply (remove_In _ _ _ Hin). - * destruct (H x);intuition;eauto with hints. + * destruct (H x); intuition; eauto with hints. Qed. End RemoveProperties. diff --git a/examples/cis1/Cis1wccd.v b/examples/cis1/Cis1wccd.v index 2acb8738..839736ac 100644 --- a/examples/cis1/Cis1wccd.v +++ b/examples/cis1/Cis1wccd.v @@ -56,8 +56,8 @@ Section WccdToken. (** The state tracked for each address.*) Record AddressState := { - wccd_balance: TokenAmount; - wccd_operators: list Address + wccd_balance : TokenAmount; + wccd_operators : list Address }. (* begin hide *) @@ -102,7 +102,7 @@ Section WccdToken. Definition is_operator (addr owner : Address)(st : State) : bool := match AddressMap.find owner st with - | Some v => existsb (fun x => (addr =? x)%address) v.(wccd_operators) + | Some v => existsb (fun x => (addr =? x)%address) v.(wccd_operators) | None => false end. @@ -139,7 +139,7 @@ Section WccdToken. (** * updateOperator *) - Definition add_remove (operators : list Address) (param : OpUpdateKind * Address) := + Definition add_remove (operators : list Address) (param : OpUpdateKind * Address) := let '(updateKind,addr) := param in match updateKind with | opAdd => addr :: operators @@ -151,7 +151,7 @@ Section WccdToken. Definition wccd_updateOperator (owner : Address) (params : list (OpUpdateKind * Address)) (prev_st : State) : option State := do owner_data <- AddressMap.find owner prev_st; - let updated_owner_data := owner_data<| wccd_operators := fold_left add_remove params owner_data.(wccd_operators) |> in + let updated_owner_data := owner_data<| wccd_operators := fold_left add_remove params owner_data.(wccd_operators) |> in ret (AddressMap.add owner updated_owner_data prev_st). (** * wccd receive *) @@ -210,7 +210,7 @@ Module WccdTypes <: CIS1Types. Definition token_id_eqb (id1 id2 : TokenID) := true. - Lemma token_id_eqb_spec : + Lemma token_id_eqb_spec : forall (a b : TokenID), Bool.reflect (a = b) (token_id_eqb a b). Proof. intros. constructor. now destruct a,b. Qed. @@ -234,11 +234,11 @@ Module WccdView <: CIS1View WccdTypes. end. Definition get_owners : Storage -> TokenID -> list Address := - fun st token_id => FMap.keys st. + fun st token_id => FMap.keys st. Lemma get_owners_no_dup : forall st token_id, NoDup (get_owners st token_id). Proof. - intros. unfold get_owners;apply FMap.NoDup_keys. + intros. unfold get_owners; apply FMap.NoDup_keys. Qed. Lemma In_keys_In_elements_iff {K V : Type} `{countable.Countable K} (m : FMap K V) (k : K) : @@ -258,8 +258,8 @@ Module WccdView <: CIS1View WccdTypes. + now destruct Hex. + destruct Hex as [v Hv]. unfold FMap.keys. - rewrite FMap.elements_add in * by assumption;cbn in *. - destruct Hv as [HH | HH];try inversion HH;easy. + rewrite FMap.elements_add in * by assumption; cbn in *. + destruct Hv as [HH | HH]; try inversion HH; easy. Qed. Lemma get_owners_balances : forall st owner token_id, @@ -279,7 +279,7 @@ Module WccdView <: CIS1View WccdTypes. destruct Hex as [b Hb]. unfold get_owners, FMap.keys. unfold get_balance_opt,Cis1wccd.get_balance_opt in *. - destruct (AddressMap.find owner st) eqn:Heq;try congruence. + destruct (AddressMap.find owner st) eqn:Heq; try congruence. unfold AddressMap.find in *. apply FMap.In_elements in Heq. apply In_keys_In_elements_iff. @@ -347,7 +347,7 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. (** Converting _from_ the CIS1 standard parameters *) - Definition from_cis1_transfer_data (p : CIS1_transfer_data) : wccd_transfer_params := + Definition from_cis1_transfer_data (p : CIS1_transfer_data) : wccd_transfer_params := let '(Build_CIS1_transfer_data _ token_id amt from_addr to_addr) := p in {| wccd_td_token_id := tt; wccd_td_amount := amt; @@ -360,8 +360,7 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. | cis1_ou_add_operator => opAdd end. - Definition from_cis1_balanceOf_params (query : CIS1_balanceOf_params) - : list Address := + Definition from_cis1_balanceOf_params (query : CIS1_balanceOf_params) : list Address := map cis1_bo_query_address query.(cis1_bo_query). Definition get_contract_msg : CIS1_entry_points -> Msg := @@ -379,19 +378,19 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. Lemma left_inverse_get_CIS1_entry_point (entry_point : CIS1_entry_points) : get_CIS1_entry_point (get_contract_msg entry_point) = Some entry_point. Proof. - destruct entry_point;cbn. + destruct entry_point; cbn. + destruct params as [xs]. repeat f_equal. - induction xs;auto. - cbn. destruct a as [tid ? ?];cbn in *. destruct tid. repeat f_equal;auto. + induction xs; auto. + cbn. destruct a as [tid ? ?]; cbn in *. destruct tid. repeat f_equal; auto. + destruct params as [xs]. repeat f_equal. rewrite map_map. - induction xs;auto. - destruct a as [ok ?];cbn in *. destruct ok; repeat f_equal;auto. - + destruct params as [xs send_to p];cbn in *. + induction xs; auto. + destruct a as [ok ?]; cbn in *. destruct ok; repeat f_equal; auto. + + destruct params as [xs send_to p]; cbn in *. unfold to_cis1_balanceOf_params. - destruct (Bool.bool_dec (address_is_contract send_to) true) eqn:Heq;repeat f_equal. - * induction xs;cbn in *;auto. - destruct a as [tid ?];destruct tid;cbn;now repeat f_equal. + destruct (Bool.bool_dec (address_is_contract send_to) true) eqn:Heq; repeat f_equal. + * induction xs; cbn in *; auto. + destruct a as [tid ?]; destruct tid; cbn; now repeat f_equal. * apply UIP_dec. apply Bool.bool_dec. * congruence. Qed. @@ -417,13 +416,13 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. Proof. intros Haddr. cbn in *. - destruct (requireTrue (_ || _)) eqn:Hpermissions;try congruence. - destruct (AddressMap.find _ _) as [v |] eqn:Hv;try congruence. - destruct (requireTrue (_ <=? _)) eqn:Hbalance;try congruence. - inversion Haddr;subst;clear Haddr. - destruct (amt <=? wccd_balance v) eqn:Hamt;cbn in *;try congruence. + destruct (requireTrue (_ || _)) eqn:Hpermissions; try congruence. + destruct (AddressMap.find _ _) as [v |] eqn:Hv; try congruence. + destruct (requireTrue (_ <=? _)) eqn:Hbalance; try congruence. + inversion Haddr; subst; clear Haddr. + destruct (amt <=? wccd_balance v) eqn:Hamt; cbn in *; try congruence. apply leb_complete in Hamt. - repeat split;cbn. + repeat split; cbn. + intros. unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance. unfold WccdView.get_balance_opt, get_balance_opt. @@ -431,14 +430,14 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. unfold AddressMap.find,AddressMap.add. now erewrite fin_maps.lookup_insert_ne. + intros. now destruct other_token_id,token_id. - + unfold requireTrue in *. destruct (orb _ _) eqn:Hp;try congruence. + + unfold requireTrue in *. destruct (orb _ _) eqn:Hp; try congruence. rewrite Bool.orb_true_iff in *. destruct Hp as [Hp | Hp]. * now destruct (address_eqb_spec owner_addr from_addr). * right. unfold is_operator in *. unfold WccdView.get_operators. - destruct (AddressMap.find owner_addr prev_st) eqn:Hfind;try congruence. + destruct (AddressMap.find owner_addr prev_st) eqn:Hfind; try congruence. apply existsb_exists in Hp. destruct Hp as [addr0 [Hin Heq]]. now destruct (address_eqb_spec from_addr addr0). @@ -450,12 +449,12 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. destruct (AddressMap.find to_addr _) eqn:Haddr. * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *. rewrite Hv. - rewrite FMap.add_commute with (m:=prev_st) by auto. - rewrite FMap.find_add with (m:=(FMap.add _ _ prev_st));cbn. + rewrite FMap.add_commute with (m := prev_st) by auto. + rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)); cbn. lia. * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *. - rewrite FMap.add_commute with (m:=prev_st) by auto. - rewrite FMap.find_add with (m:=(FMap.add _ _ prev_st)). + rewrite FMap.add_commute with (m := prev_st) by auto. + rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)). cbn. rewrite Hv. lia. + repeat rewrite get_balance_total_get_balance_default. @@ -465,13 +464,13 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. unfold setter_from_getter_AddressState_wccd_balance,set_AddressState_wccd_balance. destruct (AddressMap.find to_addr _) eqn:Haddr. * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *. - rewrite FMap.find_add with (m:=(FMap.add _ _ prev_st));cbn. - rewrite FMap.find_add_ne with (m:=prev_st) in Haddr by auto. + rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)); cbn. + rewrite FMap.find_add_ne with (m := prev_st) in Haddr by auto. unfold FMap.find in *. now rewrite Haddr. * unfold WccdView.get_balance_opt,get_balance_opt,AddressMap.find,AddressMap.add in *. - rewrite FMap.find_add with (m:=(FMap.add _ _ prev_st));cbn. - rewrite FMap.find_add_ne with (m:=prev_st) in Haddr by auto. + rewrite FMap.find_add with (m := (FMap.add _ _ prev_st)); cbn. + rewrite FMap.find_add_ne with (m := prev_st) in Haddr by auto. unfold FMap.find in *. now rewrite Haddr. + subst. repeat rewrite get_balance_total_get_balance_default. @@ -488,8 +487,8 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. unfold WccdView.get_balance_opt,get_balance_opt. rewrite Hv. unfold AddressMap.find,AddressMap.add. - rewrite FMap.find_add with (m:=prev_st);cbn. - rewrite FMap.find_add with (m:=FMap.add _ _ prev_st);cbn. + rewrite FMap.find_add with (m := prev_st); cbn. + rewrite FMap.find_add with (m := FMap.add _ _ prev_st); cbn. lia. Qed. @@ -502,14 +501,14 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. intros Hparams. unfold to_cis1_balanceOf_params in *. destruct (Bool.bool_dec (address_is_contract send_results_to)) eqn:Haddr; - inversion Hparams;subst;clear Hparams. + inversion Hparams; subst; clear Hparams. cbn. revert dependent next_st. revert dependent send_results_to. induction query. - - now intros ? ? ? Hparams;cbn in *. + - now intros ? ? ? Hparams; cbn in *. - intros. cbn. - erewrite IHquery;eauto. + erewrite IHquery; eauto. unfold WccdView.get_balance_opt. now destruct (get_balance_opt _ _). Qed. @@ -531,10 +530,10 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. end. Proof. intros ? ? ? ? ? ? ? Hep Hreceive. - destruct msg;cbn;inversion Hep as [HH];subst;clear Hep;try easy. + destruct msg; cbn; inversion Hep as [HH]; subst; clear Hep; try easy. + simpl in *. - destruct (wccd_transfer _ _) eqn:Htr;try congruence. - inversion Hreceive;subst;clear Hreceive. + destruct (wccd_transfer _ _) eqn:Htr; try congruence. + inversion Hreceive; subst; clear Hreceive. constructor. * cbn. revert dependent next_st. @@ -543,8 +542,8 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. ** cbn in *. congruence. ** intros prev_st next_st Hreceive. cbn -[wccd_transfer_single] in *. - destruct (wccd_transfer_single _ _ _ _ _) as [st |] eqn:Haddr;try congruence. - destruct a as [tid amt from_addr to_addr];cbn. + destruct (wccd_transfer_single _ _ _ _ _) as [st |] eqn:Haddr; try congruence. + destruct a as [tid amt from_addr to_addr]; cbn. simpl in *. exists st, eq_refl, eq_refl. split. @@ -554,12 +553,12 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. revert dependent prev_st. revert dependent next_st. induction params. - ** intros;cbn;auto. - ** intros;cbn -[wccd_transfer_single] in *. - destruct (wccd_transfer_single _ _ _ _ _) as [st |] eqn:Haddr;try congruence. - destruct a as [token_id amt addr];cbn. + ** intros; cbn; auto. + ** intros; cbn -[wccd_transfer_single] in *. + destruct (wccd_transfer_single _ _ _ _ _) as [st |] eqn:Haddr; try congruence. + destruct a as [token_id amt addr]; cbn. destruct (address_is_contract _). - *** constructor;simpl in *. + *** constructor; simpl in *. eexists. split. **** reflexivity. **** destruct token_id. @@ -567,43 +566,43 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. eexists. split. apply deserialize_serialize. reflexivity. - **** eapply IHparams;eauto. - *** eapply IHparams;eauto. + **** eapply IHparams; eauto. + *** eapply IHparams; eauto. + simpl in *. destruct (address_is_contract send_results_to) eqn:Haddr; - inversion Hreceive;subst;clear Hreceive;cbn in *. - destruct (to_cis1_balanceOf_params _ _) eqn:Hto_cis1;inversion HH;subst;clear HH. - constructor;subst;auto. - erewrite get_balances_wccd_balanceOf;eauto. + inversion Hreceive; subst; clear Hreceive; cbn in *. + destruct (to_cis1_balanceOf_params _ _) eqn:Hto_cis1; inversion HH; subst; clear HH. + constructor; subst; auto. + erewrite get_balances_wccd_balanceOf; eauto. cbn. repeat f_equal. unfold to_cis1_balanceOf_params in *. destruct (Bool.bool_dec (address_is_contract send_results_to)) eqn:HH; now inversion Hto_cis1. + cbn in *. unfold setter_from_getter_AddressState_wccd_operators,set_AddressState_wccd_operators in *. - constructor;intros;cbn in *;auto. + constructor; intros; cbn in *; auto. * unfold WccdView.get_balance_opt,get_balance_opt. - destruct (AddressMap.find _ _) eqn:Haddr;inversion Hreceive;subst;clear Hreceive. + destruct (AddressMap.find _ _) eqn:Haddr; inversion Hreceive; subst; clear Hreceive. destruct (address_eqb_spec addr ctx.(ctx_from)). ** subst. rewrite Haddr. unfold AddressMap.find,AddressMap.add. - now rewrite FMap.find_add with (m:=prev_st). + now rewrite FMap.find_add with (m := prev_st). ** unfold AddressMap.find,AddressMap.add. now rewrite fin_maps.lookup_insert_ne. - * destruct (AddressMap.find _ _) eqn:Haddr;inversion Hreceive;subst;clear Hreceive. - destruct a as [bal ops];cbn in *. + * destruct (AddressMap.find _ _) eqn:Haddr; inversion Hreceive; subst; clear Hreceive. + destruct a as [bal ops]; cbn in *. revert dependent ops. revert dependent prev_st. - induction params;intros prev_st ops Haddr. + induction params; intros prev_st ops Haddr. ** cbn. unfold AddressMap.add,AddressMap.find in *. - now symmetry;apply FMap.add_id. + now symmetry; apply FMap.add_id. ** cbn. unfold AddressMap.add,AddressMap.find in *. - destruct a as [ok oaddr];cbn in *. - unfold updateOperator_single_spec;cbn. - destruct ok;cbn in *. + destruct a as [ok oaddr]; cbn in *. + unfold updateOperator_single_spec; cbn. + destruct ok; cbn in *. *** set (st := FMap.add (ctx_from ctx) {| wccd_balance := bal; wccd_operators := oaddr :: ops |} prev_st). @@ -611,16 +610,16 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. **** split. ***** intros. subst st. unfold WccdView.get_operators,AddressMap.find. - rewrite Haddr. rewrite FMap.find_add with (m:=prev_st). + rewrite Haddr. rewrite FMap.find_add with (m := prev_st). cbn. - split; intros;auto. destruct H1;subst;congruence. + split; intros; auto. destruct H1; subst; congruence. ***** subst st. unfold WccdView.get_operators,AddressMap.find. - now rewrite FMap.find_add with (m:=prev_st);cbn. - **** set (ops' := oaddr :: ops). - specialize (IHparams st ops'). subst ops' st;cbn in *. - repeat rewrite FMap.add_add with (m:=prev_st)in IHparams. + now rewrite FMap.find_add with (m := prev_st); cbn. + **** set (ops' := oaddr :: ops). + specialize (IHparams st ops'). subst ops' st; cbn in *. + repeat rewrite FMap.add_add with (m := prev_st)in IHparams. apply IHparams. - now rewrite FMap.find_add with (m:=prev_st). + now rewrite FMap.find_add with (m := prev_st). *** set (st := FMap.add (ctx_from ctx) {| wccd_balance := bal; wccd_operators := remove address_eqdec oaddr ops |} prev_st). @@ -630,16 +629,16 @@ Module WccdReceiveSpec <: CIS1ReceiveSpec WccdTypes WccdView. prove using the [hint] database *) ***** intros. subst st. unfold WccdView.get_operators,AddressMap.find. - rewrite Haddr. rewrite FMap.find_add with (m:=prev_st). + rewrite Haddr. rewrite FMap.find_add with (m := prev_st). cbn. - split; intros;eauto with hints. + split; intros; eauto with hints. ***** subst st. unfold WccdView.get_operators,AddressMap.find. - rewrite FMap.find_add with (m:=prev_st);cbn;auto with hints. - **** set (ops' := remove address_eqdec oaddr ops). - specialize (IHparams st ops'). subst ops' st;cbn in *. - repeat rewrite FMap.add_add with (m:=prev_st)in IHparams. + rewrite FMap.find_add with (m := prev_st); cbn; auto with hints. + **** set (ops' := remove address_eqdec oaddr ops). + specialize (IHparams st ops'). subst ops' st; cbn in *. + repeat rewrite FMap.add_add with (m := prev_st)in IHparams. apply IHparams. - now rewrite FMap.find_add with (m:=prev_st). + now rewrite FMap.find_add with (m := prev_st). Qed. End WccdReceiveDefs. End WccdReceiveSpec. diff --git a/examples/congress/Congress.v b/examples/congress/Congress.v index ae861316..33e41125 100644 --- a/examples/congress/Congress.v +++ b/examples/congress/Congress.v @@ -74,7 +74,7 @@ Section Congress. next_proposal_id : ProposalId; members : FMap Address unit; }. - + (* begin hide *) MetaCoq Run (make_setters State). (* end hide *) diff --git a/examples/congress/LocalBlockchainTests.v b/examples/congress/LocalBlockchainTests.v index 235e4735..2d1bcaa7 100644 --- a/examples/congress/LocalBlockchainTests.v +++ b/examples/congress/LocalBlockchainTests.v @@ -150,7 +150,7 @@ Section LocalBlockchainTests. Definition chain6 : ChainBuilder := unpack_result (add_block chain5 [build_act person_1 person_1 create_proposal_call]). - Goal (FMap.elements (congress_state chain6).(proposals)) = + Goal (FMap.elements (congress_state chain6).(proposals)) = [(1, {| actions := [cact_transfer person_3 3]; votes := FMap.empty; @@ -166,7 +166,7 @@ Section LocalBlockchainTests. let acts := [build_act person_1 person_1 vote_proposal; build_act person_2 person_2 vote_proposal] in unpack_result (add_block chain6 acts). - + Goal (match FMap.find 1 (congress_state chain7).(proposals) with Some x => x.(vote_result) | None => 0%Z end) = 2%Z. Proof. vm_compute. reflexivity. Qed. diff --git a/examples/congress/tests/CongressGens.v b/examples/congress/tests/CongressGens.v index 776d9a07..19592ef8 100644 --- a/examples/congress/tests/CongressGens.v +++ b/examples/congress/tests/CongressGens.v @@ -26,11 +26,13 @@ Definition gRulesSized (n : nat) : G Rules := margin <- choose(1%Z, 1000%Z) ;; liftM (build_rules vote_count margin) arbitrary. +#[export] Instance genRulesSized : GenSized Rules := {| arbitrarySized := gRulesSized |}. +#[export] Instance genSetupSized : GenSized Setup := {| arbitrarySized n := liftM build_setup (arbitrarySized n) @@ -61,7 +63,7 @@ Definition lc_contract_members_and_proposals_with_votes (state : Congress.State) : FMap Address (list ProposalId) := let members : list Address := (map fst o FMap.elements) (members state) in let proposals_map : FMap nat Proposal := - filter_FMap (fun p => 0 =? (FMap.size (votes (snd p)))) (proposals state) in + filter_FMap (fun p => 0 =? (FMap.size (votes (snd p)))) (proposals state) in if (0 returnGen None - | m::ms => liftM Some (elems_ m members_without_caller) + | m ::ms => liftM Some (elems_ m members_without_caller) end. -Fixpoint try_newCongressMember_fix (members : list Address) +Definition try_newCongressMember_fix (members : list Address) nr_attempts curr_nr - : option Address := + : option Address := let fix aux nr_attempts curr_nr := match nr_attempts with | 0 => None @@ -196,7 +198,7 @@ Fixpoint GCongressAction (env : Environment) ) ] | S fuel' => backtrack [ - (3, GCongressAction env fuel' caddr) ; + (3, GCongressAction env fuel' caddr) ; (* add_proposal *) (1, (* recurse. Msg is converted to a SerializedType using 'serialize' *) diff --git a/examples/congress/tests/CongressPrinters.v b/examples/congress/tests/CongressPrinters.v index 65122b0b..0ed9b114 100644 --- a/examples/congress/tests/CongressPrinters.v +++ b/examples/congress/tests/CongressPrinters.v @@ -9,6 +9,7 @@ Arguments SerializedValue : clear implicits. Arguments deserialize : clear implicits. Arguments serialize : clear implicits. +#[export] Instance showRules : Show Rules := {| show r := @@ -25,10 +26,11 @@ Definition string_of_ca (str_of_msg : Msg -> string) ca := | cact_call to amount msg => "(call: " ++ show to ++ sep ++ show amount ++ sep ++ match @deserialize Msg _ msg with | Some msg => str_of_msg msg - | None => "" + | None => "" end ++ ")" end. +#[export] Instance showSetup : Show Setup := {| show v := show (setup_rules v) @@ -47,34 +49,38 @@ Fixpoint string_of_Msg (fuel : nat) (m : Msg) : string := | add_member addr => "add_member " ++ show addr | remove_member addr => "remove_member " ++ show addr | create_proposal actions => "create_proposal " ++ show_acts actions - | vote_for_proposal proposalId => "vote_for_proposal " ++ show proposalId + | vote_for_proposal proposalId => "vote_for_proposal " ++ show proposalId | vote_against_proposal proposalId => "vote_against_proposal " ++ show proposalId | retract_vote proposalId => "retract_vote " ++ show proposalId | finish_proposal proposalId => "finish_proposal " ++ show proposalId end. +#[export] Instance showMsg : Show Msg := {| show := string_of_Msg 20 |}. (* TODO: fix printing for msg of type SerializedValue such that it works whenever it is serialized from type Msg *) +#[export] Instance showCongressAction : Show CongressAction := {| show := string_of_ca (string_of_Msg 20) |}. +#[export] Instance showProposal : Show Proposal := {| show p := "Proposal{" - ++ "actions: " ++ show (actions p) ++ sep + ++ "actions: " ++ show (actions p) ++ sep ++ "votes: " ++ show (votes p) ++ sep ++ "vote_result: " ++ show (vote_result p) ++ sep ++ "proposed_in: " ++ show (proposed_in p) ++ sep ++ "}" ++ newline |}. +#[export] Instance showState : Show Congress.State := {| show s := "State{" @@ -85,5 +91,6 @@ Instance showState : Show Congress.State := ++ "members: " ++ show (members s) ++ "}" |}. +#[export] Instance showSerializedMsg : Show SerializedValue := Derive Show Msg < Msg, Setup >. diff --git a/examples/congress/tests/CongressTests.v b/examples/congress/tests/CongressTests.v index 7bd05b2f..cc4dfd81 100644 --- a/examples/congress/tests/CongressTests.v +++ b/examples/congress/tests/CongressTests.v @@ -5,8 +5,8 @@ From ConCert.Execution Require Import ResultMonad. From ConCert.Execution Require Import Serializable. From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.Congress Require Import Congress. -From ConCert.Examples.Congress Require Import CongressGens. -From ConCert.Examples.Congress Require Import CongressPrinters. +From ConCert.Examples.Congress Require Export CongressGens. +From ConCert.Examples.Congress Require Export CongressPrinters. From Coq Require Import ZArith. From Coq Require Import List. Import ListNotations. @@ -80,6 +80,7 @@ Definition receive_state_well_behaved state msg new_state (resp_acts : list Acti num_cacts_in_state new_state + length resp_acts <= num_cacts_in_state state + nr_cacts msg. +#[export] Instance receive_state_well_behaved_dec_ {state : Congress.State} {msg : option Congress.Msg} {new_state : Congress.State} @@ -92,6 +93,7 @@ Proof. apply le_dec. Qed. +#[export] Instance receive_state_well_behaved_checkable {state : Congress.State} {msg : option Congress.Msg} {new_state : Congress.State} diff --git a/examples/congress/tests/Congress_BuggyGens.v b/examples/congress/tests/Congress_BuggyGens.v index d12d6fb6..2d8fc450 100644 --- a/examples/congress/tests/Congress_BuggyGens.v +++ b/examples/congress/tests/Congress_BuggyGens.v @@ -19,11 +19,13 @@ Definition gRulesSized (n : nat) : G Rules := margin <- choose(1%Z, 1000%Z) ;; liftM (build_rules vote_count margin) arbitrary. +#[export] Instance genRulesSized : GenSized Rules := {| arbitrarySized := gRulesSized |}. +#[export] Instance genSetupSized : GenSized Setup := {| arbitrarySized n := liftM build_setup (arbitrarySized n) @@ -50,12 +52,12 @@ Definition gCongressMember_without_caller (state : Congress_Buggy.State) let members_without_caller := List.remove address_eqdec calling_addr members in match members_without_caller with | [] => returnGen None - | m::ms => liftM Some (elems_ m members_without_caller) + | m ::ms => liftM Some (elems_ m members_without_caller) end. -Fixpoint try_newCongressMember_fix (members : list Address) +Definition try_newCongressMember_fix (members : list Address) nr_attempts curr_nr - : option Address := + : option Address := let fix aux nr_attempts curr_nr := match nr_attempts with | 0 => None @@ -92,7 +94,7 @@ Definition try_gNewOwner state calling_addr contract_addr : GOpt Address := bindCallerIsOwnerOpt state calling_addr contract_addr (gCongressMember_without_caller state calling_addr contract_addr). -Fixpoint validate_addr (a : Address) : GOpt (address_is_contract a = false) := +Definition validate_addr (a : Address) : GOpt (address_is_contract a = false) := match (Bool.bool_dec (address_is_contract a) true ) with | left _ => ret None | right p => ret (Some (Bool.not_true_is_false _ p)) @@ -145,7 +147,7 @@ Definition lc_contract_members_and_proposals_with_votes (state : Congress_Buggy. : FMap Address (list ProposalId) := let members : list Address := (map fst o FMap.elements) (members state) in let proposals_map : FMap nat Proposal := - filter_FMap (fun p => 0 =? (FMap.size (votes (snd p)))) (proposals state) in + filter_FMap (fun p => 0 =? (FMap.size (votes (snd p)))) (proposals state) in if (0 "(call: " ++ show to ++ sep ++ show amount ++ sep ++ match @deserialize Msg _ msg with | Some msg => str_of_msg msg - | None => "" + | None => "" end ++ ")" end. +#[export] Instance showSetup : Show Setup := {| show v := show (setup_rules v) @@ -43,13 +45,14 @@ Fixpoint string_of_Msg (fuel : nat) (m : Msg) : string := | add_member addr => "add_member " ++ show addr | remove_member addr => "remove_member " ++ show addr | create_proposal actions => "create_proposal " ++ show_acts actions - | vote_for_proposal proposalId => "vote_for_proposal " ++ show proposalId + | vote_for_proposal proposalId => "vote_for_proposal " ++ show proposalId | vote_against_proposal proposalId => "vote_against_proposal " ++ show proposalId | retract_vote proposalId => "retract_vote " ++ show proposalId | finish_proposal proposalId => "finish_proposal " ++ show proposalId | finish_proposal_remove proposalId => "finish_proposal " ++ show proposalId end. +#[export] Instance showMsg : Show Msg := {| show := string_of_Msg 20 @@ -57,22 +60,25 @@ Instance showMsg : Show Msg := (* TODO: fix printing for msg of type SerializedValue such that it works whenever it is serialized from type Msg *) +#[export] Instance showCongressBuggyAction : Show CongressAction := {| show := string_of_ca (string_of_Msg 20) |}. +#[export] Instance showProposal : Show Proposal := {| show p := "Proposal{" - ++ "actions: " ++ show (actions p) ++ sep + ++ "actions: " ++ show (actions p) ++ sep ++ "votes: " ++ show (votes p) ++ sep ++ "vote_result: " ++ show (vote_result p) ++ sep ++ "proposed_in: " ++ show (proposed_in p) ++ sep ++ "}" ++ newline |}. +#[export] Instance showState : Show Congress_Buggy.State := {| show s := "State{" @@ -83,5 +89,6 @@ Instance showState : Show Congress_Buggy.State := ++ "members: " ++ show (members s) ++ "}" |}. +#[export] Instance showSerializedMsg : Show SerializedValue := Derive Show Msg < Msg, Setup >. diff --git a/examples/congress/tests/Congress_BuggyTests.v b/examples/congress/tests/Congress_BuggyTests.v index fc7d7dca..07109858 100644 --- a/examples/congress/tests/Congress_BuggyTests.v +++ b/examples/congress/tests/Congress_BuggyTests.v @@ -5,8 +5,8 @@ From ConCert.Execution Require Import ResultMonad. From ConCert.Execution Require Import Monad. From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.Congress Require Import Congress_Buggy. -From ConCert.Examples.Congress Require Import Congress_BuggyGens. -From ConCert.Examples.Congress Require Import Congress_BuggyPrinters. +From ConCert.Examples.Congress Require Export Congress_BuggyGens. +From ConCert.Examples.Congress Require Export Congress_BuggyPrinters. From ConCert.Utils Require Import Extras. From Coq Require Import ZArith. @@ -120,7 +120,7 @@ Action{act_from: 10%256, act_body: (act_call 128%256, 0, add_member 10%256)}]; Block 4 [ Action{act_from: 10%256, act_body: (act_call 128%256, 79, create_proposal (call: 128%256, 80, add_member 0%256))}]; Block 5 [ -Action{act_from: 10%256, act_body: (act_call 128%256, 13, finish_proposal 1)}];|} +Action{act_from: 10%256, act_body: (act_call 128%256, 13, finish_proposal 1)}]; |} *** Failed after 33 tests and 0 shrinks. (0 discards) *) diff --git a/examples/counter/Counter.v b/examples/counter/Counter.v index d205fadc..ed826baa 100644 --- a/examples/counter/Counter.v +++ b/examples/counter/Counter.v @@ -65,14 +65,14 @@ Section Counter. (ctx : ContractCallContext) (state : State) (msg : option Msg) - : result (State * list ActionBody) Error - := match msg with - | Some m => match counter state m with - | Ok res => Ok (res, []) - | Err e => Err e - end - | None => Err default_error - end. + : result (State * list ActionBody) Error := + match msg with + | Some m => match counter state m with + | Ok res => Ok (res, []) + | Err e => Err e + end + | None => Err default_error + end. (** We initialize the contract state with [init_value] and set [owner] to the address from which the contract was deployed *) Definition counter_init (chain : Chain) @@ -118,9 +118,9 @@ Section FunctionalProperties. end. Proof. intros H. - all : destruct msg;cbn in *;unfold increment,decrement in *. - all : destruct (0 True). instantiate (DeployFacts := fun _ _ => True). - unset_all;subst;cbn in *. + unset_all; subst; cbn in *. destruct_chain_step; auto. destruct_action_eval; auto. cbn. intros cstate Hc Hstate. @@ -196,9 +196,9 @@ Section SafetyProperties. assert ((outgoing_acts bstate_from to_addr) = []) as Hempty. { apply lift_outgoing_acts_nil with (contract := counter_contract); eauto. now constructor. - intros. eapply (receive_produces_no_calls (chain:=chain) (ctx:=ctx)); eauto. apply H. } + intros. eapply (receive_produces_no_calls (chain := chain) (ctx := ctx)); eauto. apply H. } unfold outgoing_acts in *. rewrite queue_prev in *. - subst act;cbn in Hempty. + subst act; cbn in Hempty. now destruct_address_eq. Qed. diff --git a/examples/counter/embedding/CounterEmbed.v b/examples/counter/embedding/CounterEmbed.v index 5536580c..fcff23e0 100644 --- a/examples/counter/embedding/CounterEmbed.v +++ b/examples/counter/embedding/CounterEmbed.v @@ -20,14 +20,14 @@ Module Counter. Open Scope list. - (** Generating names for the data structures *) + (** Generating names for the data structures *) MetaCoq Run (mp_ <- tmCurrentModPath tt ;; let mp := (PCUICTranslate.string_of_modpath mp_ ++ "@")%string in - mkNames mp ["state" ; "MkState" ; "owner" ; "msg" ] "_coq"). + mkNames mp ["state"; "MkState"; "owner"; "msg" ] "_coq"). (** Variable names and constructor names *) - MetaCoq Run (mkNames "" ["m" ;"n"; "own"; "st" ; "new_st" ; "addr" ; "new_balance"; "Inc" ; "Dec"] "_coq"). + MetaCoq Run (mkNames "" ["m"; "n"; "own"; "st" ; "new_st" ; "addr" ; "new_balance"; "Inc" ; "Dec"] "_coq"). (** ** Definitions of data structures for the contract *) @@ -69,7 +69,7 @@ Module Counter. (** The main functionality *) Definition counter_syn := [| \m : msg => \st : CounterState => - case m : msg return Maybe ((List SimpleActionBody) × CounterState) of + case m : msg return Maybe ((List SimpleActionBody) × CounterState) of | Inc n -> $Just$Maybe [: List SimpleActionBody × CounterState] (Pair (List SimpleActionBody) CounterState (Nil SimpleActionBody) @@ -80,8 +80,8 @@ Module Counter. Definition CounterModule : LiquidityModule := {| datatypes := [msg_syn]; storage := [! CounterState !]; - init := [| \n : money => \addr : address => \"c" : CallCtx => - $Just$Maybe [: money × address] Pair money address n addr |]; + init := [| \n : money => \addr : address => \"c" : CallCtx => + $Just$Maybe [: money × address] Pair money address n addr |]; message := [! msg !]; functions := [("_update_balance", update_balance_syn); ("counter", counter_syn)]; @@ -103,7 +103,7 @@ Definition TTty := (to_string_name <% nat %>, "nat")]. (** A translation table for primitive binary operations *) -Definition TT := +Definition TT := [(to_string_name <% Z.add %>, "addTez")]. (** The output has been tested in the online Liquidity editor: https://www.liquidity-lang.org/edit/ *) @@ -114,7 +114,7 @@ Definition TT := Extraction Language OCaml. Extract Inductive list => "list" [ "[]" "(::)" ]. -Extract Inductive prod => "(*)" [ "(,)" ]. +Extract Inductive prod => "(*)" [ "(,)" ]. Extract Inductive Z => "tez" ["0DUN" "id" "negate"]. Extract Inlined Constant Z.add => "addTez". @@ -128,5 +128,5 @@ Extract Inlined Constant Z.add => "addTez". (** It seems there are some syntactic and semantic differences from OCaml. E.g. it's not possible to pattern-match on tuples in Liquidity, a special form of [let] or projections must be used instead. That's why our "prelude" features the [fst] and [snd] functions. We use them explicitly instead of destructing pairs. *) -Extraction Counter._update_balance. -Extraction Counter.counter. +(* Extraction Counter._update_balance. *) +(* Extraction Counter.counter. *) diff --git a/examples/counter/extraction/CounterCertifiedExtraction.v b/examples/counter/extraction/CounterCertifiedLiquidity.v similarity index 96% rename from examples/counter/extraction/CounterCertifiedExtraction.v rename to examples/counter/extraction/CounterCertifiedLiquidity.v index 5583229a..f1f7d231 100644 --- a/examples/counter/extraction/CounterCertifiedExtraction.v +++ b/examples/counter/extraction/CounterCertifiedLiquidity.v @@ -3,7 +3,7 @@ From MetaCoq.Template Require Import All. From ConCert.Embedding Require Import Notations. From ConCert.Embedding.Extraction Require Import PreludeExt. -From ConCert.Extraction Require Import LPretty. +From ConCert.Extraction Require Import LiquidityPretty. From ConCert.Extraction Require Import LiquidityExtract. From ConCert.Extraction Require Import Common. From ConCert.Utils Require Import Automation. @@ -37,7 +37,7 @@ Module Counter. Definition init (ctx : SimpleCallCtx) (setup : Z * address) : result storage Error := - let ctx' := ctx in (* prevents optimisations from removing unused [ctx] *) + let ctx' := ctx in (* prevents optimisations from removing unused [ctx] *) Ok setup. Inductive msg := @@ -126,7 +126,7 @@ Proof. eexists. split. - simpl. - destruct ?; propify;auto;lia. + destruct ?; propify; auto; lia. - simpl. congruence. Qed. @@ -141,7 +141,7 @@ Proof. eexists. split. - simpl. - destruct ?; propify;auto;lia. + destruct ?; propify; auto; lia. - simpl. congruence. Qed. @@ -185,4 +185,4 @@ Time MetaCoq Run (* Print liquidity_counter. *) (** We redirect the extraction result for later processing and compiling with the Liquidity compiler *) -Redirect "../extraction/tests/extracted-code/liquidity-extract/CounterCertifiedExtraction.liq" Compute liquidity_counter. +Redirect "../extraction/tests/extracted-code/liquidity-extract/CounterCertifiedLiquidity.liq" Compute liquidity_counter. diff --git a/examples/counter/extraction/CounterDepCertifiedExtraction.v b/examples/counter/extraction/CounterDepCertifiedLiquidity.v similarity index 93% rename from examples/counter/extraction/CounterDepCertifiedExtraction.v rename to examples/counter/extraction/CounterDepCertifiedLiquidity.v index edbf6c88..58f4d172 100644 --- a/examples/counter/extraction/CounterDepCertifiedExtraction.v +++ b/examples/counter/extraction/CounterDepCertifiedLiquidity.v @@ -11,7 +11,7 @@ From ConCert.Embedding.Extraction Require Import PreludeExt. From ConCert.Execution Require Import Blockchain. From ConCert.Execution Require Import ResultMonad. From ConCert.Extraction Require Import LiquidityExtract. -From ConCert.Extraction Require Import LPretty. +From ConCert.Extraction Require Import LiquidityPretty. From ConCert.Extraction Require Import Common. From MetaCoq.TypedExtraction Require Import CertifyingEta. From Coq Require Import ZArith. @@ -37,21 +37,21 @@ Module Counter. Definition init (ctx : SimpleCallCtx) (setup : Z * address) : result storage Error := - let ctx' := ctx in (* prevents optimisations from removing unused [ctx] *) + let ctx' := ctx in (* prevents optimisations from removing unused [ctx] *) Ok setup. Inductive msg := | Inc (_ : Z) | Dec (_ : Z). - Definition inc_balance (st : storage) (new_balance : Z) + Definition inc_balance (st : storage) (new_balance : Z) (p : (0 <=? new_balance) = true) : storage := (st.1 + new_balance, st.2). Definition dec_balance (st : storage) (new_balance : Z) (p : (0 <=? new_balance) = true): storage := - (st.1 - new_balance, st.2). + (st.1 - new_balance, st.2). Definition my_bool_dec := Eval compute in bool_dec. @@ -124,7 +124,7 @@ Definition TT_rename : list (string * string) := ; ("Z0" ,"0") ; ("nil", "[]") ; ("true", "true") - ; (String.to_string (string_of_kername <%% storage %%>), "storage") (* we add [storage] so it is printed without the prefix *) ]. + ; (String.to_string (string_of_kername <%% storage %%>), "storage") (* we add [storage] so it is printed without the prefix *) ]. Definition COUNTER_MODULE : LiquidityMod msg _ (Z × address) storage operation Error := {| (* a name for the definition with the extracted code *) @@ -215,10 +215,10 @@ MetaCoq Run (counter_syn <- quote_recursively_body counter_partially_applied ;; (** [Σexpanded] contains expanded definitions *) (** A proof generated by the eta-expansion procedure. *) -(* Check ConCert_Examples_Counter_extraction_CounterDepCertifiedExtraction_Counter_counter_partially_applied_expanded_convertible. *) -(* ConCert_Extraction_Tests_CounterDepCertifiedExtraction_Counter_counter_partially_applied_expanded_convertible +(* Check ConCert_Examples_Counter_extraction_CounterDepCertifiedLiquidity_Counter_counter_partially_applied_expanded_convertible. *) +(* ConCert_Extraction_Tests_CounterDepCertifiedLiquidity_Counter_counter_partially_applied_expanded_convertible : counter_partially_applied = - ConCert_Extraction_Tests_CounterDepCertifiedExtraction_Counter_counter_partially_applied_expanded *) + ConCert_Extraction_Tests_CounterDepCertifiedLiquidity_Counter_counter_partially_applied_expanded *) (* Now we can extract this one successfully. *) @@ -236,7 +236,7 @@ Definition COUNTER_PARTIAL_EXPANDED_MODULE : LiquidityMod msg _ (Z × address) s lmd_init_prelude := "" ; (* the main functionality *) - lmd_receive := ConCert_Examples_Counter_extraction_CounterDepCertifiedExtraction_Counter_counter_partially_applied_expanded; + lmd_receive := ConCert_Examples_Counter_extraction_CounterDepCertifiedLiquidity_Counter_counter_partially_applied_expanded; (* code for the entry point *) lmd_entry_point := printWrapper (PREFIX ++ "counter") ++ nl @@ -250,4 +250,4 @@ Time MetaCoq Run (* Print liquidity_counter_partially_applied_expanded. *) (** We redirect the extraction result for later processing and compiling with the Liquidity compiler *) -Redirect "../extraction/tests/extracted-code/liquidity-extract/CounterDepCertifiedExtraction.liq" Compute liquidity_counter. +Redirect "../extraction/tests/extracted-code/liquidity-extract/CounterDepCertifiedLiquidity.liq" Compute liquidity_counter. diff --git a/examples/counter/extraction/CameLIGOCounter.v b/examples/counter/extraction/CounterLIGO.v similarity index 89% rename from examples/counter/extraction/CameLIGOCounter.v rename to examples/counter/extraction/CounterLIGO.v index 6a8e8b9a..356b0f8f 100644 --- a/examples/counter/extraction/CameLIGOCounter.v +++ b/examples/counter/extraction/CounterLIGO.v @@ -17,6 +17,7 @@ Import MCMonadNotation. Local Open Scope string_scope. Open Scope Z. +#[local] Existing Instance PrintConfShortNames.PrintWithShortNames. Module Counter. @@ -95,6 +96,7 @@ Module Counter. |}. End Counter. + Section CounterExtraction. Import Counter. (** A translation table for definitions we want to remap. The corresponding top-level definitions will be *ignored* *) @@ -116,28 +118,28 @@ Section CounterExtraction. ]. (** We run the extraction procedure inside the [TemplateMonad]. *) - (* It uses the certified erasure from [MetaCoq] and the certified deboxing procedure *) - (* that removes application of boxes to constants and constructors. *) + (* It uses the certified erasure from [MetaCoq] and the certified deboxing procedure *) + (* that removes application of boxes to constants and constructors. *) (** NOTE: running computations inside [TemplateMonad] is quite slow. That's why we comment out this code and use a different way below *) (* Time MetaCoq Run *) - (* (t <- CameLIGO_extract [] TT_remap_counter [] [] CameLIGO_call_ctx LIGO_COUNTER_MODULE ;; *) - (* tmDefinition LIGO_COUNTER_MODULE.(lmd_module_name) t). *) + (* (t <- CameLIGO_extract [] TT_remap_counter [] [] CameLIGO_call_ctx LIGO_COUNTER_MODULE ;; *) + (* tmDefinition LIGO_COUNTER_MODULE.(lmd_module_name) t). *) (* If we first prepare the environment for erasure in [TemplateMonad] *) - (* and run erasure/prining outside of it, it works ~4 times faster for this example *) + (* and run erasure/prining outside of it, it works ~4 times faster for this example *) (** This command adds [cameLIGO_counter_prepared] to the environment, *) - (* which can be evaluated later *) + (* which can be evaluated later *) Time MetaCoq Run (CameLIGO_prepare_extraction [] TT_remap_counter TT_rename_ctors_default [] "cctx_instance" LIGO_COUNTER_MODULE). Time Definition cameLIGO_counter_1 := Eval vm_compute in cameLIGO_counter_prepared. (** We redirect the extraction result for later processing and compiling with the CameLIGO compiler *) - Redirect "../extraction/tests/extracted-code/cameligo-extract/CounterCertifiedExtraction.mligo" + Redirect "../extraction/tests/extracted-code/cameligo-extract/CounterCertified.mligo" MetaCoq Run (tmMsg (String.of_string cameLIGO_counter_1)). End CounterExtraction. diff --git a/examples/counter/extraction/MidlangCounterRefTypes.v b/examples/counter/extraction/CounterRefTypesMidlang.v similarity index 95% rename from examples/counter/extraction/MidlangCounterRefTypes.v rename to examples/counter/extraction/CounterRefTypesMidlang.v index 65b1031c..5405e24f 100644 --- a/examples/counter/extraction/MidlangCounterRefTypes.v +++ b/examples/counter/extraction/CounterRefTypesMidlang.v @@ -18,6 +18,7 @@ From Coq Require Import ZArith. Import MCMonadNotation. Open Scope string. +#[local] Instance MidlangBoxes : ElmPrintConfig := {| term_box_symbol := "()"; type_box_symbol := "()"; @@ -54,7 +55,7 @@ Module CounterRefinmentTypes. st + proj1_sig inc. Next Obligation. unfold is_true in *. - rewrite <- Zlt_is_lt_bool in *;lia. + rewrite <- Zlt_is_lt_bool in *; lia. Qed. @@ -63,7 +64,7 @@ Module CounterRefinmentTypes. st - proj1_sig dec. Next Obligation. unfold is_true in *. - rewrite <- Zlt_is_lt_bool in *;lia. + rewrite <- Zlt_is_lt_bool in *; lia. Qed. Definition my_bool_dec := Eval compute in Bool.bool_dec. @@ -144,7 +145,7 @@ Definition counter_result := Eval compute in ret lines). Definition wrap_in_delimiters s := - concat Common.nl ["";"{-START-} "; s; "{-END-}"]. + concat Common.nl [""; "{-START-} "; s; "{-END-}"]. Definition midlang_prelude := ["import Basics exposing (..)"; @@ -167,4 +168,5 @@ Definition midlang_counter := | Err s => tmFail (String.of_string s) end. -Redirect "../extraction/tests/extracted-code/midlang-extract/MidlangCounterRefTypes.midlang" MetaCoq Run midlang_counter. +Redirect "../extraction/tests/extracted-code/midlang-extract/CounterRefTypesMidlang.midlang" + MetaCoq Run midlang_counter. diff --git a/examples/counter/extraction/RustCounter.v b/examples/counter/extraction/CounterRust.v similarity index 99% rename from examples/counter/extraction/RustCounter.v rename to examples/counter/extraction/CounterRust.v index 7d80e205..ebb02262 100644 --- a/examples/counter/extraction/RustCounter.v +++ b/examples/counter/extraction/CounterRust.v @@ -15,6 +15,7 @@ Definition COUNTER_MODULE : ConcordiumMod _ _ := concmd_extra := []; |}. (* NOTE: it is important to declare a priting config, otherwise MetaCoq evaluation tries to normalise a term with an unresolved instance and runs out of memory. *) +#[local] Instance RustConfig : RustPrintConfig := {| term_box_symbol := "()"; type_box_symbol := "()"; diff --git a/examples/counter/extraction/CounterSubsetTypesLIGO.v b/examples/counter/extraction/CounterSubsetTypesLIGO.v index 31f560e0..1f40f58f 100644 --- a/examples/counter/extraction/CounterSubsetTypesLIGO.v +++ b/examples/counter/extraction/CounterSubsetTypesLIGO.v @@ -38,7 +38,7 @@ Module CounterRefinementTypes. Definition init (ctx : SimpleCallCtx) (setup : Z) : result storage Error := - let ctx_ := ctx in (* prevents optimisations from removing unused [ctx] *) + let ctx_ := ctx in (* prevents optimisations from removing unused [ctx] *) Ok setup. Inductive msg := Inc (_ : Z) | Dec (_ : Z). @@ -84,6 +84,7 @@ Module CameLIGOExtractionSetup. Import CameLIGOPretty CameLIGOExtract. (** Exposing a printing configuration for CameLIGO *) + #[local] Existing Instance PrintConfAddModuleNames.PrintWithModuleNames. diff --git a/examples/counter/extraction/CounterSubsetTypesLiquidity.v b/examples/counter/extraction/CounterSubsetTypesLiquidity.v index c9a6d8fe..158025b4 100644 --- a/examples/counter/extraction/CounterSubsetTypesLiquidity.v +++ b/examples/counter/extraction/CounterSubsetTypesLiquidity.v @@ -5,7 +5,7 @@ From MetaCoq.Template Require Import All. From ConCert.Embedding Require Import Notations. From ConCert.Embedding.Extraction Require Import PreludeExt. -From ConCert.Extraction Require LPretty. +From ConCert.Extraction Require LiquidityPretty. From ConCert.Extraction Require LiquidityExtract. From ConCert.Extraction Require Import Common. From ConCert.Utils Require Import Automation. @@ -38,7 +38,7 @@ Module CounterRefinementTypes. Definition init (ctx : SimpleCallCtx) (setup : Z) : result storage Error := - let ctx_ := ctx in (* prevents optimisations from removing unused [ctx] *) + let ctx_ := ctx in (* prevents optimisations from removing unused [ctx] *) Ok setup. Inductive msg := Inc (_ : Z) | Dec (_ : Z). @@ -79,7 +79,7 @@ Import CounterRefinementTypes. Section LiquidityExtractionSetup. - Import LPretty. + Import LiquidityPretty. Import LiquidityExtract. Definition PREFIX := "coq_". @@ -121,14 +121,14 @@ Section LiquidityExtractionSetup. ; ("nil", "[]") ; ("true", "true") ; ("exist", "exist_") (* remapping [exist] to the wrapper *) - ; (String.to_string (string_of_kername <%% storage %%>), "storage") (* we add [storage] so it is printed without the prefix *) ]. + ; (String.to_string (string_of_kername <%% storage %%>), "storage") (* we add [storage] so it is printed without the prefix *) ]. Definition COUNTER_MODULE : LiquidityMod msg _ Z storage ActionBody Error := {| (* a name for the definition with the extracted code *) lmd_module_name := "liquidity_counter" ; (* definitions of operations on pairs and ints *) - lmd_prelude := concat nl [prod_ops;int_ops; sig_def; exist_def; result_def]; + lmd_prelude := concat nl [prod_ops; int_ops; sig_def; exist_def; result_def]; (* initial storage *) lmd_init := init ; diff --git a/examples/crowdfunding/Crowdfunding.v b/examples/crowdfunding/Crowdfunding.v index 6e1ff82c..8275318e 100644 --- a/examples/crowdfunding/Crowdfunding.v +++ b/examples/crowdfunding/Crowdfunding.v @@ -1,4 +1,4 @@ -(** We develop a deep embedding of a crowdfunding contract and prove some of its functional correctness properties using the corresponding shallow embedding *) +(** We develop a deep embedding of a crowdfunding contract and prove some of its functional correctness properties using the corresponding shallow embedding *) From ConCert.Embedding Require Import Ast. From ConCert.Embedding Require Import Notations. @@ -16,7 +16,7 @@ Open Scope list. Import Prelude.Maps. -(** Note that we define the deep embedding (abstract syntax trees) of the data structures and programs using notations. These notations are defined in [Ast.v] and make use of the "custom entries" feature. *) +(** Note that we define the deep embedding (abstract syntax trees) of the data structures and programs using notations. These notations are defined in [Ast.v] and make use of the "custom entries" feature. *) (** Brackets like [[\ \]] delimit the scope of data type definitions and like [[| |]] the scope of programs *) @@ -45,7 +45,7 @@ Module CrowdfundingContract. Import CrowdfundingData.Notations. (** We specialise some polymorphic constructors to avoid writing types all the time *) - Notation "'#Just' a" := [| {eConstr (to_string_name <% option %>) "Some"} {eTy [! Result!]} {a}|] + Notation "'#Just' a" := [| {eConstr (to_string_name <% option %>) "Some"} {eTy [! Result!]} {a}|] (in custom expr at level 0, a custom expr at level 1). @@ -63,7 +63,7 @@ Module CrowdfundingContract. Definition SChain := to_string_name <% SimpleChain_coq %>. Definition crowdfunding : expr := - [| \chain : SChain => \c : SCtx => \m : Msg => \s : State => + [| \chain : SChain => \c : SCtx => \m : Msg => \s : State => let bal : Money := balance s in let now : Nat := cur_time chain in let tx_amount : Money := amount c in @@ -72,7 +72,7 @@ Module CrowdfundingContract. let accs : Map := donations s in case m : Msg return Maybe Result of | GetFunds -> - if (own ==n sender) && (deadline s "address" ; remap <%% SimpleActionBody_coq %%> "operation" ; remap <%% Maps.addr_map_coq %%> "(address,tez) map" diff --git a/examples/crowdfunding/CrowdfundingCorrect.v b/examples/crowdfunding/CrowdfundingCorrect.v index 099aa31d..0794d90e 100644 --- a/examples/crowdfunding/CrowdfundingCorrect.v +++ b/examples/crowdfunding/CrowdfundingCorrect.v @@ -1,4 +1,4 @@ -(** We develop a deep embedding of a crowdfunding contract and prove some of its +(** We develop a deep embedding of a crowdfunding contract and prove some of its functional correctness properties using the corresponding shallow embedding *) From ConCert.Embedding Require Import Notations. @@ -20,8 +20,8 @@ Import CrowdfundingContract. Module CrowdfundingProperties. Import AcornBlockchain. - Ltac inv_andb H := apply Bool.andb_true_iff in H;destruct H. - Ltac split_andb := apply Bool.andb_true_iff;split. + Ltac inv_andb H := apply Bool.andb_true_iff in H; destruct H. + Ltac split_andb := apply Bool.andb_true_iff; split. Open Scope nat. Open Scope bool. @@ -68,18 +68,18 @@ Module CrowdfundingProperties. because we check if the deadline have passed by comparing the deadline recoded in the internal state with the current slot number.*) Lemma receive_blockchain_state height1 height2 cur_slot fheight1 fheight2 msg st ctx : - Receive.receive (Build_chain_coq height1 cur_slot fheight1) ctx msg st = + Receive.receive (Build_chain_coq height1 cur_slot fheight1) ctx msg st = Receive.receive (Build_chain_coq height2 cur_slot fheight2) ctx msg st. Proof. destruct msg; simpl; (match goal with | [ |- context[(if ?x then _ else _ )] ] => destruct x eqn:Hx - end);eauto. + end); eauto. Qed. (** This function is a simplistic execution environment that performs one step of execution *) - Definition run (receive : State_coq -> option (State_coq * list SimpleActionBody_coq) ) (init : State_coq) + Definition run (receive : State_coq -> option (State_coq * list SimpleActionBody_coq)) (init : State_coq) : State_coq * list SimpleActionBody_coq := match receive init with | Some (fin, out) => (fin, out) @@ -115,13 +115,13 @@ Module CrowdfundingProperties. Proof. unfold assertion. intros init H. simpl. destruct H as [Hdl [Hgoal [Hndone Hlook]]]. - unfold deadline_passed,goal_reached in *;simpl in *. + unfold deadline_passed,goal_reached in *; simpl in *. repeat eexists. unfold run. simpl. assert (balance_coq init sum_map (add_map k (n0+v') m) = (v' + v)%Z. Proof. - intros;subst. + intros; subst. revert dependent n0. revert v' k. - induction m;intros;subst. + induction m; intros; subst. + inversion H. + simpl in *. destruct (k =? n) eqn:Hkn. * simpl in *. inversion H. subst. lia. - * simpl in *. rewrite IHm;auto. lia. + * simpl in *. rewrite IHm; auto. lia. Qed. Lemma sum_map_add_not_in m : forall v' v k, @@ -222,13 +222,13 @@ Module CrowdfundingProperties. sum_map m = v -> sum_map (add_map k v' m) = (v' + v)%Z. Proof. - intros;subst. + intros; subst. revert dependent k. revert v'. - induction m;intros;subst. + induction m; intros; subst. + reflexivity. + simpl in *. destruct (k =? n) eqn:Hkn. * inversion H. - * simpl in *. rewrite IHm;auto. lia. + * simpl in *. rewrite IHm; auto. lia. Qed. Lemma sum_map_sub_in m k z v : @@ -236,13 +236,13 @@ Module CrowdfundingProperties. sum_map m = v -> sum_map (add_map k 0 m) = (v - z)%Z. Proof. - intros;subst. + intros; subst. revert dependent k. revert z. - induction m;intros;subst;tryfalse. + induction m; intros; subst; tryfalse. simpl in *. destruct (k =? n) eqn:Hkn. - + inversion H;subst. + + inversion H; subst. simpl in *. lia. - + simpl. now erewrite IHm;eauto. + + simpl. now erewrite IHm; eauto. Qed. (** The contract does no leak funds: the overall balance before the @@ -253,7 +253,7 @@ Module CrowdfundingProperties. sum_map (donations_coq state) = balance_coq state. - (** This lemma holds for any message *) + (** This lemma holds for any message *) Lemma contract_backed BC CallCtx msg : {{ consistent_balance_deadline (Current_slot BC) }} @@ -270,37 +270,37 @@ Module CrowdfundingProperties. (* specialize Hdl as Hdl'. *) unfold consistent_balance_deadline,deadline_passed in H. unfold run,consistent_balance_deadline. - (* apply not_ltb in Hdl. simpl. *) + (* apply not_ltb in Hdl. simpl. *) simpl. - destruct (_ <=? _);tryfalse. + destruct (_ <=? _); tryfalse. * destruct (lookup_map _ _) eqn:Hlook. - ** repeat eexists;intro Hdl;eauto. now apply sum_map_add_in. - ** repeat eexists;intro Hdl;eauto. now apply sum_map_add_not_in. - * repeat eexists;intro Hdl;eauto. + ** repeat eexists; intro Hdl; eauto. now apply sum_map_add_in. + ** repeat eexists; intro Hdl; eauto. now apply sum_map_add_not_in. + * repeat eexists; intro Hdl; eauto. + (* GetFunds *) unfold consistent_balance_deadline in *. unfold deadline_passed in *. unfold run. simpl. destruct (deadline_coq init destruct x eqn:Hx - end);eauto; repeat eexists; simpl in *; intros; - destruct (_ destruct x eqn:Hx end); - simpl in *;try destruct (lookup_map _ _);repeat eexists;eauto; intros;destruct (_ destruct x eqn:Hx - end);eauto; repeat eexists; simpl in *; intros; - destruct (_ destruct x eqn:Hx end); - simpl in *;try destruct (lookup_map _ _) eqn:Hlook;repeat eexists;eauto; intros;destruct (_ map_forallb (Z.leb 0%Z) (add_map k (n0+v') m). Proof. - intros;subst. + intros; subst. revert dependent n0. revert k. - induction m;intros k n0 Hlook;subst. + induction m; intros k n0 Hlook; subst. + inversion Hlook. + simpl in *. destruct (k =? n) eqn:Hkn. * simpl in *. inversion Hlook. - inv_andb H1. rewrite Nat.eqb_eq in *;subst. - subst;split_andb;auto. - propify;lia. + inv_andb H1. rewrite Nat.eqb_eq in *; subst. + subst; split_andb; auto. + propify; lia. * simpl in *. inv_andb H1. now propify. @@ -380,13 +380,13 @@ Module CrowdfundingProperties. map_forallb (Z.leb 0%Z) m -> map_forallb (Z.leb 0%Z) (add_map k v' m). Proof. - induction m;intros ? ? Hnneg Hlook H;subst. - + simpl in *. split_andb;now propify. + induction m; intros ? ? Hnneg Hlook H; subst. + + simpl in *. split_andb; now propify. + simpl in *. destruct (k =? n) eqn:Hkn. * simpl in *. - inv_andb H. rewrite Nat.eqb_eq in *;subst. - subst;split_andb;auto. - propify;lia. + inv_andb H. rewrite Nat.eqb_eq in *; subst. + subst; split_andb; auto. + propify; lia. * simpl in *. inv_andb H. now propify. @@ -396,7 +396,7 @@ Module CrowdfundingProperties. map_forallb (Z.leb 0%Z) m -> map_forallb (Z.leb 0%Z) (add_map k 0 m). Proof. - induction m;intros. + induction m; intros. + easy. + simpl in *. destruct (k =? n) eqn:Hkn. * simpl in *. @@ -406,7 +406,7 @@ Module CrowdfundingProperties. now propify. Qed. - (** All the entries in the table of contributions contain non-negative amounts *) + (** All the entries in the table of contributions contain non-negative amounts *) Lemma contract_state_donation_non_neg BC CallCtx msg : (0 <= CallCtx.(Ctx_amount))%Z -> @@ -423,32 +423,32 @@ Module CrowdfundingProperties. (* specialize Hdl as Hdl'. *) unfold consistent_balance,deadline_passed in H. unfold run,consistent_balance. - (* apply not_ltb in Hdl. simpl. *) + (* apply not_ltb in Hdl. simpl. *) simpl. - destruct (_ <=? _);tryfalse. + destruct (_ <=? _); tryfalse. * destruct (lookup_map _ _) eqn:Hlook. - ** repeat eexists;eauto. + ** repeat eexists; eauto. assert (0 <=? z)%Z by now eapply map_forallb_lookup_map. unfold donations_non_neg. cbn. - eapply non_neg_add_in;eauto. - ** repeat eexists;eauto. + eapply non_neg_add_in; eauto. + ** repeat eexists; eauto. unfold donations_non_neg. cbn. - eapply non_neg_add_not_in;eauto. - * repeat eexists;eauto. + eapply non_neg_add_not_in; eauto. + * repeat eexists; eauto. + (* GetFunds *) unfold donations_non_neg in *. unfold run. simpl. (match goal with | [ |- context[(if ?x then _ else _ )] ] => destruct x eqn:Hx - end);eauto; repeat eexists; simpl in *; intros; - destruct (_ destruct x eqn:Hx end); - simpl in *;try destruct (lookup_map _ _) eqn:Hlook;repeat eexists;eauto. + simpl in *; try destruct (lookup_map _ _) eqn:Hlook; repeat eexists; eauto. simpl. now apply non_neg_add_0. Qed. @@ -466,7 +466,7 @@ Module CrowdfundingProperties. (* the money are sent back *) In (Act_transfer OwnerAddr funds) out (* set balance to 0 after withdrawing by the owner *) - /\ fin.(balance_coq) = 0%Z + /\ fin.(balance_coq) = 0%Z (* set the "done" flag *) /\ fin.(done_coq) = true}}. Proof. @@ -474,8 +474,8 @@ Module CrowdfundingProperties. destruct H as [Hfunded [Hown Hbalance]]. unfold funded,goal_reached,deadline_passed in *. subst. simpl in *. unfold run. simpl in *. subst OwnerAddr. eexists. eexists. - destruct (_ \"b" : Maybe Result => case "o" : Maybe Unit return Maybe Result of | Just "_" -> "b" - | Nothing -> $Nothing$Maybe [: Result ] |]. + | Nothing -> $Nothing$Maybe [: Result ] |]. MetaCoq Unquote Definition maybe_bind_unit := (expr_to_tc Σ' (indexify nil maybe_bind_unit_syn)). @@ -79,11 +79,11 @@ Module CrowdfundingContract. (** The last argument of the [init] function must be a [CallCtx]. The init function returns an options type. The [init] function in Liquidity cannot refer to global definitions, so we have to inline validation *) Definition crowdfunding_init : expr := - [| \setup : {params_ty} => \ctx : CallCtx => + [| \setup : {params_ty} => \ctx : CallCtx => (if sent_amount ctx == 0z then $Just$Maybe [:{full_state_ty}] (mkFullState setup (mkState MNil False)) - else $Nothing$Maybe [: {full_state_ty}] : Maybe {full_state_ty})|]. + else $Nothing$Maybe [: {full_state_ty}] : Maybe {full_state_ty})|]. (* Compute ((expr_to_tc Σ' (indexify nil crowdfunding_init))). *) MetaCoq Unquote Definition init := @@ -95,7 +95,7 @@ Module CrowdfundingContract. init setup call_ctx = None. Proof. intros H. destruct call_ctx as [curr_time [sender [tx_amount total_bal]]]. - unfold init,maybe_bind_unit. destruct ?;auto. + unfold init,maybe_bind_unit. destruct ?; auto. cbn in *. unfold validate in *. rewrite Z.eqb_eq in *. lia. Qed. @@ -146,13 +146,13 @@ Module CrowdfundingContract. (** We make the remapping to the Liquidity primitives easier by using this abbreviation for the lookup, since in Liquidity the arguments are swapped *) Definition lookup_map' k m := PreludeExt.Maps.lookup_map m k. - Notation "'findm' a b" := [| {eConst (to_string_name <% lookup_map' %> )} {a} {b} |] + Notation "'findm' a b" := [| {eConst (to_string_name <% lookup_map' %> )} {a} {b} |] (in custom expr at level 0, a custom expr at level 1, b custom expr at level 1). Definition crowdfunding : expr := - [| \m : msg => \s : {full_state_ty} => \ctx : CallCtx => + [| \m : msg => \s : {full_state_ty} => \ctx : CallCtx => let sender : address := sender_addr ctx in let bal : money := acc_balance ctx in let tx_amount : money := sent_amount ctx in @@ -186,25 +186,25 @@ Module CrowdfundingContract. (expr_to_tc Σ' (indexify nil crowdfunding)). (** We prove that the call to the [receive] fails (returns [None]) if the contract was called with non-zero amount and this is not the "donate" case*) - Lemma receive_validated message state - (call_ctx : SimpleCallCtx) : + Lemma receive_validated message state + (call_ctx : SimpleCallCtx) : (sc_sent_amount call_ctx <> 0)%Z -> message <> Donate_coq -> receive message state call_ctx = None. Proof. intros Hneq Hmsg. destruct call_ctx as [curr_time [sender [tx_amount total_bal]]]. cbn in *. - destruct message;tryfalse. - + simpl. destruct ?;auto. - unfold maybe_bind_unit. destruct ?;auto. + destruct message; tryfalse. + + simpl. destruct ?; auto. + unfold maybe_bind_unit. destruct ?; auto. simpl in *. unfold validate in *. - destruct ?;tryfalse. + destruct ?; tryfalse. rewrite Z.eqb_eq in *. lia. - + simpl. destruct ?;auto. - destruct ?;auto. - unfold maybe_bind_unit. destruct ?;auto. + + simpl. destruct ?; auto. + destruct ?; auto. + unfold maybe_bind_unit. destruct ?; auto. simpl in *. unfold validate in *. - destruct ?;tryfalse. + destruct ?; tryfalse. rewrite Z.eqb_eq in *. lia. Qed. diff --git a/examples/crowdfunding/CrowdfundingLiquidity.v b/examples/crowdfunding/CrowdfundingLiquidity.v index 1529498c..d2f8ebe5 100644 --- a/examples/crowdfunding/CrowdfundingLiquidity.v +++ b/examples/crowdfunding/CrowdfundingLiquidity.v @@ -4,7 +4,7 @@ From Coq Require Import ZArith. From Coq Require Import String. From ConCert.Embedding Require Import Notations. From ConCert.Extraction Require Import LiquidityExtract. -From ConCert.Extraction Require Import LPretty. +From ConCert.Extraction Require Import LiquidityPretty. From ConCert.Extraction Require Import Common. From ConCert.Embedding.Extraction Require Import PreludeExt. From ConCert.Embedding.Extraction Require Import SimpleBlockchainExt. @@ -25,7 +25,7 @@ Definition PREFIX := "". (** A translation table for definitions we want to remap. The corresponding top-level definitions will be *ignored* *) Definition TT_remap : list (kername * String.string) := - [ (* types *) + [ (* types *) remap <%% Z %%> "tez" ; remap <%% address_coq %%> "address" ; remap <%% time_coq %%> "timestamp" @@ -119,7 +119,7 @@ Definition CROWDFUNDING_MODULE : (* the main functionality *) - lmd_receive := crowdfunding_receive ; + lmd_receive := crowdfunding_receive ; (* code for the entry point *) lmd_entry_point := printWrapper (PREFIX ++ "crowdfunding_receive") ++ Common.nl diff --git a/examples/crowdfunding/ExecFrameworkIntegration.v b/examples/crowdfunding/ExecFrameworkIntegration.v index 56c75c2d..5edc54f7 100644 --- a/examples/crowdfunding/ExecFrameworkIntegration.v +++ b/examples/crowdfunding/ExecFrameworkIntegration.v @@ -19,6 +19,7 @@ From ConCert.Utils Require Import Automation. From ConCert.Utils Require Import Extras. From ConCert.Execution Require Import Blockchain. From ConCert.Execution Require Import Monad. +From ConCert.Execution Require Import Serializable. From ConCert.Execution Require Import ResultMonad. Import ListNotations. @@ -80,13 +81,12 @@ End Serialize. Section Wrappers. Definition Setup := (nat * Z)%type. - Definition init_wrapper (f : SimpleContractCallContext_coq -> nat -> Z -> State_coq): - Chain -> ContractCallContext -> Setup -> result State_coq unit - := fun c cc setup => Ok (f (of_contract_call_context cc) (fst setup) (snd setup)). + Definition init_wrapper (f : SimpleContractCallContext_coq -> nat -> Z -> State_coq) + : Chain -> ContractCallContext -> Setup -> result State_coq unit := + fun c cc setup => Ok (f (of_contract_call_context cc) (fst setup) (snd setup)). - Definition wrapped_init - : Chain -> ContractCallContext -> Setup -> result State_coq unit - := init_wrapper Init.init. + Definition wrapped_init : Chain -> ContractCallContext -> Setup -> result State_coq unit := + init_wrapper Init.init. Definition receive_wrapper (f : SimpleChain_coq -> @@ -104,8 +104,9 @@ Section Wrappers. end. Definition wrapped_receive - : Chain -> ContractCallContext -> State_coq -> option Msg_coq -> result (State_coq * list ActionBody) unit - := receive_wrapper Receive.receive. + : Chain -> ContractCallContext -> State_coq -> option Msg_coq + -> result (State_coq * list ActionBody) unit := + receive_wrapper Receive.receive. End Wrappers. @@ -141,8 +142,8 @@ Proof. consistent_balance_deadline (current_slot chain) new_state). { intros chain ctx prev_state msg new_state new_acts receive IH. - destruct msg as [msg | ];tryfalse; cbn in receive. - destruct (Receive.receive _ _ _ _) as [[? ?] | ] eqn:Hreceive;tryfalse; cbn in *. + destruct msg as [msg | ]; tryfalse; cbn in receive. + destruct (Receive.receive _ _ _ _) as [[? ?] | ] eqn:Hreceive; tryfalse; cbn in *. specialize (contract_backed (of_chain chain) (of_contract_call_context ctx) msg) as Hnew_consistent. rewrite Current_slot_of_chain_eq in *. @@ -207,7 +208,7 @@ Proof. as [fin [out [Hrun Hcon]]]. unfold run in Hrun. destruct (Receive.receive _ _ _ _) - as [[resp_state resp_acts]| ] eqn:Hreceive;tryfalse. + as [[resp_state resp_acts]| ] eqn:Hreceive; tryfalse. cbn in *. now replace new_state with fin by congruence. - destruct msg as [msg| ]; cbn in *; try congruence. @@ -218,7 +219,7 @@ Proof. as [fin [out [Hrun Hcon]]]. unfold run in Hrun. destruct (Receive.receive _ _ _ _) - as [[resp_state resp_acts]| ] eqn:Hreceive;tryfalse. + as [[resp_state resp_acts]| ] eqn:Hreceive; tryfalse. cbn in *. now replace new_state with fin by congruence. - instantiate (AddBlockFacts := fun _ _ _ _ _ _ => Logic.True). @@ -252,8 +253,8 @@ Proof. Forall (fun a => ~~ is_deploy a && ~~ is_call a) acts). { intros ? ? ? ? ? ? receive_some. - destruct msg as [msg | ];tryfalse; cbn in *. - destruct (Receive.receive _ _ _ _) as [[? ?] | ] eqn:Hreceive;tryfalse; cbn in *. + destruct msg as [msg | ]; tryfalse; cbn in *. + destruct (Receive.receive _ _ _ _) as [[? ?] | ] eqn:Hreceive; tryfalse; cbn in *. replace acts with (map to_action_body l) by congruence. destruct msg. + (* donate *) @@ -301,12 +302,12 @@ Lemma lookup_map_sum_map_leq m k z: (z <= sum_map m)%Z. Proof. revert k z. - induction m;intros k z0 Hsum Hlook;tryfalse. - simpl in *. unfold is_true in *;repeat rewrite Bool.andb_true_iff in *. + induction m; intros k z0 Hsum Hlook; tryfalse. + simpl in *. unfold is_true in *; repeat rewrite Bool.andb_true_iff in *. destruct Hsum as [H1 H2]. destruct (k =? n). - + simpl in *. inversion Hlook;subst. - unfold is_true in *;repeat rewrite Bool.andb_true_iff in *. + + simpl in *. inversion Hlook; subst. + unfold is_true in *; repeat rewrite Bool.andb_true_iff in *. rewrite <- Zle_is_le_bool in *. assert (sum_map m >=0)%Z by now eapply all_non_neg_sum_map. lia. + specialize_hypotheses. @@ -378,24 +379,25 @@ Proof. intros Hpos Hbalance Hcall. destruct msg eqn:Hmsg. + simpl in *. - destruct (_ <=? _);tryfalse. + destruct (_ <=? _); tryfalse. destruct (lookup_map _); inversion Hcall; tauto. + simpl in *. - destruct (_ && _ && _);tryfalse. + destruct (_ && _ && _); tryfalse. inversion Hcall; tauto. + simpl in *. - destruct (_ && _ && _) eqn:Hcond;tryfalse. - destruct (lookup_map _) eqn:Hlook;tryfalse. + destruct (_ && _ && _) eqn:Hcond; tryfalse. + destruct (lookup_map _) eqn:Hlook; tryfalse. inversion Hcall. repeat rewrite Bool.andb_true_iff in *. destruct Hcond as [[? ?] Hdone]. specialize (Hbalance Hdone). assert (z <= balance_coq init)%Z. - { rewrite <- Hbalance. eapply lookup_map_sum_map_leq;eauto. } - right. right. eexists;split;eauto. + { rewrite <- Hbalance. eapply lookup_map_sum_map_leq; eauto. } + right. right. eexists; split; eauto. Qed. Local Open Scope Z. +#[local] Hint Resolve cf_balance_consistent crowfunding_donations_non_negative : core. (** ** The actual contract balance is consistent with the local state *) Theorem cf_backed bstate cf_addr lstate: @@ -422,9 +424,9 @@ Proof. subst DeployFacts; cbn in *. lia. - lia. - - destruct msg as [msg| ];tryfalse. + - destruct msg as [msg| ]; tryfalse. cbn in receive_some. - destruct (Receive.receive _ _ _ _) as [[? ?]| ] eqn:Hreceive;tryfalse. + destruct (Receive.receive _ _ _ _) as [[? ?]| ] eqn:Hreceive; tryfalse. cbn in receive_some. replace s with new_state in * by congruence. replace new_acts with (map to_action_body l) in * by congruence. @@ -448,9 +450,9 @@ Proof. + (* claim *) destruct H as [? [? [? ?]]]; subst; cbn in *. lia. - - destruct msg as [msg| ];tryfalse. + - destruct msg as [msg| ]; tryfalse. cbn in receive_some. - destruct (Receive.receive _ _ _ _) as [[? ?]| ] eqn:Hreceive;tryfalse. + destruct (Receive.receive _ _ _ _) as [[? ?]| ] eqn:Hreceive; tryfalse. cbn in receive_some. replace s with new_state in * by congruence. replace new_acts with (map to_action_body l) in * by congruence. @@ -491,11 +493,11 @@ Corollary cf_backed_after_block {ChainBuilder : ChainBuilderType} (env_account_balances new cf_addr >= balance_coq lstate)%Z. Proof. intros Hnew Hcf Hst. - destruct ChainBuilder;cbn in *. + destruct ChainBuilder; cbn in *. pose (builder_trace new) as tr. cbn in *. assert (Hr : reachable {| chain_state_env := builder_env new; chain_state_queue := [] |}) by - (constructor;eauto). + (constructor; eauto). specialize (cf_backed _ _ _ Hr Hcf Hst) as Hbacked. cbn in *. lia. Qed. @@ -510,11 +512,11 @@ Corollary cf_donations_backed_after_block {ChainBuilder : ChainBuilderType} (env_account_balances new cf_addr >= sum_map (lstate.(donations_coq)))%Z. Proof. intros Hnew Hcf Hst Hdone. - destruct ChainBuilder;cbn in *. + destruct ChainBuilder; cbn in *. pose (builder_trace new) as tr. cbn in *. assert (Hr : reachable {| chain_state_env := builder_env new; chain_state_queue := [] |}) by - (constructor;eauto). + (constructor; eauto). specialize (cf_balance_consistent _ _ _ Hr Hcf Hst Hdone) as Hconsistent. rewrite Hconsistent. specialize (cf_backed _ _ _ Hr Hcf Hst) as Hbacked. diff --git a/examples/dexter/Dexter.v b/examples/dexter/Dexter.v index 4d1a1025..0aff25ee 100644 --- a/examples/dexter/Dexter.v +++ b/examples/dexter/Dexter.v @@ -84,7 +84,7 @@ Section Dexter. (* send out asset transfer to transfer owner, and send a token transfer message to the FA2 token *) let asset_transfer_msg := act_transfer params.(exchange_owner) tokens_price in let token_transfer_param := - EIP20Token.transfer_from params.(exchange_owner) dexter_caddr params.(tokens_sold) in + EIP20Token.transfer_from params.(exchange_owner) dexter_caddr params.(tokens_sold) in let token_transfer_msg := act_call state.(token_caddr) 0%Z (@serialize EIP20Token.Msg _ (token_transfer_param)) in let new_state := state<|token_pool := N.add state.(token_pool) params.(tokens_sold)|> <| price_history := state.(price_history) ++ [tokens_price]|> in diff --git a/examples/dexter/DexterPrinters.v b/examples/dexter/DexterPrinters.v index 5265815d..7262633d 100644 --- a/examples/dexter/DexterPrinters.v +++ b/examples/dexter/DexterPrinters.v @@ -7,6 +7,7 @@ From ConCert.Examples.EIP20 Require Import EIP20TokenPrinters. Local Open Scope string_scope. +#[export] Instance showDexterExchangeParam : Show Dexter.exchange_param := {| show t := "exchange{" @@ -15,6 +16,7 @@ Instance showDexterExchangeParam : Show Dexter.exchange_param := ++ "}" |}. +#[export] Instance showDexterMsg : Show Dexter.Msg := {| show m := match m with @@ -23,6 +25,7 @@ Instance showDexterMsg : Show Dexter.Msg := end |}. +#[export] Instance showDexterState : Show Dexter.State := {| show t := "DexterState{" @@ -32,6 +35,7 @@ Instance showDexterState : Show Dexter.State := ++ "}" |}. +#[export] Instance showDexterSetup : Show Dexter.Setup := {| show t := "DexterSetup{" @@ -40,6 +44,7 @@ Instance showDexterSetup : Show Dexter.Setup := ++ "}" |}. +#[export] Instance showSerializedMsg : Show SerializedValue := Derive Show Msg < Dexter.Msg, diff --git a/examples/dexter/DexterTests.v b/examples/dexter/DexterTests.v index 7f186d80..5e88d0ac 100644 --- a/examples/dexter/DexterTests.v +++ b/examples/dexter/DexterTests.v @@ -7,7 +7,7 @@ From ConCert.Execution Require Import ResultMonad. From ConCert.Execution Require Import Monad. From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.Dexter Require Import Dexter. -From ConCert.Examples.Dexter Require Import DexterPrinters. +From ConCert.Examples.Dexter Require Export DexterPrinters. From ConCert.Examples.Dexter Require Import DexterGens. From ConCert.Examples.EIP20 Require Import EIP20Token. From Coq Require Import ZArith_base. @@ -27,7 +27,7 @@ Definition dexter_caddr : Address := addr_of_Z 129. (* Dexter will have 60 tokens in reverse initially *) Definition dexter_setup : Dexter.Setup := {| token_caddr_ := token_caddr; - token_pool_ := (token_pool_size - 40); + token_pool_ := (token_pool_size - 40); |}. Definition add_as_operator_act owner operator tokens := @@ -43,7 +43,7 @@ Definition exchange_tokens_to_money_act owner amount := Also adds some tokens to person_1 and dexter contract, and adds some operators on the fa2 contract *) Definition chain : ChainBuilder := unpack_result (TraceGens.add_block builder_initial - [ (* Give 10 to person 1 *) + [ (* Give 10 to person 1 *) build_transfer creator person_1 10 ; (* Deploy contracts *) build_deploy creator 0 EIP20Token.contract token_setup ; @@ -149,7 +149,7 @@ Action{act_from: 10%256, act_body: (act_call 128%256, 0, DexterSetup{token_caddr Action{act_from: 11%256, act_body: (act_call 128%256, 0, approve 129%256 100)}]; Block 2 [ Action{act_from: 11%256, act_body: (act_call 129%256, 0, token_to_asset exchange{exchange_owner: 11%256, tokens_sold: 20})}; -Action{act_from: 11%256, act_body: (act_call 129%256, 0, token_to_asset exchange{exchange_owner: 11%256, tokens_sold: 14})}];|} +Action{act_from: 11%256, act_body: (act_call 129%256, 0, token_to_asset exchange{exchange_owner: 11%256, tokens_sold: 14})}]; |} dexter balance was 19 while it was expected to be at least 20 person_1 balance: 11 diff --git a/examples/dexter2/Dexter2CPMM.v b/examples/dexter2/Dexter2CPMM.v index 04614867..e27cfa07 100644 --- a/examples/dexter2/Dexter2CPMM.v +++ b/examples/dexter2/Dexter2CPMM.v @@ -205,19 +205,19 @@ Module Dexter2 (SI : Dexter2Serializable) (NAddr : NullAddress). Export NAddr. (* begin hide *) - Existing Instance add_liquidity_param_serializable. - Existing Instance remove_liquidity_param_serializable. - Existing Instance xtz_to_token_param_serializable. - Existing Instance token_to_xtz_param_serializable. - Existing Instance set_baker_param_serializable. - Existing Instance token_to_token_param_serializable. - Existing Instance DexterMsg_serializable. - Existing Instance Dexter2FA12_Msg_serialize. - Existing Instance setup_serializable. - Existing Instance ClientMsg_serializable. - Existing Instance state_serializable. - Existing Instance FA2Token_Msg_serializable. - Existing Instance BaseTypes. + #[export] Existing Instance add_liquidity_param_serializable. + #[export] Existing Instance remove_liquidity_param_serializable. + #[export] Existing Instance xtz_to_token_param_serializable. + #[export] Existing Instance token_to_xtz_param_serializable. + #[export] Existing Instance set_baker_param_serializable. + #[export] Existing Instance token_to_token_param_serializable. + #[export] Existing Instance DexterMsg_serializable. + #[export] Existing Instance Dexter2FA12_Msg_serialize. + #[export] Existing Instance setup_serializable. + #[export] Existing Instance ClientMsg_serializable. + #[export] Existing Instance state_serializable. + #[export] Existing Instance FA2Token_Msg_serializable. + #[export] Existing Instance BaseTypes. (* end hide *) Section DexterDefs. @@ -321,7 +321,7 @@ Module Dexter2 (SI : Dexter2Serializable) (NAddr : NullAddress). do _ <- throwIf state.(selfIsUpdatingTokenPool) default_error; (* error_SELF_IS_UPDATING_TOKEN_POOL_MUST_BE_FALSE *) do _ <- throwIf (param.(remove_deadline) <=? chain.(current_slot))%nat default_error; (* error_THE_CURRENT_TIME_MUST_BE_LESS_THAN_THE_DEADLINE *) do _ <- throwIf (non_zero_amount ctx.(ctx_amount)) default_error; (* error_AMOUNT_MUST_BE_ZERO *) - do xtz_withdrawn <- div (param.(lqtBurned) * state.(xtzPool)) state.(lqtTotal) ; (* error_DIV_by_0 *) + do xtz_withdrawn <- div (param.(lqtBurned) * state.(xtzPool)) state.(lqtTotal) ; (* error_DIV_by_0 *) do tokens_withdrawn <- div (param.(lqtBurned) * state.(tokenPool)) state.(lqtTotal) ; (* error_DIV_by_0 *) do _ <- throwIf (xtz_withdrawn match type of rs with | list balance_of_response => - destruct rs;inversion H;clear H + destruct rs; inversion H; clear H | _ => fail "No match on list of balance_of_response" end end. @@ -489,7 +489,7 @@ Section Theories. let lqt_minted := amount_to_N ctx.(ctx_amount) * prev_state.(lqtTotal) / prev_state.(xtzPool) in let tokens_deposited := ceildiv_ (amount_to_N ctx.(ctx_amount) * prev_state.(tokenPool)) prev_state.(xtzPool) in receive_cpmm chain ctx prev_state (Some (FA2Token.other_msg (AddLiquidity param))) = Ok (new_state, new_acts) -> - prev_state<| lqtTotal := prev_state.(lqtTotal) + lqt_minted |> + prev_state<| lqtTotal := prev_state.(lqtTotal) + lqt_minted |> <| tokenPool := prev_state.(tokenPool) + tokens_deposited |> <| xtzPool := prev_state.(xtzPool) + amount_to_N ctx.(ctx_amount) |> = new_state. Proof. @@ -538,7 +538,7 @@ Section Theories. let tokens_deposited := ceildiv_ (amount_to_N ctx.(ctx_amount) * prev_state.(tokenPool)) prev_state.(xtzPool) in prev_state.(selfIsUpdatingTokenPool) = false /\ (current_slot chain < param.(add_deadline))%nat /\ - tokens_deposited <= param.(maxTokensDeposited) /\ + tokens_deposited <= param.(maxTokensDeposited) /\ param.(minLqtMinted) <= lqt_minted /\ prev_state.(xtzPool) <> 0 /\ prev_state.(lqtAddress) <> null_address @@ -571,13 +571,13 @@ Section Theories. Proof. intros * receive_some. contract_simpl. - now math_convert;cbv. + now math_convert; cbv. Qed. Lemma remove_liquidity_correct : forall prev_state new_state chain ctx new_acts param, receive_cpmm chain ctx prev_state (Some (FA2Token.other_msg (RemoveLiquidity param))) = Ok (new_state, new_acts) -> new_state.(lqtTotal) = prev_state.(lqtTotal) - param.(lqtBurned) /\ - new_state.(tokenPool) = prev_state.(tokenPool) - (param.(lqtBurned) * prev_state.(tokenPool)) / prev_state.(lqtTotal) /\ + new_state.(tokenPool) = prev_state.(tokenPool) - (param.(lqtBurned) * prev_state.(tokenPool)) / prev_state.(lqtTotal) /\ new_state.(xtzPool) = prev_state.(xtzPool) - (param.(lqtBurned) * prev_state.(xtzPool)) / prev_state.(lqtTotal). Proof. intros * receive_some. @@ -664,8 +664,8 @@ Section Theories. Lemma xtz_to_token_correct : forall prev_state new_state chain ctx new_acts param, receive_cpmm chain ctx prev_state (Some (FA2Token.other_msg (XtzToToken param))) = Ok (new_state, new_acts) -> - new_state.(tokenPool) = prev_state.(tokenPool) - (((amount_to_N ctx.(ctx_amount)) * 997 * prev_state.(tokenPool)) / - (prev_state.(xtzPool) * 1000 + ((amount_to_N ctx.(ctx_amount)) * 997)) ) /\ + new_state.(tokenPool) = prev_state.(tokenPool) - (((amount_to_N ctx.(ctx_amount)) * 997 * prev_state.(tokenPool)) / + (prev_state.(xtzPool) * 1000 + ((amount_to_N ctx.(ctx_amount)) * 997))) /\ new_state.(xtzPool) = prev_state.(xtzPool) + amount_to_N ctx.(ctx_amount). Proof. intros * receive_some. diff --git a/examples/dexter2/Dexter2CPMMExtract.v b/examples/dexter2/Dexter2CPMMExtractLIGO.v similarity index 100% rename from examples/dexter2/Dexter2CPMMExtract.v rename to examples/dexter2/Dexter2CPMMExtractLIGO.v diff --git a/examples/dexter2/Dexter2FA12.v b/examples/dexter2/Dexter2FA12.v index 3562befb..140b2223 100644 --- a/examples/dexter2/Dexter2FA12.v +++ b/examples/dexter2/Dexter2FA12.v @@ -101,7 +101,7 @@ Section LQTFA12Types. should have this type as its Msg type. The contract may have other endpoints, as composed in the 'other_msg' constructor. *) Inductive FA12ReceiverMsg {Msg' : Type} := - | receive_allowance : N -> FA12ReceiverMsg + | receive_allowance : N -> FA12ReceiverMsg | receive_balance_of : N -> FA12ReceiverMsg | receive_total_supply : N -> FA12ReceiverMsg | other_msg : Msg' -> FA12ReceiverMsg. @@ -139,7 +139,7 @@ Section LQTFA12Types. { lqt_contract : Contract Setup Msg State Error; lqt_total_supply_correct : - forall (bstate : ChainState) (caddr : Address) + forall (bstate : ChainState) (caddr : Address) (trace : ChainTrace empty_state bstate), env_contracts bstate caddr = Some (lqt_contract : WeakContract) -> exists (cstate : State) (depinfo : DeploymentInfo Setup) @@ -150,7 +150,7 @@ Section LQTFA12Types. (let initial_tokens := initial_pool (deployment_setup depinfo) in Z.of_N (total_supply cstate) = (Z.of_N initial_tokens + - sumZ (fun callInfo => mintedOrBurnedTokens (call_msg callInfo)) + sumZ (fun callInfo => mintedOrBurnedTokens (call_msg callInfo)) (filter (callFrom (admin cstate)) inc_calls))%Z) }. End LQTFA12Types. @@ -242,17 +242,17 @@ Module Dexter2Lqt (SI : Dexter2LqtSerializable). Import SI. (* begin hide *) - Existing Instance callback_serializable. - Existing Instance transfer_param_serializable. - Existing Instance approve_param_serializable. - Existing Instance mintOrBurn_param_serializable. - Existing Instance getAllowance_param_serializable. - Existing Instance getBalance_param_serializable. - Existing Instance getTotalSupply_param_serializable. - Existing Instance FA12ReceiverMsg_serializable. - Existing Instance msg_serializable. - Existing Instance state_serializable. - Existing Instance setup_serializable. + #[global] Existing Instance callback_serializable. + #[global] Existing Instance transfer_param_serializable. + #[global] Existing Instance approve_param_serializable. + #[global] Existing Instance mintOrBurn_param_serializable. + #[global] Existing Instance getAllowance_param_serializable. + #[global] Existing Instance getBalance_param_serializable. + #[global] Existing Instance getTotalSupply_param_serializable. + #[global] Existing Instance FA12ReceiverMsg_serializable. + #[global] Existing Instance msg_serializable. + #[global] Existing Instance state_serializable. + #[global] Existing Instance setup_serializable. (* end hide *) Section DexterLqtDefs. diff --git a/examples/dexter2/Dexter2FA12Correct.v b/examples/dexter2/Dexter2FA12Correct.v index 48887143..54eb50f2 100644 --- a/examples/dexter2/Dexter2FA12Correct.v +++ b/examples/dexter2/Dexter2FA12Correct.v @@ -53,7 +53,7 @@ Section Theories. ((ctx_amount ctx) <= 0)%Z. Proof. intros * receive_some. - unfold receive_lqt, throwIf in receive_some;cbn in receive_some. + unfold receive_lqt, throwIf in receive_some; cbn in receive_some. destruct (0 0 *) congruence. @@ -66,7 +66,7 @@ Section Theories. receive_lqt chain ctx prev_state msg = Err default_error. Proof. intros * ctx_amount_positive. - unfold receive_lqt,throwIf;cbn. + unfold receive_lqt,throwIf; cbn. destruct (0 0 *) reflexivity. @@ -146,7 +146,7 @@ Section Theories. - (* from = to *) destruct (address_eqb_spec param.(from) param.(to)) as [<-|]; auto. rewrite !FMap.map_update_idemp. - rewrite !FMap.find_update_eq with (map:=prev_state.(tokens)). + rewrite !FMap.find_update_eq with (map := prev_state.(tokens)). destruct (FMap.find (from param) _) eqn:from_prev; cbn in *. + now apply maybe_sub_add in enough_balance as [[-> ->] | ->]; rewrite N.eqb_refl. + rewrite N.add_0_l. @@ -154,7 +154,7 @@ Section Theories. now rewrite enough_balance. - (* from <> to *) destruct (address_eqb_spec param.(from) param.(to)) as [| from_to_eq]; auto. - rewrite !FMap.find_update_ne with (map:=prev_state.(tokens)) by auto. + rewrite !FMap.find_update_ne with (map := prev_state.(tokens)) by auto. rewrite !FMap.find_update_ne by auto. rewrite !FMap.find_update_eq. destruct (FMap.find (from param) _) eqn:from_prev; cbn; @@ -318,7 +318,7 @@ Section Theories. - intros (amount_zero & enough_balance & enough_allowance). apply Z.ltb_ge in amount_zero. cbn. - rewrite amount_zero;cbn. + rewrite amount_zero; cbn. destruct_match eqn:receive_some; destruct_match eqn:allowances_eq in receive_some; destruct_match eqn:sender_from_eqb in allowances_eq; try congruence; @@ -349,8 +349,8 @@ Section Theories. rewrite N.ltb_ge in *. destruct_match eqn:sender_from_eqb in *. destruct (address_eqb_spec ctx.(ctx_from) param.(from)) as - [send_from_eq | sender_from_ne];contract_simpl;try discriminate. - + (* sender = from *) + [send_from_eq | sender_from_ne]; contract_simpl; try discriminate. + + (* sender = from *) now split. + (* sender <> from *) destruct_match eqn:enough_allowance in *; try congruence. @@ -475,8 +475,8 @@ Section Theories. contract_simpl. rewrite Z.ltb_ge in *. cbn. - rewrite N2Z.inj_abs_N, Z.abs_eq;auto. - unfold FMap.find in *;lia. + rewrite N2Z.inj_abs_N, Z.abs_eq; auto. + unfold FMap.find in *; lia. Qed. @@ -715,7 +715,7 @@ Section Theories. |apply try_get_allowance_new_acts_correct in H |apply try_get_balance_new_acts_correct in H |apply try_get_total_supply_new_acts_correct in H ]; - subst;eauto + subst; eauto end. Ltac try_solve_preserves_state := @@ -724,7 +724,7 @@ Section Theories. first [apply try_get_allowance_preserves_state in H |apply try_get_balance_preserves_state in H |apply try_get_total_supply_preserves_state in H]; - subst;eauto + subst; eauto end. (* end hide *) @@ -801,7 +801,7 @@ Section Theories. Proof. intros * receive_some. destruct msg. - - destruct m;try_solve_acts_correct. + - destruct m; try_solve_acts_correct. - contract_simpl. Qed. @@ -814,7 +814,7 @@ Section Theories. apply (lift_outgoing_acts_prop contract); auto. intros * receive_some. simpl in *. destruct msg. - - destruct m;try_solve_acts_correct. + - destruct m; try_solve_acts_correct. - contract_simpl. Qed. @@ -929,7 +929,7 @@ Section Theories. Proof. intros * reach deployed. apply (lift_contract_state_prop contract); - intros *;simpl in *; auto; clear reach deployed bstate caddr. + intros *; simpl in *; auto; clear reach deployed bstate caddr. - intros init_some. unfold sum_balances. cbn in *. erewrite init_total_supply_correct, init_balances_correct; eauto. @@ -948,7 +948,7 @@ Section Theories. [rewrite FMap.find_update_eq | rewrite FMap.find_update_ne by auto]; destruct (FMap.find (from param) _) eqn:from_balance; destruct (FMap.find (to param) (tokens cstate)) eqn:to_balance; - destruct param;cbn in *; + destruct param; cbn in *; unshelve (repeat match goal with | H : ?x = ?y |- context [ ?x ] => rewrite H | H : _ <= 0 |- _ => apply N.lt_eq_cases in H as [H | H]; try lia; subst @@ -986,7 +986,7 @@ Section Theories. | |- context [ maybe _ ] => specialize maybe_cases as [[-> ?H] | [-> _]] | H : ?y <> ?x |- context [ sumN _ ((?x, ?n) :: FMap.elements (FMap.remove ?y _)) ] => cbn; rewrite N.add_comm; change n with ((fun '(_, v) => v) (y, n)); rewrite sumN_inv - end);try easy. + end); try easy. + erewrite <- try_approve_preserves_total_supply; eauto. unfold sum_balances. erewrite <- try_approve_preserves_balances; eauto. @@ -1177,7 +1177,7 @@ Section Theories. Proof. contract_induction; intros; auto. - - now cbn in *;erewrite init_total_supply_correct by eauto. + - now cbn in *; erewrite init_total_supply_correct by eauto. - instantiate (CallFacts := fun _ ctx state _ _ => total_supply state = sum_balances state /\ ctx_from ctx <> ctx_contract_address ctx). diff --git a/examples/dexter2/Dexter2FA12Extract.v b/examples/dexter2/Dexter2FA12ExtractLIGO.v similarity index 100% rename from examples/dexter2/Dexter2FA12Extract.v rename to examples/dexter2/Dexter2FA12ExtractLIGO.v diff --git a/examples/dexter2/Dexter2Printers.v b/examples/dexter2/Dexter2Printers.v index 8bd6535d..68204537 100644 --- a/examples/dexter2/Dexter2Printers.v +++ b/examples/dexter2/Dexter2Printers.v @@ -2,7 +2,7 @@ From ConCert.Execution Require Import Blockchain. From ConCert.Execution Require Import Serializable. From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.FA2 Require Import FA2Token. -From ConCert.Examples.FA2 Require Import FA2Printers. +From ConCert.Examples.FA2 Require Export FA2Printers. From ConCert.Examples.Dexter2 Require Import Dexter2CPMM. From ConCert.Examples.Dexter2 Require Import Dexter2FA12. @@ -25,6 +25,7 @@ Module NullAddressLocalBlockcain <: NullAddress. End NullAddressLocalBlockcain. Module DEX2 := Dexter2 DSInstances NullAddressLocalBlockcain. +#[export] Instance showAddLiqduidityParam : Show add_liquidity_param := {| show p := "params{" ++ @@ -34,6 +35,7 @@ Instance showAddLiqduidityParam : Show add_liquidity_param := "deadline: " ++ show p.(add_deadline) ++ "}" |}. +#[export] Instance showRemoveLiqduidityParam : Show remove_liquidity_param := {| show p := "params{" ++ @@ -44,6 +46,7 @@ Instance showRemoveLiqduidityParam : Show remove_liquidity_param := "deadline: " ++ show p.(remove_deadline) ++ "}" |}. +#[export] Instance showXtzToTokenParam : Show xtz_to_token_param := {| show p := "params{" ++ @@ -52,6 +55,7 @@ Instance showXtzToTokenParam : Show xtz_to_token_param := "deadline: " ++ show p.(xtt_deadline) ++ "}" |}. +#[export] Instance showTokenToXtzParam : Show token_to_xtz_param := {| show p := "params{" ++ @@ -61,6 +65,7 @@ Instance showTokenToXtzParam : Show token_to_xtz_param := "deadline: " ++ show p.(ttx_deadline) ++ "}" |}. +#[export] Instance showSetBakerParam : Show set_baker_param := {| show p := "params{" ++ @@ -68,6 +73,7 @@ Instance showSetBakerParam : Show set_baker_param := "freeze: " ++ show p.(freezeBaker_) ++ "}" |}. +#[export] Instance showTokenToTokenParam : Show token_to_token_param := {| show p := "params{" ++ @@ -78,6 +84,7 @@ Instance showTokenToTokenParam : Show token_to_token_param := "deadline: " ++ show p.(ttt_deadline) ++ "}" |}. +#[export] Instance showCPMMDexterMsg : Show DexterMsg := {| show m := @@ -94,11 +101,13 @@ Instance showCPMMDexterMsg : Show DexterMsg := end |}. +#[export] Instance showCPMMMsg : Show Dexter2CPMM.Msg := {| show m := show m |}. +#[export] Instance showCPMMSetup : Show Dexter2CPMM.Setup := {| show p := "Setup{" ++ @@ -108,6 +117,7 @@ Instance showCPMMSetup : Show Dexter2CPMM.Setup := "token Id: " ++ show p.(tokenId_) ++ "}" |}. +#[export] Instance showCPMMState : Show Dexter2CPMM.State := {| show p := "State{" ++ @@ -123,6 +133,7 @@ Instance showCPMMState : Show Dexter2CPMM.State := |}. (** * Dexter2 Lqt Token printers *) +#[export] Instance showLqtSetup : Show Dexter2FA12.Setup := {| show p := "Setup{" ++ @@ -131,6 +142,7 @@ Instance showLqtSetup : Show Dexter2FA12.Setup := "initial pool: " ++ show p.(initial_pool) ++ "}" |}. +#[export] Instance showLqtState : Show Dexter2FA12.State := {| show p := "State{" ++ @@ -140,6 +152,7 @@ Instance showLqtState : Show Dexter2FA12.State := "admin: " ++ show p.(admin) ++ "}" |}. +#[export] Instance showTransferParam : Show transfer_param := {| show p := "params{" ++ @@ -148,6 +161,7 @@ Instance showTransferParam : Show transfer_param := "value: " ++ show p.(value) ++ "}" |}. +#[export] Instance showApproveParam : Show approve_param := {| show p := "params{" ++ @@ -155,6 +169,7 @@ Instance showApproveParam : Show approve_param := "value: " ++ show p.(value_) ++ "}" |}. +#[export] Instance showMintOrBurnParam : Show mintOrBurn_param := {| show p := "params{" ++ @@ -162,6 +177,7 @@ Instance showMintOrBurnParam : Show mintOrBurn_param := "target: " ++ show p.(target) ++ "}" |}. +#[export] Instance showGetAllowanceParam : Show getAllowance_param := {| show p := "params{" ++ @@ -169,6 +185,7 @@ Instance showGetAllowanceParam : Show getAllowance_param := "callback addr: " ++ show p.(allowance_callback).(return_addr) ++ "}" |}. +#[export] Instance showGetBalanceParam : Show getBalance_param := {| show p := "params{" ++ @@ -176,12 +193,14 @@ Instance showGetBalanceParam : Show getBalance_param := "callback addr: " ++ show p.(balance_callback).(return_addr) ++ "}" |}. +#[export] Instance showGetTotalSupplyParam : Show getTotalSupply_param := {| show p := "params{" ++ "callback addr: " ++ show p.(supply_callback).(return_addr) ++ "}" |}. +#[export] Instance showLqtMsg : Show Dexter2FA12.Msg := {| show m := @@ -196,6 +215,7 @@ Instance showLqtMsg : Show Dexter2FA12.Msg := |}. (** * Combined message printer *) +#[export] Instance showSerializedMsg : Show SerializedValue := Derive Show Msg < FA2Token.Msg, diff --git a/examples/dexter2/Dexter2Tests.v b/examples/dexter2/Dexter2Tests.v index db0e18cc..2b32a821 100644 --- a/examples/dexter2/Dexter2Tests.v +++ b/examples/dexter2/Dexter2Tests.v @@ -7,7 +7,7 @@ From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.Dexter2 Require Import Dexter2CPMM. From ConCert.Examples.Dexter2 Require Import Dexter2FA12. From ConCert.Examples.Dexter2 Require Import Dexter2Gens. -From ConCert.Examples.Dexter2 Require Import Dexter2Printers. +From ConCert.Examples.Dexter2 Require Export Dexter2Printers. From ConCert.Examples.FA2 Require Import FA2Token. From ConCert.Examples.FA2 Require Import FA2LegacyInterface. From Coq Require Import ZArith_base. diff --git a/examples/eip20/EIP20LiquidityExtraction.v b/examples/eip20/EIP20LiquidityExtraction.v index 2b048fe1..3bf7cb4e 100644 --- a/examples/eip20/EIP20LiquidityExtraction.v +++ b/examples/eip20/EIP20LiquidityExtraction.v @@ -3,7 +3,7 @@ From MetaCoq.Template Require Import All. From ConCert.Embedding Require Import Notations. From ConCert.Embedding.Extraction Require Import PreludeExt. -From ConCert.Extraction Require LPretty. +From ConCert.Extraction Require LiquidityPretty. From ConCert.Extraction Require Import LiquidityExtract. From ConCert.Extraction Require Import Common. From ConCert.Execution Require Import Monad. @@ -125,7 +125,7 @@ Section EIP20TokenExtraction. lmd_module_name := "liquidity_eip20token" ; (* definitions of operations on pairs and ints *) - lmd_prelude := LPretty.LiquidityPrelude; + lmd_prelude := LiquidityPretty.LiquidityPrelude; (* initial storage *) lmd_init := init ; @@ -140,7 +140,7 @@ Section EIP20TokenExtraction. ++ nl ++ printERC20Wrapper (PREFIX ++ "receive_wrapper") ++ nl - ++ LPretty.printMain + ++ LiquidityPretty.printMain |}. diff --git a/examples/eip20/EIP20Token.v b/examples/eip20/EIP20Token.v index 0de80f1a..a3f946ea 100644 --- a/examples/eip20/EIP20Token.v +++ b/examples/eip20/EIP20Token.v @@ -44,7 +44,7 @@ Section EIP20Token. owner : Address; init_amount : TokenValue; }. - + Definition Error : Type := nat. Definition default_error : Error := 1%nat. diff --git a/examples/eip20/EIP20TokenCorrect.v b/examples/eip20/EIP20TokenCorrect.v index 577670c4..949c7bf9 100644 --- a/examples/eip20/EIP20TokenCorrect.v +++ b/examples/eip20/EIP20TokenCorrect.v @@ -43,7 +43,7 @@ Section Theories. Lemma receive_not_payable : forall prev_state new_state chain ctx msg new_acts, receive chain ctx prev_state (Some msg) = Ok (new_state, new_acts) -> match msg with - | transfer to amount => (try_transfer (ctx_from ctx) to amount prev_state) >>= (fun new_state : State => Ok (new_state, [])) + | transfer to amount => (try_transfer (ctx_from ctx) to amount prev_state) >>= (fun new_state : State => Ok (new_state, [])) | transfer_from from to amount => (try_transfer_from (ctx_from ctx) from to amount prev_state) >>= (fun new_state : State => Ok (new_state, [])) | approve delegate amount => @@ -135,7 +135,7 @@ Section Theories. Ltac address_map_convert := match goal with | H : context [ AddressMap.find _ _ ] |- _ => rewrite AddressMap_find_convertible in H - | H : context [ AddressMap.add _ _ _ ] |- _ => rewrite AddressMap_add_convertible in H + | H : context [ AddressMap.add _ _ _ ] |- _ => rewrite AddressMap_add_convertible in H | H : context [ increment_balance _ _ _ ] |- _ => rewrite increment_balanace_is_partial_alter_plus in H | |- context [ AddressMap.find _ _ ] => rewrite AddressMap_find_convertible | |- context [ AddressMap.add _ _ _ ] => rewrite AddressMap_add_convertible @@ -162,10 +162,10 @@ Section Theories. | H : ?x' <> ?x |- context [ FMap.find ?x' (FMap.partial_alter _ ?x _) ] => setoid_rewrite FMap.find_partial_alter_ne; auto | H : ?x <> ?x' |- context [ FMap.find ?x' (FMap.partial_alter _ ?x _) ] => setoid_rewrite FMap.find_partial_alter_ne | H : context [ AddressMap.find _ _ ] |- _ => rewrite AddressMap_find_convertible in H - | H : context [ AddressMap.add _ _ _ ] |- _ => rewrite AddressMap_add_convertible in H + | H : context [ AddressMap.add _ _ _ ] |- _ => rewrite AddressMap_add_convertible in H | H : context [ increment_balance _ _ _ ] |- _ => rewrite increment_balanace_is_partial_alter_plus in H | |- context [ AddressMap.find _ _ ] => rewrite AddressMap_find_convertible - | |- context [ AddressMap.add _ _ _ ] => rewrite AddressMap_add_convertible + | |- context [ AddressMap.add _ _ _ ] => rewrite AddressMap_add_convertible | |- context [ increment_balance _ _ _ ] => rewrite increment_balanace_is_partial_alter_plus end. @@ -212,7 +212,7 @@ Section Theories. | H : FMap.find ?x _ = Some ?n |- context [ sumN _ ((?x, ?n) :: (_, _) :: FMap.elements (FMap.remove ?x _)) ] => rewrite sumN_swap, fin_maps.map_to_list_delete; auto | |- context [ _ + 0 ] => rewrite N.add_0_r | |- context [ 0 + _ ] => rewrite N.add_0_l - | |- context [ sumN _ ((?t, ?n + ?m) :: _) ] => erewrite sumN_split with (x:= (t, n)) (y := (_, m)) by lia + | |- context [ sumN _ ((?t, ?n + ?m) :: _) ] => erewrite sumN_split with (x := (t, n)) (y := (_, m)) by lia | |- context [ sumN _ ((_, ?n) :: (_, ?m - ?n) :: _) ] => erewrite <- sumN_split with (z := (_, n + m - n)) by lia end. Unshelve. eauto. @@ -264,17 +264,17 @@ Section Theories. destruct_address_eq; destruct (FMap.find (ctx_from ctx) (balances prev_state)) eqn:from_prev; try congruence; subst; try (rewrite from_prev || setoid_rewrite from_prev); clear from_prev new_acts chain; cbn in *. - - (* case: from = to && find from = Some n && amount <= n *) + - (* case: from = to && find from = Some n && amount <= n *) FMap_simpl. now rewrite N.sub_add, N.eqb_refl. - - (* case: from = to && find from = None && amount = 0 *) + - (* case: from = to && find from = None && amount = 0 *) apply N.lt_eq_cases in sender_enough_balance as []; [lia | subst]. now FMap_simpl. - (* case: from <> to && find from = Some n && amount <= n *) FMap_simpl. rewrite N.sub_add; auto. now rewrite !N.eqb_refl. - - (* case: from <> to && find from = None && amount = 0 *) + - (* case: from <> to && find from = None && amount = 0 *) apply N.lt_eq_cases in sender_enough_balance as []; [lia | subst]. FMap_simpl. apply N.eqb_refl. @@ -361,17 +361,17 @@ Section Theories. destruct_address_eq; destruct (FMap.find from (balances prev_state)) eqn:from_bal_prev; subst; try (rewrite from_bal_prev || setoid_rewrite from_bal_prev); cbn in *. - * (* case: from = to && find from = Some n && amount <= n *) + * (* case: from = to && find from = Some n && amount <= n *) FMap_simpl. now rewrite N.sub_add, N.eqb_refl. - * (* case: from = to && find from = None && amount = 0 *) + * (* case: from = to && find from = None && amount = 0 *) apply N.lt_eq_cases in from_enough_balance as []; [lia | subst]. now FMap_simpl. * (* case: from <> to && find from = Some n && amount <= n *) FMap_simpl. rewrite N.sub_add by auto. now rewrite ?N.eqb_refl. - * (* case: from <> to && find from = None && amount = 0 *) + * (* case: from <> to && find from = None && amount = 0 *) apply N.lt_eq_cases in from_enough_balance as []; [lia | subst]. FMap_simpl. apply N.eqb_refl. diff --git a/examples/eip20/EIP20TokenGens.v b/examples/eip20/EIP20TokenGens.v index f4865b49..2c3a5b4f 100644 --- a/examples/eip20/EIP20TokenGens.v +++ b/examples/eip20/EIP20TokenGens.v @@ -70,7 +70,7 @@ Module EIP20Gens (Info : EIP20GensInfo). amount <- (if allower_balance =? 0 then returnGen 0 else choose (0, N.min allowance allower_balance)) ;; - returnGenSome (delegate, transfer_from allower receiver amount) + returnGenSome (delegate, transfer_from allower receiver amount) ) )). diff --git a/examples/eip20/EIP20TokenPrinters.v b/examples/eip20/EIP20TokenPrinters.v index 267001de..869ba410 100644 --- a/examples/eip20/EIP20TokenPrinters.v +++ b/examples/eip20/EIP20TokenPrinters.v @@ -5,11 +5,13 @@ From ConCert.Examples.EIP20 Require Import EIP20Token. Local Open Scope string_scope. +#[export] Instance showTokenValue : Show TokenValue := {| show v := show v |}. +#[export] Instance showMsg : Show Msg := {| show m := @@ -23,6 +25,7 @@ Instance showMsg : Show Msg := end |}. +#[export] Instance showTokenSetup : Show Setup := {| show setup := "Setup{owner: " @@ -33,6 +36,7 @@ Instance showTokenSetup : Show Setup := ++ "}" |}. +#[export] Instance showTokenState : Show EIP20Token.State := {| show s := "State{total_supply: " ++ show s.(total_supply) ++ sep @@ -40,5 +44,6 @@ Instance showTokenState : Show EIP20Token.State := ++ "allowances: " ++ show s.(allowances) ++ "}" |}. +#[export] Instance showSerializedMsg : Show SerializedValue := Derive Show Msg < Msg, Setup >. diff --git a/examples/eip20/EIP20TokenTests.v b/examples/eip20/EIP20TokenTests.v index d2642453..13c0969d 100644 --- a/examples/eip20/EIP20TokenTests.v +++ b/examples/eip20/EIP20TokenTests.v @@ -4,7 +4,7 @@ From ConCert.Execution Require Import Containers. From ConCert.Execution Require Import Serializable. From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.EIP20 Require Import EIP20Token. -From ConCert.Examples.EIP20 Require Import EIP20TokenPrinters. +From ConCert.Examples.EIP20 Require Export EIP20TokenPrinters. From ConCert.Examples.EIP20 Require Import EIP20TokenGens. From Coq Require Import ZArith. From Coq Require Import List. @@ -332,7 +332,7 @@ Definition state_has_some_approve_act (cs : ChainState) := | None => None end. -Definition delegate_made_no_transferFroms (approve_act_p : (Address * Address * EIP20Token.Msg)) +Definition delegate_made_no_transferFroms (approve_act_p : (Address * Address * EIP20Token.Msg)) (cs : ChainState) := let caddr := fst (fst approve_act_p) in let approver := snd (fst approve_act_p) in @@ -379,7 +379,7 @@ Definition transfer_from_amount (transferFrom_act_p : (Address * Address * EIP20 Definition allower_reapproves_delegate_step allower delegate (cs : ChainState) := let acts := cs.(chain_state_queue) in match find isSome (map get_approve_act acts) with - | Some (Some (caddr, caller, (approve delegate' amount)) as act) => + | Some (Some (caddr, caller, (approve delegate' amount)) as act) => if address_eqb caller allower && address_eqb delegate delegate' then Some amount else None @@ -427,7 +427,7 @@ Definition allower_reapproves_transferFrom_correct (pre_trace post_trace : list ++ show delegate_spent_incl_reapproval_act ++ " on behalf of " ++ show allower ++ " when they were only allowed to spend at most " - ++ show total_allowed ++ nl) + ++ show total_allowed ++ nl) (delegate_spent_incl_reapproval_act <=? total_allowed) | None => checker false end) in @@ -460,7 +460,7 @@ Action{act_from: 10%256, act_body: (act_call 128%256, 0, approve 12%256 32)}; Action{act_from: 10%256, act_body: (act_call 128%256, 0, approve 11%256 23)}]; Block 4 [ Action{act_from: 12%256, act_body: (act_call 128%256, 0, transfer_from 10%256 10%256 25)}; -Action{act_from: 10%256, act_body: (act_call 128%256, 0, approve 12%256 8)}];|} +Action{act_from: 10%256, act_body: (act_call 128%256, 0, approve 12%256 8)}]; |} 12%256 spent 25 on behalf of 10%256 when they were only allowed to spend at most 8 diff --git a/examples/escrow/EscrowCorrect.v b/examples/escrow/EscrowCorrect.v index b684b67b..9e4136c4 100644 --- a/examples/escrow/EscrowCorrect.v +++ b/examples/escrow/EscrowCorrect.v @@ -45,7 +45,7 @@ Section Theories. clear IH. unfold receive in receive_some. destruct_match as [[]|] in receive_some; try congruence. - + destruct_match in receive_some; try congruence;cbn in *. + + destruct_match in receive_some; try congruence; cbn in *. destruct_match in receive_some; cbn in *; try congruence. destruct_match in receive_some; cbn in *; try congruence. destruct_match in receive_some; cbn in *; try congruence. @@ -257,7 +257,7 @@ Section Theories. + (* Some commit_money *) destruct (next_step prev_state); try congruence. unfold subAmountOption in *. - destruct (ctx_contract_balance ctx |]; cbn in *; try congruence. destruct (ctx_amount ctx =? _) eqn:proper_amount in receive_some; @@ -272,7 +272,7 @@ Section Theories. replace (ctx_contract_balance _) with (2 * item_worth + 2 * item_worth / 2 * 2) by lia. rewrite <- Z.mul_comm. rewrite Z.div_mul by lia. - repeat split;eauto. + repeat split; eauto. lia. + (* Some confirm_item_received *) destruct_match in receive_some; cbn in *; try congruence. @@ -296,7 +296,7 @@ Section Theories. rewrite (Z.mul_comm 4). rewrite Z.div_mul by lia. destruct (Z.eqb_spec (2 * item_worth) 0); cbn in *; try lia. - repeat split; eauto;lia. + repeat split; eauto; lia. + (* Some withdraw. Can be sent while next_step is either commit_money or withdrawals. *) destruct_match eqn:prev_next_step in receive_some; diff --git a/examples/escrow/extraction/EscrowExtractLIGO.v b/examples/escrow/extraction/EscrowLIGO.v similarity index 98% rename from examples/escrow/extraction/EscrowExtractLIGO.v rename to examples/escrow/extraction/EscrowLIGO.v index d3fb2a11..0cf18b7f 100644 --- a/examples/escrow/extraction/EscrowExtractLIGO.v +++ b/examples/escrow/extraction/EscrowLIGO.v @@ -59,10 +59,11 @@ Definition escrow_receive (c : Chain) Module EscrowCameLIGOExtraction. Import CameLIGOExtract. Import CameLIGOPretty. + #[local] Existing Instance PrintConfShortNames.PrintWithShortNames. (** A translation table of constructors and some constants. The corresponding definitions will be extracted and renamed. *) - Definition TT_rename_ligo : list (string * string):= + Definition TT_rename_ligo : list (string * string) := [ ("true", "true") ; ("false", "false") ; ("tt", "()") diff --git a/examples/escrow/extraction/EscrowExtractLiquidity.v b/examples/escrow/extraction/EscrowLiquidity.v similarity index 96% rename from examples/escrow/extraction/EscrowExtractLiquidity.v rename to examples/escrow/extraction/EscrowLiquidity.v index 7eb0c255..5eb481ab 100644 --- a/examples/escrow/extraction/EscrowExtractLiquidity.v +++ b/examples/escrow/extraction/EscrowLiquidity.v @@ -8,7 +8,7 @@ From ConCert.Execution Require Monad. From ConCert.Execution Require OptionMonad. From ConCert.Examples.Escrow Require Import Escrow. From ConCert.Extraction Require Import Common. -From ConCert.Extraction Require LPretty. +From ConCert.Extraction Require LiquidityPretty. From ConCert.Extraction Require LiquidityExtract. From Coq Require Import String. From Coq Require Import ZArith_base. @@ -33,7 +33,7 @@ Definition escrow_receive (c : Chain) Module EscrowLiquidityExtraction. Definition PREFIX := "". - Import LPretty. + Import LiquidityPretty. Import LiquidityExtract. (** A translation table for definitions we want to remap. The corresponding top-level definitions will be *ignored* *) @@ -71,9 +71,9 @@ Module EscrowLiquidityExtraction. lmd_receive := liquidity_escrow_receive ; (* code for the entry point *) - lmd_entry_point := storageDef ++ nl - ++ printWrapper (PREFIX ++ "liquidity_escrow_receive") ++ nl - ++ printMain + lmd_entry_point := storageDef ++ nl + ++ printWrapper (PREFIX ++ "liquidity_escrow_receive") ++ nl + ++ printMain |}. diff --git a/examples/escrow/extraction/MidlangEscrow.v b/examples/escrow/extraction/EscrowMidlang.v similarity index 98% rename from examples/escrow/extraction/MidlangEscrow.v rename to examples/escrow/extraction/EscrowMidlang.v index 0e59a59a..7b77728f 100644 --- a/examples/escrow/extraction/MidlangEscrow.v +++ b/examples/escrow/extraction/EscrowMidlang.v @@ -18,6 +18,7 @@ From Coq Require Import String. Import MCMonadNotation. Open Scope string. +#[local] Instance EscrowMidlangBoxes : ElmPrintConfig := {| term_box_symbol := "()"; type_box_symbol := "()"; @@ -26,8 +27,8 @@ Instance EscrowMidlangBoxes : ElmPrintConfig := print_full_names := true; (* full names to avoid clashes*)|}. Definition TT_escrow : list (kername * string) := - [ remap <%% bool %%> "Bool" - ; remap <%% @Address %%> "Int"]. + [ remap <%% bool %%> "Bool" + ; remap <%% @Address %%> "Int"]. Definition midlang_translation_map := Eval compute in @@ -64,6 +65,7 @@ Definition extract_params := extract_transforms := [Optimize.dearg_transform (fun _ => None) true true true true true] |} |}. Axiom extraction_chain_base : ChainBase. +#[local] Existing Instance extraction_chain_base. MetaCoq Run (p <- tmQuoteRecTransp Escrow.receive false ;; diff --git a/examples/escrow/extraction/RustEscrow.v b/examples/escrow/extraction/EscrowRust.v similarity index 99% rename from examples/escrow/extraction/RustEscrow.v rename to examples/escrow/extraction/EscrowRust.v index b2faa1a8..89170f69 100644 --- a/examples/escrow/extraction/RustEscrow.v +++ b/examples/escrow/extraction/EscrowRust.v @@ -19,6 +19,7 @@ Definition should_inline kn := || if String.index 0 "setter_from_getter" (string_of_kername kn) then true else false. (* NOTE: it is important to declare a priting config, otherwise MetaCoq evaluation tries to normalise a term with an unresolved instance and runs out of memory. *) +#[local] Existing Instance DefaultPrintConfig.RustConfig. Redirect "../extraction/tests/extracted-code/concordium-extract/escrow.rs" diff --git a/examples/escrow/tests/EscrowGens.v b/examples/escrow/tests/EscrowGens.v index 5bd8748c..62991e68 100644 --- a/examples/escrow/tests/EscrowGens.v +++ b/examples/escrow/tests/EscrowGens.v @@ -21,7 +21,7 @@ Definition Env := Environment. Open Scope Z_scope. (* Try to generate an account which has balance > 0. - Returns None whenever no such address could be found. *) + Returns None whenever no such address could be found. *) Definition gAccountWithBalance (e : Env) (gAccOpt : GOpt Address) : GOpt (Address * Amount) := diff --git a/examples/escrow/tests/EscrowPrinters.v b/examples/escrow/tests/EscrowPrinters.v index 5d410330..fd1d7837 100644 --- a/examples/escrow/tests/EscrowPrinters.v +++ b/examples/escrow/tests/EscrowPrinters.v @@ -10,11 +10,13 @@ Local Open Scope string_scope. Derive Show for NextStep. Derive Show for Msg. +#[export] Instance showEscrowSetup : Show Setup := {| show setup := "Setup{buyer: " ++ show setup.(setup_buyer) ++ "}" |}. +#[export] Instance showEscrowState : Show Escrow.State := {| show s := "EscrowState{" ++ @@ -26,5 +28,6 @@ Instance showEscrowState : Show Escrow.State := "buyer_withdrawable: " ++ show s.(buyer_withdrawable) ++ "}" |}. +#[export] Instance showSerializedMsg : Show SerializedValue := Derive Show Msg < Msg, Setup >. diff --git a/examples/escrow/tests/EscrowTests.v b/examples/escrow/tests/EscrowTests.v index 6e2afd6f..11f73e3c 100644 --- a/examples/escrow/tests/EscrowTests.v +++ b/examples/escrow/tests/EscrowTests.v @@ -10,7 +10,7 @@ From ConCert.Execution Require Import ResultMonad. From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.Escrow Require Import Escrow. From ConCert.Examples.Escrow Require Import EscrowCorrect. -From ConCert.Examples.Escrow Require Import EscrowPrinters. +From ConCert.Examples.Escrow Require Export EscrowPrinters. From ConCert.Examples.Escrow Require Import EscrowGens. From Coq Require Import ZArith. From Coq Require Import List. @@ -133,7 +133,7 @@ Section TestProperties. Qed. (* Finally, we can show that escrow_correct_Prop is decidable (using escrow_correct_bool as - the decision procedure). *) + the decision procedure). *) Global Instance escrow_correct_P_dec {from to caddr cstate trace depinfo inc_calls} : Dec (@escrow_correct_Prop from to caddr cstate trace depinfo inc_calls). Proof. @@ -158,8 +158,8 @@ Section TestProperties. let trace := builder_trace cb in let depinfo' := deployment_info Escrow.Setup trace escrow_contract_addr in let inc_calls' := incoming_calls Escrow.Msg trace escrow_contract_addr in - depinfo' ===> (fun depinfo => - inc_calls' ===> (fun inc_calls => + depinfo' ===> (fun depinfo => + inc_calls' ===> (fun inc_calls => match get_contract_state Escrow.State cb escrow_contract_addr with (* main part of the property: *) | Some cstate => @@ -181,7 +181,7 @@ Section TestProperties. match trace with | snoc trace' step => match acc, get_contract_state Escrow.State to escrow_caddr with - | nextstep::_, Some state => if (nextstep = state.(next_step))? + | nextstep ::_, Some state => if (nextstep = state.(next_step))? then rec trace' acc else rec trace' (state.(next_step) :: acc) | [], Some state => rec trace' (state.(next_step) :: acc) @@ -219,8 +219,8 @@ Section TestProperties. Fixpoint is_valid_step_sequence_fix steps prev_step := match prev_step, steps with | _, [] => true - | None, step::steps' => is_valid_step_sequence_fix steps' (Some step) - | Some prev_step, step::steps' => match prev_step, step with + | None, step ::steps' => is_valid_step_sequence_fix steps' (Some step) + | Some prev_step, step ::steps' => match prev_step, step with | buyer_commit, buyer_confirm | buyer_commit, no_next_step | buyer_confirm, withdrawals @@ -252,7 +252,7 @@ Discarded: 20000 *) (* +++ Passed 10000 tests (0 discards) *) (* Or alternatively we can just write: *) (* QuickChick escrow_correct_P. *) -(* +++ Passed 10000 tests (40 discards) *) +(* +++ Passed 10000 tests (40 discards) *) (* Not sure where the 40 discards come from, but it's an acceptable amount for sure... *) (* Note that we are implicitly using the "better" generator here to generate arbitrary ChainTraces *) diff --git a/examples/exchangeBuggy/ExchangeBuggy.v b/examples/exchangeBuggy/ExchangeBuggy.v index 7fae0c42..d4947188 100644 --- a/examples/exchangeBuggy/ExchangeBuggy.v +++ b/examples/exchangeBuggy/ExchangeBuggy.v @@ -50,7 +50,7 @@ Section ExchangeBuggyContract. Definition Error : Type := nat. Definition default_error : Error := 1%nat. - + (* begin hide *) MetaCoq Run (make_setters State). MetaCoq Run (make_setters Setup). @@ -145,7 +145,7 @@ Section ExchangeBuggyContract. act_call state.(fa2_caddr) 0%Z (@serialize FA2Token.Msg _ (token_transfer_param)) in (* Remove exchange from ongoing exchanges in state *) let state := state<| ongoing_exchanges := removelast state.(ongoing_exchanges)|> - <| price_history := tokens_price :: state.(price_history) |> in + <| price_history := tokens_price :: state.(price_history) |> in Ok (state, [asset_transfer_msg; token_transfer_msg]). Definition create_tokens (tokenid : token_id) diff --git a/examples/exchangeBuggy/ExchangeBuggyGens.v b/examples/exchangeBuggy/ExchangeBuggyGens.v index 83da6745..b0dd877b 100644 --- a/examples/exchangeBuggy/ExchangeBuggyGens.v +++ b/examples/exchangeBuggy/ExchangeBuggyGens.v @@ -40,7 +40,7 @@ Module ExchangeGens (Info : ExchangeTestsInfo). let has_balance p := let ledger := snd p in 0 FA12ReceiverMsg + | receive_allowance : N -> FA12ReceiverMsg | receive_balance_of : N -> FA12ReceiverMsg | receive_total_supply : N -> FA12ReceiverMsg | other_msg : Msg' -> FA12ReceiverMsg. @@ -186,16 +186,16 @@ Module FA12 (SI : FA12Serializable). Import SI. (* begin hide *) - Existing Instance callback_serializable. - Existing Instance transfer_param_serializable. - Existing Instance approve_param_serializable. - Existing Instance getAllowance_param_serializable. - Existing Instance getBalance_param_serializable. - Existing Instance getTotalSupply_param_serializable. - Existing Instance FA12ReceiverMsg_serializable. - Existing Instance msg_serializable. - Existing Instance state_serializable. - Existing Instance setup_serializable. + #[export] Existing Instance callback_serializable. + #[export] Existing Instance transfer_param_serializable. + #[export] Existing Instance approve_param_serializable. + #[export] Existing Instance getAllowance_param_serializable. + #[export] Existing Instance getBalance_param_serializable. + #[export] Existing Instance getTotalSupply_param_serializable. + #[export] Existing Instance FA12ReceiverMsg_serializable. + #[export] Existing Instance msg_serializable. + #[export] Existing Instance state_serializable. + #[export] Existing Instance setup_serializable. (* end hide *) Section FA12Defs. diff --git a/examples/fa1_2/FA1_2Correct.v b/examples/fa1_2/FA1_2Correct.v index 8645fd33..aaceba3e 100644 --- a/examples/fa1_2/FA1_2Correct.v +++ b/examples/fa1_2/FA1_2Correct.v @@ -42,7 +42,7 @@ Section Theories. ((ctx_amount ctx) <= 0)%Z. Proof. intros * receive_some. - unfold receive, throwIf in receive_some;cbn in receive_some. + unfold receive, throwIf in receive_some; cbn in receive_some. destruct (0 0 *) congruence. @@ -55,7 +55,7 @@ Section Theories. receive chain ctx prev_state msg = Err default_error. Proof. intros * ctx_amount_positive. - unfold receive,throwIf;cbn. + unfold receive,throwIf; cbn. destruct (0 0 *) reflexivity. @@ -123,7 +123,7 @@ Section Theories. - (* from = to *) destruct (address_eqb_spec param.(from) param.(to)) as [<-|]; auto. rewrite !FMap.map_update_idemp. - rewrite !FMap.find_update_eq with (map:=prev_state.(tokens)). + rewrite !FMap.find_update_eq with (map := prev_state.(tokens)). destruct (FMap.find (from param) _) eqn:from_prev; cbn in *. + now apply maybe_sub_add in enough_balance as [[-> ->] | ->]; rewrite N.eqb_refl. + rewrite N.add_0_l. @@ -131,7 +131,7 @@ Section Theories. now rewrite enough_balance. - (* from <> to *) destruct (address_eqb_spec param.(from) param.(to)) as [| from_to_eq]; auto. - rewrite !FMap.find_update_ne with (map:=prev_state.(tokens)) by auto. + rewrite !FMap.find_update_ne with (map := prev_state.(tokens)) by auto. rewrite !FMap.find_update_ne by auto. rewrite !FMap.find_update_eq. destruct (FMap.find (from param) _) eqn:from_prev; cbn; @@ -295,7 +295,7 @@ Section Theories. - intros (amount_zero & enough_balance & enough_allowance). apply Z.ltb_ge in amount_zero. cbn. - rewrite amount_zero;cbn. + rewrite amount_zero; cbn. destruct_match eqn:receive_some; destruct_match eqn:allowances_eq in receive_some; destruct_match eqn:sender_from_eqb in allowances_eq; try congruence; @@ -325,8 +325,8 @@ Section Theories. rewrite N.ltb_ge in *. destruct_match eqn:sender_from_eqb in *. destruct (address_eqb_spec ctx.(ctx_from) param.(from)) as - [send_from_eq | sender_from_ne];contract_simpl;try discriminate. - + (* sender = from *) + [send_from_eq | sender_from_ne]; contract_simpl; try discriminate. + + (* sender = from *) now split. + (* sender <> from *) destruct_match eqn:enough_allowance in *; try congruence. @@ -577,7 +577,7 @@ Section Theories. |apply try_get_allowance_new_acts_correct in H |apply try_get_balance_new_acts_correct in H |apply try_get_total_supply_new_acts_correct in H ]; - subst;eauto + subst; eauto end. Ltac try_solve_preserves_state := @@ -586,7 +586,7 @@ Section Theories. first [apply try_get_allowance_preserves_state in H |apply try_get_balance_preserves_state in H |apply try_get_total_supply_preserves_state in H]; - subst;eauto + subst; eauto end. (* end hide *) @@ -663,7 +663,7 @@ Section Theories. Proof. intros * receive_some. destruct msg. - - destruct m;try_solve_acts_correct. + - destruct m; try_solve_acts_correct. - contract_simpl. Qed. @@ -676,7 +676,7 @@ Section Theories. apply (lift_outgoing_acts_prop contract); auto. intros * receive_some. simpl in *. destruct msg. - - destruct m;try_solve_acts_correct. + - destruct m; try_solve_acts_correct. - contract_simpl. Qed. @@ -806,7 +806,7 @@ Section Theories. Proof. intros * reach deployed. apply (lift_contract_state_prop contract); - intros *;simpl in *; auto; clear reach deployed bstate caddr. + intros *; simpl in *; auto; clear reach deployed bstate caddr. - intros init_some. unfold sum_balances. erewrite init_total_supply_correct, init_balances_correct; eauto. @@ -825,7 +825,7 @@ Section Theories. [rewrite FMap.find_update_eq | rewrite FMap.find_update_ne by auto]; destruct (FMap.find (from param) _) eqn:from_balance; destruct (FMap.find (to param) (tokens cstate)) eqn:to_balance; - destruct param;cbn in *; + destruct param; cbn in *; unshelve (repeat match goal with | H : ?x = ?y |- context [ ?x ] => rewrite H | H : _ <= 0 |- _ => apply N.lt_eq_cases in H as [H | H]; try lia; subst @@ -840,7 +840,7 @@ Section Theories. | |- context [ FMap.remove ?x (FMap.add ?x _ _) ] => rewrite fin_maps.delete_insert_delete | H : FMap.find ?x ?m = Some _ |- context [ sumN _ ((_, _) :: FMap.elements (FMap.remove ?x ?m)) ] => rewrite fin_maps.map_to_list_delete; auto | H : FMap.find ?x _ = Some ?n |- context [ sumN _ ((?x, ?n) :: (_, _) :: FMap.elements (FMap.remove ?x _)) ] => rewrite sumN_swap, fin_maps.map_to_list_delete; auto - | |- context [ sumN _ ((?t, ?n + ?m) :: _) ] => erewrite sumN_split with (x:= (t, n)) (y := (_, m)) by lia + | |- context [ sumN _ ((?t, ?n + ?m) :: _) ] => erewrite sumN_split with (x := (t, n)) (y := (_, m)) by lia | |- context [ sumN _ ((_, 0) :: (?x, ?n) :: _) ] => erewrite <- sumN_split with (z := (x, n)) by auto | |- context [ sumN _ ((_, ?n) :: (?x, ?m - ?n) :: _) ] => erewrite <- sumN_split with (z := (x, n + m - n)) | |- context [ sumN _ ((?x, ?m - ?n) :: (_, ?n) :: _) ] => erewrite <- sumN_split with (z := (x, n + m - n)) @@ -863,7 +863,7 @@ Section Theories. | |- context [ maybe _ ] => specialize maybe_cases as [[-> ?H] | [-> _]] | H : ?y <> ?x |- context [ sumN _ ((?x, ?n) :: FMap.elements (FMap.remove ?y _)) ] => cbn; rewrite N.add_comm; change n with ((fun '(_, v) => v) (y, n)); rewrite sumN_inv - end);try easy. + end); try easy. + erewrite <- try_approve_preserves_total_supply; eauto. unfold sum_balances. erewrite <- try_approve_preserves_balances; eauto. diff --git a/examples/fa2/FA2Gens.v b/examples/fa2/FA2Gens.v index 4b284e0b..1467de3e 100644 --- a/examples/fa2/FA2Gens.v +++ b/examples/fa2/FA2Gens.v @@ -108,7 +108,7 @@ Module FA2Gens (Info : FA2TestsInfo). : FMap A (list B) := match l with | [] => FMap.empty - | (a,b)::xs => let res := groupBy_fix xs in + | (a,b) ::xs => let res := groupBy_fix xs in match FMap.find a res with | Some bs => FMap.add a (b :: bs) res | None => FMap.add a [b] FMap.empty @@ -158,7 +158,7 @@ Module FA2Gens (Info : FA2TestsInfo). (state : FA2Token.State) : G (option operator_param) := owner <- liftOptGen (gAddress accounts) ;; - addr <- liftOptGen (gAddrWithout [owner] accounts) ;; + addr <- liftOptGen (gAddrWithout [owner] accounts) ;; tokenid <- liftM fst (sampleFMapOpt state.(tokens)) ;; tokens <- (elems [Some all_tokens; Some (some_tokens [tokenid])]) ;; returnGenSome {| diff --git a/examples/fa2/FA2LegacyInterface.v b/examples/fa2/FA2LegacyInterface.v index e38f3e0b..ab52c980 100644 --- a/examples/fa2/FA2LegacyInterface.v +++ b/examples/fa2/FA2LegacyInterface.v @@ -75,7 +75,7 @@ Section FA2LegacyInterface. metadata_callback : callback (list token_metadata); }. - Inductive operator_tokens := + Inductive operator_tokens := | all_tokens : operator_tokens | some_tokens : list token_id -> operator_tokens. (* a set could be used here instead of list?*) diff --git a/examples/fa2/FA2Printers.v b/examples/fa2/FA2Printers.v index 3f3ae463..39257b2c 100644 --- a/examples/fa2/FA2Printers.v +++ b/examples/fa2/FA2Printers.v @@ -9,11 +9,13 @@ Local Open Scope string_scope. Arguments return_addr {_ _}. +#[export] Instance showCallback {A : Type}: Show (FA2LegacyInterface.callback A) := {| show v := "return address: " ++ show v.(return_addr) |}. +#[export] Instance showFA2InterfaceTransferDestination : Show FA2LegacyInterface.transfer_destination := {| show t := "{" @@ -23,6 +25,7 @@ Instance showFA2InterfaceTransferDestination : Show FA2LegacyInterface.transfer_ ++ "}" |}. +#[export] Instance showFA2InterfaceTransfer : Show FA2LegacyInterface.transfer := {| show t := "{" @@ -32,6 +35,7 @@ Instance showFA2InterfaceTransfer : Show FA2LegacyInterface.transfer := ++ "}" |}. +#[export] Instance showFA2Interfacebalance_of_request : Show FA2LegacyInterface.balance_of_request := {| show t := "balance_of_request{" @@ -40,6 +44,7 @@ Instance showFA2Interfacebalance_of_request : Show FA2LegacyInterface.balance_of ++ "}" |}. +#[export] Instance showFA2Interfacebalance_of_response : Show FA2LegacyInterface.balance_of_response := {| show t := "balance_of_response{" @@ -48,6 +53,7 @@ Instance showFA2Interfacebalance_of_response : Show FA2LegacyInterface.balance_o ++ "}" |}. +#[export] Instance showFA2Interfacebalance_of_param : Show FA2LegacyInterface.balance_of_param := {| show t := "balance_of_param{" @@ -56,6 +62,7 @@ Instance showFA2Interfacebalance_of_param : Show FA2LegacyInterface.balance_of_p ++ "}" |}. +#[export] Instance showFA2Interfacetotal_supply_response : Show FA2LegacyInterface.total_supply_response := {| show t := "total_supply_response{" @@ -64,6 +71,7 @@ Instance showFA2Interfacetotal_supply_response : Show FA2LegacyInterface.total_s ++ "}" |}. +#[export] Instance showFA2Interfacetotal_supply_param : Show FA2LegacyInterface.total_supply_param := {| show t := "total_supply_param{" @@ -72,6 +80,7 @@ Instance showFA2Interfacetotal_supply_param : Show FA2LegacyInterface.total_supp ++ "}" |}. +#[export] Instance showFA2Interfacetoken_metadata : Show FA2LegacyInterface.token_metadata := {| show t := "token_metadata{" @@ -80,6 +89,7 @@ Instance showFA2Interfacetoken_metadata : Show FA2LegacyInterface.token_metadata ++ "}" |}. +#[export] Instance showFA2Interfacetoken_metadata_param : Show FA2LegacyInterface.token_metadata_param := {| show t := "token_metadata_param{" @@ -88,6 +98,7 @@ Instance showFA2Interfacetoken_metadata_param : Show FA2LegacyInterface.token_me ++ "}" |}. +#[export] Instance showoperator_tokens : Show operator_tokens := {| show m := match m with @@ -96,6 +107,7 @@ Instance showoperator_tokens : Show operator_tokens := end |}. +#[export] Instance showFA2Interfaceoperator_param : Show FA2LegacyInterface.operator_param := {| show t := "operator_param{" @@ -105,7 +117,8 @@ Instance showFA2Interfaceoperator_param : Show FA2LegacyInterface.operator_param ++ "}" |}. -Global Instance showupdate_operator : Show update_operator := +#[export] +Instance showupdate_operator : Show update_operator := {| show m := match m with | add_operator param => "add_operator " ++ show param @@ -113,6 +126,7 @@ Global Instance showupdate_operator : Show update_operator := end |}. +#[export] Instance showFA2Interfaceis_operator_response : Show FA2LegacyInterface.is_operator_response := {| show t := "is_operator_response{" @@ -121,6 +135,7 @@ Instance showFA2Interfaceis_operator_response : Show FA2LegacyInterface.is_opera ++ "}" |}. +#[export] Instance showFA2Interfaceis_operator_param : Show FA2LegacyInterface.is_operator_param := {| show t := "is_operator_param{" @@ -129,6 +144,7 @@ Instance showFA2Interfaceis_operator_param : Show FA2LegacyInterface.is_operator ++ "}" |}. +#[export] Instance showself_transfer_policy : Show self_transfer_policy := {| show m := match m with @@ -137,6 +153,7 @@ Instance showself_transfer_policy : Show self_transfer_policy := end |}. +#[export] Instance showoperator_transfer_policy : Show operator_transfer_policy := {| show m := match m with @@ -145,6 +162,7 @@ Instance showoperator_transfer_policy : Show operator_transfer_policy := end |}. +#[export] Instance showowner_transfer_policy : Show owner_transfer_policy := {| show m := match m with @@ -154,6 +172,7 @@ Instance showowner_transfer_policy : Show owner_transfer_policy := end |}. +#[export] Instance showFA2Interfacepermissions_descriptor : Show FA2LegacyInterface.permissions_descriptor := {| show t := "permissions_descriptor{" @@ -165,6 +184,7 @@ Instance showFA2Interfacepermissions_descriptor : Show FA2LegacyInterface.permis ++ "}" |}. +#[export] Instance showFA2Interfacetransfer_destination_descriptor : Show FA2LegacyInterface.transfer_destination_descriptor := {| show t := "transfer_destination_descriptor{" @@ -174,6 +194,7 @@ Instance showFA2Interfacetransfer_destination_descriptor : Show FA2LegacyInterfa ++ "}" |}. +#[export] Instance showFA2Interfacetransfer_descriptor : Show FA2LegacyInterface.transfer_descriptor := {| show t := "transfer_descriptor{" @@ -182,6 +203,7 @@ Instance showFA2Interfacetransfer_descriptor : Show FA2LegacyInterface.transfer_ ++ "}" |}. +#[export] Instance showFA2Interfacetransfer_descriptor_param : Show FA2LegacyInterface.transfer_descriptor_param := {| show t := "transfer_descriptor_param{" @@ -191,6 +213,7 @@ Instance showFA2Interfacetransfer_descriptor_param : Show FA2LegacyInterface.tra ++ "}" |}. +#[export] Instance showfa2_token_receiver : Show fa2_token_receiver := {| show m := match m with @@ -198,6 +221,7 @@ Instance showfa2_token_receiver : Show fa2_token_receiver := end |}. +#[export] Instance showfa2_token_sender : Show fa2_token_sender := {| show m := match m with @@ -205,6 +229,7 @@ Instance showfa2_token_sender : Show fa2_token_sender := end |}. +#[export] Instance showFA2Interfaceset_hook_param : Show FA2LegacyInterface.set_hook_param := {| show t := "set_hook_param{" @@ -213,6 +238,7 @@ Instance showFA2Interfaceset_hook_param : Show FA2LegacyInterface.set_hook_param ++ "}" |}. +#[export] Instance showFA2ReceiverMsg {Msg : Type} `{serMsg : Serializable Msg} `{Show Msg} @@ -228,6 +254,7 @@ Instance showFA2ReceiverMsg {Msg : Type} end |}. +#[export] Instance showFA2TransferHook {Msg : Type} `{serMsg : Serializable Msg} `{Show Msg} @@ -239,6 +266,7 @@ Instance showFA2TransferHook {Msg : Type} end |}. +#[export] Instance showFA2TokenMsg : Show FA2Token.Msg := {| show m := match m with @@ -255,6 +283,7 @@ Instance showFA2TokenMsg : Show FA2Token.Msg := end |}. +#[export] Instance showFA2TokenLedger : Show FA2Token.TokenLedger := {| show t := "Token_Ledger{" @@ -263,7 +292,8 @@ Instance showFA2TokenLedger : Show FA2Token.TokenLedger := ++ "}" |}. -Global Instance showFA2State : Show FA2Token.State := +#[export] +Instance showFA2State : Show FA2Token.State := {| show t := "FA2TokenState{" ++ "fa2_owner: " ++ show t.(fa2_owner) ++ sep @@ -275,6 +305,7 @@ Global Instance showFA2State : Show FA2Token.State := ++ "}" |}. +#[export] Instance showFA2Setup : Show FA2Token.Setup := {| show t := "FA2TokenSetup{" @@ -285,6 +316,7 @@ Instance showFA2Setup : Show FA2Token.Setup := |}. (* Printers for Test Contracts *) +#[export] Instance showFA2ClientMsg : Show FA2ClientMsg := {| show m := match m with @@ -296,11 +328,13 @@ Instance showFA2ClientMsg : Show FA2ClientMsg := end |}. +#[export] Instance showFA2ClientContractMsg : Show ClientMsg := {| show m := show m |}. +#[export] Instance showFA2ClientState : Show ClientState := {| show t := "FA2ClientState{" @@ -309,6 +343,7 @@ Instance showFA2ClientState : Show ClientState := ++ "}" |}. +#[export] Instance showFA2ClientSetup : Show ClientSetup := {| show t := "FA2ClientSetup{" @@ -316,6 +351,7 @@ Instance showFA2ClientSetup : Show ClientSetup := ++ "}" |}. +#[export] Instance showFA2TransferHookMsg : Show FA2TransferHookMsg := {| show m := match m with @@ -323,12 +359,13 @@ Instance showFA2TransferHookMsg : Show FA2TransferHookMsg := end |}. +#[export] Instance showTransferHookMsg : Show TransferHookMsg := {| show m := show m |}. - +#[export] Instance showFA2TransferHookContractState : Show HookState := {| show t := "FA2TransferHookState{" @@ -338,6 +375,7 @@ Instance showFA2TransferHookContractState : Show HookState := ++ "}" |}. +#[export] Instance showFA2TransferHookContractSetup : Show HookSetup := {| show t := "FA2TransferHookSetup{" @@ -346,6 +384,7 @@ Instance showFA2TransferHookContractSetup : Show HookSetup := ++ "}" |}. +#[export] Instance showSerializedMsg : Show SerializedValue := Derive Show Msg < FA2Token.Msg, diff --git a/examples/fa2/FA2Token.v b/examples/fa2/FA2Token.v index d0bb6719..4065ae3a 100644 --- a/examples/fa2/FA2Token.v +++ b/examples/fa2/FA2Token.v @@ -25,7 +25,7 @@ Section FA2Token. | receive_balance_of_param : list balance_of_response -> FA2ReceiverMsg | receive_total_supply_param : list total_supply_response -> FA2ReceiverMsg | receive_metadata_callback : list token_metadata -> FA2ReceiverMsg - | receive_is_operator : is_operator_response -> FA2ReceiverMsg + | receive_is_operator : is_operator_response -> FA2ReceiverMsg | receive_permissions_descriptor : permissions_descriptor -> FA2ReceiverMsg | other_msg : Msg' -> FA2ReceiverMsg. @@ -98,7 +98,7 @@ Section FA2Token. `{Serializable Msg} : Serializable (@FA2TransferHook Msg) := Derive Serializable (@FA2TransferHook_rect Msg) < - (@transfer_hook Msg), + (@transfer_hook Msg), (@hook_other_msg Msg)>. Global Instance callback_permissions_descriptor_serializable : Serializable (callback permissions_descriptor) := @@ -448,8 +448,8 @@ Section FA2Token. : result State Error := (* only owner can set transfer hook *) do _ <- throwIf (negb (address_eqb caller state.(fa2_owner))) default_error; - Ok (state<| transfer_hook_addr := Some params.(hook_addr)|> - <| permission_policy := params.(hook_permissions_descriptor) |>). + Ok (state<| transfer_hook_addr := Some params.(hook_addr)|> + <| permission_policy := params.(hook_permissions_descriptor) |>). Definition get_token_metadata_callback (param : token_metadata_param) (state : State) @@ -479,7 +479,7 @@ Section FA2Token. let caller_bal := with_default 0 (FMap.find caller ledger.(balances)) in let new_balances := FMap.add caller (caller_bal + amount) ledger.(balances) in let new_ledger := ledger<| balances := new_balances |> in - Ok (state<| assets ::= FMap.add tokenid new_ledger |>). + Ok (state<| assets ::= FMap.add tokenid new_ledger |>). Open Scope Z_scope. diff --git a/examples/fa2/FA2TokenTests.v b/examples/fa2/FA2TokenTests.v index 0bb8f9fa..a95d39ad 100644 --- a/examples/fa2/FA2TokenTests.v +++ b/examples/fa2/FA2TokenTests.v @@ -125,6 +125,7 @@ Definition token_state (cs : Environment) := get_contract_state FA2Token.State c Definition client_state (cs : Environment) := get_contract_state ClientState cs client_contract_addr. From ConCert.Examples.FA2 Require Import FA2Gens. +From ConCert.Examples.FA2 Require Export FA2Printers. Module TestInfo <: FA2TestsInfo. Import Monads. diff --git a/examples/iTokenBuggy/iTokenBuggyGens.v b/examples/iTokenBuggy/iTokenBuggyGens.v index c944c047..b1ff08ea 100644 --- a/examples/iTokenBuggy/iTokenBuggyGens.v +++ b/examples/iTokenBuggy/iTokenBuggyGens.v @@ -47,7 +47,7 @@ Module iTokenBuggyGens (Info : iTokenBuggyGensInfo). amount <- (if allower_balance =? 0 then returnGen 0 else choose (0, N.min allowance allower_balance)) ;; - returnGenSome (delegate, transfer_from allower receiver amount). + returnGenSome (delegate, transfer_from allower receiver amount). Definition gMint (c : Environment) (state : iTokenBuggy.State) diff --git a/examples/iTokenBuggy/iTokenBuggyPrinters.v b/examples/iTokenBuggy/iTokenBuggyPrinters.v index e85ac895..e3fcffaa 100644 --- a/examples/iTokenBuggy/iTokenBuggyPrinters.v +++ b/examples/iTokenBuggy/iTokenBuggyPrinters.v @@ -4,6 +4,8 @@ From ConCert.Execution.Test Require Import QCTest. From ConCert.Examples.iTokenBuggy Require Import iTokenBuggy. Local Open Scope string_scope. + +#[export] Instance showMsg : Show Msg := {| show m := @@ -17,12 +19,14 @@ Instance showMsg : Show Msg := end |}. +#[export] Instance showTokenSetup : Show Setup := {| show setup := "Setup{owner: " ++ show setup.(owner) ++ sep ++ "init_amount: " ++ show setup.(init_amount) ++ "}" |}. +#[export] Instance showTokenState : Show iTokenBuggy.State := {| show s := "State{total_supply: " ++ show s.(total_supply) ++ sep @@ -30,5 +34,6 @@ Instance showTokenState : Show iTokenBuggy.State := ++ "allowances: " ++ show s.(allowances) ++ "}" |}. +#[export] Instance showSerializedMsg : Show SerializedValue := Derive Show Msg < Msg, Setup >. diff --git a/examples/iTokenBuggy/iTokenBuggyTests.v b/examples/iTokenBuggy/iTokenBuggyTests.v index 3af442b2..d08e9006 100644 --- a/examples/iTokenBuggy/iTokenBuggyTests.v +++ b/examples/iTokenBuggy/iTokenBuggyTests.v @@ -78,6 +78,7 @@ Definition sum_balances_eq_init_supply (state : iTokenBuggy.State) : bool := |> fold_right N.add 0 in balances_sum =? state.(total_supply). +#[export] Instance genBuggyTokenChainSized : GenSized ChainBuilder := { arbitrarySized n := gChain_ token_cb n }. diff --git a/examples/stackInterpreter/StackInterpreter.v b/examples/stackInterpreter/StackInterpreter.v index f9855bc1..4a807328 100644 --- a/examples/stackInterpreter/StackInterpreter.v +++ b/examples/stackInterpreter/StackInterpreter.v @@ -14,7 +14,7 @@ Section StackInterpreter. Definition map_key_type := string * Z. - Inductive op : Set := Add | Sub | Mult | Lt | Le | Equal. + Inductive op : Set := Add | Sub | Mult | Lt | Le | Equal. Inductive instruction := | IPushZ : Z -> instruction diff --git a/examples/stackInterpreter/StackInterpreterExtract.v b/examples/stackInterpreter/StackInterpreterExtract.v index f0b5d1b8..b6f508bb 100644 --- a/examples/stackInterpreter/StackInterpreterExtract.v +++ b/examples/stackInterpreter/StackInterpreterExtract.v @@ -17,7 +17,7 @@ Definition action := ActionBody. (* TODO: use the interpreter defined in StackInterpreter.v to avoid duplication. *) Module Interpreter. - Inductive op : Set := Add | Sub | Mult | Lt | Le | Equal. + Inductive op : Set := Add | Sub | Mult | Lt | Le | Equal. Inductive instruction := | IPushZ : Z -> instruction @@ -42,7 +42,7 @@ Module Interpreter. (setup : unit) : result storage Error := let ctx0 := ctx in - let setup0 := setup in (* prevents optimisations from removing unused [ctx] and [setup] *) + let setup0 := setup in (* prevents optimisations from removing unused [ctx] and [setup] *) Ok []. Definition params := list instruction * ext_map. @@ -121,7 +121,7 @@ Module Interpreter. Definition receive (p : params) (s : storage) : result (list action * storage) Error := - let s0 := s in (* prevents optimisations from removing unused [s] *) + let s0 := s in (* prevents optimisations from removing unused [s] *) match interp p.2 p.1 [] 0 with | Ok v => Ok ([],v) | Err e => Err e @@ -135,20 +135,20 @@ Module TestInterpreter. (** Input for the interpreter in Liquidity: ([IPushZ 0; IObs ("blah",0); IOp Add; IPushZ 1; IOp Equal], (Map [(("blah", 0), (ZVal 1))])) *) Example test_interp : - let env := FMap.of_list [(("blah", 0%Z), (ZVal 1))] in + let env := FMap.of_list [(("blah", 0%Z), (ZVal 1))] in interp env [IPushZ 0; IObs ("blah", 0); IOp Add; IPushZ 1; IOp Equal] [] 0 = Ok [BVal true]. Proof. vm_compute. reflexivity. Qed. (** Input for the interpreter in Liquidity: - ([IPushZ 1; IPushZ 1; IOp Equal; IIf; IPushZ 1;IElse; IPushZ (-1);IEndIf], (Map [])) *) + ([IPushZ 1; IPushZ 1; IOp Equal; IIf; IPushZ 1; IElse; IPushZ (-1); IEndIf], (Map [])) *) Example test_interp_if_1 : - interp FMap.empty [IPushZ 1; IPushZ 1; IOp Equal; IIf; IPushZ 1;IElse; IPushZ (-1);IEndIf] [] 0 + interp FMap.empty [IPushZ 1; IPushZ 1; IOp Equal; IIf; IPushZ 1; IElse; IPushZ (-1); IEndIf] [] 0 = Ok [ZVal 1]. Proof. vm_compute. reflexivity. Qed. Example test_interp_if_2 : - interp FMap.empty [IPushZ 1; IPushZ 0; IOp Equal; IIf; IPushZ 1;IElse; IPushZ (-1);IEndIf] [] 0 + interp FMap.empty [IPushZ 1; IPushZ 0; IOp Equal; IIf; IPushZ 1; IElse; IPushZ (-1); IEndIf] [] 0 = Ok [ZVal (-1)]. Proof. vm_compute. reflexivity. Qed. @@ -189,7 +189,7 @@ Module TestInterpreter. = Ok [ZVal (-1)]. Proof. vm_compute. reflexivity. Qed. - (* let strike = 50.0 + (* let strike = 50.0 nominal = 1000.0 theobs = obs ("Carlsberg",0) in scale (r nominal) @@ -219,18 +219,18 @@ Module TestInterpreter. IPushZ 0; IEndIf]. - (* ([IObs ("Maturity", 0);IPushZ 90;IOp Equal;IIf; IObs ("Carlsberg",0); IPushZ 50; IOp Lt; IIf; IPushZ 50; IObs ("Carlsberg", 0); IOp Sub; IPushZ 1000; IOp Mult; IElse; IPushZ 0; IEndIf; IElse; IPushZ 0; IEndIf], (Map [(("Carlsberg", 0), (ZVal 100));(("Maturity", 0), (ZVal 90))])) *) + (* ([IObs ("Maturity", 0); IPushZ 90; IOp Equal; IIf; IObs ("Carlsberg",0); IPushZ 50; IOp Lt; IIf; IPushZ 50; IObs ("Carlsberg", 0); IOp Sub; IPushZ 1000; IOp Mult; IElse; IPushZ 0; IEndIf; IElse; IPushZ 0; IEndIf], (Map [(("Carlsberg", 0), (ZVal 100)); (("Maturity", 0), (ZVal 90))])) *) (* try-liquidty: estimated fee 0.054191 *) Example run_call_option_in_the_money : - let env := FMap.of_list [(("Carlsberg", 0%Z), (ZVal 100));(("Maturity", 0%Z), (ZVal 90))] in + let env := FMap.of_list [(("Carlsberg", 0%Z), (ZVal 100)); (("Maturity", 0%Z), (ZVal 90))] in interp env call_option [] 0 = Ok [ZVal 50000]. Proof. vm_compute. reflexivity. Qed. Example run_call_option_out_the_money : - let env := FMap.of_list [(("Carlsberg", 0%Z), (ZVal 30));(("Maturity", 0%Z), (ZVal 90))] in + let env := FMap.of_list [(("Carlsberg", 0%Z), (ZVal 30)); (("Maturity", 0%Z), (ZVal 90))] in interp env call_option [] 0 = Ok [ZVal 0]. Proof. vm_compute. reflexivity. Qed. diff --git a/examples/stackInterpreter/StackInterpreterLIGOExtract.v b/examples/stackInterpreter/StackInterpreterLIGOExtract.v index 9f71b742..142d5973 100644 --- a/examples/stackInterpreter/StackInterpreterLIGOExtract.v +++ b/examples/stackInterpreter/StackInterpreterLIGOExtract.v @@ -18,11 +18,12 @@ Import Interpreter. Module CameLIGOInterp. Import CameLIGOExtract CameLIGOPretty. + #[local] Existing Instance PrintConfShortNames.PrintWithShortNames. Definition init (setup : unit) : result storage Error := - (* prevents optimisations from removing unused [setup]. TODO: override masks instead *) + (* prevents optimisations from removing unused [setup]. TODO: override masks instead *) let setup0 := setup in Ok []. diff --git a/examples/stackInterpreter/StackInterpreterLiquidityExtract.v b/examples/stackInterpreter/StackInterpreterLiquidityExtract.v index 83bc8955..90ad3557 100644 --- a/examples/stackInterpreter/StackInterpreterLiquidityExtract.v +++ b/examples/stackInterpreter/StackInterpreterLiquidityExtract.v @@ -3,7 +3,7 @@ From MetaCoq.Template Require Import All. From ConCert.Embedding.Extraction Require Import PreludeExt. From ConCert.Execution Require Import Blockchain. From ConCert.Extraction Require Import Common. -From ConCert.Extraction Require LPretty. +From ConCert.Extraction Require LiquidityPretty. From ConCert.Extraction Require LiquidityExtract. From ConCert.Examples.StackInterpreter Require Import StackInterpreterExtract. From ConCert.Utils Require Import Env. @@ -18,7 +18,7 @@ Module LiquidityInterp. Definition PREFIX := "". - Import LiquidityExtract LPretty. + Import LiquidityExtract LiquidityPretty. (** A translation table for various constants we want to rename *) Definition TT_remap : list (kername * string) := diff --git a/examples/stackInterpreter/RustInterpExtract.v b/examples/stackInterpreter/StackInterpreterRustExtract.v similarity index 99% rename from examples/stackInterpreter/RustInterpExtract.v rename to examples/stackInterpreter/StackInterpreterRustExtract.v index 5aacf2ed..33948d91 100644 --- a/examples/stackInterpreter/RustInterpExtract.v +++ b/examples/stackInterpreter/StackInterpreterRustExtract.v @@ -35,6 +35,7 @@ Definition STACK_INTERP_MODULE : ConcordiumMod _ _ := Open Scope list. +#[local] Instance RustConfig : RustPrintConfig := {| term_box_symbol := "()"; type_box_symbol := "()"; diff --git a/execution/README.md b/execution/README.md index 0cc899ad..9621885c 100644 --- a/execution/README.md +++ b/execution/README.md @@ -212,7 +212,7 @@ The third property is a hoare-triple on the `receive` function of the token cont In [iTokenBuggy/iTokenBuggyTests.v](../examples/iTokenBuggy/iTokenBuggyTests.v) we test an implementation which has a bug in the `transfer_from` method, similar to the one discovered in the [iToken](https://bzx.network/blog/incident) contract. The bug allows an attacker to create (mint) arbitrary tokens for themselves by performing self-transfers. When testing this implementation against the first property above, QuickChick reports a counterexample - an execution trace leading to a violation of the property. -The testing framework was developed as part of a Master's Thesis at Aarhus University, and the thesis detailing (an earlier state of) the development can be found [here](https://github.com/mikkelmilo/ConCert-QuickChick-Testing-Thesis). +The testing framework was developed as part of a Master's Thesis at Aarhus University, and the thesis detailing (an earlier state of) the development can be found [here](https://github.com/mikkelmilo/ConCert-QuickChick-Testing-Thesis). ## Building/Developing This project uses the std++ and bignums library. These must be installed first diff --git a/execution/_CoqProject b/execution/_CoqProject index 785ed5b5..d6957264 100644 --- a/execution/_CoqProject +++ b/execution/_CoqProject @@ -1,5 +1,3 @@ --arg -w -arg -undeclared-scope - -R ../utils/theories ConCert.Utils -R theories ConCert.Execution diff --git a/execution/test/ChainPrinters.v b/execution/test/ChainPrinters.v index 0873e6e1..38bff9d0 100644 --- a/execution/test/ChainPrinters.v +++ b/execution/test/ChainPrinters.v @@ -26,6 +26,7 @@ Derive Show for SerializedType. Derive Show for result. +#[export] Instance showActionEvaluationError `{Show (@Address Base)} `{Show SerializedValue} @@ -45,6 +46,7 @@ Instance showActionEvaluationError end |}. +#[export] Instance showContract {Setup Msg State Error: Type} `{Serializable Setup} @@ -56,6 +58,7 @@ Instance showContract show c := "Contract{...}" |}. +#[export] Instance showEnvironment (BaseTypes : ChainBase) `{Show Chain} @@ -63,10 +66,10 @@ Instance showEnvironment {| show env := "Environment{" ++ "chain: " ++ show (env_chain env) ++ sep - ++ "contract states:..." ++ "}" + ++ "contract states:..." ++ "}" |}. -Fixpoint string_of_interp_type (st : SerializedType) : (interp_type st) -> string := +Fixpoint string_of_interp_type (st : SerializedType) : (interp_type st) -> string := match st as st0 return interp_type st0 -> string with | ser_unit => fun _ => "()" | ser_int => fun t => show t @@ -74,7 +77,7 @@ match st as st0 return interp_type st0 -> string with | ser_list a => fun t : list (interp_type a) => let t_str_list := map (string_of_interp_type a) t in - "[" ++ String.concat ";" t_str_list ++ "]" + "[" ++ String.concat "; " t_str_list ++ "]" | ser_pair a b => fun t : (interp_type a * interp_type b) => "(" @@ -86,10 +89,11 @@ match st as st0 return interp_type st0 -> string with Definition ex_serialized_type := ser_pair (ser_list (ser_list ser_bool)) ser_int. (* Compute (interp_type ex_serialized_type). *) -Definition ex_val := ([[true;false];[true;true];[false];[]], 2%Z). +Definition ex_val := ([[true; false]; [true; true]; [false]; []], 2%Z). (* Compute (string_of_interp_type ex_serialized_type ex_val). *) (* Show and Generator instances for types related to Traces (an execution sequence of contracts on the BC) *) +#[export] Instance showBlockHeader (BaseTypes : ChainBase) `{Show (@Address BaseTypes)} @@ -103,8 +107,9 @@ Instance showBlockHeader ++ "bcreator: " ++ show (block_creator bh) ++ "}" |}. - (* We dont show the bound because it may be a very large number which, - when converted to nat and then to string, gives a memory overflow. *) +(* We dont show the bound because it may be a very large number which, + when converted to nat and then to string, gives a memory overflow. *) +#[export] Instance showBoundedN {bound : N} `{Show N} @@ -116,25 +121,29 @@ Instance showBoundedN end |}. +#[export] Instance showBoundedNAddrSize : Show (BoundedN.BoundedN AddrSize) := {| show := @show (BoundedN.BoundedN AddrSize) showBoundedN |}. +#[export] Instance showAddress : Show (@Address Base) := {| show := @show (BoundedN.BoundedN AddrSize) showBoundedNAddrSize |}. +#[export] Instance showLocalChain : Show (@LocalChain AddrSize) := {| show lc := "LocalChain{" ++ show (lc_height lc) ++ sep - ++ show (lc_slot lc) ++ sep + ++ show (lc_slot lc) ++ sep ++ show (lc_fin_height lc) ++ sep ++ "... }" |}. +#[export] Instance showLocalContractCallContext : Show (@ContractCallContext Base) := {| show cctx := "ContractCallContext{" @@ -144,6 +153,7 @@ show cctx := "ContractCallContext{" ++ "ctx_amount: " ++ show (@ctx_amount Base cctx) ++ "}" |}. +#[export] Instance showActionBody `{Show SerializedValue} : Show ActionBody := @@ -158,6 +168,7 @@ Instance showActionBody end |}. +#[export] Instance showLocalAction `{Show ActionBody} : Show (@Action Base) := @@ -167,22 +178,27 @@ Instance showLocalAction ++ "act_body: " ++ show (act_body a) ++ "}" |}. +#[export] Instance showLocalActionList `{Show (@Action Base)} : Show (list (@Action Base)) := {| show a := String.concat (";" ++ nl) (map show a) |}. +#[export] Existing Instance showLocalActionList | 0. +#[export] Instance showOptLocalActionList `{Show (option (@Action Base))} : Show (list (option (@Action Base))) := {| show a := String.concat (";" ++ nl) (map show a) |}. +#[export] Existing Instance showOptLocalActionList | 0. +#[export] Instance showChainState `{Show Environment} `{Show (@Action Base)} @@ -193,6 +209,7 @@ Instance showChainState ++ "queue: " ++ show a.(chain_state_queue) ++ "}" |}. +#[export] Instance showContractCallInfo {Msg : Type} `{Show Msg} @@ -206,6 +223,7 @@ Instance showContractCallInfo (* Show instanced related to ChainedLists and ChainTraces *) +#[export] Instance showAddBlockError `{Show (@Action Base)} `{Show SerializedValue} @@ -221,6 +239,7 @@ Instance showAddBlockError end |}. +#[export] Instance showChainTraceI `{Show (@Action Base)} {from to : ChainState} @@ -236,14 +255,15 @@ Instance showChainTraceI showChainTrace trace' ++ nl ++ "Block " ++ show next_bstate.(current_slot) ++ " [" ++ nl ++ show next_bstate.(chain_state_queue) - ++ "];" + ++ "]; " | _ => showChainTrace trace' end - | clnil => "" + | clnil => "" end in showChainTrace |}. +#[export] Instance showLCB `{Show (@Action Base)} : Show ChainBuilder := @@ -253,18 +273,20 @@ Instance showLCB ++ "|}" ++ nl |}. +#[export] Instance showChainBuilderType {BaseTypes : ChainBase} : Show (@ChainBuilderType BaseTypes) := {| show a := "ChainBuilderType{...}" |}. +#[export] Instance showChain (BaseTypes : ChainBase) : Show Chain := {| show c := let height := show (chain_height c) in let slot := show (current_slot c) in let fin_height := show (finalized_height c) in - "Chain{" ++ "height: " ++ height ++ sep + "Chain{" ++ "height: " ++ height ++ sep ++ "current slot: " ++ slot ++ sep ++ "final height: " ++ fin_height ++ "}" |}. @@ -300,6 +322,7 @@ Notation "'Derive' 'Show' 'Msg' < c0 , .. , cn >" := end)) (at level 0, c0, cn at level 9, only parsing). +#[export] Instance showChainTraceSigT `{Show SerializedValue} : Show {to : ChainState & ChainTrace empty_state to} := {| show a := show (projT2 a) diff --git a/execution/test/LocalBlockchain.v b/execution/test/LocalBlockchain.v index b4696bcb..1f5c9293 100644 --- a/execution/test/LocalBlockchain.v +++ b/execution/test/LocalBlockchain.v @@ -161,7 +161,7 @@ Section LocalBlockchain. | build_act origin from (act_deploy amount wc setup) => deploy_contract origin from amount wc setup lc | build_act origin from (act_call to amount msg) => - send_or_call origin from to amount (Some msg) lc + send_or_call origin from to amount (Some msg) lc end. Fixpoint execute_actions @@ -517,7 +517,7 @@ Section LocalBlockchain. destruct lcopt as [lc|e] eqn:exec; [|exact (Err e)]. subst lcopt. destruct (validate_header _) eqn:validate; [|cbn in exec; congruence]. - destruct (find_origin_neq_from _) eqn:no_origin_neq_from;[cbn in exec; congruence|]. + destruct (find_origin_neq_from _) eqn:no_origin_neq_from; [cbn in exec; congruence|]. destruct (find_invalid_root_action _) eqn:no_invalid_root_act; [cbn in exec; congruence|]. destruct lcb as [prev_lc_end prev_lcb_trace]. refine (Ok {| lcb_lc := lc; lcb_trace := _ |}). diff --git a/execution/test/TestNotation.v b/execution/test/TestNotation.v index ac3a3d56..58bc2de5 100644 --- a/execution/test/TestNotation.v +++ b/execution/test/TestNotation.v @@ -71,7 +71,7 @@ Module TestNotations (p : TestNotationParameters). Definition checkForAllStatesInTrace {A} Q := fun (_ : A) (pre_trace post_trace : list ChainState) => - checker (fold_left (fun a (cs : ChainState) => a && (Q pre_trace cs) ) post_trace true). + checker (fold_left (fun a (cs : ChainState) => a && (Q pre_trace cs)) post_trace true). Notation "cb '~~>' pf" := (reachableFrom_chaintrace cb gChain_ pf) (at level 45, left associativity) : qc_test_scope. diff --git a/execution/test/TestUtils.v b/execution/test/TestUtils.v index d9ad40bf..1167a936 100644 --- a/execution/test/TestUtils.v +++ b/execution/test/TestUtils.v @@ -101,7 +101,7 @@ Definition FMap_find_ {A B : Type} `{base.EqDecision A} (k : A) (m : FMap A B) - (default : B) := + (default : B) := match FMap.find k m with | Some v => v | None => default @@ -128,7 +128,7 @@ Fixpoint pickDrop {T E} match xs with | nil => (0, returnGen (Err default), nil) | (k, x) :: xs => - if (n "?" end. +#[export] Instance showFMap {A B : Type} `{countable.Countable A} `{base.EqDecision A} @@ -261,7 +262,8 @@ Section AddressGenerators. arbitrary := gBoundedN |}. - Global Instance genAddress : Gen (@Address LocalChainBase) := {| + #[export] + Instance genAddress : Gen (@Address LocalChainBase) := {| (* I could have just written 'arbitrary' here, but this is more explicit; and i like explicit code *) arbitrary := @arbitrary (BoundedN.BoundedN AddrSize) genBoundedN |}. @@ -323,6 +325,7 @@ Fixpoint gFMapSized {A B : Type} returnGen (FMap.add a b m) end. +#[export] Instance genFMapSized {A B : Type} `{Gen A} `{Gen B} @@ -424,17 +427,18 @@ Definition forEachMapEntry {A B prop : Type} conjoin_map pf_ (FMap.elements m). (* Repeats a generator for each element in the given list *) -Fixpoint repeatWith {A prop : Type} +Definition repeatWith {A prop : Type} `{Checkable prop} (l : list A) - (c : A -> prop) - := conjoin (map (checker o c) l). + (c : A -> prop) := + conjoin (map (checker o c) l). (* Repeats a generator n times *) -Definition repeatn (n : nat) (c : Checker) := repeatWith (seq 0 n) (fun _ => c). +Definition repeatn (n : nat) (c : Checker) := + repeatWith (seq 0 n) (fun _ => c). (* Converts a discarded test into a succesful test *) -Definition discardToSuccess {prop} `{Checkable prop} (p : prop): Checker := +Definition discardToSuccess {prop} `{Checkable prop} (p : prop) : Checker := mapTotalResult (fun res => match res.(ok) with | None => updOk res (Some true) | _ => res diff --git a/execution/test/TraceGens.v b/execution/test/TraceGens.v index ed95aaf7..55a9a79e 100644 --- a/execution/test/TraceGens.v +++ b/execution/test/TraceGens.v @@ -3,7 +3,7 @@ This file defines a generator combinator, gChain, for the ChainBuilder type. From this, a generator/arbitrary instance for the ChainTrace type is derived automatically. - This file also contains checker combinator over ChainBuilders/ChainTraces, + This file also contains checker combinator over ChainBuilders/ChainTraces, like forAllChainTrace, reachableFrom_chaintrace, and pre_post_assertion. *) @@ -28,7 +28,7 @@ Import BoundedN.Stdpp. Import ListNotations. Section TraceGens. - + Context `{Show ChainBuilder}. Context `{Show ChainState}. Global Definition BlockReward : Amount := 50. @@ -292,7 +292,7 @@ Section TraceGens. | clnil => [] end. - (* Asserts that a ChainState property holds for all step_block ChainStates in a ChainTrace *) + (* Asserts that a ChainState property holds for all step_block ChainStates in a ChainTrace *) Definition ChainTrace_ChainTraceProp {prop : Type} {from to} `{Checkable prop} @@ -303,7 +303,7 @@ Section TraceGens. let trace_list := trace_states_step_block trace in discard_empty trace_list (conjoin_map printOnFail). - (* -------------------- Checker combinators on traces -------------------- *) + (* -------------------- Checker combinators on traces -------------------- *) (* Asserts that a ChainState property holds on all ChainStates in a ChainTrace *) Definition forAllChainState {prop : Type} @@ -349,7 +349,7 @@ Section TraceGens. conjoin [(checker (pf next_bstate prev_bstate)); all_statepairs trace' bstate_before_step_block] | _ => all_statepairs trace' prev_bstate end - | clnil => checker true + | clnil => checker true end in forAllShrink (gTrace init_lc maxLength) shrink (fun cb => all_statepairs (builder_trace cb) (last_cstate (builder_trace cb))). diff --git a/execution/theories/Blockchain.v b/execution/theories/Blockchain.v index c67045e0..b9465f52 100644 --- a/execution/theories/Blockchain.v +++ b/execution/theories/Blockchain.v @@ -1,63 +1,61 @@ -(* This file defines blockchains, both a contract's view (which is +(** This file defines blockchains, both a contract's view (which is more computational) and the semantics of executing smart contracts in a blockchain. The most important types are: -* The ChainBase type, describing basic assumptions made of any blockchain. -In most cases we will abstract over this type. +- The [ChainBase] type describes basic assumptions made of any blockchain. + In most cases, we will abstract over this type. -* The Chain type, describing a smart contract's view of the blockchain. -This is the the data that can be accessed by smart contracts. +- The [Chain] type describes a smart contract's view of the blockchain. + This is the data that can be accessed by smart contracts. -* The Action type, describing how smart contracts (and external users) -interact with the blockchain. We allow transfers, calls and deployment -of contracts. +- The [Action] type describes how smart contracts (and external users) + interact with the blockchain. We allow transfers, calls and deployment + of contracts. -* The WeakContract type, describing a "weak" or "stringly" typed -version of smart contracts. Contracts are just two functions init and -receive to respectively initialize state on deployment and to update -state when receiving messages. The weak version of contracts means that -the state/message/setup types, which would normally vary with contracts, -are stored in a serialized format. +- The [WeakContract] type describes a "weak" or "stringly" typed + version of smart contracts. Contracts are just two functions init and + receive to respectively initialize state on deployment and update + state when receiving messages. The weak version of contracts means that + the state/message/setup types, which would normally vary with contracts, + are stored in a serialized format. -* The Contract type, describing a more strongly typed version of a contract. -This is the same as the above except we abstract over the appropriate types. -Users of the framework will mostly need to deal with this. +- The [Contract] type describes a more strongly typed version of a contract. + This is the same as the above except we abstract over the appropriate types. + Users of the framework will mostly need to deal with this. The next types deal with semantics. -* The Environment type. This augments the Chain type with more information. -Environment can be thought of as the information that a realistic blockchain -implementation would need to keep track of to implement operations. For instance, -it is reasonable to assume that an implementation needs to access the state of -contracts, but not to assume that it needs to store the full transaction history -of all addresses. - -* The ActionEvaluation type. This specifies how to evaluate actions returned by -contracts or input in blocks. This related an environment and action to a new -environment and list of new actions to execute. - -* The ChainState type. This augments the Environment type with a queue of -"outstanding" actions that need to be executed. For instance, when a block is -added, its actions are put into this queue. - -* The ChainStep type. This specifies how the blockchain should execute smart -contracts, and how new blocks are added. It relates a ChainState to a new ChainState. -There are steps to allow adding blocks, evaluating actions in the queue and to -permute the queue (allowing to model any execution order). - -* The ChainTrace type. This just represents a sequence of steps. If a trace ends -in a state it means that state is reachable and there is a "semantically correct" -way of executing to get to this state. This type records the full history of a -blockchain's execution and it would thus be unrealistic to extract. - -* The ChainBuilderType type. This is a typeclass for implementations of blockchains, -where these implementations need to prove that they satisfy our semantics. - +- The [Environment] type augments the Chain type with more information. + [Environment] can be thought of as the information that a realistic blockchain + implementation would need to keep track of to implement operations. For instance, + it is reasonable to assume that an implementation needs to access the state of + contracts, but not to assume that it needs to store the full transaction history + of all addresses. + +- The [ActionEvaluation] type. This specifies how to evaluate actions returned by + contracts or input in blocks. This related an environment and action to a new + environment and a list of new actions to execute. + +- The [ChainState] type. This augments the [Environment] type with a queue of + "outstanding" actions that need to be executed. For instance, when a block is + added, its actions are put into this queue. + +- The [ChainStep] type. This specifies how the blockchain should execute smart + contracts, and how new blocks are added. It relates a [ChainState] to a new [ChainState]. + There are steps to allow adding blocks, evaluating actions in the queue and to + permute the queue (allowing to model any execution order). + +- The [ChainTrace] type. This just represents a sequence of steps. If a trace ends + in a state it means that state is [reachable] and there is a "semantically correct" + way of executing to get to this state. This type records the full history of a + blockchain's execution and it would thus be unrealistic to extract. + +- The [ChainBuilderType] type. This is a typeclass for implementations of blockchains, + where these implementations need to prove that they satisfy our semantics. *) - From Coq Require Import ZArith. From Coq Require Import List. From Coq Require Import Psatz. @@ -90,8 +88,10 @@ Class ChainBase := }. Global Opaque Address address_eqb address_eqb_spec - address_eqdec address_countable address_serializable. + address_eqdec address_countable + address_serializable. +Declare Scope address_scope. Delimit Scope address_scope with address. Bind Scope address_scope with Address. Infix "=?" := address_eqb (at level 70) : address_scope. @@ -125,7 +125,7 @@ Global Ltac destruct_address_eq := Section Blockchain. Context {Base : ChainBase}. -(* This represents the view of the blockchain that a contract +(** This represents the view of the blockchain that a contract can access and interact with. *) Record Chain := build_chain { @@ -136,24 +136,25 @@ Record Chain := Record ContractCallContext := build_ctx { - (* Address that initiated the transaction (never a contract) *) + (** Address that initiated the transaction (never a contract) *) ctx_origin : Address; - (* Address of the immediate account that sent the call (can be a contract or a user account) *) + (** Address of the immediate account that sent + the call (can be a contract or a user account) *) ctx_from : Address; - (* Address of the contract being called *) + (** Address of the contract being called *) ctx_contract_address : Address; - (* Balance of the contract being called *) + (** Balance of the contract being called *) ctx_contract_balance : Amount; - (* Amount of currency passed in call *) + (** Amount of currency passed in call *) ctx_amount : Amount; }. -(* Operations that a contract can return or that a user can use +(** Operations that a contract can return or that a user can use to interact with a chain. *) Inductive ActionBody := - | act_transfer (to : Address) (amount : Amount) - | act_call (to : Address) (amount : Amount) (msg : SerializedValue) - | act_deploy (amount : Amount) (c : WeakContract) (setup : SerializedValue) +| act_transfer (to : Address) (amount : Amount) +| act_call (to : Address) (amount : Amount) (msg : SerializedValue) +| act_deploy (amount : Amount) (c : WeakContract) (setup : SerializedValue) with WeakContract := | build_weak_contract (init : @@ -188,9 +189,10 @@ Record Action := act_body : ActionBody; }. -Definition act_amount (a : Action) := act_body_amount (act_body a). +Definition act_amount (a : Action) := + act_body_amount (act_body a). -(* Represents a strongly-typed contract. This is what user's will primarily +(** Represents a strongly-typed contract. This is what user's will primarily use and interact with when they want deployment. We keep the weak contract only "internally" for blockchains, while any strongly-typed contract can be converted to and from *) @@ -220,7 +222,8 @@ Global Arguments init {_ _ _ _ _ _ _ _}. Global Arguments receive {_ _ _ _ _ _ _ _}. Global Arguments build_contract {_ _ _ _ _ _ _ _}. -Definition deser_error := serialize "Deserialization failed"%string. +Definition deser_error := + serialize "Deserialization failed"%string. Definition error_to_weak_error {T E : Type} `{Serializable E} (r : result T E) @@ -233,7 +236,8 @@ Definition contract_to_weak_contract `{Serializable Msg} `{Serializable State} `{Serializable Error} - (c : Contract Setup Msg State Error) : WeakContract := + (c : Contract Setup Msg State Error) + : WeakContract := let weak_init chain ctx ser_setup := do setup <- result_of_option (deserialize ser_setup) deser_error; do state <- error_to_weak_error (c.(init) chain ctx setup); @@ -253,7 +257,7 @@ Definition contract_to_weak_contract Coercion contract_to_weak_contract : Contract >-> WeakContract. -(* Deploy a strongly typed contract with some amount and setup *) +(** Deploy a strongly typed contract with some amount and setup *) Definition create_deployment {Setup Msg State Error : Type} `{Serializable Setup} @@ -265,23 +269,25 @@ Definition create_deployment (setup : Setup) : ActionBody := act_deploy amount contract (serialize setup). -(* The contract interface is the main mechanism allowing a deployed +(** The contract interface is the main mechanism allowing a deployed contract to interact with another deployed contract. This hides the ugly details of everything being SerializedValue away from contracts. *) Record ContractInterface {Msg : Type} := build_contract_interface { - (* The address of the contract being interfaced with *) + (** The address of the contract being interfaced with *) contract_address : Address; - (* Make an action sending money and optionally a message to the contract *) + (** Make an action sending money and optionally a message to the contract *) send : Amount -> option Msg -> ActionBody; }. Global Arguments ContractInterface _ : clear implicits. Definition get_contract_interface - (chain : Chain) (addr : Address) - (Msg : Type) `{Serializable Msg} - : option (ContractInterface Msg) := + (chain : Chain) + (addr : Address) + (Msg : Type) + `{Serializable Msg} + : option (ContractInterface Msg) := let ifc_send amount msg := match msg with | None => act_transfer addr amount @@ -292,8 +298,11 @@ Definition get_contract_interface Section Semantics. MetaCoq Run (make_setters Chain). -Definition add_balance (addr : Address) (amount : Amount) (map : Address -> Amount) : - Address -> Amount := +Definition add_balance + (addr : Address) + (amount : Amount) + (map : Address -> Amount) + : Address -> Amount := fun a => if (a =? addr)%address then (amount + map a)%Z else map a. @@ -301,9 +310,10 @@ Definition add_balance (addr : Address) (amount : Amount) (map : Address -> Amou Global Arguments add_balance _ _ _ /. Definition set_chain_contract_state - (addr : Address) (state : SerializedValue) + (addr : Address) + (state : SerializedValue) (map : Address -> option SerializedValue) - : Address -> option SerializedValue := + : Address -> option SerializedValue := fun a => if (a =? addr)%address then Some state else map a. @@ -316,19 +326,25 @@ Record Environment := env_contract_states : Address -> option SerializedValue; }. -(* Two environments are equivalent if they are extensionally equal *) +(** Two environments are equivalent if they are extensionally equal *) Record EnvironmentEquiv (e1 e2 : Environment) : Prop := build_env_equiv { chain_eq : env_chain e1 = env_chain e2; - account_balances_eq : forall a, env_account_balances e1 a = env_account_balances e2 a; - contracts_eq : forall a, env_contracts e1 a = env_contracts e2 a; - contract_states_eq : forall addr, env_contract_states e1 addr = env_contract_states e2 addr; + account_balances_eq : + forall a, env_account_balances e1 a = env_account_balances e2 a; + contracts_eq : + forall a, env_contracts e1 a = env_contracts e2 a; + contract_states_eq : + forall addr, env_contract_states e1 addr = env_contract_states e2 addr; }. -(* Strongly typed version of contract state *) +(** Strongly typed version of contract state *) Definition contract_state - {A : Type} `{Serializable A} - (env : Environment) (addr : Address) : option A := + {A : Type} + `{Serializable A} + (env : Environment) + (addr : Address) + : option A := env_contract_states env addr >>= deserialize. Global Program Instance environment_equiv_equivalence : Equivalence EnvironmentEquiv. @@ -387,7 +403,7 @@ Definition set_contract_state env<|env_contract_states ::= set_chain_contract_state addr state|>. (* set_chain_contract_state updates a map (function) by returning a - new map (function). If this function is immediately applied to a + new map (function). If this function is immediately applied to a key, then unfold it. *) Global Arguments set_chain_contract_state _ _ _ /. @@ -706,11 +722,11 @@ Lemma origin_is_account acts : Forall act_origin_is_account acts. Proof. intros Hall. - induction Hall as [| a Ha];intros Hall0;auto. - inversion Hall0;subst. - constructor;auto. + induction Hall as [| a Ha]; intros Hall0; auto. + inversion Hall0; subst. + constructor; auto. specialize (address_eqb_spec (act_origin a) (act_from a)) as Haddr; - unfold act_origin_is_eq_from in *; destruct Haddr;easy. + unfold act_origin_is_eq_from in *; destruct Haddr; easy. Qed. @@ -1416,7 +1432,7 @@ Lemma origin_is_always_account {bstate : ChainState} : Forall act_origin_is_account (chain_state_queue bstate). Proof. intros [trace]. - remember empty_state; induction trace;subst; cbn in *; try constructor. + remember empty_state; induction trace; subst; cbn in *; try constructor. destruct_chain_step. - (* New block, use the fact that [act_origin] is the same as [act_from] and [act_from] is an account address*) @@ -1427,7 +1443,7 @@ Proof. rewrite queue_prev in *; cbn in *; specialize_hypotheses; - inversion IHtrace;subst; try easy. + inversion IHtrace; subst; try easy. apply Forall_app. split. * apply All_Forall.Forall_map. apply Forall_forall; easy. @@ -1762,7 +1778,7 @@ Proof. replace caddr with (ctx_contract_address ctx) by (subst; auto). replace amount with (ctx_amount ctx) by (subst; auto). rewrite Z.add_0_r. - apply init_case;auto. + apply init_case; auto. + (* Deployment of other contract, might be by this contract. *) specialize_hypotheses. destruct IH as (depinfo & cstate & inc_calls & -> & ? & -> & ?). @@ -2084,20 +2100,21 @@ Ltac contract_induction := apply (contract_induction _ AddBlockFacts DeployFacts CallFacts); cbv [P]; clear P; cycle 1; clear dependent bstate; clear dependent caddr). -Global Notation "'Please' 'prove' 'your' 'facts'" := TagFacts (at level 100, only printing). -Global Notation "'Please' 'reestablish' 'the' 'invariant' 'after' 'addition' 'of' 'a' 'block'" - := TagAddBlock (at level 100, only printing). -Global Notation "'Please' 'establish' 'the' 'invariant' 'after' 'deployment' 'of' 'the' 'contract'" - := TagDeployment (at level 100, only printing). -Global Notation "'Please' 'reestablish' 'the' 'invariant' 'after' 'an' 'outgoing' 'action'" - := TagOutgoingAct (at level 100, only printing). -Global Notation "'Please' 'reestablish' 'the' 'invariant' 'after' 'a' 'nonrecursive' 'call'" - := TagNonrecursiveCall (at level 100, only printing). -Global Notation "'Please' 'reestablish' 'the' 'invariant' 'after' 'a' 'recursive' 'call'" - := TagRecursiveCall (at level 100, only printing). +Global Notation "'Please' 'prove' 'your' 'facts'" := + TagFacts (at level 100, only printing). +Global Notation "'Please' 'reestablish' 'the' 'invariant' 'after' 'addition' 'of' 'a' 'block'" := + TagAddBlock (at level 100, only printing). +Global Notation "'Please' 'establish' 'the' 'invariant' 'after' 'deployment' 'of' 'the' 'contract'" := + TagDeployment (at level 100, only printing). +Global Notation "'Please' 'reestablish' 'the' 'invariant' 'after' 'an' 'outgoing' 'action'" := + TagOutgoingAct (at level 100, only printing). +Global Notation "'Please' 'reestablish' 'the' 'invariant' 'after' 'a' 'nonrecursive' 'call'" := + TagNonrecursiveCall (at level 100, only printing). +Global Notation "'Please' 'reestablish' 'the' 'invariant' 'after' 'a' 'recursive' 'call'" := + TagRecursiveCall (at level 100, only printing). Global Notation - "'Please' 'reestablish' 'the' 'invariant' 'after' 'permutation' 'of' 'the' 'action' 'queue'" - := TagPermuteQueue (at level 100, only printing). + "'Please' 'reestablish' 'the' 'invariant' 'after' 'permutation' 'of' 'the' 'action' 'queue'" := + TagPermuteQueue (at level 100, only printing). Section LiftTransactionProp. diff --git a/execution/theories/BoundedN.v b/execution/theories/BoundedN.v index a68c4053..d6018b48 100644 --- a/execution/theories/BoundedN.v +++ b/execution/theories/BoundedN.v @@ -280,5 +280,6 @@ Module BoundedN. elements_all := bounded_elements_all bound; |}. End BoundedN. +Declare Scope BoundedN_scope. Delimit Scope BoundedN_scope with BoundedN. Bind Scope BoundedN_scope with BoundedN. diff --git a/execution/theories/BuildUtils.v b/execution/theories/BuildUtils.v index 126d8990..df1f2683 100644 --- a/execution/theories/BuildUtils.v +++ b/execution/theories/BuildUtils.v @@ -362,8 +362,8 @@ Proof. now apply contract_addr_format in deployed; auto. - (* act_body = act_deploy amount c setup *) apply deployable_address_decidable - with (wc:=c) (setup:=setup) (act_origin:=act_origin) - (act_from:=act_from) (amount:=amount) + with (wc := c) (setup := setup) (act_origin := act_origin) + (act_from := act_from) (amount := amount) in reach. destruct reach as [[to [state [to_is_contract_addr [to_not_deployed init]]]] | no_deployable_addr]. + (* Case: act_deploy is evaluable by eval_deploy *) @@ -657,7 +657,7 @@ Proof. (cbn; destruct_address_eq; easy). assert (step : ChainStep bstate bstate'). - eapply step_action; eauto. - eapply eval_call with (msg:= Some ((@serialize Msg _) msg)); eauto. + eapply eval_call with (msg := Some ((@serialize Msg _) msg)); eauto. + rewrite new_to_balance_eq. now apply wc_receive_to_receive in receive_some. + constructor; reflexivity. @@ -887,7 +887,7 @@ Local Ltac update_chainstate bstate1 bstate2 := | H : context [ bstate1 ] |- _ => match type of H with | EnvironmentEquiv _ _ => fail 1 - | _ => update bstate1 with bstate2 in H by (try (rewrite_environment_equiv;cbn; easy)) + | _ => update bstate1 with bstate2 in H by (try (rewrite_environment_equiv; cbn; easy)) end end; only_on_match ltac:(progress update_chainstate bstate1 bstate2). @@ -961,7 +961,7 @@ Ltac add_block acts_ slot_ := | Hqueue : (chain_state_queue ?bstate) = [], Hreach : reachable ?bstate |- exists bstate', reachable_through ?bstate bstate' /\ _ => - specialize add_block with (acts:=acts_) (slot_incr:=slot_) + specialize add_block with (acts := acts_) (slot_incr := slot_) as [new_bstate [new_reach [new_queue new_env_eq]]]; [apply Hreach | apply Hqueue| | | | | |] end. diff --git a/execution/theories/ChainedList.v b/execution/theories/ChainedList.v index 6fe7efbf..b42bc9b6 100644 --- a/execution/theories/ChainedList.v +++ b/execution/theories/ChainedList.v @@ -65,6 +65,7 @@ Proof. Qed. End ChainedList. +Declare Scope clist_scope. Delimit Scope clist_scope with trace. Bind Scope clist_scope with ChainedList. Infix "++" := clist_app (right associativity, at level 60) : clist_scope. diff --git a/execution/theories/ContractCommon.v b/execution/theories/ContractCommon.v index ff803d74..1f97dba8 100644 --- a/execution/theories/ContractCommon.v +++ b/execution/theories/ContractCommon.v @@ -9,7 +9,7 @@ From ConCert.Execution Require Import ResultMonad. From Coq Require Import List. Import ListNotations. From Coq Require Import ZArith_base. -(** A type of finite maps (dictionaries) with addresses as keys. +(** A type of finite maps (dictionaries) with addresses as keys. Basically, it's just a specilisation of [FMap] to [Address] as keys. This definitions is more extraction-friendly. *) @@ -22,19 +22,19 @@ Module AddressMap. Definition find `{ChainBase} {V : Type} (addr : Address) (m : AddrMap V) : option V := FMap.find addr m. - Definition add `{ChainBase} {V : Type} (addr : Address) (val : V) (m : AddrMap V) : AddrMap V := + Definition add `{ChainBase} {V : Type} (addr : Address) (val : V) (m : AddrMap V) : AddrMap V := FMap.add addr val m. - Definition values `{ChainBase} {V : Type} (m : AddrMap V) : list V := + Definition values `{ChainBase} {V : Type} (m : AddrMap V) : list V := FMap.values m. - Definition keys `{ChainBase} {V : Type} (m : AddrMap V) : list Address := + Definition keys `{ChainBase} {V : Type} (m : AddrMap V) : list Address := FMap.keys m. - Definition of_list `{ChainBase} {V : Type} (l : list (Address * V)) : AddrMap V := + Definition of_list `{ChainBase} {V : Type} (l : list (Address * V)) : AddrMap V := FMap.of_list l. - Definition empty `{ChainBase} {V : Type} : AddrMap V := + Definition empty `{ChainBase} {V : Type} : AddrMap V := FMap.empty. Definition update `{ChainBase} {V : Type} (addr : Address) (val : option V) (m : AddrMap V) : AddrMap V := @@ -43,12 +43,12 @@ Module AddressMap. End AddressMap. (** The specialised version is convertible to [FMap.find] after resolving the instances *) -Lemma AddressMap_find_convertible `{ChainBase} {V : Type} : - AddressMap.find (V:=V) = FMap.find. +Lemma AddressMap_find_convertible `{ChainBase} {V : Type} : + AddressMap.find (V := V) = FMap.find. Proof. reflexivity. Qed. -Lemma AddressMap_add_convertible `{ChainBase} {V : Type} : - AddressMap.add (V:=V) = FMap.add. +Lemma AddressMap_add_convertible `{ChainBase} {V : Type} : + AddressMap.add (V := V) = FMap.add. Proof. reflexivity. Qed. Section Utility. diff --git a/execution/theories/ContractMonads.v b/execution/theories/ContractMonads.v index bd798418..b8d1956d 100644 --- a/execution/theories/ContractMonads.v +++ b/execution/theories/ContractMonads.v @@ -143,7 +143,7 @@ Global Instance contract_reader_to_receiver Global Instance result_to_contract_receiver {State Msg Error : Type} - : MonadTrans (ContractReceiver State Msg Error) (fun T => result T Error) := + : MonadTrans (ContractReceiver State Msg Error) (fun T => result T Error) := {| lift _ (opt : result _ Error) chain ctx state msg acts := (chain, ctx, state, msg, acts, opt) |}. Definition chain_height : ContractReader nat := diff --git a/execution/theories/Finite.v b/execution/theories/Finite.v index 07ed85f9..a904672b 100644 --- a/execution/theories/Finite.v +++ b/execution/theories/Finite.v @@ -14,4 +14,5 @@ Arguments elements _ {_}. Arguments elements_set _ {_}. Arguments elements_all _ {_}. +#[export] Hint Resolve elements_set elements_all : core. diff --git a/execution/theories/Monad.v b/execution/theories/Monad.v index e564dcc8..41c3ac45 100644 --- a/execution/theories/Monad.v +++ b/execution/theories/Monad.v @@ -43,7 +43,7 @@ Fixpoint monad_map {A B} {m : Type -> Type} `{Monad m} (f : A -> m B) (xs : list | nil => ret nil | cons x xs' => do v <- f x; - do vs <- monad_map f xs'; + do vs <- monad_map f xs'; ret (cons v vs) end. diff --git a/execution/theories/ResultMonad.v b/execution/theories/ResultMonad.v index 85013ae8..b206dcd2 100644 --- a/execution/theories/ResultMonad.v +++ b/execution/theories/ResultMonad.v @@ -70,7 +70,7 @@ Lemma result_of_option_eq_some : forall {T E : Type} (x : option T) (e : E) (y : result_of_option x e = Ok y <-> x = Some y. Proof. split; destruct x; intros eq; - (discriminate || injection eq as <-;reflexivity). + (discriminate || injection eq as <-; reflexivity). Qed. Lemma result_of_option_eq_none : forall {T E : Type} (x : option T) (e1 e2 : E), diff --git a/execution/theories/Serializable.v b/execution/theories/Serializable.v index 6a8e6c00..b8faef5b 100644 --- a/execution/theories/Serializable.v +++ b/execution/theories/Serializable.v @@ -83,21 +83,25 @@ Proof. now rewrite eq. Qed. +#[export] Program Instance unit_serializable : Serializable unit := {| serialize u := build_ser_value ser_unit u; deserialize := extract_ser_value ser_unit; |}. Solve Obligations with reflexivity. +#[export] Program Instance int_serializable : Serializable Z := {| serialize i := build_ser_value ser_int i; deserialize := extract_ser_value ser_int; |}. Solve Obligations with reflexivity. +#[export] Program Instance bool_serializable : Serializable bool := {| serialize b := build_ser_value ser_bool b; deserialize := extract_ser_value ser_bool; |}. Solve Obligations with reflexivity. +#[export] Program Instance nat_serializable : Serializable nat := {| serialize n := serialize (Z.of_nat n); deserialize z := do z' <- deserialize z; if (z' _ | None => _ end = _ |- _ => destruct x end; discriminate. diff --git a/extra/resources/coqdocjs/coqdoc.css b/extra/resources/coqdocjs/coqdoc.css index 3f21102a..4cc4e3f9 100644 --- a/extra/resources/coqdocjs/coqdoc.css +++ b/extra/resources/coqdocjs/coqdoc.css @@ -116,7 +116,7 @@ tr.infrulemiddle hr { } .id[type="constructor"], .id[type="projection"], .id[type="method"], -.id[title="constructor"], .id[title="projection"], .id[title="method"] { +.id[title="constructor"], .id[title="projection"], .id[title="method"] { color: #A30E16; } diff --git a/extraction/Makefile b/extraction/Makefile index 534cf1e1..fdf2fb80 100644 --- a/extraction/Makefile +++ b/extraction/Makefile @@ -116,9 +116,13 @@ clean-extraction-out-files: clean-extraction-sources: rm -f $(ELM_DIR)/tests/*.elm - rm -f $(ELM_WEB_DIR)/src/*.elm - rm -f $(LIQUIDITY_DIR)/*.liq - rm -f $(LIGO_DIR)/*.mligo + rm -f $(ELM_WEB_APP_DIR)/src/main.elm + rm -f $(LIQUIDITY_DIR)/tests/*.liq + rm -f $(LIQUIDITY_DIR)/liquidity.log + rm -f $(LIGO_DIR)/tests/*.mligo + rm -f $(MIDLANG_DIR)/tests/*.midlang + find $(RUST_DIR) -name 'main.rs' -delete + $(foreach dir, $(wildcard $(CONCORDIUM_DIR)/*-extracted), rm -f $(dir)/src/lib.rs;) .PHONY:clean-extraction-sources clean-extraction-examples: clean-compiled-extraction clean-extraction-out-files clean-extraction-sources diff --git a/extraction/README.md b/extraction/README.md index a018439c..8e87b6c0 100644 --- a/extraction/README.md +++ b/extraction/README.md @@ -1,7 +1,7 @@ # Extraction Contains an implementation of extraction based on the certified erasure provided by MetaCoq. The -`theories` folder contains the implementation and correctness theorems. The [examples](../examples/) folder, as +`theories` folder contains the implementation and correctness theorems. The [examples](../examples/) folder, as the name suggests, contains examples of smart contracts and programs extracted using our development. The [tests](tests/) folder contains tests for our extensions to the certified erasure. After building the project (running `make` from the project's root, or running `make` in this folder), the folders @@ -49,7 +49,7 @@ Some highlights from [theories](theories/): * [CertifyingInlinig.v](theories/CertifyingInlinig.v) -- An inlining procedure. * [CertifyingBeta.v](theories/ertifyingBeta.v) -- A procedure that finds an evalues redexes (if the reduction leads to new redexes, these are not reduced further) * [Certifying.v](theories/Certifying.v) -- proof-generating procedure; it is used to generate proofs after running inlining/eta-expansion/etc. -* [LPretty.v](theories/LPretty.v) -- Pretty-printer for Liquidity from `λ□`. +* [LiquidityPretty.v](theories/LiquidityPretty.v) -- Pretty-printer for Liquidity from `λ□`. * [Liquidity.v](theories/Liquidity.v) -- A pretty printer that works directly on the deep embedding of `λsmart` language. * [LiquidityExtract.v](theories/LiquidityExtract.v) - A high-level interface to Liquidity extraction. * [MidlangExtract.v](theories/MidlangExtract.v) -- A high-level interface to Midlang extraction including the pretty-printer to Midlang/Elm. @@ -58,10 +58,10 @@ Some highlights from [theories](theories/): Some highlights of extracted examples: -* [CounterCertifiedExtraction.v](../examples/counter/extraction/CounterCertifiedExtraction.v) -- A simple counter contract. -* [CounterDepCertifiedExtraction.v](../examples/counter/extraction/CounterDepCertifiedExtraction.v) -- A counter contract that uses propositions to filter out the correct input. It also serves as an example application of the certifying eta-expansion. -* [CounterRefinementTypes](../examples/counter/extraction/MidlangCounterRefTypes.v) -- A counter contract that uses refinement types for expressing partial functional correctness. +* [CounterCertifiedLiquidity.v](../examples/counter/extraction/CounterCertifiedLiquidity.v) -- A simple counter contract. +* [CounterDepCertifiedLiquidity.v](../examples/counter/extraction/CounterDepCertifiedLiquidity.v) -- A counter contract that uses propositions to filter out the correct input. It also serves as an example application of the certifying eta-expansion. +* [CounterRefinementTypes](../examples/counter/extraction/CounterRefTypesMidlang.v) -- A counter contract that uses refinement types for expressing partial functional correctness. * [CrowdfundingCertifiedExtraction.v](../examples/crowdfunding/CrowdfundingCertifiedExtraction.v) -- Machinery for extraction of a crowdfunding contract. * [ElmExtractTests.v](tests/ElmExtractTests.v) -- Several examples of extraction into Elm. -* [MidlangEscrow.v](../examples/escrow/extraction/MidlangEscrow.v) -- Extraction of the escrow contract defined in [Escrow.v](../examples/escrow/Escrow.v) to Midlang. +* [EscrowMidlang.v](../examples/escrow/extraction/EscrowMidlang.v) -- Extraction of the escrow contract defined in [Escrow.v](../examples/escrow/Escrow.v) to Midlang. * [StackInterpreterExtract.v](../examples/stackInterpreter/StackInterpreterExtract.v) -- An interpreter for a simple stack-based language. diff --git a/extraction/_CoqProject b/extraction/_CoqProject index 39576754..31ed0573 100644 --- a/extraction/_CoqProject +++ b/extraction/_CoqProject @@ -1,4 +1,3 @@ --arg -w -arg -undeclared-scope -arg -w -arg -notation-overridden -arg -w -arg -non-reversible-notation @@ -14,7 +13,7 @@ theories/ConcordiumExtract.v theories/ElmExtract.v theories/ExtractExtraction.v theories/LiquidityExtract.v -theories/LPretty.v +theories/LiquidityPretty.v theories/PluginExtract.v theories/PrettyPrinterMonad.v theories/Printing.v diff --git a/extraction/tests/CameLIGOExtractionTests.v b/extraction/tests/CameLIGOExtractionTests.v index 9919b8ff..8274d20c 100644 --- a/extraction/tests/CameLIGOExtractionTests.v +++ b/extraction/tests/CameLIGOExtractionTests.v @@ -17,6 +17,7 @@ Local Open Scope string_scope. Notation s_to_bs := bytestring.String.of_string. +#[local] Existing Instance PrintConfShortNames.PrintWithShortNames. Definition bindOptCont {A B} (a : option A) (f : A -> option B) : option B := @@ -29,12 +30,11 @@ Module BoolRect. (** Previously, this example extracted wrong, because some name annotations of the [bool_rect] are thse same, leading to - shadowing in the resulting code *) + shadowing in the resulting code *) (** One can see the variable names by quoting and printing the AST, as below *) - MetaCoq Quote Recursively Definition bool_rect_quoted := bool_rect. - - Compute lookup_env bool_rect_quoted.1 <%% bool_rect %%>. + (* MetaCoq Quote Recursively Definition bool_rect_quoted := bool_rect. *) + (* Compute lookup_env bool_rect_quoted.1 <%% bool_rect %%>. *) (** This is, of course meaningless in eager languages, so usually we inline such definitions, but here we keep is as it is for the @@ -45,7 +45,7 @@ Module BoolRect. Definition max_nat (n m : nat) := my_stupid_if (Nat.leb n m) m n. Definition harness (func : string) : string := - "let main (st : unit * nat option) : operation list * (nat option) = (([]: operation list), Some ( " ++ func ++ " 2n 3n))". + "let main (st : unit * nat option) : operation list * (nat option) = (([]: operation list), Some ( " ++ func ++ " 2n 3n))". Time MetaCoq Run (t <- CameLIGO_extract_single @@ -79,7 +79,7 @@ Module FoldLeft. Definition sum (xs : list nat) := foldL Nat.add xs 0. Definition harness (sum_func : string) : string := - "let main (st : unit * nat option) : operation list * (nat option) = (([]: operation list), Some ( " ++ sum_func ++ "([1n;2n;3n])))". + "let main (st : unit * nat option) : operation list * (nat option) = (([]: operation list), Some ( " ++ sum_func ++ "([1n;2n;3n])))". Time MetaCoq Run (t <- CameLIGO_extract_single @@ -93,7 +93,7 @@ Module FoldLeft. (** Extraction results in fully functional CameLIGO code *) Redirect "tests/extracted-code/cameligo-extract/FoldL.mligo" - MetaCoq Run (tmMsg (bytestring.String.of_string cameligo_sum)). + MetaCoq Run (tmMsg (bytestring.String.of_string cameligo_sum)). (** This definition is different from [foldL]. The type abstractions are part of the fixpoint, and not binded by lambdas. Therefore, the type parameters are not @@ -119,7 +119,7 @@ Module FoldLeft. (** Extraction results in fully functional CameLIGO code *) Redirect "tests/extracted-code/cameligo-extract/FoldLAlt.mligo" - MetaCoq Run (tmMsg (s_to_bs cameligo_sumAlt)). + MetaCoq Run (tmMsg (s_to_bs cameligo_sumAlt)). End FoldLeft. @@ -133,7 +133,7 @@ Module SafeHead. (** We cannot make [safe_head] polymoprhic due to CameLIGO restrictions *) Program Definition safe_head (l : list nat) (non_empty : List.length l > 0) : nat := - match l as l' return l' = l -> nat with + match l as l' return l' = l -> nat with | [] => (* this is an impossible case *) (* NOTE: we use [False_rect] to have more control over the extracted code. *) (* Leaving a hole for the whole branch potentially leads to polymoprhic *) @@ -146,7 +146,7 @@ Module SafeHead. intros. subst. inversion non_empty. Qed. - Program Definition head_of_list_2 (xs : list nat) := safe_head (0 :: 0 :: xs) _. + Program Definition head_of_list_2 (xs : list nat) := safe_head (0 :: 0 :: xs) _. Next Obligation. intros. cbn. lia. Qed. @@ -159,7 +159,7 @@ Module SafeHead. Definition TT_ctors := [("O","0n")]. Definition harness : string := - "let main (st : unit * nat option) : operation list * (nat option) = (([]: operation list), Some (head_of_list_2 ([] : nat list)))". + "let main (st : unit * nat option) : operation list * (nat option) = (([]: operation list), Some (head_of_list_2 ([] : nat list)))". Time MetaCoq Run (t <- CameLIGO_extract_single @@ -173,6 +173,6 @@ Module SafeHead. (** Extraction results in fully functional CameLIGO code *) Redirect "tests/extracted-code/cameligo-extract/SafeHead.mligo" - MetaCoq Run (tmMsg (s_to_bs cameligo_safe_head)). + MetaCoq Run (tmMsg (s_to_bs cameligo_safe_head)). End SafeHead. diff --git a/extraction/tests/ElmExtractExamples.v b/extraction/tests/ElmExtractExamples.v index c6245651..5361f964 100644 --- a/extraction/tests/ElmExtractExamples.v +++ b/extraction/tests/ElmExtractExamples.v @@ -67,7 +67,7 @@ Module ElmExamples. (* [safe_pred] example is inspired by Letozey's A New Extraction for Coq *) Definition safe_pred (n:nat) (not_zero : O<>n) : {p :nat | n=(S p)} := match n as n0 return (n0 = n -> _ -> _ )with - | O => fun heq h => False_rect _ (ltac:(cbn;intros;easy)) + | O => fun heq h => False_rect _ (ltac:(cbn; intros; easy)) | S m => fun heq h => exist m eq_refl end eq_refl not_zero. @@ -80,9 +80,9 @@ Module ElmExamples. (* In fully applied case the last argument of [safe_pred] is removed*) Redirect "tests/extracted-code/elm-extract/SafePredFull.elm" Compute general_wrapped safe_pred_full_syn - (Preambule "SafePredFull" ++ Common.nl ++ elm_false_rec) - (main_and_test "Expect.equal safe_pred_full (Exist O)") - [] []. + (Preambule "SafePredFull" ++ Common.nl ++ elm_false_rec) + (main_and_test "Expect.equal safe_pred_full (Exist O)") + [] []. MetaCoq Run (t <- tmQuoteRecTransp safe_pred_partial false ;; mpath <- tmCurrentModPath tt;; @@ -237,7 +237,7 @@ Module ElmExamples. (main_and_test "Expect.equal (last (Cons 1 (Cons 10 Nil)) 0) 10"). Program Definition safe_head {A} (non_empty_list : {l : list A | List.length l > 0}) : A := - match non_empty_list as l' return l' = non_empty_list -> A with + match non_empty_list as l' return l' = non_empty_list -> A with | [] => (* NOTE: we use [False_rect] to make the extracted code a bit nicer. It's totally possible to leave the whole branch as an obligation, @@ -251,11 +251,11 @@ Module ElmExamples. | hd :: tl => fun _ => hd end eq_refl. Next Obligation. - intros;cbn in*; lia. + intros; cbn in*; lia. Qed. - Program Definition head_of_repeat_plus_one {A} (n : nat) (a : A) : A - := safe_head (repeat a (1+n)). + Program Definition head_of_repeat_plus_one {A} (n : nat) (a : A) : A := + safe_head (repeat a (1+n)). Next Obligation. intros. cbn. lia. Qed. diff --git a/extraction/tests/ElmExtractTests.v b/extraction/tests/ElmExtractTests.v index 00b4bf74..fd08c3b2 100644 --- a/extraction/tests/ElmExtractTests.v +++ b/extraction/tests/ElmExtractTests.v @@ -18,9 +18,9 @@ Import MCMonadNotation. Local Notation "'bs_to_s' s" := (bytestring.String.to_string s) (at level 200). Local Notation "'s_to_bs' s" := (bytestring.String.of_string s) (at level 200). -Local Coercion bytestring.String.of_string : string >-> bytestring.String.t. - +Local Coercion bytestring.String.of_string : string >-> bytestring.String.t. +#[local] Instance StandardBoxes : ElmPrintConfig := {| term_box_symbol := "□"; type_box_symbol := "□"; @@ -62,26 +62,26 @@ Module ex1. Example ex1_test : extract ex1 = Ok <$ -"type Sig a"; -" = Exist a"; -""; -"proj1_sig : Sig a -> a"; -"proj1_sig e ="; -" case e of"; -" Exist a ->"; -" a"; -""; -"type Nat"; -" = O"; -" | S Nat"; -""; -"foo : Sig Nat"; -"foo ="; -" Exist O"; -""; -"bar : Nat"; -"bar ="; -" proj1_sig foo" $>. + "type Sig a"; + " = Exist a"; + ""; + "proj1_sig : Sig a -> a"; + "proj1_sig e ="; + " case e of"; + " Exist a ->"; + " a"; + ""; + "type Nat"; + " = O"; + " | S Nat"; + ""; + "foo : Sig Nat"; + "foo ="; + " Exist O"; + ""; + "bar : Nat"; + "bar ="; + " proj1_sig foo" $>. Proof. vm_compute. reflexivity. Qed. End ex1. @@ -92,26 +92,26 @@ Module ex2. MetaCoq Quote Recursively Definition ex2 := bar. Example ex2_test : extract ex2 = Ok <$ -"type Sig a"; -" = Exist a"; -""; -"proj1_sig : Sig a -> a"; -"proj1_sig e ="; -" case e of"; -" Exist a ->"; -" a"; -""; -"type Nat"; -" = O"; -" | S Nat"; -""; -"foo : Sig Nat"; -"foo ="; -" Exist O"; -""; -"bar : Nat"; -"bar ="; -" proj1_sig foo" $>. + "type Sig a"; + " = Exist a"; + ""; + "proj1_sig : Sig a -> a"; + "proj1_sig e ="; + " case e of"; + " Exist a ->"; + " a"; + ""; + "type Nat"; + " = O"; + " | S Nat"; + ""; + "foo : Sig Nat"; + "foo ="; + " Exist O"; + ""; + "bar : Nat"; + "bar ="; + " proj1_sig foo" $>. Proof. vm_compute. reflexivity. Qed. End ex2. @@ -124,21 +124,21 @@ Module ex3. Example ex3_test : extract ex3 = Ok <$ -"type Nat"; -" = O"; -" | S Nat"; -""; -"foo : (□ -> Nat -> Nat) -> Nat"; -"foo f ="; -" f □ O"; -""; -"bar : Nat -> Nat"; -"bar n ="; -" n"; -""; -"baz : Nat"; -"baz ="; -" foo (\x -> bar)" $>. + "type Nat"; + " = O"; + " | S Nat"; + ""; + "foo : (□ -> Nat -> Nat) -> Nat"; + "foo f ="; + " f □ O"; + ""; + "bar : Nat -> Nat"; + "bar n ="; + " n"; + ""; + "baz : Nat"; + "baz ="; + " foo (\x -> bar)" $>. Proof. vm_compute. reflexivity. Qed. End ex3. @@ -148,13 +148,13 @@ Module ex4. Example ex4_test : extract ex4 = Ok <$ -"type Sumbool"; -" = Left"; -" | Right"; -""; -"foo : Sumbool"; -"foo ="; -" Left" $>. + "type Sumbool"; + " = Left"; + " | Right"; + ""; + "foo : Sumbool"; + "foo ="; + " Left" $>. Proof. now vm_compute. Qed. End ex4. @@ -165,13 +165,13 @@ Module ex5. Example ex5_test : extract ex5 = Ok <$ -"type Sum a b"; -" = Inl a"; -" | Inr b"; -""; -"foo : Sum □ □"; -"foo ="; -" Inl □" $>. + "type Sum a b"; + " = Inl a"; + " | Inr b"; + ""; + "foo : Sum □ □"; + "foo ="; + " Inl □" $>. Proof. vm_compute. reflexivity. Qed. End ex5. @@ -184,29 +184,29 @@ Module ex6. Example ex6_test : extract ex6 = Ok <$ -"type Nat"; -" = O"; -" | S Nat"; -""; -"foo : (□ -> □ -> Nat -> Nat) -> Nat"; -"foo f ="; -" f □ □ O"; -""; -"add : Nat -> Nat -> Nat"; -"add n m ="; -" case n of"; -" O ->"; -" m"; -" S p ->"; -" S (add p m)"; -""; -"bar : Nat -> Nat -> Nat"; -"bar m n ="; -" add m n"; -""; -"baz : Nat -> Nat"; -"baz ="; -" (\m n -> foo (\x x2 -> bar (add m n))) O" $>. + "type Nat"; + " = O"; + " | S Nat"; + ""; + "foo : (□ -> □ -> Nat -> Nat) -> Nat"; + "foo f ="; + " f □ □ O"; + ""; + "add : Nat -> Nat -> Nat"; + "add n m ="; + " case n of"; + " O ->"; + " m"; + " S p ->"; + " S (add p m)"; + ""; + "bar : Nat -> Nat -> Nat"; + "bar m n ="; + " add m n"; + ""; + "baz : Nat -> Nat"; + "baz ="; + " (\m n -> foo (\x x2 -> bar (add m n))) O" $>. Proof. vm_compute. reflexivity. Qed. End ex6. @@ -218,25 +218,25 @@ Module ex7. Example ex7_test : extract ex7 = Ok <$ -"type Nat"; -" = O"; -" | S Nat"; -""; -"foo : Nat -> Nat -> Nat"; -"foo n ="; -" let"; -" x ="; -" O"; -" in"; -" \m -> case n of"; -" O ->"; -" m"; -" S n0 ->"; -" n"; -""; -"bar : Nat"; -"bar ="; -" foo (S O) O" $>. + "type Nat"; + " = O"; + " | S Nat"; + ""; + "foo : Nat -> Nat -> Nat"; + "foo n ="; + " let"; + " x ="; + " O"; + " in"; + " \m -> case n of"; + " O ->"; + " m"; + " S n0 ->"; + " n"; + ""; + "bar : Nat"; + "bar ="; + " foo (S O) O" $>. Proof. vm_compute. reflexivity. Qed. End ex7. @@ -249,8 +249,8 @@ Module ex8. Example ex8_test : extract ex8 = Ok <$ -"type ManyParamsInd a b"; -" = MPIConstr a b" $>. + "type ManyParamsInd a b"; + " = MPIConstr a b" $>. Proof. vm_compute. reflexivity. Qed. End ex8. @@ -264,16 +264,16 @@ Module ex9. Example ManyParamsIndNonArity_test: extract ex9 = Ok <$ -"type List a"; -" = Nil"; -" | Cons a (List a)"; -""; -"type Prod a b"; -" = Pair a b"; -""; -"type ManyParamsIndNonArity a b"; -" = MPINAConstr1 a b"; -" | MPINAConstr2 (List □) (Prod a b)" $>. + "type List a"; + " = Nil"; + " | Cons a (List a)"; + ""; + "type Prod a b"; + " = Pair a b"; + ""; + "type ManyParamsIndNonArity a b"; + " = MPINAConstr1 a b"; + " | MPINAConstr2 (List □) (Prod a b)" $>. Proof. vm_compute. reflexivity. Qed. End ex9. @@ -284,16 +284,16 @@ Module ex10. Example ex10_test : general_extract ex10 [<%% @proj1_sig %%>] [] = Ok <$ -"type Sig a"; -" = Exist a"; -""; -"type Nat"; -" = O"; -" | S Nat"; -""; -"foo : Sig Nat -> Nat"; -"foo x ="; -" proj1_sig x" $>. + "type Sig a"; + " = Exist a"; + ""; + "type Nat"; + " = O"; + " | S Nat"; + ""; + "foo : Sig Nat -> Nat"; + "foo x ="; + " proj1_sig x" $>. Proof. vm_compute. reflexivity. Qed. End ex10. @@ -301,8 +301,8 @@ Module ex11. MetaCoq Quote Recursively Definition ex11 := Monad. Example Monad_test : extract ex11 = Ok <$ -"type Monad m"; -" = Build_Monad (□ -> 𝕋 -> m) (□ -> □ -> m -> (𝕋 -> m) -> m)" $>. + "type Monad m"; + " = Build_Monad (□ -> 𝕋 -> m) (□ -> □ -> m -> (𝕋 -> m) -> m)" $>. Proof. vm_compute. reflexivity. Qed. End ex11. @@ -312,11 +312,11 @@ Module ex12. MetaCoq Quote Recursively Definition ex := @weird_id. Example test : extract ex = Ok <$ -"type alias IdT t = t"; -""; -"weird_id : IdT t -> IdT t"; -"weird_id i ="; -" i" $>. + "type alias IdT t = t"; + ""; + "weird_id : IdT t -> IdT t"; + "weird_id i ="; + " i" $>. Proof. vm_compute. reflexivity. Qed. End ex12. @@ -329,23 +329,23 @@ Module ex13. MetaCoq Quote Recursively Definition ex := unwrap. Example test : extract ex = Ok <$ -"type Option a"; -" = Some a"; -" | None"; -""; -"type alias Opt a = Option a"; -""; -"type Nat"; -" = O"; -" | S Nat"; -""; -"unwrap : Opt Nat -> Nat"; -"unwrap o ="; -" case o of"; -" Some x ->"; -" x"; -" None ->"; -" O" $>. + "type Option a"; + " = Some a"; + " | None"; + ""; + "type alias Opt a = Option a"; + ""; + "type Nat"; + " = O"; + " | S Nat"; + ""; + "unwrap : Opt Nat -> Nat"; + "unwrap o ="; + " case o of"; + " Some x ->"; + " x"; + " None ->"; + " O" $>. Proof. vm_compute. reflexivity. Qed. End ex13. @@ -361,19 +361,20 @@ Module ex_infix1. Example test : general_extract ex (map fst TT) TT = Ok <$ -""; -""; -"map : (a -> b) -> List a -> List b"; -"map f ="; -" let"; -" map2 l ="; -" case l of"; -" [] ->"; -" []"; -" a :: t ->"; -" (::) (f a) (map2 t)"; -" in"; -" map2" $>. vm_compute. reflexivity. Qed. + ""; + ""; + "map : (a -> b) -> List a -> List b"; + "map f ="; + " let"; + " map2 l ="; + " case l of"; + " [] ->"; + " []"; + " a :: t ->"; + " (::) (f a) (map2 t)"; + " in"; + " map2" $>. + Proof. vm_compute. reflexivity. Qed. End ex_infix1. Module recursor_ex. @@ -381,14 +382,34 @@ Module recursor_ex. Program Definition test {A B : Type} (f : A -> B) (xs : list A) : list B := list_rect (fun x => list B) [] (fun x _ rec => f x :: rec) xs. - Lemma test_is_map : @test = @map. + Lemma test_is_map : + @test = @map. Proof. reflexivity. Qed. - Print test. - MetaCoq Quote Recursively Definition ex := @test. - Compute general_extract ex [] []. + Example ex_test : + general_extract ex [] [] = Ok <$ + "type List a"; + " = Nil"; + " | Cons a (List a)"; + ""; + "list_rect : p -> (a -> List a -> p -> p) -> List a -> p"; + "list_rect f f0 ="; + " let"; + " f2 l ="; + " case l of"; + " Nil ->"; + " f"; + " Cons y l2 ->"; + " f0 y l2 (f2 l2)"; + " in"; + " f2"; + ""; + "test : (a -> b) -> List a -> List b"; + "test f xs ="; + " list_rect Nil (\x l rec -> Cons (f x) rec) xs" $>. + Proof. vm_compute. reflexivity. Qed. End recursor_ex. Module type_scheme_ex. @@ -424,7 +445,8 @@ Module type_scheme_ex. MetaCoq Quote Recursively Definition Arrow_syn := Arrow. Example Arrow_test : - general_extract Arrow_syn [] [] = Ok "type alias Arrow a b = a -> b". + general_extract Arrow_syn [] [] = + Ok "type alias Arrow a b = a -> b". Proof. vm_compute. reflexivity. Qed. Definition Triple (A B C : Type) := A * B * C. @@ -435,18 +457,21 @@ Module type_scheme_ex. Example Triple_test : general_extract Triple_syn [] [] = Ok <$ -"type Prod a b"; -" = Pair a b"; -""; -"type alias Triple a b c = Prod (Prod a b) c" $>. + "type Prod a b"; + " = Pair a b"; + ""; + "type alias Triple a b c = Prod (Prod a b) c" $>. Proof. vm_compute. reflexivity. Qed. Module LetouzeyExample. (* An example from Letouzey's thesis, Section 3.3.4 *) - Definition P (b : bool) : Set := if b then nat else bool. - Definition Sch3 : (bool -> Set) -> Set := fun X => X true -> X false. - Definition Sch3_applied := (fun X => X true -> X false) (fun b => if b then nat else bool). + Definition P (b : bool) : Set := + if b then nat else bool. + Definition Sch3 : (bool -> Set) -> Set := + fun X => X true -> X false. + Definition Sch3_applied := + (fun X => X true -> X false) (fun b => if b then nat else bool). MetaCoq Quote Recursively Definition Sch3_syn := Sch3. @@ -459,15 +484,15 @@ Module type_scheme_ex. (* In this case, the application reduces to a type with no type parameters *) Example Sch3_applied_test : general_extract Sch3_applied_syn [] [] = Ok <$ -"type Bool"; -" = True"; -" | False"; -""; -"type Nat"; -" = O"; -" | S Nat"; -""; -"type alias Sch3_applied = Nat -> Bool" $>. + "type Bool"; + " = True"; + " | False"; + ""; + "type Nat"; + " = O"; + " | S Nat"; + ""; + "type alias Sch3_applied = Nat -> Bool" $>. Proof. vm_compute. reflexivity. Qed. End LetouzeyExample. @@ -485,22 +510,22 @@ Module type_scheme_ex. Example singleton_vec_test: general_extract singleton_vec_syn [] [] = Ok <$ -"type Nat"; -" = O"; -" | S Nat"; -""; -"type Sig a"; -" = Exist a"; -""; -"type List a"; -" = Nil"; -" | Cons a (List a)"; -""; -"type alias Vec a = Sig (List a)"; -""; -"singleton_vec : Nat -> Vec Nat"; -"singleton_vec n ="; -" Exist (Cons n Nil)" $>. + "type Nat"; + " = O"; + " | S Nat"; + ""; + "type Sig a"; + " = Exist a"; + ""; + "type List a"; + " = Nil"; + " | Cons a (List a)"; + ""; + "type alias Vec a = Sig (List a)"; + ""; + "singleton_vec : Nat -> Vec Nat"; + "singleton_vec n ="; + " Exist (Cons n Nil)" $>. Proof. vm_compute. reflexivity. Qed. End type_scheme_ex. diff --git a/extraction/tests/ElmForms.v b/extraction/tests/ElmForms.v index d422bdea..743356f3 100644 --- a/extraction/tests/ElmForms.v +++ b/extraction/tests/ElmForms.v @@ -98,28 +98,28 @@ Definition passwordsDoNotMatchError := "Passwords do not match!". Definition passwordIsTooShortError := "Password is too short!". Definition userAlreadyExistsError := "User already exists!". -Program Definition validateModel : Model -> list string - := fun model => - let res := - [ (~~ existsb (fun nm => nm =? model.(currentEntry).(name)) (seNames model.(users)), userAlreadyExistsError) ; (~~ (model.(currentEntry).(name) =? ""), emptyNameError) - ; (model.(currentEntry).(password) =? model.(currentEntry).(passwordAgain), passwordsDoNotMatchError) - ; (8 <=? length model.(currentEntry).(password), passwordIsTooShortError)%nat] in - map snd (filter (fun x => ~~ x.1) res). +Program Definition validateModel : Model -> list string := + fun model => + let res := + [ (~~ existsb (fun nm => nm =? model.(currentEntry).(name)) (seNames model.(users)), userAlreadyExistsError) ; (~~ (model.(currentEntry).(name) =? ""), emptyNameError) + ; (model.(currentEntry).(password) =? model.(currentEntry).(passwordAgain), passwordsDoNotMatchError) + ; (8 <=? length model.(currentEntry).(password), passwordIsTooShortError)%nat] in + map snd (filter (fun x => ~~ x.1) res). -(* Messages for updating the current entry and adding the current entry to the list of users *) +(* Messages for updating the current entry and adding the current entry to the list of users *) Inductive StorageMsg := - Add - | UpdateEntry (_ : Msg). +| Add +| UpdateEntry (_ : Msg). (** We translate the user input to the stored representation. Note that the transation only works for valid entries *) -Program Definition toValidStoredEntry : ValidEntry -> ValidStoredEntry - := fun entry => - {| seName := entry.(name); sePassword := entry.(password) |}. +Program Definition toValidStoredEntry : ValidEntry -> ValidStoredEntry := + fun entry => + {| seName := entry.(name); sePassword := entry.(password) |}. Next Obligation. - destruct entry as [e He];destruct He as (? & ? & ?);cbn;auto. + destruct entry as [e He]; destruct He as (? & ? & ?); cbn; auto. Qed. Local Hint Resolve -> eqb_neq : core. @@ -135,33 +135,33 @@ Tactic Notation "destruct_validation" := destruct (password _ =? passwordAgain _) eqn: passwords_eq; destruct (8 <=? length (password _))%nat - eqn:password_long_enough;try discriminate. - -Program Definition updateModel : StorageMsg -> Model -> Model * Cmd StorageMsg - := fun msg model => - match msg with - | Add => - match validateModel model with - | [] => - let validEntry : ValidEntry := model.(currentEntry) in - let newValidStoredEntry : ValidStoredEntry := - toValidStoredEntry validEntry in - let newList := newValidStoredEntry :: model.(users) in - (model<| users := newList |>, none) - | errs => (model<| errors := errs |>, none) - end - | UpdateEntry entryMsg => - (model<|currentEntry := updateEntry entryMsg model.(currentEntry) |>, none) - end. -Solve Obligations with (cbn;intros;destruct_validation;auto). + eqn:password_long_enough; try discriminate. + +Program Definition updateModel : StorageMsg -> Model -> Model * Cmd StorageMsg := + fun msg model => + match msg with + | Add => + match validateModel model with + | [] => + let validEntry : ValidEntry := model.(currentEntry) in + let newValidStoredEntry : ValidStoredEntry := + toValidStoredEntry validEntry in + let newList := newValidStoredEntry :: model.(users) in + (model<| users := newList |>, none) + | errs => (model<| errors := errs |>, none) + end + | UpdateEntry entryMsg => + (model<|currentEntry := updateEntry entryMsg model.(currentEntry) |>, none) + end. +Solve Obligations with (cbn; intros; destruct_validation; auto). Next Obligation. - destruct_validation;auto. + destruct_validation; auto. constructor. + intro Hin. remember (fun nm : string => nm =? name (currentEntry model)) as f. remember (seNames (proj1_sig model.(users))) as l. assert (Hex_in : exists x, In x l /\ f x = true). - { exists model.(currentEntry).(name);subst;split. apply Hin. apply eqb_refl. } + { exists model.(currentEntry).(name); subst; split. apply Hin. apply eqb_refl. } now apply existsb_exists in Hex_in. + destruct (model.(users)) as (l, l_nodup). cbn. auto. Qed. @@ -276,12 +276,12 @@ Definition TT := ]. Definition to_inline := - [<%% setter_from_getter_Entry_name %%> - ;<%% setter_from_getter_Model_users %%> - ;<%% setter_from_getter_Model_errors %%> - ;<%% setter_from_getter_Model_currentEntry%%> - ;<%% setter_from_getter_Entry_password%%> - ;<%% setter_from_getter_Entry_passwordAgain%%> + [ <%% setter_from_getter_Entry_name %%> + ; <%% setter_from_getter_Model_users %%> + ; <%% setter_from_getter_Model_errors %%> + ; <%% setter_from_getter_Model_currentEntry%%> + ; <%% setter_from_getter_Entry_password%%> + ; <%% setter_from_getter_Entry_passwordAgain%%> ]. Definition elm_extraction (m : ElmMod) (TT : list (kername * string)) : TemplateMonad _ := diff --git a/extraction/tests/RecordExtractionLiquidityTests.v b/extraction/tests/RecordExtractionLiquidityTests.v index ed7165c9..5079d7a0 100644 --- a/extraction/tests/RecordExtractionLiquidityTests.v +++ b/extraction/tests/RecordExtractionLiquidityTests.v @@ -10,7 +10,7 @@ Import ListNotations. Local Open Scope string_scope. Definition PREFIX := "". -Definition TT_defs := +Definition TT_defs := [ remap <%% nat %%> "nat" ]. @@ -30,40 +30,44 @@ Module RecordsWithoutPrimitiveProjections. MetaCoq Quote Recursively Definition proj_A_quoted := proj_A. (* Print proj_A_quoted. *) - - Definition proj_A_printed := + + Definition proj_A_printed := Eval vm_compute in unwrap_sum (liquidity_extract_single TT_defs [] true "" "" proj_A_quoted). - Example A_printed_as_type_alias : proj_A_printed =? -<$ ""; -""; -"type a = nat"; -""; -"let proj_A (a : a) = a"; -""; -"" $>. - Proof. unfold proj_A_printed. reflexivity. Qed. - - Definition constructA : A := - let a1 := {| x:= 0 |} in + + Example A_printed_as_type_alias : + proj_A_printed =? + <$ ""; + ""; + "type a = nat"; + ""; + "let proj_A (a : a) = a"; + ""; + "" $>. + Proof. reflexivity. Qed. + + Definition constructA : A := + let a1 := {| x := 0 |} in let a2 := build_A 0 in a1. MetaCoq Quote Recursively Definition constructA_quoted := constructA. - Definition constructA_printed := + Definition constructA_printed := Eval vm_compute in unwrap_sum (liquidity_extract_single TT_defs [] true "" "" constructA_quoted). - Print constructA_printed. - Example constructA_omits_constructor : constructA_printed =? -<$ -""; -""; -"type a = nat"; -""; -"let constructA = let a1 = O in "; -"let a2 = O in "; -"a1"; -""; -"" $>. Proof. unfold constructA_printed. reflexivity. Qed. + + Example constructA_omits_constructor : + constructA_printed =? + <$ + ""; + ""; + "type a = nat"; + ""; + "let constructA = let a1 = O in "; + "let a2 = O in "; + "a1"; + ""; + "" $>. + Proof. reflexivity. Qed. Record B := build_B { y : nat; @@ -77,43 +81,46 @@ Module RecordsWithoutPrimitiveProjections. Definition proj_B_printed := Eval vm_compute in unwrap_sum (liquidity_extract_single TT_defs [] true "" "" proj_B_quoted). - Print proj_B_printed. - Example B_printed_as_type_alias : proj_B_printed =? -<$""; -""; -"type b = {"; -"y : nat;"; -"z : nat"; -"}"; -""; -"let proj_B (b : b) = b.z"; -""; -"" $>. - Proof. unfold proj_B_printed. reflexivity. Qed. - - Definition constructB : B := - let B1 := {| y:= 0; z:=0 |} in + + Example B_printed_as_type_alias : + proj_B_printed =? + <$""; + ""; + "type b = {"; + "y : nat;"; + "z : nat"; + "}"; + ""; + "let proj_B (b : b) = b.z"; + ""; + "" $>. + Proof. reflexivity. Qed. + + Definition constructB : B := + let B1 := {| y := 0; z := 0 |} in let B2 := build_B 0 0 in B1. MetaCoq Quote Recursively Definition constructB_quoted := constructB. - Definition constructB_printed := + Definition constructB_printed := Eval vm_compute in unwrap_sum (liquidity_extract_single TT_defs [] true "" "" constructB_quoted). - Print constructB_printed. - Example constructB_uses_record_syntax : constructB_printed =? -<$""; -""; -"type b = {"; -"y : nat;"; -"z : nat"; -"}"; -""; -"let constructB = let b1 = {y = O; z = O} in "; -"let b2 = {y = O; z = O} in "; -"b1"; -""; -"" $>. Proof. unfold constructB_printed. reflexivity. Qed. + + Example constructB_uses_record_syntax : + constructB_printed =? + <$""; + ""; + "type b = {"; + "y : nat;"; + "z : nat"; + "}"; + ""; + "let constructB = let b1 = {y = O; z = O} in "; + "let b2 = {y = O; z = O} in "; + "b1"; + ""; + "" $>. + Proof. reflexivity. Qed. End RecordsWithoutPrimitiveProjections. @@ -129,39 +136,42 @@ Module RecordWithPrimitiveProjections. MetaCoq Quote Recursively Definition proj_A_quoted := proj_A. (* Print proj_A_quoted. *) - Definition proj_A_printed := + Definition proj_A_printed := Eval vm_compute in unwrap_sum (liquidity_extract_single TT_defs [] true "" "" proj_A_quoted). - Example A_printed_as_type_alias : proj_A_printed =? -<$""; -""; -"type a = nat"; -""; -"let proj_A (a : a) = a"; -""; -"" $>. - Proof. unfold proj_A_printed. reflexivity. Qed. - - Definition constructA : A := - let a1 := {| x:= 0 |} in + Example A_printed_as_type_alias : + proj_A_printed =? + <$""; + ""; + "type a = nat"; + ""; + "let proj_A (a : a) = a"; + ""; + "" $>. + Proof. reflexivity. Qed. + + Definition constructA : A := + let a1 := {| x := 0 |} in let a2 := build_A 0 in a1. MetaCoq Quote Recursively Definition constructA_quoted := constructA. - Definition constructA_printed := + Definition constructA_printed := Eval vm_compute in unwrap_sum (liquidity_extract_single TT_defs [] true "" "" constructA_quoted). - Print constructA_printed. - Example constructA_omits_constructor : constructA_printed =? -<$""; -""; -"type a = nat"; -""; -"let constructA = let a1 = O in "; -"let a2 = O in "; -"a1"; -""; -"" $>. Proof. reflexivity. Qed. + + Example constructA_omits_constructor : + constructA_printed =? + <$""; + ""; + "type a = nat"; + ""; + "let constructA = let a1 = O in "; + "let a2 = O in "; + "a1"; + ""; + "" $>. + Proof. reflexivity. Qed. Record B := build_B { y : nat; @@ -171,49 +181,49 @@ Module RecordWithPrimitiveProjections. Definition proj_B (b : B) := b.(z). MetaCoq Quote Recursively Definition proj_B_quoted := proj_B. - (* Print proj_B_quoted. *) Definition proj_B_printed := Eval vm_compute in unwrap_sum (liquidity_extract_single TT_defs [] true "" "" proj_B_quoted). - Print proj_B_printed. - - Example B_printed_as_type_alias : proj_B_printed =? -<$""; -""; -"type b = {"; -"y : nat;"; -"z : nat"; -"}"; -""; -"let proj_B (b : b) = b.z"; -""; -"" $>. - Proof. unfold proj_B_printed. reflexivity. Qed. - - - Definition constructB : B := - let B1 := {| y:= 0; z:=0 |} in + Example B_printed_as_type_alias : + proj_B_printed =? + <$""; + ""; + "type b = {"; + "y : nat;"; + "z : nat"; + "}"; + ""; + "let proj_B (b : b) = b.z"; + ""; + "" $>. + Proof. reflexivity. Qed. + + + Definition constructB : B := + let B1 := {| y := 0; z := 0 |} in let B2 := build_B 0 0 in B1. MetaCoq Quote Recursively Definition constructB_quoted := constructB. - Definition constructB_printed := + Definition constructB_printed := Eval vm_compute in unwrap_sum (liquidity_extract_single TT_defs [] true "" "" constructB_quoted). - Print constructB_printed. - Example constructB_uses_record_syntax : constructB_printed =? -<$ ""; -""; -"type b = {"; -"y : nat;"; -"z : nat"; -"}"; -""; -"let constructB = let b1 = {y = O; z = O} in "; -"let b2 = {y = O; z = O} in "; -"b1"; -""; -"" $>. Proof. unfold constructB_printed. reflexivity. Qed. + + Example constructB_uses_record_syntax : + constructB_printed =? + <$ ""; + ""; + "type b = {"; + "y : nat;"; + "z : nat"; + "}"; + ""; + "let constructB = let b1 = {y = O; z = O} in "; + "let b2 = {y = O; z = O} in "; + "b1"; + ""; + "" $>. + Proof. reflexivity. Qed. End RecordWithPrimitiveProjections. diff --git a/extraction/tests/RustExtractTests.v b/extraction/tests/RustExtractTests.v index 3ca2f51f..eac3e8b2 100644 --- a/extraction/tests/RustExtractTests.v +++ b/extraction/tests/RustExtractTests.v @@ -57,44 +57,44 @@ Module ex1. Example ex1_test : extract ex1 = Ok <$ -"#[derive(Debug, Clone)]"; -"pub enum Sig<'a, A> {"; -" exist(PhantomData<&'a A>, A)"; -"}"; -""; -"#[derive(Debug, Clone)]"; -"pub enum Nat<'a> {"; -" O(PhantomData<&'a ()>),"; -" S(PhantomData<&'a ()>, &'a Nat<'a>)"; -"}"; -""; -"fn proj1_sig(&'a self, e: &'a Sig<'a, A>) -> A {"; -" match e {"; -" &Sig::exist(_, a) => {"; -" a"; -" },"; -" }"; -"}"; -"fn proj1_sig__curried(&'a self) -> &'a dyn Fn(&'a Sig<'a, A>) -> A {"; -" self.closure(move |e| {"; -" self.proj1_sig("; -" e)"; -" })"; -"}"; -""; -"fn foo(&'a self) -> &'a Sig<'a, &'a Nat<'a>> {"; -" self.alloc("; -" Sig::exist("; -" PhantomData,"; -" self.alloc("; -" Nat::O("; -" PhantomData))))"; -"}"; -""; -"fn bar(&'a self) -> &'a Nat<'a> {"; -" self.proj1_sig("; -" self.foo())"; -"}" $>. + "#[derive(Debug, Clone)]"; + "pub enum Sig<'a, A> {"; + " exist(PhantomData<&'a A>, A)"; + "}"; + ""; + "#[derive(Debug, Clone)]"; + "pub enum Nat<'a> {"; + " O(PhantomData<&'a ()>),"; + " S(PhantomData<&'a ()>, &'a Nat<'a>)"; + "}"; + ""; + "fn proj1_sig(&'a self, e: &'a Sig<'a, A>) -> A {"; + " match e {"; + " &Sig::exist(_, a) => {"; + " a"; + " },"; + " }"; + "}"; + "fn proj1_sig__curried(&'a self) -> &'a dyn Fn(&'a Sig<'a, A>) -> A {"; + " self.closure(move |e| {"; + " self.proj1_sig("; + " e)"; + " })"; + "}"; + ""; + "fn foo(&'a self) -> &'a Sig<'a, &'a Nat<'a>> {"; + " self.alloc("; + " Sig::exist("; + " PhantomData,"; + " self.alloc("; + " Nat::O("; + " PhantomData))))"; + "}"; + ""; + "fn bar(&'a self) -> &'a Nat<'a> {"; + " self.proj1_sig("; + " self.foo())"; + "}" $>. Proof. vm_compute. reflexivity. Qed. End ex1. @@ -105,44 +105,44 @@ Module ex2. MetaCoq Quote Recursively Definition ex2 := bar. Example ex2_test : extract ex2 = Ok <$ -"#[derive(Debug, Clone)]"; -"pub enum Sig<'a, A> {"; -" exist(PhantomData<&'a A>, A)"; -"}"; -""; -"#[derive(Debug, Clone)]"; -"pub enum Nat<'a> {"; -" O(PhantomData<&'a ()>),"; -" S(PhantomData<&'a ()>, &'a Nat<'a>)"; -"}"; -""; -"fn proj1_sig(&'a self, e: &'a Sig<'a, A>) -> A {"; -" match e {"; -" &Sig::exist(_, a) => {"; -" a"; -" },"; -" }"; -"}"; -"fn proj1_sig__curried(&'a self) -> &'a dyn Fn(&'a Sig<'a, A>) -> A {"; -" self.closure(move |e| {"; -" self.proj1_sig("; -" e)"; -" })"; -"}"; -""; -"fn foo(&'a self) -> &'a Sig<'a, &'a Nat<'a>> {"; -" self.alloc("; -" Sig::exist("; -" PhantomData,"; -" self.alloc("; -" Nat::O("; -" PhantomData))))"; -"}"; -""; -"fn bar(&'a self) -> &'a Nat<'a> {"; -" self.proj1_sig("; -" self.foo())"; -"}" $>. + "#[derive(Debug, Clone)]"; + "pub enum Sig<'a, A> {"; + " exist(PhantomData<&'a A>, A)"; + "}"; + ""; + "#[derive(Debug, Clone)]"; + "pub enum Nat<'a> {"; + " O(PhantomData<&'a ()>),"; + " S(PhantomData<&'a ()>, &'a Nat<'a>)"; + "}"; + ""; + "fn proj1_sig(&'a self, e: &'a Sig<'a, A>) -> A {"; + " match e {"; + " &Sig::exist(_, a) => {"; + " a"; + " },"; + " }"; + "}"; + "fn proj1_sig__curried(&'a self) -> &'a dyn Fn(&'a Sig<'a, A>) -> A {"; + " self.closure(move |e| {"; + " self.proj1_sig("; + " e)"; + " })"; + "}"; + ""; + "fn foo(&'a self) -> &'a Sig<'a, &'a Nat<'a>> {"; + " self.alloc("; + " Sig::exist("; + " PhantomData,"; + " self.alloc("; + " Nat::O("; + " PhantomData))))"; + "}"; + ""; + "fn bar(&'a self) -> &'a Nat<'a> {"; + " self.proj1_sig("; + " self.foo())"; + "}" $>. Proof. vm_compute. reflexivity. Qed. End ex2. @@ -151,36 +151,36 @@ Module ex3. Example test : extract quoted = Ok <$ -"#[derive(Debug, Clone)]"; -"pub enum Nat<'a> {"; -" O(PhantomData<&'a ()>),"; -" S(PhantomData<&'a ()>, &'a Nat<'a>)"; -"}"; -""; -"fn add(&'a self, n: &'a Nat<'a>, m: &'a Nat<'a>) -> &'a Nat<'a> {"; -" match n {"; -" &Nat::O(_) => {"; -" m"; -" },"; -" &Nat::S(_, p) => {"; -" self.alloc("; -" Nat::S("; -" PhantomData,"; -" self.add("; -" p,"; -" m)))"; -" },"; -" }"; -"}"; -"fn add__curried(&'a self) -> &'a dyn Fn(&'a Nat<'a>) -> &'a dyn Fn(&'a Nat<'a>) -> &'a Nat<'a> {"; -" self.closure(move |n| {"; -" self.closure(move |m| {"; -" self.add("; -" n,"; -" m)"; -" })"; -" })"; -"}" $>. + "#[derive(Debug, Clone)]"; + "pub enum Nat<'a> {"; + " O(PhantomData<&'a ()>),"; + " S(PhantomData<&'a ()>, &'a Nat<'a>)"; + "}"; + ""; + "fn add(&'a self, n: &'a Nat<'a>, m: &'a Nat<'a>) -> &'a Nat<'a> {"; + " match n {"; + " &Nat::O(_) => {"; + " m"; + " },"; + " &Nat::S(_, p) => {"; + " self.alloc("; + " Nat::S("; + " PhantomData,"; + " self.add("; + " p,"; + " m)))"; + " },"; + " }"; + "}"; + "fn add__curried(&'a self) -> &'a dyn Fn(&'a Nat<'a>) -> &'a dyn Fn(&'a Nat<'a>) -> &'a Nat<'a> {"; + " self.closure(move |n| {"; + " self.closure(move |m| {"; + " self.add("; + " n,"; + " m)"; + " })"; + " })"; + "}" $>. Proof. vm_compute. reflexivity. Qed. End ex3. @@ -195,62 +195,63 @@ Module ex4. end in ackn m end. + MetaCoq Quote Recursively Definition quoted := ack. Example test : extract quoted = Ok <$ -"#[derive(Debug, Clone)]"; -"pub enum Nat<'a> {"; -" O(PhantomData<&'a ()>),"; -" S(PhantomData<&'a ()>, &'a Nat<'a>)"; -"}"; -""; -"fn ack(&'a self, n: &'a Nat<'a>, m: &'a Nat<'a>) -> &'a Nat<'a> {"; -" match n {"; -" &Nat::O(_) => {"; -" self.alloc("; -" Nat::S("; -" PhantomData,"; -" m))"; -" },"; -" &Nat::S(_, p) => {"; -" let ackn = {"; -" let ackn = self.alloc(std::cell::Cell::new(None));"; -" ackn.set(Some("; -" self.closure(move |m2| {"; -" match m2 {"; -" &Nat::O(_) => {"; -" self.ack("; -" p,"; -" self.alloc("; -" Nat::S("; -" PhantomData,"; -" self.alloc("; -" Nat::O("; -" PhantomData)))))"; -" },"; -" &Nat::S(_, q) => {"; -" self.ack("; -" p,"; -" hint_app(ackn.get().unwrap())(q))"; -" },"; -" }"; -" })));"; -" ackn.get().unwrap()"; -" };"; -" hint_app(ackn)(m)"; -" },"; -" }"; -"}"; -"fn ack__curried(&'a self) -> &'a dyn Fn(&'a Nat<'a>) -> &'a dyn Fn(&'a Nat<'a>) -> &'a Nat<'a> {"; -" self.closure(move |n| {"; -" self.closure(move |m| {"; -" self.ack("; -" n,"; -" m)"; -" })"; -" })"; -"}" $>. + "#[derive(Debug, Clone)]"; + "pub enum Nat<'a> {"; + " O(PhantomData<&'a ()>),"; + " S(PhantomData<&'a ()>, &'a Nat<'a>)"; + "}"; + ""; + "fn ack(&'a self, n: &'a Nat<'a>, m: &'a Nat<'a>) -> &'a Nat<'a> {"; + " match n {"; + " &Nat::O(_) => {"; + " self.alloc("; + " Nat::S("; + " PhantomData,"; + " m))"; + " },"; + " &Nat::S(_, p) => {"; + " let ackn = {"; + " let ackn = self.alloc(std::cell::Cell::new(None));"; + " ackn.set(Some("; + " self.closure(move |m2| {"; + " match m2 {"; + " &Nat::O(_) => {"; + " self.ack("; + " p,"; + " self.alloc("; + " Nat::S("; + " PhantomData,"; + " self.alloc("; + " Nat::O("; + " PhantomData)))))"; + " },"; + " &Nat::S(_, q) => {"; + " self.ack("; + " p,"; + " hint_app(ackn.get().unwrap())(q))"; + " },"; + " }"; + " })));"; + " ackn.get().unwrap()"; + " };"; + " hint_app(ackn)(m)"; + " },"; + " }"; + "}"; + "fn ack__curried(&'a self) -> &'a dyn Fn(&'a Nat<'a>) -> &'a dyn Fn(&'a Nat<'a>) -> &'a Nat<'a> {"; + " self.closure(move |n| {"; + " self.closure(move |m| {"; + " self.ack("; + " n,"; + " m)"; + " })"; + " })"; + "}" $>. Proof. vm_compute. reflexivity. Qed. End ex4. @@ -264,39 +265,39 @@ Module ex5. Example test : extract quoted = Ok <$ -"#[derive(Debug, Clone)]"; -"pub enum Nat<'a> {"; -" O(PhantomData<&'a ()>),"; -" S(PhantomData<&'a ()>, &'a Nat<'a>)"; -"}"; -""; -"#[derive(Debug, Clone)]"; -"pub enum T<'a> {"; -" F1(PhantomData<&'a ()>, &'a Nat<'a>),"; -" FS(PhantomData<&'a ()>, &'a Nat<'a>, &'a T<'a>)"; -"}"; -""; -"#[derive(Debug, Clone)]"; -"pub enum Eq<'a, A> {"; -" eq_refl(PhantomData<&'a A>)"; -"}"; -""; -"fn code(&'a self, f: &'a T<'a>) -> &'a T<'a> {"; -" f"; -"}"; -"fn code__curried(&'a self) -> &'a dyn Fn(&'a T<'a>) -> &'a T<'a> {"; -" self.closure(move |f| {"; -" self.code("; -" f)"; -" })"; -"}" $>. + "#[derive(Debug, Clone)]"; + "pub enum Nat<'a> {"; + " O(PhantomData<&'a ()>),"; + " S(PhantomData<&'a ()>, &'a Nat<'a>)"; + "}"; + ""; + "#[derive(Debug, Clone)]"; + "pub enum T<'a> {"; + " F1(PhantomData<&'a ()>, &'a Nat<'a>),"; + " FS(PhantomData<&'a ()>, &'a Nat<'a>, &'a T<'a>)"; + "}"; + ""; + "#[derive(Debug, Clone)]"; + "pub enum Eq<'a, A> {"; + " eq_refl(PhantomData<&'a A>)"; + "}"; + ""; + "fn code(&'a self, f: &'a T<'a>) -> &'a T<'a> {"; + " f"; + "}"; + "fn code__curried(&'a self) -> &'a dyn Fn(&'a T<'a>) -> &'a T<'a> {"; + " self.closure(move |f| {"; + " self.code("; + " f)"; + " })"; + "}" $>. Proof. vm_compute. reflexivity. Qed. End ex5. Module SafeHead. Program Definition safe_head {A} (non_empty_list : {l : list A | List.length l > 0}) : A := - match non_empty_list as l' return l' = non_empty_list -> A with + match non_empty_list as l' return l' = non_empty_list -> A with | [] => (* NOTE: we use [False_rect] to make the extracted code a bit nicer. It's totally possible to leave the whole branch as an obligation, @@ -310,14 +311,14 @@ Module SafeHead. | hd :: tl => fun _ => hd end eq_refl. Next Obligation. - cbn in *;subst. + cbn in *; subst. match goal with | H : 0 > 0 |- _ => inversion H end. Qed. - Program Definition head_of_repeat_plus_one {A} (n : nat) (a : A) : A - := safe_head (repeat a (S n)). + Program Definition head_of_repeat_plus_one {A} (n : nat) (a : A) : A := + safe_head (repeat a (S n)). Next Obligation. intros. cbn. lia. Qed. @@ -325,122 +326,121 @@ Module SafeHead. MetaCoq Run (p <- Core.tmQuoteRecTransp (@head_of_repeat_plus_one) false;; Core.tmDefinition (s_to_bs "Prog") p). - Compute extract Prog. - - Example test : extract Prog = Ok <$ -"#[derive(Debug, Clone)]"; -"pub enum Nat<'a> {"; -" O(PhantomData<&'a ()>),"; -" S(PhantomData<&'a ()>, &'a Nat<'a>)"; -"}"; -""; -"#[derive(Debug, Clone)]"; -"pub enum Sig<'a, A> {"; -" exist(PhantomData<&'a A>, A)"; -"}"; -""; -"#[derive(Debug, Clone)]"; -"pub enum List<'a, A> {"; -" nil(PhantomData<&'a A>),"; -" cons(PhantomData<&'a A>, A, &'a List<'a, A>)"; -"}"; -""; -"fn proj1_sig(&'a self, e: &'a Sig<'a, A>) -> A {"; -" match e {"; -" &Sig::exist(_, a) => {"; -" a"; -" },"; -" }"; -"}"; -"fn proj1_sig__curried(&'a self) -> &'a dyn Fn(&'a Sig<'a, A>) -> A {"; -" self.closure(move |e| {"; -" self.proj1_sig("; -" e)"; -" })"; -"}"; -""; -"fn False_rect(&'a self, P: ()) -> P {"; -" panic!(""Absurd case!"")"; -"}"; -"fn False_rect__curried(&'a self) -> &'a dyn Fn(()) -> P {"; -" self.closure(move |P| {"; -" self.False_rect("; -" P)"; -" })"; -"}"; -""; -"fn safe_head(&'a self, non_empty_list: &'a Sig<'a, &'a List<'a, A>>) -> A {"; -" hint_app(match self.proj1_sig("; -" non_empty_list) {"; -" &List::nil(_) => {"; -" self.closure(move |x| {"; -" self.False_rect("; -" ())"; -" })"; -" },"; -" &List::cons(_, hd, tl) => {"; -" self.closure(move |x| {"; -" hd"; -" })"; -" },"; -" })(())"; -"}"; -"fn safe_head__curried(&'a self) -> &'a dyn Fn(&'a Sig<'a, &'a List<'a, A>>) -> A {"; -" self.closure(move |non_empty_list| {"; -" self.safe_head("; -" non_empty_list)"; -" })"; -"}"; -""; -"fn repeat(&'a self, x: A, n: &'a Nat<'a>) -> &'a List<'a, A> {"; -" match n {"; -" &Nat::O(_) => {"; -" self.alloc("; -" List::nil("; -" PhantomData))"; -" },"; -" &Nat::S(_, k) => {"; -" self.alloc("; -" List::cons("; -" PhantomData,"; -" x,"; -" self.repeat("; -" x,"; -" k)))"; -" },"; -" }"; -"}"; -"fn repeat__curried(&'a self) -> &'a dyn Fn(A) -> &'a dyn Fn(&'a Nat<'a>) -> &'a List<'a, A> {"; -" self.closure(move |x| {"; -" self.closure(move |n| {"; -" self.repeat("; -" x,"; -" n)"; -" })"; -" })"; -"}"; -""; -"fn head_of_repeat_plus_one(&'a self, n: &'a Nat<'a>, a: A) -> A {"; -" self.safe_head("; -" self.alloc("; -" Sig::exist("; -" PhantomData,"; -" self.repeat("; -" a,"; -" self.alloc("; -" Nat::S("; -" PhantomData,"; -" n))))))"; -"}"; -"fn head_of_repeat_plus_one__curried(&'a self) -> &'a dyn Fn(&'a Nat<'a>) -> &'a dyn Fn(A) -> A {"; -" self.closure(move |n| {"; -" self.closure(move |a| {"; -" self.head_of_repeat_plus_one("; -" n,"; -" a)"; -" })"; -" })"; -"}" $>. + Example test : + extract Prog = Ok <$ + "#[derive(Debug, Clone)]"; + "pub enum Nat<'a> {"; + " O(PhantomData<&'a ()>),"; + " S(PhantomData<&'a ()>, &'a Nat<'a>)"; + "}"; + ""; + "#[derive(Debug, Clone)]"; + "pub enum Sig<'a, A> {"; + " exist(PhantomData<&'a A>, A)"; + "}"; + ""; + "#[derive(Debug, Clone)]"; + "pub enum List<'a, A> {"; + " nil(PhantomData<&'a A>),"; + " cons(PhantomData<&'a A>, A, &'a List<'a, A>)"; + "}"; + ""; + "fn proj1_sig(&'a self, e: &'a Sig<'a, A>) -> A {"; + " match e {"; + " &Sig::exist(_, a) => {"; + " a"; + " },"; + " }"; + "}"; + "fn proj1_sig__curried(&'a self) -> &'a dyn Fn(&'a Sig<'a, A>) -> A {"; + " self.closure(move |e| {"; + " self.proj1_sig("; + " e)"; + " })"; + "}"; + ""; + "fn False_rect(&'a self, P: ()) -> P {"; + " panic!(""Absurd case!"")"; + "}"; + "fn False_rect__curried(&'a self) -> &'a dyn Fn(()) -> P {"; + " self.closure(move |P| {"; + " self.False_rect("; + " P)"; + " })"; + "}"; + ""; + "fn safe_head(&'a self, non_empty_list: &'a Sig<'a, &'a List<'a, A>>) -> A {"; + " hint_app(match self.proj1_sig("; + " non_empty_list) {"; + " &List::nil(_) => {"; + " self.closure(move |x| {"; + " self.False_rect("; + " ())"; + " })"; + " },"; + " &List::cons(_, hd, tl) => {"; + " self.closure(move |x| {"; + " hd"; + " })"; + " },"; + " })(())"; + "}"; + "fn safe_head__curried(&'a self) -> &'a dyn Fn(&'a Sig<'a, &'a List<'a, A>>) -> A {"; + " self.closure(move |non_empty_list| {"; + " self.safe_head("; + " non_empty_list)"; + " })"; + "}"; + ""; + "fn repeat(&'a self, x: A, n: &'a Nat<'a>) -> &'a List<'a, A> {"; + " match n {"; + " &Nat::O(_) => {"; + " self.alloc("; + " List::nil("; + " PhantomData))"; + " },"; + " &Nat::S(_, k) => {"; + " self.alloc("; + " List::cons("; + " PhantomData,"; + " x,"; + " self.repeat("; + " x,"; + " k)))"; + " },"; + " }"; + "}"; + "fn repeat__curried(&'a self) -> &'a dyn Fn(A) -> &'a dyn Fn(&'a Nat<'a>) -> &'a List<'a, A> {"; + " self.closure(move |x| {"; + " self.closure(move |n| {"; + " self.repeat("; + " x,"; + " n)"; + " })"; + " })"; + "}"; + ""; + "fn head_of_repeat_plus_one(&'a self, n: &'a Nat<'a>, a: A) -> A {"; + " self.safe_head("; + " self.alloc("; + " Sig::exist("; + " PhantomData,"; + " self.repeat("; + " a,"; + " self.alloc("; + " Nat::S("; + " PhantomData,"; + " n))))))"; + "}"; + "fn head_of_repeat_plus_one__curried(&'a self) -> &'a dyn Fn(&'a Nat<'a>) -> &'a dyn Fn(A) -> A {"; + " self.closure(move |n| {"; + " self.closure(move |a| {"; + " self.head_of_repeat_plus_one("; + " n,"; + " a)"; + " })"; + " })"; + "}" $>. Proof. vm_compute. reflexivity. Qed. End SafeHead. diff --git a/extraction/tests/extracted-code/concordium-extract/escrow-extracted/src/tests.rs b/extraction/tests/extracted-code/concordium-extract/escrow-extracted/src/tests.rs index c682dd6c..4c62a8db 100644 --- a/extraction/tests/extracted-code/concordium-extract/escrow-extracted/src/tests.rs +++ b/extraction/tests/extracted-code/concordium-extract/escrow-extracted/src/tests.rs @@ -77,7 +77,7 @@ mod tests { let arena = bumpalo::Bump::new(); st.seek(SeekFrom::Start(0)).expect("Seek failed"); let deserial_state : ConCert_Examples_Escrow_Escrow_State = <_>::concert_deserial(&mut st, &arena).expect("Deserialisation failed"); - let res = match deserial_state { + let res = match deserial_state { ConCert_Examples_Escrow_Escrow_State::build_state(_, last_action, next_step, seller, buyer, seller_withdrawable, buyer_withdrawable) => { claim_eq!(last_action, slot_time.timestamp_millis(), "Wrong last_action:{:?}",last_action); match next_step { @@ -146,7 +146,7 @@ mod tests { let arena = bumpalo::Bump::new(); st.seek(SeekFrom::Start(0)).expect("Seek failed"); let deserial_state : ConCert_Examples_Escrow_Escrow_State = <_>::concert_deserial(&mut st, &arena).expect("Deserialisation failed"); - let res = match deserial_state { + let res = match deserial_state { ConCert_Examples_Escrow_Escrow_State::build_state(_, last_action, next_step, seller, buyer, seller_withdrawable, buyer_withdrawable) => { claim_eq!(last_action, slot_time.timestamp_millis(), "Wrong last_action:{:?}",last_action); match next_step { diff --git a/extraction/theories/CameLIGOExtract.v b/extraction/theories/CameLIGOExtract.v index 79e380c1..d1020367 100644 --- a/extraction/theories/CameLIGOExtract.v +++ b/extraction/theories/CameLIGOExtract.v @@ -69,7 +69,7 @@ Proof. (* set (extract_cameligo_params inline) as params. *) set (fun kn => existsb (eq_kername kn) ignore) as to_ignore. unshelve epose proof (annot_extract_pcuic_env cameligo_args Σ wfΣ include to_ignore _). - - subst;cbn;constructor; [|constructor]. + - subst; cbn; constructor; [|constructor]. apply annot_dearg_transform. - destruct extract_pcuic_env. * exact (Ok (t; X)). @@ -78,8 +78,6 @@ Defined. Definition blah : Monad (fun A => result A string) := _. -Print Instances Monad. - Program Definition annot_extract_template_env_specalize (e : Ast.Env.global_env) (seeds : KernameSet.t) @@ -229,7 +227,7 @@ Section LigoExtract. Definition printCameLIGODefs {msg ctx params storage operation error : Type} (Σ : Ast.Env.global_env) - (TT_defs : list (kername * String.string)) + (TT_defs : list (kername * String.string)) (TT_ctors : env String.string) (extra_ignore : list kername) (build_call_ctx : String.string) @@ -313,7 +311,7 @@ Definition quote_and_preprocess {Base : ChainBase} Σcert <- tmEval lazy (inline_globals to_inline decls) ;; mpath <- tmCurrentModPath tt;; Certifying.gen_defs_and_proofs decls Σcert mpath "_cert_pass" - (KernameSetProp.of_list [init_nm;receive_nm]);; + (KernameSetProp.of_list [init_nm; receive_nm]);; ret Σcert);; Σret <- tmEval lazy (if WITH_UNIVERSES then Ast.Env.Build_global_env (Ast.Env.universes Σ) decls @@ -347,7 +345,7 @@ Definition CameLIGO_prepare_extraction {msg ctx params storage operation error : Convenient to use, but might be slow, becase performance of [tmEval lazy] is not great. *) Definition CameLIGO_extract {msg ctx params storage operation error : Type} (inline : list kername) - (TT_defs : list (kername * String.string)) + (TT_defs : list (kername * String.string)) (TT_ctors : env String.string) (extra_ignore : list kername) (build_call_ctx : String.string) @@ -393,8 +391,8 @@ Definition simple_def_print `{ChainBase} TT_defs TT_ctors seeds (prelude harness |> map (fun d => match d with ConstDecl d' => d' | TyDecl d' => d' end) |> filter not_empty_str in let defs : list String.string := - ldef_const_list |> map snd - |> List.app (map snd ldef_ty_list) in + ldef_const_list |> map snd + |> List.app (map snd ldef_ty_list) in Strings.String.concat (Common.nl ++ Common.nl) ((prelude :: defs ++ [harness]))%list |> inl | Err e => inr (bs_to_s e) end. @@ -429,7 +427,7 @@ Definition quote_and_preprocess_one_def {A} of [storage], [main], etc.*) Definition CameLIGO_extract_single `{ChainBase} {A} (inline : list kername) - (TT_defs : list (kername * String.string)) + (TT_defs : list (kername * String.string)) (TT_ctors : env String.string) (prelude : String.string) (harness: String.string) @@ -438,10 +436,10 @@ Definition CameLIGO_extract_single `{ChainBase} {A} let seeds := KernameSetProp.of_list [def_nm] in tmEval lazy (unwrap_string_sum (simple_def_print TT_defs TT_ctors (KernameSet.singleton def_nm) prelude harness Σ)). -(** Similar to [CameLIGO_prepare_extraction], but for a single definition *) +(** Similar to [CameLIGO_prepare_extraction], but for a single definition *) Definition CameLIGO_prepare_extraction_single `{ChainBase} {A} (inline : list kername) - (TT_defs : list (kername * String.string)) + (TT_defs : list (kername * String.string)) (TT_ctors : env String.string) (prelude : String.string) (harness: String.string) diff --git a/extraction/theories/CameLIGOPretty.v b/extraction/theories/CameLIGOPretty.v index 327dbef4..a4b42030 100644 --- a/extraction/theories/CameLIGOPretty.v +++ b/extraction/theories/CameLIGOPretty.v @@ -43,7 +43,7 @@ Class CameLIGOPrintConfig := { (* cosnstructors start with an uppercase letter *) print_ctor_name : kername -> string; - (* types start with a lowercase letter *) + (* types start with a lowercase letter *) print_type_name : kername -> string; (* constants start with a lowercase letter *) @@ -53,12 +53,12 @@ Notation "'bs_to_s' s" := (bytestring.String.to_string s) (at level 200). Local Coercion bytestring.String.to_string : bytestring.String.t >-> string. -(** Prepend the last module name all global declaration names to avoid name clashes. Due +(** Prepend the last module name all global declaration names to avoid name clashes. Due to limitations for constructors, use only part of the module name and cut the first 31 letters *) Module PrintConfAddModuleNames. - + Definition last_module_name (mp : modpath) : string := match mp with | MPdot mp' nm => nm @@ -84,7 +84,7 @@ Module PrintConfAddModuleNames. let nm := (snd ind_kn) in let ty_name := if lmn =? "" then bs_to_s nm else lmn ^ "_" ^ nm in uncapitalize ty_name. - + Local Instance PrintWithModuleNames : CameLIGOPrintConfig := {| print_ctor_name := print_ctor_name_; print_type_name := print_ind_type_name_; @@ -131,7 +131,7 @@ Section PPTerm. else let no_parens := (#|args| =? 1)%nat in Common.parens (no_parens) (String.concat ", " args). - + Definition print_uncurried_app (s : string) (args : list string) := let print_parens := (Nat.ltb 0 (List.length args)) in s ++ " " ++ print_uncurried args. @@ -142,13 +142,13 @@ Section PPTerm. | _ => false end. - Definition map_targs (f : box_type -> string) : box_type -> list string - := fix go bt := match bt with - | TApp t1 t2 => (go t1 ++ [f t2])%list - | _ => [] - end. + Definition map_targs (f : box_type -> string) : box_type -> list string := + fix go bt := match bt with + | TApp t1 t2 => (go t1 ++ [f t2])%list + | _ => [] + end. + - Fixpoint get_tapp_hd (bt : box_type) : box_type := match bt with | TApp t1 t2 => get_tapp_hd t1 @@ -158,10 +158,10 @@ Section PPTerm. (* Certain names in CameLIGO are reserved (like 'to' and others) so we ensure no fresh names are reserved *) (* Note: for reserved names from the syntax (like 'let', 'in', 'match', etc.) we don't need to add them since they are also reserved names in Coq, hence we can't write coq programs with these names anyways. *) - Definition is_reserved_name (id : string) (reserved : list string) := + Definition is_reserved_name (id : string) (reserved : list string) := List.existsb (String.eqb id) reserved. - Definition ligo_reserved_names := + Definition ligo_reserved_names := [ "to" ; "val" @@ -240,8 +240,8 @@ Section PPTerm. (Γ2, nm :: vs1) end in go Γ vs. - - + + (** The [for_ind] flag tells the type printer whether the type is used in an inductive type definition or in a fucntion, since the syntax is different for these two cases in CameLIGO *) @@ -289,7 +289,7 @@ Section PPTerm. Open Scope program_scope. Definition print_box_type := print_box_type_aux false. - Definition print_ind_box_type := print_box_type_aux true. + Definition print_ind_box_type := print_box_type_aux true. Definition print_ctor (TT : env string) (ind_kn : kername) @@ -312,19 +312,19 @@ Section PPTerm. else let ps := String.concat "," (map (print_type_var_name true) ty_ctx) in parens (Nat.eqb #|ty_ctx| 1) ps ^ " ". - + Definition print_type_declaration (nm : string) (ty_ctx : list string) (body : string) : string := "type " ^ print_type_params ty_ctx ^ nm ^ " = " ^ body. - + Definition print_inductive (ind_kn : kername) (TT : env string) (oib : ExAst.one_inductive_body) := - let ind_nm := with_default (print_type_name (fst ind_kn, oib.(ExAst.ind_name))) + let ind_nm := with_default (print_type_name (fst ind_kn, oib.(ExAst.ind_name))) (lookup TT oib.(ExAst.ind_name)) in (* a context of type variable names, potentially renamed to avoid clashes *) let '(_, type_params_ctx) := fresh_string_names [] (map tvar_name oib.(ind_type_vars)) in (* one-constructor inductives are interpreted/printed as records *) match oib.(ExAst.ind_ctors), oib.(ExAst.ind_projs) with - | [build_record_ctor], _::_ => + | [build_record_ctor], _ :: _ => let '(_, ctors,_) := build_record_ctor in let projs_and_ctors := combine oib.(ExAst.ind_projs) ctors in let projs_and_ctors_printed := map (fun '(p, (na, ty)) => print_proj TT type_params_ctx (fst p, ty)) projs_and_ctors in @@ -390,14 +390,14 @@ Section PPTerm. Definition print_pair (f : term -> string) (t1 : term) (t2 : term) := parens false ((f t1) ++ " ," ++ (f t2)). - Definition is_list_cons (ind : inductive) (ctor_num : nat):= + Definition is_list_cons (ind : inductive) (ctor_num : nat) := andb (eq_kername ind.(inductive_mind) <%% list %%>) (Nat.eqb ctor_num 1). Definition print_list_cons (f : term -> string) (t1 : term) (t2 : term) := (f t1) ++ " :: " ++ (f t2). - Definition is_record_constr (t : term) : option ExAst.one_inductive_body := + Definition is_record_constr (t : term) : option ExAst.one_inductive_body := match t with | tConstruct (mkInd mind j as ind) i _ => match lookup_ind_decl mind i with @@ -411,7 +411,7 @@ Section PPTerm. | _ => None end. - Definition is_name_remapped nm TT := + Definition is_name_remapped nm TT := match (look TT nm) with | Some nm' => true | None => false @@ -487,7 +487,7 @@ Section PPTerm. Definition print_transfer (args : list string) := match args with | [] => "MalformedTransfer()" - | [a1;a2] => "Tezos.transaction unit " ++ a2 ++ " (get_contract_unit " ++ a1 ++ ")" + | [a1; a2] => "Tezos.transaction unit " ++ a2 ++ " (get_contract_unit " ++ a1 ++ ")" | _ => "MalformedTransfer(" ++ String.concat "," args ++ ")" end. @@ -506,7 +506,7 @@ Section PPTerm. [top,inapp] - flags used to determine how to print parenthesis. - [t] - a term to be printed. *) + [t] - a term to be printed. *) Fixpoint print_term (TT : env string) (ctx : context) @@ -527,7 +527,7 @@ Section PPTerm. | None => "UnboundRel(" ++ string_of_nat n ++ ")" end | tVar n => fun bt => "Var(" ++ n ++ ")" - | tEvar ev args => fun bt => "Evar(" ++ string_of_nat ev ++ "[]" (* TODO *) ++ ")" + | tEvar ev args => fun bt => "Evar(" ++ string_of_nat ev ++ "[]" (* TODO *) ++ ")" | tLambda na body => fun '(bt, a) => let na' := fresh_string_name ctx na in let (dom_tys, _) := ExAst.decompose_arr bt in @@ -545,7 +545,7 @@ Section PPTerm. print_term TT (vdef (nNamed (bytestring.String.of_string na')) def :: ctx) ty_ctx true false body bodya) | tApp f l as t => fun '(bt, (fa, la)) => let apps := rev (app_args_annot (fun '(t; a) => print_term TT ctx ty_ctx false false t a) t (bt, (fa, la))) in - let '((b;ba),argas) := Edecompose_app_annot f fa in + let '((b; ba),argas) := Edecompose_app_annot f fa in match apps with | [] => print_term TT ctx ty_ctx false true f fa | _ => @@ -583,12 +583,12 @@ Section PPTerm. | Some s => s | None => match is_name_remapped nm TT, is_record_constr b with - | false, Some oib => - let projs_and_apps := combine (map (bytestring.String.to_string ∘ fst) oib.(ExAst.ind_projs)) apps in + | false, Some oib => + let projs_and_apps := combine (map (bytestring.String.to_string ∘ fst) oib.(ExAst.ind_projs)) apps in let field_decls_printed := projs_and_apps |> map (fun '(proj, e) => proj ++ " = " ++ e) |> String.concat "; " in "({" ++ field_decls_printed ++ "}: " ++ print_box_type ty_ctx TT bt ++ ")" - | _,_ => + | _,_ => let nm' := with_default (print_ctor_name (fst mind, bytestring.String.of_string nm)) (look TT nm) in (* constructors take a single argument (uncurried), so we wrap the args into a tuple *) parens top (print_uncurried_app nm' apps) @@ -635,7 +635,7 @@ Section PPTerm. (* [if-then-else] is a special case *) if eq_kername mind <%% bool %%> then match brs with - | [b1;b2] => fun '(bt, (ta, (b1a, (b2a, _)))) => + | [b1; b2] => fun '(bt, (ta, (b1a, (b2a, _)))) => parens top ("if " ++ print_term TT ctx ty_ctx true false t ta ++ " then " ++ print_term TT ctx ty_ctx true false (snd b1) b1a @@ -655,9 +655,9 @@ Section PPTerm. (* [list] is a special case *) let na := bs_to_s na in if (eq_kername mind <%% list %%>) && (na =? "cons") then - print_pat TT mind "::" true b + print_pat TT mind "::" true b (* else if (eq_kername mind <%% list %%>) && (na =? "nil") then *) - (* print_pat "" TT mind "[]" false b *) + (* print_pat "" TT mind "[]" false b *) else print_pat TT mind na false b) (nl ++ " | ") brs_ in @@ -696,7 +696,7 @@ Section PPTerm. let targs := combine sargs (map (print_box_type ty_ctx TT) tys) in let sargs_typed := String.concat " " (map (fun '(x,ty) => parens false (x ++ " : " ++ ty)) targs) in let fix_call := parens false (fix_name ^ " : " ^ print_box_type ty_ctx TT bt) in - (* NOTE: we cannot directly use the result of decomposing with [Edecompose_lam_annot] beause the guardedness check cannot see through it *) + (* NOTE: we cannot directly use the result of decomposing with [Edecompose_lam_annot] beause the guardedness check cannot see through it *) let fix_body := lam_body_annot_cont (fun body body_annot => print_term TT ctx ty_ctx true false body body_annot) fix_decl.(dbody) fixa in parens top ("let rec " ++ fix_name ^ " " ^ sargs_typed ^ " : " ^ sret_ty ^ " = " ^ nl ^ fix_body ^ nl ^ @@ -727,7 +727,7 @@ Section PPLigo. | _ => let binders := String.concat " " ty_ctx in parens false ("type " ++ binders) end. - + Example print_forall_ex : let (_, tys) := fresh_string_names [] [BasicAst.nNamed (bytestring.String.of_string "a"); BasicAst.nNamed (bytestring.String.of_string "b"); BasicAst.nAnon] in @@ -739,13 +739,28 @@ Section PPLigo. Proof. reflexivity. Qed. Import bytestring.String. - Compute - (let (args,_) :=Edecompose_lam (tLambda (BasicAst.nNamed (bytestring.String.of_string "a")) (tLambda (BasicAst.nNamed (bytestring.String.of_string "b")) (tRel 0))) in - fresh_string_names [{| - Extract.E.decl_name := BasicAst.nNamed (String "b" EmptyString); + Example print_ex1 : + (let (args,_) := Edecompose_lam (tLambda (BasicAst.nNamed (bytestring.String.of_string "a")) + (tLambda (BasicAst.nNamed (bytestring.String.of_string "b")) (tRel 0))) in + fresh_string_names [{| + Extract.E.decl_name := BasicAst.nNamed (String "b" EmptyString); + Extract.E.decl_body := None + |}] args) = + ([{| + Extract.E.decl_name := + BasicAst.nNamed (String "b" (String "0" EmptyString)); Extract.E.decl_body := None - |}] args). - + |}; + {| + Extract.E.decl_name := BasicAst.nNamed (String "a" EmptyString); + Extract.E.decl_body := None + |}; + {| + Extract.E.decl_name := BasicAst.nNamed (String "b" EmptyString); + Extract.E.decl_body := None + |}], ["a"; "b0"]). + Proof. reflexivity. Qed. + Definition print_decl (TT : env string) (* translation table *) (env : ExAst.global_env) @@ -753,8 +768,7 @@ Section PPLigo. (wrap : string -> string) (ty_in_ctx : list BasicAst.name * box_type) (t : term) - (ta : annots box_type t) - := + (ta : annots box_type t) := let '(args,(lam_body; body_annot)) := Edecompose_lam_annot t ta in let (ctx, args) := fresh_string_names [] args in let '(ty_ctx, ty) := ty_in_ctx in @@ -852,7 +866,7 @@ Section PPLigo. | ExAst.ConstantDecl cst => fun annot => match print_cst TT env nm cst annot with | Some r => ConstDecl (nm, r) - | None => ConstDecl (nm, "print_global_decl ConstantDecl ERROR: " ++ string_of_kername nm) + | None => ConstDecl (nm, "print_global_decl ConstantDecl ERROR: " ++ string_of_kername nm) end | ExAst.InductiveDecl mib as d => fun annot => match mib.(ExAst.ind_bodies) with @@ -908,8 +922,8 @@ Section PPLigo. "[@inline] let addTez (n : tez) (m : tez) = n + m" ; "[@inline] let subTez (n : tez) (m : tez) : tez option = n - m" ; "[@inline] let leTez (a : tez ) (b : tez ) = a <= b" ; - "[@inline] let ltTez (a : tez ) (b : tez ) = a < b" ; - "[@inline] let gtbTez (a : tez ) (b : tez ) = a > b" ; + "[@inline] let ltTez (a : tez ) (b : tez ) = a < b" ; + "[@inline] let gtbTez (a : tez ) (b : tez ) = a > b" ; "[@inline] let eqTez (a : tez ) (b : tez ) = a = b" ; "[@inline] let natural_to_mutez (a: nat): tez = a * 1mutez" ; "[@inline] let divTez (a : tez) (b : tez) : tez = natural_to_mutez (a/b)" ; @@ -950,7 +964,7 @@ Section PPLigo. Definition get_contract_def := <$ - "let get_contract_unit (a : address) : unit contract =" ; + "let get_contract_unit (a : address) : unit contract =" ; " match (Tezos.get_contract_opt a : unit contract option) with" ; " Some c -> c" ; " | None -> (failwith (""Contract not found."") : unit contract)" @@ -1032,7 +1046,7 @@ Section PPLigo. "type return = (operation) list * " ++ storage_name ; "" ; "let main (p, st : " ++ parameter_name ++ " option * " ++ storage_name ++ ") : return = " ; - " (match (" ++ contract ++ " dummy_chain cctx_instance " ++ " st p) with " ; + " (match (" ++ contract ++ " dummy_chain cctx_instance " ++ " st p) with " ; " Ok v -> (v.0, v.1)" ; " | Err e -> (failwith e : return))" $>. diff --git a/extraction/theories/Common.v b/extraction/theories/Common.v index e85e5752..9907fa37 100644 --- a/extraction/theories/Common.v +++ b/extraction/theories/Common.v @@ -114,7 +114,7 @@ Definition quote_recursively_body {A : Type} (def : A) : TemplateMonad program : p <- tmQuoteRecTransp def false ;; kn <- match p.2 with | tConst name _ => ret name - | _ => tmFail ("Expected constant, got " ++ + | _ => tmFail ("Expected constant, got " ++ string_of_term p.2) end;; match lookup_env p.1 kn with @@ -158,11 +158,11 @@ Definition _N0 := EAst.tConstruct {| inductive_mind := <%% N %%>; inductive_ind Definition _Npos := EAst.tConstruct {| inductive_mind := <%% N %%>; inductive_ind := 0 |} 1 []. -Definition _Z0 := EAst.tConstruct {| inductive_mind := <%% Z %%>; inductive_ind := 0 |} 0 []. +Definition _Z0 := EAst.tConstruct {| inductive_mind := <%% Z %%>; inductive_ind := 0 |} 0 []. -Definition _Zpos := EAst.tConstruct {| inductive_mind := <%% Z %%>; inductive_ind := 0 |} 1 []. +Definition _Zpos := EAst.tConstruct {| inductive_mind := <%% Z %%>; inductive_ind := 0 |} 1 []. -Definition _Zneg := EAst.tConstruct {| inductive_mind := <%% Z %%>; inductive_ind := 0 |} 2 []. +Definition _Zneg := EAst.tConstruct {| inductive_mind := <%% Z %%>; inductive_ind := 0 |} 2 []. Fixpoint pos_syn_to_nat_aux (n : nat) (t : EAst.term) : option nat := match t with @@ -226,7 +226,7 @@ Definition Z_syn_to_Z (t : EAst.term) : option Z := (* TODO: port the pretty-printers to use bytestring and use metacoq's MCString utils *) Definition parens (top : bool) (s : String.string) : String.string := - if top then s else "(" ++ s ++ ")". + if top then s else "(" ++ s ++ ")". Definition nl : String.string := String (Ascii.ascii_of_nat 10) EmptyString. diff --git a/extraction/theories/ConcordiumExtract.v b/extraction/theories/ConcordiumExtract.v index 24aa64c1..6865bc3f 100644 --- a/extraction/theories/ConcordiumExtract.v +++ b/extraction/theories/ConcordiumExtract.v @@ -194,8 +194,8 @@ Definition remap_string : remapped_inductive := Definition remap_std_types := [ (, remap_nat) ; (, remap_positive) - ; (, remap_Z) - ; (, remap_N) + ; (, remap_Z) + ; (, remap_N) ; (, remap_bool) ; (, remap_pair) ; (, remap_option) diff --git a/extraction/theories/ElmExtract.v b/extraction/theories/ElmExtract.v index ea47d409..47d94ee7 100644 --- a/extraction/theories/ElmExtract.v +++ b/extraction/theories/ElmExtract.v @@ -260,7 +260,7 @@ Definition print_define_term Local Open Scope bool. (* TODO: Eventually, we might want to include some checks is the operators actually meets the syntactic creteria of Elm *) -Definition get_infix (s : string) : option string:= +Definition get_infix (s : string) : option string := let len := String.length s in let begins := substring_count 1 s in let ends := substring_from (len - 1) s in @@ -552,7 +552,7 @@ Definition print_mutual_inductive_body (if first then ret tt else append_nl);; (* Add type parameters. Note that since we are in prenex form, *) - (* our context will have last type parameter last, not first. *) + (* our context will have last type parameter last, not first. *) Γ <- monad_fold_left (fun Γ name => name <- fresh_ty_arg_name (tvar_name name) Γ;; diff --git a/extraction/theories/ExtractExtraction.v b/extraction/theories/ExtractExtraction.v index 35546c16..6719050b 100644 --- a/extraction/theories/ExtractExtraction.v +++ b/extraction/theories/ExtractExtraction.v @@ -41,13 +41,13 @@ Extract Constant PCUICSafeChecker.check_one_ind_body => "(fun _ _ _ _ _ _ _ -> r bytestrings from MetaCoq that leads to clashes. E.g. we cannot use [ExtrOcamlString]. *) -(* Extract Constant timed => *) -(* "(fun c x -> *) -(* let time = Unix.gettimeofday() in *) -(* let temp = x () in *) -(* let time = (Unix.gettimeofday() -. time) in *) -(* Feedback.msg_debug (Pp.str (Printf.sprintf ""%s executed in: %fs"" ((fun s-> (String.concat """" (List.map (String.make 1) s))) c) time)); *) -(* temp)". *) +(* Extract Constant timed => +"(fun c x -> + let time = Unix.gettimeofday() in + let temp = x () in + let time = (Unix.gettimeofday() -. time) in + Feedback.msg_debug (Pp.str (Printf.sprintf ""%s executed in: %fs"" ((fun s-> (String.concat """" (List.map (String.make 1) s))) c) time)); + temp)". *) Cd "plugin/src". Separate Extraction PluginExtract.extract diff --git a/extraction/theories/LiquidityExtract.v b/extraction/theories/LiquidityExtract.v index 5e16ac9e..e1cc8954 100644 --- a/extraction/theories/LiquidityExtract.v +++ b/extraction/theories/LiquidityExtract.v @@ -5,7 +5,7 @@ From ConCert.Execution Require Import Blockchain. From ConCert.Execution Require Import Serializable. From ConCert.Execution Require Import ContractCommon. From ConCert.Execution Require ResultMonad. -From ConCert.Extraction Require Import LPretty. +From ConCert.Extraction Require Import LiquidityPretty. From ConCert.Extraction Require Import Common. From MetaCoq.TypedExtraction Require Import Optimize. From MetaCoq.TypedExtraction Require Import Extraction. @@ -51,7 +51,7 @@ Definition overridden_masks (kn : kername) : option bitmask := if eq_kername kn <%% @AddressMap.empty %%> then Some [true] else None. -Definition result_string_err A := result A string. +Definition result_string_err A := result A string. (* Machinery for specializing chain base *) Definition extract_template_env_specialize @@ -82,17 +82,17 @@ Definition extract_liquidity_within_coq (to_inline : kername -> bool) |} |}. -Definition extract (to_inline : kername -> bool) +Definition extract (to_inline : kername -> bool) (seeds : KernameSet.t) (extract_ignore : kername -> bool) - (Σ : global_env) : TemplateMonad ExAst.global_env - := extract_template_env_certifying_passes Ok (extract_liquidity_within_coq to_inline seeds) Σ seeds extract_ignore. + (Σ : global_env) : TemplateMonad ExAst.global_env := + extract_template_env_certifying_passes Ok (extract_liquidity_within_coq to_inline seeds) Σ seeds extract_ignore. -Definition extract_specialize (to_inline : kername -> bool) +Definition extract_specialize (to_inline : kername -> bool) (seeds : KernameSet.t) (extract_ignore : kername -> bool) - (Σ : global_env) : TemplateMonad ExAst.global_env - := extract_template_env_certifying_passes specialize_ChainBase_env (extract_liquidity_within_coq to_inline seeds) Σ seeds extract_ignore. + (Σ : global_env) : TemplateMonad ExAst.global_env := + extract_template_env_certifying_passes specialize_ChainBase_env (extract_liquidity_within_coq to_inline seeds) Σ seeds extract_ignore. Definition printLiquidityDefs_ @@ -244,7 +244,7 @@ Definition liquidity_extract_single let seeds := KernameSet.singleton kn in let TT := (TT_ctors ++ map (fun '(kn,d) => (bs_to_s (string_of_kername kn), d)) TT_defs)%list in - let ignore := if extract_deps then fun kn => existsb (eq_kername kn) (map fst TT_defs) else fun kn' => negb (eq_kername kn' kn) in + let ignore := if extract_deps then fun kn => existsb (eq_kername kn) (map fst TT_defs) else fun kn' => negb (eq_kername kn' kn) in match extract_template_env liquidity_extract_args p.1 seeds ignore with | Ok eΣ => (* filtering out empty type declarations *) @@ -264,7 +264,7 @@ Definition liquidity_extract_single end. Definition wrap_in_delimiters (s : String.string) : String.string := - Strings.String.concat Common.nl [bs_to_s "";bs_to_s "(*START*)"; s; bs_to_s"(*END*)"]. + Strings.String.concat Common.nl [bs_to_s ""; bs_to_s "(*START*)"; s; bs_to_s"(*END*)"]. (** A flag that controls whether info abou universes is preserved after quoting *) Definition WITH_UNIVERSES := false. @@ -278,7 +278,7 @@ Definition liquidity_extraction_ {msg ctx params storage operation error : Type} list kername -> String.string -> String.string -> kername -> kername -> TemplateMonad String.string) (prefix : String.string) - (TT_defs : list (kername * String.string)) + (TT_defs : list (kername * String.string)) (TT_ctors : env String.string) (inline : list kername) (m : LiquidityMod msg ctx params storage operation error) : TemplateMonad String.string := @@ -290,7 +290,7 @@ Definition liquidity_extraction_ {msg ctx params storage operation error : Type} let TT := (TT_ctors ++ map (fun '(kn,d) => (bs_to_s (string_of_kername kn), d)) TT_defs)%list in Σ <- tmEval lazy (if WITH_UNIVERSES then - Ast.Env.Build_global_env (Ast.Env.universes Σ) (Ast.Env.declarations Σ) + Ast.Env.Build_global_env (Ast.Env.universes Σ) (Ast.Env.declarations Σ) else Ast.Env.Build_global_env (ContextSet.empty) (Ast.Env.declarations Σ));; s <- printLiquidityDefs_ prefix Σ TT inline ignore @@ -330,7 +330,7 @@ Definition quote_and_preprocess {Base : ChainBase} Σcert <- tmEval lazy (inline_globals to_inline decls) ;; mpath <- tmCurrentModPath tt;; Certifying.gen_defs_and_proofs decls Σcert mpath "_cert_pass" - (KernameSetProp.of_list [init_nm;receive_nm]);; + (KernameSetProp.of_list [init_nm; receive_nm]);; ret Σcert);; Σret <- tmEval lazy (if WITH_UNIVERSES then Ast.Env.Build_global_env (Ast.Env.universes Σ) decls @@ -345,10 +345,10 @@ Definition quote_and_preprocess {Base : ChainBase} which is much faster than running the computations inside [TemplateMonad]. *) Definition liquidity_prepare_extraction {Base : ChainBase} {msg ctx params storage operation error : Type} (prefix : String.string) - (TT_defs : list (kername * String.string)) + (TT_defs : list (kername * String.string)) (TT_ctors : env String.string) (inline : list kername) - (m : LiquidityMod msg ctx params storage operation error) := + (m : LiquidityMod msg ctx params storage operation error) := '(Σ, init_nm, receive_nm) <- quote_and_preprocess inline m;; let TT_defs := (TT_defs ++ TT_remap_default)%list in let ignore := (map fst TT_defs ++ liquidity_ignore_default)%list in diff --git a/extraction/theories/LPretty.v b/extraction/theories/LiquidityPretty.v similarity index 94% rename from extraction/theories/LPretty.v rename to extraction/theories/LiquidityPretty.v index a5ce10e0..ea146747 100644 --- a/extraction/theories/LPretty.v +++ b/extraction/theories/LiquidityPretty.v @@ -50,7 +50,7 @@ Section print_term. Context (Σ : ExAst.global_env). Import BasicAst. - + Definition look (e : env string) (s : string) : option string := lookup e s. @@ -87,28 +87,28 @@ Section print_term. | _ => false end. - Definition map_targs (f : box_type -> string) : box_type -> list string - := fix go bt := match bt with - | TApp t1 t2 => (go t1 ++ [f t2])%list - | _ => [] - end. + Definition map_targs (f : box_type -> string) : box_type -> list string := + fix go bt := match bt with + | TApp t1 t2 => (go t1 ++ [f t2])%list + | _ => [] + end. Fixpoint get_tapp_hd (bt : box_type) : box_type := match bt with | TApp t1 t2 => get_tapp_hd t1 | _ => bt end. - + Definition print_type_var (v : name) (i : nat) := match v with | nNamed nm => "'" ++ uncapitalize nm | nAnon => "anon_tvar" ++ string_of_nat i end. - + Definition print_box_type (prefix : string) (TT : env string) (vars : list name) : box_type -> string := - fix go (bt : box_type) := + fix go (bt : box_type) := match bt with | TBox => "unit" | TArr dom codom => parens (negb (is_arr dom)) (go dom) ++ " -> " ++ go codom @@ -148,7 +148,7 @@ Section print_term. | _ => prefix ++ nm ++ " of " ++ concat " * " (map (print_box_type prefix TT vars ∘ snd) tys) end. - + Definition print_proj (prefix : string) (TT : env string) (vars : list name) @@ -159,15 +159,15 @@ Section print_term. ^ " : " ^ print_box_type prefix TT vars ty. - Definition is_one_constructor_inductive_and_not_record (oib : ExAst.one_inductive_body) := + Definition is_one_constructor_inductive_and_not_record (oib : ExAst.one_inductive_body) := match oib.(ExAst.ind_ctors), oib.(ExAst.ind_projs) with | [_], _::_::_ => false (* it is a record because it has projections, and one constructor *) (* 1-inductive that's not a record *) - | [(_, [_],_)],_ => true + | [(_, [_],_)],_ => true (* record without primitive projections; 1-inductive with > args in its constructor *) - | [_],[] => false + | [_],[] => false | _,_ => false - end. + end. Definition print_inductive (prefix : string) (TT : env string) @@ -178,21 +178,21 @@ Section print_term. if (Nat.eqb #|oib.(ind_type_vars)| 0) then "" else let ps := concat "," (mapi (fun i v => print_type_var v i) vars) in (parens (Nat.ltb #|oib.(ind_type_vars)| 1) ps) ++ " " in - let print_record projs_and_ctors := + let print_record projs_and_ctors := let projs_and_ctors_printed := map (fun '(p, (proj_nm, ty)) => print_proj (capitalize prefix) TT vars (p.1, ty)) projs_and_ctors in "type " ++ params ++ uncapitalize ind_nm ++ " = {" ++ nl ++ concat (";" ++ nl) projs_and_ctors_printed ++ nl - ++ "}" in + ++ "}" in (* one-constructor inductives with non-empty ind_projs (projection identifiers) - and > 1 projections + and > 1 projections are assumed to be records *) match oib.(ExAst.ind_ctors), oib.(ExAst.ind_projs) with | [build_record_ctor], _::_::_ => let '(_, ctors,_) := build_record_ctor in let projs_and_ctors := combine oib.(ExAst.ind_projs) ctors in print_record projs_and_ctors - (* otherwise, one-constructor inductives are printed as aliases since liquidity doesn't allow inductives with 1 constructor. *) - | [(_, [ctor_arg], _)], _ => "type " ++ params ++ uncapitalize ind_nm ++" = " + (* otherwise, one-constructor inductives are printed as aliases since liquidity doesn't allow inductives with 1 constructor. *) + | [(_, [ctor_arg], _)], _ => "type " ++ params ++ uncapitalize ind_nm ++" = " ++ concat " * " (map (print_box_type prefix TT vars ∘ snd) [ctor_arg]) (* otherwise, the record might be defined without primitive projections. Hence, we look for "projections" in the constructor *) | [(_,ctor_args,_)],[] => @@ -236,15 +236,15 @@ Section print_term. end. Import EAst. - - Definition print_def (print_term : context -> bool -> bool -> term -> string) (Γ : context) (fdef : def term) := + + Definition print_def (print_term : context -> bool -> bool -> term -> string) (Γ : context) (fdef : def term) := let ctx' := [{| decl_name := dname fdef; decl_body := None |}] in let fix_name := string_of_name (fdef.(dname)) in let (args, _) := Edecompose_lam (fdef.(dbody)) in let ctx := rev (map vass args) in let sargs := print_uncurried "" (map (fun x => bs_to_s (string_of_name x)) args) in string_of_name fdef.(dname) - ++ " " ++ sargs ++ " = " + ++ " " ++ sargs ++ " = " ++ nl ++ print_term (ctx ++ ctx' ++ Γ)%list true false (lam_body fdef.(dbody)). @@ -261,10 +261,10 @@ Section print_term. (* Certain names in Liquidity are reserved (like 'to' and others) so we ensure no fresh names are reserved *) (* Note: for reserved names from the syntax (like 'let', 'in', 'match', etc.) we don't need to add them since they are also reserved names in Coq, hence we can't write coq programs with these names anyways. *) - Definition is_reserved_name (id : string) (reserved : list string) := + Definition is_reserved_name (id : string) (reserved : list string) := List.existsb (eqb id) reserved. - - Definition liquidity_reserved_names : list string := + + Definition liquidity_reserved_names : list string := [ "to" ; "from" @@ -335,16 +335,16 @@ Section print_term. Definition print_pair (f : term -> string) (t1 : term) (t2 : term) := parens false ((f t1) ++ " ," ++ (f t2)). - Definition is_list_cons (ind : inductive) (ctor_num : nat):= + Definition is_list_cons (ind : inductive) (ctor_num : nat) := andb (eq_kername ind.(inductive_mind) <%% list %%>) (Nat.eqb ctor_num 1). Definition print_list_cons (f : term -> string) (t1 : term) (t2 : term) := (f t1) ++ " :: " ++ (f t2). - Definition is_record_constr (t : term) + Definition is_record_constr (t : term) (projs : list (ident * ExAst.one_inductive_body)) - : option ExAst.one_inductive_body := + : option ExAst.one_inductive_body := match t with | tConstruct (mkInd mind j as ind) i [] => match lookup_ind_decl mind i with @@ -360,23 +360,23 @@ Section print_term. | _ => None end. -Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := +Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := match oib.(ExAst.ind_ctors), oib.(ExAst.ind_projs) with (* it is a record because it has projections, and one constructor *) - | [_], _::_::_ => map (fun x => bs_to_s (fst x)) oib.(ExAst.ind_projs) + | [_], _::_::_ => map (fun x => bs_to_s (fst x)) oib.(ExAst.ind_projs) (* 1-inductive that's not a record *) - | [(_, projs, _)],_ => projs |> map fst - |> map (fun x => bs_to_s (string_of_name x)) + | [(_, projs, _)],_ => projs |> map fst + |> map (fun x => bs_to_s (string_of_name x)) (* record without primitive projections; 1-inductive with > args in its constructor *) | _,_ => [] - end. + end. - Definition is_name_remapped nm TT := + Definition is_name_remapped nm TT := match (look TT nm) with | Some nm' => true | None => false end. - + Definition app_args {A} (f : term -> A) := fix go (t : term) := match t with | tApp t1 t2 => f t2 :: go t1 @@ -389,8 +389,8 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := | [] => false | hd :: tl => if eq_dec hd a then true else in_list eq_dec tl a - end. - + end. + (** Builds a context for the branch *) Definition get_ctx_from_branch (Γ : context) : nat -> term -> context := let fix go (ctx : context) (arity: nat) (branch : term) := @@ -417,7 +417,7 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := end. (* [print_pat] expects that the names in pt.1 are already checked for freshness *) - Definition print_pat (Γ : context) (prefix : string) (TT : env string) (ctor : string) (infix : bool) (pt : list string * string) : string:= + Definition print_pat (Γ : context) (prefix : string) (TT : env string) (ctor : string) (infix : bool) (pt : list string * string) : string := let vars := rev pt.1 in if infix then concat (" " ++ ctor ++ " ") vars ++ " -> " ++ pt.2 @@ -430,7 +430,7 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := Definition print_transfer (args : list string) := match args with | [] => "MalformedTransfer()" - | [a1;a2] => "Contract.call " ++ a1 ++ " " ++ a2 ++ " " + | [a1; a2] => "Contract.call " ++ a1 ++ " " ++ a2 ++ " " ++ "default" ++ " ()" | _ => "MalformedTransfer(" ++ concat "," args ++ ")" end. @@ -449,7 +449,7 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := [t] - a term to be printed. *) Fixpoint print_term (projs : list (ident * ExAst.one_inductive_body)) - (prefix : string) + (prefix : string) (FT : list string) (TT : env string) (Γ : context) @@ -469,7 +469,7 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := | None => "UnboundRel(" ++ string_of_nat n ++ ")" end | tVar n => "Var(" ++ n ++ ")" - | tEvar ev args => "Evar(" ++ string_of_nat ev ++ "[]" (* TODO *) ++ ")" + | tEvar ev args => "Evar(" ++ string_of_nat ev ++ "[]" (* TODO *) ++ ")" | tLambda na body => let na' := fresh_string_name Γ na t in parens top ("fun " ++ na' @@ -501,9 +501,9 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := else if nm =? "snd" then (concat " " (map (parens true) apps)) ++ ".(1)" (* check if it is a record projection *) - else + else match List.find (fun '(na,_) => (bs_to_s na) =? nm) projs with - | Some (proj_na, oib) => + | Some (proj_na, oib) => (* check if it's a 1-ind with *) if is_one_constructor_inductive_and_not_record oib then concat " " (map (parens true) apps) @@ -533,15 +533,15 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := (* is it a record declaration? *) (* if it is a inductive with one constructor, and not a record, then it is an alias, so we don't print the constructor *) else match lookup_ind_decl ind.(inductive_mind) ind.(inductive_ind) with - | Some oib => (* Check if it has only 1 constructor, and projections are specified, and > 1 projections *) - if is_one_constructor_inductive_and_not_record oib then + | Some oib => (* Check if it has only 1 constructor, and projections are specified, and > 1 projections *) + if is_one_constructor_inductive_and_not_record oib then print_term prefix FT TT Γ false false l - else + else match is_name_remapped nm TT, is_record_constr b projs with | false, Some oib => let projs : list string := get_record_projs oib in - let projs_and_apps := combine projs apps in - let field_decls_printed := projs_and_apps |> map (fun '(proj, e) => proj ++ " = " ++ e) + let projs_and_apps := combine projs apps in + let field_decls_printed := projs_and_apps |> map (fun '(proj, e) => proj ++ " = " ++ e) |> concat "; " in "{" ++ field_decls_printed ++ "}" | _,_ => let nm' := with_default ((capitalize prefix) ++ nm) (look TT nm) in @@ -551,7 +551,7 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := parens top (print_uncurried nm' apps) end | tConstruct ind l (_ :: _) => "Error(constructors_as_blocks_not_supported)" - | _ => parens (top || inapp) (print_term prefix FT TT Γ false true f ++ " " ++ print_term prefix FT TT Γ false false l) + | _ => parens (top || inapp) (print_term prefix FT TT Γ false true f ++ " " ++ print_term prefix FT TT Γ false false l) end | tConst c => let cst_name := string_of_kername c in @@ -559,7 +559,7 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := | tConstruct ind l [] => (* if it is a inductive with one constructor, and not a record, then it is an alias, so we don't print the constructor *) match lookup_ind_decl ind.(inductive_mind) ind.(inductive_ind) with - (* Check if it has only 1 constructor, and projections are specified, and > 1 projections *) + (* Check if it has only 1 constructor, and projections are specified, and > 1 projections *) | Some oib => if is_one_constructor_inductive_and_not_record oib then "" else let nm := get_constr_name ind l in with_default (capitalize prefix ++ capitalize nm) (look TT nm) @@ -575,7 +575,7 @@ Definition get_record_projs (oib : ExAst.one_inductive_body) : list string := (* [if-then-else] is a special case *) if eq_kername mind <%% bool %%> then match brs with - | [b1;b2] => + | [b1; b2] => parens top ("if " ++ print_term prefix FT TT Γ true false t ++ " then " ++ print_term prefix FT TT Γ true false (snd b1) @@ -689,7 +689,7 @@ Fixpoint get_fix_names (t : term) : list BasicAst.name := Definition print_decl (prefix : string) (TT : env string) (* tranlation table *) (Σ : ExAst.global_env) - (projs : list (Kernames.ident * ExAst.one_inductive_body)) + (projs : list (Kernames.ident * ExAst.one_inductive_body)) (decl_name : string) (modifier : option string) (wrap : string -> string) @@ -707,7 +707,7 @@ Definition print_decl (prefix : string) | None => "" end in "let" ++ modif ++ " " ++ decl ++ " = " - ++ wrap (LPretty.print_term Σ projs prefix [] TT ctx true false lam_body). + ++ wrap (LiquidityPretty.print_term Σ projs prefix [] TT ctx true false lam_body). Definition print_init (prefix : string) (TT : env string) (* tranlation table *) @@ -729,7 +729,7 @@ Definition print_init (prefix : string) let wrap t := "match " ++ t ++ " with Ok v -> v | Err e -> failwith e" in let let_inner := "let " ++ decl_inner ++ " = " - ++ LPretty.print_term Σ projs prefix [] TT ctx true false lam_body + ++ LiquidityPretty.print_term Σ projs prefix [] TT ctx true false lam_body ++ " in" in (* ignore the first argument because it's a call context *) let printed_targs_outer := tl printed_targs_inner in @@ -750,8 +750,8 @@ Definition print_cst (prefix : string) (TT : env string) (* tranlation table *) (Σ : ExAst.global_env) (kn : Kernames.kername) - (cst : ExAst.constant_body) - (projs : list (Kernames.ident * ExAst.one_inductive_body)) + (cst : ExAst.constant_body) + (projs : list (Kernames.ident * ExAst.one_inductive_body)) : string := match cst.(ExAst.cst_body) with | Some cst_body => @@ -764,8 +764,8 @@ Definition print_cst (prefix : string) Definition print_global_decl (prefix : string) (TT : env string) (nm : Kernames.kername) (Σ : ExAst.global_env) - (d : ExAst.global_decl) - (projs : list (Kernames.ident * ExAst.one_inductive_body)) + (d : ExAst.global_decl) + (projs : list (Kernames.ident * ExAst.one_inductive_body)) : Kernames.kername * string := match d with | ExAst.ConstantDecl cst => @@ -773,7 +773,7 @@ Definition print_global_decl (prefix : string) (TT : env string) if List.existsb (fun p => bytestring.String.eqb nm.2 p.1) projs then (nm, "") (* (nm, "projs: " ++ nm.2 ++ " : " ++ String.concat ";" (map fst projs )) *) - else + else (nm, print_cst prefix TT Σ nm cst projs) | ExAst.InductiveDecl mib => match mib.(ExAst.ind_bodies) with @@ -784,14 +784,14 @@ Definition print_global_decl (prefix : string) (TT : env string) let ta_nm := with_default (prefix ++ nm.2) (lookup TT (Kernames.string_of_kername nm)) in (nm, "type " ++ parens (Nat.ltb #|params| 1) (concat "," (mapi (fun i v => print_type_var v.(tvar_name) i) params)) ++ " " ++ uncapitalize ta_nm - ++ " = " + ++ " = " ++ print_box_type prefix TT (map tvar_name params) ty) | TypeAliasDecl None => (nm, "") end. Fixpoint print_global_env (prefix : string) (TT : env string) (Σ : ExAst.global_env) - (projs : list (Kernames.ident * ExAst.one_inductive_body)) + (projs : list (Kernames.ident * ExAst.one_inductive_body)) : list (Kernames.kername * string) := match Σ with | (kn, has_deps, decl) :: Σ' => @@ -843,22 +843,22 @@ Definition tez_ops := ++ nl ++ "let[@inline] leTez (a : tez ) (b : tez ) = a <= b" ++ nl - ++ "let[@inline] ltTez (a : tez ) (b : tez ) = a < b" + ++ "let[@inline] ltTez (a : tez ) (b : tez ) = a < b" ++ nl - ++ "let[@inline] gtTez (a : tez ) (b : tez ) = a > b" + ++ "let[@inline] gtTez (a : tez ) (b : tez ) = a > b" ++ nl ++ "let[@inline] eqTez (a : tez ) (b : tez ) = a = b" ++ nl ++ "let[@inline] evenTez (i : tez) = match i/2tz with | Some (_, r) -> r=0tz | None -> false" ++ nl ++ "let tez_to_nat (a : tez) : nat =" ++ nl - ++ "let (n, _) = match a / 1DUN with" ++ nl - ++ "| Some qr -> qr" ++ nl - ++ "| None -> failwith () (* impossible case *)" ++ nl + ++ "let (n, _) = match a / 1DUN with" ++ nl + ++ "| Some qr -> qr" ++ nl + ++ "| None -> failwith () (* impossible case *)" ++ nl ++ "in n" ++ nl ++ "let[@inline] divTez (a : tez) (b : tez) : tez = match a/(tez_to_nat b) with Some(d,_) -> d | None -> 0tz" - ++ nl + ++ nl ++ "let[@inline] multTez (n : tez) (m : tez) : tez = n * tez_to_nat m". diff --git a/extraction/theories/PluginExtract.v b/extraction/theories/PluginExtract.v index 31549ffc..fb1ac85c 100644 --- a/extraction/theories/PluginExtract.v +++ b/extraction/theories/PluginExtract.v @@ -136,12 +136,12 @@ Instance RustConfig : RustPrintConfig := Definition default_attrs : ind_attr_map := fun _ => "#[derive(Debug, Clone)]". -Module T:=Ast.Env. +Module T := Ast.Env. Definition extract_lines (p : T.program) (remaps : remaps) - (should_inline : kername -> bool) : result (list bytestring.string) bytestring.string := + (should_inline : kername -> bool) : result (list bytestring.string) bytestring.string := entry <- match snd p with | T.tConst kn _ => ret kn | T.tInd ind _ => ret (inductive_mind ind) diff --git a/extraction/theories/PrettyPrinterMonad.v b/extraction/theories/PrettyPrinterMonad.v index 31180771..ecc77a87 100644 --- a/extraction/theories/PrettyPrinterMonad.v +++ b/extraction/theories/PrettyPrinterMonad.v @@ -27,6 +27,7 @@ Local Coercion bs_to_s : bytestring.string >-> string. Definition PrettyPrinter A := PrettyPrinterState -> result (A * PrettyPrinterState) string. +#[export] Instance Monad_PrettyPrinter : Monad PrettyPrinter := {| ret _ a pps := Ok (a, pps); bind _ _ m f pps := diff --git a/extraction/theories/Printing.v b/extraction/theories/Printing.v index e2616a09..d32423a7 100644 --- a/extraction/theories/Printing.v +++ b/extraction/theories/Printing.v @@ -1,4 +1,5 @@ -From MetaCoq.Template Require Import BasicAst MCString. +From MetaCoq.Template Require Import BasicAst. +From MetaCoq.Template Require Import MCString. Record remapped_inductive := build_remapped_inductive { re_ind_name : string; diff --git a/extraction/theories/RustExtract.v b/extraction/theories/RustExtract.v index c215d962..2d7d7d35 100644 --- a/extraction/theories/RustExtract.v +++ b/extraction/theories/RustExtract.v @@ -372,7 +372,7 @@ Section print_term. let args := (extra ++ map bs_to_s (rev args))%list in print_parenthesized (0 {";; - append_nl ;; + append_nl ;; print_term Γ t | name :: bctx0 => name <- fresh_ident name Γ;; diff --git a/extraction/theories/SpecializeChainBase.v b/extraction/theories/SpecializeChainBase.v index da8e0f10..4788ecca 100644 --- a/extraction/theories/SpecializeChainBase.v +++ b/extraction/theories/SpecializeChainBase.v @@ -13,7 +13,7 @@ Definition b (addr : Foo) (n : N) := a (N.to_nat n). - Note: Only specializes ChainBase when it is the very first abstraction. *) + Note: Only specializes ChainBase when it is the very first abstraction. *) (* From Coq Require Import String. *) From ConCert.Execution Require Import Blockchain. From ConCert.Extraction Require Import Common. @@ -58,8 +58,6 @@ Section ChainBaseSpecialization. | false, _ => specialize_term Γ t end. - Compute (rev (List.fold_right (fun e '(l,y) => ((l ++ [(e, y)] ), 0 :: y ))%list ([],[]) ([1;2;3])).1). - Definition specialize_term (specialized : list kername) : list VarInfo -> term -> result_string term := fix f Γ t := diff --git a/typed-extraction b/typed-extraction index fffec474..56504f6a 160000 --- a/typed-extraction +++ b/typed-extraction @@ -1 +1 @@ -Subproject commit fffec474b372a50e8b6638fbf800fde0548dcfd5 +Subproject commit 56504f6a0f5fbf5e100d210d3adebcae5ffc8c6a diff --git a/utils/theories/Automation.v b/utils/theories/Automation.v index 07c50e51..c9604f3d 100644 --- a/utils/theories/Automation.v +++ b/utils/theories/Automation.v @@ -1,5 +1,4 @@ -(* This file implements various helper tactics *) - +(** * This file implements various helper tactics *) From Coq Require Import List. From Coq Require Import Permutation. From Coq Require Import ZArith. @@ -16,7 +15,7 @@ Proof. auto. Qed. -(* Change all x :: l into [x] ++ l *) +(** Change all x :: l into [x] ++ l *) Ltac appify := match goal with | [|- context[?e :: ?l]] => @@ -46,8 +45,8 @@ Local Ltac perm_simplify_once := let rec aux := apply Permutation_app_middle || tryif reassoc_right - then aux - else (unassoc_right; reassoc_left; aux) in + then aux + else (unassoc_right; reassoc_left; aux) in repeat rewrite <- app_assoc; aux. @@ -69,7 +68,7 @@ Local Ltac perm_simplify_round := | [H: Permutation ?l1 ?l2|-_] => rewrite H end. -(* Automatically tries to solve obvious "Permutation x y" goals. *) +(** Automatically tries to solve obvious "Permutation x y" goals. *) Ltac perm_simplify := repeat perm_simplify_round; cbn; @@ -219,9 +218,9 @@ Ltac unset_all := Ltac destruct_or_hyps := repeat - match goal with - | [H: _ \/ _ |- _] => destruct H - end. + match goal with + | [H: _ \/ _ |- _] => destruct H + end. Ltac destruct_hyps := repeat @@ -243,7 +242,10 @@ Ltac destruct_and_split := end. Tactic Notation "tryfalse" := - try solve [ elimtype False; try solve [assumption | discriminate | congruence ]]. + try solve [ + elimtype False; + try solve [assumption | discriminate | congruence] + ]. Ltac propify := unfold is_true in *; diff --git a/utils/theories/Env.v b/utils/theories/Env.v index 3f83c9d0..3ab9f026 100644 --- a/utils/theories/Env.v +++ b/utils/theories/Env.v @@ -14,62 +14,79 @@ Definition env (A : Type) := list (string * A). Fixpoint lookup {A} (ρ : env A) (key : string) : option A := match ρ with | [] => None - | (nm,a) :: ρ' => - if (eqb nm key) then Some a else lookup ρ' key + | (nm, a) :: ρ' => + if (eqb nm key) + then Some a + else lookup ρ' key end. -Fixpoint lookup_with_ind_rec {A} (i : nat) (ρ : env A) (key : string) : option (nat * A) := +Fixpoint lookup_with_ind_rec {A} + (i : nat) + (ρ : env A) + (key : string) + : option (nat * A) := match ρ with | [] => None - | (nm,a) :: ρ' => - if (eqb nm key) then Some (i,a) - else lookup_with_ind_rec (1+i) ρ' key + | (nm, a) :: ρ' => + if (eqb nm key) + then Some (i, a) + else lookup_with_ind_rec (1 + i) ρ' key end. -Definition lookup_with_ind {A} (ρ : env A) (key : string) - : option (nat * A) := lookup_with_ind_rec 0 ρ key. +Definition lookup_with_ind {A} (ρ : env A) (key : string) : option (nat * A) := + lookup_with_ind_rec 0 ρ key. - (** Lookup by index (similar to [List.nth_error], but defined by recursion on env *) +(** Lookup by index (similar to [List.nth_error], but defined by recursion on env *) Fixpoint lookup_i {A} (ρ : env A) (i : nat) : option A := match ρ with | [] => None - | (nm,a) :: ρ' => - if (Nat.eqb i 0) then Some a else lookup_i ρ' (i-1) + | (nm, a) :: ρ' => + if (Nat.eqb i 0) + then Some a + else lookup_i ρ' (i - 1) end. - (** A value environment lookup: *) +(** A value environment lookup: *) Notation "ρ # '(' k ')'" := (lookup ρ k) (at level 10). (** A value environment extension: *) -Notation "ρ # [ k ~> v ]" := ( (k,v) :: ρ) (at level 50). +Notation "ρ # [ k ~> v ]" := ((k,v) :: ρ) (at level 50). Fixpoint remove_by_key {A} (key : string) (ρ : env A) : env A := match ρ with | [] => [] - | (nm,a) :: ρ' => if (eqb nm key) then remove_by_key key ρ' - else (nm,a) :: (remove_by_key key ρ') + | (nm, a) :: ρ' => + if (eqb nm key) + then remove_by_key key ρ' + else (nm, a) :: (remove_by_key key ρ') end. Lemma lookup_i_length {A} (ρ : env A) n : (n {e | lookup_i ρ n = Some e}. Proof. intros H. revert dependent n. - induction ρ;intros;propify;simpl in *. + induction ρ; intros; propify; simpl in *. elimtype False. lia. destruct a. destruct n. - + simpl;eauto. - + simpl. assert (n < length ρ) by lia. replace (n-0) with n by lia. - apply IHρ. now propify. + + simpl; eauto. + + simpl. + assert (n < length ρ) by lia. + replace (n - 0) with n by lia. + apply IHρ. + now propify. Qed. Lemma lookup_i_length_false {A} (ρ : env A) n : (n lookup_i ρ n = None. Proof. intros H. revert dependent n. - induction ρ;intros;propify;simpl in *;auto. + induction ρ; intros; propify; simpl in *; auto. destruct a. destruct n. - + simpl;eauto. inversion H. - + simpl. assert (length ρ <= n) by lia. replace (n-0) with n by lia. + + simpl; eauto. + inversion H. + + simpl. + assert (length ρ <= n) by lia. + replace (n - 0) with n by lia. rewrite <- PeanoNat.Nat.ltb_ge in *. now apply IHρ. Qed. diff --git a/utils/theories/Extras.v b/utils/theories/Extras.v index a2c3f599..29fa5367 100644 --- a/utils/theories/Extras.v +++ b/utils/theories/Extras.v @@ -1,4 +1,4 @@ -(* This file implements various helper functions and proofs *) +(** This file implements various helper functions and proofs *) From Coq Require Import ZArith. From Coq Require Import List. @@ -8,12 +8,11 @@ From Coq Require Import Psatz. From ConCert.Utils Require Import Automation. Import ListNotations. -Fixpoint map_option {A B : Type} (f : A -> option B) (l : list A) - : list B := +Fixpoint map_option {A B : Type} (f : A -> option B) (l : list A) : list B := match l with | hd :: tl => match f hd with - | Some b => b :: map_option f tl - | None => map_option f tl + | Some b => b :: map_option f tl + | None => map_option f tl end | [] => [] end. @@ -57,8 +56,9 @@ Lemma sumnat_permutation sumnat f xs = sumnat f ys. Proof. induction perm_eq; perm_simplify; lia. Qed. +#[export] Instance sumnat_perm_proper {A : Type} : - Proper (eq ==> Permutation (A:=A) ==> eq) sumnat. + Proper (eq ==> Permutation (A := A) ==> eq) sumnat. Proof. repeat intro. subst. now apply sumnat_permutation. Qed. Lemma sumnat_map {A B : Type} (f : A -> B) (g : B -> nat) (xs : list A) : @@ -76,13 +76,13 @@ Lemma sumZ_permutation sumZ f xs = sumZ f ys. Proof. induction perm_eq; perm_simplify; lia. Qed. +#[export] Instance sumZ_perm_proper {A : Type} : - Proper (eq ==> Permutation (A:=A) ==> eq) sumZ. + Proper (eq ==> Permutation (A := A) ==> eq) sumZ. Proof. repeat intro. subst. now apply sumZ_permutation. Qed. Local Open Scope Z. -Lemma sumZ_app - {A : Type} {f : A -> Z} {xs ys : list A} : +Lemma sumZ_app {A : Type} {f : A -> Z} {xs ys : list A} : sumZ f (xs ++ ys) = sumZ f xs + sumZ f ys. Proof. revert ys. @@ -128,18 +128,18 @@ Proof. auto. Qed. -Lemma NoDup_incl_reorganize - {A : Type} - (l l' : list A) : +Lemma NoDup_incl_reorganize {A : Type} (l l' : list A) : NoDup l' -> incl l' l -> exists suf, Permutation (l' ++ suf) l. Proof. revert l. induction l' as [| x xs IH]; intros l nodup_l' incl_l'_l. - - exists l. apply Permutation_refl. + - exists l. + apply Permutation_refl. - assert (x_in_l: In x l). - + apply (incl_l'_l x). left. constructor. + + apply (incl_l'_l x). + left. constructor. + destruct (in_split _ _ x_in_l) as [pref [suf eq]]; subst. inversion nodup_l'; subst. assert (incl xs (pref ++ suf)). @@ -194,6 +194,7 @@ Proof. apply Permutation_in with ys; symmetry in perm; auto. Qed. +#[export] Instance Forall_Permutation_proper {A} : Proper (eq ==> @Permutation A ==> iff) (@Forall A). Proof. @@ -202,6 +203,7 @@ Proof. split; apply forall_respects_permutation; auto; symmetry; auto. Qed. +#[export] Instance forallb_Permutation_proper {A} : Proper (eq ==> @Permutation A ==> eq) (@forallb A). Proof. @@ -333,7 +335,8 @@ Proof. Qed. Lemma existsb_forallb {A} f (l : list A) : - existsb f l = negb (forallb (fun x => negb (f x)) l). + existsb f l = + negb (forallb (fun x => negb (f x)) l). Proof. induction l as [|x xs IH]; auto. cbn. @@ -391,7 +394,8 @@ Proof. induction l; auto. Qed. Lemma sumZ_seq_feq (f g : nat -> Z) len : (forall i, i < len -> f i = g i)%nat -> - sumZ g (seq 0 len) = sumZ f (seq 0 len). + sumZ g (seq 0 len) = + sumZ f (seq 0 len). Proof. revert f g. induction len as [|len IH]; intros f g all_same; auto. @@ -599,7 +603,7 @@ Proof. intros * f_positive Hin. induction l. - inversion Hin. - - apply in_inv in Hin as [Hin | Hin]. + - apply in_inv in Hin as [Hin | Hin]. + cbn. subst. rewrite <- (Z.add_0_r (f x)). apply Z.add_le_mono. @@ -748,14 +752,18 @@ Qed. Local Open Scope N. -Lemma sumN_permutation {A : Type} {f : A -> N} {xs ys : list A} (perm_eq : Permutation xs ys) : +Lemma sumN_permutation {A : Type} + {f : A -> N} + {xs ys : list A} + (perm_eq : Permutation xs ys) : sumN f xs = sumN f ys. Proof. induction perm_eq; perm_simplify; lia. Qed. +#[export] Instance sumN_perm_proper {A : Type} : - Proper (eq ==> Permutation (A:=A) ==> eq) sumN. + Proper (eq ==> Permutation (A := A) ==> eq) sumN. Proof. repeat intro. subst. now apply sumN_permutation. Qed. @@ -770,16 +778,17 @@ Proof. Qed. Lemma sumN_map_id {A} (f : A -> N) l : - sumN f l = sumN id (map f l). + sumN f l = + sumN id (map f l). Proof. induction l; cbn; auto. unfold id. now rewrite IHl. Qed. -Lemma sumN_app - {A : Type} {f : A -> N} {xs ys : list A} : - sumN f (xs ++ ys) = sumN f xs + sumN f ys. +Lemma sumN_app {A : Type} {f : A -> N} {xs ys : list A} : + sumN f (xs ++ ys) = + sumN f xs + sumN f ys. Proof. revert ys. induction xs as [| x xs IH]; intros ys; auto. @@ -829,8 +838,16 @@ Proof. Qed. -Definition isSome {A : Type} (a : option A) := match a with | Some _ => true | None => false end. -Definition isNone {A : Type} (a : option A) := match a with | Some _ => false | None => true end. +Definition isSome {A : Type} (a : option A) := + match a with + | Some _ => true + | None => false + end. +Definition isNone {A : Type} (a : option A) := + match a with + | Some _ => false + | None => true + end. Lemma with_default_is_some : forall {A : Type} (x : option A) (y : A), isSome x = false -> @@ -839,10 +856,12 @@ Proof. now destruct x. Qed. -Lemma with_default_indep {A} (o : option A) d d' v : - o = Some v -> with_default d o = with_default d' o. +Lemma with_default_indep {A} (o : option A) d d' v : + o = Some v -> + with_default d o = + with_default d' o. Proof. - intros;subst;easy. + intros; subst; easy. Qed. Lemma isSome_some : forall {A : Type} (x : option A) (y : A), diff --git a/utils/theories/RecordSet.v b/utils/theories/RecordSet.v index 98e20466..5c28bc0d 100644 --- a/utils/theories/RecordSet.v +++ b/utils/theories/RecordSet.v @@ -10,7 +10,8 @@ Global Unset Asymmetric Patterns. Import MCMonadNotation. -Class SetterFromGetter {A B} (a : A -> B) := setter_from_getter : (B -> B) -> A -> A. +Class SetterFromGetter {A B} (a : A -> B) := + setter_from_getter : (B -> B) -> A -> A. Definition aRelevant (na : name) : aname := {| binder_name := na; binder_relevance := Relevant |}. @@ -106,7 +107,7 @@ Definition make_setters (T : Type) : TemplateMonad unit := end;; create_setters B (S idx) | tLetIn na a A B => create_setters B idx - | _ => ret tt + | _ => ret tt end in create_setters ctor 0. @@ -114,10 +115,10 @@ Module RecordSetNotations. Declare Scope record_set. Delimit Scope record_set with rs. Open Scope rs. - Notation "x <| proj ::= f |>" := ((_ : SetterFromGetter proj) f x) - (at level 12, f at next level, left associativity) : record_set. - Notation "x <| proj := v |>" := ((_ : SetterFromGetter proj) (fun _ => v) x) - (at level 12, left associativity) : record_set. + Notation "x <| proj ::= f |>" := ((_ : SetterFromGetter proj) f x) + (at level 12, f at next level, left associativity) : record_set. + Notation "x <| proj := v |>" := ((_ : SetterFromGetter proj) (fun _ => v) x) + (at level 12, left associativity) : record_set. Notation "x <| proj1 ; proj2 ; .. ; projn ::= f |>" := ((_ : SetterFromGetter proj1) ((_ : SetterFromGetter proj2) .. ((_ : SetterFromGetter projn) f) ..) x) diff --git a/utils/theories/StringExtra.v b/utils/theories/StringExtra.v index f6348908..db33bf29 100644 --- a/utils/theories/StringExtra.v +++ b/utils/theories/StringExtra.v @@ -133,12 +133,15 @@ Definition remove_char (c : ascii) : string -> string := end. Local Open Scope char. -(* Structurally recursive starts_with with continuation from +(** Structurally recursive starts_with with continuation from rest of string if it does start with *) Definition starts_with_cont - (with_char : ascii) (with_str : string) + (with_char : ascii) + (with_str : string) {A} - (cont : string -> A) (s : string) : option A := + (cont : string -> A) + (s : string) + : option A := (fix f s c ws := match s with | EmptyString => None @@ -166,12 +169,12 @@ Definition replace (orig : string) (new : string) : string -> string := | EmptyString => fun s => s | String origc origs => fix replace s := - match starts_with_cont origc origs replace s with - | Some s => new ++ s - | None => match s with - | EmptyString => EmptyString - | String c s => String c (replace s) - end + match starts_with_cont origc origs replace s with + | Some s => new ++ s + | None => match s with + | EmptyString => EmptyString + | String c s => String c (replace s) + end end end.