163 lines
4.4 KiB
Plaintext
163 lines
4.4 KiB
Plaintext
(*
|
|
* Copyright 2016, 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)
|
|
*)
|
|
|
|
(*
|
|
* Extend a locale by seamlessly generating sublocales.
|
|
*)
|
|
|
|
theory Extend_Locale
|
|
imports Main Defs
|
|
keywords "extend_locale" :: thy_decl
|
|
begin
|
|
|
|
ML \<open>
|
|
fun note_new_facts prev_lthy (lthy : local_theory) =
|
|
let
|
|
val facts = Proof_Context.facts_of lthy;
|
|
|
|
val local_facts = Facts.dest_static false [Proof_Context.facts_of prev_lthy] facts;
|
|
|
|
val space = Facts.space_of (Proof_Context.facts_of lthy);
|
|
|
|
fun make_binding (long_name, pos) =
|
|
let val (qualifier, name) = split_last (Long_Name.explode long_name)
|
|
in fold (Binding.qualify true) qualifier (Binding.make (name, pos)) end;
|
|
|
|
fun add_entry (nm, thms) lthy =
|
|
let
|
|
val extern_nm = Name_Space.extern_shortest lthy space nm;
|
|
val {pos, ...} = Name_Space.the_entry space nm;
|
|
val b = make_binding (extern_nm, pos);
|
|
val (_, lthy') = Local_Theory.note ((b,[]),thms) lthy;
|
|
in lthy' end
|
|
|
|
in fold add_entry local_facts lthy end;
|
|
\<close>
|
|
|
|
ML \<open>
|
|
|
|
val _ =
|
|
Outer_Syntax.command @{command_keyword extend_locale} "extend current locale"
|
|
(Parse.opt_target -- (Scan.repeat1 Parse_Spec.context_element) >> (fn (target, (elems)) =>
|
|
(Toplevel.local_theory NONE target (fn lthy =>
|
|
let
|
|
val locale_name = case Named_Target.locale_of lthy of SOME x => x | NONE => error "Not in a locale!"
|
|
val binding = Binding.make (Long_Name.base_name locale_name, Position.none)
|
|
|
|
val chunkN = "extchunk_"
|
|
|
|
val last_chunk =
|
|
case Long_Name.explode locale_name of
|
|
[_, chunk, _] => (unprefix chunkN chunk |> Int.fromString |> the)
|
|
| [_, _] => 0
|
|
| _ => raise Fail ("Unexpected locale naming scheme:" ^ locale_name)
|
|
|
|
val chunk = Int.toString (last_chunk + 1)
|
|
|
|
|
|
val (next_locale_name, lthy') = lthy
|
|
|> Local_Theory.map_background_naming
|
|
(Name_Space.parent_path #> Name_Space.add_path (chunkN ^ chunk))
|
|
|> Local_Theory.background_theory_result
|
|
(Expression.add_locale_cmd binding binding
|
|
([((locale_name,Position.none), (("#",false), Expression.Positional []))], []) elems
|
|
##> Local_Theory.exit_global)
|
|
||> Local_Theory.restore_background_naming lthy
|
|
|
|
|
|
val lthy'' = lthy'
|
|
|> Local_Theory.exit_global
|
|
|> Named_Target.init next_locale_name
|
|
|
|
in lthy'' end)
|
|
)));
|
|
|
|
\<close>
|
|
|
|
locale Internal begin
|
|
definition "internal_const1 = True"
|
|
definition "internal_const2 = False"
|
|
end
|
|
|
|
locale Generic
|
|
begin
|
|
|
|
definition "generic_const = ((\<forall>x :: nat. x \<noteq> x))"
|
|
|
|
extend_locale
|
|
assumes asm_1: "Internal.internal_const1 = (\<forall>x :: nat. x = x)"
|
|
|
|
lemma generic_lemma_1: "Internal.internal_const1"
|
|
apply (insert asm_1)
|
|
apply simp
|
|
done
|
|
|
|
extend_locale
|
|
assumes asm_2: "\<not> Internal.internal_const2"
|
|
|
|
lemma generic_lemma_2: "generic_const = Internal.internal_const2"
|
|
by (simp add: asm_2 generic_const_def)
|
|
|
|
extend_locale
|
|
fixes param_const_1 :: nat
|
|
assumes asm_3: "param_const_1 > 0"
|
|
|
|
lemma generic_lemma_3: "param_const_1 \<noteq> 0"
|
|
by (simp add: asm_3)
|
|
|
|
extend_locale
|
|
assumes asm_4: "\<not> generic_const"
|
|
|
|
lemma generic_lemma_4: "generic_const = Internal.internal_const2"
|
|
by (simp add: asm_4 asm_2 generic_lemma_2)
|
|
|
|
extend_locale
|
|
assumes asm_4: "x = param_const_1 \<Longrightarrow> y > x \<Longrightarrow> y > 1"
|
|
|
|
|
|
end
|
|
|
|
context Internal begin
|
|
|
|
lemma internal_lemma1: "internal_const1 = (\<forall>x :: nat. x = x)" by (simp add: internal_const1_def)
|
|
|
|
lemma internal_lemma2: "\<not> internal_const2" by (simp add: internal_const2_def)
|
|
|
|
lemma internal_lemma3: "\<not> Generic.generic_const" by (simp add: Generic.generic_const_def)
|
|
|
|
definition "internal_const3 = (1 :: nat)"
|
|
|
|
lemma internal_lemma4: "internal_const3 > 0" by (simp add: internal_const3_def)
|
|
|
|
lemma asm_4: "x = internal_const3 \<Longrightarrow> y > x \<Longrightarrow> y > 1"
|
|
by (simp add: internal_const3_def)
|
|
|
|
end
|
|
|
|
interpretation Generic
|
|
where param_const_1 = Internal.internal_const3
|
|
subgoal
|
|
proof -
|
|
interpret Internal .
|
|
show ?thesis by (intro_locales; (unfold_locales, fact)?)
|
|
qed
|
|
done
|
|
|
|
context Internal begin
|
|
|
|
lemma internal_lemma5:
|
|
"internal_const3 \<noteq> 0"
|
|
by (rule generic_lemma_3)
|
|
|
|
end
|
|
|
|
|
|
end
|