226 lines
6.5 KiB
Plaintext
226 lines
6.5 KiB
Plaintext
(*
|
|
* Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
|
|
*
|
|
* SPDX-License-Identifier: BSD-2-Clause
|
|
*)
|
|
|
|
(*
|
|
Requalify constants, types and facts into the current naming
|
|
*)
|
|
|
|
theory Requalify
|
|
imports Main
|
|
keywords "requalify_facts" :: thy_decl and "requalify_types" :: thy_decl and "requalify_consts" :: thy_decl and
|
|
"global_naming" :: thy_decl
|
|
begin
|
|
|
|
ML \<open>
|
|
|
|
local
|
|
|
|
|
|
fun all_facts_of ctxt =
|
|
let
|
|
val thy = Proof_Context.theory_of ctxt;
|
|
val global_facts = Global_Theory.facts_of thy;
|
|
in
|
|
Facts.dest_static false [] global_facts
|
|
end;
|
|
|
|
fun global_fact ctxt nm =
|
|
let
|
|
val facts = Proof_Context.facts_of ctxt;
|
|
val {name, thms, ...} = (Facts.retrieve (Context.Proof ctxt) facts (nm, Position.none));
|
|
|
|
fun tl' (_ :: xs) = xs
|
|
| tl' _ = []
|
|
|
|
fun matches suf (gnm, gthms) =
|
|
let
|
|
val gsuf = Long_Name.explode gnm |> tl' |> tl' |> Long_Name.implode;
|
|
|
|
in suf = gsuf andalso eq_list (Thm.equiv_thm (Proof_Context.theory_of ctxt)) (thms, gthms)
|
|
end
|
|
in
|
|
case Long_Name.dest_local name of NONE => (name, thms) | SOME suf =>
|
|
(case (find_first (matches suf) (all_facts_of ctxt)) of
|
|
SOME x => x
|
|
| NONE => raise Fail ("Couldn't find global equivalent of local fact: " ^ nm))
|
|
end
|
|
|
|
fun syntax_alias global_alias local_alias b (name : string) =
|
|
Local_Theory.declaration {syntax = false, pos = Position.none, pervasive = true} (fn phi =>
|
|
let val b' = Morphism.binding phi b
|
|
in Context.mapping (global_alias b' name) (local_alias b' name) end);
|
|
|
|
val alias_fact = syntax_alias Global_Theory.alias_fact Proof_Context.alias_fact;
|
|
val const_alias = syntax_alias Sign.const_alias Proof_Context.const_alias;
|
|
val type_alias = syntax_alias Sign.type_alias Proof_Context.type_alias;
|
|
|
|
in
|
|
|
|
fun gen_requalify get_proper_nm parse_nm check_nm alias =
|
|
(Parse.opt_target -- Scan.repeat1 (Parse.position (Scan.ahead parse_nm -- Parse.name))
|
|
>> (fn (target,bs) =>
|
|
Toplevel.local_theory NONE target (fn lthy =>
|
|
let
|
|
|
|
fun read_entry ((entry, t), pos) lthy =
|
|
let
|
|
val local_nm = get_proper_nm lthy t;
|
|
val _ = check_nm lthy (entry, (local_nm, pos));
|
|
val b = Binding.make (Long_Name.base_name t, pos)
|
|
|
|
val lthy' = lthy
|
|
|> alias b local_nm
|
|
|
|
in lthy' end
|
|
|
|
in fold read_entry bs lthy end)))
|
|
|
|
local
|
|
|
|
val get_const_nm = ((fst o dest_Const) oo (Proof_Context.read_const {proper = true, strict = false}))
|
|
val get_type_nm = ((fst o dest_Type) oo (Proof_Context.read_type_name {proper = true, strict = false}))
|
|
val get_fact_nm = (fst oo global_fact)
|
|
|
|
fun check_fact lthy (_, (nm, pos)) = Proof_Context.get_fact lthy (Facts.Named ((nm,pos), NONE))
|
|
|
|
in
|
|
|
|
val _ =
|
|
Outer_Syntax.command @{command_keyword requalify_consts} "alias const with current naming"
|
|
(gen_requalify get_const_nm Parse.const (fn lthy => fn (e, _) => get_const_nm lthy e) const_alias)
|
|
|
|
val _ =
|
|
Outer_Syntax.command @{command_keyword requalify_types} "alias type with current naming"
|
|
(gen_requalify get_type_nm Parse.typ (fn lthy => fn (e, _) => get_type_nm lthy e) type_alias)
|
|
|
|
val _ =
|
|
Outer_Syntax.command @{command_keyword requalify_facts} "alias fact with current naming"
|
|
(gen_requalify get_fact_nm Parse.thm check_fact alias_fact)
|
|
|
|
val _ =
|
|
Outer_Syntax.command @{command_keyword global_naming} "change global naming of context block"
|
|
(Parse.binding >> (fn naming =>
|
|
Toplevel.local_theory NONE NONE
|
|
(Local_Theory.map_background_naming (Name_Space.parent_path #> Name_Space.qualified_path true naming))))
|
|
|
|
end
|
|
|
|
end
|
|
\<close>
|
|
|
|
(*Tests and examples *)
|
|
|
|
locale Requalify_Locale
|
|
begin
|
|
|
|
typedecl requalify_type
|
|
|
|
definition "requalify_const == (undefined :: requalify_type)"
|
|
|
|
|
|
end
|
|
|
|
typedecl requalify_type
|
|
definition "requalify_const == (undefined :: requalify_type)"
|
|
|
|
context Requalify_Locale begin global_naming Requalify_Locale2
|
|
|
|
requalify_consts requalify_const
|
|
requalify_types requalify_type
|
|
requalify_facts requalify_const_def
|
|
|
|
end
|
|
|
|
term "requalify_const :: requalify_type"
|
|
term "Requalify_Locale2.requalify_const :: Requalify_Locale2.requalify_type"
|
|
lemma "Requalify_Locale2.requalify_const = (undefined :: Requalify_Locale2.requalify_type)"
|
|
by (simp add: Requalify_Locale2.requalify_const_def)
|
|
|
|
consts requalify_test_f :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
|
|
|
|
lemma
|
|
assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const"
|
|
and f2: "requalify_test_f Requalify_Locale2.requalify_const Requalify.requalify_const"
|
|
shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined"
|
|
apply (rule f1)?
|
|
apply (rule f2)
|
|
apply (simp add: requalify_const_def)
|
|
done
|
|
|
|
context Requalify_Locale begin
|
|
|
|
lemma
|
|
assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const"
|
|
and f2: "requalify_test_f Requalify_Locale2.requalify_const Requalify.requalify_const"
|
|
shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined"
|
|
apply (rule f2)?
|
|
apply (rule f1)
|
|
apply (simp add: requalify_const_def)
|
|
done
|
|
|
|
end
|
|
|
|
context Requalify_Locale begin global_naming global
|
|
|
|
requalify_consts Requalify.requalify_const
|
|
requalify_types Requalify.requalify_type
|
|
requalify_facts Requalify.requalify_const_def
|
|
|
|
end
|
|
|
|
context Requalify_Locale begin
|
|
|
|
lemma
|
|
assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const"
|
|
and f2: "requalify_test_f Requalify_Locale2.requalify_const global.requalify_const"
|
|
shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined"
|
|
apply (rule f1)?
|
|
apply (rule f2)
|
|
apply (simp add: requalify_const_def)
|
|
done
|
|
end
|
|
|
|
context begin interpretation Requalify_Locale .
|
|
|
|
lemma
|
|
assumes f1: "requalify_test_f requalify_const Requalify_Locale2.requalify_const"
|
|
and f2: "requalify_test_f Requalify_Locale2.requalify_const global.requalify_const"
|
|
shows "requalify_test_f Requalify_Locale2.requalify_const requalify_const" "requalify_const = undefined"
|
|
apply (rule f1)?
|
|
apply (rule f2)
|
|
apply (simp add: requalify_const_def)
|
|
done
|
|
end
|
|
|
|
locale Requalify_Locale3
|
|
begin
|
|
|
|
typedecl requalify_type2
|
|
definition "requalify_const2 == (undefined :: requalify_type2)"
|
|
|
|
end
|
|
|
|
context begin interpretation Requalify_Locale3 .
|
|
|
|
requalify_consts requalify_const2
|
|
requalify_types requalify_type2
|
|
requalify_facts requalify_const2_def
|
|
|
|
end
|
|
|
|
lemma "(requalify_const2 :: requalify_type2) = undefined"
|
|
by (simp add: requalify_const2_def)
|
|
|
|
context Requalify_Locale3 begin
|
|
|
|
lemma "(requalify_const2 :: requalify_type2) = undefined"
|
|
by (simp add: requalify_const2_def)
|
|
|
|
end
|
|
|
|
|
|
end
|