diff options
author | Arnaud Spiwack <arnaud@spiwack.net> | 2013-11-25 19:05:48 +0100 |
---|---|---|
committer | Arnaud Spiwack <arnaud@spiwack.net> | 2013-12-04 14:14:33 +0100 |
commit | 078efbe2dfff0b783cd35b0b3ab2354f554e95a6 (patch) | |
tree | e79c02a053d44a79f841a2e1ba013b12a08bd014 /plugins/Derive/derive.ml | |
parent | 3c199b86ddf919d79ad79eb7d69f4b6f81bb73ab (diff) |
Derive plugin.
A small plugin to support program deriving (à la Richard Bird) in Coq.
It's fairly simple:
Require Coq.Derive.Derive.
Derive f From g Upto eq As h.
Produces a goal (actually two, but the first one is automatically shelved):
|- eq g ?42
And closing the proof produces two definitions: f is instantiated with the value of ?42 (it's always transparent). And h is instantiated with the content of the proof (it is transparent or opaque depending on whether the proof was closed with Defined or Qed).
Diffstat (limited to 'plugins/Derive/derive.ml')
-rw-r--r-- | plugins/Derive/derive.ml | 74 |
1 files changed, 74 insertions, 0 deletions
diff --git a/plugins/Derive/derive.ml b/plugins/Derive/derive.ml new file mode 100644 index 000000000..c6a96b31a --- /dev/null +++ b/plugins/Derive/derive.ml @@ -0,0 +1,74 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +let interp_init_def_and_relation env sigma init_def r = + let init_def = Constrintern.interp_constr sigma env init_def in + let init_type = Typing.type_of env sigma init_def in + + let r_type = + let open Term in + mkProd (Names.Anonymous,init_type, mkProd (Names.Anonymous,init_type,mkProp)) + in + let r = Constrintern.interp_casted_constr sigma env r r_type in + init_def , init_type , r + + +(** [start_deriving f init r lemma] starts a proof of [r init + ?x]. When the proof ends, [f] is defined as the value of [?x] and + [lemma] as the proof. *) +let start_deriving f init_def r lemma = + let env = Global.env () in + let kind = Decl_kinds.(Global,DefinitionBody Definition) in + let ( init_def , init_type , r ) = + interp_init_def_and_relation env Evd.empty init_def r + in + let goals = + let open Proofview in + TCons ( env , init_type , (fun ef -> + TCons ( env , Term.mkApp ( r , [| init_def ; ef |] ) , (fun _ -> TNil)))) + in + let terminator com = + let open Proof_global in + match com with + | Admitted -> Errors.error"Admitted isn't supported in Derive." + | Proved (_,Some _,_) -> + Errors.error"Cannot save a proof of Derive with an explicit name." + | Proved (opaque, None, obj) -> + let (f_def,lemma_def) = + match Proof_global.(obj.entries) with + | [f_def;lemma_def] -> + f_def , lemma_def + | _ -> assert false + in + (* The opacity of [f_def] is adjusted to be [false]. *) + let f_def = let open Entries in { f_def with + const_entry_opaque = false ; } + in + let f_def = Entries.DefinitionEntry f_def , Decl_kinds.(IsDefinition Definition) in + let f_kn = Declare.declare_constant f f_def in + let lemma_typ = Term.(mkApp ( r , [| init_def ; mkConst f_kn |] )) in + (* The type of [lemma_def] is adjusted to refer to [f_kn], the + opacity is adjusted by the proof ending command. *) + let lemma_def = let open Entries in { lemma_def with + const_entry_type = Some lemma_typ ; + const_entry_opaque = opaque ; } + in + let lemma_def = + Entries.DefinitionEntry lemma_def , + Decl_kinds.(IsProof Proposition) + in + ignore (Declare.declare_constant lemma lemma_def) + in + let () = Proof_global.start_dependent_proof + lemma kind goals terminator + in + let _ = Proof_global.with_current_proof begin fun _ p -> + Proof.run_tactic env Proofview.(tclFOCUS 1 1 shelve) p + end in + () + |