236 lines
12 KiB
Plaintext
236 lines
12 KiB
Plaintext
chapter \<open>The Document Meta-Class Framework for Isabelle \<close>
|
|
|
|
text{* A kind of ".dtd" for Isabelle documents modeled inside Isabelle for Isabelle, including
|
|
general reg-exps for specifying the syntactic structure of sub-entities as well as
|
|
sub-typing between document classes. *}
|
|
|
|
theory Isa_MOF
|
|
imports RegExp
|
|
"~~/src/HOL/Library/Code_Target_Numeral"
|
|
"~~/src/HOL/Library/String"
|
|
begin
|
|
|
|
type_synonym string = String.literal
|
|
type_synonym cid = string (*class identifier *)
|
|
type_synonym aid = string (*attribute identifier *)
|
|
type_synonym xstring = string
|
|
type_synonym oid = string
|
|
|
|
|
|
|
|
datatype attribute_types = file\<^sub>T (file_name: string)
|
|
| image_file\<^sub>T (image_file_name : string)
|
|
| thms\<^sub>T (thm_names : "string list")
|
|
| int\<^sub>T (int_of : int)
|
|
| bool\<^sub>T (bool_of : bool)
|
|
| string\<^sub>T (string_of : string)
|
|
| text\<^sub>T (text_of : xstring)
|
|
| range\<^sub>T (start : int) (end_opt : "int option")
|
|
| enum\<^sub>T (enum_ids : "string list")
|
|
|
|
(*
|
|
datatype ('\<sigma>\<^sub>s\<^sub>y\<^sub>s)base_types = int\<^sub>T (default1:"int")
|
|
| string\<^sub>T (default2:"string")
|
|
| int_list\<^sub>T (default3:"int list")
|
|
| string\<^sub>_list\<^sub>T (default4:"string list")
|
|
| method\<^sub>T (action:"'\<sigma>\<^sub>s\<^sub>y\<^sub>s \<Rightarrow> '\<sigma>\<^sub>s\<^sub>y\<^sub>s")
|
|
(* Options ?*)
|
|
*)
|
|
|
|
|
|
type_synonym attribute_env = "(string \<times> attribute_types)list"
|
|
|
|
type_synonym entity_env = "(string \<times> (oid \<times> cid)rexp) list"
|
|
(* entities have a regular structure, i.e. their syntactic structure is described by
|
|
a regular grammar involving in object-conformance checks a grammar check. *)
|
|
|
|
datatype class_hierarchy = class\<^sub>T (class_name : cid)
|
|
(subclasses : "class_hierarchy list" )
|
|
(attributes : "attribute_env")
|
|
(entities : "entity_env")
|
|
(* The conceptual distinction between attributes and entities is pragmatic - attributes
|
|
are basic values, components sub-OBJECTS having an class-typed syntactical
|
|
structure. *)
|
|
|
|
(* Note: we may have override in attributes and entities,
|
|
and their name-spaces are disjoint. Obviously, the syntactic entity structure may be
|
|
inexistent ([]) or having empty entities ("bla", <>). The semantics of the list concatenation
|
|
of two entities is textual sequencing. *)
|
|
|
|
text{* in the reflection part, @{typ 'oid} will be instantiated with
|
|
@{ML_type "bstring * Binding.binding"} pairs allowing native Isabelle/jedit support for
|
|
document editing. *} (* quatsch *)
|
|
|
|
|
|
definition mt :: "class_hierarchy"
|
|
where "mt == class\<^sub>T (String.implode ''/'') [] [] [] "
|
|
|
|
fun classes :: "class_hierarchy \<Rightarrow> string list"
|
|
where "classes (class\<^sub>T name sub_classes attr comps) = name # concat(map classes sub_classes)"
|
|
|
|
fun all_attributes :: "class_hierarchy \<Rightarrow> attribute_env list"
|
|
where "all_attributes (class\<^sub>T name sub_classes attr comps) = attr # (map attributes sub_classes)"
|
|
|
|
fun all_entities :: "class_hierarchy \<Rightarrow> entity_env list"
|
|
where "all_entities (class\<^sub>T name sub_classes attr comps) = comps # (map entities sub_classes)"
|
|
|
|
fun atoms_of :: "'a rexp \<Rightarrow> 'a list"
|
|
where "atoms_of <> = []"
|
|
|"atoms_of (\<lfloor>x\<rfloor>) = [x]"
|
|
|"atoms_of(a | b) = atoms_of a @ atoms_of b"
|
|
|"atoms_of(a : b) = atoms_of a @ atoms_of b"
|
|
|"atoms_of(Star a) = atoms_of a"
|
|
|
|
|
|
text{* Elementary consistency definitions ... *}
|
|
definition wff :: "class_hierarchy \<Rightarrow> bool"
|
|
where "wff H = (distinct(classes H) \<and>
|
|
(\<forall> (_,cid) \<in> set(concat(map(atoms_of o snd)
|
|
(concat(all_entities H)))). cid \<in> set(classes H)) \<and>
|
|
(\<forall> attribute_list \<in> set(all_attributes H). distinct(map fst attribute_list)) \<and>
|
|
(\<forall> entity_list \<in> set(all_entities H). distinct(map fst entity_list))
|
|
)"
|
|
|
|
lemma wff_mt [simp]: "wff mt"
|
|
unfolding mt_def wff_def by auto
|
|
|
|
lemma class_names_distinct : "wff H \<Longrightarrow> distinct(classes H)" unfolding wff_def by(auto)
|
|
|
|
lemma class_names_declared_in_component_decl :
|
|
"wff H \<Longrightarrow> (\<forall> (_,cid) \<in> set(concat(map(atoms_of o snd)
|
|
(concat(all_entities H)))). cid \<in> set(classes H))"
|
|
unfolding wff_def by(auto)
|
|
|
|
lemma attribute_names_unique_in_attr_decl :
|
|
"wff H \<Longrightarrow> (\<forall> attribute_list \<in> set(all_attributes H). distinct(map fst attribute_list))"
|
|
unfolding wff_def by(auto)
|
|
|
|
lemma component_names_unique_in_attr_decl :
|
|
"wff H \<Longrightarrow> (\<forall> entity_list \<in> set(all_attributes H). distinct(map fst entity_list))"
|
|
unfolding wff_def by(auto)
|
|
|
|
|
|
fun get_subclass :: "class_hierarchy \<Rightarrow> nat list \<Rightarrow> class_hierarchy option"
|
|
where "get_subclass H [] = Some H"
|
|
|"get_subclass (class\<^sub>T cid subs attrs ents) (n#S) =
|
|
(if n < length subs
|
|
then case get_subclass (subs ! n) S of
|
|
Some H' \<Rightarrow> Some (class\<^sub>T cid (subs[n := H']) attrs ents)
|
|
| None \<Rightarrow> None
|
|
else None)"
|
|
|
|
(* I don't know if this is general enough. It does not allow the introduction
|
|
of classes which are mutually dependant.
|
|
*)
|
|
fun extend_class_hierarchy :: "((class_hierarchy \<Rightarrow> class_hierarchy) \<times> class_hierarchy) \<Rightarrow>
|
|
(cid \<times> attribute_env \<times> entity_env) \<Rightarrow>
|
|
class_hierarchy" (infixl "\<uplus>" 70)
|
|
where "(C,H) \<uplus> (cid,attrs,ents) =
|
|
(if cid \<notin> set(classes (C H)) (* cid fresh in context and subhierarchy *)
|
|
then if distinct(map fst attrs)
|
|
then if distinct(map fst ents)
|
|
then case H of
|
|
class\<^sub>T cid' subs attrs' ents' \<Rightarrow>
|
|
C(class\<^sub>T cid' (( class\<^sub>T cid [] attrs' ents') # subs) attrs ents)
|
|
else mt
|
|
else mt
|
|
else mt)"
|
|
|
|
(* Todo : Lemmas that establish wff of extended trees *)
|
|
|
|
lemma wff_preserved :
|
|
assumes "wff (C H)"
|
|
shows "wff((C,H) \<uplus> (cid,attrs,ents))"
|
|
apply(insert assms)
|
|
sorry
|
|
|
|
(* well, this does not hold. this can only be true for standard contexts C, but
|
|
how do we model this ? ? ? *)
|
|
(* sigh, then try Dewey notation and classical grafting. *)
|
|
|
|
|
|
section{* Subclass properties *}
|
|
|
|
fun dir_sub_class :: "string \<Rightarrow> class_hierarchy \<Rightarrow> string \<Rightarrow> bool"
|
|
("(_)\<sqsubset>\<^bsub>(_)\<^esub> (_)"[60,80,60]80)
|
|
where "(s \<sqsubset>\<^bsub>(class\<^sub>T n subs _ _)\<^esub> t) = ((s=n \<and> t \<in> set (map class_name subs) \<or>
|
|
(\<exists> sub\<in>set subs. s \<sqsubset>\<^bsub>sub\<^esub> t)))"
|
|
|
|
definition sub_class :: "string \<Rightarrow> class_hierarchy \<Rightarrow> string \<Rightarrow> bool"
|
|
("(_)\<sqsubseteq>\<^bsub>(_)\<^esub> (_)"[60,80,60]80)
|
|
where "(s \<sqsubseteq>\<^bsub>(H)\<^esub> t) = ((s,t) \<in> {(x,y). x \<sqsubset>\<^bsub>(H)\<^esub> y}\<^sup>*) "
|
|
|
|
lemma sub_class_refl : "(s \<sqsubseteq>\<^bsub>(H)\<^esub> s)"
|
|
unfolding sub_class_def
|
|
by simp
|
|
|
|
text{* A manner to compute the subclass relationship effectively gives the following lemma: *}
|
|
lemma sub_class_trans_comp :
|
|
"(s \<sqsubseteq>\<^bsub>(H)\<^esub> t) = (if class_name H = s
|
|
then \<exists> s'\<in> set(map class_name (subclasses H)). (s' \<sqsubseteq>\<^bsub>(H)\<^esub> t)
|
|
else \<exists> H'\<in> set(subclasses H). (s \<sqsubseteq>\<^bsub>(H')\<^esub> t) )"
|
|
proof(induct H) print_cases
|
|
case (class\<^sub>T n subs attrs)
|
|
then show ?case (* using class\<^sub>T.hyps *) apply auto
|
|
sorry
|
|
qed
|
|
|
|
|
|
subsection{* Fundamental search and replacement operations in a hierarchy *}
|
|
|
|
fun replace_class_hierarchy :: "((class_hierarchy \<Rightarrow> class_hierarchy) \<times> class_hierarchy) \<Rightarrow>
|
|
cid \<Rightarrow>
|
|
class_hierarchy \<Rightarrow>
|
|
class_hierarchy" ("(_)[_\\_]" [80,80,80]80)
|
|
where "(C,class\<^sub>T cid' subs attrs ents) [cid \\ H'] = (if cid = cid'
|
|
then C H'
|
|
else C(class\<^sub>T cid'
|
|
(map (\<lambda>X. (\<lambda>x. x, X) [cid \\ H']) subs) attrs ents))"
|
|
|
|
|
|
fun get_class :: "cid \<Rightarrow> class_hierarchy \<Rightarrow> (attribute_env \<times> entity_env \<times> class_hierarchy)option"
|
|
where "get_class cid (class\<^sub>T c_name subc attrs comps) =
|
|
(if cid = c_name then Some([],[],(class\<^sub>T c_name subc attrs comps))
|
|
else (case filter (\<lambda>X. X \<noteq> None) (map (get_class cid) subc) of
|
|
[] \<Rightarrow> None
|
|
| (Some(x,y,H) # _) \<Rightarrow> Some(attrs@x,comps@y,H)))"
|
|
|
|
|
|
subsection{* Objects and States *}
|
|
type_synonym object = "cid \<times> attribute_env \<times> (oid \<times> cid) list"
|
|
type_synonym state = "oid \<rightharpoonup> object"
|
|
|
|
fun remove_overrides :: "('\<alpha> \<Rightarrow> '\<beta>) \<Rightarrow> '\<alpha> list \<Rightarrow> '\<alpha> list"
|
|
where "remove_overrides f [] = []"
|
|
|"remove_overrides f (a#R) = (if f a \<in> set(map f R) then remove_overrides f R
|
|
else a # (remove_overrides f R))"
|
|
|
|
|
|
subsection{* Code-Generation *}
|
|
|
|
code_printing
|
|
type_constructor prod \<rightharpoonup> (SML) infix 2 "*"
|
|
| constant Pair \<rightharpoonup> (SML) "!((_),/ (_))"
|
|
|
|
|
|
code_printing
|
|
type_constructor bool \<rightharpoonup> (SML) "bool"
|
|
| constant True \<rightharpoonup> (SML) "true"
|
|
| constant False \<rightharpoonup> (SML) "false"
|
|
| constant "HOL.conj" \<rightharpoonup> (SML) infix 1 "_ andalso _"
|
|
|
|
|
|
(* todo: checker for "validity" of an object wrt to its class description *)
|
|
|
|
|
|
export_code mt classes all_attributes all_entities remove_overrides
|
|
(* replace_class_hierarchy get_class extend_class_hierarchy *) in SML
|
|
module_name MOF file "MOF.sml"
|
|
|
|
|
|
(* Hhm, a slightly more pragmatic approach to document types ... *)
|
|
|
|
|
|
|
|
end
|
|
|