From 38381e8cd19ad650adf2beae740c0f9d25bd400f Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Sat, 11 Feb 2023 15:00:42 -0800 Subject: [PATCH 01/10] Gallina quotation functions
Timing

``` Time | Peak Mem | File Name ------------------------------------------------------------------------------------------------------ 28m36.07s | 1742960 ko | Total Time / Peak Mem ------------------------------------------------------------------------------------------------------ 3m30.41s | 1335360 ko | ToTemplate/QuotationOf/Common/Kernames/KernameMap/Instances.vo 3m21.62s | 1701848 ko | ToTemplate/QuotationOf/Coq/FSets/FMapAVL/Sig.vo 1m50.32s | 1606248 ko | ToTemplate/QuotationOf/Coq/MSets/MSetAVL/Sig.vo 1m25.21s | 1283592 ko | ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.vo 1m21.88s | 1284000 ko | ToTemplate/QuotationOf/Common/Kernames/KernameSet/Instances.vo 1m19.88s | 1742960 ko | ToTemplate/Coq/MSets.vo 1m15.76s | 1282544 ko | ToTemplate/QuotationOf/Common/Universes/LevelSet/Instances.vo 1m12.04s | 1368088 ko | ToTemplate/QuotationOf/Coq/MSets/MSetList/Sig.vo 0m58.84s | 1057848 ko | ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.vo 0m56.64s | 1034060 ko | ToTemplate/QuotationOf/Common/Universes/LevelExprSetOrdProp/Instances.vo 0m56.61s | 1004488 ko | ToTemplate/QuotationOf/Common/Kernames/KernameSetOrdProp/Instances.vo 0m53.50s | 1016636 ko | ToTemplate/QuotationOf/Common/Universes/LevelSetOrdProp/Instances.vo 0m51.59s | 1138188 ko | ToTemplate/QuotationOf/Common/Universes/LevelExprSet/Instances.vo 0m49.75s | 1379420 ko | ToTemplate/Coq/FSets.vo 0m49.74s | 1107368 ko | ToTemplate/QuotationOf/Coq/MSets/MSetProperties/Sig.vo 0m42.10s | 1256528 ko | ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.vo 0m37.84s | 1016312 ko | ToTemplate/QuotationOf/Coq/FSets/FMapList/Sig.vo 0m34.52s | 1013440 ko | ToTemplate/QuotationOf/Common/Environment/Sig.vo 0m22.88s | 852064 ko | ToTemplate/QuotationOf/Template/Ast/Env/Instances.vo 0m21.17s | 877048 ko | ToTemplate/QuotationOf/Coq/Structures/OrdersFacts/Sig.vo 0m19.04s | 1263092 ko | ToTemplate/Common/EnvironmentTyping.vo 0m18.07s | 841212 ko | ToTemplate/QuotationOf/Coq/MSets/MSetDecide/Sig.vo 0m17.21s | 834976 ko | ToTemplate/QuotationOf/Coq/Structures/OrdersAlt/Sig.vo 0m15.02s | 1075516 ko | ToTemplate/Template/Typing.vo 0m14.61s | 905324 ko | ToTemplate/Common/Universes.vo 0m13.40s | 816856 ko | ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.vo 0m13.34s | 780536 ko | ToTemplate/QuotationOf/Coq/MSets/MSetFacts/Sig.vo 0m12.93s | 774728 ko | ToTemplate/QuotationOf/Coq/FSets/FMapFacts/Sig.vo 0m11.78s | 862636 ko | ToTemplate/Common/Kernames.vo 0m10.00s | 828792 ko | ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.vo 0m08.93s | 725948 ko | ToTemplate/QuotationOf/Common/Kernames/KernameMapFact/Instances.vo 0m07.23s | 728332 ko | ToTemplate/QuotationOf/Coq/MSets/MSetInterface/Sig.vo 0m06.99s | 705852 ko | ToTemplate/QuotationOf/Coq/Structures/Equalities/Sig.vo 0m05.96s | 725548 ko | ToTemplate/QuotationOf/Coq/FSets/FMapInterface/Sig.vo 0m05.11s | 992248 ko | ToTemplate/Template/TermEquality.vo 0m04.96s | 761740 ko | ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.vo 0m04.71s | 932436 ko | ToTemplate/Common/Environment.vo 0m04.53s | 989628 ko | ToTemplate/Template/WfAst.vo 0m03.78s | 769156 ko | ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.vo 0m03.18s | 713016 ko | ToTemplate/QuotationOf/Coq/Structures/OrdersTac/Sig.vo 0m02.95s | 701344 ko | ToTemplate/QuotationOf/Common/Universes/Level/Instances.vo 0m02.90s | 756624 ko | ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.vo 0m02.86s | 703056 ko | ToTemplate/QuotationOf/Coq/Structures/Orders/Sig.vo 0m02.64s | 698816 ko | ToTemplate/QuotationOf/Common/Kernames/Kername/Instances.vo 0m02.53s | 922916 ko | ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.vo 0m02.49s | 699500 ko | ToTemplate/QuotationOf/Common/Universes/LevelExpr/Instances.vo 0m02.12s | 984776 ko | ToTemplate/Template/Ast.vo 0m02.01s | 700412 ko | ToTemplate/Coq/Init.vo 0m01.99s | 701512 ko | ToTemplate/QuotationOf/Common/Universes/UnivConstraint/Instances.vo 0m01.98s | 704288 ko | ToTemplate/Utils/utils.vo 0m01.87s | 709068 ko | ToTemplate/QuotationOf/Template/Ast/TemplateTerm/Instances.vo 0m01.82s | 696724 ko | ToTemplate/Utils/MCUtils.vo 0m01.63s | 713200 ko | ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.vo 0m01.62s | 695876 ko | ToTemplate/Init.vo 0m01.53s | 696780 ko | ToTemplate/Coq/Lists.vo 0m01.49s | 699684 ko | ToTemplate/Utils/All_Forall.vo 0m01.43s | 695080 ko | ToTemplate/Utils/MCProd.vo 0m01.34s | 696508 ko | ToTemplate/Utils/ReflectEq.vo 0m01.27s | 697288 ko | ToTemplate/Utils/MCOption.vo 0m01.26s | 980920 ko | ToTemplate/Template/AstUtils.vo 0m01.23s | 693944 ko | ToTemplate/Coq/Bool.vo 0m01.22s | 755464 ko | ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.vo 0m01.20s | 757612 ko | ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.vo 0m01.19s | 710540 ko | ToTemplate/QuotationOf/Template/ReflectAst/TemplateTermDecide/Instances.vo 0m01.18s | 694060 ko | ToTemplate/Utils/MCList.vo 0m01.15s | 697976 ko | CommonUtils.vo 0m01.12s | 955240 ko | ToTemplate/QuotationOf/Template/Ast/Instances.vo 0m01.12s | 706104 ko | ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.vo 0m01.08s | 867856 ko | ToTemplate/Common/BasicAst.vo 0m01.07s | 695148 ko | ToTemplate/Utils/bytestring.vo 0m01.06s | 693992 ko | ToTemplate/Utils/MCArith.vo 0m01.03s | 703564 ko | ToTemplate/Coq/Floats.vo 0m00.98s | 700584 ko | ToTemplate/Coq/Numbers.vo 0m00.98s | 694564 ko | ToTemplate/Utils/MCReflect.vo 0m00.88s | 756228 ko | ToTemplate/QuotationOf/Template/Typing/Instances.vo 0m00.87s | 695256 ko | ToTemplate/Coq/Strings.vo 0m00.86s | 766292 ko | ToTemplate/QuotationOf/Common/Kernames/Instances.vo 0m00.84s | 696340 ko | ToTemplate/Coq/ssr.vo 0m00.83s | 694736 ko | ToTemplate/Common/Primitive.vo 0m00.83s | 698224 ko | ToTemplate/Common/config.vo 0m00.81s | 745564 ko | ToTemplate/QuotationOf/Common/Universes/Instances.vo 0m00.80s | 700668 ko | ToTemplate/QuotationOf/Template/ReflectAst/Instances.vo 0m00.20s | 63332 ko | ToTemplate/Utils/monad_utils.vo 0m00.08s | 64744 ko | ToTemplate/Utils/MCRelations.vo 0m00.06s | 64376 ko | ToTemplate/Utils/MCString.vo 0m00.05s | 64560 ko | ToTemplate/Common/Reflect.vo 0m00.05s | 63284 ko | ToTemplate/Template/ReflectAst.vo 0m00.05s | 65008 ko | ToTemplate/Utils/MCPrelude.vo 0m00.05s | 65068 ko | ToTemplate/Utils/MCSquash.vo 0m00.04s | 64248 ko | ToTemplate/Template/Induction.vo 0m00.04s | 64996 ko | ToTemplate/Template/LiftSubst.vo 0m00.04s | 64736 ko | ToTemplate/Template/UnivSubst.vo 0m00.04s | 64308 ko | ToTemplate/Utils/MCCompare.vo 0m00.04s | 63324 ko | ToTemplate/Utils/MCEquality.vo 0m00.04s | 65020 ko | ToTemplate/Utils/wGraph.vo 0m00.03s | 64724 ko | ToTemplate/Utils/ByteCompare.vo 0m00.03s | 63432 ko | ToTemplate/Utils/ByteCompareSpec.vo 0m00.03s | 64856 ko | ToTemplate/Utils/LibHypsNaming.vo 0m00.03s | 64768 ko | ToTemplate/Utils/MCPred.vo 0m00.02s | 65064 ko | ToTemplate/Common/Transform.vo 0m00.01s | 64484 ko | ToTemplate/Utils/ByteCompare_opt.vo ```

--- .../workflows/nix-action-coq-8.16-macos.yml | 4 + .../workflows/nix-action-coq-8.16-ubuntu.yml | 4 + .gitignore | 5 + .nix/cachedMake.sh | 1 + .nix/coq-overlays/metacoq/default.nix | 4 +- Makefile | 19 +- configure.sh | 6 +- coq-metacoq-common.opam | 1 + coq-metacoq-erasure-plugin.opam | 1 + coq-metacoq-erasure.opam | 1 + coq-metacoq-pcuic.opam | 1 + coq-metacoq-quotation.opam | 37 ++ coq-metacoq-safechecker-plugin.opam | 1 + coq-metacoq-safechecker.opam | 1 + coq-metacoq-template-pcuic.opam | 1 + coq-metacoq-template.opam | 1 + coq-metacoq-translations.opam | 5 +- coq-metacoq-utils.opam | 1 + coq-metacoq.opam | 8 +- quotation/Makefile | 33 + quotation/_CoqProject.in | 103 +++ quotation/theories/CommonUtils.v | 382 +++++++++++ .../theories/ToTemplate/Common/BasicAst.v | 26 + .../theories/ToTemplate/Common/Environment.v | 116 ++++ .../ToTemplate/Common/EnvironmentTyping.v | 216 +++++++ .../theories/ToTemplate/Common/Kernames.v | 20 + .../theories/ToTemplate/Common/Primitive.v | 4 + .../theories/ToTemplate/Common/Reflect.v | 1 + .../theories/ToTemplate/Common/Transform.v | 1 + .../theories/ToTemplate/Common/Universes.v | 165 +++++ quotation/theories/ToTemplate/Common/config.v | 4 + quotation/theories/ToTemplate/Coq/Bool.v | 5 + quotation/theories/ToTemplate/Coq/FSets.v | 209 ++++++ quotation/theories/ToTemplate/Coq/Floats.v | 11 + quotation/theories/ToTemplate/Coq/Init.v | 114 ++++ quotation/theories/ToTemplate/Coq/Lists.v | 63 ++ quotation/theories/ToTemplate/Coq/MSets.v | 289 +++++++++ quotation/theories/ToTemplate/Coq/Numbers.v | 37 ++ quotation/theories/ToTemplate/Coq/Strings.v | 5 + quotation/theories/ToTemplate/Coq/ssr.v | 23 + quotation/theories/ToTemplate/Init.v | 607 ++++++++++++++++++ .../QuotationOf/Common/Environment/Sig.v | 58 ++ .../Common/EnvironmentTyping/Sig.v | 180 ++++++ .../QuotationOf/Common/Kernames/Instances.v | 8 + .../Common/Kernames/Kername/Instances.v | 12 + .../Common/Kernames/KernameMap/Instances.v | 37 ++ .../Kernames/KernameMapFact/Instances.v | 9 + .../Common/Kernames/KernameSet/Instances.v | 7 + .../Kernames/KernameSetOrdProp/Instances.v | 25 + .../Universes/ConstraintSet/Instances.v | 7 + .../ConstraintSetOrdProp/Instances.v | 25 + .../QuotationOf/Common/Universes/Instances.v | 12 + .../Common/Universes/Level/Instances.v | 9 + .../Common/Universes/LevelExpr/Instances.v | 9 + .../Common/Universes/LevelExprSet/Instances.v | 7 + .../Universes/LevelExprSetOrdProp/Instances.v | 25 + .../Common/Universes/LevelSet/Instances.v | 7 + .../Universes/LevelSetOrdProp/Instances.v | 25 + .../Universes/UnivConstraint/Instances.v | 9 + .../QuotationOf/Coq/FSets/FMapAVL/Sig.v | 27 + .../QuotationOf/Coq/FSets/FMapFacts/Sig.v | 11 + .../QuotationOf/Coq/FSets/FMapInterface/Sig.v | 7 + .../QuotationOf/Coq/FSets/FMapList/Sig.v | 17 + .../QuotationOf/Coq/MSets/MSetAVL/Sig.v | 11 + .../QuotationOf/Coq/MSets/MSetDecide/Sig.v | 14 + .../QuotationOf/Coq/MSets/MSetFacts/Sig.v | 14 + .../QuotationOf/Coq/MSets/MSetInterface/Sig.v | 28 + .../QuotationOf/Coq/MSets/MSetList/Sig.v | 29 + .../Coq/MSets/MSetProperties/Sig.v | 32 + .../Coq/Structures/Equalities/Sig.v | 159 +++++ .../QuotationOf/Coq/Structures/Orders/Sig.v | 155 +++++ .../Coq/Structures/OrdersAlt/Sig.v | 110 ++++ .../Coq/Structures/OrdersFacts/Sig.v | 52 ++ .../Coq/Structures/OrdersTac/Sig.v | 35 + .../QuotationOf/Template/Ast/Env/Instances.v | 7 + .../Template/Ast/EnvHelper/Instances.v | 9 + .../QuotationOf/Template/Ast/Instances.v | 10 + .../Template/Ast/TemplateLookup/Instances.v | 7 + .../Template/Ast/TemplateTerm/Instances.v | 7 + .../Ast/TemplateTermUtils/Instances.v | 7 + .../Template/ReflectAst/EnvDecide/Instances.v | 7 + .../Template/ReflectAst/Instances.v | 5 + .../ReflectAst/TemplateTermDecide/Instances.v | 7 + .../QuotationOf/Template/Typing/Instances.v | 9 + .../Typing/TemplateConversion/Instances.v | 7 + .../Typing/TemplateConversionPar/Instances.v | 7 + .../TemplateDeclarationTyping/Instances.v | 7 + .../Typing/TemplateEnvTyping/Instances.v | 7 + .../Typing/TemplateGlobalMaps/Instances.v | 7 + .../Typing/TemplateTyping/Instances.v | 7 + quotation/theories/ToTemplate/Template/Ast.v | 29 + .../theories/ToTemplate/Template/AstUtils.v | 10 + .../theories/ToTemplate/Template/Induction.v | 1 + .../theories/ToTemplate/Template/LiftSubst.v | 1 + .../theories/ToTemplate/Template/ReflectAst.v | 1 + .../ToTemplate/Template/TermEquality.v | 48 ++ .../theories/ToTemplate/Template/Typing.v | 119 ++++ .../theories/ToTemplate/Template/UnivSubst.v | 1 + .../theories/ToTemplate/Template/WfAst.v | 18 + .../theories/ToTemplate/Utils/All_Forall.v | 14 + .../theories/ToTemplate/Utils/ByteCompare.v | 1 + .../ToTemplate/Utils/ByteCompareSpec.v | 1 + .../ToTemplate/Utils/ByteCompare_opt.v | 1 + .../theories/ToTemplate/Utils/LibHypsNaming.v | 1 + quotation/theories/ToTemplate/Utils/MCArith.v | 4 + .../theories/ToTemplate/Utils/MCCompare.v | 1 + .../theories/ToTemplate/Utils/MCEquality.v | 1 + quotation/theories/ToTemplate/Utils/MCList.v | 4 + .../theories/ToTemplate/Utils/MCOption.v | 39 ++ quotation/theories/ToTemplate/Utils/MCPred.v | 1 + .../theories/ToTemplate/Utils/MCPrelude.v | 1 + quotation/theories/ToTemplate/Utils/MCProd.v | 19 + .../theories/ToTemplate/Utils/MCReflect.v | 4 + .../theories/ToTemplate/Utils/MCRelations.v | 1 + .../theories/ToTemplate/Utils/MCSquash.v | 1 + .../theories/ToTemplate/Utils/MCString.v | 1 + quotation/theories/ToTemplate/Utils/MCUtils.v | 16 + .../theories/ToTemplate/Utils/ReflectEq.v | 7 + .../theories/ToTemplate/Utils/bytestring.v | 24 + .../theories/ToTemplate/Utils/monad_utils.v | 1 + quotation/theories/ToTemplate/Utils/utils.v | 3 + quotation/theories/ToTemplate/Utils/wGraph.v | 408 ++++++++++++ template-pcuic/metacoq-config | 2 +- utils/theories/monad_utils.v | 4 +- 124 files changed, 4598 insertions(+), 15 deletions(-) create mode 100644 coq-metacoq-quotation.opam create mode 100644 quotation/Makefile create mode 100644 quotation/_CoqProject.in create mode 100644 quotation/theories/CommonUtils.v create mode 100644 quotation/theories/ToTemplate/Common/BasicAst.v create mode 100644 quotation/theories/ToTemplate/Common/Environment.v create mode 100644 quotation/theories/ToTemplate/Common/EnvironmentTyping.v create mode 100644 quotation/theories/ToTemplate/Common/Kernames.v create mode 100644 quotation/theories/ToTemplate/Common/Primitive.v create mode 100644 quotation/theories/ToTemplate/Common/Reflect.v create mode 100644 quotation/theories/ToTemplate/Common/Transform.v create mode 100644 quotation/theories/ToTemplate/Common/Universes.v create mode 100644 quotation/theories/ToTemplate/Common/config.v create mode 100644 quotation/theories/ToTemplate/Coq/Bool.v create mode 100644 quotation/theories/ToTemplate/Coq/FSets.v create mode 100644 quotation/theories/ToTemplate/Coq/Floats.v create mode 100644 quotation/theories/ToTemplate/Coq/Init.v create mode 100644 quotation/theories/ToTemplate/Coq/Lists.v create mode 100644 quotation/theories/ToTemplate/Coq/MSets.v create mode 100644 quotation/theories/ToTemplate/Coq/Numbers.v create mode 100644 quotation/theories/ToTemplate/Coq/Strings.v create mode 100644 quotation/theories/ToTemplate/Coq/ssr.v create mode 100644 quotation/theories/ToTemplate/Init.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Environment/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Kernames/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Kernames/Kername/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameMap/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameMapFact/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameSet/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameSetOrdProp/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/Level/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExpr/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSet/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSetOrdProp/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelSet/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelSetOrdProp/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Common/Universes/UnivConstraint/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapAVL/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapFacts/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapInterface/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapList/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetAVL/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetDecide/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetFacts/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetInterface/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetList/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetProperties/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/Structures/Equalities/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/Structures/Orders/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersAlt/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersFacts/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersTac/Sig.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Ast/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTerm/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/TemplateTermDecide/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Typing/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.v create mode 100644 quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.v create mode 100644 quotation/theories/ToTemplate/Template/Ast.v create mode 100644 quotation/theories/ToTemplate/Template/AstUtils.v create mode 100644 quotation/theories/ToTemplate/Template/Induction.v create mode 100644 quotation/theories/ToTemplate/Template/LiftSubst.v create mode 100644 quotation/theories/ToTemplate/Template/ReflectAst.v create mode 100644 quotation/theories/ToTemplate/Template/TermEquality.v create mode 100644 quotation/theories/ToTemplate/Template/Typing.v create mode 100644 quotation/theories/ToTemplate/Template/UnivSubst.v create mode 100644 quotation/theories/ToTemplate/Template/WfAst.v create mode 100644 quotation/theories/ToTemplate/Utils/All_Forall.v create mode 100644 quotation/theories/ToTemplate/Utils/ByteCompare.v create mode 100644 quotation/theories/ToTemplate/Utils/ByteCompareSpec.v create mode 100644 quotation/theories/ToTemplate/Utils/ByteCompare_opt.v create mode 100644 quotation/theories/ToTemplate/Utils/LibHypsNaming.v create mode 100644 quotation/theories/ToTemplate/Utils/MCArith.v create mode 100644 quotation/theories/ToTemplate/Utils/MCCompare.v create mode 100644 quotation/theories/ToTemplate/Utils/MCEquality.v create mode 100644 quotation/theories/ToTemplate/Utils/MCList.v create mode 100644 quotation/theories/ToTemplate/Utils/MCOption.v create mode 100644 quotation/theories/ToTemplate/Utils/MCPred.v create mode 100644 quotation/theories/ToTemplate/Utils/MCPrelude.v create mode 100644 quotation/theories/ToTemplate/Utils/MCProd.v create mode 100644 quotation/theories/ToTemplate/Utils/MCReflect.v create mode 100644 quotation/theories/ToTemplate/Utils/MCRelations.v create mode 100644 quotation/theories/ToTemplate/Utils/MCSquash.v create mode 100644 quotation/theories/ToTemplate/Utils/MCString.v create mode 100644 quotation/theories/ToTemplate/Utils/MCUtils.v create mode 100644 quotation/theories/ToTemplate/Utils/ReflectEq.v create mode 100644 quotation/theories/ToTemplate/Utils/bytestring.v create mode 100644 quotation/theories/ToTemplate/Utils/monad_utils.v create mode 100644 quotation/theories/ToTemplate/Utils/utils.v create mode 100644 quotation/theories/ToTemplate/Utils/wGraph.v diff --git a/.github/workflows/nix-action-coq-8.16-macos.yml b/.github/workflows/nix-action-coq-8.16-macos.yml index 550041697..7246ffa41 100644 --- a/.github/workflows/nix-action-coq-8.16-macos.yml +++ b/.github/workflows/nix-action-coq-8.16-macos.yml @@ -146,6 +146,10 @@ jobs: name: 'Building/fetching previous CI target: metacoq-erasure' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.16" --argstr job "metacoq-erasure" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-quotation' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.16" + --argstr job "metacoq-quotation" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: metacoq-safechecker-plugin' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.16" diff --git a/.github/workflows/nix-action-coq-8.16-ubuntu.yml b/.github/workflows/nix-action-coq-8.16-ubuntu.yml index e30a18ad1..0342ad788 100644 --- a/.github/workflows/nix-action-coq-8.16-ubuntu.yml +++ b/.github/workflows/nix-action-coq-8.16-ubuntu.yml @@ -146,6 +146,10 @@ jobs: name: 'Building/fetching previous CI target: metacoq-erasure' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.16" --argstr job "metacoq-erasure" + - if: steps.stepCheck.outputs.status == 'built' + name: 'Building/fetching previous CI target: metacoq-quotation' + run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.16" + --argstr job "metacoq-quotation" - if: steps.stepCheck.outputs.status == 'built' name: 'Building/fetching previous CI target: metacoq-safechecker-plugin' run: NIXPKGS_ALLOW_UNFREE=1 nix-build --no-out-link --argstr bundle "coq-8.16" diff --git a/.gitignore b/.gitignore index 0ef7b5799..a2e32d8a5 100644 --- a/.gitignore +++ b/.gitignore @@ -378,6 +378,11 @@ template-pcuic/_CoqProject template-pcuic/Makefile.templatepcuic template-pcuic/Makefile.templatepcuic.conf +quotation/Makefile.local +quotation/_CoqProject +quotation/Makefile.quotation +quotation/Makefile.quotation.conf + safechecker-plugin/metacoq-config safechecker-plugin/demo.v safechecker-plugin/Makefile.local diff --git a/.nix/cachedMake.sh b/.nix/cachedMake.sh index d9e419ff5..d0a57632c 100755 --- a/.nix/cachedMake.sh +++ b/.nix/cachedMake.sh @@ -50,6 +50,7 @@ my-cachedMake 'pcuic' 'pcuic/theories' 'MetaCoq.PCUIC' my-cachedMake 'safechecker' 'safechecker/theories' 'MetaCoq.SafeChecker' my-cachedMake 'template-pcuic' 'template-pcuic/theories' 'MetaCoq.TemplatePCUIC' my-cachedMake 'erasure' 'erasure/theories' 'MetaCoq.Erasure' +my-cachedMake 'quotation' 'quotation/theories' 'MetaCoq.Quotation' unset -f my-nix-build-with-target unset -f my-cachedMake diff --git a/.nix/coq-overlays/metacoq/default.nix b/.nix/coq-overlays/metacoq/default.nix index 95bf9b9c3..dd835ef1a 100644 --- a/.nix/coq-overlays/metacoq/default.nix +++ b/.nix/coq-overlays/metacoq/default.nix @@ -25,7 +25,7 @@ let releaseRev = v: "v${v}"; # list of core metacoq packages sorted by dependency order - packages = [ "utils" "common" "template-coq" "pcuic" "safechecker" "template-pcuic" "erasure" "safechecker-plugin" "erasure-plugin" "all" ]; + packages = [ "utils" "common" "template-coq" "pcuic" "safechecker" "template-pcuic" "erasure" "quotation" "safechecker-plugin" "erasure-plugin" "all" ]; template-coq = metacoq_ "template-coq"; @@ -57,7 +57,7 @@ let configurePhase = optionalString (package == "all") pkgallMake + '' touch ${pkgpath}/metacoq-config - '' + optionalString (elem package ["safechecker" "erasure" "template-pcuic" "safechecker-plugin" "erasure-plugin"]) '' + '' + optionalString (elem package ["safechecker" "erasure" "template-pcuic" "quotation" "safechecker-plugin" "erasure-plugin"]) '' echo "-I ${template-coq}/lib/coq/${coq.coq-version}/user-contrib/MetaCoq/Template/" > ${pkgpath}/metacoq-config '' + optionalString (package == "single") '' ./configure.sh local diff --git a/Makefile b/Makefile index 48b2bba14..2c1e7d1d6 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -all: printconf template-coq pcuic safechecker erasure examples test-suite translations +all: printconf template-coq pcuic safechecker erasure examples test-suite translations quotation -include Makefile.conf @@ -33,6 +33,7 @@ install: all translations $(MAKE) -C pcuic install $(MAKE) -C safechecker install $(MAKE) -C template-pcuic install + $(MAKE) -C quotation install $(MAKE) -C safechecker-plugin install $(MAKE) -C erasure install $(MAKE) -C translations install @@ -44,6 +45,7 @@ uninstall: $(MAKE) -C pcuic uninstall $(MAKE) -C safechecker uninstall $(MAKE) -C template-pcuic uninstall + $(MAKE) -C quotation uninstall $(MAKE) -C safechecker-plugin uninstall $(MAKE) -C erasure uninstall $(MAKE) -C translations uninstall @@ -57,6 +59,7 @@ html: all -R pcuic/theories MetaCoq.PCUIC \ -R safechecker/theories MetaCoq.SafeChecker \ -R template-pcuic/theories MetaCoq.TemplatePCUIC \ + -R quotation/theories MetaCoq.Quotation \ -R erasure/theories MetaCoq.Erasure \ -R erasure-plugin/theories MetaCoq.ErasurePlugin \ -R translations MetaCoq.Translations \ @@ -70,6 +73,7 @@ clean: $(MAKE) -C pcuic clean $(MAKE) -C safechecker clean $(MAKE) -C template-pcuic clean + $(MAKE) -C quotation clean $(MAKE) -C erasure clean $(MAKE) -C erasure-plugin clean $(MAKE) -C examples clean @@ -83,6 +87,7 @@ vos: $(MAKE) -C pcuic vos $(MAKE) -C safechecker vos $(MAKE) -C template-pcuic vos + $(MAKE) -C quotation vos $(MAKE) -C erasure vos $(MAKE) -C erasure-plugin vos $(MAKE) -C translations vos @@ -91,9 +96,10 @@ quick: $(MAKE) -C utils $(MAKE) -C common $(MAKE) -C template-coq - $(MAKE) -C pcuic quick + $(MAKE) -C pcuic quick $(MAKE) -C safechecker quick - $(MAKE) -C template-pcuic quick + $(MAKE) -C template-pcuic quick + $(MAKE) -C quotation quick $(MAKE) -C erasure quick $(MAKE) -C erasure-plugin quick $(MAKE) -C translations quick @@ -105,6 +111,7 @@ mrproper: $(MAKE) -C pcuic mrproper $(MAKE) -C safechecker mrproper $(MAKE) -C template-pcuic mrproper + $(MAKE) -C quotation mrproper $(MAKE) -C erasure mrproper $(MAKE) -C erasure-plugin mrproper $(MAKE) -C examples mrproper @@ -118,6 +125,7 @@ mrproper: $(MAKE) -C pcuic .merlin $(MAKE) -C safechecker .merlin $(MAKE) -C template-pcuic .merlin + $(MAKE) -C quotation .merlin $(MAKE) -C erasure .merlin $(MAKE) -C erasure-plugin .merin @@ -139,6 +147,9 @@ safechecker: pcuic template-pcuic: template-coq pcuic $(MAKE) -C template-pcuic +quotation: template-coq pcuic template-pcuic + $(MAKE) -C quotation + safechecker-plugin: safechecker template-pcuic $(MAKE) -C safechecker-plugin @@ -166,7 +177,7 @@ ci-local-noclean: ./configure.sh local $(MAKE) all test-suite TIMED=pretty-timed -ci-local: ci-local-noclean +ci-local: ci-local-noclean $(MAKE) clean ci-quick: diff --git a/configure.sh b/configure.sh index 83155b94d..fe8ab9c2a 100755 --- a/configure.sh +++ b/configure.sh @@ -21,7 +21,8 @@ then TEMPLATE_COQ_DEPS="-R ../common/theories MetaCoq.Common" PCUIC_DEPS="-R ../common/theories MetaCoq.Common" SAFECHECKER_DEPS="-R ../pcuic/theories MetaCoq.PCUIC" - TEMPLATE_PCUIC_DEPS="-R ../pcuic/theories MetaCoq.PCUIC -R ../template-coq/theories MetaCoq.Template" + TEMPLATE_PCUIC_DEPS="-R ../pcuic/theories MetaCoq.PCUIC -R ../template-coq/theories MetaCoq.Template -I ../template-coq" + QUOTATION_DEPS="-R ../template-pcuic/theories MetaCoq.TemplatePCUIC -R ../pcuic/theories MetaCoq.PCUIC -R ../template-coq/theories MetaCoq.Template" SAFECHECKER_PLUGIN_DEPS="-R ../template-pcuic/theories MetaCoq.TemplatePCUIC -R ../safechecker/theories MetaCoq.SafeChecker -I ../template-coq" ERASURE_DEPS="-R ../safechecker-plugin/theories MetaCoq.SafeCheckerPlugin -R ../template-pcuic/theories MetaCoq.TemplatePCUIC -R ../template-coq/theories MetaCoq.Template -I ../template-coq -R ../safechecker/theories MetaCoq.SafeChecker" ERASURE_PLUGIN_DEPS="-R ../template-coq/theories MetaCoq.Template -I ../template-coq -R ../template-pcuic/theories MetaCoq.TemplatePCUIC -R ../erasure/theories MetaCoq.Erasure" @@ -37,6 +38,7 @@ then PCUIC_DEPS="" SAFECHECKER_DEPS="" TEMPLATE_PCUIC_DEPS="" + QUOTATION_DEPS="" SAFECHECKER_PLUGIN_DEPS="" ERASURE_DEPS="" ERASURE_PLUGIN_DEPS="" @@ -53,6 +55,7 @@ then echo "# DO NOT EDIT THIS FILE: autogenerated from ./configure.sh" > safechecker/metacoq-config echo "# DO NOT EDIT THIS FILE: autogenerated from ./configure.sh" > erasure/metacoq-config echo "# DO NOT EDIT THIS FILE: autogenerated from ./configure.sh" > template-pcuic/metacoq-config + echo "# DO NOT EDIT THIS FILE: autogenerated from ./configure.sh" > quotation/metacoq-config echo "# DO NOT EDIT THIS FILE: autogenerated from ./configure.sh" > safechecker-plugin/metacoq-config echo "# DO NOT EDIT THIS FILE: autogenerated from ./configure.sh" > erasure-plugin/metacoq-config echo "# DO NOT EDIT THIS FILE: autogenerated from ./configure.sh" > translations/metacoq-config @@ -65,6 +68,7 @@ then echo ${COMMON_DEPS} ${PCUIC_DEPS} >> pcuic/metacoq-config echo ${COMMON_DEPS} ${PCUIC_DEPS} ${SAFECHECKER_DEPS} >> safechecker/metacoq-config echo ${COMMON_DEPS} ${PCUIC_DEPS} ${TEMPLATE_PCUIC_DEPS} >> template-pcuic/metacoq-config + echo ${COMMON_DEPS} ${PCUIC_DEPS} ${TEMPLATE_PCUIC_DEPS} ${QUOTATION_DEPS} >> quotation/metacoq-config echo ${COMMON_DEPS} ${PCUIC_DEPS} ${TEMPLATE_PCUIC_DEPS} ${SAFECHECKER_PLUGIN_DEPS} >> safechecker-plugin/metacoq-config echo ${COMMON_DEPS} ${PCUIC_DEPS} ${SAFECHECKER_DEPS} ${ERASURE_DEPS} >> erasure/metacoq-config echo ${COMMON_DEPS} ${PCUIC_DEPS} ${ERASURE_DEPS} ${TEMPLATE_PCUIC_DEPS} ${ERASURE_PLUGIN_DEPS} >> erasure-plugin/metacoq-config diff --git a/coq-metacoq-common.opam b/coq-metacoq-common.opam index 38b588b9b..8fc75c933 100644 --- a/coq-metacoq-common.opam +++ b/coq-metacoq-common.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " diff --git a/coq-metacoq-erasure-plugin.opam b/coq-metacoq-erasure-plugin.opam index 8f19bbffb..424e22a28 100644 --- a/coq-metacoq-erasure-plugin.opam +++ b/coq-metacoq-erasure-plugin.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " diff --git a/coq-metacoq-erasure.opam b/coq-metacoq-erasure.opam index 604adec94..145e6b993 100644 --- a/coq-metacoq-erasure.opam +++ b/coq-metacoq-erasure.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " diff --git a/coq-metacoq-pcuic.opam b/coq-metacoq-pcuic.opam index afbff8994..b3f618e91 100644 --- a/coq-metacoq-pcuic.opam +++ b/coq-metacoq-pcuic.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " diff --git a/coq-metacoq-quotation.opam b/coq-metacoq-quotation.opam new file mode 100644 index 000000000..766c7c6f2 --- /dev/null +++ b/coq-metacoq-quotation.opam @@ -0,0 +1,37 @@ +opam-version: "2.0" +version: "8.16.dev" +maintainer: "matthieu.sozeau@inria.fr" +homepage: "https://metacoq.github.io/metacoq" +dev-repo: "git+https://github.com/MetaCoq/metacoq.git#coq-8.16" +bug-reports: "https://github.com/MetaCoq/metacoq/issues" +authors: ["Abhishek Anand " + "Danil Annenkov " + "Simon Boulier " + "Cyril Cohen " + "Yannick Forster " + "Jason Gross " + "Fabian Kunze " + "Meven Lennon-Bertrand " + "Kenji Maillard " + "Gregory Malecha " + "Jakob Botsch Nielsen " + "Matthieu Sozeau " + "Nicolas Tabareau " + "Théo Winterhalter " +] +license: "MIT" +build: [ + ["bash" "./configure.sh"] + [make "-j" "%{jobs}%" "-C" "quotation"] +] +install: [ + [make "-C" "quotation" "install"] +] +depends: [ + "coq-metacoq-template" {= version} + "coq-metacoq-pcuic" {= version} + "coq-metacoq-template-pcuic" {= version} +] +synopsis: "Gallina quotation functions for Template Coq and PCUIC." +description: """ +""" diff --git a/coq-metacoq-safechecker-plugin.opam b/coq-metacoq-safechecker-plugin.opam index 77ce0dc99..43ad01a19 100644 --- a/coq-metacoq-safechecker-plugin.opam +++ b/coq-metacoq-safechecker-plugin.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " diff --git a/coq-metacoq-safechecker.opam b/coq-metacoq-safechecker.opam index 60d626705..6f6f59808 100644 --- a/coq-metacoq-safechecker.opam +++ b/coq-metacoq-safechecker.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " diff --git a/coq-metacoq-template-pcuic.opam b/coq-metacoq-template-pcuic.opam index 460257f1f..c09570ebb 100644 --- a/coq-metacoq-template-pcuic.opam +++ b/coq-metacoq-template-pcuic.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " diff --git a/coq-metacoq-template.opam b/coq-metacoq-template.opam index 10e1786c9..8fc98964d 100644 --- a/coq-metacoq-template.opam +++ b/coq-metacoq-template.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " diff --git a/coq-metacoq-translations.opam b/coq-metacoq-translations.opam index d9508fb75..6114b34c8 100644 --- a/coq-metacoq-translations.opam +++ b/coq-metacoq-translations.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " @@ -33,7 +34,7 @@ synopsis: "Translations built on top of MetaCoq" description: """ MetaCoq is a meta-programming framework for Coq. -The Translations modules provides implementation of standard translations -from type theory to type theory, e.g. parametricity and the `cross-bool` +The Translations modules provides implementation of standard translations +from type theory to type theory, e.g. parametricity and the `cross-bool` translation that invalidates functional extensionality. """ diff --git a/coq-metacoq-utils.opam b/coq-metacoq-utils.opam index 6e4e98e2e..3d1e5e34e 100644 --- a/coq-metacoq-utils.opam +++ b/coq-metacoq-utils.opam @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " diff --git a/coq-metacoq.opam b/coq-metacoq.opam index efb6d7f4c..a8fbffd27 100644 --- a/coq-metacoq.opam +++ b/coq-metacoq.opam @@ -1,4 +1,4 @@ -opam-version: "2.0" +opam-version: "2.0" version: "8.16.dev" maintainer: "matthieu.sozeau@inria.fr" homepage: "https://metacoq.github.io/metacoq" @@ -9,6 +9,7 @@ authors: ["Abhishek Anand " "Simon Boulier " "Cyril Cohen " "Yannick Forster " + "Jason Gross " "Fabian Kunze " "Meven Lennon-Bertrand " "Kenji Maillard " @@ -23,6 +24,7 @@ depends: [ "coq-metacoq-safechecker-plugin" {= version} "coq-metacoq-erasure-plugin" {= version} "coq-metacoq-translations" {= version} + "coq-metacoq-quotation" {= version} ] build: [ ["bash" "./configure.sh" ] {with-test} @@ -34,8 +36,8 @@ description: """ MetaCoq is a meta-programming framework for Coq. The meta-package includes the template-coq library, -the PCUIC development including a verified equivalence between Coq and PCUIC, -a safe type checker and verified erasure for PCUIC and example translations. +the PCUIC development including a verified equivalence between Coq and PCUIC, +a safe type checker and verified erasure for PCUIC and example translations. See individual packages for more detailed descriptions. """ diff --git a/quotation/Makefile b/quotation/Makefile new file mode 100644 index 000000000..fe18b83ab --- /dev/null +++ b/quotation/Makefile @@ -0,0 +1,33 @@ +all: theory + +_CoqProject: _CoqProject.in metacoq-config + cat metacoq-config > _CoqProject + cat _CoqProject.in >> _CoqProject + +Makefile.quotation: _CoqProject + coq_makefile -f _CoqProject -o Makefile.quotation $(DEPS) + +theory: Makefile.quotation + $(MAKE) -f Makefile.quotation + +install: theory + $(MAKE) -f Makefile.quotation install + +uninstall: Makefile.quotation + $(MAKE) -f Makefile.quotation uninstall + +clean: Makefile.quotation + make -f Makefile.quotation clean + +mrproper: + rm -f metacoq-config + rm -f Makefile.quotation _CoqProject + +.merlin: + make -f $< $@ + +vos: Makefile.quotation + $(MAKE) -f Makefile.quotation vos + +quick: Makefile.quotation + $(MAKE) -f Makefile.quotation COQEXTRAFLAGS="-unset \"Universe Checking\"" vos diff --git a/quotation/_CoqProject.in b/quotation/_CoqProject.in new file mode 100644 index 000000000..f1d0a150a --- /dev/null +++ b/quotation/_CoqProject.in @@ -0,0 +1,103 @@ +-R theories MetaCoq.Quotation + +theories/CommonUtils.v +theories/ToTemplate/Common/BasicAst.v +theories/ToTemplate/Common/Environment.v +theories/ToTemplate/Common/EnvironmentTyping.v +theories/ToTemplate/Common/Kernames.v +theories/ToTemplate/Common/Primitive.v +theories/ToTemplate/Common/Reflect.v +theories/ToTemplate/Common/Transform.v +theories/ToTemplate/Common/Universes.v +theories/ToTemplate/Common/config.v +theories/ToTemplate/Coq/Bool.v +theories/ToTemplate/Coq/FSets.v +theories/ToTemplate/Coq/Floats.v +theories/ToTemplate/Coq/Init.v +theories/ToTemplate/Coq/Lists.v +theories/ToTemplate/Coq/MSets.v +theories/ToTemplate/Coq/Numbers.v +theories/ToTemplate/Coq/Strings.v +theories/ToTemplate/Coq/ssr.v +theories/ToTemplate/Init.v +theories/ToTemplate/QuotationOf/Common/Environment/Sig.v +theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v +theories/ToTemplate/QuotationOf/Common/Kernames/Instances.v +theories/ToTemplate/QuotationOf/Common/Kernames/Kername/Instances.v +theories/ToTemplate/QuotationOf/Common/Kernames/KernameMap/Instances.v +theories/ToTemplate/QuotationOf/Common/Kernames/KernameMapFact/Instances.v +theories/ToTemplate/QuotationOf/Common/Kernames/KernameSet/Instances.v +theories/ToTemplate/QuotationOf/Common/Kernames/KernameSetOrdProp/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/Level/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/LevelExpr/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSet/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSetOrdProp/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/LevelSet/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/LevelSetOrdProp/Instances.v +theories/ToTemplate/QuotationOf/Common/Universes/UnivConstraint/Instances.v +theories/ToTemplate/QuotationOf/Coq/FSets/FMapAVL/Sig.v +theories/ToTemplate/QuotationOf/Coq/FSets/FMapFacts/Sig.v +theories/ToTemplate/QuotationOf/Coq/FSets/FMapInterface/Sig.v +theories/ToTemplate/QuotationOf/Coq/FSets/FMapList/Sig.v +theories/ToTemplate/QuotationOf/Coq/MSets/MSetAVL/Sig.v +theories/ToTemplate/QuotationOf/Coq/MSets/MSetDecide/Sig.v +theories/ToTemplate/QuotationOf/Coq/MSets/MSetFacts/Sig.v +theories/ToTemplate/QuotationOf/Coq/MSets/MSetInterface/Sig.v +theories/ToTemplate/QuotationOf/Coq/MSets/MSetList/Sig.v +theories/ToTemplate/QuotationOf/Coq/MSets/MSetProperties/Sig.v +theories/ToTemplate/QuotationOf/Coq/Structures/Equalities/Sig.v +theories/ToTemplate/QuotationOf/Coq/Structures/Orders/Sig.v +theories/ToTemplate/QuotationOf/Coq/Structures/OrdersAlt/Sig.v +theories/ToTemplate/QuotationOf/Coq/Structures/OrdersFacts/Sig.v +theories/ToTemplate/QuotationOf/Coq/Structures/OrdersTac/Sig.v +theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v +theories/ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.v +theories/ToTemplate/QuotationOf/Template/Ast/Instances.v +theories/ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.v +theories/ToTemplate/QuotationOf/Template/Ast/TemplateTerm/Instances.v +theories/ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.v +theories/ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.v +theories/ToTemplate/QuotationOf/Template/ReflectAst/Instances.v +theories/ToTemplate/QuotationOf/Template/ReflectAst/TemplateTermDecide/Instances.v +theories/ToTemplate/QuotationOf/Template/Typing/Instances.v +theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.v +theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.v +theories/ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.v +theories/ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.v +theories/ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.v +theories/ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.v +theories/ToTemplate/Template/Ast.v +theories/ToTemplate/Template/AstUtils.v +theories/ToTemplate/Template/Induction.v +theories/ToTemplate/Template/LiftSubst.v +theories/ToTemplate/Template/ReflectAst.v +theories/ToTemplate/Template/TermEquality.v +theories/ToTemplate/Template/Typing.v +theories/ToTemplate/Template/UnivSubst.v +theories/ToTemplate/Template/WfAst.v +theories/ToTemplate/Utils/All_Forall.v +theories/ToTemplate/Utils/ByteCompare.v +theories/ToTemplate/Utils/ByteCompareSpec.v +theories/ToTemplate/Utils/ByteCompare_opt.v +theories/ToTemplate/Utils/LibHypsNaming.v +theories/ToTemplate/Utils/MCArith.v +theories/ToTemplate/Utils/MCCompare.v +theories/ToTemplate/Utils/MCEquality.v +theories/ToTemplate/Utils/MCList.v +theories/ToTemplate/Utils/MCOption.v +theories/ToTemplate/Utils/MCPred.v +theories/ToTemplate/Utils/MCPrelude.v +theories/ToTemplate/Utils/MCProd.v +theories/ToTemplate/Utils/MCReflect.v +theories/ToTemplate/Utils/MCRelations.v +theories/ToTemplate/Utils/MCSquash.v +theories/ToTemplate/Utils/MCString.v +theories/ToTemplate/Utils/MCUtils.v +theories/ToTemplate/Utils/ReflectEq.v +theories/ToTemplate/Utils/bytestring.v +theories/ToTemplate/Utils/monad_utils.v +theories/ToTemplate/Utils/utils.v +theories/ToTemplate/Utils/wGraph.v diff --git a/quotation/theories/CommonUtils.v b/quotation/theories/CommonUtils.v new file mode 100644 index 000000000..5ac0dcfcc --- /dev/null +++ b/quotation/theories/CommonUtils.v @@ -0,0 +1,382 @@ +From MetaCoq.Utils Require Import utils monad_utils MCList. +From MetaCoq.Common Require Import Kernames MonadBasicAst. +From MetaCoq.Template Require MonadAst TemplateMonad Ast Loader. +Require Import Equations.Prop.Classes. +Require Import Coq.Lists.List. +Import ListNotations. + +Local Unset Universe Minimization ToSet. +Local Set Primitive Projections. +Local Open Scope bs. +Import MCMonadNotation. + +Class debug_opt := debug : bool. +Class cls_is_true (b : bool) := is_truev : is_true b. + +(* returns true if a modpath is suitable for quotation, i.e., does not mention functor-bound arguments *) +Fixpoint modpath_is_absolute (mp : modpath) : bool + := match mp with + | MPfile _ => true + | MPbound _ _ _ => false + | MPdot mp _ => modpath_is_absolute mp + end. +Definition kername_is_absolute (kn : kername) : bool + := modpath_is_absolute (fst kn). +(* gives the dirpath and the reversed list of idents, or None if bound *) +Fixpoint split_common_prefix_ls (mp1 mp2 : list ident) := + match mp1, mp2 with + | [], _ | _, [] => ([], mp1, mp2) + | i1 :: mp1, i2 :: mp2 + => if i1 == i2 + then let '(common, mp1, mp2) := split_common_prefix_ls mp1 mp2 in + (i1 :: common, mp1, mp2) + else ([], mp1, mp2) + end. +Definition common_prefix_ls (mp1 mp2 : list ident) := + let '(common, _, _) := split_common_prefix_ls mp1 mp2 in common. +Fixpoint split_modpath (mp : modpath) : (list ident * (dirpath * option (ident * nat))) + := match mp with + | MPfile f => ([], (f, None)) + | MPbound f i idx => ([], (f, Some (i, idx))) + | MPdot mp i => let '(l, d) := split_modpath mp in (i :: l, d) + end. +(* returns None if either [mp] shares no prefix with [mp] or either modpath is bound, otherwise returns the list of idents of the common prefix *) +Definition split_common_prefix (mp1 mp2 : modpath) : option ((dirpath * option (ident * nat)) * (list ident * list ident * list ident)) + := match split_modpath mp1, split_modpath mp2 with + | (mp1, f1), (mp2, f2) + => if f1 == f2 + then Some (f1, split_common_prefix_ls (rev mp1) (rev mp2)) + else None + end. +Definition common_prefix (mp1 mp2 : modpath) : option ((dirpath * option (ident * nat)) * list ident) + := option_map (fun '(f, (common, _, _)) => (f, common)) (split_common_prefix mp1 mp2). +(* Kludge for not having https://github.com/MetaCoq/metacoq/issues/839 *) +Definition modpath_is_okay (cur_modpath : modpath) (mp : modpath) : bool + := andb (modpath_is_absolute mp) + match mp with + | MPfile _ => true + | MPbound _ _ _ => false + | MPdot _ _ + => match common_prefix cur_modpath mp with + | None => true (* it's not part of the current module, so it's fine *) + | Some (_, []) => true (* only share the top-level, so it can't be a functor *) + | Some _ => false + end + end. +Definition kername_is_okay (cur_modpath : modpath) (kn : kername) : bool + := modpath_is_okay cur_modpath (fst kn). + +Definition b_of_dec {P} (H : {P} + {~P}) : bool := if H then true else false. +Definition bp_of_dec {P H} : @b_of_dec P H = true -> P. +Proof. cbv [b_of_dec]; destruct H; auto; discriminate. Defined. +Definition pb_of_dec {P:Prop} {H} : P -> @b_of_dec P H = true. +Proof. cbv [b_of_dec]; destruct H; auto; discriminate. Defined. +Definition neg_bp_of_dec {P H} : @b_of_dec P H = false -> ~P. +Proof. cbv [b_of_dec]; destruct H; auto; discriminate. Defined. +Definition neg_pb_of_dec {P:Prop} {H} : ~P -> @b_of_dec P H = false. +Proof. cbv [b_of_dec]; destruct H; tauto. Defined. + +(* TODO: move? *) +Definition kername_of_global_reference (g : global_reference) : option kername + := match g with + | VarRef _ => None + | ConstRef x => Some x + | IndRef ind + | ConstructRef ind _ + => Some ind.(inductive_mind) + end. + +Definition replace_inductive_kn (t : inductive) (ind : inductive) : inductive + := {| inductive_mind := ind.(inductive_mind) ; inductive_ind := t.(inductive_ind) |}. + +Definition replace_inductive_modpath (mp : modpath) (ind : inductive) : inductive + := {| inductive_mind := (mp, snd ind.(inductive_mind)) ; inductive_ind := ind.(inductive_ind) |}. + +Definition rebase_global_reference (mp : modpath) (g : global_reference) : global_reference + := match g with + | VarRef x => VarRef x + | ConstRef (_, i) => ConstRef (mp, i) + | IndRef ind => IndRef (replace_inductive_modpath mp ind) + | ConstructRef ind idx => ConstructRef (replace_inductive_modpath mp ind) idx + end. + +(* hack around https://github.com/MetaCoq/metacoq/issues/850 *) +Fixpoint dedup_grefs' (g : list global_reference) (seen : KernameSet.t) : list global_reference + := match g with + | nil => nil + | g :: gs + => match kername_of_global_reference g with + | None => g :: dedup_grefs' gs seen + | Some kn + => if KernameSet.mem kn seen + then dedup_grefs' gs seen + else g :: dedup_grefs' gs (KernameSet.add kn seen) + end + end. +Definition dedup_grefs (g : list global_reference) : list global_reference + := dedup_grefs' g KernameSet.empty. + +Module WithTemplate. + Import MetaCoq.Template.Loader. + Import MetaCoq.Template.Ast. + Import MonadBasicAst MonadAst. + Import MetaCoq.Template.TemplateMonad.Common. + Import MetaCoq.Template.TemplateMonad.Core. + + (* unfolding Qed'd definitions for the benefit of quotation *) + Polymorphic Definition tmUnfoldQed {A} (v : A) : TemplateMonad A + := p <- tmQuote v;; + v <- match p return TemplateMonad term with + | tConst c u + => cb <- tmQuoteConstant c true;; + match cb with + | {| cst_body := Some cb |} => tmReturn (subst_instance_constr u cb) + | {| cst_body := None |} => _ <- tmMsg "tmUnfoldQed: failed to find body for";; _ <- tmPrint v;; tmReturn p + end + | _ => _ <- tmMsg "tmUnfoldQed: not const";; _ <- tmPrint v;; tmReturn p + end;; + tmUnquoteTyped A v. + Notation transparentify v := (match tmUnfoldQed v return _ with v' => ltac:(run_template_program v' (fun v' => exact v')) end) (only parsing). + + + Polymorphic Definition tmQuoteToGlobalReference {A} (n : A) : TemplateMonad global_reference + := qn <- tmQuote n;; + match qn with + | tVar id => tmReturn (VarRef id) + | tConst c u => tmReturn (ConstRef c) + | tInd ind u => tmReturn (IndRef ind) + | tConstruct ind idx u => tmReturn (ConstructRef ind idx) + | _ => _ <- tmMsg "tmQuoteToGlobalReference: Not a global reference";; + _ <- tmPrint n;; + _ <- tmPrint qn;; + tmFail "tmQuoteToGlobalReference: Not a global reference" + end. + + Polymorphic Definition tmObj_magic {A B} (x : A) : TemplateMonad B + := qx <- tmQuote x;; + tmUnquoteTyped B qx. + + Polymorphic Definition tmRetype {A} (x : A) : TemplateMonad A + := tmObj_magic x. + + Polymorphic Definition tmExtractBaseModPathFromMod (mp : qualid) : TemplateMonad modpath + := vs <- tmQuoteModule mp;; + match option_map kername_of_global_reference (hd_error vs) with + | Some (Some (mp, _)) => ret mp + | _ => tmFail "tmExtractBaseModPathFromMod: module has no accessible constant with a kername" + end. + + Section with_monad. + Context {M} {M_monad : Monad M} (in_domain : bool) (U : Universe.t -> M term). + + #[local] + Fixpoint tmRelaxSortsM (t : term) {struct t} : M term + := let tmRelaxSortsM_dom t := if in_domain then tmRelaxSortsM t else ret t in + match t with + | tRel _ + | tVar _ + | tInt _ + | tFloat _ + | tConst _ _ + | tInd _ _ + | tConstruct _ _ _ + => ret t + | tEvar ev args + => args <- monad_map tmRelaxSortsM_dom args;; + ret (tEvar ev args) + | tCast t kind v + => t <- tmRelaxSortsM t;; + v <- tmRelaxSortsM v;; + ret (tCast t kind v) + | tProd na ty body + => ty <- tmRelaxSortsM_dom ty;; + body <- tmRelaxSortsM body;; + ret (tProd na ty body) + | tLambda na ty body + => ty <- tmRelaxSortsM_dom ty;; + body <- tmRelaxSortsM body;; + ret (tLambda na ty body) + | tLetIn na def def_ty body + => def <- tmRelaxSortsM_dom def;; + def_ty <- tmRelaxSortsM_dom def_ty;; + body <- tmRelaxSortsM body;; + ret (tLetIn na def def_ty body) + | tApp f args + => f <- tmRelaxSortsM_dom f;; + args <- monad_map tmRelaxSortsM_dom args;; + ret (tApp f args) + | tCase ci type_info discr branches + => type_info <- monad_map_predicate (fun x => ret x) tmRelaxSortsM tmRelaxSortsM type_info;; + discr <- tmRelaxSortsM_dom discr;; + branches <- monad_map_branches tmRelaxSortsM branches;; + ret (tCase ci type_info discr branches) + | tProj proj t + => t <- tmRelaxSortsM_dom t;; + ret (tProj proj t) + | tFix mfix idx + => mfix <- monad_map (monad_map_def tmRelaxSortsM tmRelaxSortsM) mfix;; + ret (tFix mfix idx) + | tCoFix mfix idx + => mfix <- monad_map (monad_map_def tmRelaxSortsM tmRelaxSortsM) mfix;; + ret (tCoFix mfix idx) + | tSort s => U s + end. + End with_monad. + + #[local] Definition CacheT T : Type := term * list term * UniverseMap.t term -> T * (term * list term * UniverseMap.t term). + #[local] Instance CacheT_Monad : Monad CacheT + := {| ret A v := fun st => (v, st) + ; bind A B v f := fun st => let '(v, st) := v st in f v st |}. + #[local] Definition init_cache_and_run (lProp_t lSProp_t lSet_t : term) (default_univ : term) (available_univs : list term) {T} : CacheT T -> T + := fun f + => fst + (f (default_univ, + available_univs, + UniverseMap.add + Universe.lProp lProp_t + (UniverseMap.add + Universe.lSProp lSProp_t + (UniverseMap.add + (Universe.of_levels (inr Level.lzero)) lSet_t + (UniverseMap.empty _))))). + #[local] Definition lookupU (u : Universe.t) : CacheT term + := fun '((default_univ, fresh_univs, map) as st) + => match UniverseMap.find u map, fresh_univs with + | Some t, _ => (t, st) + | None, nil => (default_univ, st) + | None, t :: fresh_univs + => (t, (default_univ, fresh_univs, UniverseMap.add u t map)) + end. + + #[local] + Definition tmRelaxSortsCached (in_domain : bool) (do_replace_U : Universe.t -> bool) (lProp_t lSProp_t lSet_t : term) (default_univ : term) (available_univs : list term) (t : term) : term + := init_cache_and_run + lProp_t lSProp_t lSet_t default_univ available_univs + (tmRelaxSortsM + in_domain + (fun u => if do_replace_U u + then lookupU u + else ret (tSort u)) + t). + + Polymorphic Inductive list_of_types := nil | cons (x : Type) (xs : list_of_types). + Declare Scope list_of_types_scope. + Delimit Scope list_of_types_scope with list_of_types. + Bind Scope list_of_types_scope with list_of_types. + + Infix "::" := cons : list_of_types_scope. + Notation "[ ]" := nil : list_of_types_scope. + Notation "[ x ]" := (cons x nil) : list_of_types_scope. + Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) : list_of_types_scope. + + Polymorphic Definition types_monad_map@{l b a t u} {T} {M : Monad@{t u} T} {B : Type@{b}} (f : Type@{a} -> T B) + := fix types_monad_map (l : list_of_types@{l}) : T (list B) + := match l with + | []%list_of_types => ret []%list + | (x :: xs)%list_of_types + => fx <- f x;; + fxs <- types_monad_map xs;; + ret (fx :: fxs)%list + end. + + #[local] Polymorphic Definition tmRelaxSortsQuote@{uP uSP uS uD uL t u _high} (in_domain : bool) (do_replace_U : Universe.t -> bool) (available_univs : list_of_types@{uL}) (t : term) : TemplateMonad@{t u} term + := lProp_t <- @tmQuote Type@{_high} Type@{uP};; + lSProp_t <- @tmQuote Type@{_high} Type@{uSP};; + lSet_t <- @tmQuote Type@{_high} Type@{uS};; + default_univ <- @tmQuote Type@{_high} Type@{uD};; + available_univs <- types_monad_map@{uL _high _ _ _} tmQuote available_univs;; + ret (tmRelaxSortsCached in_domain do_replace_U lProp_t lSProp_t lSet_t default_univ available_univs t). + + + #[local] Definition is_set (s : Universe.t) : bool + := match option_map Level.is_set (Universe.get_is_level s) with + | Some true => true + | _ => false + end. + + #[local] Definition is_type (s : Universe.t) : bool + := match Universe.get_is_level s with + | Some _ => true + | _ => false + end. + + #[local] Definition is_only_type (s : Universe.t) : bool + := match option_map Level.is_set (Universe.get_is_level s) with + | Some false => true + | _ => false + end. + + Polymorphic Definition tmRetypeMagicRelaxSetInCodomain@{U a b t u _high} {A : Type@{a}} (B : Type@{b}) (x : A) : TemplateMonad@{t u} B + := qx <- tmQuote x;; + qx <- tmRelaxSortsQuote@{U U U U _high t u _high} false is_set [] qx;; + tmUnquoteTyped B qx. + Polymorphic Definition tmRetypeRelaxSetInCodomain@{U a t u _high} {A : Type@{a}} (x : A) : TemplateMonad@{t u} A + := tmRetypeMagicRelaxSetInCodomain@{U a a t u _high} A x. + + Local Notation many_Types_2 tail := (Type :: Type :: Type :: Type :: tail)%list_of_types (only parsing). + Local Notation many_Types_3 tail := (many_Types_2 (many_Types_2 tail)) (only parsing). + Local Notation many_Types_4 tail := (many_Types_3 (many_Types_3 tail)) (only parsing). + Local Notation many_Types_5 tail := (many_Types_4 (many_Types_4 tail)) (only parsing). + Local Notation many_Types := (many_Types_5 nil) (only parsing). + + Polymorphic Definition tmRetypeMagicRelaxOnlyType0@{U a b t u _high} {A : Type@{a}} (B : Type@{b}) (x : A) : TemplateMonad@{t u} B + := qx <- tmQuote x;; + qx <- tmRelaxSortsQuote@{U U U U _high t u _high} true is_only_type [] qx;; + tmUnquoteTyped B qx. + Polymorphic Definition tmRetypeRelaxOnlyType0@{U a t u _high} {A : Type@{a}} (x : A) : TemplateMonad@{t u} A + := tmRetypeMagicRelaxOnlyType0@{U a a t u _high} A x. + + Polymorphic Definition tmRetypeMagicRelaxOnlyType {A : Type} (B : Type) (x : A) : TemplateMonad B + := qx <- tmQuote x;; + qx <- tmRelaxSortsQuote true is_only_type many_Types qx;; + tmUnquoteTyped B qx. + Polymorphic Definition tmRetypeRelaxOnlyType {A} (x : A) : TemplateMonad A + := tmRetypeMagicRelaxOnlyType A x. + + (* Hack around https://github.com/MetaCoq/metacoq/issues/853 *) + Polymorphic Definition tmRetypeAroundMetaCoqBug853_0 (t : typed_term) : TemplateMonad typed_term + := let '{| my_projT1 := ty ; my_projT2 := v |} := t in + ty <- tmRetypeRelaxOnlyType0 ty;; + v <- tmRetypeMagicRelaxOnlyType0 ty v;; + ret {| my_projT1 := ty ; my_projT2 := v |}. + + Polymorphic Definition tmRetypeAroundMetaCoqBug853_gen (t : typed_term) : TemplateMonad typed_term + := let '{| my_projT1 := ty ; my_projT2 := v |} := t in + ty <- tmRetypeRelaxOnlyType ty;; + v <- tmRetypeMagicRelaxOnlyType ty v;; + ret {| my_projT1 := ty ; my_projT2 := v |}. + + (* Hack around https://github.com/MetaCoq/metacoq/pull/876#issuecomment-1487743822 *) + Monomorphic Variant exn : Set := GenericError. + + Polymorphic Variant option_try (A : Type) : Type := my_Value (val : A) | my_Error (err : exn). + + Arguments my_Value {A} val. + Arguments my_Error {A} _. + Polymorphic Class tmCheckSuccessHelper@{t u} {A : Type@{t}} (run : TemplateMonad@{t u} A) := tmCheckSuccess_ret : unit. + #[global] Hint Extern 0 (tmCheckSuccessHelper ?run) => run_template_program run (fun v => exact tt) : typeclass_instances. + Polymorphic Definition tmCheckSuccess@{t u} {A : Type@{t}} (run : TemplateMonad@{t u} A) : TemplateMonad@{t u} bool + := tmBind (tmInferInstance None (tmCheckSuccessHelper run)) + (fun inst => match inst with + | my_Some _ => tmReturn true + | my_None => tmReturn false + end). + Polymorphic Definition tmTryWorseButNoAnomaly@{t u} {A : Type@{t}} (run : TemplateMonad@{t u} A) : TemplateMonad@{t u} (option_try@{t} A) + := succeeds <- tmCheckSuccess run;; + if succeeds:bool + then v <- run;; ret (my_Value v) + else ret (my_Error GenericError). + + Definition tmRetypeAroundMetaCoqBug853 (t : typed_term) : TemplateMonad typed_term + := Eval cbv [List.fold_right] in + List.fold_right + (fun tmRetype acc + => res <- tmTryWorseButNoAnomaly (tmRetype t);; + match res with + | my_Value v => ret v + | my_Error _ => acc + end) + (tmRetypeAroundMetaCoqBug853_gen t) + [tmRetypeAroundMetaCoqBug853_0; tmRetypeAroundMetaCoqBug853_gen]. +End WithTemplate. +Export WithTemplate (transparentify, tmQuoteToGlobalReference, tmRetypeRelaxSetInCodomain, tmRetypeRelaxOnlyType, tmRetypeMagicRelaxSetInCodomain, tmRetypeMagicRelaxOnlyType, tmObj_magic, tmRetype, tmExtractBaseModPathFromMod, tmRetypeAroundMetaCoqBug853). diff --git a/quotation/theories/ToTemplate/Common/BasicAst.v b/quotation/theories/ToTemplate/Common/BasicAst.v new file mode 100644 index 000000000..62c1e5a21 --- /dev/null +++ b/quotation/theories/ToTemplate/Common/BasicAst.v @@ -0,0 +1,26 @@ +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.Floats Coq.Numbers. +From MetaCoq.Quotation.ToTemplate.Utils Require Import (hints) utils. +From MetaCoq.Quotation.ToTemplate.Common Require Import (hints) Kernames. +From MetaCoq.Common Require Import BasicAst. +From MetaCoq.Utils Require Import MCUtils. +From MetaCoq.Template Require Import AstUtils (* for tFixType *). + +#[export] Instance quote_name : ground_quotable name := ltac:(destruct 1; exact _). +#[export] Instance quote_relevance : ground_quotable relevance := ltac:(destruct 1; exact _). +#[export] Instance quote_binder_annot {A} {qA : quotation_of A} {quoteA : ground_quotable A} : ground_quotable (binder_annot A) := ltac:(destruct 1; exact _). +#[export] Instance quote_cast_kind : ground_quotable cast_kind := ltac:(destruct 1; exact _). +#[export] Instance quote_case_info : ground_quotable case_info := ltac:(destruct 1; exact _). +#[export] Instance quote_recursivity_kind : ground_quotable recursivity_kind := ltac:(destruct 1; exact _). +#[export] Instance quote_conv_pb : ground_quotable conv_pb := ltac:(destruct 1; exact _). +#[export] Hint Unfold aname : quotation. +#[export] Typeclasses Transparent aname. +#[export] Instance quote_def {term} {qterm : quotation_of term} {quote_term : ground_quotable term} : ground_quotable (def term) := ltac:(destruct 1; exact _). +#[export] Instance quote_typ_or_sort_ {term} {qterm : quotation_of term} {quote_term : ground_quotable term} : ground_quotable (typ_or_sort_ term) := ltac:(destruct 1; exact _). +#[export] Instance quote_context_decl {term} {qterm : quotation_of term} {quote_term : ground_quotable term} : ground_quotable (context_decl term) := ltac:(destruct 1; exact _). +#[export] Hint Unfold mfixpoint : quotation. +#[export] Typeclasses Transparent mfixpoint. +#[local] Hint Unfold dtype dbody : quotation. +#[export] Instance quotation_of_mfixpoint {term} {m : mfixpoint term} {qterm : quotation_of term} {qm : tFixType quotation_of quotation_of m} : quotation_of m := ltac:(induction qm; destruct_head'_prod; destruct_head' def; exact _). +#[export] Hint Unfold eq_binder_annot : quotation. +#[export] Typeclasses Transparent eq_binder_annot. diff --git a/quotation/theories/ToTemplate/Common/Environment.v b/quotation/theories/ToTemplate/Common/Environment.v new file mode 100644 index 000000000..7b82eb191 --- /dev/null +++ b/quotation/theories/ToTemplate/Common/Environment.v @@ -0,0 +1,116 @@ +From Coq Require Import Structures.Equalities Lists.List Lists.ListDec. +From MetaCoq.Utils Require Import MCProd All_Forall ReflectEq MCRelations MCReflect. +From MetaCoq.Common Require Import Environment Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.ssr utils BasicAst Primitive Universes Kernames. +From MetaCoq.Quotation.ToTemplate.Utils Require Import (hints) MCOption MCProd All_Forall. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. + +Module Retroknowledge. + #[export] Instance quote_t : ground_quotable Retroknowledge.t := ltac:(destruct 1; exact _). + #[export] Instance quote_extends {x y} : ground_quotable (@Retroknowledge.extends x y) := ltac:(cbv [Retroknowledge.extends]; exact _). +End Retroknowledge. +Export (hints) Retroknowledge. + +Module QuoteEnvironmentHelper (T : Term) (Import E : EnvironmentSig T). + Lemma forall_all_helper_iff {Σ Σ' : global_env} + : (forall c, { decls & lookup_envs Σ' c = (decls ++ lookup_envs Σ c)%list }) + <~> All (fun '(c, _) => { decls & lookup_envs Σ' c = decls ++ lookup_envs Σ c }) (declarations Σ). + Proof. + split. + { intro H. + apply In_All; intros [c ?] _; specialize (H c); assumption. } + { intros H c. + generalize (fun n k H' => @nth_error_all _ _ _ n (c, k) H' H). + destruct (In_dec Kernames.KernameSet.E.eq_dec c (List.map fst (declarations Σ))) as [H'|H']. + { induction (declarations Σ) as [|[k ?] xs IH]; cbn in *. + { exfalso; assumption. } + { destruct (eqb_specT k c); subst. + { intro H''; specialize (H'' 0 _ eq_refl); cbn in H''. + exact H''. } + { assert (H'' : In c (map fst xs)) by now destruct H'. + inversion H; subst. + intro H'''; apply IH; auto. + intros; eapply (H''' (S _)); cbn; eassumption. } } } + { unfold lookup_envs in *. + intros _. + clear H. + induction (declarations Σ) as [|x xs IH]; cbn in *. + { eexists; rewrite List.app_nil_r; reflexivity. } + { destruct (eqb_specT c x.1); subst. + { exfalso; intuition. } + { apply IH. + intuition. } } } } + Qed. + + (* quotable versions *) + Definition extends_alt (Σ Σ' : global_env) := + [× Σ.(universes) ⊂_cs Σ'.(universes), + All (fun '(c, _) => { decls & lookup_envs Σ' c = decls ++ lookup_envs Σ c }) (declarations Σ) & + Retroknowledge.extends Σ.(retroknowledge) Σ'.(retroknowledge)]. + + Definition extends_decls_alt (Σ Σ' : global_env) := + [× Σ.(universes) = Σ'.(universes), + All (fun '(c, _) => { decls & lookup_envs Σ' c = decls ++ lookup_envs Σ c }) (declarations Σ) & + Σ.(retroknowledge) = Σ'.(retroknowledge)]. + + Lemma extends_alt_iff {Σ Σ'} : extends_alt Σ Σ' <~> extends Σ Σ'. + Proof. + cbv [extends extends_alt]. + destruct (@forall_all_helper_iff Σ Σ'). + split; intros []; split; auto with nocore. + Defined. + + Lemma extends_decls_alt_iff {Σ Σ'} : extends_decls_alt Σ Σ' <~> extends_decls Σ Σ'. + Proof. + cbv [extends_decls extends_decls_alt]. + destruct (@forall_all_helper_iff Σ Σ'). + split; intros []; split; auto with nocore. + Defined. +End QuoteEnvironmentHelper. + +Module Type QuoteEnvironmentHelperSig (T : Term) (E : EnvironmentSig T) := Nop <+ QuoteEnvironmentHelper T E. + +Module Type QuotationOfQuoteEnvironmentHelper (T : Term) (E : EnvironmentSig T) (QEH : QuoteEnvironmentHelperSig T E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "QEH"). +End QuotationOfQuoteEnvironmentHelper. + +Module QuoteEnvironment (T : Term) (Import E : EnvironmentSig T) (Import QEH : QuoteEnvironmentHelperSig T E) (Import qT : QuotationOfTerm T) (Import qE : QuotationOfEnvironment T E) (Import qQEH : QuotationOfQuoteEnvironmentHelper T E QEH) (Import QuoteT : QuoteTerm T) <: QuoteEnvironmentSig T E. + + #[export] Hint Unfold + context + global_declarations + global_env_ext + typ_or_sort + : quotation. + #[export] Typeclasses Transparent + context + global_declarations + global_env_ext + typ_or_sort + . + + #[export] Instance quote_constructor_body : ground_quotable constructor_body := ltac:(destruct 1; exact _). + #[export] Instance quote_projection_body : ground_quotable projection_body := ltac:(destruct 1; exact _). + #[export] Instance quote_one_inductive_body : ground_quotable one_inductive_body := ltac:(destruct 1; exact _). + #[export] Instance quote_mutual_inductive_body : ground_quotable mutual_inductive_body := ltac:(destruct 1; exact _). + #[export] Instance quote_constant_body : ground_quotable constant_body := ltac:(destruct 1; exact _). + #[export] Instance quote_global_decl : ground_quotable global_decl := ltac:(destruct 1; exact _). + + #[export] Instance quote_global_env : ground_quotable global_env := ltac:(destruct 1; exact _). + + #[export] Instance quote_extends_alt {Σ Σ'} : ground_quotable (@extends_alt Σ Σ') := ltac:(cbv [extends_alt]; exact _). + #[export] Instance quote_extends_decls_alt {Σ Σ'} : ground_quotable (@extends_decls_alt Σ Σ') := ltac:(cbv [extends_decls_alt]; exact _). + #[export] Instance qextends_alt : quotation_of extends_alt := ltac:(cbv [extends_alt]; exact _). + #[export] Instance qextends_decls_alt : quotation_of extends_decls_alt := ltac:(cbv [extends_decls_alt]; exact _). + + #[export] Instance quote_extends {Σ Σ'} : ground_quotable (@extends Σ Σ') := ground_quotable_of_iffT extends_alt_iff. + #[export] Instance quote_extends_decls {Σ Σ'} : ground_quotable (@extends_decls Σ Σ') := ground_quotable_of_iffT (@extends_decls_alt_iff Σ Σ'). + #[export] Instance quote_extends_strictly_on_decls {Σ Σ'} : ground_quotable (@extends_strictly_on_decls Σ Σ') := ltac:(cbv [extends_strictly_on_decls]; exact _). + #[export] Instance quote_strictly_extends_decls {Σ Σ'} : ground_quotable (@strictly_extends_decls Σ Σ') := ltac:(cbv [strictly_extends_decls]; exact _). + + #[export] Instance quote_primitive_invariants {cdecl} : ground_quotable (primitive_invariants cdecl) := ltac:(cbv [primitive_invariants]; exact _). + + #[export] Instance quote_All_decls {P t t'} {qP : quotation_of P} {quoteP : forall t t', ground_quotable (P t t')} : ground_quotable (All_decls P t t') := ltac:(induction 1; exact _). + #[export] Instance quote_All_decls_alpha {P t t'} {qP : quotation_of P} {quoteP : forall t t', ground_quotable (P t t')} : ground_quotable (All_decls_alpha P t t') := ltac:(induction 1; exact _). +End QuoteEnvironment. diff --git a/quotation/theories/ToTemplate/Common/EnvironmentTyping.v b/quotation/theories/ToTemplate/Common/EnvironmentTyping.v new file mode 100644 index 000000000..7601387cf --- /dev/null +++ b/quotation/theories/ToTemplate/Common/EnvironmentTyping.v @@ -0,0 +1,216 @@ +From MetaCoq.Common Require Import BasicAst Environment EnvironmentTyping Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.Lists Coq.ssr. +From MetaCoq.Quotation.ToTemplate.Utils Require Import (hints) All_Forall MCOption. +From MetaCoq.Quotation.ToTemplate.Common Require Import (hints) config BasicAst Kernames Universes Environment. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig EnvironmentTyping.Sig. +From Equations.Prop Require Import EqDecInstances. + +Module QuoteLookup (Import T : Term) (Import E : EnvironmentSig T) (Import L : LookupSig T E) (Import EDec : EnvironmentDecide T E) (Import qE : QuotationOfEnvironment T E) (Import qL : QuotationOfLookup T E L) (Import qEDec : QuotationOfEnvironmentDecide T E EDec) (Import QuoteE : QuoteEnvironmentSig T E) <: QuoteLookupSig T E L. + + #[export] Hint Unfold + consistent_instance_ext + : quotation. + #[export] Typeclasses Transparent + consistent_instance_ext + . + + Section with_refl. + #[local] Hint Extern 2 => reflexivity : typeclass_instances. + #[export] Polymorphic Instance quote_on_udecl_decl {F d} {quoteF1 : forall cb, d = ConstantDecl cb -> ground_quotable (F cb.(cst_universes))} {quoteF2 : forall mb, d = InductiveDecl mb -> ground_quotable (F mb.(ind_universes))} : ground_quotable (@on_udecl_decl _ F d) := ltac:(cbv [on_udecl_decl]; exact _). + End with_refl. + + #[export] Instance quote_consistent_instance {cf lvs ϕ uctx u} : ground_quotable (@consistent_instance cf lvs ϕ uctx u) := ltac:(cbv [consistent_instance]; exact _). + #[export] Instance quote_wf_universe {Σ s} : ground_quotable (@wf_universe Σ s) + := ground_quotable_of_dec (@wf_universe_dec Σ s). + + #[export] Instance quote_declared_constant {Σ id decl} : ground_quotable (@declared_constant Σ id decl) := ltac:(cbv [declared_constant]; exact _). + #[export] Instance quote_declared_minductive {Σ mind decl} : ground_quotable (@declared_minductive Σ mind decl) := ltac:(cbv [declared_minductive]; exact _). + #[export] Instance quote_declared_inductive {Σ ind mdecl decl} : ground_quotable (@declared_inductive Σ ind mdecl decl) := ltac:(cbv [declared_inductive]; exact _). + #[export] Instance quote_declared_constructor {Σ cstr mdecl idecl cdecl} : ground_quotable (@declared_constructor Σ cstr mdecl idecl cdecl) := ltac:(cbv [declared_constructor]; exact _). + #[export] Instance quote_declared_projection {Σ proj mdecl idecl cdecl pdecl} : ground_quotable (@declared_projection Σ proj mdecl idecl cdecl pdecl) := ltac:(cbv [declared_projection]; exact _). +End QuoteLookup. + +Module QuoteEnvTyping (Import T : Term) (Import E : EnvironmentSig T) (Import TU : TermUtils T E) (Import ET : EnvTypingSig T E TU) (Import qT : QuotationOfTerm T) (Import qE : QuotationOfEnvironment T E) (Import qET : QuotationOfEnvTyping T E TU ET) (Import QuoteT : QuoteTerm T) (Import QuoteE : QuoteEnvironmentSig T E) <: QuoteEnvTypingSig T E TU ET. + + #[export] Hint Unfold + infer_sort + lift_typing + : quotation. + #[export] Typeclasses Transparent + infer_sort + lift_typing + . + + #[export] Instance quote_All_local_env {typing Γ} {qtyping : quotation_of typing} {quote_typing : forall Γ t T, ground_quotable (typing Γ t T)} : ground_quotable (@All_local_env typing Γ) := ltac:(induction 1; exact _). + Import StrongerInstances. + #[local] Hint Extern 2 (_ = _) => reflexivity : typeclass_instances. + #[export] Instance quote_on_local_decl {P Γ d} {quoteP1 : forall b, d.(decl_body) = Some b -> ground_quotable (P Γ b (Typ d.(decl_type)))} {quoteP2 : d.(decl_body) = None -> ground_quotable (P Γ d.(decl_type) Sort)} : ground_quotable (@on_local_decl P Γ d) := ltac:(cbv [on_local_decl]; exact _). + #[export] Instance quote_lift_judgment {check infer_sort Σ Γ t T} {quote_check : forall T', T = Typ T' -> ground_quotable (check Σ Γ t T')} {quote_infer_sort : T = Sort -> ground_quotable (infer_sort Σ Γ t)} : ground_quotable (@lift_judgment check infer_sort Σ Γ t T) := ltac:(cbv [lift_judgment]; exact _). + #[local] Typeclasses Transparent lift_judgment. + #[export] Instance quote_All_local_env_over_gen + {checking sorting cproperty sproperty Σ Γ H} + {qchecking : quotation_of checking} {qsorting : quotation_of sorting} {qcproperty : quotation_of cproperty} {qsproperty : quotation_of sproperty} + {quote_checking : forall Γ t T, ground_quotable (checking Σ Γ t T)} {quote_sorting : forall Γ T, ground_quotable (sorting Σ Γ T)} {quote_sproperty : forall Γ all t tu, ground_quotable (sproperty Σ Γ all t tu)} {quote_cproperty : forall Γ all b t tb, ground_quotable (cproperty Σ Γ all b t tb)} + : ground_quotable (@All_local_env_over_gen checking sorting cproperty sproperty Σ Γ H) + := ltac:(induction 1; exact _). + #[export] Instance quote_All_local_env_over {typing property Σ Γ H} + {qtyping : quotation_of typing} {qproperty : quotation_of property} + {quote_typing : forall Γ t T, ground_quotable (typing Σ Γ t T)} {quote_property : forall Γ all b t tb, ground_quotable (property Σ Γ all b t tb)} + : ground_quotable (@All_local_env_over typing property Σ Γ H) + := ltac:(cbv [All_local_env_over]; exact _). + #[export] Instance quote_All_local_env_over_sorting + {checking sorting cproperty sproperty Σ Γ H} + {qchecking : quotation_of checking} {qsorting : quotation_of sorting} {qcproperty : quotation_of cproperty} {qsproperty : quotation_of sproperty} + {quote_checking : forall Γ t T, ground_quotable (checking Σ Γ t T)} {quote_sorting : forall Γ T U, ground_quotable (sorting Σ Γ T U)} {quote_sproperty : forall Γ all t tu U, ground_quotable (sproperty Σ Γ all t tu U)} {quote_cproperty : forall Γ all b t tb, ground_quotable (cproperty Σ Γ all b t tb)} + : ground_quotable (@All_local_env_over_sorting checking sorting cproperty sproperty Σ Γ H) + := ltac:(cbv [All_local_env_over_sorting]; exact _). + + #[export] Instance quote_ctx_inst {typing Σ Γ ctx inst} + {qtyping : quotation_of typing} + {quote_typing : forall i t, ground_quotable (typing Σ Γ i t)} + : ground_quotable (@ctx_inst typing Σ Γ ctx inst) + := ltac:(induction 1; exact _). +End QuoteEnvTyping. + +Module QuoteConversion (Import T : Term) (Import E : EnvironmentSig T) (Import TU : TermUtils T E) (Import ET : EnvTypingSig T E TU) (Import C : ConversionSig T E TU ET) (Import qT : QuotationOfTerm T) (Import qE : QuotationOfEnvironment T E) (Import qC : QuotationOfConversion T E TU ET C) (Import QuoteT : QuoteTerm T) (Import QuoteE : QuoteEnvironmentSig T E) <: QuoteConversionSig T E TU ET C. + + #[export] Instance quote_All_decls_alpha_pb {pb P b b'} {qP : quotation_of P} {quoteP : forall pb t t', ground_quotable (P pb t t')} + : ground_quotable (@All_decls_alpha_pb pb P b b') := ltac:(induction 1; exact _). + + #[export] Instance quote_cumul_pb_decls {cumul_gen pb Σ Γ Γ' x y} + {qcumul_gen : quotation_of cumul_gen} + {quote_cumul_gen : forall pb t t', ground_quotable (cumul_gen Σ Γ pb t t')} + : ground_quotable (@cumul_pb_decls cumul_gen pb Σ Γ Γ' x y) + := ltac:(cbv [cumul_pb_decls]; exact _). + + #[export] Instance quote_cumul_pb_context {cumul_gen pb Σ Γ Γ'} + {qcumul_gen : quotation_of cumul_gen} + {quote_cumul_gen : forall Γ pb t t', ground_quotable (cumul_gen Σ Γ pb t t')} + : ground_quotable (@cumul_pb_context cumul_gen pb Σ Γ Γ') + := ltac:(cbv [cumul_pb_context]; exact _). + + #[export] Instance quote_cumul_ctx_rel {cumul_gen Σ Γ Δ Δ'} + {qcumul_gen : quotation_of cumul_gen} + {quote_cumul_gen : forall Γ pb t t', ground_quotable (cumul_gen Σ Γ pb t t')} + : ground_quotable (@cumul_ctx_rel cumul_gen Σ Γ Δ Δ') + := ltac:(cbv [cumul_ctx_rel]; exact _). +End QuoteConversion. + +Module QuoteGlobalMaps (Import T : Term) (Import E : EnvironmentSig T) (Import TU : TermUtils T E) (Import ET : EnvTypingSig T E TU) (Import C : ConversionSig T E TU ET) (Import L : LookupSig T E) (Import GM : GlobalMapsSig T E TU ET C L) (Import qT : QuotationOfTerm T) (Import qE : QuotationOfEnvironment T E) (Import qET : QuotationOfEnvTyping T E TU ET) (Import qC : QuotationOfConversion T E TU ET C) (Import qL : QuotationOfLookup T E L) (Import qGM : QuotationOfGlobalMaps T E TU ET C L GM) (Import QuoteT : QuoteTerm T) (Import QuoteE : QuoteEnvironmentSig T E) (Import QuoteET : QuoteEnvTypingSig T E TU ET) (Import QuoteC : QuoteConversionSig T E TU ET C) (Import QuoteL : QuoteLookupSig T E L) <: QuoteGlobalMapsSig T E TU ET C L GM. + + #[export] Hint Unfold + mdecl_at_i + constructor_univs + on_constructors + fresh_global + : quotation. + #[export] Typeclasses Transparent + mdecl_at_i + constructor_univs + on_constructors + fresh_global + . + + Section GlobalMaps. + Context {cf : config.checker_flags} + {Pcmp: global_env_ext -> context -> conv_pb -> term -> term -> Type} + {P : global_env_ext -> context -> term -> typ_or_sort -> Type} + {qPcmp : quotation_of Pcmp} {qP : quotation_of P} + {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} + {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)}. + + #[export] Instance quote_on_context {Σ ctx} : ground_quotable (@on_context P Σ ctx) + := ltac:(cbv [on_context]; exact _). + + #[export] Instance quote_type_local_ctx {Σ Γ Δ u} : ground_quotable (@type_local_ctx P Σ Γ Δ u) + := ltac:(induction Δ; cbn [type_local_ctx]; exact _). + + #[export] Instance quote_sorts_local_ctx {Σ Γ Δ us} : ground_quotable (@sorts_local_ctx P Σ Γ Δ us) + := ltac:(revert us; induction Δ, us; cbn [sorts_local_ctx]; exact _). + + #[export] Instance quote_on_type {Σ Γ T} : ground_quotable (@on_type P Σ Γ T) + := ltac:(cbv [on_type]; exact _). + + #[export] Instance quote_satisfiable_udecl {univs ϕ} : ground_quotable (@satisfiable_udecl univs ϕ) + := ltac:(cbv [satisfiable_udecl]; exact _). + #[export] Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ) + := ltac:(cbv [valid_on_mono_udecl]; exact _). + #[export] Instance quote_on_udecl {univs udecl} : ground_quotable (@on_udecl univs udecl) + := ltac:(cbv [on_udecl]; exact _). + + #[export] Instance quote_positive_cstr_arg {mdecl ctx t} : ground_quotable (@positive_cstr_arg mdecl ctx t) + := ltac:(induction 1; exact _). + #[export] Instance quote_positive_cstr {mdecl i ctx t} : ground_quotable (@positive_cstr mdecl i ctx t) + := ltac:(induction 1; exact _). + + Import StrongerInstances. + #[export] Instance quote_ind_respects_variance {Σ mdecl v indices} : ground_quotable (@ind_respects_variance Pcmp Σ mdecl v indices) := ltac:(cbv [ind_respects_variance]; exact _). + #[export] Instance quote_cstr_respects_variance {Σ mdecl v cs} : ground_quotable (@cstr_respects_variance Pcmp Σ mdecl v cs) := ltac:(cbv [cstr_respects_variance]; exact _). + #[export] Instance quote_on_constructor {Σ mdecl i idecl ind_indices cdecl cunivs} : ground_quotable (@on_constructor cf Pcmp P Σ mdecl i idecl ind_indices cdecl cunivs) + := ltac:(destruct 1; exact _). + #[export] Instance quote_on_proj {mdecl mind i k p decl} : ground_quotable (@on_proj mdecl mind i k p decl) := ltac:(destruct 1; cbv [proj_type] in *; exact _). + #[export] Instance quote_on_projection {mdecl mind i cdecl k p} : ground_quotable (@on_projection mdecl mind i cdecl k p) := ltac:(cbv [on_projection]; exact _). + #[export] Instance quote_on_projections {mdecl mind i idecl ind_indices cdecl} : ground_quotable (@on_projections mdecl mind i idecl ind_indices cdecl) := ltac:(destruct 1; cbv [on_projection] in *; exact _). + #[export] Instance quote_check_ind_sorts {Σ params kelim ind_indices cdecls ind_sort} : ground_quotable (@check_ind_sorts cf P Σ params kelim ind_indices cdecls ind_sort) := ltac:(cbv [check_ind_sorts check_constructors_smaller global_ext_constraints global_constraints] in *; exact _). + #[export] Instance quote_on_ind_body {Σ mind mdecl i idecl} : ground_quotable (@on_ind_body cf Pcmp P Σ mind mdecl i idecl) := ltac:(destruct 1; cbv [it_mkProd_or_LetIn mkProd_or_LetIn ind_indices ind_sort] in *; exact _). + #[export] Instance quote_on_variance {Σ univs variances} : ground_quotable (@on_variance cf Σ univs variances) := ltac:(cbv [on_variance consistent_instance_ext consistent_instance global_ext_constraints global_constraints]; exact _). + #[export] Instance quote_on_inductive {Σ mind mdecl} : ground_quotable (@on_inductive cf Pcmp P Σ mind mdecl) := ltac:(destruct 1; exact _). + #[export] Instance quote_on_constant_decl {Σ d} : ground_quotable (@on_constant_decl P Σ d) := ltac:(cbv [on_constant_decl]; exact _). + #[export] Instance quote_on_global_decl {Σ kn d} : ground_quotable (@on_global_decl cf Pcmp P Σ kn d) := ltac:(cbv [on_global_decl]; exact _). + #[export] Instance quote_on_global_decls_data {univs retro Σ kn d} : ground_quotable (@on_global_decls_data cf Pcmp P univs retro Σ kn d) := ltac:(destruct 1; exact _). + #[export] Instance quote_on_global_decls {univs retro Σ} : ground_quotable (@on_global_decls cf Pcmp P univs retro Σ) := ltac:(induction 1; exact _). + #[export] Instance quote_on_global_univs {univs} : ground_quotable (@on_global_univs univs) := ltac:(cbv [on_global_univs]; exact _). + #[export] Instance quote_on_global_env {g} : ground_quotable (@on_global_env cf Pcmp P g) := ltac:(cbv [on_global_env]; exact _). + #[export] Instance quote_on_global_env_ext {Σ} : ground_quotable (@on_global_env_ext cf Pcmp P Σ) := ltac:(cbv [on_global_env_ext]; exact _). + End GlobalMaps. + + #[export] Existing Instances + quote_on_context + quote_type_local_ctx + quote_sorts_local_ctx + quote_on_type + quote_on_udecl + quote_satisfiable_udecl + quote_valid_on_mono_udecl + quote_positive_cstr_arg + quote_positive_cstr + quote_ind_respects_variance + quote_cstr_respects_variance + quote_on_constructor + quote_on_proj + quote_on_projection + quote_on_projections + quote_check_ind_sorts + quote_on_ind_body + quote_on_variance + quote_on_inductive + quote_on_constant_decl + quote_on_global_decl + quote_on_global_decls_data + quote_on_global_decls + quote_on_global_univs + quote_on_global_env + quote_on_global_env_ext + . +End QuoteGlobalMaps. + +Module QuoteDeclarationTyping (Import T : Term) (Import E : EnvironmentSig T) (Import TU : TermUtils T E) + (Import ET : EnvTypingSig T E TU) (Import CT : ConversionSig T E TU ET) + (Import CS : ConversionParSig T E TU ET) (Import Ty : Typing T E TU ET CT CS) + (Import L : LookupSig T E) (Import GM : GlobalMapsSig T E TU ET CT L) + (Import DT : DeclarationTypingSig T E TU ET CT CS Ty L GM) + (Import qT : QuotationOfTerm T) (Import qE : QuotationOfEnvironment T E) + (Import qET : QuotationOfEnvTyping T E TU ET) (Import qCT : QuotationOfConversion T E TU ET CT) + (Import qTy : QuotationOfTyping T E TU ET CT CS Ty) + (Import qGM : QuotationOfGlobalMaps T E TU ET CT L GM) + (Import QuoteT : QuoteTerm T) (Import QuoteE : QuoteEnvironmentSig T E) + (Import QuoteET : QuoteEnvTypingSig T E TU ET) (Import QuoteCT : QuoteConversionSig T E TU ET CT) + (Import QuoteTy : QuoteTyping T E TU ET CT CS Ty) + (Import QuoteL : QuoteLookupSig T E L) (Import QuoteGM : QuoteGlobalMapsSig T E TU ET CT L GM) +<: QuoteDeclarationTypingSig T E TU ET CT CS Ty L GM DT. + + Import StrongerInstances. + #[export] Instance quote_type_local_decl {cf Σ Γ d} : ground_quotable (@type_local_decl cf Σ Γ d) := ltac:(cbv [type_local_decl isType]; exact _). + #[export] Instance quote_wf_local_rel {cf Σ Γ Γ'} : ground_quotable (@wf_local_rel cf Σ Γ Γ') := ltac:(cbv [wf_local_rel]; exact _). +End QuoteDeclarationTyping. diff --git a/quotation/theories/ToTemplate/Common/Kernames.v b/quotation/theories/ToTemplate/Common/Kernames.v new file mode 100644 index 000000000..ccec4adb7 --- /dev/null +++ b/quotation/theories/ToTemplate/Common/Kernames.v @@ -0,0 +1,20 @@ +From MetaCoq.Common Require Import Kernames. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.MSets Coq.FSets bytestring. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Kernames.Instances. + +#[local] Hint Unfold ident qualid dirpath kername : quotation. +#[export] Instance quote_ident : ground_quotable ident := _. +#[export] Instance quote_qualid : ground_quotable qualid := _. +#[export] Instance quote_dirpath : ground_quotable dirpath := _. +#[export] Instance quote_modpath : ground_quotable modpath := ltac:(induction 1; exact _). +#[export] Instance quote_kername : ground_quotable kername := _. + +Module QuoteKernameSet := MSets.QuoteMSetAVL Kername KernameSet KernameSetOrdProp qKername qKernameSet qKernameSetOrdProp. +Export (hints) QuoteKernameSet. +Module QuoteKernameMap := FSets.QuoteFMapAVL Kername.OT KernameMap KernameMapFact.F qKername.qOT qKernameMap qKernameMapFact.qF. +Export (hints) QuoteKernameMap. + +#[export] Instance quote_inductive : ground_quotable inductive := ltac:(destruct 1; exact _). +#[export] Instance quote_projection : ground_quotable projection := ltac:(destruct 1; exact _). +#[export] Instance quote_global_reference : ground_quotable global_reference := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Common/Primitive.v b/quotation/theories/ToTemplate/Common/Primitive.v new file mode 100644 index 000000000..de30e8d71 --- /dev/null +++ b/quotation/theories/ToTemplate/Common/Primitive.v @@ -0,0 +1,4 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Common Require Import Primitive. + +#[export] Instance quote_prim_tag : ground_quotable prim_tag := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Common/Reflect.v b/quotation/theories/ToTemplate/Common/Reflect.v new file mode 100644 index 000000000..8d576052e --- /dev/null +++ b/quotation/theories/ToTemplate/Common/Reflect.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant/Class here *) diff --git a/quotation/theories/ToTemplate/Common/Transform.v b/quotation/theories/ToTemplate/Common/Transform.v new file mode 100644 index 000000000..8d576052e --- /dev/null +++ b/quotation/theories/ToTemplate/Common/Transform.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant/Class here *) diff --git a/quotation/theories/ToTemplate/Common/Universes.v b/quotation/theories/ToTemplate/Common/Universes.v new file mode 100644 index 000000000..96747326b --- /dev/null +++ b/quotation/theories/ToTemplate/Common/Universes.v @@ -0,0 +1,165 @@ +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.Coq Require Import (hints) Init MSets Numbers. +From MetaCoq.Quotation.ToTemplate.Utils Require Import (hints) MCOption bytestring. +From MetaCoq.Quotation.ToTemplate.Common Require Import (hints) BasicAst config. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Universes.Instances. +From MetaCoq.Common Require Import Kernames Universes UniversesDec. +From MetaCoq.Utils Require Import bytestring monad_utils. +From MetaCoq.Template Require Import Loader TemplateMonad. + +Local Open Scope bs. +Import MCMonadNotation. + +(* Grrr, [valuation]s cause so much trouble, because they're not quotable *) +(* +Record valuation := + { valuation_mono : string -> positive ; + valuation_poly : nat -> nat }. +Class Evaluable (A : Type) := val : valuation -> A -> nat. + *) + +Module QuoteLevelSet := MSets.QuoteMSetAVL Level LevelSet LevelSetOrdProp qLevel qLevelSet qLevelSetOrdProp. +Export (hints) QuoteLevelSet. +Module QuoteLevelExprSet := MSets.QuoteMSetListWithLeibniz LevelExpr LevelExprSet LevelExprSetOrdProp qLevelExpr qLevelExprSet qLevelExprSetOrdProp. +Export (hints) QuoteLevelExprSet. +Module QuoteConstraintSet := MSets.QuoteMSetAVL UnivConstraint ConstraintSet ConstraintSetOrdProp qUnivConstraint qConstraintSet qConstraintSetOrdProp. +Export (hints) QuoteConstraintSet. + +Module QuoteUniverses1. + Module Import Level. + #[export] Instance quote_t_ : ground_quotable Level.t_ := ltac:(destruct 1; exact _). + #[export] Hint Unfold Level.t : quotation. + #[export] Typeclasses Transparent Level.t. + #[export] Instance quote_lt_ {x y} : ground_quotable (Level.lt_ x y). + Proof. + destruct x, y; + solve [ intro pf; exfalso; inversion pf + | adjust_ground_quotable_by_econstructor_inversion () ]. + Defined. + #[export] Hint Unfold Level.lt : quotation. + End Level. + Export (hints) Level. + + Module Import PropLevel. + #[export] Instance quote_t : ground_quotable PropLevel.t := ltac:(destruct 1; exact _). + #[export] Instance quote_lt_ {x y} : ground_quotable (PropLevel.lt_ x y). + Proof. + destruct x, y; + solve [ intro pf; exfalso; inversion pf + | adjust_ground_quotable_by_econstructor_inversion () ]. + Defined. + #[export] Hint Unfold PropLevel.lt : quotation. + End PropLevel. + Export (hints) PropLevel. + + Module Import LevelExpr. + #[export] Instance quote_t : ground_quotable LevelExpr.t := ltac:(cbv [LevelExpr.t]; exact _). + #[export] Instance quote_lt_ {x y} : ground_quotable (LevelExpr.lt_ x y) + := ground_quotable_of_dec (@LevelExprSet.Raw.MX.lt_dec x y). + #[export] Hint Unfold LevelExpr.lt : quotation. + End LevelExpr. + Export (hints) LevelExpr. +End QuoteUniverses1. +Export (hints) QuoteUniverses1. + +#[export] Hint Unfold + LevelAlgExpr.t + Instance.t + UContext.t + AUContext.t + ContextSet.t + ContextSet.equal + ContextSet.subset + : quotation. + +#[export] Typeclasses Transparent + LevelAlgExpr.t + Instance.t + UContext.t + AUContext.t + ContextSet.t +. + +#[export] Instance quote_nonEmptyLevelExprSet : ground_quotable nonEmptyLevelExprSet := ltac:(destruct 1; exact _). + +#[export] Instance quote_concreteUniverses : ground_quotable concreteUniverses := ltac:(destruct 1; exact _). +Import StrongerInstances. +#[export] Instance quote_leq_cuniverse_n {cf n u u'} : ground_quotable (@leq_cuniverse_n cf n u u') := ltac:(cbv [leq_cuniverse_n]; exact _). +#[export] Instance quote_is_uprop {u} : ground_quotable (@is_uprop u) := ltac:(cbv [is_uprop]; exact _). +#[export] Instance quote_is_usprop {u} : ground_quotable (@is_usprop u) := ltac:(cbv [is_usprop]; exact _). +#[export] Instance quote_is_uproplevel {u} : ground_quotable (@is_uproplevel u) := ltac:(cbv [is_uproplevel]; exact _). +#[export] Instance quote_is_uproplevel_or_set {u} : ground_quotable (@is_uproplevel_or_set u) := ltac:(cbv [is_uproplevel_or_set]; exact _). +#[export] Instance quote_is_utype {u} : ground_quotable (@is_utype u) := ltac:(cbv [is_utype]; exact _). + +#[export] Instance quote_allowed_eliminations : ground_quotable allowed_eliminations := ltac:(destruct 1; exact _). +#[export] Instance quote_is_allowed_elimination_cuniv {allowed u} : ground_quotable (is_allowed_elimination_cuniv allowed u) := ltac:(destruct allowed; cbv [is_allowed_elimination_cuniv]; exact _). + +Module QuoteUniverses2. + Module Import Universe. + #[export] Instance quote_t_ : ground_quotable Universe.t_ := ltac:(destruct 1; exact _). + #[export] Hint Unfold Universe.t : quotation. + #[export] Typeclasses Transparent Universe.t. + #[local] Hint Constructors or eq : typeclass_instances. + #[export] Instance quote_on_sort {P def s} {quoteP : forall l, s = Universe.lType l -> ground_quotable (P l:Prop)} {quote_def : s = Universe.lProp \/ s = Universe.lSProp -> ground_quotable (def:Prop)} : ground_quotable (@Universe.on_sort P def s) := ltac:(cbv [Universe.on_sort]; exact _). + End Universe. + Export (hints) Universe. + + Module Import ConstraintType. + #[export] Instance quote_t_ : ground_quotable ConstraintType.t_ := ltac:(destruct 1; exact _). + #[export] Hint Unfold ConstraintType.t : quotation. + #[export] Typeclasses Transparent ConstraintType.t. + #[export] Instance quote_lt_ {x y} : ground_quotable (ConstraintType.lt_ x y). + Proof. + destruct x, y; + solve [ intro pf; exfalso; inversion pf + | adjust_ground_quotable_by_econstructor_inversion () ]. + Defined. + #[export] Hint Unfold ConstraintType.lt : quotation. + End ConstraintType. + Export (hints) ConstraintType. + + Module Import UnivConstraint. + #[export] Hint Unfold UnivConstraint.t : quotation. + #[export] Typeclasses Transparent UnivConstraint.t. + #[export] Instance quote_lt_ {x y} : ground_quotable (UnivConstraint.lt_ x y) + := ground_quotable_of_dec (@ConstraintSet.Raw.MX.lt_dec x y). + #[export] Hint Unfold UnivConstraint.lt : quotation. + End UnivConstraint. + Export (hints) UnivConstraint. + + Module Import Variance. + #[export] Instance quote_t : ground_quotable Variance.t := ltac:(destruct 1; exact _). + End Variance. + Export (hints) Variance. +End QuoteUniverses2. +Export (hints) QuoteUniverses2. + +#[export] Instance quote_declared_cstr_levels {levels cstr} : ground_quotable (declared_cstr_levels levels cstr) := ltac:(cbv [declared_cstr_levels]; exact _). +#[export] Instance quote_universes_decl : ground_quotable universes_decl := ltac:(destruct 1; exact _). +#[export] Instance quote_satisfies0 {v s} {qv : quotation_of v} : ground_quotable (@satisfies0 v s) + := ground_quotable_of_iff (iff_sym (@uGraph.gc_of_constraint_spec config.default_checker_flags v s)). +#[export] Instance quote_satisfies {v s} {qv : quotation_of v} : ground_quotable (@satisfies v s) + := ground_quotable_of_iff (iff_sym (@uGraph.gc_of_constraints_spec config.default_checker_flags v s)). +#[export] Instance quote_consistent {ctrs} : ground_quotable (@consistent ctrs) + := ground_quotable_of_dec (@consistent_dec ctrs). +#[export] Instance quote_consistent_extension_on {cs cstr} : ground_quotable (@consistent_extension_on cs cstr) + := ground_quotable_of_dec (@consistent_extension_on_dec cs cstr). +#[export] Instance quote_leq_levelalg_n {cf n ϕ u u'} : ground_quotable (@leq_levelalg_n cf (uGraph.Z_of_bool n) ϕ u u') + := ground_quotable_of_dec (@leq_levelalg_n_dec cf _ ϕ u u'). +#[export] Instance quote_leq_universe_n_ {cf CS leq_levelalg_n n ϕ s s'} {quote_leq_levelalg_n : forall u u', ground_quotable (leq_levelalg_n n ϕ u u':Prop)} : ground_quotable (@leq_universe_n_ cf CS leq_levelalg_n n ϕ s s') := ltac:(cbv [leq_universe_n_]; exact _). +#[export] Instance quote_leq_universe_n {cf n ϕ s s'} : ground_quotable (@leq_universe_n cf (uGraph.Z_of_bool n) ϕ s s') := ltac:(cbv [leq_universe_n]; exact _). +#[export] Instance quote_leq_universe {cf ϕ s s'} : ground_quotable (@leq_universe cf ϕ s s') := @quote_leq_universe_n cf false ϕ s s'. +#[export] Instance quote_eq_levelalg {cf ϕ u u'} : ground_quotable (@eq_levelalg cf ϕ u u') + := ground_quotable_of_dec (@eq_levelalg_dec cf ϕ u u'). +#[export] Instance quote_eq_universe_ {CS eq_levelalg ϕ s s'} {quote_eq_levelalg : forall u u', ground_quotable (eq_levelalg ϕ u u':Prop)} : ground_quotable (@eq_universe_ CS eq_levelalg ϕ s s') := ltac:(cbv [eq_universe_]; exact _). +#[export] Instance quote_eq_universe {cf ϕ s s'} : ground_quotable (@eq_universe cf ϕ s s') := ltac:(cbv [eq_universe]; exact _). +#[export] Instance quote_compare_universe {cf pb ϕ u u'} : ground_quotable (@compare_universe cf pb ϕ u u') := ltac:(destruct pb; cbv [compare_universe]; exact _). +#[export] Instance quote_valid_constraints0 {ϕ ctrs} : ground_quotable (@valid_constraints0 ϕ ctrs) + := ground_quotable_of_dec (@valid_constraints0_dec ϕ ctrs). +#[export] Instance quote_valid_constraints {cf ϕ ctrs} : ground_quotable (@valid_constraints cf ϕ ctrs) + := ground_quotable_of_dec (@valid_constraints_dec cf ϕ ctrs). +#[export] Instance quote_is_lSet {cf φ s} : ground_quotable (@is_lSet cf φ s) := ltac:(cbv [is_lSet]; exact _). +#[export] Instance quote_is_allowed_elimination {cf ϕ allowed u} : ground_quotable (@is_allowed_elimination cf ϕ allowed u) + := ground_quotable_of_dec (@is_allowed_elimination_dec cf ϕ allowed u). + +#[export] Instance quote_universes_entry : ground_quotable universes_entry := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Common/config.v b/quotation/theories/ToTemplate/Common/config.v new file mode 100644 index 000000000..7a4182d0f --- /dev/null +++ b/quotation/theories/ToTemplate/Common/config.v @@ -0,0 +1,4 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Common Require Import config. + +#[export] Instance quote_checker_flags : ground_quotable checker_flags := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Coq/Bool.v b/quotation/theories/ToTemplate/Coq/Bool.v new file mode 100644 index 000000000..c98868e31 --- /dev/null +++ b/quotation/theories/ToTemplate/Coq/Bool.v @@ -0,0 +1,5 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From Coq.Bool Require Import Bool IfProp. + +#[export] Instance quote_reflect {P : Prop} {qP : quotation_of P} {quoteP : ground_quotable P} {quote_negP : ground_quotable (~P)} {b} : ground_quotable (reflect P b) := ltac:(destruct 1; exact _). +#[export] Instance quote_IfProp {A B : Prop} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {b} : ground_quotable (IfProp A B b) := ltac:(destruct b; adjust_ground_quotable_by_econstructor_inversion ()). diff --git a/quotation/theories/ToTemplate/Coq/FSets.v b/quotation/theories/ToTemplate/Coq/FSets.v new file mode 100644 index 000000000..34bb5bd48 --- /dev/null +++ b/quotation/theories/ToTemplate/Coq/FSets.v @@ -0,0 +1,209 @@ +From Coq Require Import Structures.Equalities Structures.OrdersAlt FMapInterface FMapList FMapAVL FMapFullAVL FMapFacts. +From MetaCoq.Utils Require Import MCUtils. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Numbers Coq.Init Coq.Lists. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import OrdersAlt.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.FSets Require Import FMapInterface.Sig FMapFacts.Sig FMapAVL.Sig FMapList.Sig. + +#[export] Hint Unfold Int.Z_as_Int.t : quotation. + +Module QuoteWSfun (E : DecidableTypeOrig) (Import W : WSfun E) (Import WFacts : WFacts_funSig E W) (qE : QuotationOfDecidableTypeOrig E) (qW : QuotationOfWSfun E W) (qWFacts : QuotationOfWFacts_fun E W WFacts). + Import (hints) qE qW qWFacts. + #[export] Hint Unfold Int.Z_as_Int.t : quotation. + + Section with_quote. + Context {elt : Type} + {qelt : quotation_of elt}. + + #[export] Instance quote_MapsTo {x y z} {qx : quotation_of x} {qy : quotation_of y} {qz : quotation_of z} : ground_quotable (@MapsTo elt x y z) + := ground_quotable_of_iff (iff_sym (@find_mapsto_iff _ _ _ _)). + #[export] Instance quote_In {k m} {qk : quotation_of k} {qm : quotation_of m} : ground_quotable (@In elt k m) + := ground_quotable_of_iff (iff_sym (@mem_in_iff _ _ _)). + #[export] Instance quote_neg_In {k m} {qk : quotation_of k} {qm : quotation_of m} : ground_quotable (~@In elt k m) + := quote_neg_of_iff (iff_sym (@mem_in_iff _ _ _)). + + #[export] Instance quote_Empty {m} {qm : quotation_of m} : ground_quotable (@Empty elt m) + := ground_quotable_of_iff (iff_sym (@is_empty_iff _ _)). + #[export] Instance quote_neg_Empty {m} {qm : quotation_of m} : ground_quotable (~@Empty elt m) + := quote_neg_of_iff (iff_sym (@is_empty_iff _ _)). + + Definition Equiv_alt (eq_elt : elt -> elt -> Prop) m m' := + let eq_opt_elt x y := match x, y with + | Some x, Some y => eq_elt x y + | None, None => True + | Some _, None | None, Some _ => False + end in + List.Forall (fun '(k, _) => eq_opt_elt (find k m) (find k m')) (@elements elt m) + /\ List.Forall (fun '(k, _) => eq_opt_elt (find k m) (find k m')) (@elements elt m'). + Import StrongerInstances. + Lemma Equiv_alt_iff {eq_elt m m'} : Equiv_alt eq_elt m m' <-> Equiv eq_elt m m'. + Proof using Type. + cbv [Equiv Equiv_alt]. + cbv [In] in *. + setoid_rewrite find_mapsto_iff. + rewrite !Forall_forall. + pose proof (@find_o elt m). + pose proof (@find_o elt m'). + transitivity + (let eq_opt_elt x y := match x, y with + | Some x, Some y => eq_elt x y + | None, None => True + | Some _, None | None, Some _ => False + end in + (forall k, In k m -> eq_opt_elt (find k m) (find k m')) + /\ (forall k, In k m' -> eq_opt_elt (find k m) (find k m'))). + 1: cbv [In]; setoid_rewrite elements_mapsto_iff; setoid_rewrite InA_alt; cbv [eq_key_elt]; cbn [fst snd]. + 2: cbv [In]; setoid_rewrite find_mapsto_iff. + all: repeat (split || intros || destruct_head'_and || split_iff || destruct_head'_prod || destruct_head'_ex || subst). + all: specialize_dep_under_binders_by eapply ex_intro. + all: specialize_dep_under_binders_by eapply conj. + all: specialize_dep_under_binders_by eapply eq_refl. + all: specialize_dep_under_binders_by eapply pair. + all: cbn [fst snd] in *. + all: specialize_all_ways_under_binders_by apply E.eq_refl. + all: repeat first [ progress destruct_head'_ex + | match goal with + | [ H : List.In _ _ |- _ ] + => progress specialize_under_binders_by exact H + | [ H : E.eq _ _ |- _ ] + => progress specialize_under_binders_by exact H + | [ H : find _ _ = Some _ |- _ ] + => progress specialize_under_binders_by exact H + end ]. + all: try solve [ repeat destruct ?; subst; try congruence; eauto ]. + Qed. + + #[export] Instance quote_Equiv_alt {eq_elt} {m m'} {qeq_elt : quotation_of eq_elt} {quote_elt : ground_quotable elt} {quote_key : ground_quotable key} {quote_eq_elt : forall x y, ground_quotable (eq_elt x y:Prop)} {qm : quotation_of m} {qm' : quotation_of m'} : ground_quotable (@Equiv_alt eq_elt m m') := ltac:(cbv [Equiv_alt]; exact _). + #[local] Instance qEquiv_alt : quotation_of (@Equiv_alt) := ltac:(unfold_quotation_of (); exact _). + (* too slow :-( *) + (*#[local] Instance qEquiv_alt_iff : quotation_of (@Equiv_alt_iff) := ltac:(unfold_quotation_of (); exact _).*) + + #[export] Instance quote_Equiv {qEquiv_alt_iff : quotation_of (@Equiv_alt_iff)} {qEquiv_alt_iff : quotation_of (@Equiv_alt_iff)} {eq_elt m m'} {qm : quotation_of m} {qm' : quotation_of m'} {quote_elt : ground_quotable elt} {quote_key : ground_quotable key} {qeq_elt : quotation_of eq_elt} {quote_eq_elt : forall x y, ground_quotable (eq_elt x y:Prop)} : ground_quotable (@Equiv elt eq_elt m m') := ground_quotable_of_iff Equiv_alt_iff. + + #[export] Instance quote_Equal {qEquiv_alt_iff : quotation_of (@Equiv_alt_iff)} {m m'} {qm : quotation_of m} {qm' : quotation_of m'} {quote_elt : ground_quotable elt} {quote_key : ground_quotable key} : ground_quotable (@Equal elt m m') := ground_quotable_of_iff (iff_sym (@Equal_Equiv elt m m')). + + #[export] Instance quote_Equivb {qEquiv_alt_iff : quotation_of (@Equiv_alt_iff)} {cmp m m'} {qm : quotation_of m} {qm' : quotation_of m'} {quote_elt : ground_quotable elt} {quote_key : ground_quotable key} {qcmp : quotation_of cmp} : ground_quotable (@Equivb elt cmp m m') := ltac:(cbv [Equivb Cmp]; exact _). + End with_quote. + + #[export] Existing Instances + quote_MapsTo + quote_In + quote_neg_In + quote_Empty + quote_neg_Empty + quote_Equiv_alt + quote_Equiv + quote_Equal + quote_Equivb + . + #[export] Typeclasses Opaque + In + Empty + Equiv_alt + Equiv + Equal + Equivb + . +End QuoteWSfun. + +Module QuoteFMapAVL (T : OrderedTypeOrig) (M : FMapAVL.MakeSig T) (Import WFacts : WFacts_funSig T M) (qT : QuotationOfOrderedTypeOrig T) (qM : FMapAVL.QuotationOfMake T M) (qWFacts : QuotationOfWFacts_fun T M WFacts). + Import (hints) qT qM qWFacts. + Include QuoteWSfun T M WFacts qT qM qWFacts. + + Module Raw. + Scheme Induction for M.Raw.tree Sort Type. + Scheme Induction for M.Raw.tree Sort Set. + Scheme Induction for M.Raw.tree Sort Prop. + Scheme Case for M.Raw.tree Sort Type. + Scheme Case for M.Raw.tree Sort Prop. + Scheme Minimality for M.Raw.tree Sort Type. + Scheme Minimality for M.Raw.tree Sort Set. + Scheme Minimality for M.Raw.tree Sort Prop. + + Section with_t. + Context {elt : Type} + {qelt : quotation_of elt} + {quote_elt : ground_quotable elt} {quote_T_t : ground_quotable T.t}. + + Fixpoint lt_tree_dec x t : { @M.Raw.lt_tree elt x t } + {~ @M.Raw.lt_tree elt x t}. + Proof. + refine match t with + | M.Raw.Leaf => left _ + | M.Raw.Node l k n r z + => match T.compare k x, lt_tree_dec x l, lt_tree_dec x r with + | LT p1, left p2, left p3 => left _ + | _, right pf, _ => right _ + | _, _, right pf => right _ + | _, _, _ => right _ + end + end; + try solve [ inversion 1 + | inversion 1; subst; auto; + match goal with + | [ H : T.lt _ _, H' : T.eq _ _ |- _ ] + => now first [ rewrite -> H' in H | rewrite <- H' in H ] + end + | intro f; apply pf; hnf in *; intros; apply f; constructor; (assumption + reflexivity) + | intro f; eapply M.Raw.Proofs.MX.lt_antirefl; (idtac + etransitivity); (eassumption + (eapply f; constructor; (idtac + symmetry); (eassumption + reflexivity))) ]. + Defined. + Fixpoint gt_tree_dec x t : { @M.Raw.gt_tree elt x t } + {~ @M.Raw.gt_tree elt x t}. + Proof. + refine match t with + | M.Raw.Leaf => left _ + | M.Raw.Node l k n r z + => match T.compare k x, gt_tree_dec x l, gt_tree_dec x r with + | GT p1, left p2, left p3 => left _ + | _, right pf, _ => right _ + | _, _, right pf => right _ + | _, _, _ => right _ + end + end; + try solve [ inversion 1 + | inversion 1; subst; auto; + match goal with + | [ H : T.lt _ _, H' : T.eq _ _ |- _ ] + => now first [ rewrite -> H' in H | rewrite <- H' in H ] + end + | intro f; apply pf; hnf in *; intros; apply f; constructor; (assumption + reflexivity) + | intro f; eapply M.Raw.Proofs.MX.lt_antirefl; (idtac + etransitivity); (eassumption + (eapply f; constructor; (idtac + symmetry); (eassumption + reflexivity))) ]. + Defined. + Fixpoint bst_dec t : { @M.Raw.bst elt t } + {~ @M.Raw.bst elt t}. + Proof. + refine match t with + | M.Raw.Leaf => left _ + | M.Raw.Node l k n r z + => match bst_dec l, bst_dec r, lt_tree_dec k l, gt_tree_dec k r with + | right pf, _, _, _ => right _ + | _, right pf, _, _ => right _ + | _, _, right pf, _ => right _ + | _, _, _, right pf => right _ + | left p1, left p2, left p3, left p4 => left _ + end + end; + try solve [ constructor; assumption + | inversion 1; subst; auto ]. + Defined. + #[local] Hint Unfold M.Raw.key : quotation. + #[export] Instance quote_tree : ground_quotable (M.Raw.tree elt) := (ltac:(induction 1; exact _)). + (* very slow :-( *) + #[local] Instance qlt_tree_dec : quotation_of (@lt_tree_dec) := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qgt_tree_dec : quotation_of (@gt_tree_dec) := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qbst_dec : quotation_of (@bst_dec) := ltac:(unfold_quotation_of (); exact _). + #[export] Instance quote_bst t : ground_quotable (M.Raw.bst t) + := ground_quotable_of_dec (@bst_dec t). + End with_t. + #[export] Hint Unfold M.Raw.key : quotation. + #[export] Existing Instances + quote_bst + . + End Raw. + Export (hints) Raw. + + #[export] Hint Unfold M.t : quotation. + #[export] Typeclasses Transparent M.t. + #[export] Instance quote_bst + {elt : Type} + {qelt : quotation_of elt} + {quote_elt : ground_quotable elt} {quote_T_t : ground_quotable T.t} + : ground_quotable (M.bst elt) := (ltac:(induction 1; exact _)). +End QuoteFMapAVL. diff --git a/quotation/theories/ToTemplate/Coq/Floats.v b/quotation/theories/ToTemplate/Coq/Floats.v new file mode 100644 index 000000000..a74518aa3 --- /dev/null +++ b/quotation/theories/ToTemplate/Coq/Floats.v @@ -0,0 +1,11 @@ +From Coq.Floats Require Import FloatClass Floats PrimFloat SpecFloat. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.Numbers. + +#[export] Instance quote_float : ground_quotable float := Ast.tFloat. +#[export] Instance quote_float_class : ground_quotable float_class := ltac:(destruct 1; exact _). +#[export] Instance quote_float_comparison : ground_quotable float_comparison := ltac:(destruct 1; exact _). +#[export] Instance quote_float_wrapper : ground_quotable float_wrapper := ltac:(destruct 1; exact _). +#[export] Instance quote_spec_float : ground_quotable spec_float := ltac:(destruct 1; exact _). +#[export] Instance quote_location : ground_quotable location := ltac:(destruct 1; exact _). +#[export] Instance quote_shr_record : ground_quotable shr_record := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Coq/Init.v b/quotation/theories/ToTemplate/Coq/Init.v new file mode 100644 index 000000000..933e5aa79 --- /dev/null +++ b/quotation/theories/ToTemplate/Coq/Init.v @@ -0,0 +1,114 @@ +Require Import Coq.Lists.List. +From MetaCoq.Quotation.ToTemplate Require Export Init. +From MetaCoq.Utils Require Export bytestring. (* for display of quoted objects *) +From MetaCoq.Utils Require Export ReflectEq. +From MetaCoq.Utils Require Import All_Forall. +Require Import Equations.Prop.Classes. +Import ListNotations. + +Export Quotation.ToTemplate.Init.Instances. + +#[export] Instance quote_True : ground_quotable True := ltac:(destruct 1; exact _). +#[export] Instance quote_False : ground_quotable False := ltac:(destruct 1; exact _). +#[export] Instance quote_byte : ground_quotable Byte.byte := ltac:(destruct 1; exact _). +#[export] Instance quote_Empty_set : ground_quotable Empty_set := ltac:(destruct 1; exact _). +#[export] Instance quote_unit : ground_quotable unit := ltac:(destruct 1; exact _). +#[export] Instance quote_bool : ground_quotable bool := ltac:(destruct 1; exact _). + +#[export] Instance quote_eq {A} {qA : quotation_of A} {quoteA : ground_quotable A} {x y : A} : ground_quotable (x = y :> A) := ltac:(intros []; exact _). +#[export] Instance quote_eq_refl_l {A} {qA : quotation_of A} {x y : A} {qx : quotation_of x} : ground_quotable (x = y :> A) := ltac:(intros []; exact _). +#[export] Instance quote_eq_refl_r {A} {qA : quotation_of A} {x y : A} {qy : quotation_of y} : ground_quotable (x = y :> A) := ltac:(intro; subst; exact _). + +#[export] Typeclasses Opaque not. + +#[export] Hint Unfold is_true : quotation. +#[export] Hint Unfold lt : quotation. +#[export] Hint Unfold PeanoNat.Nat.lt : quotation. + +#[export] Instance quote_eq_true {b} : ground_quotable (eq_true b) := ltac:(destruct 1; exact _). +#[export] Instance quote_BoolSpec {P Q : Prop} {b} {qP : quotation_of P} {qQ : quotation_of Q} {quoteP : ground_quotable P} {quoteQ : ground_quotable Q} : ground_quotable (BoolSpec P Q b). +Proof. + destruct b; adjust_ground_quotable_by_econstructor_inversion (). +Defined. +#[export] Instance quote_nat : ground_quotable nat := ltac:(induction 1; exact _). +#[export] Polymorphic Instance quote_option {A} {qA : quotation_of A} {quoteA : ground_quotable A} : ground_quotable (option A) := (ltac:(induction 1; exact _)). +#[export] Polymorphic Instance quote_sum {A B} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} : ground_quotable (sum A B) := (ltac:(induction 1; exact _)). +#[export] Polymorphic Instance quote_prod {A B} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} : ground_quotable (prod A B) := (ltac:(induction 1; exact _)). +#[export] Polymorphic Instance quote_list {A} {qA : quotation_of A} {quoteA : ground_quotable A} : ground_quotable (list A) := (ltac:(induction 1; exact _)). +#[export] Polymorphic Instance quotation_of_list {A ls} {qA : quotation_of A} {qls : @All A quotation_of ls} : quotation_of ls := ltac:(induction qls; exact _). +#[export] Instance quote_comparison : ground_quotable comparison := ltac:(destruct 1; exact _). +#[export] Instance quote_CompareSpec {Peq Plt Pgt : Prop} {qPeq : quotation_of Peq} {qPlt : quotation_of Plt} {qPgt : quotation_of Pgt} {quote_Peq : ground_quotable Peq} {quote_Plt : ground_quotable Plt} {quote_Pgt : ground_quotable Pgt} {c} : ground_quotable (CompareSpec Peq Plt Pgt c). +Proof. + destruct c; adjust_ground_quotable_by_econstructor_inversion (). +Defined. +#[export] Instance quote_CompareSpecT {Peq Plt Pgt : Prop} {qPeq : quotation_of Peq} {qPlt : quotation_of Plt} {qPgt : quotation_of Pgt} {quote_Peq : ground_quotable Peq} {quote_Plt : ground_quotable Plt} {quote_Pgt : ground_quotable Pgt} {c} : ground_quotable (CompareSpecT Peq Plt Pgt c) := ltac:(destruct 1; exact _). +(* Work around masking-absolute-name warning *) +Module Export Init. + Module Decimal. + #[export] Instance quote_uint : ground_quotable Decimal.uint := ltac:(induction 1; exact _). + #[export] Instance quote_neq_uint {x y} : ground_quotable (x <> y :> Decimal.uint) := ground_quotable_neg_of_dec (@Decimal.uint_eq_dec x y). + End Decimal. + #[export] Existing Instances Decimal.quote_uint Decimal.quote_neq_uint. + Module Hexadecimal. + #[export] Instance quote_uint : ground_quotable Hexadecimal.uint := ltac:(induction 1; exact _). + #[export] Instance quote_neq_uint {x y} : ground_quotable (x <> y :> Hexadecimal.uint) := ground_quotable_neg_of_dec (@Hexadecimal.uint_eq_dec x y). + End Hexadecimal. + #[export] Existing Instances Hexadecimal.quote_uint Hexadecimal.quote_neq_uint. + Module Number. + #[export] Instance quote_uint : ground_quotable Number.uint := ltac:(induction 1; exact _). + #[export] Instance quote_neq_uint {x y} : ground_quotable (x <> y :> Number.uint) := ground_quotable_neg_of_dec (@Number.uint_eq_dec x y). + End Number. + #[export] Existing Instances Number.quote_uint Number.quote_neq_uint. +End Init. +#[export] Instance quote_and {A B : Prop} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} : ground_quotable (A /\ B) := (ltac:(destruct 1; exact _)). + +#[export] Instance quote_le {n m} : ground_quotable (le n m) := ground_quotable_of_dec (Compare_dec.le_dec n m). + +#[export] Polymorphic Instance quote_sig {A} {P : A -> Prop} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall x, quotation_of x -> ground_quotable (P x)} : ground_quotable (@sig A P) := (ltac:(induction 1; exact _)). +#[export] Polymorphic Instance quote_sig2 {A} {P Q : A -> Prop} {qA : quotation_of A} {qP : quotation_of P} {qQ : quotation_of Q} {quoteA : ground_quotable A} {quoteP : forall x, quotation_of x -> ground_quotable (P x)} {quoteQ : forall x, quotation_of x -> ground_quotable (Q x)} : ground_quotable (@sig2 A P Q) := (ltac:(induction 1; exact _)). +#[export] Polymorphic Instance quote_sigT {A P} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall x, quotation_of x -> ground_quotable (P x)} : ground_quotable (@sigT A P) := (ltac:(induction 1; exact _)). +#[export] Polymorphic Instance quote_sigT2 {A} {P Q} {qA : quotation_of A} {qP : quotation_of P} {qQ : quotation_of Q} {quoteA : ground_quotable A} {quoteP : forall x, quotation_of x -> ground_quotable (P x)} {quoteQ : forall x, quotation_of x -> ground_quotable (Q x)} : ground_quotable (@sigT2 A P Q) := (ltac:(induction 1; exact _)). +#[export] Instance quote_sumbool {A B : Prop} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} : ground_quotable (sumbool A B) := ltac:(destruct 1; exact _). +#[export] Instance quote_sumor {A} {B : Prop} {qA : quotation_of A} {qB : quotation_of B} {quoteA : ground_quotable A} {quoteB : ground_quotable B} : ground_quotable (sumor A B) := ltac:(destruct 1; exact _). + +Definition quote_or_dec_l {P Q : Prop} (decP : {P} + {~P}) {qP : quotation_of P} {qQ : quotation_of Q} {quoteP : ground_quotable P} {quoteQ : ground_quotable Q} : ground_quotable (or P Q). +Proof. + destruct decP. + all: intro pf; adjust_quotation_of_by_econstructor_then ltac:(fun _ => destruct pf; first [ eassumption | tauto ]) ltac:(fun _ => exact _). +Defined. +Definition quote_or_dec_r {P Q : Prop} (decQ : {Q} + {~Q}) {qP : quotation_of P} {qQ : quotation_of Q} {quoteP : ground_quotable P} {quoteQ : ground_quotable Q} : ground_quotable (or P Q). +Proof. + destruct decQ. + all: intro pf; adjust_quotation_of_by_econstructor_then ltac:(fun _ => destruct pf; first [ eassumption | tauto ]) ltac:(fun _ => exact _). +Defined. + +(* These are not possible *) +(* +#[export] Instance quote_or : ground_quotable or := ltac:(destruct 1; exact _). (A B:Prop) : Prop := +#[export] Instance quote_ex : ground_quotable ex := ltac:(destruct 1; exact _). (A:Type) (P:A -> Prop) : Prop := +#[export] Instance quote_ex2 : ground_quotable ex2 := ltac:(destruct 1; exact _). (A:Type) (P Q:A -> Prop) : Prop := +#[export] Instance quote_inhabited : ground_quotable inhabited := ltac:(destruct 1; exact _). (A:Type) : Prop := inhabits : A -> inhabited A. +*) + +#[export] Instance quote_neq_True {x y : True} : ground_quotable (x <> y). +Proof. destruct x, y; intro; exfalso; congruence. Defined. +#[export] Instance quote_neq_False {x y : False} : ground_quotable (x <> y) := ltac:(destruct x). +#[export] Instance quote_neq_byte {x y} : ground_quotable (x <> y :> Byte.byte) := ground_quotable_neg_of_dec (@Byte.byte_eq_dec x y). +#[export] Instance quote_neq_Empty_set {x y : Empty_set} : ground_quotable (x <> y) := ltac:(destruct x). +#[export] Instance quote_neq_unit {x y : unit} : ground_quotable (x <> y). +Proof. destruct x, y; intro; exfalso; congruence. Defined. +#[export] Instance quote_neq_bool {x y} : ground_quotable (x <> y :> bool) := ground_quotable_neg_of_dec (@Bool.bool_dec x y). +#[export] Instance quote_neq_nat {x y} : ground_quotable (x <> y :> nat) := ground_quotable_neg_of_dec (@PeanoNat.Nat.eq_dec x y). +Scheme Equality for comparison. +#[export] Instance quote_neq_comparison {x y} : ground_quotable (x <> y :> comparison) := ground_quotable_neg_of_dec (@comparison_eq_dec x y). + +#[export] Instance quote_nle {n m} : ground_quotable (~le n m) := ground_quotable_neg_of_dec (Compare_dec.le_dec n m). + +Definition option_eq_None_dec_r {A} {l : option A} : {l = None} + {l <> None}. +Proof. destruct l; [ right | left ]; try reflexivity; congruence. Defined. +Definition option_eq_None_dec_l {A} {l : option A} : {None = l} + {None <> l}. +Proof. destruct l; [ right | left ]; try reflexivity; congruence. Defined. +#[export] Instance quote_option_neq_None_r {A} {qA : quotation_of A} (l : option A) {ql : quotation_of l} : ground_quotable (l <> None) + := ground_quotable_neg_of_dec option_eq_None_dec_r. +#[export] Instance quote_option_neq_None_l {A} {qA : quotation_of A} (l : option A) {ql : quotation_of l} : ground_quotable (None <> l) + := ground_quotable_neg_of_dec option_eq_None_dec_l. diff --git a/quotation/theories/ToTemplate/Coq/Lists.v b/quotation/theories/ToTemplate/Coq/Lists.v new file mode 100644 index 000000000..a360203e4 --- /dev/null +++ b/quotation/theories/ToTemplate/Coq/Lists.v @@ -0,0 +1,63 @@ +Require Import Coq.Lists.List. +Require Import Coq.Lists.ListDec. +From MetaCoq.Utils Require Import ReflectEq. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init. +From Equations.Prop Require Import Classes. +Import ListNotations. +Local Open Scope list_scope. + +(* not decidable *) +(* +#[export] Instance quote_Add {A a ls1 ls2} {qA : quotation_of A} {quoteA : ground_quotable A} : ground_quotable (@Add A a ls1 ls2) := ltac:(destruct 1; exact _). (a:A) : list A -> list A -> Prop := +#[export] Instance quote_NoDup {A} {qA : quotation_of A} {quoteA : ground_quotable A} {quote_neg_In : forall (a : A) ls, ground_quotable (~In a ls)} {ls} : ground_quotable (@NoDup A ls). +Proof. + induction ls; adjust_ground_quotable_by_econstructor_inversion (). +Defined. +#[export] Instance quote_Exists : ground_quotable Exists := ltac:(destruct 1; exact _). : list A -> Prop := + *) +#[export] Instance quote_Forall {A R ls} {qA : quotation_of A} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteR : forall x, ground_quotable (R x:Prop)} : ground_quotable (@Forall A R ls). +Proof. + induction ls as [|a ls IH]. + all: adjust_ground_quotable_by_econstructor_inversion (). +Defined. +#[export] Instance quote_Forall2 {A B R lsA lsB} {qA : quotation_of A} {qB : quotation_of B} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@Forall2 A B R lsA lsB). +Proof. + revert lsB; induction lsA as [|a lsA IH], lsB as [|b lsB]. + all: try solve [ intro pf; exfalso; inversion pf ]. + all: adjust_ground_quotable_by_econstructor_inversion (). +Defined. +#[export] Instance quote_ForallOrdPairs {A R ls} {qA : quotation_of A} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@ForallOrdPairs A R ls). +Proof. + induction ls as [|a ls IH]. + all: adjust_ground_quotable_by_econstructor_inversion (). +Defined. +#[export] Instance quote_eqlistA {A R ls1 ls2} {qA : quotation_of A} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@SetoidList.eqlistA A R ls1 ls2). +Proof. + revert ls2; induction ls1 as [|a ls1 IH], ls2 as [|b ls2]. + all: try solve [ intro pf; exfalso; inversion pf ]. + all: adjust_ground_quotable_by_econstructor_inversion (). +Defined. +(* +#[export] Instance quote_PermutationA : ground_quotable PermutationA := ltac:(destruct 1; exact _). : list A -> list A -> Prop := + *) +(* +#[export] Instance quote_memo_val : ground_quotable memo_val := ltac:(destruct 1; exact _). {A : nat -> Type} : Type := +Co#[export] Instance quote_Stream : ground_quotable Stream := ltac:(destruct 1; exact _). (A : Type) := +Co#[export] Instance quote_EqSt : ground_quotable EqSt := ltac:(destruct 1; exact _). (s1 s2: Stream) : Prop := +#[export] Instance quote_Exists : ground_quotable Exists := ltac:(destruct 1; exact _). : Stream -> Prop := +#[export] Instance quote_Exists : ground_quotable Exists := ltac:(destruct 1; exact _). ( x: Stream ) : Prop := +Co#[export] Instance quote_ForAll : ground_quotable ForAll := ltac:(destruct 1; exact _). (x: Stream) : Prop := +*) + +Definition list_eq_nil_dec_r {A} {l : list A} : {l = []} + {l <> []}. +Proof. destruct l; [ left | right ]; try reflexivity; congruence. Defined. +Definition list_eq_nil_dec_l {A} {l : list A} : {[] = l} + {[] <> l}. +Proof. destruct l; [ left | right ]; try reflexivity; congruence. Defined. +#[export] Instance quote_list_neq_nil_r {A} {qA : quotation_of A} (l : list A) {ql : quotation_of l} : ground_quotable (l <> []) + := ground_quotable_neg_of_dec list_eq_nil_dec_r. +#[export] Instance quote_list_neq_nil_l {A} {qA : quotation_of A} (l : list A) {ql : quotation_of l} : ground_quotable ([] <> l) + := ground_quotable_neg_of_dec list_eq_nil_dec_l. + +#[export] Instance quote_list_In {A x l} {decA : EqDec A} {qA : quotation_of A} {qx : quotation_of x} {ql : quotation_of l} {qdecA : quotation_of decA} : ground_quotable (@List.In A x l) + := ground_quotable_of_dec (in_dec decA _ _). diff --git a/quotation/theories/ToTemplate/Coq/MSets.v b/quotation/theories/ToTemplate/Coq/MSets.v new file mode 100644 index 000000000..818fccff5 --- /dev/null +++ b/quotation/theories/ToTemplate/Coq/MSets.v @@ -0,0 +1,289 @@ +From Coq Require Import MSetInterface MSetList MSetAVL MSetFacts MSetProperties MSetDecide. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Numbers Coq.Init Coq.Lists. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetInterface.Sig MSetProperties.Sig MSetAVL.Sig MSetList.Sig. + +#[export] Hint Unfold Int.Z_as_Int.t : quotation. + +Module QuoteWSetsOn (E : DecidableType) (Import W : WSetsOn E) (WProperties : WPropertiesOnSig E W) (qE : QuotationOfDecidableType E) (qW : QuotationOfWSetsOn E W) (qWProperties : QuotationOfWPropertiesOn E W WProperties). + Import (hints) qE qW qWProperties. + + #[export] Hint Unfold Int.Z_as_Int.t : quotation. + + #[export] Instance quote_In {x y} {qx : quotation_of x} {qy : quotation_of y} : ground_quotable (In x y) + := ground_quotable_of_dec (WProperties.In_dec x y). + #[export] Instance quote_neg_In {x y} {qx : quotation_of x} {qy : quotation_of y} : ground_quotable (~In x y) + := ground_quotable_neg_of_dec (WProperties.In_dec x y). + #[export] Instance quote_Equal {x y} {qx : quotation_of x} {qy : quotation_of y} : ground_quotable (Equal x y) + := ground_quotable_of_dec (eq_dec x y). + #[export] Typeclasses Opaque Equal. + #[export] Instance quote_neg_Equal {x y} {qx : quotation_of x} {qy : quotation_of y} : ground_quotable (~Equal x y) + := ground_quotable_neg_of_dec (eq_dec x y). + #[export] Instance quote_Subset {x y} {qx : quotation_of x} {qy : quotation_of y} : ground_quotable (Subset x y) := ground_quotable_of_iff (@subset_spec x y). + #[export] Typeclasses Opaque Subset. + #[export] Instance quote_neg_Subset {x y} {qx : quotation_of x} {qy : quotation_of y} : ground_quotable (~Subset x y) := quote_neg_of_iff (@subset_spec x y). + #[export] Instance quote_Empty {x} {qx : quotation_of x} : ground_quotable (Empty x) := ground_quotable_of_iff (conj (@WProperties.empty_is_empty_2 x) (@WProperties.empty_is_empty_1 x)). + #[export] Typeclasses Opaque Empty. + #[export] Instance quote_neg_Empty {x} {qx : quotation_of x} : ground_quotable (~Empty x) := quote_neg_of_iff (conj (@WProperties.empty_is_empty_2 x) (@WProperties.empty_is_empty_1 x)). + #[export] Instance quote_Add {x s s'} {qx : quotation_of x} {qs : quotation_of s} {qs' : quotation_of s'} : ground_quotable (WProperties.Add x s s') + := ground_quotable_of_iff (iff_sym (WProperties.Add_Equal _ _ _)). + #[export] Instance quote_neg_Add {x s s'} {qx : quotation_of x} {qs : quotation_of s} {qs' : quotation_of s'} : ground_quotable (~WProperties.Add x s s') + := quote_neg_of_iff (iff_sym (WProperties.Add_Equal _ _ _)). + Definition For_all_alt (P : elt -> Prop) (s : t) : Prop + := List.Forall P (elements s). + #[local] Hint Extern 1 (E.eq _ _) => reflexivity : core. + Lemma For_all_alt_iff {P} {P_Proper : Proper (E.eq ==> Basics.impl) P} {s} + : For_all_alt P s <-> For_all P s. + Proof using Type. + cbv [For_all_alt For_all]. + setoid_rewrite WProperties.FM.elements_iff. + induction (elements s) as [|x xs IH]. + { split; solve [ constructor | inversion 2 ]. } + { setoid_rewrite Forall_cons_iff; setoid_rewrite InA_cons; setoid_rewrite IH. + intuition auto. + eapply P_Proper; (idtac + symmetry); eassumption. } + Qed. + #[local] Instance qFor_all_alt : quotation_of For_all_alt := ltac:(cbv [For_all_alt]; exact _). + #[local] Instance qForall_all_iff : quotation_of (@For_all_alt_iff) := ltac:(unfold_quotation_of (); exact _). + #[export] Typeclasses Transparent elt. + #[export] Hint Unfold For_all_alt : quotation. + Definition quote_For_all {P s} {quote_elt : ground_quotable elt} {quote_P : forall x, ground_quotable (P x:Prop)} {qP : quotation_of P} {P_Proper : Proper (E.eq ==> Basics.impl) P} {qP_Proper : quotation_of P_Proper} {qs : quotation_of s} : ground_quotable (For_all P s) + := ground_quotable_of_iff For_all_alt_iff. + #[export] Typeclasses Opaque For_all. + Lemma For_all_forall_iff {P s} : (For_all P s) <-> (forall v, In v s -> P v). + Proof using Type. reflexivity. Qed. + Lemma For_all_forall2_iff {P s} : (For_all (fun v1 => For_all (P v1) s) s) <-> (forall v1 v2, In v1 s -> In v2 s -> P v1 v2). + Proof using Type. cbv [For_all]; intuition eauto. Qed. + #[local] Instance qFor_all_forall_iff : quotation_of (@For_all_forall_iff) := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qFor_all_forall2_iff : quotation_of (@For_all_forall2_iff) := ltac:(unfold_quotation_of (); exact _). + #[export] Instance quote_forall2_In {P s} {qP : quotation_of P} {qs : quotation_of s} {quote_For_all : ground_quotable (For_all (fun v1 => For_all (P v1) s) s)} : ground_quotable (forall v1 v2, In v1 s -> In v2 s -> P v1 v2) + := ground_quotable_of_iff For_all_forall2_iff. + + Definition Exists_alt (P : elt -> Prop) (s : t) : Prop + := List.Exists P (elements s). + Lemma Exists_alt_iff {P} {P_Proper : Proper (E.eq ==> Basics.impl) P} {s} + : Exists_alt P s <-> Exists P s. + Proof. + cbv [Exists_alt Exists]. + setoid_rewrite WProperties.FM.elements_iff. + induction (elements s) as [|x xs IH]. + { split; try solve [ constructor | inversion 1 | intros [x [H H']]; inversion H ]. } + { setoid_rewrite Exists_cons; setoid_rewrite InA_cons; setoid_rewrite IH. + firstorder intuition auto. } + Qed. + Definition Exists_dec {P s} (P_dec : forall x, {P x} + {~P x}) {P_Proper : Proper (E.eq ==> Basics.impl) P} : {Exists P s} + {~Exists P s}. + Proof. + destruct (List.Exists_dec P (elements s) P_dec) as [H|H]; [ left | right ]; revert H. + { intro H; apply Exists_alt_iff, H. } + { intros H H'; apply H, Exists_alt_iff, H'. } + Defined. + #[local] Instance qExists_alt : quotation_of (@Exists_alt) := ltac:(cbv [Exists_alt]; exact _). + #[local] Instance qExists_alt_iff : quotation_of (@Exists_alt_iff) := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qExists_dec : quotation_of (@Exists_dec) := ltac:(cbv [Exists_dec]; exact _). + + Definition quote_Exists_dec {P} (P_dec : forall x, {P x} + {~P x}) {s} {quote_elt : ground_quotable elt} {qP_dec : quotation_of P_dec} {quote_P : forall x, ground_quotable (P x:Prop)} {qP : quotation_of P} {P_Proper : Proper (E.eq ==> Basics.impl) P} {qP_Proper : quotation_of P_Proper} {qs : quotation_of s} : ground_quotable (Exists P s) + := ground_quotable_of_dec (Exists_dec P_dec). + #[export] Typeclasses Opaque Exists. + + #[export] Hint Extern 13 (ground_quotable (For_all _ _)) + => simple notypeclasses refine (@quote_For_all _ _ _ _ _ _ _ _) : typeclass_instances. + + #[export] Typeclasses Transparent W.elt. +End QuoteWSetsOn. + +Module Type QuoteWSetsOnSig (E : DecidableType) (W : WSetsOn E) (WProperties : WPropertiesOnSig E W) (qE : QuotationOfDecidableType E) (qW : QuotationOfWSetsOn E W) (qWProperties : QuotationOfWPropertiesOn E W WProperties) := Nop <+ QuoteWSetsOn E W WProperties qE qW qWProperties. + +Module QuoteOrdProperties (Import M : Sets) (Import MOrdProperties : OrdPropertiesSig M) (qE : QuotationOfOrderedType M.E) (qM : QuotationOfSets M) (qMOrdProperties : QuotationOfOrdProperties M MOrdProperties). + Import (hints) qE qM qMOrdProperties. + + Definition above x s : bool := for_all (fun y => if ME.lt_dec y x then true else false) s. + Definition below x s : bool := for_all (fun y => if ME.lt_dec x y then true else false) s. + Lemma above_spec x s : above x s = true <-> Above x s. + Proof. + cbv [Above above]. + rewrite for_all_spec + by (intros ?? H; repeat (let H' := fresh in destruct ME.lt_dec as [H'|H']; rewrite ?H in H'); try reflexivity; tauto). + cbv [For_all]. + split; intros H y H'; generalize (H y H'); destruct ME.lt_dec; try reflexivity; eauto; congruence. + Qed. + Lemma below_spec x s : below x s = true <-> Below x s. + Proof. + cbv [Below below]. + rewrite for_all_spec + by (intros ?? H; repeat (let H' := fresh in destruct ME.lt_dec as [H'|H']; rewrite ?H in H'); try reflexivity; tauto). + cbv [For_all]. + split; intros H y H'; generalize (H y H'); destruct ME.lt_dec; try reflexivity; eauto; congruence. + Qed. + #[local] Instance qabove : quotation_of above := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qAbove : quotation_of Above := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qbelow : quotation_of below := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qBelow : quotation_of Below := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qabove_spec : quotation_of above_spec := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qbelow_spec : quotation_of below_spec := ltac:(unfold_quotation_of (); exact _). + #[export] Instance quote_Above {x s} {qx : quotation_of x} {qs : quotation_of s} : ground_quotable (Above x s) + := ground_quotable_of_iff (above_spec x s). + #[export] Typeclasses Opaque Above. + #[export] Instance quote_Below {x s} {qx : quotation_of x} {qs : quotation_of s} : ground_quotable (Below x s) + := ground_quotable_of_iff (below_spec x s). + #[export] Typeclasses Opaque Below. +End QuoteOrdProperties. + +Module QuoteSets (Import M : Sets) (Import MOrdProperties : OrdPropertiesSig M) (qE : QuotationOfOrderedType M.E) (qM : QuotationOfSets M) (qMOrdProperties : QuotationOfOrdProperties M MOrdProperties). + Include QuoteWSetsOn M.E M MOrdProperties.P qE qM qMOrdProperties.qP. + Include QuoteOrdProperties M MOrdProperties qE qM qMOrdProperties. +End QuoteSets. + +Module QuoteMSetAVL (T : OrderedType) (M : MSetAVL.MakeSig T) (Import MOrdProperties : OrdPropertiesSig M) (Import qT : QuotationOfOrderedType T) (Import qM : MSetAVL.QuotationOfMake T M) (qMOrdProperties : QuotationOfOrdProperties M MOrdProperties). + Import (hints) qT qM qMOrdProperties. + Include QuoteSets M MOrdProperties qT qM qMOrdProperties. + + Module Raw. + Scheme Induction for M.Raw.tree Sort Type. + Scheme Induction for M.Raw.tree Sort Set. + Scheme Induction for M.Raw.tree Sort Prop. + Scheme Case for M.Raw.tree Sort Type. + Scheme Case for M.Raw.tree Sort Prop. + Scheme Minimality for M.Raw.tree Sort Type. + Scheme Minimality for M.Raw.tree Sort Set. + Scheme Minimality for M.Raw.tree Sort Prop. + + Section with_t. + Context {quote_T_t : ground_quotable T.t}. + + Fixpoint lt_tree_dec x t : { M.Raw.lt_tree x t } + {~ M.Raw.lt_tree x t}. + Proof. + refine match t with + | M.Raw.Leaf => left _ + | M.Raw.Node z l n r + => match T.compare n x as c, lt_tree_dec x l, lt_tree_dec x r return CompareSpec _ _ _ c -> _ with + | Lt, left p2, left p3 => fun pfc => left _ + | _, right pf, _ => fun pfc => right _ + | _, _, right pf => fun pfc => right _ + | _, _, _ => fun pfc => right _ + end (T.compare_spec _ _) + end; + try solve [ inversion 1; inversion pfc + | inversion 1; inversion pfc; subst; auto; + match goal with + | [ H : T.lt _ _, H' : T.eq _ _ |- _ ] + => now first [ rewrite -> H' in H | rewrite <- H' in H ] + end + | intro f; apply pf; hnf in *; intros; apply f; constructor; (assumption + reflexivity) + | intro f; inversion pfc; eapply M.Raw.MX.lt_irrefl; (idtac + etransitivity); (eassumption + (eapply f; constructor; (idtac + symmetry); (eassumption + reflexivity))) ]. + Defined. + Fixpoint gt_tree_dec x t : { M.Raw.gt_tree x t } + {~ M.Raw.gt_tree x t}. + Proof. + refine match t with + | M.Raw.Leaf => left _ + | M.Raw.Node z l n r + => match T.compare n x as c, gt_tree_dec x l, gt_tree_dec x r return CompareSpec _ _ _ c -> _ with + | Gt, left p2, left p3 => fun pfc => left _ + | _, right pf, _ => fun pfc => right _ + | _, _, right pf => fun pfc => right _ + | _, _, _ => fun pfc => right _ + end (T.compare_spec _ _) + end; + try solve [ inversion 1; inversion pfc + | inversion 1; inversion pfc; subst; auto; + match goal with + | [ H : T.lt _ _, H' : T.eq _ _ |- _ ] + => now first [ rewrite -> H' in H | rewrite <- H' in H ] + end + | intro f; apply pf; hnf in *; intros; apply f; constructor; (assumption + reflexivity) + | intro f; inversion pfc; eapply M.Raw.MX.lt_irrefl; (idtac + etransitivity); (eassumption + (eapply f; constructor; (idtac + symmetry); (eassumption + reflexivity))) ]. + Defined. + Fixpoint bst_dec t : { M.Raw.bst t } + {~ M.Raw.bst t}. + Proof. + refine match t with + | M.Raw.Leaf => left _ + | M.Raw.Node z l n r + => match bst_dec l, bst_dec r, lt_tree_dec n l, gt_tree_dec n r with + | right pf, _, _, _ => right _ + | _, right pf, _, _ => right _ + | _, _, right pf, _ => right _ + | _, _, _, right pf => right _ + | left p1, left p2, left p3, left p4 => left _ + end + end; + try solve [ constructor; assumption + | inversion 1; subst; auto ]. + Defined. + (* very slow :-( *) + #[local] Instance qlt_tree_dec : quotation_of (@lt_tree_dec) := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qgt_tree_dec : quotation_of (@gt_tree_dec) := ltac:(unfold_quotation_of (); exact _). + #[local] Instance qbst_dec : quotation_of (@bst_dec) := ltac:(unfold_quotation_of (); exact _). + #[local] Hint Unfold Int.Z_as_Int.t : quotation. + #[export] Instance quote_tree : ground_quotable M.Raw.tree := (ltac:(induction 1; exact _)). + #[export] Instance quote_bst t : ground_quotable (M.Raw.bst t) + := ground_quotable_of_dec (@bst_dec t). + #[export] Instance quote_Ok s : ground_quotable (M.Raw.Ok s) := (ltac:(cbv [M.Raw.Ok]; exact _)). + End with_t. + #[export] Hint Unfold M.Raw.t : quotation. + #[export] Existing Instances + quote_tree + quote_bst + quote_Ok + . + End Raw. + Export (hints) Raw. + + #[export] Instance quote_t_ {quote_T_t : ground_quotable T.t} : ground_quotable M.t_ := ltac:(induction 1; exact _). + #[export] Hint Unfold M.t : quotation. + #[export] Typeclasses Transparent M.t. +End QuoteMSetAVL. + +Module QuoteWSetsOnIsUsual (E : UsualDecidableType) (Import M : WSetsOn E) (MProperties : WPropertiesOnSig E M) (qE : QuotationOfUsualDecidableType E) (qM : QuotationOfWSetsOn E M) (qMProperties : QuotationOfWPropertiesOn E M MProperties) (Import QuoteM : QuoteWSetsOnSig E M MProperties qE qM qMProperties). + Import (hints) qE qM qMProperties. + + #[export] Instance quote_For_all_usual {P s} {quote_elt : ground_quotable elt} {quote_P : forall x, ground_quotable (P x:Prop)} {qP : quotation_of P} {qs : quotation_of s} : ground_quotable (For_all P s) + := quote_For_all. + Definition quote_Exists_dec_usual {P} (P_dec : forall x, {P x} + {~P x}) {s} {quote_elt : ground_quotable elt} {qP_dec : quotation_of P_dec} {quote_P : forall x, ground_quotable (P x:Prop)} {qP : quotation_of P} {qs : quotation_of s} : ground_quotable (Exists P s) + := quote_Exists_dec P_dec. + #[export] Instance quote_forall2_In_usual {P s} {qP : quotation_of P} {qs : quotation_of s} {quote_elt : ground_quotable elt} {quote_P : forall x y, ground_quotable (P x y:Prop)} : ground_quotable (forall v1 v2, In v1 s -> In v2 s -> P v1 v2) := _. +End QuoteWSetsOnIsUsual. + +Module QuoteUsualWSetsOn (E : UsualDecidableType) (M : WSetsOn E) (MProperties : WPropertiesOnSig E M) (qE : QuotationOfUsualDecidableType E) (qM : QuotationOfWSetsOn E M) (qMProperties : QuotationOfWPropertiesOn E M MProperties) + := QuoteWSetsOn E M MProperties qE qM qMProperties <+ QuoteWSetsOnIsUsual E M MProperties qE qM qMProperties. + +Module QuoteUsualSets (M : UsualSets) (MProperties : OrdPropertiesSig M) (qE : QuotationOfUsualOrderedType M.E) (qM : QuotationOfSets M) (qMProperties : QuotationOfOrdProperties M MProperties) + := QuoteSets M MProperties qE qM qMProperties <+ QuoteWSetsOnIsUsual M.E M MProperties.P qE qM qMProperties.qP. + +Module QuoteWSetsOnIsLeibniz (E : OrderedTypeWithLeibniz) (Import M : WSetsOn E) (MProperties : WPropertiesOnSig E M) (qE : QuotationOfOrderedTypeWithLeibniz E) (qM : QuotationOfWSetsOn E M) (qMProperties : QuotationOfWPropertiesOn E M MProperties) (Import QuoteM : QuoteWSetsOnSig E M MProperties qE qM qMProperties). + Import (hints) qE qM qMProperties. + + #[local] Instance all_P_Proper {P : E.t -> Prop} : Proper (E.eq ==> Basics.impl) P. + Proof. + intros ?? H. + apply E.eq_leibniz in H; subst; exact id. + Defined. + #[local] Instance qall_P_Proper : quotation_of (@all_P_Proper) := ltac:(unfold_quotation_of (); exact _). + + #[export] Instance quote_For_all_leibniz {P s} {quote_elt : ground_quotable elt} {quote_P : forall x, ground_quotable (P x:Prop)} {qP : quotation_of P} {qs : quotation_of s} : ground_quotable (For_all P s) + := quote_For_all. + Definition quote_Exists_dec_leibniz {P} (P_dec : forall x, {P x} + {~P x}) {s} {quote_elt : ground_quotable elt} {qP_dec : quotation_of P_dec} {quote_P : forall x, ground_quotable (P x:Prop)} {qP : quotation_of P} {qs : quotation_of s} : ground_quotable (Exists P s) + := quote_Exists_dec P_dec. + #[export] Instance quote_forall2_In_leibniz {P s} {qP : quotation_of P} {qs : quotation_of s} {quote_elt : ground_quotable elt} {quote_P : forall x y, ground_quotable (P x y:Prop)} : ground_quotable (forall v1 v2, In v1 s -> In v2 s -> P v1 v2) := _. +End QuoteWSetsOnIsLeibniz. + +Module QuoteSWithLeibniz (M : SWithLeibniz) (MProperties : OrdPropertiesSig M) (qE : QuotationOfOrderedTypeWithLeibniz M.E) (qM : QuotationOfSets M) (qMProperties : QuotationOfOrdProperties M MProperties) + := QuoteSets M MProperties qE qM qMProperties <+ QuoteWSetsOnIsLeibniz M.E M MProperties.P qE qM qMProperties.qP. + +Module QuoteMSetIsList (T : OrderedType) (Import M : MSetList.MakeSig T) (Import MProperties : WPropertiesOnSig T M) (Import qT : QuotationOfOrderedType T) (Import qM : MSetList.QuotationOfMake T M) (qMProperties : QuotationOfWPropertiesOn T M MProperties) (Import QuoteM : QuoteWSetsOnSig T M MProperties qT qM qMProperties). + Import (hints) qT qM qMProperties. + + Module Raw. + #[export] Instance quote_Ok {v} : ground_quotable (M.Raw.Ok v) := ltac:(cbv [M.Raw.Ok]; exact _). + #[export] Hint Unfold M.Raw.t M.Raw.elt : quotation. + End Raw. + Export (hints) Raw. + #[export] Instance quote_t_ {quoteE_t : ground_quotable E.t} : ground_quotable t_ := ltac:(destruct 1; exact _). + #[export] Hint Unfold M.t M.elt : quotation. + #[export] Typeclasses Transparent M.t M.elt. +End QuoteMSetIsList. + +Module QuoteMSetList (T : OrderedType) (M : MSetList.MakeSig T) (MOrdProperties : OrdPropertiesSig M) (qT : QuotationOfOrderedType T) (qM : MSetList.QuotationOfMake T M) (qMOrdProperties : QuotationOfOrdProperties M MOrdProperties) + := QuoteSets M MOrdProperties qT qM qMOrdProperties <+ QuoteMSetIsList T M MOrdProperties.P qT qM qMOrdProperties.qP. + +Module QuoteMSetListWithLeibniz (T : OrderedTypeWithLeibniz) (M : MSetList.MakeWithLeibnizSig T) (MOrdProperties : OrdPropertiesSig M) (qT : QuotationOfOrderedTypeWithLeibniz T) (qM : MSetList.QuotationOfMakeWithLeibniz T M) (qMOrdProperties : QuotationOfOrdProperties M MOrdProperties) + := QuoteMSetList T M MOrdProperties qT qM qMOrdProperties <+ QuoteWSetsOnIsLeibniz M.E M MOrdProperties.P qT qM qMOrdProperties.qP. diff --git a/quotation/theories/ToTemplate/Coq/Numbers.v b/quotation/theories/ToTemplate/Coq/Numbers.v new file mode 100644 index 000000000..7e0e3a493 --- /dev/null +++ b/quotation/theories/ToTemplate/Coq/Numbers.v @@ -0,0 +1,37 @@ +From Coq.Numbers Require Import BinNums DecimalFacts HexadecimalFacts + Cyclic.Int63.PrimInt63 Cyclic.Int31.Int31 + Cyclic.Abstract.CyclicAxioms + Cyclic.Abstract.DoubleType + Cyclic.Abstract.CarryType +. +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. + +#[export] Instance quote_positive : ground_quotable positive := ltac:(induction 1; exact _). +#[export] Instance quote_N : ground_quotable N := ltac:(induction 1; exact _). +#[export] Instance quote_Z : ground_quotable Z := ltac:(induction 1; exact _). + +#[export] Hint Unfold + Pos.le Pos.lt Pos.ge Pos.gt + N.le N.lt N.ge N.gt + Z.le Z.lt Z.ge Z.gt + : quotation. + +(* Work around masking-absolute-name warning *) +Module Export Numbers. + Module Export DecimalFacts. + #[export] Instance quote_digits : ground_quotable DecimalFacts.digits := ltac:(destruct 1; exact _). + End DecimalFacts. + Module Export HexadecimalFacts. + #[export] Instance quote_digits : ground_quotable HexadecimalFacts.digits := ltac:(destruct 1; exact _). + End HexadecimalFacts. + Module Export Int31. + #[export] Instance quote_digits : ground_quotable Int31.digits := ltac:(destruct 1; exact _). + End Int31. +End Numbers. + +#[export] Instance quote_int : ground_quotable int := Ast.tInt. +#[export] Instance quote_pos_neg_int63 : ground_quotable pos_neg_int63 := ltac:(destruct 1; exact _). +#[export] Instance quote_int_wrapper : ground_quotable int_wrapper := ltac:(destruct 1; exact _). +#[export] Instance quote_int31 : ground_quotable int31 := ltac:(destruct 1; exact _). +#[export] Instance quote_zn2z {znz} {qznz : quotation_of znz} {quoteznz : ground_quotable znz} : ground_quotable (zn2z znz) := ltac:(destruct 1; exact _). +#[export] Instance quote_carry {A} {qA : quotation_of A} {quoteA : ground_quotable A} : ground_quotable (carry A) := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Coq/Strings.v b/quotation/theories/ToTemplate/Coq/Strings.v new file mode 100644 index 000000000..b947ea986 --- /dev/null +++ b/quotation/theories/ToTemplate/Coq/Strings.v @@ -0,0 +1,5 @@ +Require Import Coq.Strings.String Coq.Strings.Ascii. +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. + +#[export] Instance quote_ascii : ground_quotable Ascii.ascii := (ltac:(induction 1; exact _)). +#[export] Instance quote_string : ground_quotable string := (ltac:(induction 1; exact _)). diff --git a/quotation/theories/ToTemplate/Coq/ssr.v b/quotation/theories/ToTemplate/Coq/ssr.v new file mode 100644 index 000000000..ee4b6a62b --- /dev/null +++ b/quotation/theories/ToTemplate/Coq/ssr.v @@ -0,0 +1,23 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From Coq.ssr Require Import ssrbool ssreflect. + +#[export] Instance quote_if_spec {A b vT vF} {not_b:Prop} {b' a} {qA : quotation_of A} {qvT : quotation_of vT} {qvF : quotation_of vF} {qnot_b : quotation_of not_b} {quote_not_b : ground_quotable not_b} : ground_quotable (@if_spec A b vT vF not_b b' a) := ltac:(destruct 1; exact _). +#[export] Instance quote_alt_spec {P:Prop} {b b'} {qP : quotation_of P} {quoteP : ground_quotable P} : ground_quotable (@alt_spec P b b') := ltac:(destruct 1; exact _). +Section and. + Context {P1 P2 P3 P4 P5 : Prop} + {qP1 : quotation_of P1} {qP2 : quotation_of P2} {qP3 : quotation_of P3} {qP4 : quotation_of P4} {qP5 : quotation_of P5} + {quoteP1 : ground_quotable P1} {quoteP2 : ground_quotable P2} {quoteP3 : ground_quotable P3} {quoteP4 : ground_quotable P4} {quoteP5 : ground_quotable P5}. + + #[export] Instance quote_and3 : ground_quotable (and3 P1 P2 P3) := (ltac:(destruct 1; exact _)). + #[export] Instance quote_and4 : ground_quotable (and4 P1 P2 P3 P4) := (ltac:(destruct 1; exact _)). + #[export] Instance quote_and5 : ground_quotable (and5 P1 P2 P3 P4 P5) := (ltac:(destruct 1; exact _)). +End and. +#[export] Existing Instances quote_and3 quote_and4 quote_and5. +(* can't do or without decidability *) +(* +Inductive or3 (P1 P2 P3 : Prop) : Prop := Or31 of P1 | Or32 of P2 | Or33 of P3. +Inductive or4 (P1 P2 P3 P4 : Prop) : Prop := + *) +#[export] Instance quote_put {vT sT v1 v2 s} {qvT : quotation_of vT} {qsT : quotation_of sT} {qv1 : quotation_of v1} {qv2 : quotation_of v2} {qs : quotation_of s} : ground_quotable (@TheCanonical.put vT sT v1 v2 s) := ltac:(destruct 1; exact _). +#[export] Instance quote_phantom {T p} {qT : quotation_of T} {qp : quotation_of p} : ground_quotable (@phantom T p) := ltac:(destruct 1; exact _). +#[export] Instance quote_phant {p} {qp : quotation_of p} : ground_quotable (@phant p) := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Init.v b/quotation/theories/ToTemplate/Init.v new file mode 100644 index 000000000..a60c416ba --- /dev/null +++ b/quotation/theories/ToTemplate/Init.v @@ -0,0 +1,607 @@ +From MetaCoq.Utils Require Export bytestring. +From MetaCoq.Utils Require Import utils MCList. +From MetaCoq.Common Require Import MonadBasicAst. +From MetaCoq.Template Require Import MonadAst TemplateMonad Ast Loader. +From MetaCoq.Quotation Require Export CommonUtils. +Require Import Equations.Prop.Classes. +Require Import Coq.Lists.List. +Export TemplateMonad.Common (export, local, global). +Import ListNotations. + +Local Set Primitive Projections. +Local Open Scope bs. +Import MCMonadNotation. + +Class quotation_of {T} (t : T) := quoted_term_of : Ast.term. +Class ground_quotable T := quote_ground : forall t : T, quotation_of t. +Class inductive_quotation_of {T} (t : T) + := { qinductive : inductive + ; qinst : Instance.t + ; qquotation : quotation_of t := tInd qinductive qinst }. +Definition default_inductive_quotation_of {T} {t : T} (qt : quotation_of t) (pf : cls_is_true match qt with tInd _ _ => true | _ => false end) + : inductive_quotation_of t + := match qt return cls_is_true match qt with tInd _ _ => true | _ => false end -> _ with + | tInd ind u => fun _ => @Build_inductive_quotation_of T t ind u + | _ => fun pf : false = true => match diff_false_true pf with end + end pf. + +(* returns false iff a term is suitable for quotation at the top-level, i.e., returns true iff it mentions functor-bound arguments or is a local variable or evar *) +Definition head_term_is_bound (cur_modpath : modpath) (t : term) : bool + := match t with + | tConst kn _ + | tInd {| inductive_mind := kn |} _ + | tConstruct {| inductive_mind := kn |} _ _ + | tProj {| proj_ind := {| inductive_mind := kn |} |} _ + | tCase {| ci_ind := {| inductive_mind := kn |} |} _ _ _ + => negb (kername_is_okay cur_modpath kn) + | tVar _ + | tEvar _ _ + => true + | _ => false + end. + +Fixpoint head (t : term) : term + := match t with + | tCast t _ _ + | tApp t _ + => head t + | _ => t + end. + +Definition infer_replacement_inductive {debug : debug_opt} (qt : term) : TemplateMonad (option inductive). +Proof. + simple + refine (match qt with + | tInd ind u + | tConstruct ind _ u + | tCase {| ci_ind := ind |} {| puinst := u |} _ _ + => (indv <- tmUnquote (tInd ind u);; + let '(existT_typed_term _ indv) := indv in + v <- (tmInferInstance None (inductive_quotation_of indv));; + match v with + | my_Some v => ret (Some (replace_inductive_kn ind v.(qinductive))) + | my_None => (if debug then tmPrint (inductive_quotation_of indv) else ret tt);; ret None + end) + | tProj {| proj_ind := ind |} t + => (t <- tmUnquote t;; + let '(existT_typed_term ty _) := t in + ty <- tmEval hnf ty;; + ty <- tmQuote ty;; + let indv := head ty in + indv <- tmUnquote indv;; + let '(existT_typed_term _ indv) := indv in + v <- (tmInferInstance None (inductive_quotation_of indv));; + match v with + | my_Some v => ret (Some (replace_inductive_kn ind v.(qinductive))) + | my_None => (if debug then tmPrint (qt, inductive_quotation_of ind) else ret tt);; ret None + end) + | _ => ret None + end). +Defined. + +Fixpoint replace_quotation_of' {debug : debug_opt} (do_top_inference : bool) (qt : term) : TemplateMonad term. +Proof. + specialize (replace_quotation_of' debug). + simple + refine + (let replace_quotation_of' := replace_quotation_of' true in + let tmTryInferQuotation t + := (t <- tmUnquote t;; + let '(existT_typed_term _ t) := t in + v <- tmInferInstance None (quotation_of t);; + match v return TemplateMonad (option_instance Ast.term) with + | my_Some v => ret (@my_Some _ v) + | my_None => (if debug then tmPrint (quotation_of t) else ret tt);; ret (@my_None _) + end) in + let tmInferQuotation t + := (v <- tmTryInferQuotation t;; + match v return TemplateMonad Ast.term with + | my_Some v => ret v + | my_None => tmFail "No typeclass instance" + end) in + let tmMaybeInferQuotation 'tt := + if do_top_inference then tmInferQuotation qt else tmFail "Avoiding loops" in + cur_modpath <- tmCurrentModPath tt;; + match qt return TemplateMonad Ast.term with + | tRel _ + | tSort _ + | tInt _ + | tFloat _ + | tConst _ _ + => if head_term_is_bound cur_modpath qt + then tmMaybeInferQuotation tt + else ret qt + | tConstruct ind idx u + => if head_term_is_bound cur_modpath qt + then (ind <- infer_replacement_inductive qt;; + match ind with + | Some ind => ret (tConstruct ind idx u) + | None => tmMaybeInferQuotation tt + end) + else ret qt + | tInd ind u + => if head_term_is_bound cur_modpath qt + then if do_top_inference + then (ind <- infer_replacement_inductive qt;; + match ind with + | Some ind => ret (tInd ind u) + | None => tmMaybeInferQuotation tt + end) + else tmFail "Avoiding ind loops" + else ret qt + | tVar _ + => tmMaybeInferQuotation tt + | tEvar ev args => args <- monad_map replace_quotation_of' args;; ret (tEvar ev args) + | tLambda na T M => T <- replace_quotation_of' T;; M <- replace_quotation_of' M;; ret (tLambda na T M) + | tApp u v => u <- replace_quotation_of' u;; v <- monad_map replace_quotation_of' v;; ret (mkApps u v) + | tProd na A B => A <- replace_quotation_of' A;; B <- replace_quotation_of' B;; ret (tProd na A B) + | tCast c kind ty => c <- replace_quotation_of' c;; ty <- replace_quotation_of' ty;; ret (tCast c kind ty) + | tLetIn na b ty b' => b <- replace_quotation_of' b;; ty <- replace_quotation_of' ty;; b' <- replace_quotation_of' b';; ret (tLetIn na b ty b') + | tProj p c + => res <- (if head_term_is_bound cur_modpath qt + then (ind <- infer_replacement_inductive qt;; + match ind with + | Some ind + => let p := {| proj_ind := ind ; proj_npars := p.(proj_npars) ; proj_arg := p.(proj_arg) |} in + ret (inr p) + | None + => res <- tmMaybeInferQuotation tt;; + ret (inl res) + end) + else ret (inr p));; + match res with + | inl res => ret res + | inr p => c <- replace_quotation_of' c;; + ret (tProj p c) + end + | tFix mfix idx => + mfix' <- monad_map (monad_map_def replace_quotation_of' replace_quotation_of') mfix;; + ret (tFix mfix' idx) + | tCoFix mfix idx => + mfix' <- monad_map (monad_map_def replace_quotation_of' replace_quotation_of') mfix;; + ret (tCoFix mfix' idx) + | tCase ci p c brs + => res <- (if head_term_is_bound cur_modpath qt + then (ind <- infer_replacement_inductive qt;; + match ind with + | Some ind + => ret (inr {| ci_ind := ind ; ci_npar := ci.(ci_npar) ; ci_relevance := ci.(ci_relevance) |}) + | None + => res <- tmMaybeInferQuotation tt;; + ret (inl res) + end) + else ret (inr ci));; + match res with + | inl res => ret res + | inr ci + => p' <- monad_map_predicate ret replace_quotation_of' replace_quotation_of' p;; + brs' <- monad_map_branches replace_quotation_of' brs;; + c <- replace_quotation_of' c;; + ret (tCase ci p' c brs') + end + end); + try exact _. +Defined. + +Definition replace_quotation_of {debug : debug_opt} {T} (t : T) : TemplateMonad term + := qt <- tmQuote t;; + replace_quotation_of' false qt. + +(** for fancier goals when we have [ground_quotable] for some subterms but not for subterms of those subterms *) +Definition make_quotation_of {debug : debug_opt} {T} (t : T) : TemplateMonad (quotation_of t). +Proof. + simple + refine + (qt <- tmQuote t;; + let tmInferQuotation t + := (t <- tmUnquote t;; + let '(existT_typed_term _ t) := t in + v <- tmInferInstance None (quotation_of t);; + match v with + | my_Some v => ret v + | my_None => (if debug then tmPrint (quotation_of t) else ret tt);; tmFail "No typeclass instance" + end) in + cur_modpath <- tmCurrentModPath tt;; + if head_term_is_bound cur_modpath qt + then ((if debug then tmPrint qt else ret tt);; tmFail "bound argument is not ground") + else + match qt return TemplateMonad Ast.term with + | tSort _ + | tConst _ _ + | tConstruct _ _ _ + | tInt _ + | tFloat _ + | tInd _ _ + => ret qt + | tCast t kind v + => tmInferQuotation t + | tApp f args + => match List.rev args with + | [] + => tmInferQuotation f + | [x] + => qf <- tmInferQuotation f;; + qx <- tmInferQuotation x;; + ret (mkApp qf qx) + | x :: xs + => qfxs <- tmInferQuotation (mkApps f (List.rev xs));; + qx <- tmInferQuotation x;; + ret (mkApp qfxs qx) + end + | tProj proj t => tmFail "Proj is not reduced" + | tRel n => tmFail "Rel is not ground" + | tVar id => tmFail "Var is not ground" + | tEvar ev args => tmFail "Evar is not ground" + | tProd na ty body => tmFail "Prod not yet handled" + | tLambda na ty body => tmFail "Lambda not yet handled" + | tLetIn na def def_ty body => tmFail "LetIn not yet handled" + | tCase ci type_info discr branches => tmFail "Case not yet handled" + | tFix mfix idx => tmFail "Fix not yet handled" + | tCoFix mfix idx => tmFail "CoFix not yet handled" + end); + exact _. +Defined. + +Ltac replace_quotation_of_goal _ := + let t := match goal with |- quotation_of ?t => t end in + run_template_program (replace_quotation_of t) (fun v => exact v). + +Ltac make_quotation_of_goal _ := + let t := match goal with |- quotation_of ?t => t end in + run_template_program (make_quotation_of t) (fun v => exact v). + +Ltac adjust_quotation_of_by_econstructor_then tac1 tac2 := + let f := match goal with |- ?f _ => f end in + unshelve (let g := open_constr:(f _) in + change g); + [ unshelve econstructor + | ]; + [ .. + | repeat match goal with |- context[?ev] => is_evar ev; generalize ev; intro end ]; + [ tac1 () .. + | tac2 () ]. + +Ltac adjust_ground_quotable_by_econstructor_inversion _ := + let pf := fresh "pf" in + intro pf; + adjust_quotation_of_by_econstructor_then ltac:(fun _ => inversion pf; try assumption) ltac:(fun _ => try exact _). + +Ltac revert_quotable_hyp _ := + match goal with + | [ H : _ |- quotation_of ?v ] + => lazymatch v with + | H => fail + | context[H] => idtac + end; + revert H; + lazymatch goal with + | [ |- forall x : ?A, quotation_of (@?P x) ] + => assert (quotation_of P); + [ + | intro H; + pose proof (_ : quotation_of H); + change (quotation_of (P H)); exact _ ] + end + end. +Ltac revert_quotable_hyps _ := + repeat revert_quotable_hyp (). + +Create HintDb quotation discriminated. + +Module Export Instances. + (* some performance settings *) + #[export] Set Typeclasses Unique Instances. + #[export] Instance default_debug : debug_opt | 1000 := false. + #[export] Existing Instance quote_ground. + #[export] Typeclasses Opaque quotation_of. + #[export] Hint Constants Opaque : typeclass_instances. + #[export] Typeclasses Transparent Relation_Definitions.relation. (* for setoid_rewrite *) + #[export] Hint Extern 0 => progress intros : typeclass_instances. + #[export] Hint Extern 0 (quotation_of _) => progress repeat autounfold with quotation in * : typeclass_instances. + #[export] Hint Extern 0 (ground_quotable _) => progress repeat autounfold with quotation in * : typeclass_instances. + #[export] + Hint Extern 0 (quotation_of match ?t with _ => _ end) => is_var t; destruct t : typeclass_instances. + #[export] + Hint Extern 0 (ground_quotable match ?t with _ => _ end) => is_var t; destruct t : typeclass_instances. + #[export] + Hint Extern 1 (quotation_of _) => replace_quotation_of_goal () : typeclass_instances. + #[export] + Hint Extern 2 (quotation_of _) => make_quotation_of_goal () : typeclass_instances. + (*#[export] + Hint Extern 100 (quotation_of _) => progress revert_quotable_hyps () : typeclass_instances.*) + #[export] Hint Mode cls_is_true + : typeclass_instances. + #[export] Existing Instances qquotation | 10. + (* Hack around COQBUG(https://github.com/coq/coq/issues/16760) *) + #[export] Hint Extern 10 (@inductive_quotation_of ?T ?t) => simple notypeclasses refine (@default_inductive_quotation_of T t _ _) : typeclass_instances. + #[export] Hint Extern 10 (cls_is_true ?b) + => tryif is_evar b then refine (eq_refl true) else tryif has_evar b then fail else vm_compute; reflexivity + : typeclass_instances. + #[export] Hint Cut [ + ( _ * ) + qquotation + ( _ * ) + qquotation + ] : typeclass_instances. +End Instances. + +Module StrongerInstances. + #[export] + Hint Extern 1 (quotation_of match ?t with _ => _ end) => destruct t : typeclass_instances. + #[export] + Hint Extern 1 (ground_quotable match ?t with _ => _ end) => destruct t : typeclass_instances. +End StrongerInstances. + +(** Some helper lemmas for defining quotations *) +Definition ground_quotable_of_bp {b P} (H : b = true -> P) {qH : quotation_of H} (H_for_safety : P -> b = true) : ground_quotable P. +Proof. + intro p. + exact (Ast.mkApps qH [_ : quotation_of (@eq_refl bool true)]). +Defined. + +Definition ground_quotable_neg_of_bp {b P} (H : b = false -> ~P) {qH : quotation_of H} (H_for_safety : ~P -> b = false) : ground_quotable (~P). +Proof. + intro p. + exact (Ast.mkApps qH [_ : quotation_of (@eq_refl bool false)]). +Defined. + +Definition ground_quotable_of_dec {P} (H : {P} + {~P}) {qP : quotation_of P} {qH : quotation_of H} : ground_quotable P + := ground_quotable_of_bp bp_of_dec pb_of_dec. +Definition ground_quotable_neg_of_dec {P} (H : {P} + {~P}) {qP : quotation_of P} {qH : quotation_of H} : ground_quotable (~P) + := ground_quotable_neg_of_bp neg_bp_of_dec neg_pb_of_dec. +Definition ground_quotable_neq_of_EqDec {A x y} {qA : quotation_of A} {quoteA : ground_quotable A} {H : EqDec A} {qH : quotation_of H} : ground_quotable (x <> y :> A) + := ground_quotable_neg_of_dec (H x y). +#[export] Hint Extern 1 (ground_quotable (?x <> ?y :> ?A)) => simple notypeclasses refine (@ground_quotable_neq_of_EqDec A x y _ _ _ _) : typeclass_instances. + +(* avoid universe inconsistencies *) +#[export] Polymorphic Instance qfst_cps {A B} {qA : quotation_of A} {qB : quotation_of B} : quotation_of (@fst A B) | 0 + := tApp <% @fst %> [qA; qB]. +#[export] Polymorphic Instance qsnd_cps {A B} {qA : quotation_of A} {qB : quotation_of B} : quotation_of (@snd A B) | 0 + := tApp <% @snd %> [qA; qB]. +#[export] Polymorphic Instance qpair_cps {A B} {qA : quotation_of A} {qB : quotation_of B} : quotation_of (@pair A B) | 0 + := tApp <% @pair %> [qA; qB]. +#[export] Polymorphic Instance qprod_cps {A B} {qA : quotation_of A} {qB : quotation_of B} : quotation_of (@prod A B) | 0 + := tApp <% @prod %> [qA; qB]. +#[export] Polymorphic Instance qSome_cps {A} {qA : quotation_of A} : quotation_of (@Some A) | 0 + := tApp <% @Some %> [qA]. +#[export] Polymorphic Instance qNone_cps {A} {qA : quotation_of A} : quotation_of (@None A) | 0 + := tApp <% @None %> [qA]. +#[export] Polymorphic Instance qoption_cps {A} {qA : quotation_of A} : quotation_of (@option A) | 0 + := tApp <% @option %> [qA]. +#[export] Polymorphic Instance qcons_cps {A} {qA : quotation_of A} : quotation_of (@cons A) | 0 + := tApp <% @cons %> [qA]. +#[export] Polymorphic Instance qnil_cps {A} {qA : quotation_of A} : quotation_of (@nil A) | 0 + := tApp <% @nil %> [qA]. +#[export] Polymorphic Instance qlist_cps {A} {qA : quotation_of A} : quotation_of (@list A) | 0 + := tApp <% @list %> [qA]. + +Polymorphic Definition ground_quotable_of_iffT {A B} {quoteA : ground_quotable A} {qA : quotation_of A} {qB : quotation_of B} (H : A <~> B) {qH : quotation_of H} : ground_quotable B. +Proof. + intro b. + change (@quotation_of B (fst H (snd H b))). + make_quotation_of_goal (). +Defined. +(* Transparent versions *) +Definition proj1 {A B} (x : A /\ B) : A := ltac:(apply x). +Definition proj2 {A B} (x : A /\ B) : B := ltac:(apply x). +Definition ground_quotable_of_iff {A B : Prop} {quoteA : ground_quotable A} {qA : quotation_of A} {qB : quotation_of B} (H : iff A B) {qH : quotation_of H} : ground_quotable B. +Proof. + intro b. + change (@quotation_of B (proj1 H (proj2 H b))). + exact _. +Defined. +Definition quote_neg_of_iffT {A B} {quoteA : ground_quotable (A -> False)} {qA : quotation_of A} {qB : quotation_of B} (H : A <~> B) {qH : quotation_of H} : ground_quotable (B -> False). +Proof. + intro nb. + assert (na : A -> False) by (intro a; apply nb, H, a). + change (@quotation_of (B -> False) (fun b => na (snd H b))). + exact _. +Defined. +Definition quote_neg_of_iff {A B : Prop} {quoteA : ground_quotable (~A)} {qA : quotation_of A} {qB : quotation_of B} (H : iff A B) {qH : quotation_of H} : ground_quotable (~B). +Proof. + intro nb. + assert (na : ~A) by (intro a; apply nb, H, a). + change (@quotation_of (~B) (fun b => na (proj2 H b))). + exact _. +Defined. + +Ltac unfold_quotation_of _ := + lazymatch goal with + | [ |- @quotation_of ?A ?t ] + => first [ progress cbv delta [t] + | change (@quotation_of A (transparentify t)) ] + end. + +Polymorphic Definition tmPrepareMakeQuotationOfConstants@{U t u u' _T _above_u _above_u'} {debug:debug_opt} (work_aronud_coq_bug_17303 : bool) (include_submodule : list ident -> bool) (include_supermodule : list ident -> list ident -> bool) (base : modpath) (cs : list global_reference) : TemplateMonad@{t u} (list (string * typed_term@{u'})) + := let warn_bad_ctx c ctx := + (_ <- tmMsg "tmPrepareMakeQuotationOfModule: cannot handle polymorphism";; + _ <- tmPrint c;; + _ <- tmPrint ctx;; + tmReturn tt) in + let tmDebugMsg s := (if debug + then tmMsg s + else tmReturn tt) in + let tmDebugPrint {T : Type@{_T}} (v : T) + := (if debug + then tmPrint v + else tmReturn tt) in + let on_bad_relevance r := + (_ <- tmDebugMsg "skipping irrelevant constant";; + _ <- tmDebugPrint r;; + tmReturn []) in + let make_qname '(mp, name) + (* ideally we'd replace _ with __ so that there can't be any collision, but the utility functions aren't written and we don't need it in practice *) + := option_map + (fun n => "q" ++ n)%bs + match split_common_prefix base mp with + | None => if include_supermodule [] [] + then Some name + else None + | Some (_, (_common, [], [])) => Some name + | Some (_, (_common, [], postfix)) + => if include_submodule postfix + then Some (String.concat "__DOT__" postfix ++ "__" ++ name) + else None + | Some (_, (_common, base_postfix, postfix)) + => if include_supermodule base_postfix postfix + then Some ("__DOT_DOT__" ++ String.concat "__DOT__" base_postfix ++ "__SLASH__" ++ String.concat "__DOT__" postfix ++ "__" ++ name) + else None + end%bs in + let tmDebugSkipGR '(mp, name) := + _ <- tmDebugMsg ("tmPrepareMakeQuotationOfConstants: skipping excluded constant " ++ name);; + _ <- tmDebugPrint (split_common_prefix base mp);; + ret [] in + let cs := dedup_grefs cs in + cs <- tmEval cbv cs;; + _ <- tmDebugMsg "tmPrepareMakeQuotationOfConstants: looking up module constants";; + ps <- monad_map@{_ _ _ _above_u'} + (fun r + => _ <- tmDebugMsg "tmPrepareMakeQuotationOfConstants: handling";; + _ <- tmDebugPrint r;; + match r with + | ConstRef cr + => '(inst, rel) <- (cb <- tmQuoteConstant cr false;; + inst <- match cb.(cst_universes) with + | Monomorphic_ctx => tmReturn ([] : Instance.t) + | (Polymorphic_ctx (univs, constraints)) as ctx + => _ <- warn_bad_ctx r ctx;; + tmReturn ([] : Instance.t) + end;; + tmReturn (inst, cb.(cst_relevance)));; + match rel, make_qname cr with + | Irrelevant, _ => on_bad_relevance r + | _, None => tmDebugSkipGR cr + | Relevant, Some qname + => let c := tConst cr inst in + _ <- tmDebugMsg "tmPrepareMakeQuotationOfConstants: tmUnquote";; + '{| my_projT1 := cty ; my_projT2 := cv |} <- tmUnquote c;; + _ <- tmDebugMsg "tmPrepareMakeQuotationOfConstants: tmUnquote done";; + tmReturn [(qname, if work_aronud_coq_bug_17303 + then {| my_projT1 := term ; my_projT2 := c |} + else {| my_projT1 := @quotation_of cty cv ; my_projT2 := c |})] + end + | IndRef ind + => match make_qname ind.(inductive_mind) with + | None => tmDebugSkipGR ind.(inductive_mind) + | Some qname + => inst <- (mib <- tmQuoteInductive ind.(inductive_mind);; + match mib.(ind_universes) with + | Monomorphic_ctx => tmReturn ([] : Instance.t) + | (Polymorphic_ctx (univs, constraints)) as ctx + => _ <- warn_bad_ctx r ctx;; + tmReturn ([] : Instance.t) + end);; + let c := tInd ind inst in + _ <- tmDebugMsg "tmPrepareMakeQuotationOfConstants: tmUnquote";; + '{| my_projT1 := cty ; my_projT2 := cv |} <- tmUnquote c;; + _ <- tmDebugMsg "tmPrepareMakeQuotationOfConstants: tmUnquote done";; + let tmcty := tmRetypeRelaxSetInCodomain@{U t t u _above_u} cty in + _ <- tmDebugPrint tmcty;; + cty <- tmcty;; + let tmcv := tmObj_magic (B:=cty) cv in + _ <- tmDebugPrint tmcv;; + cv <- tmcv;; + let ty := @inductive_quotation_of cty cv in + let v : ty := {| qinductive := ind ; qinst := inst |} in + tmReturn [(qname, {| my_projT1 := ty ; my_projT2 := v |})] + end + | ConstructRef _ _ | VarRef _ => tmReturn [] + end) + cs;; + let ps := flat_map (fun x => x) ps in + ret ps. + +(* N.B. We need to kludge around COQBUG(https://github.com/coq/coq/issues/17303) in Kernames :-( *) +Polymorphic Definition tmMakeQuotationOfConstants_gen@{U d t u u' _T _above_u _above_u' _above_gr} {debug:debug_opt} (work_aronud_coq_bug_17303 : bool) (include_submodule : list ident -> bool) (include_supermodule : list ident -> list ident -> bool) (existing_instance : option hint_locality) (base : modpath) (cs : list global_reference) (tmDoWithDefinition : ident -> forall A : Type@{d}, A -> TemplateMonad A) : TemplateMonad unit + := let tmDebugMsg s := (if debug + then tmMsg s + else tmReturn tt) in + let tmDebugPrint {T : Type@{_T}} (v : T) + := (if debug + then tmPrint v + else tmReturn tt) in + ps <- tmPrepareMakeQuotationOfConstants@{U t u u' _T _above_u _above_u'} work_aronud_coq_bug_17303 include_submodule include_supermodule base cs;; + _ <- tmDebugMsg "tmMakeQuotationOfConstants_gen: defining module constants";; + ps <- monad_map@{_ _ _above_gr _above_u'} + (fun '(name, tyv) + => let tmTyv := tmRetypeAroundMetaCoqBug853 tyv in + _ <- tmDebugPrint tmTyv;; + '{| my_projT1 := ty ; my_projT2 := v |} <- tmTyv;; + tmDef_name <- tmEval cbv (@tmDoWithDefinition (name:string));; + let tmn := tmDef_name ty v in + _ <- tmDebugPrint tmn;; + n <- tmn;; + _ <- tmDebugMsg "tmMakeQuotationOfConstants_gen: tmQuoteToGlobalReference";; + qn <- tmQuoteToGlobalReference n;; + tmReturn qn) + ps;; + _ <- (match existing_instance with + | Some locality + => _ <- tmDebugMsg "tmMakeQuotationOfConstants_gen: making instances";; + monad_map + (fun p + => let tmEx := tmExistingInstance locality p in + _ <- tmDebugPrint tmEx;; + tmEx) + ps + | None => tmReturn [] + end);; + tmReturn tt. + +Definition tmMakeQuotationOfConstants {debug:debug_opt} (include_submodule : list ident -> bool) (include_supermodule : list ident -> list ident -> bool) (existing_instance : option hint_locality) (base : modpath) (cs : list global_reference) : TemplateMonad unit + := tmMakeQuotationOfConstants_gen false include_submodule include_supermodule existing_instance base cs (fun name ty body => @tmDefinition name ty body). + +Definition tmMakeQuotationOfConstantsWorkAroundCoqBug17303 {debug:debug_opt} (include_submodule : list ident -> bool) (include_supermodule : list ident -> list ident -> bool) (base : modpath) (cs : list global_reference) : TemplateMonad unit + := tmMakeQuotationOfConstants_gen true include_submodule include_supermodule None base cs (fun name ty body => @tmDefinition name ty body). + +Definition tmDeclareQuotationOfConstants {debug:debug_opt} (include_submodule : list ident -> bool) (include_supermodule : list ident -> list ident -> bool) (existing_instance : option hint_locality) (base : modpath) (cs : list global_reference) : TemplateMonad unit + := tmMakeQuotationOfConstants_gen false include_submodule include_supermodule existing_instance base cs (fun name ty _ => @tmAxiom name ty). + +Variant submodule_inclusion := only_toplevel | all_submodules_except (_ : list (list ident)) | toplevel_and_submodules (_ : list (list ident)) | everything. + +#[local] Typeclasses Transparent ident IdentOT.t. +Definition is_submodule_of (super : list ident) (sub : list ident) : bool + := firstn #|super| sub == super. +Definition is_supermodule_of (sub : list ident) (super : list ident) : bool + := is_submodule_of super sub. +Definition include_submodule_of_submodule_inclusion (si : submodule_inclusion) : list ident -> bool + := match si with + | only_toplevel => fun _ => false + | all_submodules_except ls => fun i => negb (existsb (is_supermodule_of i) ls) + | toplevel_and_submodules ls => fun i => existsb (is_supermodule_of i) ls + | everything => fun _ => true + end. +Definition include_supermodule_of_submodule_inclusion (si : submodule_inclusion) : list ident -> list ident -> bool + := match si with + | everything => fun _ _ => true + | _ => fun _ _ => false + end. + +Definition tmMakeQuotationOfModule {debug:debug_opt} (include_submodule : submodule_inclusion) (existing_instance : option hint_locality) (m : qualid) : TemplateMonad _ + := cs <- tmQuoteModule m;; + base <- tmLocateModule1 m;; + let include_supermodule := include_supermodule_of_submodule_inclusion include_submodule in + let include_submodule := include_submodule_of_submodule_inclusion include_submodule in + tmMakeQuotationOfConstants include_submodule include_supermodule existing_instance base cs. +Global Arguments tmMakeQuotationOfModule {_%bool} _ _ _%bs. + +Definition tmMakeQuotationOfModuleWorkAroundCoqBug17303 {debug:debug_opt} (include_submodule : submodule_inclusion) (m : qualid) : TemplateMonad _ + := cs <- tmQuoteModule m;; + base <- tmLocateModule1 m;; + let include_supermodule := include_supermodule_of_submodule_inclusion include_submodule in + let include_submodule := include_submodule_of_submodule_inclusion include_submodule in + tmMakeQuotationOfConstantsWorkAroundCoqBug17303 include_submodule include_supermodule base cs. +Global Arguments tmMakeQuotationOfModuleWorkAroundCoqBug17303 {_%bool} _ _%bs. + +Definition tmDeclareQuotationOfModule {debug:debug_opt} (include_submodule : submodule_inclusion) (existing_instance : option hint_locality) (m : qualid) : TemplateMonad _ + := cs <- tmQuoteModule m;; + base <- tmLocateModule1 m;; + let include_supermodule := include_supermodule_of_submodule_inclusion include_submodule in + let include_submodule := include_submodule_of_submodule_inclusion include_submodule in + tmDeclareQuotationOfConstants include_submodule include_supermodule existing_instance base cs. +Global Arguments tmDeclareQuotationOfModule {_%bool} _ _ _%bs. + +(* +Require Import MSetPositive. +Instance: debug_opt := true. +MetaCoq Run (tmMakeQuotationOfModule None "Coq.MSets.MSetPositive.PositiveSet"%bs). +*) diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Environment/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Common/Environment/Sig.v new file mode 100644 index 000000000..7bfba4ce3 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Environment/Sig.v @@ -0,0 +1,58 @@ +From MetaCoq.Common Require Import Environment. +From MetaCoq.Quotation.ToTemplate Require Import Init. + +Module Type QuotationOfTerm (T : Term). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "T"). +End QuotationOfTerm. + +Module Type QuoteTerm (T : Term). + #[export] Declare Instance quote_term : ground_quotable T.term. +End QuoteTerm. + +Module Type QuotationOfTermDecide (T : Term) (TD : TermDecide T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "TD"). +End QuotationOfTermDecide. + +Module Type QuotationOfEnvironment (T : Term) (Import E : EnvironmentSig T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "E"). +End QuotationOfEnvironment. + +Module Type QuoteEnvironmentSig (T : Term) (Import E : EnvironmentSig T). + + #[export] Hint Unfold + context + global_declarations + global_env_ext + typ_or_sort + : quotation. + #[export] Typeclasses Transparent + context + global_declarations + global_env_ext + typ_or_sort + . + + #[export] Declare Instance quote_constructor_body : ground_quotable constructor_body. + #[export] Declare Instance quote_projection_body : ground_quotable projection_body. + #[export] Declare Instance quote_one_inductive_body : ground_quotable one_inductive_body. + #[export] Declare Instance quote_mutual_inductive_body : ground_quotable mutual_inductive_body. + #[export] Declare Instance quote_constant_body : ground_quotable constant_body. + #[export] Declare Instance quote_global_decl : ground_quotable global_decl. + + #[export] Declare Instance quote_global_env : ground_quotable global_env. + + #[export] Declare Instance quote_extends {Σ Σ'} : ground_quotable (@extends Σ Σ'). + #[export] Declare Instance quote_extends_decls {Σ Σ'} : ground_quotable (@extends_decls Σ Σ'). + #[export] Declare Instance quote_primitive_invariants {cdecl} : ground_quotable (primitive_invariants cdecl). + + #[export] Declare Instance quote_All_decls {P t t'} {qP : quotation_of P} {quoteP : forall t t', ground_quotable (P t t')} : ground_quotable (All_decls P t t'). + #[export] Declare Instance quote_All_decls_alpha {P t t'} {qP : quotation_of P} {quoteP : forall t t', ground_quotable (P t t')} : ground_quotable (All_decls_alpha P t t'). +End QuoteEnvironmentSig. + +Module Type QuotationOfEnvironmentDecide (T : Term) (E : EnvironmentSig T) (ED : EnvironmentDecide T E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "ED"). +End QuotationOfEnvironmentDecide. + +Module Type QuotationOfTermUtils (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "TU"). +End QuotationOfTermUtils. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v new file mode 100644 index 000000000..8ed05be49 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/EnvironmentTyping/Sig.v @@ -0,0 +1,180 @@ +From MetaCoq.Common Require Import BasicAst Environment EnvironmentTyping. +From MetaCoq.Quotation.ToTemplate Require Import Init. + +Module Type QuotationOfLookup (T : Term) (E : EnvironmentSig T) (L : LookupSig T E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "L"). +End QuotationOfLookup. + +Module Type QuoteLookupSig (Import T : Term) (Import E : EnvironmentSig T) (Import L : LookupSig T E). + #[export] Hint Unfold + consistent_instance_ext + : quotation. + #[export] Typeclasses Transparent + consistent_instance_ext + . + + #[export] Declare Instance quote_consistent_instance {cf lvs ϕ uctx u} : ground_quotable (@consistent_instance cf lvs ϕ uctx u). + #[export] Declare Instance quote_wf_universe {Σ s} : ground_quotable (@wf_universe Σ s). + #[export] Declare Instance quote_declared_constant {Σ id decl} : ground_quotable (@declared_constant Σ id decl). + #[export] Declare Instance quote_declared_minductive {Σ mind decl} : ground_quotable (@declared_minductive Σ mind decl). + #[export] Declare Instance quote_declared_inductive {Σ ind mdecl decl} : ground_quotable (@declared_inductive Σ ind mdecl decl). + #[export] Declare Instance quote_declared_constructor {Σ cstr mdecl idecl cdecl} : ground_quotable (@declared_constructor Σ cstr mdecl idecl cdecl). + #[export] Declare Instance quote_declared_projection {Σ proj mdecl idecl cdecl pdecl} : ground_quotable (@declared_projection Σ proj mdecl idecl cdecl pdecl). +End QuoteLookupSig. + +Module Type QuotationOfEnvTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : EnvTypingSig T E TU). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "ET"). +End QuotationOfEnvTyping. + +Module Type QuoteEnvTypingSig (Import T : Term) (Import E : EnvironmentSig T) (Import TU : TermUtils T E) (Import ET : EnvTypingSig T E TU). + + #[export] Hint Unfold + infer_sort + lift_typing + All_local_rel + : quotation. + #[export] Typeclasses Transparent + infer_sort + lift_typing + All_local_rel + . + + #[export] Declare Instance quote_All_local_env {typing Γ} {qtyping : quotation_of typing} {quote_typing : forall Γ t T, ground_quotable (typing Γ t T)} : ground_quotable (@All_local_env typing Γ). + #[export] Declare Instance quote_on_local_decl {P Γ d} {quoteP1 : forall b, d.(decl_body) = Some b -> ground_quotable (P Γ b (Typ d.(decl_type)))} {quoteP2 : d.(decl_body) = None -> ground_quotable (P Γ d.(decl_type) Sort)} : ground_quotable (@on_local_decl P Γ d). + #[export] Declare Instance quote_lift_judgment {check infer_sort Σ Γ t T} {quote_check : forall T', T = Typ T' -> ground_quotable (check Σ Γ t T')} {quote_infer_sort : T = Sort -> ground_quotable (infer_sort Σ Γ t)} : ground_quotable (@lift_judgment check infer_sort Σ Γ t T). + + #[export] Declare Instance quote_All_local_env_over_gen + {checking sorting cproperty sproperty Σ Γ H} + {qchecking : quotation_of checking} {qsorting : quotation_of sorting} {qcproperty : quotation_of cproperty} {qsproperty : quotation_of sproperty} + {quote_checking : forall Γ t T, ground_quotable (checking Σ Γ t T)} {quote_sorting : forall Γ T, ground_quotable (sorting Σ Γ T)} {quote_sproperty : forall Γ all t tu, ground_quotable (sproperty Σ Γ all t tu)} {quote_cproperty : forall Γ all b t tb, ground_quotable (cproperty Σ Γ all b t tb)} + : ground_quotable (@All_local_env_over_gen checking sorting cproperty sproperty Σ Γ H). + + #[export] Declare Instance quote_All_local_env_over {typing property Σ Γ H} + {qtyping : quotation_of typing} {qproperty : quotation_of property} + {quote_typing : forall Γ t T, ground_quotable (typing Σ Γ t T)} {quote_property : forall Γ all b t tb, ground_quotable (property Σ Γ all b t tb)} + : ground_quotable (@All_local_env_over typing property Σ Γ H). + + #[export] Declare Instance quote_All_local_env_over_sorting + {checking sorting cproperty sproperty Σ Γ H} + {qchecking : quotation_of checking} {qsorting : quotation_of sorting} {qcproperty : quotation_of cproperty} {qsproperty : quotation_of sproperty} + {quote_checking : forall Γ t T, ground_quotable (checking Σ Γ t T)} {quote_sorting : forall Γ T U, ground_quotable (sorting Σ Γ T U)} {quote_sproperty : forall Γ all t tu U, ground_quotable (sproperty Σ Γ all t tu U)} {quote_cproperty : forall Γ all b t tb, ground_quotable (cproperty Σ Γ all b t tb)} + : ground_quotable (@All_local_env_over_sorting checking sorting cproperty sproperty Σ Γ H). + + #[export] Declare Instance quote_ctx_inst {typing Σ Γ ctx inst} + {qtyping : quotation_of typing} + {quote_typing : forall i t, ground_quotable (typing Σ Γ i t)} + : ground_quotable (@ctx_inst typing Σ Γ ctx inst). +End QuoteEnvTypingSig. + +Module Type QuotationOfConversion (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : EnvTypingSig T E TU) (C : ConversionSig T E TU ET). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "C"). +End QuotationOfConversion. + +Module Type QuoteConversionSig (Import T : Term) (Import E : EnvironmentSig T) (Import TU : TermUtils T E) (Import ET : EnvTypingSig T E TU) (Import C : ConversionSig T E TU ET). + + #[export] Declare Instance quote_All_decls_alpha_pb {pb P b b'} {qP : quotation_of P} {quoteP : forall pb t t', ground_quotable (P pb t t')} + : ground_quotable (@All_decls_alpha_pb pb P b b'). + + #[export] Declare Instance quote_cumul_pb_decls {cumul_gen pb Σ Γ Γ' x y} + {qcumul_gen : quotation_of cumul_gen} + {quote_cumul_gen : forall pb t t', ground_quotable (cumul_gen Σ Γ pb t t')} + : ground_quotable (@cumul_pb_decls cumul_gen pb Σ Γ Γ' x y). + + #[export] Declare Instance quote_cumul_pb_context {cumul_gen pb Σ Γ Γ'} + {qcumul_gen : quotation_of cumul_gen} + {quote_cumul_gen : forall Γ pb t t', ground_quotable (cumul_gen Σ Γ pb t t')} + : ground_quotable (@cumul_pb_context cumul_gen pb Σ Γ Γ'). + + #[export] Declare Instance quote_cumul_ctx_rel {cumul_gen Σ Γ Δ Δ'} + {qcumul_gen : quotation_of cumul_gen} + {quote_cumul_gen : forall Γ pb t t', ground_quotable (cumul_gen Σ Γ pb t t')} + : ground_quotable (@cumul_ctx_rel cumul_gen Σ Γ Δ Δ'). +End QuoteConversionSig. + +Module Type QuotationOfGlobalMaps (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : EnvTypingSig T E TU) (C : ConversionSig T E TU ET) (L : LookupSig T E) (GM : GlobalMapsSig T E TU ET C L). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "GM"). +End QuotationOfGlobalMaps. + +Module Type QuoteGlobalMapsSig (Import T: Term) (Import E: EnvironmentSig T) (Import TU : TermUtils T E) (Import ET: EnvTypingSig T E TU) (Import C: ConversionSig T E TU ET) (Import L: LookupSig T E) (Import GM : GlobalMapsSig T E TU ET C L). + + #[export] Hint Unfold + mdecl_at_i + constructor_univs + on_constructors + fresh_global + : quotation. + #[export] Typeclasses Transparent + mdecl_at_i + constructor_univs + on_constructors + fresh_global + . + + #[export] Declare Instance quote_on_context {P} {qP : quotation_of P} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ ctx} : ground_quotable (@on_context P Σ ctx). + + #[export] Declare Instance quote_type_local_ctx {P} {qP : quotation_of P} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ Γ Δ u} : ground_quotable (@type_local_ctx P Σ Γ Δ u). + + #[export] Declare Instance quote_sorts_local_ctx {P} {qP : quotation_of P} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ Γ Δ us} : ground_quotable (@sorts_local_ctx P Σ Γ Δ us). + + #[export] Declare Instance quote_on_type {P} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ Γ T} : ground_quotable (@on_type P Σ Γ T). + + #[export] Declare Instance quote_on_udecl {univs udecl} : ground_quotable (@on_udecl univs udecl). + #[export] Declare Instance quote_satisfiable_udecl {univs ϕ} : ground_quotable (@satisfiable_udecl univs ϕ). + #[export] Declare Instance quote_valid_on_mono_udecl {univs ϕ} : ground_quotable (@valid_on_mono_udecl univs ϕ). + + #[export] Declare Instance quote_positive_cstr_arg {mdecl ctx t} : ground_quotable (@positive_cstr_arg mdecl ctx t). + #[export] Declare Instance quote_positive_cstr {mdecl i ctx t} : ground_quotable (@positive_cstr mdecl i ctx t). + + #[export] Declare Instance quote_ind_respects_variance {Pcmp} {qPcmp : quotation_of Pcmp} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {Σ mdecl v indices} : ground_quotable (@ind_respects_variance Pcmp Σ mdecl v indices). + #[export] Declare Instance quote_cstr_respects_variance {Pcmp} {qPcmp : quotation_of Pcmp} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {Σ mdecl v cs} : ground_quotable (@cstr_respects_variance Pcmp Σ mdecl v cs). + #[export] Declare Instance quote_on_constructor {cf Pcmp P} {qPcmp : quotation_of Pcmp} {qP : quotation_of P} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ mdecl i idecl ind_indices cdecl cunivs} : ground_quotable (@on_constructor cf Pcmp P Σ mdecl i idecl ind_indices cdecl cunivs). + #[export] Declare Instance quote_on_proj {mdecl mind i k p decl} : ground_quotable (@on_proj mdecl mind i k p decl). + #[export] Declare Instance quote_on_projection {mdecl mind i cdecl k p} : ground_quotable (@on_projection mdecl mind i cdecl k p). + #[export] Declare Instance quote_on_projections {mdecl mind i idecl ind_indices cdecl} : ground_quotable (@on_projections mdecl mind i idecl ind_indices cdecl). + #[export] Declare Instance quote_check_ind_sorts {cf P} {qP : quotation_of P} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ params kelim ind_indices cdecls ind_sort} : ground_quotable (@check_ind_sorts cf P Σ params kelim ind_indices cdecls ind_sort). + #[export] Declare Instance quote_on_ind_body {cf Pcmp P} {qPcmp : quotation_of Pcmp} {qP : quotation_of P} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ mind mdecl i idecl} : ground_quotable (@on_ind_body cf Pcmp P Σ mind mdecl i idecl). + #[export] Declare Instance quote_on_variance {cf Σ univs variances} : ground_quotable (@on_variance cf Σ univs variances). + #[export] Declare Instance quote_on_inductive {cf Pcmp P} {qPcmp : quotation_of Pcmp} {qP : quotation_of P} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ mind mdecl} : ground_quotable (@on_inductive cf Pcmp P Σ mind mdecl). + #[export] Declare Instance quote_on_constant_decl {P} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ d} : ground_quotable (@on_constant_decl P Σ d). + #[export] Declare Instance quote_on_global_decl {cf Pcmp P} {qPcmp : quotation_of Pcmp} {qP : quotation_of P} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ kn d} : ground_quotable (@on_global_decl cf Pcmp P Σ kn d). + #[export] Declare Instance quote_on_global_decls_data {cf Pcmp P} {qPcmp : quotation_of Pcmp} {qP : quotation_of P} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {univs retro Σ kn d} : ground_quotable (@on_global_decls_data cf Pcmp P univs retro Σ kn d). + #[export] Declare Instance quote_on_global_decls {cf Pcmp P} {qPcmp : quotation_of Pcmp} {qP : quotation_of P} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {univs retro Σ} : ground_quotable (@on_global_decls cf Pcmp P univs retro Σ). + #[export] Declare Instance quote_on_global_univs {univs} : ground_quotable (@on_global_univs univs). + #[export] Declare Instance quote_on_global_env {cf Pcmp P} {qPcmp : quotation_of Pcmp} {qP : quotation_of P} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {g} : ground_quotable (@on_global_env cf Pcmp P g). + #[export] Declare Instance quote_on_global_env_ext {cf Pcmp P} {qPcmp : quotation_of Pcmp} {qP : quotation_of P} {quotePcmp : forall Σ Γ pb t T, ground_quotable (Pcmp Σ Γ pb t T)} {quoteP : forall Σ Γ t T, ground_quotable (P Σ Γ t T)} {Σ} : ground_quotable (@on_global_env_ext cf Pcmp P Σ). +End QuoteGlobalMapsSig. + +Module Type QuotationOfConversionPar (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : EnvTypingSig T E TU) (CS : ConversionParSig T E TU ET). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "CS"). +End QuotationOfConversionPar. + +Module Type QuoteConversionParSig (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : EnvTypingSig T E TU) (Import CS : ConversionParSig T E TU ET). + #[export] Declare Instance quote_cumul_gen {cf Σ Γ pb t t'} : ground_quotable (@cumul_gen cf Σ Γ pb t t'). +End QuoteConversionParSig. + +Module Type QuotationOfTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : EnvTypingSig T E TU) + (CT : ConversionSig T E TU ET) (CS : ConversionParSig T E TU ET) (Ty : Typing T E TU ET CT CS). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "Ty"). +End QuotationOfTyping. + +Module Type QuoteTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) (ET : EnvTypingSig T E TU) + (CT : ConversionSig T E TU ET) (CS : ConversionParSig T E TU ET) (Import Ty : Typing T E TU ET CT CS). + + #[export] Declare Instance quote_typing {cf Σ Γ t T} : ground_quotable (@typing cf Σ Γ t T). +End QuoteTyping. + +Module Type QuotationOfDeclarationTyping (T : Term) (E : EnvironmentSig T) (TU : TermUtils T E) + (ET : EnvTypingSig T E TU) (CT : ConversionSig T E TU ET) + (CS : ConversionParSig T E TU ET) (Ty : Typing T E TU ET CT CS) + (L : LookupSig T E) (GM : GlobalMapsSig T E TU ET CT L) (DT : DeclarationTypingSig T E TU ET CT CS Ty L GM). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "DT"). +End QuotationOfDeclarationTyping. + +Module Type QuoteDeclarationTypingSig (Import T : Term) (Import E : EnvironmentSig T) (Import TU : TermUtils T E) + (Import ET : EnvTypingSig T E TU) (Import CT : ConversionSig T E TU ET) + (Import CS : ConversionParSig T E TU ET) (Import Ty : Typing T E TU ET CT CS) + (Import L : LookupSig T E) (Import GM : GlobalMapsSig T E TU ET CT L) + (Import DT : DeclarationTypingSig T E TU ET CT CS Ty L GM). + #[export] Declare Instance quote_type_local_decl {cf Σ Γ d} : ground_quotable (@type_local_decl cf Σ Γ d). + #[export] Declare Instance quote_wf_local_rel {cf Σ Γ Γ'} : ground_quotable (@wf_local_rel cf Σ Γ Γ'). +End QuoteDeclarationTypingSig. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/Instances.v new file mode 100644 index 000000000..6b7d80477 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/Instances.v @@ -0,0 +1,8 @@ +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common.Kernames Require Export + Kername.Instances + KernameSet.Instances + KernameSetOrdProp.Instances + KernameMap.Instances + KernameMapFact.Instances +. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/Kername/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/Kername/Instances.v new file mode 100644 index 000000000..259ad02fb --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/Kername/Instances.v @@ -0,0 +1,12 @@ +From MetaCoq.Common Require Import Kernames. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig OrdersAlt.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module qKername <: QuotationOfOrderedType Kername. + Module qOT <: QuotationOfOrderedTypeOrig Kername.OT. + MetaCoq Run (tmMakeQuotationOfModule everything None "Kername.OT"). + End qOT. + MetaCoq Run (tmMakeQuotationOfModuleWorkAroundCoqBug17303 (all_submodules_except [["OT"]]%bs) (*None*) "Kername"). +End qKername. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameMap/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameMap/Instances.v new file mode 100644 index 000000000..3db1cd993 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameMap/Instances.v @@ -0,0 +1,37 @@ +From MetaCoq.Common Require Import Kernames. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig OrdersAlt.Sig OrdersFacts.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.FSets Require Import FMapAVL.Sig FMapList.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module qKernameMap <: FMapAVL.QuotationOfMake Kername.OT KernameMap. + Module qRaw. + Module qProofs. + Module qMX <: QuotationOfOrderedTypeOrigFacts Kername.OT KernameMap.Raw.Proofs.MX. + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameMap.Raw.Proofs.MX"). + End qMX. + Module qPX <: QuotationOfKeyOrderedTypeOrig Kername.OT KernameMap.Raw.Proofs.PX. + Module qMO <: QuotationOfOrderedTypeOrigFacts Kername.OT KernameMap.Raw.Proofs.PX.MO. + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameMap.Raw.Proofs.PX.MO"). + End qMO. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["MO"]]%bs) None "KernameMap.Raw.Proofs.PX"). + End qPX. + Module qL <: FMapList.QuotationOfRaw Kername.OT KernameMap.Raw.Proofs.L. + Module qMX <: QuotationOfOrderedTypeOrigFacts Kername.OT KernameMap.Raw.Proofs.L.MX. + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameMap.Raw.Proofs.L.MX"). + End qMX. + Module qPX <: QuotationOfKeyOrderedTypeOrig Kername.OT KernameMap.Raw.Proofs.L.PX. + Module qMO <: QuotationOfOrderedTypeOrigFacts Kername.OT KernameMap.Raw.Proofs.L.PX.MO. + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameMap.Raw.Proofs.L.PX.MO"). + End qMO. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["MO"]]%bs) None "KernameMap.Raw.Proofs.L.PX"). + End qPX. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["MX"]; ["PX"]]%bs) None "KernameMap.Raw.Proofs.L"). + End qL. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["MX"]; ["PX"]; ["L"]]%bs) None "KernameMap.Raw.Proofs"). + End qProofs. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["Proofs"]]%bs) None "KernameMap.Raw"). + End qRaw. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["Raw"]]%bs) None "KernameMap"). +End qKernameMap. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameMapFact/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameMapFact/Instances.v new file mode 100644 index 000000000..15fe993b4 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameMapFact/Instances.v @@ -0,0 +1,9 @@ +From MetaCoq.Common Require Import Kernames. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.FSets Require Import FMapFacts.Sig. + +Module qKernameMapFact. + Module qF <: QuotationOfWFacts_fun Kername.OT KernameMap KernameMapFact.F. + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameMapFact.F"). + End qF. +End qKernameMapFact. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameSet/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameSet/Instances.v new file mode 100644 index 000000000..0c3b58576 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameSet/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Common Require Import Kernames. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetAVL.Sig. + +Module qKernameSet <: MSetAVL.QuotationOfMake Kername KernameSet. + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameSet"). +End qKernameSet. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameSetOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameSetOrdProp/Instances.v new file mode 100644 index 000000000..45e03bdbe --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Kernames/KernameSetOrdProp/Instances.v @@ -0,0 +1,25 @@ +From MetaCoq.Common Require Import Kernames. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig OrdersAlt.Sig OrdersFacts.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetProperties.Sig MSetDecide.Sig MSetFacts.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module qKernameSetOrdProp <: QuotationOfOrdProperties KernameSet KernameSetOrdProp. + Module qME <: QuotationOfOrderedTypeFacts KernameSet.E KernameSetOrdProp.ME. + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameSetOrdProp.ME"). + End qME. + Module qML. (* OrderedTypeLists(M.E). *) + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameSetOrdProp.ML"). + End qML. + Module qP <: QuotationOfWProperties KernameSet KernameSetOrdProp.P. + Module qDec <: QuotationOfWDecideOn Kername KernameSet KernameSetOrdProp.P.Dec. + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameSetOrdProp.P.Dec"). + End qDec. + Module qFM <: QuotationOfWFactsOn Kername KernameSet KernameSetOrdProp.P.FM. + MetaCoq Run (tmMakeQuotationOfModule everything None "KernameSetOrdProp.P.FM"). + End qFM. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "KernameSetOrdProp.P"). + End qP. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "KernameSetOrdProp"). +End qKernameSetOrdProp. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v new file mode 100644 index 000000000..2c85d2ebe --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSet/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Common Require Import Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetAVL.Sig. + +Module qConstraintSet <: MSetAVL.QuotationOfMake UnivConstraint ConstraintSet. + MetaCoq Run (tmMakeQuotationOfModule everything None "ConstraintSet"). +End qConstraintSet. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v new file mode 100644 index 000000000..8e77b0d2c --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/ConstraintSetOrdProp/Instances.v @@ -0,0 +1,25 @@ +From MetaCoq.Common Require Import Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig OrdersAlt.Sig OrdersFacts.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetProperties.Sig MSetDecide.Sig MSetFacts.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module qConstraintSetOrdProp <: QuotationOfOrdProperties ConstraintSet ConstraintSetOrdProp. + Module qME <: QuotationOfOrderedTypeFacts ConstraintSet.E ConstraintSetOrdProp.ME. + MetaCoq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.ME"). + End qME. + Module qML. (* OrderedTypeLists(M.E). *) + MetaCoq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.ML"). + End qML. + Module qP <: QuotationOfWProperties ConstraintSet ConstraintSetOrdProp.P. + Module qDec <: QuotationOfWDecideOn UnivConstraint ConstraintSet ConstraintSetOrdProp.P.Dec. + MetaCoq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.P.Dec"). + End qDec. + Module qFM <: QuotationOfWFactsOn UnivConstraint ConstraintSet ConstraintSetOrdProp.P.FM. + MetaCoq Run (tmMakeQuotationOfModule everything None "ConstraintSetOrdProp.P.FM"). + End qFM. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "ConstraintSetOrdProp.P"). + End qP. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "ConstraintSetOrdProp"). +End qConstraintSetOrdProp. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v new file mode 100644 index 000000000..753b84e60 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Instances.v @@ -0,0 +1,12 @@ +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common.Universes Require Export + Level.Instances + LevelSet.Instances + LevelSetOrdProp.Instances + LevelExpr.Instances + LevelExprSet.Instances + LevelExprSetOrdProp.Instances + UnivConstraint.Instances + ConstraintSet.Instances + ConstraintSetOrdProp.Instances +. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Level/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Level/Instances.v new file mode 100644 index 000000000..40de3ec6c --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/Level/Instances.v @@ -0,0 +1,9 @@ +From MetaCoq.Common Require Import Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig OrdersAlt.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module qLevel <: QuotationOfOrderedType Level. + MetaCoq Run (tmMakeQuotationOfModuleWorkAroundCoqBug17303 everything (*None*) "Level"). +End qLevel. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExpr/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExpr/Instances.v new file mode 100644 index 000000000..527d205ab --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExpr/Instances.v @@ -0,0 +1,9 @@ +From MetaCoq.Common Require Import Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig OrdersAlt.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module qLevelExpr <: QuotationOfOrderedType LevelExpr. + MetaCoq Run (tmMakeQuotationOfModuleWorkAroundCoqBug17303 everything (*None*) "LevelExpr"). +End qLevelExpr. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSet/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSet/Instances.v new file mode 100644 index 000000000..1dcbc18c9 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSet/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Common Require Import Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetList.Sig. + +Module qLevelExprSet <: MSetList.QuotationOfMakeWithLeibniz LevelExpr LevelExprSet. + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelExprSet"). +End qLevelExprSet. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSetOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSetOrdProp/Instances.v new file mode 100644 index 000000000..0ace7b49e --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelExprSetOrdProp/Instances.v @@ -0,0 +1,25 @@ +From MetaCoq.Common Require Import Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig OrdersAlt.Sig OrdersFacts.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetProperties.Sig MSetDecide.Sig MSetFacts.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module qLevelExprSetOrdProp <: QuotationOfOrdProperties LevelExprSet LevelExprSetOrdProp. + Module qME <: QuotationOfOrderedTypeFacts LevelExprSet.E LevelExprSetOrdProp.ME. + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelExprSetOrdProp.ME"). + End qME. + Module qML. (* OrderedTypeLists(M.E). *) + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelExprSetOrdProp.ML"). + End qML. + Module qP <: QuotationOfWProperties LevelExprSet LevelExprSetOrdProp.P. + Module qDec <: QuotationOfWDecideOn LevelExpr LevelExprSet LevelExprSetOrdProp.P.Dec. + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelExprSetOrdProp.P.Dec"). + End qDec. + Module qFM <: QuotationOfWFactsOn LevelExpr LevelExprSet LevelExprSetOrdProp.P.FM. + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelExprSetOrdProp.P.FM"). + End qFM. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "LevelExprSetOrdProp.P"). + End qP. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "LevelExprSetOrdProp"). +End qLevelExprSetOrdProp. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelSet/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelSet/Instances.v new file mode 100644 index 000000000..f2f8fe104 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelSet/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Common Require Import Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetAVL.Sig. + +Module qLevelSet <: MSetAVL.QuotationOfMake Level LevelSet. + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelSet"). +End qLevelSet. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelSetOrdProp/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelSetOrdProp/Instances.v new file mode 100644 index 000000000..91696d248 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/LevelSetOrdProp/Instances.v @@ -0,0 +1,25 @@ +From MetaCoq.Common Require Import Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig OrdersAlt.Sig OrdersFacts.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetProperties.Sig MSetDecide.Sig MSetFacts.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module qLevelSetOrdProp <: QuotationOfOrdProperties LevelSet LevelSetOrdProp. + Module qME <: QuotationOfOrderedTypeFacts LevelSet.E LevelSetOrdProp.ME. + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelSetOrdProp.ME"). + End qME. + Module qML. (* OrderedTypeLists(M.E). *) + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelSetOrdProp.ML"). + End qML. + Module qP <: QuotationOfWProperties LevelSet LevelSetOrdProp.P. + Module qDec <: QuotationOfWDecideOn Level LevelSet LevelSetOrdProp.P.Dec. + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelSetOrdProp.P.Dec"). + End qDec. + Module qFM <: QuotationOfWFactsOn Level LevelSet LevelSetOrdProp.P.FM. + MetaCoq Run (tmMakeQuotationOfModule everything None "LevelSetOrdProp.P.FM"). + End qFM. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) None "LevelSetOrdProp.P"). + End qP. + MetaCoq Run (tmMakeQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) None "LevelSetOrdProp"). +End qLevelSetOrdProp. diff --git a/quotation/theories/ToTemplate/QuotationOf/Common/Universes/UnivConstraint/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/UnivConstraint/Instances.v new file mode 100644 index 000000000..775965a56 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Common/Universes/UnivConstraint/Instances.v @@ -0,0 +1,9 @@ +From MetaCoq.Common Require Import Universes. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import Orders.Sig OrdersAlt.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module qUnivConstraint <: QuotationOfOrderedType UnivConstraint. + MetaCoq Run (tmMakeQuotationOfModuleWorkAroundCoqBug17303 everything (*None*) "UnivConstraint"). +End qUnivConstraint. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapAVL/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapAVL/Sig.v new file mode 100644 index 000000000..e6ac8d086 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapAVL/Sig.v @@ -0,0 +1,27 @@ +From Coq.FSets Require Import FMapAVL. +From Coq.Structures Require Import Equalities OrdersAlt. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import OrdersAlt.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.FSets Require Import FMapList.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module FMapAVL. + Module Type MakeSig (T : OrderedTypeOrig) := Nop <+ FMapAVL.Make T. + + Module Type QuotationOfMake (T : OrderedTypeOrig) (M : MakeSig T). + Module qRaw. + Module qProofs. + Module qMX := Nop <+ QuotationOfOrderedTypeOrigFacts T M.Raw.Proofs.MX. + Module qPX := Nop <+ QuotationOfKeyOrderedTypeOrig T M.Raw.Proofs.PX. + Module qL := Nop <+ FMapList.QuotationOfRaw T M.Raw.Proofs.L. + Export (hints) qMX qPX qL. + MetaCoq Run (tmDeclareQuotationOfModule (all_submodules_except [["MX"]; ["PX"]; ["L"]]%bs) (Some export) "M.Raw.Proofs"). + End qProofs. + Export (hints) qProofs. + MetaCoq Run (tmDeclareQuotationOfModule (all_submodules_except [["Proofs"]]%bs) (Some export) "M.Raw"). + End qRaw. + Export (hints) qRaw. + MetaCoq Run (tmDeclareQuotationOfModule (all_submodules_except [["Raw"]]%bs) (Some export) "M"). + End QuotationOfMake. +End FMapAVL. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapFacts/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapFacts/Sig.v new file mode 100644 index 000000000..0051fd4c8 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapFacts/Sig.v @@ -0,0 +1,11 @@ +From Coq.FSets Require Import FMapFacts. +From Coq.Structures Require Import Orders. +From MetaCoq.Quotation.ToTemplate Require Import Init. + +Module Export FSets. + Module Type WFacts_funSig (E : DecidableTypeOrig) (M : WSfun E) := Nop <+ WFacts_fun E M. + + Module Type QuotationOfWFacts_fun (E : DecidableTypeOrig) (M : WSfun E) (F : WFacts_funSig E M). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F"). + End QuotationOfWFacts_fun. +End FSets. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapInterface/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapInterface/Sig.v new file mode 100644 index 000000000..16b9e0e11 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapInterface/Sig.v @@ -0,0 +1,7 @@ +From Coq.FSets Require Import FMapInterface. +From Coq.Structures Require Import Orders. +From MetaCoq.Quotation.ToTemplate Require Import Init. + +Module Type QuotationOfWSfun (E : DecidableTypeOrig) (Import M : WSfun E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "M"). +End QuotationOfWSfun. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapList/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapList/Sig.v new file mode 100644 index 000000000..bc8582877 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/FSets/FMapList/Sig.v @@ -0,0 +1,17 @@ +From Coq.FSets Require Import FMapList. +From Coq.Structures Require Import Equalities OrdersAlt. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import OrdersAlt.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module FMapList. + Module Type RawSig (T : OrderedTypeOrig) := Nop <+ FMapList.Raw T. + + Module Type QuotationOfRaw (T : OrderedTypeOrig) (M : RawSig T). + Module qMX := Nop <+ QuotationOfOrderedTypeOrigFacts T M.MX. + Module qPX := Nop <+ QuotationOfKeyOrderedTypeOrig T M.PX. + Export (hints) qMX qPX. + MetaCoq Run (tmDeclareQuotationOfModule (all_submodules_except [["MX"]; ["PX"]]%bs) (Some export) "M"). + End QuotationOfRaw. +End FMapList. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetAVL/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetAVL/Sig.v new file mode 100644 index 000000000..738298dcc --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetAVL/Sig.v @@ -0,0 +1,11 @@ +From Coq.Structures Require Import Orders. +From Coq.MSets Require Import MSetAVL. +From MetaCoq.Quotation.ToTemplate Require Import Init. + +Module MSetAVL. + Module Type MakeSig (T : OrderedType) := Nop <+ MSetAVL.Make T. + + Module Type QuotationOfMake (T : OrderedType) (M : MakeSig T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "M"). + End QuotationOfMake. +End MSetAVL. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetDecide/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetDecide/Sig.v new file mode 100644 index 000000000..61604fc1c --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetDecide/Sig.v @@ -0,0 +1,14 @@ +From Coq.MSets Require Import MSetInterface MSetDecide. +From MetaCoq.Quotation.ToTemplate Require Import Init. + +Module Export MSets. + Module Type WDecideOnSig (E : DecidableType) (M : WSetsOn E) := Nop <+ WDecideOn E M. + Module Type WDecideSig (M : WSets) := Nop <+ WDecide M. + Module Type DecideSig (M : WSets) := Nop <+ Decide M. + + Module Type QuotationOfWDecideOn (E : DecidableType) (M : WSetsOn E) (F : WDecideOnSig E M). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F"). + End QuotationOfWDecideOn. + + Module Type QuotationOfWDecide (M : WSets) (F : WDecideSig M) := QuotationOfWDecideOn M.E M F. +End MSets. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetFacts/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetFacts/Sig.v new file mode 100644 index 000000000..c2e70b046 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetFacts/Sig.v @@ -0,0 +1,14 @@ +From Coq.MSets Require Import MSetFacts. +From MetaCoq.Quotation.ToTemplate Require Import Init. + +Module Export MSets. + Module Type WFactsOnSig (E : DecidableType) (M : WSetsOn E) := Nop <+ WFactsOn E M. + Module Type WFactsSig (M : WSets) := Nop <+ WFacts M. + Module Type FactsSig (M : WSets) := Nop <+ Facts M. + + Module Type QuotationOfWFactsOn (E : DecidableType) (M : WSetsOn E) (F : WFactsOnSig E M). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F"). + End QuotationOfWFactsOn. + + Module Type QuotationOfWFacts (M : WSets) (F : WFactsSig M) := QuotationOfWFactsOn M.E M F. +End MSets. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetInterface/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetInterface/Sig.v new file mode 100644 index 000000000..a5ddb92f5 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetInterface/Sig.v @@ -0,0 +1,28 @@ +From Coq.MSets Require Import MSetInterface. +From MetaCoq.Quotation.ToTemplate Require Import Init. + +Module Type QuotationOfWSetsOn (E : DecidableType) (Import W : WSetsOn E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "W"). +End QuotationOfWSetsOn. +Module Type QuotationOfWSets (W : WSets) := QuotationOfWSetsOn W.E W. +Module Type QuotationOfSetsOn (E : OrderedType) (Import M : SetsOn E). + Include QuotationOfWSetsOn E M. + #[export] Declare Instance qcompare : quotation_of M.compare. + #[export] Declare Instance qmin_elt : quotation_of M.min_elt. + #[export] Declare Instance qmax_elt : quotation_of M.max_elt. + #[export] Declare Instance qcompare_spec : quotation_of M.compare_spec. + #[export] Declare Instance qelements_spec2 : quotation_of M.elements_spec2. + #[export] Declare Instance qmin_elt_spec1 : quotation_of M.min_elt_spec1. + #[export] Declare Instance qmin_elt_spec2 : quotation_of M.min_elt_spec2. + #[export] Declare Instance qmin_elt_spec3 : quotation_of M.min_elt_spec3. + #[export] Declare Instance qmax_elt_spec1 : quotation_of M.max_elt_spec1. + #[export] Declare Instance qmax_elt_spec2 : quotation_of M.max_elt_spec2. + #[export] Declare Instance qmax_elt_spec3 : quotation_of M.max_elt_spec3. + #[export] Declare Instance qchoose_spec3 : quotation_of M.choose_spec3. +End QuotationOfSetsOn. +Module Type QuotationOfSets (M : Sets) := QuotationOfSetsOn M.E M. + +Module Type UsualSets <: Sets. + Declare Module E : UsualOrderedType. + Include SetsOn E. +End UsualSets. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetList/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetList/Sig.v new file mode 100644 index 000000000..a2919eb45 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetList/Sig.v @@ -0,0 +1,29 @@ +From Coq.Structures Require Import Equalities Orders. +From Coq.MSets Require Import MSetList. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetInterface.Sig. + +Module Type QuotationOfOrderedTypeWithLeibniz (O : OrderedTypeWithLeibniz). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "O"). +End QuotationOfOrderedTypeWithLeibniz. + +Module Type QuotationOfSWithLeibniz (S : SWithLeibniz). + Include QuotationOfSetsOn S.E S. + #[export] Declare Instance qeq_leibniz : quotation_of S.eq_leibniz. +End QuotationOfSWithLeibniz. + +Module MSetList. + Module Type MakeSig (T : OrderedType) := Nop <+ MSetList.Make T. + + Module Type QuotationOfMake (T : OrderedType) (M : MakeSig T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "M"). + End QuotationOfMake. + + Module Type MakeWithLeibnizSig (X : OrderedTypeWithLeibniz) := Nop <+ MakeWithLeibniz X. + + Module Type QuotationOfMakeWithLeibniz (T : OrderedTypeWithLeibniz) (M : MakeWithLeibnizSig T). + Include QuotationOfMake T M. + #[export] Declare Instance qeq_leibniz_list : quotation_of M.eq_leibniz_list. + #[export] Declare Instance qeq_leibniz : quotation_of M.eq_leibniz. + End QuotationOfMakeWithLeibniz. +End MSetList. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetProperties/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetProperties/Sig.v new file mode 100644 index 000000000..ea367e04b --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/MSets/MSetProperties/Sig.v @@ -0,0 +1,32 @@ +From Coq.MSets Require Import MSetProperties. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.Structures Require Import OrdersFacts.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq.MSets Require Import MSetFacts.Sig MSetDecide.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module Export MSets. + Module Type WPropertiesOnSig (E : DecidableType) (M : WSetsOn E) := Nop <+ WPropertiesOn E M. + Module Type WPropertiesSig (M : WSets) := Nop <+ WProperties M. + Module Type PropertiesSig (M : WSets) := Nop <+ Properties M. + Module Type OrdPropertiesSig (M : Sets) := Nop <+ OrdProperties M. + + Module Type QuotationOfWPropertiesOn (E : DecidableType) (M : WSetsOn E) (F : WPropertiesOnSig E M). + Module qDec := Nop <+ QuotationOfWDecideOn E M F.Dec. + Module qFM := Nop <+ QuotationOfWFactsOn E M F.FM. + Export (hints) qDec qFM. + MetaCoq Run (tmDeclareQuotationOfModule (all_submodules_except [["Dec"]; ["FM"]]%bs) (Some export) "F"). + End QuotationOfWPropertiesOn. + + Module Type QuotationOfWProperties (M : WSets) (F : WPropertiesSig M) := QuotationOfWPropertiesOn M.E M F. + + Module Type QuotationOfOrdProperties (M : Sets) (F : OrdPropertiesSig M). + Module qME := Nop <+ QuotationOfOrderedTypeFacts M.E F.ME. + Module qML. (* OrderedTypeLists(M.E). *) + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F.ML"). + End qML. + Module qP := Nop <+ QuotationOfWProperties M F.P. + Export (hints) qME qML qP. + MetaCoq Run (tmDeclareQuotationOfModule (all_submodules_except [["ME"]; ["ML"]; ["P"]]%bs) (Some export) "F"). + End QuotationOfOrdProperties. +End MSets. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/Equalities/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/Equalities/Sig.v new file mode 100644 index 000000000..b3feb8a62 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/Equalities/Sig.v @@ -0,0 +1,159 @@ +From Coq.Structures Require Import Equalities. +From MetaCoq.Quotation.ToTemplate Require Import Init. + +Module Type QuotationOfTyp (Import T : Typ). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "T"). +End QuotationOfTyp. +Module Type QuotationOfHasEq (T : Typ) (Import E : HasEq T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "E"). +End QuotationOfHasEq. +Module Type QuotationOfEq (E : Eq) := QuotationOfTyp E <+ QuotationOfHasEq E E. +Module Type QuotationOfIsEq (E : Eq) (Import IE : IsEq E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "IE"). +End QuotationOfIsEq. +Module Type QuotationOfIsEqOrig (E : Eq) (Import IEO : IsEqOrig E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "IEO"). +End QuotationOfIsEqOrig. +Module Type QuotationOfHasEqDec (E : Eq) (Import EDec : HasEqDec E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "EDec"). +End QuotationOfHasEqDec. +Module Type QuotationOfHasEqb (T : Typ) (Import E : HasEqb T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "E"). +End QuotationOfHasEqb. + +Module Type QuotationOfEqbSpec (T : Typ) (X : HasEq T) (Y : HasEqb T) (Import ES : EqbSpec T X Y). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "ES"). +End QuotationOfEqbSpec. + +Module Type QuotationOfHasEqBool (E : Eq) (EB : HasEqBool E) := QuotationOfHasEqb E EB <+ QuotationOfEqbSpec E E EB EB. + +Module Type QuotationOfEqualityType (E : EqualityType) := QuotationOfEq E <+ QuotationOfIsEq E E. + +Module Type QuotationOfEqualityTypeOrig (E : EqualityTypeOrig) := QuotationOfEq E <+ QuotationOfIsEqOrig E E. + +Module Type QuotationOfEqualityTypeBoth (E : EqualityTypeBoth) <: QuotationOfEqualityType E <: QuotationOfEqualityTypeOrig E + := QuotationOfEq E <+ QuotationOfIsEq E E <+ QuotationOfIsEqOrig E E. + +Module Type QuotationOfDecidableType (E : DecidableType) <: QuotationOfEqualityType E + := QuotationOfEq E <+ QuotationOfIsEq E E <+ QuotationOfHasEqDec E E. + +Module Type QuotationOfDecidableTypeOrig (E : DecidableTypeOrig) <: QuotationOfEqualityTypeOrig E + := QuotationOfEq E <+ QuotationOfIsEqOrig E E <+ QuotationOfHasEqDec E E. + +Module Type QuotationOfDecidableTypeBoth (E : DecidableTypeBoth) <: QuotationOfDecidableType E <: QuotationOfDecidableTypeOrig E + := QuotationOfEqualityTypeBoth E <+ QuotationOfHasEqDec E E. + +Module Type QuotationOfBooleanEqualityType (E : BooleanEqualityType) <: QuotationOfEqualityType E + := QuotationOfEq E <+ QuotationOfIsEq E E <+ QuotationOfHasEqBool E E. + +Module Type QuotationOfBooleanDecidableType (E : BooleanDecidableType) <: QuotationOfDecidableType E <: QuotationOfBooleanEqualityType E + := QuotationOfEq E <+ QuotationOfIsEq E E <+ QuotationOfHasEqDec E E <+ QuotationOfHasEqBool E E. + +Module Type QuotationOfDecidableTypeFull (E : DecidableTypeFull) <: QuotationOfDecidableTypeBoth E <: QuotationOfBooleanDecidableType E + := QuotationOfEq E <+ QuotationOfIsEq E E <+ QuotationOfIsEqOrig E E <+ QuotationOfHasEqDec E E <+ QuotationOfHasEqBool E E. + +Module Type BackportEqSig (E : Eq) (F : IsEq E) := Nop <+ BackportEq E F. + +Module QuotationOfBackportEq (E : Eq) (F : IsEq E) (Import E' : BackportEqSig E F) (Import qE : QuotationOfEq E) (Import qF : QuotationOfIsEq E F) <: QuotationOfIsEqOrig E E'. + #[export] Instance qeq_refl : quotation_of eq_refl := ltac:(cbv [eq_refl]; exact _). + #[export] Instance qeq_sym : quotation_of eq_sym := ltac:(cbv [eq_sym]; exact _). + #[export] Instance qeq_trans : quotation_of eq_trans := ltac:(cbv [eq_trans]; exact _). +End QuotationOfBackportEq. + +Module Type UpdateEqSig (E : Eq) (F : IsEqOrig E) := Nop <+ UpdateEq E F. + +Module QuotationOfUpdateEq (E : Eq) (F : IsEqOrig E) (Import E' : UpdateEqSig E F) (Import qE : QuotationOfEq E) (Import qF : QuotationOfIsEqOrig E F) <: QuotationOfIsEq E E'. + #[export] Instance qeq_equiv : quotation_of E'.eq_equiv := ltac:(change (quotation_of (Build_Equivalence _ F.eq_refl F.eq_sym F.eq_trans)); exact _). +End QuotationOfUpdateEq. + +Module Type Backport_ETSig (E:EqualityType) := Nop <+ Backport_ET E. +Module Type Update_ETSig (E:EqualityTypeOrig) := Nop <+ Update_ET E. +Module Type Backport_DTSig (E:DecidableType) := Nop <+ Backport_DT E. +Module Type Update_DTSig (E:DecidableTypeOrig) := Nop <+ Update_DT E. + +Module QuotationOfBackport_ET (E : EqualityType) (E' : Backport_ETSig E) (qE : QuotationOfEqualityType E) <: QuotationOfEqualityTypeBoth E' + := qE <+ QuotationOfBackportEq E E E'. + +Module QuotationOfUpdate_ET (E : EqualityTypeOrig) (E' : Update_ETSig E) (qE : QuotationOfEqualityTypeOrig E) <: QuotationOfEqualityTypeBoth E' + := qE <+ QuotationOfUpdateEq E E E'. + +Module QuotationOfBackport_DT (E : DecidableType) (E' : Backport_DTSig E) (qE : QuotationOfDecidableType E) <: QuotationOfDecidableTypeBoth E' + := qE <+ QuotationOfBackportEq E E E'. + +Module QuotationOfUpdate_DT (E : DecidableTypeOrig) (E' : Update_DTSig E) (qE : QuotationOfDecidableTypeOrig E) <: QuotationOfDecidableTypeBoth E' + := qE <+ QuotationOfUpdateEq E E E'. + +Module Type HasEqDec2BoolSig (E : Eq) (F : HasEqDec E) <: HasEqBool E := Nop <+ HasEqDec2Bool E F. + +Module QuotationOfHasEqDec2Bool (E : Eq) (F : HasEqDec E) (Import E' : HasEqDec2BoolSig E F) (Import qE : QuotationOfEq E) (Import qF : QuotationOfHasEqDec E F) <: QuotationOfHasEqBool E E'. + #[export] Instance qeqb : quotation_of eqb := ltac:(cbv [eqb]; exact _). + #[export] Instance qeqb_eq : quotation_of eqb_eq := ltac:(unfold_quotation_of (); exact _). +End QuotationOfHasEqDec2Bool. + +Module Type HasEqBool2DecSig (E : Eq) (F : HasEqBool E) <: HasEqDec E := Nop <+ HasEqBool2Dec E F. + +Module QuotationOfHasEqBool2Dec (E : Eq) (F : HasEqBool E) (Import E' : HasEqBool2DecSig E F) (Import qE : QuotationOfEq E) (Import qF : QuotationOfHasEqBool E F) <: QuotationOfHasEqDec E E'. + #[export] Instance qeq_dec : quotation_of eq_dec := ltac:(cbv [eq_dec]; exact _). +End QuotationOfHasEqBool2Dec. + +Module Type Dec2BoolSig (E : DecidableType) <: BooleanDecidableType := Nop <+ Dec2Bool E. +Module Type Bool2DecSig (E : BooleanEqualityType) <: BooleanDecidableType := Nop <+ Bool2Dec E. + +Module QuotationOfDec2Bool (E : DecidableType) (E' : Dec2BoolSig E) (qE : QuotationOfDecidableType E) <: QuotationOfBooleanDecidableType E' + := qE <+ QuotationOfHasEqDec2Bool E E E'. + +Module QuotationOfBool2Dec (E : BooleanEqualityType) (E' : Bool2DecSig E) (qE : QuotationOfBooleanEqualityType E) <: QuotationOfBooleanDecidableType E' + := qE <+ QuotationOfHasEqBool2Dec E E E'. + +Module Type BoolEqualityFactsSig (E : BooleanEqualityType) := Nop <+ BoolEqualityFacts E. + +Module Type QuotationOfBoolEqualityFacts (Import E : BooleanEqualityType) (Import F : BoolEqualityFactsSig E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F"). +End QuotationOfBoolEqualityFacts. + +Module Type QuotationOfHasUsualEq (Import T : Typ) (Import E : HasUsualEq T) (Import qT : QuotationOfTyp T) <: QuotationOfHasEq T E. + #[export] Instance qeq : quotation_of E.eq := ltac:(cbv [E.eq]; exact _). +End QuotationOfHasUsualEq. + +Module Type QuotationOfUsualEq (E : UsualEq) <: QuotationOfEq E := QuotationOfTyp E <+ QuotationOfHasUsualEq E E. + +Module Type QuotationOfUsualIsEq (E : UsualEq) (Import E' : UsualIsEq E) (Import qE : QuotationOfTyp E) <: QuotationOfIsEq E E'. + #[export] Instance qeq_equiv : quotation_of eq_equiv := ltac:(cbv [eq_equiv]; exact _). +End QuotationOfUsualIsEq. + +Module Type QuotationOfUsualIsEqOrig (E : UsualEq) (Import E' : UsualIsEqOrig E) (Import qE : QuotationOfTyp E) <: QuotationOfIsEqOrig E E'. + #[export] Instance qeq_refl : quotation_of eq_refl := ltac:(cbv [eq_refl]; exact _). + #[export] Instance qeq_sym : quotation_of eq_sym := ltac:(cbv [eq_sym]; exact _). + #[export] Instance qeq_trans : quotation_of eq_trans := ltac:(cbv [eq_trans]; exact _). +End QuotationOfUsualIsEqOrig. + +Module Type QuotationOfUsualEqualityType (E : UsualEqualityType) <: QuotationOfEqualityType E + := QuotationOfUsualEq E <+ QuotationOfUsualIsEq E E. + +Module Type QuotationOfUsualDecidableType (E : UsualDecidableType) <: QuotationOfDecidableType E + := QuotationOfUsualEq E <+ QuotationOfUsualIsEq E E <+ QuotationOfHasEqDec E E. + +Module Type QuotationOfUsualDecidableTypeOrig (E : UsualDecidableTypeOrig) <: QuotationOfDecidableTypeOrig E + := QuotationOfUsualEq E <+ QuotationOfUsualIsEqOrig E E <+ QuotationOfHasEqDec E E. + +Module Type QuotationOfUsualDecidableTypeBoth (E : UsualDecidableTypeBoth) <: QuotationOfDecidableTypeBoth E + := QuotationOfUsualEq E <+ QuotationOfUsualIsEq E E <+ QuotationOfUsualIsEqOrig E E <+ QuotationOfHasEqDec E E. + +Module Type QuotationOfUsualBoolEq (E : UsualBoolEq) := QuotationOfUsualEq E <+ QuotationOfHasEqBool E E. + +Module Type QuotationOfUsualDecidableTypeFull (E : UsualDecidableTypeFull) <: QuotationOfDecidableTypeFull E + := QuotationOfUsualEq E <+ QuotationOfUsualIsEq E E <+ QuotationOfUsualIsEqOrig E E <+ QuotationOfHasEqDec E E <+ QuotationOfHasEqBool E E. + +Module Type QuotationOfMiniDecidableType (Import M : MiniDecidableType). + Include QuotationOfTyp M. + #[export] Declare Instance qeq_dec : quotation_of eq_dec. +End QuotationOfMiniDecidableType. + +Module Type Make_UDTSig (M : MiniDecidableType) <: UsualDecidableTypeBoth := Nop <+ Make_UDT M. +Module Type Make_UDTFSig (M : UsualBoolEq) <: UsualDecidableTypeFull := Nop <+ Make_UDTF M. + +Module QuotationOfMake_UDT (M : MiniDecidableType) (M' : Make_UDTSig M) (qM : QuotationOfMiniDecidableType M) <: QuotationOfUsualDecidableTypeBoth M' + := qM <+ QuotationOfHasUsualEq M' M' <+ QuotationOfUsualIsEq M' M' <+ QuotationOfUsualIsEqOrig M' M'. + +Module QuotationOfMake_UDTF (M : UsualBoolEq) (M' : Make_UDTFSig M) (qM : QuotationOfUsualBoolEq M) <: QuotationOfUsualDecidableTypeFull M' + := qM <+ QuotationOfUsualIsEq M M' <+ QuotationOfUsualIsEqOrig M' M' <+ QuotationOfHasEqBool2Dec M' M' M'. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/Orders/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/Orders/Sig.v new file mode 100644 index 000000000..c1e91e9a4 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/Orders/Sig.v @@ -0,0 +1,155 @@ +From Coq.Structures Require Import Orders. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq Require Export Structures.Equalities.Sig. + +Module Type QuotationOfHasLt (Import T : Typ) (Import E : HasLt T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "E"). +End QuotationOfHasLt. + +Module Type QuotationOfHasLe (Import T : Typ) (Import E : HasLe T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "E"). +End QuotationOfHasLe. + +Module Type QuotationOfEqLt (E : EqLt) := QuotationOfTyp E <+ QuotationOfHasEq E E <+ QuotationOfHasLt E E. +Module Type QuotationOfEqLe (E : EqLe) := QuotationOfTyp E <+ QuotationOfHasEq E E <+ QuotationOfHasLe E E. +Module Type QuotationOfEqLtLe (E : EqLtLe) := QuotationOfTyp E <+ QuotationOfHasEq E E <+ QuotationOfHasLt E E <+ QuotationOfHasLe E E. + +Module Type QuotationOfIsStrOrder (Import E : EqLt) (Import S : IsStrOrder E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfIsStrOrder. + +Module Type QuotationOfLeIsLtEq (Import E : EqLtLe) (Import S : LeIsLtEq E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfLeIsLtEq. + +Module Type QuotationOfStrOrder (E : StrOrder) := QuotationOfEqualityType E <+ QuotationOfHasLt E E <+ QuotationOfIsStrOrder E E. + +Module Type QuotationOfHasCmp (Import T : Typ) (S : HasCmp T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfHasCmp. + +Module Type QuotationOfCmpSpec (Import E : EqLt) (Import C : HasCmp E) (S : CmpSpec E C). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfCmpSpec. + +Module Type QuotationOfHasCompare (E : EqLt) (C : HasCompare E) := QuotationOfHasCmp E C <+ QuotationOfCmpSpec E C C. + +Module Type QuotationOfDecStrOrder (E : DecStrOrder) := QuotationOfStrOrder E <+ QuotationOfHasCompare E E. + +Module Type QuotationOfOrderedType (E : Orders.OrderedType) <: QuotationOfDecidableType E := QuotationOfDecStrOrder E <+ QuotationOfHasEqDec E E. + +Module Type QuotationOfOrderedTypeFull (E : OrderedTypeFull) := QuotationOfOrderedType E <+ QuotationOfHasLe E E <+ QuotationOfLeIsLtEq E E. + +Module Type QuotationOfUsualStrOrder (E : UsualStrOrder) := QuotationOfUsualEqualityType E <+ QuotationOfHasLt E E <+ QuotationOfIsStrOrder E E. +Module Type QuotationOfUsualDecStrOrder (E : UsualDecStrOrder) := QuotationOfUsualStrOrder E <+ QuotationOfHasCompare E E. +Module Type QuotationOfUsualOrderedType (E : UsualOrderedType) <: QuotationOfUsualDecidableType E <: QuotationOfOrderedType E + := QuotationOfUsualDecStrOrder E <+ QuotationOfHasEqDec E E. +Module Type QuotationOfUsualOrderedTypeFull (E : UsualOrderedTypeFull) := QuotationOfUsualOrderedType E <+ QuotationOfHasLe E E <+ QuotationOfLeIsLtEq E E. + +Module Type QuotationOfLtIsTotal (Import E : EqLt) (S : LtIsTotal E). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfLtIsTotal. + +Module Type QuotationOfTotalOrder (E : TotalOrder) := QuotationOfStrOrder E <+ QuotationOfHasLe E E <+ QuotationOfLeIsLtEq E E <+ QuotationOfLtIsTotal E E. +Module Type QuotationOfUsualTotalOrder (E : UsualTotalOrder) <: QuotationOfTotalOrder E + := QuotationOfUsualStrOrder E <+ QuotationOfHasLe E E <+ QuotationOfLeIsLtEq E E <+ QuotationOfLtIsTotal E E. + +Module Type Compare2EqBoolSig (O : DecStrOrder) <: HasEqBool O := Nop <+ Compare2EqBool O. + +(* +Module QuotationOfCompare2EqBool (O : DecStrOrder) (Import E : Compare2EqBoolSig O) (Import qE : QuotationOfDecStrOrder O) <: QuotationOfHasEqBool O E. + #[export] Instance qeqb : quotation_of E.eqb := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeqb_eq : quotation_of E.eqb_eq := ltac:(unfold_quotation_of (); exact _). +End QuotationOfCompare2EqBool. +*) +Module Type DSO_to_OTSig (O : DecStrOrder) <: Orders.OrderedType := Nop <+ DSO_to_OT O. +(* +Module QuotationOfDSO_to_OT (O : DecStrOrder) (E : DSO_to_OTSig O) (qO : QuotationOfDecStrOrder O) <: QuotationOfOrderedType E := + qO <+ QuotationOfCompare2EqBool O E <+ QuotationOfHasEqBool2Dec O E E. +*) +Local Set Warnings Append "-notation-overridden". +Module Type OT_to_FullSig (O : Orders.OrderedType) <: OrderedTypeFull := Nop <+ OT_to_Full O. +Module QuotationOfOT_to_Full (O : Orders.OrderedType) (E : OT_to_FullSig O) (qO : QuotationOfOrderedType O) <: QuotationOfOrderedTypeFull E. + Include qO. + #[export] Instance qle : quotation_of E.le := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qle_lteq : quotation_of E.le_lteq := ltac:(unfold_quotation_of (); exact _). +End QuotationOfOT_to_Full. + +Module Type OTF_LtIsTotalSig (O : OrderedTypeFull) <: LtIsTotal O := Nop <+ OTF_LtIsTotal O. + +Module QuotationOfOTF_LtIsTotal (O : OrderedTypeFull) (S : OTF_LtIsTotalSig O) (Import qO : QuotationOfOrderedTypeFull O) <: QuotationOfLtIsTotal O S. + #[export] Instance qlt_total : quotation_of S.lt_total := ltac:(unfold_quotation_of (); exact _). +End QuotationOfOTF_LtIsTotal. + +Module Type OTF_to_TotalOrderSig (O : OrderedTypeFull) <: TotalOrder := Nop <+ OTF_to_TotalOrder O. +Module QuotationOfOTF_to_TotalOrder (O : OrderedTypeFull) (S : OTF_to_TotalOrderSig O) (qO : QuotationOfOrderedTypeFull O) <: QuotationOfTotalOrder S + := qO <+ QuotationOfOTF_LtIsTotal O S. + +Module Type QuotationOfHasLeb (Import T : Typ) (Import S : HasLeb T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfHasLeb. + +Module Type QuotationOfHasLtb (Import T : Typ) (Import S : HasLtb T). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfHasLtb. + +Module Type QuotationOfLebSpec (T : Typ) (X : HasLe T) (Y : HasLeb T) (S : LebSpec T X Y). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfLebSpec. + +Module Type QuotationOfLtbSpec (T : Typ) (X : HasLt T) (Y : HasLtb T) (S : LtbSpec T X Y). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfLtbSpec. + +Module Type QuotationOfLeBool (E : LeBool) := QuotationOfTyp E <+ QuotationOfHasLeb E E. +Module Type QuotationOfLtBool (E : LtBool) := QuotationOfTyp E <+ QuotationOfHasLtb E E. + +Module Type QuotationOfLebIsTotal (Import X : LeBool) (Import S : LebIsTotal X). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfLebIsTotal. + +Module Type QuotationOfTotalLeBool (E : TotalLeBool) := QuotationOfLeBool E <+ QuotationOfLebIsTotal E E. + +Module Type QuotationOfLebIsTransitive (Import X : LeBool) (S : LebIsTransitive X). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfLebIsTransitive. + +Module Type QuotationOfTotalTransitiveLeBool (E : TotalTransitiveLeBool) := QuotationOfTotalLeBool E <+ QuotationOfLebIsTransitive E E. + +Module Type QuotationOfHasBoolOrdFuns (T : Typ) (S : HasBoolOrdFuns T) := QuotationOfHasEqb T S <+ QuotationOfHasLtb T S <+ QuotationOfHasLeb T S. + +Module Type QuotationOfBoolOrdSpecs (O : EqLtLe) (F : HasBoolOrdFuns O) (S : BoolOrdSpecs O F) := + QuotationOfEqbSpec O O F S <+ QuotationOfLtbSpec O O F S <+ QuotationOfLebSpec O O F S. + +Module Type QuotationOfOrderFunctions (E : EqLtLe) (S : OrderFunctions E) := + QuotationOfHasCompare E S <+ QuotationOfHasBoolOrdFuns E S <+ QuotationOfBoolOrdSpecs E S S. + +Module Type OTF_to_TTLBSig (O : OrderedTypeFull) <: TotalTransitiveLeBool := Nop <+ OTF_to_TTLB O. + +(* +Module QuotationOfOTF_to_TTLB (Import O : OrderedTypeFull) (Import S : OTF_to_TTLBSig O) (Import qO : QuotationOfOrderedTypeFull O) <: QuotationOfTotalTransitiveLeBool S. + #[export] Instance qleb : quotation_of S.leb := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qleb_le : quotation_of S.leb_le := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qleb_total : quotation_of S.leb_total := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qleb_trans : quotation_of S.leb_trans := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qt : quotation_of S.t := ltac:(unfold_quotation_of (); exact _). +End QuotationOfOTF_to_TTLB. +*) +Module Type TTLB_to_OTFSig (O : TotalTransitiveLeBool) <: OrderedTypeFull := Nop <+ TTLB_to_OTF O. +(* +Module QuotationOfTTLB_to_OTF (Import O : TotalTransitiveLeBool) (Import S : TTLB_to_OTFSig O) (Import qO : QuotationOfTotalTransitiveLeBool O) <: QuotationOfOrderedTypeFull S. + #[export] Instance qt : quotation_of S.t := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qle : quotation_of S.le := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt : quotation_of S.lt := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeq : quotation_of S.eq := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare : quotation_of S.compare := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare_spec : quotation_of S.compare_spec := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeqb : quotation_of S.eqb := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeqb_eq : quotation_of S.eqb_eq := ltac:(unfold_quotation_of (); exact _). + Include QuotationOfHasEqBool2Dec S S S. + #[export] Instance qeq_equiv : quotation_of S.eq_equiv := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_strorder : quotation_of S.lt_strorder := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_compat : quotation_of S.lt_compat := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qle_lteq : quotation_of S.le_lteq := ltac:(unfold_quotation_of (); exact _). +End QuotationOfTTLB_to_OTF. +*) diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersAlt/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersAlt/Sig.v new file mode 100644 index 000000000..c315e1a41 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersAlt/Sig.v @@ -0,0 +1,110 @@ +From Coq.Structures Require Import Equalities OrdersAlt. +From Coq.Structures Require OrderedType. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq Require Export Structures.Orders.Sig. +Import List.ListNotations. +Local Open Scope list_scope. + +Module Type QuotationOfOrderedTypeOrig (Import O : OrderedTypeOrig). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "O"). +End QuotationOfOrderedTypeOrig. + +Module Type QuotationOfOrderedTypeAlt (Import O : OrderedTypeAlt). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "O"). +End QuotationOfOrderedTypeAlt. + +Module Type Update_OTSig (O : OrderedTypeOrig) <: Orders.OrderedType := Nop <+ Update_OT O. +(* +Module QuotationOfUpdate_OT (O : OrderedTypeOrig) (S : Update_OTSig O) (Import qO : QuotationOfOrderedTypeOrig O) <: QuotationOfOrderedType S. + + Include QuotationOfUpdate_DT O S qO. (* Provides : qt qeq qeq_equiv qeq_dec *) + #[export] Instance qlt : quotation_of S.lt := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_strorder : quotation_of S.lt_strorder := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_compat : quotation_of S.lt_compat := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare : quotation_of S.compare := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare_spec : quotation_of S.compare_spec := ltac:(unfold_quotation_of (); exact _). +End QuotationOfUpdate_OT. +*) +Module Type Backport_OTSig (O : Orders.OrderedType) <: OrderedTypeOrig := Nop <+ Backport_OT O. +(* +Module QuotationOfBackport_OT (O : Orders.OrderedType) (S : Backport_OTSig O) (Import qO : QuotationOfOrderedType O) <: QuotationOfOrderedTypeOrig S. + + Include QuotationOfBackport_DT O S qO. (* Provides : qt qeq qeq_refl qeq_sym qeq_trans qeq_dec *) + #[export] Instance qlt : quotation_of S.lt := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_not_eq : quotation_of S.lt_not_eq := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_trans : quotation_of S.lt_trans := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare : quotation_of S.compare := ltac:(unfold_quotation_of (); exact _). +End QuotationOfBackport_OT. +*) +Module Type OT_from_AltSig (O : OrderedTypeAlt) <: Orders.OrderedType := Nop <+ OT_from_Alt O. +(* +Module QuotationOfOT_from_Alt (O : OrderedTypeAlt) (S : OT_from_AltSig O) (Import qO : QuotationOfOrderedTypeAlt O) <: QuotationOfOrderedType S. + #[export] Instance qt : quotation_of S.t := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeq : quotation_of S.eq := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt : quotation_of S.lt := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeq_equiv : quotation_of S.eq_equiv := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_strorder : quotation_of S.lt_strorder := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_eq : quotation_of S.lt_eq := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeq_lt : quotation_of S.eq_lt := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_compat : quotation_of S.lt_compat := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare : quotation_of S.compare := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare_spec : quotation_of S.compare_spec := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeq_dec : quotation_of S.eq_dec := ltac:(unfold_quotation_of (); exact _). +End QuotationOfOT_from_Alt. +*) +Module Type OT_to_AltSig (O : Orders.OrderedType) <: OrderedTypeAlt := Nop <+ OT_to_Alt O. +(* +Module QuotationOfOT_to_Alt (O : Orders.OrderedType) (S : OT_to_AltSig O) (Import qO : QuotationOfOrderedType O) <: QuotationOfOrderedTypeAlt S. + #[export] Instance qt : quotation_of S.t := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare : quotation_of S.compare := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare_sym : quotation_of S.compare_sym := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare_Eq : quotation_of S.compare_Eq := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare_Lt : quotation_of S.compare_Lt := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare_Gt : quotation_of S.compare_Gt := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare_trans : quotation_of S.compare_trans := ltac:(unfold_quotation_of (); exact _). +End QuotationOfOT_to_Alt. +*) + +(** * OrderedType *) +Module Type QuotationOfMiniOrderedType (O : OrderedType.MiniOrderedType). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "O"). +End QuotationOfMiniOrderedType. + +Module Type MOT_to_OTOrigSig (O : OrderedType.MiniOrderedType) <: OrderedTypeOrig := Nop <+ OrderedType.MOT_to_OT O. + +Module QuotationOfMOT_to_OTOrig (O : OrderedType.MiniOrderedType) (O' : MOT_to_OTOrigSig O) (Import qO : QuotationOfMiniOrderedType O) <: QuotationOfOrderedTypeOrig O'. + Include qO. + + #[export] Instance qeq_dec : quotation_of O'.eq_dec := ltac:(unfold_quotation_of (); exact _). +End QuotationOfMOT_to_OTOrig. + +Module Type OrderedTypeOrigFactsSig (O : OrderedTypeOrig) := Nop <+ OrderedType.OrderedTypeFacts O. + +Module Type QuotationOfOrderedTypeOrigFacts (O : OrderedTypeOrig) (F : OrderedTypeOrigFactsSig O). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F"). + (*Module qTO. + #[export] Instance qt : quotation_of F.TO.t := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeq : quotation_of F.TO.eq := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt : quotation_of F.TO.lt := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qle : quotation_of F.TO.le := ltac:(unfold_quotation_of (); exact _). + End qTO. + Export (hints) qTO. + Module qIsTO. + #[export] Instance qeq_equiv : quotation_of F.IsTO.eq_equiv := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_strorder : quotation_of F.IsTO.lt_strorder := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_compat : quotation_of F.IsTO.lt_compat := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_total : quotation_of F.IsTO.lt_total := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qle_lteq : quotation_of F.IsTO.le_lteq := ltac:(unfold_quotation_of (); exact _). + End qIsTO. + Export (hints) qIsTO. + Module qOrderTac := !QuotationOfMakeOrderTac F.TO F.IsTO F.OrderTac qTO qIsTO. + Export (hints) qOrderTac.*) +End QuotationOfOrderedTypeOrigFacts. + +Module Type KeyOrderedTypeOrigSig (O : OrderedTypeOrig) := Nop <+ OrderedType.KeyOrderedType O. + +Module Type QuotationOfKeyOrderedTypeOrig (O : OrderedTypeOrig) (K : KeyOrderedTypeOrigSig O). + Module qMO := Nop <+ QuotationOfOrderedTypeOrigFacts O K.MO. + Export (hints) qMO. + MetaCoq Run (tmDeclareQuotationOfModule (all_submodules_except [["MO"]]%bs) (Some export) "K"). +End QuotationOfKeyOrderedTypeOrig. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersFacts/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersFacts/Sig.v new file mode 100644 index 000000000..006a5bec7 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersFacts/Sig.v @@ -0,0 +1,52 @@ +From Coq.Structures Require Import Equalities Orders OrdersFacts. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq Require Export Structures.Orders.Sig. + +Module Type QuotationOfCompareFacts (O : DecStrOrder) (F : CompareFacts O). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F"). +End QuotationOfCompareFacts. + +Module Type OrderedTypeFullFactsSig (O : OrderedTypeFull) := Nop <+ OrderedTypeFullFacts O. + +Module Type QuotationOfOrderedTypeFullFacts (O : OrderedTypeFull) (F : OrderedTypeFullFactsSig O). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F"). +End QuotationOfOrderedTypeFullFacts. + +Module Type OrderedTypeFactsSig (O : Orders.OrderedType) := Nop <+ OrderedTypeFacts O. + +Module Type QuotationOfOrderedTypeFacts (O : Orders.OrderedType) (F : OrderedTypeFactsSig O). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F"). +End QuotationOfOrderedTypeFacts. + +Module Type OrderedTypeRevSig (O : OrderedTypeFull) <: OrderedTypeFull := Nop <+ OrderedTypeRev O. +Module QuotationOfOrderedTypeRev (O : OrderedTypeFull) (S : OrderedTypeRevSig O) (Import qO : QuotationOfOrderedTypeFull O) <: QuotationOfOrderedTypeFull S. + #[export] Instance qt : quotation_of S.t := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeq : quotation_of S.eq := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeq_equiv : quotation_of S.eq_equiv := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qeq_dec : quotation_of S.eq_dec := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt : quotation_of S.lt := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qle : quotation_of S.le := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_strorder : quotation_of S.lt_strorder := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qlt_compat : quotation_of S.lt_compat := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qle_lteq : quotation_of S.le_lteq := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare : quotation_of S.compare := ltac:(unfold_quotation_of (); exact _). + #[export] Instance qcompare_spec : quotation_of S.compare_spec := ltac:(unfold_quotation_of (); exact _). +End QuotationOfOrderedTypeRev. + +Module Type QuotationOfCompareBasedOrder (E : EqLtLe) (C : HasCmp E) (S : CompareBasedOrder E C). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfCompareBasedOrder. + +Module Type QuotationOfCompareBasedOrderFacts (E : EqLtLe) (C : HasCmp E) (O : CompareBasedOrder E C) (F : CompareBasedOrderFacts E C O). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "F"). +End QuotationOfCompareBasedOrderFacts. + +Module Type QuotationOfBoolOrderFacts + (E : EqLtLe) + (C : HasCmp E) + (F : HasBoolOrdFuns E) + (O : CompareBasedOrder E C) + (S : BoolOrdSpecs E F) + (Facts : BoolOrderFacts E C F O S). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "Facts"). +End QuotationOfBoolOrderFacts. diff --git a/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersTac/Sig.v b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersTac/Sig.v new file mode 100644 index 000000000..b7db44a04 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Coq/Structures/OrdersTac/Sig.v @@ -0,0 +1,35 @@ +From Coq.Structures Require Import Equalities Orders OrdersTac. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Coq Require Export Structures.Orders.Sig. + +Module Type QuotationOfIsTotalOrder (O : EqLtLe) (S : IsTotalOrder O) := + QuotationOfIsEq O S <+ QuotationOfIsStrOrder O S <+ QuotationOfLeIsLtEq O S <+ QuotationOfLtIsTotal O S. + +Module Type OrderFactsSig (O : EqLtLe) (P : IsTotalOrder O) := Nop <+ OrderFacts O P. +Module Type QuotationOfOrderFacts (O : EqLtLe) (P : IsTotalOrder O) (S : OrderFactsSig O P). + MetaCoq Run (tmDeclareQuotationOfModule everything (Some export) "S"). +End QuotationOfOrderFacts. + +Module Type MakeOrderTacSig (O : EqLtLe) (P : IsTotalOrder O) := Nop <+ MakeOrderTac O P. + +(* +Module QuotationOfMakeOrderTac (O : EqLtLe) (P : IsTotalOrder O) (S : MakeOrderTacSig O P) (Import qO : QuotationOfEqLtLe O) (Import qP : QuotationOfIsTotalOrder O P). + Include QuotationOfOrderFacts O P S qO qP. +End QuotationOfMakeOrderTac. +*) +Module Type OTF_to_OrderTacSig (OTF : OrderedTypeFull) := Nop <+ OTF_to_OrderTac OTF. +(* +Module QuotationOfOTF_to_OrderTac (OTF : OrderedTypeFull) (S : OTF_to_OrderTacSig OTF) (Import qOTF : QuotationOfOrderedTypeFull OTF). + Module qTO := QuotationOfOTF_to_TotalOrder OTF S.TO qOTF. + Export (hints) qTO. + Include !QuotationOfMakeOrderTac OTF S.TO S qOTF qTO. +End QuotationOfOTF_to_OrderTac. +*) +Module Type OT_to_OrderTacSig (OT : OrderedType) := Nop <+ OT_to_OrderTac OT. +(* +Module QuotationOfOT_to_OrderTac (OT : OrderedType) (S : OT_to_OrderTacSig OT) (Import qOT : QuotationOfOrderedType OT). + Module qOTF := QuotationOfOT_to_Full OT S.OTF qOT. + Export (hints) qOTF. + Include !QuotationOfOTF_to_OrderTac S.OTF S qOTF. +End QuotationOfOT_to_OrderTac. +*) diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v new file mode 100644 index 000000000..1546c1411 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Env/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. + +Module qEnv <: QuotationOfEnvironment TemplateTerm Env. + MetaCoq Run (tmMakeQuotationOfModule everything None "Env"). +End qEnv. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.v new file mode 100644 index 000000000..ec618c6fc --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/EnvHelper/Instances.v @@ -0,0 +1,9 @@ +From MetaCoq.Template Require Import Ast. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.Common Require Import Environment. + +Module QuoteEnvHelper <: QuoteEnvironmentHelperSig TemplateTerm Env := QuoteEnvironmentHelper TemplateTerm Env. + +Module qQuoteEnvHelper <: QuotationOfQuoteEnvironmentHelper TemplateTerm Env QuoteEnvHelper. + MetaCoq Run (tmMakeQuotationOfModule everything None "QuoteEnvHelper"). +End qQuoteEnvHelper. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Instances.v new file mode 100644 index 000000000..a40cdc539 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/Instances.v @@ -0,0 +1,10 @@ +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Template.Ast Require Export + TemplateTerm.Instances + EnvHelper.Instances + Env.Instances + TemplateTermUtils.Instances + TemplateLookup.Instances +. + +(* TODO: maybe do something about [Include TemplateLookup.] *) diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.v new file mode 100644 index 000000000..4af57fa7f --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateLookup/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. + +Module qTemplateLookup <: QuotationOfLookup TemplateTerm Env TemplateLookup. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateLookup"). +End qTemplateLookup. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTerm/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTerm/Instances.v new file mode 100644 index 000000000..cba732505 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTerm/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. + +Module qTemplateTerm <: QuotationOfTerm TemplateTerm. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateTerm"). +End qTemplateTerm. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.v new file mode 100644 index 000000000..72749d0e5 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Ast/TemplateTermUtils/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. + +Module qTemplateTermUtils <: QuotationOfTermUtils TemplateTerm Env TemplateTermUtils. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateTermUtils"). +End qTemplateTermUtils. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.v new file mode 100644 index 000000000..e48fc5d80 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/EnvDecide/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast ReflectAst. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. + +Module qEnvDecide <: QuotationOfEnvironmentDecide TemplateTerm Env EnvDecide. + MetaCoq Run (tmMakeQuotationOfModule everything None "EnvDecide"). +End qEnvDecide. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/Instances.v new file mode 100644 index 000000000..29ccdf230 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/Instances.v @@ -0,0 +1,5 @@ +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Template.ReflectAst Require Export + TemplateTermDecide.Instances + EnvDecide.Instances +. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/TemplateTermDecide/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/TemplateTermDecide/Instances.v new file mode 100644 index 000000000..1d2b0bd02 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/ReflectAst/TemplateTermDecide/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast ReflectAst. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig. + +Module qTemplateTermDecide <: QuotationOfTermDecide TemplateTerm TemplateTermDecide. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateTermDecide"). +End qTemplateTermDecide. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/Instances.v new file mode 100644 index 000000000..adcf8ca36 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/Instances.v @@ -0,0 +1,9 @@ +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Template.Typing Require Export + TemplateEnvTyping.Instances + TemplateConversion.Instances + TemplateGlobalMaps.Instances + TemplateConversionPar.Instances + TemplateTyping.Instances + TemplateDeclarationTyping.Instances +. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.v new file mode 100644 index 000000000..5c17e1e15 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversion/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast Typing. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. + +Module qTemplateConversion <: QuotationOfConversion TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateConversion"). +End qTemplateConversion. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.v new file mode 100644 index 000000000..9c0b6267f --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateConversionPar/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast Typing. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. + +Module qTemplateConversionPar <: QuotationOfConversionPar TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversionPar. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateConversionPar"). +End qTemplateConversionPar. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.v new file mode 100644 index 000000000..306d3d118 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateDeclarationTyping/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast Typing. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. + +Module qTemplateDeclarationTyping <: QuotationOfDeclarationTyping TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion TemplateConversionPar TemplateTyping TemplateLookup TemplateGlobalMaps TemplateDeclarationTyping. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateDeclarationTyping"). +End qTemplateDeclarationTyping. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.v new file mode 100644 index 000000000..0092625b0 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateEnvTyping/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast Typing. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. + +Module qTemplateEnvTyping <: QuotationOfEnvTyping TemplateTerm Env TemplateTermUtils TemplateEnvTyping. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateEnvTyping"). +End qTemplateEnvTyping. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.v new file mode 100644 index 000000000..722dd8929 --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateGlobalMaps/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast Typing. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. + +Module qTemplateGlobalMaps <: QuotationOfGlobalMaps TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion TemplateLookup TemplateGlobalMaps. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateGlobalMaps"). +End qTemplateGlobalMaps. diff --git a/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.v b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.v new file mode 100644 index 000000000..ea325a5bf --- /dev/null +++ b/quotation/theories/ToTemplate/QuotationOf/Template/Typing/TemplateTyping/Instances.v @@ -0,0 +1,7 @@ +From MetaCoq.Template Require Import Ast Typing. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. + +Module qTemplateTyping <: QuotationOfTyping TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion TemplateConversionPar TemplateTyping. + MetaCoq Run (tmMakeQuotationOfModule everything None "TemplateTyping"). +End qTemplateTyping. diff --git a/quotation/theories/ToTemplate/Template/Ast.v b/quotation/theories/ToTemplate/Template/Ast.v new file mode 100644 index 000000000..28de2e3df --- /dev/null +++ b/quotation/theories/ToTemplate/Template/Ast.v @@ -0,0 +1,29 @@ +From MetaCoq.Template Require Import Ast ReflectAst Induction. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.Lists Coq.Numbers Coq.Floats. +From MetaCoq.Quotation.ToTemplate.Common Require Import (hints) Universes BasicAst Kernames. +From MetaCoq.Quotation.ToTemplate.Common Require Import Environment EnvironmentTyping. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import Environment.Sig EnvironmentTyping.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Template Require Import Ast.Instances ReflectAst.Instances. + +#[export] Instance quote_predicate {term} {qterm : quotation_of term} {quote_term : ground_quotable term} : ground_quotable (predicate term) := ltac:(destruct 1; exact _). +#[export] Instance quote_branch {term} {qterm : quotation_of term} {quote_term : ground_quotable term} : ground_quotable (branch term) := ltac:(destruct 1; exact _). +#[local] Hint Extern 1 => assumption : typeclass_instances. +#[export] Instance quote_term : ground_quotable term := ltac:(induction 1 using term_forall_list_rect; exact _). + +Module QuoteTemplateTerm <: QuoteTerm TemplateTerm. + #[export] Instance quote_term : ground_quotable TemplateTerm.term := ltac:(cbv [TemplateTerm.term]; exact _). +End QuoteTemplateTerm. +Export (hints) QuoteTemplateTerm. + +Module QuoteEnv := QuoteEnvironment TemplateTerm Env QuoteEnvHelper qTemplateTerm qEnv qQuoteEnvHelper QuoteTemplateTerm. +Export (hints) QuoteEnv. + +Module QuoteTemplateLookup := QuoteLookup TemplateTerm Env TemplateLookup EnvDecide qEnv qTemplateLookup qEnvDecide QuoteEnv. +Export (hints) QuoteTemplateLookup. + +#[export] Instance quote_parameter_entry : ground_quotable parameter_entry := ltac:(destruct 1; exact _). +#[export] Instance quote_definition_entry : ground_quotable definition_entry := ltac:(destruct 1; exact _). +#[export] Instance quote_constant_entry : ground_quotable constant_entry := ltac:(destruct 1; exact _). +#[export] Instance quote_one_inductive_entry : ground_quotable one_inductive_entry := ltac:(destruct 1; exact _). +#[export] Instance quote_mutual_inductive_entry : ground_quotable mutual_inductive_entry := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Template/AstUtils.v b/quotation/theories/ToTemplate/Template/AstUtils.v new file mode 100644 index 000000000..d877facb1 --- /dev/null +++ b/quotation/theories/ToTemplate/Template/AstUtils.v @@ -0,0 +1,10 @@ +From MetaCoq.Template Require Import AstUtils. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init. +From MetaCoq.Quotation.ToTemplate.Template Require Import (hints) Ast. + +#[export] Instance quote_mkApps_spec {f args fargs1 args2 fargs} : ground_quotable (@mkApps_spec f args fargs1 args2 fargs) := ltac:(destruct 1; exact _). +(* +#[export] Instance quote_tCaseBrsType {A P l} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall x, ground_quotable (P x)} : ground_quotable (@tCaseBrsType A P l) := _. +#[export] Instance quote_tFixType {A P P' m} {qA : quotation_of A} {qP : quotation_of P} {qP' : quotation_of P'} {quoteA : ground_quotable A} {quoteP : forall x, ground_quotable (P x)} {quoteP' : forall x, ground_quotable (P' x)} : ground_quotable (@tFixType A P P' m) := _. +*) diff --git a/quotation/theories/ToTemplate/Template/Induction.v b/quotation/theories/ToTemplate/Template/Induction.v new file mode 100644 index 000000000..8d576052e --- /dev/null +++ b/quotation/theories/ToTemplate/Template/Induction.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant/Class here *) diff --git a/quotation/theories/ToTemplate/Template/LiftSubst.v b/quotation/theories/ToTemplate/Template/LiftSubst.v new file mode 100644 index 000000000..8d576052e --- /dev/null +++ b/quotation/theories/ToTemplate/Template/LiftSubst.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant/Class here *) diff --git a/quotation/theories/ToTemplate/Template/ReflectAst.v b/quotation/theories/ToTemplate/Template/ReflectAst.v new file mode 100644 index 000000000..8d576052e --- /dev/null +++ b/quotation/theories/ToTemplate/Template/ReflectAst.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant/Class here *) diff --git a/quotation/theories/ToTemplate/Template/TermEquality.v b/quotation/theories/ToTemplate/Template/TermEquality.v new file mode 100644 index 000000000..eac3907cc --- /dev/null +++ b/quotation/theories/ToTemplate/Template/TermEquality.v @@ -0,0 +1,48 @@ +From MetaCoq.Template Require Import Ast TermEquality. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.Lists Coq.Numbers Coq.Floats. +From MetaCoq.Quotation.ToTemplate.Utils Require Import (hints) utils All_Forall. +From MetaCoq.Quotation.ToTemplate.Common Require Import (hints) config Reflect Environment Universes BasicAst Kernames. +From MetaCoq.Quotation.ToTemplate.Template Require Import (hints) Ast AstUtils Induction. + +#[export] Instance quote_R_universe_instance {R u u'} {qR : quotation_of R} {quoteR : forall x y, ground_quotable (R x y:Prop)} : ground_quotable (@R_universe_instance R u u') := ltac:(cbv [R_universe_instance]; exact _). +Section with_R. + Context {Re Rle : Universe.t -> Universe.t -> Prop} + {qRe : quotation_of Re} {qRle : quotation_of Rle} + {quoteRe : forall x y, ground_quotable (Re x y)} {quoteRle : forall x y, ground_quotable (Rle x y)}. + + #[export] Instance quote_R_universe_variance {v u u'} : ground_quotable (@R_universe_variance Re Rle v u u') := ltac:(cbv [R_universe_variance]; exact _). + + #[export] Instance quote_R_universe_instance_variance {v u u'} : ground_quotable (@R_universe_instance_variance Re Rle v u u') := ltac:(revert v u'; induction u, u'; cbn; exact _). + + #[export] Instance quote_R_opt_variance {v u u'} : ground_quotable (@R_opt_variance Re Rle v u u') := ltac:(destruct v; cbv [R_opt_variance]; exact _). + + #[export] Instance quote_R_global_instance {Σ gr napp u u'} : ground_quotable (@R_global_instance Σ Re Rle gr napp u u') := ltac:(cbv [R_global_instance]; exact _). +End with_R. +#[export] Existing Instances + quote_R_universe_variance + quote_R_universe_instance_variance + quote_R_opt_variance + quote_R_global_instance +. + +#[export] Instance quote_compare_decls {eq_term leq_term u u'} {qeq_term : quotation_of eq_term} {qleq_term : quotation_of leq_term} {quote_eq_term : forall x y, ground_quotable (eq_term x y)} {quote_leq_term : forall x y, ground_quotable (leq_term x y)} : ground_quotable (@compare_decls eq_term leq_term u u') + := ltac:(destruct 1; exact _). + +#[export] Instance quote_eq_term_upto_univ_napp + {Re Rle : Universe.t -> Universe.t -> Prop} + {qRe : quotation_of Re} {qRle : quotation_of Rle} + {quoteRe : forall x y, ground_quotable (Re x y)} {quoteRle : forall x y, ground_quotable (Rle x y)} + {Σ napp x y} + : ground_quotable (@eq_term_upto_univ_napp Σ Re Rle napp x y). +Proof. + unfold ground_quotable; revert Σ Re Rle napp x y qRe qRle quoteRe quoteRle. + fix quote_eq_term_upto_univ_napp 11; intros. + lazymatch type of quote_eq_term_upto_univ_napp with + | forall (x1 : ?X1) (x2 : ?X2) (x3 : ?X3) (x4 : ?X4) (x5 : ?X5) (x6 : ?X6) (x7 : ?X7) (x8 : ?X8) (x9 : ?X9) (x10 : ?X10) (t : ?X11), quotation_of t + => change (forall (x1 : X1) (x2 : X2) (x3 : X3) (x4 : X4) (x5 : X5) (x6 : X6) (x7 : X7) (x8 : X8) (x9 : X9) (x10 : X10), ground_quotable X11) in quote_eq_term_upto_univ_napp + end. + destruct t; replace_quotation_of_goal (). +Defined. + +#[export] Instance quote_compare_term {cf pb Σ ϕ x y} : ground_quotable (@compare_term cf pb Σ ϕ x y) := ltac:(cbv [compare_term]; exact _). diff --git a/quotation/theories/ToTemplate/Template/Typing.v b/quotation/theories/ToTemplate/Template/Typing.v new file mode 100644 index 000000000..bc287b3fa --- /dev/null +++ b/quotation/theories/ToTemplate/Template/Typing.v @@ -0,0 +1,119 @@ +From MetaCoq.Template Require Import Ast Typing. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.Lists Coq.Numbers Coq.Floats. +From MetaCoq.Quotation.ToTemplate.Utils Require Import (hints) utils All_Forall (* MCProd*). +From MetaCoq.Quotation.ToTemplate.Common Require Import (hints) config BasicAst Universes Kernames Environment EnvironmentTyping Primitive Reflect. +From MetaCoq.Quotation.ToTemplate.Template Require Import (hints) AstUtils + LiftSubst UnivSubst ReflectAst TermEquality WfAst. +From MetaCoq.Quotation.ToTemplate.Common Require Import Environment EnvironmentTyping. +From MetaCoq.Quotation.ToTemplate.Template Require Import Ast. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Common Require Import EnvironmentTyping.Sig. +From MetaCoq.Quotation.ToTemplate.QuotationOf.Template Require Import Ast.Instances Typing.Instances. + +#[export] Instance quote_instantiate_params_subst_spec {params pars s pty s' pty'} : ground_quotable (@instantiate_params_subst_spec params pars s pty s' pty'). +Proof. + revert params pars s pty s' pty'; induction params as [|a params]; intros; [ | destruct a as [? [] ?], pty ]; destruct pars. + all: try solve [ intro H; exfalso; inversion H ]. + { intro pf. + assert (s' = s) by now inversion pf. + assert (pty' = pty) by now inversion pf. + subst. + revert pf. + adjust_ground_quotable_by_econstructor_inversion (). } + adjust_ground_quotable_by_econstructor_inversion (). + adjust_ground_quotable_by_econstructor_inversion (). + adjust_ground_quotable_by_econstructor_inversion (). +Defined. +#[export] Instance quote_red1 {Σ Γ x y} : ground_quotable (@red1 Σ Γ x y). +Proof. + revert Γ x y; cbv [ground_quotable]. + fix quote_red1 4; change (forall Γ x y, ground_quotable (@red1 Σ Γ x y)) in quote_red1. + intros Γ x y. + destruct 1; replace_quotation_of_goal (). +Defined. +#[export] Instance quote_red {Σ Γ x y} : ground_quotable (@red Σ Γ x y) := ltac:(induction 1; exact _). +#[export] Instance quote_eq_term_nocast {cf Σ ϕ t u} : ground_quotable (@eq_term_nocast cf Σ ϕ t u) := ltac:(cbv [eq_term_nocast]; exact _). +#[export] Instance quote_leq_term_nocast {cf Σ ϕ t u} : ground_quotable (@leq_term_nocast cf Σ ϕ t u) := ltac:(cbv [leq_term_nocast]; exact _). +#[export] Instance quote_cumul_gen {cf Σ Γ pb t u} : ground_quotable (@cumul_gen cf Σ Γ pb t u) := ltac:(induction 1; exact _). +#[export] Instance quote_eq_opt_term {cf Σ ϕ t u} : ground_quotable (@eq_opt_term cf Σ ϕ t u) := ltac:(cbv [eq_opt_term]; exact _). +#[export] Instance quote_eq_decl {cf Σ ϕ d d'} : ground_quotable (@eq_decl cf Σ ϕ d d') := ltac:(cbv [eq_decl]; exact _). +#[export] Instance quote_eq_context {cf Σ ϕ d d'} : ground_quotable (@eq_context cf Σ ϕ d d') := ltac:(cbv [eq_context]; exact _). + +Module QuoteTemplateEnvTyping := QuoteEnvTyping TemplateTerm Env TemplateTermUtils TemplateEnvTyping qTemplateTerm qEnv qTemplateEnvTyping QuoteTemplateTerm QuoteEnv. +Export (hints) QuoteTemplateEnvTyping. + +Module QuoteTemplateConversion := QuoteConversion TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion qTemplateTerm qEnv qTemplateConversion QuoteTemplateTerm QuoteEnv. +Export (hints) QuoteTemplateConversion. + +Module QuoteTemplateGlobalMaps := QuoteGlobalMaps TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversion TemplateLookup TemplateGlobalMaps qTemplateTerm qEnv qTemplateEnvTyping qTemplateConversion qTemplateLookup qTemplateGlobalMaps QuoteTemplateTerm QuoteEnv QuoteTemplateEnvTyping QuoteTemplateConversion QuoteTemplateLookup. +Export (hints) QuoteTemplateGlobalMaps. + +Module QuoteTemplateConversionPar <: QuoteConversionParSig TemplateTerm Env TemplateTermUtils TemplateEnvTyping TemplateConversionPar. + #[export] Instance quote_cumul_gen {cf Σ Γ pb t t'} : ground_quotable (@TemplateConversionPar.cumul_gen cf Σ Γ pb t t') := ltac:(cbv [TemplateConversionPar.cumul_gen]; exact _). +End QuoteTemplateConversionPar. +Export (hints) QuoteTemplateConversionPar. + +Section quote_typing. + Context {cf : config.checker_flags} {Σ : global_env_ext}. + + #[local] Hint Extern 1 => progress cbv zeta : typeclass_instances. + Typeclasses Transparent typ_or_sort. + Hint Unfold + consistent_instance_ext + : quotation. + Typeclasses Transparent + consistent_instance_ext + . + + + Fixpoint quote_typing' {Γ t T} (pf : @typing cf Σ Γ t T) {struct pf} : quotation_of pf + with quote_typing_spine' {Γ t s T} (pf : @typing_spine cf Σ Γ t s T) {struct pf} : quotation_of pf. + Proof. + all: change (forall Γ t T, ground_quotable (@typing cf Σ Γ t T)) in quote_typing'. + all: change (forall Γ t s T, ground_quotable (@typing_spine cf Σ Γ t s T)) in quote_typing_spine'. + all: destruct pf. + Time all: [ > time replace_quotation_of_goal () .. ]. + Defined. +End quote_typing. +#[export] Instance quote_typing {cf Σ Γ t T} : ground_quotable (@typing cf Σ Γ t T) := quote_typing'. +#[export] Instance quote_typing_spine {cf Σ Γ t s T} : ground_quotable (@typing_spine cf Σ Γ t s T) := quote_typing_spine'. + +#[export] Instance quote_has_nparams {npars ty} : ground_quotable (@has_nparams npars ty) := ltac:(cbv [has_nparams]; exact _). +#[export] Instance quote_infer_sorting {cf Σ Γ T} : ground_quotable (@infer_sorting cf Σ Γ T) := ltac:(cbv [infer_sorting]; exact _). + +Module QuoteTemplateTyping <: QuoteTyping TemplateTerm Env TemplateTermUtils TemplateEnvTyping + TemplateConversion TemplateConversionPar TemplateTyping. + #[export] Instance quote_typing {cf Σ Γ t T} : ground_quotable (@TemplateTyping.typing cf Σ Γ t T) := quote_typing. +End QuoteTemplateTyping. +Export (hints) QuoteTemplateTyping. + +Module QuoteTemplateDeclarationTyping + := QuoteDeclarationTyping + TemplateTerm + Env + TemplateTermUtils + TemplateEnvTyping + TemplateConversion + TemplateConversionPar + TemplateTyping + TemplateLookup + TemplateGlobalMaps + TemplateDeclarationTyping + qTemplateTerm + qEnv + qTemplateEnvTyping + qTemplateConversion + qTemplateTyping + qTemplateGlobalMaps + QuoteTemplateTerm + QuoteEnv + QuoteTemplateEnvTyping + QuoteTemplateConversion + QuoteTemplateTyping + QuoteTemplateLookup + QuoteTemplateGlobalMaps. +Export (hints) QuoteTemplateDeclarationTyping. + +#[export] Instance quote_wf {cf Σ} : ground_quotable (@wf cf Σ) := ltac:(cbv [wf]; exact _). +#[export] Instance quote_wf_ext {cf Σ} : ground_quotable (@wf_ext cf Σ) := ltac:(cbv [wf_ext]; exact _). +#[export] Instance quote_Forall_typing_spine {cf Σ Γ P T t U tls} {qP : quotation_of P} {quoteP : forall x y, ground_quotable (P x y)} : ground_quotable (@Forall_typing_spine cf Σ Γ P T t U tls) := ltac:(induction 1; exact _). diff --git a/quotation/theories/ToTemplate/Template/UnivSubst.v b/quotation/theories/ToTemplate/Template/UnivSubst.v new file mode 100644 index 000000000..8d576052e --- /dev/null +++ b/quotation/theories/ToTemplate/Template/UnivSubst.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant/Class here *) diff --git a/quotation/theories/ToTemplate/Template/WfAst.v b/quotation/theories/ToTemplate/Template/WfAst.v new file mode 100644 index 000000000..a7b1fbeb9 --- /dev/null +++ b/quotation/theories/ToTemplate/Template/WfAst.v @@ -0,0 +1,18 @@ +From MetaCoq.Template Require Import Ast WfAst. +From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.Lists Coq.Numbers Coq.Floats. +From MetaCoq.Quotation.ToTemplate.Utils Require Import (hints) utils All_Forall MCProd. +From MetaCoq.Quotation.ToTemplate.Common Require Import (hints) config BasicAst Universes Kernames. +From MetaCoq.Quotation.ToTemplate.Template Require Import (hints) Ast AstUtils Induction UnivSubst. + +#[export] Instance quote_wf {Σ t} : ground_quotable (@wf Σ t). +Proof. + cbv [ground_quotable]; revert t. + fix quote_wf 2; change (forall t, ground_quotable (@wf Σ t)) in quote_wf. + intro t; destruct 1; replace_quotation_of_goal (). +Defined. + +#[export] Instance quote_wf_Inv {Σ t} : ground_quotable (@wf_Inv Σ t) := ltac:(cbv [wf_Inv]; exact _). +Import StrongerInstances. +#[export] Instance quote_wf_decl {Σ d} : ground_quotable (@wf_decl Σ d) := ltac:(cbv [wf_decl]; exact _). +#[export] Instance quote_wf_decl_pred {Σ Γ t T} : ground_quotable (@wf_decl_pred Σ Γ t T) := ltac:(cbv [wf_decl_pred]; exact _). diff --git a/quotation/theories/ToTemplate/Utils/All_Forall.v b/quotation/theories/ToTemplate/Utils/All_Forall.v new file mode 100644 index 000000000..3ca6da367 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/All_Forall.v @@ -0,0 +1,14 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Utils Require Import All_Forall. + +#[export] Instance quote_All {A R ls} {qA : quotation_of A} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteR : forall x, ground_quotable (R x)} : ground_quotable (@All A R ls) := ltac:(induction 1; exact _). +#[export] Instance quote_Alli {A P n ls} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall n x, ground_quotable (P n x)} : ground_quotable (@Alli A P n ls) := ltac:(induction 1; exact _). +#[export] Instance quote_All2 {A B R lsA lsB} {qA : quotation_of A} {qB : quotation_of B} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteR : forall x y, ground_quotable (R x y)} : ground_quotable (@All2 A B R lsA lsB) := ltac:(induction 1; exact _). +#[export] Instance quote_All2i {A B R n lsA lsB} {qA : quotation_of A} {qB : quotation_of B} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteR : forall n x y, ground_quotable (R n x y)} : ground_quotable (@All2i A B R n lsA lsB) := ltac:(induction 1; exact _). +#[export] Instance quote_All3 {A B C R lsA lsB lsC} {qA : quotation_of A} {qB : quotation_of B} {qB : quotation_of C} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteC : ground_quotable C} {quoteR : forall x y z, ground_quotable (R x y z)} : ground_quotable (@All3 A B C R lsA lsB lsC) := ltac:(induction 1; exact _). +#[export] Instance quote_OnOne2 {A R lsA lsB} {qA : quotation_of A} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteR : forall x y, ground_quotable (R x y)} : ground_quotable (@OnOne2 A R lsA lsB) := ltac:(induction 1; exact _). +#[export] Instance quote_OnOne2i {A R n lsA lsB} {qA : quotation_of A} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteR : forall n x y, ground_quotable (R n x y)} : ground_quotable (@OnOne2i A R n lsA lsB) := ltac:(induction 1; exact _). +#[export] Instance quote_OnOne2All {A B P lsB lsA1 lsA2} {qA : quotation_of A} {qB : quotation_of B} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteP : forall b x y, ground_quotable (P b x y)} : ground_quotable (@OnOne2All A B P lsB lsA1 lsA2) := ltac:(induction 1; exact _). +#[export] Instance quote_All2i_len {A B R lsA lsB} {qA : quotation_of A} {qB : quotation_of B} {qR : quotation_of R} {quoteA : ground_quotable A} {quoteB : ground_quotable B} {quoteR : forall n x y, ground_quotable (R n x y)} : ground_quotable (@All2i_len A B R lsA lsB) := ltac:(induction 1; exact _). +#[export] Instance quote_All_fold {A P ls} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall x y, ground_quotable (P x y)} : ground_quotable (@All_fold A P ls) := ltac:(induction 1; exact _). +#[export] Instance quote_All2_fold {A P ls1 ls2} {qA : quotation_of A} {qP : quotation_of P} {quoteA : ground_quotable A} {quoteP : forall x y z w, ground_quotable (P x y z w)} : ground_quotable (@All2_fold A P ls1 ls2) := ltac:(induction 1; exact _). diff --git a/quotation/theories/ToTemplate/Utils/ByteCompare.v b/quotation/theories/ToTemplate/Utils/ByteCompare.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/ByteCompare.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/ByteCompareSpec.v b/quotation/theories/ToTemplate/Utils/ByteCompareSpec.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/ByteCompareSpec.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/ByteCompare_opt.v b/quotation/theories/ToTemplate/Utils/ByteCompare_opt.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/ByteCompare_opt.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/LibHypsNaming.v b/quotation/theories/ToTemplate/Utils/LibHypsNaming.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/LibHypsNaming.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/MCArith.v b/quotation/theories/ToTemplate/Utils/MCArith.v new file mode 100644 index 000000000..c5eca7cfc --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCArith.v @@ -0,0 +1,4 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Utils Require Import MCArith. + +#[export] Instance quote_BoolSpecSet {P Q : Prop} {b} {qP : quotation_of P} {qQ : quotation_of Q} {quoteP : ground_quotable P} {quoteQ : ground_quotable Q} : ground_quotable (BoolSpecSet P Q b) := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Utils/MCCompare.v b/quotation/theories/ToTemplate/Utils/MCCompare.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCCompare.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/MCEquality.v b/quotation/theories/ToTemplate/Utils/MCEquality.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCEquality.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/MCList.v b/quotation/theories/ToTemplate/Utils/MCList.v new file mode 100644 index 000000000..53728f9b6 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCList.v @@ -0,0 +1,4 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Utils Require Import MCList. + +#[export] Instance quote_nth_error_Spec {A l n o} {qA : quotation_of A} {quoteA : ground_quotable A} {qo : quotation_of o} {ql : quotation_of l} : ground_quotable (@nth_error_Spec A l n o) := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Utils/MCOption.v b/quotation/theories/ToTemplate/Utils/MCOption.v new file mode 100644 index 000000000..6d5a37cf0 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCOption.v @@ -0,0 +1,39 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Utils Require Import MCOption MCRelations. + +#[local] Hint Extern 0 => reflexivity : typeclass_instances. + +#[export] Instance quote_ForOption {A P o} {qA : quotation_of A} {qP : quotation_of P} {qo : quotation_of o} {quoteP : forall t, o = Some t -> ground_quotable (P t:Prop)} : ground_quotable (@ForOption A P o). +Proof. + destruct o; adjust_ground_quotable_by_econstructor_inversion (); eauto. +Defined. + +#[export] Instance quote_option_extends {A o1 o2} {qA : quotation_of A} {qo1 : quotation_of o1} {qo2 : quotation_of o2} {quoteA : forall t, o2 = Some t -> quotation_of t} : ground_quotable (@option_extends A o1 o2). +Proof. + destruct o1 as [a|], o2 as [a'|]. + all: try specialize (quoteA _ eq_refl). + all: try solve [ intro pf; exfalso; inversion pf ]. + all: try (intro pf; assert (a = a') by (now inversion pf); subst; + let t := type of pf in + revert pf; change (ground_quotable t)). + all: adjust_ground_quotable_by_econstructor_inversion (). +Defined. + +#[export] Polymorphic Instance quote_option_default {A P o b} {quoteP : forall x, o = Some x -> ground_quotable (P x)} {quoteP' : o = None -> ground_quotable b} : ground_quotable (@option_default A Type P o b) := ltac:(destruct o; cbv [option_default]; exact _). + +#[export] Instance quote_on_Some {A P o} {quoteP : forall x, o = Some x -> ground_quotable (P x:Prop)} : ground_quotable (@on_Some A P o) := ltac:(destruct o; cbv [on_Some]; exact _). +#[export] Typeclasses Opaque on_Some. +#[export] Instance quote_on_Some_or_None {A P o} {quoteP : forall x, o = Some x -> ground_quotable (P x:Prop)} : ground_quotable (@on_Some_or_None A P o) := ltac:(destruct o; cbv [on_Some_or_None]; exact _). +#[export] Typeclasses Opaque on_Some_or_None. +#[export] Instance quote_on_some {A P o} {quoteP : forall x, o = Some x -> ground_quotable (P x)} : ground_quotable (@on_some A P o) := ltac:(destruct o; cbv [on_some]; exact _). +#[export] Typeclasses Opaque on_some. +#[export] Instance quote_on_some_or_none {A P o} {quoteP : forall x, o = Some x -> ground_quotable (P x)} : ground_quotable (@on_some_or_none A P o) := ltac:(destruct o; cbv [on_some_or_none]; exact _). +#[export] Typeclasses Opaque on_some_or_none. +Lemma on_Some_or_None_iff_forall {A P o} : @on_Some_or_None A P o <-> (forall x, o = Some x -> P x). +Proof. destruct o; cbn; firstorder try congruence. Qed. +#[export] Instance quote_forall_eq_Some_impl {A P o} {qA : quotation_of A} {qP : quotation_of P} {qo : quotation_of o} {quoteP : forall x, o = Some x -> ground_quotable (P x:Prop)} : ground_quotable (forall x, o = Some x -> P x) | 10 + := ground_quotable_of_iff (@on_Some_or_None_iff_forall A P o). +Lemma on_some_or_none_iff_forall {A P o} : @on_some_or_none A P o <~> (forall x, o = Some x -> P x). +Proof. destruct o; cbn; firstorder try congruence. Qed. +#[export] Polymorphic Instance quote_forall_eq_some_impl {A P o} {qA : quotation_of A} {qP : quotation_of P} {qo : quotation_of o} {quoteP : forall x, o = Some x -> ground_quotable (P x)} : ground_quotable (forall x, o = Some x -> P x) | 20 + := ground_quotable_of_iffT (@on_some_or_none_iff_forall A P o). diff --git a/quotation/theories/ToTemplate/Utils/MCPred.v b/quotation/theories/ToTemplate/Utils/MCPred.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCPred.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/MCPrelude.v b/quotation/theories/ToTemplate/Utils/MCPrelude.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCPrelude.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/MCProd.v b/quotation/theories/ToTemplate/Utils/MCProd.v new file mode 100644 index 000000000..4e85411d9 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCProd.v @@ -0,0 +1,19 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Utils Require Import MCProd. + +Section and. + Context {P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 : Type} + {qP1 : quotation_of P1} {qP2 : quotation_of P2} {qP3 : quotation_of P3} {qP4 : quotation_of P4} {qP5 : quotation_of P5} {qP6 : quotation_of P6} {qP7 : quotation_of P7} {qP8 : quotation_of P8} {qP9 : quotation_of P9} {qP10 : quotation_of P10} + {quoteP1 : ground_quotable P1} {quoteP2 : ground_quotable P2} {quoteP3 : ground_quotable P3} {quoteP4 : ground_quotable P4} {quoteP5 : ground_quotable P5} {quoteP6 : ground_quotable P6} {quoteP7 : ground_quotable P7} {quoteP8 : ground_quotable P8} {quoteP9 : ground_quotable P9} {quoteP10 : ground_quotable P10}. + + #[export] Instance quote_and3 : ground_quotable (@and3 P1 P2 P3) := ltac:(destruct 1; exact _). + #[export] Instance quote_and4 : ground_quotable (@and4 P1 P2 P3 P4) := ltac:(destruct 1; exact _). + #[export] Instance quote_and5 : ground_quotable (@and5 P1 P2 P3 P4 P5) := ltac:(destruct 1; exact _). + #[export] Instance quote_and6 : ground_quotable (@and6 P1 P2 P3 P4 P5 P6) := ltac:(destruct 1; exact _). + #[export] Instance quote_and7 : ground_quotable (@and7 P1 P2 P3 P4 P5 P6 P7) := ltac:(destruct 1; exact _). + #[export] Instance quote_and8 : ground_quotable (@and8 P1 P2 P3 P4 P5 P6 P7 P8) := ltac:(destruct 1; exact _). + #[export] Instance quote_and9 : ground_quotable (@and9 P1 P2 P3 P4 P5 P6 P7 P8 P9) := ltac:(destruct 1; exact _). + #[export] Instance quote_and10 : ground_quotable (@and10 P1 P2 P3 P4 P5 P6 P7 P8 P9 P10) := ltac:(destruct 1; exact _). +End and. +#[export] Existing Instances + quote_and3 quote_and4 quote_and5 quote_and6 quote_and7 quote_and8 quote_and9 quote_and10. diff --git a/quotation/theories/ToTemplate/Utils/MCReflect.v b/quotation/theories/ToTemplate/Utils/MCReflect.v new file mode 100644 index 000000000..dc3c77035 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCReflect.v @@ -0,0 +1,4 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Utils Require Import MCReflect. + +#[export] Instance quote_reflectT {A} {qA : quotation_of A} {quoteA : ground_quotable A} {quote_negA : ground_quotable (A -> False)} {b} : ground_quotable (@reflectT A b) := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Utils/MCRelations.v b/quotation/theories/ToTemplate/Utils/MCRelations.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCRelations.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/MCSquash.v b/quotation/theories/ToTemplate/Utils/MCSquash.v new file mode 100644 index 000000000..bbb9bc0e2 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCSquash.v @@ -0,0 +1 @@ +(* squash is not quotable *) diff --git a/quotation/theories/ToTemplate/Utils/MCString.v b/quotation/theories/ToTemplate/Utils/MCString.v new file mode 100644 index 000000000..6abe48271 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCString.v @@ -0,0 +1 @@ +(* No Inductive/Record/Variant here *) diff --git a/quotation/theories/ToTemplate/Utils/MCUtils.v b/quotation/theories/ToTemplate/Utils/MCUtils.v new file mode 100644 index 000000000..88d928536 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/MCUtils.v @@ -0,0 +1,16 @@ +From MetaCoq.Quotation.ToTemplate.Utils Require Import + MCPrelude + MCReflect + All_Forall + MCArith + MCCompare + MCEquality + MCList + MCOption + MCProd + MCSquash + MCRelations + MCString + ReflectEq + bytestring +. diff --git a/quotation/theories/ToTemplate/Utils/ReflectEq.v b/quotation/theories/ToTemplate/Utils/ReflectEq.v new file mode 100644 index 000000000..24c1f69fa --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/ReflectEq.v @@ -0,0 +1,7 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Utils Require Import ReflectEq. + +#[export] Instance quote_reflectProp {A:Prop} {qA : quotation_of A} {quoteA : ground_quotable A} {quote_negA : ground_quotable (~A)} {b} : ground_quotable (@reflectProp A b). +Proof. + destruct b; adjust_ground_quotable_by_econstructor_inversion (). +Defined. diff --git a/quotation/theories/ToTemplate/Utils/bytestring.v b/quotation/theories/ToTemplate/Utils/bytestring.v new file mode 100644 index 000000000..bd0ba88e4 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/bytestring.v @@ -0,0 +1,24 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init. +From MetaCoq.Utils Require Import bytestring. + +Module String. + #[export] Instance quote_t : ground_quotable String.t := ltac:(induction 1; exact _). +End String. +#[export] Existing Instance String.quote_t. +Notation quote_bs := String.quote_t. +Notation quote_string := String.quote_t. + +#[export] Hint Unfold + bs + OT_byte.t + OT_byte.eq + OT_byte.lt + StringOT.t + StringOT.eq + StringOT.lt + : quotation. + +Module Tree. + #[export] Instance quote_t : ground_quotable Tree.t := ltac:(induction 1; exact _). +End Tree. +#[export] Existing Instance Tree.quote_t. diff --git a/quotation/theories/ToTemplate/Utils/monad_utils.v b/quotation/theories/ToTemplate/Utils/monad_utils.v new file mode 100644 index 000000000..7c77c3ce0 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/monad_utils.v @@ -0,0 +1 @@ +(* The classes here hold functions and hence are not quotable *) diff --git a/quotation/theories/ToTemplate/Utils/utils.v b/quotation/theories/ToTemplate/Utils/utils.v new file mode 100644 index 000000000..381dc1fc1 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/utils.v @@ -0,0 +1,3 @@ +From MetaCoq.Quotation.ToTemplate Require Import Coq.Init Coq.Bool Coq.Numbers Coq.Lists. +From MetaCoq.Quotation.ToTemplate.Utils Require Import MCUtils monad_utils. +From MetaCoq.Utils Require Import utils. diff --git a/quotation/theories/ToTemplate/Utils/wGraph.v b/quotation/theories/ToTemplate/Utils/wGraph.v new file mode 100644 index 000000000..683df87c2 --- /dev/null +++ b/quotation/theories/ToTemplate/Utils/wGraph.v @@ -0,0 +1,408 @@ +(*From MetaCoq.Quotation.ToTemplate Require Import Init. +From MetaCoq.Quotation.ToTemplate Require Import (hints) Coq.Init Coq.Structures Coq.MSets Coq.Numbers. +From MetaCoq.Utils Require Import wGraph. +From Coq Require Import MSetDecide MSetInterface. + +Module Nbar. + #[export] Instance quote_le {x y} : ground_quotable (Nbar.le x y) := ltac:(cbv [Nbar.le]; exact _). + #[export] Instance quote_lt {x y} : ground_quotable (Nbar.lt x y) := ltac:(cbv [Nbar.lt]; exact _). +End Nbar. +Export (hints) Nbar. + +Module Type QuotationOfWeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module E := V) (WGraph : WeightedGraphSig V VSet). + Module qVSetFact := Nop <+ QuotationOfWFactsOn V VSet WGraph.VSetFact. + Export (hints) qVSetFact. + Module qVSetProp := Nop <+ QuotationOfWPropertiesOn V VSet WGraph.VSetProp. + Export (hints) qVSetProp. + Module qVSetDecide := Nop <+ QuotationOfWDecide VSet WGraph.VSetDecide. + Export (hints) qVSetDecide. + Module qEdge. + #[export] Declare Instance qt : quotation_of WGraph.Edge.t. + #[export] Declare Instance qeq : quotation_of WGraph.Edge.eq. + #[export] Declare Instance qeq_equiv : quotation_of WGraph.Edge.eq_equiv. + #[export] Declare Instance qlt : quotation_of WGraph.Edge.lt. + #[export] Declare Instance qlt_strorder : quotation_of WGraph.Edge.lt_strorder. + #[export] Declare Instance qlt_compat : quotation_of WGraph.Edge.lt_compat. + #[export] Declare Instance qcompare : quotation_of WGraph.Edge.compare. + #[export] Declare Instance qcompare_spec : quotation_of WGraph.Edge.compare_spec. + #[export] Declare Instance qeq_dec : quotation_of WGraph.Edge.eq_dec. + #[export] Declare Instance qeqb : quotation_of WGraph.Edge.eqb. + #[export] Declare Instance qeq_leibniz : quotation_of WGraph.Edge.eq_leibniz. + End qEdge. + Export (hints) qEdge. + Module qEdgeSet:= MSetAVL.Make Edge. + Module qEdgeSetFact := WFactsOn Edge EdgeSet. + Module qEdgeSetProp := WPropertiesOn Edge EdgeSet. + Module qEdgeSetDecide := WDecide (EdgeSet). + + Module qEdgeSet. + Module EdgeSetFact + Module EdgeSetProp + Module EdgeSetDecide + Module Subgraph1 + Module IsFullSubgraph + Module RelabelWrtEdge + #[export] Declare Instance qVSet_add_remove : quotation_of WGraph.VSet_add_remove. + #[export] Declare Instance qVSet_remove_add : quotation_of WGraph.VSet_remove_add. + #[export] Declare Instance qVSet_add_add : quotation_of WGraph.VSet_add_add. + #[export] Declare Instance qVSet_add_add_same : quotation_of WGraph.VSet_add_add_same. + #[export] Declare Instance qDisjoint : quotation_of WGraph.Disjoint. + #[export] Declare Instance qDisjointAdd : quotation_of WGraph.DisjointAdd. + #[export] Declare Instance qDisjointAdd_add1 : quotation_of WGraph.DisjointAdd_add1. + #[export] Declare Instance qDisjointAdd_add2 : quotation_of WGraph.DisjointAdd_add2. + #[export] Declare Instance qDisjointAdd_add3 : quotation_of WGraph.DisjointAdd_add3. + #[export] Declare Instance qDisjointAdd_remove : quotation_of WGraph.DisjointAdd_remove. + #[export] Declare Instance qDisjointAdd_Subset : quotation_of WGraph.DisjointAdd_Subset. + #[export] Declare Instance qDisjointAdd_union : quotation_of WGraph.DisjointAdd_union. + #[export] Declare Instance qDisjointAdd_remove1 : quotation_of WGraph.DisjointAdd_remove1. + #[export] Declare Instance qAdd_Proper : quotation_of WGraph.Add_Proper. + #[export] Declare Instance qDisjointAdd_Proper : quotation_of WGraph.DisjointAdd_Proper. + #[export] Declare Instance qAdd_In : quotation_of WGraph.Add_In. + #[export] Declare Instance qAdd_Add : quotation_of WGraph.Add_Add. + #[export] Declare Instance qDisjoint_DisjointAdd : quotation_of WGraph.Disjoint_DisjointAdd. + #[export] Declare Instance qDisjointAdd_remove_add : quotation_of WGraph.DisjointAdd_remove_add. + #[export] Declare Instance qDisjointAdd_Equal : quotation_of WGraph.DisjointAdd_Equal. + #[export] Declare Instance qDisjointAdd_Equal_l : quotation_of WGraph.DisjointAdd_Equal_l. + #[export] Declare Instance qDisjointAdd_remove_inv : quotation_of WGraph.DisjointAdd_remove_inv. + #[export] Declare Instance qt : quotation_of WGraph.t. + #[export] Declare Instance qV : quotation_of WGraph.V. + #[export] Declare Instance qE : quotation_of WGraph.E. + #[export] Declare Instance qs : quotation_of WGraph.s. + #[export] Declare Instance qe_source : quotation_of WGraph.e_source. + #[export] Declare Instance qe_target : quotation_of WGraph.e_target. + #[export] Declare Instance qe_weight : quotation_of WGraph.e_weight. + #[export] Declare Instance qopp_edge : quotation_of WGraph.opp_edge. + #[export] Declare Instance qlabelling : quotation_of WGraph.labelling. + #[export] Declare Instance qadd_node : quotation_of WGraph.add_node. + #[export] Declare Instance qadd_edge : quotation_of WGraph.add_edge. + #[export] Declare Instance qEdgeOf : quotation_of WGraph.EdgeOf. + #[export] Declare Instance qPathOf : inductive_quotation_of WGraph.PathOf. + #[export] Declare Instance qPathOf_rect : quotation_of WGraph.PathOf_rect. + #[export] Declare Instance qPathOf_ind : quotation_of WGraph.PathOf_ind. + #[export] Declare Instance qPathOf_rec : quotation_of WGraph.PathOf_rec. + #[export] Declare Instance qPathOf_sind : quotation_of WGraph.PathOf_sind. + #[export] Declare Instance qweight : quotation_of WGraph.weight. + #[export] Declare Instance qnodes : quotation_of WGraph.nodes. + #[export] Declare Instance qconcat : quotation_of WGraph.concat. + #[export] Declare Instance qlength : quotation_of WGraph.length. + #[export] Declare Instance qinvariants : inductive_quotation_of WGraph.invariants. + #[export] Declare Instance qedges_vertices : quotation_of WGraph.edges_vertices. + #[export] Declare Instance qsource_vertex : quotation_of WGraph.source_vertex. + #[export] Declare Instance qsource_pathOf : quotation_of WGraph.source_pathOf. + #[export] Declare Instance qPosPathOf : quotation_of WGraph.PosPathOf. + #[export] Declare Instance qacyclic_no_loop : quotation_of WGraph.acyclic_no_loop. + #[export] Declare Instance qBuild_acyclic_no_loop : quotation_of WGraph.Build_acyclic_no_loop. + #[export] Declare Instance qacyclic_no_loop' : quotation_of WGraph.acyclic_no_loop'. + #[export] Declare Instance qacyclic_no_loop_loop' : quotation_of WGraph.acyclic_no_loop_loop'. + #[export] Declare Instance qcorrect_labelling : quotation_of WGraph.correct_labelling. + #[export] Declare Instance qleq_vertices : quotation_of WGraph.leq_vertices. + #[export] Declare Instance qSPath : inductive_quotation_of WGraph.SPath. + #[export] Declare Instance qSPath_rect : quotation_of WGraph.SPath_rect. + #[export] Declare Instance qSPath_ind : quotation_of WGraph.SPath_ind. + #[export] Declare Instance qSPath_rec : quotation_of WGraph.SPath_rec. + #[export] Declare Instance qSPath_sind : quotation_of WGraph.SPath_sind. + #[export] Declare Instance qSPath_sig : quotation_of WGraph.SPath_sig. + #[export] Declare Instance qSPath_sig_pack : quotation_of WGraph.SPath_sig_pack. + #[export] Declare Instance qSPath_Signature : quotation_of WGraph.SPath_Signature. + #[export] Declare Instance qNoConfusion_SPath : quotation_of WGraph.NoConfusion_SPath. + #[export] Declare Instance qnoConfusion_SPath_obligation_1 : quotation_of WGraph.noConfusion_SPath_obligation_1. + #[export] Declare Instance qnoConfusion_SPath_obligation_2 : quotation_of WGraph.noConfusion_SPath_obligation_2. + #[export] Declare Instance qnoConfusion_SPath_obligation_3 : quotation_of WGraph.noConfusion_SPath_obligation_3. + #[export] Declare Instance qnoConfusion_SPath_obligation_4 : quotation_of WGraph.noConfusion_SPath_obligation_4. + #[export] Declare Instance qNoConfusionPackage_SPath : quotation_of WGraph.NoConfusionPackage_SPath. + #[export] Declare Instance qto_pathOf : quotation_of WGraph.to_pathOf. + #[export] Declare Instance qsweight : quotation_of WGraph.sweight. + #[export] Declare Instance qsweight_weight : quotation_of WGraph.sweight_weight. + #[export] Declare Instance qis_simple : quotation_of WGraph.is_simple. + #[export] Declare Instance qto_simple_obligation_1 : quotation_of WGraph.to_simple_obligation_1. + #[export] Declare Instance qto_simple_obligation_2 : quotation_of WGraph.to_simple_obligation_2. + #[export] Declare Instance qto_simple : quotation_of WGraph.to_simple. + #[export] Declare Instance qweight_concat : quotation_of WGraph.weight_concat. + #[export] Declare Instance qadd_end : quotation_of WGraph.add_end. + #[export] Declare Instance qweight_add_end : quotation_of WGraph.weight_add_end. + #[export] Declare Instance qSPath_sub : quotation_of WGraph.SPath_sub. + #[export] Declare Instance qweight_SPath_sub : quotation_of WGraph.weight_SPath_sub. + #[export] Declare Instance qsconcat_obligation_1 : quotation_of WGraph.sconcat_obligation_1. + #[export] Declare Instance qsconcat_obligation_2 : quotation_of WGraph.sconcat_obligation_2. + #[export] Declare Instance qsconcat_obligation_3 : quotation_of WGraph.sconcat_obligation_3. + #[export] Declare Instance qsconcat : quotation_of WGraph.sconcat. + #[export] Declare Instance qsweight_sconcat : quotation_of WGraph.sweight_sconcat. + #[export] Declare Instance qsnodes : quotation_of WGraph.snodes. + #[export] Declare Instance qsplit : quotation_of WGraph.split. + #[export] Declare Instance qweight_split : quotation_of WGraph.weight_split. + #[export] Declare Instance qsplit' : quotation_of WGraph.split'. + #[export] Declare Instance qweight_split' : quotation_of WGraph.weight_split'. + #[export] Declare Instance qspath_one : quotation_of WGraph.spath_one. + #[export] Declare Instance qsimplify_aux1 : quotation_of WGraph.simplify_aux1. + #[export] Declare Instance qsimplify_aux2 : quotation_of WGraph.simplify_aux2. + #[export] Declare Instance qsimplify_aux3 : quotation_of WGraph.simplify_aux3. + #[export] Declare Instance qsimplify : quotation_of WGraph.simplify. + #[export] Declare Instance qweight_simplify : quotation_of WGraph.weight_simplify. + #[export] Declare Instance qsuccs : quotation_of WGraph.succs. + #[export] Declare Instance qlsp00 : quotation_of WGraph.lsp00. + #[export] Declare Instance qlsp0 : quotation_of WGraph.lsp0. + #[export] Declare Instance qlsp0_eq : quotation_of WGraph.lsp0_eq. + #[export] Declare Instance qlsp00_fast : quotation_of WGraph.lsp00_fast. + #[export] Declare Instance qfold_left_map : quotation_of WGraph.fold_left_map. + #[export] Declare Instance qfold_left_filter : quotation_of WGraph.fold_left_filter. + #[export] Declare Instance qfold_left_proper : quotation_of WGraph.fold_left_proper. + #[export] Declare Instance qfold_left_equiv : quotation_of WGraph.fold_left_equiv. + #[export] Declare Instance qlsp00_optim : quotation_of WGraph.lsp00_optim. + #[export] Declare Instance qlsp_fast : quotation_of WGraph.lsp_fast. + #[export] Declare Instance qlsp : quotation_of WGraph.lsp. + #[export] Declare Instance qlsp_optim : quotation_of WGraph.lsp_optim. + #[export] Declare Instance qlsp0_VSet_Equal : quotation_of WGraph.lsp0_VSet_Equal. + #[export] Declare Instance qlsp0_spec_le : quotation_of WGraph.lsp0_spec_le. + #[export] Declare Instance qlsp0_spec_eq : quotation_of WGraph.lsp0_spec_eq. + #[export] Declare Instance qlsp0_spec_eq0 : quotation_of WGraph.lsp0_spec_eq0. + #[export] Declare Instance qcorrect_labelling_PathOf : quotation_of WGraph.correct_labelling_PathOf. + #[export] Declare Instance qcorrect_labelling_lsp : quotation_of WGraph.correct_labelling_lsp. + #[export] Declare Instance qacyclic_labelling : quotation_of WGraph.acyclic_labelling. + #[export] Declare Instance qlsp0_triangle_inequality : quotation_of WGraph.lsp0_triangle_inequality. + #[export] Declare Instance qis_nonpos : quotation_of WGraph.is_nonpos. + #[export] Declare Instance qis_nonpos_spec : quotation_of WGraph.is_nonpos_spec. + #[export] Declare Instance qis_nonpos_nbar : quotation_of WGraph.is_nonpos_nbar. + #[export] Declare Instance qlsp0_sub : quotation_of WGraph.lsp0_sub. + #[export] Declare Instance qsnodes_Subset : quotation_of WGraph.snodes_Subset. + #[export] Declare Instance qreduce : quotation_of WGraph.reduce. + #[export] Declare Instance qsimplify2 : quotation_of WGraph.simplify2. + #[export] Declare Instance qweight_reduce : quotation_of WGraph.weight_reduce. + #[export] Declare Instance qweight_simplify2 : quotation_of WGraph.weight_simplify2. + #[export] Declare Instance qnodes_subset : quotation_of WGraph.nodes_subset. + #[export] Declare Instance qsimplify2' : quotation_of WGraph.simplify2'. + #[export] Declare Instance qweight_simplify2' : quotation_of WGraph.weight_simplify2'. + #[export] Declare Instance qlsp_s : quotation_of WGraph.lsp_s. + #[export] Declare Instance qSPath_In : quotation_of WGraph.SPath_In. + #[export] Declare Instance qSPath_In' : quotation_of WGraph.SPath_In'. + #[export] Declare Instance qPathOf_In : quotation_of WGraph.PathOf_In. + #[export] Declare Instance qacyclic_lsp0_xx : quotation_of WGraph.acyclic_lsp0_xx. + #[export] Declare Instance qto_label : quotation_of WGraph.to_label. + #[export] Declare Instance qZ_of_to_label : quotation_of WGraph.Z_of_to_label. + #[export] Declare Instance qZ_of_to_label_s : quotation_of WGraph.Z_of_to_label_s. + #[export] Declare Instance qlsp_correctness : quotation_of WGraph.lsp_correctness. + #[export] Declare Instance qlsp_codistance : quotation_of WGraph.lsp_codistance. + #[export] Declare Instance qlsp_sym : quotation_of WGraph.lsp_sym. + #[export] Declare Instance qle_Some_lsp : quotation_of WGraph.le_Some_lsp. + #[export] Declare Instance qsource_bottom : quotation_of WGraph.source_bottom. + #[export] Declare Instance qlsp_to_s : quotation_of WGraph.lsp_to_s. + #[export] Declare Instance qlsp_xx_acyclic : quotation_of WGraph.lsp_xx_acyclic. + #[export] Declare Instance qVSet_Forall_reflect : quotation_of WGraph.VSet_Forall_reflect. + #[export] Declare Instance qreflect_logically_equiv : quotation_of WGraph.reflect_logically_equiv. + #[export] Declare Instance qis_acyclic : quotation_of WGraph.is_acyclic. + #[export] Declare Instance qacyclic_caract1 : quotation_of WGraph.acyclic_caract1. + #[export] Declare Instance qacyclic_caract2 : quotation_of WGraph.acyclic_caract2. + #[export] Declare Instance qis_acyclic_spec : quotation_of WGraph.is_acyclic_spec. + #[export] Declare Instance qZle_opp : quotation_of WGraph.Zle_opp. + #[export] Declare Instance qZle_opp' : quotation_of WGraph.Zle_opp'. + #[export] Declare Instance qlsp_xx : quotation_of WGraph.lsp_xx. + #[export] Declare Instance qedge_pathOf : quotation_of WGraph.edge_pathOf. + #[export] Declare Instance qZ_of_to_label_pos : quotation_of WGraph.Z_of_to_label_pos. + #[export] Declare Instance qto_label_max : quotation_of WGraph.to_label_max. + #[export] Declare Instance qlsp_from_source : quotation_of WGraph.lsp_from_source. + #[export] Declare Instance qlsp_to_source : quotation_of WGraph.lsp_to_source. + #[export] Declare Instance qlsp_source_max : quotation_of WGraph.lsp_source_max. + #[export] Declare Instance qis_acyclic_correct : quotation_of WGraph.is_acyclic_correct. + #[export] Declare Instance qG' : quotation_of WGraph.G'. + #[export] Declare Instance qto_G' : quotation_of WGraph.to_G'. + #[export] Declare Instance qto_G'_weight : quotation_of WGraph.to_G'_weight. + #[export] Declare Instance qfrom_G'_path : quotation_of WGraph.from_G'_path. + #[export] Declare Instance qfrom_G'_path_weight : quotation_of WGraph.from_G'_path_weight. + #[export] Declare Instance qfrom_G' : quotation_of WGraph.from_G'. + #[export] Declare Instance qfrom_G'_weight : quotation_of WGraph.from_G'_weight. + #[export] Declare Instance qlsp_pathOf : quotation_of WGraph.lsp_pathOf. + #[export] Declare Instance qHI' : quotation_of WGraph.HI'. + #[export] Declare Instance qHG' : quotation_of WGraph.HG'. + #[export] Declare Instance qlsp_G'_yx : quotation_of WGraph.lsp_G'_yx. + #[export] Declare Instance qlsp_G'_sx : quotation_of WGraph.lsp_G'_sx. + #[export] Declare Instance qcorrect_labelling_lsp_G' : quotation_of WGraph.correct_labelling_lsp_G'. + #[export] Declare Instance qsto_G' : quotation_of WGraph.sto_G'. + #[export] Declare Instance qsto_G'_weight : quotation_of WGraph.sto_G'_weight. + #[export] Declare Instance qlsp_G'_incr : quotation_of WGraph.lsp_G'_incr. + #[export] Declare Instance qlsp_G'_spec_left : quotation_of WGraph.lsp_G'_spec_left. + #[export] Declare Instance qSPath_sets : quotation_of WGraph.SPath_sets. + #[export] Declare Instance qPathOf_add_end : quotation_of WGraph.PathOf_add_end. + #[export] Declare Instance qPathOf_add_end_weight : quotation_of WGraph.PathOf_add_end_weight. + #[export] Declare Instance qnegbe : quotation_of WGraph.negbe. + #[export] Declare Instance qIn_nodes_app_end : quotation_of WGraph.In_nodes_app_end. + #[export] Declare Instance qpathOf_add_end_simpl : quotation_of WGraph.pathOf_add_end_simpl. + #[export] Declare Instance qleq_vertices_caract0 : quotation_of WGraph.leq_vertices_caract0. + #[export] Declare Instance qlsp_vset_in : quotation_of WGraph.lsp_vset_in. + #[export] Declare Instance qleq_vertices_caract_subproof : quotation_of WGraph.leq_vertices_caract_subproof. + #[export] Declare Instance qleq_vertices_caract : quotation_of WGraph.leq_vertices_caract. + #[export] Declare Instance qleqb_vertices : quotation_of WGraph.leqb_vertices. + #[export] Declare Instance qleqb_vertices_correct : quotation_of WGraph.leqb_vertices_correct. + #[export] Declare Instance qedge_map : quotation_of WGraph.edge_map. + #[export] Declare Instance qedge_map_spec1 : quotation_of WGraph.edge_map_spec1. + #[export] Declare Instance qedge_map_spec2 : quotation_of WGraph.edge_map_spec2. + #[export] Declare Instance qdiff : quotation_of WGraph.diff. + #[export] Declare Instance qrelabel : quotation_of WGraph.relabel. + #[export] Declare Instance qrelabel_weight : quotation_of WGraph.relabel_weight. + #[export] Declare Instance qrelabel_lsp : quotation_of WGraph.relabel_lsp. + #[export] Declare Instance qacyclic_relabel : quotation_of WGraph.acyclic_relabel. + #[export] Declare Instance qrelabel_path : quotation_of WGraph.relabel_path. + #[export] Declare Instance qinvariants_relabel : quotation_of WGraph.invariants_relabel. + #[export] Declare Instance qrelabel_map : quotation_of WGraph.relabel_map. + #[export] Declare Instance qrelabel_on : quotation_of WGraph.relabel_on. + #[export] Declare Instance qweight_inverse : quotation_of WGraph.weight_inverse. + #[export] Declare Instance qsweight_inverse : quotation_of WGraph.sweight_inverse. + #[export] Declare Instance qacyclic_no_sloop : quotation_of WGraph.acyclic_no_sloop. + #[export] Declare Instance qacyclic_no_loop_sloop : quotation_of WGraph.acyclic_no_loop_sloop. + #[export] Declare Instance qDisjointAdd_add4 : quotation_of WGraph.DisjointAdd_add4. + #[export] Declare Instance qDisjointAdd_In : quotation_of WGraph.DisjointAdd_In. + #[export] Declare Instance qreroot_spath_aux1 : quotation_of WGraph.reroot_spath_aux1. + #[export] Declare Instance qreroot_spath_aux2 : quotation_of WGraph.reroot_spath_aux2. + #[export] Declare Instance qreroot_spath_aux3 : quotation_of WGraph.reroot_spath_aux3. + #[export] Declare Instance qreroot_spath_aux : quotation_of WGraph.reroot_spath_aux. + #[export] Declare Instance qreroot_spath : quotation_of WGraph.reroot_spath. + #[export] Declare Instance qmap_path : quotation_of WGraph.map_path. + #[export] Declare Instance qmap_path_equation_1 : quotation_of WGraph.map_path_equation_1. + #[export] Declare Instance qmap_path_equation_2 : quotation_of WGraph.map_path_equation_2. + #[export] Declare Instance qmap_path_graph : inductive_quotation_of WGraph.map_path_graph. + #[export] Declare Instance qmap_path_graph_rect : quotation_of WGraph.map_path_graph_rect. + #[export] Declare Instance qmap_path_graph_correct : quotation_of WGraph.map_path_graph_correct. + #[export] Declare Instance qmap_path_elim : quotation_of WGraph.map_path_elim. + #[export] Declare Instance qFunctionalElimination_map_path : quotation_of WGraph.FunctionalElimination_map_path. + #[export] Declare Instance qFunctionalInduction_map_path : quotation_of WGraph.FunctionalInduction_map_path. + #[export] Declare Instance qweight_map_path1 : quotation_of WGraph.weight_map_path1. + #[export] Declare Instance qweight_map_path2 : quotation_of WGraph.weight_map_path2. + #[export] Declare Instance qmap_spath : quotation_of WGraph.map_spath. + #[export] Declare Instance qmap_spath_equation_1 : quotation_of WGraph.map_spath_equation_1. + #[export] Declare Instance qmap_spath_equation_2 : quotation_of WGraph.map_spath_equation_2. + #[export] Declare Instance qmap_spath_graph : inductive_quotation_of WGraph.map_spath_graph. + #[export] Declare Instance qmap_spath_graph_rect : quotation_of WGraph.map_spath_graph_rect. + #[export] Declare Instance qmap_spath_graph_correct : quotation_of WGraph.map_spath_graph_correct. + #[export] Declare Instance qmap_spath_elim : quotation_of WGraph.map_spath_elim. + #[export] Declare Instance qFunctionalElimination_map_spath : quotation_of WGraph.FunctionalElimination_map_spath. + #[export] Declare Instance qFunctionalInduction_map_spath : quotation_of WGraph.FunctionalInduction_map_spath. + #[export] Declare Instance qweight_map_spath1 : quotation_of WGraph.weight_map_spath1. + #[export] Declare Instance qweight_map_spath2 : quotation_of WGraph.weight_map_spath2. + #[export] Declare Instance qlsp_map_path2 : quotation_of WGraph.lsp_map_path2. + #[export] Declare Instance qlsp_edge : quotation_of WGraph.lsp_edge. + #[export] Declare Instance qfirst_in_clause_2 : quotation_of WGraph.first_in_clause_2. + #[export] Declare Instance qfirst_in : quotation_of WGraph.first_in. + #[export] Declare Instance qfirst_in_equation_1 : quotation_of WGraph.first_in_equation_1. + #[export] Declare Instance qfirst_in_equation_2 : quotation_of WGraph.first_in_equation_2. + #[export] Declare Instance qfirst_in_clause_2_equation_1 : quotation_of WGraph.first_in_clause_2_equation_1. + #[export] Declare Instance qfirst_in_clause_2_equation_2 : quotation_of WGraph.first_in_clause_2_equation_2. + #[export] Declare Instance qfirst_in_graph : inductive_quotation_of WGraph.first_in_graph. + #[export] Declare Instance qfirst_in_clause_2_graph_mut : quotation_of WGraph.first_in_clause_2_graph_mut. + #[export] Declare Instance qfirst_in_graph_mut : quotation_of WGraph.first_in_graph_mut. + #[export] Declare Instance qfirst_in_graph_rect : quotation_of WGraph.first_in_graph_rect. + #[export] Declare Instance qfirst_in_graph_correct : quotation_of WGraph.first_in_graph_correct. + #[export] Declare Instance qfirst_in_elim : quotation_of WGraph.first_in_elim. + #[export] Declare Instance qFunctionalElimination_first_in : quotation_of WGraph.FunctionalElimination_first_in. + #[export] Declare Instance qFunctionalInduction_first_in : quotation_of WGraph.FunctionalInduction_first_in. + #[export] Declare Instance qfirst_in_in : quotation_of WGraph.first_in_in. + #[export] Declare Instance qfirst_in_first : quotation_of WGraph.first_in_first. + #[export] Declare Instance qfrom1 : quotation_of WGraph.from1. + #[export] Declare Instance qfrom2 : quotation_of WGraph.from2. + #[export] Declare Instance qrelabel_on_lsp_G1 : quotation_of WGraph.relabel_on_lsp_G1. + #[export] Declare Instance qrelabel_on_lsp_G2 : quotation_of WGraph.relabel_on_lsp_G2. + #[export] Declare Instance qweight_from1 : quotation_of WGraph.weight_from1. + #[export] Declare Instance qweight_from2 : quotation_of WGraph.weight_from2. + #[export] Declare Instance qrelabel_on_invariants : quotation_of WGraph.relabel_on_invariants. + #[export] Declare Instance qsweight_relabel_on_G1 : quotation_of WGraph.sweight_relabel_on_G1. + #[export] Declare Instance qsweight_relabel_on_G2 : quotation_of WGraph.sweight_relabel_on_G2. + #[export] Declare Instance qacyclic_relabel_on : quotation_of WGraph.acyclic_relabel_on. + #[export] Declare Instance qSPath_direct_subterm : inductive_quotation_of WGraph.SPath_direct_subterm. + #[export] Declare Instance qSPath_direct_subterm_ind : quotation_of WGraph.SPath_direct_subterm_ind. + #[export] Declare Instance qSPath_direct_subterm_sind : quotation_of WGraph.SPath_direct_subterm_sind. + #[export] Declare Instance qSPath_direct_subterm_sig : quotation_of WGraph.SPath_direct_subterm_sig. + #[export] Declare Instance qSPath_direct_subterm_sig_pack : quotation_of WGraph.SPath_direct_subterm_sig_pack. + #[export] Declare Instance qSPath_direct_subterm_Signature : quotation_of WGraph.SPath_direct_subterm_Signature. + #[export] Declare Instance qSPath_subterm : quotation_of WGraph.SPath_subterm. + #[export] Declare Instance qwell_founded_SPath_subterm_obligation_1 : quotation_of WGraph.well_founded_SPath_subterm_obligation_1. + #[export] Declare Instance qwell_founded_SPath_subterm : quotation_of WGraph.well_founded_SPath_subterm. + #[export] Declare Instance qspathG1_lsp_Gl : quotation_of WGraph.spathG1_lsp_Gl. + #[export] Declare Instance qlsp_Gl_upperbound_G1 : quotation_of WGraph.lsp_Gl_upperbound_G1. + #[export] Declare Instance qlsp_Gl_between_G1 : quotation_of WGraph.lsp_Gl_between_G1. + #[export] Declare Instance qsubgraph : inductive_quotation_of WGraph.subgraph. + #[export] Declare Instance qvertices_sub : quotation_of WGraph.vertices_sub. + #[export] Declare Instance qedges_sub : quotation_of WGraph.edges_sub. + #[export] Declare Instance qsame_src : quotation_of WGraph.same_src. + #[export] Declare Instance qsubgraph_on_edge : quotation_of WGraph.subgraph_on_edge. + #[export] Declare Instance qsubgraph_acyclic : quotation_of WGraph.subgraph_acyclic. + #[export] Declare Instance qfull_subgraph : inductive_quotation_of WGraph.full_subgraph. + #[export] Declare Instance qis_subgraph : quotation_of WGraph.is_subgraph. + #[export] Declare Instance qlsp_dominate : quotation_of WGraph.lsp_dominate. + #[export] Declare Instance qreflectEq_vertices_obligation_1 : quotation_of WGraph.reflectEq_vertices_obligation_1. + #[export] Declare Instance qreflectEq_vertices : quotation_of WGraph.reflectEq_vertices. + #[export] Declare Instance qreflectEq_Z_obligation_1 : quotation_of WGraph.reflectEq_Z_obligation_1. + #[export] Declare Instance qreflectEq_Z : quotation_of WGraph.reflectEq_Z. + #[export] Declare Instance qreflectEq_nbar : quotation_of WGraph.reflectEq_nbar. + #[export] Declare Instance qextends_labelling : quotation_of WGraph.extends_labelling. + #[export] Declare Instance qrelabel_on_correct_labelling : quotation_of WGraph.relabel_on_correct_labelling. + #[export] Declare Instance qextends_correct_labelling : quotation_of WGraph.extends_correct_labelling. + #[export] Declare Instance qto_label_to_nat : quotation_of WGraph.to_label_to_nat. + #[export] Declare Instance qlabelling_ext_lsp : quotation_of WGraph.labelling_ext_lsp. + + (qV : QuotationOfUsualOrderedType V) (qVSet : MSets.QuotationOfSets VSet). + + (MProperties : OrdPropertiesSig M) (qE : QuotationOfUsualOrderedType M.E) (qM : QuotationOfSets M) (qMProperties : QuotationOfOrdProperties M MProperties qE). + + *)(* +Module QuoteWeightedGraph (V : UsualOrderedType) (VSet : MSetInterface.S with Module E := V) (Import W : WeightedGraphSig V VSet). + Module Import QuoteVSet := QuoteUsualSetsOn V VSet. + Module Import QuoteEdgeSet := QuoteMSetAVL Edge EdgeSet. + + Section with_quote. + Context {qEdgeSet_t : quotation_of EdgeSet.t} {qV_t : quotation_of V.t} {qVSet_t : quotation_of VSet.t} + {qVSet_In : quotation_of VSet.In} {qEdgeSet_In : quotation_of EdgeSet.In} + {qVSet_eq_dec : quotation_of VSet.eq_dec} {qVSet_add : quotation_of VSet.add} {qEdgeSet_subset_spec : quotation_of EdgeSet.subset_spec} {qlsp : quotation_of lsp} + {qEdgeSet_tree : inductive_quotation_of EdgeSet.Raw.tree} {qEdgeSetbst : inductive_quotation_of EdgeSet.Raw.bst} {qEdgeSet_t_ : inductive_quotation_of EdgeSet.t_} + {qPathOf : inductive_quotation_of PathOf} + {qSPath : inductive_quotation_of SPath} + {qsubgraph : inductive_quotation_of subgraph} {qfull_subgraph : inductive_quotation_of full_subgraph} + {quote_V_t : ground_quotable V.t} {quote_VSet_t : ground_quotable VSet.t}. + + #[export] Instance qEdgeSet_elt : quotation_of EdgeSet.elt := ltac:(cbv -[quotation_of]; exact _). + #[export] Instance qt : quotation_of t := ltac:(cbv [t]; exact _). + #[export] Instance qWE : quotation_of W.E := ltac:(cbv [W.E]; exact _). + #[export] Instance qWV : quotation_of W.V := ltac:(cbv [W.V]; exact _). + #[export] Instance qVSetProp_Add : quotation_of VSetProp.Add := ltac:(cbv [VSetProp.Add]; exact _). + #[export] Instance qVSet : quotation_of VSetProp.Add := ltac:(cbv [VSetProp.Add]; exact _). + #[export] Instance quote_t : ground_quotable t := _. + #[export] Instance quote_PathOf {G x y} : ground_quotable (@PathOf G x y) := ltac:(induction 1; exact _). + #[export] Instance quote_SPath {G s x y} : ground_quotable (@SPath G s x y) := ltac:(induction 1; exact _). + #[export] Instance quote_subgraph {G1 G2} : ground_quotable (@subgraph G1 G2) := ltac:(induction 1; exact _). + #[export] Instance quote_full_subgraph {G1 G2} : ground_quotable (@full_subgraph G1 G2) := ltac:(induction 1; exact _). + End with_quote. + + Module Import Edge. + Definition lt_dec x y : {Edge.lt x y} + {~Edge.lt x y}. + Proof. + pose proof (Edge.compare_spec x y) as H. + destruct (Edge.compare x y); + solve [ left; inversion H; assumption + | right; intro H'; inversion H; subst; + eapply Edge.lt_strorder; (idtac + etransitivity); eassumption ]. + Defined. + + Section with_quote. + Context {qV_t : quotation_of V.t} {qV_lt : quotation_of V.lt}. + + #[export] Instance qEdge_t : quotation_of Edge.t := ltac:(cbv -[quotation_of]; exact _). + #[export] Instance qlt : quotation_of Edge.lt := ltac:(cbv [Edge.lt V.eq]; try exact _). + #[export] Instance quote_lt {x y} {qx : quotation_of x} {qy : quotation_of y} : ground_quotable (Edge.lt x y) := ground_quotable_of_dec (@lt_dec x y). + End with_quote. + + Module Export Instances. + #[export] Existing Instances + quote_lt + . + End Instances. + End Edge. + Module Export Instances. + Export QuoteVSet.Instances. + Export QuoteEdgeSet.Instances. + Export Edge.Instances. + #[export] Existing Instances + quote_t + quote_PathOf + quote_SPath + quote_subgraph + quote_full_subgraph + . + End Instances. +End QuoteWeightedGraph. +*) diff --git a/template-pcuic/metacoq-config b/template-pcuic/metacoq-config index cd8e824c7..00bfe61cd 100644 --- a/template-pcuic/metacoq-config +++ b/template-pcuic/metacoq-config @@ -1,2 +1,2 @@ # DO NOT EDIT THIS FILE: autogenerated from ./configure.sh --R ../utils/theories MetaCoq.Utils -R ../common/theories MetaCoq.Common -R ../pcuic/theories MetaCoq.PCUIC -R ../template-coq/theories MetaCoq.Template +-R ../utils/theories MetaCoq.Utils -R ../common/theories MetaCoq.Common -R ../pcuic/theories MetaCoq.PCUIC -R ../template-coq/theories MetaCoq.Template -I ../template-coq diff --git a/utils/theories/monad_utils.v b/utils/theories/monad_utils.v index e185b1f0b..e417e82ba 100644 --- a/utils/theories/monad_utils.v +++ b/utils/theories/monad_utils.v @@ -70,9 +70,9 @@ Import MCMonadNotation. Open Scope monad. Section MapOpt. - Context {A} (f : A -> option A). + Context {A} {B} (f : A -> option B). - Fixpoint mapopt (l : list A) : option (list A) := + Fixpoint mapopt (l : list A) : option (list B) := match l with | nil => ret nil | x :: xs => x' <- f x ;; From dbae09d6842b3e2ca0c4ba263be7492cd63e720e Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Mon, 3 Apr 2023 15:31:50 -0700 Subject: [PATCH 02/10] Add Quotation.ToTemplate.All for the exported definitions --- quotation/_CoqProject.in | 1 + quotation/theories/ToTemplate/All.v | 20 +++++++++++++++++++ .../theories/ToTemplate/Template/Typing.v | 1 + 3 files changed, 22 insertions(+) create mode 100644 quotation/theories/ToTemplate/All.v diff --git a/quotation/_CoqProject.in b/quotation/_CoqProject.in index f1d0a150a..992b93ede 100644 --- a/quotation/_CoqProject.in +++ b/quotation/_CoqProject.in @@ -1,6 +1,7 @@ -R theories MetaCoq.Quotation theories/CommonUtils.v +theories/ToTemplate/All.v theories/ToTemplate/Common/BasicAst.v theories/ToTemplate/Common/Environment.v theories/ToTemplate/Common/EnvironmentTyping.v diff --git a/quotation/theories/ToTemplate/All.v b/quotation/theories/ToTemplate/All.v new file mode 100644 index 000000000..030b0bb17 --- /dev/null +++ b/quotation/theories/ToTemplate/All.v @@ -0,0 +1,20 @@ +From MetaCoq.Common Require Import config. +From MetaCoq.Template Require Import Ast Typing. +From MetaCoq.Template Require WfAst (*WfTyping*). +From MetaCoq.Quotation.ToTemplate.Template Require Ast Typing WfAst (*WfTyping*). + +(* without typing derivations *) +Module Raw. + (* These are probably the only quotation functions that users of this development will want to use; other files should be considered internal to the development of quotation *) + Definition quote_term : Ast.term -> Ast.term := Ast.quote_term. + Definition quote_typing {cf : checker_flags} {Σ Γ t T} : (Σ ;;; Γ |- t : T) -> Ast.term := Typing.quote_typing. + Definition quote_wf_local {cf : checker_flags} {Σ Γ} : wf_local Σ Γ -> Ast.term := Typing.quote_wf_local. + Definition quote_wf {cf Σ} : @wf cf Σ -> Ast.term := Typing.quote_wf. + Definition quote_wf_ext {cf Σ} : @wf_ext cf Σ -> Ast.term := Typing.quote_wf_ext. + Module WfAst. + Definition quote_wf {Σ t} : @WfAst.wf Σ t -> Ast.term := WfAst.quote_wf. + End WfAst. + (* TODO: do we want anything from WfTyping? Is there anything else missing here? *) +End Raw. + +(* eventually we'll have proofs that the above definitions are well-typed *) diff --git a/quotation/theories/ToTemplate/Template/Typing.v b/quotation/theories/ToTemplate/Template/Typing.v index bc287b3fa..51ef3bdcb 100644 --- a/quotation/theories/ToTemplate/Template/Typing.v +++ b/quotation/theories/ToTemplate/Template/Typing.v @@ -77,6 +77,7 @@ Section quote_typing. End quote_typing. #[export] Instance quote_typing {cf Σ Γ t T} : ground_quotable (@typing cf Σ Γ t T) := quote_typing'. #[export] Instance quote_typing_spine {cf Σ Γ t s T} : ground_quotable (@typing_spine cf Σ Γ t s T) := quote_typing_spine'. +Definition quote_wf_local {cf : config.checker_flags} {Σ Γ} : ground_quotable (wf_local Σ Γ) := _. #[export] Instance quote_has_nparams {npars ty} : ground_quotable (@has_nparams npars ty) := ltac:(cbv [has_nparams]; exact _). #[export] Instance quote_infer_sorting {cf Σ Γ T} : ground_quotable (@infer_sorting cf Σ Γ T) := ltac:(cbv [infer_sorting]; exact _). From 24560cfa73bab0fdb3bd5721d111eadc854e0597 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Mon, 3 Apr 2023 16:55:10 -0700 Subject: [PATCH 03/10] Work around `-unset "Universe Checking"` being passed in `quick` mode --- quotation/theories/CommonUtils.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/quotation/theories/CommonUtils.v b/quotation/theories/CommonUtils.v index 5ac0dcfcc..423eb9cb9 100644 --- a/quotation/theories/CommonUtils.v +++ b/quotation/theories/CommonUtils.v @@ -259,7 +259,7 @@ Module WithTemplate. else ret (tSort u)) t). - Polymorphic Inductive list_of_types := nil | cons (x : Type) (xs : list_of_types). + Polymorphic Inductive list_of_types@{u} : Type@{u+1} := nil | cons (x : Type@{u}) (xs : list_of_types). Declare Scope list_of_types_scope. Delimit Scope list_of_types_scope with list_of_types. Bind Scope list_of_types_scope with list_of_types. @@ -349,7 +349,7 @@ Module WithTemplate. (* Hack around https://github.com/MetaCoq/metacoq/pull/876#issuecomment-1487743822 *) Monomorphic Variant exn : Set := GenericError. - Polymorphic Variant option_try (A : Type) : Type := my_Value (val : A) | my_Error (err : exn). + Polymorphic Variant option_try@{u} (A : Type@{u}) : Type@{max(Set, u)} := my_Value (val : A) | my_Error (err : exn). Arguments my_Value {A} val. Arguments my_Error {A} _. From 172a6cf356314ee97a3537e937829a5cf509f49d Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Mon, 3 Apr 2023 20:16:55 -0700 Subject: [PATCH 04/10] Slightly better universe error messages in `{replace,make}_quotation_of_goal` --- quotation/theories/ToTemplate/Init.v | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/quotation/theories/ToTemplate/Init.v b/quotation/theories/ToTemplate/Init.v index a60c416ba..d2a84fc57 100644 --- a/quotation/theories/ToTemplate/Init.v +++ b/quotation/theories/ToTemplate/Init.v @@ -244,11 +244,13 @@ Defined. Ltac replace_quotation_of_goal _ := let t := match goal with |- quotation_of ?t => t end in - run_template_program (replace_quotation_of t) (fun v => exact v). + let T := match goal with |- @quotation_of ?T ?t => T end in + run_template_program (@replace_quotation_of _ T t) (fun v => exact v). Ltac make_quotation_of_goal _ := let t := match goal with |- quotation_of ?t => t end in - run_template_program (make_quotation_of t) (fun v => exact v). + let T := match goal with |- @quotation_of ?T ?t => T end in + run_template_program (@make_quotation_of _ T t) (fun v => exact v). Ltac adjust_quotation_of_by_econstructor_then tac1 tac2 := let f := match goal with |- ?f _ => f end in From 55c781cf8f3bda3b35795856fff893445fd8b0dd Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Mon, 3 Apr 2023 21:47:05 -0700 Subject: [PATCH 05/10] Fix a build error Unclear why recent changes resulted in swapping the order of `quote_prod` and `destruct` result in universe inconsistencies... --- quotation/theories/ToTemplate/Template/WfAst.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/quotation/theories/ToTemplate/Template/WfAst.v b/quotation/theories/ToTemplate/Template/WfAst.v index a7b1fbeb9..9ba8c3d34 100644 --- a/quotation/theories/ToTemplate/Template/WfAst.v +++ b/quotation/theories/ToTemplate/Template/WfAst.v @@ -14,5 +14,5 @@ Defined. #[export] Instance quote_wf_Inv {Σ t} : ground_quotable (@wf_Inv Σ t) := ltac:(cbv [wf_Inv]; exact _). Import StrongerInstances. -#[export] Instance quote_wf_decl {Σ d} : ground_quotable (@wf_decl Σ d) := ltac:(cbv [wf_decl]; exact _). +#[export] Instance quote_wf_decl {Σ d} : ground_quotable (@wf_decl Σ d) := ltac:(cbv [wf_decl]; destruct decl_body; exact _). #[export] Instance quote_wf_decl_pred {Σ Γ t T} : ground_quotable (@wf_decl_pred Σ Γ t T) := ltac:(cbv [wf_decl_pred]; exact _). From 4719f668ba43f6d51d94b64b9a69c9f78650a430 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Tue, 4 Apr 2023 00:19:29 -0700 Subject: [PATCH 06/10] Fix name ambiguity --- test-suite/plugin-demo/theories/MyPlugin.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/plugin-demo/theories/MyPlugin.v b/test-suite/plugin-demo/theories/MyPlugin.v index e0d3babef..eb1194317 100644 --- a/test-suite/plugin-demo/theories/MyPlugin.v +++ b/test-suite/plugin-demo/theories/MyPlugin.v @@ -3,7 +3,7 @@ From MetaCoq.Utils Require Import bytestring. From MetaCoq.Common Require Import BasicAst. From MetaCoq.Template Require Import Ast Loader TemplateMonad.Extractable. Import TemplateMonad.Extractable. -From MetaCoq Require Import Template.AstUtils Ast. +From MetaCoq.Template Require Import AstUtils Ast. Open Scope bs_scope. From 02873eea66b3beb41520c895ccb3b5e4c891c235 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Tue, 4 Apr 2023 11:23:22 -0700 Subject: [PATCH 07/10] Don't unset universe checking in quick mode in quotation We cannot unset universe checking in 8.16 due to COQBUG(https://github.com/coq/coq/issues/17361), and quick does not buy much in quotation anyway, where almost everything is transparent --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 2c1e7d1d6..ebbda1a48 100644 --- a/Makefile +++ b/Makefile @@ -99,7 +99,7 @@ quick: $(MAKE) -C pcuic quick $(MAKE) -C safechecker quick $(MAKE) -C template-pcuic quick - $(MAKE) -C quotation quick + $(MAKE) -C quotation # quick # we cannot unset universe checking in 8.16 due to COQBUG(https://github.com/coq/coq/issues/17361), and quick does not buy much in quotation anyway, where almost everything is transparent $(MAKE) -C erasure quick $(MAKE) -C erasure-plugin quick $(MAKE) -C translations quick From 6e78750f4444120ffa910944da859830f3064281 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Mon, 3 Apr 2023 22:21:59 -0700 Subject: [PATCH 08/10] Be more explicit about polymorphism --- quotation/theories/CommonUtils.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/quotation/theories/CommonUtils.v b/quotation/theories/CommonUtils.v index 423eb9cb9..1f7fd3435 100644 --- a/quotation/theories/CommonUtils.v +++ b/quotation/theories/CommonUtils.v @@ -152,11 +152,11 @@ Module WithTemplate. tmFail "tmQuoteToGlobalReference: Not a global reference" end. - Polymorphic Definition tmObj_magic {A B} (x : A) : TemplateMonad B + Polymorphic Definition tmObj_magic@{a b t u} {A : Type@{a}} {B : Type@{b}} (x : A) : TemplateMonad@{t u} B := qx <- tmQuote x;; tmUnquoteTyped B qx. - Polymorphic Definition tmRetype {A} (x : A) : TemplateMonad A + Polymorphic Definition tmRetype@{a t u} {A : Type@{a}} (x : A) : TemplateMonad@{t u} A := tmObj_magic x. Polymorphic Definition tmExtractBaseModPathFromMod (mp : qualid) : TemplateMonad modpath From b2fb9e22d0c823f07689f80cc4bcfae7fd4d6360 Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Tue, 4 Apr 2023 00:03:55 -0700 Subject: [PATCH 09/10] Work around more universe issues Not currently needed, but will be needed for TypingWf compatiblity --- quotation/theories/ToTemplate/Common/Environment.v | 2 ++ quotation/theories/ToTemplate/Init.v | 10 ++++++++++ 2 files changed, 12 insertions(+) diff --git a/quotation/theories/ToTemplate/Common/Environment.v b/quotation/theories/ToTemplate/Common/Environment.v index 7b82eb191..a2a3abdce 100644 --- a/quotation/theories/ToTemplate/Common/Environment.v +++ b/quotation/theories/ToTemplate/Common/Environment.v @@ -90,6 +90,8 @@ Module QuoteEnvironment (T : Term) (Import E : EnvironmentSig T) (Import QEH : Q typ_or_sort . + Import PolymorphicInstances. + #[export] Instance quote_constructor_body : ground_quotable constructor_body := ltac:(destruct 1; exact _). #[export] Instance quote_projection_body : ground_quotable projection_body := ltac:(destruct 1; exact _). #[export] Instance quote_one_inductive_body : ground_quotable one_inductive_body := ltac:(destruct 1; exact _). diff --git a/quotation/theories/ToTemplate/Init.v b/quotation/theories/ToTemplate/Init.v index d2a84fc57..5b6fe823a 100644 --- a/quotation/theories/ToTemplate/Init.v +++ b/quotation/theories/ToTemplate/Init.v @@ -326,6 +326,16 @@ Module Export Instances. ] : typeclass_instances. End Instances. +Module PolymorphicInstances. + #[export] Polymorphic Instance quote_relax_universe@{a b c} {A : Type@{a}} {q : @quotation_of Type@{b} A} : @quotation_of Type@{c} A | 100 := (q : Ast.term). + #[export] Hint Cut [ + ( _ * ) + quote_relax_universe + ( _ * ) + quote_relax_universe + ] : typeclass_instances. +End PolymorphicInstances. + Module StrongerInstances. #[export] Hint Extern 1 (quotation_of match ?t with _ => _ end) => destruct t : typeclass_instances. From 3127b62c09811cf16f1892b203ccd6d4cc168dba Mon Sep 17 00:00:00 2001 From: Jason Gross Date: Tue, 4 Apr 2023 13:52:08 -0700 Subject: [PATCH 10/10] Universe polymorphism in `{replace,make}_quotation_of` --- quotation/theories/ToTemplate/Init.v | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/quotation/theories/ToTemplate/Init.v b/quotation/theories/ToTemplate/Init.v index 5b6fe823a..e9e4d3811 100644 --- a/quotation/theories/ToTemplate/Init.v +++ b/quotation/theories/ToTemplate/Init.v @@ -9,6 +9,7 @@ Export TemplateMonad.Common (export, local, global). Import ListNotations. Local Set Primitive Projections. +Local Unset Universe Minimization ToSet. Local Open Scope bs. Import MCMonadNotation. @@ -48,7 +49,7 @@ Fixpoint head (t : term) : term | _ => t end. -Definition infer_replacement_inductive {debug : debug_opt} (qt : term) : TemplateMonad (option inductive). +Polymorphic Definition infer_replacement_inductive {debug : debug_opt} (qt : term) : TemplateMonad (option inductive). Proof. simple refine (match qt with @@ -79,7 +80,7 @@ Proof. end). Defined. -Fixpoint replace_quotation_of' {debug : debug_opt} (do_top_inference : bool) (qt : term) : TemplateMonad term. +Polymorphic Fixpoint replace_quotation_of' {debug : debug_opt} (do_top_inference : bool) (qt : term) : TemplateMonad term. Proof. specialize (replace_quotation_of' debug). simple @@ -183,12 +184,12 @@ Proof. try exact _. Defined. -Definition replace_quotation_of {debug : debug_opt} {T} (t : T) : TemplateMonad term +Polymorphic Definition replace_quotation_of {debug : debug_opt} {T} (t : T) : TemplateMonad term := qt <- tmQuote t;; replace_quotation_of' false qt. (** for fancier goals when we have [ground_quotable] for some subterms but not for subterms of those subterms *) -Definition make_quotation_of {debug : debug_opt} {T} (t : T) : TemplateMonad (quotation_of t). +Polymorphic Definition make_quotation_of {debug : debug_opt} {T} (t : T) : TemplateMonad (quotation_of t). Proof. simple refine @@ -465,7 +466,7 @@ Polymorphic Definition tmPrepareMakeQuotationOfConstants@{U t u u' _T _above_u _ let cs := dedup_grefs cs in cs <- tmEval cbv cs;; _ <- tmDebugMsg "tmPrepareMakeQuotationOfConstants: looking up module constants";; - ps <- monad_map@{_ _ _ _above_u'} + ps <- monad_map@{_ _ Set _above_u'} (fun r => _ <- tmDebugMsg "tmPrepareMakeQuotationOfConstants: handling";; _ <- tmDebugPrint r;; @@ -549,7 +550,7 @@ Polymorphic Definition tmMakeQuotationOfConstants_gen@{U d t u u' _T _above_u _a _ <- (match existing_instance with | Some locality => _ <- tmDebugMsg "tmMakeQuotationOfConstants_gen: making instances";; - monad_map + monad_map@{_ _ Set Set} (fun p => let tmEx := tmExistingInstance locality p in _ <- tmDebugPrint tmEx;;