From 7db0eb0b467614bbe8e0f1b0d78ea9077de2bfa0 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sun, 31 Mar 2019 23:43:12 -0400 Subject: [PATCH 01/71] working on plugin extraction --- template-coq/_CoqProject | 17 ++++++++++---- template-coq/src/meta_coq_plugin.mlpack | 14 +++++++++++ .../src/{pluginCore.ml => plugin_core.ml} | 0 .../src/{pluginCore.mli => plugin_core.mli} | 0 template-coq/src/run_extractable.ml | 23 +++++++++++++++++++ template-coq/theories/.gitignore | 2 ++ .../theories/TemplateMonad/Extractable.v | 3 +-- test-suite/extractable.v | 3 ++- 8 files changed, 55 insertions(+), 7 deletions(-) create mode 100644 template-coq/src/meta_coq_plugin.mlpack rename template-coq/src/{pluginCore.ml => plugin_core.ml} (100%) rename template-coq/src/{pluginCore.mli => plugin_core.mli} (100%) create mode 100644 template-coq/src/run_extractable.ml create mode 100644 template-coq/theories/.gitignore diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index f7ae6d913..fbd7ba731 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -1,6 +1,8 @@ -I src +-I gen-src -R theories Template +# the MetaCoq plugin src/tm_util.ml # src/quoter.mli src/quoter.ml @@ -14,8 +16,12 @@ src/template_coq.mlpack src/template_monad.ml src/run_template_monad.mli src/run_template_monad.ml -src/pluginCore.mli -src/pluginCore.ml +src/plugin_core.mli +src/plugin_core.ml + +# the MetaCoq plugin-extraction code +src/run_extractable.ml +src/meta_coq_plugin.mlpack theories/LibHypsNaming.v theories/utils.v theories/config.v theories/kernel/univ.v @@ -26,7 +32,7 @@ theories/LiftSubst.v theories/UnivSubst.v theories/Typing.v theories/TypingWf.v theories/Generation.v theories/WeakeningEnv.v theories/Closed.v theories/Weakening.v theories/Substitution.v theories/MetaTheory.v theories/Checker.v theories/WcbvEval.v -theories/Retyping.v theories/All.v theories/Extraction.v +theories/Retyping.v theories/All.v # the Template monad theories/TemplateMonad.v @@ -34,4 +40,7 @@ theories/TemplateMonad/Common.v theories/TemplateMonad/Core.v theories/TemplateMonad/Extractable.v theories/TemplateMonad/Monad.v -theories/monad_utils.v \ No newline at end of file +theories/monad_utils.v + +# for Extraction +theories/Extraction.v diff --git a/template-coq/src/meta_coq_plugin.mlpack b/template-coq/src/meta_coq_plugin.mlpack new file mode 100644 index 000000000..fd3bdd531 --- /dev/null +++ b/template-coq/src/meta_coq_plugin.mlpack @@ -0,0 +1,14 @@ + + + + +Tm_util +Quoter +Constr_quoter +Template_monad +Denote +Plugin_core + +Extractable + +Run_extractable \ No newline at end of file diff --git a/template-coq/src/pluginCore.ml b/template-coq/src/plugin_core.ml similarity index 100% rename from template-coq/src/pluginCore.ml rename to template-coq/src/plugin_core.ml diff --git a/template-coq/src/pluginCore.mli b/template-coq/src/plugin_core.mli similarity index 100% rename from template-coq/src/pluginCore.mli rename to template-coq/src/plugin_core.mli diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml new file mode 100644 index 000000000..0403a9c02 --- /dev/null +++ b/template-coq/src/run_extractable.ml @@ -0,0 +1,23 @@ +open Extractable +open PluginCore + +let rec interp_tm (t : 'a coq_TM) : 'a tm = + match t with + | Coq_tmReturn x -> tmReturn x + | Coq_tmBind (c, k) -> tmBind (interp_tm c) (fun x -> interp_tm (k x)) + | Coq_tmPrint t -> tmPrint t + | Coq_tmMsg msg -> tmMsg msg + | Coq_tmFail err -> tmFail err + | Coq_tmEval (r,t) -> tmEval r t + | Coq_tmDefinition (nm, typ, trm) -> tmDefinition nm typ trm + | Coq_tmAxiom (nm, typ) -> tmAxiom nm typ + | Coq_tmLemma (nm, typ) -> tmLemma nm typ + | Coq_tmFreshName nm -> tmFreshName tm + | Coq_tmAbout id -> tmAbout id + | Coq_tmCurrentModPath -> tmCurrentModPath + | Coq_tmQuoteIndutive kn -> tmQuoteInductive kn + | Coq_tmQuoteUniverses -> tmQuoteUniverses + | Coq_tmQuoteConstant (kn, b) -> tmQuoteConstant kn b + | Coq_tmInductive i -> tmInductive i + | Coq_tmExistingInstance k -> tmExistingInstance k + | Coq_tmInferInstance t -> tmInferInstance t diff --git a/template-coq/theories/.gitignore b/template-coq/theories/.gitignore new file mode 100644 index 000000000..d3646e2a9 --- /dev/null +++ b/template-coq/theories/.gitignore @@ -0,0 +1,2 @@ +*.mli +*.ml \ No newline at end of file diff --git a/template-coq/theories/TemplateMonad/Extractable.v b/template-coq/theories/TemplateMonad/Extractable.v index 054079e6d..3cc646839 100644 --- a/template-coq/theories/TemplateMonad/Extractable.v +++ b/template-coq/theories/TemplateMonad/Extractable.v @@ -14,7 +14,6 @@ Set Printing Universes. *) - Cumulative Inductive TM@{t} : Type@{t} -> Type := (* Monadic operations *) | tmReturn {A:Type@{t}} @@ -98,4 +97,4 @@ Definition tmDefinitionRed (i : ident) (rd : reductionStrategy) Definition tmInferInstanceRed (rd : reductionStrategy) (type : Ast.term) : TM (option Ast.term) := - tmBind (tmEval rd type) (fun type => tmInferInstance type). \ No newline at end of file + tmBind (tmEval rd type) (fun type => tmInferInstance type). diff --git a/test-suite/extractable.v b/test-suite/extractable.v index 5906586c9..6edec3073 100644 --- a/test-suite/extractable.v +++ b/test-suite/extractable.v @@ -7,7 +7,8 @@ From Template.TemplateMonad Require Import Local Open Scope string_scope. -Notation "<% x %>" := (ltac:(let p y := exact y in quote_term x p)). +Notation "<% x %>" := (ltac:(let p y := exact y in quote_term x p)) + (only parsing). Run TemplateProgram (tmBind (tmReturn 1) (fun x => tmMsg (utils.string_of_nat x))). From 53254670e50d0b574714694acc5cfc8ac2b47661 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sun, 31 Mar 2019 23:48:33 -0400 Subject: [PATCH 02/71] typo --- template-coq/_CoqProject | 1 - 1 file changed, 1 deletion(-) diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index fbd7ba731..e971cb2ca 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -1,5 +1,4 @@ -I src --I gen-src -R theories Template # the MetaCoq plugin From ea3f49a10861f19cd942a64fa8c89db0e03f2ec0 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 2 Apr 2019 15:34:40 -0400 Subject: [PATCH 03/71] working on some of the extraction pieces --- template-coq/.gitignore | 2 + template-coq/Makefile | 18 ++++- template-coq/_CoqProject | 8 +- template-coq/_PluginProject | 88 +++++++++++++++++++++ template-coq/gen-src/.gitignore | 2 + template-coq/gen-src/Extraction.v | 54 +++++++++++++ template-coq/gen-src/coq_constr.ml | 60 ++++++++++++++ template-coq/gen-src/meta_coq_plugin.mlpack | 33 ++++++++ template-coq/src/run_extractable.ml | 2 +- template-coq/src/run_template_monad.ml | 16 ++-- template-coq/src/template_coq.mlpack | 2 +- template-coq/theories/Extraction.v | 26 ------ 12 files changed, 267 insertions(+), 44 deletions(-) create mode 100644 template-coq/.gitignore create mode 100644 template-coq/_PluginProject create mode 100644 template-coq/gen-src/.gitignore create mode 100644 template-coq/gen-src/Extraction.v create mode 100644 template-coq/gen-src/coq_constr.ml create mode 100644 template-coq/gen-src/meta_coq_plugin.mlpack delete mode 100644 template-coq/theories/Extraction.v diff --git a/template-coq/.gitignore b/template-coq/.gitignore new file mode 100644 index 000000000..f08c6eae6 --- /dev/null +++ b/template-coq/.gitignore @@ -0,0 +1,2 @@ +Makefile.plugin +Makefile.plugin.conf \ No newline at end of file diff --git a/template-coq/Makefile b/template-coq/Makefile index 5ae45fd51..97a1a2ce5 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -1,4 +1,12 @@ -all: Makefile.coq +all: coq plugin + +gen-src/Extraction.vo: coq gen-src/Extraction.v + $(COQPATH)coqc -I src -Q theories Template gen-src/Extraction.v + +plugin: coq Makefile.plugin + $(MAKE) -f Makefile.plugin + +coq: Makefile.coq $(MAKE) -f Makefile.coq .PHONY: all install html clean mrproper @@ -9,14 +17,18 @@ install: Makefile.coq html: all $(MAKE) -f Makefile.coq html -clean: Makefile.coq +clean: Makefile.coq Makefile.plugin $(MAKE) -f Makefile.coq clean + $(MAKE) -f Makefile.plugin clean mrproper: clean - rm -f Makefile.coq + rm -f Makefile.coq Makefile.plugin Makefile.coq: _CoqProject coq_makefile -f _CoqProject -o Makefile.coq +Makefile.plugin: coq _PluginProject + $(COQPATH)coq_makefile -f _PluginProject -o Makefile.plugin + .merlin: Makefile.coq $(MAKE) -f Makefile.coq .merlin diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index e971cb2ca..dfb0033b1 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -1,4 +1,5 @@ -I src +-I gen-src -R theories Template # the MetaCoq plugin @@ -18,10 +19,6 @@ src/run_template_monad.ml src/plugin_core.mli src/plugin_core.ml -# the MetaCoq plugin-extraction code -src/run_extractable.ml -src/meta_coq_plugin.mlpack - theories/LibHypsNaming.v theories/utils.v theories/config.v theories/kernel/univ.v theories/kernel/uGraph.v theories/BasicAst.v theories/Ast.v @@ -42,4 +39,5 @@ theories/TemplateMonad/Monad.v theories/monad_utils.v # for Extraction -theories/Extraction.v +gen-src/Extraction.v +gen-src/extracted.mlpack diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject new file mode 100644 index 000000000..13cebaf19 --- /dev/null +++ b/template-coq/_PluginProject @@ -0,0 +1,88 @@ +-I src +-I gen-src +-Q theories Template + +gen-src/Ascii.ml +gen-src/Ascii.mli +gen-src/Ast0.ml +gen-src/Ast0.mli +gen-src/AstUtils.ml +gen-src/AstUtils.mli +gen-src/BasicAst.ml +gen-src/BasicAst.mli +gen-src/Basics.ml +gen-src/Basics.mli +gen-src/BinInt.ml +gen-src/BinInt.mli +gen-src/BinNat.ml +gen-src/BinNat.mli +gen-src/BinNums.ml +gen-src/BinNums.mli +gen-src/BinPosDef.ml +gen-src/BinPosDef.mli +gen-src/BinPos.ml +gen-src/BinPos.mli +gen-src/Bool.ml +gen-src/Bool.mli +gen-src/Checker0.ml +gen-src/Checker0.mli +gen-src/Common.ml +gen-src/Common.mli +gen-src/config0.ml +gen-src/config0.mli +gen-src/Datatypes.ml +gen-src/Datatypes.mli +gen-src/DecidableType.ml +gen-src/DecidableType.mli +gen-src/Decimal.ml +gen-src/Decimal.mli +gen-src/Equalities.ml +gen-src/Equalities.mli +gen-src/Extractable.ml +gen-src/Extractable.mli +gen-src/FMapWeakList.ml +gen-src/FMapWeakList.mli +gen-src/LiftSubst.ml +gen-src/LiftSubst.mli +gen-src/List0.ml +gen-src/List0.mli +gen-src/Logic.ml +gen-src/Logic.mli +gen-src/monad_utils.ml +gen-src/monad_utils.mli +gen-src/MSetWeakList.ml +gen-src/MSetWeakList.mli +gen-src/Nat0.ml +gen-src/Nat0.mli +gen-src/OrderedType0.ml +gen-src/OrderedType0.mli +gen-src/Orders.ml +gen-src/Orders.mli +gen-src/OrdersTac.ml +gen-src/OrdersTac.mli +gen-src/PeanoNat.ml +gen-src/PeanoNat.mli +gen-src/Retyping0.ml +gen-src/Retyping0.mli +gen-src/Specif.ml +gen-src/Specif.mli +gen-src/String0.ml +gen-src/String0.mli +gen-src/Typing0.ml +gen-src/Typing0.mli +gen-src/TypingWf.ml +gen-src/TypingWf.mli +gen-src/uGraph0.ml +gen-src/uGraph0.mli +gen-src/univ0.ml +gen-src/univ0.mli +gen-src/UnivSubst0.ml +gen-src/UnivSubst0.mli +gen-src/utils.ml +gen-src/utils.mli +gen-src/Wf.ml +gen-src/Wf.mli +gen-src/coq_constr.ml + +gen-src/run_extractable.ml +gen-src/meta_coq_plugin.mlpack \ No newline at end of file diff --git a/template-coq/gen-src/.gitignore b/template-coq/gen-src/.gitignore new file mode 100644 index 000000000..d3646e2a9 --- /dev/null +++ b/template-coq/gen-src/.gitignore @@ -0,0 +1,2 @@ +*.mli +*.ml \ No newline at end of file diff --git a/template-coq/gen-src/Extraction.v b/template-coq/gen-src/Extraction.v new file mode 100644 index 000000000..7483685f5 --- /dev/null +++ b/template-coq/gen-src/Extraction.v @@ -0,0 +1,54 @@ +(** Extraction setup for template-coq. + + Any extracted code planning to link with the plugin's OCaml reifier + should use these same directives for consistency. +*) + +From Template Require All. + +Require Import FSets. +Require Import ExtrOcamlBasic. +Require Import ExtrOcamlString ExtrOcamlZInt. + +(* Ignore [Decimal.int] before the extraction issue is solved: + https://github.com/coq/coq/issues/7017. *) +Extract Inductive Decimal.int => unit [ "(fun _ -> ())" "(fun _ -> ())" ] "(fun _ _ _ -> assert false)". + +Extract Constant utils.ascii_compare => + "fun x y -> match Char.compare x y with 0 -> Eq | x when x < 0 -> Lt | _ -> Gt". + +Extraction Blacklist config uGraph univ Ast String List Nat Int + UnivSubst Typing Checker Retyping OrderedType. +Set Warnings "-extraction-opaque-accessed". + +Require Import Template.Ast. + +Extract Inductive BasicAst.cast_kind => "Constr.cast_kind" + [ "Constr.VMcast" "Constr.NATIVEcast" "Constr.DEFAULTcast" "Constr.REVERTcast" ]. + +Extract Inductive Ast.term => + "Constr.t" [ "Coq_constr.tRel" + "Coq_constr.tVar" + "Coq_constr.tMeta" + "Coq_constr.tEvar" + "Coq_constr.tSort" + "Coq_constr.tCast" + "Coq_constr.tProd" + "Coq_constr.tLambda" + "Coq_constr.tLetIn" + "Coq_constr.tApp" + "Coq_constr.tConst" + "Coq_constr.tInd" + "Coq_constr.tConstruct" + "Coq_constr.tCase" + "Coq_constr.tProj" + "Coq_constr.tFix" + "Coq_constr.tCoFix" ] "Coq_constr.constr_match". + +Cd "gen-src". + +Require Import Template.TemplateMonad.Extractable. + +Recursive Extraction Library Extractable. + +Cd "..". \ No newline at end of file diff --git a/template-coq/gen-src/coq_constr.ml b/template-coq/gen-src/coq_constr.ml new file mode 100644 index 000000000..23cff6c2c --- /dev/null +++ b/template-coq/gen-src/coq_constr.ml @@ -0,0 +1,60 @@ +open Plugin_core +open Constr + +type nat + +let tRel (n : nat) = + failwith "tRel" +let tVar (i : Names.Id.t) : Constr.t = + Constr.mkVar i + +let tMeta (n : nat) : Constr.t = + failwith "tMeta" + +let tEvar (n : nat) (ls : Constr.t list) : Constr.t = +(* Constr.mkEvar n (Array.of_list ls) *) + failwith "tEvar" + +let tSort (u : Univ.universe) : Constr.t = + Constr.mkSort u + +let tCast (a : Constr.t) (b : Constr.cast_kind) (c : Constr.t) : Constr.t = + Constr.mkCast (a, b, c) + + +let constr_match + (rel : nat -> 'a) + (var : ident -> 'a) + (meta : nat -> 'a) + (evar : nat -> term list -> 'a) + (sort : universe -> 'a) + (cast : term -> Constr.cast_kind -> term -> 'a) + (prod : name -> term -> term -> 'a) + (lambda : name -> term -> term -> 'a) + (letin : name -> term -> term -> term -> 'a) + (app : term -> term list -> 'a) + (const : kername -> universe_instance -> 'a) + (construct : inductive -> nat -> universe_instance -> 'a) + (case : inductive * nat * term -> term -> (nat * term) list -> 'a) + (proj : projection -> term -> 'a) + (fix : term mfixpoint -> nat -> 'a) + (cofix : term mfixpoint -> nat -> 'a) + (t : term) : 'a = + match Constr.kind t with + | Constr.Rel n -> rel n + | Constr.Var id -> var id + | Constr.Meta m -> meta m + | Constr.Evar (a,b) -> evar a b + | Constr.Sort s -> sort s + | Constr.Cast (a,b,c) -> cast a b c + | Constr.Prod (a,b,c) -> prod a b c + | Constr.Lambda (a,b,c) -> lambda a b c + | Constr.LetIn (a,b,c,d) -> letin a b c d + | Constr.App (f, xs) -> app f (Array.to_list xs) + | Constr.Const _ + | Constr.Ind _ + | Constr.Construct _ + | Constr.Case _ + | Constr.Fix _ + | Constr.CoFix _ + | Constr.Proj _ -> failwith "not implemented" diff --git a/template-coq/gen-src/meta_coq_plugin.mlpack b/template-coq/gen-src/meta_coq_plugin.mlpack new file mode 100644 index 000000000..b1c6f74eb --- /dev/null +++ b/template-coq/gen-src/meta_coq_plugin.mlpack @@ -0,0 +1,33 @@ +Utils +Ascii +Ast0 +Univ0 +AstUtils +BasicAst +Basics +BinInt +BinNat +BinNums +BinPosDef +BinPos +Bool +Common +Config0 +Datatypes +DecidableType +Decimal +Equalities +Extractable +FMapWeakList +List0 +Logic +MSetWeakList +Nat0 +OrderedType0 +Orders +OrdersTac +PeanoNat +Specif +String0 +UGraph0 +Coq_constr \ No newline at end of file diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 0403a9c02..ea7702019 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -1,5 +1,5 @@ open Extractable -open PluginCore +open Plugin_core let rec interp_tm (t : 'a coq_TM) : 'a tm = match t with diff --git a/template-coq/src/run_template_monad.ml b/template-coq/src/run_template_monad.ml index a133bc937..9065d0940 100644 --- a/template-coq/src/run_template_monad.ml +++ b/template-coq/src/run_template_monad.ml @@ -254,13 +254,13 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m (evm, Some t) in let poly = Flags.is_universe_polymorphism () in - PluginCore.run (PluginCore.tmDefinition name ~poly typ body) env evm + Plugin_core.run (Plugin_core.tmDefinition name ~poly typ body) env evm (fun env evm res -> k (env, evm, quote_kn res)) | TmLemmaTerm (name, typ) -> let ident = unquote_ident (reduce_all env evm name) in let evm,typ = denote_term evm (reduce_all env evm typ) in let poly = Flags.is_universe_polymorphism () in - PluginCore.run (PluginCore.tmLemma ident ~poly typ) env evm + Plugin_core.run (Plugin_core.tmLemma ident ~poly typ) env evm (fun env evm kn -> k (env, evm, quote_kn kn)) | TmAxiom (name,s,typ) -> if intactic @@ -284,7 +284,7 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m let name = unquote_ident (reduce_all env evm name) in let evm,typ = denote_term evm (reduce_all env evm typ) in let poly = Flags.is_universe_polymorphism () in - PluginCore.run (PluginCore.tmAxiom name ~poly typ) env evm + Plugin_core.run (Plugin_core.tmAxiom name ~poly typ) env evm (fun a b c -> k (a,b,quote_kn c)) | TmLemma (name,s,typ) -> let name = reduce_all env evm name in @@ -349,14 +349,14 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m k (env, evm, unit_tt) | TmMsg msg -> let msg = unquote_string (reduce_all env evm msg) in - PluginCore.run (PluginCore.tmMsg msg) env evm + Plugin_core.run (Plugin_core.tmMsg msg) env evm (fun env evm _ -> k (env, evm, unit_tt)) | TmFail trm -> let err = unquote_string (reduce_all env evm trm) in CErrors.user_err (str err) | TmAbout id -> let id = Libnames.qualid_of_string (unquote_string id) in - PluginCore.run (PluginCore.tmAbout id) env evm + Plugin_core.run (Plugin_core.tmAbout id) env evm (fun env evm -> function None -> k (env, evm, Constr.mkApp (cNone, [|tglobal_reference|])) | Some gr -> @@ -375,7 +375,7 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m | TmEvalTerm (s,trm) -> let red = unquote_reduction_strategy env evm (reduce_all env evm s) in let evm,trm = denote_term evm (reduce_all env evm trm) in - PluginCore.run (PluginCore.tmEval red trm) env evm + Plugin_core.run (Plugin_core.tmEval red trm) env evm (fun env evm trm -> k (env, evm, TermReify.quote_term env trm)) | TmMkInductive mind -> declare_inductive env evm mind; @@ -430,7 +430,7 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m end | TmInferInstanceTerm typ -> let evm,typ = denote_term evm (reduce_all env evm typ) in - PluginCore.run (PluginCore.tmInferInstance typ) env evm + Plugin_core.run (Plugin_core.tmInferInstance typ) env evm (fun env evm -> function None -> k (env, evm, Constr.mkApp (cNone, [| tTerm|])) | Some trm -> @@ -438,5 +438,5 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m k (env, evm, Constr.mkApp (cSome, [| tTerm; qtrm |]))) | TmPrintTerm trm -> let evm,trm = denote_term evm (reduce_all env evm trm) in - PluginCore.run (PluginCore.tmPrint trm) env evm + Plugin_core.run (Plugin_core.tmPrint trm) env evm (fun env evm _ -> k (env, evm, unit_tt)) diff --git a/template-coq/src/template_coq.mlpack b/template-coq/src/template_coq.mlpack index b97bb642d..2fa42b395 100644 --- a/template-coq/src/template_coq.mlpack +++ b/template-coq/src/template_coq.mlpack @@ -3,6 +3,6 @@ Quoter Constr_quoter Template_monad Denote -PluginCore +Plugin_core Run_template_monad G_template_coq diff --git a/template-coq/theories/Extraction.v b/template-coq/theories/Extraction.v deleted file mode 100644 index cbe4384b8..000000000 --- a/template-coq/theories/Extraction.v +++ /dev/null @@ -1,26 +0,0 @@ -(** Extraction setup for template-coq. - - Any extracted code planning to link with the plugin's OCaml reifier - should use these same directives for consistency. -*) - -From Template Require All. - -Require Import FSets. -Require Import ExtrOcamlBasic. -Require Import ExtrOcamlString ExtrOcamlZInt. - -(* Ignore [Decimal.int] before the extraction issue is solved: - https://github.com/coq/coq/issues/7017. *) -Extract Inductive Decimal.int => unit [ "(fun _ -> ())" "(fun _ -> ())" ] "(fun _ _ _ -> assert false)". - -Extract Constant utils.ascii_compare => - "fun x y -> match Char.compare x y with 0 -> Eq | x when x < 0 -> Lt | _ -> Gt". - -Extraction Blacklist config uGraph univ Ast String List Nat Int - UnivSubst Typing Checker Retyping OrderedType. -Set Warnings "-extraction-opaque-accessed". - -Recursive Extraction Library TypingWf. -Recursive Extraction Library Checker. -Recursive Extraction Library Retyping. From c53fe15fbe463bb7248965551fd0fa475d1fd9d5 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Thu, 4 Apr 2019 22:18:08 -0400 Subject: [PATCH 04/71] checkpoint. giving up on trying to do native extraction. --- template-coq/_PluginProject | 4 ++ template-coq/gen-src/Extraction.v | 8 ++++ template-coq/gen-src/coq_constr.ml | 46 +++++++++++++++++---- template-coq/gen-src/meta_coq_plugin.mlpack | 1 + 4 files changed, 50 insertions(+), 9 deletions(-) diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 13cebaf19..ee2b50f0c 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -82,7 +82,11 @@ gen-src/utils.ml gen-src/utils.mli gen-src/Wf.ml gen-src/Wf.mli + +gen-src/coq_basicast.ml +gen-src/coq_basicast.mli gen-src/coq_constr.ml + gen-src/run_extractable.ml gen-src/meta_coq_plugin.mlpack \ No newline at end of file diff --git a/template-coq/gen-src/Extraction.v b/template-coq/gen-src/Extraction.v index 7483685f5..45b596d2f 100644 --- a/template-coq/gen-src/Extraction.v +++ b/template-coq/gen-src/Extraction.v @@ -26,6 +26,11 @@ Require Import Template.Ast. Extract Inductive BasicAst.cast_kind => "Constr.cast_kind" [ "Constr.VMcast" "Constr.NATIVEcast" "Constr.DEFAULTcast" "Constr.REVERTcast" ]. +Extract Inductive Template.BasicAst.name => "Names.Name.t" + [ "Names.Name.Anonymous" + "Coq_basicast.mkName" ] + "Coq_basicast.name_match". + Extract Inductive Ast.term => "Constr.t" [ "Coq_constr.tRel" "Coq_constr.tVar" @@ -44,6 +49,9 @@ Extract Inductive Ast.term => "Coq_constr.tProj" "Coq_constr.tFix" "Coq_constr.tCoFix" ] "Coq_constr.constr_match". +Print universe. + + Cd "gen-src". diff --git a/template-coq/gen-src/coq_constr.ml b/template-coq/gen-src/coq_constr.ml index 23cff6c2c..e59f3aeaa 100644 --- a/template-coq/gen-src/coq_constr.ml +++ b/template-coq/gen-src/coq_constr.ml @@ -1,26 +1,54 @@ open Plugin_core open Constr -type nat +type name = Names.Name.t +type id = Names.Id.t +type universe = Univ.Universe.t +type universe_instance = unit +type projection = Names.Projection.t +type 'a mfixpoint = 'a BasicAst.mfixpoint +type nat = int let tRel (n : nat) = failwith "tRel" -let tVar (i : Names.Id.t) : Constr.t = +let tVar (i : id) : Constr.t = Constr.mkVar i let tMeta (n : nat) : Constr.t = failwith "tMeta" let tEvar (n : nat) (ls : Constr.t list) : Constr.t = -(* Constr.mkEvar n (Array.of_list ls) *) - failwith "tEvar" + failwith "tEvar is not supported" -let tSort (u : Univ.universe) : Constr.t = - Constr.mkSort u +let tSort (u : Univ.Universe.t) : Constr.t = + failwith "tSort" let tCast (a : Constr.t) (b : Constr.cast_kind) (c : Constr.t) : Constr.t = Constr.mkCast (a, b, c) +let tProd (n : name) (a : Constr.t) (b : Constr.t) : Constr.t = + Constr.mkProd (n, a, b) + +let tLambda (n : name) (a : Constr.t) (b : Constr.t) : Constr.t = + Constr.mkLambda (n, a, b) + +let tLetIn (n : name) (t : Constr.t) (b : Constr.t) (c : Constr.t) : Constr.t = + Constr.mkLetIn (n, t, b, c) + +let tApp (f : Constr.t) (ls : Constr.t list) : Constr.t = + Constr.mkApp (f, Array.of_list ls) + +let tConst (kn : 'a) : 'a = + failwith "tConst" + +let tConstruct (kn : 'a) : 'a = + failwith "tConstruct" + +let tCase (_ : 'a) : 'a = + failwith "tCase" + +let tProj (_ : BasicAst.projection) (_ : Constr.t) : Constr.t = + failwith "tProj" let constr_match (rel : nat -> 'a) @@ -34,8 +62,8 @@ let constr_match (letin : name -> term -> term -> term -> 'a) (app : term -> term list -> 'a) (const : kername -> universe_instance -> 'a) - (construct : inductive -> nat -> universe_instance -> 'a) - (case : inductive * nat * term -> term -> (nat * term) list -> 'a) + (construct : Names.inductive -> nat -> universe_instance -> 'a) + (case : Names.inductive * nat * term -> term -> (nat * term) list -> 'a) (proj : projection -> term -> 'a) (fix : term mfixpoint -> nat -> 'a) (cofix : term mfixpoint -> nat -> 'a) @@ -44,7 +72,7 @@ let constr_match | Constr.Rel n -> rel n | Constr.Var id -> var id | Constr.Meta m -> meta m - | Constr.Evar (a,b) -> evar a b + | Constr.Evar (a,b) -> evar (Evar.repr a) (Array.to_list b) | Constr.Sort s -> sort s | Constr.Cast (a,b,c) -> cast a b c | Constr.Prod (a,b,c) -> prod a b c diff --git a/template-coq/gen-src/meta_coq_plugin.mlpack b/template-coq/gen-src/meta_coq_plugin.mlpack index b1c6f74eb..ec211ccd3 100644 --- a/template-coq/gen-src/meta_coq_plugin.mlpack +++ b/template-coq/gen-src/meta_coq_plugin.mlpack @@ -30,4 +30,5 @@ PeanoNat Specif String0 UGraph0 +Coq_basicast Coq_constr \ No newline at end of file From 92ff62c93ce03d1c3f7a7432d8bc23b6904655ef Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Thu, 4 Apr 2019 23:07:29 -0400 Subject: [PATCH 05/71] fixing run_extractable. - the previous implementation was completely wrong. --- template-coq/_CoqProject | 1 - template-coq/_PluginProject | 5 - template-coq/gen-src/Extraction.v | 30 ------ template-coq/gen-src/meta_coq_plugin.mlpack | 17 +++- template-coq/gen-src/run_extractable.ml | 103 ++++++++++++++++++++ template-coq/src/meta_coq_plugin.mlpack | 14 --- template-coq/src/plugin_core.ml | 3 + template-coq/src/plugin_core.mli | 1 + template-coq/src/run_extractable.ml | 23 ----- 9 files changed, 122 insertions(+), 75 deletions(-) create mode 100644 template-coq/gen-src/run_extractable.ml delete mode 100644 template-coq/src/meta_coq_plugin.mlpack delete mode 100644 template-coq/src/run_extractable.ml diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index dfb0033b1..35998b2c4 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -40,4 +40,3 @@ theories/monad_utils.v # for Extraction gen-src/Extraction.v -gen-src/extracted.mlpack diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index ee2b50f0c..04921d9f9 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -83,10 +83,5 @@ gen-src/utils.mli gen-src/Wf.ml gen-src/Wf.mli -gen-src/coq_basicast.ml -gen-src/coq_basicast.mli -gen-src/coq_constr.ml - - gen-src/run_extractable.ml gen-src/meta_coq_plugin.mlpack \ No newline at end of file diff --git a/template-coq/gen-src/Extraction.v b/template-coq/gen-src/Extraction.v index 45b596d2f..ae11d543c 100644 --- a/template-coq/gen-src/Extraction.v +++ b/template-coq/gen-src/Extraction.v @@ -23,36 +23,6 @@ Set Warnings "-extraction-opaque-accessed". Require Import Template.Ast. -Extract Inductive BasicAst.cast_kind => "Constr.cast_kind" - [ "Constr.VMcast" "Constr.NATIVEcast" "Constr.DEFAULTcast" "Constr.REVERTcast" ]. - -Extract Inductive Template.BasicAst.name => "Names.Name.t" - [ "Names.Name.Anonymous" - "Coq_basicast.mkName" ] - "Coq_basicast.name_match". - -Extract Inductive Ast.term => - "Constr.t" [ "Coq_constr.tRel" - "Coq_constr.tVar" - "Coq_constr.tMeta" - "Coq_constr.tEvar" - "Coq_constr.tSort" - "Coq_constr.tCast" - "Coq_constr.tProd" - "Coq_constr.tLambda" - "Coq_constr.tLetIn" - "Coq_constr.tApp" - "Coq_constr.tConst" - "Coq_constr.tInd" - "Coq_constr.tConstruct" - "Coq_constr.tCase" - "Coq_constr.tProj" - "Coq_constr.tFix" - "Coq_constr.tCoFix" ] "Coq_constr.constr_match". -Print universe. - - - Cd "gen-src". Require Import Template.TemplateMonad.Extractable. diff --git a/template-coq/gen-src/meta_coq_plugin.mlpack b/template-coq/gen-src/meta_coq_plugin.mlpack index ec211ccd3..231802d88 100644 --- a/template-coq/gen-src/meta_coq_plugin.mlpack +++ b/template-coq/gen-src/meta_coq_plugin.mlpack @@ -30,5 +30,18 @@ PeanoNat Specif String0 UGraph0 -Coq_basicast -Coq_constr \ No newline at end of file + + + + + +Tm_util +Quoter +Constr_quoter +Template_monad +Denote +Plugin_core + +Extractable + +Run_extractable \ No newline at end of file diff --git a/template-coq/gen-src/run_extractable.ml b/template-coq/gen-src/run_extractable.ml new file mode 100644 index 000000000..ddfb79bac --- /dev/null +++ b/template-coq/gen-src/run_extractable.ml @@ -0,0 +1,103 @@ +open Extractable +open Plugin_core + +(* todo(gmm): determine what of these already exist. *) +let to_constr (t : Ast0.term) : Constr.t = + failwith "to_constr" + +let of_constr (t : Constr.t) : Ast0.term = + failwith "of_constr" + +let to_string (cl : char list) : string = + failwith "to_string" + +let of_string (s : string) : char list = + failwith "of_string" + +let to_reduction_strategy (s : Common.reductionStrategy) = + failwith "to_reduction_strategy" + +let to_ident : char list -> Names.Id.t = + failwith "to_ident" + +let of_ident : Names.Id.t -> char list = + failwith "of_ident" + +let of_global_reference (t : global_reference) : BasicAst.global_reference = + failwith "of_global_reference" + +let to_qualid (c : char list) : Libnames.qualid = + Libnames.qualid_of_string (to_string c) + +let of_qualid (q : Libnames.qualid) : char list = + of_string (Libnames.string_of_qualid q) + +let of_kername : Names.KerName.t -> char list = + failwith "of_kername" + +let to_kername : char list -> Names.KerName.t = + failwith "of_kername" + +let of_mib : Plugin_core.mutual_inductive_body -> _ = + failwith "of_mib" + +let to_mie : _ -> Plugin_core.mutual_inductive_entry = + failwith "to_mie" + +let of_constant_entry : _ -> Ast0.constant_entry = + failwith "of_constant_entry" + +let rec interp_tm (t : 'a coq_TM) : 'a tm = + match t with + | Coq_tmReturn x -> tmReturn x + | Coq_tmBind (c, k) -> tmBind (interp_tm c) (fun x -> interp_tm (k x)) + | Coq_tmPrint t -> Obj.magic (tmPrint (to_constr t)) + | Coq_tmMsg msg -> Obj.magic (tmMsg (to_string msg)) + | Coq_tmFail err -> tmFail (to_string err) + | Coq_tmEval (r,t) -> + tmMap (fun x -> Obj.magic (of_constr x)) + (tmEval (to_reduction_strategy r) (to_constr t)) + | Coq_tmDefinition (nm, typ, trm) -> + let typ = + match typ with + None -> None + | Some typ -> Some (to_constr typ) + in + tmMap (fun x -> Obj.magic (of_kername x)) + (tmDefinition (to_ident nm) typ (to_constr trm)) + | Coq_tmAxiom (nm, typ) -> + tmMap (fun x -> Obj.magic (of_kername x)) + (tmAxiom (to_ident nm) (to_constr typ)) + | Coq_tmLemma (nm, typ) -> + tmMap (fun x -> Obj.magic (of_kername x)) + (tmLemma (to_ident nm) (to_constr typ)) + | Coq_tmFreshName nm -> + tmMap (fun x -> Obj.magic (of_ident x)) + (tmFreshName (to_ident nm)) + | Coq_tmAbout id -> + tmMap (function + None -> Obj.magic None + | Some gr -> Obj.magic (Some (of_global_reference gr))) + (tmAbout (to_qualid id)) + | Coq_tmCurrentModPath -> + tmMap (fun mp -> Obj.magic (of_string (Names.ModPath.to_string mp))) + tmCurrentModPath + | Coq_tmQuoteInductive kn -> + tmMap (function + None -> Obj.magic None + | Some mib -> Obj.magic (Some (of_mib mib))) + (tmQuoteInductive (to_kername kn)) + | Coq_tmQuoteUniverses -> + tmMap (fun x -> failwith "tmQuoteUniverses") tmQuoteUniverses + | Coq_tmQuoteConstant (kn, b) -> + tmMap (fun x -> Obj.magic (of_constant_entry x)) + (tmQuoteConstant (to_kername kn) b) + | Coq_tmInductive i -> + tmMap (fun _ -> Obj.magic ()) (tmInductive (to_mie i)) + | Coq_tmExistingInstance k -> + Obj.magic (tmExistingInstance (to_kername k)) + | Coq_tmInferInstance t -> + tmMap (function + None -> Obj.magic None + | Some inst -> Obj.magic (Some (of_constr inst))) + (tmInferInstance (to_constr t)) diff --git a/template-coq/src/meta_coq_plugin.mlpack b/template-coq/src/meta_coq_plugin.mlpack deleted file mode 100644 index fd3bdd531..000000000 --- a/template-coq/src/meta_coq_plugin.mlpack +++ /dev/null @@ -1,14 +0,0 @@ - - - - -Tm_util -Quoter -Constr_quoter -Template_monad -Denote -Plugin_core - -Extractable - -Run_extractable \ No newline at end of file diff --git a/template-coq/src/plugin_core.ml b/template-coq/src/plugin_core.ml index 7885625e9..4b6cca8b3 100644 --- a/template-coq/src/plugin_core.ml +++ b/template-coq/src/plugin_core.ml @@ -38,6 +38,9 @@ let tmReturn (x : 'a) : 'a tm = let tmBind (x : 'a tm) (k : 'a -> 'b tm) : 'b tm = fun env evd success fail -> x env evd (fun env evd v -> k v env evd success fail) fail +let tmMap (f : 'a -> 'b) (x : 'a tm) : 'b tm = + fun env evd success fail -> + x env evd (fun env evd v -> success env evd (f v)) fail let tmPrint (t : term) : unit tm = fun env evd success _fail -> diff --git a/template-coq/src/plugin_core.mli b/template-coq/src/plugin_core.mli index c56584c70..1ddd5def9 100644 --- a/template-coq/src/plugin_core.mli +++ b/template-coq/src/plugin_core.mli @@ -24,6 +24,7 @@ val run : 'a tm -> Environ.env -> Evd.evar_map -> (Environ.env -> Evd.evar_map - val tmReturn : 'a -> 'a tm val tmBind : 'a tm -> ('a -> 'b tm) -> 'b tm +val tmMap : ('a -> 'b) -> 'a tm -> 'b tm val tmPrint : term -> unit tm val tmMsg : string -> unit tm diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml deleted file mode 100644 index ea7702019..000000000 --- a/template-coq/src/run_extractable.ml +++ /dev/null @@ -1,23 +0,0 @@ -open Extractable -open Plugin_core - -let rec interp_tm (t : 'a coq_TM) : 'a tm = - match t with - | Coq_tmReturn x -> tmReturn x - | Coq_tmBind (c, k) -> tmBind (interp_tm c) (fun x -> interp_tm (k x)) - | Coq_tmPrint t -> tmPrint t - | Coq_tmMsg msg -> tmMsg msg - | Coq_tmFail err -> tmFail err - | Coq_tmEval (r,t) -> tmEval r t - | Coq_tmDefinition (nm, typ, trm) -> tmDefinition nm typ trm - | Coq_tmAxiom (nm, typ) -> tmAxiom nm typ - | Coq_tmLemma (nm, typ) -> tmLemma nm typ - | Coq_tmFreshName nm -> tmFreshName tm - | Coq_tmAbout id -> tmAbout id - | Coq_tmCurrentModPath -> tmCurrentModPath - | Coq_tmQuoteIndutive kn -> tmQuoteInductive kn - | Coq_tmQuoteUniverses -> tmQuoteUniverses - | Coq_tmQuoteConstant (kn, b) -> tmQuoteConstant kn b - | Coq_tmInductive i -> tmInductive i - | Coq_tmExistingInstance k -> tmExistingInstance k - | Coq_tmInferInstance t -> tmInferInstance t From d76a82f6868374cb47366ea44601b7f4e87a97a1 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Sun, 7 Apr 2019 21:07:07 -0700 Subject: [PATCH 06/71] did rel, var, and cast cases of to_constr. WIP: universes. --- template-coq/gen-src/run_extractable.ml | 99 ++++++++++++++++++++++++- 1 file changed, 96 insertions(+), 3 deletions(-) diff --git a/template-coq/gen-src/run_extractable.ml b/template-coq/gen-src/run_extractable.ml index ddfb79bac..3607cbb81 100644 --- a/template-coq/gen-src/run_extractable.ml +++ b/template-coq/gen-src/run_extractable.ml @@ -1,9 +1,8 @@ open Extractable open Plugin_core +open Ast0 +open BasicAst -(* todo(gmm): determine what of these already exist. *) -let to_constr (t : Ast0.term) : Constr.t = - failwith "to_constr" let of_constr (t : Constr.t) : Ast0.term = failwith "of_constr" @@ -47,6 +46,100 @@ let to_mie : _ -> Plugin_core.mutual_inductive_entry = let of_constant_entry : _ -> Ast0.constant_entry = failwith "of_constant_entry" +(* what about the overflow? + efficiency? extract to bigint using Coq directives and convert to int here? *) +let of_nat (t : Datatypes.nat) : int = + failwith "of_constr" + +let of_cast_kind (ck: BasicAst.cast_kind) : Constr.cast_kind = + match ck with + | VmCast -> Constr.VMcast + | NativeCast -> Constr.VMcast + | Cast -> Constr.DEFAULTcast + | RevertCast -> Constr.REVERTcast + + + (* todo(gmm): determine what of these already exist. *) +let rec to_constr_ev (evm : Evd.evar_map) (t : Ast0.term) : Evd.evar_map * Constr.t = + match t with + | Coq_tRel x -> evm, Constr.mkRel (of_nat x + 1) + | Coq_tVar x -> evm, Constr.mkVar (to_ident x) + | Coq_tCast (t,c,ty) -> let evm, t = to_constr_ev evm t in + let evm, ty = to_constr_ev evm ty in + evm, Constr.mkCast (t, of_cast_kind c, ty) + (* the next case is quite complex: look at Denote.unquote_universe *) + | Coq_tSort u -> evm, Constr.mkType u + | Coq_tProd (n,t,b) -> let evm, t = aux evm t in + let evm, b = aux evm b in + evm, Constr.mkProd (unquote_name n, t, b) + | Coq_tLambda (n,t,b) -> let evm, t = aux evm t in + let evm, b = aux evm b in + evm, Constr.mkLambda (unquote_name n, t, b) + | Coq_tLetIn (n,e,t,b) -> let evm, e = aux evm e in + let evm, t = aux evm t in + let evm, b = aux evm b in + evm, Constr.mkLetIn (unquote_name n, e, t, b) + | Coq_tApp (f,xs) -> let evm, f = aux evm f in + let evm, xs = map_evm aux evm xs in + evm, Constr.mkApp (f, Array.of_list xs) + | Coq_tConst (s,u) -> + let s = unquote_kn s in + let evm, u = unquote_universe_instance evm u in + (try + match Nametab.locate s with + | Globnames.ConstRef c -> evm, Constr.mkConstU (c, u) + | Globnames.IndRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is an inductive, use tInd.") + | Globnames.VarRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is a variable, use tVar.") + | Globnames.ConstructRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is a constructor, use tConstructor.") + with + Not_found -> CErrors.user_err (str"Constant not found: " ++ Libnames.pr_qualid s)) + | Coq_tConstruct (i,idx,u) -> + let ind = unquote_inductive i in + let evm, u = unquote_universe_instance evm u in + evm, Constr.mkConstructU ((ind, unquote_nat idx + 1), u) + | Coq_tInd (i, u) -> + let i = unquote_inductive i in + let evm, u = unquote_universe_instance evm u in + evm, Constr.mkIndU (i, u) + | Coq_tCase ((i, _), ty, d, brs) -> + let ind = unquote_inductive i in + let evm, ty = aux evm ty in + let evm, d = aux evm d in + let evm, brs = map_evm aux evm (List.map snd brs) in + (* todo: reify better case_info *) + let ci = Inductiveops.make_case_info (Global.env ()) ind Constr.RegularStyle in + evm, Constr.mkCase (ci, ty, d, Array.of_list brs) + | Coq_tFix (lbd, i) -> + let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, + List.map (fun p->p.rarg) lbd) in + let evm, types = map_evm aux evm types in + let evm, bodies = map_evm aux evm bodies in + let (names,rargs) = (List.map unquote_name names, List.map unquote_nat rargs) in + let la = Array.of_list in + evm, Constr.mkFix ((la rargs,unquote_nat i), (la names, la types, la bodies)) + | Coq_tCoFix (lbd, i) -> + let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, + List.map (fun p->p.rarg) lbd) in + let evm, types = map_evm aux evm types in + let evm, bodies = map_evm aux evm bodies in + let (names,rargs) = (List.map unquote_name names, List.map unquote_nat rargs) in + let la = Array.of_list in + evm, Constr.mkCoFix (unquote_nat i, (la names, la types, la bodies)) + | Coq_tProj (proj,t) -> + let (ind, _, narg) = unquote_proj proj in (* todo: is narg the correct projection? *) + let ind' = unquote_inductive ind in + let projs = Recordops.lookup_projections ind' in + let evm, t = aux evm t in + (match List.nth projs (unquote_nat narg) with + | Some p -> evm, Constr.mkProj (Names.Projection.make p false, t) + | None -> bad_term trm) + | _ -> not_supported_verb trm "big_case" + + +let to_constr (t : Ast0.term) : Constr.t = + snd (to_constr_ev Evd.empty t) + + let rec interp_tm (t : 'a coq_TM) : 'a tm = match t with | Coq_tmReturn x -> tmReturn x From a682153507fdff73dce2958c741c8e11591f6717 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 13:18:56 -0400 Subject: [PATCH 07/71] fix up an annotation. --- template-coq/gen-src/run_extractable.ml | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/template-coq/gen-src/run_extractable.ml b/template-coq/gen-src/run_extractable.ml index 3607cbb81..50fd0b5cc 100644 --- a/template-coq/gen-src/run_extractable.ml +++ b/template-coq/gen-src/run_extractable.ml @@ -22,7 +22,7 @@ let to_ident : char list -> Names.Id.t = let of_ident : Names.Id.t -> char list = failwith "of_ident" -let of_global_reference (t : global_reference) : BasicAst.global_reference = +let of_global_reference (t : Plugin_core.global_reference) : BasicAst.global_reference = failwith "of_global_reference" let to_qualid (c : char list) : Libnames.qualid = @@ -46,7 +46,7 @@ let to_mie : _ -> Plugin_core.mutual_inductive_entry = let of_constant_entry : _ -> Ast0.constant_entry = failwith "of_constant_entry" -(* what about the overflow? +(* what about the overflow? efficiency? extract to bigint using Coq directives and convert to int here? *) let of_nat (t : Datatypes.nat) : int = failwith "of_constr" @@ -58,7 +58,7 @@ let of_cast_kind (ck: BasicAst.cast_kind) : Constr.cast_kind = | Cast -> Constr.DEFAULTcast | RevertCast -> Constr.REVERTcast - + (* todo(gmm): determine what of these already exist. *) let rec to_constr_ev (evm : Evd.evar_map) (t : Ast0.term) : Evd.evar_map * Constr.t = match t with @@ -135,11 +135,10 @@ let rec to_constr_ev (evm : Evd.evar_map) (t : Ast0.term) : Evd.evar_map * Const | None -> bad_term trm) | _ -> not_supported_verb trm "big_case" - let to_constr (t : Ast0.term) : Constr.t = snd (to_constr_ev Evd.empty t) - + let rec interp_tm (t : 'a coq_TM) : 'a tm = match t with | Coq_tmReturn x -> tmReturn x From 622b96cf77829f902bd7d0ab626c14efd38a7f6a Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 14:52:07 -0400 Subject: [PATCH 08/71] looking at functorizing denote --- template-coq/_CoqProject | 1 + template-coq/gen-src/run_extractable.ml | 3 +- template-coq/src/constr_quoter.ml | 1 + template-coq/src/denote.ml | 1 + template-coq/src/quoted.ml | 90 ++++++++++++++++++++++++ template-coq/src/quoter.ml | 93 ++----------------------- template-coq/src/template_coq.mlpack | 1 + 7 files changed, 101 insertions(+), 89 deletions(-) create mode 100644 template-coq/src/quoted.ml diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index 35998b2c4..767303033 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -4,6 +4,7 @@ # the MetaCoq plugin src/tm_util.ml +src/quoted.ml # src/quoter.mli src/quoter.ml # src/constr_quoter.mli diff --git a/template-coq/gen-src/run_extractable.ml b/template-coq/gen-src/run_extractable.ml index 50fd0b5cc..c5b386ce4 100644 --- a/template-coq/gen-src/run_extractable.ml +++ b/template-coq/gen-src/run_extractable.ml @@ -61,6 +61,7 @@ let of_cast_kind (ck: BasicAst.cast_kind) : Constr.cast_kind = (* todo(gmm): determine what of these already exist. *) let rec to_constr_ev (evm : Evd.evar_map) (t : Ast0.term) : Evd.evar_map * Constr.t = + failwith "to_constr_ev" (* match t with | Coq_tRel x -> evm, Constr.mkRel (of_nat x + 1) | Coq_tVar x -> evm, Constr.mkVar (to_ident x) @@ -134,7 +135,7 @@ let rec to_constr_ev (evm : Evd.evar_map) (t : Ast0.term) : Evd.evar_map * Const | Some p -> evm, Constr.mkProj (Names.Projection.make p false, t) | None -> bad_term trm) | _ -> not_supported_verb trm "big_case" - +*) let to_constr (t : Ast0.term) : Constr.t = snd (to_constr_ev Evd.empty t) diff --git a/template-coq/src/constr_quoter.ml b/template-coq/src/constr_quoter.ml index cb01a1f07..4560062d6 100644 --- a/template-coq/src/constr_quoter.ml +++ b/template-coq/src/constr_quoter.ml @@ -3,6 +3,7 @@ open Entries open Names open Pp +open Quoted open Quoter let contrib_name = "template-coq" diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index bfe6d1650..5bfc32f6b 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -3,6 +3,7 @@ open Names open Pp (* this adds the ++ to the current scope *) open Tm_util +open Quoted open Quoter open Constr_quoter open TemplateCoqQuoter diff --git a/template-coq/src/quoted.ml b/template-coq/src/quoted.ml new file mode 100644 index 000000000..7b62fc905 --- /dev/null +++ b/template-coq/src/quoted.ml @@ -0,0 +1,90 @@ +type ('a,'b) sum = + Left of 'a | Right of 'b + +type ('term, 'name, 'nat) adef = { adname : 'name; adtype : 'term; adbody : 'term; rarg : 'nat } + +type ('term, 'name, 'nat) amfixpoint = ('term, 'name, 'nat) adef list + +type ('term, 'nat, 'ident, 'name, 'quoted_sort, 'cast_kind, 'kername, 'inductive, 'universe_instance, 'projection) structure_of_term = + | ACoq_tRel of 'nat + | ACoq_tVar of 'ident + | ACoq_tMeta of 'nat + | ACoq_tEvar of 'nat * 'term list + | ACoq_tSort of 'quoted_sort + | ACoq_tCast of 'term * 'cast_kind * 'term + | ACoq_tProd of 'name * 'term * 'term + | ACoq_tLambda of 'name * 'term * 'term + | ACoq_tLetIn of 'name * 'term * 'term * 'term + | ACoq_tApp of 'term * 'term list + | ACoq_tConst of 'kername * 'universe_instance + | ACoq_tInd of 'inductive * 'universe_instance + | ACoq_tConstruct of 'inductive * 'nat * 'universe_instance + | ACoq_tCase of ('inductive * 'nat) * 'term * 'term * ('nat * 'term) list + | ACoq_tProj of 'projection * 'term + | ACoq_tFix of ('term, 'name, 'nat) amfixpoint * 'nat + | ACoq_tCoFix of ('term, 'name, 'nat) amfixpoint * 'nat + +module type Quoted = +sig + type t (* this represented quoted Gallina terms *) + + type quoted_ident + type quoted_int + type quoted_bool + type quoted_name + type quoted_sort + type quoted_cast_kind + type quoted_kernel_name + type quoted_inductive + type quoted_proj + type quoted_global_reference + + type quoted_sort_family + type quoted_constraint_type + type quoted_univ_constraint + type quoted_univ_instance + type quoted_univ_constraints + type quoted_univ_context + type quoted_inductive_universes + + type quoted_mind_params + type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list + type quoted_definition_entry = t * t option * quoted_univ_context + type quoted_mind_entry + type quoted_mind_finiteness + type quoted_entry + + (* Local contexts *) + type quoted_context_decl + type quoted_context + + type quoted_one_inductive_body + type quoted_mutual_inductive_body + type quoted_constant_body + type quoted_global_decl + type quoted_global_declarations + type quoted_program (* the return type of quote_recursively *) + + val mkRel : quoted_int -> t + val mkVar : quoted_ident -> t + val mkMeta : quoted_int -> t + val mkEvar : quoted_int -> t array -> t + val mkSort : quoted_sort -> t + val mkCast : t -> quoted_cast_kind -> t -> t + val mkProd : quoted_name -> t -> t -> t + val mkLambda : quoted_name -> t -> t -> t + val mkLetIn : quoted_name -> t -> t -> t -> t + val mkApp : t -> t array -> t + val mkConst : quoted_kernel_name -> quoted_univ_instance -> t + val mkInd : quoted_inductive -> quoted_univ_instance -> t + val mkConstruct : quoted_inductive * quoted_int -> quoted_univ_instance -> t + val mkCase : (quoted_inductive * quoted_int) -> quoted_int list -> t -> t -> + t list -> t + val mkProj : quoted_proj -> t -> t + val mkFix : (quoted_int array * quoted_int) * (quoted_name array * t array * t array) -> t + val mkCoFix : quoted_int * (quoted_name array * t array * t array) -> t + + val mkName : quoted_ident -> quoted_name + val mkAnon : quoted_name + +end diff --git a/template-coq/src/quoter.ml b/template-coq/src/quoter.ml index 03746fbcf..be517dc84 100644 --- a/template-coq/src/quoter.ml +++ b/template-coq/src/quoter.ml @@ -3,6 +3,8 @@ open Entries open Declarations open Pp +open Quoted + let cast_prop = ref (false) (* whether Set Template Cast Propositions is on, as needed for erasure in Certicoq *) @@ -72,72 +74,9 @@ let split_name s : (Names.DirPath.t * Names.Id.t) = let dp = (DirPath.make (List.map Id.of_string rst)) in (dp, Names.Id.of_string nm) | [] -> raise (Failure "Empty name cannot be quoted") - -type ('a,'b) sum = - Left of 'a | Right of 'b - -type ('term, 'name, 'nat) adef = { adname : 'name; adtype : 'term; adbody : 'term; rarg : 'nat } - -type ('term, 'name, 'nat) amfixpoint = ('term, 'name, 'nat) adef list - -type ('term, 'nat, 'ident, 'name, 'quoted_sort, 'cast_kind, 'kername, 'inductive, 'universe_instance, 'projection) structure_of_term = - | ACoq_tRel of 'nat - | ACoq_tVar of 'ident - | ACoq_tMeta of 'nat - | ACoq_tEvar of 'nat * 'term list - | ACoq_tSort of 'quoted_sort - | ACoq_tCast of 'term * 'cast_kind * 'term - | ACoq_tProd of 'name * 'term * 'term - | ACoq_tLambda of 'name * 'term * 'term - | ACoq_tLetIn of 'name * 'term * 'term * 'term - | ACoq_tApp of 'term * 'term list - | ACoq_tConst of 'kername * 'universe_instance - | ACoq_tInd of 'inductive * 'universe_instance - | ACoq_tConstruct of 'inductive * 'nat * 'universe_instance - | ACoq_tCase of ('inductive * 'nat) * 'term * 'term * ('nat * 'term) list - | ACoq_tProj of 'projection * 'term - | ACoq_tFix of ('term, 'name, 'nat) amfixpoint * 'nat - | ACoq_tCoFix of ('term, 'name, 'nat) amfixpoint * 'nat - -module type Quoter = sig - type t - - type quoted_ident - type quoted_int - type quoted_bool - type quoted_name - type quoted_sort - type quoted_cast_kind - type quoted_kernel_name - type quoted_inductive - type quoted_proj - type quoted_global_reference - - type quoted_sort_family - type quoted_constraint_type - type quoted_univ_constraint - type quoted_univ_instance - type quoted_univ_constraints - type quoted_univ_context - type quoted_inductive_universes - - type quoted_mind_params - type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list - type quoted_definition_entry = t * t option * quoted_univ_context - type quoted_mind_entry - type quoted_mind_finiteness - type quoted_entry - - (* Local contexts *) - type quoted_context_decl - type quoted_context - - type quoted_one_inductive_body - type quoted_mutual_inductive_body - type quoted_constant_body - type quoted_global_decl - type quoted_global_declarations - type quoted_program (* the return type of quote_recursively *) +module type Quoter = +sig + include Quoted val quote_ident : Id.t -> quoted_ident val quote_name : Name.t -> quoted_name @@ -168,28 +107,6 @@ module type Quoter = sig val quote_entry : (quoted_definition_entry, quoted_mind_entry) sum option -> quoted_entry - val mkName : quoted_ident -> quoted_name - val mkAnon : quoted_name - - val mkRel : quoted_int -> t - val mkVar : quoted_ident -> t - val mkMeta : quoted_int -> t - val mkEvar : quoted_int -> t array -> t - val mkSort : quoted_sort -> t - val mkCast : t -> quoted_cast_kind -> t -> t - val mkProd : quoted_name -> t -> t -> t - val mkLambda : quoted_name -> t -> t -> t - val mkLetIn : quoted_name -> t -> t -> t -> t - val mkApp : t -> t array -> t - val mkConst : quoted_kernel_name -> quoted_univ_instance -> t - val mkInd : quoted_inductive -> quoted_univ_instance -> t - val mkConstruct : quoted_inductive * quoted_int -> quoted_univ_instance -> t - val mkCase : (quoted_inductive * quoted_int) -> quoted_int list -> t -> t -> - t list -> t - val mkProj : quoted_proj -> t -> t - val mkFix : (quoted_int array * quoted_int) * (quoted_name array * t array * t array) -> t - val mkCoFix : quoted_int * (quoted_name array * t array * t array) -> t - val quote_context_decl : quoted_name -> t option -> t -> quoted_context_decl val quote_context : quoted_context_decl list -> quoted_context diff --git a/template-coq/src/template_coq.mlpack b/template-coq/src/template_coq.mlpack index 2fa42b395..c23ab63ea 100644 --- a/template-coq/src/template_coq.mlpack +++ b/template-coq/src/template_coq.mlpack @@ -1,4 +1,5 @@ Tm_util +Quoted Quoter Constr_quoter Template_monad From 94d5e8ffd7c23cb325aea7ad69fe52170a9e74bc Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 15:13:43 -0400 Subject: [PATCH 09/71] fixing up the _CoqProject. --- template-coq/_CoqProject | 1 + 1 file changed, 1 insertion(+) diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index 767303033..7bedee538 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -9,6 +9,7 @@ src/quoted.ml src/quoter.ml # src/constr_quoter.mli src/constr_quoter.ml +src/denoter.ml src/denote.mli src/denote.ml # src/g_template_coq.mli From 496e99a97820602b8ec02a354003bfaeb5d688ad Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 15:14:34 -0400 Subject: [PATCH 10/71] just a start --- template-coq/src/denote.ml | 116 +++++-------------------------------- 1 file changed, 14 insertions(+), 102 deletions(-) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index 5bfc32f6b..e54706228 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -5,13 +5,19 @@ open Pp (* this adds the ++ to the current scope *) open Tm_util open Quoted open Quoter +open Denoter open Constr_quoter open TemplateCoqQuoter + + (* todo: the recursive call is uneeded provided we call it on well formed terms *) let print_term (u: t) : Pp.t = pr_constr u +module Denote (D : Denoter) = +struct + let unquote_pair trm = let (h,args) = app_full trm [] in if Constr.equal h c_pair then @@ -33,102 +39,6 @@ let rec unquote_list trm = not_supported_verb trm "unquote_list" -let inspect_term (t:Constr.t) : (Constr.t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term = - let (h,args) = app_full t [] in - if Constr.equal h tRel then - match args with - x :: _ -> ACoq_tRel x - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tVar then - match args with - x :: _ -> ACoq_tVar x - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tMeta then - match args with - x :: _ -> ACoq_tMeta x - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tSort then - match args with - x :: _ -> ACoq_tSort x - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tCast then - match args with - x :: y :: z :: _ -> ACoq_tCast (x, y, z) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tProd then - match args with - n :: t :: b :: _ -> ACoq_tProd (n,t,b) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tLambda then - match args with - n :: t :: b :: _ -> ACoq_tLambda (n,t,b) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tLetIn then - match args with - n :: e :: t :: b :: _ -> ACoq_tLetIn (n,e,t,b) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tApp then - match args with - f::xs::_ -> ACoq_tApp (f, unquote_list xs) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tConst then - match args with - s::u::_ -> ACoq_tConst (s, u) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tInd then - match args with - i::u::_ -> ACoq_tInd (i,u) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tConstructor then - match args with - i::idx::u::_ -> ACoq_tConstruct (i,idx,u) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure: constructor case")) - else if Constr.equal h tCase then - match args with - info::ty::d::brs::_ -> ACoq_tCase (unquote_pair info, ty, d, List.map unquote_pair (unquote_list brs)) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tFix then - match args with - bds::i::_ -> - let unquoteFbd b = - let (_,args) = app_full b [] in - match args with - | _(*type*) :: na :: ty :: body :: rarg :: [] -> - { adtype = ty; - adname = na; - adbody = body; - rarg - } - |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") - in - let lbd = List.map unquoteFbd (unquote_list bds) in - ACoq_tFix (lbd, i) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tCoFix then - match args with - bds::i::_ -> - let unquoteFbd b = - let (_,args) = app_full b [] in - match args with - | _(*type*) :: na :: ty :: body :: rarg :: [] -> - { adtype = ty; - adname = na; - adbody = body; - rarg - } - |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") - in - let lbd = List.map unquoteFbd (unquote_list bds) in - ACoq_tCoFix (lbd, i) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tProj then - match args with - proj::t::_ -> ACoq_tProj (proj, t) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - - else - CErrors.user_err (str"inspect_term: cannot recognize " ++ print_term t ++ str" (maybe you forgot to reduce it?)") - (* Unquote Coq nat to OCaml int *) let rec unquote_nat trm = let (h,args) = app_full trm [] in @@ -339,16 +249,16 @@ let unquote_inductive trm = (* TODO: replace app_full by this abstract version?*) -let rec app_full_abs (trm: Constr.t) (acc: Constr.t list) = - match inspect_term trm with +let rec app_full_abs (trm: D.t) (acc: D.t list) = + match D.inspect_term trm with ACoq_tApp (f, xs) -> app_full_abs f (xs @ acc) | _ -> (trm, acc) -let denote_term evm (trm: Constr.t) : Evd.evar_map * Constr.t = - let rec aux evm (trm: Constr.t) : _ * Constr.t = - debug (fun () -> Pp.(str "denote_term" ++ spc () ++ pr_constr trm)) ; - match inspect_term trm with +let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = + let rec aux evm (trm: D.t) : _ * Constr.t = +(* debug (fun () -> Pp.(str "denote_term" ++ spc () ++ pr_constr trm)) ; *) + match D.inspect_term trm with | ACoq_tRel x -> evm, Constr.mkRel (unquote_nat x + 1) | ACoq_tVar x -> evm, Constr.mkVar (unquote_ident x) | ACoq_tSort x -> let evm, u = unquote_universe evm x in evm, Constr.mkType u @@ -421,3 +331,5 @@ let denote_term evm (trm: Constr.t) : Evd.evar_map * Constr.t = | None -> bad_term trm) | _ -> not_supported_verb trm "big_case" in aux evm trm + +end From a755b912df7bf1d7489eb9271f7363ed9eb04c01 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 15:27:50 -0400 Subject: [PATCH 11/71] missing file. --- template-coq/src/denoter.ml | 84 +++++++++++++++++++++++++++++++++++++ 1 file changed, 84 insertions(+) create mode 100644 template-coq/src/denoter.ml diff --git a/template-coq/src/denoter.ml b/template-coq/src/denoter.ml new file mode 100644 index 000000000..163d1075d --- /dev/null +++ b/template-coq/src/denoter.ml @@ -0,0 +1,84 @@ +open Univ +open Names +open Quoted + +module type Denoter = +sig + include Quoted + + val unquote_ident : quoted_ident -> Id.t + val unquote_name : quoted_name -> Name.t + val unquote_int : quoted_int -> int + val unquote_bool : quoted_bool -> bool + (* val unquote_sort : quoted_sort -> Sorts.t *) + (* val unquote_sort_family : quoted_sort_family -> Sorts.family *) + val unquote_cast_kind : quoted_cast_kind -> Constr.cast_kind + val unquote_kn : quoted_kernel_name -> Libnames.qualid + val unquote_inductive : quoted_inductive -> Names.inductive + (*val unquote_univ_instance : quoted_univ_instance -> Univ.Instance.t *) + val unquote_proj : quoted_proj -> (quoted_inductive * quoted_int * quoted_int) + val unquote_universe : Evd.evar_map -> quoted_sort -> Evd.evar_map * Univ.Universe.t + val print_term : t -> Pp.std_ppcmds + + (* val representsIndConstuctor : quoted_inductive -> Term.constr -> bool *) + val inspect_term : t -> (t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term + +(* + val quote_ident : quoted_ident -> Id.t + val quote_name : quoted_name -> Name.t + val quote_int : quoted_int -> int + val quote_bool : quoted_bool -> bool + val quote_sort : quoted_sort -> Sorts.t + val quote_sort_family : quoted_sort_family -> Sorts.family + val quote_cast_kind : quoted_cast_kind -> Constr.cast_kind + val quote_kn : quoted_kernel_name -> KerName.t + val quote_inductive : quoted_inductive -> quoted_kernel_name * quoted_int + val quote_proj : quoted_proj -> (quoted_inductive * quoted_int * quoted_int) + + val quote_constraint_type : quoted_constraint_type -> Univ.constraint_type + val quote_univ_constraint : quoted_univ_constraint -> Univ.univ_constraint + val quote_univ_instance : quoted_univ_instance -> Univ.Instance.t + val quote_univ_constraints : quoted_univ_constraints -> Univ.Constraint.t + val quote_univ_context : quoted_univ_context -> Univ.UContext.t + val quote_cumulative_univ_context : quoted_univ_context -> Univ.CumulativityInfo.t + val quote_abstract_univ_context : quoted_univ_context -> Univ.AUContext.t + val quote_inductive_universes : quoted_inductive_universes -> Entries.inductive_universes + + val quote_mind_params : quoted_mind_params -> (quoted_ident * (t,t) sum) list + val quote_mind_finiteness : quoted_mind_finiteness -> Declarations.recursivity_kind + val quote_mutual_inductive_entry : + quoted_mind_entry -> + (quoted_mind_finiteness * quoted_mind_params * quoted_ind_entry list * + quoted_inductive_universes) + + val quote_entry : quoted_entry -> (quoted_definition_entry, quoted_mind_entry) sum option + + val quote_context_decl : quoted_context_decl -> (quoted_name * t option * t) + val quote_context : quoted_context -> quoted_context_decl list + + val mk_one_inductive_body + : quoted_one_inductive_body -> + (quoted_ident * t (* ind type *) * quoted_sort_family list + * (quoted_ident * t (* constr type *) * quoted_int) list + * (quoted_ident * t (* projection type *)) list) + + val mk_mutual_inductive_body : + quoted_mutual_inductive_body -> + ( quoted_int (* number of params (no lets) *) + * quoted_context (* parameters context with lets *) + * quoted_one_inductive_body list + * quoted_univ_context ) + + val mk_constant_body : quoted_constant_body -> (quoted_univ_context * t (* type *) * t option (* body *)) + + val mk_inductive_decl : quoted_global_decl -> (quoted_kernel_name * quoted_mutual_inductive_body) + + val mk_constant_decl : quoted_global_decl -> (quoted_kernel_name * quoted_constant_body) + + val empty_global_declartions : quoted_global_declarations + val add_global_decl : quoted_global_declarations -> (quoted_global_decl * quoted_global_declarations) + + val mk_program : quoted_program -> (quoted_global_declarations * t) +*) + +end From 7f48a3fa63e8fd66bd80b183840e8808e26c39a0 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 15:50:49 -0400 Subject: [PATCH 12/71] hacky rules to build the plugin. --- template-coq/Makefile | 11 +++- template-coq/_PluginProject | 11 +++- template-coq/src/denote.ml | 116 +++++++++++++++++++++++++++++++----- 3 files changed, 120 insertions(+), 18 deletions(-) diff --git a/template-coq/Makefile b/template-coq/Makefile index 97a1a2ce5..afd16c8f6 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -1,9 +1,10 @@ +TOCOPY=tm_util quoted quoter constr_quoter template_monad denoter denote plugin_core all: coq plugin gen-src/Extraction.vo: coq gen-src/Extraction.v $(COQPATH)coqc -I src -Q theories Template gen-src/Extraction.v -plugin: coq Makefile.plugin +plugin: coq Makefile.plugin gen-src/Extraction.vo $(MAKE) -f Makefile.plugin coq: Makefile.coq @@ -27,8 +28,14 @@ mrproper: clean Makefile.coq: _CoqProject coq_makefile -f _CoqProject -o Makefile.coq -Makefile.plugin: coq _PluginProject +Makefile.plugin: coq _PluginProject $(TOCOPY:%=gen-src/%.ml) $(COQPATH)coq_makefile -f _PluginProject -o Makefile.plugin .merlin: Makefile.coq $(MAKE) -f Makefile.coq .merlin + +gen-src/%.ml: src/%.ml + ln -s ../$< $@ + +clean-plugin: + (cd gen-src; rm -rf *.d *.c* $(TOCOPY:%=%.ml) ) diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 04921d9f9..89835573b 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -1,6 +1,4 @@ --I src -I gen-src --Q theories Template gen-src/Ascii.ml gen-src/Ascii.mli @@ -83,5 +81,14 @@ gen-src/utils.mli gen-src/Wf.ml gen-src/Wf.mli +gen-src/tm_util.ml +gen-src/quoted.ml +gen-src/quoter.ml +gen-src/constr_quoter.ml +gen-src/template_monad.ml +gen-src/denoter.ml +gen-src/denote.ml +gen-src/plugin_core.ml + gen-src/run_extractable.ml gen-src/meta_coq_plugin.mlpack \ No newline at end of file diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index e54706228..5bfc32f6b 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -5,19 +5,13 @@ open Pp (* this adds the ++ to the current scope *) open Tm_util open Quoted open Quoter -open Denoter open Constr_quoter open TemplateCoqQuoter - - (* todo: the recursive call is uneeded provided we call it on well formed terms *) let print_term (u: t) : Pp.t = pr_constr u -module Denote (D : Denoter) = -struct - let unquote_pair trm = let (h,args) = app_full trm [] in if Constr.equal h c_pair then @@ -39,6 +33,102 @@ let rec unquote_list trm = not_supported_verb trm "unquote_list" +let inspect_term (t:Constr.t) : (Constr.t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term = + let (h,args) = app_full t [] in + if Constr.equal h tRel then + match args with + x :: _ -> ACoq_tRel x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tVar then + match args with + x :: _ -> ACoq_tVar x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tMeta then + match args with + x :: _ -> ACoq_tMeta x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tSort then + match args with + x :: _ -> ACoq_tSort x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tCast then + match args with + x :: y :: z :: _ -> ACoq_tCast (x, y, z) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tProd then + match args with + n :: t :: b :: _ -> ACoq_tProd (n,t,b) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tLambda then + match args with + n :: t :: b :: _ -> ACoq_tLambda (n,t,b) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tLetIn then + match args with + n :: e :: t :: b :: _ -> ACoq_tLetIn (n,e,t,b) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tApp then + match args with + f::xs::_ -> ACoq_tApp (f, unquote_list xs) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tConst then + match args with + s::u::_ -> ACoq_tConst (s, u) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tInd then + match args with + i::u::_ -> ACoq_tInd (i,u) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tConstructor then + match args with + i::idx::u::_ -> ACoq_tConstruct (i,idx,u) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure: constructor case")) + else if Constr.equal h tCase then + match args with + info::ty::d::brs::_ -> ACoq_tCase (unquote_pair info, ty, d, List.map unquote_pair (unquote_list brs)) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tFix then + match args with + bds::i::_ -> + let unquoteFbd b = + let (_,args) = app_full b [] in + match args with + | _(*type*) :: na :: ty :: body :: rarg :: [] -> + { adtype = ty; + adname = na; + adbody = body; + rarg + } + |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") + in + let lbd = List.map unquoteFbd (unquote_list bds) in + ACoq_tFix (lbd, i) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tCoFix then + match args with + bds::i::_ -> + let unquoteFbd b = + let (_,args) = app_full b [] in + match args with + | _(*type*) :: na :: ty :: body :: rarg :: [] -> + { adtype = ty; + adname = na; + adbody = body; + rarg + } + |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") + in + let lbd = List.map unquoteFbd (unquote_list bds) in + ACoq_tCoFix (lbd, i) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tProj then + match args with + proj::t::_ -> ACoq_tProj (proj, t) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + + else + CErrors.user_err (str"inspect_term: cannot recognize " ++ print_term t ++ str" (maybe you forgot to reduce it?)") + (* Unquote Coq nat to OCaml int *) let rec unquote_nat trm = let (h,args) = app_full trm [] in @@ -249,16 +339,16 @@ let unquote_inductive trm = (* TODO: replace app_full by this abstract version?*) -let rec app_full_abs (trm: D.t) (acc: D.t list) = - match D.inspect_term trm with +let rec app_full_abs (trm: Constr.t) (acc: Constr.t list) = + match inspect_term trm with ACoq_tApp (f, xs) -> app_full_abs f (xs @ acc) | _ -> (trm, acc) -let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = - let rec aux evm (trm: D.t) : _ * Constr.t = -(* debug (fun () -> Pp.(str "denote_term" ++ spc () ++ pr_constr trm)) ; *) - match D.inspect_term trm with +let denote_term evm (trm: Constr.t) : Evd.evar_map * Constr.t = + let rec aux evm (trm: Constr.t) : _ * Constr.t = + debug (fun () -> Pp.(str "denote_term" ++ spc () ++ pr_constr trm)) ; + match inspect_term trm with | ACoq_tRel x -> evm, Constr.mkRel (unquote_nat x + 1) | ACoq_tVar x -> evm, Constr.mkVar (unquote_ident x) | ACoq_tSort x -> let evm, u = unquote_universe evm x in evm, Constr.mkType u @@ -331,5 +421,3 @@ let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = | None -> bad_term trm) | _ -> not_supported_verb trm "big_case" in aux evm trm - -end From c2c0315a0c227f85fc5b12538494af05866aadc0 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Mon, 8 Apr 2019 13:04:33 -0700 Subject: [PATCH 13/71] denote_term function now has no errors. there is another error: Error: The implementation src/denote.ml does not match the interface src/denote.cmi: The value `denote_term' is required but not provided The value `map_evm' is required but not provided The value `unquote_universe_instance' is required but not provided The value `unquote_level' is required but not provided The value `unquote_string' is required but not provided The value `unquote_ident' is required but not provided The value `unquote_bool' is required but not provided The value `unquote_list' is required but not provided The value `unquote_pair' is required but not provided Makefile.coq:604: recipe for target 'src/denote.cmx' failed --- template-coq/src/denote.ml | 50 ++++++++++++++++++------------------- template-coq/src/denoter.ml | 2 +- 2 files changed, 25 insertions(+), 27 deletions(-) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index e54706228..32b3943b7 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -10,7 +10,6 @@ open Constr_quoter open TemplateCoqQuoter - (* todo: the recursive call is uneeded provided we call it on well formed terms *) let print_term (u: t) : Pp.t = pr_constr u @@ -254,33 +253,32 @@ let rec app_full_abs (trm: D.t) (acc: D.t list) = ACoq_tApp (f, xs) -> app_full_abs f (xs @ acc) | _ -> (trm, acc) - let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = let rec aux evm (trm: D.t) : _ * Constr.t = (* debug (fun () -> Pp.(str "denote_term" ++ spc () ++ pr_constr trm)) ; *) match D.inspect_term trm with - | ACoq_tRel x -> evm, Constr.mkRel (unquote_nat x + 1) - | ACoq_tVar x -> evm, Constr.mkVar (unquote_ident x) - | ACoq_tSort x -> let evm, u = unquote_universe evm x in evm, Constr.mkType u + | ACoq_tRel x -> evm, Constr.mkRel (D.unquote_int x + 1) + | ACoq_tVar x -> evm, Constr.mkVar (D.unquote_ident x) + | ACoq_tSort x -> let evm, u = D.unquote_universe evm x in evm, Constr.mkType u | ACoq_tCast (t,c,ty) -> let evm, t = aux evm t in let evm, ty = aux evm ty in - evm, Constr.mkCast (t, unquote_cast_kind c, ty) + evm, Constr.mkCast (t, D.unquote_cast_kind c, ty) | ACoq_tProd (n,t,b) -> let evm, t = aux evm t in let evm, b = aux evm b in - evm, Constr.mkProd (unquote_name n, t, b) + evm, Constr.mkProd (D.unquote_name n, t, b) | ACoq_tLambda (n,t,b) -> let evm, t = aux evm t in let evm, b = aux evm b in - evm, Constr.mkLambda (unquote_name n, t, b) + evm, Constr.mkLambda (D.unquote_name n, t, b) | ACoq_tLetIn (n,e,t,b) -> let evm, e = aux evm e in let evm, t = aux evm t in let evm, b = aux evm b in - evm, Constr.mkLetIn (unquote_name n, e, t, b) + evm, Constr.mkLetIn (D.unquote_name n, e, t, b) | ACoq_tApp (f,xs) -> let evm, f = aux evm f in let evm, xs = map_evm aux evm xs in evm, Constr.mkApp (f, Array.of_list xs) | ACoq_tConst (s,u) -> - let s = unquote_kn s in - let evm, u = unquote_universe_instance evm u in + let s = D.unquote_kn s in + let evm, u = D.unquote_universe_instance evm u in (try match Nametab.locate s with | Globnames.ConstRef c -> evm, Constr.mkConstU (c, u) @@ -290,15 +288,15 @@ let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = with Not_found -> CErrors.user_err (str"Constant not found: " ++ Libnames.pr_qualid s)) | ACoq_tConstruct (i,idx,u) -> - let ind = unquote_inductive i in - let evm, u = unquote_universe_instance evm u in - evm, Constr.mkConstructU ((ind, unquote_nat idx + 1), u) + let ind = D.unquote_inductive i in + let evm, u = D.unquote_universe_instance evm u in + evm, Constr.mkConstructU ((ind, D.unquote_int idx + 1), u) | ACoq_tInd (i, u) -> - let i = unquote_inductive i in - let evm, u = unquote_universe_instance evm u in + let i = D.unquote_inductive i in + let evm, u = D.unquote_universe_instance evm u in evm, Constr.mkIndU (i, u) | ACoq_tCase ((i, _), ty, d, brs) -> - let ind = unquote_inductive i in + let ind = D.unquote_inductive i in let evm, ty = aux evm ty in let evm, d = aux evm d in let evm, brs = map_evm aux evm (List.map snd brs) in @@ -310,26 +308,26 @@ let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = List.map (fun p->p.rarg) lbd) in let evm, types = map_evm aux evm types in let evm, bodies = map_evm aux evm bodies in - let (names,rargs) = (List.map unquote_name names, List.map unquote_nat rargs) in + let (names,rargs) = (List.map D.unquote_name names, List.map D.unquote_int rargs) in let la = Array.of_list in - evm, Constr.mkFix ((la rargs,unquote_nat i), (la names, la types, la bodies)) + evm, Constr.mkFix ((la rargs, D.unquote_int i), (la names, la types, la bodies)) | ACoq_tCoFix (lbd, i) -> let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, List.map (fun p->p.rarg) lbd) in let evm, types = map_evm aux evm types in let evm, bodies = map_evm aux evm bodies in - let (names,rargs) = (List.map unquote_name names, List.map unquote_nat rargs) in + let (names,rargs) = (List.map D.unquote_name names, List.map D.unquote_int rargs) in let la = Array.of_list in - evm, Constr.mkCoFix (unquote_nat i, (la names, la types, la bodies)) + evm, Constr.mkCoFix (D.unquote_int i, (la names, la types, la bodies)) | ACoq_tProj (proj,t) -> - let (ind, _, narg) = unquote_proj proj in (* todo: is narg the correct projection? *) - let ind' = unquote_inductive ind in + let (ind, _, narg) = D.unquote_proj proj in (* todo: is narg the correct projection? *) + let ind' = D.unquote_inductive ind in let projs = Recordops.lookup_projections ind' in let evm, t = aux evm t in - (match List.nth projs (unquote_nat narg) with + (match List.nth projs (D.unquote_int narg) with | Some p -> evm, Constr.mkProj (Names.Projection.make p false, t) - | None -> bad_term trm) - | _ -> not_supported_verb trm "big_case" + | None -> (*bad_term trm *) failwith "tproj case of denote_term") + | _ -> failwith "big case of denote_term" in aux evm trm end diff --git a/template-coq/src/denoter.ml b/template-coq/src/denoter.ml index 163d1075d..33cd1674b 100644 --- a/template-coq/src/denoter.ml +++ b/template-coq/src/denoter.ml @@ -19,7 +19,7 @@ sig val unquote_proj : quoted_proj -> (quoted_inductive * quoted_int * quoted_int) val unquote_universe : Evd.evar_map -> quoted_sort -> Evd.evar_map * Univ.Universe.t val print_term : t -> Pp.std_ppcmds - + val unquote_universe_instance: Evd.evar_map -> quoted_univ_instance -> Evd.evar_map * Univ.Instance.t (* val representsIndConstuctor : quoted_inductive -> Term.constr -> bool *) val inspect_term : t -> (t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term From 89404333bc4ab654a6250ce8ec8cf1ade93927af Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Mon, 8 Apr 2019 13:19:15 -0700 Subject: [PATCH 14/71] fixed many compilation errors. 1 remains: File "src/denote.ml", line 1: Error: The implementation src/denote.ml does not match the interface src/denote.cmi: The value `denote_term' is required but not provided --- template-coq/src/denote.ml | 107 +++++++++++++++++++------------------ 1 file changed, 54 insertions(+), 53 deletions(-) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index f721f892b..762cde4b0 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -14,8 +14,7 @@ open TemplateCoqQuoter let print_term (u: t) : Pp.t = pr_constr u -module Denote (D : Denoter) = -struct +let strict_unquote_universe_mode = ref true let unquote_pair trm = let (h,args) = app_full trm [] in @@ -101,7 +100,6 @@ let unquote_cast_kind trm = else not_supported_verb trm "unquote_cast_kind" - let unquote_name trm = let (h,args) = app_full trm [] in if Constr.equal h nAnon then @@ -113,53 +111,31 @@ let unquote_name trm = else not_supported_verb trm "unquote_name" - -(* If strict unquote universe mode is on then fail when unquoting a non *) -(* declared universe / an empty list of level expressions. *) -(* Otherwise, add it / a fresh level the global environnment. *) - -let strict_unquote_universe_mode = ref true - -let _ = - let open Goptions in - declare_bool_option - { optdepr = false; - optname = "strict unquote universe mode"; - optkey = ["Strict"; "Unquote"; "Universe"; "Mode"]; - optread = (fun () -> !strict_unquote_universe_mode); - optwrite = (fun b -> strict_unquote_universe_mode := b) } - -let map_evm (f : 'a -> 'b -> 'a * 'c) (evm : 'a) (l : 'b list) : 'a * ('c list) = - let evm, res = List.fold_left (fun (evm, l) b -> let evm, c = f evm b in evm, c :: l) (evm, []) l in - evm, List.rev res - - - let get_level evm s = if CString.string_contains ~where:s ~what:"." then match List.rev (CString.split '.' s) with | [] -> CErrors.anomaly (str"Invalid universe name " ++ str s ++ str".") | n :: dp -> - let num = int_of_string n in - let dp = DirPath.make (List.map Id.of_string dp) in - let l = Univ.Level.make dp num in - try - let evm = Evd.add_global_univ evm l in - if !strict_unquote_universe_mode then - CErrors.user_err ~hdr:"unquote_level" (str ("Level "^s^" is not a declared level and you are in Strict Unquote Universe Mode.")) - else (Feedback.msg_info (str"Fresh universe " ++ Level.pr l ++ str" was added to the context."); - evm, l) - with - | UGraph.AlreadyDeclared -> evm, l + let num = int_of_string n in + let dp = DirPath.make (List.map Id.of_string dp) in + let l = Univ.Level.make dp num in + try + let evm = Evd.add_global_univ evm l in + if !strict_unquote_universe_mode then + CErrors.user_err ~hdr:"unquote_level" (str ("Level "^s^" is not a declared level and you are in Strict Unquote Universe Mode.")) + else (Feedback.msg_info (str"Fresh universe " ++ Level.pr l ++ str" was added to the context."); + evm, l) + with + | UGraph.AlreadyDeclared -> evm, l else try evm, Evd.universe_of_name evm (Id.of_string s) with Not_found -> - try - let univ, k = Nametab.locate_universe (Libnames.qualid_of_string s) in - evm, Univ.Level.make univ k - with Not_found -> - CErrors.user_err ~hdr:"unquote_level" (str ("Level "^s^" is not a declared level.")) + try + let univ, k = Nametab.locate_universe (Libnames.qualid_of_string s) in + evm, Univ.Level.make univ k + with Not_found -> + CErrors.user_err ~hdr:"unquote_level" (str ("Level "^s^" is not a declared level.")) @@ -178,7 +154,7 @@ let unquote_level evm trm (* of type level *) : Evd.evar_map * Univ.Level.t = else if Constr.equal h tLevel then match args with | s :: [] -> debug (fun () -> str "Unquoting level " ++ pr_constr trm); - get_level evm (unquote_string s) + get_level evm (unquote_string s) | _ -> bad_term_verb trm "unquote_level" else if Constr.equal h tLevelVar then match args with @@ -197,15 +173,19 @@ let unquote_universe evm trm (* of type universe *) = let levels = List.map unquote_pair (unquote_list trm) in match levels with | [] -> if !strict_unquote_universe_mode then - CErrors.user_err ~hdr:"unquote_universe" (str "It is not possible to unquote an empty universe in Strict Unquote Universe Mode.") - else - let evm, u = Evd.new_univ_variable (Evd.UnivFlexible false) evm in - Feedback.msg_info (str"Fresh universe " ++ Universe.pr u ++ str" was added to the context."); - evm, u + CErrors.user_err ~hdr:"unquote_universe" (str "It is not possible to unquote an empty universe in Strict Unquote Universe Mode.") + else + let evm, u = Evd.new_univ_variable (Evd.UnivFlexible false) evm in + Feedback.msg_info (str"Fresh universe " ++ Universe.pr u ++ str" was added to the context."); + evm, u | (l,b)::q -> List.fold_left (fun (evm,u) (l,b) -> let evm, u' = unquote_level_expr evm l b - in evm, Univ.Universe.sup u u') - (unquote_level_expr evm l b) q + in evm, Univ.Universe.sup u u') + (unquote_level_expr evm l b) q +let map_evm (f : 'a -> 'b -> 'a * 'c) (evm : 'a) (l : 'b list) : 'a * ('c list) = + let evm, res = List.fold_left (fun (evm, l) b -> let evm, c = f evm b in evm, c :: l) (evm, []) l in + evm, List.rev res + let unquote_universe_instance evm trm (* of type universe_instance *) = let l = unquote_list trm in let evm, l = map_evm unquote_level evm l in @@ -220,10 +200,10 @@ let unquote_proj (qp : quoted_proj) : (quoted_inductive * quoted_int * quoted_in let (h,args) = app_full qp [] in match args with | tyin::tynat::indpars::idx::[] -> - let (h',args') = app_full indpars [] in - (match args' with - | tyind :: tynat :: ind :: n :: [] -> (ind, n, idx) - | _ -> bad_term_verb qp "unquote_proj") + let (h',args') = app_full indpars [] in + (match args' with + | tyind :: tynat :: ind :: n :: [] -> (ind, n, idx) + | _ -> bad_term_verb qp "unquote_proj") | _ -> bad_term_verb qp "unquote_proj" let unquote_inductive trm = @@ -245,6 +225,27 @@ let unquote_inductive trm = else bad_term_verb trm "non-constructor" +module Denote (D : Denoter) = +struct + + + +(* If strict unquote universe mode is on then fail when unquoting a non *) +(* declared universe / an empty list of level expressions. *) +(* Otherwise, add it / a fresh level the global environnment. *) + + +let _ = + let open Goptions in + declare_bool_option + { optdepr = false; + optname = "strict unquote universe mode"; + optkey = ["Strict"; "Unquote"; "Universe"; "Mode"]; + optread = (fun () -> !strict_unquote_universe_mode); + optwrite = (fun b -> strict_unquote_universe_mode := b) } + + + (* TODO: replace app_full by this abstract version?*) let rec app_full_abs (trm: D.t) (acc: D.t list) = From d7d38b2b8b6cbc91e7b4c0ac593e95e8ec9d926a Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Mon, 8 Apr 2019 15:02:12 -0700 Subject: [PATCH 15/71] fixed the compiler error in denote_term. provided instance of Denoter for running live in Coq --- template-coq/src/denote.ml | 237 ++++++++++++++++++++++++++++++++++++ template-coq/src/denoter.ml | 58 --------- 2 files changed, 237 insertions(+), 58 deletions(-) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index 762cde4b0..33523ae24 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -225,6 +225,102 @@ let unquote_inductive trm = else bad_term_verb trm "non-constructor" +let inspect_term (t:Constr.t) : (Constr.t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term = + let (h,args) = app_full t [] in + if Constr.equal h tRel then + match args with + x :: _ -> ACoq_tRel x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tVar then + match args with + x :: _ -> ACoq_tVar x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tMeta then + match args with + x :: _ -> ACoq_tMeta x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tSort then + match args with + x :: _ -> ACoq_tSort x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tCast then + match args with + x :: y :: z :: _ -> ACoq_tCast (x, y, z) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tProd then + match args with + n :: t :: b :: _ -> ACoq_tProd (n,t,b) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tLambda then + match args with + n :: t :: b :: _ -> ACoq_tLambda (n,t,b) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tLetIn then + match args with + n :: e :: t :: b :: _ -> ACoq_tLetIn (n,e,t,b) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tApp then + match args with + f::xs::_ -> ACoq_tApp (f, unquote_list xs) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tConst then + match args with + s::u::_ -> ACoq_tConst (s, u) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tInd then + match args with + i::u::_ -> ACoq_tInd (i,u) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tConstructor then + match args with + i::idx::u::_ -> ACoq_tConstruct (i,idx,u) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure: constructor case")) + else if Constr.equal h tCase then + match args with + info::ty::d::brs::_ -> ACoq_tCase (unquote_pair info, ty, d, List.map unquote_pair (unquote_list brs)) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tFix then + match args with + bds::i::_ -> + let unquoteFbd b = + let (_,args) = app_full b [] in + match args with + | _(*type*) :: na :: ty :: body :: rarg :: [] -> + { adtype = ty; + adname = na; + adbody = body; + rarg + } + |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") + in + let lbd = List.map unquoteFbd (unquote_list bds) in + ACoq_tFix (lbd, i) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tCoFix then + match args with + bds::i::_ -> + let unquoteFbd b = + let (_,args) = app_full b [] in + match args with + | _(*type*) :: na :: ty :: body :: rarg :: [] -> + { adtype = ty; + adname = na; + adbody = body; + rarg + } + |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") + in + let lbd = List.map unquoteFbd (unquote_list bds) in + ACoq_tCoFix (lbd, i) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tProj then + match args with + proj::t::_ -> ACoq_tProj (proj, t) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + + else + CErrors.user_err (str"inspect_term: cannot recognize " ++ print_term t ++ str" (maybe you forgot to reduce it?)") + module Denote (D : Denoter) = struct @@ -331,3 +427,144 @@ let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = in aux evm trm end + +open Denoter +module CoqLiveDenoter = +struct + type t = Constr.t + + type quoted_ident = Constr.t (* of type Ast.ident *) + type quoted_int = Constr.t (* of type nat *) + type quoted_bool = Constr.t (* of type bool *) + type quoted_name = Constr.t (* of type Ast.name *) + type quoted_sort = Constr.t (* of type Ast.universe *) + type quoted_cast_kind = Constr.t (* of type Ast.cast_kind *) + type quoted_kernel_name = Constr.t (* of type Ast.kername *) + type quoted_inductive = Constr.t (* of type Ast.inductive *) + type quoted_proj = Constr.t (* of type Ast.projection *) + type quoted_global_reference = Constr.t (* of type Ast.global_reference *) + + type quoted_sort_family = Constr.t (* of type Ast.sort_family *) + type quoted_constraint_type = Constr.t (* of type univ.constraint_type *) + type quoted_univ_constraint = Constr.t (* of type univ.univ_constraint *) + type quoted_univ_constraints = Constr.t (* of type univ.constraints *) + type quoted_univ_instance = Constr.t (* of type univ.universe_instance *) + type quoted_univ_context = Constr.t (* of type univ.universe_context *) + type quoted_inductive_universes = Constr.t (* of type univ.universe_context *) + + type quoted_mind_params = Constr.t (* of type list (Ast.ident * list (ident * local_entry)local_entry) *) + type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list + type quoted_definition_entry = t * t option * quoted_univ_context + type quoted_mind_entry = Constr.t (* of type Ast.mutual_inductive_entry *) + type quoted_mind_finiteness = Constr.t (* of type Ast.mutual_inductive_entry ?? *) + type quoted_entry = Constr.t (* of type option (constant_entry + mutual_inductive_entry) *) + + type quoted_context_decl = Constr.t (* in Ast *) + type quoted_context = Constr.t (* in Ast *) + + type quoted_one_inductive_body = Constr.t (* of type Ast.one_inductive_body *) + type quoted_mutual_inductive_body = Constr.t (* of type Ast.mutual_inductive_body *) + type quoted_constant_body = Constr.t (* of type Ast.constant_body *) + type quoted_global_decl = Constr.t (* of type Ast.global_decl *) + type quoted_global_declarations = Constr.t (* of type Ast.global_declarations *) + type quoted_program = Constr.t (* of type Ast.program *) + + type quoted_reduction_strategy = Constr.t (* of type Ast.reductionStrategy *) + + let unquote_ident=unquote_ident + let unquote_name=unquote_name + let unquote_int=unquote_nat + let print_term=print_term + let inspect_term=inspect_term + let unquote_universe_instance=unquote_universe_instance + + let unquote_universe=unquote_universe + let unquote_proj=unquote_proj + let unquote_inductive=unquote_inductive + let unquote_kn=unquote_kn + let unquote_cast_kind=unquote_cast_kind + let unquote_bool=unquote_bool + + + + let mkAnon = nAnon + let mkName id = Constr.mkApp (nNamed, [| id |]) + let quote_kn kn = quote_string (KerName.to_string kn) + let mkRel i = Constr.mkApp (tRel, [| i |]) + let mkVar id = Constr.mkApp (tVar, [| id |]) + let mkMeta i = Constr.mkApp (tMeta, [| i |]) + let mkEvar n args = Constr.mkApp (tEvar, [| n; to_coq_list tTerm (Array.to_list args) |]) + let mkSort s = Constr.mkApp (tSort, [| s |]) + let mkCast c k t = Constr.mkApp (tCast, [| c ; k ; t |]) + let mkConst kn u = Constr.mkApp (tConst, [| kn ; u |]) + let mkProd na t b = + Constr.mkApp (tProd, [| na ; t ; b |]) + let mkLambda na t b = + Constr.mkApp (tLambda, [| na ; t ; b |]) + let mkApp f xs = + Constr.mkApp (tApp, [| f ; to_coq_list tTerm (Array.to_list xs) |]) + + let mkLetIn na t t' b = + Constr.mkApp (tLetIn, [| na ; t ; t' ; b |]) + + let rec seq f t = + if f < t then f :: seq (f + 1) t + else [] + + let mkFix ((a,b),(ns,ts,ds)) = + let mk_fun xs i = + Constr.mkApp (tmkdef, [| tTerm ; Array.get ns i ; + Array.get ts i ; Array.get ds i ; Array.get a i |]) :: xs + in + let defs = List.fold_left mk_fun [] (seq 0 (Array.length a)) in + let block = to_coq_list (Constr.mkApp (tdef, [| tTerm |])) (List.rev defs) in + Constr.mkApp (tFix, [| block ; b |]) + + let mkConstruct (ind, i) u = + Constr.mkApp (tConstructor, [| ind ; i ; u |]) + + let mkCoFix (a,(ns,ts,ds)) = + let mk_fun xs i = + Constr.mkApp (tmkdef, [| tTerm ; Array.get ns i ; + Array.get ts i ; Array.get ds i ; tO |]) :: xs + in + let defs = List.fold_left mk_fun [] (seq 0 (Array.length ns)) in + let block = to_coq_list (Constr.mkApp (tdef, [| tTerm |])) (List.rev defs) in + Constr.mkApp (tCoFix, [| block ; a |]) + + let mkInd i u = Constr.mkApp (tInd, [| i ; u |]) + + let mkCase (ind, npar) nargs p c brs = + let info = pair tIndTy tnat ind npar in + let branches = List.map2 (fun br nargs -> pair tnat tTerm nargs br) brs nargs in + let tl = prod tnat tTerm in + Constr.mkApp (tCase, [| info ; p ; c ; to_coq_list tl branches |]) + + let quote_proj ind pars args = + pair (prod tIndTy tnat) tnat (pair tIndTy tnat ind pars) args + + let mkProj kn t = + Constr.mkApp (tProj, [| kn; t |]) +end + +(* + + let unquote_bool : quoted_bool -> bool +(* val unquote_sort : quoted_sort -> Sorts.t *) +(* val unquote_sort_family : quoted_sort_family -> Sorts.family *) +val unquote_cast_kind : quoted_cast_kind -> Constr.cast_kind +val unquote_kn : quoted_kernel_name -> Libnames.qualid +val unquote_inductive : quoted_inductive -> Names.inductive +(*val unquote_univ_instance : quoted_univ_instance -> Univ.Instance.t *) +val unquote_proj : quoted_proj -> (quoted_inductive * quoted_int * quoted_int) +val unquote_universe : Evd.evar_map -> quoted_sort -> Evd.evar_map * Univ.Universe.t +val print_term : t -> Pp.std_ppcmds +val unquote_universe_instance: Evd.evar_map -> quoted_univ_instance -> Evd.evar_map * Univ.Instance.t +(* val representsIndConstuctor : quoted_inductive -> Term.constr -> bool *) +val inspect_term : t -> (t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term +*) + + +module CoqLiveDenote = Denote(CoqLiveDenoter) + +let denote_term=CoqLiveDenote.denote_term \ No newline at end of file diff --git a/template-coq/src/denoter.ml b/template-coq/src/denoter.ml index 33cd1674b..8227d543e 100644 --- a/template-coq/src/denoter.ml +++ b/template-coq/src/denoter.ml @@ -23,62 +23,4 @@ sig (* val representsIndConstuctor : quoted_inductive -> Term.constr -> bool *) val inspect_term : t -> (t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term -(* - val quote_ident : quoted_ident -> Id.t - val quote_name : quoted_name -> Name.t - val quote_int : quoted_int -> int - val quote_bool : quoted_bool -> bool - val quote_sort : quoted_sort -> Sorts.t - val quote_sort_family : quoted_sort_family -> Sorts.family - val quote_cast_kind : quoted_cast_kind -> Constr.cast_kind - val quote_kn : quoted_kernel_name -> KerName.t - val quote_inductive : quoted_inductive -> quoted_kernel_name * quoted_int - val quote_proj : quoted_proj -> (quoted_inductive * quoted_int * quoted_int) - - val quote_constraint_type : quoted_constraint_type -> Univ.constraint_type - val quote_univ_constraint : quoted_univ_constraint -> Univ.univ_constraint - val quote_univ_instance : quoted_univ_instance -> Univ.Instance.t - val quote_univ_constraints : quoted_univ_constraints -> Univ.Constraint.t - val quote_univ_context : quoted_univ_context -> Univ.UContext.t - val quote_cumulative_univ_context : quoted_univ_context -> Univ.CumulativityInfo.t - val quote_abstract_univ_context : quoted_univ_context -> Univ.AUContext.t - val quote_inductive_universes : quoted_inductive_universes -> Entries.inductive_universes - - val quote_mind_params : quoted_mind_params -> (quoted_ident * (t,t) sum) list - val quote_mind_finiteness : quoted_mind_finiteness -> Declarations.recursivity_kind - val quote_mutual_inductive_entry : - quoted_mind_entry -> - (quoted_mind_finiteness * quoted_mind_params * quoted_ind_entry list * - quoted_inductive_universes) - - val quote_entry : quoted_entry -> (quoted_definition_entry, quoted_mind_entry) sum option - - val quote_context_decl : quoted_context_decl -> (quoted_name * t option * t) - val quote_context : quoted_context -> quoted_context_decl list - - val mk_one_inductive_body - : quoted_one_inductive_body -> - (quoted_ident * t (* ind type *) * quoted_sort_family list - * (quoted_ident * t (* constr type *) * quoted_int) list - * (quoted_ident * t (* projection type *)) list) - - val mk_mutual_inductive_body : - quoted_mutual_inductive_body -> - ( quoted_int (* number of params (no lets) *) - * quoted_context (* parameters context with lets *) - * quoted_one_inductive_body list - * quoted_univ_context ) - - val mk_constant_body : quoted_constant_body -> (quoted_univ_context * t (* type *) * t option (* body *)) - - val mk_inductive_decl : quoted_global_decl -> (quoted_kernel_name * quoted_mutual_inductive_body) - - val mk_constant_decl : quoted_global_decl -> (quoted_kernel_name * quoted_constant_body) - - val empty_global_declartions : quoted_global_declarations - val add_global_decl : quoted_global_declarations -> (quoted_global_decl * quoted_global_declarations) - - val mk_program : quoted_program -> (quoted_global_declarations * t) -*) - end From be56a76aa6d38fefdf0ce92f5ad7ad591fb3d5ee Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Mon, 8 Apr 2019 15:16:04 -0700 Subject: [PATCH 16/71] reducde code duplication --- template-coq/src/denote.ml | 105 +++++++++++-------------------------- 1 file changed, 31 insertions(+), 74 deletions(-) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index 33523ae24..c733256f2 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -429,6 +429,7 @@ let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = end open Denoter +open Constr_quoter module CoqLiveDenoter = struct type t = Constr.t @@ -487,82 +488,38 @@ struct - let mkAnon = nAnon - let mkName id = Constr.mkApp (nNamed, [| id |]) - let quote_kn kn = quote_string (KerName.to_string kn) - let mkRel i = Constr.mkApp (tRel, [| i |]) - let mkVar id = Constr.mkApp (tVar, [| id |]) - let mkMeta i = Constr.mkApp (tMeta, [| i |]) - let mkEvar n args = Constr.mkApp (tEvar, [| n; to_coq_list tTerm (Array.to_list args) |]) - let mkSort s = Constr.mkApp (tSort, [| s |]) - let mkCast c k t = Constr.mkApp (tCast, [| c ; k ; t |]) - let mkConst kn u = Constr.mkApp (tConst, [| kn ; u |]) - let mkProd na t b = - Constr.mkApp (tProd, [| na ; t ; b |]) - let mkLambda na t b = - Constr.mkApp (tLambda, [| na ; t ; b |]) - let mkApp f xs = - Constr.mkApp (tApp, [| f ; to_coq_list tTerm (Array.to_list xs) |]) - - let mkLetIn na t t' b = - Constr.mkApp (tLetIn, [| na ; t ; t' ; b |]) - - let rec seq f t = - if f < t then f :: seq (f + 1) t - else [] - - let mkFix ((a,b),(ns,ts,ds)) = - let mk_fun xs i = - Constr.mkApp (tmkdef, [| tTerm ; Array.get ns i ; - Array.get ts i ; Array.get ds i ; Array.get a i |]) :: xs - in - let defs = List.fold_left mk_fun [] (seq 0 (Array.length a)) in - let block = to_coq_list (Constr.mkApp (tdef, [| tTerm |])) (List.rev defs) in - Constr.mkApp (tFix, [| block ; b |]) - - let mkConstruct (ind, i) u = - Constr.mkApp (tConstructor, [| ind ; i ; u |]) - - let mkCoFix (a,(ns,ts,ds)) = - let mk_fun xs i = - Constr.mkApp (tmkdef, [| tTerm ; Array.get ns i ; - Array.get ts i ; Array.get ds i ; tO |]) :: xs - in - let defs = List.fold_left mk_fun [] (seq 0 (Array.length ns)) in - let block = to_coq_list (Constr.mkApp (tdef, [| tTerm |])) (List.rev defs) in - Constr.mkApp (tCoFix, [| block ; a |]) - - let mkInd i u = Constr.mkApp (tInd, [| i ; u |]) - - let mkCase (ind, npar) nargs p c brs = - let info = pair tIndTy tnat ind npar in - let branches = List.map2 (fun br nargs -> pair tnat tTerm nargs br) brs nargs in - let tl = prod tnat tTerm in - Constr.mkApp (tCase, [| info ; p ; c ; to_coq_list tl branches |]) - - let quote_proj ind pars args = - pair (prod tIndTy tnat) tnat (pair tIndTy tnat ind pars) args - - let mkProj kn t = - Constr.mkApp (tProj, [| kn; t |]) + let mkAnon = mkAnon + let mkName = mkName + let quote_kn = quote_kn + let mkRel = mkRel + let mkVar = mkVar + let mkMeta = mkMeta + let mkEvar = mkEvar + let mkSort = mkSort + let mkCast = mkCast + let mkConst = mkConst + let mkProd = mkProd + + let mkLambda = mkLambda + let mkApp = mkApp + + let mkLetIn = mkLetIn + + let mkFix = mkFix + + let mkConstruct = mkConstruct + + let mkCoFix = mkCoFix + + let mkInd = mkInd + + let mkCase = mkCase + + let quote_proj = quote_proj + + let mkProj = mkProj end -(* - - let unquote_bool : quoted_bool -> bool -(* val unquote_sort : quoted_sort -> Sorts.t *) -(* val unquote_sort_family : quoted_sort_family -> Sorts.family *) -val unquote_cast_kind : quoted_cast_kind -> Constr.cast_kind -val unquote_kn : quoted_kernel_name -> Libnames.qualid -val unquote_inductive : quoted_inductive -> Names.inductive -(*val unquote_univ_instance : quoted_univ_instance -> Univ.Instance.t *) -val unquote_proj : quoted_proj -> (quoted_inductive * quoted_int * quoted_int) -val unquote_universe : Evd.evar_map -> quoted_sort -> Evd.evar_map * Univ.Universe.t -val print_term : t -> Pp.std_ppcmds -val unquote_universe_instance: Evd.evar_map -> quoted_univ_instance -> Evd.evar_map * Univ.Instance.t -(* val representsIndConstuctor : quoted_inductive -> Term.constr -> bool *) -val inspect_term : t -> (t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term -*) module CoqLiveDenote = Denote(CoqLiveDenoter) From 49077dcbe8a349e0ee5e2c2ed02f6bac92bca1d0 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 17:40:22 -0400 Subject: [PATCH 17/71] implementing a few more pieces of run_extractable. --- template-coq/_PluginProject | 1 + template-coq/gen-src/ast_quoter.ml | 394 ++++++++++++++++++++ template-coq/gen-src/meta_coq_plugin.mlpack | 1 + template-coq/gen-src/run_extractable.ml | 43 ++- 4 files changed, 421 insertions(+), 18 deletions(-) create mode 100644 template-coq/gen-src/ast_quoter.ml diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 89835573b..996659f63 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -89,6 +89,7 @@ gen-src/template_monad.ml gen-src/denoter.ml gen-src/denote.ml gen-src/plugin_core.ml +gen-src/ast_quoter.ml gen-src/run_extractable.ml gen-src/meta_coq_plugin.mlpack \ No newline at end of file diff --git a/template-coq/gen-src/ast_quoter.ml b/template-coq/gen-src/ast_quoter.ml new file mode 100644 index 000000000..d9a099492 --- /dev/null +++ b/template-coq/gen-src/ast_quoter.ml @@ -0,0 +1,394 @@ +(*i camlp4deps: "parsing/grammar.cma" i*) +(*i camlp4use: "pa_extend.cmp" i*) + +open Constr +open BasicAst +open Ast0 +open Quoted +open Quoter + +let quote_string s = + let rec aux acc i = + if i < 0 then acc + else aux (s.[i] :: acc) (i - 1) + in aux [] (String.length s - 1) + +let unquote_string l = + let buf = Bytes.create (List.length l) in + let rec aux i = function + | [] -> () + | c :: cs -> + Bytes.set buf i c; aux (succ i) cs + in + aux 0 l; + Bytes.to_string buf + +module TemplateASTQuoter = +struct + type t = Ast0.term + type quoted_ident = char list + type quoted_int = Datatypes.nat + type quoted_bool = bool + type quoted_name = name + type quoted_sort = Univ0.universe + type quoted_cast_kind = cast_kind + type quoted_kernel_name = char list + type quoted_inductive = inductive + type quoted_proj = projection + type quoted_global_reference = global_reference + + type quoted_sort_family = sort_family + type quoted_constraint_type = Univ0.constraint_type + type quoted_univ_constraint = Univ0.univ_constraint + type quoted_univ_instance = Univ0.Instance.t + type quoted_univ_constraints = Univ0.constraints + type quoted_univ_context = Univ0.universe_context + type quoted_inductive_universes = quoted_univ_context + + type quoted_mind_params = (ident * local_entry) list + type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list + type quoted_definition_entry = t * t option * quoted_univ_context + type quoted_mind_entry = mutual_inductive_entry + type quoted_mind_finiteness = recursivity_kind + type quoted_entry = (constant_entry, quoted_mind_entry) sum option + + type quoted_context_decl = context_decl + type quoted_context = context + type quoted_one_inductive_body = one_inductive_body + type quoted_mutual_inductive_body = mutual_inductive_body + type quoted_constant_body = constant_body + type quoted_global_decl = global_decl + type quoted_global_declarations = global_declarations + type quoted_program = program + + open Names + + let quote_ident id = + quote_string (Id.to_string id) + + let quote_name = function + | Anonymous -> Coq_nAnon + | Name i -> Coq_nNamed (quote_ident i) + + let quote_int i = + let rec aux acc i = + if i < 0 then acc + else aux (Datatypes.S acc) (i - 1) + in aux Datatypes.O (i - 1) + + let quote_bool x = x + + let quote_level l = + if Univ.Level.is_prop l then Univ0.Level.prop + else if Univ.Level.is_set l then Univ0.Level.set + else match Univ.Level.var_index l with + | Some x -> Univ0.Level.Var (quote_int x) + | None -> Univ0.Level.Level (quote_string (Univ.Level.to_string l)) + + let quote_universe s : Univ0.universe = + (* hack because we can't recover the list of level*int *) + (* todo : map on LSet is now exposed in Coq trunk, we should use it to remove this hack *) + let levels = Univ.LSet.elements (Univ.Universe.levels s) in + List.map (fun l -> let l' = quote_level l in + (* is indeed i always 0 or 1 ? *) + let b' = quote_bool (Univ.Universe.exists (fun (l2,i) -> Univ.Level.equal l l2 && i = 1) s) in + (l', b')) + levels + + let quote_sort s = + quote_universe (Sorts.univ_of_sort s) + + let quote_sort_family s = + match s with + | Sorts.InProp -> BasicAst.InProp + | Sorts.InSet -> BasicAst.InSet + | Sorts.InType -> BasicAst.InType + + let quote_cast_kind = function + | DEFAULTcast -> Cast + | REVERTcast -> RevertCast + | NATIVEcast -> NativeCast + | VMcast -> VmCast + + let quote_kn kn = quote_string (KerName.to_string kn) + let quote_inductive (kn, i) = { inductive_mind = kn ; inductive_ind = i } + let quote_proj ind p a = ((ind,p),a) + + let quote_constraint_type = function + | Univ.Lt -> Univ0.ConstraintType.Lt + | Univ.Le -> Univ0.ConstraintType.Le + | Univ.Eq -> Univ0.ConstraintType.Eq + + let quote_univ_constraint ((l, ct, l') : Univ.univ_constraint) : quoted_univ_constraint = + ((quote_level l, quote_constraint_type ct), quote_level l') + + let quote_univ_instance (i : Univ.Instance.t) : quoted_univ_instance = + let arr = Univ.Instance.to_array i in + CArray.map_to_list quote_level arr + + let quote_univ_constraints (c : Univ.Constraint.t) : quoted_univ_constraints = + let l = List.map quote_univ_constraint (Univ.Constraint.elements c) in + Univ0.ConstraintSet.(List.fold_right add l empty) + + let quote_variance (v : Univ.Variance.t) = + match v with + | Univ.Variance.Irrelevant -> Univ0.Variance.Irrelevant + | Univ.Variance.Covariant -> Univ0.Variance.Covariant + | Univ.Variance.Invariant -> Univ0.Variance.Invariant + + let quote_cuminfo_variance (var : Univ.Variance.t array) = + CArray.map_to_list quote_variance var + + let quote_univ_context (uctx : Univ.UContext.t) : quoted_univ_context = + let levels = Univ.UContext.instance uctx in + let constraints = Univ.UContext.constraints uctx in + Univ0.Monomorphic_ctx (quote_univ_instance levels, quote_univ_constraints constraints) + + let quote_cumulative_univ_context (cumi : Univ.CumulativityInfo.t) : quoted_univ_context = + let uctx = Univ.CumulativityInfo.univ_context cumi in + let levels = Univ.UContext.instance uctx in + let constraints = Univ.UContext.constraints uctx in + let var = Univ.CumulativityInfo.variance cumi in + let uctx' = (quote_univ_instance levels, quote_univ_constraints constraints) in + let var' = quote_cuminfo_variance var in + Univ0.Cumulative_ctx (uctx', var') + + let quote_abstract_univ_context_aux uctx : quoted_univ_context = + let levels = Univ.UContext.instance uctx in + let constraints = Univ.UContext.constraints uctx in + Univ0.Polymorphic_ctx (quote_univ_instance levels, quote_univ_constraints constraints) + + let quote_abstract_univ_context (uctx : Univ.AUContext.t) = + let uctx = Univ.AUContext.repr uctx in + quote_abstract_univ_context_aux uctx + + let quote_inductive_universes = function + | Entries.Monomorphic_ind_entry ctx -> quote_univ_context (Univ.ContextSet.to_context ctx) + | Entries.Polymorphic_ind_entry ctx -> quote_abstract_univ_context_aux ctx + | Entries.Cumulative_ind_entry ctx -> + quote_abstract_univ_context_aux (Univ.CumulativityInfo.univ_context ctx) + + let quote_context_decl na b t = + { decl_name = na; + decl_body = b; + decl_type = t } + + let quote_context l = l + + let mkAnon = Coq_nAnon + let mkName i = Coq_nNamed i + + let mkRel n = Coq_tRel n + let mkVar id = Coq_tVar id + let mkMeta n = Coq_tMeta n + let mkEvar n args = Coq_tEvar (n,Array.to_list args) + let mkSort s = Coq_tSort s + let mkCast c k t = Coq_tCast (c,k,t) + + let mkConst c u = Coq_tConst (c, u) + let mkProd na t b = Coq_tProd (na, t, b) + let mkLambda na t b = Coq_tLambda (na, t, b) + let mkApp f xs = Coq_tApp (f, Array.to_list xs) + let mkInd i u = Coq_tInd (i, u) + let mkConstruct (ind, i) u = Coq_tConstruct (ind, i, u) + let mkLetIn na b t t' = Coq_tLetIn (na,b,t,t') + + let rec seq f t = + if f < t then + f :: seq (f + 1) t + else [] + + let mkFix ((a,b),(ns,ts,ds)) = + let mk_fun xs i = + { dname = Array.get ns i ; + dtype = Array.get ts i ; + dbody = Array.get ds i ; + rarg = Array.get a i } :: xs + in + let defs = List.fold_left mk_fun [] (seq 0 (Array.length a)) in + let block = List.rev defs in + Coq_tFix (block, b) + + let mkCoFix (a,(ns,ts,ds)) = + let mk_fun xs i = + { dname = Array.get ns i ; + dtype = Array.get ts i ; + dbody = Array.get ds i ; + rarg = Datatypes.O } :: xs + in + let defs = List.fold_left mk_fun [] (seq 0 (Array.length ns)) in + let block = List.rev defs in + Coq_tFix (block, a) + + let mkCase (ind, npar) nargs p c brs = + let info = (ind, npar) in + let branches = List.map2 (fun br nargs -> (nargs, br)) brs nargs in + Coq_tCase (info,p,c,branches) + let mkProj p c = Coq_tProj (p,c) + + let mk_one_inductive_body (id, ty, kel, ctr, proj) = + let ctr = List.map (fun (a, b, c) -> ((a, b), c)) ctr in + { ind_name = id; ind_type = ty; + ind_kelim = kel; ind_ctors = ctr; ind_projs = proj } + + let mk_mutual_inductive_body npars params inds uctx = + {ind_npars = npars; ind_params = params; ind_bodies = inds; ind_universes = uctx} + + let mk_constant_body ty tm uctx = + {cst_type = ty; cst_body = tm; cst_universes = uctx} + + let mk_inductive_decl kn bdy = InductiveDecl (kn, bdy) + + let mk_constant_decl kn bdy = ConstantDecl (kn, bdy) + + let empty_global_declartions = [] + + let add_global_decl a b = a :: b + + let mk_program decls tm = (decls, tm) + + let quote_mind_finiteness = function + | Declarations.Finite -> Finite + | Declarations.CoFinite -> CoFinite + | Declarations.BiFinite -> BiFinite + + let quote_mind_params l = + let map (id, body) = + match body with + | Left ty -> (id, LocalAssum ty) + | Right trm -> (id, LocalDef trm) + in List.map map l + + let quote_one_inductive_entry (id, ar, b, consnames, constypes) = + { mind_entry_typename = id; + mind_entry_arity = ar; + mind_entry_template = b; + mind_entry_consnames = consnames; + mind_entry_lc = constypes } + + let quote_mutual_inductive_entry (mf, mp, is, univs) = + { mind_entry_record = None; + mind_entry_finite = mf; + mind_entry_params = mp; + mind_entry_inds = List.map quote_one_inductive_entry is; + mind_entry_universes = univs; + mind_entry_private = None } + + let quote_constant_entry (ty, body, ctx) : constant_entry = + match body with + | None -> ParameterEntry { parameter_entry_type = ty; + parameter_entry_universes = ctx } + | Some b -> DefinitionEntry { definition_entry_type = ty; + definition_entry_body = b; + definition_entry_universes = ctx; + definition_entry_opaque = false } + + let quote_entry e = + match e with + | Some (Left (ty, body, ctx)) -> + Some (Left (quote_constant_entry (ty, body, ctx))) + | Some (Right mind_entry) -> + Some (Right mind_entry) + | None -> None + + let inspectTerm (t : term) : (term, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term = + match t with + | Coq_tRel n -> ACoq_tRel n + (* so on *) + | _ -> failwith "not yet implemented" + + + + + let unquote_ident (qi: quoted_ident) : Id.t = + let s = unquote_string qi in + Id.of_string s + + let unquote_name (q: quoted_name) : Name.t = + match q with + | Coq_nAnon -> Anonymous + | Coq_nNamed n -> Name (unquote_ident n) + + let rec unquote_int (q: quoted_int) : int = + match q with + | Datatypes.O -> 0 + | Datatypes.S x -> succ (unquote_int x) + + let unquote_bool (q : quoted_bool) : bool = q + + (* val unquote_sort : quoted_sort -> Sorts.t *) + (* val unquote_sort_family : quoted_sort_family -> Sorts.family *) + let unquote_cast_kind (q : quoted_cast_kind) : Constr.cast_kind = + match q with + | VmCast -> VMcast + | NativeCast -> NATIVEcast + | Cast -> DEFAULTcast + | RevertCast -> REVERTcast + + let unquote_kn (q: quoted_kernel_name) : Libnames.qualid = + let s = unquote_string q in + Libnames.qualid_of_string s + + let unquote_inductive (q: quoted_inductive) : Names.inductive = + let { inductive_mind = na; inductive_ind = i } = q in + let comps = CString.split '.' (unquote_string na) in + let comps = List.map Id.of_string comps in + let id, dp = CList.sep_last comps in + let dp = DirPath.make dp in + let mind = Globnames.encode_mind dp id in + (mind, unquote_int i) + + (*val unquote_univ_instance : quoted_univ_instance -> Univ.Instance.t *) + let unquote_proj (q : quoted_proj) : (quoted_inductive * quoted_int * quoted_int) = + let (ind, ps), idx = q in + (ind, ps, idx) + + let unquote_level (trm : Univ0.Level.t) : Univ.Level.t = + match trm with + | Univ0.Level.Coq_lProp -> Univ.Level.prop + | Univ0.Level.Coq_lSet -> Univ.Level.set + | Univ0.Level.Level s -> + let s = unquote_string s in + let comps = CString.split '.' s in + let last, dp = CList.sep_last comps in + let dp = DirPath.make (List.map Id.of_string comps) in + let idx = int_of_string last in + Univ.Level.make dp idx + | Univ0.Level.Var n -> Univ.Level.var (unquote_int n) + + let unquote_level_expr (trm : Univ0.Level.t) (b : quoted_bool) : Univ.Universe.t = + let l = unquote_level trm in + let u = Univ.Universe.make l in + if b then Univ.Universe.super u + else u + + let unquote_universe evd (trm : Univ0.Universe.t) = + match trm with + | [] -> Evd.new_univ_variable (Evd.UnivFlexible false) evd + | (l,b)::q -> + evd, List.fold_left (fun u (l,b) -> + let u' = unquote_level_expr l b in Univ.Universe.sup u u') + (unquote_level_expr l b) q + + let print_term (u: t) : Pp.t = failwith "print_term in term_quoter.ml not yet implemented" + + let quote_global_reference : Globnames.global_reference -> quoted_global_reference = function + | Globnames.VarRef _ -> CErrors.user_err (Pp.str "VarRef unsupported") + | Globnames.ConstRef c -> + let kn = quote_kn (Names.Constant.canonical c) in + BasicAst.ConstRef kn + | Globnames.IndRef (i, n) -> + let kn = quote_kn (Names.MutInd.canonical i) in + let n = quote_int n in + BasicAst.IndRef (quote_inductive (kn,n)) + | Globnames.ConstructRef ((i, n), k) -> + let kn = quote_kn (Names.MutInd.canonical i) in + let n = quote_int n in + let k = (quote_int (k - 1)) in + BasicAst.ConstructRef (quote_inductive (kn,n), k) +end + +module TemplateASTReifier = Reify(TemplateASTQuoter) + +include TemplateASTQuoter +include TemplateASTReifier diff --git a/template-coq/gen-src/meta_coq_plugin.mlpack b/template-coq/gen-src/meta_coq_plugin.mlpack index 231802d88..62b285d4d 100644 --- a/template-coq/gen-src/meta_coq_plugin.mlpack +++ b/template-coq/gen-src/meta_coq_plugin.mlpack @@ -41,6 +41,7 @@ Constr_quoter Template_monad Denote Plugin_core +Ast_quoter Extractable diff --git a/template-coq/gen-src/run_extractable.ml b/template-coq/gen-src/run_extractable.ml index c5b386ce4..ef34b141a 100644 --- a/template-coq/gen-src/run_extractable.ml +++ b/template-coq/gen-src/run_extractable.ml @@ -3,15 +3,18 @@ open Plugin_core open Ast0 open BasicAst +open Quoter +open Ast_quoter -let of_constr (t : Constr.t) : Ast0.term = - failwith "of_constr" + +let of_constr (env : Environ.env) (t : Constr.t) : Ast0.term = + Ast_quoter.quote_term env t let to_string (cl : char list) : string = failwith "to_string" -let of_string (s : string) : char list = - failwith "of_string" +let of_string : string -> char list = + Ast_quoter.quote_string let to_reduction_strategy (s : Common.reductionStrategy) = failwith "to_reduction_strategy" @@ -19,11 +22,11 @@ let to_reduction_strategy (s : Common.reductionStrategy) = let to_ident : char list -> Names.Id.t = failwith "to_ident" -let of_ident : Names.Id.t -> char list = - failwith "of_ident" +let of_ident (id : Names.Id.t) : char list = + of_string (Names.Id.to_string id) -let of_global_reference (t : Plugin_core.global_reference) : BasicAst.global_reference = - failwith "of_global_reference" +let of_global_reference : Plugin_core.global_reference -> BasicAst.global_reference = + Ast_quoter.quote_global_reference let to_qualid (c : char list) : Libnames.qualid = Libnames.qualid_of_string (to_string c) @@ -32,19 +35,19 @@ let of_qualid (q : Libnames.qualid) : char list = of_string (Libnames.string_of_qualid q) let of_kername : Names.KerName.t -> char list = - failwith "of_kername" + Ast_quoter.quote_kn let to_kername : char list -> Names.KerName.t = failwith "of_kername" -let of_mib : Plugin_core.mutual_inductive_body -> _ = +let of_mib (t : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body = failwith "of_mib" let to_mie : _ -> Plugin_core.mutual_inductive_entry = failwith "to_mie" -let of_constant_entry : _ -> Ast0.constant_entry = - failwith "of_constant_entry" +let of_constant_entry : Plugin_core.constant_entry -> Ast0.constant_entry = + failwith "of_constant_entry" (* Ast_quoter.quote_constant_entry *) (* what about the overflow? efficiency? extract to bigint using Coq directives and convert to int here? *) @@ -139,6 +142,10 @@ let rec to_constr_ev (evm : Evd.evar_map) (t : Ast0.term) : Evd.evar_map * Const let to_constr (t : Ast0.term) : Constr.t = snd (to_constr_ev Evd.empty t) +let tmOfConstr (t : Constr.t) : Ast0.term tm = + fun env evm k _ -> + k env evm (of_constr env t) + let rec interp_tm (t : 'a coq_TM) : 'a tm = match t with @@ -148,8 +155,8 @@ let rec interp_tm (t : 'a coq_TM) : 'a tm = | Coq_tmMsg msg -> Obj.magic (tmMsg (to_string msg)) | Coq_tmFail err -> tmFail (to_string err) | Coq_tmEval (r,t) -> - tmMap (fun x -> Obj.magic (of_constr x)) - (tmEval (to_reduction_strategy r) (to_constr t)) + tmBind (tmEval (to_reduction_strategy r) (to_constr t)) + (fun x -> Obj.magic (tmOfConstr x)) | Coq_tmDefinition (nm, typ, trm) -> let typ = match typ with @@ -190,7 +197,7 @@ let rec interp_tm (t : 'a coq_TM) : 'a tm = | Coq_tmExistingInstance k -> Obj.magic (tmExistingInstance (to_kername k)) | Coq_tmInferInstance t -> - tmMap (function - None -> Obj.magic None - | Some inst -> Obj.magic (Some (of_constr inst))) - (tmInferInstance (to_constr t)) + tmBind (tmInferInstance (to_constr t)) + (function + None -> Obj.magic None + | Some inst -> Obj.magic (tmMap (fun x -> Some x) (tmOfConstr inst))) From d52c13671c1e6d5e4a377680cdae45888ef760bf Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 18:40:34 -0400 Subject: [PATCH 18/71] implementation of `of_mib` --- template-coq/gen-src/run_extractable.ml | 82 +++++++++++++++++++++++-- template-coq/src/denote.ml | 4 +- 2 files changed, 80 insertions(+), 6 deletions(-) diff --git a/template-coq/gen-src/run_extractable.ml b/template-coq/gen-src/run_extractable.ml index ef34b141a..8f084abbd 100644 --- a/template-coq/gen-src/run_extractable.ml +++ b/template-coq/gen-src/run_extractable.ml @@ -1,6 +1,5 @@ open Extractable open Plugin_core -open Ast0 open BasicAst open Quoter @@ -40,8 +39,80 @@ let of_kername : Names.KerName.t -> char list = let to_kername : char list -> Names.KerName.t = failwith "of_kername" -let of_mib (t : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body = - failwith "of_mib" +(* todo(gmm): this definition adapted from quoter.ml *) +let quote_rel_decl env = function + | Context.Rel.Declaration.LocalAssum (na, t) -> + let t' = Ast_quoter.quote_term env t in + Ast_quoter.quote_context_decl (Ast_quoter.quote_name na) None t' + | Context.Rel.Declaration.LocalDef (na, b, t) -> + let b' = Ast_quoter.quote_term env b in + let t' = Ast_quoter.quote_term env t in + Ast_quoter.quote_context_decl (Ast_quoter.quote_name na) (Some b') t' + +(* todo(gmm): this definition adapted from quoter.ml *) +let quote_rel_context env ctx = + let decls, env = + List.fold_right (fun decl (ds, env) -> + let x = quote_rel_decl env decl in + (x :: ds, Environ.push_rel decl env)) + ctx ([],env) in + Ast_quoter.quote_context decls + +(* todo(gmm): this definition adapted from quoter.ml (the body of quote_minductive_type) *) +let of_mib (env : Environ.env) (mib : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body = + let open Declarations in + let uctx = get_abstract_inductive_universes mib.mind_universes in + let inst = Univ.UContext.instance uctx in + let indtys = + (CArray.map_to_list (fun oib -> + let ty = Inductive.type_of_inductive env ((mib,oib),inst) in + (Context.Rel.Declaration.LocalAssum (Names.Name oib.mind_typename, ty))) mib.mind_packets) + in + let envind = Environ.push_rel_context (List.rev indtys) env in + let (ls,acc) = + List.fold_left (fun (ls,acc) oib -> + let named_ctors = + CList.combine3 + (Array.to_list oib.mind_consnames) + (Array.to_list oib.mind_user_lc) + (Array.to_list oib.mind_consnrealargs) + in + let indty = Inductive.type_of_inductive env ((mib,oib),inst) in + let indty = Ast_quoter.quote_term env indty in + let (reified_ctors,acc) = + List.fold_left (fun (ls,acc) (nm,ty,ar) -> + debug (fun () -> Pp.(str "opt_hnf_ctor_types:" ++ spc () ++ + bool !opt_hnf_ctor_types)) ; + let ty = if !opt_hnf_ctor_types then hnf_type envind ty else ty in + let ty = quote_term acc ty in + ((Ast_quoter.quote_ident nm, ty, Ast_quoter.quote_int ar) :: ls, acc)) + ([],acc) named_ctors + in + let projs, acc = + match mib.mind_record with + | Some (Some (id, csts, ps)) -> + let ctxwolet = Termops.smash_rel_context mib.mind_params_ctxt in + let indty = Constr.mkApp (Constr.mkIndU ((assert false (* t *),0),inst), + Context.Rel.to_extended_vect Constr.mkRel 0 ctxwolet) in + let indbinder = Context.Rel.Declaration.LocalAssum (Names.Name id,indty) in + let envpars = Environ.push_rel_context (indbinder :: ctxwolet) env in + let ps, acc = CArray.fold_right2 (fun cst pb (ls,acc) -> + let ty = quote_term envpars pb.proj_type in + let kn = Names.KerName.label (Names.Constant.canonical cst) in + let na = Ast_quoter.quote_ident (Names.Label.to_id kn) in + ((na, ty) :: ls, acc)) csts ps ([],acc) + in ps, acc + | _ -> [], acc + in + let sf = List.map Ast_quoter.quote_sort_family oib.mind_kelim in + (Ast_quoter.quote_ident oib.mind_typename, indty, sf, (List.rev reified_ctors), projs) :: ls, acc) + ([],env) (Array.to_list mib.mind_packets) + in + let nparams = Ast_quoter.quote_int mib.mind_nparams in + let paramsctx = quote_rel_context env mib.mind_params_ctxt in + let uctx = quote_abstract_inductive_universes mib.mind_universes in + let bodies = List.map Ast_quoter.mk_one_inductive_body (List.rev ls) in + Ast_quoter.mk_mutual_inductive_body nparams paramsctx bodies uctx let to_mie : _ -> Plugin_core.mutual_inductive_entry = failwith "to_mie" @@ -146,6 +217,9 @@ let tmOfConstr (t : Constr.t) : Ast0.term tm = fun env evm k _ -> k env evm (of_constr env t) +let tmOfMib (t : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body tm = + fun env evm k _ -> + k env evm (of_mib env t) let rec interp_tm (t : 'a coq_TM) : 'a tm = match t with @@ -185,7 +259,7 @@ let rec interp_tm (t : 'a coq_TM) : 'a tm = | Coq_tmQuoteInductive kn -> tmMap (function None -> Obj.magic None - | Some mib -> Obj.magic (Some (of_mib mib))) + | Some mib -> Obj.magic (tmMap (fun x -> Some x) (tmOfMib mib))) (tmQuoteInductive (to_kername kn)) | Coq_tmQuoteUniverses -> tmMap (fun x -> failwith "tmQuoteUniverses") tmQuoteUniverses diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index c733256f2..facdca9dd 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -185,7 +185,7 @@ let unquote_universe evm trm (* of type universe *) = let map_evm (f : 'a -> 'b -> 'a * 'c) (evm : 'a) (l : 'b list) : 'a * ('c list) = let evm, res = List.fold_left (fun (evm, l) b -> let evm, c = f evm b in evm, c :: l) (evm, []) l in evm, List.rev res - + let unquote_universe_instance evm trm (* of type universe_instance *) = let l = unquote_list trm in let evm, l = map_evm unquote_level evm l in @@ -423,7 +423,7 @@ let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = (match List.nth projs (D.unquote_int narg) with | Some p -> evm, Constr.mkProj (Names.Projection.make p false, t) | None -> (*bad_term trm *) failwith "tproj case of denote_term") - | _ -> failwith "big case of denote_term" + | _ -> failwith "big case of denote_term" in aux evm trm end From 23d578824517cdb1ac614fd8e81481985b1f060f Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 18:58:31 -0400 Subject: [PATCH 19/71] support for ConstantEntry --- template-coq/gen-src/run_extractable.ml | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/template-coq/gen-src/run_extractable.ml b/template-coq/gen-src/run_extractable.ml index 8f084abbd..a6a069e83 100644 --- a/template-coq/gen-src/run_extractable.ml +++ b/template-coq/gen-src/run_extractable.ml @@ -117,8 +117,20 @@ let of_mib (env : Environ.env) (mib : Plugin_core.mutual_inductive_body) : Ast0. let to_mie : _ -> Plugin_core.mutual_inductive_entry = failwith "to_mie" -let of_constant_entry : Plugin_core.constant_entry -> Ast0.constant_entry = - failwith "of_constant_entry" (* Ast_quoter.quote_constant_entry *) +(* note(gmm): code taken from quoter.ml (quote_entry_aux) *) +let of_constant_entry (env : Environ.env) (cd : Plugin_core.constant_entry) : Ast0.constant_entry = + let open Declarations in + let ty = quote_term env cd.const_type in + let body = match cd.const_body with + | Undef _ -> None + | Def cs -> Some (Ast_quoter.quote_term env (Mod_subst.force_constr cs)) + | OpaqueDef cs -> + if true + then Some (Ast_quoter.quote_term env (Opaqueproof.force_proof (Global.opaque_tables ()) cs)) + else None + in + let uctx = quote_constant_uctx cd.const_universes in + Ast_quoter.quote_constant_entry (ty, body, uctx) (* what about the overflow? efficiency? extract to bigint using Coq directives and convert to int here? *) @@ -221,6 +233,10 @@ let tmOfMib (t : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body fun env evm k _ -> k env evm (of_mib env t) +let tmOfConstantEntry (t : Plugin_core.constant_entry) : Ast0.constant_entry tm = + fun env evm k _ -> + k env evm (of_constant_entry env t) + let rec interp_tm (t : 'a coq_TM) : 'a tm = match t with | Coq_tmReturn x -> tmReturn x @@ -264,7 +280,7 @@ let rec interp_tm (t : 'a coq_TM) : 'a tm = | Coq_tmQuoteUniverses -> tmMap (fun x -> failwith "tmQuoteUniverses") tmQuoteUniverses | Coq_tmQuoteConstant (kn, b) -> - tmMap (fun x -> Obj.magic (of_constant_entry x)) + tmMap (fun x -> Obj.magic (tmOfConstantEntry x)) (tmQuoteConstant (to_kername kn) b) | Coq_tmInductive i -> tmMap (fun _ -> Obj.magic ()) (tmInductive (to_mie i)) From 4f25d9227f179d0ddd0ca5bf9535d86f30548ceb Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 19:03:37 -0400 Subject: [PATCH 20/71] fixing the _CoqProject. --- template-coq/_CoqProject | 4 ---- 1 file changed, 4 deletions(-) diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index 7bedee538..662a54e52 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -1,5 +1,4 @@ -I src --I gen-src -R theories Template # the MetaCoq plugin @@ -39,6 +38,3 @@ theories/TemplateMonad/Core.v theories/TemplateMonad/Extractable.v theories/TemplateMonad/Monad.v theories/monad_utils.v - -# for Extraction -gen-src/Extraction.v From 747f84a49f7286d48e0084aa63a1b15222a3340a Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Mon, 8 Apr 2019 16:04:25 -0700 Subject: [PATCH 21/71] WIP:Extraction denoter instance. compiles, but many items are failwith --- template-coq/src/denote.ml | 99 +++++++++++++++++++++++++++++++++++++- 1 file changed, 98 insertions(+), 1 deletion(-) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index c733256f2..b417b14b9 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -524,4 +524,101 @@ end module CoqLiveDenote = Denote(CoqLiveDenoter) -let denote_term=CoqLiveDenote.denote_term \ No newline at end of file +let denote_term=CoqLiveDenote.denote_term + +open Constr +open BasicAst +open Ast0 +open Quoted +open Quoter +open Ast_quoter + +module ExtractionDenoter = +struct + type t = Ast0.term + type quoted_ident = char list + type quoted_int = Datatypes.nat + type quoted_bool = bool + type quoted_name = name + type quoted_sort = Univ0.universe + type quoted_cast_kind = cast_kind + type quoted_kernel_name = char list + type quoted_inductive = inductive + type quoted_proj = projection + type quoted_global_reference = global_reference + + type quoted_sort_family = sort_family + type quoted_constraint_type = Univ0.constraint_type + type quoted_univ_constraint = Univ0.univ_constraint + type quoted_univ_instance = Univ0.Instance.t + type quoted_univ_constraints = Univ0.constraints + type quoted_univ_context = Univ0.universe_context + type quoted_inductive_universes = quoted_univ_context + + type quoted_mind_params = (ident * local_entry) list + type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list + type quoted_definition_entry = t * t option * quoted_univ_context + type quoted_mind_entry = mutual_inductive_entry + type quoted_mind_finiteness = recursivity_kind + type quoted_entry = (constant_entry, quoted_mind_entry) sum option + + type quoted_context_decl = context_decl + type quoted_context = context + type quoted_one_inductive_body = one_inductive_body + type quoted_mutual_inductive_body = mutual_inductive_body + type quoted_constant_body = constant_body + type quoted_global_decl = global_decl + type quoted_global_declarations = global_declarations + type quoted_program = program + + let mkAnon = mkAnon + let mkName = mkName + let quote_kn = quote_kn + let mkRel = mkRel + let mkVar = mkVar + let mkMeta = mkMeta + let mkEvar = mkEvar + let mkSort = mkSort + let mkCast = mkCast + let mkConst = mkConst + let mkProd = mkProd + + let mkLambda = mkLambda + let mkApp = mkApp + let mkLetIn = mkLetIn + let mkFix = mkFix + let mkConstruct = mkConstruct + let mkCoFix = mkCoFix + let mkInd = mkInd + let mkCase = mkCase + let quote_proj = quote_proj + let mkProj = mkProj + let print_term (u: t) : Pp.t = Pp.str "printing not implemented" + + let inspect_term (tt: t):(t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term= + failwith "nyi" + + let unquote_ident (qi: quoted_ident) : Id.t + = failwith "nyi" + let unquote_name (qn: quoted_name) : Name.t + = failwith "nyi" + let unquote_int (q: quoted_int ) : int + = failwith "nyi" + let unquote_bool (q: quoted_bool ) : bool + = failwith "nyi" + let unquote_cast_kind (q: quoted_cast_kind ) : Constr.cast_kind + = failwith "nyi" + let unquote_kn (q: quoted_kernel_name ) : Libnames.qualid + = failwith "nyi" + let unquote_inductive (q: quoted_inductive ) : Names.inductive + = failwith "nyi" + let unquote_proj (q: quoted_proj ) : (quoted_inductive * quoted_int * quoted_int) + = failwith "nyi" + let unquote_universe (q: Evd.evar_map) (qs: quoted_sort): Evd.evar_map * Univ.Universe.t + = failwith "nyi" + let unquote_universe_instance(q: Evd.evar_map) (qu: quoted_univ_instance): Evd.evar_map * Univ.Instance.t + = failwith "nyi" + +end + +module ExtractionDenote = Denote(ExtractionDenoter) From 039c112f087fbcadfe79e313434718257f1dd71a Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 19:49:42 -0400 Subject: [PATCH 22/71] things should now compile. --- checker/src/term_quoter.ml | 1 + template-coq/Makefile | 23 +++---------------- template-coq/_CoqProject | 3 +++ template-coq/src/run_template_monad.ml | 4 ++-- .../{gen-src => theories}/Extraction.v | 3 +++ 5 files changed, 12 insertions(+), 22 deletions(-) rename template-coq/{gen-src => theories}/Extraction.v (89%) diff --git a/checker/src/term_quoter.ml b/checker/src/term_quoter.ml index 72af6bcb9..9425b42ea 100644 --- a/checker/src/term_quoter.ml +++ b/checker/src/term_quoter.ml @@ -5,6 +5,7 @@ open Constr open BasicAst open Ast0 open Template_coq +open Quoted open Quoter let quote_string s = diff --git a/template-coq/Makefile b/template-coq/Makefile index afd16c8f6..df2ef0a54 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -1,11 +1,4 @@ -TOCOPY=tm_util quoted quoter constr_quoter template_monad denoter denote plugin_core -all: coq plugin - -gen-src/Extraction.vo: coq gen-src/Extraction.v - $(COQPATH)coqc -I src -Q theories Template gen-src/Extraction.v - -plugin: coq Makefile.plugin gen-src/Extraction.vo - $(MAKE) -f Makefile.plugin +all: coq coq: Makefile.coq $(MAKE) -f Makefile.coq @@ -18,24 +11,14 @@ install: Makefile.coq html: all $(MAKE) -f Makefile.coq html -clean: Makefile.coq Makefile.plugin +clean: Makefile.coq $(MAKE) -f Makefile.coq clean - $(MAKE) -f Makefile.plugin clean mrproper: clean - rm -f Makefile.coq Makefile.plugin + rm -f Makefile.coq Makefile.coq: _CoqProject coq_makefile -f _CoqProject -o Makefile.coq -Makefile.plugin: coq _PluginProject $(TOCOPY:%=gen-src/%.ml) - $(COQPATH)coq_makefile -f _PluginProject -o Makefile.plugin - .merlin: Makefile.coq $(MAKE) -f Makefile.coq .merlin - -gen-src/%.ml: src/%.ml - ln -s ../$< $@ - -clean-plugin: - (cd gen-src; rm -rf *.d *.c* $(TOCOPY:%=%.ml) ) diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index 662a54e52..55dc5aa04 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -38,3 +38,6 @@ theories/TemplateMonad/Core.v theories/TemplateMonad/Extractable.v theories/TemplateMonad/Monad.v theories/monad_utils.v + +# Extraction +theories/Extraction.v diff --git a/template-coq/src/run_template_monad.ml b/template-coq/src/run_template_monad.ml index 9065d0940..b0f7059aa 100644 --- a/template-coq/src/run_template_monad.ml +++ b/template-coq/src/run_template_monad.ml @@ -336,8 +336,8 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m let entry = TermReify.quote_entry_aux bypass env evm name in let entry = match entry with - | Some (Left cstentry) -> TemplateCoqQuoter.quote_constant_entry cstentry - | Some (Right _) -> CErrors.user_err (str name ++ str " refers to an inductive") + | Some (Quoted.Left cstentry) -> TemplateCoqQuoter.quote_constant_entry cstentry + | Some (Quoted.Right _) -> CErrors.user_err (str name ++ str " refers to an inductive") | None -> bad_term_verb pgm "anomaly in QuoteConstant" in k (env, evm, entry) diff --git a/template-coq/gen-src/Extraction.v b/template-coq/theories/Extraction.v similarity index 89% rename from template-coq/gen-src/Extraction.v rename to template-coq/theories/Extraction.v index ae11d543c..b04693b43 100644 --- a/template-coq/gen-src/Extraction.v +++ b/template-coq/theories/Extraction.v @@ -27,6 +27,9 @@ Cd "gen-src". Require Import Template.TemplateMonad.Extractable. +Recursive Extraction Library TypingWf. +Recursive Extraction Library Checker. +Recursive Extraction Library Retyping. Recursive Extraction Library Extractable. Cd "..". \ No newline at end of file From 7e4e366bf93bcdd5223cf3c2b0ab68ad94b4ab44 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Mon, 8 Apr 2019 16:57:12 -0700 Subject: [PATCH 23/71] implemented inspect_term --- template-coq/src/denote.ml | 37 ++++++++++++++++++++++++++++++++++++- 1 file changed, 36 insertions(+), 1 deletion(-) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index b417b14b9..05a17d5f6 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -595,8 +595,43 @@ struct let mkProj = mkProj let print_term (u: t) : Pp.t = Pp.str "printing not implemented" + let unquote_def (x: 't BasicAst.def) : ('t, name, quoted_int) Quoted.adef = + { + adname=dname x; + adtype=dtype x; + adbody=dbody x; + rarg=rarg x + } + let inspect_term (tt: t):(t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term= - failwith "nyi" + match tt with + | Coq_tRel n -> ACoq_tRel n + | Coq_tVar v -> ACoq_tVar v + | Coq_tMeta n -> ACoq_tMeta n + | Coq_tEvar (x,l) -> ACoq_tEvar (x,l) + | Coq_tSort u -> ACoq_tSort u + | Coq_tCast (t,k,tt) -> ACoq_tCast (t,k,tt) + | Coq_tProd (a,b,c) -> ACoq_tProd (a,b,c) + | Coq_tLambda (a,b,c) -> ACoq_tLambda (a,b,c) + | Coq_tLetIn (a,b,c,d) -> ACoq_tLetIn (a,b,c,d) + | Coq_tApp (a,b) -> ACoq_tApp (a,b) + | Coq_tConst (a,b) -> ACoq_tConst (a,b) + | Coq_tInd (a,b) -> ACoq_tInd (a,b) + | Coq_tConstruct (a,b,c) -> ACoq_tConstruct (a,b,c) + | Coq_tCase (a,b,c,d) -> ACoq_tCase (a,b,c,d) + | Coq_tProj (a,b) -> ACoq_tProj (a,b) + | Coq_tFix (a,b) -> ACoq_tFix (List.map unquote_def a,b) + | Coq_tCoFix (a,b) -> ACoq_tCoFix (List.map unquote_def a,b) + (* + | Coq_tApp of term * term list + | Coq_tConst of kername * universe_instance + | Coq_tInd of inductive * universe_instance + | Coq_tConstruct of inductive * nat * universe_instance + | Coq_tCase of (inductive * nat) * term * term * (nat * term) list + | Coq_tProj of projection * term + | Coq_tFix of term mfixpoint * nat + | Coq_tCoFix of term mfixpoint * nat + *) let unquote_ident (qi: quoted_ident) : Id.t = failwith "nyi" From 1e954457b12de6e120b0d0079e1ae0d7f865137e Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 20:58:17 -0400 Subject: [PATCH 24/71] get rid of the gen-src directory --- movefiles.sh | 2 +- template-coq/gen-src/coq_constr.ml | 88 ------------------- template-coq/{gen-src => src}/ast_quoter.ml | 0 template-coq/src/plugin_core.ml | 5 ++ template-coq/src/plugin_core.mli | 2 + .../{gen-src => src}/run_extractable.ml | 0 template-coq/theories/Extraction.v | 2 +- 7 files changed, 9 insertions(+), 90 deletions(-) delete mode 100644 template-coq/gen-src/coq_constr.ml rename template-coq/{gen-src => src}/ast_quoter.ml (100%) rename template-coq/{gen-src => src}/run_extractable.ml (100%) diff --git a/movefiles.sh b/movefiles.sh index c0f7b1c5e..3eda25690 100755 --- a/movefiles.sh +++ b/movefiles.sh @@ -7,5 +7,5 @@ shopt -s nullglob # make the for loop do nothnig when there is no *.ml* files for i in *.ml*; do j=`echo $i | cut -b 1 | tr '[:upper:]' '[:lower:]'`; # the first letter of file name is put in lowercase k=`echo $i | cut -b 2-`; # the rest is untouched - mv $i ../checker/src/$j$k; + mv $i ../plugin-demo/mc-src/$j$k; done diff --git a/template-coq/gen-src/coq_constr.ml b/template-coq/gen-src/coq_constr.ml deleted file mode 100644 index e59f3aeaa..000000000 --- a/template-coq/gen-src/coq_constr.ml +++ /dev/null @@ -1,88 +0,0 @@ -open Plugin_core -open Constr - -type name = Names.Name.t -type id = Names.Id.t -type universe = Univ.Universe.t -type universe_instance = unit -type projection = Names.Projection.t -type 'a mfixpoint = 'a BasicAst.mfixpoint -type nat = int - -let tRel (n : nat) = - failwith "tRel" -let tVar (i : id) : Constr.t = - Constr.mkVar i - -let tMeta (n : nat) : Constr.t = - failwith "tMeta" - -let tEvar (n : nat) (ls : Constr.t list) : Constr.t = - failwith "tEvar is not supported" - -let tSort (u : Univ.Universe.t) : Constr.t = - failwith "tSort" - -let tCast (a : Constr.t) (b : Constr.cast_kind) (c : Constr.t) : Constr.t = - Constr.mkCast (a, b, c) - -let tProd (n : name) (a : Constr.t) (b : Constr.t) : Constr.t = - Constr.mkProd (n, a, b) - -let tLambda (n : name) (a : Constr.t) (b : Constr.t) : Constr.t = - Constr.mkLambda (n, a, b) - -let tLetIn (n : name) (t : Constr.t) (b : Constr.t) (c : Constr.t) : Constr.t = - Constr.mkLetIn (n, t, b, c) - -let tApp (f : Constr.t) (ls : Constr.t list) : Constr.t = - Constr.mkApp (f, Array.of_list ls) - -let tConst (kn : 'a) : 'a = - failwith "tConst" - -let tConstruct (kn : 'a) : 'a = - failwith "tConstruct" - -let tCase (_ : 'a) : 'a = - failwith "tCase" - -let tProj (_ : BasicAst.projection) (_ : Constr.t) : Constr.t = - failwith "tProj" - -let constr_match - (rel : nat -> 'a) - (var : ident -> 'a) - (meta : nat -> 'a) - (evar : nat -> term list -> 'a) - (sort : universe -> 'a) - (cast : term -> Constr.cast_kind -> term -> 'a) - (prod : name -> term -> term -> 'a) - (lambda : name -> term -> term -> 'a) - (letin : name -> term -> term -> term -> 'a) - (app : term -> term list -> 'a) - (const : kername -> universe_instance -> 'a) - (construct : Names.inductive -> nat -> universe_instance -> 'a) - (case : Names.inductive * nat * term -> term -> (nat * term) list -> 'a) - (proj : projection -> term -> 'a) - (fix : term mfixpoint -> nat -> 'a) - (cofix : term mfixpoint -> nat -> 'a) - (t : term) : 'a = - match Constr.kind t with - | Constr.Rel n -> rel n - | Constr.Var id -> var id - | Constr.Meta m -> meta m - | Constr.Evar (a,b) -> evar (Evar.repr a) (Array.to_list b) - | Constr.Sort s -> sort s - | Constr.Cast (a,b,c) -> cast a b c - | Constr.Prod (a,b,c) -> prod a b c - | Constr.Lambda (a,b,c) -> lambda a b c - | Constr.LetIn (a,b,c,d) -> letin a b c d - | Constr.App (f, xs) -> app f (Array.to_list xs) - | Constr.Const _ - | Constr.Ind _ - | Constr.Construct _ - | Constr.Case _ - | Constr.Fix _ - | Constr.CoFix _ - | Constr.Proj _ -> failwith "not implemented" diff --git a/template-coq/gen-src/ast_quoter.ml b/template-coq/src/ast_quoter.ml similarity index 100% rename from template-coq/gen-src/ast_quoter.ml rename to template-coq/src/ast_quoter.ml diff --git a/template-coq/src/plugin_core.ml b/template-coq/src/plugin_core.ml index 4b6cca8b3..1611215e6 100644 --- a/template-coq/src/plugin_core.ml +++ b/template-coq/src/plugin_core.ml @@ -33,6 +33,10 @@ type 'a tm = let run (c : 'a tm) env evm (k : Environ.env -> Evd.evar_map -> 'a -> unit) : unit = c env evm k (fun x -> CErrors.user_err (Pp.str x)) +let run_vernac (c : 'a tm) : unit = + let (evm,env) = Pfedit.get_current_context () in + run c env evm (fun _ _ _ -> ()) + let tmReturn (x : 'a) : 'a tm = fun env evd k _fail -> k env evd x let tmBind (x : 'a tm) (k : 'a -> 'b tm) : 'b tm = @@ -160,3 +164,4 @@ let tmInferInstance (typ : term) : term option tm = success env evm (Some (EConstr.to_constr evm t)) with Not_found -> success env evm None + diff --git a/template-coq/src/plugin_core.mli b/template-coq/src/plugin_core.mli index 1ddd5def9..89f23a68c 100644 --- a/template-coq/src/plugin_core.mli +++ b/template-coq/src/plugin_core.mli @@ -22,6 +22,8 @@ type 'a tm val run : 'a tm -> Environ.env -> Evd.evar_map -> (Environ.env -> Evd.evar_map -> 'a -> unit) -> unit +val run_vernac : 'a tm -> unit + val tmReturn : 'a -> 'a tm val tmBind : 'a tm -> ('a -> 'b tm) -> 'b tm val tmMap : ('a -> 'b) -> 'a tm -> 'b tm diff --git a/template-coq/gen-src/run_extractable.ml b/template-coq/src/run_extractable.ml similarity index 100% rename from template-coq/gen-src/run_extractable.ml rename to template-coq/src/run_extractable.ml diff --git a/template-coq/theories/Extraction.v b/template-coq/theories/Extraction.v index b04693b43..04e2edc3e 100644 --- a/template-coq/theories/Extraction.v +++ b/template-coq/theories/Extraction.v @@ -21,7 +21,7 @@ Extraction Blacklist config uGraph univ Ast String List Nat Int UnivSubst Typing Checker Retyping OrderedType. Set Warnings "-extraction-opaque-accessed". -Require Import Template.Ast. +Require Export Template.Ast. Cd "gen-src". From f57000c012ef33a8fffc2c4f55361b770a90e391 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Mon, 8 Apr 2019 17:58:41 -0700 Subject: [PATCH 25/71] implemented all of denoter instance except unquote univ instance Ast_quoter had unquote functions too: all of them except unquote univ instance. --- template-coq/src/denote.ml | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index 05a17d5f6..4ad6a76f4 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -634,23 +634,32 @@ struct *) let unquote_ident (qi: quoted_ident) : Id.t - = failwith "nyi" + = Ast_quoter.unquote_ident qi + let unquote_name (qn: quoted_name) : Name.t - = failwith "nyi" + = Ast_quoter.unquote_name qn + let unquote_int (q: quoted_int ) : int - = failwith "nyi" + = Ast_quoter.unquote_int q + let unquote_bool (q: quoted_bool ) : bool - = failwith "nyi" + = Ast_quoter.unquote_bool q + let unquote_cast_kind (q: quoted_cast_kind ) : Constr.cast_kind - = failwith "nyi" + = Ast_quoter.unquote_cast_kind q + let unquote_kn (q: quoted_kernel_name ) : Libnames.qualid - = failwith "nyi" + = Ast_quoter.unquote_kn q + let unquote_inductive (q: quoted_inductive ) : Names.inductive - = failwith "nyi" + = Ast_quoter.unquote_inductive q + let unquote_proj (q: quoted_proj ) : (quoted_inductive * quoted_int * quoted_int) - = failwith "nyi" + = Ast_quoter.unquote_proj q + let unquote_universe (q: Evd.evar_map) (qs: quoted_sort): Evd.evar_map * Univ.Universe.t - = failwith "nyi" + = Ast_quoter.unquote_universe q qs + let unquote_universe_instance(q: Evd.evar_map) (qu: quoted_univ_instance): Evd.evar_map * Univ.Instance.t = failwith "nyi" From ac2f74f02d5207688debf1420548e8f36edc4b3b Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Mon, 8 Apr 2019 18:26:29 -0700 Subject: [PATCH 26/71] some fixes for compilation --- template-coq/_CoqProject | 1 + template-coq/theories/Extraction.v | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index 55dc5aa04..8671a977f 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -8,6 +8,7 @@ src/quoted.ml src/quoter.ml # src/constr_quoter.mli src/constr_quoter.ml +src/ast_quoter.ml src/denoter.ml src/denote.mli src/denote.ml diff --git a/template-coq/theories/Extraction.v b/template-coq/theories/Extraction.v index 04e2edc3e..3e9f3d422 100644 --- a/template-coq/theories/Extraction.v +++ b/template-coq/theories/Extraction.v @@ -23,7 +23,7 @@ Set Warnings "-extraction-opaque-accessed". Require Export Template.Ast. -Cd "gen-src". +Cd "src". Require Import Template.TemplateMonad.Extractable. From b5460d6c460a646b35d14925be9131c961881c26 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Mon, 8 Apr 2019 21:59:39 -0400 Subject: [PATCH 27/71] an almost working plugin --- plugin-demo/Makefile | 19 ++++++ plugin-demo/_CoqProject | 90 ++++++++++++++++++++++++++++ plugin-demo/gen-src/Extract.v | 8 +++ plugin-demo/gen-src/Makefile | 8 +++ plugin-demo/gen-src/_CoqProject | 6 ++ plugin-demo/gen-src/demo.v | 7 +++ plugin-demo/src/.gitignore | 2 + plugin-demo/src/g_demo_plugin.ml4 | 12 ++++ plugin-demo/src/movefiles.sh | 12 ++++ plugin-demo/theories/Demo.v | 2 + template-coq/src/denote.ml | 2 +- template-coq/src/plugin_core.ml | 3 + template-coq/src/plugin_core.mli | 2 + template-coq/src/run_extractable.ml | 12 ++-- template-coq/src/run_extractable.mli | 11 ++++ 15 files changed, 189 insertions(+), 7 deletions(-) create mode 100644 plugin-demo/Makefile create mode 100644 plugin-demo/_CoqProject create mode 100644 plugin-demo/gen-src/Extract.v create mode 100644 plugin-demo/gen-src/Makefile create mode 100644 plugin-demo/gen-src/_CoqProject create mode 100644 plugin-demo/gen-src/demo.v create mode 100644 plugin-demo/src/.gitignore create mode 100644 plugin-demo/src/g_demo_plugin.ml4 create mode 100755 plugin-demo/src/movefiles.sh create mode 100644 plugin-demo/theories/Demo.v create mode 100644 template-coq/src/run_extractable.mli diff --git a/plugin-demo/Makefile b/plugin-demo/Makefile new file mode 100644 index 000000000..9d977108f --- /dev/null +++ b/plugin-demo/Makefile @@ -0,0 +1,19 @@ +TEMPLATE_LIB=../template-coq + +coq: Makefile.coq + $(MAKE) -f Makefile.coq + +Makefile.coq: _CoqProject gen-src get-mc + coq_makefile -f _CoqProject -o Makefile.coq + +gen-src: + $(MAKE) -C gen-src + +get-mc: + cp -r $(TEMPLATE_LIB)/src/*.ml $(TEMPLATE_LIB)/src/*.mli src + (cd src; ./movefiles.sh) + +.PHONY: get-mc gen-src + +clean: + $(MAKE) -f Makefile.coq clean diff --git a/plugin-demo/_CoqProject b/plugin-demo/_CoqProject new file mode 100644 index 000000000..950c34870 --- /dev/null +++ b/plugin-demo/_CoqProject @@ -0,0 +1,90 @@ +-I src +-Q theories Demo + +src/ascii.ml +src/ascii.mli +src/ast0.ml +src/ast0.mli +src/astUtils.ml +src/astUtils.mli +src/basicAst.ml +src/basicAst.mli +src/basics.ml +src/basics.mli +src/binInt.ml +src/binInt.mli +src/binNat.ml +src/binNat.mli +src/binNums.ml +src/binNums.mli +src/binPosDef.ml +src/binPosDef.mli +src/binPos.ml +src/binPos.mli +src/bool.ml +src/bool.mli +src/common.ml +src/common.mli +src/config0.ml +src/config0.mli +src/datatypes.ml +src/datatypes.mli +src/decidableType.ml +src/decidableType.mli +src/decimal.ml +src/decimal.mli +src/equalities.ml +src/equalities.mli +src/extractable.ml +src/extractable.mli +src/fMapWeakList.ml +src/fMapWeakList.mli +src/list0.ml +src/list0.mli +src/logic.ml +src/logic.mli +src/mSetWeakList.ml +src/mSetWeakList.mli +src/nat0.ml +src/nat0.mli +src/orderedType0.ml +src/orderedType0.mli +src/orders.ml +src/orders.mli +src/ordersTac.ml +src/ordersTac.mli +src/peanoNat.ml +src/peanoNat.mli +src/specif.ml +src/specif.mli +src/string0.ml +src/string0.mli +src/uGraph0.ml +src/uGraph0.mli +src/univ0.ml +src/univ0.mli +src/utils.ml +src/utils.mli + +# copied from MetaCoq +src/run_extractable.mli +src/run_extractable.ml +src/tm_util.ml +src/quoter.ml +src/quoted.ml +src/denote.ml +src/denote.mli +src/denoter.ml +src/plugin_core.mli +src/plugin_core.ml +src/ast_quoter.ml +src/constr_quoter.ml # this shouldn't be necessary + +src/demo.ml +src/demo.mli + + +src/g_demo_plugin.ml4 +src/demo_plugin.mlpack + +theories/Demo.v \ No newline at end of file diff --git a/plugin-demo/gen-src/Extract.v b/plugin-demo/gen-src/Extract.v new file mode 100644 index 000000000..cb88c951a --- /dev/null +++ b/plugin-demo/gen-src/Extract.v @@ -0,0 +1,8 @@ +Require Import Template.Extraction. +Require Import Demo.demo. + +Cd "../src". + +Recursive Extraction Library demo. + +Cd "../gen-src". \ No newline at end of file diff --git a/plugin-demo/gen-src/Makefile b/plugin-demo/gen-src/Makefile new file mode 100644 index 000000000..7f6123f7f --- /dev/null +++ b/plugin-demo/gen-src/Makefile @@ -0,0 +1,8 @@ +coq: Makefile.coq + $(MAKE) -f Makefile.coq + +Makefile.coq: _CoqProject + coq_makefile -f _CoqProject -o Makefile.coq + +clean: Makefile.coq + $(MAKE) -f Makefile.coq clean diff --git a/plugin-demo/gen-src/_CoqProject b/plugin-demo/gen-src/_CoqProject new file mode 100644 index 000000000..a2395b917 --- /dev/null +++ b/plugin-demo/gen-src/_CoqProject @@ -0,0 +1,6 @@ +-R ../../template-coq/theories Template +-I ../../template-coq/src +-Q . Demo + +demo.v +Extract.v \ No newline at end of file diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v new file mode 100644 index 000000000..debf3280d --- /dev/null +++ b/plugin-demo/gen-src/demo.v @@ -0,0 +1,7 @@ +From Template Require Import + Ast + TemplateMonad.Extractable. + + +Definition showoff : TM unit := + tmMsg "running from an extracted plugin!". diff --git a/plugin-demo/src/.gitignore b/plugin-demo/src/.gitignore new file mode 100644 index 000000000..37230597a --- /dev/null +++ b/plugin-demo/src/.gitignore @@ -0,0 +1,2 @@ +*.ml* +*.cm* \ No newline at end of file diff --git a/plugin-demo/src/g_demo_plugin.ml4 b/plugin-demo/src/g_demo_plugin.ml4 new file mode 100644 index 000000000..8e18737d0 --- /dev/null +++ b/plugin-demo/src/g_demo_plugin.ml4 @@ -0,0 +1,12 @@ +(*i camlp4deps: "parsing/grammar.cma" i*) +(*i camlp4use: "pa_extend.cmp" i*) + +open Entries +open Run_extractable + +DECLARE PLUGIN "demo_plugin" + +VERNAC COMMAND EXTEND Make_vernac CLASSIFIED AS QUERY + | [ "Showoff" ] -> + [ Run_extractable.run_vernac Demo.showoff ] +END;; diff --git a/plugin-demo/src/movefiles.sh b/plugin-demo/src/movefiles.sh new file mode 100755 index 000000000..f54553870 --- /dev/null +++ b/plugin-demo/src/movefiles.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +shopt -s nullglob # make the for loop do nothnig when there is no *.ml* files + +for i in `ls *.ml *.mli`; do + # echo $i + j=`echo $i | cut -b 1 | tr '[:upper:]' '[:lower:]'`; # the first letter of file name is put in lowercase + k=`echo $i | cut -b 2-`; # the rest is untouched + if [ "$i" != "$j$k" ]; then + mv -f $i $j$k + fi +done diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v new file mode 100644 index 000000000..fd2a76121 --- /dev/null +++ b/plugin-demo/theories/Demo.v @@ -0,0 +1,2 @@ +Require Import Coq.Strings.String. +Declare ML Module "demo_plugin". diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index 205bb60b6..4fe6b1735 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -12,7 +12,7 @@ open TemplateCoqQuoter (* todo: the recursive call is uneeded provided we call it on well formed terms *) -let print_term (u: t) : Pp.t = pr_constr u +let print_term (u: Constr.t) : Pp.t = Printer.pr_constr u let strict_unquote_universe_mode = ref true diff --git a/template-coq/src/plugin_core.ml b/template-coq/src/plugin_core.ml index 1611215e6..48e8ae791 100644 --- a/template-coq/src/plugin_core.ml +++ b/template-coq/src/plugin_core.ml @@ -37,6 +37,9 @@ let run_vernac (c : 'a tm) : unit = let (evm,env) = Pfedit.get_current_context () in run c env evm (fun _ _ _ -> ()) +let with_env_evm (c : Environ.env -> Evd.evar_map -> 'a tm) : 'a tm = + fun env evm success fail -> c env evm env evm success fail + let tmReturn (x : 'a) : 'a tm = fun env evd k _fail -> k env evd x let tmBind (x : 'a tm) (k : 'a -> 'b tm) : 'b tm = diff --git a/template-coq/src/plugin_core.mli b/template-coq/src/plugin_core.mli index 89f23a68c..7493925ac 100644 --- a/template-coq/src/plugin_core.mli +++ b/template-coq/src/plugin_core.mli @@ -22,6 +22,8 @@ type 'a tm val run : 'a tm -> Environ.env -> Evd.evar_map -> (Environ.env -> Evd.evar_map -> 'a -> unit) -> unit +val with_env_evm : (Environ.env -> Evd.evar_map -> 'a tm) -> 'a tm + val run_vernac : 'a tm -> unit val tmReturn : 'a -> 'a tm diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index a6a069e83..365d17739 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -226,16 +226,13 @@ let to_constr (t : Ast0.term) : Constr.t = snd (to_constr_ev Evd.empty t) let tmOfConstr (t : Constr.t) : Ast0.term tm = - fun env evm k _ -> - k env evm (of_constr env t) + Plugin_core.with_env_evm (fun env _ -> tmReturn (of_constr env t)) let tmOfMib (t : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body tm = - fun env evm k _ -> - k env evm (of_mib env t) + Plugin_core.with_env_evm (fun env _ -> tmReturn (of_mib env t)) let tmOfConstantEntry (t : Plugin_core.constant_entry) : Ast0.constant_entry tm = - fun env evm k _ -> - k env evm (of_constant_entry env t) + Plugin_core.with_env_evm (fun env _ -> tmReturn (of_constant_entry env t)) let rec interp_tm (t : 'a coq_TM) : 'a tm = match t with @@ -291,3 +288,6 @@ let rec interp_tm (t : 'a coq_TM) : 'a tm = (function None -> Obj.magic None | Some inst -> Obj.magic (tmMap (fun x -> Some x) (tmOfConstr inst))) + +let run_vernac (c : 'a coq_TM) : unit = + Plugin_core.run_vernac (interp_tm (Obj.magic c)) diff --git a/template-coq/src/run_extractable.mli b/template-coq/src/run_extractable.mli new file mode 100644 index 000000000..28ab45e4c --- /dev/null +++ b/template-coq/src/run_extractable.mli @@ -0,0 +1,11 @@ +open Extractable +open Plugin_core +open BasicAst + +open Quoter +open Ast_quoter + + +val interp_tm : Extractable.__ coq_TM -> Extractable.__ Plugin_core.tm + +val run_vernac : 'a coq_TM -> unit From 7a7de9cb326345bb691cfb0d642621e0ca5684d0 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Mon, 8 Apr 2019 22:03:54 -0700 Subject: [PATCH 28/71] added a second phase compilation/mlpack for extraction-based plugin make in `template-coq` fully compiles make in `checker` fails --- template-coq/Makefile | 6 +- template-coq/_PluginProject | 185 +++++++++--------- template-coq/src/ast_denoter.ml | 140 +++++++++++++ template-coq/src/denote.ml | 141 ------------- .../monad_extraction.mlpack} | 2 + 5 files changed, 240 insertions(+), 234 deletions(-) create mode 100644 template-coq/src/ast_denoter.ml rename template-coq/{gen-src/meta_coq_plugin.mlpack => src/monad_extraction.mlpack} (94%) diff --git a/template-coq/Makefile b/template-coq/Makefile index df2ef0a54..0aac21161 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -1,7 +1,8 @@ all: coq -coq: Makefile.coq +coq: Makefile.coq Makefile.plugin $(MAKE) -f Makefile.coq + $(MAKE) -f Makefile.plugin .PHONY: all install html clean mrproper @@ -20,5 +21,8 @@ mrproper: clean Makefile.coq: _CoqProject coq_makefile -f _CoqProject -o Makefile.coq +Makefile.plugin: _PluginProject + coq_makefile -f _PluginProject -o Makefile.plugin + .merlin: Makefile.coq $(MAKE) -f Makefile.coq .merlin diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 996659f63..59ce957b4 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -1,95 +1,96 @@ --I gen-src +src/Ascii.ml +src/Ast0.ml +src/AstUtils.ml +src/BasicAst.ml +src/Basics.ml +src/BinInt.ml +src/BinNat.ml +src/BinNums.ml +src/BinPosDef.ml +src/BinPos.ml +src/Bool.ml +src/Checker0.ml +src/Common.ml +src/config0.ml +src/Datatypes.ml +src/DecidableType.ml +src/Decimal.ml +src/Equalities.ml +src/Extractable.ml +src/FMapWeakList.ml +src/LiftSubst.ml +src/List0.ml +src/Logic.ml +src/monad_utils.ml +src/MSetWeakList.ml +src/Nat0.ml +src/OrderedType0.ml +src/Orders.ml +src/OrdersTac.ml +src/PeanoNat.ml +src/Retyping0.ml +src/Specif.ml +src/String0.ml +src/Typing0.ml +src/TypingWf.ml +src/uGraph0.ml +src/univ0.ml +src/UnivSubst0.ml +src/utils.ml +src/Wf.ml -gen-src/Ascii.ml -gen-src/Ascii.mli -gen-src/Ast0.ml -gen-src/Ast0.mli -gen-src/AstUtils.ml -gen-src/AstUtils.mli -gen-src/BasicAst.ml -gen-src/BasicAst.mli -gen-src/Basics.ml -gen-src/Basics.mli -gen-src/BinInt.ml -gen-src/BinInt.mli -gen-src/BinNat.ml -gen-src/BinNat.mli -gen-src/BinNums.ml -gen-src/BinNums.mli -gen-src/BinPosDef.ml -gen-src/BinPosDef.mli -gen-src/BinPos.ml -gen-src/BinPos.mli -gen-src/Bool.ml -gen-src/Bool.mli -gen-src/Checker0.ml -gen-src/Checker0.mli -gen-src/Common.ml -gen-src/Common.mli -gen-src/config0.ml -gen-src/config0.mli -gen-src/Datatypes.ml -gen-src/Datatypes.mli -gen-src/DecidableType.ml -gen-src/DecidableType.mli -gen-src/Decimal.ml -gen-src/Decimal.mli -gen-src/Equalities.ml -gen-src/Equalities.mli -gen-src/Extractable.ml -gen-src/Extractable.mli -gen-src/FMapWeakList.ml -gen-src/FMapWeakList.mli -gen-src/LiftSubst.ml -gen-src/LiftSubst.mli -gen-src/List0.ml -gen-src/List0.mli -gen-src/Logic.ml -gen-src/Logic.mli -gen-src/monad_utils.ml -gen-src/monad_utils.mli -gen-src/MSetWeakList.ml -gen-src/MSetWeakList.mli -gen-src/Nat0.ml -gen-src/Nat0.mli -gen-src/OrderedType0.ml -gen-src/OrderedType0.mli -gen-src/Orders.ml -gen-src/Orders.mli -gen-src/OrdersTac.ml -gen-src/OrdersTac.mli -gen-src/PeanoNat.ml -gen-src/PeanoNat.mli -gen-src/Retyping0.ml -gen-src/Retyping0.mli -gen-src/Specif.ml -gen-src/Specif.mli -gen-src/String0.ml -gen-src/String0.mli -gen-src/Typing0.ml -gen-src/Typing0.mli -gen-src/TypingWf.ml -gen-src/TypingWf.mli -gen-src/uGraph0.ml -gen-src/uGraph0.mli -gen-src/univ0.ml -gen-src/univ0.mli -gen-src/UnivSubst0.ml -gen-src/UnivSubst0.mli -gen-src/utils.ml -gen-src/utils.mli -gen-src/Wf.ml -gen-src/Wf.mli +src/Ascii.mli +src/Ast0.mli +src/AstUtils.mli +src/BasicAst.mli +src/Basics.mli +src/BinInt.mli +src/BinNat.mli +src/BinNums.mli +src/BinPosDef.mli +src/BinPos.mli +src/Bool.mli +src/Checker0.mli +src/Common.mli +src/config0.mli +src/Datatypes.mli +src/DecidableType.mli +src/Decimal.mli +src/Equalities.mli +src/Extractable.mli +src/FMapWeakList.mli +src/LiftSubst.mli +src/List0.mli +src/Logic.mli +src/monad_utils.mli +src/MSetWeakList.mli +src/Nat0.mli +src/OrderedType0.mli +src/Orders.mli +src/OrdersTac.mli +src/PeanoNat.mli +src/Retyping0.mli +src/Specif.mli +src/String0.mli +src/Typing0.mli +src/TypingWf.mli +src/uGraph0.mli +src/univ0.mli +src/UnivSubst0.mli +src/utils.mli +src/Wf.mli -gen-src/tm_util.ml -gen-src/quoted.ml -gen-src/quoter.ml -gen-src/constr_quoter.ml -gen-src/template_monad.ml -gen-src/denoter.ml -gen-src/denote.ml -gen-src/plugin_core.ml -gen-src/ast_quoter.ml -gen-src/run_extractable.ml -gen-src/meta_coq_plugin.mlpack \ No newline at end of file +src/tm_util.ml +src/quoted.ml +src/quoter.ml +src/constr_quoter.ml +src/template_monad.ml +src/denoter.ml +src/denote.ml +src/plugin_core.ml +src/ast_quoter.ml +src/ast_denoter.ml + +src/run_extractable.ml +src/monad_extraction.mlpack \ No newline at end of file diff --git a/template-coq/src/ast_denoter.ml b/template-coq/src/ast_denoter.ml new file mode 100644 index 000000000..2255dcdef --- /dev/null +++ b/template-coq/src/ast_denoter.ml @@ -0,0 +1,140 @@ +open Constr +open BasicAst +open Ast0 +open Quoted +open Quoter +open Ast_quoter + +module ExtractionDenoter = +struct + type t = Ast0.term + type quoted_ident = char list + type quoted_int = Datatypes.nat + type quoted_bool = bool + type quoted_name = name + type quoted_sort = Univ0.universe + type quoted_cast_kind = cast_kind + type quoted_kernel_name = char list + type quoted_inductive = inductive + type quoted_proj = projection + type quoted_global_reference = global_reference + + type quoted_sort_family = sort_family + type quoted_constraint_type = Univ0.constraint_type + type quoted_univ_constraint = Univ0.univ_constraint + type quoted_univ_instance = Univ0.Instance.t + type quoted_univ_constraints = Univ0.constraints + type quoted_univ_context = Univ0.universe_context + type quoted_inductive_universes = quoted_univ_context + + type quoted_mind_params = (ident * local_entry) list + type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list + type quoted_definition_entry = t * t option * quoted_univ_context + type quoted_mind_entry = mutual_inductive_entry + type quoted_mind_finiteness = recursivity_kind + type quoted_entry = (constant_entry, quoted_mind_entry) sum option + + type quoted_context_decl = context_decl + type quoted_context = context + type quoted_one_inductive_body = one_inductive_body + type quoted_mutual_inductive_body = mutual_inductive_body + type quoted_constant_body = constant_body + type quoted_global_decl = global_decl + type quoted_global_declarations = global_declarations + type quoted_program = program + + let mkAnon = mkAnon + let mkName = mkName + let quote_kn = quote_kn + let mkRel = mkRel + let mkVar = mkVar + let mkMeta = mkMeta + let mkEvar = mkEvar + let mkSort = mkSort + let mkCast = mkCast + let mkConst = mkConst + let mkProd = mkProd + + let mkLambda = mkLambda + let mkApp = mkApp + let mkLetIn = mkLetIn + let mkFix = mkFix + let mkConstruct = mkConstruct + let mkCoFix = mkCoFix + let mkInd = mkInd + let mkCase = mkCase + let quote_proj = quote_proj + let mkProj = mkProj + let print_term (u: t) : Pp.t = Pp.str "printing not implemented" + + let unquote_def (x: 't BasicAst.def) : ('t, name, quoted_int) Quoted.adef = + { + adname=dname x; + adtype=dtype x; + adbody=dbody x; + rarg=rarg x + } + + let inspect_term (tt: t):(t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term= + match tt with + | Coq_tRel n -> ACoq_tRel n + | Coq_tVar v -> ACoq_tVar v + | Coq_tMeta n -> ACoq_tMeta n + | Coq_tEvar (x,l) -> ACoq_tEvar (x,l) + | Coq_tSort u -> ACoq_tSort u + | Coq_tCast (t,k,tt) -> ACoq_tCast (t,k,tt) + | Coq_tProd (a,b,c) -> ACoq_tProd (a,b,c) + | Coq_tLambda (a,b,c) -> ACoq_tLambda (a,b,c) + | Coq_tLetIn (a,b,c,d) -> ACoq_tLetIn (a,b,c,d) + | Coq_tApp (a,b) -> ACoq_tApp (a,b) + | Coq_tConst (a,b) -> ACoq_tConst (a,b) + | Coq_tInd (a,b) -> ACoq_tInd (a,b) + | Coq_tConstruct (a,b,c) -> ACoq_tConstruct (a,b,c) + | Coq_tCase (a,b,c,d) -> ACoq_tCase (a,b,c,d) + | Coq_tProj (a,b) -> ACoq_tProj (a,b) + | Coq_tFix (a,b) -> ACoq_tFix (List.map unquote_def a,b) + | Coq_tCoFix (a,b) -> ACoq_tCoFix (List.map unquote_def a,b) + (* + | Coq_tApp of term * term list + | Coq_tConst of kername * universe_instance + | Coq_tInd of inductive * universe_instance + | Coq_tConstruct of inductive * nat * universe_instance + | Coq_tCase of (inductive * nat) * term * term * (nat * term) list + | Coq_tProj of projection * term + | Coq_tFix of term mfixpoint * nat + | Coq_tCoFix of term mfixpoint * nat + *) + + let unquote_ident (qi: quoted_ident) : Id.t + = Ast_quoter.unquote_ident qi + + let unquote_name (qn: quoted_name) : Name.t + = Ast_quoter.unquote_name qn + + let unquote_int (q: quoted_int ) : int + = Ast_quoter.unquote_int q + + let unquote_bool (q: quoted_bool ) : bool + = Ast_quoter.unquote_bool q + + let unquote_cast_kind (q: quoted_cast_kind ) : Constr.cast_kind + = Ast_quoter.unquote_cast_kind q + + let unquote_kn (q: quoted_kernel_name ) : Libnames.qualid + = Ast_quoter.unquote_kn q + + let unquote_inductive (q: quoted_inductive ) : Names.inductive + = Ast_quoter.unquote_inductive q + + let unquote_proj (q: quoted_proj ) : (quoted_inductive * quoted_int * quoted_int) + = Ast_quoter.unquote_proj q + + let unquote_universe (q: Evd.evar_map) (qs: quoted_sort): Evd.evar_map * Univ.Universe.t + = Ast_quoter.unquote_universe q qs + + let unquote_universe_instance(q: Evd.evar_map) (qu: quoted_univ_instance): Evd.evar_map * Univ.Instance.t + = failwith "nyi" + +end + +module ExtractionDenote = Denote(ExtractionDenoter) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index 4fe6b1735..db3768783 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -525,144 +525,3 @@ end module CoqLiveDenote = Denote(CoqLiveDenoter) let denote_term=CoqLiveDenote.denote_term - -open Constr -open BasicAst -open Ast0 -open Quoted -open Quoter -open Ast_quoter - -module ExtractionDenoter = -struct - type t = Ast0.term - type quoted_ident = char list - type quoted_int = Datatypes.nat - type quoted_bool = bool - type quoted_name = name - type quoted_sort = Univ0.universe - type quoted_cast_kind = cast_kind - type quoted_kernel_name = char list - type quoted_inductive = inductive - type quoted_proj = projection - type quoted_global_reference = global_reference - - type quoted_sort_family = sort_family - type quoted_constraint_type = Univ0.constraint_type - type quoted_univ_constraint = Univ0.univ_constraint - type quoted_univ_instance = Univ0.Instance.t - type quoted_univ_constraints = Univ0.constraints - type quoted_univ_context = Univ0.universe_context - type quoted_inductive_universes = quoted_univ_context - - type quoted_mind_params = (ident * local_entry) list - type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list - type quoted_definition_entry = t * t option * quoted_univ_context - type quoted_mind_entry = mutual_inductive_entry - type quoted_mind_finiteness = recursivity_kind - type quoted_entry = (constant_entry, quoted_mind_entry) sum option - - type quoted_context_decl = context_decl - type quoted_context = context - type quoted_one_inductive_body = one_inductive_body - type quoted_mutual_inductive_body = mutual_inductive_body - type quoted_constant_body = constant_body - type quoted_global_decl = global_decl - type quoted_global_declarations = global_declarations - type quoted_program = program - - let mkAnon = mkAnon - let mkName = mkName - let quote_kn = quote_kn - let mkRel = mkRel - let mkVar = mkVar - let mkMeta = mkMeta - let mkEvar = mkEvar - let mkSort = mkSort - let mkCast = mkCast - let mkConst = mkConst - let mkProd = mkProd - - let mkLambda = mkLambda - let mkApp = mkApp - let mkLetIn = mkLetIn - let mkFix = mkFix - let mkConstruct = mkConstruct - let mkCoFix = mkCoFix - let mkInd = mkInd - let mkCase = mkCase - let quote_proj = quote_proj - let mkProj = mkProj - let print_term (u: t) : Pp.t = Pp.str "printing not implemented" - - let unquote_def (x: 't BasicAst.def) : ('t, name, quoted_int) Quoted.adef = - { - adname=dname x; - adtype=dtype x; - adbody=dbody x; - rarg=rarg x - } - - let inspect_term (tt: t):(t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term= - match tt with - | Coq_tRel n -> ACoq_tRel n - | Coq_tVar v -> ACoq_tVar v - | Coq_tMeta n -> ACoq_tMeta n - | Coq_tEvar (x,l) -> ACoq_tEvar (x,l) - | Coq_tSort u -> ACoq_tSort u - | Coq_tCast (t,k,tt) -> ACoq_tCast (t,k,tt) - | Coq_tProd (a,b,c) -> ACoq_tProd (a,b,c) - | Coq_tLambda (a,b,c) -> ACoq_tLambda (a,b,c) - | Coq_tLetIn (a,b,c,d) -> ACoq_tLetIn (a,b,c,d) - | Coq_tApp (a,b) -> ACoq_tApp (a,b) - | Coq_tConst (a,b) -> ACoq_tConst (a,b) - | Coq_tInd (a,b) -> ACoq_tInd (a,b) - | Coq_tConstruct (a,b,c) -> ACoq_tConstruct (a,b,c) - | Coq_tCase (a,b,c,d) -> ACoq_tCase (a,b,c,d) - | Coq_tProj (a,b) -> ACoq_tProj (a,b) - | Coq_tFix (a,b) -> ACoq_tFix (List.map unquote_def a,b) - | Coq_tCoFix (a,b) -> ACoq_tCoFix (List.map unquote_def a,b) - (* - | Coq_tApp of term * term list - | Coq_tConst of kername * universe_instance - | Coq_tInd of inductive * universe_instance - | Coq_tConstruct of inductive * nat * universe_instance - | Coq_tCase of (inductive * nat) * term * term * (nat * term) list - | Coq_tProj of projection * term - | Coq_tFix of term mfixpoint * nat - | Coq_tCoFix of term mfixpoint * nat - *) - - let unquote_ident (qi: quoted_ident) : Id.t - = Ast_quoter.unquote_ident qi - - let unquote_name (qn: quoted_name) : Name.t - = Ast_quoter.unquote_name qn - - let unquote_int (q: quoted_int ) : int - = Ast_quoter.unquote_int q - - let unquote_bool (q: quoted_bool ) : bool - = Ast_quoter.unquote_bool q - - let unquote_cast_kind (q: quoted_cast_kind ) : Constr.cast_kind - = Ast_quoter.unquote_cast_kind q - - let unquote_kn (q: quoted_kernel_name ) : Libnames.qualid - = Ast_quoter.unquote_kn q - - let unquote_inductive (q: quoted_inductive ) : Names.inductive - = Ast_quoter.unquote_inductive q - - let unquote_proj (q: quoted_proj ) : (quoted_inductive * quoted_int * quoted_int) - = Ast_quoter.unquote_proj q - - let unquote_universe (q: Evd.evar_map) (qs: quoted_sort): Evd.evar_map * Univ.Universe.t - = Ast_quoter.unquote_universe q qs - - let unquote_universe_instance(q: Evd.evar_map) (qu: quoted_univ_instance): Evd.evar_map * Univ.Instance.t - = failwith "nyi" - -end - -module ExtractionDenote = Denote(ExtractionDenoter) diff --git a/template-coq/gen-src/meta_coq_plugin.mlpack b/template-coq/src/monad_extraction.mlpack similarity index 94% rename from template-coq/gen-src/meta_coq_plugin.mlpack rename to template-coq/src/monad_extraction.mlpack index 62b285d4d..153ad83e5 100644 --- a/template-coq/gen-src/meta_coq_plugin.mlpack +++ b/template-coq/src/monad_extraction.mlpack @@ -40,8 +40,10 @@ Quoter Constr_quoter Template_monad Denote +Denoter Plugin_core Ast_quoter +Ast_denoter Extractable From 3c9df845eea51afa2e35ba89857d9ba1c101fdaa Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Tue, 9 Apr 2019 06:50:34 -0700 Subject: [PATCH 29/71] .o files seem to be building now for _PluginProject --- template-coq/_PluginProject | 3 +++ 1 file changed, 3 insertions(+) diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 59ce957b4..3d6540fa7 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -1,3 +1,6 @@ +-I src +-R theories Template + src/Ascii.ml src/Ast0.ml src/AstUtils.ml From 32b38f06c39a2d200267f77fec1fd11730444694 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 10:13:50 -0400 Subject: [PATCH 30/71] making the template-coq directory compile. --- template-coq/_CoqProject | 4 ++-- template-coq/_PluginProject | 7 ++++++- template-coq/src/ast_denoter.ml | 21 +++++++++++---------- template-coq/src/denote.mli | 19 ------------------- 4 files changed, 19 insertions(+), 32 deletions(-) delete mode 100644 template-coq/src/denote.mli diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index 8671a977f..4a87af161 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -8,9 +8,9 @@ src/quoted.ml src/quoter.ml # src/constr_quoter.mli src/constr_quoter.ml -src/ast_quoter.ml +# src/ast_quoter.ml src/denoter.ml -src/denote.mli +# src/denote.mli src/denote.ml # src/g_template_coq.mli src/g_template_coq.ml4 diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 59ce957b4..5d5490728 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -1,3 +1,6 @@ +-I src +-R theories Template + src/Ascii.ml src/Ast0.ml src/AstUtils.ml @@ -93,4 +96,6 @@ src/ast_quoter.ml src/ast_denoter.ml src/run_extractable.ml -src/monad_extraction.mlpack \ No newline at end of file +src/run_extractable.mli + +# src/monad_extraction.mlpack \ No newline at end of file diff --git a/template-coq/src/ast_denoter.ml b/template-coq/src/ast_denoter.ml index 2255dcdef..79a3433da 100644 --- a/template-coq/src/ast_denoter.ml +++ b/template-coq/src/ast_denoter.ml @@ -1,3 +1,4 @@ +open Names open Constr open BasicAst open Ast0 @@ -50,11 +51,11 @@ struct let mkVar = mkVar let mkMeta = mkMeta let mkEvar = mkEvar - let mkSort = mkSort + let mkSort = mkSort let mkCast = mkCast let mkConst = mkConst let mkProd = mkProd - + let mkLambda = mkLambda let mkApp = mkApp let mkLetIn = mkLetIn @@ -109,14 +110,14 @@ struct = Ast_quoter.unquote_ident qi let unquote_name (qn: quoted_name) : Name.t - = Ast_quoter.unquote_name qn - - let unquote_int (q: quoted_int ) : int + = Ast_quoter.unquote_name qn + + let unquote_int (q: quoted_int) : int = Ast_quoter.unquote_int q - let unquote_bool (q: quoted_bool ) : bool + let unquote_bool (q: quoted_bool) : bool = Ast_quoter.unquote_bool q - + let unquote_cast_kind (q: quoted_cast_kind ) : Constr.cast_kind = Ast_quoter.unquote_cast_kind q @@ -130,11 +131,11 @@ struct = Ast_quoter.unquote_proj q let unquote_universe (q: Evd.evar_map) (qs: quoted_sort): Evd.evar_map * Univ.Universe.t - = Ast_quoter.unquote_universe q qs + = Ast_quoter.unquote_universe q qs let unquote_universe_instance(q: Evd.evar_map) (qu: quoted_univ_instance): Evd.evar_map * Univ.Instance.t = failwith "nyi" - + end -module ExtractionDenote = Denote(ExtractionDenoter) +module ExtractionDenote = Denote.Denote(ExtractionDenoter) diff --git a/template-coq/src/denote.mli b/template-coq/src/denote.mli deleted file mode 100644 index 7f6dc0655..000000000 --- a/template-coq/src/denote.mli +++ /dev/null @@ -1,19 +0,0 @@ -val unquote_pair : Constr.t -> Constr.t * Constr.t - -val unquote_list : Constr.t -> Constr.t list - -val unquote_bool : Constr.t -> bool - -val unquote_ident : Constr.t -> Names.Id.t - -val unquote_string : Constr.t -> string - -(* ^^ above this is completely generic *) - -val unquote_level : Evd.evar_map -> Constr.constr -> Evd.evar_map * Univ.Level.t - -val unquote_universe_instance : Evd.evar_map -> Constr.constr -> Evd.evar_map * Univ.Instance.t - -val map_evm : ('a -> 'b -> 'a * 'c) -> 'a -> 'b list -> 'a * 'c list - -val denote_term : Evd.evar_map -> Constr.t -> Evd.evar_map * Constr.t From dc9c3d7f0059f2d189948d7196540be538b86397 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 10:33:43 -0400 Subject: [PATCH 31/71] a plugin that works! --- plugin-demo/_CoqProject | 1 + plugin-demo/test/test.v | 4 ++++ plugin-demo/theories/Demo.v | 1 + template-coq/src/run_extractable.ml | 12 ++++++------ 4 files changed, 12 insertions(+), 6 deletions(-) create mode 100644 plugin-demo/test/test.v diff --git a/plugin-demo/_CoqProject b/plugin-demo/_CoqProject index 950c34870..7830acfa5 100644 --- a/plugin-demo/_CoqProject +++ b/plugin-demo/_CoqProject @@ -1,3 +1,4 @@ +-Q ../template-coq/theories Template -I src -Q theories Demo diff --git a/plugin-demo/test/test.v b/plugin-demo/test/test.v new file mode 100644 index 000000000..6991415ab --- /dev/null +++ b/plugin-demo/test/test.v @@ -0,0 +1,4 @@ +Require Import Demo.Demo. + + +Showoff. \ No newline at end of file diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index fd2a76121..c8ca12abd 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -1,2 +1,3 @@ +Require Import Template.Ast Template.TemplateMonad.Extractable. Require Import Coq.Strings.String. Declare ML Module "demo_plugin". diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 365d17739..4caa4a00a 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -9,8 +9,8 @@ open Ast_quoter let of_constr (env : Environ.env) (t : Constr.t) : Ast0.term = Ast_quoter.quote_term env t -let to_string (cl : char list) : string = - failwith "to_string" +let to_string : char list -> string = + Ast_quoter.unquote_string let of_string : string -> char list = Ast_quoter.quote_string @@ -18,8 +18,8 @@ let of_string : string -> char list = let to_reduction_strategy (s : Common.reductionStrategy) = failwith "to_reduction_strategy" -let to_ident : char list -> Names.Id.t = - failwith "to_ident" +let to_ident : char list -> Names.Id.t = + Ast_quoter.unquote_ident let of_ident (id : Names.Id.t) : char list = of_string (Names.Id.to_string id) @@ -36,7 +36,7 @@ let of_qualid (q : Libnames.qualid) : char list = let of_kername : Names.KerName.t -> char list = Ast_quoter.quote_kn -let to_kername : char list -> Names.KerName.t = +let to_kername (s : char list) : Names.KerName.t = failwith "of_kername" (* todo(gmm): this definition adapted from quoter.ml *) @@ -114,7 +114,7 @@ let of_mib (env : Environ.env) (mib : Plugin_core.mutual_inductive_body) : Ast0. let bodies = List.map Ast_quoter.mk_one_inductive_body (List.rev ls) in Ast_quoter.mk_mutual_inductive_body nparams paramsctx bodies uctx -let to_mie : _ -> Plugin_core.mutual_inductive_entry = +let to_mie x : Plugin_core.mutual_inductive_entry = failwith "to_mie" (* note(gmm): code taken from quoter.ml (quote_entry_aux) *) From 83ed27b7132c2b57b7d166ae87fdaa450247b275 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Tue, 9 Apr 2019 08:58:18 -0700 Subject: [PATCH 32/71] implemented Ast_denoter.unquote_universe_instance --- movefiles.sh | 2 +- template-coq/src/ast_denoter.ml | 5 +++-- template-coq/src/ast_quoter.ml | 1 + 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/movefiles.sh b/movefiles.sh index 3eda25690..c0f7b1c5e 100755 --- a/movefiles.sh +++ b/movefiles.sh @@ -7,5 +7,5 @@ shopt -s nullglob # make the for loop do nothnig when there is no *.ml* files for i in *.ml*; do j=`echo $i | cut -b 1 | tr '[:upper:]' '[:lower:]'`; # the first letter of file name is put in lowercase k=`echo $i | cut -b 2-`; # the rest is untouched - mv $i ../plugin-demo/mc-src/$j$k; + mv $i ../checker/src/$j$k; done diff --git a/template-coq/src/ast_denoter.ml b/template-coq/src/ast_denoter.ml index 79a3433da..73017b105 100644 --- a/template-coq/src/ast_denoter.ml +++ b/template-coq/src/ast_denoter.ml @@ -133,8 +133,9 @@ struct let unquote_universe (q: Evd.evar_map) (qs: quoted_sort): Evd.evar_map * Univ.Universe.t = Ast_quoter.unquote_universe q qs - let unquote_universe_instance(q: Evd.evar_map) (qu: quoted_univ_instance): Evd.evar_map * Univ.Instance.t - = failwith "nyi" + let unquote_universe_instance(evm: Evd.evar_map) (l: quoted_univ_instance): Evd.evar_map * Univ.Instance.t + = (evm, Univ.Instance.of_array (Array.of_list (List0.map unquote_level l))) + end diff --git a/template-coq/src/ast_quoter.ml b/template-coq/src/ast_quoter.ml index d9a099492..769c0dbc9 100644 --- a/template-coq/src/ast_quoter.ml +++ b/template-coq/src/ast_quoter.ml @@ -354,6 +354,7 @@ struct let dp = DirPath.make (List.map Id.of_string comps) in let idx = int_of_string last in Univ.Level.make dp idx + (* should this level be added to the environment. Denote.unquote_level does that *) | Univ0.Level.Var n -> Univ.Level.var (unquote_int n) let unquote_level_expr (trm : Univ0.Level.t) (b : quoted_bool) : Univ.Universe.t = From 760fc80c171b20bc761eefa12ae5efaaaaecd873 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Tue, 9 Apr 2019 09:57:26 -0700 Subject: [PATCH 33/71] implemented to_constr_ev and unquote reduction strategy --- template-coq/src/run_extractable.ml | 91 ++++------------------------- 1 file changed, 12 insertions(+), 79 deletions(-) diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 4caa4a00a..f00da3c29 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -15,8 +15,14 @@ let to_string : char list -> string = let of_string : string -> char list = Ast_quoter.quote_string -let to_reduction_strategy (s : Common.reductionStrategy) = - failwith "to_reduction_strategy" +let to_reduction_strategy (s : Common.reductionStrategy) : Plugin_core.reduction_strategy = + match s with + | Common.Coq_cbv -> Plugin_core.rs_cbv + | Common.Coq_cbn -> Plugin_core.rs_cbn + | Common.Coq_hnf -> Plugin_core.rs_hnf + | Common.Coq_all -> Plugin_core.rs_all + | Common.Coq_lazy -> Plugin_core.rs_lazy + | Common.Coq_unfold x -> failwith "not yet implemented: to_reduction_strategy" let to_ident : char list -> Names.Id.t = Ast_quoter.unquote_ident @@ -37,7 +43,7 @@ let of_kername : Names.KerName.t -> char list = Ast_quoter.quote_kn let to_kername (s : char list) : Names.KerName.t = - failwith "of_kername" + (* Ast_quoter.unquote_kn c *) failwith "to_kername" (* todo(gmm): this definition adapted from quoter.ml *) let quote_rel_decl env = function @@ -144,84 +150,11 @@ let of_cast_kind (ck: BasicAst.cast_kind) : Constr.cast_kind = | Cast -> Constr.DEFAULTcast | RevertCast -> Constr.REVERTcast - +open Ast_denoter (* todo(gmm): determine what of these already exist. *) let rec to_constr_ev (evm : Evd.evar_map) (t : Ast0.term) : Evd.evar_map * Constr.t = - failwith "to_constr_ev" (* - match t with - | Coq_tRel x -> evm, Constr.mkRel (of_nat x + 1) - | Coq_tVar x -> evm, Constr.mkVar (to_ident x) - | Coq_tCast (t,c,ty) -> let evm, t = to_constr_ev evm t in - let evm, ty = to_constr_ev evm ty in - evm, Constr.mkCast (t, of_cast_kind c, ty) - (* the next case is quite complex: look at Denote.unquote_universe *) - | Coq_tSort u -> evm, Constr.mkType u - | Coq_tProd (n,t,b) -> let evm, t = aux evm t in - let evm, b = aux evm b in - evm, Constr.mkProd (unquote_name n, t, b) - | Coq_tLambda (n,t,b) -> let evm, t = aux evm t in - let evm, b = aux evm b in - evm, Constr.mkLambda (unquote_name n, t, b) - | Coq_tLetIn (n,e,t,b) -> let evm, e = aux evm e in - let evm, t = aux evm t in - let evm, b = aux evm b in - evm, Constr.mkLetIn (unquote_name n, e, t, b) - | Coq_tApp (f,xs) -> let evm, f = aux evm f in - let evm, xs = map_evm aux evm xs in - evm, Constr.mkApp (f, Array.of_list xs) - | Coq_tConst (s,u) -> - let s = unquote_kn s in - let evm, u = unquote_universe_instance evm u in - (try - match Nametab.locate s with - | Globnames.ConstRef c -> evm, Constr.mkConstU (c, u) - | Globnames.IndRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is an inductive, use tInd.") - | Globnames.VarRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is a variable, use tVar.") - | Globnames.ConstructRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is a constructor, use tConstructor.") - with - Not_found -> CErrors.user_err (str"Constant not found: " ++ Libnames.pr_qualid s)) - | Coq_tConstruct (i,idx,u) -> - let ind = unquote_inductive i in - let evm, u = unquote_universe_instance evm u in - evm, Constr.mkConstructU ((ind, unquote_nat idx + 1), u) - | Coq_tInd (i, u) -> - let i = unquote_inductive i in - let evm, u = unquote_universe_instance evm u in - evm, Constr.mkIndU (i, u) - | Coq_tCase ((i, _), ty, d, brs) -> - let ind = unquote_inductive i in - let evm, ty = aux evm ty in - let evm, d = aux evm d in - let evm, brs = map_evm aux evm (List.map snd brs) in - (* todo: reify better case_info *) - let ci = Inductiveops.make_case_info (Global.env ()) ind Constr.RegularStyle in - evm, Constr.mkCase (ci, ty, d, Array.of_list brs) - | Coq_tFix (lbd, i) -> - let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, - List.map (fun p->p.rarg) lbd) in - let evm, types = map_evm aux evm types in - let evm, bodies = map_evm aux evm bodies in - let (names,rargs) = (List.map unquote_name names, List.map unquote_nat rargs) in - let la = Array.of_list in - evm, Constr.mkFix ((la rargs,unquote_nat i), (la names, la types, la bodies)) - | Coq_tCoFix (lbd, i) -> - let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, - List.map (fun p->p.rarg) lbd) in - let evm, types = map_evm aux evm types in - let evm, bodies = map_evm aux evm bodies in - let (names,rargs) = (List.map unquote_name names, List.map unquote_nat rargs) in - let la = Array.of_list in - evm, Constr.mkCoFix (unquote_nat i, (la names, la types, la bodies)) - | Coq_tProj (proj,t) -> - let (ind, _, narg) = unquote_proj proj in (* todo: is narg the correct projection? *) - let ind' = unquote_inductive ind in - let projs = Recordops.lookup_projections ind' in - let evm, t = aux evm t in - (match List.nth projs (unquote_nat narg) with - | Some p -> evm, Constr.mkProj (Names.Projection.make p false, t) - | None -> bad_term trm) - | _ -> not_supported_verb trm "big_case" -*) + ExtractionDenote.denote_term evm t + let to_constr (t : Ast0.term) : Constr.t = snd (to_constr_ev Evd.empty t) From dceb9756dd25ae6526924db111484a7e882724ea Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 15:43:31 -0400 Subject: [PATCH 34/71] now template-coq builds --- template-coq/Makefile | 17 +- template-coq/_CoqProject | 10 +- template-coq/_PluginProject | 174 +++-- template-coq/gen-src/.gitignore | 3 +- .../gen-src/meta_coq_plugin_template.mlpack | 44 ++ template-coq/src/ast_quoter.ml | 30 +- template-coq/src/constr_denoter.ml | 325 ++++++++++ template-coq/src/constr_quoted.ml | 606 ++++++++++++++++++ template-coq/src/constr_quoter.ml | 178 +---- template-coq/src/denote.ml | 584 +++-------------- template-coq/src/g_template_coq.ml4 | 8 +- template-coq/src/quoted.ml | 19 + template-coq/src/quoter.ml | 25 +- template-coq/src/run_extractable.ml | 6 +- template-coq/src/run_template_monad.ml | 20 +- template-coq/src/template_coq.mlpack | 5 +- template-coq/src/template_monad.ml | 1 + template-coq/src/tm_util.ml | 33 + template-coq/theories/Extraction.v | 9 +- 19 files changed, 1250 insertions(+), 847 deletions(-) create mode 100644 template-coq/gen-src/meta_coq_plugin_template.mlpack create mode 100644 template-coq/src/constr_denoter.ml create mode 100644 template-coq/src/constr_quoted.ml diff --git a/template-coq/Makefile b/template-coq/Makefile index 0aac21161..149627030 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -1,10 +1,19 @@ -all: coq +all: coq plugin -coq: Makefile.coq Makefile.plugin +coq: Makefile.coq $(MAKE) -f Makefile.coq + +plugin: coq Makefile.plugin gen-src/.generate + @ echo "Copying from src to gen-src" + @ for x in $(TOCOPY); do rm -f gen-src/$$x; ln -s ../src/$$x gen-src/$$x; done $(MAKE) -f Makefile.plugin -.PHONY: all install html clean mrproper +gen-src/.generate: theories/Extraction.vo theories/Extraction.v + coqc -Q theories Template theories/Extraction.v + @ touch gen-src/.generate + + +.PHONY: all install html clean mrproper plugin coq install: Makefile.coq $(MAKE) -f Makefile.coq install @@ -26,3 +35,5 @@ Makefile.plugin: _PluginProject .merlin: Makefile.coq $(MAKE) -f Makefile.coq .merlin + +TOCOPY=ast_denoter.ml ast_quoter.ml denote.ml denoter.ml plugin_core.ml plugin_core.mli quoted.ml quoter.ml run_extractable.ml run_extractable.mli run_template_monad.mli tm_util.ml diff --git a/template-coq/_CoqProject b/template-coq/_CoqProject index 4a87af161..26084f0d8 100644 --- a/template-coq/_CoqProject +++ b/template-coq/_CoqProject @@ -3,16 +3,16 @@ # the MetaCoq plugin src/tm_util.ml + src/quoted.ml -# src/quoter.mli src/quoter.ml -# src/constr_quoter.mli +src/constr_quoted.ml src/constr_quoter.ml -# src/ast_quoter.ml + src/denoter.ml -# src/denote.mli src/denote.ml -# src/g_template_coq.mli +src/constr_denoter.ml + src/g_template_coq.ml4 src/template_coq.mlpack src/template_monad.ml diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 5d5490728..322c1976a 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -1,101 +1,83 @@ --I src --R theories Template +-I gen-src -src/Ascii.ml -src/Ast0.ml -src/AstUtils.ml -src/BasicAst.ml -src/Basics.ml -src/BinInt.ml -src/BinNat.ml -src/BinNums.ml -src/BinPosDef.ml -src/BinPos.ml -src/Bool.ml -src/Checker0.ml -src/Common.ml -src/config0.ml -src/Datatypes.ml -src/DecidableType.ml -src/Decimal.ml -src/Equalities.ml -src/Extractable.ml -src/FMapWeakList.ml -src/LiftSubst.ml -src/List0.ml -src/Logic.ml -src/monad_utils.ml -src/MSetWeakList.ml -src/Nat0.ml -src/OrderedType0.ml -src/Orders.ml -src/OrdersTac.ml -src/PeanoNat.ml -src/Retyping0.ml -src/Specif.ml -src/String0.ml -src/Typing0.ml -src/TypingWf.ml -src/uGraph0.ml -src/univ0.ml -src/UnivSubst0.ml -src/utils.ml -src/Wf.ml +# Generated Code +gen-src/Ascii.ml +gen-src/Ascii.mli +gen-src/Ast0.ml +gen-src/Ast0.mli +gen-src/AstUtils.ml +gen-src/AstUtils.mli +gen-src/BasicAst.ml +gen-src/BasicAst.mli +gen-src/Basics.ml +gen-src/Basics.mli +gen-src/BinInt.ml +gen-src/BinInt.mli +gen-src/BinNat.ml +gen-src/BinNat.mli +gen-src/BinNums.ml +gen-src/BinNums.mli +gen-src/BinPosDef.ml +gen-src/BinPosDef.mli +gen-src/BinPos.ml +gen-src/BinPos.mli +gen-src/Bool.ml +gen-src/Bool.mli +gen-src/Common.ml +gen-src/Common.mli +gen-src/config0.ml +gen-src/config0.mli +gen-src/Datatypes.ml +gen-src/Datatypes.mli +gen-src/DecidableType.ml +gen-src/DecidableType.mli +gen-src/Decimal.ml +gen-src/Decimal.mli +gen-src/Equalities.ml +gen-src/Equalities.mli +gen-src/Extractable.ml +gen-src/Extractable.mli +gen-src/FMapWeakList.ml +gen-src/FMapWeakList.mli +gen-src/List0.ml +gen-src/List0.mli +gen-src/Logic.ml +gen-src/Logic.mli +gen-src/MSetWeakList.ml +gen-src/MSetWeakList.mli +gen-src/Nat0.ml +gen-src/Nat0.mli +gen-src/OrderedType0.ml +gen-src/OrderedType0.mli +gen-src/Orders.ml +gen-src/Orders.mli +gen-src/OrdersTac.ml +gen-src/OrdersTac.mli +gen-src/PeanoNat.ml +gen-src/PeanoNat.mli +gen-src/Specif.ml +gen-src/Specif.mli +gen-src/String0.ml +gen-src/String0.mli +gen-src/uGraph0.ml +gen-src/uGraph0.mli +gen-src/univ0.ml +gen-src/univ0.mli +gen-src/utils.ml +gen-src/utils.mli -src/Ascii.mli -src/Ast0.mli -src/AstUtils.mli -src/BasicAst.mli -src/Basics.mli -src/BinInt.mli -src/BinNat.mli -src/BinNums.mli -src/BinPosDef.mli -src/BinPos.mli -src/Bool.mli -src/Checker0.mli -src/Common.mli -src/config0.mli -src/Datatypes.mli -src/DecidableType.mli -src/Decimal.mli -src/Equalities.mli -src/Extractable.mli -src/FMapWeakList.mli -src/LiftSubst.mli -src/List0.mli -src/Logic.mli -src/monad_utils.mli -src/MSetWeakList.mli -src/Nat0.mli -src/OrderedType0.mli -src/Orders.mli -src/OrdersTac.mli -src/PeanoNat.mli -src/Retyping0.mli -src/Specif.mli -src/String0.mli -src/Typing0.mli -src/TypingWf.mli -src/uGraph0.mli -src/univ0.mli -src/UnivSubst0.mli -src/utils.mli -src/Wf.mli +gen-src/tm_util.ml +gen-src/quoted.ml +gen-src/quoter.ml +gen-src/denoter.ml +gen-src/denote.ml +gen-src/plugin_core.ml +gen-src/plugin_core.mli +gen-src/ast_quoter.ml +gen-src/ast_denoter.ml -src/tm_util.ml -src/quoted.ml -src/quoter.ml -src/constr_quoter.ml -src/template_monad.ml -src/denoter.ml -src/denote.ml -src/plugin_core.ml -src/ast_quoter.ml -src/ast_denoter.ml +gen-src/run_extractable.ml +gen-src/run_extractable.mli -src/run_extractable.ml -src/run_extractable.mli - -# src/monad_extraction.mlpack \ No newline at end of file +gen-src/meta_coq_plugin_template.mlpack \ No newline at end of file diff --git a/template-coq/gen-src/.gitignore b/template-coq/gen-src/.gitignore index d3646e2a9..a8e0efef5 100644 --- a/template-coq/gen-src/.gitignore +++ b/template-coq/gen-src/.gitignore @@ -1,2 +1,3 @@ *.mli -*.ml \ No newline at end of file +*.ml +.generate \ No newline at end of file diff --git a/template-coq/gen-src/meta_coq_plugin_template.mlpack b/template-coq/gen-src/meta_coq_plugin_template.mlpack new file mode 100644 index 000000000..1ae3ffd88 --- /dev/null +++ b/template-coq/gen-src/meta_coq_plugin_template.mlpack @@ -0,0 +1,44 @@ +Datatypes +Utils +Basics +BinInt +BinNat +BinNums +BinPosDef +BinPos +Bool +Ascii +Ast0 +AstUtils +BasicAst +Common +Config0 + +Univ0 +DecidableType +Decimal +Denote +Denoter +Equalities +Extractable +FMapWeakList +List0 +Logic +MSetWeakList +Nat0 +OrderedType0 +Orders +OrdersTac +PeanoNat +Specif +String0 +UGraph0 + + +Tm_util +Quoted +Quoter +Ast_quoter +Ast_denoter +Plugin_core +Run_extractable diff --git a/template-coq/src/ast_quoter.ml b/template-coq/src/ast_quoter.ml index 769c0dbc9..240a95535 100644 --- a/template-coq/src/ast_quoter.ml +++ b/template-coq/src/ast_quoter.ml @@ -7,22 +7,6 @@ open Ast0 open Quoted open Quoter -let quote_string s = - let rec aux acc i = - if i < 0 then acc - else aux (s.[i] :: acc) (i - 1) - in aux [] (String.length s - 1) - -let unquote_string l = - let buf = Bytes.create (List.length l) in - let rec aux i = function - | [] -> () - | c :: cs -> - Bytes.set buf i c; aux (succ i) cs - in - aux 0 l; - Bytes.to_string buf - module TemplateASTQuoter = struct type t = Ast0.term @@ -64,7 +48,7 @@ struct open Names let quote_ident id = - quote_string (Id.to_string id) + string_to_list (Id.to_string id) let quote_name = function | Anonymous -> Coq_nAnon @@ -83,7 +67,7 @@ struct else if Univ.Level.is_set l then Univ0.Level.set else match Univ.Level.var_index l with | Some x -> Univ0.Level.Var (quote_int x) - | None -> Univ0.Level.Level (quote_string (Univ.Level.to_string l)) + | None -> Univ0.Level.Level (string_to_list (Univ.Level.to_string l)) let quote_universe s : Univ0.universe = (* hack because we can't recover the list of level*int *) @@ -110,7 +94,7 @@ struct | NATIVEcast -> NativeCast | VMcast -> VmCast - let quote_kn kn = quote_string (KerName.to_string kn) + let quote_kn kn = string_to_list (KerName.to_string kn) let quote_inductive (kn, i) = { inductive_mind = kn ; inductive_ind = i } let quote_proj ind p a = ((ind,p),a) @@ -301,7 +285,7 @@ struct let unquote_ident (qi: quoted_ident) : Id.t = - let s = unquote_string qi in + let s = list_to_string qi in Id.of_string s let unquote_name (q: quoted_name) : Name.t = @@ -326,12 +310,12 @@ struct | RevertCast -> REVERTcast let unquote_kn (q: quoted_kernel_name) : Libnames.qualid = - let s = unquote_string q in + let s = list_to_string q in Libnames.qualid_of_string s let unquote_inductive (q: quoted_inductive) : Names.inductive = let { inductive_mind = na; inductive_ind = i } = q in - let comps = CString.split '.' (unquote_string na) in + let comps = CString.split '.' (list_to_string na) in let comps = List.map Id.of_string comps in let id, dp = CList.sep_last comps in let dp = DirPath.make dp in @@ -348,7 +332,7 @@ struct | Univ0.Level.Coq_lProp -> Univ.Level.prop | Univ0.Level.Coq_lSet -> Univ.Level.set | Univ0.Level.Level s -> - let s = unquote_string s in + let s = list_to_string s in let comps = CString.split '.' s in let last, dp = CList.sep_last comps in let dp = DirPath.make (List.map Id.of_string comps) in diff --git a/template-coq/src/constr_denoter.ml b/template-coq/src/constr_denoter.ml new file mode 100644 index 000000000..452701182 --- /dev/null +++ b/template-coq/src/constr_denoter.ml @@ -0,0 +1,325 @@ +open Pp +open Names +open Univ +open Tm_util +open Quoted +open Denote +open Denoter +open Constr_quoted +open Constr_quoter (* the things in here that are common should be pulled out *) + + + +(* If strict unquote universe mode is on then fail when unquoting a non *) +(* declared universe / an empty list of level expressions. *) +(* Otherwise, add it / a fresh level the global environnment. *) + + +let _ = + let open Goptions in + declare_bool_option + { optdepr = false; + optname = "strict unquote universe mode"; + optkey = ["Strict"; "Unquote"; "Universe"; "Mode"]; + optread = (fun () -> !strict_unquote_universe_mode); + optwrite = (fun b -> strict_unquote_universe_mode := b) } + + +module CoqLiveDenoter = +struct + include ConstrQuoted + + type quoted_reduction_strategy = Constr.t (* of type Ast.reductionStrategy *) + + + let unquote_ident trm = + Names.Id.of_string (unquote_string trm) + + let unquote_cast_kind trm = + if Constr.equal trm kVmCast then + Constr.VMcast + else if Constr.equal trm kCast then + Constr.DEFAULTcast + else if Constr.equal trm kRevertCast then + Constr.REVERTcast + else if Constr.equal trm kNative then + Constr.VMcast + else + not_supported_verb trm "unquote_cast_kind" + + let unquote_name trm = + let (h,args) = app_full trm [] in + if Constr.equal h nAnon then + Names.Anonymous + else if Constr.equal h nNamed then + match args with + n :: [] -> Names.Name (unquote_ident n) + | _ -> bad_term_verb trm "unquote_name" + else + not_supported_verb trm "unquote_name" + + let get_level evm s = + if CString.string_contains ~where:s ~what:"." then + match List.rev (CString.split '.' s) with + | [] -> CErrors.anomaly (str"Invalid universe name " ++ str s ++ str".") + | n :: dp -> + let num = int_of_string n in + let dp = DirPath.make (List.map Id.of_string dp) in + let l = Univ.Level.make dp num in + try + let evm = Evd.add_global_univ evm l in + if !strict_unquote_universe_mode then + CErrors.user_err ~hdr:"unquote_level" (str ("Level "^s^" is not a declared level and you are in Strict Unquote Universe Mode.")) + else (Feedback.msg_info (str"Fresh universe " ++ Level.pr l ++ str" was added to the context."); + evm, l) + with + | UGraph.AlreadyDeclared -> evm, l + else + try + evm, Evd.universe_of_name evm (Id.of_string s) + with Not_found -> + try + let univ, k = Nametab.locate_universe (Libnames.qualid_of_string s) in + evm, Univ.Level.make univ k + with Not_found -> + CErrors.user_err ~hdr:"unquote_level" (str ("Level "^s^" is not a declared level.")) + + + + + + let unquote_level evm trm (* of type level *) : Evd.evar_map * Univ.Level.t = + let (h,args) = app_full trm [] in + if Constr.equal h lProp then + match args with + | [] -> evm, Univ.Level.prop + | _ -> bad_term_verb trm "unquote_level" + else if Constr.equal h lSet then + match args with + | [] -> evm, Univ.Level.set + | _ -> bad_term_verb trm "unquote_level" + else if Constr.equal h tLevel then + match args with + | s :: [] -> debug (fun () -> str "Unquoting level " ++ pr_constr trm); + get_level evm (unquote_string s) + | _ -> bad_term_verb trm "unquote_level" + else if Constr.equal h tLevelVar then + match args with + | l :: [] -> evm, Univ.Level.var (unquote_nat l) + | _ -> bad_term_verb trm "unquote_level" + else + not_supported_verb trm "unquote_level" + + let unquote_level_expr evm trm (* of type level *) b (* of type bool *) : Evd.evar_map * Univ.Universe.t = + let evm, l = unquote_level evm trm in + let u = Univ.Universe.make l in + evm, if unquote_bool b then Univ.Universe.super u else u + + + let unquote_universe evm trm (* of type universe *) = + let levels = List.map unquote_pair (unquote_list trm) in + match levels with + | [] -> if !strict_unquote_universe_mode then + CErrors.user_err ~hdr:"unquote_universe" (str "It is not possible to unquote an empty universe in Strict Unquote Universe Mode.") + else + let evm, u = Evd.new_univ_variable (Evd.UnivFlexible false) evm in + Feedback.msg_info (str"Fresh universe " ++ Universe.pr u ++ str" was added to the context."); + evm, u + | (l,b)::q -> List.fold_left (fun (evm,u) (l,b) -> let evm, u' = unquote_level_expr evm l b + in evm, Univ.Universe.sup u u') + (unquote_level_expr evm l b) q + + + let unquote_universe_instance evm trm (* of type universe_instance *) = + let l = unquote_list trm in + let evm, l = map_evm unquote_level evm l in + evm, Univ.Instance.of_array (Array.of_list l) + + + let clean_name _ = failwith "clean_name" + + let unquote_kn (k : quoted_kernel_name) : Libnames.qualid = + Libnames.qualid_of_string (clean_name (unquote_string k)) + + let unquote_proj (qp : quoted_proj) : (quoted_inductive * quoted_int * quoted_int) = + let (h,args) = app_full qp [] in + match args with + | tyin::tynat::indpars::idx::[] -> + let (h',args') = app_full indpars [] in + (match args' with + | tyind :: tynat :: ind :: n :: [] -> (ind, n, idx) + | _ -> bad_term_verb qp "unquote_proj") + | _ -> bad_term_verb qp "unquote_proj" + + let split_name _ = failwith "split_name" + + let unquote_inductive trm = + let (h,args) = app_full trm [] in + if Constr.equal h tmkInd then + match args with + nm :: num :: _ -> + let s = unquote_string nm in + let (dp, nm) = split_name s in + (try + match Nametab.locate (Libnames.make_qualid dp nm) with + | Globnames.ConstRef c -> CErrors.user_err (str "this not an inductive constant. use tConst instead of tInd : " ++ str s) + | Globnames.IndRef i -> (fst i, unquote_nat num) + | Globnames.VarRef _ -> CErrors.user_err (str "the constant is a variable. use tVar : " ++ str s) + | Globnames.ConstructRef _ -> CErrors.user_err (str "the constant is a consructor. use tConstructor : " ++ str s) + with + Not_found -> CErrors.user_err (str "Constant not found : " ++ str s)) + | _ -> assert false + else + bad_term_verb trm "non-constructor" + + + let unquote_ident=unquote_ident + let unquote_name=unquote_name + let unquote_int=unquote_nat + let print_term=print_term + + let inspect_term (t:Constr.t) + : (Constr.t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term = + let (h,args) = app_full t [] in + if Constr.equal h tRel then + match args with + x :: _ -> ACoq_tRel x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tVar then + match args with + x :: _ -> ACoq_tVar x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tMeta then + match args with + x :: _ -> ACoq_tMeta x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tSort then + match args with + x :: _ -> ACoq_tSort x + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tCast then + match args with + x :: y :: z :: _ -> ACoq_tCast (x, y, z) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tProd then + match args with + n :: t :: b :: _ -> ACoq_tProd (n,t,b) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tLambda then + match args with + n :: t :: b :: _ -> ACoq_tLambda (n,t,b) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tLetIn then + match args with + n :: e :: t :: b :: _ -> ACoq_tLetIn (n,e,t,b) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tApp then + match args with + f::xs::_ -> ACoq_tApp (f, unquote_list xs) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tConst then + match args with + s::u::_ -> ACoq_tConst (s, u) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tInd then + match args with + i::u::_ -> ACoq_tInd (i,u) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tConstructor then + match args with + i::idx::u::_ -> ACoq_tConstruct (i,idx,u) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure: constructor case")) + else if Constr.equal h tCase then + match args with + info::ty::d::brs::_ -> ACoq_tCase (unquote_pair info, ty, d, List.map unquote_pair (unquote_list brs)) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tFix then + match args with + bds::i::_ -> + let unquoteFbd b = + let (_,args) = app_full b [] in + match args with + | _(*type*) :: na :: ty :: body :: rarg :: [] -> + { adtype = ty; + adname = na; + adbody = body; + rarg + } + |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") + in + let lbd = List.map unquoteFbd (unquote_list bds) in + ACoq_tFix (lbd, i) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tCoFix then + match args with + bds::i::_ -> + let unquoteFbd b = + let (_,args) = app_full b [] in + match args with + | _(*type*) :: na :: ty :: body :: rarg :: [] -> + { adtype = ty; + adname = na; + adbody = body; + rarg + } + |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") + in + let lbd = List.map unquoteFbd (unquote_list bds) in + ACoq_tCoFix (lbd, i) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + else if Constr.equal h tProj then + match args with + proj::t::_ -> ACoq_tProj (proj, t) + | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) + + else + CErrors.user_err (str"inspect_term: cannot recognize " ++ print_term t ++ str" (maybe you forgot to reduce it?)") + + let unquote_universe_instance=unquote_universe_instance + + let unquote_universe=unquote_universe + let unquote_proj=unquote_proj + let unquote_inductive=unquote_inductive + let unquote_kn=unquote_kn + let unquote_cast_kind=unquote_cast_kind + let unquote_bool=unquote_bool + + + + let mkAnon = mkAnon + let mkName = mkName + let quote_kn = quote_kn + let mkRel = mkRel + let mkVar = mkVar + let mkMeta = mkMeta + let mkEvar = mkEvar + let mkSort = mkSort + let mkCast = mkCast + let mkConst = mkConst + let mkProd = mkProd + + let mkLambda = mkLambda + let mkApp = mkApp + + let mkLetIn = mkLetIn + + let mkFix = mkFix + + let mkConstruct = mkConstruct + + let mkCoFix = mkCoFix + + let mkInd = mkInd + + let mkCase = mkCase + + let quote_proj = quote_proj + + let mkProj = mkProj +end + + + +module CoqLiveDenote = Denote(CoqLiveDenoter) + +let denote_term=CoqLiveDenote.denote_term diff --git a/template-coq/src/constr_quoted.ml b/template-coq/src/constr_quoted.ml new file mode 100644 index 000000000..d1a2a1873 --- /dev/null +++ b/template-coq/src/constr_quoted.ml @@ -0,0 +1,606 @@ +open Univ +open Entries +open Names +open Pp +open Tm_util +open Quoted + +(** The reifier to Coq values *) +module ConstrQuoted = +struct + type t = Constr.t + + type quoted_ident = Constr.t (* of type Ast.ident *) + type quoted_int = Constr.t (* of type nat *) + type quoted_bool = Constr.t (* of type bool *) + type quoted_name = Constr.t (* of type Ast.name *) + type quoted_sort = Constr.t (* of type Ast.universe *) + type quoted_cast_kind = Constr.t (* of type Ast.cast_kind *) + type quoted_kernel_name = Constr.t (* of type Ast.kername *) + type quoted_inductive = Constr.t (* of type Ast.inductive *) + type quoted_proj = Constr.t (* of type Ast.projection *) + type quoted_global_reference = Constr.t (* of type Ast.global_reference *) + + type quoted_sort_family = Constr.t (* of type Ast.sort_family *) + type quoted_constraint_type = Constr.t (* of type univ.constraint_type *) + type quoted_univ_constraint = Constr.t (* of type univ.univ_constraint *) + type quoted_univ_constraints = Constr.t (* of type univ.constraints *) + type quoted_univ_instance = Constr.t (* of type univ.universe_instance *) + type quoted_univ_context = Constr.t (* of type univ.universe_context *) + type quoted_inductive_universes = Constr.t (* of type univ.universe_context *) + + type quoted_mind_params = Constr.t (* of type list (Ast.ident * list (ident * local_entry)local_entry) *) + type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list + type quoted_definition_entry = t * t option * quoted_univ_context + type quoted_mind_entry = Constr.t (* of type Ast.mutual_inductive_entry *) + type quoted_mind_finiteness = Constr.t (* of type Ast.mutual_inductive_entry ?? *) + type quoted_entry = Constr.t (* of type option (constant_entry + mutual_inductive_entry) *) + + type quoted_context_decl = Constr.t (* in Ast *) + type quoted_context = Constr.t (* in Ast *) + + type quoted_one_inductive_body = Constr.t (* of type Ast.one_inductive_body *) + type quoted_mutual_inductive_body = Constr.t (* of type Ast.mutual_inductive_body *) + type quoted_constant_body = Constr.t (* of type Ast.constant_body *) + type quoted_global_decl = Constr.t (* of type Ast.global_decl *) + type quoted_global_declarations = Constr.t (* of type Ast.global_declarations *) + type quoted_program = Constr.t (* of type Ast.program *) + +(* + type quoted_reduction_strategy = Constr.t (* of type Ast.reductionStrategy *) +*) + + let resolve_symbol (path : string list) (tm : string) : Constr.t = + gen_constant_in_modules contrib_name [path] tm + + let resolve_symbol_p (path : string list) (tm : string) : Globnames.global_reference = + Coqlib.gen_reference_in_modules contrib_name [path] tm + + let pkg_datatypes = ["Coq";"Init";"Datatypes"] + let pkg_string = ["Coq";"Strings";"String"] + let pkg_base_reify = ["Template";"BasicAst"] + let pkg_reify = ["Template";"Ast"] + let pkg_template_monad = ["Template";"TemplateMonad"] + let pkg_univ = ["Template";"kernel";"univ"] + let pkg_level = ["Template";"kernel";"univ";"Level"] + let pkg_variance = ["Template";"kernel";"univ";"Variance"] + let pkg_ugraph = ["Template";"kernel";"uGraph"] + let ext_pkg_univ s = List.append pkg_univ [s] + + let r_base_reify = resolve_symbol pkg_base_reify + let r_reify = resolve_symbol pkg_reify + let r_template_monad = resolve_symbol pkg_template_monad + let r_template_monad_p = resolve_symbol_p pkg_template_monad + + let tString = resolve_symbol pkg_string "String" + let tEmptyString = resolve_symbol pkg_string "EmptyString" + let tO = resolve_symbol pkg_datatypes "O" + let tS = resolve_symbol pkg_datatypes "S" + let tnat = resolve_symbol pkg_datatypes "nat" + let ttrue = resolve_symbol pkg_datatypes "true" + let cSome = resolve_symbol pkg_datatypes "Some" + let cNone = resolve_symbol pkg_datatypes "None" + let tfalse = resolve_symbol pkg_datatypes "false" + let unit_tt = resolve_symbol pkg_datatypes "tt" + let tAscii = resolve_symbol ["Coq";"Strings";"Ascii"] "Ascii" + let tlist = resolve_symbol pkg_datatypes "list" + let c_nil = resolve_symbol pkg_datatypes "nil" + let c_cons = resolve_symbol pkg_datatypes "cons" + let prod_type = resolve_symbol pkg_datatypes "prod" + let sum_type = resolve_symbol pkg_datatypes "sum" + let option_type = resolve_symbol pkg_datatypes "option" + let bool_type = resolve_symbol pkg_datatypes "bool" + let cInl = resolve_symbol pkg_datatypes "inl" + let cInr = resolve_symbol pkg_datatypes "inr" + let prod a b = Constr.mkApp (prod_type, [| a ; b |]) + let c_pair = resolve_symbol pkg_datatypes "pair" + let pair a b f s = Constr.mkApp (c_pair, [| a ; b ; f ; s |]) + + (* reify the constructors in Template.Ast.v, which are the building blocks of reified terms *) + let nAnon = r_base_reify "nAnon" + let nNamed = r_base_reify "nNamed" + let kVmCast = r_base_reify "VmCast" + let kNative = r_base_reify "NativeCast" + let kCast = r_base_reify "Cast" + let kRevertCast = r_base_reify "RevertCast" + let lProp = resolve_symbol pkg_level "lProp" + let lSet = resolve_symbol pkg_level "lSet" + let sfProp = r_base_reify "InProp" + let sfSet = r_base_reify "InSet" + let sfType = r_base_reify "InType" + let tident = r_base_reify "ident" + let tname = r_base_reify "name" + let tIndTy = r_base_reify "inductive" + let tmkInd = r_base_reify "mkInd" + let tsort_family = r_base_reify "sort_family" + let tmkdecl = r_reify "mkdecl" + let (tTerm,tRel,tVar,tMeta,tEvar,tSort,tCast,tProd, + tLambda,tLetIn,tApp,tCase,tFix,tConstructor,tConst,tInd,tCoFix,tProj) = + (r_reify "term", r_reify "tRel", r_reify "tVar", r_reify "tMeta", r_reify "tEvar", + r_reify "tSort", r_reify "tCast", r_reify "tProd", r_reify "tLambda", + r_reify "tLetIn", r_reify "tApp", r_reify "tCase", r_reify "tFix", + r_reify "tConstruct", r_reify "tConst", r_reify "tInd", r_reify "tCoFix", r_reify "tProj") + + let tlevel = resolve_symbol pkg_level "t" + let tLevel = resolve_symbol pkg_level "Level" + let tLevelVar = resolve_symbol pkg_level "Var" + let tunivLe = resolve_symbol (ext_pkg_univ "ConstraintType") "Le" + let tunivLt = resolve_symbol (ext_pkg_univ "ConstraintType") "Lt" + let tunivEq = resolve_symbol (ext_pkg_univ "ConstraintType") "Eq" + (* let tunivcontext = resolve_symbol pkg_univ "universe_context" *) + let tVariance = resolve_symbol pkg_variance "t" + let cIrrelevant = resolve_symbol pkg_variance "Irrelevant" + let cCovariant = resolve_symbol pkg_variance "Covariant" + let cInvariant = resolve_symbol pkg_variance "Invariant" + let cMonomorphic_ctx = resolve_symbol pkg_univ "Monomorphic_ctx" + let cPolymorphic_ctx = resolve_symbol pkg_univ "Polymorphic_ctx" + let cCumulative_ctx = resolve_symbol pkg_univ "Cumulative_ctx" + let tUContext = resolve_symbol (ext_pkg_univ "UContext") "t" + let tUContextmake = resolve_symbol (ext_pkg_univ "UContext") "make" + (* let tConstraintSetempty = resolve_symbol (ext_pkg_univ "ConstraintSet") "empty" *) + let tConstraintSetempty = Universes.constr_of_global (Coqlib.find_reference "template coq bug" (ext_pkg_univ "ConstraintSet") "empty") + let tConstraintSetadd = Universes.constr_of_global (Coqlib.find_reference "template coq bug" (ext_pkg_univ "ConstraintSet") "add") + let tmake_univ_constraint = resolve_symbol pkg_univ "make_univ_constraint" + let tinit_graph = resolve_symbol pkg_ugraph "init_graph" + let tadd_global_constraints = resolve_symbol pkg_ugraph "add_global_constraints" + + let (tdef,tmkdef) = (r_base_reify "def", r_base_reify "mkdef") + let (tLocalDef,tLocalAssum,tlocal_entry) = (r_reify "LocalDef", r_reify "LocalAssum", r_reify "local_entry") + + let (cFinite,cCoFinite,cBiFinite) = (r_reify "Finite", r_reify "CoFinite", r_reify "BiFinite") + let tone_inductive_body = r_reify "one_inductive_body" + let tBuild_one_inductive_body = r_reify "Build_one_inductive_body" + let tBuild_mutual_inductive_body = r_reify "Build_mutual_inductive_body" + let tBuild_constant_body = r_reify "Build_constant_body" + let tglobal_decl = r_reify "global_decl" + let tConstantDecl = r_reify "ConstantDecl" + let tInductiveDecl = r_reify "InductiveDecl" + let tglobal_declarations = r_reify "global_declarations" + + let tcontext_decl = r_reify "context_decl" + let tcontext = r_reify "context" + + let tMutual_inductive_entry = r_reify "mutual_inductive_entry" + let tOne_inductive_entry = r_reify "one_inductive_entry" + let tBuild_mutual_inductive_entry = r_reify "Build_mutual_inductive_entry" + let tBuild_one_inductive_entry = r_reify "Build_one_inductive_entry" + let tConstant_entry = r_reify "constant_entry" + let cParameterEntry = r_reify "ParameterEntry" + let cDefinitionEntry = r_reify "DefinitionEntry" + let cParameter_entry = r_reify "Build_parameter_entry" + let cDefinition_entry = r_reify "Build_definition_entry" + + let (tcbv, tcbn, thnf, tall, tlazy, tunfold) = (r_template_monad "cbv", r_template_monad "cbn", r_template_monad "hnf", r_template_monad "all", r_template_monad "lazy", r_template_monad "unfold") + + let (tglobal_reference, tConstRef, tIndRef, tConstructRef) = + (r_base_reify "global_reference", r_base_reify "ConstRef", r_base_reify "IndRef", r_base_reify "ConstructRef") + + (* let pkg_specif = ["Coq";"Init";"Specif"] *) + (* let texistT = resolve_symbol pkg_specif "existT" *) + (* let texistT_typed_term = r_template_monad "existT_typed_term" *) + let texistT_typed_term = r_template_monad_p "existT_typed_term" + + let unquote_pair trm = + let (h,args) = app_full trm [] in + if Constr.equal h c_pair then + match args with + _ :: _ :: x :: y :: [] -> (x, y) + | _ -> bad_term_verb trm "unquote_pair" + else + not_supported_verb trm "unquote_pair" + + let rec unquote_list trm = + let (h,args) = app_full trm [] in + if Constr.equal h c_nil then + [] + else if Constr.equal h c_cons then + match args with + _ :: x :: xs :: [] -> x :: unquote_list xs + | _ -> bad_term_verb trm "unquote_list" + else + not_supported_verb trm "unquote_list" + + (* Unquote Coq nat to OCaml int *) + let rec unquote_nat trm = + let (h,args) = app_full trm [] in + if Constr.equal h tO then + 0 + else if Constr.equal h tS then + match args with + n :: [] -> 1 + unquote_nat n + | _ -> bad_term_verb trm "unquote_nat" + else + not_supported_verb trm "unquote_nat" + + let unquote_bool trm = + if Constr.equal trm ttrue then + true + else if Constr.equal trm tfalse then + false + else not_supported_verb trm "from_bool" + + let unquote_char trm = + let (h,args) = app_full trm [] in + if Constr.equal h tAscii then + match args with + a :: b :: c :: d :: e :: f :: g :: h :: [] -> + let bits = List.rev [a;b;c;d;e;f;g;h] in + let v = List.fold_left (fun a n -> (a lsl 1) lor if unquote_bool n then 1 else 0) 0 bits in + char_of_int v + | _ -> bad_term_verb trm "unquote_char" + else + not_supported trm + + let unquote_string trm = + let rec go n trm = + let (h,args) = app_full trm [] in + if Constr.equal h tEmptyString then + Bytes.create n + else if Constr.equal h tString then + match args with + c :: s :: [] -> + let res = go (n + 1) s in + let _ = Bytes.set res n (unquote_char c) in + res + | _ -> bad_term_verb trm "unquote_string" + else + not_supported_verb trm "unquote_string" + in + Bytes.to_string (go 0 trm) + + + + let to_coq_list typ = + let the_nil = Constr.mkApp (c_nil, [| typ |]) in + let rec to_list (ls : Constr.t list) : Constr.t = + match ls with + [] -> the_nil + | l :: ls -> + Constr.mkApp (c_cons, [| typ ; l ; to_list ls |]) + in to_list + + let quote_option ty = function + | Some tm -> Constr.mkApp (cSome, [|ty; tm|]) + | None -> Constr.mkApp (cNone, [|ty|]) + + (* Quote OCaml int to Coq nat *) + let quote_int = + (* the cache is global but only accessible through quote_int *) + let cache = Hashtbl.create 10 in + let rec recurse i = + try Hashtbl.find cache i + with + Not_found -> + if i = 0 then + let result = tO in + let _ = Hashtbl.add cache i result in + result + else + let result = Constr.mkApp (tS, [| recurse (i - 1) |]) in + let _ = Hashtbl.add cache i result in + result + in + fun i -> + if i >= 0 then recurse i else + CErrors.anomaly Pp.(str "Negative int can't be unquoted to nat.") + + let quote_bool b = + if b then ttrue else tfalse + + let quote_char i = + Constr.mkApp (tAscii, Array.of_list (List.map (fun m -> quote_bool ((i land m) = m)) + (List.rev [128;64;32;16;8;4;2;1]))) + + let chars = Array.init 255 quote_char + + let quote_char c = chars.(int_of_char c) + + let string_hash = Hashtbl.create 420 + + let to_string s = + let len = String.length s in + let rec go from acc = + if from < 0 then acc + else + let term = Constr.mkApp (tString, [| quote_char (String.get s from) ; acc |]) in + go (from - 1) term + in + go (len - 1) tEmptyString + + let quote_string s = + try Hashtbl.find string_hash s + with Not_found -> + let term = to_string s in + Hashtbl.add string_hash s term; term + + let quote_ident i = + let s = Names.Id.to_string i in + quote_string s + + let quote_name n = + match n with + Names.Name id -> Constr.mkApp (nNamed, [| quote_ident id |]) + | Names.Anonymous -> nAnon + + let quote_cast_kind k = + match k with + Constr.VMcast -> kVmCast + | Constr.DEFAULTcast -> kCast + | Constr.REVERTcast -> kRevertCast + | Constr.NATIVEcast -> kNative + + let string_of_level s = + to_string (Univ.Level.to_string s) + + let quote_level l = + let open Univ in + debug (fun () -> str"quote_level " ++ Level.pr l); + if Level.is_prop l then lProp + else if Level.is_set l then lSet + else match Level.var_index l with + | Some x -> Constr.mkApp (tLevelVar, [| quote_int x |]) + | None -> Constr.mkApp (tLevel, [| string_of_level l|]) + + let quote_universe s = + let levels = Universe.map (fun (l,i) -> pair tlevel bool_type (quote_level l) (if i > 0 then ttrue else tfalse)) s in + to_coq_list (prod tlevel bool_type) levels + + (* todo : can be deduced from quote_level, hence shoud be in the Reify module *) + let quote_univ_instance u = + let arr = Univ.Instance.to_array u in + to_coq_list tlevel (CArray.map_to_list quote_level arr) + + let quote_constraint_type (c : Univ.constraint_type) = + match c with + | Lt -> tunivLt + | Le -> tunivLe + | Eq -> tunivEq + + let quote_univ_constraint ((l1, ct, l2) : Univ.univ_constraint) = + let l1 = quote_level l1 in + let l2 = quote_level l2 in + let ct = quote_constraint_type ct in + Constr.mkApp (tmake_univ_constraint, [| l1; ct; l2 |]) + + let quote_univ_constraints const = + let const = Univ.Constraint.elements const in + List.fold_left (fun tm c -> + let c = quote_univ_constraint c in + Constr.mkApp (tConstraintSetadd, [| c; tm|]) + ) tConstraintSetempty const + + let quote_variance v = + match v with + | Univ.Variance.Irrelevant -> cIrrelevant + | Univ.Variance.Covariant -> cCovariant + | Univ.Variance.Invariant -> cInvariant + + let quote_cuminfo_variance var = + let var_list = CArray.map_to_list quote_variance var in + to_coq_list tVariance var_list + + let quote_ucontext inst const = + let inst' = quote_univ_instance inst in + let const' = quote_univ_constraints const in + Constr.mkApp (tUContextmake, [|inst'; const'|]) + + let quote_univ_context uctx = + let inst = Univ.UContext.instance uctx in + let const = Univ.UContext.constraints uctx in + Constr.mkApp (cMonomorphic_ctx, [| quote_ucontext inst const |]) + + let quote_cumulative_univ_context cumi = + let uctx = Univ.CumulativityInfo.univ_context cumi in + let inst = Univ.UContext.instance uctx in + let const = Univ.UContext.constraints uctx in + let var = Univ.CumulativityInfo.variance cumi in + let uctx' = quote_ucontext inst const in + let var' = quote_cuminfo_variance var in + let listvar = Constr.mkApp (tlist, [| tVariance |]) in + let cumi' = pair tUContext listvar uctx' var' in + Constr.mkApp (cCumulative_ctx, [| cumi' |]) + + let quote_abstract_univ_context_aux uctx = + let inst = Univ.UContext.instance uctx in + let const = Univ.UContext.constraints uctx in + Constr.mkApp (cPolymorphic_ctx, [| quote_ucontext inst const |]) + + let quote_abstract_univ_context uctx = + let uctx = Univ.AUContext.repr uctx in + quote_abstract_univ_context_aux uctx + + let quote_inductive_universes uctx = + match uctx with + | Monomorphic_ind_entry uctx -> quote_univ_context (Univ.ContextSet.to_context uctx) + | Polymorphic_ind_entry uctx -> quote_abstract_univ_context_aux uctx + | Cumulative_ind_entry info -> + quote_abstract_univ_context_aux (CumulativityInfo.univ_context info) (* FIXME lossy *) + + let quote_ugraph (g : UGraph.t) = + let inst' = quote_univ_instance Univ.Instance.empty in + let const' = quote_univ_constraints (UGraph.constraints_of_universes g) in + let uctx = Constr.mkApp (tUContextmake, [|inst' ; const'|]) in + Constr.mkApp (tadd_global_constraints, [|Constr.mkApp (cMonomorphic_ctx, [| uctx |]); tinit_graph|]) + + let quote_sort s = + quote_universe (Sorts.univ_of_sort s) + + let quote_sort_family = function + | Sorts.InProp -> sfProp + | Sorts.InSet -> sfSet + | Sorts.InType -> sfType + + let quote_context_decl na b t = + Constr.mkApp (tmkdecl, [| na; quote_option tTerm b; t |]) + + let quote_context ctx = + to_coq_list tcontext_decl ctx + + let mk_ctor_list = + let ctor_list = + let ctor_info_typ = prod (prod tident tTerm) tnat in + to_coq_list ctor_info_typ + in + fun ls -> + let ctors = List.map (fun (a,b,c) -> pair (prod tident tTerm) tnat + (pair tident tTerm a b) c) ls in + ctor_list ctors + + let mk_proj_list d = + to_coq_list (prod tident tTerm) + (List.map (fun (a, b) -> pair tident tTerm a b) d) + + let quote_inductive (kn, i) = + Constr.mkApp (tmkInd, [| kn; i |]) + + let rec seq f t = + if f < t then f :: seq (f + 1) t + else [] + + let quote_proj ind pars args = + pair (prod tIndTy tnat) tnat (pair tIndTy tnat ind pars) args + + let mkAnon = nAnon + let mkName id = Constr.mkApp (nNamed, [| id |]) + let quote_kn kn = quote_string (KerName.to_string kn) + + let mkRel i = Constr.mkApp (tRel, [| i |]) + let mkVar id = Constr.mkApp (tVar, [| id |]) + let mkMeta i = Constr.mkApp (tMeta, [| i |]) + let mkEvar n args = Constr.mkApp (tEvar, [| n; to_coq_list tTerm (Array.to_list args) |]) + let mkSort s = Constr.mkApp (tSort, [| s |]) + let mkCast c k t = Constr.mkApp (tCast, [| c ; k ; t |]) + let mkConst kn u = Constr.mkApp (tConst, [| kn ; u |]) + let mkProd na t b = + Constr.mkApp (tProd, [| na ; t ; b |]) + let mkLambda na t b = + Constr.mkApp (tLambda, [| na ; t ; b |]) + let mkApp f xs = + Constr.mkApp (tApp, [| f ; to_coq_list tTerm (Array.to_list xs) |]) + + let mkLetIn na t t' b = + Constr.mkApp (tLetIn, [| na ; t ; t' ; b |]) + + let mkFix ((a,b),(ns,ts,ds)) = + let mk_fun xs i = + Constr.mkApp (tmkdef, [| tTerm ; Array.get ns i ; + Array.get ts i ; Array.get ds i ; Array.get a i |]) :: xs + in + let defs = List.fold_left mk_fun [] (seq 0 (Array.length a)) in + let block = to_coq_list (Constr.mkApp (tdef, [| tTerm |])) (List.rev defs) in + Constr.mkApp (tFix, [| block ; b |]) + + let mkConstruct (ind, i) u = + Constr.mkApp (tConstructor, [| ind ; i ; u |]) + + let mkCoFix (a,(ns,ts,ds)) = + let mk_fun xs i = + Constr.mkApp (tmkdef, [| tTerm ; Array.get ns i ; + Array.get ts i ; Array.get ds i ; tO |]) :: xs + in + let defs = List.fold_left mk_fun [] (seq 0 (Array.length ns)) in + let block = to_coq_list (Constr.mkApp (tdef, [| tTerm |])) (List.rev defs) in + Constr.mkApp (tCoFix, [| block ; a |]) + + let mkInd i u = Constr.mkApp (tInd, [| i ; u |]) + + let mkCase (ind, npar) nargs p c brs = + let info = pair tIndTy tnat ind npar in + let branches = List.map2 (fun br nargs -> pair tnat tTerm nargs br) brs nargs in + let tl = prod tnat tTerm in + Constr.mkApp (tCase, [| info ; p ; c ; to_coq_list tl branches |]) + + let mkProj kn t = + Constr.mkApp (tProj, [| kn; t |]) + + let mk_one_inductive_body (a, b, c, d, e) = + let c = to_coq_list tsort_family c in + let d = mk_ctor_list d in + let e = mk_proj_list e in + Constr.mkApp (tBuild_one_inductive_body, [| a; b; c; d; e |]) + + let mk_mutual_inductive_body npars params inds uctx = + let inds = to_coq_list tone_inductive_body inds in + Constr.mkApp (tBuild_mutual_inductive_body, [|npars; params; inds; uctx|]) + + let mk_constant_body ty tm uctx = + let tm = quote_option tTerm tm in + Constr.mkApp (tBuild_constant_body, [|ty; tm; uctx|]) + + let mk_inductive_decl kn mind = + Constr.mkApp (tInductiveDecl, [|kn; mind|]) + + let mk_constant_decl kn bdy = + Constr.mkApp (tConstantDecl, [|kn; bdy|]) + + let empty_global_declartions = + Constr.mkApp (c_nil, [| tglobal_decl |]) + + let add_global_decl d l = + Constr.mkApp (c_cons, [|tglobal_decl; d; l|]) + + let mk_program = pair tglobal_declarations tTerm + + let quote_mind_finiteness (f: Declarations.recursivity_kind) = + match f with + | Declarations.Finite -> cFinite + | Declarations.CoFinite -> cCoFinite + | Declarations.BiFinite -> cBiFinite + + let make_one_inductive_entry (iname, arity, templatePoly, consnames, constypes) = + let consnames = to_coq_list tident consnames in + let constypes = to_coq_list tTerm constypes in + Constr.mkApp (tBuild_one_inductive_entry, [| iname; arity; templatePoly; consnames; constypes |]) + + let quote_mind_params l = + let pair i l = pair tident tlocal_entry i l in + let map (id, ob) = + match ob with + | Left b -> pair id (Constr.mkApp (tLocalDef,[|b|])) + | Right t -> pair id (Constr.mkApp (tLocalAssum,[|t|])) + in + let the_prod = Constr.mkApp (prod_type,[|tident; tlocal_entry|]) in + to_coq_list the_prod (List.map map l) + + let quote_mutual_inductive_entry (mf, mp, is, mpol) = + let is = to_coq_list tOne_inductive_entry (List.map make_one_inductive_entry is) in + let mpr = Constr.mkApp (cNone, [|bool_type|]) in + let mr = Constr.mkApp (cNone, [|Constr.mkApp (option_type, [|tident|])|]) in + Constr.mkApp (tBuild_mutual_inductive_entry, [| mr; mf; mp; is; mpol; mpr |]) + + + let quote_constant_entry (ty, body, ctx) = + match body with + | None -> + Constr.mkApp (cParameterEntry, [| Constr.mkApp (cParameter_entry, [|ty; ctx|]) |]) + | Some body -> + Constr.mkApp (cDefinitionEntry, + [| Constr.mkApp (cDefinition_entry, [|ty;body;ctx;tfalse (*FIXME*)|]) |]) + + let quote_entry decl = + let opType = Constr.mkApp(sum_type, [|tConstant_entry;tMutual_inductive_entry|]) in + let mkSome c t = Constr.mkApp (cSome, [|opType; Constr.mkApp (c, [|tConstant_entry;tMutual_inductive_entry; t|] )|]) in + let mkSomeDef = mkSome cInl in + let mkSomeInd = mkSome cInr in + match decl with + | Some (Left centry) -> mkSomeDef (quote_constant_entry centry) + | Some (Right mind) -> mkSomeInd mind + | None -> Constr.mkApp (cNone, [| opType |]) + + + let quote_global_reference : Globnames.global_reference -> quoted_global_reference = function + | Globnames.VarRef _ -> CErrors.user_err (str "VarRef unsupported") + | Globnames.ConstRef c -> + let kn = quote_kn (Names.Constant.canonical c) in + Constr.mkApp (tConstRef, [|kn|]) + | Globnames.IndRef (i, n) -> + let kn = quote_kn (Names.MutInd.canonical i) in + let n = quote_int n in + Constr.mkApp (tIndRef, [|quote_inductive (kn ,n)|]) + | Globnames.ConstructRef ((i, n), k) -> + let kn = quote_kn (Names.MutInd.canonical i) in + let n = quote_int n in + let k = (quote_int (k - 1)) in + Constr.mkApp (tConstructRef, [|quote_inductive (kn ,n); k|]) + +end diff --git a/template-coq/src/constr_quoter.ml b/template-coq/src/constr_quoter.ml index 4560062d6..f2f7a558e 100644 --- a/template-coq/src/constr_quoter.ml +++ b/template-coq/src/constr_quoter.ml @@ -2,187 +2,15 @@ open Univ open Entries open Names open Pp - +open Tm_util open Quoted open Quoter - -let contrib_name = "template-coq" - -let gen_constant_in_modules locstr dirs s = - Universes.constr_of_global (Coqlib.gen_reference_in_modules locstr dirs s) +open Constr_quoted (** The reifier to Coq values *) module TemplateCoqQuoter = struct - type t = Constr.t - - type quoted_ident = Constr.t (* of type Ast.ident *) - type quoted_int = Constr.t (* of type nat *) - type quoted_bool = Constr.t (* of type bool *) - type quoted_name = Constr.t (* of type Ast.name *) - type quoted_sort = Constr.t (* of type Ast.universe *) - type quoted_cast_kind = Constr.t (* of type Ast.cast_kind *) - type quoted_kernel_name = Constr.t (* of type Ast.kername *) - type quoted_inductive = Constr.t (* of type Ast.inductive *) - type quoted_proj = Constr.t (* of type Ast.projection *) - type quoted_global_reference = Constr.t (* of type Ast.global_reference *) - - type quoted_sort_family = Constr.t (* of type Ast.sort_family *) - type quoted_constraint_type = Constr.t (* of type univ.constraint_type *) - type quoted_univ_constraint = Constr.t (* of type univ.univ_constraint *) - type quoted_univ_constraints = Constr.t (* of type univ.constraints *) - type quoted_univ_instance = Constr.t (* of type univ.universe_instance *) - type quoted_univ_context = Constr.t (* of type univ.universe_context *) - type quoted_inductive_universes = Constr.t (* of type univ.universe_context *) - - type quoted_mind_params = Constr.t (* of type list (Ast.ident * list (ident * local_entry)local_entry) *) - type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list - type quoted_definition_entry = t * t option * quoted_univ_context - type quoted_mind_entry = Constr.t (* of type Ast.mutual_inductive_entry *) - type quoted_mind_finiteness = Constr.t (* of type Ast.mutual_inductive_entry ?? *) - type quoted_entry = Constr.t (* of type option (constant_entry + mutual_inductive_entry) *) - - type quoted_context_decl = Constr.t (* in Ast *) - type quoted_context = Constr.t (* in Ast *) - - type quoted_one_inductive_body = Constr.t (* of type Ast.one_inductive_body *) - type quoted_mutual_inductive_body = Constr.t (* of type Ast.mutual_inductive_body *) - type quoted_constant_body = Constr.t (* of type Ast.constant_body *) - type quoted_global_decl = Constr.t (* of type Ast.global_decl *) - type quoted_global_declarations = Constr.t (* of type Ast.global_declarations *) - type quoted_program = Constr.t (* of type Ast.program *) - - type quoted_reduction_strategy = Constr.t (* of type Ast.reductionStrategy *) - - let resolve_symbol (path : string list) (tm : string) : Constr.t = - gen_constant_in_modules contrib_name [path] tm - - let resolve_symbol_p (path : string list) (tm : string) : global_reference = - Coqlib.gen_reference_in_modules contrib_name [path] tm - - let pkg_datatypes = ["Coq";"Init";"Datatypes"] - let pkg_string = ["Coq";"Strings";"String"] - let pkg_base_reify = ["Template";"BasicAst"] - let pkg_reify = ["Template";"Ast"] - let pkg_template_monad = ["Template";"TemplateMonad"] - let pkg_univ = ["Template";"kernel";"univ"] - let pkg_level = ["Template";"kernel";"univ";"Level"] - let pkg_variance = ["Template";"kernel";"univ";"Variance"] - let pkg_ugraph = ["Template";"kernel";"uGraph"] - let ext_pkg_univ s = List.append pkg_univ [s] - - let r_base_reify = resolve_symbol pkg_base_reify - let r_reify = resolve_symbol pkg_reify - let r_template_monad = resolve_symbol pkg_template_monad - let r_template_monad_p = resolve_symbol_p pkg_template_monad - - let tString = resolve_symbol pkg_string "String" - let tEmptyString = resolve_symbol pkg_string "EmptyString" - let tO = resolve_symbol pkg_datatypes "O" - let tS = resolve_symbol pkg_datatypes "S" - let tnat = resolve_symbol pkg_datatypes "nat" - let ttrue = resolve_symbol pkg_datatypes "true" - let cSome = resolve_symbol pkg_datatypes "Some" - let cNone = resolve_symbol pkg_datatypes "None" - let tfalse = resolve_symbol pkg_datatypes "false" - let unit_tt = resolve_symbol pkg_datatypes "tt" - let tAscii = resolve_symbol ["Coq";"Strings";"Ascii"] "Ascii" - let tlist = resolve_symbol pkg_datatypes "list" - let c_nil = resolve_symbol pkg_datatypes "nil" - let c_cons = resolve_symbol pkg_datatypes "cons" - let prod_type = resolve_symbol pkg_datatypes "prod" - let sum_type = resolve_symbol pkg_datatypes "sum" - let option_type = resolve_symbol pkg_datatypes "option" - let bool_type = resolve_symbol pkg_datatypes "bool" - let cInl = resolve_symbol pkg_datatypes "inl" - let cInr = resolve_symbol pkg_datatypes "inr" - let prod a b = Constr.mkApp (prod_type, [| a ; b |]) - let c_pair = resolve_symbol pkg_datatypes "pair" - let pair a b f s = Constr.mkApp (c_pair, [| a ; b ; f ; s |]) - - (* reify the constructors in Template.Ast.v, which are the building blocks of reified terms *) - let nAnon = r_base_reify "nAnon" - let nNamed = r_base_reify "nNamed" - let kVmCast = r_base_reify "VmCast" - let kNative = r_base_reify "NativeCast" - let kCast = r_base_reify "Cast" - let kRevertCast = r_base_reify "RevertCast" - let lProp = resolve_symbol pkg_level "lProp" - let lSet = resolve_symbol pkg_level "lSet" - let sfProp = r_base_reify "InProp" - let sfSet = r_base_reify "InSet" - let sfType = r_base_reify "InType" - let tident = r_base_reify "ident" - let tname = r_base_reify "name" - let tIndTy = r_base_reify "inductive" - let tmkInd = r_base_reify "mkInd" - let tsort_family = r_base_reify "sort_family" - let tmkdecl = r_reify "mkdecl" - let (tTerm,tRel,tVar,tMeta,tEvar,tSort,tCast,tProd, - tLambda,tLetIn,tApp,tCase,tFix,tConstructor,tConst,tInd,tCoFix,tProj) = - (r_reify "term", r_reify "tRel", r_reify "tVar", r_reify "tMeta", r_reify "tEvar", - r_reify "tSort", r_reify "tCast", r_reify "tProd", r_reify "tLambda", - r_reify "tLetIn", r_reify "tApp", r_reify "tCase", r_reify "tFix", - r_reify "tConstruct", r_reify "tConst", r_reify "tInd", r_reify "tCoFix", r_reify "tProj") - - let tlevel = resolve_symbol pkg_level "t" - let tLevel = resolve_symbol pkg_level "Level" - let tLevelVar = resolve_symbol pkg_level "Var" - let tunivLe = resolve_symbol (ext_pkg_univ "ConstraintType") "Le" - let tunivLt = resolve_symbol (ext_pkg_univ "ConstraintType") "Lt" - let tunivEq = resolve_symbol (ext_pkg_univ "ConstraintType") "Eq" - (* let tunivcontext = resolve_symbol pkg_univ "universe_context" *) - let tVariance = resolve_symbol pkg_variance "t" - let cIrrelevant = resolve_symbol pkg_variance "Irrelevant" - let cCovariant = resolve_symbol pkg_variance "Covariant" - let cInvariant = resolve_symbol pkg_variance "Invariant" - let cMonomorphic_ctx = resolve_symbol pkg_univ "Monomorphic_ctx" - let cPolymorphic_ctx = resolve_symbol pkg_univ "Polymorphic_ctx" - let cCumulative_ctx = resolve_symbol pkg_univ "Cumulative_ctx" - let tUContext = resolve_symbol (ext_pkg_univ "UContext") "t" - let tUContextmake = resolve_symbol (ext_pkg_univ "UContext") "make" - (* let tConstraintSetempty = resolve_symbol (ext_pkg_univ "ConstraintSet") "empty" *) - let tConstraintSetempty = Universes.constr_of_global (Coqlib.find_reference "template coq bug" (ext_pkg_univ "ConstraintSet") "empty") - let tConstraintSetadd = Universes.constr_of_global (Coqlib.find_reference "template coq bug" (ext_pkg_univ "ConstraintSet") "add") - let tmake_univ_constraint = resolve_symbol pkg_univ "make_univ_constraint" - let tinit_graph = resolve_symbol pkg_ugraph "init_graph" - let tadd_global_constraints = resolve_symbol pkg_ugraph "add_global_constraints" - - let (tdef,tmkdef) = (r_base_reify "def", r_base_reify "mkdef") - let (tLocalDef,tLocalAssum,tlocal_entry) = (r_reify "LocalDef", r_reify "LocalAssum", r_reify "local_entry") - - let (cFinite,cCoFinite,cBiFinite) = (r_reify "Finite", r_reify "CoFinite", r_reify "BiFinite") - let tone_inductive_body = r_reify "one_inductive_body" - let tBuild_one_inductive_body = r_reify "Build_one_inductive_body" - let tBuild_mutual_inductive_body = r_reify "Build_mutual_inductive_body" - let tBuild_constant_body = r_reify "Build_constant_body" - let tglobal_decl = r_reify "global_decl" - let tConstantDecl = r_reify "ConstantDecl" - let tInductiveDecl = r_reify "InductiveDecl" - let tglobal_declarations = r_reify "global_declarations" - - let tcontext_decl = r_reify "context_decl" - let tcontext = r_reify "context" - - let tMutual_inductive_entry = r_reify "mutual_inductive_entry" - let tOne_inductive_entry = r_reify "one_inductive_entry" - let tBuild_mutual_inductive_entry = r_reify "Build_mutual_inductive_entry" - let tBuild_one_inductive_entry = r_reify "Build_one_inductive_entry" - let tConstant_entry = r_reify "constant_entry" - let cParameterEntry = r_reify "ParameterEntry" - let cDefinitionEntry = r_reify "DefinitionEntry" - let cParameter_entry = r_reify "Build_parameter_entry" - let cDefinition_entry = r_reify "Build_definition_entry" - - let (tcbv, tcbn, thnf, tall, tlazy, tunfold) = (r_template_monad "cbv", r_template_monad "cbn", r_template_monad "hnf", r_template_monad "all", r_template_monad "lazy", r_template_monad "unfold") - - let (tglobal_reference, tConstRef, tIndRef, tConstructRef) = - (r_base_reify "global_reference", r_base_reify "ConstRef", r_base_reify "IndRef", r_base_reify "ConstructRef") - - (* let pkg_specif = ["Coq";"Init";"Specif"] *) - (* let texistT = resolve_symbol pkg_specif "existT" *) - (* let texistT_typed_term = r_template_monad "existT_typed_term" *) - let texistT_typed_term = r_template_monad_p "existT_typed_term" + include ConstrQuoted let to_coq_list typ = let the_nil = Constr.mkApp (c_nil, [| typ |]) in diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index db3768783..bd83f4770 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -1,13 +1,14 @@ -open Univ -open Names +(* open Univ + * open Names *) open Pp (* this adds the ++ to the current scope *) open Tm_util open Quoted open Quoter open Denoter -open Constr_quoter -open TemplateCoqQuoter +(* open Constr_quoted + * open Constr_quoter + * open TemplateCoqQuoter *) (* todo: the recursive call is uneeded provided we call it on well formed terms *) @@ -16,512 +17,99 @@ let print_term (u: Constr.t) : Pp.t = Printer.pr_constr u let strict_unquote_universe_mode = ref true -let unquote_pair trm = - let (h,args) = app_full trm [] in - if Constr.equal h c_pair then - match args with - _ :: _ :: x :: y :: [] -> (x, y) - | _ -> bad_term_verb trm "unquote_pair" - else - not_supported_verb trm "unquote_pair" -let rec unquote_list trm = - let (h,args) = app_full trm [] in - if Constr.equal h c_nil then - [] - else if Constr.equal h c_cons then - match args with - _ :: x :: xs :: [] -> x :: unquote_list xs - | _ -> bad_term_verb trm "unquote_list" - else - not_supported_verb trm "unquote_list" -(* Unquote Coq nat to OCaml int *) -let rec unquote_nat trm = - let (h,args) = app_full trm [] in - if Constr.equal h tO then - 0 - else if Constr.equal h tS then - match args with - n :: [] -> 1 + unquote_nat n - | _ -> bad_term_verb trm "unquote_nat" - else - not_supported_verb trm "unquote_nat" - -let unquote_bool trm = - if Constr.equal trm ttrue then - true - else if Constr.equal trm tfalse then - false - else not_supported_verb trm "from_bool" - -let unquote_char trm = - let (h,args) = app_full trm [] in - if Constr.equal h tAscii then - match args with - a :: b :: c :: d :: e :: f :: g :: h :: [] -> - let bits = List.rev [a;b;c;d;e;f;g;h] in - let v = List.fold_left (fun a n -> (a lsl 1) lor if unquote_bool n then 1 else 0) 0 bits in - char_of_int v - | _ -> bad_term_verb trm "unquote_char" - else - not_supported trm - -let unquote_string trm = - let rec go n trm = - let (h,args) = app_full trm [] in - if Constr.equal h tEmptyString then - Bytes.create n - else if Constr.equal h tString then - match args with - c :: s :: [] -> - let res = go (n + 1) s in - let _ = Bytes.set res n (unquote_char c) in - res - | _ -> bad_term_verb trm "unquote_string" - else - not_supported_verb trm "unquote_string" - in - Bytes.to_string (go 0 trm) - -let unquote_ident trm = - Id.of_string (unquote_string trm) - -let unquote_cast_kind trm = - if Constr.equal trm kVmCast then - Constr.VMcast - else if Constr.equal trm kCast then - Constr.DEFAULTcast - else if Constr.equal trm kRevertCast then - Constr.REVERTcast - else if Constr.equal trm kNative then - Constr.VMcast - else - not_supported_verb trm "unquote_cast_kind" - -let unquote_name trm = - let (h,args) = app_full trm [] in - if Constr.equal h nAnon then - Names.Anonymous - else if Constr.equal h nNamed then - match args with - n :: [] -> Names.Name (unquote_ident n) - | _ -> bad_term_verb trm "unquote_name" - else - not_supported_verb trm "unquote_name" - -let get_level evm s = - if CString.string_contains ~where:s ~what:"." then - match List.rev (CString.split '.' s) with - | [] -> CErrors.anomaly (str"Invalid universe name " ++ str s ++ str".") - | n :: dp -> - let num = int_of_string n in - let dp = DirPath.make (List.map Id.of_string dp) in - let l = Univ.Level.make dp num in - try - let evm = Evd.add_global_univ evm l in - if !strict_unquote_universe_mode then - CErrors.user_err ~hdr:"unquote_level" (str ("Level "^s^" is not a declared level and you are in Strict Unquote Universe Mode.")) - else (Feedback.msg_info (str"Fresh universe " ++ Level.pr l ++ str" was added to the context."); - evm, l) - with - | UGraph.AlreadyDeclared -> evm, l - else - try - evm, Evd.universe_of_name evm (Id.of_string s) - with Not_found -> - try - let univ, k = Nametab.locate_universe (Libnames.qualid_of_string s) in - evm, Univ.Level.make univ k - with Not_found -> - CErrors.user_err ~hdr:"unquote_level" (str ("Level "^s^" is not a declared level.")) - - - - - -let unquote_level evm trm (* of type level *) : Evd.evar_map * Univ.Level.t = - let (h,args) = app_full trm [] in - if Constr.equal h lProp then - match args with - | [] -> evm, Univ.Level.prop - | _ -> bad_term_verb trm "unquote_level" - else if Constr.equal h lSet then - match args with - | [] -> evm, Univ.Level.set - | _ -> bad_term_verb trm "unquote_level" - else if Constr.equal h tLevel then - match args with - | s :: [] -> debug (fun () -> str "Unquoting level " ++ pr_constr trm); - get_level evm (unquote_string s) - | _ -> bad_term_verb trm "unquote_level" - else if Constr.equal h tLevelVar then - match args with - | l :: [] -> evm, Univ.Level.var (unquote_nat l) - | _ -> bad_term_verb trm "unquote_level" - else - not_supported_verb trm "unquote_level" - -let unquote_level_expr evm trm (* of type level *) b (* of type bool *) : Evd.evar_map * Univ.Universe.t = - let evm, l = unquote_level evm trm in - let u = Univ.Universe.make l in - evm, if unquote_bool b then Univ.Universe.super u else u - - -let unquote_universe evm trm (* of type universe *) = - let levels = List.map unquote_pair (unquote_list trm) in - match levels with - | [] -> if !strict_unquote_universe_mode then - CErrors.user_err ~hdr:"unquote_universe" (str "It is not possible to unquote an empty universe in Strict Unquote Universe Mode.") - else - let evm, u = Evd.new_univ_variable (Evd.UnivFlexible false) evm in - Feedback.msg_info (str"Fresh universe " ++ Universe.pr u ++ str" was added to the context."); - evm, u - | (l,b)::q -> List.fold_left (fun (evm,u) (l,b) -> let evm, u' = unquote_level_expr evm l b - in evm, Univ.Universe.sup u u') - (unquote_level_expr evm l b) q let map_evm (f : 'a -> 'b -> 'a * 'c) (evm : 'a) (l : 'b list) : 'a * ('c list) = let evm, res = List.fold_left (fun (evm, l) b -> let evm, c = f evm b in evm, c :: l) (evm, []) l in evm, List.rev res -let unquote_universe_instance evm trm (* of type universe_instance *) = - let l = unquote_list trm in - let evm, l = map_evm unquote_level evm l in - evm, Univ.Instance.of_array (Array.of_list l) - - -let unquote_kn (k : quoted_kernel_name) : Libnames.qualid = - Libnames.qualid_of_string (clean_name (unquote_string k)) - -let unquote_proj (qp : quoted_proj) : (quoted_inductive * quoted_int * quoted_int) = - let (h,args) = app_full qp [] in - match args with - | tyin::tynat::indpars::idx::[] -> - let (h',args') = app_full indpars [] in - (match args' with - | tyind :: tynat :: ind :: n :: [] -> (ind, n, idx) - | _ -> bad_term_verb qp "unquote_proj") - | _ -> bad_term_verb qp "unquote_proj" - -let unquote_inductive trm = - let (h,args) = app_full trm [] in - if Constr.equal h tmkInd then - match args with - nm :: num :: _ -> - let s = (unquote_string nm) in - let (dp, nm) = split_name s in - (try - match Nametab.locate (Libnames.make_qualid dp nm) with - | Globnames.ConstRef c -> CErrors.user_err (str "this not an inductive constant. use tConst instead of tInd : " ++ str s) - | Globnames.IndRef i -> (fst i, unquote_nat num) - | Globnames.VarRef _ -> CErrors.user_err (str "the constant is a variable. use tVar : " ++ str s) - | Globnames.ConstructRef _ -> CErrors.user_err (str "the constant is a consructor. use tConstructor : " ++ str s) - with - Not_found -> CErrors.user_err (str "Constant not found : " ++ str s)) - | _ -> assert false - else - bad_term_verb trm "non-constructor" - -let inspect_term (t:Constr.t) : (Constr.t, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term = - let (h,args) = app_full t [] in - if Constr.equal h tRel then - match args with - x :: _ -> ACoq_tRel x - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tVar then - match args with - x :: _ -> ACoq_tVar x - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tMeta then - match args with - x :: _ -> ACoq_tMeta x - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tSort then - match args with - x :: _ -> ACoq_tSort x - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tCast then - match args with - x :: y :: z :: _ -> ACoq_tCast (x, y, z) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tProd then - match args with - n :: t :: b :: _ -> ACoq_tProd (n,t,b) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tLambda then - match args with - n :: t :: b :: _ -> ACoq_tLambda (n,t,b) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tLetIn then - match args with - n :: e :: t :: b :: _ -> ACoq_tLetIn (n,e,t,b) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tApp then - match args with - f::xs::_ -> ACoq_tApp (f, unquote_list xs) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tConst then - match args with - s::u::_ -> ACoq_tConst (s, u) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tInd then - match args with - i::u::_ -> ACoq_tInd (i,u) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tConstructor then - match args with - i::idx::u::_ -> ACoq_tConstruct (i,idx,u) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure: constructor case")) - else if Constr.equal h tCase then - match args with - info::ty::d::brs::_ -> ACoq_tCase (unquote_pair info, ty, d, List.map unquote_pair (unquote_list brs)) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tFix then - match args with - bds::i::_ -> - let unquoteFbd b = - let (_,args) = app_full b [] in - match args with - | _(*type*) :: na :: ty :: body :: rarg :: [] -> - { adtype = ty; - adname = na; - adbody = body; - rarg - } - |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") - in - let lbd = List.map unquoteFbd (unquote_list bds) in - ACoq_tFix (lbd, i) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tCoFix then - match args with - bds::i::_ -> - let unquoteFbd b = - let (_,args) = app_full b [] in - match args with - | _(*type*) :: na :: ty :: body :: rarg :: [] -> - { adtype = ty; - adname = na; - adbody = body; - rarg - } - |_ -> raise (Failure " (mkdef must take exactly 5 arguments)") - in - let lbd = List.map unquoteFbd (unquote_list bds) in - ACoq_tCoFix (lbd, i) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - else if Constr.equal h tProj then - match args with - proj::t::_ -> ACoq_tProj (proj, t) - | _ -> CErrors.user_err (print_term t ++ Pp.str ("has bad structure")) - - else - CErrors.user_err (str"inspect_term: cannot recognize " ++ print_term t ++ str" (maybe you forgot to reduce it?)") - module Denote (D : Denoter) = struct - - -(* If strict unquote universe mode is on then fail when unquoting a non *) -(* declared universe / an empty list of level expressions. *) -(* Otherwise, add it / a fresh level the global environnment. *) - - -let _ = - let open Goptions in - declare_bool_option - { optdepr = false; - optname = "strict unquote universe mode"; - optkey = ["Strict"; "Unquote"; "Universe"; "Mode"]; - optread = (fun () -> !strict_unquote_universe_mode); - optwrite = (fun b -> strict_unquote_universe_mode := b) } - - - - -(* TODO: replace app_full by this abstract version?*) -let rec app_full_abs (trm: D.t) (acc: D.t list) = - match D.inspect_term trm with - ACoq_tApp (f, xs) -> app_full_abs f (xs @ acc) - | _ -> (trm, acc) - -let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = - let rec aux evm (trm: D.t) : _ * Constr.t = -(* debug (fun () -> Pp.(str "denote_term" ++ spc () ++ pr_constr trm)) ; *) + (* TODO: replace app_full by this abstract version?*) + let rec app_full_abs (trm: D.t) (acc: D.t list) = match D.inspect_term trm with - | ACoq_tRel x -> evm, Constr.mkRel (D.unquote_int x + 1) - | ACoq_tVar x -> evm, Constr.mkVar (D.unquote_ident x) - | ACoq_tSort x -> let evm, u = D.unquote_universe evm x in evm, Constr.mkType u - | ACoq_tCast (t,c,ty) -> let evm, t = aux evm t in - let evm, ty = aux evm ty in - evm, Constr.mkCast (t, D.unquote_cast_kind c, ty) - | ACoq_tProd (n,t,b) -> let evm, t = aux evm t in - let evm, b = aux evm b in - evm, Constr.mkProd (D.unquote_name n, t, b) - | ACoq_tLambda (n,t,b) -> let evm, t = aux evm t in - let evm, b = aux evm b in - evm, Constr.mkLambda (D.unquote_name n, t, b) - | ACoq_tLetIn (n,e,t,b) -> let evm, e = aux evm e in - let evm, t = aux evm t in - let evm, b = aux evm b in - evm, Constr.mkLetIn (D.unquote_name n, e, t, b) - | ACoq_tApp (f,xs) -> let evm, f = aux evm f in - let evm, xs = map_evm aux evm xs in - evm, Constr.mkApp (f, Array.of_list xs) - | ACoq_tConst (s,u) -> - let s = D.unquote_kn s in - let evm, u = D.unquote_universe_instance evm u in - (try - match Nametab.locate s with - | Globnames.ConstRef c -> evm, Constr.mkConstU (c, u) - | Globnames.IndRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is an inductive, use tInd.") - | Globnames.VarRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is a variable, use tVar.") - | Globnames.ConstructRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is a constructor, use tConstructor.") - with - Not_found -> CErrors.user_err (str"Constant not found: " ++ Libnames.pr_qualid s)) - | ACoq_tConstruct (i,idx,u) -> - let ind = D.unquote_inductive i in - let evm, u = D.unquote_universe_instance evm u in - evm, Constr.mkConstructU ((ind, D.unquote_int idx + 1), u) - | ACoq_tInd (i, u) -> - let i = D.unquote_inductive i in - let evm, u = D.unquote_universe_instance evm u in - evm, Constr.mkIndU (i, u) - | ACoq_tCase ((i, _), ty, d, brs) -> - let ind = D.unquote_inductive i in - let evm, ty = aux evm ty in - let evm, d = aux evm d in - let evm, brs = map_evm aux evm (List.map snd brs) in - (* todo: reify better case_info *) - let ci = Inductiveops.make_case_info (Global.env ()) ind Constr.RegularStyle in - evm, Constr.mkCase (ci, ty, d, Array.of_list brs) - | ACoq_tFix (lbd, i) -> - let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, - List.map (fun p->p.rarg) lbd) in - let evm, types = map_evm aux evm types in - let evm, bodies = map_evm aux evm bodies in - let (names,rargs) = (List.map D.unquote_name names, List.map D.unquote_int rargs) in - let la = Array.of_list in - evm, Constr.mkFix ((la rargs, D.unquote_int i), (la names, la types, la bodies)) - | ACoq_tCoFix (lbd, i) -> - let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, - List.map (fun p->p.rarg) lbd) in - let evm, types = map_evm aux evm types in - let evm, bodies = map_evm aux evm bodies in - let (names,rargs) = (List.map D.unquote_name names, List.map D.unquote_int rargs) in - let la = Array.of_list in - evm, Constr.mkCoFix (D.unquote_int i, (la names, la types, la bodies)) - | ACoq_tProj (proj,t) -> - let (ind, _, narg) = D.unquote_proj proj in (* todo: is narg the correct projection? *) - let ind' = D.unquote_inductive ind in - let projs = Recordops.lookup_projections ind' in - let evm, t = aux evm t in - (match List.nth projs (D.unquote_int narg) with - | Some p -> evm, Constr.mkProj (Names.Projection.make p false, t) - | None -> (*bad_term trm *) failwith "tproj case of denote_term") - | _ -> failwith "big case of denote_term" - in aux evm trm - -end - -open Denoter -open Constr_quoter -module CoqLiveDenoter = -struct - type t = Constr.t - - type quoted_ident = Constr.t (* of type Ast.ident *) - type quoted_int = Constr.t (* of type nat *) - type quoted_bool = Constr.t (* of type bool *) - type quoted_name = Constr.t (* of type Ast.name *) - type quoted_sort = Constr.t (* of type Ast.universe *) - type quoted_cast_kind = Constr.t (* of type Ast.cast_kind *) - type quoted_kernel_name = Constr.t (* of type Ast.kername *) - type quoted_inductive = Constr.t (* of type Ast.inductive *) - type quoted_proj = Constr.t (* of type Ast.projection *) - type quoted_global_reference = Constr.t (* of type Ast.global_reference *) - - type quoted_sort_family = Constr.t (* of type Ast.sort_family *) - type quoted_constraint_type = Constr.t (* of type univ.constraint_type *) - type quoted_univ_constraint = Constr.t (* of type univ.univ_constraint *) - type quoted_univ_constraints = Constr.t (* of type univ.constraints *) - type quoted_univ_instance = Constr.t (* of type univ.universe_instance *) - type quoted_univ_context = Constr.t (* of type univ.universe_context *) - type quoted_inductive_universes = Constr.t (* of type univ.universe_context *) - - type quoted_mind_params = Constr.t (* of type list (Ast.ident * list (ident * local_entry)local_entry) *) - type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list - type quoted_definition_entry = t * t option * quoted_univ_context - type quoted_mind_entry = Constr.t (* of type Ast.mutual_inductive_entry *) - type quoted_mind_finiteness = Constr.t (* of type Ast.mutual_inductive_entry ?? *) - type quoted_entry = Constr.t (* of type option (constant_entry + mutual_inductive_entry) *) - - type quoted_context_decl = Constr.t (* in Ast *) - type quoted_context = Constr.t (* in Ast *) - - type quoted_one_inductive_body = Constr.t (* of type Ast.one_inductive_body *) - type quoted_mutual_inductive_body = Constr.t (* of type Ast.mutual_inductive_body *) - type quoted_constant_body = Constr.t (* of type Ast.constant_body *) - type quoted_global_decl = Constr.t (* of type Ast.global_decl *) - type quoted_global_declarations = Constr.t (* of type Ast.global_declarations *) - type quoted_program = Constr.t (* of type Ast.program *) - - type quoted_reduction_strategy = Constr.t (* of type Ast.reductionStrategy *) - - let unquote_ident=unquote_ident - let unquote_name=unquote_name - let unquote_int=unquote_nat - let print_term=print_term - let inspect_term=inspect_term - let unquote_universe_instance=unquote_universe_instance - - let unquote_universe=unquote_universe - let unquote_proj=unquote_proj - let unquote_inductive=unquote_inductive - let unquote_kn=unquote_kn - let unquote_cast_kind=unquote_cast_kind - let unquote_bool=unquote_bool + ACoq_tApp (f, xs) -> app_full_abs f (xs @ acc) + | _ -> (trm, acc) + + let denote_term (evm : Evd.evar_map) (trm: D.t) : Evd.evar_map * Constr.t = + let rec aux evm (trm: D.t) : _ * Constr.t = + (* debug (fun () -> Pp.(str "denote_term" ++ spc () ++ pr_constr trm)) ; *) + match D.inspect_term trm with + | ACoq_tRel x -> evm, Constr.mkRel (D.unquote_int x + 1) + | ACoq_tVar x -> evm, Constr.mkVar (D.unquote_ident x) + | ACoq_tSort x -> let evm, u = D.unquote_universe evm x in evm, Constr.mkType u + | ACoq_tCast (t,c,ty) -> let evm, t = aux evm t in + let evm, ty = aux evm ty in + evm, Constr.mkCast (t, D.unquote_cast_kind c, ty) + | ACoq_tProd (n,t,b) -> let evm, t = aux evm t in + let evm, b = aux evm b in + evm, Constr.mkProd (D.unquote_name n, t, b) + | ACoq_tLambda (n,t,b) -> let evm, t = aux evm t in + let evm, b = aux evm b in + evm, Constr.mkLambda (D.unquote_name n, t, b) + | ACoq_tLetIn (n,e,t,b) -> let evm, e = aux evm e in + let evm, t = aux evm t in + let evm, b = aux evm b in + evm, Constr.mkLetIn (D.unquote_name n, e, t, b) + | ACoq_tApp (f,xs) -> let evm, f = aux evm f in + let evm, xs = map_evm aux evm xs in + evm, Constr.mkApp (f, Array.of_list xs) + | ACoq_tConst (s,u) -> + let s = D.unquote_kn s in + let evm, u = D.unquote_universe_instance evm u in + (try + match Nametab.locate s with + | Globnames.ConstRef c -> evm, Constr.mkConstU (c, u) + | Globnames.IndRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is an inductive, use tInd.") + | Globnames.VarRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is a variable, use tVar.") + | Globnames.ConstructRef _ -> CErrors.user_err (str"The constant " ++ Libnames.pr_qualid s ++ str" is a constructor, use tConstructor.") + with + Not_found -> CErrors.user_err (str"Constant not found: " ++ Libnames.pr_qualid s)) + | ACoq_tConstruct (i,idx,u) -> + let ind = D.unquote_inductive i in + let evm, u = D.unquote_universe_instance evm u in + evm, Constr.mkConstructU ((ind, D.unquote_int idx + 1), u) + | ACoq_tInd (i, u) -> + let i = D.unquote_inductive i in + let evm, u = D.unquote_universe_instance evm u in + evm, Constr.mkIndU (i, u) + | ACoq_tCase ((i, _), ty, d, brs) -> + let ind = D.unquote_inductive i in + let evm, ty = aux evm ty in + let evm, d = aux evm d in + let evm, brs = map_evm aux evm (List.map snd brs) in + (* todo: reify better case_info *) + let ci = Inductiveops.make_case_info (Global.env ()) ind Constr.RegularStyle in + evm, Constr.mkCase (ci, ty, d, Array.of_list brs) + | ACoq_tFix (lbd, i) -> + let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, + List.map (fun p->p.rarg) lbd) in + let evm, types = map_evm aux evm types in + let evm, bodies = map_evm aux evm bodies in + let (names,rargs) = (List.map D.unquote_name names, List.map D.unquote_int rargs) in + let la = Array.of_list in + evm, Constr.mkFix ((la rargs, D.unquote_int i), (la names, la types, la bodies)) + | ACoq_tCoFix (lbd, i) -> + let (names,types,bodies,rargs) = (List.map (fun p->p.adname) lbd, List.map (fun p->p.adtype) lbd, List.map (fun p->p.adbody) lbd, + List.map (fun p->p.rarg) lbd) in + let evm, types = map_evm aux evm types in + let evm, bodies = map_evm aux evm bodies in + let (names,rargs) = (List.map D.unquote_name names, List.map D.unquote_int rargs) in + let la = Array.of_list in + evm, Constr.mkCoFix (D.unquote_int i, (la names, la types, la bodies)) + | ACoq_tProj (proj,t) -> + let (ind, _, narg) = D.unquote_proj proj in (* todo: is narg the correct projection? *) + let ind' = D.unquote_inductive ind in + let projs = Recordops.lookup_projections ind' in + let evm, t = aux evm t in + (match List.nth projs (D.unquote_int narg) with + | Some p -> evm, Constr.mkProj (Names.Projection.make p false, t) + | None -> (*bad_term trm *) failwith "tproj case of denote_term") + | _ -> failwith "big case of denote_term" + in aux evm trm - - - let mkAnon = mkAnon - let mkName = mkName - let quote_kn = quote_kn - let mkRel = mkRel - let mkVar = mkVar - let mkMeta = mkMeta - let mkEvar = mkEvar - let mkSort = mkSort - let mkCast = mkCast - let mkConst = mkConst - let mkProd = mkProd - - let mkLambda = mkLambda - let mkApp = mkApp - - let mkLetIn = mkLetIn - - let mkFix = mkFix - - let mkConstruct = mkConstruct - - let mkCoFix = mkCoFix - - let mkInd = mkInd - - let mkCase = mkCase - - let quote_proj = quote_proj - - let mkProj = mkProj end - - - -module CoqLiveDenote = Denote(CoqLiveDenoter) - -let denote_term=CoqLiveDenote.denote_term diff --git a/template-coq/src/g_template_coq.ml4 b/template-coq/src/g_template_coq.ml4 index 5f8c60fce..802c74f55 100644 --- a/template-coq/src/g_template_coq.ml4 +++ b/template-coq/src/g_template_coq.ml4 @@ -62,7 +62,7 @@ TACTIC EXTEND denote_term | [ "denote_term" constr(c) tactic(tac) ] -> [ Proofview.Goal.enter (begin fun gl -> let evm = Proofview.Goal.sigma gl in - let evm, c = Denote.denote_term evm (EConstr.to_constr evm c) in + let evm, c = Constr_denoter.denote_term evm (EConstr.to_constr evm c) in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evm) (ltac_apply tac (List.map to_ltac_val [EConstr.of_constr c])) end) ] @@ -107,7 +107,7 @@ VERNAC COMMAND EXTEND Unquote_vernac CLASSIFIED AS SIDEFF | [ "Make" "Definition" ident(name) ":=" constr(def) ] -> [ let (evm, env) = Pfedit.get_current_context () in let (trm, uctx) = Constrintern.interp_constr env evm def in - let evm, trm = Denote.denote_term evm (EConstr.to_constr evm trm) in + let evm, trm = Constr_denoter.denote_term evm (EConstr.to_constr evm trm) in let _ = Declare.declare_definition ~kind:Decl_kinds.Definition name @@ -122,7 +122,7 @@ VERNAC COMMAND EXTEND Unquote_vernac_red CLASSIFIED AS SIDEFF let evm = Evd.from_ctx uctx in let (evm,rd) = Tacinterp.interp_redexp env evm rd in let (evm,trm) = Quoter.reduce env evm rd (EConstr.to_constr evm trm) in - let evm, trm = Denote.denote_term evm trm in + let evm, trm = Constr_denoter.denote_term evm trm in let _ = Declare.declare_definition ~kind:Decl_kinds.Definition name (trm, Monomorphic_const_entry (Evd.universe_context_set evm)) in () ] @@ -163,6 +163,6 @@ VERNAC COMMAND EXTEND Make_tests CLASSIFIED AS QUERY [ let (evm,env) = Pfedit.get_current_context () in let c = Constrintern.interp_constr env evm c in let result = Constr_quoter.TermReify.quote_term env (EConstr.to_constr evm (fst c)) in - Feedback.msg_notice (Quoter.pr_constr result) ; + Feedback.msg_notice (Tm_util.pr_constr result) ; () ] END;; diff --git a/template-coq/src/quoted.ml b/template-coq/src/quoted.ml index 7b62fc905..278cf7f10 100644 --- a/template-coq/src/quoted.ml +++ b/template-coq/src/quoted.ml @@ -24,6 +24,25 @@ type ('term, 'nat, 'ident, 'name, 'quoted_sort, 'cast_kind, 'kername, 'inductive | ACoq_tFix of ('term, 'name, 'nat) amfixpoint * 'nat | ACoq_tCoFix of ('term, 'name, 'nat) amfixpoint * 'nat +(* todo(gmm): these are helper functions *) +let string_to_list s = + let rec aux acc i = + if i < 0 then acc + else aux (s.[i] :: acc) (i - 1) + in aux [] (String.length s - 1) + +let list_to_string l = + let buf = Bytes.create (List.length l) in + let rec aux i = function + | [] -> () + | c :: cs -> + Bytes.set buf i c; aux (succ i) cs + in + aux 0 l; + Bytes.to_string buf + + + module type Quoted = sig type t (* this represented quoted Gallina terms *) diff --git a/template-coq/src/quoter.ml b/template-coq/src/quoter.ml index be517dc84..10f404edf 100644 --- a/template-coq/src/quoter.ml +++ b/template-coq/src/quoter.ml @@ -3,6 +3,7 @@ open Entries open Declarations open Pp +open Tm_util open Quoted let cast_prop = ref (false) @@ -10,13 +11,6 @@ let cast_prop = ref (false) (* whether Set Template Cast Propositions is on, as needed for erasure in Certicoq *) let is_cast_prop () = !cast_prop -let opt_debug = ref false - -let debug (m : unit ->Pp.t) = - if !opt_debug then - Feedback.(msg_debug (m ())) - else - () let toDecl (old: Name.t * ((Constr.constr) option) * Constr.constr) : Context.Rel.Declaration.t = let (name,value,typ) = old in @@ -27,23 +21,6 @@ let toDecl (old: Name.t * ((Constr.constr) option) * Constr.constr) : Context.Re let getType env (t:Constr.t) : Constr.t = EConstr.to_constr Evd.empty (Retyping.get_type_of env Evd.empty (EConstr.of_constr t)) -let pr_constr trm = - let (evm, env) = Pfedit.get_current_context () in - Printer.pr_constr_env env evm trm - -let not_supported trm = - CErrors.user_err (str "Not Supported:" ++ spc () ++ pr_constr trm) - -let not_supported_verb trm rs = - CErrors.user_err (str "Not Supported raised at " ++ str rs ++ str ":" ++ spc () ++ pr_constr trm) - -let bad_term trm = - CErrors.user_err (str "Bad term:" ++ spc () ++ pr_constr trm) - -let bad_term_verb trm rs = - CErrors.user_err (str "Bad term:" ++ spc () ++ pr_constr trm - ++ spc () ++ str " Error: " ++ str rs) - (* TODO: remove? *) let opt_hnf_ctor_types = ref false diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 4caa4a00a..6952b6587 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -10,10 +10,10 @@ let of_constr (env : Environ.env) (t : Constr.t) : Ast0.term = Ast_quoter.quote_term env t let to_string : char list -> string = - Ast_quoter.unquote_string + Quoted.list_to_string let of_string : string -> char list = - Ast_quoter.quote_string + Quoted.string_to_list let to_reduction_strategy (s : Common.reductionStrategy) = failwith "to_reduction_strategy" @@ -81,7 +81,7 @@ let of_mib (env : Environ.env) (mib : Plugin_core.mutual_inductive_body) : Ast0. let indty = Ast_quoter.quote_term env indty in let (reified_ctors,acc) = List.fold_left (fun (ls,acc) (nm,ty,ar) -> - debug (fun () -> Pp.(str "opt_hnf_ctor_types:" ++ spc () ++ + Tm_util.debug (fun () -> Pp.(str "opt_hnf_ctor_types:" ++ spc () ++ bool !opt_hnf_ctor_types)) ; let ty = if !opt_hnf_ctor_types then hnf_type envind ty else ty in let ty = quote_term acc ty in diff --git a/template-coq/src/run_template_monad.ml b/template-coq/src/run_template_monad.ml index b0f7059aa..4a1ef8f80 100644 --- a/template-coq/src/run_template_monad.ml +++ b/template-coq/src/run_template_monad.ml @@ -8,10 +8,14 @@ open Pp (* this adds the ++ to the current scope *) open Tm_util open Quoter +open Denote +open Constr_quoted open Constr_quoter -open TemplateCoqQuoter open Template_monad -open Denote +open Constr_denoter + +open ConstrQuoted +open CoqLiveDenoter let unquote_reduction_strategy env evm trm (* of type reductionStrategy *) : Redexpr.red_expr = let (trm, args) = app_full trm [] in @@ -72,7 +76,7 @@ let unquote_map_option f trm = else not_supported_verb trm "unquote_map_option" -let denote_option = unquote_map_option (fun x -> x) +let unquote_option = unquote_map_option (fun x -> x) @@ -222,7 +226,7 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m then not_in_tactic "tmDefinition" else let name = unquote_ident (reduce_all env evm name) in - let evm, typ = (match denote_option s with Some s -> let red = unquote_reduction_strategy env evm s in reduce env evm red typ | None -> evm, typ) in + let evm, typ = (match unquote_option s with Some s -> let red = unquote_reduction_strategy env evm s in reduce env evm red typ | None -> evm, typ) in let univs = if Flags.is_universe_polymorphism () then Polymorphic_const_entry (Evd.to_universe_context evm) else Monomorphic_const_entry (Evd.universe_context_set evm) in @@ -247,7 +251,7 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m let name = unquote_ident (reduce_all env evm name) in let evm,body = denote_term evm (reduce_all env evm body) in let evm,typ = - match denote_option typ with + match unquote_option typ with | None -> (evm, None) | Some t -> let (evm, t) = denote_term evm (reduce_all env evm t) in @@ -268,7 +272,7 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m else let name = unquote_ident (reduce_all env evm name) in let evm, typ = - match denote_option s with + match unquote_option s with Some s -> let red = unquote_reduction_strategy env evm s in reduce env evm red typ @@ -288,7 +292,7 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m (fun a b c -> k (a,b,quote_kn c)) | TmLemma (name,s,typ) -> let name = reduce_all env evm name in - let evm, typ = (match denote_option s with Some s -> let red = unquote_reduction_strategy env evm s in reduce env evm red typ | None -> evm, typ) in + let evm, typ = (match unquote_option s with Some s -> let red = unquote_reduction_strategy env evm s in reduce env evm red typ | None -> evm, typ) in let poly = Flags.is_universe_polymorphism () in let kind = (Decl_kinds.Global, poly, Decl_kinds.Definition) in let hole = CAst.make (Constrexpr.CHole (None, Misctypes.IntroAnonymous, None)) in @@ -417,7 +421,7 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m | TmInferInstance (s, typ) -> begin let evm, typ = - match denote_option s with + match unquote_option s with Some s -> let red = unquote_reduction_strategy env evm s in reduce env evm red typ diff --git a/template-coq/src/template_coq.mlpack b/template-coq/src/template_coq.mlpack index c23ab63ea..f1093ea95 100644 --- a/template-coq/src/template_coq.mlpack +++ b/template-coq/src/template_coq.mlpack @@ -1,9 +1,12 @@ Tm_util Quoted Quoter +Denote +Constr_quoted Constr_quoter +Constr_denoter Template_monad -Denote + Plugin_core Run_template_monad G_template_coq diff --git a/template-coq/src/template_monad.ml b/template-coq/src/template_monad.ml index a536900ff..457069a04 100644 --- a/template-coq/src/template_monad.ml +++ b/template-coq/src/template_monad.ml @@ -3,6 +3,7 @@ open Names open Constr_quoter open Pp +open Tm_util open Quoter module TemplateMonad : diff --git a/template-coq/src/tm_util.ml b/template-coq/src/tm_util.ml index 507ffa3bc..e9e811fbd 100644 --- a/template-coq/src/tm_util.ml +++ b/template-coq/src/tm_util.ml @@ -1,4 +1,37 @@ +open Pp + +let contrib_name = "template-coq" + +let gen_constant_in_modules locstr dirs s = + Universes.constr_of_global (Coqlib.gen_reference_in_modules locstr dirs s) + + +let opt_debug = ref false + +let debug (m : unit ->Pp.t) = + if !opt_debug then + Feedback.(msg_debug (m ())) + else + () + let rec app_full trm acc = match Constr.kind trm with Constr.App (f, xs) -> app_full f (Array.to_list xs @ acc) | _ -> (trm, acc) + +let pr_constr trm = + let (evm, env) = Pfedit.get_current_context () in + Printer.pr_constr_env env evm trm + +let not_supported trm = + CErrors.user_err (str "Not Supported:" ++ spc () ++ pr_constr trm) + +let not_supported_verb trm rs = + CErrors.user_err (str "Not Supported raised at " ++ str rs ++ str ":" ++ spc () ++ pr_constr trm) + +let bad_term trm = + CErrors.user_err (str "Bad term:" ++ spc () ++ pr_constr trm) + +let bad_term_verb trm rs = + CErrors.user_err (str "Bad term:" ++ spc () ++ pr_constr trm + ++ spc () ++ str " Error: " ++ str rs) diff --git a/template-coq/theories/Extraction.v b/template-coq/theories/Extraction.v index 3e9f3d422..165b1565b 100644 --- a/template-coq/theories/Extraction.v +++ b/template-coq/theories/Extraction.v @@ -4,8 +4,8 @@ should use these same directives for consistency. *) -From Template Require All. - +(* From Template Require All. *) +Require Import Template.utils. Require Import FSets. Require Import ExtrOcamlBasic. Require Import ExtrOcamlString ExtrOcamlZInt. @@ -23,13 +23,10 @@ Set Warnings "-extraction-opaque-accessed". Require Export Template.Ast. -Cd "src". +Cd "gen-src". Require Import Template.TemplateMonad.Extractable. -Recursive Extraction Library TypingWf. -Recursive Extraction Library Checker. -Recursive Extraction Library Retyping. Recursive Extraction Library Extractable. Cd "..". \ No newline at end of file From 819f7c05d29274bbd81250da8d55dd9be759afa0 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 16:30:54 -0400 Subject: [PATCH 35/71] everything seems to work except the linker is droppign a symbol --- plugin-demo/Makefile | 3 +- plugin-demo/_CoqProject | 115 ++++++++++++++--------------- plugin-demo/src/.gitignore | 7 +- plugin-demo/src/demo_plugin.mlpack | 50 +++++++++++++ plugin-demo/src/movefiles.sh | 12 --- plugin-demo/theories/Demo.v | 1 - template-coq/Makefile | 4 +- template-coq/_PluginProject | 5 +- template-coq/test-plugin/test.v | 1 + 9 files changed, 120 insertions(+), 78 deletions(-) create mode 100644 plugin-demo/src/demo_plugin.mlpack delete mode 100755 plugin-demo/src/movefiles.sh create mode 100644 template-coq/test-plugin/test.v diff --git a/plugin-demo/Makefile b/plugin-demo/Makefile index 9d977108f..8ad4c2642 100644 --- a/plugin-demo/Makefile +++ b/plugin-demo/Makefile @@ -10,8 +10,7 @@ gen-src: $(MAKE) -C gen-src get-mc: - cp -r $(TEMPLATE_LIB)/src/*.ml $(TEMPLATE_LIB)/src/*.mli src - (cd src; ./movefiles.sh) + cp -r $(TEMPLATE_LIB)/gen-src/*.ml $(TEMPLATE_LIB)/gen-src/*.mli src .PHONY: get-mc gen-src diff --git a/plugin-demo/_CoqProject b/plugin-demo/_CoqProject index 7830acfa5..2a4c63c7d 100644 --- a/plugin-demo/_CoqProject +++ b/plugin-demo/_CoqProject @@ -1,65 +1,64 @@ --Q ../template-coq/theories Template -I src -Q theories Demo -src/ascii.ml -src/ascii.mli -src/ast0.ml -src/ast0.mli -src/astUtils.ml -src/astUtils.mli -src/basicAst.ml -src/basicAst.mli -src/basics.ml -src/basics.mli -src/binInt.ml -src/binInt.mli -src/binNat.ml -src/binNat.mli -src/binNums.ml -src/binNums.mli -src/binPosDef.ml -src/binPosDef.mli -src/binPos.ml -src/binPos.mli -src/bool.ml -src/bool.mli -src/common.ml -src/common.mli +src/Ascii.ml +src/Ascii.mli +src/Ast0.ml +src/Ast0.mli +src/AstUtils.ml +src/AstUtils.mli +src/BasicAst.ml +src/BasicAst.mli +src/Basics.ml +src/Basics.mli +src/BinInt.ml +src/BinInt.mli +src/BinNat.ml +src/BinNat.mli +src/BinNums.ml +src/BinNums.mli +src/BinPosDef.ml +src/BinPosDef.mli +src/BinPos.ml +src/BinPos.mli +src/Bool.ml +src/Bool.mli +src/Common.ml +src/Common.mli src/config0.ml src/config0.mli -src/datatypes.ml -src/datatypes.mli -src/decidableType.ml -src/decidableType.mli -src/decimal.ml -src/decimal.mli -src/equalities.ml -src/equalities.mli -src/extractable.ml -src/extractable.mli -src/fMapWeakList.ml -src/fMapWeakList.mli -src/list0.ml -src/list0.mli -src/logic.ml -src/logic.mli -src/mSetWeakList.ml -src/mSetWeakList.mli -src/nat0.ml -src/nat0.mli -src/orderedType0.ml -src/orderedType0.mli -src/orders.ml -src/orders.mli -src/ordersTac.ml -src/ordersTac.mli -src/peanoNat.ml -src/peanoNat.mli -src/specif.ml -src/specif.mli -src/string0.ml -src/string0.mli +src/Datatypes.ml +src/Datatypes.mli +src/DecidableType.ml +src/DecidableType.mli +src/Decimal.ml +src/Decimal.mli +src/Equalities.ml +src/Equalities.mli +src/Extractable.ml +src/Extractable.mli +src/FMapWeakList.ml +src/FMapWeakList.mli +src/List0.ml +src/List0.mli +src/Logic.ml +src/Logic.mli +src/MSetWeakList.ml +src/MSetWeakList.mli +src/Nat0.ml +src/Nat0.mli +src/OrderedType0.ml +src/OrderedType0.mli +src/Orders.ml +src/Orders.mli +src/OrdersTac.ml +src/OrdersTac.mli +src/PeanoNat.ml +src/PeanoNat.mli +src/Specif.ml +src/Specif.mli +src/String0.ml +src/String0.mli src/uGraph0.ml src/uGraph0.mli src/univ0.ml @@ -79,7 +78,7 @@ src/denoter.ml src/plugin_core.mli src/plugin_core.ml src/ast_quoter.ml -src/constr_quoter.ml # this shouldn't be necessary +src/ast_denoter.ml src/demo.ml src/demo.mli diff --git a/plugin-demo/src/.gitignore b/plugin-demo/src/.gitignore index 37230597a..68bcb3bff 100644 --- a/plugin-demo/src/.gitignore +++ b/plugin-demo/src/.gitignore @@ -1,2 +1,5 @@ -*.ml* -*.cm* \ No newline at end of file +*.ml +*.mli +*.cm* +*.o +*.a \ No newline at end of file diff --git a/plugin-demo/src/demo_plugin.mlpack b/plugin-demo/src/demo_plugin.mlpack new file mode 100644 index 000000000..3c267a87d --- /dev/null +++ b/plugin-demo/src/demo_plugin.mlpack @@ -0,0 +1,50 @@ +Datatypes +Utils +Basics +BinInt +BinNat +BinNums +BinPosDef +BinPos +Bool +Ascii +Ast0 +AstUtils +BasicAst +Common +Config0 + +Univ0 +DecidableType +Decimal +Denote +Denoter +Equalities +Extractable +FMapWeakList +List0 +Logic +MSetWeakList +Nat0 +OrderedType0 +Orders +OrdersTac +PeanoNat +Specif +String0 +UGraph0 + +Tm_util +Quoted +Quoter +Ast_quoter +Ast_denoter +Plugin_core +Run_extractable + +Demo +G_demo_plugin + +Datatypes +Datatypes +Datatypes \ No newline at end of file diff --git a/plugin-demo/src/movefiles.sh b/plugin-demo/src/movefiles.sh deleted file mode 100755 index f54553870..000000000 --- a/plugin-demo/src/movefiles.sh +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/bash - -shopt -s nullglob # make the for loop do nothnig when there is no *.ml* files - -for i in `ls *.ml *.mli`; do - # echo $i - j=`echo $i | cut -b 1 | tr '[:upper:]' '[:lower:]'`; # the first letter of file name is put in lowercase - k=`echo $i | cut -b 2-`; # the rest is untouched - if [ "$i" != "$j$k" ]; then - mv -f $i $j$k - fi -done diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index c8ca12abd..fd2a76121 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -1,3 +1,2 @@ -Require Import Template.Ast Template.TemplateMonad.Extractable. Require Import Coq.Strings.String. Declare ML Module "demo_plugin". diff --git a/template-coq/Makefile b/template-coq/Makefile index 149627030..eef72029f 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -5,7 +5,7 @@ coq: Makefile.coq plugin: coq Makefile.plugin gen-src/.generate @ echo "Copying from src to gen-src" - @ for x in $(TOCOPY); do rm -f gen-src/$$x; ln -s ../src/$$x gen-src/$$x; done + @ for x in $(TOCOPY); do rm -f gen-src/$$x; cp src/$$x gen-src/$$x; done $(MAKE) -f Makefile.plugin gen-src/.generate: theories/Extraction.vo theories/Extraction.v @@ -36,4 +36,4 @@ Makefile.plugin: _PluginProject .merlin: Makefile.coq $(MAKE) -f Makefile.coq .merlin -TOCOPY=ast_denoter.ml ast_quoter.ml denote.ml denoter.ml plugin_core.ml plugin_core.mli quoted.ml quoter.ml run_extractable.ml run_extractable.mli run_template_monad.mli tm_util.ml +TOCOPY=ast_denoter.ml ast_quoter.ml denote.ml denoter.ml plugin_core.ml plugin_core.mli quoted.ml quoter.ml run_extractable.ml run_extractable.mli tm_util.ml diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 322c1976a..12a633cf9 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -1,4 +1,5 @@ -I gen-src +-R test-plugin Test # Generated Code gen-src/Ascii.ml @@ -80,4 +81,6 @@ gen-src/ast_denoter.ml gen-src/run_extractable.ml gen-src/run_extractable.mli -gen-src/meta_coq_plugin_template.mlpack \ No newline at end of file +gen-src/meta_coq_plugin_template.mlpack + +test-plugin/test.v \ No newline at end of file diff --git a/template-coq/test-plugin/test.v b/template-coq/test-plugin/test.v new file mode 100644 index 000000000..bd2287f22 --- /dev/null +++ b/template-coq/test-plugin/test.v @@ -0,0 +1 @@ +Declare ML Module "meta_coq_plugin_template". \ No newline at end of file From b3adfca461db9141367be0161771cbaf8ddd3c75 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 17:00:16 -0400 Subject: [PATCH 36/71] working build of demo-plugin. --- plugin-demo/Makefile | 2 + plugin-demo/_CoqProject | 112 +++++++++--------- plugin-demo/src/demo_plugin.mlpack | 32 ++--- template-coq/_PluginProject | 112 +++++++++--------- .../gen-src/meta_coq_plugin_template.mlpack | 33 +++--- template-coq/gen-src/to-lower.sh | 9 ++ 6 files changed, 155 insertions(+), 145 deletions(-) create mode 100755 template-coq/gen-src/to-lower.sh diff --git a/plugin-demo/Makefile b/plugin-demo/Makefile index 8ad4c2642..96a6f7bde 100644 --- a/plugin-demo/Makefile +++ b/plugin-demo/Makefile @@ -10,6 +10,8 @@ gen-src: $(MAKE) -C gen-src get-mc: + cp -r $(TEMPLATE_LIB)/gen-src/to-lower.sh src + (cd src; ./to-lower.sh) cp -r $(TEMPLATE_LIB)/gen-src/*.ml $(TEMPLATE_LIB)/gen-src/*.mli src .PHONY: get-mc gen-src diff --git a/plugin-demo/_CoqProject b/plugin-demo/_CoqProject index 2a4c63c7d..df3789bb5 100644 --- a/plugin-demo/_CoqProject +++ b/plugin-demo/_CoqProject @@ -1,64 +1,64 @@ -I src -Q theories Demo -src/Ascii.ml -src/Ascii.mli -src/Ast0.ml -src/Ast0.mli -src/AstUtils.ml -src/AstUtils.mli -src/BasicAst.ml -src/BasicAst.mli -src/Basics.ml -src/Basics.mli -src/BinInt.ml -src/BinInt.mli -src/BinNat.ml -src/BinNat.mli -src/BinNums.ml -src/BinNums.mli -src/BinPosDef.ml -src/BinPosDef.mli -src/BinPos.ml -src/BinPos.mli -src/Bool.ml -src/Bool.mli -src/Common.ml -src/Common.mli +src/ascii.ml +src/ascii.mli +src/ast0.ml +src/ast0.mli +src/astUtils.ml +src/astUtils.mli +src/basicAst.ml +src/basicAst.mli +src/basics.ml +src/basics.mli +src/binInt.ml +src/binInt.mli +src/binNat.ml +src/binNat.mli +src/binNums.ml +src/binNums.mli +src/binPosDef.ml +src/binPosDef.mli +src/binPos.ml +src/binPos.mli +src/bool.ml +src/bool.mli +src/common.ml +src/common.mli src/config0.ml src/config0.mli -src/Datatypes.ml -src/Datatypes.mli -src/DecidableType.ml -src/DecidableType.mli -src/Decimal.ml -src/Decimal.mli -src/Equalities.ml -src/Equalities.mli -src/Extractable.ml -src/Extractable.mli -src/FMapWeakList.ml -src/FMapWeakList.mli -src/List0.ml -src/List0.mli -src/Logic.ml -src/Logic.mli -src/MSetWeakList.ml -src/MSetWeakList.mli -src/Nat0.ml -src/Nat0.mli -src/OrderedType0.ml -src/OrderedType0.mli -src/Orders.ml -src/Orders.mli -src/OrdersTac.ml -src/OrdersTac.mli -src/PeanoNat.ml -src/PeanoNat.mli -src/Specif.ml -src/Specif.mli -src/String0.ml -src/String0.mli +src/datatypes.ml +src/datatypes.mli +src/decidableType.ml +src/decidableType.mli +src/decimal.ml +src/decimal.mli +src/equalities.ml +src/equalities.mli +src/extractable.ml +src/extractable.mli +src/fMapWeakList.ml +src/fMapWeakList.mli +src/list0.ml +src/list0.mli +src/logic.ml +src/logic.mli +src/mSetWeakList.ml +src/mSetWeakList.mli +src/nat0.ml +src/nat0.mli +src/orderedType0.ml +src/orderedType0.mli +src/orders.ml +src/orders.mli +src/ordersTac.ml +src/ordersTac.mli +src/peanoNat.ml +src/peanoNat.mli +src/specif.ml +src/specif.mli +src/string0.ml +src/string0.mli src/uGraph0.ml src/uGraph0.mli src/univ0.ml diff --git a/plugin-demo/src/demo_plugin.mlpack b/plugin-demo/src/demo_plugin.mlpack index 3c267a87d..abe37536a 100644 --- a/plugin-demo/src/demo_plugin.mlpack +++ b/plugin-demo/src/demo_plugin.mlpack @@ -1,37 +1,37 @@ Datatypes +Bool +Decimal +Nat0 +List0 +PeanoNat Utils Basics -BinInt -BinNat -BinNums BinPosDef BinPos -Bool +BinNat +BinInt Ascii +String0 +DecidableType +Orders +OrdersTac +OrderedType0 +MSetWeakList +FMapWeakList +BinNums +Univ0 Ast0 AstUtils BasicAst Common Config0 -Univ0 -DecidableType -Decimal Denote Denoter Equalities Extractable -FMapWeakList -List0 Logic -MSetWeakList -Nat0 -OrderedType0 -Orders -OrdersTac -PeanoNat Specif -String0 UGraph0 Tm_util diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index 12a633cf9..ac9459cb5 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -2,64 +2,64 @@ -R test-plugin Test # Generated Code -gen-src/Ascii.ml -gen-src/Ascii.mli -gen-src/Ast0.ml -gen-src/Ast0.mli -gen-src/AstUtils.ml -gen-src/AstUtils.mli -gen-src/BasicAst.ml -gen-src/BasicAst.mli -gen-src/Basics.ml -gen-src/Basics.mli -gen-src/BinInt.ml -gen-src/BinInt.mli -gen-src/BinNat.ml -gen-src/BinNat.mli -gen-src/BinNums.ml -gen-src/BinNums.mli -gen-src/BinPosDef.ml -gen-src/BinPosDef.mli -gen-src/BinPos.ml -gen-src/BinPos.mli -gen-src/Bool.ml -gen-src/Bool.mli -gen-src/Common.ml -gen-src/Common.mli +gen-src/ascii.ml +gen-src/ascii.mli +gen-src/ast0.ml +gen-src/ast0.mli +gen-src/astUtils.ml +gen-src/astUtils.mli +gen-src/basicAst.ml +gen-src/basicAst.mli +gen-src/basics.ml +gen-src/basics.mli +gen-src/binInt.ml +gen-src/binInt.mli +gen-src/binNat.ml +gen-src/binNat.mli +gen-src/binNums.ml +gen-src/binNums.mli +gen-src/binPosDef.ml +gen-src/binPosDef.mli +gen-src/binPos.ml +gen-src/binPos.mli +gen-src/bool.ml +gen-src/bool.mli +gen-src/common.ml +gen-src/common.mli gen-src/config0.ml gen-src/config0.mli -gen-src/Datatypes.ml -gen-src/Datatypes.mli -gen-src/DecidableType.ml -gen-src/DecidableType.mli -gen-src/Decimal.ml -gen-src/Decimal.mli -gen-src/Equalities.ml -gen-src/Equalities.mli -gen-src/Extractable.ml -gen-src/Extractable.mli -gen-src/FMapWeakList.ml -gen-src/FMapWeakList.mli -gen-src/List0.ml -gen-src/List0.mli -gen-src/Logic.ml -gen-src/Logic.mli -gen-src/MSetWeakList.ml -gen-src/MSetWeakList.mli -gen-src/Nat0.ml -gen-src/Nat0.mli -gen-src/OrderedType0.ml -gen-src/OrderedType0.mli -gen-src/Orders.ml -gen-src/Orders.mli -gen-src/OrdersTac.ml -gen-src/OrdersTac.mli -gen-src/PeanoNat.ml -gen-src/PeanoNat.mli -gen-src/Specif.ml -gen-src/Specif.mli -gen-src/String0.ml -gen-src/String0.mli +gen-src/datatypes.ml +gen-src/datatypes.mli +gen-src/decidableType.ml +gen-src/decidableType.mli +gen-src/decimal.ml +gen-src/decimal.mli +gen-src/equalities.ml +gen-src/equalities.mli +gen-src/extractable.ml +gen-src/extractable.mli +gen-src/fMapWeakList.ml +gen-src/fMapWeakList.mli +gen-src/list0.ml +gen-src/list0.mli +gen-src/logic.ml +gen-src/logic.mli +gen-src/mSetWeakList.ml +gen-src/mSetWeakList.mli +gen-src/nat0.ml +gen-src/nat0.mli +gen-src/orderedType0.ml +gen-src/orderedType0.mli +gen-src/orders.ml +gen-src/orders.mli +gen-src/ordersTac.ml +gen-src/ordersTac.mli +gen-src/peanoNat.ml +gen-src/peanoNat.mli +gen-src/specif.ml +gen-src/specif.mli +gen-src/string0.ml +gen-src/string0.mli gen-src/uGraph0.ml gen-src/uGraph0.mli gen-src/univ0.ml diff --git a/template-coq/gen-src/meta_coq_plugin_template.mlpack b/template-coq/gen-src/meta_coq_plugin_template.mlpack index 1ae3ffd88..74679db84 100644 --- a/template-coq/gen-src/meta_coq_plugin_template.mlpack +++ b/template-coq/gen-src/meta_coq_plugin_template.mlpack @@ -1,40 +1,39 @@ Datatypes +Bool +Decimal +Nat0 +List0 +PeanoNat Utils Basics -BinInt -BinNat -BinNums BinPosDef BinPos -Bool +BinNat +BinInt Ascii +String0 +DecidableType +Orders +OrdersTac +OrderedType0 +MSetWeakList +FMapWeakList +BinNums +Univ0 Ast0 AstUtils BasicAst Common Config0 -Univ0 -DecidableType -Decimal Denote Denoter Equalities Extractable -FMapWeakList -List0 Logic -MSetWeakList -Nat0 -OrderedType0 -Orders -OrdersTac -PeanoNat Specif -String0 UGraph0 - Tm_util Quoted Quoter diff --git a/template-coq/gen-src/to-lower.sh b/template-coq/gen-src/to-lower.sh new file mode 100755 index 000000000..93bb3e362 --- /dev/null +++ b/template-coq/gen-src/to-lower.sh @@ -0,0 +1,9 @@ +for i in *.ml* +do + newi=`echo $i | cut -b 1 | tr '[:upper:]' '[:lower:]'``echo $i | cut -b 2-`; + if [ $i != $newi ] + then + echo "Moving " $i "to" $newi; + mv $i $newi; + fi +done From 9a95c3dcf8ba04835dd2356bcef62c01b4267328 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 17:05:11 -0400 Subject: [PATCH 37/71] lift clean_name and split_name --- template-coq/src/constr_denoter.ml | 8 ++------ template-coq/src/quoted.ml | 15 +++++++++++++++ template-coq/src/quoter.ml | 15 --------------- template-coq/src/run_template_monad.ml | 2 +- 4 files changed, 18 insertions(+), 22 deletions(-) diff --git a/template-coq/src/constr_denoter.ml b/template-coq/src/constr_denoter.ml index 452701182..0f5f305b4 100644 --- a/template-coq/src/constr_denoter.ml +++ b/template-coq/src/constr_denoter.ml @@ -136,10 +136,8 @@ struct evm, Univ.Instance.of_array (Array.of_list l) - let clean_name _ = failwith "clean_name" - let unquote_kn (k : quoted_kernel_name) : Libnames.qualid = - Libnames.qualid_of_string (clean_name (unquote_string k)) + Libnames.qualid_of_string (Quoted.clean_name (unquote_string k)) let unquote_proj (qp : quoted_proj) : (quoted_inductive * quoted_int * quoted_int) = let (h,args) = app_full qp [] in @@ -151,15 +149,13 @@ struct | _ -> bad_term_verb qp "unquote_proj") | _ -> bad_term_verb qp "unquote_proj" - let split_name _ = failwith "split_name" - let unquote_inductive trm = let (h,args) = app_full trm [] in if Constr.equal h tmkInd then match args with nm :: num :: _ -> let s = unquote_string nm in - let (dp, nm) = split_name s in + let (dp, nm) = Quoted.split_name s in (try match Nametab.locate (Libnames.make_qualid dp nm) with | Globnames.ConstRef c -> CErrors.user_err (str "this not an inductive constant. use tConst instead of tInd : " ++ str s) diff --git a/template-coq/src/quoted.ml b/template-coq/src/quoted.ml index 278cf7f10..3cb0c273e 100644 --- a/template-coq/src/quoted.ml +++ b/template-coq/src/quoted.ml @@ -41,6 +41,21 @@ let list_to_string l = aux 0 l; Bytes.to_string buf +(* Remove '#' from names *) +let clean_name s = + let l = List.rev (CString.split '#' s) in + match l with + s :: rst -> s + | [] -> raise (Failure "Empty name cannot be quoted") + +let split_name s : (Names.DirPath.t * Names.Id.t) = + let ss = List.rev (CString.split '.' s) in + match ss with + nm :: rst -> + let nm = clean_name nm in + let dp = (Names.DirPath.make (List.map Names.Id.of_string rst)) in (dp, Names.Id.of_string nm) + | [] -> raise (Failure "Empty name cannot be quoted") + module type Quoted = diff --git a/template-coq/src/quoter.ml b/template-coq/src/quoter.ml index 10f404edf..4fe3bc81a 100644 --- a/template-coq/src/quoter.ml +++ b/template-coq/src/quoter.ml @@ -36,21 +36,6 @@ let hnf_type env ty = in hnf_type true ty -(* Remove '#' from names *) -let clean_name s = - let l = List.rev (CString.split '#' s) in - match l with - s :: rst -> s - | [] -> raise (Failure "Empty name cannot be quoted") - -let split_name s : (Names.DirPath.t * Names.Id.t) = - let ss = List.rev (CString.split '.' s) in - match ss with - nm :: rst -> - let nm = clean_name nm in - let dp = (DirPath.make (List.map Id.of_string rst)) in (dp, Names.Id.of_string nm) - | [] -> raise (Failure "Empty name cannot be quoted") - module type Quoter = sig include Quoted diff --git a/template-coq/src/run_template_monad.ml b/template-coq/src/run_template_monad.ml index 4a1ef8f80..7f084f6eb 100644 --- a/template-coq/src/run_template_monad.ml +++ b/template-coq/src/run_template_monad.ml @@ -321,7 +321,7 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m k (env, evm, qt) | TmQuoteInd name -> let name = unquote_string (reduce_all env evm name) in - let (dp, nm) = split_name name in + let (dp, nm) = Quoted.split_name name in (match Nametab.locate (Libnames.make_qualid dp nm) with | Globnames.IndRef ni -> let t = TermReify.quote_mind_decl env (fst ni) in From 355b7cfd73278140b4740c53785a4857442b919d Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 14:44:39 -0700 Subject: [PATCH 38/71] capitalization fix. need to run to-lower before copying from template-coq --- plugin-demo/Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/plugin-demo/Makefile b/plugin-demo/Makefile index 96a6f7bde..f439b41e4 100644 --- a/plugin-demo/Makefile +++ b/plugin-demo/Makefile @@ -12,6 +12,7 @@ gen-src: get-mc: cp -r $(TEMPLATE_LIB)/gen-src/to-lower.sh src (cd src; ./to-lower.sh) + (cd $(TEMPLATE_LIB)/gen-src/; ./to-lower.sh) cp -r $(TEMPLATE_LIB)/gen-src/*.ml $(TEMPLATE_LIB)/gen-src/*.mli src .PHONY: get-mc gen-src From b96bc5124274b7330fc2255409a2aa0c6893f92d Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 14:54:03 -0700 Subject: [PATCH 39/71] removed more name clashes by blacklisting. error remains: CAMLOPT -pp -c -for-pack Demo_plugin src/g_demo_plugin.ml4 File "_none_", line 1: Error: Unbound module Run_extractable --- plugin-demo/_CoqProject | 8 ++++---- template-coq/theories/Extraction.v | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/plugin-demo/_CoqProject b/plugin-demo/_CoqProject index df3789bb5..c10fede7f 100644 --- a/plugin-demo/_CoqProject +++ b/plugin-demo/_CoqProject @@ -23,8 +23,8 @@ src/binPos.ml src/binPos.mli src/bool.ml src/bool.mli -src/common.ml -src/common.mli +src/common0.ml +src/common0.mli src/config0.ml src/config0.mli src/datatypes.ml @@ -41,8 +41,8 @@ src/fMapWeakList.ml src/fMapWeakList.mli src/list0.ml src/list0.mli -src/logic.ml -src/logic.mli +src/logic0.ml +src/logic0.mli src/mSetWeakList.ml src/mSetWeakList.mli src/nat0.ml diff --git a/template-coq/theories/Extraction.v b/template-coq/theories/Extraction.v index 165b1565b..41003f03b 100644 --- a/template-coq/theories/Extraction.v +++ b/template-coq/theories/Extraction.v @@ -18,7 +18,7 @@ Extract Constant utils.ascii_compare => "fun x y -> match Char.compare x y with 0 -> Eq | x when x < 0 -> Lt | _ -> Gt". Extraction Blacklist config uGraph univ Ast String List Nat Int - UnivSubst Typing Checker Retyping OrderedType. + UnivSubst Typing Checker Retyping OrderedType logic common. Set Warnings "-extraction-opaque-accessed". Require Export Template.Ast. From 13e414a64530496af7a15f4ef36fe45bf28f93da Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 15:15:13 -0700 Subject: [PATCH 40/71] propagated the renaming in HEAD^ to other files. eg. Common -> Common0 --- template-coq/Makefile | 1 + template-coq/_PluginProject | 8 ++++---- template-coq/src/run_extractable.ml | 2 +- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/template-coq/Makefile b/template-coq/Makefile index eef72029f..9ba0393a7 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -6,6 +6,7 @@ coq: Makefile.coq plugin: coq Makefile.plugin gen-src/.generate @ echo "Copying from src to gen-src" @ for x in $(TOCOPY); do rm -f gen-src/$$x; cp src/$$x gen-src/$$x; done + (cd gen-src; ./to-lower.sh) $(MAKE) -f Makefile.plugin gen-src/.generate: theories/Extraction.vo theories/Extraction.v diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index ac9459cb5..da230befc 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -24,8 +24,8 @@ gen-src/binPos.ml gen-src/binPos.mli gen-src/bool.ml gen-src/bool.mli -gen-src/common.ml -gen-src/common.mli +gen-src/common0.ml +gen-src/common0.mli gen-src/config0.ml gen-src/config0.mli gen-src/datatypes.ml @@ -42,8 +42,8 @@ gen-src/fMapWeakList.ml gen-src/fMapWeakList.mli gen-src/list0.ml gen-src/list0.mli -gen-src/logic.ml -gen-src/logic.mli +gen-src/logic0.ml +gen-src/logic0.mli gen-src/mSetWeakList.ml gen-src/mSetWeakList.mli gen-src/nat0.ml diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 6952b6587..ef4ee7bc3 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -15,7 +15,7 @@ let to_string : char list -> string = let of_string : string -> char list = Quoted.string_to_list -let to_reduction_strategy (s : Common.reductionStrategy) = +let to_reduction_strategy (s : Common0.reductionStrategy) = failwith "to_reduction_strategy" let to_ident : char list -> Names.Id.t = From 9afb9bbb90f90ba0cc3a467755405fd27996ea58 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 15:25:23 -0700 Subject: [PATCH 41/71] removed the redundant to-lower. it is now done in template-coq/gen-src --- plugin-demo/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin-demo/Makefile b/plugin-demo/Makefile index f439b41e4..fa1c44487 100644 --- a/plugin-demo/Makefile +++ b/plugin-demo/Makefile @@ -12,7 +12,7 @@ gen-src: get-mc: cp -r $(TEMPLATE_LIB)/gen-src/to-lower.sh src (cd src; ./to-lower.sh) - (cd $(TEMPLATE_LIB)/gen-src/; ./to-lower.sh) +# (cd $(TEMPLATE_LIB)/gen-src/; ./to-lower.sh) cp -r $(TEMPLATE_LIB)/gen-src/*.ml $(TEMPLATE_LIB)/gen-src/*.mli src .PHONY: get-mc gen-src From 98cb234df591fd01ab5d52ea27c00d79280b9f6b Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 18:29:45 -0400 Subject: [PATCH 42/71] some fixes --- plugin-demo/Makefile | 1 - template-coq/theories/Extraction.v | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/plugin-demo/Makefile b/plugin-demo/Makefile index fa1c44487..96a6f7bde 100644 --- a/plugin-demo/Makefile +++ b/plugin-demo/Makefile @@ -12,7 +12,6 @@ gen-src: get-mc: cp -r $(TEMPLATE_LIB)/gen-src/to-lower.sh src (cd src; ./to-lower.sh) -# (cd $(TEMPLATE_LIB)/gen-src/; ./to-lower.sh) cp -r $(TEMPLATE_LIB)/gen-src/*.ml $(TEMPLATE_LIB)/gen-src/*.mli src .PHONY: get-mc gen-src diff --git a/template-coq/theories/Extraction.v b/template-coq/theories/Extraction.v index 41003f03b..45222293a 100644 --- a/template-coq/theories/Extraction.v +++ b/template-coq/theories/Extraction.v @@ -18,7 +18,7 @@ Extract Constant utils.ascii_compare => "fun x y -> match Char.compare x y with 0 -> Eq | x when x < 0 -> Lt | _ -> Gt". Extraction Blacklist config uGraph univ Ast String List Nat Int - UnivSubst Typing Checker Retyping OrderedType logic common. + UnivSubst Typing Checker Retyping OrderedType Logic Common. Set Warnings "-extraction-opaque-accessed". Require Export Template.Ast. From c393b65566e6caf2ed64dcaceffce1f2d86984cd Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 18:55:35 -0400 Subject: [PATCH 43/71] a simple README for the plugin-demo --- plugin-demo/Makefile | 5 ++++- plugin-demo/README.md | 26 ++++++++++++++++++++++++++ plugin-demo/src/.gitignore | 3 ++- 3 files changed, 32 insertions(+), 2 deletions(-) create mode 100644 plugin-demo/README.md diff --git a/plugin-demo/Makefile b/plugin-demo/Makefile index 96a6f7bde..058d53b00 100644 --- a/plugin-demo/Makefile +++ b/plugin-demo/Makefile @@ -1,6 +1,6 @@ TEMPLATE_LIB=../template-coq -coq: Makefile.coq +coq: sources Makefile.coq $(MAKE) -f Makefile.coq Makefile.coq: _CoqProject gen-src get-mc @@ -18,3 +18,6 @@ get-mc: clean: $(MAKE) -f Makefile.coq clean + +sources: + $(MAKE) -C gen-src diff --git a/plugin-demo/README.md b/plugin-demo/README.md new file mode 100644 index 000000000..430d42ea4 --- /dev/null +++ b/plugin-demo/README.md @@ -0,0 +1,26 @@ +# Writing a Plugin with the Extractable Monad + +You can use `Template.TemplateMonad.Extractable` to write plugins in Gallina. +You can use this project as a template for doing this. + + +**Beware**: Things are a little bit convoluted/brittle due to the extraction processes. +Pull requests are welcome. + +## How to use it + +1. Write your plugin inside the `gen-src` directory (using the `_CoqProject` in that directory). The plugin should use the `Template.TemplateMonad.Extractable` monad to interact with Coq. +2. Modify the `gen-src/Extract.v` file to extract the module that you want to call from your plugin. +3. Run `make sources` which will build the Coq sources to your plugin and extract them to OCaml. +4. In the `src` directory, write the entry point to your plugin. See `src/g_plugin_demo.ml4` for some examples. *Make sure that you do not use any names that conflict with names of `ml` files inside of `template-coq`.* +5. In the `src` directory, create an `mlpack` file which includes all the files that you need. This file *must* start with the template located in `template-coq/gen-src/meta_coq_plugin_template.mlpack` to ensure that it uses the appropriate dependencies. +6. Include any Coq files that your plugin requires in the top-level `theories` directory. +7. Build the plugin from the root directory and you should be good to go. + + +## How it works + +As mentioned above, things are a bit brittle. +Essentially, what the `Makefile` does is first build the contents of `gen-src` to build the OCaml for the plugin. +The recursive extraction command will generate all of the files into the `src` directory, including the files that `template-coq` provides. +The top-level `Makefile` then copies the contents of the `template-coq/gen-src` directory over the `src` directory before building it to ensure that everything is consistent. diff --git a/plugin-demo/src/.gitignore b/plugin-demo/src/.gitignore index 68bcb3bff..573f734a5 100644 --- a/plugin-demo/src/.gitignore +++ b/plugin-demo/src/.gitignore @@ -2,4 +2,5 @@ *.mli *.cm* *.o -*.a \ No newline at end of file +*.a +to-lower.sh \ No newline at end of file From bcb71dade3ee22820f26a01e8fdfb58ce5efe534 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (on lenovo laptop)" Date: Tue, 9 Apr 2019 16:02:37 -0700 Subject: [PATCH 44/71] partial implementation of to_kernname. can now test quoting --- template-coq/src/run_extractable.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index f00da3c29..7f72c90bb 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -42,8 +42,13 @@ let of_qualid (q : Libnames.qualid) : char list = let of_kername : Names.KerName.t -> char list = Ast_quoter.quote_kn +(* TODO: check that [s] was fully qualified *) let to_kername (s : char list) : Names.KerName.t = - (* Ast_quoter.unquote_kn c *) failwith "to_kername" + match Nametab.locate (Ast_quoter.unquote_kn s) with + | Globnames.VarRef vr -> failwith "not yet implemented" + | Globnames.ConstRef c -> Names.Constant.canonical c + | Globnames.IndRef i -> Names.MutInd.canonical (fst i) + | Globnames.ConstructRef c -> failwith "not yet implemented" (* todo(gmm): this definition adapted from quoter.ml *) let quote_rel_decl env = function From 2db0ac30223f76488a96838a13b51d0233267485 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 19:55:54 -0400 Subject: [PATCH 45/71] fixing the checker plugin --- checker/Makefile | 31 +- checker/_CoqProject | 171 ++++---- checker/gen-src/Extract.v | 9 + checker/gen-src/Makefile | 8 + checker/gen-src/_CoqProject | 5 + checker/src/.gitignore | 3 + checker/src/g_template_checker.ml4 | 2 +- .../src/template_coq_checker_plugin.mlpack | 44 +- checker/src/term_quoter.ml | 380 ------------------ plugin-demo/_CoqProject | 23 +- template-coq/Makefile | 2 + 11 files changed, 185 insertions(+), 493 deletions(-) create mode 100644 checker/gen-src/Extract.v create mode 100644 checker/gen-src/Makefile create mode 100644 checker/gen-src/_CoqProject create mode 100644 checker/src/.gitignore delete mode 100644 checker/src/term_quoter.ml diff --git a/checker/Makefile b/checker/Makefile index 5ae45fd51..058d53b00 100644 --- a/checker/Makefile +++ b/checker/Makefile @@ -1,22 +1,23 @@ -all: Makefile.coq - $(MAKE) -f Makefile.coq +TEMPLATE_LIB=../template-coq -.PHONY: all install html clean mrproper +coq: sources Makefile.coq + $(MAKE) -f Makefile.coq -install: Makefile.coq - $(MAKE) -f Makefile.coq install +Makefile.coq: _CoqProject gen-src get-mc + coq_makefile -f _CoqProject -o Makefile.coq -html: all - $(MAKE) -f Makefile.coq html +gen-src: + $(MAKE) -C gen-src -clean: Makefile.coq - $(MAKE) -f Makefile.coq clean +get-mc: + cp -r $(TEMPLATE_LIB)/gen-src/to-lower.sh src + (cd src; ./to-lower.sh) + cp -r $(TEMPLATE_LIB)/gen-src/*.ml $(TEMPLATE_LIB)/gen-src/*.mli src -mrproper: clean - rm -f Makefile.coq +.PHONY: get-mc gen-src -Makefile.coq: _CoqProject - coq_makefile -f _CoqProject -o Makefile.coq +clean: + $(MAKE) -f Makefile.coq clean -.merlin: Makefile.coq - $(MAKE) -f Makefile.coq .merlin +sources: + $(MAKE) -C gen-src diff --git a/checker/_CoqProject b/checker/_CoqProject index 298c9f671..4441f306a 100644 --- a/checker/_CoqProject +++ b/checker/_CoqProject @@ -1,90 +1,107 @@ --R ../template-coq/theories Template --R theories TemplateChecker --I ../template-coq/src +-Q ../template-coq/theories Template +-I ../template-coq/build -I src --Q src TemplateChecker +-Q theories TemplateChecker -src/decimal.mli -src/decimal.ml -src/peanoNat.mli -src/peanoNat.ml -src/datatypes.mli -src/datatypes.ml -src/bool.mli -src/bool.ml -src/checker0.mli src/checker0.ml -src/utils.mli -src/utils.ml -src/config0.mli -src/config0.ml -src/univSubst0.mli -src/univSubst0.ml -src/univ0.mli -src/univ0.ml -src/nat0.mli -src/nat0.ml -src/mSetWeakList.mli -src/mSetWeakList.ml -src/list0.mli -src/list0.ml -src/specif.mli -src/specif.ml -src/equalities.mli -src/equalities.ml -src/basics.mli -src/basics.ml -src/fSetWeakList.mli -src/fSetWeakList.ml -src/decidableType.mli -src/decidableType.ml -src/fMapWeakList.mli -src/fMapWeakList.ml -src/ascii.mli -src/ascii.ml -src/binNums.mli -src/binNums.ml -src/binNat.mli -src/binNat.ml -src/binPos.mli -src/binPos.ml -src/binPosDef.mli -src/binPosDef.ml - -src/orders.mli -src/orders.ml -src/ordersTac.mli -src/ordersTac.ml -src/orderedType0.mli -src/orderedType0.ml - -src/basicAst.mli -src/basicAst.ml -src/ast0.mli -src/ast0.ml -src/astUtils.mli -src/astUtils.ml -src/uGraph0.mli -src/uGraph0.ml -src/binInt.mli -src/binInt.ml -src/monad_utils.mli -src/monad_utils.ml -src/templateMonad.mli -src/templateMonad.ml -src/typing0.mli -src/typing0.ml -src/string0.mli -src/string0.ml -src/liftSubst.mli +src/checker0.mli src/liftSubst.ml -src/retyping0.mli +src/liftSubst.mli +src/monad_utils.ml +src/monad_utils.mli src/retyping0.ml +src/retyping0.mli +src/typing0.ml +src/typing0.mli src/typingWf.ml src/typingWf.mli +src/univSubst0.ml +src/univSubst0.mli +src/wf.ml +src/wf.mli src/term_quoter.ml src/g_template_checker.ml4 src/template_coq_checker_plugin.mlpack theories/Loader.v + +# from MetaCoq (include verbatim) +src/ascii.ml +src/ascii.mli +src/ast0.ml +src/ast0.mli +src/astUtils.ml +src/astUtils.mli +src/basicAst.ml +src/basicAst.mli +src/basics.ml +src/basics.mli +src/binInt.ml +src/binInt.mli +src/binNat.ml +src/binNat.mli +src/binNums.ml +src/binNums.mli +src/binPosDef.ml +src/binPosDef.mli +src/binPos.ml +src/binPos.mli +src/bool.ml +src/bool.mli +src/common0.ml +src/common0.mli +src/config0.ml +src/config0.mli +src/datatypes.ml +src/datatypes.mli +src/decidableType.ml +src/decidableType.mli +src/decimal.ml +src/decimal.mli +src/equalities.ml +src/equalities.mli +src/extractable.ml +src/extractable.mli +src/fMapWeakList.ml +src/fMapWeakList.mli +src/list0.ml +src/list0.mli +src/logic0.ml +src/logic0.mli +src/mSetWeakList.ml +src/mSetWeakList.mli +src/nat0.ml +src/nat0.mli +src/orderedType0.ml +src/orderedType0.mli +src/orders.ml +src/orders.mli +src/ordersTac.ml +src/ordersTac.mli +src/peanoNat.ml +src/peanoNat.mli +src/specif.ml +src/specif.mli +src/string0.ml +src/string0.mli +src/uGraph0.ml +src/uGraph0.mli +src/univ0.ml +src/univ0.mli +src/utils.ml +src/utils.mli + +# From MetaCoq +src/run_extractable.mli +src/run_extractable.ml +src/tm_util.ml +src/quoter.ml +src/quoted.ml +src/denote.ml +src/denote.mli +src/denoter.ml +src/plugin_core.mli +src/plugin_core.ml +src/ast_quoter.ml +src/ast_denoter.ml diff --git a/checker/gen-src/Extract.v b/checker/gen-src/Extract.v new file mode 100644 index 000000000..0f53bed41 --- /dev/null +++ b/checker/gen-src/Extract.v @@ -0,0 +1,9 @@ +From Template Require Import All Extraction. + +Cd "../src". + +Recursive Extraction Library TypingWf. +Recursive Extraction Library Checker. +Recursive Extraction Library Retyping. + +Cd "../gen-src". \ No newline at end of file diff --git a/checker/gen-src/Makefile b/checker/gen-src/Makefile new file mode 100644 index 000000000..7f6123f7f --- /dev/null +++ b/checker/gen-src/Makefile @@ -0,0 +1,8 @@ +coq: Makefile.coq + $(MAKE) -f Makefile.coq + +Makefile.coq: _CoqProject + coq_makefile -f _CoqProject -o Makefile.coq + +clean: Makefile.coq + $(MAKE) -f Makefile.coq clean diff --git a/checker/gen-src/_CoqProject b/checker/gen-src/_CoqProject new file mode 100644 index 000000000..17b07667b --- /dev/null +++ b/checker/gen-src/_CoqProject @@ -0,0 +1,5 @@ +-R ../../template-coq/theories Template +-I ../../template-coq/src +-Q . Checker + +Extract.v \ No newline at end of file diff --git a/checker/src/.gitignore b/checker/src/.gitignore new file mode 100644 index 000000000..bd41c435d --- /dev/null +++ b/checker/src/.gitignore @@ -0,0 +1,3 @@ +*.mli +*.ml +to-lower.sh \ No newline at end of file diff --git a/checker/src/g_template_checker.ml4 b/checker/src/g_template_checker.ml4 index 65b80e6c9..59af545bf 100644 --- a/checker/src/g_template_checker.ml4 +++ b/checker/src/g_template_checker.ml4 @@ -12,7 +12,7 @@ let pr_char_list = prlist_with_sep mt pr_char let check env evm c = (* Feedback.msg_debug (str"Quoting"); *) - let term = Term_quoter.quote_term_rec env (EConstr.to_constr evm c) in + let term = Ast_quoter.quote_term_rec env (EConstr.to_constr evm c) in (* Feedback.msg_debug (str"Finished quoting.. checking."); *) let fuel = pow two (pow two (pow two two)) in let checker_flags = true in diff --git a/checker/src/template_coq_checker_plugin.mlpack b/checker/src/template_coq_checker_plugin.mlpack index 441688c60..746897925 100644 --- a/checker/src/template_coq_checker_plugin.mlpack +++ b/checker/src/template_coq_checker_plugin.mlpack @@ -1,26 +1,50 @@ -Decimal Datatypes Bool -PeanoNat +Decimal +Nat0 List0 -Equalities -DecidableType +PeanoNat +Utils Basics -MSetWeakList -FSetWeakList -FMapWeakList -Nat0 -BinNums BinPosDef BinPos BinNat BinInt Ascii String0 -Specif +DecidableType Orders OrdersTac OrderedType0 +MSetWeakList +FMapWeakList +BinNums +Univ0 +Ast0 +AstUtils +BasicAst +Common +Config0 + +Denote +Denoter +Equalities +Extractable +Logic +Specif +UGraph0 + +Tm_util +Quoted +Quoter +Ast_quoter +Ast_denoter +Plugin_core +Run_extractable + + + +FSetWeakList Utils Config0 diff --git a/checker/src/term_quoter.ml b/checker/src/term_quoter.ml deleted file mode 100644 index 9425b42ea..000000000 --- a/checker/src/term_quoter.ml +++ /dev/null @@ -1,380 +0,0 @@ -(*i camlp4deps: "parsing/grammar.cma" i*) -(*i camlp4use: "pa_extend.cmp" i*) - -open Constr -open BasicAst -open Ast0 -open Template_coq -open Quoted -open Quoter - -let quote_string s = - let rec aux acc i = - if i < 0 then acc - else aux (s.[i] :: acc) (i - 1) - in aux [] (String.length s - 1) - -let unquote_string l = - let buf = Bytes.create (List.length l) in - let rec aux i = function - | [] -> () - | c :: cs -> - Bytes.set buf i c; aux (succ i) cs - in - aux 0 l; - Bytes.to_string buf - -module TemplateASTQuoter = -struct - type t = term - type quoted_ident = char list - type quoted_int = Datatypes.nat - type quoted_bool = bool - type quoted_name = name - type quoted_sort = Univ0.universe - type quoted_cast_kind = cast_kind - type quoted_kernel_name = char list - type quoted_inductive = inductive - type quoted_proj = projection - type quoted_global_reference = global_reference - - type quoted_sort_family = sort_family - type quoted_constraint_type = Univ0.constraint_type - type quoted_univ_constraint = Univ0.univ_constraint - type quoted_univ_instance = Univ0.Instance.t - type quoted_univ_constraints = Univ0.constraints - type quoted_univ_context = Univ0.universe_context - type quoted_inductive_universes = quoted_univ_context - - type quoted_mind_params = (ident * local_entry) list - type quoted_ind_entry = quoted_ident * t * quoted_bool * quoted_ident list * t list - type quoted_definition_entry = t * t option * quoted_univ_context - type quoted_mind_entry = mutual_inductive_entry - type quoted_mind_finiteness = recursivity_kind - type quoted_entry = (constant_entry, quoted_mind_entry) sum option - - type quoted_context_decl = context_decl - type quoted_context = context - type quoted_one_inductive_body = one_inductive_body - type quoted_mutual_inductive_body = mutual_inductive_body - type quoted_constant_body = constant_body - type quoted_global_decl = global_decl - type quoted_global_declarations = global_declarations - type quoted_program = program - - open Names - - let quote_ident id = - quote_string (Id.to_string id) - - let quote_name = function - | Anonymous -> Coq_nAnon - | Name i -> Coq_nNamed (quote_ident i) - - let quote_int i = - let rec aux acc i = - if i < 0 then acc - else aux (Datatypes.S acc) (i - 1) - in aux Datatypes.O (i - 1) - - let quote_bool x = x - - let quote_level l = - if Univ.Level.is_prop l then Univ0.Level.prop - else if Univ.Level.is_set l then Univ0.Level.set - else match Univ.Level.var_index l with - | Some x -> Univ0.Level.Var (quote_int x) - | None -> Univ0.Level.Level (quote_string (Univ.Level.to_string l)) - - let quote_universe s : Univ0.universe = - (* hack because we can't recover the list of level*int *) - (* todo : map on LSet is now exposed in Coq trunk, we should use it to remove this hack *) - let levels = Univ.LSet.elements (Univ.Universe.levels s) in - List.map (fun l -> let l' = quote_level l in - (* is indeed i always 0 or 1 ? *) - let b' = quote_bool (Univ.Universe.exists (fun (l2,i) -> Univ.Level.equal l l2 && i = 1) s) in - (l', b')) - levels - - let quote_sort s = - quote_universe (Sorts.univ_of_sort s) - - let quote_sort_family s = - match s with - | Sorts.InProp -> BasicAst.InProp - | Sorts.InSet -> BasicAst.InSet - | Sorts.InType -> BasicAst.InType - - let quote_cast_kind = function - | DEFAULTcast -> Cast - | REVERTcast -> RevertCast - | NATIVEcast -> NativeCast - | VMcast -> VmCast - - let quote_kn kn = quote_string (KerName.to_string kn) - let quote_inductive (kn, i) = { inductive_mind = kn ; inductive_ind = i } - let quote_proj ind p a = ((ind,p),a) - - let quote_constraint_type = function - | Univ.Lt -> Univ0.ConstraintType.Lt - | Univ.Le -> Univ0.ConstraintType.Le - | Univ.Eq -> Univ0.ConstraintType.Eq - - let quote_univ_constraint ((l, ct, l') : Univ.univ_constraint) : quoted_univ_constraint = - ((quote_level l, quote_constraint_type ct), quote_level l') - - let quote_univ_instance (i : Univ.Instance.t) : quoted_univ_instance = - let arr = Univ.Instance.to_array i in - CArray.map_to_list quote_level arr - - let quote_univ_constraints (c : Univ.Constraint.t) : quoted_univ_constraints = - let l = List.map quote_univ_constraint (Univ.Constraint.elements c) in - Univ0.ConstraintSet.(List.fold_right add l empty) - - let quote_variance (v : Univ.Variance.t) = - match v with - | Univ.Variance.Irrelevant -> Univ0.Variance.Irrelevant - | Univ.Variance.Covariant -> Univ0.Variance.Covariant - | Univ.Variance.Invariant -> Univ0.Variance.Invariant - - let quote_cuminfo_variance (var : Univ.Variance.t array) = - CArray.map_to_list quote_variance var - - let quote_univ_context (uctx : Univ.UContext.t) : quoted_univ_context = - let levels = Univ.UContext.instance uctx in - let constraints = Univ.UContext.constraints uctx in - Univ0.Monomorphic_ctx (quote_univ_instance levels, quote_univ_constraints constraints) - - let quote_cumulative_univ_context (cumi : Univ.CumulativityInfo.t) : quoted_univ_context = - let uctx = Univ.CumulativityInfo.univ_context cumi in - let levels = Univ.UContext.instance uctx in - let constraints = Univ.UContext.constraints uctx in - let var = Univ.CumulativityInfo.variance cumi in - let uctx' = (quote_univ_instance levels, quote_univ_constraints constraints) in - let var' = quote_cuminfo_variance var in - Univ0.Cumulative_ctx (uctx', var') - - let quote_abstract_univ_context_aux uctx : quoted_univ_context = - let levels = Univ.UContext.instance uctx in - let constraints = Univ.UContext.constraints uctx in - Univ0.Polymorphic_ctx (quote_univ_instance levels, quote_univ_constraints constraints) - - let quote_abstract_univ_context (uctx : Univ.AUContext.t) = - let uctx = Univ.AUContext.repr uctx in - quote_abstract_univ_context_aux uctx - - let quote_inductive_universes = function - | Entries.Monomorphic_ind_entry ctx -> quote_univ_context (Univ.ContextSet.to_context ctx) - | Entries.Polymorphic_ind_entry ctx -> quote_abstract_univ_context_aux ctx - | Entries.Cumulative_ind_entry ctx -> - quote_abstract_univ_context_aux (Univ.CumulativityInfo.univ_context ctx) - - let quote_context_decl na b t = - { decl_name = na; - decl_body = b; - decl_type = t } - - let quote_context l = l - - let mkAnon = Coq_nAnon - let mkName i = Coq_nNamed i - - let mkRel n = Coq_tRel n - let mkVar id = Coq_tVar id - let mkMeta n = Coq_tMeta n - let mkEvar n args = Coq_tEvar (n,Array.to_list args) - let mkSort s = Coq_tSort s - let mkCast c k t = Coq_tCast (c,k,t) - - let mkConst c u = Coq_tConst (c, u) - let mkProd na t b = Coq_tProd (na, t, b) - let mkLambda na t b = Coq_tLambda (na, t, b) - let mkApp f xs = Coq_tApp (f, Array.to_list xs) - let mkInd i u = Coq_tInd (i, u) - let mkConstruct (ind, i) u = Coq_tConstruct (ind, i, u) - let mkLetIn na b t t' = Coq_tLetIn (na,b,t,t') - - let rec seq f t = - if f < t then - f :: seq (f + 1) t - else [] - - let mkFix ((a,b),(ns,ts,ds)) = - let mk_fun xs i = - { dname = Array.get ns i ; - dtype = Array.get ts i ; - dbody = Array.get ds i ; - rarg = Array.get a i } :: xs - in - let defs = List.fold_left mk_fun [] (seq 0 (Array.length a)) in - let block = List.rev defs in - Coq_tFix (block, b) - - let mkCoFix (a,(ns,ts,ds)) = - let mk_fun xs i = - { dname = Array.get ns i ; - dtype = Array.get ts i ; - dbody = Array.get ds i ; - rarg = Datatypes.O } :: xs - in - let defs = List.fold_left mk_fun [] (seq 0 (Array.length ns)) in - let block = List.rev defs in - Coq_tFix (block, a) - - let mkCase (ind, npar) nargs p c brs = - let info = (ind, npar) in - let branches = List.map2 (fun br nargs -> (nargs, br)) brs nargs in - Coq_tCase (info,p,c,branches) - let mkProj p c = Coq_tProj (p,c) - - let mk_one_inductive_body (id, ty, kel, ctr, proj) = - let ctr = List.map (fun (a, b, c) -> ((a, b), c)) ctr in - { ind_name = id; ind_type = ty; - ind_kelim = kel; ind_ctors = ctr; ind_projs = proj } - - let mk_mutual_inductive_body npars params inds uctx = - {ind_npars = npars; ind_params = params; ind_bodies = inds; ind_universes = uctx} - - let mk_constant_body ty tm uctx = - {cst_type = ty; cst_body = tm; cst_universes = uctx} - - let mk_inductive_decl kn bdy = InductiveDecl (kn, bdy) - - let mk_constant_decl kn bdy = ConstantDecl (kn, bdy) - - let empty_global_declartions = [] - - let add_global_decl a b = a :: b - - let mk_program decls tm = (decls, tm) - - let quote_mind_finiteness = function - | Declarations.Finite -> Finite - | Declarations.CoFinite -> CoFinite - | Declarations.BiFinite -> BiFinite - - let quote_mind_params l = - let map (id, body) = - match body with - | Left ty -> (id, LocalAssum ty) - | Right trm -> (id, LocalDef trm) - in List.map map l - - let quote_one_inductive_entry (id, ar, b, consnames, constypes) = - { mind_entry_typename = id; - mind_entry_arity = ar; - mind_entry_template = b; - mind_entry_consnames = consnames; - mind_entry_lc = constypes } - - let quote_mutual_inductive_entry (mf, mp, is, univs) = - { mind_entry_record = None; - mind_entry_finite = mf; - mind_entry_params = mp; - mind_entry_inds = List.map quote_one_inductive_entry is; - mind_entry_universes = univs; - mind_entry_private = None } - - let quote_entry e = - match e with - | Some (Left (ty, body, ctx)) -> - let entry = match body with - | None -> ParameterEntry { parameter_entry_type = ty; - parameter_entry_universes = ctx } - | Some b -> DefinitionEntry { definition_entry_type = ty; - definition_entry_body = b; - definition_entry_universes = ctx; - definition_entry_opaque = false } - in Some (Left entry) - | Some (Right mind_entry) -> - Some (Right mind_entry) - | None -> None - - let inspectTerm (t : term) : (term, quoted_int, quoted_ident, quoted_name, quoted_sort, quoted_cast_kind, quoted_kernel_name, quoted_inductive, quoted_univ_instance, quoted_proj) structure_of_term = - match t with - | Coq_tRel n -> ACoq_tRel n - (* so on *) - | _ -> failwith "not yet implemented" - - - - - let unquote_ident (qi: quoted_ident) : Id.t = - let s = unquote_string qi in - Id.of_string s - - let unquote_name (q: quoted_name) : Name.t = - match q with - | Coq_nAnon -> Anonymous - | Coq_nNamed n -> Name (unquote_ident n) - - let rec unquote_int (q: quoted_int) : int = - match q with - | Datatypes.O -> 0 - | Datatypes.S x -> succ (unquote_int x) - - let unquote_bool (q : quoted_bool) : bool = q - - (* val unquote_sort : quoted_sort -> Sorts.t *) - (* val unquote_sort_family : quoted_sort_family -> Sorts.family *) - let unquote_cast_kind (q : quoted_cast_kind) : Constr.cast_kind = - match q with - | VmCast -> VMcast - | NativeCast -> NATIVEcast - | Cast -> DEFAULTcast - | RevertCast -> REVERTcast - - let unquote_kn (q: quoted_kernel_name) : Libnames.qualid = - let s = unquote_string q in - Libnames.qualid_of_string s - - let unquote_inductive (q: quoted_inductive) : Names.inductive = - let { inductive_mind = na; inductive_ind = i } = q in - let comps = CString.split '.' (unquote_string na) in - let comps = List.map Id.of_string comps in - let id, dp = CList.sep_last comps in - let dp = DirPath.make dp in - let mind = Globnames.encode_mind dp id in - (mind, unquote_int i) - - (*val unquote_univ_instance : quoted_univ_instance -> Univ.Instance.t *) - let unquote_proj (q : quoted_proj) : (quoted_inductive * quoted_int * quoted_int) = - let (ind, ps), idx = q in - (ind, ps, idx) - - let unquote_level (trm : Univ0.Level.t) : Univ.Level.t = - match trm with - | Univ0.Level.Coq_lProp -> Univ.Level.prop - | Univ0.Level.Coq_lSet -> Univ.Level.set - | Univ0.Level.Level s -> - let s = unquote_string s in - let comps = CString.split '.' s in - let last, dp = CList.sep_last comps in - let dp = DirPath.make (List.map Id.of_string comps) in - let idx = int_of_string last in - Univ.Level.make dp idx - | Univ0.Level.Var n -> Univ.Level.var (unquote_int n) - - let unquote_level_expr (trm : Univ0.Level.t) (b : quoted_bool) : Univ.Universe.t = - let l = unquote_level trm in - let u = Univ.Universe.make l in - if b then Univ.Universe.super u - else u - - let unquote_universe evd (trm : Univ0.Universe.t) = - match trm with - | [] -> Evd.new_univ_variable (Evd.UnivFlexible false) evd - | (l,b)::q -> - evd, List.fold_left (fun u (l,b) -> - let u' = unquote_level_expr l b in Univ.Universe.sup u u') - (unquote_level_expr l b) q - - let print_term (u: t) : Pp.t = failwith "print_term in term_quoter.ml not yet implemented" - -end - - - -module TemplateASTReifier = Reify(TemplateASTQuoter) - -include TemplateASTReifier diff --git a/plugin-demo/_CoqProject b/plugin-demo/_CoqProject index c10fede7f..551c7f0eb 100644 --- a/plugin-demo/_CoqProject +++ b/plugin-demo/_CoqProject @@ -1,6 +1,18 @@ -I src -Q theories Demo + +src/demo.ml +src/demo.mli + + +src/g_demo_plugin.ml4 +src/demo_plugin.mlpack + +theories/Demo.v + + +# from MetaCoq (include verbatim) src/ascii.ml src/ascii.mli src/ast0.ml @@ -66,7 +78,7 @@ src/univ0.mli src/utils.ml src/utils.mli -# copied from MetaCoq +# From MetaCoq src/run_extractable.mli src/run_extractable.ml src/tm_util.ml @@ -79,12 +91,3 @@ src/plugin_core.mli src/plugin_core.ml src/ast_quoter.ml src/ast_denoter.ml - -src/demo.ml -src/demo.mli - - -src/g_demo_plugin.ml4 -src/demo_plugin.mlpack - -theories/Demo.v \ No newline at end of file diff --git a/template-coq/Makefile b/template-coq/Makefile index 9ba0393a7..517427d4a 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -2,6 +2,8 @@ all: coq plugin coq: Makefile.coq $(MAKE) -f Makefile.coq + cp src/template_coq.cmx src/template_coq.cmxa src/template_coq.cmxs build + plugin: coq Makefile.plugin gen-src/.generate @ echo "Copying from src to gen-src" From 3bef645e9f59c6efc136f8226cd2bc50c11cb8ab Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 9 Apr 2019 20:10:10 -0400 Subject: [PATCH 46/71] fixing some Makefiles --- Makefile | 7 +++++-- template-coq/Makefile | 1 + template-coq/_PluginProject | 2 -- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 6780d1a14..2ced02b9b 100644 --- a/Makefile +++ b/Makefile @@ -1,8 +1,8 @@ -all: template-coq checker pcuic extraction +all: template-coq plugin-demo checker pcuic extraction .PHONY: all template-coq checker install html clean mrproper .merlin test-suite translations -install: +install: $(MAKE) -C template-coq install $(MAKE) -C checker install $(MAKE) -C pcuic install @@ -42,6 +42,9 @@ template-coq: pcuic: template-coq $(MAKE) -C pcuic +plugin-demo: template-coq + $(MAKE) -C plugin-demo + extraction: checker template-coq pcuic $(MAKE) -C extraction diff --git a/template-coq/Makefile b/template-coq/Makefile index 517427d4a..13ee76d58 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -2,6 +2,7 @@ all: coq plugin coq: Makefile.coq $(MAKE) -f Makefile.coq + mkdir -p build cp src/template_coq.cmx src/template_coq.cmxa src/template_coq.cmxs build diff --git a/template-coq/_PluginProject b/template-coq/_PluginProject index da230befc..8adc44e4d 100644 --- a/template-coq/_PluginProject +++ b/template-coq/_PluginProject @@ -82,5 +82,3 @@ gen-src/run_extractable.ml gen-src/run_extractable.mli gen-src/meta_coq_plugin_template.mlpack - -test-plugin/test.v \ No newline at end of file From c9525ad80d36af6dd6b6accb3306d5057e9b761b Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 17:30:01 -0700 Subject: [PATCH 47/71] ported genLensN to TM.Extractable --- plugin-demo/gen-src/demo.v | 229 +++++++++++++++++++++++++++++++++++++ 1 file changed, 229 insertions(+) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index debf3280d..deee694df 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -1,7 +1,236 @@ From Template Require Import Ast + Loader TemplateMonad.Extractable. Definition showoff : TM unit := tmMsg "running from an extracted plugin!". + + +Require Import ExtLib.Structures.Functor. +Require Import ExtLib.Structures.Monad. +Require Import ExtLib.Structures.MonadState. +Require Import ExtLib.Structures.MonadExc. + +Set Primitive Projections. + +Record Lens (a b c d : Type) : Type := +{ view : a -> c +; over : (c -> d) -> a -> b +}. + +Arguments over {_ _ _ _} _ _ _. +Arguments view {_ _ _ _} _ _. + +Definition lens_compose {a b c d e f : Type} + (l1 : Lens a b c d) (l2 : Lens c d e f) +: Lens a b e f := +{| view := fun x : a => view l2 (view l1 x) + ; over := fun f0 : e -> f => over l1 (over l2 f0) |}. + +Infix "∙" := lens_compose (at level 90, left associativity). + +Require Import ExtLib.Core.RelDec. +Definition lensAt {A C} (x : A) {reqd: RelDec (@eq A)}: Lens (A->C) (A->C) C C. + constructor. + intros f. exact (f x). + intros f g x'. + exact (if (rel_dec x' x) then (f (g x)) else (g x')). +Defined. + +Section ops. + Context {a b c d : Type} (l : Lens a b c d). + + Definition set (new : d) : a -> b := + l.(over) (fun _ => new). +End ops. + + +Section GuardExc. + Context {e} {m} {Monad_m : Monad m} {MonadExc_m : MonadExc e m}. + + Definition guard (err : e) (g : bool) : m unit := + if g then ret tt else raise err. +End GuardExc. + +Import MonadNotation. + +Local Open Scope monad_scope. + +Definition to_bool {P Q} (x : {P} + {Q}) : bool := + match x with + | left _ => true + | right _ => false + end. + +Section stateL. + Context {m : Type -> Type} {Monad_m : Monad m} {s} {MS : MonadState s m}. + + Definition modifyL + {a} (l : Lens s s a a) (f : a -> a) : m a := + x <- get ;; + let res := l.(over) f x in + put res ;; + ret (l.(view) res). + + Definition putL {a} (l : Lens s s a a) (x : a) : m unit := + modifyL l (fun _ => x) ;; ret tt. + + Definition getL {a} (l : Lens s s a a) : m a := + fmap l.(view) get. +End stateL. + +Lemma view_set : forall {A B} (l : Lens A A B B) x, + set l (l.(view) x) x = x. +Admitted. +Lemma set_view : forall {A B} (l : Lens A A B B) x r, + l.(view) (set l x r) = x. +Admitted. + + +Set Primitive Projections. +Set Universe Polymorphism. + +Import MonadNotation. + +Record Info : Set := +{ type : ident +; ctor : ident +; fields : list (ident * term) +}. + +Fixpoint countTo (n : nat) : list nat := + match n with + | 0 => nil + | S m => countTo m ++ (m :: nil) + end. + +Require Import String. +Open Scope string_scope. +Definition prepend (ls : string) (i : ident) : ident := + ls ++ i. + +Quote Definition cBuild_Lens := Build_Lens. + +Require Import Coq.Lists.List. +Require Import Coq.Bool.Bool. + +Fixpoint boundIn (v : nat) (t : term) : bool. +refine + match t with + | tRel n => PeanoNat.Nat.eqb n v + | tVar i => _ + | tMeta n => false + | tEvar n l => existsb (boundIn v) l + | tSort u => false + | tCast t1 c t2 => boundIn v t1 || boundIn v t2 + | tProd n t1 t2 => boundIn v t1 || boundIn (S v) t2 + | tLambda n t1 t2 => boundIn v t1 || boundIn (S v) t2 + | tLetIn n t1 t2 t3 => boundIn v t1 || boundIn v t2 || boundIn (S v) t3 + | tApp t0 l => boundIn v t0 || existsb (boundIn v) l + | tConst k u => false + | tInd i u => false + | tConstruct i n u => false + | tCase p t1 t2 l => _ + | tProj p t0 => boundIn v t0 + | tFix m n => _ + | tCoFix m n => _ + end. +Admitted. + +(* check to see if Var 0 is referenced in any of the terms *) +Definition mentions (v : nat) (ls : list (ident * term)) : bool := + false. + + +Definition mkLens (At : term) (fields : list (ident * term)) (i : nat) +: option (ident * term) := + match At with + | tInd ind args => + let ctor := tConstruct ind 0 args in + match nth_error fields i with + | None => None + | Some (name, Bt) => + if mentions 1 (skipn (S i) fields) + then None + else + let p (x : nat) : projection := (ind, 0, x) in + let get_body := tProj (p i) (tRel 0) in + let f x := + let this := tProj (p x) (tRel 0) in + if PeanoNat.Nat.eqb x i + then tApp (tRel 1) (this :: nil) + else this + in + let update_body := + tApp ctor (map f (countTo (List.length fields))) + in + Some ( prepend "_" name + , tApp cBuild_Lens + (At :: At :: Bt :: Bt :: + tLambda nAnon At get_body :: + tLambda nAnon (tProd nAnon Bt Bt) (tLambda nAnon At update_body) :: + nil)) + end + | _ => None + end. + +Definition getFields (mi : mutual_inductive_body) +: option Info := + match mi.(ind_bodies) with + | oib :: nil => + match oib.(ind_ctors) with + | ctor :: nil => + Some {| type := oib.(ind_name) + ; ctor := let '(x,_,_) := ctor in x + ; fields := oib.(ind_projs) + |} + | _ => None + end + | _ => None + end. + +Import TemplateMonad.Extractable. +Require Import Template.BasicAst Template.AstUtils Ast. +Let TemplateMonad := TM. +Fixpoint mconcat (ls : list (TemplateMonad unit)) : TemplateMonad unit := + match ls with + | nil => tmReturn tt + | m :: ms => tmBind m (fun _ => mconcat ms) + end. + + +(* baseName should not contain any paths. For example, if the full name +is A.B.C#D#E#F, baseName should be F. Also, by import ordering, +ensure that F resolves to A.B.C#D#E#F. Use Locate to check this. + +If the definition of F refers to any other inductive, they should not +be in the current section(s). + *) +Set Printing All. + +Definition genLensN (baseName : String.string) : TM unit := + let name := baseName in + let ty := + (Ast.tInd + {| + BasicAst.inductive_mind := name; + BasicAst.inductive_ind := 0 (* TODO: fix for mutual records *) |} List.nil) in + tmBind (tmQuoteInductive name) (fun ind => + match getFields ind with + | Some info => + let gen i := + match mkLens ty info.(fields) i return TemplateMonad unit with + | None => tmFail "failed to build lens" + | Some x => + tmBind (tmEval Common.cbv (snd x)) + (fun d => + tmBind + (tmDefinition (fst x) None d) + (fun _ => tmReturn tt)) + end + in + mconcat (map gen (countTo (List.length info.(fields)))) + | None => tmFail "failed to get info" + end). From 38b1608eaa248f24e3fa310d7ff80e95af129ca5 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 17:51:24 -0700 Subject: [PATCH 48/71] cleaned up the lens example to not require other libs. removed admits as they would make Demo.v crash with "admitted axiom" --- plugin-demo/gen-src/demo.v | 78 -------------------------------------- 1 file changed, 78 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index deee694df..dd1d665c2 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -9,9 +9,6 @@ Definition showoff : TM unit := Require Import ExtLib.Structures.Functor. -Require Import ExtLib.Structures.Monad. -Require Import ExtLib.Structures.MonadState. -Require Import ExtLib.Structures.MonadExc. Set Primitive Projections. @@ -31,14 +28,6 @@ Definition lens_compose {a b c d e f : Type} Infix "∙" := lens_compose (at level 90, left associativity). -Require Import ExtLib.Core.RelDec. -Definition lensAt {A C} (x : A) {reqd: RelDec (@eq A)}: Lens (A->C) (A->C) C C. - constructor. - intros f. exact (f x). - intros f g x'. - exact (if (rel_dec x' x) then (f (g x)) else (g x')). -Defined. - Section ops. Context {a b c d : Type} (l : Lens a b c d). @@ -47,53 +36,9 @@ Section ops. End ops. -Section GuardExc. - Context {e} {m} {Monad_m : Monad m} {MonadExc_m : MonadExc e m}. - - Definition guard (err : e) (g : bool) : m unit := - if g then ret tt else raise err. -End GuardExc. - -Import MonadNotation. - -Local Open Scope monad_scope. - -Definition to_bool {P Q} (x : {P} + {Q}) : bool := - match x with - | left _ => true - | right _ => false - end. - -Section stateL. - Context {m : Type -> Type} {Monad_m : Monad m} {s} {MS : MonadState s m}. - - Definition modifyL - {a} (l : Lens s s a a) (f : a -> a) : m a := - x <- get ;; - let res := l.(over) f x in - put res ;; - ret (l.(view) res). - - Definition putL {a} (l : Lens s s a a) (x : a) : m unit := - modifyL l (fun _ => x) ;; ret tt. - - Definition getL {a} (l : Lens s s a a) : m a := - fmap l.(view) get. -End stateL. - -Lemma view_set : forall {A B} (l : Lens A A B B) x, - set l (l.(view) x) x = x. -Admitted. -Lemma set_view : forall {A B} (l : Lens A A B B) x r, - l.(view) (set l x r) = x. -Admitted. - - Set Primitive Projections. Set Universe Polymorphism. -Import MonadNotation. - Record Info : Set := { type : ident ; ctor : ident @@ -116,28 +61,6 @@ Quote Definition cBuild_Lens := Build_Lens. Require Import Coq.Lists.List. Require Import Coq.Bool.Bool. -Fixpoint boundIn (v : nat) (t : term) : bool. -refine - match t with - | tRel n => PeanoNat.Nat.eqb n v - | tVar i => _ - | tMeta n => false - | tEvar n l => existsb (boundIn v) l - | tSort u => false - | tCast t1 c t2 => boundIn v t1 || boundIn v t2 - | tProd n t1 t2 => boundIn v t1 || boundIn (S v) t2 - | tLambda n t1 t2 => boundIn v t1 || boundIn (S v) t2 - | tLetIn n t1 t2 t3 => boundIn v t1 || boundIn v t2 || boundIn (S v) t3 - | tApp t0 l => boundIn v t0 || existsb (boundIn v) l - | tConst k u => false - | tInd i u => false - | tConstruct i n u => false - | tCase p t1 t2 l => _ - | tProj p t0 => boundIn v t0 - | tFix m n => _ - | tCoFix m n => _ - end. -Admitted. (* check to see if Var 0 is referenced in any of the terms *) Definition mentions (v : nat) (ls : list (ident * term)) : bool := @@ -208,7 +131,6 @@ ensure that F resolves to A.B.C#D#E#F. Use Locate to check this. If the definition of F refers to any other inductive, they should not be in the current section(s). *) -Set Printing All. Definition genLensN (baseName : String.string) : TM unit := let name := baseName in From 416c796a1753722eeff28a4d43bff499452b1195 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 20:58:35 -0700 Subject: [PATCH 49/71] ran the lens example, it segfaulted --- plugin-demo/src/g_demo_plugin.ml4 | 22 ++++++++++++++++++++++ plugin-demo/theories/Demo.v | 9 +++++++++ 2 files changed, 31 insertions(+) diff --git a/plugin-demo/src/g_demo_plugin.ml4 b/plugin-demo/src/g_demo_plugin.ml4 index 8e18737d0..ff0bee272 100644 --- a/plugin-demo/src/g_demo_plugin.ml4 +++ b/plugin-demo/src/g_demo_plugin.ml4 @@ -3,6 +3,15 @@ open Entries open Run_extractable +open Ltac_plugin +open Entries +open Names +open Tacexpr +open Tacinterp +open Misctypes +open Stdarg +open Tacarg +open Ast_quoter DECLARE PLUGIN "demo_plugin" @@ -10,3 +19,16 @@ VERNAC COMMAND EXTEND Make_vernac CLASSIFIED AS QUERY | [ "Showoff" ] -> [ Run_extractable.run_vernac Demo.showoff ] END;; + +let quote_string s = + let rec aux acc i = + if i < 0 then acc + else aux (s.[i] :: acc) (i - 1) + in aux [] (String.length s - 1) + +VERNAC COMMAND EXTEND Unquote_vernac CLASSIFIED AS SIDEFF +| [ "Make" "Lens" ident(name) ] -> + [ Run_extractable.run_vernac (Demo.genLensN (quote_string (Names.Id.to_string name))) ] + +END;; + diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index fd2a76121..1dcf16c5d 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -1,2 +1,11 @@ Require Import Coq.Strings.String. Declare ML Module "demo_plugin". + +Record Point : Set := + { x: nat; + y:nat + }. + +Make Lens Point. +(* process coq segmentation fault *) + \ No newline at end of file From 35ff66b26dbc13720262dcd32a755705106dfb4a Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 21:09:39 -0700 Subject: [PATCH 50/71] the error seems to happen in the extracted code. will simplify --- plugin-demo/gen-src/demo.v | 2 ++ plugin-demo/src/g_demo_plugin.ml4 | 2 +- plugin-demo/theories/Demo.v | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index dd1d665c2..c60f545d3 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -156,3 +156,5 @@ Definition genLensN (baseName : String.string) : TM unit := mconcat (map gen (countTo (List.length info.(fields)))) | None => tmFail "failed to get info" end). + +Definition genLensNInst : TM unit := genLensN "Point". diff --git a/plugin-demo/src/g_demo_plugin.ml4 b/plugin-demo/src/g_demo_plugin.ml4 index ff0bee272..8af8bccbf 100644 --- a/plugin-demo/src/g_demo_plugin.ml4 +++ b/plugin-demo/src/g_demo_plugin.ml4 @@ -17,7 +17,7 @@ DECLARE PLUGIN "demo_plugin" VERNAC COMMAND EXTEND Make_vernac CLASSIFIED AS QUERY | [ "Showoff" ] -> - [ Run_extractable.run_vernac Demo.showoff ] + [ Run_extractable.run_vernac Demo.genLensNInst ] END;; let quote_string s = diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index 1dcf16c5d..84cc2b03a 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -6,6 +6,6 @@ Record Point : Set := y:nat }. -Make Lens Point. +Showoff. (* process coq segmentation fault *) \ No newline at end of file From 79e610bbf1202c2366914304f89e3147c68c9481 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 21:44:25 -0700 Subject: [PATCH 51/71] just quoting and printing segfaults --- plugin-demo/gen-src/demo.v | 19 ++++++++++++++++++- plugin-demo/src/g_demo_plugin.ml4 | 5 +++++ plugin-demo/theories/Demo.v | 8 +++++++- 3 files changed, 30 insertions(+), 2 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index c60f545d3..1b9a2abcb 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -4,9 +4,10 @@ From Template Require Import TemplateMonad.Extractable. +(* Definition showoff : TM unit := tmMsg "running from an extracted plugin!". - +*) Require Import ExtLib.Structures.Functor. @@ -157,4 +158,20 @@ Definition genLensN (baseName : String.string) : TM unit := | None => tmFail "failed to get info" end). + +Print definition_entry. +Definition lookupPrint (baseName : String.string) : TM unit := + tmBind (tmQuoteConstant baseName true) + (fun b => + match b with + | ParameterEntry _ => tmReturn tt + | DefinitionEntry d => + tmPrint (definition_entry_body d) + end + ). + Definition genLensNInst : TM unit := genLensN "Point". + + +Definition showoff : TM unit := + lookupPrint "Nat.add". diff --git a/plugin-demo/src/g_demo_plugin.ml4 b/plugin-demo/src/g_demo_plugin.ml4 index 8af8bccbf..94f196120 100644 --- a/plugin-demo/src/g_demo_plugin.ml4 +++ b/plugin-demo/src/g_demo_plugin.ml4 @@ -32,3 +32,8 @@ VERNAC COMMAND EXTEND Unquote_vernac CLASSIFIED AS SIDEFF END;; +VERNAC COMMAND EXTEND Unquote_vernac CLASSIFIED AS SIDEFF +| [ "LookupPring" ident(name) ] -> + [ Run_extractable.run_vernac (Demo.lookupPrint (quote_string (Names.Id.to_string name))) ] + +END;; diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index 84cc2b03a..eb2b08b08 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -6,6 +6,12 @@ Record Point : Set := y:nat }. +Definition two:=1+2. +About plus. + Showoff. +(* +lookupPrint + "two". (* process coq segmentation fault *) - \ No newline at end of file + *) \ No newline at end of file From 490c8738028a320f73348746b7932a201dbb21bf Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 9 Apr 2019 21:45:46 -0700 Subject: [PATCH 52/71] just quoting constant segfaults --- plugin-demo/gen-src/demo.v | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index 1b9a2abcb..fbd0085f2 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -170,8 +170,13 @@ Definition lookupPrint (baseName : String.string) : TM unit := end ). +Definition lookup (baseName : String.string) : TM unit := + tmBind (tmQuoteConstant baseName true) + (fun b => tmReturn tt + ). + Definition genLensNInst : TM unit := genLensN "Point". Definition showoff : TM unit := - lookupPrint "Nat.add". + lookup "Nat.add". From 926d39cf63ab89e67c2f9f79738ccab624313e73 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Wed, 10 Apr 2019 06:52:24 -0700 Subject: [PATCH 53/71] now showoff just does tmDefinition. Not_found error --- plugin-demo/gen-src/demo.v | 11 ++++++++++- plugin-demo/src/g_demo_plugin.ml4 | 2 +- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index fbd0085f2..0d2bfe0bc 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -170,6 +170,12 @@ Definition lookupPrint (baseName : String.string) : TM unit := end ). +Definition x := + tConstruct + {| inductive_mind := "Coq.Init.Datatypes.nat"; inductive_ind := 0 |} + 0 nil +. + Definition lookup (baseName : String.string) : TM unit := tmBind (tmQuoteConstant baseName true) (fun b => tmReturn tt @@ -179,4 +185,7 @@ Definition genLensNInst : TM unit := genLensN "Point". Definition showoff : TM unit := - lookup "Nat.add". + tmBind (tmMsg "showing off tmDefn" ) + (fun _ => + tmBind (tmDefinition "zeroE" None x) + (fun _ => tmReturn tt)). diff --git a/plugin-demo/src/g_demo_plugin.ml4 b/plugin-demo/src/g_demo_plugin.ml4 index 94f196120..8262cbf25 100644 --- a/plugin-demo/src/g_demo_plugin.ml4 +++ b/plugin-demo/src/g_demo_plugin.ml4 @@ -17,7 +17,7 @@ DECLARE PLUGIN "demo_plugin" VERNAC COMMAND EXTEND Make_vernac CLASSIFIED AS QUERY | [ "Showoff" ] -> - [ Run_extractable.run_vernac Demo.genLensNInst ] + [ Run_extractable.run_vernac Demo.showoff ] END;; let quote_string s = From 80bb4fa36638566d8db8b4bfae6a3591d3625775 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Wed, 10 Apr 2019 14:04:06 -0400 Subject: [PATCH 54/71] some debugging. --- plugin-demo/gen-src/demo.v | 4 ++-- plugin-demo/src/demo_plugin.mlpack | 2 +- plugin-demo/src/g_demo_plugin.ml4 | 2 +- plugin-demo/theories/Demo.v | 5 +++-- template-coq/src/ast_quoter.ml | 2 +- template-coq/src/plugin_core.ml | 18 +++++++++++------- template-coq/src/tm_util.ml | 2 +- 7 files changed, 20 insertions(+), 15 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index 0d2bfe0bc..b57a94005 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -157,8 +157,8 @@ Definition genLensN (baseName : String.string) : TM unit := mconcat (map gen (countTo (List.length info.(fields)))) | None => tmFail "failed to get info" end). - - +Notation "<% x %>" := (ltac:(let p y := exact y in quote_term x p)) + (only parsing). Print definition_entry. Definition lookupPrint (baseName : String.string) : TM unit := tmBind (tmQuoteConstant baseName true) diff --git a/plugin-demo/src/demo_plugin.mlpack b/plugin-demo/src/demo_plugin.mlpack index abe37536a..fb2aa38d1 100644 --- a/plugin-demo/src/demo_plugin.mlpack +++ b/plugin-demo/src/demo_plugin.mlpack @@ -26,6 +26,7 @@ BasicAst Common Config0 +Tm_util Denote Denoter Equalities @@ -34,7 +35,6 @@ Logic Specif UGraph0 -Tm_util Quoted Quoter Ast_quoter diff --git a/plugin-demo/src/g_demo_plugin.ml4 b/plugin-demo/src/g_demo_plugin.ml4 index 8262cbf25..1109f1360 100644 --- a/plugin-demo/src/g_demo_plugin.ml4 +++ b/plugin-demo/src/g_demo_plugin.ml4 @@ -33,7 +33,7 @@ VERNAC COMMAND EXTEND Unquote_vernac CLASSIFIED AS SIDEFF END;; VERNAC COMMAND EXTEND Unquote_vernac CLASSIFIED AS SIDEFF -| [ "LookupPring" ident(name) ] -> +| [ "LookupPrint" ident(name) ] -> [ Run_extractable.run_vernac (Demo.lookupPrint (quote_string (Names.Id.to_string name))) ] END;; diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index eb2b08b08..210656376 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -9,9 +9,10 @@ Record Point : Set := Definition two:=1+2. About plus. +LookupPrint two. + + Showoff. (* -lookupPrint - "two". (* process coq segmentation fault *) *) \ No newline at end of file diff --git a/template-coq/src/ast_quoter.ml b/template-coq/src/ast_quoter.ml index 240a95535..0706d0cee 100644 --- a/template-coq/src/ast_quoter.ml +++ b/template-coq/src/ast_quoter.ml @@ -318,7 +318,7 @@ struct let comps = CString.split '.' (list_to_string na) in let comps = List.map Id.of_string comps in let id, dp = CList.sep_last comps in - let dp = DirPath.make dp in + let dp = DirPath.make (List.rev dp) in let mind = Globnames.encode_mind dp id in (mind, unquote_int i) diff --git a/template-coq/src/plugin_core.ml b/template-coq/src/plugin_core.ml index 48e8ae791..4acf69e44 100644 --- a/template-coq/src/plugin_core.ml +++ b/template-coq/src/plugin_core.ml @@ -28,10 +28,10 @@ let rs_unfold (env : Environ.env) (gr : global_reference) = type 'a tm = Environ.env -> Evd.evar_map -> (Environ.env -> Evd.evar_map -> 'a -> unit) -> - (string -> unit) -> unit + (Pp.t -> unit) -> unit let run (c : 'a tm) env evm (k : Environ.env -> Evd.evar_map -> 'a -> unit) : unit = - c env evm k (fun x -> CErrors.user_err (Pp.str x)) + c env evm k (fun x -> CErrors.user_err x) let run_vernac (c : 'a tm) : unit = let (evm,env) = Pfedit.get_current_context () in @@ -59,7 +59,7 @@ let tmMsg (s : string) : unit tm = success env evd () let tmFail (s : string) : 'a tm = - fun _ _ _ fail -> fail s + fun _ _ _ fail -> fail Pp.(str s) let tmEval (rd : reduction_strategy) (t : term) : term tm = fun env evd k _fail -> @@ -136,7 +136,7 @@ let tmQuoteInductive (kn : kername) : mutual_inductive_body option tm = let mind = Environ.lookup_mind (Names.MutInd.make1 kn) env in success env evm (Some mind) with - _ -> success env evm None + Not_found -> success env evm None let tmQuoteUniverses : UGraph.t tm = fun env evm success _fail -> @@ -144,9 +144,13 @@ let tmQuoteUniverses : UGraph.t tm = (* get the definition associated to a kername *) let tmQuoteConstant (kn : kername) (bypass : bool) : constant_entry tm = - fun env evd success _fail -> - let cnst = Environ.lookup_constant (Names.Constant.make1 kn) env in - success env evd cnst + fun env evd success fail -> + (* todo(gmm): there is a bug here *) + try + let cnst = Environ.lookup_constant (Names.Constant.make1 kn) env in + success env evd cnst + with + Not_found -> fail Pp.(str "constant not found " ++ Names.KerName.print kn) let tmInductive (mi : mutual_inductive_entry) : unit tm = fun env evd success _fail -> diff --git a/template-coq/src/tm_util.ml b/template-coq/src/tm_util.ml index e9e811fbd..70b9d4a6e 100644 --- a/template-coq/src/tm_util.ml +++ b/template-coq/src/tm_util.ml @@ -6,7 +6,7 @@ let gen_constant_in_modules locstr dirs s = Universes.constr_of_global (Coqlib.gen_reference_in_modules locstr dirs s) -let opt_debug = ref false +let opt_debug = ref true let debug (m : unit ->Pp.t) = if !opt_debug then From 2234271c358f039819ef21b83d310acde792d307 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sun, 14 Apr 2019 15:18:15 -0400 Subject: [PATCH 55/71] bug fixes for extraction. --- plugin-demo/gen-src/demo.v | 43 +++++++++++++--- plugin-demo/src/g_demo_plugin.ml4 | 3 +- template-coq/src/plugin_core.ml | 15 ++++-- template-coq/src/plugin_core.mli | 4 +- template-coq/src/quoter.ml | 39 ++++++++------- template-coq/src/run_extractable.ml | 6 +-- template-coq/src/run_template_monad.ml | 49 +++++++++++++------ template-coq/src/template_monad.ml | 29 +++++++---- template-coq/src/tm_util.ml | 2 +- .../theories/TemplateMonad/Extractable.v | 7 +-- test-suite/extractable.v | 7 +++ 11 files changed, 142 insertions(+), 62 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index b57a94005..bdcff9395 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -160,15 +160,46 @@ Definition genLensN (baseName : String.string) : TM unit := Notation "<% x %>" := (ltac:(let p y := exact y in quote_term x p)) (only parsing). Print definition_entry. + +Definition gr_to_kername (gr : global_reference) : kername := + match gr with + | ConstRef kn => kn + | IndRef ind => ind.(inductive_mind) + | ConstructRef ind _ => ind.(inductive_mind) + end. + +Definition tmResolve (nm : String.string) : TM (option kername) := + tmBind (tmAbout nm) + (fun gr => + match gr with + | None => tmReturn None + | Some (ConstRef kn) => tmReturn (Some kn) + | Some (IndRef ind) => tmReturn (Some ind.(inductive_mind)) + | Some (ConstructRef ind _) => tmReturn (Some ind.(inductive_mind)) + end). + +Definition tmQuoteConstantR (nm : String.string) (bypass : bool) : TM _ := + tmBind (tmAbout nm) + (fun gr => + match gr with + | Some (ConstRef kn) => + tmBind (tmQuoteConstant kn bypass) + (fun x => tmReturn (Some x)) + | _ => tmReturn None + end). + Definition lookupPrint (baseName : String.string) : TM unit := - tmBind (tmQuoteConstant baseName true) + tmBind (tmQuoteConstantR baseName true) (fun b => match b with - | ParameterEntry _ => tmReturn tt - | DefinitionEntry d => - tmPrint (definition_entry_body d) - end - ). + | None => tmFail "not a constant" + | Some b => + match b with + | ParameterEntry _ => tmReturn tt + | DefinitionEntry d => + tmPrint (definition_entry_body d) + end + end). Definition x := tConstruct diff --git a/plugin-demo/src/g_demo_plugin.ml4 b/plugin-demo/src/g_demo_plugin.ml4 index 1109f1360..f194d9380 100644 --- a/plugin-demo/src/g_demo_plugin.ml4 +++ b/plugin-demo/src/g_demo_plugin.ml4 @@ -34,6 +34,7 @@ END;; VERNAC COMMAND EXTEND Unquote_vernac CLASSIFIED AS SIDEFF | [ "LookupPrint" ident(name) ] -> - [ Run_extractable.run_vernac (Demo.lookupPrint (quote_string (Names.Id.to_string name))) ] + [ let nstr = Names.Id.to_string name in + Run_extractable.run_vernac (Demo.lookupPrint (quote_string nstr)) ] END;; diff --git a/template-coq/src/plugin_core.ml b/template-coq/src/plugin_core.ml index 4acf69e44..cf76e7634 100644 --- a/template-coq/src/plugin_core.ml +++ b/template-coq/src/plugin_core.ml @@ -58,8 +58,10 @@ let tmMsg (s : string) : unit tm = let _ = Feedback.msg_info (Pp.str s) in success env evd () -let tmFail (s : string) : 'a tm = - fun _ _ _ fail -> fail Pp.(str s) +let tmFail (s : Pp.t) : 'a tm = + fun _ _ _ fail -> fail s +let tmFailString (s : string) : 'a tm = + tmFail Pp.(str s) let tmEval (rd : reduction_strategy) (t : term) : term tm = fun env evd k _fail -> @@ -124,7 +126,13 @@ let tmAbout (qualid : qualid) : global_reference option tm = let gr = Smartlocate.locate_global_with_alias (CAst.make qualid) in success env evd (Some gr) with - | Not_found -> success env evd None + Not_found -> success env evd None + +let tmAboutString (s : string) : global_reference option tm = + fun env evd success fail -> + let (dp, nm) = Quoted.split_name s in + let q = Libnames.make_qualid dp nm in + tmAbout q env evd success fail let tmCurrentModPath : Names.ModPath.t tm = fun env evd success _fail -> @@ -171,4 +179,3 @@ let tmInferInstance (typ : term) : term option tm = success env evm (Some (EConstr.to_constr evm t)) with Not_found -> success env evm None - diff --git a/template-coq/src/plugin_core.mli b/template-coq/src/plugin_core.mli index 7493925ac..dbb83de64 100644 --- a/template-coq/src/plugin_core.mli +++ b/template-coq/src/plugin_core.mli @@ -33,7 +33,8 @@ val tmMap : ('a -> 'b) -> 'a tm -> 'b tm val tmPrint : term -> unit tm val tmMsg : string -> unit tm -val tmFail : string -> 'a tm +val tmFail : Pp.t -> 'a tm +val tmFailString : string -> 'a tm val tmEval : reduction_strategy -> term -> term tm val tmDefinition : ident -> ?poly:bool -> term option -> term -> kername tm @@ -43,6 +44,7 @@ val tmLemma : ident -> ?poly:bool -> term -> kername tm val tmFreshName : ident -> ident tm val tmAbout : qualid -> global_reference option tm +val tmAboutString : string -> global_reference option tm val tmCurrentModPath : Names.ModPath.t tm val tmQuoteInductive : kername -> mutual_inductive_body option tm diff --git a/template-coq/src/quoter.ml b/template-coq/src/quoter.ml index 4fe3bc81a..bf8985677 100644 --- a/template-coq/src/quoter.ml +++ b/template-coq/src/quoter.ml @@ -494,30 +494,33 @@ since [absrt_info] is a private type *) let uctx = Q.quote_inductive_universes t.mind_entry_universes in Q.quote_mutual_inductive_entry (mf, mp, is, uctx) + let quote_constant_body bypass env evm (cd : constant_body) = + let ty = quote_term env cd.const_type in + let body = + match cd.const_body with + | Undef _ -> None + | Def cs -> Some (quote_term env (Mod_subst.force_constr cs)) + | OpaqueDef cs -> + if bypass + then Some (quote_term env (Opaqueproof.force_proof (Global.opaque_tables ()) cs)) + else None + in + let uctx = quote_constant_uctx cd.const_universes in + (ty, body, uctx) + let quote_entry_aux bypass env evm (name:string) = let (dp, nm) = split_name name in let entry = match Nametab.locate (Libnames.make_qualid dp nm) with | Globnames.ConstRef c -> - let cd = Environ.lookup_constant c env in - (*CHANGE : template polymorphism for definitions was removed. - See: https://github.com/coq/coq/commit/d9530632321c0b470ece6337cda2cf54d02d61eb *) - let ty = quote_term env cd.const_type in - let body = match cd.const_body with - | Undef _ -> None - | Def cs -> Some (quote_term env (Mod_subst.force_constr cs)) - | OpaqueDef cs -> - if bypass - then Some (quote_term env (Opaqueproof.force_proof (Global.opaque_tables ()) cs)) - else None - in - let uctx = quote_constant_uctx cd.const_universes in - Some (Left (ty, body, uctx)) - + let cd = Environ.lookup_constant c env in + (*CHANGE : template polymorphism for definitions was removed. + See: https://github.com/coq/coq/commit/d9530632321c0b470ece6337cda2cf54d02d61eb *) + Some (Left (quote_constant_body bypass env evm cd)) | Globnames.IndRef ni -> - let c = Environ.lookup_mind (fst ni) env in (* FIX: For efficienctly, we should also export (snd ni)*) - let miq = quote_mut_ind env c in - Some (Right miq) + let c = Environ.lookup_mind (fst ni) env in (* FIX: For efficienctly, we should also export (snd ni)*) + let miq = quote_mut_ind env c in + Some (Right miq) | Globnames.ConstructRef _ -> None (* FIX?: return the enclusing mutual inductive *) | Globnames.VarRef _ -> None in entry diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 0f107230e..9fd339a38 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -178,7 +178,7 @@ let rec interp_tm (t : 'a coq_TM) : 'a tm = | Coq_tmBind (c, k) -> tmBind (interp_tm c) (fun x -> interp_tm (k x)) | Coq_tmPrint t -> Obj.magic (tmPrint (to_constr t)) | Coq_tmMsg msg -> Obj.magic (tmMsg (to_string msg)) - | Coq_tmFail err -> tmFail (to_string err) + | Coq_tmFail err -> tmFailString (to_string err) | Coq_tmEval (r,t) -> tmBind (tmEval (to_reduction_strategy r) (to_constr t)) (fun x -> Obj.magic (tmOfConstr x)) @@ -215,8 +215,8 @@ let rec interp_tm (t : 'a coq_TM) : 'a tm = | Coq_tmQuoteUniverses -> tmMap (fun x -> failwith "tmQuoteUniverses") tmQuoteUniverses | Coq_tmQuoteConstant (kn, b) -> - tmMap (fun x -> Obj.magic (tmOfConstantEntry x)) - (tmQuoteConstant (to_kername kn) b) + tmBind (tmQuoteConstant (to_kername kn) b) + (fun x -> Obj.magic (tmOfConstantEntry x)) | Coq_tmInductive i -> tmMap (fun _ -> Obj.magic ()) (tmInductive (to_mie i)) | Coq_tmExistingInstance k -> diff --git a/template-coq/src/run_template_monad.ml b/template-coq/src/run_template_monad.ml index 7f084f6eb..bf8e79f17 100644 --- a/template-coq/src/run_template_monad.ml +++ b/template-coq/src/run_template_monad.ml @@ -319,32 +319,49 @@ let rec run_template_program_rec ?(intactic=false) (k : Environ.env * Evd.evar_m | TmQuote (true, trm) -> let qt = TermReify.quote_term_rec env trm in k (env, evm, qt) - | TmQuoteInd name -> + | TmQuoteInd (name, strict) -> let name = unquote_string (reduce_all env evm name) in let (dp, nm) = Quoted.split_name name in (match Nametab.locate (Libnames.make_qualid dp nm) with - | Globnames.IndRef ni -> - let t = TermReify.quote_mind_decl env (fst ni) in - let _, args = Constr.destApp t in - (match args with - | [|kn; decl|] -> - k (env, evm, decl) - | _ -> bad_term_verb t "anomaly in quoting of inductive types") + | Globnames.IndRef (ind, _) -> + let _ = + let kn = Names.KerName.to_string (Names.MutInd.canonical ind) in + if strict && kn <> name then + CErrors.user_err (str "strict mode not canonical: \"" ++ str name ++ str "\" <> \"" ++ str kn ++ str "\"") + else () + in + let t = TermReify.quote_mind_decl env ind in + let _, args = Constr.destApp t in + (match args with + | [|kn; decl|] -> + k (env, evm, decl) + | _ -> bad_term_verb t "anomaly in quoting of inductive types") (* quote_mut_ind produce an entry rather than a decl *) (* let c = Environ.lookup_mind (fst ni) env in (\* FIX: For efficienctly, we should also export (snd ni)*\) *) (* TermReify.quote_mut_ind env c *) | _ -> CErrors.user_err (str name ++ str " does not seem to be an inductive.")) - | TmQuoteConst (name,bypass) -> + | TmQuoteConst (name, bypass, strict) -> + begin let name = unquote_string (reduce_all env evm name) in let bypass = unquote_bool (reduce_all env evm bypass) in - let entry = TermReify.quote_entry_aux bypass env evm name in - let entry = - match entry with - | Some (Quoted.Left cstentry) -> TemplateCoqQuoter.quote_constant_entry cstentry - | Some (Quoted.Right _) -> CErrors.user_err (str name ++ str " refers to an inductive") - | None -> bad_term_verb pgm "anomaly in QuoteConstant" + let cmd = + let open Plugin_core in + tmBind (tmAboutString name) + (function + None -> tmFail (str "not found: " ++ str name) + | Some (Globnames.ConstRef cnst) -> + let kn = KerName.to_string (Names.Constant.canonical cnst) in + if strict && kn <> name then + tmFail (str "strict mode not canonical: \"" ++ str name ++ str "\" <> \"" ++ str kn ++ str "\"") + else + with_env_evm (fun env evm -> + let cd = Environ.lookup_constant cnst env in + tmReturn (TermReify.quote_constant_body bypass env evm cd)) + | Some _ -> + tmFail (str "\"" ++ str name ++ str "\" does not refer to a constant")) in - k (env, evm, entry) + Plugin_core.run cmd env evm (fun a b c -> k (a,b, TemplateCoqQuoter.quote_constant_entry c)) + end | TmQuoteUnivs -> let univs = Environ.universes env in k (env, evm, quote_ugraph univs) diff --git a/template-coq/src/template_monad.ml b/template-coq/src/template_monad.ml index 457069a04..3d4ad2117 100644 --- a/template-coq/src/template_monad.ml +++ b/template-coq/src/template_monad.ml @@ -39,8 +39,8 @@ sig (* quoting *) | TmQuote of bool * Constr.t (* only Prop *) - | TmQuoteInd of Constr.t - | TmQuoteConst of Constr.t * Constr.t + | TmQuoteInd of Constr.t * bool (* strict *) + | TmQuoteConst of Constr.t * Constr.t * bool (* strict *) | TmQuoteUnivs | TmUnquote of Constr.t (* only Prop *) @@ -169,8 +169,8 @@ struct r_template_monad_type_p "tmCurrentModPath", r_template_monad_type_p "tmQuoteInductive", - r_template_monad_type_p "tmQuoteUniverses", r_template_monad_type_p "tmQuoteConstant", + r_template_monad_type_p "tmQuoteUniverses", r_template_monad_type_p "tmInductive", @@ -210,8 +210,8 @@ struct (* quoting *) | TmQuote of bool * Constr.t (* only Prop *) - | TmQuoteInd of Constr.t - | TmQuoteConst of Constr.t * Constr.t + | TmQuoteInd of Constr.t * bool (* strict *) + | TmQuoteConst of Constr.t * Constr.t * bool (* strict *) | TmQuoteUnivs | TmUnquote of Constr.t (* only Prop *) @@ -357,20 +357,31 @@ struct (TmQuote (true,trm), universes) | _ -> monad_failure "tmQuoteRec" 2 - else if Globnames.eq_gr glob_ref ptmQuoteInductive || Globnames.eq_gr glob_ref ttmQuoteInductive then + else if Globnames.eq_gr glob_ref ptmQuoteInductive then + match args with + | name::[] -> + (TmQuoteInd (name, false), universes) + | _ -> monad_failure "tmQuoteInductive" 1 + else if Globnames.eq_gr glob_ref ttmQuoteInductive then match args with | name::[] -> - (TmQuoteInd name, universes) + (TmQuoteInd (name, true), universes) | _ -> monad_failure "tmQuoteInductive" 1 + else if Globnames.eq_gr glob_ref ptmQuoteUniverses || Globnames.eq_gr glob_ref ttmQuoteUniverses then match args with | [] -> (TmQuoteUnivs, universes) | _ -> monad_failure "tmQuoteUniverses" 0 - else if Globnames.eq_gr glob_ref ptmQuoteConstant || Globnames.eq_gr glob_ref ttmQuoteConstant then + else if Globnames.eq_gr glob_ref ptmQuoteConstant then + match args with + | name::bypass::[] -> + (TmQuoteConst (name, bypass, false), universes) + | _ -> monad_failure "tmQuoteConstant" 2 + else if Globnames.eq_gr glob_ref ttmQuoteConstant then match args with | name::bypass::[] -> - (TmQuoteConst (name, bypass), universes) + (TmQuoteConst (name, bypass, true), universes) | _ -> monad_failure "tmQuoteConstant" 2 else if Globnames.eq_gr glob_ref ptmMkInductive then diff --git a/template-coq/src/tm_util.ml b/template-coq/src/tm_util.ml index 70b9d4a6e..e9e811fbd 100644 --- a/template-coq/src/tm_util.ml +++ b/template-coq/src/tm_util.ml @@ -6,7 +6,7 @@ let gen_constant_in_modules locstr dirs s = Universes.constr_of_global (Coqlib.gen_reference_in_modules locstr dirs s) -let opt_debug = ref true +let opt_debug = ref false let debug (m : unit ->Pp.t) = if !opt_debug then diff --git a/template-coq/theories/TemplateMonad/Extractable.v b/template-coq/theories/TemplateMonad/Extractable.v index 3cc646839..a6a382c2b 100644 --- a/template-coq/theories/TemplateMonad/Extractable.v +++ b/template-coq/theories/TemplateMonad/Extractable.v @@ -42,16 +42,17 @@ Cumulative Inductive TM@{t} : Type@{t} -> Type := (* Guaranteed to not cause "... already declared" error *) | tmFreshName : ident -> TM ident -| tmAbout : ident -> TM (option global_reference) +| tmAbout : qualid -> TM (option global_reference) | tmCurrentModPath : TM string (* Quote the body of a definition or inductive. *) -| tmQuoteInductive (nm : kername) +| tmQuoteInductive (nm : kername) (* nm is the kernel name of the mutind *) : TM mutual_inductive_body -| tmQuoteUniverses : TM uGraph.t | tmQuoteConstant (nm : kername) (bypass_opacity : bool) : TM constant_entry +| tmQuoteUniverses : TM uGraph.t + (* unquote before making the definition *) (* FIXME take an optional universe context as well *) | tmInductive : mutual_inductive_entry -> TM unit diff --git a/test-suite/extractable.v b/test-suite/extractable.v index 6edec3073..8459221a1 100644 --- a/test-suite/extractable.v +++ b/test-suite/extractable.v @@ -74,3 +74,10 @@ Print thing. Run TemplateProgram (tmBind tmCurrentModPath tmMsg). + + +Fail Run TemplateProgram (tmQuoteInductive "nat"). +Run TemplateProgram (tmQuoteInductive "Coq.Init.Datatypes.nat"). + +Fail Run TemplateProgram (tmQuoteConstant "plus" true). +Run TemplateProgram (tmQuoteConstant "Coq.Init.Nat.add" true). \ No newline at end of file From d90a97f421ce3a3426ea7fe0dcab44f0efa21bd3 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sun, 14 Apr 2019 16:17:14 -0400 Subject: [PATCH 56/71] toying with Makefile rules. --- template-coq/Makefile | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/template-coq/Makefile b/template-coq/Makefile index 13ee76d58..9b749cc64 100644 --- a/template-coq/Makefile +++ b/template-coq/Makefile @@ -12,7 +12,9 @@ plugin: coq Makefile.plugin gen-src/.generate (cd gen-src; ./to-lower.sh) $(MAKE) -f Makefile.plugin -gen-src/.generate: theories/Extraction.vo theories/Extraction.v +theories/Extraction.vo: coq + +gen-src/.generate: theories/Extraction.vo coqc -Q theories Template theories/Extraction.v @ touch gen-src/.generate From bdcf8987091a25b490103879b021bc6d3bc4c899 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sun, 14 Apr 2019 22:04:05 -0400 Subject: [PATCH 57/71] some more Makefile fixes. --- checker/Makefile | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/checker/Makefile b/checker/Makefile index 058d53b00..712dbfdf0 100644 --- a/checker/Makefile +++ b/checker/Makefile @@ -9,7 +9,7 @@ Makefile.coq: _CoqProject gen-src get-mc gen-src: $(MAKE) -C gen-src -get-mc: +get-mc: gen-src cp -r $(TEMPLATE_LIB)/gen-src/to-lower.sh src (cd src; ./to-lower.sh) cp -r $(TEMPLATE_LIB)/gen-src/*.ml $(TEMPLATE_LIB)/gen-src/*.mli src @@ -19,5 +19,4 @@ get-mc: clean: $(MAKE) -f Makefile.coq clean -sources: - $(MAKE) -C gen-src +sources: gen-src From 8f6eaaa3d46ea79cd00b0975680e795c98eaacd3 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Sun, 14 Apr 2019 22:13:18 -0400 Subject: [PATCH 58/71] unneeded import. --- plugin-demo/gen-src/demo.v | 2 -- 1 file changed, 2 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index bdcff9395..5df41382a 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -9,8 +9,6 @@ Definition showoff : TM unit := tmMsg "running from an extracted plugin!". *) -Require Import ExtLib.Structures.Functor. - Set Primitive Projections. Record Lens (a b c d : Type) : Type := From 829b1092c729c315a6f15926a51223364217026b Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 23 Apr 2019 17:21:44 -0700 Subject: [PATCH 59/71] genLensN returns the error "failed to get info" --- plugin-demo/gen-src/demo.v | 30 +++++++++++++++++++++++++++--- plugin-demo/theories/Demo.v | 6 ++++++ 2 files changed, 33 insertions(+), 3 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index 5df41382a..f6b21d5df 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -122,6 +122,20 @@ Fixpoint mconcat (ls : list (TemplateMonad unit)) : TemplateMonad unit := | m :: ms => tmBind m (fun _ => mconcat ms) end. +Definition tmQuoteInductiveR (nm: kername) : + TM (option mutual_inductive_body). + refine ( + tmBind (tmAbout nm) + (fun gr => + match gr with + | Some (IndRef kn) => + tmBind (tmQuoteInductive (inductive_mind kn)) + (fun x => tmReturn (Some x)) + | _ => tmReturn None + end) + ). + Defined. + (* baseName should not contain any paths. For example, if the full name is A.B.C#D#E#F, baseName should be F. Also, by import ordering, @@ -131,6 +145,14 @@ If the definition of F refers to any other inductive, they should not be in the current section(s). *) +Definition opBind {A B} (a: option A) (f: A -> option B) : option B := + match a with + | Some a => f a + | None => None + end. + + + Definition genLensN (baseName : String.string) : TM unit := let name := baseName in let ty := @@ -138,8 +160,8 @@ Definition genLensN (baseName : String.string) : TM unit := {| BasicAst.inductive_mind := name; BasicAst.inductive_ind := 0 (* TODO: fix for mutual records *) |} List.nil) in - tmBind (tmQuoteInductive name) (fun ind => - match getFields ind with + tmBind (tmQuoteInductiveR name) (fun ind => + match opBind ind getFields with | Some info => let gen i := match mkLens ty info.(fields) i return TemplateMonad unit with @@ -213,8 +235,10 @@ Definition lookup (baseName : String.string) : TM unit := Definition genLensNInst : TM unit := genLensN "Point". -Definition showoff : TM unit := +Definition showoffOld : TM unit := tmBind (tmMsg "showing off tmDefn" ) (fun _ => tmBind (tmDefinition "zeroE" None x) (fun _ => tmReturn tt)). + +Definition showoff : TM unit := genLensNInst. diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index 210656376..e1ef92dfd 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -11,8 +11,14 @@ About plus. LookupPrint two. +LookupPrint Point. + +Fail Print zeroE. Showoff. + +Print zeroE. + (* (* process coq segmentation fault *) *) \ No newline at end of file From 215106557a846061f9a62eb1a602ba8b0d4fb718 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 23 Apr 2019 22:21:25 -0400 Subject: [PATCH 60/71] removing unused imports. --- template-coq/src/ast_quoter.ml | 2 -- template-coq/src/constr_denoter.ml | 2 -- template-coq/src/denote.ml | 6 ------ template-coq/src/run_template_monad.ml | 2 -- template-coq/src/template_monad.ml | 2 -- 5 files changed, 14 deletions(-) diff --git a/template-coq/src/ast_quoter.ml b/template-coq/src/ast_quoter.ml index 1c8f0176e..00e11ab2a 100644 --- a/template-coq/src/ast_quoter.ml +++ b/template-coq/src/ast_quoter.ml @@ -354,8 +354,6 @@ struct let u' = unquote_level_expr l b in Univ.Universe.sup u u') (unquote_level_expr l b) q - let print_term (u: t) : Pp.t = failwith "print_term in term_quoter.ml not yet implemented" - let quote_global_reference : Globnames.global_reference -> quoted_global_reference = function | Globnames.VarRef _ -> CErrors.user_err (Pp.str "VarRef unsupported") | Globnames.ConstRef c -> diff --git a/template-coq/src/constr_denoter.ml b/template-coq/src/constr_denoter.ml index 4a5dc5028..7e3148d4a 100644 --- a/template-coq/src/constr_denoter.ml +++ b/template-coq/src/constr_denoter.ml @@ -4,9 +4,7 @@ open Univ open Tm_util open Quoted open Denote -open Denoter open Constr_quoted -open Constr_quoter (* the things in here that are common should be pulled out *) diff --git a/template-coq/src/denote.ml b/template-coq/src/denote.ml index bd83f4770..80abaa9e8 100644 --- a/template-coq/src/denote.ml +++ b/template-coq/src/denote.ml @@ -2,14 +2,8 @@ * open Names *) open Pp (* this adds the ++ to the current scope *) -open Tm_util open Quoted -open Quoter open Denoter -(* open Constr_quoted - * open Constr_quoter - * open TemplateCoqQuoter *) - (* todo: the recursive call is uneeded provided we call it on well formed terms *) diff --git a/template-coq/src/run_template_monad.ml b/template-coq/src/run_template_monad.ml index 0c22d6de4..47e32dd34 100644 --- a/template-coq/src/run_template_monad.ml +++ b/template-coq/src/run_template_monad.ml @@ -9,12 +9,10 @@ open Pp (* this adds the ++ to the current scope *) open Tm_util open Quoter open Denote -open Constr_quoted open Constr_quoter open Template_monad open Constr_denoter -open ConstrQuoted open CoqLiveDenoter let unquote_reduction_strategy env evm trm (* of type reductionStrategy *) : Redexpr.red_expr = diff --git a/template-coq/src/template_monad.ml b/template-coq/src/template_monad.ml index 3d4ad2117..6d78d4bb6 100644 --- a/template-coq/src/template_monad.ml +++ b/template-coq/src/template_monad.ml @@ -1,10 +1,8 @@ open Univ open Names -open Constr_quoter open Pp open Tm_util -open Quoter module TemplateMonad : sig From 675d5568c683ec9e030bb89feac8e754950d62d9 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Tue, 23 Apr 2019 22:21:45 -0400 Subject: [PATCH 61/71] trying something to fix the import problem in pcuic --- pcuic/Makefile.plugin.local | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pcuic/Makefile.plugin.local b/pcuic/Makefile.plugin.local index 97774d3d0..8337be017 100644 --- a/pcuic/Makefile.plugin.local +++ b/pcuic/Makefile.plugin.local @@ -1,2 +1,2 @@ -CAMLFLAGS+=-open Template_coq_checker_plugin +# CAMLFLAGS+=-open Template_coq_checker_plugin CAMLFLAGS+=-w -33 # Unused opens \ No newline at end of file From b2ed26ce4e957aa53773666f2f82dd8908df2f9a Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 23 Apr 2019 20:30:40 -0700 Subject: [PATCH 62/71] it seems that tmQuoteInductiveR succeeds and getFields fails --- plugin-demo/gen-src/demo.v | 39 +++++++++++++++++++++---------------- plugin-demo/theories/Demo.v | 1 - 2 files changed, 22 insertions(+), 18 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index f6b21d5df..8ea589ca8 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -152,7 +152,6 @@ Definition opBind {A B} (a: option A) (f: A -> option B) : option B := end. - Definition genLensN (baseName : String.string) : TM unit := let name := baseName in let ty := @@ -160,23 +159,29 @@ Definition genLensN (baseName : String.string) : TM unit := {| BasicAst.inductive_mind := name; BasicAst.inductive_ind := 0 (* TODO: fix for mutual records *) |} List.nil) in - tmBind (tmQuoteInductiveR name) (fun ind => - match opBind ind getFields with - | Some info => - let gen i := - match mkLens ty info.(fields) i return TemplateMonad unit with - | None => tmFail "failed to build lens" - | Some x => - tmBind (tmEval Common.cbv (snd x)) - (fun d => - tmBind - (tmDefinition (fst x) None d) - (fun _ => tmReturn tt)) + tmBind (tmQuoteInductiveR name) (fun ind => + match ind with + | Some ind => + match getFields ind with + | Some info => + let gen i := + match mkLens ty info.(fields) i return TemplateMonad unit with + | None => tmFail "failed to build lens" + | Some x => + tmBind (tmEval Common.cbv (snd x)) + (fun d => + tmBind + (tmDefinition (fst x) None d) + (fun _ => tmReturn tt)) + end + in + mconcat (map gen (countTo (List.length info.(fields)))) + | None => tmFail ("failed to get inductive info but quote succeeded") end - in - mconcat (map gen (countTo (List.length info.(fields)))) - | None => tmFail "failed to get info" - end). + | None => tmFail "failed to quote inductive" + end + +). Notation "<% x %>" := (ltac:(let p y := exact y in quote_term x p)) (only parsing). Print definition_entry. diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index e1ef92dfd..873b788a3 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -11,7 +11,6 @@ About plus. LookupPrint two. -LookupPrint Point. Fail Print zeroE. From 2cd7a03f29bcbfb7c17814dea56c2c544aab64ae Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 23 Apr 2019 21:29:43 -0700 Subject: [PATCH 63/71] manually added prints in the extract of getFields: let getFields mi = Printf.printf "in get fields\n"; match mi.ind_bodies with | [] -> Printf.printf "no ind bodies\n"; None | oib :: l -> (match l with | [] -> (match oib.ind_ctors with | [] -> Printf.printf "no constructors\n"; None | ctor0 :: l0 -> (match l0 with | [] -> Some { coq_type = oib.ind_name; ctor = (let (p, _) = ctor0 in let (x0, _) = p in x0); fields = oib.ind_projs } | _ :: _ -> None)) | _ :: _ -> Printf.printf "multiple constructors\n"; None) it turns out there are multiple constructors for the Point record. --- plugin-demo/src/g_demo_plugin.ml4 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin-demo/src/g_demo_plugin.ml4 b/plugin-demo/src/g_demo_plugin.ml4 index f194d9380..b7b7124ab 100644 --- a/plugin-demo/src/g_demo_plugin.ml4 +++ b/plugin-demo/src/g_demo_plugin.ml4 @@ -26,7 +26,7 @@ let quote_string s = else aux (s.[i] :: acc) (i - 1) in aux [] (String.length s - 1) -VERNAC COMMAND EXTEND Unquote_vernac CLASSIFIED AS SIDEFF +VERNAC COMMAND EXTEND Make_lens_vernac CLASSIFIED AS SIDEFF | [ "Make" "Lens" ident(name) ] -> [ Run_extractable.run_vernac (Demo.genLensN (quote_string (Names.Id.to_string name))) ] From febdaf03af64b04727e6f0fff38943a4f1819407 Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Tue, 23 Apr 2019 22:10:46 -0700 Subject: [PATCH 64/71] again segfault, with: let cl2s cl = String.concat "" (List.map (String.make 1) cl) let getFields mi = match mi.ind_bodies with | [] -> Printf.printf "no ind bodies\n"; None | oib :: l -> print_string (String.concat "in get fields: " [cl2s (oib.ind_name)]); (match l with | [] -> (match oib.ind_ctors with | [] -> Printf.printf "no constructors\n"; None | ctor0 :: l0 -> (match l0 with | [] -> Some { coq_type = oib.ind_name; ctor = (let (p, _) = ctor0 in let (x0, _) = p in x0); fields = oib.ind_projs } | _ :: _ -> None)) | _ :: _ -> Printf.printf "multiple constructors\n"; None) Most likely, the inductive structure is corrupt. Some use of Obj.magic is likely suspect. --- plugin-demo/theories/Demo.v | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index 873b788a3..31fd669e5 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -14,9 +14,7 @@ LookupPrint two. Fail Print zeroE. -Showoff. - -Print zeroE. +Make Lens Point. (* (* process coq segmentation fault *) From d7f380e84d23fd312a540fe4c518a3ad41528acc Mon Sep 17 00:00:00 2001 From: "Abhishek Anand (optiplex7010@home)" Date: Wed, 24 Apr 2019 07:24:46 -0700 Subject: [PATCH 65/71] put the segfault generator in Gallina now. so just make should trigger it, instead of needing to manually edit the extract --- plugin-demo/gen-src/demo.v | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index 8ea589ca8..e4c64e20b 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -151,6 +151,13 @@ Definition opBind {A B} (a: option A) (f: A -> option B) : option B := | None => None end. +Definition printFirstIndName (ind : mutual_inductive_body) : TM unit. + destruct ind. destruct ind_bodies. + exact (tmReturn tt). + destruct o. + exact (tmMsg ind_name). + Defined. + Definition genLensN (baseName : String.string) : TM unit := let name := baseName in @@ -162,6 +169,8 @@ Definition genLensN (baseName : String.string) : TM unit := tmBind (tmQuoteInductiveR name) (fun ind => match ind with | Some ind => + tmBind (printFirstIndName ind) (* this causes segfault. also, there are unexpectedly multiple constructors in the first inductive *) + (fun _ => match getFields ind with | Some info => let gen i := @@ -177,7 +186,7 @@ Definition genLensN (baseName : String.string) : TM unit := in mconcat (map gen (countTo (List.length info.(fields)))) | None => tmFail ("failed to get inductive info but quote succeeded") - end + end ) | None => tmFail "failed to quote inductive" end From 2a4f7108c82cd6d4ec5ce171f912cc9f3f9f531e Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Wed, 24 Apr 2019 12:43:07 -0400 Subject: [PATCH 66/71] some bug fixes. --- plugin-demo/gen-src/demo.v | 7 +++--- plugin-demo/theories/Demo.v | 4 ++++ template-coq/src/plugin_core.ml | 7 +++--- template-coq/src/plugin_core.mli | 2 +- template-coq/src/run_extractable.ml | 37 ++++++++++++++++++++++------- 5 files changed, 42 insertions(+), 15 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index e4c64e20b..0c9e79185 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -157,8 +157,9 @@ Definition printFirstIndName (ind : mutual_inductive_body) : TM unit. destruct o. exact (tmMsg ind_name). Defined. - - + +Print printFirstIndName. + Definition genLensN (baseName : String.string) : TM unit := let name := baseName in let ty := @@ -189,7 +190,7 @@ Definition genLensN (baseName : String.string) : TM unit := end ) | None => tmFail "failed to quote inductive" end - + ). Notation "<% x %>" := (ltac:(let p y := exact y in quote_term x p)) (only parsing). diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index 31fd669e5..6c5f76eab 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -1,6 +1,8 @@ Require Import Coq.Strings.String. Declare ML Module "demo_plugin". +Set Primitive Projections. + Record Point : Set := { x: nat; y:nat @@ -16,6 +18,8 @@ Fail Print zeroE. Make Lens Point. +SearchAbout Point. + (* (* process coq segmentation fault *) *) \ No newline at end of file diff --git a/template-coq/src/plugin_core.ml b/template-coq/src/plugin_core.ml index cf76e7634..d5d88f2dc 100644 --- a/template-coq/src/plugin_core.ml +++ b/template-coq/src/plugin_core.ml @@ -138,11 +138,12 @@ let tmCurrentModPath : Names.ModPath.t tm = fun env evd success _fail -> let mp = Lib.current_mp () in success env evd mp -let tmQuoteInductive (kn : kername) : mutual_inductive_body option tm = +let tmQuoteInductive (kn : kername) : (Names.MutInd.t * mutual_inductive_body) option tm = fun env evm success _fail -> try - let mind = Environ.lookup_mind (Names.MutInd.make1 kn) env in - success env evm (Some mind) + let mi = Names.MutInd.make1 kn in + let mind = Environ.lookup_mind mi env in + success env evm (Some (mi, mind)) with Not_found -> success env evm None diff --git a/template-coq/src/plugin_core.mli b/template-coq/src/plugin_core.mli index dbb83de64..3b8a1bfb5 100644 --- a/template-coq/src/plugin_core.mli +++ b/template-coq/src/plugin_core.mli @@ -47,7 +47,7 @@ val tmAbout : qualid -> global_reference option tm val tmAboutString : string -> global_reference option tm val tmCurrentModPath : Names.ModPath.t tm -val tmQuoteInductive : kername -> mutual_inductive_body option tm +val tmQuoteInductive : kername -> (Names.MutInd.t * mutual_inductive_body) option tm val tmQuoteUniverses : UGraph.t tm val tmQuoteConstant : kername -> bool -> constant_entry tm diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 9fd339a38..0142072c3 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -70,7 +70,7 @@ let quote_rel_context env ctx = Ast_quoter.quote_context decls (* todo(gmm): this definition adapted from quoter.ml (the body of quote_minductive_type) *) -let of_mib (env : Environ.env) (mib : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body = +let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body = let open Declarations in let uctx = get_abstract_inductive_universes mib.mind_universes in let inst = Univ.UContext.instance uctx in @@ -103,7 +103,7 @@ let of_mib (env : Environ.env) (mib : Plugin_core.mutual_inductive_body) : Ast0. match mib.mind_record with | Some (Some (id, csts, ps)) -> let ctxwolet = Termops.smash_rel_context mib.mind_params_ctxt in - let indty = Constr.mkApp (Constr.mkIndU ((assert false (* t *),0),inst), + let indty = Constr.mkApp (Constr.mkIndU ((t,0),inst), Context.Rel.to_extended_vect Constr.mkRel 0 ctxwolet) in let indbinder = Context.Rel.Declaration.LocalAssum (Names.Name id,indty) in let envpars = Environ.push_rel_context (indbinder :: ctxwolet) env in @@ -166,13 +166,34 @@ let to_constr (t : Ast0.term) : Constr.t = let tmOfConstr (t : Constr.t) : Ast0.term tm = Plugin_core.with_env_evm (fun env _ -> tmReturn (of_constr env t)) -let tmOfMib (t : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body tm = - Plugin_core.with_env_evm (fun env _ -> tmReturn (of_mib env t)) +let tmOfMib (ti : Names.MutInd.t) (t : Plugin_core.mutual_inductive_body) : Ast0.mutual_inductive_body tm = + Plugin_core.with_env_evm (fun env _ -> tmReturn (of_mib env ti t)) let tmOfConstantEntry (t : Plugin_core.constant_entry) : Ast0.constant_entry tm = Plugin_core.with_env_evm (fun env _ -> tmReturn (of_constant_entry env t)) +let dbg = function + Coq_tmReturn _ -> "tmReturn" + | Coq_tmBind _ -> "tmBind" + | Coq_tmPrint _ -> "tmPrint" + | Coq_tmMsg msg -> "tmMsg" + | Coq_tmFail err -> "tmFail" + | Coq_tmEval (r,t) -> "tmEval" + | Coq_tmDefinition (nm, typ, trm) -> "tmDefinition" + | Coq_tmAxiom (nm, typ) -> "tmAxiom" + | Coq_tmLemma (nm, typ) -> "tmLemma" + | Coq_tmFreshName nm -> "tmFreshName" + | Coq_tmAbout id -> "tmAbout" + | Coq_tmCurrentModPath -> "tmCurrentModPath" + | Coq_tmQuoteInductive kn -> "tmQuoteInductive" + | Coq_tmQuoteUniverses -> "tmQuoteUniverses" + | Coq_tmQuoteConstant (kn, b) -> "tmQuoteConstant" + | Coq_tmInductive i -> "tmInductive" + | Coq_tmExistingInstance k -> "tmExistingInstance" + | Coq_tmInferInstance t -> "tmInferInstance" + let rec interp_tm (t : 'a coq_TM) : 'a tm = + Feedback.msg_debug Pp.(str (dbg t)) ; match t with | Coq_tmReturn x -> tmReturn x | Coq_tmBind (c, k) -> tmBind (interp_tm c) (fun x -> interp_tm (k x)) @@ -208,10 +229,10 @@ let rec interp_tm (t : 'a coq_TM) : 'a tm = tmMap (fun mp -> Obj.magic (of_string (Names.ModPath.to_string mp))) tmCurrentModPath | Coq_tmQuoteInductive kn -> - tmMap (function - None -> Obj.magic None - | Some mib -> Obj.magic (tmMap (fun x -> Some x) (tmOfMib mib))) - (tmQuoteInductive (to_kername kn)) + tmBind (tmQuoteInductive (to_kername kn)) + (function + None -> Obj.magic (tmFail Pp.(str "inductive does not exist")) + | Some (mi, mib) -> Obj.magic (tmOfMib mi mib)) | Coq_tmQuoteUniverses -> tmMap (fun x -> failwith "tmQuoteUniverses") tmQuoteUniverses | Coq_tmQuoteConstant (kn, b) -> From d951c125c20d2f6e5c45c30130cb927c71d4bdf9 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Wed, 24 Apr 2019 13:32:48 -0400 Subject: [PATCH 67/71] working gen-lens --- plugin-demo/_CoqProject | 3 +- plugin-demo/gen-src/_CoqProject | 2 + plugin-demo/gen-src/demo.v | 161 +++++++++++++++----------------- plugin-demo/theories/Demo.v | 1 + plugin-demo/theories/Lens.v | 24 +++++ 5 files changed, 106 insertions(+), 85 deletions(-) create mode 100644 plugin-demo/theories/Lens.v diff --git a/plugin-demo/_CoqProject b/plugin-demo/_CoqProject index 551c7f0eb..ee148f665 100644 --- a/plugin-demo/_CoqProject +++ b/plugin-demo/_CoqProject @@ -1,5 +1,5 @@ -I src --Q theories Demo +-Q theories Lens src/demo.ml @@ -9,6 +9,7 @@ src/demo.mli src/g_demo_plugin.ml4 src/demo_plugin.mlpack +theories/Lens.v theories/Demo.v diff --git a/plugin-demo/gen-src/_CoqProject b/plugin-demo/gen-src/_CoqProject index a2395b917..d6cf9e427 100644 --- a/plugin-demo/gen-src/_CoqProject +++ b/plugin-demo/gen-src/_CoqProject @@ -1,6 +1,8 @@ -R ../../template-coq/theories Template -I ../../template-coq/src +-Q ../theories Lens -Q . Demo +../theories/Lens.v demo.v Extract.v \ No newline at end of file diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index 0c9e79185..0a50df211 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -1,38 +1,39 @@ +Require Import Coq.Lists.List. From Template Require Import Ast Loader TemplateMonad.Extractable. +Import TemplateMonad.Extractable. +Require Import Template.BasicAst Template.AstUtils Ast. +Require Import Lens.Lens. -(* -Definition showoff : TM unit := - tmMsg "running from an extracted plugin!". -*) - -Set Primitive Projections. - -Record Lens (a b c d : Type) : Type := -{ view : a -> c -; over : (c -> d) -> a -> b -}. - -Arguments over {_ _ _ _} _ _ _. -Arguments view {_ _ _ _} _ _. - -Definition lens_compose {a b c d e f : Type} - (l1 : Lens a b c d) (l2 : Lens c d e f) -: Lens a b e f := -{| view := fun x : a => view l2 (view l1 x) - ; over := fun f0 : e -> f => over l1 (over l2 f0) |}. - -Infix "∙" := lens_compose (at level 90, left associativity). - -Section ops. - Context {a b c d : Type} (l : Lens a b c d). +Let TemplateMonad := TM. +Fixpoint mconcat (ls : list (TemplateMonad unit)) : TemplateMonad unit := + match ls with + | nil => tmReturn tt + | m :: ms => tmBind m (fun _ => mconcat ms) + end. - Definition set (new : d) : a -> b := - l.(over) (fun _ => new). -End ops. +Fixpoint print_all_kns (t : Ast.term) : TM unit := + match t with + | tEvar _ ls => + mconcat (List.map print_all_kns ls) + | tCast a _ b + | tProd _ a b + | tLambda _ a b => + tmBind (print_all_kns a) (fun _ => print_all_kns b) + | tApp a b => + tmBind (print_all_kns a) (fun _ => mconcat (List.map print_all_kns b)) + | tLetIn _ a b c => + tmBind (print_all_kns a) (fun _ => tmBind (print_all_kns b) (fun _ => print_all_kns c)) + | tConst c _ => tmMsg c + | tInd i _ => tmMsg i.(inductive_mind) + | tConstruct i _ _ => tmMsg i.(inductive_mind) + | tProj (i,_,_) b => + tmBind (tmMsg i.(inductive_mind)) (fun _ => print_all_kns b) + | _ => tmReturn tt + end. Set Primitive Projections. @@ -113,15 +114,24 @@ Definition getFields (mi : mutual_inductive_body) | _ => None end. -Import TemplateMonad.Extractable. -Require Import Template.BasicAst Template.AstUtils Ast. -Let TemplateMonad := TM. -Fixpoint mconcat (ls : list (TemplateMonad unit)) : TemplateMonad unit := - match ls with - | nil => tmReturn tt - | m :: ms => tmBind m (fun _ => mconcat ms) +Definition gr_to_kername (gr : global_reference) : kername := + match gr with + | ConstRef kn => kn + | IndRef ind => ind.(inductive_mind) + | ConstructRef ind _ => ind.(inductive_mind) end. +Definition tmResolve (nm : String.string) : TM (option kername) := + tmBind (tmAbout nm) + (fun gr => + match gr with + | None => tmReturn None + | Some (ConstRef kn) => tmReturn (Some kn) + | Some (IndRef ind) => tmReturn (Some ind.(inductive_mind)) + | Some (ConstructRef ind _) => tmReturn (Some ind.(inductive_mind)) + end). + + Definition tmQuoteInductiveR (nm: kername) : TM (option mutual_inductive_body). refine ( @@ -158,61 +168,44 @@ Definition printFirstIndName (ind : mutual_inductive_body) : TM unit. exact (tmMsg ind_name). Defined. -Print printFirstIndName. - Definition genLensN (baseName : String.string) : TM unit := - let name := baseName in - let ty := - (Ast.tInd - {| - BasicAst.inductive_mind := name; - BasicAst.inductive_ind := 0 (* TODO: fix for mutual records *) |} List.nil) in - tmBind (tmQuoteInductiveR name) (fun ind => - match ind with - | Some ind => - tmBind (printFirstIndName ind) (* this causes segfault. also, there are unexpectedly multiple constructors in the first inductive *) - (fun _ => - match getFields ind with - | Some info => - let gen i := - match mkLens ty info.(fields) i return TemplateMonad unit with - | None => tmFail "failed to build lens" - | Some x => - tmBind (tmEval Common.cbv (snd x)) - (fun d => - tmBind - (tmDefinition (fst x) None d) - (fun _ => tmReturn tt)) - end - in - mconcat (map gen (countTo (List.length info.(fields)))) - | None => tmFail ("failed to get inductive info but quote succeeded") - end ) - | None => tmFail "failed to quote inductive" - end + tmBind (tmAbout baseName) (fun gr => + match gr with + | Some (IndRef kn) => + let name := kn.(inductive_mind) in + let ty := Ast.tInd + {| BasicAst.inductive_mind := name + ; BasicAst.inductive_ind := 0 (* TODO: fix for mutual records *) |} List.nil in + tmBind (tmQuoteInductiveR name) (fun ind => + match ind with + | Some ind => + tmBind (printFirstIndName ind) (* this causes segfault. also, there are unexpectedly multiple constructors in the first inductive *) + (fun _ => + match getFields ind with + | Some info => + let gen i := + match mkLens ty info.(fields) i return TemplateMonad unit with + | None => tmFail "failed to build lens" + | Some x => + tmBind (tmMsg "dumping kns") (fun _ => + tmBind (print_all_kns (snd x)) (fun _ => + tmBind (tmEval Common.cbv (snd x)) (fun d => + tmBind (tmDefinition (fst x) None d) (fun _ => + tmReturn tt)))) + end + in + mconcat (map gen (countTo (List.length info.(fields)))) + | None => tmFail ("failed to get inductive info but quote succeeded") + end ) + | None => tmFail "failed to quote inductive" + end) + | _ => tmFail "not an inductive" + end). -). Notation "<% x %>" := (ltac:(let p y := exact y in quote_term x p)) (only parsing). Print definition_entry. -Definition gr_to_kername (gr : global_reference) : kername := - match gr with - | ConstRef kn => kn - | IndRef ind => ind.(inductive_mind) - | ConstructRef ind _ => ind.(inductive_mind) - end. - -Definition tmResolve (nm : String.string) : TM (option kername) := - tmBind (tmAbout nm) - (fun gr => - match gr with - | None => tmReturn None - | Some (ConstRef kn) => tmReturn (Some kn) - | Some (IndRef ind) => tmReturn (Some ind.(inductive_mind)) - | Some (ConstructRef ind _) => tmReturn (Some ind.(inductive_mind)) - end). - Definition tmQuoteConstantR (nm : String.string) (bypass : bool) : TM _ := tmBind (tmAbout nm) (fun gr => diff --git a/plugin-demo/theories/Demo.v b/plugin-demo/theories/Demo.v index 6c5f76eab..ff2670ec4 100644 --- a/plugin-demo/theories/Demo.v +++ b/plugin-demo/theories/Demo.v @@ -1,5 +1,6 @@ Require Import Coq.Strings.String. Declare ML Module "demo_plugin". +Require Import Lens.Lens. Set Primitive Projections. diff --git a/plugin-demo/theories/Lens.v b/plugin-demo/theories/Lens.v new file mode 100644 index 000000000..8b226ad9e --- /dev/null +++ b/plugin-demo/theories/Lens.v @@ -0,0 +1,24 @@ +Set Primitive Projections. + +Record Lens (a b c d : Type) : Type := +{ view : a -> c +; over : (c -> d) -> a -> b +}. + +Arguments over {_ _ _ _} _ _ _. +Arguments view {_ _ _ _} _ _. + +Definition lens_compose {a b c d e f : Type} + (l1 : Lens a b c d) (l2 : Lens c d e f) +: Lens a b e f := +{| view := fun x : a => view l2 (view l1 x) + ; over := fun f0 : e -> f => over l1 (over l2 f0) |}. + +Infix "∙" := lens_compose (at level 90, left associativity). + +Section ops. + Context {a b c d : Type} (l : Lens a b c d). + + Definition set (new : d) : a -> b := + l.(over) (fun _ => new). +End ops. From 3b4b6f9a2a9275e6b4bca73aa2c7f4d5c04be7a3 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Wed, 24 Apr 2019 13:43:20 -0400 Subject: [PATCH 68/71] cleanup the implementation of genLens --- plugin-demo/gen-src/demo.v | 120 ++++++++++++++----------------------- 1 file changed, 45 insertions(+), 75 deletions(-) diff --git a/plugin-demo/gen-src/demo.v b/plugin-demo/gen-src/demo.v index 0a50df211..815e7af1e 100644 --- a/plugin-demo/gen-src/demo.v +++ b/plugin-demo/gen-src/demo.v @@ -6,7 +6,6 @@ From Template Require Import Import TemplateMonad.Extractable. Require Import Template.BasicAst Template.AstUtils Ast. -Require Import Lens.Lens. Let TemplateMonad := TM. Fixpoint mconcat (ls : list (TemplateMonad unit)) : TemplateMonad unit := @@ -35,6 +34,32 @@ Fixpoint print_all_kns (t : Ast.term) : TM unit := | _ => tmReturn tt end. +Notation "<% x %>" := (ltac:(let p y := exact y in quote_term x p)) + (only parsing). + + +Definition gr_to_kername (gr : global_reference) : kername := + match gr with + | ConstRef kn => kn + | IndRef ind => ind.(inductive_mind) + | ConstructRef ind _ => ind.(inductive_mind) + end. + +Definition tmResolve (nm : String.string) : TM (option kername) := + tmBind (tmAbout nm) + (fun gr => + match gr with + | None => tmReturn None + | Some (ConstRef kn) => tmReturn (Some kn) + | Some (IndRef ind) => tmReturn (Some ind.(inductive_mind)) + | Some (ConstructRef ind _) => tmReturn (Some ind.(inductive_mind)) + end). + + +(* ^^ Everything above here is generic *) + +Require Import Lens.Lens. + Set Primitive Projections. Set Universe Polymorphism. @@ -56,7 +81,7 @@ Open Scope string_scope. Definition prepend (ls : string) (i : ident) : ident := ls ++ i. -Quote Definition cBuild_Lens := Build_Lens. +Definition cBuild_Lens := <% Build_Lens %>. Require Import Coq.Lists.List. Require Import Coq.Bool.Bool. @@ -67,6 +92,7 @@ Definition mentions (v : nat) (ls : list (ident * term)) : bool := false. + Definition mkLens (At : term) (fields : list (ident * term)) (i : nat) : option (ident * term) := match At with @@ -114,39 +140,6 @@ Definition getFields (mi : mutual_inductive_body) | _ => None end. -Definition gr_to_kername (gr : global_reference) : kername := - match gr with - | ConstRef kn => kn - | IndRef ind => ind.(inductive_mind) - | ConstructRef ind _ => ind.(inductive_mind) - end. - -Definition tmResolve (nm : String.string) : TM (option kername) := - tmBind (tmAbout nm) - (fun gr => - match gr with - | None => tmReturn None - | Some (ConstRef kn) => tmReturn (Some kn) - | Some (IndRef ind) => tmReturn (Some ind.(inductive_mind)) - | Some (ConstructRef ind _) => tmReturn (Some ind.(inductive_mind)) - end). - - -Definition tmQuoteInductiveR (nm: kername) : - TM (option mutual_inductive_body). - refine ( - tmBind (tmAbout nm) - (fun gr => - match gr with - | Some (IndRef kn) => - tmBind (tmQuoteInductive (inductive_mind kn)) - (fun x => tmReturn (Some x)) - | _ => tmReturn None - end) - ). - Defined. - - (* baseName should not contain any paths. For example, if the full name is A.B.C#D#E#F, baseName should be F. Also, by import ordering, ensure that F resolves to A.B.C#D#E#F. Use Locate to check this. @@ -161,13 +154,6 @@ Definition opBind {A B} (a: option A) (f: A -> option B) : option B := | None => None end. -Definition printFirstIndName (ind : mutual_inductive_body) : TM unit. - destruct ind. destruct ind_bodies. - exact (tmReturn tt). - destruct o. - exact (tmMsg ind_name). - Defined. - Definition genLensN (baseName : String.string) : TM unit := tmBind (tmAbout baseName) (fun gr => match gr with @@ -176,35 +162,24 @@ Definition genLensN (baseName : String.string) : TM unit := let ty := Ast.tInd {| BasicAst.inductive_mind := name ; BasicAst.inductive_ind := 0 (* TODO: fix for mutual records *) |} List.nil in - tmBind (tmQuoteInductiveR name) (fun ind => - match ind with - | Some ind => - tmBind (printFirstIndName ind) (* this causes segfault. also, there are unexpectedly multiple constructors in the first inductive *) - (fun _ => - match getFields ind with - | Some info => - let gen i := - match mkLens ty info.(fields) i return TemplateMonad unit with - | None => tmFail "failed to build lens" - | Some x => - tmBind (tmMsg "dumping kns") (fun _ => - tmBind (print_all_kns (snd x)) (fun _ => - tmBind (tmEval Common.cbv (snd x)) (fun d => - tmBind (tmDefinition (fst x) None d) (fun _ => - tmReturn tt)))) - end - in - mconcat (map gen (countTo (List.length info.(fields)))) - | None => tmFail ("failed to get inductive info but quote succeeded") - end ) - | None => tmFail "failed to quote inductive" - end) + tmBind (tmQuoteInductive name) (fun ind => + match getFields ind with + | Some info => + let gen i := + match mkLens ty info.(fields) i return TemplateMonad unit with + | None => tmFail "failed to build lens" + | Some x => + tmBind (tmEval Common.cbv (snd x)) (fun d => + tmBind (tmDefinition (fst x) None d) (fun _ => + tmReturn tt)) + end + in + mconcat (map gen (countTo (List.length info.(fields)))) + | None => tmFail ("failed to get inductive info but quote succeeded") + end) | _ => tmFail "not an inductive" end). -Notation "<% x %>" := (ltac:(let p y := exact y in quote_term x p)) - (only parsing). -Print definition_entry. Definition tmQuoteConstantR (nm : String.string) (bypass : bool) : TM _ := tmBind (tmAbout nm) @@ -229,16 +204,11 @@ Definition lookupPrint (baseName : String.string) : TM unit := end end). -Definition x := - tConstruct - {| inductive_mind := "Coq.Init.Datatypes.nat"; inductive_ind := 0 |} - 0 nil -. +Definition x := <% 0 %>. Definition lookup (baseName : String.string) : TM unit := tmBind (tmQuoteConstant baseName true) - (fun b => tmReturn tt - ). + (fun b => tmReturn tt). Definition genLensNInst : TM unit := genLensN "Point". From 8bd1423bb9cb1d11eb62aa69a584347f3f295bda Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Wed, 24 Apr 2019 13:45:27 -0400 Subject: [PATCH 69/71] removing some debug printing. --- template-coq/src/run_extractable.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 0142072c3..1fe744343 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -172,6 +172,7 @@ let tmOfMib (ti : Names.MutInd.t) (t : Plugin_core.mutual_inductive_body) : Ast0 let tmOfConstantEntry (t : Plugin_core.constant_entry) : Ast0.constant_entry tm = Plugin_core.with_env_evm (fun env _ -> tmReturn (of_constant_entry env t)) +(* let dbg = function Coq_tmReturn _ -> "tmReturn" | Coq_tmBind _ -> "tmBind" @@ -191,9 +192,10 @@ let dbg = function | Coq_tmInductive i -> "tmInductive" | Coq_tmExistingInstance k -> "tmExistingInstance" | Coq_tmInferInstance t -> "tmInferInstance" +*) let rec interp_tm (t : 'a coq_TM) : 'a tm = - Feedback.msg_debug Pp.(str (dbg t)) ; +(* Feedback.msg_debug Pp.(str (dbg t)) ; *) match t with | Coq_tmReturn x -> tmReturn x | Coq_tmBind (c, k) -> tmBind (interp_tm c) (fun x -> interp_tm (k x)) From 6d37f6f1562ef6a0f1ff004e2b83fff29a5fe16c Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Wed, 24 Apr 2019 18:03:50 -0400 Subject: [PATCH 70/71] updating the extraction makefile. --- extraction/Makefile.plugin.local | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extraction/Makefile.plugin.local b/extraction/Makefile.plugin.local index bfa366be4..2c5fb9068 100644 --- a/extraction/Makefile.plugin.local +++ b/extraction/Makefile.plugin.local @@ -1,2 +1,2 @@ -CAMLFLAGS+=-open Template_coq_checker_plugin -open Template_coq_checker_plugin.Typing0 -open Template_coq_pcuic_plugin +# CAMLFLAGS+=-open Template_coq_checker_plugin -open Template_coq_checker_plugin.Typing0 -open Template_coq_pcuic_plugin CAMLFLAGS+=-w -33 # Unused opens From 1ac2b6379a350069997e49f4055ead51766aad52 Mon Sep 17 00:00:00 2001 From: Gregory Malecha Date: Thu, 25 Apr 2019 07:42:27 -0400 Subject: [PATCH 71/71] type annotation. --- template-coq/src/run_extractable.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/template-coq/src/run_extractable.ml b/template-coq/src/run_extractable.ml index 1fe744343..1a389e65c 100644 --- a/template-coq/src/run_extractable.ml +++ b/template-coq/src/run_extractable.ml @@ -125,7 +125,7 @@ let of_mib (env : Environ.env) (t : Names.MutInd.t) (mib : Plugin_core.mutual_in let bodies = List.map Ast_quoter.mk_one_inductive_body (List.rev ls) in Ast_quoter.mk_mutual_inductive_body nparams paramsctx bodies uctx -let to_mie x : Plugin_core.mutual_inductive_entry = +let to_mie (x : Ast0.mutual_inductive_entry) : Plugin_core.mutual_inductive_entry = failwith "to_mie" (* note(gmm): code taken from quoter.ml (quote_entry_aux) *)