├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── _CoqProject ├── src ├── reify.ml4 └── template_plugin.mlpack ├── test-suite ├── Makefile ├── bug1.v ├── bug2.v ├── bug3.v ├── bug4.v ├── bug5.v ├── bug6.v ├── demo.v ├── hnf_ctor.v ├── mutind.v └── opaque.v └── theories ├── Ast.v ├── Makefile └── Template.v /.gitignore: -------------------------------------------------------------------------------- 1 | .coq_config 2 | src/myocamlbuild.ml 3 | src/*.cm* 4 | src/_build 5 | *.vo 6 | *.v.d 7 | *.glob 8 | Makefile.coq 9 | theories/*.cmxs 10 | \#*# 11 | *~ 12 | .coq-native 13 | .*.aux 14 | *.o 15 | *.ml4.d 16 | *.mlpack.d 17 | Makefile.plugin.coq -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Gregory Malecha 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | coq: Makefile.coq 2 | $(MAKE) -f Makefile.coq 3 | 4 | install: coq 5 | $(MAKE) -f Makefile.coq install 6 | 7 | clean: Makefile.coq 8 | $(MAKE) -f Makefile.coq clean 9 | rm -f Makefile.coq 10 | 11 | Makefile.coq: _CoqProject 12 | coq_makefile -f _CoqProject -o Makefile.coq 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | template-coq 2 | ============ 3 | 4 | **Template Coq development has moved:** https://github.com/Template-Coq/template-coq 5 | 6 | Template Coq is a quoting library for Coq. It takes Coq terms and constructs a representation of their syntax tree as a Coq inductive data type. 7 | The representation is based on the kernel's term representation. Reasoning about this data type can only be done informally, i.e. there is no Coq function that can take this syntax and produce its meaning. 8 | 9 | Install with OPAM 10 | ----------------- 11 | Add the Coq repository: 12 | 13 | opam repo add coq-released https://coq.inria.fr/opam/released 14 | 15 | and run: 16 | 17 | opam install coq-template-coq 18 | 19 | To get the beta versions of Coq, activate the repository: 20 | 21 | opam repo add coq-core-dev https://coq.inria.fr/opam/core-dev 22 | 23 | How to Use 24 | ---------- 25 | 26 | Check test-suite/demo.v for examples. 27 | 28 | You must add the theories directory to your Coq load path with the prefix 29 | Template. This can be done on the command line by adding: 30 | ``` 31 | coqc ... -R -as Template ... 32 | ``` 33 | or inside a running Coq session with: 34 | 35 | ``` 36 | Add LoadPath "" as Template. 37 | ``` 38 | 39 | Because paths are often not portable the later is not recommended. 40 | 41 | If you use Emacs and Proof General, you can set up a .dir-locals.el with the 42 | following code: 43 | ``` 44 | ((coq-mode . ((coq-load-path . ( 45 | (nonrec "" "Template") 46 | ))))) 47 | ``` 48 | As long as you don't check this file into a repository things should work out 49 | well. 50 | 51 | Bugs 52 | ---- 53 | 54 | Please report any bugs (or feature requests) on the github issue tracker: 55 | 56 | https://github.com/gmalecha/template-coq/issues 57 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -I src 2 | -R theories Template 3 | src/reify.ml4 4 | src/template_plugin.mlpack 5 | theories/Ast.v 6 | theories/Template.v 7 | -------------------------------------------------------------------------------- /src/reify.ml4: -------------------------------------------------------------------------------- 1 | (*i camlp4deps: "parsing/grammar.cma" i*) 2 | (*i camlp4use: "pa_extend.cmp" i*) 3 | 4 | let contrib_name = "template-coq" 5 | 6 | let pp_constr fmt x = Pp.pp_with fmt (Printer.pr_constr x) 7 | 8 | module TermReify = 9 | struct 10 | exception NotSupported of Term.constr 11 | 12 | module Cmap = Names.Cmap 13 | module Cset = Names.Cset 14 | module Mindset = Names.Mindset 15 | 16 | (* flags *) 17 | let opt_hnf_ctor_types = ref false 18 | 19 | let with_hnf_ctor_types f = 20 | opt_hnf_ctor_types := true ; 21 | try 22 | let result = f () in 23 | opt_hnf_ctor_types := false ; 24 | result 25 | with 26 | e -> let _ = opt_hnf_ctor_types := false in raise e 27 | 28 | let not_supported trm = 29 | Format.eprintf "\nNot Supported: %a\n" pp_constr trm ; 30 | flush stderr ; 31 | raise (NotSupported trm) 32 | let bad_term trm = 33 | raise (NotSupported trm) 34 | 35 | let resolve_symbol (path : string list) (tm : string) : Term.constr = 36 | let re = Coqlib.find_reference contrib_name path tm in 37 | Libnames.constr_of_global re 38 | 39 | let pkg_bignums = ["Coq";"Numbers";"BinNums"] 40 | let pkg_datatypes = ["Coq";"Init";"Datatypes"] 41 | let pkg_reify = ["Template";"Ast"] 42 | let pkg_string = ["Coq";"Strings";"String"] 43 | 44 | let r_reify = resolve_symbol pkg_reify 45 | 46 | let tString = resolve_symbol pkg_string "String" 47 | let tEmptyString = resolve_symbol pkg_string "EmptyString" 48 | let tO = resolve_symbol pkg_datatypes "O" 49 | let tS = resolve_symbol pkg_datatypes "S" 50 | let ttrue = resolve_symbol pkg_datatypes "true" 51 | let tfalse = resolve_symbol pkg_datatypes "false" 52 | let tAscii = resolve_symbol ["Coq";"Strings";"Ascii"] "Ascii" 53 | let c_nil = resolve_symbol pkg_datatypes "nil" 54 | let c_cons = resolve_symbol pkg_datatypes "cons" 55 | let prod_type = resolve_symbol pkg_datatypes "prod" 56 | let prod a b = 57 | Term.mkApp (prod_type, [| a ; b |]) 58 | let c_pair = resolve_symbol pkg_datatypes "pair" 59 | let pair a b f s = 60 | Term.mkApp (c_pair, [| a ; b ; f ; s |]) 61 | 62 | let nAnon = r_reify "nAnon" 63 | let nNamed = r_reify "nNamed" 64 | let kVmCast = r_reify "VmCast" 65 | let kNative = r_reify "NativeCast" 66 | let kCast = r_reify "Cast" 67 | let kRevertCast = r_reify "RevertCast" 68 | let sProp = r_reify "sProp" 69 | let sSet = r_reify "sSet" 70 | let sType = r_reify "sType" 71 | let tident = r_reify "ident" 72 | let tmkInd = r_reify "mkInd" 73 | let [tTerm;tRel;tVar;tMeta;tEvar;tSort;tCast;tProd;tLambda;tLetIn;tApp;tCase;tFix;tConstructor;tConst;tInd;tUnknown] 74 | = List.map r_reify ["term";"tRel";"tVar";"tMeta";"tEvar";"tSort";"tCast";"tProd";"tLambda";"tLetIn";"tApp";"tCase";"tFix";"tConstruct";"tConst";"tInd";"tUnknown"] 75 | let [tdef;tmkdef] = List.map r_reify ["def";"mkdef"] 76 | let [pConstr;pType;pAxiom;pIn] 77 | = List.map r_reify ["PConstr";"PType";"PAxiom";"PIn"] 78 | let tinductive_body = r_reify "inductive_body" 79 | let tmkinductive_body = r_reify "mkinductive_body" 80 | 81 | let to_positive = 82 | let xH = resolve_symbol pkg_bignums "xH" in 83 | let xO = resolve_symbol pkg_bignums "xO" in 84 | let xI = resolve_symbol pkg_bignums "xI" in 85 | let rec to_positive n = 86 | if n = 1 then 87 | xH 88 | else 89 | if n mod 2 = 0 then 90 | Term.mkApp (xO, [| to_positive (n / 2) |]) 91 | else 92 | Term.mkApp (xI, [| to_positive (n / 2) |]) 93 | in 94 | fun n -> 95 | if n <= 0 96 | then raise (Invalid_argument ("to_positive: " ^ string_of_int n)) 97 | else to_positive n 98 | 99 | let to_coq_list typ = 100 | let the_nil = Term.mkApp (c_nil, [| typ |]) in 101 | let rec to_list (ls : Term.constr list) : Term.constr = 102 | match ls with 103 | [] -> the_nil 104 | | l :: ls -> 105 | Term.mkApp (c_cons, [| typ ; l ; to_list ls |]) 106 | in to_list 107 | 108 | let int_to_nat = 109 | let cache = Hashtbl.create 10 in 110 | let rec recurse i = 111 | try Hashtbl.find cache i 112 | with 113 | Not_found -> 114 | if i = 0 then 115 | let result = tO in 116 | let _ = Hashtbl.add cache i result in 117 | result 118 | else 119 | let result = Term.mkApp (tS, [| recurse (i - 1) |]) in 120 | let _ = Hashtbl.add cache i result in 121 | result 122 | in 123 | fun i -> 124 | assert (i >= 0) ; 125 | recurse i 126 | 127 | let quote_bool b = 128 | if b then ttrue else tfalse 129 | 130 | let quote_char c = 131 | let i = int_of_char c in 132 | Term.mkApp (tAscii, Array.of_list (List.map (fun m -> quote_bool ((i land m) = m)) 133 | (List.rev [128;64;32;16;8;4;2;1]))) 134 | 135 | let quote_string s = 136 | let rec go from acc = 137 | if from < 0 then acc 138 | else 139 | go (from - 1) (Term.mkApp (tString, [| quote_char (String.get s from) ; acc |])) 140 | in 141 | go (String.length s - 1) tEmptyString 142 | 143 | let quote_ident i = 144 | let s = Names.string_of_id i in 145 | quote_string s 146 | 147 | let quote_name n = 148 | match n with 149 | Names.Name id -> Term.mkApp (nNamed, [| quote_ident id |]) 150 | | Names.Anonymous -> nAnon 151 | 152 | let quote_cast_kind k = 153 | match k with 154 | Term.VMcast -> kVmCast 155 | | Term.DEFAULTcast -> kCast 156 | | Term.REVERTcast -> kRevertCast 157 | 158 | let quote_universe s = 159 | (** TODO: This doesn't work yet **) 160 | to_positive 1 161 | 162 | let quote_sort s = 163 | match s with 164 | Term.Prop _ -> 165 | if s = Term.prop_sort then sProp 166 | else 167 | let _ = assert (s = Term.set_sort) in 168 | sSet 169 | | Term.Type u -> Term.mkApp (sType, [| quote_universe u |]) 170 | 171 | let quote_inductive env (t : Names.inductive) = 172 | let (m,i) = t in 173 | Term.mkApp (tmkInd, [| quote_string (Names.string_of_kn (Names.canonical_mind m)) 174 | ; int_to_nat i |]) 175 | 176 | let mk_ctor_list = 177 | let ctor_list = 178 | let ctor_info_typ = prod tident tTerm in 179 | to_coq_list ctor_info_typ 180 | in 181 | fun ls -> 182 | let ctors = List.map (fun (a,b) -> pair tident tTerm a b) ls in 183 | Term.mkApp (tmkinductive_body, [| ctor_list ctors |]) 184 | 185 | let rec pair_with_number st ls = 186 | match ls with 187 | [] -> [] 188 | | l :: ls -> (st,l) :: pair_with_number (st + 1) ls 189 | 190 | let hnf_type env ty = 191 | let rec hnf_type continue ty = 192 | match Term.kind_of_term ty with 193 | Term.Prod (n,t,b) -> Term.mkProd (n,t,hnf_type true b) 194 | | Term.LetIn _ 195 | | Term.Cast _ 196 | | Term.App _ when continue -> 197 | hnf_type false (Reduction.whd_betadeltaiota env ty) 198 | | _ -> ty 199 | in 200 | hnf_type true ty 201 | 202 | let quote_term_remember 203 | (add_constant : Names.constant -> 'a -> 'a) 204 | (add_inductive : Names.inductive -> 'a -> 'a) = 205 | let rec quote_term (acc : 'a) env trm = 206 | match Term.kind_of_term trm with 207 | Term.Rel i -> (Term.mkApp (tRel, [| int_to_nat (i - 1) |]), acc) 208 | | Term.Var v -> (Term.mkApp (tVar, [| quote_ident v |]), acc) 209 | | Term.Sort s -> (Term.mkApp (tSort, [| quote_sort s |]), acc) 210 | | Term.Cast (c,k,t) -> 211 | let (c',acc) = quote_term acc env c in 212 | let (t',acc) = quote_term acc env t in 213 | (Term.mkApp (tCast, [| c' ; quote_cast_kind k ; t' |]), acc) 214 | | Term.Prod (n,t,b) -> 215 | let (t',acc) = quote_term acc env t in 216 | let (b',acc) = quote_term acc env b in 217 | (Term.mkApp (tProd, [| quote_name n ; t' ; b' |]), acc) 218 | | Term.Lambda (n,t,b) -> 219 | let (t',acc) = quote_term acc env t in 220 | let (b',acc) = quote_term acc env b in 221 | (Term.mkApp (tLambda, [| quote_name n ; t' ; b' |]), acc) 222 | | Term.LetIn (n,t,e,b) -> 223 | let (t',acc) = quote_term acc env t in 224 | let (e',acc) = quote_term acc env e in 225 | let (b',acc) = quote_term acc env b in 226 | (Term.mkApp (tLetIn, [| quote_name n ; t' ; e' ; b' |]), acc) 227 | | Term.App (f,xs) -> 228 | let (f',acc) = quote_term acc env f in 229 | let (xs',acc) = 230 | List.fold_left (fun (xs,acc) x -> 231 | let (x,acc) = quote_term acc env x in (x :: xs, acc)) 232 | ([],acc) (Array.to_list xs) in 233 | (Term.mkApp (tApp, [| f' ; to_coq_list tTerm (List.rev xs') |]), acc) 234 | | Term.Const c -> 235 | (Term.mkApp (tConst, [| quote_string (Names.string_of_con c) |]), add_constant c acc) 236 | | Term.Construct (ind,c) -> 237 | (Term.mkApp (tConstructor, [| quote_inductive env ind ; int_to_nat (c - 1) |]), add_inductive ind acc) 238 | | Term.Ind i -> (Term.mkApp (tInd, [| quote_inductive env i |]), add_inductive i acc) 239 | | Term.Case (ci,a,b,e) -> 240 | let npar = int_to_nat ci.ci_npar in 241 | let (a',acc) = quote_term acc env a in 242 | let (b',acc) = quote_term acc env b in 243 | let (branches,acc) = 244 | List.fold_left (fun (xs,acc) x -> 245 | let (x,acc) = quote_term acc env x in (x :: xs, acc)) 246 | ([],acc) (Array.to_list e) in 247 | (Term.mkApp (tCase, [| npar ; a' ; b' ; to_coq_list tTerm (List.rev branches) |]), acc) 248 | | Term.Fix fp -> 249 | let (t,n,acc) = quote_fixpoint acc env fp in 250 | (Term.mkApp (tFix, [| t ; int_to_nat n |]), acc) 251 | | _ -> (Term.mkApp (tUnknown, [| quote_string (Format.asprintf "%a" pp_constr trm) |]), acc) 252 | and quote_fixpoint acc env t = 253 | let ((a,b),(ns,ts,ds)) = t in 254 | let rec seq f t = 255 | if f < t then 256 | f :: seq (f + 1) t 257 | else 258 | [] 259 | in 260 | let mk_fun (xs,acc) i = 261 | let n = int_to_nat (Array.get a i) in 262 | let nm = quote_name (Array.get ns i) in 263 | let (ty,acc) = quote_term acc env (Array.get ts i) in 264 | let (ds,acc) = quote_term acc env (Array.get ds i) in 265 | (Term.mkApp (tmkdef, [| tTerm ; nm ; ty ; ds ; n |]) :: xs, acc) 266 | in 267 | let (defs,acc) = List.fold_left mk_fun ([],acc) (seq 0 (Array.length a)) in 268 | (to_coq_list (Term.mkApp (tdef, [| tTerm |])) (List.rev defs), b, acc) 269 | and quote_minductive_type (acc : 'a) env (t : Names.mutual_inductive) = 270 | let mib = Environ.lookup_mind t env in 271 | let (ls,acc) = 272 | List.fold_left (fun (ls,acc) (n,oib) -> 273 | let named_ctors = 274 | List.combine 275 | Declarations.(Array.to_list oib.mind_consnames) 276 | Declarations.(Array.to_list oib.mind_user_lc) 277 | in 278 | let (reified_ctors,acc) = 279 | List.fold_left (fun (ls,acc) (nm,ty) -> 280 | Printf.eprintf "XXXX %b\n" !opt_hnf_ctor_types ; 281 | let ty = if !opt_hnf_ctor_types then hnf_type env ty else ty in 282 | let (ty,acc) = quote_term acc env ty in 283 | ((quote_ident nm, ty) :: ls, acc)) 284 | ([],acc) named_ctors 285 | in 286 | Declarations.((quote_ident oib.mind_typename, 287 | mk_ctor_list (List.rev reified_ctors)) :: ls, acc)) 288 | ([],acc) Declarations.(pair_with_number 0 289 | (Array.to_list mib.mind_packets)) 290 | in 291 | (to_coq_list (prod tident tinductive_body) 292 | (List.map (fun (a,b) -> 293 | pair tident tinductive_body a b) (List.rev ls)), 294 | acc) 295 | in (quote_term, quote_minductive_type) 296 | 297 | let quote_term env trm = 298 | let (fn,_) = quote_term_remember (fun _ () -> ()) (fun _ () -> ()) in 299 | fst (fn () env trm) 300 | 301 | type defType = 302 | Ind of Names.inductive 303 | | Const of Names.constant 304 | 305 | let quote_term_rec env trm = 306 | let visited_terms = ref Cset.empty in 307 | let visited_types = ref Mindset.empty in 308 | let constants = ref [] in 309 | let add quote_term quote_type trm acc = 310 | match trm with 311 | | Ind (mi,idx) -> 312 | let t = mi in 313 | if Mindset.mem t !visited_types then () 314 | else 315 | begin 316 | let (result,acc) = quote_type acc env mi in 317 | let ref_name = 318 | quote_string (Names.string_of_kn (Names.canonical_mind mi)) in 319 | visited_types := Mindset.add t !visited_types ; 320 | constants := Term.mkApp (pType, [| ref_name 321 | ; result |]) :: !constants 322 | end 323 | | Const c -> 324 | if Cset.mem c !visited_terms then () 325 | else 326 | begin 327 | visited_terms := Cset.add c !visited_terms ; 328 | let cd = Environ.lookup_constant c env in 329 | let do_body body = 330 | let (result,acc) = 331 | quote_term acc Environ.empty_env body 332 | in 333 | constants := Term.mkApp (pConstr, 334 | [| quote_string (Names.string_of_con c) 335 | ; result |]) :: !constants 336 | in 337 | Declarations.( 338 | match cd.const_body with 339 | Undef i -> 340 | constants := Term.mkApp (pAxiom, 341 | [| quote_string (Names.string_of_con c) |]) :: !constants 342 | | Def cs -> 343 | do_body (force cs) 344 | | OpaqueDef lc -> 345 | do_body (force_opaque lc)) 346 | end 347 | in 348 | let (quote_rem,quote_typ) = 349 | let a = ref (fun _ _ _ -> assert false) in 350 | let b = ref (fun _ _ _ -> assert false) in 351 | let (x,y) = 352 | quote_term_remember (fun x () -> add !a !b (Const x) ()) 353 | (fun y () -> add !a !b (Ind y) ()) 354 | in 355 | a := x ; 356 | b := y ; 357 | (x,y) 358 | in 359 | let (x,acc) = quote_rem () env trm 360 | in List.fold_left (fun acc x -> Term.mkApp (x, [| acc |])) 361 | (Term.mkApp (pIn, [| x |])) !constants 362 | 363 | let rec app_full trm acc = 364 | match Term.kind_of_term trm with 365 | Term.App (f, xs) -> app_full f (Array.to_list xs @ acc) 366 | | _ -> (trm, acc) 367 | 368 | let rec nat_to_int trm = 369 | let (h,args) = app_full trm [] in 370 | if Term.eq_constr h tO then 371 | 0 372 | else if Term.eq_constr h tS then 373 | match args with 374 | n :: _ -> 1 + nat_to_int n 375 | | _ -> not_supported trm 376 | else 377 | not_supported trm 378 | 379 | let from_bool trm = 380 | if Term.eq_constr trm ttrue then 381 | true 382 | else if Term.eq_constr trm tfalse then 383 | false 384 | else not_supported trm 385 | 386 | let unquote_char trm = 387 | let (h,args) = app_full trm [] in 388 | if Term.eq_constr h tAscii then 389 | match args with 390 | a :: b :: c :: d :: e :: f :: g :: h :: _ -> 391 | let bits = List.rev [a;b;c;d;e;f;g;h] in 392 | let v = List.fold_left (fun a n -> (a lsl 1) lor if from_bool n then 1 else 0) 0 bits in 393 | char_of_int v 394 | | _ -> assert false 395 | else 396 | not_supported trm 397 | 398 | let unquote_string trm = 399 | let rec go n trm = 400 | let (h,args) = app_full trm [] in 401 | if Term.eq_constr h tEmptyString then 402 | String.create n 403 | else if Term.eq_constr h tString then 404 | match args with 405 | c :: s :: _ -> 406 | let res = go (n + 1) s in 407 | let _ = String.set res n (unquote_char c) in 408 | res 409 | | _ -> bad_term trm 410 | else 411 | not_supported trm 412 | in 413 | go 0 trm 414 | 415 | let unquote_ident trm = 416 | Names.id_of_string (unquote_string trm) 417 | 418 | let unquote_cast_kind trm = 419 | if Term.eq_constr trm kVmCast then 420 | Term.VMcast 421 | else if Term.eq_constr trm kCast then 422 | Term.DEFAULTcast 423 | else if Term.eq_constr trm kRevertCast then 424 | Term.REVERTcast 425 | else if Term.eq_constr trm kNative then 426 | Term.VMcast 427 | else 428 | bad_term trm 429 | 430 | 431 | let unquote_name trm = 432 | let (h,args) = app_full trm [] in 433 | if Term.eq_constr h nAnon then 434 | Names.Anonymous 435 | else if Term.eq_constr h nNamed then 436 | match args with 437 | n :: _ -> Names.Name (unquote_ident n) 438 | | _ -> raise (Failure "ill-typed, expected name") 439 | else 440 | raise (Failure "non-value") 441 | 442 | let unquote_sort trm = 443 | let (h,args) = app_full trm [] in 444 | if Term.eq_constr h sType then 445 | raise (NotSupported h) 446 | else if Term.eq_constr h sProp then 447 | Term.Prop Term.Pos 448 | else if Term.eq_constr h sSet then 449 | Term.Prop Term.Null 450 | else 451 | raise (Failure "ill-typed, expected sort") 452 | 453 | let kn_of_canonical_string s = 454 | let ss = List.rev (Str.split (Str.regexp (Str.quote ".")) s) in 455 | match ss with 456 | nm :: rst -> 457 | let rec to_mp ls = Names.MPfile (Names.make_dirpath (List.map Names.id_of_string ls)) in 458 | let mp = to_mp rst in 459 | Names.make_kn mp Names.empty_dirpath (Names.mk_label nm) 460 | | _ -> assert false 461 | 462 | let denote_inductive trm = 463 | let (h,args) = app_full trm [] in 464 | if Term.eq_constr h tmkInd then 465 | match args with 466 | nm :: num :: _ -> 467 | let n = unquote_string nm in 468 | let kn = kn_of_canonical_string n in 469 | let mi = Names.mind_of_kn kn in 470 | let i = nat_to_int num in 471 | (mi, i) 472 | | _ -> assert false 473 | else 474 | raise (Failure "non-constructor") 475 | 476 | let rec from_coq_list trm = 477 | let (h,args) = app_full trm [] in 478 | if Term.eq_constr h c_nil then [] 479 | else if Term.eq_constr h c_cons then 480 | match args with 481 | _ :: x :: xs :: _ -> x :: from_coq_list xs 482 | | _ -> bad_term trm 483 | else 484 | not_supported trm 485 | 486 | 487 | (** NOTE: Because the representation is lossy, I should probably 488 | ** come back through elaboration. 489 | ** - This would also allow me to write terms with holes 490 | **) 491 | let rec denote_term trm = 492 | Format.eprintf "%a\n" pp_constr trm ; 493 | let (h,args) = app_full trm [] in 494 | if Term.eq_constr h tRel then 495 | match args with 496 | x :: _ -> 497 | Format.eprintf "Rel\n" ; 498 | Term.mkRel (nat_to_int x + 1) 499 | | _ -> raise (Failure "ill-typed") 500 | else if Term.eq_constr h tVar then 501 | match args with 502 | x :: _ -> Format.eprintf "var\n"; Term.mkVar (unquote_ident x) 503 | | _ -> raise (Failure "ill-typed") 504 | else if Term.eq_constr h tSort then 505 | match args with 506 | x :: _ -> Term.mkSort (unquote_sort x) 507 | | _ -> raise (Failure "ill-typed") 508 | else if Term.eq_constr h tCast then 509 | match args with 510 | t :: c :: ty :: _ -> 511 | Term.mkCast (denote_term t, unquote_cast_kind c, denote_term ty) 512 | | _ -> raise (Failure "ill-typed") 513 | else if Term.eq_constr h tProd then 514 | match args with 515 | n :: t :: b :: _ -> 516 | Term.mkProd (unquote_name n, denote_term t, denote_term b) 517 | | _ -> raise (Failure "ill-typed (product)") 518 | else if Term.eq_constr h tLambda then 519 | match args with 520 | n :: t :: b :: _ -> 521 | Format.eprintf "lambda\n"; 522 | Term.mkLambda (unquote_name n, denote_term t, denote_term b) 523 | | _ -> raise (Failure "ill-typed (lambda)") 524 | else if Term.eq_constr h tLetIn then 525 | match args with 526 | n :: t :: e :: b :: _ -> 527 | Term.mkLetIn (unquote_name n, denote_term t, denote_term e, denote_term b) 528 | | _ -> raise (Failure "ill-typed (let-in)") 529 | else if Term.eq_constr h tApp then 530 | match args with 531 | f :: xs :: _ -> 532 | Term.mkApp (denote_term f, 533 | Array.of_list (List.map denote_term (from_coq_list xs))) 534 | | _ -> raise (Failure "ill-typed (app)") 535 | else if Term.eq_constr h tConstructor then 536 | match args with 537 | i :: idx :: _ -> 538 | let i = denote_inductive i in 539 | Term.mkConstruct (i, nat_to_int idx + 1) 540 | | _ -> raise (Failure "ill-typed (constructor)") 541 | else if Term.eq_constr h tInd then 542 | match args with 543 | i :: _ -> 544 | let i = denote_inductive i in 545 | Term.mkInd i 546 | | _ -> raise (Failure "ill-typed (inductive)") 547 | else if Term.eq_constr h tCase then 548 | match args with 549 | ty :: d :: brs :: _ -> 550 | Term.mkCase (assert false (** I don't have any information to put here **) 551 | , denote_term ty, denote_term d , 552 | Array.of_list (List.map denote_term (from_coq_list brs))) 553 | | _ -> raise (Failure "ill-typed (case)") 554 | else 555 | not_supported trm 556 | 557 | end 558 | 559 | let _= Mltop.add_known_module "templateCoq" 560 | 561 | (** Stolen from CoqPluginUtils **) 562 | (** Calling Ltac **) 563 | let ltac_call tac (args:Tacexpr.glob_tactic_arg list) = 564 | Tacexpr.TacArg(Util.dummy_loc,Tacexpr.TacCall(Util.dummy_loc, Glob_term.ArgArg(Util.dummy_loc, Lazy.force tac),args)) 565 | 566 | (* Calling a locally bound tactic *) 567 | let ltac_lcall tac args = 568 | Tacexpr.TacArg(Util.dummy_loc,Tacexpr.TacCall(Util.dummy_loc, Glob_term.ArgVar(Util.dummy_loc, Names.id_of_string tac),args)) 569 | 570 | let ltac_letin (x, e1) e2 = 571 | Tacexpr.TacLetIn(false,[(Util.dummy_loc,Names.id_of_string x),e1],e2) 572 | 573 | let ltac_apply (f:Tacexpr.glob_tactic_expr) (args:Tacexpr.glob_tactic_arg list) = 574 | Tacinterp.eval_tactic 575 | (ltac_letin ("F", Tacexpr.Tacexp f) (ltac_lcall "F" args)) 576 | 577 | let to_ltac_val c = Tacexpr.TacDynamic(Util.dummy_loc,Pretyping.constr_in c) 578 | 579 | (** From Containers **) 580 | let declare_definition 581 | id (loc, boxed_flag, def_obj_kind) 582 | binder_list red_expr_opt constr_expr 583 | constr_expr_opt decl_hook = 584 | let (def_entry, man_impl) = 585 | Command.interp_definition binder_list red_expr_opt constr_expr 586 | constr_expr_opt 587 | in 588 | Command.declare_definition 589 | id (loc, def_obj_kind) def_entry man_impl decl_hook 590 | 591 | let check_inside_section () = 592 | if Lib.sections_are_opened () then 593 | (** In trunk this seems to be moved to Errors **) 594 | Util.errorlabstrm "Quote" (Pp.str "You can not quote within a section.") 595 | else () 596 | 597 | 598 | 599 | TACTIC EXTEND get_goal 600 | | [ "quote_term" constr(c) tactic(tac) ] -> 601 | [ (** quote the given term, pass the result to t **) 602 | fun gl -> 603 | let env = Tacmach.pf_env gl in 604 | let c = TermReify.quote_term env c in 605 | ltac_apply tac (List.map to_ltac_val [c]) gl ] 606 | (* 607 | | [ "quote_goal" ] -> 608 | [ (** get the representation of the goal **) 609 | fun gl -> assert false ] 610 | | [ "get_inductive" constr(i) ] -> 611 | [ fun gl -> assert false ] 612 | *) 613 | END;; 614 | 615 | VERNAC COMMAND EXTEND Make_vernac 616 | | [ "Quote" "Definition" ident(name) ":=" constr(def) ] -> 617 | [ check_inside_section () ; 618 | let (evm,env) = Lemmas.get_current_context () in 619 | let def = Constrintern.interp_constr evm env def in 620 | let trm = TermReify.quote_term env def in 621 | let result = Constrextern.extern_constr true env trm in 622 | declare_definition name 623 | (Decl_kinds.Global, false, Decl_kinds.Definition) 624 | [] None result None (fun _ _ -> ()) ] 625 | | [ "Quote" "Definition" ident(name) ":=" "Eval" red_expr(rd) "in" constr(def) ] -> 626 | [ check_inside_section () ; 627 | let (evm,env) = Lemmas.get_current_context () in 628 | let def = Constrintern.interp_constr evm env def in 629 | let (evm2,red) = Tacinterp.interp_redexp env evm rd in 630 | let red = fst (Redexpr.reduction_of_red_expr red) in 631 | let def = red env evm2 def in 632 | let trm = TermReify.quote_term env def in 633 | let result = Constrextern.extern_constr true env trm in 634 | declare_definition name 635 | (Decl_kinds.Global, false, Decl_kinds.Definition) 636 | [] None result None (fun _ _ -> ()) ] 637 | END;; 638 | 639 | VERNAC COMMAND EXTEND Make_recursive 640 | | [ "Quote" "Recursively" "Definition" ident(name) ":=" constr(def) ] -> 641 | [ check_inside_section () ; 642 | let (evm,env) = Lemmas.get_current_context () in 643 | let def = Constrintern.interp_constr evm env def in 644 | let trm = TermReify.quote_term_rec env def in 645 | let result = Constrextern.extern_constr true env trm in 646 | declare_definition name 647 | (Decl_kinds.Global, false, Decl_kinds.Definition) 648 | [] None result None (fun _ _ -> ()) ] 649 | END;; 650 | 651 | VERNAC COMMAND EXTEND Make_recursive_hnf 652 | | [ "Quote" "Recursively" "[" "hnf" "ind" "typ" "]" "Definition" ident(name) ":=" constr(def) ] -> 653 | [ check_inside_section () ; 654 | let (evm,env) = Lemmas.get_current_context () in 655 | let def = Constrintern.interp_constr evm env def in 656 | let trm = TermReify.with_hnf_ctor_types (fun () -> TermReify.quote_term_rec env def) in 657 | let result = Constrextern.extern_constr true env trm in 658 | declare_definition name 659 | (Decl_kinds.Global, false, Decl_kinds.Definition) 660 | [] None result None (fun _ _ -> ()) ] 661 | END;; 662 | 663 | 664 | VERNAC COMMAND EXTEND Unquote_vernac 665 | | [ "Make" "Definition" ident(name) ":=" constr(def) ] -> 666 | [ check_inside_section () ; 667 | let (evm,env) = Lemmas.get_current_context () in 668 | let def = Constrintern.interp_constr evm env def in 669 | let trm = TermReify.denote_term def in 670 | let result = Constrextern.extern_constr true env trm in 671 | declare_definition name 672 | (Decl_kinds.Global, false, Decl_kinds.Definition) 673 | [] None result None (fun _ _ -> ()) ] 674 | END;; 675 | 676 | VERNAC COMMAND EXTEND Make_tests 677 | (* 678 | | [ "Make" "Definitions" tactic(t) ] -> 679 | [ (** [t] returns a [list (string * term)] **) 680 | assert false ] 681 | *) 682 | | [ "Test" "Quote" constr(c) ] -> 683 | [ check_inside_section () ; 684 | let (evm,env) = Lemmas.get_current_context () in 685 | let c = Constrintern.interp_constr evm env c in 686 | let result = TermReify.quote_term env c in 687 | (* DEBUGGING 688 | let back = TermReify.denote_term result in 689 | Format.eprintf "%a\n" pp_constr result ; 690 | Format.eprintf "%a\n" pp_constr back ; 691 | assert (Term.eq_constr c back) ; 692 | *) 693 | Pp.msgnl (Printer.pr_constr result) ; 694 | () ] 695 | END;; 696 | -------------------------------------------------------------------------------- /src/template_plugin.mlpack: -------------------------------------------------------------------------------- 1 | Reify -------------------------------------------------------------------------------- /test-suite/Makefile: -------------------------------------------------------------------------------- 1 | TESTS:=demo bug1 bug2 bug3 opaque 2 | ARGS:=-I ../src -R ../theories Template 3 | 4 | all: Makefile.coq 5 | $(MAKE) -f Makefile.coq 6 | 7 | Makefile.coq: Makefile 8 | coq_makefile -o Makefile.coq $(ARGS) $(TESTS:%=%.v) 9 | -------------------------------------------------------------------------------- /test-suite/bug1.v: -------------------------------------------------------------------------------- 1 | (** Reported by Randy Pollack **) 2 | 3 | Require Import Template.Template. 4 | Require Import List. 5 | Fixpoint fibrec (n:nat) (fs:list nat) {struct n} : nat := 6 | match n with 7 | | 0 => hd 0 fs 8 | | (S n) => fibrec n (cons ((hd 0 fs) + (hd 0 (tl fs))) fs) 9 | end. 10 | Definition fib n := fibrec n (cons 0 (cons 1 nil)). 11 | Quote Definition qfib := fib. (** works **) 12 | Quote Recursively Definition qfib_syntax := fib. 13 | -------------------------------------------------------------------------------- /test-suite/bug2.v: -------------------------------------------------------------------------------- 1 | Require Import Template.Template. 2 | 3 | Definition I (t:Type) (x:t) : t := x. 4 | Definition II := I (forall t:Type, t -> t) I. 5 | Quote Recursively Definition qII := II. 6 | Print qII. -------------------------------------------------------------------------------- /test-suite/bug3.v: -------------------------------------------------------------------------------- 1 | (** Reported by Randy Pollack **) 2 | Require Import Template.Template. 3 | 4 | Section foo. 5 | Variable x : nat. 6 | 7 | Fail Quote Definition this_should_fail := x. 8 | Fail Quote Recursively Definition this_should_fail := x. 9 | End foo. -------------------------------------------------------------------------------- /test-suite/bug4.v: -------------------------------------------------------------------------------- 1 | (** Reported by Randy Pollack **) 2 | Require Import Template.Template. 3 | 4 | Definition I (t:Type) (x:t) : t := x. 5 | Definition II := I (forall t:Type, t -> t) I. 6 | Quote Recursively Definition qII := II. 7 | Print qII. 8 | 9 | Section foo. 10 | Variable x : nat. 11 | 12 | Fail Quote Definition this_should_fail := x. 13 | Fail Quote Recursively Definition this_should_fail := x. 14 | End foo. -------------------------------------------------------------------------------- /test-suite/bug5.v: -------------------------------------------------------------------------------- 1 | Require Import Template.Template. 2 | 3 | Quote Recursively Definition aterm := Ast.term. 4 | Time Quote Recursively Definition aterm' := aterm. 5 | -------------------------------------------------------------------------------- /test-suite/bug6.v: -------------------------------------------------------------------------------- 1 | (** Reported by Randy Pollack **) 2 | Require Import Template.Template. 3 | 4 | Definition I (t:Type) (x:t) : t := x. 5 | Definition II := I (forall t:Type, t -> t) I. 6 | Quote Definition qII := Eval compute in II. -------------------------------------------------------------------------------- /test-suite/demo.v: -------------------------------------------------------------------------------- 1 | Require Import Template.Template. 2 | 3 | Local Open Scope string_scope. 4 | 5 | (** This is just printing **) 6 | Test Quote (fun x : nat => x). 7 | 8 | Test Quote (fun (f : nat -> nat) (x : nat) => f x). 9 | 10 | Test Quote (let x := 2 in x). 11 | 12 | Test Quote (let x := 2 in 13 | match x with 14 | | 0 => 0 15 | | S n => n 16 | end). 17 | 18 | (** Build a definition **) 19 | Definition d : Ast.term. 20 | let t := constr:(fun x : nat => x) in 21 | let k x := refine x in 22 | quote_term t k. 23 | Defined. 24 | 25 | (** Another way **) 26 | Quote Definition d' := (fun x : nat => x). 27 | 28 | (** To quote existing definitions **) 29 | Definition id_nat : nat -> nat := fun x => x. 30 | 31 | Quote Definition d'' := Eval compute in id_nat. 32 | 33 | (** Fixpoints **) 34 | Fixpoint add (a b : nat) : nat := 35 | match a with 36 | | 0 => b 37 | | S a => S (add a b) 38 | end. 39 | 40 | Fixpoint add' (a b : nat) : nat := 41 | match b with 42 | | 0 => a 43 | | S b => S (add' a b) 44 | end. 45 | 46 | Quote Definition add_syntax := Eval compute in add. 47 | 48 | Quote Definition add'_syntax := Eval compute in add'. 49 | 50 | (** Reflecting definitions **) 51 | 52 | Make Definition zero_from_syntax := (Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.nat" 0) 0). 53 | 54 | Make Definition two_from_syntax := (Ast.tApp (Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.nat" 0) 1) 55 | (Ast.tApp (Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.nat" 0) 1) 56 | (Ast.tConstruct (Ast.mkInd "Coq.Init.Datatypes.nat" 0) 0 :: nil) :: nil)). 57 | 58 | Quote Recursively Definition plus_syntax := plus. 59 | 60 | Quote Recursively Definition mult_syntax := mult. 61 | -------------------------------------------------------------------------------- /test-suite/hnf_ctor.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Strings.String. 2 | Require Import Template.Template. 3 | 4 | Inductive U : Type := 5 | | TT : id U. 6 | 7 | Quote Recursively [ hnf ind typ ] Definition qU := U. 8 | Print qU. -------------------------------------------------------------------------------- /test-suite/mutind.v: -------------------------------------------------------------------------------- 1 | Require Import Template.Template. 2 | 3 | Section with_T. 4 | Variable T : Type. 5 | 6 | Inductive tree := 7 | | leaf 8 | | node : tree -> tree_list -> tree -> tree 9 | with tree_list := 10 | | tdata : T -> tree_list 11 | | tcons : tree -> tree_list -> tree_list. 12 | 13 | Fixpoint count_tree (t : tree) : nat := 14 | match t with 15 | | leaf => 0 16 | | node a b c => count_tree a + count_list b + count_tree c 17 | end 18 | with count_list (l : tree_list) : nat := 19 | match l with 20 | | tdata _ => 1 21 | | tcons t l => count_tree t + count_list l 22 | end. 23 | End with_T. 24 | 25 | Local Open Scope string_scope. 26 | Local Open Scope positive_scope. 27 | Quote Recursively Definition count_tree_syntax := count_tree. 28 | -------------------------------------------------------------------------------- /test-suite/opaque.v: -------------------------------------------------------------------------------- 1 | Require Import Template.Template. 2 | 3 | Definition foo : nat. exact 0. Qed. 4 | 5 | Local Open Scope string_scope. 6 | Quote Recursively Definition foo_syn := foo. 7 | 8 | Axiom really_opaque : nat. 9 | 10 | Quote Recursively Definition really_opaque_syn := really_opaque. 11 | -------------------------------------------------------------------------------- /theories/Ast.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Strings.String. 2 | Require Import Coq.PArith.BinPos. 3 | 4 | Definition universe := positive. 5 | Definition ident := string. 6 | 7 | Inductive sort : Set := 8 | | sProp 9 | | sSet 10 | | sType (_ : universe). 11 | 12 | Record ind : Set := {} . 13 | 14 | Inductive name : Set := 15 | | nAnon 16 | | nNamed (_ : ident). 17 | 18 | Inductive cast_kind : Set := 19 | | VmCast 20 | | NativeCast 21 | | Cast 22 | | RevertCast. 23 | 24 | Inductive inductive : Set := 25 | | mkInd : string -> nat -> inductive. 26 | 27 | Record def (term : Set) : Set := mkdef 28 | { dname : name (** the name (note, this may mention other definitions **) 29 | ; dtype : term 30 | ; dbody : term (** the body (a lambda term) **) 31 | ; rarg : nat (** the index of the recursive argument **) 32 | }. 33 | 34 | Definition mfixpoint (term : Set) : Set := 35 | list (def term). 36 | 37 | Inductive term : Set := 38 | | tRel : nat -> term 39 | | tVar : ident -> term (** this can go away **) 40 | | tMeta : nat -> term (** NOTE: this can go away *) 41 | | tEvar : nat -> term 42 | | tSort : sort -> term 43 | | tCast : term -> cast_kind -> term -> term 44 | | tProd : name -> term (** the type **) -> term -> term 45 | | tLambda : name -> term (** the type **) -> term -> term 46 | | tLetIn : name -> term (** the type **) -> term -> term -> term 47 | | tApp : term -> list term -> term 48 | | tConst : string -> term 49 | | tInd : inductive -> term 50 | | tConstruct : inductive -> nat -> term 51 | | tCase : nat (* # of parameters *) -> term (** type info **) -> term -> list term -> term 52 | | tFix : mfixpoint term -> nat -> term 53 | (* 54 | | CoFix of ('constr, 'types) pcofixpoint 55 | *) 56 | | tUnknown : string -> term. 57 | 58 | Record inductive_body := mkinductive_body 59 | { ctors : list (ident * term) }. 60 | 61 | Inductive program : Set := 62 | | PConstr : string -> term -> program -> program 63 | | PType : ident -> list (ident * inductive_body) -> program -> program 64 | | PAxiom : ident -> program -> program 65 | | PIn : term -> program. 66 | -------------------------------------------------------------------------------- /theories/Makefile: -------------------------------------------------------------------------------- 1 | MODULES := Ast Template 2 | VS := $(MODULES:%=%.v) 3 | 4 | ARGS := -R . Template 5 | 6 | .PHONY: coq clean package 7 | 8 | coq: Makefile.coq template_plugin.cmxs 9 | $(MAKE) -f Makefile.coq 10 | 11 | install: coq 12 | $(MAKE) -f Makefile.coq install 13 | 14 | Makefile.coq: Makefile $(VS) 15 | coq_makefile $(ARGS) $(VS) > Makefile.coq 16 | 17 | 18 | clean:: Makefile.coq 19 | $(MAKE) -f Makefile.coq clean 20 | rm -f Makefile.coq Makefile.test.coq .depend 21 | 22 | template_plugin.cmxs: ../src/template_plugin.cmxs 23 | @ ln -s ../src/template_plugin.cmxs . 24 | 25 | ../src/template_plugin.cmxs: 26 | $(MAKE) -C ../src 27 | 28 | admit: 29 | @ grep -n -e 'admit' -e 'Admitted' ${VS} 30 | 31 | depgraph: Makefile.coq 32 | @ echo Generating dependency graph to ../deps.pdf 33 | @ ./../tools/deps.py $(MODULES:%=%.v.d) > ../deps.dot 34 | @ ./../tools/deps.py $(MODULES:%=%.v.d) | dot -Tpdf -o ../deps.pdf 35 | 36 | toplevel: coq 37 | coqtop.opt $(ARGS) 38 | 39 | -include ../Makefile.paths 40 | -------------------------------------------------------------------------------- /theories/Template.v: -------------------------------------------------------------------------------- 1 | Require Import Template.Ast. 2 | 3 | Declare ML Module "template_plugin". --------------------------------------------------------------------------------