├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── tuto0 ├── Makefile ├── _CoqProject ├── src │ ├── dune │ ├── g_tuto0.mlg │ ├── tuto0_main.ml │ ├── tuto0_main.mli │ └── tuto0_plugin.mlpack └── theories │ ├── Demo.v │ └── Loader.v ├── tuto1 ├── Makefile ├── _CoqProject ├── src │ ├── dune │ ├── g_tuto1.mlg │ ├── simple_check.ml │ ├── simple_check.mli │ ├── simple_declare.ml │ ├── simple_declare.mli │ ├── simple_print.ml │ ├── simple_print.mli │ └── tuto1_plugin.mlpack └── theories │ └── Loader.v ├── tuto2 ├── Makefile ├── _CoqProject ├── src │ ├── .gitignore │ ├── demo.mlg │ ├── demo_plugin.mlpack │ └── dune └── theories │ └── Test.v └── tuto3 ├── Makefile ├── _CoqProject ├── src ├── construction_game.ml ├── construction_game.mli ├── dune ├── g_tuto3.mlg ├── tuto3_plugin.mlpack ├── tuto_tactic.ml └── tuto_tactic.mli └── theories ├── Data.v ├── Loader.v └── test.v /.gitignore: -------------------------------------------------------------------------------- 1 | *.ml*.d 2 | *.cm[ixt]* 3 | Makefile.coq* 4 | *~ 5 | *.[ao] 6 | .coqdeps.d 7 | *.vo 8 | *.glob 9 | *.aux 10 | */*/.merlin 11 | 12 | # by convention g_foo.ml is generated 13 | g_*.ml 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | dist: trusty 2 | sudo: required 3 | language: generic 4 | 5 | services: 6 | - docker 7 | 8 | env: 9 | global: 10 | - NJOBS="2" 11 | - CONTRIB_NAME="plugin_tutorials" 12 | matrix: 13 | - COQ_IMAGE="coqorg/coq:dev" 14 | 15 | install: | 16 | # Prepare the COQ container 17 | docker run -d -i --init --name=COQ -v ${TRAVIS_BUILD_DIR}:/home/coq/$CONTRIB_NAME -w /home/coq/$CONTRIB_NAME ${COQ_IMAGE} 18 | docker exec COQ /bin/bash --login -c " 19 | # This bash script is double-quoted to interpolate Travis CI env vars: 20 | echo \"Build triggered by ${TRAVIS_EVENT_TYPE}\" 21 | export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' 22 | set -ex # -e = exit on failure; -x = trace for debug 23 | opam list 24 | " 25 | script: 26 | - echo -e "${ANSI_YELLOW}Building $CONTRIB_NAME...${ANSI_RESET}" && echo -en 'travis_fold:start:testbuild\\r' 27 | - | 28 | docker exec COQ /bin/bash --login -c " 29 | export PS4='+ \e[33;1m(\$0 @ line \$LINENO) \$\e[0m ' 30 | set -ex 31 | sudo chown -R coq:coq /home/coq/$CONTRIB_NAME 32 | ( cd tuto0 && make ) 33 | ( cd tuto1 && make ) 34 | ( cd tuto2 && make ) 35 | ( cd tuto3 && make ) 36 | " 37 | - docker stop COQ # optional 38 | - echo -en 'travis_fold:end:testbuild\\r' 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | This site is now frozen 2 | ======================= 3 | 4 | This development has moved to the Coq repository in directory `doc/plugin_tutorials`. For the master branch you can access at https://github.com/coq/coq/tree/master/doc/plugin_tutorial. 5 | 6 | 7 | 8 | How to write plugins in Coq 9 | =========================== 10 | # Working environment : merlin, tuareg (open question) 11 | 12 | ## OCaml & related tools 13 | 14 | These instructions use [OPAM](http://opam.ocaml.org/doc/Install.html) 15 | 16 | ```shell 17 | opam init --root=$PWD/CIW2018 --compiler=4.06.0 -j2 18 | eval `opam config env --root=$PWD/CIW2018` 19 | opam install camlp5 ocamlfind num # Coq's dependencies 20 | opam install lablgtk # Coqide's dependencies (optional) 21 | opam install merlin # prints instructions for vim and emacs 22 | ``` 23 | 24 | ## Coq 25 | 26 | ```shell 27 | git clone git@github.com:coq/coq.git 28 | cd coq 29 | ./configure -profile devel 30 | make -j2 31 | cd .. 32 | export PATH=$PWD/coq/bin:$PATH 33 | ``` 34 | 35 | ## This tutorial 36 | 37 | ```shell 38 | git clone git@github.com:ybertot/plugin_tutorials.git 39 | cd plugin_tutorials/tuto0 40 | make .merlin # run before opening .ml files in your editor 41 | make # build 42 | ``` 43 | 44 | 45 | 46 | # tuto0 : basics of project organization 47 | package a ml4 file in a plugin, organize a `Makefile`, `_CoqProject` 48 | - Example of syntax to add a new toplevel command 49 | - Example of function call to print a simple message 50 | - Example of syntax to add a simple tactic 51 | (that does nothing and prints a message) 52 | - To use it: 53 | 54 | ```bash 55 | cd tuto0; make 56 | coqtop -I src -R theories Tuto0 57 | ``` 58 | 59 | In the Coq session type: 60 | ```coq 61 | Require Import Tuto0.Loader. HelloWorld. 62 | ``` 63 | 64 | # tuto1 : Ocaml to Coq communication 65 | Explore the memory of Coq, modify it 66 | - Commands that take arguments: strings, symbols, expressions of the calculus of constructions 67 | - Commands that interact with type-checking in Coq 68 | - A command that adds a new definition or theorem 69 | - A command that uses a name and exploits the existing definitions 70 | or theorems 71 | - A command that exploits an existing ongoing proof 72 | - A command that defines a new tactic 73 | 74 | Compilation and loading must be performed as for `tuto0`. 75 | 76 | # tuto2 : Ocaml to Coq communication 77 | A more step by step introduction to writing commands 78 | - Explanation of the syntax of entries 79 | - Adding a new type to and parsing to the available choices 80 | - Handling commands that store information in user-chosen registers and tables 81 | 82 | Compilation and loading must be performed as for `tuto1`. 83 | 84 | # tuto3 : manipulating terms of the calculus of constructions 85 | Manipulating terms, inside commands and tactics. 86 | - Obtaining existing values from memory 87 | - Composing values 88 | - Verifying types 89 | - Using these terms in commands 90 | - Using these terms in tactics 91 | - Automatic proofs without tactics using type classes and canonical structures 92 | 93 | compilation and loading must be performed as for `tuto0`. 94 | -------------------------------------------------------------------------------- /tuto0/Makefile: -------------------------------------------------------------------------------- 1 | ifeq "$(COQBIN)" "" 2 | COQBIN=$(dir $(shell which coqtop))/ 3 | endif 4 | 5 | %: Makefile.coq 6 | 7 | Makefile.coq: _CoqProject 8 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 9 | 10 | tests: all 11 | @$(MAKE) -C tests -s clean 12 | @$(MAKE) -C tests -s all 13 | 14 | -include Makefile.coq 15 | -------------------------------------------------------------------------------- /tuto0/_CoqProject: -------------------------------------------------------------------------------- 1 | -R theories/ Tuto0 2 | -I src 3 | 4 | theories/Loader.v 5 | theories/Demo.v 6 | 7 | src/tuto0_main.ml 8 | src/tuto0_main.mli 9 | src/g_tuto0.mlg 10 | src/tuto0_plugin.mlpack 11 | -------------------------------------------------------------------------------- /tuto0/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tuto0_plugin) 3 | (public_name coq.plugins.tutorial.p0) 4 | (libraries coq.plugins.ltac)) 5 | 6 | (rule 7 | (targets g_tuto0.ml) 8 | (deps (:pp-file g_tuto0.mlg) ) 9 | (action (run coqpp %{pp-file}))) 10 | -------------------------------------------------------------------------------- /tuto0/src/g_tuto0.mlg: -------------------------------------------------------------------------------- 1 | DECLARE PLUGIN "tuto0_plugin" 2 | 3 | { 4 | 5 | open Pp 6 | open Ltac_plugin 7 | 8 | } 9 | 10 | VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY 11 | | [ "HelloWorld" ] -> { Feedback.msg_notice (strbrk Tuto0_main.message) } 12 | END 13 | 14 | TACTIC EXTEND hello_world_tactic 15 | | [ "hello_world" ] -> 16 | { let _ = Feedback.msg_notice (str Tuto0_main.message) in 17 | Tacticals.New.tclIDTAC } 18 | END 19 | -------------------------------------------------------------------------------- /tuto0/src/tuto0_main.ml: -------------------------------------------------------------------------------- 1 | let message = "Hello world!" 2 | -------------------------------------------------------------------------------- /tuto0/src/tuto0_main.mli: -------------------------------------------------------------------------------- 1 | val message : string -------------------------------------------------------------------------------- /tuto0/src/tuto0_plugin.mlpack: -------------------------------------------------------------------------------- 1 | Tuto0_main 2 | G_tuto0 -------------------------------------------------------------------------------- /tuto0/theories/Demo.v: -------------------------------------------------------------------------------- 1 | From Tuto0 Require Import Loader. 2 | 3 | HelloWorld. 4 | 5 | Lemma test : True. 6 | Proof. 7 | hello_world. 8 | Abort. 9 | -------------------------------------------------------------------------------- /tuto0/theories/Loader.v: -------------------------------------------------------------------------------- 1 | Declare ML Module "tuto0_plugin". -------------------------------------------------------------------------------- /tuto1/Makefile: -------------------------------------------------------------------------------- 1 | ifeq "$(COQBIN)" "" 2 | COQBIN=$(dir $(shell which coqtop))/ 3 | endif 4 | 5 | %: Makefile.coq 6 | 7 | Makefile.coq: _CoqProject 8 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 9 | 10 | tests: all 11 | @$(MAKE) -C tests -s clean 12 | @$(MAKE) -C tests -s all 13 | 14 | -include Makefile.coq 15 | -------------------------------------------------------------------------------- /tuto1/_CoqProject: -------------------------------------------------------------------------------- 1 | -R theories Tuto1 2 | -I src 3 | 4 | theories/Loader.v 5 | 6 | src/simple_check.mli 7 | src/simple_check.ml 8 | src/simple_declare.mli 9 | src/simple_declare.ml 10 | src/simple_print.ml 11 | src/simple_print.mli 12 | src/g_tuto1.mlg 13 | src/tuto1_plugin.mlpack 14 | -------------------------------------------------------------------------------- /tuto1/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tuto1_plugin) 3 | (public_name coq.plugins.tutorial.p1) 4 | (libraries coq.plugins.ltac)) 5 | 6 | (rule 7 | (targets g_tuto1.ml) 8 | (deps (:pp-file g_tuto1.mlg) ) 9 | (action (run coqpp %{pp-file}))) 10 | -------------------------------------------------------------------------------- /tuto1/src/g_tuto1.mlg: -------------------------------------------------------------------------------- 1 | DECLARE PLUGIN "tuto1_plugin" 2 | 3 | { 4 | 5 | (* If we forget this line and include our own tactic definition using 6 | TACTIC EXTEND, as below, then we get the strange error message 7 | no implementation available for Tacentries, only when compiling 8 | theories/Loader.v 9 | *) 10 | open Ltac_plugin 11 | open Attributes 12 | open Pp 13 | (* This module defines the types of arguments to be used in the 14 | EXTEND directives below, for example the string one. *) 15 | open Stdarg 16 | 17 | } 18 | 19 | VERNAC COMMAND EXTEND HelloWorld CLASSIFIED AS QUERY 20 | | [ "Hello" string(s) ] -> 21 | { Feedback.msg_notice (strbrk "Hello " ++ str s) } 22 | END 23 | 24 | (* reference is allowed as a syntactic entry, but so are all the entries 25 | found the signature of module Prim in file coq/parsing/pcoq.mli *) 26 | 27 | VERNAC COMMAND EXTEND HelloAgain CLASSIFIED AS QUERY 28 | | [ "HelloAgain" reference(r)] -> 29 | (* The function Ppconstr.pr_qualid was found by searching all mli files 30 | for a function of type qualid -> Pp.t *) 31 | { Feedback.msg_notice 32 | (strbrk "Hello again " ++ Ppconstr.pr_qualid r)} 33 | END 34 | 35 | (* According to parsing/pcoq.mli, e has type constr_expr *) 36 | (* this type is defined in pretyping/constrexpr.ml *) 37 | (* Question for the developers: why is the file constrexpr.ml and not 38 | constrexpr.mli --> Easier for packing the software in components. *) 39 | VERNAC COMMAND EXTEND TakingConstr CLASSIFIED AS QUERY 40 | | [ "Cmd1" constr(e) ] -> 41 | { let _ = e in Feedback.msg_notice (strbrk "Cmd1 parsed something") } 42 | END 43 | 44 | (* The next step is to make something of parsed expression. 45 | Interesting information in interp/constrintern.mli *) 46 | 47 | (* There are several phases of transforming a parsed expression into 48 | the final internal data-type (constr). There exists a collection of 49 | functions that combine all the phases *) 50 | 51 | VERNAC COMMAND EXTEND TakingConstr2 CLASSIFIED AS QUERY 52 | | [ "Cmd2" constr(e) ] -> 53 | { let _ = Constrintern.interp_constr 54 | (Global.env()) 55 | (* Make sure you don't use Evd.empty here, as this does not 56 | check consistency with existing universe constraints. *) 57 | (Evd.from_env (Global.env())) e in 58 | Feedback.msg_notice (strbrk "Cmd2 parsed something legitimate") } 59 | END 60 | 61 | (* This is to show what happens when typing in an empty environment 62 | with an empty evd. 63 | Question for the developers: why does "Cmd3 (fun x : nat => x)." 64 | raise an anomaly, not the same error as "Cmd3 (fun x : a => x)." *) 65 | 66 | VERNAC COMMAND EXTEND TakingConstr3 CLASSIFIED AS QUERY 67 | | [ "Cmd3" constr(e) ] -> 68 | { let _ = Constrintern.interp_constr Environ.empty_env 69 | Evd.empty e in 70 | Feedback.msg_notice 71 | (strbrk "Cmd3 accepted something in the empty context")} 72 | END 73 | 74 | (* When adding a definition, we have to be careful that just 75 | the operation of constructing a well-typed term may already change 76 | the environment, at the level of universe constraints (which 77 | are recorded in the evd component). The function 78 | Constrintern.interp_constr ignores this side-effect, so it should 79 | not be used here. *) 80 | 81 | (* Looking at the interface file interp/constrintern.ml4, I lost 82 | some time because I did not see that the "constr" type appearing 83 | there was "EConstr.constr" and not "Constr.constr". *) 84 | 85 | VERNAC COMMAND EXTEND Define1 CLASSIFIED AS SIDEFF 86 | | #[ poly = polymorphic ] [ "Cmd4" ident(i) constr(e) ] -> 87 | { let v = Constrintern.interp_constr (Global.env()) 88 | (Evd.from_env (Global.env())) e in 89 | Simple_declare.packed_declare_definition ~poly i v } 90 | END 91 | 92 | VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY 93 | | [ "Cmd5" constr(e) ] -> 94 | { let v = Constrintern.interp_constr (Global.env()) 95 | (Evd.from_env (Global.env())) e in 96 | let (_, ctx) = v in 97 | let evd = Evd.from_ctx ctx in 98 | Feedback.msg_notice 99 | (Printer.pr_econstr_env (Global.env()) evd 100 | (Simple_check.simple_check1 v)) } 101 | END 102 | 103 | VERNAC COMMAND EXTEND Check2 CLASSIFIED AS QUERY 104 | | [ "Cmd6" constr(e) ] -> 105 | { let v = Constrintern.interp_constr (Global.env()) 106 | (Evd.from_env (Global.env())) e in 107 | let evd, ty = Simple_check.simple_check2 v in 108 | Feedback.msg_notice 109 | (Printer.pr_econstr_env (Global.env()) evd ty) } 110 | END 111 | 112 | VERNAC COMMAND EXTEND Check1 CLASSIFIED AS QUERY 113 | | [ "Cmd7" constr(e) ] -> 114 | { let v = Constrintern.interp_constr (Global.env()) 115 | (Evd.from_env (Global.env())) e in 116 | let (a, ctx) = v in 117 | let evd = Evd.from_ctx ctx in 118 | Feedback.msg_notice 119 | (Printer.pr_econstr_env (Global.env()) evd 120 | (Simple_check.simple_check3 v)) } 121 | END 122 | 123 | (* This command takes a name and return its value. It does less 124 | than Print, because it fails on constructors, axioms, and inductive types. 125 | This should be improved, because the error message is an anomaly. 126 | Anomalies should never appear even when using a command outside of its 127 | intended use. *) 128 | VERNAC COMMAND EXTEND ExamplePrint CLASSIFIED AS QUERY 129 | | [ "Cmd8" reference(r) ] -> 130 | { let env = Global.env() in 131 | let evd = Evd.from_env env in 132 | Feedback.msg_notice 133 | (Printer.pr_econstr_env env evd 134 | (EConstr.of_constr 135 | (Simple_print.simple_body_access (Nametab.global r)))) } 136 | END 137 | 138 | TACTIC EXTEND my_intro 139 | | [ "my_intro" ident(i) ] -> 140 | { Tactics.introduction i } 141 | END 142 | 143 | (* if one write this: 144 | VERNAC COMMAND EXTEND exploreproof CLASSIFIED AS QUERY 145 | it gives an error message that is basically impossible to understand. *) 146 | 147 | VERNAC COMMAND EXTEND ExploreProof CLASSIFIED AS QUERY 148 | | [ "Cmd9" ] -> 149 | { let p = Proof_global.give_me_the_proof () in 150 | let sigma, env = Pfedit.get_current_context () in 151 | let pprf = Proof.partial_proof p in 152 | Feedback.msg_notice 153 | (Pp.prlist_with_sep Pp.fnl (Printer.pr_econstr_env env sigma) pprf) } 154 | END 155 | -------------------------------------------------------------------------------- /tuto1/src/simple_check.ml: -------------------------------------------------------------------------------- 1 | let simple_check1 value_with_constraints = 2 | begin 3 | let evalue, st = value_with_constraints in 4 | let evd = Evd.from_ctx st in 5 | (* This is reverse engineered from vernacentries.ml *) 6 | (* The point of renaming is to make sure the bound names printed by Check 7 | can be re-used in `apply with` tactics that use bound names to 8 | refer to arguments. *) 9 | let j = Termops.on_judgment EConstr.of_constr 10 | (Arguments_renaming.rename_typing (Global.env()) 11 | (EConstr.to_constr evd evalue)) in 12 | let {Environ.uj_type=x}=j in x 13 | end 14 | 15 | let simple_check2 value_with_constraints = 16 | let evalue, st = value_with_constraints in 17 | let evd = Evd.from_ctx st in 18 | (* This version should be preferred if bound variable names are not so 19 | important, you want to really verify that the input is well-typed, 20 | and if you want to obtain the type. *) 21 | (* Note that the output value is a pair containing a new evar_map: 22 | typing will fill out blanks in the term by add evar bindings. *) 23 | Typing.type_of (Global.env()) evd evalue 24 | 25 | let simple_check3 value_with_constraints = 26 | let evalue, st = value_with_constraints in 27 | let evd = Evd.from_ctx st in 28 | (* This version should be preferred if bound variable names are not so 29 | important and you already expect the input to have been type-checked 30 | before. Set ~lax to false if you want an anomaly to be raised in 31 | case of a type error. Otherwise a ReTypeError exception is raised. *) 32 | Retyping.get_type_of ~lax:true (Global.env()) evd evalue -------------------------------------------------------------------------------- /tuto1/src/simple_check.mli: -------------------------------------------------------------------------------- 1 | val simple_check1 : 2 | EConstr.constr Evd.in_evar_universe_context -> EConstr.constr 3 | 4 | val simple_check2 : 5 | EConstr.constr Evd.in_evar_universe_context -> Evd.evar_map * EConstr.constr 6 | 7 | val simple_check3 : 8 | EConstr.constr Evd.in_evar_universe_context -> EConstr.constr -------------------------------------------------------------------------------- /tuto1/src/simple_declare.ml: -------------------------------------------------------------------------------- 1 | (* Ideally coq/coq#8811 would get merged and then this function could be much simpler. *) 2 | let edeclare ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps hook = 3 | let sigma = Evd.minimize_universes sigma in 4 | let body = EConstr.to_constr sigma body in 5 | let tyopt = Option.map (EConstr.to_constr sigma) tyopt in 6 | let uvars_fold uvars c = 7 | Univ.LSet.union uvars (Vars.universes_of_constr c) in 8 | let uvars = List.fold_left uvars_fold Univ.LSet.empty 9 | (Option.List.cons tyopt [body]) in 10 | let sigma = Evd.restrict_universe_context sigma uvars in 11 | let univs = Evd.check_univ_decl ~poly sigma udecl in 12 | let ubinders = Evd.universe_binders sigma in 13 | let ce = Declare.definition_entry ?types:tyopt ~univs body in 14 | DeclareDef.declare_definition ident k ce ubinders imps ~hook 15 | 16 | let packed_declare_definition ~poly ident value_with_constraints = 17 | let body, ctx = value_with_constraints in 18 | let sigma = Evd.from_ctx ctx in 19 | let k = (Decl_kinds.Global, poly, Decl_kinds.Definition) in 20 | let udecl = UState.default_univ_decl in 21 | let nohook = Lemmas.mk_hook (fun _ x -> ()) in 22 | ignore (edeclare ident k ~opaque:false sigma udecl body None [] nohook) 23 | 24 | (* But this definition cannot be undone by Reset ident *) 25 | -------------------------------------------------------------------------------- /tuto1/src/simple_declare.mli: -------------------------------------------------------------------------------- 1 | open Names 2 | open EConstr 3 | 4 | val packed_declare_definition : 5 | poly:bool -> Id.t -> constr Evd.in_evar_universe_context -> unit 6 | -------------------------------------------------------------------------------- /tuto1/src/simple_print.ml: -------------------------------------------------------------------------------- 1 | (* A more advanced example of how to explore the structure of terms of 2 | type constr is given in the coq-dpdgraph plugin. *) 3 | 4 | let simple_body_access gref = 5 | match gref with 6 | | Globnames.VarRef _ -> 7 | failwith "variables are not covered in this example" 8 | | Globnames.IndRef _ -> 9 | failwith "inductive types are not covered in this example" 10 | | Globnames.ConstructRef _ -> 11 | failwith "constructors are not covered in this example" 12 | | Globnames.ConstRef cst -> 13 | let cb = Environ.lookup_constant cst (Global.env()) in 14 | match Global.body_of_constant_body cb with 15 | | Some(e, _) -> e 16 | | None -> failwith "This term has no value" 17 | 18 | -------------------------------------------------------------------------------- /tuto1/src/simple_print.mli: -------------------------------------------------------------------------------- 1 | val simple_body_access : Names.GlobRef.t -> Constr.constr 2 | -------------------------------------------------------------------------------- /tuto1/src/tuto1_plugin.mlpack: -------------------------------------------------------------------------------- 1 | Simple_check 2 | Simple_declare 3 | Simple_print 4 | G_tuto1 -------------------------------------------------------------------------------- /tuto1/theories/Loader.v: -------------------------------------------------------------------------------- 1 | Declare ML Module "tuto1_plugin". -------------------------------------------------------------------------------- /tuto2/Makefile: -------------------------------------------------------------------------------- 1 | ifeq "$(COQBIN)" "" 2 | COQBIN=$(dir $(shell which coqtop))/ 3 | endif 4 | 5 | %: Makefile.coq 6 | 7 | Makefile.coq: _CoqProject 8 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 9 | 10 | tests: all 11 | @$(MAKE) -C tests -s clean 12 | @$(MAKE) -C tests -s all 13 | 14 | -include Makefile.coq 15 | -------------------------------------------------------------------------------- /tuto2/_CoqProject: -------------------------------------------------------------------------------- 1 | -R theories/ Tuto 2 | -I src 3 | 4 | theories/Test.v 5 | src/demo.mlg 6 | src/demo_plugin.mlpack 7 | -------------------------------------------------------------------------------- /tuto2/src/.gitignore: -------------------------------------------------------------------------------- 1 | /demo.ml 2 | -------------------------------------------------------------------------------- /tuto2/src/demo.mlg: -------------------------------------------------------------------------------- 1 | (* -------------------------------------------------------------------------- *) 2 | (* *) 3 | (* Initial ritual dance *) 4 | (* *) 5 | (* -------------------------------------------------------------------------- *) 6 | 7 | DECLARE PLUGIN "demo_plugin" 8 | 9 | (* 10 | Use this macro before any of the other OCaml macros. 11 | 12 | Each plugin has a unique name. 13 | We have decided to name this plugin as "demo_plugin". 14 | That means that: 15 | 16 | (1) If we want to load this particular plugin to Coq toplevel, 17 | we must use the following command. 18 | 19 | Declare ML Module "demo_plugin". 20 | 21 | (2) The above command will succeed only if there is "demo_plugin.cmxs" 22 | in some of the directories that Coq is supposed to look 23 | (i.e. the ones we specified via "-I ..." command line options). 24 | 25 | (3) The file "demo_plugin.mlpack" lists the OCaml modules to be linked in 26 | "demo_plugin.cmxs". 27 | 28 | (4) The file "demo_plugin.mlpack" as well as all .ml, .mli and .mlg files 29 | are listed in the "_CoqProject" file. 30 | *) 31 | 32 | (* -------------------------------------------------------------------------- *) 33 | (* *) 34 | (* How to define a new Vernacular command? *) 35 | (* *) 36 | (* -------------------------------------------------------------------------- *) 37 | 38 | VERNAC COMMAND EXTEND Cmd1 CLASSIFIED AS QUERY 39 | | [ "Cmd1" ] -> { () } 40 | END 41 | 42 | (* 43 | These: 44 | 45 | VERNAC COMMAND EXTEND 46 | 47 | and 48 | 49 | END 50 | 51 | mark the beginning and the end of the definition of a new Vernacular command. 52 | 53 | Cmd1 is a unique identifier (which must start with an upper-case letter) 54 | associated with the new Vernacular command we are defining. 55 | 56 | CLASSIFIED AS QUERY tells Coq that the new Vernacular command: 57 | - changes neither the global environment 58 | - nor does it modify the plugin's state. 59 | 60 | If the new command could: 61 | - change the global environment 62 | - or modify a plugin's state 63 | then one would have to use CLASSIFIED AS SIDEFF instead. 64 | 65 | This: 66 | 67 | [ "Cmd1" ] -> { () } 68 | 69 | defines: 70 | - the parsing rule 71 | - the interpretation rule 72 | 73 | The parsing rule and the interpretation rule are separated by -> token. 74 | 75 | The parsing rule, in this case, is: 76 | 77 | [ "Cmd1" ] 78 | 79 | By convention, all vernacular command start with an upper-case letter. 80 | 81 | The [ and ] characters mark the beginning and the end of the parsing rule. 82 | The parsing rule itself says that the syntax of the newly defined command 83 | is composed from a single terminal Cmd1. 84 | 85 | The interpretation rule, in this case, is: 86 | 87 | { () } 88 | 89 | Similarly to the case of the parsing rule, 90 | { and } characters mark the beginning and the end of the interpretation rule. 91 | In this case, the following Ocaml expression: 92 | 93 | () 94 | 95 | defines the effect of the Vernacular command we have just defined. 96 | That is, it behaves is no-op. 97 | *) 98 | 99 | (* -------------------------------------------------------------------------- *) 100 | (* *) 101 | (* How to define a new Vernacular command with some terminal parameters? *) 102 | (* *) 103 | (* -------------------------------------------------------------------------- *) 104 | 105 | VERNAC COMMAND EXTEND Cmd2 CLASSIFIED AS QUERY 106 | | [ "Cmd2" "With" "Some" "Terminal" "Parameters" ] -> { () } 107 | END 108 | 109 | (* 110 | As shown above, the Vernacular command can be composed from 111 | any number of terminals. 112 | 113 | By convention, each of these terminals starts with an upper-case letter. 114 | *) 115 | 116 | (* -------------------------------------------------------------------------- *) 117 | (* *) 118 | (* How to define a new Vernacular command with some non-terminal parameter? *) 119 | (* *) 120 | (* -------------------------------------------------------------------------- *) 121 | 122 | { 123 | 124 | open Stdarg 125 | 126 | } 127 | 128 | VERNAC COMMAND EXTEND Cmd3 CLASSIFIED AS QUERY 129 | | [ "Cmd3" int(i) ] -> { () } 130 | END 131 | 132 | (* 133 | This: 134 | 135 | open Stdarg 136 | 137 | is needed as some identifiers in the Ocaml code generated by the 138 | 139 | VERNAC COMMAND EXTEND ... END 140 | 141 | macros are not fully qualified. 142 | 143 | This: 144 | 145 | int(i) 146 | 147 | means that the new command is expected to be followed by an integer. 148 | The integer is bound in the parsing rule to variable i. 149 | This variable i then can be used in the interpretation rule. 150 | 151 | To see value of which Ocaml types can be bound this way, 152 | look at the wit_* function declared in interp/stdarg.mli 153 | (in the Coq's codebase). 154 | 155 | If we drop the wit_ prefix, we will get the token 156 | that we can use in the parsing rule. 157 | That is, since there exists wit_int, we know that 158 | we can write: 159 | 160 | int(i) 161 | 162 | By looking at the signature of the wit_int function: 163 | 164 | val wit_int : int uniform_genarg_type 165 | 166 | we also know that variable i will have the type int. 167 | 168 | The types of wit_* functions are either: 169 | 170 | 'c uniform_genarg_type 171 | 172 | or 173 | 174 | ('a,'b,'c) genarg_type 175 | 176 | In both cases, the bound variable will have type 'c. 177 | *) 178 | 179 | (* -------------------------------------------------------------------------- *) 180 | (* *) 181 | (* How to define a new Vernacular command with variable number of arguments? *) 182 | (* *) 183 | (* -------------------------------------------------------------------------- *) 184 | 185 | VERNAC COMMAND EXTEND Cmd4 CLASSIFIED AS QUERY 186 | | [ "Cmd4" int_list(l) ] -> { () } 187 | END 188 | 189 | (* 190 | This: 191 | 192 | int_list(l) 193 | 194 | means that the new Vernacular command is expected to be followed 195 | by a (whitespace separated) list of integers. 196 | This list of integers is bound to the indicated l. 197 | 198 | In this case, as well as in the cases we point out below, instead of int 199 | in int_list we could use any other supported type, e.g. ident, bool, ... 200 | 201 | To see which other Ocaml type constructors (in addition to list) 202 | are supported, have a look at the parse_user_entry function defined 203 | in grammar/q_util.mlp file. 204 | 205 | E.g.: 206 | - ne_int_list(x) would represent a non-empty list of integers, 207 | - int_list(x) would represent a list of integers, 208 | - int_opt(x) would represent a value of type int option, 209 | - ··· 210 | *) 211 | 212 | (* -------------------------------------------------------------------------- *) 213 | (* *) 214 | (* How to define a new Vernacular command that takes values of a custom type? *) 215 | (* *) 216 | (* -------------------------------------------------------------------------- *) 217 | 218 | { 219 | 220 | open Ltac_plugin 221 | 222 | } 223 | 224 | (* 225 | If we want to avoid a compilation failure 226 | 227 | "no implementation available for Tacenv" 228 | 229 | then we have to open the Ltac_plugin module. 230 | *) 231 | 232 | (* 233 | Pp module must be opened because some of the macros that are part of the API 234 | do not expand to fully qualified names. 235 | *) 236 | 237 | { 238 | 239 | type type_5 = Foo_5 | Bar_5 240 | 241 | } 242 | 243 | (* 244 | We define a type of values that we want to pass to our Vernacular command. 245 | *) 246 | 247 | (* 248 | By default, we are able to define new Vernacular commands that can take 249 | parameters of some of the supported types. Which types are supported, 250 | that was discussed earlier. 251 | 252 | If we want to be able to define Vernacular command that takes parameters 253 | of a type that is not supported by default, we must use the following macro: 254 | *) 255 | 256 | { 257 | 258 | open Pp 259 | 260 | } 261 | 262 | VERNAC ARGUMENT EXTEND custom5 263 | | [ "Foo_5" ] -> { Foo_5 } 264 | | [ "Bar_5" ] -> { Bar_5 } 265 | END 266 | 267 | (* 268 | where: 269 | 270 | custom5 271 | 272 | indicates that, from now on, in our parsing rules we can write: 273 | 274 | custom5(some_variable) 275 | 276 | in those places where we expect user to provide an input 277 | that can be parsed by the parsing rules above 278 | (and interpreted by the interpretations rules above). 279 | *) 280 | 281 | (* Here: *) 282 | 283 | VERNAC COMMAND EXTEND Cmd5 CLASSIFIED AS QUERY 284 | | [ "Cmd5" custom5(x) ] -> { () } 285 | END 286 | 287 | (* 288 | we define a new Vernacular command whose parameters, provided by the user, 289 | can be mapped to values of type_5. 290 | *) 291 | 292 | (* -------------------------------------------------------------------------- *) 293 | (* *) 294 | (* How to give a feedback to the user? *) 295 | (* *) 296 | (* -------------------------------------------------------------------------- *) 297 | 298 | VERNAC COMMAND EXTEND Cmd6 CLASSIFIED AS QUERY 299 | | [ "Cmd6" ] -> { Feedback.msg_notice (Pp.str "Everything is awesome!") } 300 | END 301 | 302 | (* 303 | The following functions: 304 | 305 | - Feedback.msg_info : Pp.t -> unit 306 | - Feedback.msg_notice : Pp.t -> unit 307 | - Feedback.msg_warning : Pp.t -> unit 308 | - Feedback.msg_error : Pp.t -> unit 309 | - Feedback.msg_debug : Pp.t -> unit 310 | 311 | enable us to give user a textual feedback. 312 | 313 | Pp module enable us to represent and construct pretty-printing instructions. 314 | The concepts defined and the services provided by the Pp module are in 315 | various respects related to the concepts and services provided 316 | by the Format module that is part of the Ocaml standard library. 317 | *) 318 | 319 | (* -------------------------------------------------------------------------- *) 320 | (* *) 321 | (* How to implement a Vernacular command with (undoable) side-effects? *) 322 | (* *) 323 | (* -------------------------------------------------------------------------- *) 324 | 325 | { 326 | 327 | open Summary.Local 328 | 329 | } 330 | 331 | (* 332 | By opening Summary.Local module we shadow the original functions 333 | that we traditionally use for implementing stateful behavior. 334 | 335 | ref 336 | ! 337 | := 338 | 339 | are now shadowed by their counterparts in Summary.Local. *) 340 | 341 | { 342 | 343 | let counter = ref ~name:"counter" 0 344 | 345 | } 346 | 347 | VERNAC COMMAND EXTEND Cmd7 CLASSIFIED AS SIDEFF 348 | | [ "Cmd7" ] -> { counter := succ !counter; 349 | Feedback.msg_notice (Pp.str "counter = " ++ Pp.str (string_of_int (!counter))) } 350 | END 351 | 352 | TACTIC EXTEND tactic1 353 | | [ "tactic1" ] -> { Proofview.tclUNIT () } 354 | END 355 | 356 | (* ---- *) 357 | 358 | { 359 | 360 | type custom = Foo_2 | Bar_2 361 | 362 | let pr_custom _ _ _ = function 363 | | Foo_2 -> Pp.str "Foo_2" 364 | | Bar_2 -> Pp.str "Bar_2" 365 | 366 | } 367 | 368 | ARGUMENT EXTEND custom2 PRINTED BY { pr_custom } 369 | | [ "Foo_2" ] -> { Foo_2 } 370 | | [ "Bar_2" ] -> { Bar_2 } 371 | END 372 | 373 | TACTIC EXTEND tactic2 374 | | [ "tactic2" custom2(x) ] -> { Proofview.tclUNIT () } 375 | END 376 | -------------------------------------------------------------------------------- /tuto2/src/demo_plugin.mlpack: -------------------------------------------------------------------------------- 1 | Demo -------------------------------------------------------------------------------- /tuto2/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tuto2_plugin) 3 | (public_name coq.plugins.tutorial.p2) 4 | (libraries coq.plugins.ltac)) 5 | 6 | (rule 7 | (targets demo.ml) 8 | (deps (:pp-file demo.mlg) ) 9 | (action (run coqpp %{pp-file}))) 10 | -------------------------------------------------------------------------------- /tuto2/theories/Test.v: -------------------------------------------------------------------------------- 1 | Declare ML Module "demo_plugin". 2 | 3 | Cmd1. 4 | Cmd2 With Some Terminal Parameters. 5 | Cmd3 42. 6 | Cmd4 100 200 300 400. 7 | Cmd5 Foo_5. 8 | Cmd5 Bar_5. 9 | Cmd6. 10 | Cmd7. 11 | Cmd7. 12 | Cmd7. 13 | 14 | Goal True. 15 | Proof. 16 | tactic1. 17 | tactic2 Foo_2. 18 | tactic2 Bar_2. 19 | Abort. 20 | -------------------------------------------------------------------------------- /tuto3/Makefile: -------------------------------------------------------------------------------- 1 | ifeq "$(COQBIN)" "" 2 | COQBIN=$(dir $(shell which coqtop))/ 3 | endif 4 | 5 | %: Makefile.coq 6 | 7 | Makefile.coq: _CoqProject 8 | $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq 9 | 10 | tests: all 11 | @$(MAKE) -C tests -s clean 12 | @$(MAKE) -C tests -s all 13 | 14 | -include Makefile.coq 15 | -------------------------------------------------------------------------------- /tuto3/_CoqProject: -------------------------------------------------------------------------------- 1 | -R theories Tuto3 2 | -I src 3 | 4 | theories/Data.v 5 | theories/Loader.v 6 | 7 | src/tuto_tactic.ml 8 | src/tuto_tactic.mli 9 | src/construction_game.ml 10 | src/construction_game.mli 11 | src/g_tuto3.mlg 12 | src/tuto3_plugin.mlpack 13 | -------------------------------------------------------------------------------- /tuto3/src/construction_game.ml: -------------------------------------------------------------------------------- 1 | open Pp 2 | 3 | let example_sort evd = 4 | (* creating a new sort requires that universes should be recorded 5 | in the evd datastructure, so this datastructure also needs to be 6 | passed around. *) 7 | let evd, s = Evd.new_sort_variable Evd.univ_rigid evd in 8 | let new_type = EConstr.mkSort s in 9 | evd, new_type 10 | 11 | let c_one evd = 12 | (* In the general case, global references may refer to universe polymorphic 13 | objects, and their universe has to be made afresh when creating an instance. *) 14 | let gr_S = 15 | Coqlib.find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "S" in 16 | (* the long name of "S" was found with the command "About S." *) 17 | let gr_O = 18 | Coqlib.find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "O" in 19 | let evd, c_O = Evarutil.new_global evd gr_O in 20 | let evd, c_S = Evarutil.new_global evd gr_S in 21 | (* Here is the construction of a new term by applying functions to argument. *) 22 | evd, EConstr.mkApp (c_S, [| c_O |]) 23 | 24 | let dangling_identity env evd = 25 | (* I call this a dangling identity, because it is not polymorph, but 26 | the type on which it applies is left unspecified, as it is 27 | represented by an existential variable. The declaration for this 28 | existential variable needs to be added in the evd datastructure. *) 29 | let evd, type_type = example_sort evd in 30 | let evd, arg_type = Evarutil.new_evar env evd type_type in 31 | (* Notice the use of a De Bruijn index for the inner occurrence of the 32 | bound variable. *) 33 | evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, 34 | EConstr.mkRel 1) 35 | 36 | let dangling_identity2 env evd = 37 | (* This example uses directly a function that produces an evar that 38 | is meant to be a type. *) 39 | let evd, (arg_type, type_type) = 40 | Evarutil.new_type_evar env evd Evd.univ_rigid in 41 | evd, EConstr.mkLambda(Names.Name (Names.Id.of_string "x"), arg_type, 42 | EConstr.mkRel 1) 43 | 44 | let example_sort_app_lambda () = 45 | let env = Global.env () in 46 | let evd = Evd.from_env env in 47 | let evd, c_v = c_one evd in 48 | (* dangling_identity and dangling_identity2 can be used interchangeably here *) 49 | let evd, c_f = dangling_identity2 env evd in 50 | let c_1 = EConstr.mkApp (c_f, [| c_v |]) in 51 | let _ = Feedback.msg_notice 52 | (Printer.pr_econstr_env env evd c_1) in 53 | (* type verification happens here. Type verification will update 54 | existential variable information in the evd part. *) 55 | let evd, the_type = Typing.type_of env evd c_1 in 56 | (* At display time, you will notice that the system knows about the 57 | existential variable being instantiated to the "nat" type, even 58 | though c_1 still contains the meta-variable. *) 59 | Feedback.msg_notice 60 | ((Printer.pr_econstr_env env evd c_1) ++ 61 | str " has type " ++ 62 | (Printer.pr_econstr_env env evd the_type)) 63 | 64 | 65 | let c_S evd = 66 | let gr = Coqlib.find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "S" in 67 | Evarutil.new_global evd gr 68 | 69 | let c_O evd = 70 | let gr = Coqlib.find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "O" in 71 | Evarutil.new_global evd gr 72 | 73 | let c_E evd = 74 | let gr = Coqlib.find_reference "Tuto3" ["Tuto3"; "Data"] "EvenNat" in 75 | Evarutil.new_global evd gr 76 | 77 | let c_D evd = 78 | let gr = Coqlib.find_reference "Tuto3" ["Tuto3"; "Data"] "tuto_div2" in 79 | Evarutil.new_global evd gr 80 | 81 | let c_Q evd = 82 | let gr = Coqlib.find_reference "Tuto3" ["Coq"; "Init"; "Logic"] "eq" in 83 | Evarutil.new_global evd gr 84 | 85 | let c_R evd = 86 | let gr = Coqlib.find_reference "Tuto3" ["Coq"; "Init"; "Logic"] "eq_refl" in 87 | Evarutil.new_global evd gr 88 | 89 | let c_N evd = 90 | let gr = Coqlib.find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "nat" in 91 | Evarutil.new_global evd gr 92 | 93 | let c_C evd = 94 | let gr = Coqlib.find_reference "Tuto3" ["Tuto3"; "Data"] "C" in 95 | Evarutil.new_global evd gr 96 | 97 | let c_F evd = 98 | let gr = Coqlib.find_reference "Tuto3" ["Tuto3"; "Data"] "S_ev" in 99 | Evarutil.new_global evd gr 100 | 101 | let c_P evd = 102 | let gr = Coqlib.find_reference "Tuto3" ["Tuto3"; "Data"] "s_half_proof" in 103 | Evarutil.new_global evd gr 104 | 105 | (* If c_S was universe polymorphic, we should have created a new constant 106 | at each iteration of buildup. *) 107 | let mk_nat evd n = 108 | let evd, c_S = c_S evd in 109 | let evd, c_O = c_O evd in 110 | let rec buildup = function 111 | | 0 -> c_O 112 | | n -> EConstr.mkApp (c_S, [| buildup (n - 1) |]) in 113 | if n <= 0 then evd, c_O else evd, buildup n 114 | 115 | let example_classes n = 116 | let env = Global.env () in 117 | let evd = Evd.from_env env in 118 | let evd, c_n = mk_nat evd n in 119 | let evd, n_half = mk_nat evd (n / 2) in 120 | let evd, c_N = c_N evd in 121 | let evd, c_div = c_D evd in 122 | let evd, c_even = c_E evd in 123 | let evd, c_Q = c_Q evd in 124 | let evd, c_R = c_R evd in 125 | let arg_type = EConstr.mkApp (c_even, [| c_n |]) in 126 | let evd0 = evd in 127 | let evd, instance = Evarutil.new_evar env evd arg_type in 128 | let c_half = EConstr.mkApp (c_div, [|c_n; instance|]) in 129 | let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd c_half) in 130 | let evd, the_type = Typing.type_of env evd c_half in 131 | let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd c_half) in 132 | let proved_equality = 133 | EConstr.mkCast(EConstr.mkApp (c_R, [| c_N; c_half |]), Constr.DEFAULTcast, 134 | EConstr.mkApp (c_Q, [| c_N; c_half; n_half|])) in 135 | (* This is where we force the system to compute with type classes. *) 136 | (* Question to coq developers: why do we pass two evd arguments to 137 | solve_remaining_evars? Is the choice of evd0 relevant here? *) 138 | let evd = Pretyping.solve_remaining_evars 139 | (Pretyping.default_inference_flags true) env evd ~initial:evd0 in 140 | let evd, final_type = Typing.type_of env evd proved_equality in 141 | Feedback.msg_notice (Printer.pr_econstr_env env evd proved_equality) 142 | 143 | (* This function, together with definitions in Data.v, shows how to 144 | trigger automatic proofs at the time of typechecking, based on 145 | canonical structures. 146 | 147 | n is a number for which we want to find the half (and a proof that 148 | this half is indeed the half) 149 | *) 150 | let example_canonical n = 151 | let env = Global.env () in 152 | let evd = Evd.from_env env in 153 | (* Construct a natural representation of this integer. *) 154 | let evd, c_n = mk_nat evd n in 155 | (* terms for "nat", "eq", "S_ev", "eq_refl", "C" *) 156 | let evd, c_N = c_N evd in 157 | let evd, c_F = c_F evd in 158 | let evd, c_R = c_R evd in 159 | let evd, c_C = c_C evd in 160 | let evd, c_P = c_P evd in 161 | (* the last argument of C *) 162 | let refl_term = EConstr.mkApp (c_R, [|c_N; c_n |]) in 163 | (* Now we build two existential variables, for the value of the half and for 164 | the "S_ev" structure that triggers the proof search. *) 165 | let evd, ev1 = Evarutil.new_evar env evd c_N in 166 | (* This is the type for the second existential variable *) 167 | let csev = EConstr.mkApp (c_F, [| ev1 |]) in 168 | let evd, ev2 = Evarutil.new_evar env evd csev in 169 | (* Now we build the C structure. *) 170 | let test_term = EConstr.mkApp (c_C, [| c_n; ev1; ev2; refl_term |]) in 171 | (* Type-checking this term will compute values for the existential variables *) 172 | let evd, final_type = Typing.type_of env evd test_term in 173 | (* The computed type has two parameters, the second one is the proof. *) 174 | let value = match EConstr.kind evd final_type with 175 | | Constr.App(_, [| _; the_half |]) -> the_half 176 | | _ -> failwith "expecting the whole type to be \"cmp _ the_half\"" in 177 | let _ = Feedback.msg_notice (Printer.pr_econstr_env env evd value) in 178 | (* I wish for a nicer way to get the value of ev2 in the evar_map *) 179 | let prf_struct = EConstr.of_constr (EConstr.to_constr evd ev2) in 180 | let the_prf = EConstr.mkApp (c_P, [| ev1; prf_struct |]) in 181 | let evd, the_statement = Typing.type_of env evd the_prf in 182 | Feedback.msg_notice 183 | (Printer.pr_econstr_env env evd the_prf ++ str " has type " ++ 184 | Printer.pr_econstr_env env evd the_statement) 185 | -------------------------------------------------------------------------------- /tuto3/src/construction_game.mli: -------------------------------------------------------------------------------- 1 | val dangling_identity : Environ.env -> Evd.evar_map -> Evd.evar_map * EConstr.t 2 | val example_sort_app_lambda : unit -> unit 3 | val example_classes : int -> unit 4 | val example_canonical : int -> unit 5 | -------------------------------------------------------------------------------- /tuto3/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tuto3_plugin) 3 | (public_name coq.plugins.tutorial.p3) 4 | (flags :standard -warn-error -3) 5 | (libraries coq.plugins.ltac)) 6 | 7 | (rule 8 | (targets g_tuto3.ml) 9 | (deps (:pp-file g_tuto3.mlg)) 10 | (action (run coqpp %{pp-file}))) 11 | -------------------------------------------------------------------------------- /tuto3/src/g_tuto3.mlg: -------------------------------------------------------------------------------- 1 | DECLARE PLUGIN "tuto3_plugin" 2 | 3 | { 4 | 5 | open Ltac_plugin 6 | 7 | open Construction_game 8 | 9 | (* This one is necessary, to avoid message about missing wit_string *) 10 | open Stdarg 11 | 12 | } 13 | 14 | VERNAC COMMAND EXTEND ShowTypeConstruction CLASSIFIED AS QUERY 15 | | [ "Tuto3_1" ] -> 16 | { let env = Global.env () in 17 | let evd = Evd.from_env env in 18 | let evd, s = Evd.new_sort_variable Evd.univ_rigid evd in 19 | let new_type_2 = EConstr.mkSort s in 20 | let evd, _ = 21 | Typing.type_of (Global.env()) (Evd.from_env (Global.env())) new_type_2 in 22 | Feedback.msg_notice 23 | (Printer.pr_econstr_env env evd new_type_2) } 24 | END 25 | 26 | VERNAC COMMAND EXTEND ShowOneConstruction CLASSIFIED AS QUERY 27 | | [ "Tuto3_2" ] -> { example_sort_app_lambda () } 28 | END 29 | 30 | TACTIC EXTEND collapse_hyps 31 | | [ "pack" "hypothesis" ident(i) ] -> 32 | { Tuto_tactic.pack_tactic i } 33 | END 34 | 35 | (* More advanced examples, where automatic proof happens but 36 | no tactic is being called explicitely. The first one uses 37 | type classes. *) 38 | VERNAC COMMAND EXTEND TriggerClasses CLASSIFIED AS QUERY 39 | | [ "Tuto3_3" int(n) ] -> { example_classes n } 40 | END 41 | 42 | (* The second one uses canonical structures. *) 43 | VERNAC COMMAND EXTEND TriggerCanonical CLASSIFIED AS QUERY 44 | | [ "Tuto3_4" int(n) ] -> { example_canonical n } 45 | END 46 | 47 | -------------------------------------------------------------------------------- /tuto3/src/tuto3_plugin.mlpack: -------------------------------------------------------------------------------- 1 | Construction_game 2 | Tuto_tactic 3 | G_tuto3 -------------------------------------------------------------------------------- /tuto3/src/tuto_tactic.ml: -------------------------------------------------------------------------------- 1 | open Proofview 2 | 3 | let constants = ref ([] : EConstr.t list) 4 | 5 | (* This is a pattern to collect terms from the Coq memory of valid terms 6 | and proofs. This pattern extends all the way to the definition of function 7 | c_U *) 8 | let collect_constants () = 9 | if (!constants = []) then 10 | let open Coqlib in 11 | let open EConstr in 12 | let open UnivGen in 13 | let gr_H = find_reference "Tuto3" ["Tuto3"; "Data"] "pack" in 14 | let gr_M = find_reference "Tuto3" ["Tuto3"; "Data"] "packer" in 15 | let gr_R = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "pair" in 16 | let gr_P = find_reference "Tuto3" ["Coq"; "Init"; "Datatypes"] "prod" in 17 | let gr_U = find_reference "Tuto3" ["Tuto3"; "Data"] "uncover" in 18 | constants := List.map (fun x -> of_constr (constr_of_monomorphic_global x)) 19 | [gr_H; gr_M; gr_R; gr_P; gr_U]; 20 | !constants 21 | else 22 | !constants 23 | 24 | let c_H () = 25 | match collect_constants () with 26 | it :: _ -> it 27 | | _ -> failwith "could not obtain an internal representation of pack" 28 | 29 | let c_M () = 30 | match collect_constants () with 31 | _ :: it :: _ -> it 32 | | _ -> failwith "could not obtain an internal representation of pack_marker" 33 | 34 | let c_R () = 35 | match collect_constants () with 36 | _ :: _ :: it :: _ -> it 37 | | _ -> failwith "could not obtain an internal representation of pair" 38 | 39 | let c_P () = 40 | match collect_constants () with 41 | _ :: _ :: _ :: it :: _ -> it 42 | | _ -> failwith "could not obtain an internal representation of prod" 43 | 44 | let c_U () = 45 | match collect_constants () with 46 | _ :: _ :: _ :: _ :: it :: _ -> it 47 | | _ -> failwith "could not obtain an internal representation of prod" 48 | 49 | (* The following tactic is meant to pack an hypothesis when no other 50 | data is already packed. 51 | 52 | The main difficulty in defining this tactic is to understand how to 53 | construct the input expected by apply_in. *) 54 | let package i = Goal.enter begin fun gl -> 55 | Tactics.apply_in true false i 56 | [(* this means that the applied theorem is not to be cleared. *) 57 | None, (CAst.make (c_M (), 58 | (* we don't specialize the theorem with extra values. *) 59 | Tactypes.NoBindings))] 60 | (* we don't destruct the result according to any intro_pattern *) 61 | None 62 | end 63 | 64 | (* This function is meant to observe a type of shape (f a) 65 | and return the value a. *) 66 | 67 | (* Remark by Maxime: look for destApp combinator. *) 68 | let unpack_type evd term = 69 | let report () = 70 | CErrors.user_err (Pp.str "expecting a packed type") in 71 | match EConstr.kind evd term with 72 | | Constr.App (_, [| ty |]) -> ty 73 | | _ -> report () 74 | 75 | (* This function is meant to observe a type of shape 76 | A -> pack B -> C and return A, B, C 77 | but it is not used in the current version of our tactic. 78 | It is kept as an example. *) 79 | let two_lambda_pattern evd term = 80 | let report () = 81 | CErrors.user_err (Pp.str "expecting two nested implications") in 82 | (* Note that pattern-matching is always done through the EConstr.kind function, 83 | which only provides one-level deep patterns. *) 84 | match EConstr.kind evd term with 85 | (* Here we recognize the outer implication *) 86 | | Constr.Prod (_, ty1, l1) -> 87 | (* Here we recognize the inner implication *) 88 | (match EConstr.kind evd l1 with 89 | | Constr.Prod (n2, packed_ty2, deep_conclusion) -> 90 | (* Here we recognized that the second type is an application *) 91 | ty1, unpack_type evd packed_ty2, deep_conclusion 92 | | _ -> report ()) 93 | | _ -> report () 94 | 95 | (* In the environment of the goal, we can get the type of an assumption 96 | directly by a lookup. The other solution is to call a low-cost retyping 97 | function like *) 98 | let get_type_of_hyp env id = 99 | match EConstr.lookup_named id env with 100 | | Context.Named.Declaration.LocalAssum (_, ty) -> ty 101 | | _ -> CErrors.user_err (let open Pp in 102 | str (Names.Id.to_string id) ++ 103 | str " is not a plain hypothesis") 104 | 105 | let repackage i h_hyps_id = Goal.enter begin fun gl -> 106 | let env = Goal.env gl in 107 | let evd = Tacmach.New.project gl in 108 | let concl = Tacmach.New.pf_concl gl in 109 | let (ty1 : EConstr.t) = get_type_of_hyp env i in 110 | let (packed_ty2 : EConstr.t) = get_type_of_hyp env h_hyps_id in 111 | let ty2 = unpack_type evd packed_ty2 in 112 | let new_packed_type = EConstr.mkApp (c_P (), [| ty1; ty2 |]) in 113 | let open EConstr in 114 | let new_packed_value = 115 | mkApp (c_R (), [| ty1; ty2; mkVar i; 116 | mkApp (c_U (), [| ty2; mkVar h_hyps_id|]) |]) in 117 | Refine.refine ~typecheck:true begin fun evd -> 118 | let evd, new_goal = Evarutil.new_evar env evd 119 | (mkProd (Names.Name.Anonymous, 120 | mkApp(c_H (), [| new_packed_type |]), 121 | Vars.lift 1 concl)) in 122 | evd, mkApp (new_goal, 123 | [|mkApp(c_M (), [|new_packed_type; new_packed_value |]) |]) 124 | end 125 | end 126 | 127 | let pack_tactic i = 128 | let h_hyps_id = (Names.Id.of_string "packed_hyps") in 129 | Proofview.Goal.enter begin fun gl -> 130 | let hyps = Environ.named_context_val (Proofview.Goal.env gl) in 131 | if not (Termops.mem_named_context_val i hyps) then 132 | (CErrors.user_err 133 | (Pp.str ("no hypothesis named" ^ (Names.Id.to_string i)))) 134 | else 135 | if Termops.mem_named_context_val h_hyps_id hyps then 136 | tclTHEN (repackage i h_hyps_id) 137 | (tclTHEN (Tactics.clear [h_hyps_id; i]) 138 | (Tactics.introduction h_hyps_id)) 139 | else 140 | tclTHEN (package i) 141 | (tclTHEN (Tactics.rename_hyp [i, h_hyps_id]) 142 | (Tactics.move_hyp h_hyps_id Logic.MoveLast)) 143 | end 144 | -------------------------------------------------------------------------------- /tuto3/src/tuto_tactic.mli: -------------------------------------------------------------------------------- 1 | val two_lambda_pattern : 2 | Evd.evar_map -> EConstr.t -> EConstr.t * EConstr.t * EConstr.t 3 | val pack_tactic : Names.Id.t -> unit Proofview.tactic 4 | -------------------------------------------------------------------------------- /tuto3/theories/Data.v: -------------------------------------------------------------------------------- 1 | Require Import ArithRing. 2 | 3 | Inductive pack (A: Type) : Type := 4 | packer : A -> pack A. 5 | 6 | Arguments packer {A}. 7 | 8 | Definition uncover (A : Type) (packed : pack A) : A := 9 | match packed with packer v => v end. 10 | 11 | Notation "!!!" := (pack _) (at level 0, only printing). 12 | 13 | (* The following data is used as material for automatic proofs 14 | based on type classes. *) 15 | 16 | Class EvenNat the_even := {half : nat; half_prop : 2 * half = the_even}. 17 | 18 | Instance EvenNat0 : EvenNat 0 := {half := 0; half_prop := eq_refl}. 19 | 20 | Lemma even_rec n h : 2 * h = n -> 2 * S h = S (S n). 21 | Proof. intros H; ring [H]. Qed. 22 | 23 | Instance EvenNat_rec n (p : EvenNat n) : EvenNat (S (S n)) := 24 | {half := S (@half _ p); half_prop := even_rec n (@half _ p) (@half_prop _ p)}. 25 | 26 | Definition tuto_div2 n (p : EvenNat n) := @half _ p. 27 | 28 | (* to be used in the following examples 29 | Compute (@half 8 _). 30 | 31 | Check (@half_prop 8 _). 32 | 33 | Check (@half_prop 7 _). 34 | 35 | and in command Tuto3_3 8. *) 36 | 37 | (* The following data is used as material for automatic proofs 38 | based on canonical structures. *) 39 | 40 | Record S_ev n := Build_S_ev {double_of : nat; _ : 2 * n = double_of}. 41 | 42 | Definition s_half_proof n (r : S_ev n) : 2 * n = double_of n r := 43 | match r with Build_S_ev _ _ h => h end. 44 | 45 | Canonical Structure can_ev_default n d (Pd : 2 * n = d) : S_ev n := 46 | Build_S_ev n d Pd. 47 | 48 | Canonical Structure can_ev0 : S_ev 0 := 49 | Build_S_ev 0 0 (@eq_refl _ 0). 50 | 51 | Lemma can_ev_rec n : forall (s : S_ev n), S_ev (S n). 52 | Proof. 53 | intros s; exists (S (S (double_of _ s))). 54 | destruct s as [a P]. simpl. ring [P]. 55 | Defined. 56 | 57 | Canonical Structure can_ev_rec. 58 | 59 | Record cmp (n : nat) (k : nat) := 60 | C {h : S_ev k; _ : double_of k h = n}. 61 | 62 | (* To be used in, e.g., 63 | 64 | Check (C _ _ _ eq_refl : cmp 6 _). 65 | 66 | Check (C _ _ _ eq_refl : cmp 7 _). 67 | 68 | *) 69 | -------------------------------------------------------------------------------- /tuto3/theories/Loader.v: -------------------------------------------------------------------------------- 1 | From Tuto3 Require Export Data. 2 | 3 | Declare ML Module "tuto3_plugin". -------------------------------------------------------------------------------- /tuto3/theories/test.v: -------------------------------------------------------------------------------- 1 | (* to be used e.g. in : coqtop -I src -R theories Tuto3 < theories/test.v *) 2 | 3 | Require Import Tuto3.Loader. 4 | 5 | (* This should print Type. *) 6 | Tuto3_1. 7 | 8 | (* This should print a term that contains an existential variable. *) 9 | (* And then print the same term, where the variable has been correctly 10 | instantiated. *) 11 | Tuto3_2. 12 | 13 | Lemma tutu x y (A : 0 < x) (B : 10 < y) : True. 14 | Proof. 15 | pack hypothesis A. 16 | (* Hypothesis A should have disappeared and a "packed_hyps" hypothesis 17 | should have appeared, with unreadable content. *) 18 | pack hypothesis B. 19 | (* Hypothesis B should have disappeared *) 20 | destruct packed_hyps as [unpacked_hyps]. 21 | (* Hypothesis unpacked_hyps should contain the previous contents of A and B. *) 22 | exact I. 23 | Qed. 24 | --------------------------------------------------------------------------------