2014-07-14 19:32:44 +00:00
|
|
|
(*
|
|
|
|
* Copyright 2014, NICTA
|
|
|
|
*
|
|
|
|
* This software may be distributed and modified according to the terms of
|
|
|
|
* the BSD 2-Clause license. Note that NO WARRANTY is provided.
|
|
|
|
* See "LICENSE_BSD2.txt" for details.
|
|
|
|
*
|
|
|
|
* @TAG(NICTA_BSD)
|
|
|
|
*)
|
|
|
|
|
|
|
|
(* Backend for tracing apply statements. Useful for doing proof step dependency analysis.
|
|
|
|
* Provides an alternate refinement function which takes an additional stateful journaling operation. *)
|
|
|
|
theory Apply_Trace
|
|
|
|
imports Main
|
|
|
|
begin
|
|
|
|
|
|
|
|
|
|
|
|
ML {*
|
|
|
|
signature APPLY_TRACE =
|
|
|
|
sig
|
2014-09-17 06:38:16 +00:00
|
|
|
val apply_results :
|
2014-10-08 04:18:29 +00:00
|
|
|
{silent_fail : bool} ->
|
2015-09-16 07:01:09 +00:00
|
|
|
(Proof.context -> thm -> ((string * int option) * term) list -> unit) ->
|
2014-09-17 06:38:16 +00:00
|
|
|
Method.text_range -> Proof.state -> Proof.state Seq.result Seq.seq
|
2014-07-14 19:32:44 +00:00
|
|
|
|
2014-09-17 06:38:16 +00:00
|
|
|
(* Lower level interface. *)
|
|
|
|
val clear_deps : thm -> thm
|
|
|
|
val join_deps : thm -> thm -> thm
|
|
|
|
val used_facts : thm -> (string * term) list
|
2014-07-14 19:32:44 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
structure Apply_Trace : APPLY_TRACE =
|
|
|
|
struct
|
|
|
|
|
2014-10-08 04:18:29 +00:00
|
|
|
(*TODO: Add more robust oracle without hyp clearing *)
|
|
|
|
fun thm_to_cterm keep_hyps thm =
|
2014-07-14 19:32:44 +00:00
|
|
|
let
|
|
|
|
|
|
|
|
val thy = Thm.theory_of_thm thm
|
2016-02-04 03:30:12 +00:00
|
|
|
val pairs = Thm.tpairs_of thm
|
|
|
|
val ceqs = map (Thm.global_cterm_of thy o Logic.mk_equals) pairs
|
|
|
|
val hyps = Thm.chyps_of thm
|
|
|
|
val prop = Thm.cprop_of thm
|
|
|
|
val thm' = if keep_hyps then Drule.list_implies (hyps,prop) else prop
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
in
|
2014-10-08 04:18:29 +00:00
|
|
|
Drule.list_implies (ceqs,thm') end
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
|
|
|
|
val (_, clear_thm_deps') =
|
2014-10-08 04:18:29 +00:00
|
|
|
Context.>>> (Context.map_theory_result (Thm.add_oracle (Binding.name "count_cheat", thm_to_cterm false)));
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
fun clear_deps thm =
|
|
|
|
let
|
|
|
|
|
|
|
|
val thm' = try clear_thm_deps' thm
|
2016-02-04 03:30:12 +00:00
|
|
|
|> Option.map (fold (fn _ => fn t => (@{thm Pure.reflexive} RS t)) (Thm.tpairs_of thm))
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
in case thm' of SOME thm' => thm' | NONE => error "Can't clear deps here" end
|
|
|
|
|
|
|
|
|
2016-02-04 03:30:12 +00:00
|
|
|
fun can_clear thy = Context.subthy(@{theory},thy)
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
fun join_deps thm thm' = Conjunction.intr thm thm' |> Conjunction.elim |> snd
|
|
|
|
|
|
|
|
fun thms_of (PBody {thms,...}) = thms
|
|
|
|
|
|
|
|
fun proof_body_descend' (_,("",_,body)) = fold (append o proof_body_descend') (thms_of (Future.join body)) []
|
|
|
|
| proof_body_descend' (_,(nm,t,_)) = [(nm,t)]
|
|
|
|
|
|
|
|
|
|
|
|
fun used_facts thm = fold (append o proof_body_descend') (thms_of (Thm.proof_body_of thm)) []
|
|
|
|
|
2015-04-17 15:19:32 +00:00
|
|
|
fun raw_primitive_text f = Method.Basic (fn ctxt => (Method.METHOD (K (fn thm => Seq.single (f thm)))))
|
2014-10-08 04:18:29 +00:00
|
|
|
|
2014-07-14 19:32:44 +00:00
|
|
|
|
2014-10-08 04:18:29 +00:00
|
|
|
(*Find local facts from new hyps*)
|
|
|
|
fun used_local_facts ctxt thm =
|
2014-07-14 19:32:44 +00:00
|
|
|
let
|
2016-02-04 03:30:12 +00:00
|
|
|
val hyps = Thm.hyps_of thm
|
2014-10-08 04:18:29 +00:00
|
|
|
val facts = Proof_Context.facts_of ctxt |> Facts.dest_static true []
|
|
|
|
|
|
|
|
fun match_hyp hyp =
|
|
|
|
let
|
|
|
|
fun get (nm,thms) =
|
2015-04-17 15:19:32 +00:00
|
|
|
case (get_index (fn t => if (Thm.prop_of t) aconv hyp then SOME hyp else NONE) thms)
|
2014-10-08 04:18:29 +00:00
|
|
|
of SOME t => SOME (nm,t)
|
|
|
|
| NONE => NONE
|
|
|
|
|
|
|
|
|
|
|
|
in
|
|
|
|
get_first get facts
|
|
|
|
end
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
in
|
2014-10-08 04:18:29 +00:00
|
|
|
map_filter match_hyp hyps end
|
|
|
|
|
|
|
|
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
(* Perform refinement step, and run the given stateful function
|
|
|
|
against computed dependencies afterwards. *)
|
|
|
|
fun refine args f text state =
|
|
|
|
let
|
2014-10-08 04:18:29 +00:00
|
|
|
|
|
|
|
val ctxt = Proof.context_of state
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
val thm = Proof.simple_goal state |> #goal
|
|
|
|
|
2015-09-16 07:01:09 +00:00
|
|
|
fun save_deps deps = f ctxt thm deps
|
2014-10-08 04:18:29 +00:00
|
|
|
|
|
|
|
fun get_used thm =
|
|
|
|
let
|
|
|
|
val used_from_pbody = used_facts thm |> map (fn (nm,t) => ((nm,NONE),t))
|
|
|
|
val used_from_hyps = used_local_facts ctxt thm |> map (fn (nm,(i,t)) => ((nm,SOME i),t))
|
|
|
|
in
|
|
|
|
(used_from_hyps @ used_from_pbody)
|
|
|
|
end
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
in
|
2014-10-08 04:18:29 +00:00
|
|
|
if (can_clear (Proof.theory_of state)) then
|
2015-09-16 07:01:09 +00:00
|
|
|
Proof.refine (Method.Combinator (Method.no_combinator_info,Method.Then, [raw_primitive_text (clear_deps),text,
|
2014-10-08 04:18:29 +00:00
|
|
|
raw_primitive_text (fn thm' => (save_deps (get_used thm');join_deps thm thm'))])) state
|
2014-07-14 19:32:44 +00:00
|
|
|
else
|
|
|
|
(if (#silent_fail args) then (save_deps [];Proof.refine text state) else error "Apply_Trace theory must be imported to trace applies")
|
|
|
|
end
|
|
|
|
|
|
|
|
(* Boilerplate from Proof.ML *)
|
|
|
|
|
|
|
|
|
|
|
|
fun method_error kind pos state =
|
|
|
|
Seq.single (Proof_Display.method_error kind pos (Proof.raw_goal state));
|
|
|
|
|
2016-02-04 03:30:12 +00:00
|
|
|
fun apply args f text = Proof.assert_backward #> refine args f text #> Seq.map_result (Proof.using_facts []);
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
fun apply_results args f (text, range) =
|
2016-02-04 03:30:12 +00:00
|
|
|
Seq.APPEND (apply args f text, method_error "" (Position.set_range range));
|
2014-07-14 19:32:44 +00:00
|
|
|
|
|
|
|
|
|
|
|
end
|
|
|
|
*}
|
|
|
|
|
|
|
|
end
|
|
|
|
|