Use a name space for Onto Classes
ci/woodpecker/push/build Pipeline failed Details

- Use a name space table to store ontological class objects
- Remove docclass_tab table and accesses
This commit is contained in:
Nicolas Méric 2023-02-14 17:57:53 +01:00
parent 55690bba33
commit 234ff18ec0
11 changed files with 241 additions and 320 deletions

View File

@ -350,8 +350,7 @@ is currently only available in the SML API's of the kernel.
| macro_command
\<close>
\<^item> \<^isadof> \<open>change_status_command\<close> :
\<^rail>\<open> (@@{command "update_instance*"} '[' upd_meta_args ']')
| (@@{command "declare_reference*"} (obj_id ('::' class_id)))\<close>
\<^rail>\<open> (@@{command "update_instance*"} '[' upd_meta_args ']')\<close>
\<^item> \<^isadof> \<open>inspection_command\<close> :
\<^rail>\<open> @@{command "print_doc_classes"}
| @@{command "print_doc_items"}

View File

@ -46,40 +46,42 @@ text\<open>
A plugin in Isabelle starts with defining the local data and registering it in the framework. As
mentioned before, contexts are structures with independent cells/compartments having three
primitives \<^boxed_sml>\<open>init\<close>, \<^boxed_sml>\<open>extend\<close> and \<^boxed_sml>\<open>merge\<close>. Technically this is done by
instantiating a functor \<^boxed_sml>\<open>Generic_Data\<close>, and the following fairly typical code-fragment
instantiating a functor \<^boxed_sml>\<open>Theory_Data\<close>, and the following fairly typical code-fragment
is drawn from \<^isadof>:
@{boxed_sml [display]
\<open>structure Data = Generic_Data
( type T = docobj_tab * docclass_tab * ...
val empty = (initial_docobj_tab, initial_docclass_tab, ...)
fun merge((d1,c1,...),(d2,c2,...)) = (merge_docobj_tab (d1,d2,...),
merge_docclass_tab(c1,c2,...))
);\<close>}
where the table \<^boxed_sml>\<open>docobj_tab\<close> manages document class instances
and \<^boxed_sml>\<open>docclass_tab\<close> the environment for class definitions
(inducing the inheritance relation). Other tables capture, \eg,
the class invariants, inner-syntax antiquotations. Operations follow the MVC-pattern, where
\<open>structure Onto_Classes = Theory_Data
(
type T = onto_class Name_Space.table;
val empty : T = Name_Space.empty_table onto_classN;
fun merge data : T = Name_Space.merge_tables data;
);\<close>}
where the table \<^boxed_sml>\<open>Name_Space.table\<close> manages
the environment for class definitions (\<^boxed_sml>\<open>onto_class\<close>), inducing the inheritance relation,
using a \<^boxed_sml>\<open>Name_Space\<close> table. Other tables capture, \eg,
the class instances, class invariants, inner-syntax antiquotations.
Operations follow the MVC-pattern, where
Isabelle/Isar provides the controller part. A typical model operation has the type:
@{boxed_sml [display]
\<open>val opn :: <args_type> -> Context.generic -> Context.generic\<close>}
representing a transformation on system contexts. For example, the operation of declaring a local
reference in the context is presented as follows:
\<open>val opn :: <args_type> -> theory -> theory\<close>}
representing a transformation on system contexts. For example, the operation of defining a class
in the context is presented as follows:
@{boxed_sml [display]
\<open>fun declare_object_local oid ctxt =
let fun decl {tab,maxano} = {tab=Symtab.update_new(oid,NONE) tab,
maxano=maxano}
in (Data.map(apfst decl)(ctxt)
handle Symtab.DUP _ =>
error("multiple declaration of document reference"))
end\<close>}
where \<^boxed_sml>\<open>Data.map\<close> is the update function resulting from the instantiation of the
functor \<^boxed_sml>\<open>Generic_Data\<close>. This code fragment uses operations from a library structure
\<^boxed_sml>\<open>Symtab\<close> that were used to update the appropriate table for document objects in
the plugin-local state. Possible exceptions to the update operation were mapped to a system-global
error reporting function.
\<open>fun add_onto_class name onto_class thy =
thy |> Onto_Classes.map
(Name_Space.define (Context.Theory thy) true (name, onto_class) #> #2);
\<close>}
This code fragment uses operations from the library structure \<^boxed_sml>\<open>Name_Space\<close>
that were used to update the appropriate table for document objects in
the plugin-local state.
A name space manages a collection of long names, together with a mapping
between partially qualified external names and fully qualified internal names
(in both directions).
It can also keep track of the declarations and updates position of objects,
and then allows a simple markup-generation.
Possible exceptions to the update operation are automatically triggered.
Finally, the view-aspects were handled by an API for parsing-combinators. The library structure
\<^boxed_sml>\<open>Scan\<close> provides the operators:
@ -120,7 +122,7 @@ val attributes =(Parse.$$$ "[" |-- (reference
new \emph{command}:
@{boxed_theory_text [display]\<open>
declare_reference [lal::requirement, alpha="main", beta=42]
declare_reference* [lal::requirement, alpha="main", beta=42]
\<close>}
The construction also generates implicitly some markup information; for example, when hovering

View File

@ -30,7 +30,7 @@ theory Isa_COL
"figure*" "side_by_side_figure*" :: document_body
begin
section\<open>Basic Text and Text-Structuring Elements\<close>
text\<open> The attribute @{term "level"} in the subsequent enables doc-notation support section* etc.
@ -92,8 +92,8 @@ local
fun transform_cid thy NONE X = X
|transform_cid thy (SOME ncid) NONE = (SOME(ncid,@{here}))
|transform_cid thy (SOME cid) (SOME (sub_cid,pos)) =
let val cid_long = DOF_core.read_cid_global thy cid
val sub_cid_long = DOF_core.read_cid_global thy sub_cid
let val cid_long = DOF_core.get_onto_class_name_global' cid thy
val sub_cid_long = DOF_core.get_onto_class_name_global' sub_cid thy
in if DOF_core.is_subclass_global thy sub_cid_long cid_long
then (SOME (sub_cid,pos))
else (* (SOME (sub_cid,pos)) *)
@ -146,7 +146,8 @@ datatype placement = pl_h | (*here*)
pl_ht | (*here -> top*)
pl_hb (*here -> bottom*)
ML\<open>(Symtab.defined (#docclass_tab(DOF_core.get_data_global @{theory}))) "side_by_side_figure"\<close>
ML\<open> "side_by_side_figure" |> Name_Space.declared (DOF_core.get_onto_classes \<^context>
|> Name_Space.space_of_table)\<close>
print_doc_classes

View File

@ -61,6 +61,7 @@ ML\<open>
val docrefN = "docref";
val docclassN = "doc_class";
val onto_classN = "onto_class";
(** name components **)
@ -146,23 +147,84 @@ ML\<open>
structure DOF_core =
struct
type virtual = {virtual : bool}
type docclass_struct = {params : (string * sort) list, (*currently not used *)
name : binding,
virtual : virtual,
thy_name : string, id : serial, (* for pide *)
inherits_from : (typ list * string) option, (* imports *)
attribute_decl : (binding*typ*term option)list, (* class local *)
rejectS : term list,
rex : term list,
invs : ((string * Position.T) * term) list } (* monitoring regexps --- product semantics*)
datatype onto_class = Onto_Class of
{params : (string * sort) list, (*currently not used *)
name : binding,
virtual : {virtual : bool},
thy_name : string, id : serial, (* for pide *)
inherits_from : (typ list * string) option, (* imports *)
attribute_decl : (binding*typ*term option)list, (* class local *)
rejectS : term list,
rex : term list,
invs : ((string * Position.T) * term) list } (* monitoring regexps --- product semantics*)
type docclass_tab = docclass_struct Symtab.table
fun make_onto_class (params, name, virtual, thy_name, id, inherits_from, attribute_decl
, rejectS, rex, invs) =
Onto_Class {params = params, name = name, virtual = virtual, thy_name = thy_name, id = id
, inherits_from = inherits_from, attribute_decl = attribute_decl, rejectS = rejectS
, rex = rex, invs = invs}
val initial_docclass_tab = Symtab.empty:docclass_tab
structure Onto_Classes = Theory_Data
(
type T = onto_class Name_Space.table;
val empty : T = Name_Space.empty_table onto_classN;
fun merge data : T = Name_Space.merge_tables data;
);
val get_onto_classes = Onto_Classes.get o Proof_Context.theory_of
fun get_onto_class_global name thy =
Name_Space.check (Context.Theory thy)
(get_onto_classes (Proof_Context.init_global thy)) (name, Position.none) |> #2
(* takes class synonyms into account *)
fun get_onto_class_global' name thy =
let val name' = name |> Syntax.read_typ_global thy
|> Syntax.string_of_typ_global thy
|> YXML.parse_body |> XML.content_of
in Name_Space.check (Context.Theory thy)
(get_onto_classes (Proof_Context.init_global thy)) (name', Position.none) |> #2
end
fun get_onto_class_name_global name thy =
Name_Space.check (Context.Theory thy)
(get_onto_classes (Proof_Context.init_global thy)) (name, Position.none) |> #1
(* takes class synonyms into account *)
fun get_onto_class_name_global' name thy =
let val name' = name |> Syntax.read_typ_global thy
|> Syntax.string_of_typ_global thy
|> YXML.parse_body |> XML.content_of
in Name_Space.check (Context.Theory thy)
(get_onto_classes (Proof_Context.init_global thy)) (name', Position.none) |> #1
end
fun check_onto_class ctxt =
#1 o Name_Space.check (Context.Proof ctxt) (get_onto_classes ctxt);
fun add_onto_class name onto_class thy =
thy |> Onto_Classes.map
(Name_Space.define (Context.Theory thy) true (name, onto_class) #> #2);
fun update_onto_class name onto_class thy =
thy |> Onto_Classes.map
(Name_Space.define (Context.Theory thy) false (name, onto_class) #> #2);
fun update_onto_class_entry name new_onto_class thy =
thy |> Onto_Classes.map
(Name_Space.map_table_entry name (fn _ => new_onto_class));
fun print_onto_classes verbose ctxt =
Pretty.big_list "Isabelle.DOF Onto_Classes:"
(map (Pretty.mark_str o #1) (Name_Space.markup_table verbose ctxt (get_onto_classes ctxt)))
|> Pretty.writeln;
fun the_onto_class T i =
(case Name_Space.lookup_key T i of
SOME entry => entry
| NONE => raise TYPE ("Unknown onto_class: " ^ quote i, [], []));
fun merge_docclass_tab (otab,otab') = Symtab.merge (op =) (otab,otab')
val tag_attr = (\<^binding>\<open>tag_attribute\<close>, \<^Type>\<open>int\<close>, Mixfix.NoSyn)
(* Attribute hidden to the user and used internally by isabelle_DOF.
@ -172,21 +234,22 @@ struct
val default_cid = "text" (* the top (default) document class: everything is a text.*)
fun is_subclass0 (tab:docclass_tab) s t =
let val _ = case Symtab.lookup tab t of
NONE => if t <> default_cid
then error ("document superclass not defined: "^t)
else default_cid
| SOME _ => ""
fun father_is_sub s = case Symtab.lookup tab s of
NONE => error ("document subclass not defined: "^s)
| SOME ({inherits_from=NONE, ...}) => s = t
| SOME ({inherits_from=SOME (_,s'), ...}) =>
s' = t orelse father_is_sub s'
in s = t orelse
(t = default_cid andalso Symtab.defined tab s ) orelse
(s <> default_cid andalso father_is_sub s)
end
fun is_subclass0 s t ctxt =
let fun get id = if id = default_cid
then default_cid
else check_onto_class ctxt (id, Position.none)
val s' = get s
val t' = get t
fun father_is_sub s = case get_onto_class_global s (Proof_Context.theory_of ctxt) of
(Onto_Class {inherits_from=NONE, ...}) => s' = t'
| (Onto_Class {inherits_from=SOME (_,s''), ...}) =>
s'' = t' orelse father_is_sub s''
val s'_defined = s' |> Name_Space.declared (get_onto_classes ctxt
|> Name_Space.space_of_table)
in s' = t' orelse
(t' = default_cid andalso s'_defined) orelse
(s' <> default_cid andalso father_is_sub s')
end
datatype instance = Instance of
@ -479,28 +542,6 @@ struct
| NONE => raise TYPE ("Unknown monitor_info: " ^ quote i, [], []));
fun override(t1,t2) = fold(Symtab.update)(Symtab.dest t2)(t1)
(* registrating data of the Isa_DOF component *)
structure Data = Generic_Data
(
type T = {docclass_tab : docclass_tab}
val empty = {docclass_tab = initial_docclass_tab}
fun merge( {docclass_tab = c1},
{docclass_tab = c2}) =
{docclass_tab = merge_docclass_tab (c1,c2) }
);
val get_data = Data.get o Context.Proof;
val map_data = Data.map;
val get_data_global = Data.get o Context.Theory;
val map_data_global = Context.theory_map o map_data;
fun upd_docclass_tab f {docclass_tab = y} =
{docclass_tab = f y};
fun get_accepted_cids (Monitor_Info {accepted_cids, ... }) = accepted_cids
fun get_rejected_cids (Monitor_Info {rejected_cids, ... }) = rejected_cids
fun get_alphabet monitor_info = (get_accepted_cids monitor_info) @ (get_rejected_cids monitor_info)
@ -518,8 +559,9 @@ fun get_automatas (Monitor_Info {automatas, ... }) = automatas
However, we use Syntax.read_typ in order to allow type-synonyms which requires
an appropriate adaption in read_cid.*)
fun is_subclass (ctxt) s t = is_subclass0(#docclass_tab(get_data ctxt)) s t
fun is_subclass_global thy s t = is_subclass0(#docclass_tab(get_data_global thy)) s t
fun is_subclass (ctxt) s t = is_subclass0 s t ctxt
fun is_subclass_global thy s t = let val ctxt = Proof_Context.init_global thy
in is_subclass0 s t ctxt end
fun typ_to_cid (Type(s,[\<^Type>\<open>unit\<close>])) = Long_Name.qualifier s
@ -527,63 +569,13 @@ fun typ_to_cid (Type(s,[\<^Type>\<open>unit\<close>])) = Long_Name.qualifier s
|typ_to_cid _ = error("type is not an ontological type.")
fun parse_cid ctxt cid =
(* parses a type lexically/syntactically, checks absence of type vars *)
(case Syntax.parse_typ ctxt cid of
Type(tyname, []) => tyname
| _ => error "illegal type-format for doc-class-name.")
handle ERROR _ => "" (* ignore error *)
fun get_onto_class_name_super_class_global _ "text" = default_cid
| get_onto_class_name_super_class_global thy cid = get_onto_class_name_global' cid thy
fun read_cid ctxt "text" = default_cid (* text = default_cid *)
| read_cid ctxt cid =
(* parses a type syntactically, type-identification, checking as class id *)
(case Syntax.read_typ ctxt cid of
ty as Type(tyname, _) => let val res = typ_to_cid ty
val t = #docclass_tab(get_data ctxt)
in if Symtab.defined t res
then res
else error("type identifier not a class id:"^res)
end
| _ => error "illegal type-format for doc-class-name.")
handle ERROR _ => error("type identifier not a class id:"^cid)
fun parse_cid_global thy cid = parse_cid (Proof_Context.init_global thy) cid
fun read_cid_global thy cid = read_cid (Proof_Context.init_global thy) cid
fun is_defined_cid_global cid thy =
(* works with short and long names *)
let val t = #docclass_tab(get_data_global thy)
in cid=default_cid orelse
Symtab.defined t (parse_cid_global thy cid)
end
fun is_defined_cid_global' cid_long thy =
(* works with long names only *)
let val t = #docclass_tab(get_data_global thy)
in cid_long=default_cid orelse Symtab.defined t cid_long end
fun is_defined_cid_local cid ctxt =
(* works with short and long names *)
let val t = #docclass_tab(get_data ctxt)
in cid=default_cid orelse
Symtab.defined t (parse_cid ctxt cid)
end
fun is_defined_cid_local' cid_long ctxt =
(* works with long names only *)
let val t = #docclass_tab(get_data ctxt)
in cid_long=default_cid orelse Symtab.defined t cid_long end
fun is_virtual cid thy = let val tab = (#docclass_tab(get_data_global thy))
(* takes class synonyms into account *)
val long_name = read_cid_global thy cid
in case Symtab.lookup tab long_name of
NONE => error("Undefined class id: " ^ cid)
| SOME ({virtual=virtual, ...}) => #virtual virtual
end
fun is_virtual cid thy =
let val Onto_Class {virtual, ...} = get_onto_class_global' cid thy
in virtual |> #virtual end
val SPY = Unsynchronized.ref(Bound 0)
@ -598,7 +590,7 @@ fun check_regexps term =
(* Missing: Checks on constants such as undefined, ... *)
in term end
fun check_reject_atom cid_long term =
fun check_reject_atom term =
let val _ = case fold_aterms Term.add_free_names term [] of
n::_ => error("No free variables allowed in monitor regexp:" ^ n)
| _ => ()
@ -616,23 +608,15 @@ fun define_doc_class_global (params', binding) parent fields rexp reject_Atoms i
the space where it is ... *)
val cid = (Binding.name_of binding)
val pos = (Binding.pos_of binding)
val _ = if is_defined_cid_global cid thy
(*val _ = if is_defined_cid_global cid thy
then error("redefinition of document class:"^cid )
else ()
val parent' = map_option (map_snd (read_cid_global thy)) parent
(* weird construction. Necessary since parse produces at rare cases
string representations that do no longer have the lexis of a type name. *)
val cid_long = parse_cid_global thy cid
val cid_long' = parse_cid_global thy cid_long
val _ = if cid_long' <> "" then ()
else error("Could not construct type from doc_class (lexical problem?)")
else ()*)
(* takes class synonyms into account *)
val parent' = map_option (map_snd (fn x => get_onto_class_name_global' x thy)) parent
val id = serial ();
val _ = Position.report pos (docclass_markup true cid id pos);
val rejectS = map (Syntax.read_term_global thy) reject_Atoms;
val _ = map (check_reject_atom cid_long) rejectS;
val _ = map (check_reject_atom) rejectS;
val reg_exps = map (Syntax.read_term_global thy) rexp;
val _ = map check_regexps reg_exps
val _ = if not(null rejectS) andalso (null reg_exps)
@ -641,20 +625,8 @@ fun define_doc_class_global (params', binding) parent fields rexp reject_Atoms i
then error("invariant labels must be unique"^ Position.here (snd(fst(hd invs))))
else ()
val invs' = map (map_snd(Syntax.read_term_global thy)) invs
val info = {params=params',
name = binding,
virtual = virtual,
thy_name = nn,
id = id, (* for pide --- really fresh or better reconstruct
from prior record definition ? For the moment: own
generation of serials ... *)
inherits_from = parent',
attribute_decl = fields ,
rejectS = rejectS,
rex = reg_exps,
invs = invs'}
in map_data_global(upd_docclass_tab(Symtab.update(cid_long,info)))(thy)
in thy |> add_onto_class binding (make_onto_class (params', binding, virtual, nn, id, parent'
, fields, rejectS, reg_exps, invs'))
end
fun define_object_global {define = define} ((oid, pos), bbb) thy =
@ -678,33 +650,16 @@ fun define_object_global {define = define} ((oid, pos), bbb) thy =
else add_instance binding (Instance bbb) thy
end
fun get_doc_class_global cid thy =
if cid = default_cid then error("default class access") (* TODO *)
else let val t = #docclass_tab(get_data_global thy)
in (Symtab.lookup t cid) end
fun get_doc_class_local cid ctxt =
if cid = default_cid then error("default class access") (* TODO *)
else let val t = #docclass_tab(get_data ctxt)
in (Symtab.lookup t cid) end
fun is_defined_cid_local cid ctxt = let val t = #docclass_tab(get_data ctxt)
in cid=default_cid orelse
Symtab.defined t (parse_cid ctxt cid)
end
fun get_attributes_local cid ctxt =
if cid = default_cid then []
else let val t = #docclass_tab(get_data ctxt)
val cid_long = read_cid ctxt cid (* to assure that the given cid is really a long_cid *)
in case Symtab.lookup t cid_long of
NONE => error("undefined class id for attributes: "^cid)
| (SOME ({inherits_from=NONE,
attribute_decl = X, ...})) => [(cid_long,X)]
| (SOME ({inherits_from=SOME(_,father),
attribute_decl = X, ...})) =>
else let val cid_long = get_onto_class_name_global cid (Proof_Context.theory_of ctxt)
in
case get_onto_class_global cid (Proof_Context.theory_of ctxt) of
Onto_Class {inherits_from=NONE,
attribute_decl = X, ...} => [(cid_long,X)]
| Onto_Class {inherits_from=SOME(_,father),
attribute_decl = X, ...} =>
get_attributes_local father ctxt @ [(cid_long,X)]
end
@ -754,15 +709,21 @@ fun get_value_local oid ctxt =
(* missing : setting terms to ground (no type-schema vars, no schema vars. )*)
fun binding_from_instance_pos name thy =
fun binding_from_pos get_objects get_objects_name name thy =
let
val ns = get_instances (Proof_Context.init_global thy)
val ns = get_objects (Proof_Context.init_global thy)
|> Name_Space.space_of_table
val {pos, ...} = Name_Space.the_entry ns (get_instance_name_global name thy)
val {pos, ...} = Name_Space.the_entry ns (get_objects_name name thy)
in if Long_Name.is_qualified name
then Binding.make (Long_Name.base_name name, pos)
else Binding.make (name, pos)end
fun binding_from_onto_class_pos name thy =
binding_from_pos get_onto_classes get_onto_class_name_global name thy
fun binding_from_instance_pos name thy =
binding_from_pos get_instances get_instance_name_global name thy
fun update_value_global name upd_value thy =
let
val binding = binding_from_instance_pos name thy
@ -792,17 +753,6 @@ fun get_class_name_without_prefix s = String.extract (s, String.size(doc_class_p
fun get_doc_class_name_without_ISA_prefix s = String.extract (s, String.size(ISA_prefix), NONE)
fun is_class_ISA thy s = let val bname = Long_Name.base_name s
val qual = Long_Name.qualifier s
in
if String.isPrefix doc_class_prefix bname then
let
val class_name =
Long_Name.qualify qual (get_class_name_without_prefix bname)
in
is_defined_cid_global (class_name) thy end
else false end
fun transduce_term_global {mk_elaboration=mk_elaboration} (term,pos) thy =
(* pre: term should be fully typed in order to allow type-related term-transformations *)
@ -845,23 +795,19 @@ fun check_term ctxt term = transduce_term_global {mk_elaboration=false}
(term , Position.none)
(Proof_Context.theory_of ctxt)
fun writeln_classrefs ctxt = let val tab = #docclass_tab(get_data ctxt)
in writeln (String.concatWith "," (Symtab.keys tab)) end
fun print_doc_class_tree ctxt P T =
let val {docclass_tab, ...} = get_data ctxt;
val class_tab:(string * docclass_struct)list = (Symtab.dest docclass_tab)
fun is_class_son X (n, dc:docclass_struct) = (X = #inherits_from dc)
fun tree lev ([]:(string * docclass_struct)list) = ""
|tree lev ((n,R)::S) = (if P(lev,n)
let val classes = Name_Space.dest_table (get_onto_classes ctxt)
fun is_class_son X (_, onto_class) =
let val Onto_Class inherits_from = onto_class
in (inherits_from |> #inherits_from) = X end
fun tree _ [] = ""
|tree lev ((n,_)::S) = (if P(lev,n)
then "."^Int.toString lev^" "^(T n)^"{...}.\n"
^ (tree(lev + 1)(filter(is_class_son(SOME([],n)))class_tab))
^ (tree(lev + 1)(filter(is_class_son(SOME([],n))) classes))
else "."^Int.toString lev^" ... \n")
^ (tree lev S)
val roots = filter(is_class_son NONE) class_tab
val roots = filter(is_class_son NONE) classes
in ".0 .\n" ^ tree 1 roots end
val (object_value_debug, object_value_debug_setup)
@ -1169,7 +1115,7 @@ fun elaborate_instances_list thy isa_name _ _ pos =
val base_name' = DOF_core.get_class_name_without_prefix (base_name_without_suffix)
val class_typ = Proof_Context.read_typ (Proof_Context.init_global thy)
(base_name')
val long_class_name = DOF_core.read_cid_global thy base_name'
val long_class_name = DOF_core.get_onto_class_name_global base_name' thy
val values = thy |> Proof_Context.init_global |> DOF_core.get_instances
|> Name_Space.dest_table
|> filter (fn (_, instance) =>
@ -1231,7 +1177,7 @@ fun compute_attr_access ctxt attr oid pos_option pos' = (* template *)
| SOME pos =>
let
val class_name = Long_Name.qualifier long_name
val SOME{id,...} = DOF_core.get_doc_class_local class_name ctxt'
val DOF_core.Onto_Class {id,...} = DOF_core.get_onto_class_global class_name thy
val class_markup = docclass_markup false class_name id def_pos
in Context_Position.report ctxt' pos class_markup end
in symbex_attr_access0 ctxt' proj_term value end
@ -1245,7 +1191,7 @@ case term_option of
val traces = compute_attr_access (Context.Theory thy) "trace" oid NONE pos
fun conv (\<^Const>\<open>Pair \<^typ>\<open>doc_class rexp\<close> \<^typ>\<open>string\<close>\<close>
$ (\<^Const>\<open>Atom \<^typ>\<open>doc_class\<close>\<close> $ (\<^Const>\<open>mk\<close> $ s)) $ S) =
let val s' = DOF_core.read_cid (Proof_Context.init_global thy) (HOLogic.dest_string s)
let val s' = DOF_core.get_onto_class_name_global (HOLogic.dest_string s) thy
in \<^Const>\<open>Pair \<^typ>\<open>string\<close> \<^typ>\<open>string\<close>\<close> $ HOLogic.mk_string s' $ S end
val traces' = map conv (HOLogic.dest_list traces)
in HOLogic.mk_list \<^Type>\<open>prod \<^typ>\<open>string\<close> \<^typ>\<open>string\<close>\<close> traces' end
@ -1470,16 +1416,11 @@ struct
fun cid_2_cidType cid_long thy =
if cid_long = DOF_core.default_cid then \<^Type>\<open>unit\<close>
else let val t = #docclass_tab(DOF_core.get_data_global thy)
fun ty_name cid = cid^"."^ Long_Name.base_name cid ^ Record.extN
fun fathers cid_long = case Symtab.lookup t cid_long of
NONE => let val ctxt = Proof_Context.init_global thy
val tty = Syntax.parse_typ (Proof_Context.init_global thy) cid_long
in error("undefined doc class id :"^cid_long)
end
| SOME ({inherits_from=NONE, ...}) => [cid_long]
| SOME ({inherits_from=SOME(_,father), ...}) =>
cid_long :: (fathers father)
else let fun ty_name cid = cid^"."^ Long_Name.base_name cid ^ Record.extN
fun fathers cid_long = case DOF_core.get_onto_class_global cid_long thy of
DOF_core.Onto_Class {inherits_from=NONE, ...} => [cid_long]
| DOF_core.Onto_Class {inherits_from=SOME(_,father), ...} =>
cid_long :: (fathers father)
in fold (fn x => fn y => Type(ty_name x,[y])) (fathers cid_long) \<^Type>\<open>unit\<close>
end
@ -1513,9 +1454,9 @@ fun create_default_object thy class_name =
fun check_classref {is_monitor=is_monitor} (SOME(cid,pos)) thy =
let
val cid_long = DOF_core.read_cid_global thy cid
val {id, name=bind_target,rex,...} = the(DOF_core.get_doc_class_global cid_long thy)
val cid_long = DOF_core.get_onto_class_name_global' cid thy
val DOF_core.Onto_Class {id, name=bind_target,rex,...} =
DOF_core.get_onto_class_global cid_long thy
val _ = if is_monitor andalso (null rex orelse cid_long= DOF_core.default_cid )
then error("should be monitor class!")
else ()
@ -1542,8 +1483,8 @@ fun calc_update_term {mk_elaboration=mk_elaboration} thy cid_long
let
fun get_class_name parent_cid attribute_name pos =
let
val {attribute_decl, inherits_from, ...} =
the (DOF_core.get_doc_class_global parent_cid thy)
val DOF_core.Onto_Class {attribute_decl, inherits_from, ...} =
DOF_core.get_onto_class_global parent_cid thy
in
if exists (fn (binding, _, _) => Binding.name_of binding = attribute_name)
attribute_decl
@ -1558,7 +1499,8 @@ fun calc_update_term {mk_elaboration=mk_elaboration} thy cid_long
val _ = if mk_elaboration
then
let val attr_defined_cid = get_class_name cid_long lhs pos
val {id, name, ...} = the (DOF_core.get_doc_class_global attr_defined_cid thy)
val DOF_core.Onto_Class {id, name, ...} =
DOF_core.get_onto_class_global attr_defined_cid thy
val markup = docclass_markup false cid_long id (Binding.pos_of name);
val ctxt = Context.Theory thy
in Context_Position.report_generic ctxt pos markup end
@ -1708,10 +1650,10 @@ fun check_invariants thy (oid, pos) =
val DOF_core.Instance params = DOF_core.get_instance_global oid thy
val cid = #cid params
fun get_all_invariants cid thy =
case DOF_core.get_doc_class_global cid thy of
NONE => error("undefined class id for invariants: " ^ cid)
| SOME ({inherits_from=NONE, invs, ...}) => invs
| SOME ({inherits_from=SOME(_,father), invs, ...}) => (invs) @ (get_all_invariants father thy)
case DOF_core.get_onto_class_global cid thy of
DOF_core.Onto_Class {inherits_from=NONE, invs, ...} => invs
| DOF_core.Onto_Class {inherits_from=SOME(_,father), invs, ...} =>
(invs) @ (get_all_invariants father thy)
val invariants = get_all_invariants cid thy
val inv_and_apply_list =
let fun mk_inv_and_apply inv value thy =
@ -1778,13 +1720,13 @@ fun check_invariants thy (oid, pos) =
fun create_and_check_docitem is_monitor {is_inline=is_inline} {define=define} oid pos cid_pos doc_attrs thy =
let
val id = serial ();
val id = serial ();
val cid_pos' = check_classref is_monitor cid_pos thy
val cid_long = fst cid_pos'
val default_cid = cid_long = DOF_core.default_cid
val vcid = case cid_pos of NONE => NONE
| SOME (cid,_) => if (DOF_core.is_virtual cid thy)
then SOME (DOF_core.parse_cid_global thy cid)
then SOME (DOF_core.get_onto_class_name_global' cid thy)
else NONE
val value_terms = if default_cid
then let
@ -2058,14 +2000,10 @@ fun open_monitor_command ((((oid, pos),cid_pos), doc_attrs) : ODL_Meta_Args_Par
oid pos cid_pos doc_attrs thy
fun compute_enabled_set cid thy =
let
val long_cid = DOF_core.read_cid (Proof_Context.init_global thy) cid
in
case DOF_core.get_doc_class_global long_cid thy of
SOME X => let val ralph = RegExpInterface.alphabet (#rejectS X)
val aalph = RegExpInterface.alphabet (#rex X)
in (aalph, ralph, map (RegExpInterface.rexp_term2da aalph)(#rex X)) end
| NONE => error("Internal error: class id undefined. ")
end
val DOF_core.Onto_Class X = DOF_core.get_onto_class_global' cid thy
val ralph = RegExpInterface.alphabet (#rejectS X)
val aalph = RegExpInterface.alphabet (#rex X)
in (aalph, ralph, map (RegExpInterface.rexp_term2da aalph)(#rex X)) end
fun create_monitor_entry oid thy =
let val cid = case cid_pos of
NONE => ISA_core.err ("You must specified a monitor class.") pos
@ -2135,7 +2073,7 @@ fun meta_args_2_latex thy ((((lab, pos), cid_opt), attr_list) : ODL_Meta_Args_Pa
DOF_core.get_instance_global lab thy
in cid |> #cid end
| SOME(cid,_) => DOF_core.parse_cid_global thy cid
| SOME(cid,_) => DOF_core.get_onto_class_name_global' cid thy
(* val _ = writeln("meta_args_2_string cid_long:"^ cid_long ) *)
val cid_txt = "type = " ^ (enclose "{" "}" cid_long);
@ -2279,13 +2217,14 @@ end (* structure Monitor_Command_Parser *)
ML\<open>
fun print_doc_classes b ctxt =
let val {docclass_tab, ...} = DOF_core.get_data ctxt;
let val classes = Name_Space.dest_table (DOF_core.get_onto_classes ctxt)
val _ = writeln "=====================================";
fun print_attr (n, ty, NONE) = (Binding.print n)
| print_attr (n, ty, SOME t)= (Binding.print n^"("^Syntax.string_of_term ctxt t^")")
fun print_inv ((lab,pos),trm) = (lab ^"::"^Syntax.string_of_term ctxt trm)
fun print_virtual {virtual} = Bool.toString virtual
fun print_class (n, {attribute_decl, id, inherits_from, name, virtual, params, thy_name, rejectS, rex,invs}) =
fun print_class (n, DOF_core.Onto_Class {attribute_decl, id, inherits_from, name, virtual
, params, thy_name, rejectS, rex,invs}) =
(case inherits_from of
NONE => writeln ("docclass: "^n)
| SOME(_,nn) => writeln ("docclass: "^n^" = "^nn^" + ");
@ -2295,7 +2234,7 @@ fun print_doc_classes b ctxt =
writeln (" attrs: "^commas (map print_attr attribute_decl));
writeln (" invs: "^commas (map print_inv invs))
);
in map print_class (Symtab.dest docclass_tab);
in map print_class classes;
writeln "=====================================\n\n\n"
end;
@ -2304,7 +2243,8 @@ val _ =
(Parse.opt_bang >> (fn b => Toplevel.keep (print_doc_classes b o Toplevel.context_of)));
fun print_docclass_template cid ctxt =
let val cid_long = DOF_core.read_cid ctxt cid (* assure that given cid is really a long_cid *)
let (* takes class synonyms into account *)
val cid_long = DOF_core.get_onto_class_name_global' cid (Proof_Context.theory_of ctxt)
val brute_hierarchy = (DOF_core.get_attributes_local cid_long ctxt)
val flatten_hrchy = flat o (map(fn(lname, attrS) =>
map (fn (s,_,_)=>(lname,(Binding.name_of s))) attrS))
@ -2410,7 +2350,7 @@ fun meta_args_2_string thy ((((lab, pos), cid_opt), attr_list) : ODL_Meta_Args_P
NONE => let val DOF_core.Instance cid =
DOF_core.get_instance_global lab thy
in cid |> #cid end
| SOME(cid,_) => DOF_core.parse_cid_global thy cid
| SOME(cid,_) => DOF_core.get_onto_class_name_global cid thy
(* val _ = writeln("meta_args_2_string cid_long:"^ cid_long ) *)
val cid_txt = "type = " ^ (enclose "{" "}" cid_long);
@ -2586,7 +2526,7 @@ fun compute_trace_ML ctxt oid pos_opt pos' =
let val term = ISA_core.compute_attr_access ctxt "trace" oid pos_opt pos'
fun conv (\<^Const>\<open>Pair \<^typ>\<open>doc_class rexp\<close> \<^typ>\<open>string\<close>\<close>
$ (\<^Const>\<open>Atom \<^typ>\<open>doc_class\<close>\<close> $ (\<^Const>\<open>mk\<close> $ s)) $ S) =
let val s' = DOF_core.read_cid (Context.proof_of ctxt) (HOLogic.dest_string s)
let val s' = DOF_core.get_onto_class_name_global (HOLogic.dest_string s) (Context.theory_of ctxt)
in (s', HOLogic.dest_string S) end
in map conv (HOLogic.dest_list term) end
@ -2634,8 +2574,8 @@ fun trace_attr_2_ML ctxt (oid:string,pos) =
in toML (compute_trace_ML ctxt oid NONE pos) end
fun compute_cid_repr ctxt cid pos =
if DOF_core.is_defined_cid_local cid ctxt then Const(cid,dummyT)
else ISA_core.err ("Undefined Class Identifier:"^cid) pos
let val _ = DOF_core.get_onto_class_name_global cid (Proof_Context.theory_of ctxt)
in Const(cid,dummyT) end
fun compute_name_repr ctxt oid pos =
let val instances = DOF_core.get_instances ctxt
@ -2767,7 +2707,8 @@ fun define_inv cid_long ((lbl, pos), inv) thy =
(Const (s, Type (st,[ty, ty'])) $ t) =
let
val cid = Long_Name.qualifier s
in case DOF_core.get_doc_class_global cid thy of
in case Name_Space.lookup
(DOF_core.get_onto_classes (Proof_Context.init_global thy)) cid of
NONE => Const (s, Type(st,[ty, ty']))
$ (update_attribute_type thy class_scheme_ty cid_long t)
| SOME _ => if DOF_core.is_subclass_global thy cid_long cid
@ -2801,15 +2742,18 @@ fun define_inv cid_long ((lbl, pos), inv) thy =
fun add_doc_class_cmd overloaded (raw_params, binding)
raw_parent raw_fieldsNdefaults reject_Atoms regexps invariants thy =
let
let
val ctxt = Proof_Context.init_global thy;
val params = map (apsnd (Typedecl.read_constraint ctxt)) raw_params;
val ctxt1 = fold (Variable.declare_typ o TFree) params ctxt;
fun cid thy = DOF_core.parse_cid_global thy (Binding.name_of binding)
fun cid thy = (* takes class synonyms into account *)
DOF_core.get_onto_class_name_global' (Binding.name_of binding) thy
val (parent, ctxt2) = read_parent raw_parent ctxt1;
val parent_cid_long = map_optional snd DOF_core.default_cid parent;
(* takes class synonyms into account *)
val parent' = map_option (map_snd (K (DOF_core.read_cid_global thy parent_cid_long))) parent
val parent' = map_option
(map_snd (K (DOF_core.get_onto_class_name_super_class_global thy parent_cid_long)))
parent
val parent'_cid_long = map_optional snd DOF_core.default_cid parent';
val raw_fieldsNdefaults' = filter (fn((bi,_,_),_) => Binding.name_of bi <> "trace")
raw_fieldsNdefaults

View File

@ -1033,10 +1033,8 @@ fun check_sil oid _ ctxt =
setup\<open>
(fn thy =>
let val ctxt = Proof_Context.init_global thy
val binding = let val cid = DOF_core.read_cid ctxt "monitor_SIL0"
in the ((DOF_core.get_data ctxt |> #docclass_tab |> Symtab.lookup) cid)
|> #name end
in DOF_core.add_ml_invariant binding check_sil thy end)
val binding = DOF_core.binding_from_onto_class_pos "monitor_SIL0" thy
in DOF_core.add_ml_invariant binding check_sil thy end)
\<close>
text\<open>
@ -1076,10 +1074,8 @@ fun check_sil_slow oid _ ctxt =
(*setup\<open>
(fn thy =>
let val ctxt = Proof_Context.init_global thy
val binding = let val cid = DOF_core.read_cid ctxt "monitor_SIL0"
in the ((DOF_core.get_data ctxt |> #docclass_tab |> Symtab.lookup) cid)
|> #name end
in DOF_core.add_ml_invariant binding check_sil_slow thy end)
val binding = DOF_core.binding_from_onto_class_pos "monitor_SIL0" thy
in DOF_core.add_ml_invariant binding check_sil_slow thy end)
\<close>*)
(* As traces of monitor instances (docitems) are updated each time an instance is declared
@ -1111,12 +1107,10 @@ fun check_required_documents oid _ ctxt =
\<close>
setup\<open>
(fn thy =>
fn thy =>
let val ctxt = Proof_Context.init_global thy
val binding = let val cid = DOF_core.read_cid ctxt "monitor_SIL0"
in the ((DOF_core.get_data ctxt |> #docclass_tab |> Symtab.lookup) cid)
|> #name end
in DOF_core.add_closing_ml_invariant binding check_required_documents thy end)
val binding = DOF_core.binding_from_onto_class_pos "monitor_SIL0" thy
in DOF_core.add_closing_ml_invariant binding check_required_documents thy end
\<close>
(* Test pattern matching for the records of the current CENELEC implementation classes,
@ -1281,10 +1275,10 @@ section\<open> META : Testing and Validation \<close>
text\<open>Test : @{semi_formal_content \<open>COTS\<close>}\<close>
ML
\<open> DOF_core.read_cid_global @{theory} "requirement";
DOF_core.read_cid_global @{theory} "SRAC";
DOF_core.is_defined_cid_global "SRAC" @{theory};
DOF_core.is_defined_cid_global "EC" @{theory}; \<close>
\<open> DOF_core.get_onto_class_name_global "requirement" @{theory};
DOF_core.get_onto_class_name_global "SRAC" @{theory};
DOF_core.get_onto_class_global "SRAC" @{theory};
DOF_core.get_onto_class_global "EC" @{theory}; \<close>
ML
\<open> DOF_core.is_subclass @{context} "CENELEC_50128.EC" "CENELEC_50128.EC";
@ -1294,15 +1288,15 @@ ML
ML
\<open> val ref_tab = DOF_core.get_instances \<^context>
val {docclass_tab=class_tab,...} = DOF_core.get_data @{context};
val docclass_tab = DOF_core.get_onto_classes @{context};
Name_Space.dest_table ref_tab;
Symtab.dest class_tab; \<close>
Name_Space.dest_table docclass_tab; \<close>
ML
\<open> val internal_data_of_SRAC_definition = DOF_core.get_attributes_local "SRAC" @{context} \<close>
ML
\<open> DOF_core.read_cid_global @{theory} "requirement";
\<open> DOF_core.get_onto_class_name_global "requirement" @{theory};
Syntax.parse_typ @{context} "requirement";
val Type(t,_) = Syntax.parse_typ @{context} "requirement" handle ERROR _ => dummyT;
Syntax.read_typ @{context} "hypothesis" handle _ => dummyT;

View File

@ -495,9 +495,7 @@ let val cidS = ["scholarly_paper.introduction","scholarly_paper.technical",
"scholarly_paper.example", "scholarly_paper.conclusion"];
fun body moni_oid _ ctxt = (Scholarly_paper_trace_invariant.check ctxt cidS moni_oid NONE; true)
val ctxt = Proof_Context.init_global thy
val binding = let val cid = DOF_core.read_cid ctxt "article"
in the ((DOF_core.get_data ctxt |> #docclass_tab |> Symtab.lookup) cid)
|> #name end
val binding = DOF_core.binding_from_onto_class_pos "article" thy
in DOF_core.add_ml_invariant binding body thy end)
\<close>

View File

@ -75,10 +75,7 @@ let fun check_invariant_invariant oid {is_monitor:bool} ctxt =
else error("class class invariant violation")
| _ => false
end
val ctxt = Proof_Context.init_global thy
val binding = let val cid = DOF_core.read_cid ctxt "result"
in the ((DOF_core.get_data ctxt |> #docclass_tab |> Symtab.lookup) cid)
|> #name end
val binding = DOF_core.binding_from_onto_class_pos "result" thy
in DOF_core.add_ml_invariant binding check_invariant_invariant thy end
\<close>
@ -177,9 +174,7 @@ let val cidS = ["small_math.introduction","small_math.technical", "small_math.co
fun body moni_oid _ ctxt = (Small_Math_trace_invariant.check ctxt cidS moni_oid NONE;
true)
val ctxt = Proof_Context.init_global thy
val binding = let val cid = DOF_core.read_cid ctxt "article"
in the ((DOF_core.get_data ctxt |> #docclass_tab |> Symtab.lookup) cid)
|> #name end
val binding = DOF_core.binding_from_onto_class_pos "article" thy
in DOF_core.add_ml_invariant binding body thy end
\<close>

View File

@ -27,9 +27,9 @@ print_doc_items
ML\<open>
val docitem_tab = DOF_core.get_instances \<^context>
val isa_transformer_tab = DOF_core.get_isa_transformers \<^context>
val {docclass_tab, ...} = DOF_core.get_data @{context};
val docclass_tab = DOF_core.get_onto_classes @{context};
Name_Space.dest_table docitem_tab;
Symtab.dest docclass_tab;
Name_Space.dest_table docclass_tab;
\<close>
ML\<open>
val (oid, DOF_core.Instance {value, ...}) =
@ -176,11 +176,6 @@ section\<open>Simulation of a Monitor\<close>
declare[[free_class_in_monitor_checking]]
ML\<open>
val thy = \<^theory>
val long_cid = "Isa_COL.figure_group"
val t = DOF_core.get_doc_class_global long_cid thy
\<close>
open_monitor*[figs1::figure_group,
caption="''Sample ''"]
ML\<open>val monitor_infos = DOF_core.get_monitor_infos \<^context>\<close>

View File

@ -37,9 +37,7 @@ text\<open>Setting a sample invariant, which simply produces some side-effect:\<
setup\<open>
fn thy =>
let val ctxt = Proof_Context.init_global thy
val binding = let val cid = DOF_core.read_cid ctxt "A"
in the ((DOF_core.get_data ctxt |> #docclass_tab |> Symtab.lookup) cid)
|> #name end
val binding = DOF_core.binding_from_onto_class_pos "A" thy
in DOF_core.add_ml_invariant binding (fn oid =>
fn {is_monitor = b} =>
fn ctxt =>
@ -56,10 +54,7 @@ let fun check_A_invariant oid {is_monitor:bool} ctxt =
let val term = ISA_core.compute_attr_access ctxt "x" oid NONE @{here}
val (@{typ "int"},x_value) = HOLogic.dest_number term
in if x_value > 5 then error("class A invariant violation") else true end
val ctxt = Proof_Context.init_global thy
val binding = let val cid = DOF_core.read_cid ctxt "A"
in the ((DOF_core.get_data ctxt |> #docclass_tab |> Symtab.lookup) cid)
|> #name end
val binding = DOF_core.binding_from_onto_class_pos "A" thy
in DOF_core.add_ml_invariant binding check_A_invariant thy end
\<close>
@ -96,7 +91,7 @@ let fun check_M_invariant oid {is_monitor} ctxt =
let val term = ISA_core.compute_attr_access ctxt "trace" oid NONE @{here}
fun conv (\<^Const>\<open>Pair \<^typ>\<open>doc_class rexp\<close> \<^typ>\<open>string\<close>\<close>
$ (\<^Const>\<open>Atom \<^typ>\<open>doc_class\<close>\<close> $ (\<^Const>\<open>mk\<close> $ s)) $ S) =
let val s' = DOF_core.read_cid (Context.proof_of ctxt) (HOLogic.dest_string s)
let val s' = DOF_core.get_onto_class_name_global' (HOLogic.dest_string s) thy
in (s', HOLogic.dest_string S) end
val string_pair_list = map conv (HOLogic.dest_list term)
val cid_list = map fst string_pair_list
@ -106,10 +101,7 @@ let fun check_M_invariant oid {is_monitor} ctxt =
val n = length (filter is_C cid_list)
val m = length (filter is_D cid_list)
in if m > n then error("class M invariant violation") else true end
val ctxt = Proof_Context.init_global thy
val binding = let val cid = DOF_core.read_cid ctxt "M"
in the ((DOF_core.get_data ctxt |> #docclass_tab |> Symtab.lookup) cid)
|> #name end
val binding = DOF_core.binding_from_onto_class_pos "M" thy
in DOF_core.add_ml_invariant binding check_M_invariant thy end
\<close>
@ -138,7 +130,8 @@ ML\<open>val ctxt = @{context}
fun conv (Const(@{const_name "Pair"},_) $ Const(s,_) $ S) = (s, HOLogic.dest_string S)
fun conv' (\<^Const>\<open>Pair \<^typ>\<open>doc_class rexp\<close> \<^typ>\<open>string\<close>\<close>
$ (\<^Const>\<open>Atom \<^typ>\<open>doc_class\<close>\<close> $ (\<^Const>\<open>mk\<close> $ s)) $ S) =
let val s' = DOF_core.read_cid ctxt (HOLogic.dest_string s)
let val s' = DOF_core.get_onto_class_name_global' (HOLogic.dest_string s)
(Proof_Context.theory_of ctxt)
in (s', HOLogic.dest_string S) end
val string_pair_list = map conv' (HOLogic.dest_list term)
\<close>

View File

@ -29,13 +29,13 @@ print_doc_items
(* this corresponds to low-level accesses : *)
ML\<open>
val docitem_tab = DOF_core.get_instances \<^context>
val isa_transformer_tab = DOF_core.get_isa_transformers \<^context>
val {docclass_tab, ...}
= DOF_core.get_data @{context};
val docitem_tab = DOF_core.get_instances \<^context>;
val isa_transformer_tab = DOF_core.get_isa_transformers \<^context>;
val docclass_tab = DOF_core.get_onto_classes \<^context>;
Name_Space.dest_table docitem_tab;
Name_Space.dest_table isa_transformer_tab;
Symtab.dest docclass_tab;
Name_Space.dest_table docclass_tab;
app;
\<close>

View File

@ -44,7 +44,7 @@ text\<open>Voila the content of the Isabelle_DOF environment so far:\<close>
ML\<open>
val x = DOF_core.get_instances \<^context>
val isa_transformer_tab = DOF_core.get_isa_transformers \<^context>
val {docclass_tab,...} = DOF_core.get_data @{context};
val docclass_tab = DOF_core.get_onto_classes \<^context>;
Name_Space.dest_table isa_transformer_tab;
\<close>