81 lines
3.0 KiB
Plaintext
81 lines
3.0 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: BSD-2-Clause
|
|
*)
|
|
|
|
theory AddUpdSimps
|
|
|
|
imports Main
|
|
keywords "add_upd_simps" :: thy_decl
|
|
|
|
begin
|
|
|
|
ML \<open>
|
|
fun mk_var_app nm (f $ _) = let
|
|
val (_, xs) = strip_comb f
|
|
val n = length xs
|
|
val T = domain_type (fastype_of f)
|
|
in mk_var_app nm f $ Free (nm ^ string_of_int n, T) end
|
|
| mk_var_app _ t = t
|
|
|
|
fun get_upd_apps (f $ (g $ x)) = if
|
|
is_Const (head_of f) andalso is_Const (head_of g)
|
|
andalso domain_type (fastype_of g) = range_type (fastype_of g)
|
|
then mk_var_app "x" f $ (mk_var_app "y" (g $ x))
|
|
:: get_upd_apps f @ get_upd_apps (g $ x)
|
|
else get_upd_apps f @ get_upd_apps (g $ x)
|
|
| get_upd_apps (f $ x) = get_upd_apps f @ get_upd_apps x
|
|
| get_upd_apps (Abs (_, _, t)) = get_upd_apps t
|
|
| get_upd_apps _ = []
|
|
|
|
fun mk_upd_simps ctxt upd_app (simps, done, n) = let
|
|
val n = n + 1
|
|
val _ = n <= 5000 orelse raise TERM ("mk_upd_simps: 5000", [upd_app])
|
|
val (nm, _) = dest_Const (head_of upd_app)
|
|
val def = Proof_Context.get_thm ctxt (nm ^ "_def")
|
|
val rhs = case (mk_var_app "x" upd_app, upd_app)
|
|
of (f $ _, _ $ (_ $ x)) => f $ x
|
|
| _ => raise TERM ("mk_upd_simps: impossible", [upd_app])
|
|
val prop = HOLogic.mk_eq (upd_app, rhs) |> HOLogic.mk_Trueprop
|
|
val thm = Thm.trivial (Thm.cterm_of ctxt prop)
|
|
|> simp_tac (ctxt addsimps [def, @{thm fun_eq_iff}] addsimps simps) 1
|
|
|> Seq.hd
|
|
val upd_apps_prem = Thm.prems_of thm |> maps get_upd_apps
|
|
|> sort_distinct Term_Ord.fast_term_ord
|
|
|> filter_out (Termtab.defined done)
|
|
|> filter_out (curry (op =) upd_app)
|
|
|> filter_out (head_of #> dest_Const #> fst #> String.isPrefix "HOL.")
|
|
val (simps2, done, n) = fold (mk_upd_simps ctxt)
|
|
upd_apps_prem (simps, done, n)
|
|
val thm = Drule.export_without_context thm
|
|
in if length simps2 <> length simps
|
|
then mk_upd_simps ctxt upd_app (simps2, done, n)
|
|
else (if Thm.nprems_of thm = 0 then thm :: simps2 else simps2,
|
|
Termtab.update (upd_app, ()) done, n)
|
|
end
|
|
handle ERROR _ => (warning (fst (dest_Const (head_of upd_app)) ^ ": no def.");
|
|
(simps, done, n))
|
|
|
|
fun mk_upd_simps_tm ctxt t = let
|
|
val uas = get_upd_apps t |> sort_distinct Term_Ord.fast_term_ord
|
|
val (simps, _, _) = fold (mk_upd_simps ctxt) uas ([], Termtab.empty, 0)
|
|
in simps end
|
|
|
|
fun add_upd_simps t exsimps ctxt = let
|
|
val thms = mk_upd_simps_tm (ctxt addsimps exsimps) t
|
|
val _ = map (Thm.pretty_thm ctxt #> Pretty.writeln) thms
|
|
in if null thms then ctxt
|
|
else (Local_Theory.notes [((@{binding upd_simps}, []), [(thms, [])])] ctxt |> #2) addsimps thms
|
|
end
|
|
|
|
val add_upd_simps_syn = Outer_Syntax.local_theory @{command_keyword "add_upd_simps"}
|
|
"recursively show updates don't matter to constants"
|
|
(Parse.term -- Scan.optional
|
|
(Parse.$$$ "(" |-- Scan.repeat Parse.thm --| Parse.$$$ ")") []
|
|
>> (fn (t, simps) => fn ctxt => add_upd_simps (Syntax.read_term ctxt t)
|
|
(Attrib.eval_thms ctxt simps) ctxt))
|
|
\<close>
|
|
|
|
end
|