2019-08-15 14:09:55 +00:00
|
|
|
(*************************************************************************
|
|
|
|
* Copyright (C)
|
2022-07-17 21:46:56 +00:00
|
|
|
* 2019-2022 The University of Exeter
|
|
|
|
* 2018-2022 The University of Paris-Saclay
|
2019-08-15 14:09:55 +00:00
|
|
|
* 2018 The University of Sheffield
|
|
|
|
*
|
|
|
|
* License:
|
|
|
|
* This program can be redistributed and/or modified under the terms
|
|
|
|
* of the 2-clause BSD-style license.
|
|
|
|
*
|
|
|
|
* SPDX-License-Identifier: BSD-2-Clause
|
|
|
|
*************************************************************************)
|
|
|
|
|
2018-09-11 07:33:17 +00:00
|
|
|
chapter \<open>The Document Ontology Framework for Isabelle\<close>
|
|
|
|
|
|
|
|
text\<open> Offering
|
|
|
|
\<^item> text-elements that can be annotated with meta-information
|
|
|
|
\<^item> typed links to text-elements via specifically generated anti-quotations
|
|
|
|
\<^item> typed structure of this meta-information specifiable in an Ontology-Language ODL
|
2018-11-21 10:15:21 +00:00
|
|
|
providing syntax and PIDE support of document classes
|
2018-11-20 09:11:11 +00:00
|
|
|
\<^item> inner-syntax-antiquotations (ISA's) allowing to reference Isabelle-entities such as
|
2018-09-11 07:33:17 +00:00
|
|
|
types, terms, theorems inside the meta-information
|
|
|
|
\<^item> monitors allowing to enforce a specific textual structure of an Isabelle Document
|
2018-11-21 10:15:21 +00:00
|
|
|
\<^item> a basic infrastructure to define class invariants
|
|
|
|
(for continuous checking of meta-information side-conditions of text-elements
|
2018-09-11 07:33:17 +00:00
|
|
|
\<^item> LaTeX support. \<close>
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
text\<open> In this section, we develop on the basis of a management of references Isar-markups
|
2019-03-31 14:13:27 +00:00
|
|
|
that provide direct support in the PIDE framework. \<close>
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-11-04 17:56:59 +00:00
|
|
|
theory Isa_DOF (* Isabelle Document Ontology Framework *)
|
|
|
|
imports Main
|
|
|
|
RegExpInterface (* Interface to functional regular automata for monitoring *)
|
2018-10-30 14:50:01 +00:00
|
|
|
|
2020-12-30 11:47:54 +00:00
|
|
|
keywords "+=" ":=" "accepts" "rejects" "invariant"
|
2018-04-29 09:35:24 +00:00
|
|
|
|
2020-12-30 11:47:54 +00:00
|
|
|
and "open_monitor*" "close_monitor*"
|
|
|
|
"declare_reference*" "update_instance*"
|
2022-03-11 11:30:34 +00:00
|
|
|
"doc_class" "onto_class" (* a syntactic alternative *)
|
|
|
|
"ML*"
|
2020-12-30 11:47:54 +00:00
|
|
|
"define_shortcut*" "define_macro*" :: thy_decl
|
2018-04-29 09:35:24 +00:00
|
|
|
|
2021-05-13 20:46:00 +00:00
|
|
|
and "text*" "text-macro*" :: document_body
|
2022-03-31 04:57:18 +00:00
|
|
|
and "term*" "value*" "assert*" :: document_body
|
2020-04-23 16:30:46 +00:00
|
|
|
|
2022-12-03 23:09:29 +00:00
|
|
|
and "use_template" "use_ontology" :: thy_decl
|
|
|
|
and "define_template" "define_ontology" :: thy_load
|
2020-12-30 11:47:54 +00:00
|
|
|
and "print_doc_classes" "print_doc_items"
|
2020-06-23 12:02:04 +00:00
|
|
|
"print_doc_class_template" "check_doc_global" :: diag
|
2020-04-23 16:30:46 +00:00
|
|
|
|
2020-05-19 15:32:25 +00:00
|
|
|
|
2018-08-19 08:17:17 +00:00
|
|
|
|
2018-04-29 09:35:24 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
begin
|
2018-11-05 20:42:36 +00:00
|
|
|
|
2019-04-29 20:24:32 +00:00
|
|
|
text\<open> @{footnote \<open>sdf\<close>}, @{file "$ISABELLE_HOME/src/Pure/ROOT.ML"}\<close>
|
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
section\<open>Primitive Markup Generators\<close>
|
|
|
|
ML\<open>
|
2018-02-28 13:06:52 +00:00
|
|
|
|
2018-03-28 15:05:01 +00:00
|
|
|
val docrefN = "docref";
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
val docclassN = "doc_class";
|
|
|
|
|
|
|
|
(** name components **)
|
|
|
|
|
2021-12-14 17:04:04 +00:00
|
|
|
val defN = "def"
|
|
|
|
val def_suffixN = "_" ^ defN
|
|
|
|
val defsN = defN ^ "s"
|
2021-12-09 08:57:21 +00:00
|
|
|
val instances_of_suffixN = "_instances"
|
2021-12-14 17:04:04 +00:00
|
|
|
val invariant_suffixN = "_inv"
|
|
|
|
val invariantN = "\<sigma>"
|
|
|
|
val makeN = "make"
|
|
|
|
val schemeN = "_scheme"
|
2018-02-28 13:06:52 +00:00
|
|
|
|
2018-03-28 11:08:55 +00:00
|
|
|
(* derived from: theory_markup *)
|
2018-03-28 15:05:01 +00:00
|
|
|
fun docref_markup_gen refN def name id pos =
|
2018-02-28 13:06:52 +00:00
|
|
|
if id = 0 then Markup.empty
|
2021-12-18 22:06:51 +00:00
|
|
|
else Position.make_entity_markup {def = def} id refN (name, pos); (* or better store the thy-name as property ? ? ? *)
|
2018-03-28 15:05:01 +00:00
|
|
|
|
|
|
|
val docref_markup = docref_markup_gen docrefN
|
|
|
|
|
|
|
|
val docclass_markup = docref_markup_gen docclassN
|
2018-11-04 19:27:05 +00:00
|
|
|
|
|
|
|
\<close>
|
2018-09-03 19:31:06 +00:00
|
|
|
|
2020-02-21 14:39:50 +00:00
|
|
|
section\<open> Utilities\<close>
|
2019-03-05 08:36:12 +00:00
|
|
|
|
|
|
|
ML\<open>
|
2019-03-05 21:47:38 +00:00
|
|
|
fun spy x y = (writeln (x ^ y); y)
|
2019-03-05 08:36:12 +00:00
|
|
|
|
|
|
|
fun markup2string x = XML.content_of (YXML.parse_body x)
|
|
|
|
|
|
|
|
(* a hacky, but save encoding of unicode comming from the interface to the string format
|
|
|
|
that can be parsed by the inner-syntax string parser ''dfdf''. *)
|
|
|
|
fun bstring_to_holstring ctxt x (* (x:bstring) *) : string =
|
|
|
|
let val term = Syntax.parse_term ctxt (markup2string x)
|
|
|
|
fun hpp x = if x = #"\\" then "@" else
|
|
|
|
if x = #"@" then "@@" else String.implode [x]
|
|
|
|
in term |> Sledgehammer_Util.hackish_string_of_term ctxt
|
|
|
|
|> map hpp o String.explode |> String.concat
|
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
|
|
fun chopper p (x:string) =
|
|
|
|
let fun hss buff [] = rev buff
|
2019-04-29 20:24:32 +00:00
|
|
|
|hss buff (S as a::R) = if p a then let val (front,rest) = chop_prefix p S
|
2019-03-05 08:36:12 +00:00
|
|
|
in hss (String.implode front :: buff) rest end
|
2019-04-29 20:24:32 +00:00
|
|
|
else let val (front,rest) = chop_prefix (not o p) S
|
2019-03-05 08:36:12 +00:00
|
|
|
in hss (String.implode front ::buff) rest end
|
|
|
|
in hss [] (String.explode x) end;
|
|
|
|
|
|
|
|
|
|
|
|
fun holstring_to_bstring ctxt (x:string) : bstring =
|
|
|
|
let fun collapse "" = ""
|
|
|
|
|collapse S = if String.sub(S,0) = #"@"
|
|
|
|
then let val n = String.size S
|
|
|
|
val front = replicate (n div 2) #"@"
|
|
|
|
val back = if (n mod 2)=1 then [#"\\"] else []
|
|
|
|
in String.implode (front @ back) end
|
|
|
|
else S;
|
|
|
|
val t = String.concat (map collapse (chopper (fn x => x = #"@") x));
|
|
|
|
in t |> Syntax.string_of_term ctxt o Syntax.parse_term ctxt end;
|
|
|
|
|
2020-02-21 14:39:50 +00:00
|
|
|
fun map_option _ NONE = NONE
|
|
|
|
|map_option f (SOME x) = SOME (f x);
|
|
|
|
|
|
|
|
fun map_optional _ s NONE = s
|
|
|
|
|map_optional f _ (SOME x) = f x;
|
|
|
|
|
2020-02-21 15:33:28 +00:00
|
|
|
fun map_fst f (x,y) = (f x,y)
|
|
|
|
fun map_snd f (x,y) = (x,f y)
|
|
|
|
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
fun map_eq_fst_triple f (x,_,_) (y,_,_) = equal (f x) (f y)
|
2020-02-21 15:33:28 +00:00
|
|
|
|
2019-03-05 08:36:12 +00:00
|
|
|
\<close>
|
2018-09-03 19:31:06 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
section\<open> A HomeGrown Document Type Management (the ''Model'') \<close>
|
2021-09-29 12:21:13 +00:00
|
|
|
|
|
|
|
|
2019-05-14 07:13:42 +00:00
|
|
|
ML\<open>
|
2018-02-09 11:25:15 +00:00
|
|
|
structure DOF_core =
|
2021-09-29 12:21:13 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
struct
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
type virtual = {virtual : bool}
|
2019-04-29 20:24:32 +00:00
|
|
|
type docclass_struct = {params : (string * sort) list, (*currently not used *)
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
name : binding,
|
|
|
|
virtual : virtual,
|
2019-04-29 20:24:32 +00:00
|
|
|
thy_name : string, id : serial, (* for pide *)
|
|
|
|
inherits_from : (typ list * string) option, (* imports *)
|
|
|
|
attribute_decl : (binding*typ*term option)list, (* class local *)
|
2018-11-19 19:53:59 +00:00
|
|
|
rejectS : term list,
|
2020-02-21 18:23:51 +00:00
|
|
|
rex : term list,
|
|
|
|
invs : ((string * Position.T) * term) list } (* monitoring regexps --- product semantics*)
|
2018-02-08 15:25:15 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
type docclass_tab = docclass_struct Symtab.table
|
|
|
|
|
|
|
|
val initial_docclass_tab = Symtab.empty:docclass_tab
|
|
|
|
|
|
|
|
fun merge_docclass_tab (otab,otab') = Symtab.merge (op =) (otab,otab')
|
|
|
|
|
2022-12-02 12:50:16 +00:00
|
|
|
val tag_attr = (\<^binding>\<open>tag_attribute\<close>, \<^Type>\<open>int\<close>, Mixfix.NoSyn)
|
2021-10-20 07:10:11 +00:00
|
|
|
(* Attribute hidden to the user and used internally by isabelle_DOF.
|
|
|
|
For example, this allows to add a specific id to a class
|
|
|
|
to be able to reference the class internally.
|
|
|
|
*)
|
2018-02-28 10:31:42 +00:00
|
|
|
|
2018-02-28 13:06:52 +00:00
|
|
|
val default_cid = "text" (* the top (default) document class: everything is a text.*)
|
2018-02-28 10:31:42 +00:00
|
|
|
|
|
|
|
fun is_subclass0 (tab:docclass_tab) s t =
|
2018-02-07 18:44:27 +00:00
|
|
|
let val _ = case Symtab.lookup tab t of
|
2018-02-28 10:31:42 +00:00
|
|
|
NONE => if t <> default_cid
|
2018-04-04 16:08:18 +00:00
|
|
|
then error ("document superclass not defined: "^t)
|
2018-02-28 10:31:42 +00:00
|
|
|
else default_cid
|
|
|
|
| SOME _ => ""
|
2018-02-07 18:44:27 +00:00
|
|
|
fun father_is_sub s = case Symtab.lookup tab s of
|
2018-04-04 16:08:18 +00:00
|
|
|
NONE => error ("document subclass not defined: "^s)
|
2018-02-08 15:25:15 +00:00
|
|
|
| SOME ({inherits_from=NONE, ...}) => s = t
|
2018-02-28 10:31:42 +00:00
|
|
|
| SOME ({inherits_from=SOME (_,s'), ...}) =>
|
|
|
|
s' = t orelse father_is_sub s'
|
|
|
|
in s = t orelse
|
2018-10-09 13:56:17 +00:00
|
|
|
(t = default_cid andalso Symtab.defined tab s ) orelse
|
|
|
|
(s <> default_cid andalso father_is_sub s)
|
2018-02-07 18:44:27 +00:00
|
|
|
end
|
|
|
|
|
2018-09-03 18:56:08 +00:00
|
|
|
type docobj = {pos : Position.T,
|
|
|
|
thy_name : string,
|
2022-03-28 16:19:41 +00:00
|
|
|
input_term : term,
|
2020-06-16 07:08:36 +00:00
|
|
|
value : term,
|
|
|
|
inline : bool,
|
|
|
|
id : serial,
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
cid : string,
|
|
|
|
vcid : string option}
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
type docobj_tab ={tab : (docobj option) Symtab.table,
|
|
|
|
maxano : int
|
|
|
|
}
|
|
|
|
|
|
|
|
val initial_docobj_tab:docobj_tab = {tab = Symtab.empty, maxano = 0}
|
|
|
|
|
|
|
|
fun merge_docobj_tab ({tab=otab,maxano=m}, {tab=otab',maxano=m'}) =
|
|
|
|
(let fun X(NONE,NONE) = false
|
|
|
|
|X(SOME _, NONE) = false
|
|
|
|
|X(NONE, SOME _) = false
|
|
|
|
|X(SOME b, SOME b') = true (* b = b' *)
|
|
|
|
in {tab=Symtab.merge X (otab,otab'),maxano=Int.max(m,m')}
|
|
|
|
end)
|
2021-10-20 07:10:11 +00:00
|
|
|
type ISA_transformers = {check :
|
|
|
|
(theory -> term * typ * Position.T -> string -> term option),
|
2022-03-11 11:30:34 +00:00
|
|
|
elaborate : (theory -> string -> typ -> term option -> Position.T -> term)
|
2021-10-20 07:10:11 +00:00
|
|
|
}
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2021-10-20 07:10:11 +00:00
|
|
|
type ISA_transformer_tab = ISA_transformers Symtab.table
|
2018-09-03 18:56:08 +00:00
|
|
|
val initial_ISA_tab:ISA_transformer_tab = Symtab.empty
|
|
|
|
|
2018-12-04 09:41:34 +00:00
|
|
|
type docclass_inv_tab = (string -> {is_monitor:bool} -> Context.generic -> bool) Symtab.table
|
2018-11-20 09:11:11 +00:00
|
|
|
val initial_docclass_inv_tab : docclass_inv_tab = Symtab.empty
|
|
|
|
|
2022-05-25 15:13:49 +00:00
|
|
|
type docclass_eager_inv_tab =
|
|
|
|
(string -> {is_monitor:bool} -> Context.generic -> bool) Symtab.table
|
|
|
|
val initial_docclass_eager_inv_tab : docclass_eager_inv_tab = Symtab.empty
|
|
|
|
|
|
|
|
type docclass_lazy_inv_tab =
|
|
|
|
(string -> {is_monitor:bool} -> Context.generic -> bool) Symtab.table
|
|
|
|
val initial_docclass_lazy_inv_tab : docclass_lazy_inv_tab = Symtab.empty
|
|
|
|
|
2018-10-11 11:38:32 +00:00
|
|
|
type open_monitor_info = {accepted_cids : string list,
|
2018-11-19 19:53:59 +00:00
|
|
|
rejected_cids : string list,
|
2019-04-29 20:24:32 +00:00
|
|
|
automatas : RegExpInterface.automaton list
|
|
|
|
}
|
2018-10-09 13:56:17 +00:00
|
|
|
|
2018-10-08 13:13:47 +00:00
|
|
|
type monitor_tab = open_monitor_info Symtab.table
|
|
|
|
val initial_monitor_tab:monitor_tab = Symtab.empty
|
|
|
|
|
2018-11-04 19:27:05 +00:00
|
|
|
fun override(t1,t2) = fold(Symtab.update)(Symtab.dest t2)(t1)
|
2018-10-08 13:13:47 +00:00
|
|
|
|
2018-04-04 12:44:21 +00:00
|
|
|
(* registrating data of the Isa_DOF component *)
|
2018-02-07 18:44:27 +00:00
|
|
|
structure Data = Generic_Data
|
|
|
|
(
|
2018-10-08 13:13:47 +00:00
|
|
|
type T = {docobj_tab : docobj_tab,
|
|
|
|
docclass_tab : docclass_tab,
|
|
|
|
ISA_transformer_tab : ISA_transformer_tab,
|
2018-11-20 09:11:11 +00:00
|
|
|
monitor_tab : monitor_tab,
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab : docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab : docclass_eager_inv_tab,
|
|
|
|
docclass_lazy_inv_tab : docclass_lazy_inv_tab}
|
2018-11-20 09:11:11 +00:00
|
|
|
val empty = {docobj_tab = initial_docobj_tab,
|
|
|
|
docclass_tab = initial_docclass_tab,
|
2018-10-08 13:13:47 +00:00
|
|
|
ISA_transformer_tab = initial_ISA_tab,
|
2018-11-20 09:11:11 +00:00
|
|
|
monitor_tab = initial_monitor_tab,
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab = initial_docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab = initial_docclass_eager_inv_tab,
|
|
|
|
docclass_lazy_inv_tab = initial_docclass_lazy_inv_tab
|
2018-10-08 13:13:47 +00:00
|
|
|
}
|
2018-11-20 09:11:11 +00:00
|
|
|
fun merge( {docobj_tab=d1,docclass_tab = c1,
|
|
|
|
ISA_transformer_tab = e1, monitor_tab=m1,
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab = n1,
|
|
|
|
docclass_eager_inv_tab = en1, docclass_lazy_inv_tab = ln1},
|
2018-11-20 09:11:11 +00:00
|
|
|
{docobj_tab=d2,docclass_tab = c2,
|
|
|
|
ISA_transformer_tab = e2, monitor_tab=m2,
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab = n2,
|
|
|
|
docclass_eager_inv_tab = en2, docclass_lazy_inv_tab = ln2}) =
|
2018-10-05 07:45:24 +00:00
|
|
|
{docobj_tab=merge_docobj_tab (d1,d2),
|
|
|
|
docclass_tab = merge_docclass_tab (c1,c2),
|
2021-05-13 20:46:00 +00:00
|
|
|
(*
|
|
|
|
The following merge is ultra-critical: the transformer tabs were
|
|
|
|
just extended by letting *the first* entry with the same long-name win.
|
|
|
|
Since the range is a (call-back) function, a comparison on its content
|
|
|
|
is impossible and some choice has to be made... Alternative: Symtab.join ?
|
|
|
|
*)
|
|
|
|
ISA_transformer_tab = Symtab.merge (fn (_ , _) => true)(e1,e2),
|
2018-11-20 09:11:11 +00:00
|
|
|
monitor_tab = override(m1,m2),
|
2018-10-08 13:13:47 +00:00
|
|
|
(* PROVISORY ... ITS A REAL QUESTION HOW TO DO THIS!*)
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab = override(n1,n2),
|
|
|
|
(* PROVISORY ... ITS A REAL QUESTION HOW TO DO THIS!*)
|
|
|
|
docclass_eager_inv_tab = override(en1,en2),
|
|
|
|
(* PROVISORY ... ITS A REAL QUESTION HOW TO DO THIS!*)
|
|
|
|
docclass_lazy_inv_tab = override(ln1,ln2)
|
2018-11-21 10:15:21 +00:00
|
|
|
(* PROVISORY ... ITS A REAL QUESTION HOW TO DO THIS!*)
|
2018-10-09 07:59:46 +00:00
|
|
|
}
|
2018-02-07 18:44:27 +00:00
|
|
|
);
|
|
|
|
|
2018-09-03 18:56:08 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
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;
|
|
|
|
|
2018-10-08 08:30:53 +00:00
|
|
|
|
2022-05-25 15:13:49 +00:00
|
|
|
fun upd_docobj_tab f {docobj_tab,docclass_tab,ISA_transformer_tab,
|
|
|
|
monitor_tab,docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab, docclass_lazy_inv_tab} =
|
2018-10-08 13:13:47 +00:00
|
|
|
{docobj_tab = f docobj_tab, docclass_tab=docclass_tab,
|
2018-11-20 09:11:11 +00:00
|
|
|
ISA_transformer_tab=ISA_transformer_tab, monitor_tab=monitor_tab,
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab=docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab=docclass_eager_inv_tab,
|
|
|
|
docclass_lazy_inv_tab=docclass_lazy_inv_tab};
|
|
|
|
fun upd_docclass_tab f {docobj_tab=x,docclass_tab = y,ISA_transformer_tab = z,
|
|
|
|
monitor_tab, docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab, docclass_lazy_inv_tab} =
|
2018-11-20 09:11:11 +00:00
|
|
|
{docobj_tab=x,docclass_tab = f y,ISA_transformer_tab = z, monitor_tab=monitor_tab,
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab=docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab=docclass_eager_inv_tab,
|
|
|
|
docclass_lazy_inv_tab=docclass_lazy_inv_tab};
|
|
|
|
fun upd_ISA_transformers f {docobj_tab=x,docclass_tab = y,ISA_transformer_tab = z,
|
|
|
|
monitor_tab, docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab, docclass_lazy_inv_tab} =
|
2018-11-20 09:11:11 +00:00
|
|
|
{docobj_tab=x,docclass_tab = y,ISA_transformer_tab = f z, monitor_tab=monitor_tab,
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab=docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab=docclass_eager_inv_tab,
|
|
|
|
docclass_lazy_inv_tab=docclass_lazy_inv_tab};
|
|
|
|
fun upd_monitor_tabs f {docobj_tab,docclass_tab,ISA_transformer_tab,
|
|
|
|
monitor_tab, docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab, docclass_lazy_inv_tab} =
|
2018-11-20 09:11:11 +00:00
|
|
|
{docobj_tab = docobj_tab,docclass_tab = docclass_tab,
|
|
|
|
ISA_transformer_tab = ISA_transformer_tab, monitor_tab = f monitor_tab,
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab=docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab=docclass_eager_inv_tab,
|
|
|
|
docclass_lazy_inv_tab=docclass_lazy_inv_tab};
|
|
|
|
fun upd_docclass_inv_tab f {docobj_tab,docclass_tab,ISA_transformer_tab,
|
|
|
|
monitor_tab, docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab, docclass_lazy_inv_tab} =
|
2018-10-08 13:13:47 +00:00
|
|
|
{docobj_tab = docobj_tab,docclass_tab = docclass_tab,
|
2018-11-20 09:11:11 +00:00
|
|
|
ISA_transformer_tab = ISA_transformer_tab, monitor_tab = monitor_tab,
|
2022-05-25 15:13:49 +00:00
|
|
|
docclass_inv_tab = f docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab=docclass_eager_inv_tab,
|
|
|
|
docclass_lazy_inv_tab=docclass_lazy_inv_tab};
|
2018-10-08 13:13:47 +00:00
|
|
|
|
2022-05-25 15:13:49 +00:00
|
|
|
fun upd_docclass_eager_inv_tab f {docobj_tab,docclass_tab,ISA_transformer_tab,
|
|
|
|
monitor_tab, docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab, docclass_lazy_inv_tab} =
|
|
|
|
{docobj_tab = docobj_tab,docclass_tab = docclass_tab,
|
|
|
|
ISA_transformer_tab = ISA_transformer_tab, monitor_tab = monitor_tab,
|
|
|
|
docclass_inv_tab=docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab=f docclass_eager_inv_tab,
|
|
|
|
docclass_lazy_inv_tab=docclass_lazy_inv_tab};
|
|
|
|
|
|
|
|
fun upd_docclass_lazy_inv_tab f {docobj_tab,docclass_tab,ISA_transformer_tab,
|
|
|
|
monitor_tab, docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab, docclass_lazy_inv_tab} =
|
|
|
|
{docobj_tab = docobj_tab,docclass_tab = docclass_tab,
|
|
|
|
ISA_transformer_tab = ISA_transformer_tab, monitor_tab = monitor_tab,
|
|
|
|
docclass_inv_tab=docclass_inv_tab,
|
|
|
|
docclass_eager_inv_tab=docclass_eager_inv_tab,
|
|
|
|
docclass_lazy_inv_tab=f docclass_lazy_inv_tab};
|
2018-10-08 13:13:47 +00:00
|
|
|
|
2018-11-19 19:53:59 +00:00
|
|
|
fun get_accepted_cids ({accepted_cids, ... } : open_monitor_info) = accepted_cids
|
2022-12-14 11:02:15 +00:00
|
|
|
fun get_rejected_cids ({rejected_cids, ... } : open_monitor_info) = rejected_cids
|
|
|
|
fun get_alphabet monitor_info = (get_accepted_cids monitor_info) @ (get_rejected_cids monitor_info)
|
2018-11-19 19:53:59 +00:00
|
|
|
fun get_automatas ({automatas, ... } : open_monitor_info) = automatas
|
2018-10-09 13:56:17 +00:00
|
|
|
|
2018-02-27 11:02:19 +00:00
|
|
|
|
|
|
|
(* doc-class-name management: We still use the record-package for internally
|
|
|
|
representing doc-classes. The main motivation is that "links" to entities are
|
|
|
|
types over doc-classes, *types* in the Isabelle sense, enriched by additional data.
|
|
|
|
This has the advantage that the type-inference can be abused to infer long-names
|
|
|
|
for doc-class-names. Note, however, that doc-classes are currently implemented
|
|
|
|
by non-polymorphic records only; this means that the extensible "_ext" versions
|
|
|
|
of type names must be reduced to qualifier names only. The used Syntax.parse_typ
|
2020-02-20 12:30:51 +00:00
|
|
|
handling the identification does that already.
|
|
|
|
However, we use Syntax.read_typ in order to allow type-synonyms which requires
|
|
|
|
an appropriate adaption in read_cid.*)
|
2018-02-27 11:02:19 +00:00
|
|
|
|
2018-10-05 07:45:24 +00:00
|
|
|
fun is_subclass (ctxt) s t = is_subclass0(#docclass_tab(get_data ctxt)) s t
|
2018-10-09 13:56:17 +00:00
|
|
|
fun is_subclass_global thy s t = is_subclass0(#docclass_tab(get_data_global thy)) s t
|
2018-02-28 10:31:42 +00:00
|
|
|
|
2018-02-27 11:02:19 +00:00
|
|
|
|
2022-12-02 10:41:31 +00:00
|
|
|
fun typ_to_cid (Type(s,[\<^Type>\<open>unit\<close>])) = Long_Name.qualifier s
|
2018-09-17 14:48:05 +00:00
|
|
|
|typ_to_cid (Type(_,[T])) = typ_to_cid T
|
|
|
|
|typ_to_cid _ = error("type is not an ontological type.")
|
|
|
|
|
2018-02-27 11:02:19 +00:00
|
|
|
|
2020-02-21 14:39:50 +00:00
|
|
|
fun parse_cid ctxt cid =
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
(* parses a type lexically/syntactically, checks absence of type vars *)
|
2019-08-14 15:22:55 +00:00
|
|
|
(case Syntax.parse_typ ctxt cid of
|
2020-02-21 14:39:50 +00:00
|
|
|
Type(tyname, []) => tyname
|
2020-02-20 12:30:51 +00:00
|
|
|
| _ => error "illegal type-format for doc-class-name.")
|
2019-08-14 15:22:55 +00:00
|
|
|
handle ERROR _ => "" (* ignore error *)
|
2020-02-21 14:39:50 +00:00
|
|
|
|
|
|
|
|
|
|
|
fun read_cid ctxt "text" = default_cid (* text = default_cid *)
|
|
|
|
| read_cid ctxt cid =
|
|
|
|
(* parses a type syntactically, type-identification, checking as class id *)
|
2020-02-20 12:30:51 +00:00
|
|
|
(case Syntax.read_typ ctxt cid of
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
ty as Type(tyname, _) => let val res = typ_to_cid ty
|
2020-02-21 14:39:50 +00:00
|
|
|
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
|
2020-02-20 12:30:51 +00:00
|
|
|
| _ => error "illegal type-format for doc-class-name.")
|
2020-02-21 14:39:50 +00:00
|
|
|
handle ERROR _ => error("type identifier not a class id:"^cid)
|
|
|
|
|
|
|
|
fun parse_cid_global thy cid = parse_cid (Proof_Context.init_global thy) cid
|
2020-02-21 15:33:28 +00:00
|
|
|
fun read_cid_global thy cid = read_cid (Proof_Context.init_global thy) cid
|
2019-08-14 15:22:55 +00:00
|
|
|
|
2018-02-08 15:25:15 +00:00
|
|
|
|
2020-02-21 14:39:50 +00:00
|
|
|
fun is_defined_cid_global cid thy =
|
|
|
|
(* works with short and long names *)
|
|
|
|
let val t = #docclass_tab(get_data_global thy)
|
2018-02-27 11:02:19 +00:00
|
|
|
in cid=default_cid orelse
|
2020-02-21 14:39:50 +00:00
|
|
|
Symtab.defined t (parse_cid_global thy cid)
|
2018-02-27 11:02:19 +00:00
|
|
|
end
|
|
|
|
|
2020-02-21 14:39:50 +00:00
|
|
|
fun is_defined_cid_global' cid_long thy =
|
|
|
|
(* works with long names only *)
|
|
|
|
let val t = #docclass_tab(get_data_global thy)
|
2018-12-03 12:19:31 +00:00
|
|
|
in cid_long=default_cid orelse Symtab.defined t cid_long end
|
|
|
|
|
|
|
|
|
2020-02-21 14:39:50 +00:00
|
|
|
fun is_defined_cid_local cid ctxt =
|
|
|
|
(* works with short and long names *)
|
|
|
|
let val t = #docclass_tab(get_data ctxt)
|
2018-02-27 11:02:19 +00:00
|
|
|
in cid=default_cid orelse
|
2020-02-21 14:39:50 +00:00
|
|
|
Symtab.defined t (parse_cid ctxt cid)
|
2018-02-27 11:02:19 +00:00
|
|
|
end
|
2018-02-08 15:25:15 +00:00
|
|
|
|
2020-02-21 14:39:50 +00:00
|
|
|
fun is_defined_cid_local' cid_long ctxt =
|
|
|
|
(* works with long names only *)
|
|
|
|
let val t = #docclass_tab(get_data ctxt)
|
2018-12-03 12:19:31 +00:00
|
|
|
in cid_long=default_cid orelse Symtab.defined t cid_long end
|
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-10-05 07:45:24 +00:00
|
|
|
fun is_declared_oid_global oid thy = let val {tab,...} = #docobj_tab(get_data_global thy)
|
2018-04-04 08:45:56 +00:00
|
|
|
in Symtab.defined tab oid end
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-10-05 07:45:24 +00:00
|
|
|
fun is_declared_oid_local oid thy = let val {tab,...} = #docobj_tab(get_data thy)
|
2018-04-04 08:45:56 +00:00
|
|
|
in Symtab.defined tab oid end
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-10-05 07:45:24 +00:00
|
|
|
fun is_defined_oid_global oid thy = let val {tab,...} = #docobj_tab(get_data_global thy)
|
2018-04-04 08:45:56 +00:00
|
|
|
in case Symtab.lookup tab oid of
|
2018-02-07 18:44:27 +00:00
|
|
|
NONE => false
|
|
|
|
|SOME(NONE) => false
|
|
|
|
|SOME _ => true
|
|
|
|
end
|
|
|
|
|
2018-10-05 07:45:24 +00:00
|
|
|
fun is_defined_oid_local oid thy = let val {tab,...} = #docobj_tab(get_data thy)
|
2018-04-04 08:45:56 +00:00
|
|
|
in case Symtab.lookup tab oid of
|
2018-02-07 18:44:27 +00:00
|
|
|
NONE => false
|
|
|
|
|SOME(NONE) => false
|
|
|
|
|SOME _ => true
|
|
|
|
end
|
|
|
|
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
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
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-04-04 08:45:56 +00:00
|
|
|
fun declare_object_global oid thy =
|
|
|
|
let fun decl {tab=t,maxano=x} = {tab=Symtab.update_new(oid,NONE)t, maxano=x}
|
2018-10-08 08:30:53 +00:00
|
|
|
in (map_data_global (upd_docobj_tab(decl)) (thy)
|
2018-04-04 08:45:56 +00:00
|
|
|
handle Symtab.DUP _ => error("multiple declaration of document reference"))
|
|
|
|
end
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-04-04 08:45:56 +00:00
|
|
|
fun declare_object_local oid ctxt =
|
|
|
|
let fun decl {tab,maxano} = {tab=Symtab.update_new(oid,NONE) tab, maxano=maxano}
|
2018-10-08 08:30:53 +00:00
|
|
|
in (map_data(upd_docobj_tab decl)(ctxt)
|
2018-04-04 08:45:56 +00:00
|
|
|
handle Symtab.DUP _ => error("multiple declaration of document reference"))
|
|
|
|
end
|
2018-02-28 13:06:52 +00:00
|
|
|
|
2018-12-03 12:19:31 +00:00
|
|
|
|
|
|
|
fun update_class_invariant cid_long f thy =
|
|
|
|
let val _ = if is_defined_cid_global' cid_long thy then ()
|
|
|
|
else error("undefined class id : " ^cid_long)
|
|
|
|
in map_data_global (upd_docclass_inv_tab (Symtab.update (cid_long,
|
2018-12-04 09:41:34 +00:00
|
|
|
(fn ctxt => ((writeln("Inv check of : " ^cid_long); f ctxt ))))))
|
2018-12-03 12:19:31 +00:00
|
|
|
thy
|
|
|
|
end
|
|
|
|
|
2022-05-25 15:13:49 +00:00
|
|
|
fun update_class_eager_invariant cid_long f thy =
|
|
|
|
let val _ = if is_defined_cid_global' cid_long thy then ()
|
|
|
|
else error("undefined class id : " ^cid_long)
|
|
|
|
in map_data_global (upd_docclass_eager_inv_tab (Symtab.update (cid_long,
|
|
|
|
(fn ctxt => ((writeln("Eager Invariant check of: " ^cid_long); f ctxt ))))))
|
|
|
|
thy
|
|
|
|
end
|
|
|
|
|
|
|
|
fun update_class_lazy_invariant cid_long f thy =
|
|
|
|
let val _ = if is_defined_cid_global' cid_long thy then ()
|
|
|
|
else error("undefined class id : " ^cid_long)
|
|
|
|
in map_data_global (upd_docclass_lazy_inv_tab (Symtab.update (cid_long,
|
|
|
|
(fn ctxt => ((writeln("Lazy Invariant check of: " ^cid_long); f ctxt ))))))
|
|
|
|
thy
|
|
|
|
end
|
|
|
|
|
2018-12-03 12:19:31 +00:00
|
|
|
fun get_class_invariant cid_long thy =
|
|
|
|
let val _ = if is_defined_cid_global' cid_long thy then ()
|
|
|
|
else error("undefined class id : " ^cid_long)
|
|
|
|
val {docclass_inv_tab, ...} = get_data_global thy
|
|
|
|
in case Symtab.lookup docclass_inv_tab cid_long of
|
2018-12-04 09:41:34 +00:00
|
|
|
NONE => K(K(K true))
|
2018-12-03 12:19:31 +00:00
|
|
|
| SOME f => f
|
|
|
|
end
|
|
|
|
|
2022-05-25 15:13:49 +00:00
|
|
|
fun get_class_eager_invariant cid_long thy =
|
|
|
|
let val _ = if is_defined_cid_global' cid_long thy then ()
|
|
|
|
else error("undefined class id : " ^cid_long)
|
|
|
|
val {docclass_eager_inv_tab, ...} = get_data_global thy
|
|
|
|
in case Symtab.lookup docclass_eager_inv_tab cid_long of
|
|
|
|
NONE => K(K(K true))
|
|
|
|
| SOME f => f
|
|
|
|
end
|
|
|
|
|
|
|
|
fun get_class_lazy_invariant cid_long thy =
|
|
|
|
let val _ = if is_defined_cid_global' cid_long thy then ()
|
|
|
|
else error("undefined class id : " ^cid_long)
|
|
|
|
val {docclass_lazy_inv_tab, ...} = get_data_global thy
|
|
|
|
in case Symtab.lookup docclass_lazy_inv_tab cid_long of
|
|
|
|
NONE => K(K(K true))
|
|
|
|
| SOME f => f
|
|
|
|
end
|
|
|
|
|
2018-11-19 19:53:59 +00:00
|
|
|
val SPY = Unsynchronized.ref(Bound 0)
|
2018-02-28 13:06:52 +00:00
|
|
|
|
2018-11-19 19:53:59 +00:00
|
|
|
fun check_regexps term =
|
|
|
|
let val _ = case fold_aterms Term.add_free_names term [] of
|
|
|
|
n::_ => error("No free variables allowed in monitor regexp:" ^ n)
|
|
|
|
| _ => ()
|
|
|
|
val _ = case fold_aterms Term.add_var_names term [] of
|
|
|
|
(n,_)::_ => error("No schematic variables allowed in monitor regexp:" ^ n)
|
|
|
|
| _ => ()
|
|
|
|
(* Missing: Checks on constants such as undefined, ... *)
|
|
|
|
in term end
|
|
|
|
|
|
|
|
fun check_reject_atom cid_long term =
|
|
|
|
let val _ = case fold_aterms Term.add_free_names term [] of
|
|
|
|
n::_ => error("No free variables allowed in monitor regexp:" ^ n)
|
|
|
|
| _ => ()
|
|
|
|
val _ = case fold_aterms Term.add_var_names term [] of
|
|
|
|
(n,_)::_ => error("No schematic variables allowed in monitor regexp:" ^ n)
|
|
|
|
| _ => ()
|
|
|
|
(* Missing: Checks on constants such as undefined, ... *)
|
|
|
|
in term end
|
|
|
|
|
|
|
|
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
fun define_doc_class_global (params', binding) parent fields rexp reject_Atoms invs virtual thy =
|
|
|
|
(* This operation is executed in a context where the record has already been defined, but
|
2020-02-21 14:39:50 +00:00
|
|
|
its conversion into a class is not yet done. *)
|
2018-04-04 08:45:56 +00:00
|
|
|
let val nn = Context.theory_name thy (* in case that we need the thy-name to identify
|
|
|
|
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
|
2020-02-21 14:39:50 +00:00
|
|
|
then error("redefinition of document class:"^cid )
|
2018-04-04 08:45:56 +00:00
|
|
|
else ()
|
2020-02-21 15:33:28 +00:00
|
|
|
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
|
2020-02-21 14:39:50 +00:00
|
|
|
val cid_long' = parse_cid_global thy cid_long
|
2020-02-20 12:30:51 +00:00
|
|
|
val _ = if cid_long' <> "" then ()
|
|
|
|
else error("Could not construct type from doc_class (lexical problem?)")
|
2020-02-21 14:39:50 +00:00
|
|
|
|
2018-04-04 08:45:56 +00:00
|
|
|
val id = serial ();
|
|
|
|
val _ = Position.report pos (docclass_markup true cid id pos);
|
|
|
|
|
2018-11-19 19:53:59 +00:00
|
|
|
val rejectS = map (Syntax.read_term_global thy) reject_Atoms;
|
|
|
|
val _ = map (check_reject_atom cid_long) 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)
|
2020-02-21 18:23:51 +00:00
|
|
|
then error ("reject clause requires accept clause ! " ) else ();
|
|
|
|
val _ = if has_duplicates (op =) (map (fst o fst) invs)
|
|
|
|
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
|
2018-04-04 08:45:56 +00:00
|
|
|
val info = {params=params',
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
name = binding,
|
|
|
|
virtual = virtual,
|
2018-04-04 08:45:56 +00:00
|
|
|
thy_name = nn,
|
|
|
|
id = id, (* for pide --- really fresh or better reconstruct
|
2018-04-04 12:44:21 +00:00
|
|
|
from prior record definition ? For the moment: own
|
|
|
|
generation of serials ... *)
|
2020-02-21 15:33:28 +00:00
|
|
|
inherits_from = parent',
|
2018-10-08 08:30:53 +00:00
|
|
|
attribute_decl = fields ,
|
2018-11-19 19:53:59 +00:00
|
|
|
rejectS = rejectS,
|
2020-02-21 18:23:51 +00:00
|
|
|
rex = reg_exps,
|
|
|
|
invs = invs'}
|
2018-04-04 08:45:56 +00:00
|
|
|
|
2018-10-08 08:30:53 +00:00
|
|
|
in map_data_global(upd_docclass_tab(Symtab.update(cid_long,info)))(thy)
|
2018-04-04 08:45:56 +00:00
|
|
|
end
|
2018-02-08 15:25:15 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
fun define_object_global (oid, bbb) thy =
|
2018-04-04 08:45:56 +00:00
|
|
|
let val nn = Context.theory_name thy (* in case that we need the thy-name to identify
|
|
|
|
the space where it is ... *)
|
|
|
|
in if is_defined_oid_global oid thy
|
|
|
|
then error("multiple definition of document reference")
|
2018-10-08 08:30:53 +00:00
|
|
|
else map_data_global (upd_docobj_tab(fn {tab=t,maxano=x} =>
|
2018-04-04 08:45:56 +00:00
|
|
|
{tab=Symtab.update(oid,SOME bbb) t,
|
|
|
|
maxano=x}))
|
2018-08-18 12:44:39 +00:00
|
|
|
(thy)
|
2018-04-04 08:45:56 +00:00
|
|
|
end
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
fun define_object_local (oid, bbb) ctxt =
|
2018-10-08 08:30:53 +00:00
|
|
|
map_data (upd_docobj_tab(fn{tab,maxano}=>{tab=Symtab.update(oid,SOME bbb)tab,maxano=maxano})) ctxt
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
|
|
|
|
(* declares an anonyme label of a given type and generates a unique reference ... *)
|
2018-04-04 08:45:56 +00:00
|
|
|
fun declare_anoobject_global thy cid =
|
|
|
|
let fun declare {tab,maxano} = let val str = cid^":"^Int.toString(maxano+1)
|
2020-02-20 12:30:51 +00:00
|
|
|
val _ = writeln("Anonymous reference declared: " ^ str)
|
2018-04-04 08:45:56 +00:00
|
|
|
in {tab=Symtab.update(str,NONE)tab,maxano= maxano+1} end
|
2018-10-08 08:30:53 +00:00
|
|
|
in map_data_global (upd_docobj_tab declare) (thy)
|
2018-04-04 08:45:56 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
fun declare_anoobject_local ctxt cid =
|
|
|
|
let fun declare {tab,maxano} = let val str = cid^":"^Int.toString(maxano+1)
|
2020-02-20 12:30:51 +00:00
|
|
|
val _ = writeln("Anonymous reference declared: " ^str)
|
2018-04-04 08:45:56 +00:00
|
|
|
in {tab=Symtab.update(str,NONE)tab, maxano=maxano+1} end
|
2018-10-08 08:30:53 +00:00
|
|
|
in map_data (upd_docobj_tab declare) (ctxt)
|
2018-04-04 08:45:56 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
|
2019-02-27 10:42:45 +00:00
|
|
|
fun get_object_global_opt oid thy = Symtab.lookup (#tab(#docobj_tab(get_data_global thy))) oid
|
|
|
|
|
|
|
|
fun get_object_global oid thy = case get_object_global_opt oid thy of
|
2018-04-27 08:34:24 +00:00
|
|
|
NONE => error("undefined reference: "^oid)
|
2018-04-04 08:45:56 +00:00
|
|
|
|SOME(bbb) => bbb
|
|
|
|
|
2019-02-27 10:42:45 +00:00
|
|
|
fun get_object_local_opt oid ctxt = Symtab.lookup (#tab(#docobj_tab(get_data ctxt))) oid
|
|
|
|
|
|
|
|
fun get_object_local oid ctxt = case get_object_local_opt oid ctxt of
|
2018-04-27 08:34:24 +00:00
|
|
|
NONE => error("undefined reference: "^oid)
|
2018-04-04 08:45:56 +00:00
|
|
|
|SOME(bbb) => bbb
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-02-28 10:31:42 +00:00
|
|
|
fun get_doc_class_global cid thy =
|
2021-12-14 17:04:04 +00:00
|
|
|
if cid = default_cid then error("default class access") (* TODO *)
|
2018-10-05 07:45:24 +00:00
|
|
|
else let val t = #docclass_tab(get_data_global thy)
|
2018-04-04 08:45:56 +00:00
|
|
|
in (Symtab.lookup t cid) end
|
|
|
|
|
2018-02-28 10:31:42 +00:00
|
|
|
|
|
|
|
fun get_doc_class_local cid ctxt =
|
2021-12-14 17:04:04 +00:00
|
|
|
if cid = default_cid then error("default class access") (* TODO *)
|
2018-10-05 07:45:24 +00:00
|
|
|
else let val t = #docclass_tab(get_data ctxt)
|
2018-04-04 08:45:56 +00:00
|
|
|
in (Symtab.lookup t cid) end
|
2018-02-28 10:31:42 +00:00
|
|
|
|
|
|
|
|
2018-10-05 07:45:24 +00:00
|
|
|
fun is_defined_cid_local cid ctxt = let val t = #docclass_tab(get_data ctxt)
|
2018-02-28 10:31:42 +00:00
|
|
|
in cid=default_cid orelse
|
2020-02-21 14:39:50 +00:00
|
|
|
Symtab.defined t (parse_cid ctxt cid)
|
2018-02-28 10:31:42 +00:00
|
|
|
end
|
|
|
|
|
2018-04-20 11:19:50 +00:00
|
|
|
fun get_attributes_local cid ctxt =
|
2021-10-20 07:10:11 +00:00
|
|
|
if cid = default_cid then []
|
2021-10-29 06:26:03 +00:00
|
|
|
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, ...})) =>
|
2021-10-20 07:10:11 +00:00
|
|
|
get_attributes_local father ctxt @ [(cid_long,X)]
|
2021-10-29 06:26:03 +00:00
|
|
|
end
|
2018-04-20 11:19:50 +00:00
|
|
|
|
|
|
|
fun get_attributes cid thy = get_attributes_local cid (Proof_Context.init_global thy)
|
|
|
|
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
|
2021-10-29 06:26:03 +00:00
|
|
|
fun get_all_attributes_local cid ctxt =
|
|
|
|
(tag_attr, get_attributes_local cid ctxt)
|
|
|
|
|
|
|
|
fun get_all_attributes cid thy = get_all_attributes_local cid (Proof_Context.init_global thy)
|
|
|
|
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
|
2018-08-20 11:54:53 +00:00
|
|
|
type attributes_info = { def_occurrence : string,
|
2018-08-28 16:21:37 +00:00
|
|
|
def_pos : Position.T,
|
|
|
|
long_name : string,
|
|
|
|
typ : typ
|
2018-08-20 11:54:53 +00:00
|
|
|
}
|
|
|
|
|
2018-08-20 18:29:04 +00:00
|
|
|
fun get_attribute_info_local (*long*)cid attr ctxt : attributes_info option=
|
2018-04-20 11:19:50 +00:00
|
|
|
let val hierarchy = get_attributes_local cid ctxt (* search in order *)
|
2018-08-20 11:54:53 +00:00
|
|
|
fun found (s,L) = case find_first (fn (bind,_,_) => Binding.name_of bind = attr) L of
|
|
|
|
NONE => NONE
|
|
|
|
| SOME X => SOME(s,X)
|
2018-04-20 11:19:50 +00:00
|
|
|
in case get_first found hierarchy of
|
|
|
|
NONE => NONE
|
2018-08-20 11:54:53 +00:00
|
|
|
| SOME (cid',(bind, ty,_)) => SOME({def_occurrence = cid,
|
2018-08-22 20:06:15 +00:00
|
|
|
def_pos = Binding.pos_of bind,
|
2018-08-20 11:54:53 +00:00
|
|
|
long_name = cid'^"."^(Binding.name_of bind),
|
|
|
|
typ = ty})
|
2018-04-20 11:19:50 +00:00
|
|
|
end
|
|
|
|
|
2018-08-20 18:29:04 +00:00
|
|
|
fun get_attribute_info (*long*)cid attr thy =
|
|
|
|
get_attribute_info_local cid attr (Proof_Context.init_global thy)
|
2018-04-20 11:19:50 +00:00
|
|
|
|
2018-08-24 13:49:13 +00:00
|
|
|
fun get_attribute_defaults (* long*)cid thy =
|
|
|
|
let val attrS = flat(map snd (get_attributes cid thy))
|
|
|
|
fun trans (_,_,NONE) = NONE
|
|
|
|
|trans (na,ty,SOME def) =SOME(na,ty, def)
|
|
|
|
in map_filter trans attrS end
|
2018-04-27 08:34:24 +00:00
|
|
|
|
|
|
|
fun get_value_global oid thy = case get_object_global oid thy of
|
|
|
|
SOME{value=term,...} => SOME term
|
|
|
|
| NONE => NONE
|
|
|
|
|
|
|
|
fun get_value_local oid ctxt = case get_object_local oid ctxt of
|
|
|
|
SOME{value=term,...} => SOME term
|
|
|
|
| NONE => NONE
|
|
|
|
|
2018-06-07 11:56:15 +00:00
|
|
|
(* missing : setting terms to ground (no type-schema vars, no schema vars. )*)
|
2022-03-28 16:19:41 +00:00
|
|
|
fun update_value_global oid upd_input_term upd_value thy =
|
2018-04-27 08:34:24 +00:00
|
|
|
case get_object_global oid thy of
|
2022-03-28 16:19:41 +00:00
|
|
|
SOME{pos,thy_name, input_term, value,inline,id,cid,vcid} =>
|
2018-04-27 08:34:24 +00:00
|
|
|
let val tab' = Symtab.update(oid,SOME{pos=pos,thy_name=thy_name,
|
2022-03-28 16:19:41 +00:00
|
|
|
input_term=upd_input_term input_term,
|
|
|
|
value=upd_value value,id=id,
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
inline=inline,cid=cid, vcid=vcid})
|
2019-04-29 20:24:32 +00:00
|
|
|
in map_data_global (upd_docobj_tab(fn{tab,maxano}=>{tab=tab' tab,maxano=maxano})) thy end
|
2018-04-27 08:34:24 +00:00
|
|
|
| NONE => error("undefined doc object: "^oid)
|
|
|
|
|
|
|
|
|
2021-05-13 20:46:00 +00:00
|
|
|
val ISA_prefix = "ISA_" (* ISA's must be declared in Isa_DOF.thy !!! *)
|
|
|
|
|
|
|
|
val doc_class_prefix = ISA_prefix ^ "doc_class_"
|
|
|
|
|
|
|
|
fun is_ISA s = String.isPrefix ISA_prefix (Long_Name.base_name s)
|
|
|
|
|
|
|
|
fun get_class_name_without_prefix s = String.extract (s, String.size(doc_class_prefix), NONE)
|
|
|
|
|
|
|
|
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
|
2018-09-11 06:50:51 +00:00
|
|
|
|
2018-12-03 12:19:31 +00:00
|
|
|
fun get_isa_global isa thy =
|
|
|
|
case Symtab.lookup (#ISA_transformer_tab(get_data_global thy)) (ISA_prefix^isa) of
|
|
|
|
NONE => error("undefined inner syntax antiquotation: "^isa)
|
|
|
|
| SOME(bbb) => bbb
|
2018-09-03 19:31:06 +00:00
|
|
|
|
|
|
|
|
2018-10-05 07:45:24 +00:00
|
|
|
fun get_isa_local isa ctxt = case Symtab.lookup (#ISA_transformer_tab(get_data ctxt)) (ISA_prefix^isa) of
|
2018-09-03 19:31:06 +00:00
|
|
|
NONE => error("undefined inner syntax antiquotation: "^isa)
|
|
|
|
|SOME(bbb) => bbb
|
|
|
|
|
2021-05-13 20:46:00 +00:00
|
|
|
fun update_isa map_data_fun (isa, trans) ctxt =
|
|
|
|
let
|
|
|
|
val bname = Long_Name.base_name isa;
|
|
|
|
val qual = Long_Name.qualifier isa;
|
|
|
|
val long_name = Long_Name.qualify qual (ISA_prefix ^ bname);
|
|
|
|
in map_data_fun (upd_ISA_transformers(Symtab.update(long_name, trans))) ctxt end
|
2018-09-03 19:31:06 +00:00
|
|
|
|
2021-05-13 20:46:00 +00:00
|
|
|
fun update_isa_local (isa, trans) ctxt = update_isa map_data (isa, trans) ctxt
|
2018-09-03 19:31:06 +00:00
|
|
|
|
2021-05-13 20:46:00 +00:00
|
|
|
fun update_isa_global (isa, trans) thy = update_isa map_data_global (isa, trans) thy
|
2018-09-03 19:31:06 +00:00
|
|
|
|
2021-10-20 07:10:11 +00:00
|
|
|
fun transduce_term_global {mk_elaboration=mk_elaboration} (term,pos) thy =
|
2019-03-05 08:36:12 +00:00
|
|
|
(* pre: term should be fully typed in order to allow type-related term-transformations *)
|
2018-10-05 07:45:24 +00:00
|
|
|
let val tab = #ISA_transformer_tab(get_data_global thy)
|
2021-05-13 20:46:00 +00:00
|
|
|
fun T(Const(s,ty) $ t) = if is_ISA s
|
2018-09-03 19:31:06 +00:00
|
|
|
then case Symtab.lookup tab s of
|
2021-12-09 08:57:21 +00:00
|
|
|
NONE => error("undefined inner syntax antiquotation: "^s)
|
|
|
|
| SOME({check=check, elaborate=elaborate}) =>
|
|
|
|
case check thy (t,ty,pos) s of
|
|
|
|
NONE => Const(s,ty) $ t
|
|
|
|
(* checking isa, may raise error though. *)
|
|
|
|
| SOME t => if mk_elaboration
|
2022-03-11 11:30:34 +00:00
|
|
|
then elaborate thy s ty (SOME t) pos
|
2021-12-09 08:57:21 +00:00
|
|
|
else Const(s,ty) $ t
|
2018-09-03 19:31:06 +00:00
|
|
|
(* transforming isa *)
|
|
|
|
else (Const(s,ty) $ (T t))
|
|
|
|
|T(t1 $ t2) = T(t1) $ T(t2)
|
2021-12-09 08:57:21 +00:00
|
|
|
|T(Const(s,ty)) = if is_ISA s
|
|
|
|
then case Symtab.lookup tab s of
|
|
|
|
NONE => error("undefined inner syntax antiquotation: "^s)
|
|
|
|
| SOME({elaborate=elaborate, ...}) =>
|
|
|
|
if mk_elaboration
|
2022-03-11 11:30:34 +00:00
|
|
|
then elaborate thy s ty NONE pos
|
2021-12-09 08:57:21 +00:00
|
|
|
else Const(s, ty)
|
|
|
|
(* transforming isa *)
|
|
|
|
else Const(s, ty)
|
2018-09-03 19:31:06 +00:00
|
|
|
|T(Abs(s,ty,t)) = Abs(s,ty,T t)
|
|
|
|
|T t = t
|
2021-12-09 08:57:21 +00:00
|
|
|
in T term end
|
2018-09-03 19:31:06 +00:00
|
|
|
|
2022-12-22 09:55:03 +00:00
|
|
|
fun elaborate_term ctxt term = transduce_term_global {mk_elaboration=true}
|
|
|
|
(term , Position.none)
|
|
|
|
(Proof_Context.theory_of ctxt)
|
|
|
|
|
|
|
|
fun check_term ctxt term = transduce_term_global {mk_elaboration=false}
|
|
|
|
(term , Position.none)
|
|
|
|
(Proof_Context.theory_of ctxt)
|
|
|
|
|
2018-10-05 07:45:24 +00:00
|
|
|
fun writeln_classrefs ctxt = let val tab = #docclass_tab(get_data ctxt)
|
2018-04-04 08:45:56 +00:00
|
|
|
in writeln (String.concatWith "," (Symtab.keys tab)) end
|
2018-02-28 13:06:52 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-10-05 07:45:24 +00:00
|
|
|
fun writeln_docrefs ctxt = let val {tab,...} = #docobj_tab(get_data ctxt)
|
2018-04-04 08:45:56 +00:00
|
|
|
in writeln (String.concatWith "," (Symtab.keys tab)) end
|
2018-08-19 08:17:17 +00:00
|
|
|
|
|
|
|
|
2020-06-23 12:02:04 +00:00
|
|
|
|
|
|
|
|
2018-08-19 08:17:17 +00:00
|
|
|
|
2020-12-30 11:47:54 +00:00
|
|
|
fun print_doc_class_tree ctxt P T =
|
|
|
|
let val {docobj_tab={tab = x, ...},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)
|
2021-01-01 20:23:21 +00:00
|
|
|
then "."^Int.toString lev^" "^(T n)^"{...}.\n"
|
2020-12-30 11:47:54 +00:00
|
|
|
^ (tree(lev + 1)(filter(is_class_son(SOME([],n)))class_tab))
|
|
|
|
else "."^Int.toString lev^" ... \n")
|
|
|
|
^ (tree lev S)
|
|
|
|
val roots = filter(is_class_son NONE) class_tab
|
2021-01-01 20:23:21 +00:00
|
|
|
in ".0 .\n" ^ tree 1 roots end
|
2020-12-30 11:47:54 +00:00
|
|
|
|
|
|
|
|
2022-03-28 16:19:41 +00:00
|
|
|
val (strict_monitor_checking, strict_monitor_checking_setup)
|
2019-04-29 20:24:32 +00:00
|
|
|
= Attrib.config_bool \<^binding>\<open>strict_monitor_checking\<close> (K false);
|
2018-11-05 20:42:36 +00:00
|
|
|
|
2022-12-14 11:02:15 +00:00
|
|
|
val (free_class_in_monitor_checking, free_class_in_monitor_checking_setup)
|
|
|
|
= Attrib.config_bool \<^binding>\<open>free_class_in_monitor_checking\<close> (K false);
|
|
|
|
|
|
|
|
val (free_class_in_monitor_strict_checking, free_class_in_monitor_strict_checking_setup)
|
|
|
|
= Attrib.config_bool \<^binding>\<open>free_class_in_monitor_strict_checking\<close> (K false);
|
|
|
|
|
2022-12-22 06:53:42 +00:00
|
|
|
val (invariants_checking, invariants_checking_setup)
|
|
|
|
= Attrib.config_bool \<^binding>\<open>invariants_checking\<close> (K true);
|
|
|
|
|
2022-12-12 11:01:04 +00:00
|
|
|
val (invariants_strict_checking, invariants_strict_checking_setup)
|
|
|
|
= Attrib.config_bool \<^binding>\<open>invariants_strict_checking\<close> (K false);
|
2021-12-14 17:04:04 +00:00
|
|
|
|
|
|
|
val (invariants_checking_with_tactics, invariants_checking_with_tactics_setup)
|
|
|
|
= Attrib.config_bool \<^binding>\<open>invariants_checking_with_tactics\<close> (K false);
|
|
|
|
|
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
end (* struct *)
|
2018-11-05 20:42:36 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
\<close>
|
|
|
|
|
2021-12-14 17:04:04 +00:00
|
|
|
setup\<open>DOF_core.strict_monitor_checking_setup
|
2022-12-14 11:02:15 +00:00
|
|
|
#> DOF_core.free_class_in_monitor_checking_setup
|
|
|
|
#> DOF_core.free_class_in_monitor_strict_checking_setup
|
2022-12-22 06:53:42 +00:00
|
|
|
#> DOF_core.invariants_checking_setup
|
2022-12-12 11:01:04 +00:00
|
|
|
#> DOF_core.invariants_strict_checking_setup
|
2021-12-14 17:04:04 +00:00
|
|
|
#> DOF_core.invariants_checking_with_tactics_setup\<close>
|
2018-11-05 20:42:36 +00:00
|
|
|
|
2020-08-25 09:11:38 +00:00
|
|
|
section\<open> Syntax for Term Annotation Antiquotations (TA)\<close>
|
2018-11-05 20:42:36 +00:00
|
|
|
|
2020-08-25 09:11:38 +00:00
|
|
|
text\<open>Isabelle/DOF allows for annotations at the term level, for which an
|
|
|
|
antiquotation syntax and semantics is defined at the inner syntax level.
|
|
|
|
(For this reasons, the mechanism has been called somewhat misleading
|
|
|
|
\<^emph>\<open>inner syntax antiquotations\<close> in earlier versions of Isabelle/DOF.)
|
|
|
|
|
|
|
|
For the moment, only a fixed number of builtin TA's is supported, future
|
|
|
|
versions might extend this feature substantially.\<close>
|
2018-09-11 06:50:51 +00:00
|
|
|
|
|
|
|
subsection\<open> Syntax \<close>
|
|
|
|
|
2022-11-24 13:20:29 +00:00
|
|
|
datatype "doc_class" = mk string
|
|
|
|
|
2019-07-20 15:08:47 +00:00
|
|
|
\<comment> \<open>and others in the future : file, http, thy, ...\<close>
|
2018-09-11 06:50:51 +00:00
|
|
|
|
2021-11-04 14:10:02 +00:00
|
|
|
datatype "typ" = ISA_typ string ("@{typ _}")
|
|
|
|
datatype "term" = ISA_term string ("@{term _}")
|
2019-03-05 08:36:12 +00:00
|
|
|
consts ISA_term_repr :: "string \<Rightarrow> term" ("@{termrepr _}")
|
2021-11-04 14:10:02 +00:00
|
|
|
datatype "thm" = ISA_thm string ("@{thm _}")
|
|
|
|
datatype "file" = ISA_file string ("@{file _}")
|
|
|
|
datatype "thy" = ISA_thy string ("@{thy _}")
|
2018-09-11 06:50:51 +00:00
|
|
|
consts ISA_docitem :: "string \<Rightarrow> 'a" ("@{docitem _}")
|
2021-11-04 14:10:02 +00:00
|
|
|
datatype "docitem_attr" = ISA_docitem_attr string string ("@{docitemattr (_) :: (_)}")
|
2022-11-25 07:57:59 +00:00
|
|
|
consts ISA_trace_attribute :: "string \<Rightarrow> (string * string) list" ("@{trace-attribute _}")
|
2018-09-11 06:50:51 +00:00
|
|
|
|
2019-04-04 13:43:48 +00:00
|
|
|
\<comment> \<open>Dynamic setup of inner syntax cartouche\<close>
|
|
|
|
|
2019-04-16 14:30:43 +00:00
|
|
|
ML \<open>
|
|
|
|
(* Author: Frédéric Tuong, Université Paris-Saclay *)
|
|
|
|
(* Title: HOL/ex/Cartouche_Examples.thy
|
|
|
|
Author: Makarius
|
|
|
|
*)
|
|
|
|
local
|
|
|
|
fun mk_char (f_char, f_cons, _) (s, _) accu =
|
|
|
|
fold
|
|
|
|
(fn c => fn (accu, l) =>
|
|
|
|
(f_char c accu, f_cons c l))
|
|
|
|
(rev (map Char.ord (String.explode s)))
|
|
|
|
accu;
|
|
|
|
|
|
|
|
fun mk_string (_, _, f_nil) accu [] = (accu, f_nil)
|
|
|
|
| mk_string f accu (s :: ss) = mk_char f s (mk_string f accu ss);
|
|
|
|
in
|
|
|
|
fun string_tr f f_mk accu content args =
|
|
|
|
let fun err () = raise TERM ("string_tr", args) in
|
|
|
|
(case args of
|
|
|
|
[(c as Const (@{syntax_const "_constrain"}, _)) $ Free (s, _) $ p] =>
|
|
|
|
(case Term_Position.decode_position p of
|
|
|
|
SOME (pos, _) => c $ f (mk_string f_mk accu (content (s, pos))) $ p
|
|
|
|
| NONE => err ())
|
|
|
|
| _ => err ())
|
|
|
|
end;
|
|
|
|
end;
|
|
|
|
\<close>
|
|
|
|
|
|
|
|
syntax "_cartouche_string" :: "cartouche_position \<Rightarrow> _" ("_")
|
|
|
|
|
|
|
|
ML\<open>
|
|
|
|
structure Cartouche_Grammar = struct
|
|
|
|
fun list_comb_mk cst n c = list_comb (Syntax.const cst, String_Syntax.mk_bits_syntax n c)
|
|
|
|
val nil1 = Syntax.const @{const_syntax String.empty_literal}
|
|
|
|
fun cons1 c l = list_comb_mk @{const_syntax String.Literal} 7 c $ l
|
|
|
|
|
|
|
|
val default =
|
|
|
|
[ ( "char list"
|
|
|
|
, ( Const (@{const_syntax Nil}, @{typ "char list"})
|
|
|
|
, fn c => fn l => Syntax.const @{const_syntax Cons} $ list_comb_mk @{const_syntax Char} 8 c $ l
|
|
|
|
, snd))
|
|
|
|
, ( "String.literal", (nil1, cons1, snd))]
|
|
|
|
end
|
|
|
|
\<close>
|
|
|
|
|
|
|
|
ML\<open>
|
|
|
|
fun parse_translation_cartouche binding l f_integer accu =
|
|
|
|
let val cartouche_type = Attrib.setup_config_string binding (K (fst (hd l)))
|
|
|
|
(* if there is no type specified, by default we set the first element
|
|
|
|
to be the default type of cartouches *) in
|
|
|
|
fn ctxt =>
|
|
|
|
let val cart_type = Config.get ctxt cartouche_type in
|
|
|
|
case List.find (fn (s, _) => s = cart_type) l of
|
|
|
|
NONE => error ("Unregistered return type for the cartouche: \"" ^ cart_type ^ "\"")
|
|
|
|
| SOME (_, (nil0, cons, f)) =>
|
|
|
|
string_tr f (f_integer, cons, nil0) accu (Symbol_Pos.cartouche_content o Symbol_Pos.explode)
|
|
|
|
end
|
|
|
|
end
|
|
|
|
\<close>
|
|
|
|
|
|
|
|
parse_translation \<open>
|
|
|
|
[( @{syntax_const "_cartouche_string"}
|
2019-04-29 20:24:32 +00:00
|
|
|
, parse_translation_cartouche \<^binding>\<open>cartouche_type\<close> Cartouche_Grammar.default (K I) ())]
|
2019-04-16 14:30:43 +00:00
|
|
|
\<close>
|
2019-04-04 13:43:48 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
(* tests *)
|
|
|
|
term "@{typ ''int => int''}"
|
|
|
|
term "@{term ''Bound 0''}"
|
|
|
|
term "@{thm ''refl''}"
|
|
|
|
term "@{docitem ''<doc_ref>''}"
|
2018-09-11 11:51:25 +00:00
|
|
|
ML\<open> @{term "@{docitem ''<doc_ref>''}"}\<close>
|
2019-04-29 20:24:32 +00:00
|
|
|
|
|
|
|
term "@{typ \<open>int \<Rightarrow> int\<close>}"
|
|
|
|
term "@{term \<open>\<forall>x. P x \<longrightarrow> Q\<close>}"
|
2019-04-04 13:43:48 +00:00
|
|
|
term "@{thm \<open>refl\<close>}"
|
2019-04-29 20:24:32 +00:00
|
|
|
term "@{docitem \<open>doc_ref\<close>}"
|
|
|
|
ML\<open> @{term "@{docitem \<open>doc_ref\<close>}"}\<close>
|
2019-04-04 13:43:48 +00:00
|
|
|
(**)
|
|
|
|
declare [[cartouche_type = "String.literal"]]
|
|
|
|
term "\<open>Université\<close> :: String.literal"
|
|
|
|
declare [[cartouche_type = "char list"]]
|
|
|
|
term "\<open>Université\<close> :: char list"
|
2019-04-29 20:24:32 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
|
|
|
|
|
|
|
|
subsection\<open> Semantics \<close>
|
|
|
|
|
|
|
|
ML\<open>
|
|
|
|
structure ISA_core =
|
|
|
|
struct
|
|
|
|
|
|
|
|
fun err msg pos = error (msg ^ Position.here pos);
|
2022-12-12 11:01:04 +00:00
|
|
|
fun warn msg pos = warning (msg ^ Position.here pos);
|
2018-09-11 06:50:51 +00:00
|
|
|
|
|
|
|
fun check_path check_file ctxt dir (name, pos) =
|
|
|
|
let
|
2021-03-10 22:04:09 +00:00
|
|
|
val _ = Context_Position.report ctxt pos (Markup.language_path true); (* TODO: pos should be
|
|
|
|
"lifted" to
|
|
|
|
type source *)
|
2018-09-11 06:50:51 +00:00
|
|
|
|
|
|
|
val path = Path.append dir (Path.explode name) handle ERROR msg => err msg pos;
|
|
|
|
val _ = Path.expand path handle ERROR msg => err msg pos;
|
2021-03-10 22:04:09 +00:00
|
|
|
val _ = Context_Position.report ctxt pos (Markup.path (Path.implode_symbolic path));
|
2018-09-11 06:50:51 +00:00
|
|
|
val _ =
|
|
|
|
(case check_file of
|
|
|
|
NONE => path
|
|
|
|
| SOME check => (check path handle ERROR msg => err msg pos));
|
|
|
|
in path end;
|
|
|
|
|
|
|
|
|
2018-09-17 14:48:05 +00:00
|
|
|
fun ML_isa_antiq check_file thy (name, _, pos) =
|
2018-09-11 06:50:51 +00:00
|
|
|
let val path = check_path check_file (Proof_Context.init_global thy) Path.current (name, pos);
|
|
|
|
in "Path.explode " ^ ML_Syntax.print_string (Path.implode path) end;
|
|
|
|
|
2018-08-16 14:52:08 +00:00
|
|
|
|
2021-12-13 16:19:51 +00:00
|
|
|
fun ML_isa_check_generic check thy (term, pos) =
|
2018-09-11 06:50:51 +00:00
|
|
|
let val name = (HOLogic.dest_string term
|
|
|
|
handle TERM(_,[t]) => error ("wrong term format: must be string constant: "
|
2018-09-11 10:08:25 +00:00
|
|
|
^ Syntax.string_of_term_global thy t ))
|
|
|
|
val _ = check thy (name,pos)
|
|
|
|
in SOME term end;
|
|
|
|
|
2021-12-13 16:19:51 +00:00
|
|
|
fun check_identity _ (term, _, _) _ = SOME term
|
2018-09-11 10:08:25 +00:00
|
|
|
|
2021-12-13 16:19:51 +00:00
|
|
|
fun ML_isa_check_typ thy (term, _, pos) _ =
|
2019-01-17 22:06:10 +00:00
|
|
|
let fun check thy (name, _) = let val ctxt = (Proof_Context.init_global thy)
|
|
|
|
in (Syntax.check_typ ctxt o Syntax.parse_typ ctxt) name end
|
2021-12-13 16:19:51 +00:00
|
|
|
in ML_isa_check_generic check thy (term, pos) end
|
2018-09-11 10:08:25 +00:00
|
|
|
|
|
|
|
|
2021-12-13 16:19:51 +00:00
|
|
|
fun ML_isa_check_term thy (term, _, pos) _ =
|
2019-01-17 22:06:10 +00:00
|
|
|
let fun check thy (name, _) = let val ctxt = (Proof_Context.init_global thy)
|
|
|
|
in (Syntax.check_term ctxt o Syntax.parse_term ctxt) name end
|
2021-12-13 16:19:51 +00:00
|
|
|
in ML_isa_check_generic check thy (term, pos) end
|
2018-09-11 10:08:25 +00:00
|
|
|
|
|
|
|
|
2021-12-13 16:19:51 +00:00
|
|
|
fun ML_isa_check_thm thy (term, _, pos) _ =
|
2018-09-11 11:51:25 +00:00
|
|
|
(* this works for long-names only *)
|
|
|
|
let fun check thy (name, _) = case Proof_Context.lookup_fact (Proof_Context.init_global thy) name of
|
|
|
|
NONE => err ("No Theorem:" ^name) pos
|
|
|
|
| SOME X => X
|
2021-12-13 16:19:51 +00:00
|
|
|
in ML_isa_check_generic check thy (term, pos) end
|
2018-09-11 11:51:25 +00:00
|
|
|
|
|
|
|
|
2021-12-13 16:19:51 +00:00
|
|
|
fun ML_isa_check_file thy (term, _, pos) _ =
|
2018-09-11 10:08:25 +00:00
|
|
|
let fun check thy (name, pos) = check_path (SOME File.check_file)
|
|
|
|
(Proof_Context.init_global thy)
|
|
|
|
(Path.current)
|
|
|
|
(name, pos);
|
2021-12-13 16:19:51 +00:00
|
|
|
in ML_isa_check_generic check thy (term, pos) end;
|
2018-09-11 10:08:25 +00:00
|
|
|
|
2021-05-13 20:46:00 +00:00
|
|
|
fun check_instance thy (term, _, pos) s =
|
|
|
|
let
|
|
|
|
val bname = Long_Name.base_name s;
|
|
|
|
val qual = Long_Name.qualifier s;
|
|
|
|
val class_name =
|
|
|
|
Long_Name.qualify qual (String.extract(bname , String.size(DOF_core.doc_class_prefix), NONE));
|
|
|
|
fun check thy (name, _) =
|
|
|
|
let
|
|
|
|
val object_cid = case DOF_core.get_object_global name thy of
|
2021-10-20 07:10:11 +00:00
|
|
|
NONE => err ("No class instance: " ^ name) pos
|
2021-05-13 20:46:00 +00:00
|
|
|
| SOME(object) => #cid object
|
|
|
|
fun check' (class_name, object_cid) =
|
|
|
|
if class_name = object_cid then
|
|
|
|
DOF_core.get_value_global name thy
|
|
|
|
else err (name ^ " is not an instance of " ^ class_name) pos
|
|
|
|
in check' (class_name, object_cid) end;
|
2021-12-13 16:19:51 +00:00
|
|
|
in ML_isa_check_generic check thy (term, pos) end
|
2018-09-11 06:50:51 +00:00
|
|
|
|
|
|
|
|
2018-09-11 09:35:25 +00:00
|
|
|
fun ML_isa_id thy (term,pos) = SOME term
|
|
|
|
|
2018-09-11 12:15:11 +00:00
|
|
|
|
2021-12-13 16:19:51 +00:00
|
|
|
fun ML_isa_check_docitem thy (term, req_ty, pos) _ =
|
2021-05-13 20:46:00 +00:00
|
|
|
let fun check thy (name, _) s =
|
2018-09-17 14:48:05 +00:00
|
|
|
if DOF_core.is_declared_oid_global name thy
|
|
|
|
then case DOF_core.get_object_global name thy of
|
|
|
|
NONE => warning("oid declared, but not yet defined --- "^
|
|
|
|
" type-check incomplete")
|
|
|
|
| SOME {pos=pos_decl,cid,id,...} =>
|
|
|
|
let val ctxt = (Proof_Context.init_global thy)
|
|
|
|
val req_class = case req_ty of
|
2022-12-02 10:41:31 +00:00
|
|
|
\<^Type>\<open>fun _ T\<close> => DOF_core.typ_to_cid T
|
2018-09-17 14:48:05 +00:00
|
|
|
| _ => error("can not infer type for: "^ name)
|
|
|
|
in if cid <> DOF_core.default_cid
|
|
|
|
andalso not(DOF_core.is_subclass ctxt cid req_class)
|
2020-12-01 22:18:13 +00:00
|
|
|
then error("reference ontologically inconsistent: "
|
|
|
|
^cid^" vs. "^req_class^ Position.here pos_decl)
|
2018-09-17 14:48:05 +00:00
|
|
|
else ()
|
|
|
|
end
|
|
|
|
else err ("faulty reference to docitem: "^name) pos
|
2021-12-13 16:19:51 +00:00
|
|
|
in ML_isa_check_generic check thy (term, pos) end
|
2021-05-13 20:46:00 +00:00
|
|
|
|
2022-11-24 13:20:29 +00:00
|
|
|
fun ML_isa_check_trace_attribute thy (term, _, pos) s =
|
|
|
|
let
|
|
|
|
fun check thy (name, _) =
|
|
|
|
case DOF_core.get_object_global name thy of
|
|
|
|
NONE => err ("No class instance: " ^ name) pos
|
|
|
|
| SOME(_) => ()
|
|
|
|
in ML_isa_check_generic check thy (term, pos) end
|
|
|
|
|
2022-03-14 15:17:28 +00:00
|
|
|
fun ML_isa_elaborate_generic (_:theory) isa_name ty term_option _ =
|
2021-12-09 08:57:21 +00:00
|
|
|
case term_option of
|
|
|
|
NONE => error("Wrong term option. You must use a defined term")
|
|
|
|
| SOME term => Const (isa_name, ty) $ term
|
2021-11-04 14:10:02 +00:00
|
|
|
|
2022-03-11 11:30:34 +00:00
|
|
|
fun elaborate_instance thy _ _ term_option pos =
|
2021-12-09 08:57:21 +00:00
|
|
|
case term_option of
|
|
|
|
NONE => error ("Malformed term annotation")
|
|
|
|
| SOME term => let val instance_name = HOLogic.dest_string term
|
|
|
|
in case DOF_core.get_value_global instance_name thy of
|
|
|
|
NONE => error ("No class instance: " ^ instance_name)
|
2022-03-11 11:30:34 +00:00
|
|
|
| SOME(value) =>
|
2022-03-14 15:17:28 +00:00
|
|
|
DOF_core.transduce_term_global {mk_elaboration=true} (value, pos) thy
|
2021-12-09 08:57:21 +00:00
|
|
|
end
|
2021-05-13 20:46:00 +00:00
|
|
|
|
|
|
|
(*
|
|
|
|
The function declare_ISA_class_accessor_and_check_instance uses a prefix
|
|
|
|
because the class name is already bound to "doc_class Regular_Exp.rexp" constant
|
|
|
|
by add_doc_class_cmd function
|
|
|
|
*)
|
|
|
|
fun declare_ISA_class_accessor_and_check_instance doc_class_name =
|
|
|
|
let
|
|
|
|
val bind = Binding.prefix_name DOF_core.doc_class_prefix doc_class_name
|
|
|
|
val typestring = "string => " ^ (Binding.name_of doc_class_name)
|
|
|
|
(* Unfortunately due to different lexical conventions for constant symbols and mixfix symbols
|
|
|
|
we can not use "_" for classes names in term antiquotation.
|
|
|
|
We chose to convert "_" to "-".*)
|
|
|
|
val conv_class_name = String.translate (fn #"_" => "-"
|
|
|
|
| x => String.implode [x] )
|
|
|
|
(Binding.name_of doc_class_name)
|
|
|
|
val mixfix_string = "@{" ^ conv_class_name ^ " _}"
|
|
|
|
in
|
|
|
|
Sign.add_consts_cmd [(bind, typestring, Mixfix.mixfix(mixfix_string))]
|
|
|
|
#> (fn thy => let
|
|
|
|
val long_name = DOF_core.read_cid_global thy (Binding.name_of doc_class_name)
|
|
|
|
val qual = Long_Name.qualifier long_name
|
|
|
|
val class_name = Long_Name.qualify qual
|
|
|
|
(DOF_core.get_doc_class_name_without_ISA_prefix (Binding.name_of bind))
|
|
|
|
in
|
2021-12-09 08:57:21 +00:00
|
|
|
DOF_core.update_isa_global
|
|
|
|
(class_name, {check=check_instance, elaborate=elaborate_instance}) thy
|
|
|
|
end)
|
2021-05-13 20:46:00 +00:00
|
|
|
end
|
2018-09-11 12:15:11 +00:00
|
|
|
|
2022-03-14 15:17:28 +00:00
|
|
|
fun elaborate_instances_list thy isa_name _ _ _ =
|
2021-12-09 08:57:21 +00:00
|
|
|
let
|
|
|
|
val base_name = Long_Name.base_name isa_name
|
|
|
|
fun get_isa_name_without_intances_suffix s =
|
|
|
|
String.extract (s, 0, SOME (String.size(s) - String.size(instances_of_suffixN)))
|
|
|
|
val base_name_without_suffix = get_isa_name_without_intances_suffix base_name
|
|
|
|
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 tab = #tab(#docobj_tab(DOF_core.get_data_global thy))
|
|
|
|
val table_list = Symtab.dest tab
|
|
|
|
fun get_instances_name_list _ [] = []
|
|
|
|
| get_instances_name_list class_name (x::xs) =
|
|
|
|
let
|
|
|
|
val (_, docobj_option) = x
|
|
|
|
in
|
|
|
|
case docobj_option of
|
|
|
|
NONE => get_instances_name_list class_name xs
|
|
|
|
| SOME {cid=cid, value=value, ...} =>
|
|
|
|
if cid = class_name
|
|
|
|
then value::get_instances_name_list class_name xs
|
|
|
|
else get_instances_name_list class_name xs
|
|
|
|
end
|
|
|
|
val long_class_name = DOF_core.read_cid_global thy base_name'
|
|
|
|
val values_list = get_instances_name_list long_class_name table_list
|
2022-04-19 12:05:52 +00:00
|
|
|
in HOLogic.mk_list class_typ values_list end
|
2021-12-09 08:57:21 +00:00
|
|
|
|
|
|
|
fun declare_class_instances_annotation thy doc_class_name =
|
|
|
|
let
|
|
|
|
val bind = Binding.prefix_name DOF_core.doc_class_prefix doc_class_name
|
|
|
|
val bind' = Binding.suffix_name instances_of_suffixN bind
|
|
|
|
val class_list_typ = Proof_Context.read_typ (Proof_Context.init_global thy)
|
|
|
|
((Binding.name_of doc_class_name) ^ " List.list")
|
|
|
|
(* Unfortunately due to different lexical conventions for constant symbols and mixfix symbols
|
|
|
|
we can not use "_" for classes names in term antiquotation.
|
|
|
|
We chose to convert "_" to "-".*)
|
|
|
|
val conv_class_name' = String.translate (fn #"_" => "-" | x=> String.implode [x])
|
|
|
|
((Binding.name_of doc_class_name) ^ instances_of_suffixN)
|
|
|
|
val mixfix_string = "@{" ^ conv_class_name' ^ "}"
|
|
|
|
in
|
|
|
|
Sign.add_consts [(bind', class_list_typ, Mixfix.mixfix(mixfix_string))]
|
|
|
|
#> (fn thy => let
|
|
|
|
val long_name = DOF_core.read_cid_global thy (Binding.name_of doc_class_name)
|
|
|
|
val qual = Long_Name.qualifier long_name
|
|
|
|
val transformer_name = Long_Name.qualify qual
|
|
|
|
(DOF_core.get_doc_class_name_without_ISA_prefix (Binding.name_of bind'))
|
|
|
|
in
|
|
|
|
DOF_core.update_isa_global (transformer_name,
|
|
|
|
{check=check_identity, elaborate= elaborate_instances_list}) thy end)
|
|
|
|
end
|
|
|
|
|
2022-11-24 13:20:29 +00:00
|
|
|
fun symbex_attr_access0 ctxt proj_term term =
|
|
|
|
let
|
|
|
|
val [subterm'] = Type_Infer_Context.infer_types ctxt [proj_term $ term]
|
|
|
|
in Value_Command.value ctxt (subterm') end
|
|
|
|
|
|
|
|
fun compute_attr_access ctxt attr oid pos_option pos' = (* template *)
|
|
|
|
case DOF_core.get_value_global oid (Context.theory_of ctxt) of
|
|
|
|
SOME term => let val ctxt = (Proof_Context.init_global (Context.theory_of ctxt))
|
|
|
|
val SOME{cid,pos=pos_decl,id,...} = DOF_core.get_object_local oid ctxt
|
|
|
|
val docitem_markup = docref_markup false oid id pos_decl;
|
|
|
|
val _ = Context_Position.report ctxt pos' docitem_markup;
|
|
|
|
val (* (long_cid, attr_b,ty) = *)
|
|
|
|
{long_name, typ=ty, def_pos, ...} =
|
|
|
|
case DOF_core.get_attribute_info_local cid attr ctxt of
|
|
|
|
SOME f => f
|
2022-11-28 08:58:58 +00:00
|
|
|
| NONE => error("attribute undefined for reference: "
|
|
|
|
^ oid
|
|
|
|
^ Position.here
|
|
|
|
(the pos_option handle Option.Option =>
|
|
|
|
error("Attribute "
|
|
|
|
^ attr
|
|
|
|
^ " undefined for reference: "
|
|
|
|
^ oid ^ Position.here pos')))
|
2022-11-24 13:20:29 +00:00
|
|
|
val proj_term = Const(long_name,dummyT --> ty)
|
|
|
|
val _ = case pos_option of
|
|
|
|
NONE => ()
|
|
|
|
| SOME pos =>
|
|
|
|
let
|
|
|
|
val class_name = Long_Name.qualifier long_name
|
|
|
|
val SOME{id,...} = DOF_core.get_doc_class_local class_name ctxt
|
|
|
|
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 term end
|
|
|
|
(*in Value_Command.value ctxt term end*)
|
|
|
|
| NONE => error("identifier not a docitem reference" ^ Position.here pos')
|
|
|
|
|
|
|
|
fun ML_isa_elaborate_trace_attribute (thy:theory) _ _ term_option pos =
|
|
|
|
case term_option of
|
|
|
|
NONE => err ("Malformed term annotation") pos
|
|
|
|
| SOME term =>
|
|
|
|
let
|
|
|
|
val oid = HOLogic.dest_string term
|
|
|
|
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)
|
|
|
|
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
|
|
|
|
|
2019-01-21 14:00:18 +00:00
|
|
|
(* utilities *)
|
|
|
|
|
2022-12-02 10:41:31 +00:00
|
|
|
fun property_list_dest ctxt X =
|
|
|
|
map (fn \<^Const_>\<open>ISA_term for s\<close> => HOLogic.dest_string s
|
|
|
|
|\<^Const_>\<open>ISA_term_repr for s\<close> => holstring_to_bstring ctxt (HOLogic.dest_string s))
|
|
|
|
(HOLogic.dest_list X)
|
2018-09-11 12:15:11 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
end; (* struct *)
|
2018-09-11 07:33:17 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
\<close>
|
2019-03-31 16:47:10 +00:00
|
|
|
|
|
|
|
|
2018-09-11 10:08:25 +00:00
|
|
|
subsection\<open> Isar - Setup\<close>
|
2018-09-11 12:15:11 +00:00
|
|
|
|
2021-11-04 14:10:02 +00:00
|
|
|
setup\<open>DOF_core.update_isa_global("Isa_DOF.typ.typ",
|
|
|
|
{check=ISA_core.ML_isa_check_typ, elaborate=ISA_core.ML_isa_elaborate_generic}) \<close>
|
|
|
|
setup\<open>DOF_core.update_isa_global("Isa_DOF.term.term",
|
|
|
|
{check=ISA_core.ML_isa_check_term, elaborate=ISA_core.ML_isa_elaborate_generic}) \<close>
|
|
|
|
setup\<open>DOF_core.update_isa_global("Isa_DOF.term_repr",
|
2021-12-09 08:57:21 +00:00
|
|
|
{check=ISA_core.check_identity, elaborate=ISA_core.ML_isa_elaborate_generic}) \<close>
|
2021-11-04 14:10:02 +00:00
|
|
|
setup\<open>DOF_core.update_isa_global("Isa_DOF.thm.thm",
|
|
|
|
{check=ISA_core.ML_isa_check_thm, elaborate=ISA_core.ML_isa_elaborate_generic}) \<close>
|
|
|
|
setup\<open>DOF_core.update_isa_global("Isa_DOF.file.file",
|
|
|
|
{check=ISA_core.ML_isa_check_file, elaborate=ISA_core.ML_isa_elaborate_generic}) \<close>
|
|
|
|
setup\<open>DOF_core.update_isa_global("Isa_DOF.docitem",
|
|
|
|
{check=ISA_core.ML_isa_check_docitem, elaborate=ISA_core.ML_isa_elaborate_generic}) \<close>
|
2022-11-25 07:57:59 +00:00
|
|
|
setup\<open>DOF_core.update_isa_global("Isa_DOF.trace_attribute",
|
2022-11-24 13:20:29 +00:00
|
|
|
{check=ISA_core.ML_isa_check_trace_attribute, elaborate=ISA_core.ML_isa_elaborate_trace_attribute}) \<close>
|
2018-09-11 06:50:51 +00:00
|
|
|
section\<open> Syntax for Annotated Documentation Commands (the '' View'' Part I) \<close>
|
2019-04-06 17:58:13 +00:00
|
|
|
|
2019-04-29 20:24:32 +00:00
|
|
|
|
|
|
|
(*
|
|
|
|
================== 2018 ======================================================
|
|
|
|
(* Exported from Pure_Syn *)
|
|
|
|
|
|
|
|
fun output_document state markdown txt =
|
|
|
|
let
|
|
|
|
val ctxt = Toplevel.presentation_context state;
|
|
|
|
val _ =
|
|
|
|
Context_Position.report ctxt
|
|
|
|
(Input.pos_of txt) (Markup.language_document (Input.is_delimited txt));
|
|
|
|
in Thy_Output.output_document ctxt markdown txt end;
|
|
|
|
|
|
|
|
fun document_command markdown (loc, txt) =
|
|
|
|
Toplevel.keep (fn state =>
|
|
|
|
(case loc of
|
|
|
|
NONE => ignore (output_document state markdown txt)
|
|
|
|
| SOME (_, pos) =>
|
|
|
|
error ("Illegal target specification -- not a theory context" ^ Position.here pos))) o
|
|
|
|
Toplevel.present_local_theory loc (fn state =>
|
|
|
|
ignore (output_document state markdown txt));
|
|
|
|
|
|
|
|
|
|
|
|
====================== 2017 ===================================================
|
|
|
|
|
|
|
|
(* Exported from Thy_Output *)
|
|
|
|
fun document_command markdown (loc, txt) =
|
|
|
|
Toplevel.keep (fn state =>
|
|
|
|
(case loc of
|
|
|
|
NONE => ignore (output_text state markdown txt)
|
|
|
|
| SOME (_, pos) =>
|
|
|
|
error ("Illegal target specification -- not a theory context" ^ Position.here pos))) o
|
|
|
|
Toplevel.present_local_theory loc (fn state => ignore (output_text state markdown txt));
|
|
|
|
|
|
|
|
|
|
|
|
*)
|
|
|
|
|
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
ML\<open>
|
2022-05-25 15:07:06 +00:00
|
|
|
structure ODL_Meta_Args_Parser =
|
2018-02-07 18:44:27 +00:00
|
|
|
struct
|
|
|
|
|
2019-04-29 20:24:32 +00:00
|
|
|
|
2018-08-16 14:52:08 +00:00
|
|
|
type meta_args_t = (((string * Position.T) *
|
|
|
|
(string * Position.T) option)
|
|
|
|
* ((string * Position.T) * string) list)
|
|
|
|
|
2023-01-23 07:50:36 +00:00
|
|
|
val empty_meta_args = ((("", Position.none), NONE), [])
|
|
|
|
|
2018-10-04 13:58:20 +00:00
|
|
|
val is_improper = not o (Token.is_proper orf Token.is_begin_ignore orf Token.is_end_ignore);
|
2018-10-04 15:25:45 +00:00
|
|
|
val improper = Scan.many is_improper; (* parses white-space and comments *)
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
val attribute =
|
2018-10-04 14:58:09 +00:00
|
|
|
Parse.position Parse.const
|
|
|
|
--| improper
|
2018-10-04 15:25:45 +00:00
|
|
|
-- Scan.optional (Parse.$$$ "=" --| improper |-- Parse.!!! Parse.term --| improper) "True"
|
2018-10-04 14:58:09 +00:00
|
|
|
: ((string * Position.T) * string) parser;
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-04-27 15:12:42 +00:00
|
|
|
val attribute_upd : (((string * Position.T) * string) * string) parser =
|
2018-04-16 15:00:31 +00:00
|
|
|
Parse.position Parse.const
|
2018-10-04 15:25:45 +00:00
|
|
|
--| improper
|
|
|
|
-- ((@{keyword "+="} --| improper) || (@{keyword ":="} --| improper))
|
|
|
|
-- Parse.!!! Parse.term
|
|
|
|
--| improper
|
|
|
|
: (((string * Position.T) * string) * string) parser;
|
2018-04-29 09:35:24 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
val reference =
|
2018-04-04 08:45:56 +00:00
|
|
|
Parse.position Parse.name
|
2018-10-04 15:25:45 +00:00
|
|
|
--| improper
|
2018-10-04 15:45:39 +00:00
|
|
|
-- Scan.option (Parse.$$$ "::"
|
|
|
|
-- improper
|
|
|
|
|-- (Parse.!!! (Parse.position Parse.name))
|
|
|
|
)
|
|
|
|
--| improper;
|
2018-02-28 10:31:42 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-04-05 10:44:52 +00:00
|
|
|
val attributes =
|
2018-10-04 14:58:09 +00:00
|
|
|
((Parse.$$$ "["
|
2018-10-04 13:58:20 +00:00
|
|
|
-- improper
|
2018-04-05 10:44:52 +00:00
|
|
|
|-- (reference --
|
2018-10-04 14:58:09 +00:00
|
|
|
(Scan.optional(Parse.$$$ "," -- improper |-- (Parse.enum "," (improper |-- attribute)))) []))
|
|
|
|
--| Parse.$$$ "]"
|
2023-01-23 07:50:36 +00:00
|
|
|
--| improper) : meta_args_t parser
|
|
|
|
|
|
|
|
val opt_attributes = Scan.optional attributes empty_meta_args
|
2018-04-05 10:44:52 +00:00
|
|
|
|
|
|
|
val attributes_upd =
|
2018-10-04 15:45:39 +00:00
|
|
|
((Parse.$$$ "["
|
2018-10-04 13:58:20 +00:00
|
|
|
-- improper
|
2018-04-05 10:44:52 +00:00
|
|
|
|-- (reference --
|
2018-10-04 14:58:09 +00:00
|
|
|
(Scan.optional(Parse.$$$ "," -- improper |-- (Parse.enum "," (improper |-- attribute_upd)))) []))
|
2018-10-04 15:45:39 +00:00
|
|
|
--| Parse.$$$ "]")
|
|
|
|
--| improper
|
2022-05-25 15:07:06 +00:00
|
|
|
end (* structure ODL_Meta_Args_Parser *)
|
|
|
|
\<close>
|
|
|
|
|
|
|
|
ML\<open>
|
|
|
|
(* c.f. \<^file>\<open>~~/src/HOL/Tools/value_command.ML\<close> *)
|
|
|
|
(*
|
|
|
|
The value* command uses the same code as the value command
|
|
|
|
and adds the evaluation Term Annotation Antiquotations (TA)
|
|
|
|
with the help of the DOF_core.transduce_term_global function.
|
|
|
|
*)
|
|
|
|
(* Based on:
|
|
|
|
Title: HOL/Tools/value_command.ML
|
|
|
|
Author: Florian Haftmann, TU Muenchen
|
|
|
|
|
|
|
|
Generic value command for arbitrary evaluators, with default using nbe or SML.
|
|
|
|
*)
|
|
|
|
|
|
|
|
(*signature VALUE_COMMAND =
|
|
|
|
sig
|
|
|
|
val value: Proof.context -> term -> term
|
|
|
|
val value_without_elaboration: Proof.context -> term -> term
|
|
|
|
val value_select: string -> Proof.context -> term -> term
|
|
|
|
val value_cmd: {assert: bool} -> ODL_Command_Parser.meta_args_t option ->
|
|
|
|
string -> string list -> string -> Position.T
|
|
|
|
-> theory -> theory
|
|
|
|
val add_evaluator: binding * (Proof.context -> term -> term)
|
|
|
|
-> theory -> string * theory
|
|
|
|
end;*)
|
|
|
|
|
|
|
|
|
|
|
|
structure Value_Command (*: VALUE_COMMAND*) =
|
|
|
|
struct
|
|
|
|
|
|
|
|
structure Evaluators = Theory_Data
|
|
|
|
(
|
|
|
|
type T = (Proof.context -> term -> term) Name_Space.table;
|
|
|
|
val empty = Name_Space.empty_table "evaluator";
|
|
|
|
val merge = Name_Space.merge_tables;
|
|
|
|
)
|
|
|
|
|
|
|
|
fun add_evaluator (b, evaluator) thy =
|
|
|
|
let
|
|
|
|
val (name, tab') = Name_Space.define (Context.Theory thy) true
|
|
|
|
(b, evaluator) (Evaluators.get thy);
|
|
|
|
val thy' = Evaluators.put tab' thy;
|
|
|
|
in (name, thy') end;
|
|
|
|
|
|
|
|
fun intern_evaluator thy raw_name =
|
|
|
|
if raw_name = "" then ""
|
|
|
|
else Name_Space.intern (Name_Space.space_of_table
|
|
|
|
(Evaluators.get (thy))) raw_name;
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2022-05-25 15:07:06 +00:00
|
|
|
fun default_value ctxt t =
|
|
|
|
if null (Term.add_frees t [])
|
|
|
|
then Code_Evaluation.dynamic_value_strict ctxt t
|
|
|
|
else Nbe.dynamic_value ctxt t;
|
2018-06-14 13:35:14 +00:00
|
|
|
|
2022-05-25 15:07:06 +00:00
|
|
|
fun value_select name ctxt =
|
|
|
|
if name = ""
|
|
|
|
then default_value ctxt
|
|
|
|
else Name_Space.get (Evaluators.get (Proof_Context.theory_of ctxt)) name ctxt;
|
|
|
|
|
2023-01-09 10:34:40 +00:00
|
|
|
fun value_select' raw_name ctxt =
|
|
|
|
if raw_name = ""
|
2022-12-22 09:55:03 +00:00
|
|
|
then (DOF_core.elaborate_term ctxt) #> default_value ctxt
|
|
|
|
else (DOF_core.elaborate_term ctxt)
|
2023-01-09 10:34:40 +00:00
|
|
|
#> (let val name = intern_evaluator (Proof_Context.theory_of ctxt) raw_name in
|
|
|
|
Name_Space.get (Evaluators.get (Proof_Context.theory_of ctxt)) name ctxt end);
|
2022-12-22 09:55:03 +00:00
|
|
|
|
|
|
|
val value = value_select' ""
|
|
|
|
|
2022-05-25 15:07:06 +00:00
|
|
|
val value_without_elaboration = value_select ""
|
|
|
|
|
|
|
|
structure Docitem_Parser =
|
|
|
|
struct
|
2018-04-27 08:34:24 +00:00
|
|
|
|
2018-08-24 14:58:06 +00:00
|
|
|
fun cid_2_cidType cid_long thy =
|
2022-12-02 10:41:31 +00:00
|
|
|
if cid_long = DOF_core.default_cid then \<^Type>\<open>unit\<close>
|
2018-10-05 07:45:24 +00:00
|
|
|
else let val t = #docclass_tab(DOF_core.get_data_global thy)
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
fun ty_name cid = cid^"."^ Long_Name.base_name cid ^ Record.extN
|
2018-08-24 14:58:06 +00:00
|
|
|
fun fathers cid_long = case Symtab.lookup t cid_long of
|
2020-02-20 12:30:51 +00:00
|
|
|
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
|
2018-08-24 14:58:06 +00:00
|
|
|
| SOME ({inherits_from=NONE, ...}) => [cid_long]
|
|
|
|
| SOME ({inherits_from=SOME(_,father), ...}) =>
|
|
|
|
cid_long :: (fathers father)
|
2022-12-02 10:41:31 +00:00
|
|
|
in fold (fn x => fn y => Type(ty_name x,[y])) (fathers cid_long) \<^Type>\<open>unit\<close>
|
2018-08-24 14:58:06 +00:00
|
|
|
end
|
2018-08-22 20:06:15 +00:00
|
|
|
|
2021-10-20 07:10:11 +00:00
|
|
|
fun create_default_object thy class_name =
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
let
|
|
|
|
val purified_class_name = String.translate (fn #"." => "_" | x => String.implode [x]) class_name
|
|
|
|
val make_const = Syntax.read_term_global thy (Long_Name.qualify class_name makeN);
|
|
|
|
fun attr_to_free (binding, typ, _) = Free (purified_class_name ^ "_"
|
|
|
|
^ (Binding.name_of binding)
|
|
|
|
^ "_Attribute_Not_Initialized", typ)
|
2022-11-24 13:20:29 +00:00
|
|
|
val class_list = DOF_core.get_attributes class_name thy
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
fun attrs_filter [] = []
|
|
|
|
| attrs_filter (x::xs) =
|
|
|
|
let val (cid, ys) = x
|
|
|
|
fun is_duplicated _ [] = false
|
|
|
|
| is_duplicated y (x::xs) =
|
|
|
|
let val (_, ys) = x
|
|
|
|
in if exists (map_eq_fst_triple Binding.name_of y) ys
|
|
|
|
then true
|
|
|
|
else is_duplicated y xs end
|
|
|
|
in (cid, filter_out (fn y => is_duplicated y xs) ys)::attrs_filter xs end
|
2022-11-24 13:20:29 +00:00
|
|
|
val class_list' = rev (attrs_filter (rev class_list))
|
2022-12-02 10:41:31 +00:00
|
|
|
val tag_attr = HOLogic.mk_number \<^Type>\<open>int\<close>
|
2022-11-24 13:20:29 +00:00
|
|
|
fun add_tag_to_attrs_free' tag_attr thy (cid, filtered_attr_list) =
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
if DOF_core.is_virtual cid thy
|
2022-11-24 13:20:29 +00:00
|
|
|
then (tag_attr (serial ()))::(map (attr_to_free) filtered_attr_list)
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
else (map (attr_to_free) filtered_attr_list)
|
2022-11-24 13:20:29 +00:00
|
|
|
val class_list'' = flat (map (add_tag_to_attrs_free' tag_attr thy) class_list')
|
|
|
|
in list_comb (make_const, (tag_attr (serial()))::class_list'') end
|
|
|
|
|
2018-04-27 08:34:24 +00:00
|
|
|
|
2022-12-14 11:02:15 +00:00
|
|
|
fun check_classref {is_monitor=is_monitor} (SOME(cid,pos)) thy =
|
2020-02-21 14:39:50 +00:00
|
|
|
let
|
|
|
|
val cid_long = DOF_core.read_cid_global thy cid
|
|
|
|
|
2018-10-08 13:13:47 +00:00
|
|
|
val {id, name=bind_target,rex,...} = the(DOF_core.get_doc_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 ()
|
2018-04-27 08:34:24 +00:00
|
|
|
val markup = docclass_markup false cid id (Binding.pos_of bind_target);
|
|
|
|
val ctxt = Context.Theory thy
|
2022-12-14 11:02:15 +00:00
|
|
|
val _ = Context_Position.report_generic ctxt pos markup;
|
|
|
|
in (cid_long, pos)
|
2018-04-27 08:34:24 +00:00
|
|
|
end
|
2022-12-21 17:32:07 +00:00
|
|
|
| check_classref _ NONE _ = (DOF_core.default_cid, Position.none)
|
2018-04-27 08:34:24 +00:00
|
|
|
|
|
|
|
|
2018-04-27 15:12:42 +00:00
|
|
|
fun generalize_typ n = Term.map_type_tfree (fn (str,sort)=> Term.TVar((str,n),sort));
|
|
|
|
fun infer_type thy term = hd (Type_Infer_Context.infer_types (Proof_Context.init_global thy) [term])
|
2018-08-24 13:49:13 +00:00
|
|
|
|
|
|
|
|
2022-03-28 16:19:41 +00:00
|
|
|
fun calc_update_term {mk_elaboration=mk_elaboration} thy cid_long
|
|
|
|
(S:(string * Position.T * string * term)list) term =
|
2022-04-04 06:08:47 +00:00
|
|
|
let val cid_ty = cid_2_cidType cid_long thy
|
2018-08-24 13:49:13 +00:00
|
|
|
val generalize_term = Term.map_types (generalize_typ 0)
|
|
|
|
fun toString t = Syntax.string_of_term (Proof_Context.init_global thy) t
|
2021-12-18 22:06:51 +00:00
|
|
|
fun instantiate_term S t =
|
|
|
|
Term_Subst.map_types_same (Term_Subst.instantiateT (TVars.make S)) (t)
|
2018-09-11 06:50:51 +00:00
|
|
|
fun read_assn (lhs, pos:Position.T, opr, rhs) term =
|
2022-04-04 06:08:47 +00:00
|
|
|
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)
|
|
|
|
in
|
|
|
|
if exists (fn (binding, _, _) => Binding.name_of binding = attribute_name)
|
|
|
|
attribute_decl
|
|
|
|
then parent_cid
|
|
|
|
else
|
|
|
|
case inherits_from of
|
|
|
|
NONE =>
|
|
|
|
ISA_core.err ("Attribute not defined for class: " ^ cid_long) pos
|
|
|
|
| SOME (_, parent_name) =>
|
|
|
|
get_class_name parent_name attribute_name pos
|
|
|
|
end
|
|
|
|
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 markup = docclass_markup false cid_long id (Binding.pos_of name);
|
|
|
|
val ctxt = Context.Theory thy
|
|
|
|
val _ = Context_Position.report_generic ctxt pos markup;
|
|
|
|
val info_opt = DOF_core.get_attribute_info cid_long (Long_Name.base_name lhs) thy
|
2018-08-24 13:49:13 +00:00
|
|
|
val (ln,lnt,lnu,lnut) = case info_opt of
|
|
|
|
NONE => error ("unknown attribute >"
|
|
|
|
^((Long_Name.base_name lhs))
|
|
|
|
^"< in class: "^cid_long)
|
|
|
|
| SOME{long_name, typ, ...} => (long_name, typ,
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
long_name ^ Record.updateN,
|
2018-08-24 13:49:13 +00:00
|
|
|
(typ --> typ)
|
|
|
|
--> cid_ty --> cid_ty)
|
|
|
|
val tyenv = Sign.typ_match thy ((generalize_typ 0)(type_of rhs), lnt) (Vartab.empty)
|
2019-03-05 08:36:12 +00:00
|
|
|
handle Type.TYPE_MATCH => (error ("type of attribute: " ^ ln
|
2018-08-24 13:49:13 +00:00
|
|
|
^ " does not fit to term: "
|
2019-03-05 08:36:12 +00:00
|
|
|
^ toString rhs));
|
2018-08-24 13:49:13 +00:00
|
|
|
val tyenv' = (map (fn (s,(t,u)) => ((s,t),u)) (Vartab.dest tyenv))
|
|
|
|
val _ = if Long_Name.base_name lhs = lhs orelse ln = lhs then ()
|
|
|
|
else error("illegal notation for attribute of "^cid_long)
|
2022-12-02 10:41:31 +00:00
|
|
|
fun join (ttt as \<^Type>\<open>int\<close>) = \<^Const>\<open>Groups.plus ttt\<close>
|
|
|
|
|join (ttt as \<^Type>\<open>set _\<close>) = \<^Const>\<open>Lattices.sup ttt\<close>
|
|
|
|
|join \<^Type>\<open>list A\<close> = \<^Const>\<open>List.append A\<close>
|
2018-08-24 13:49:13 +00:00
|
|
|
|join _ = error("implicit fusion operation not defined for attribute: "^ lhs)
|
|
|
|
(* could be extended to bool, map, multisets, ... *)
|
2018-09-17 14:48:05 +00:00
|
|
|
val rhs' = instantiate_term tyenv' (generalize_term rhs)
|
2022-03-28 16:19:41 +00:00
|
|
|
val rhs'' = DOF_core.transduce_term_global {mk_elaboration=mk_elaboration}
|
|
|
|
(rhs',pos) thy
|
2018-08-24 13:49:13 +00:00
|
|
|
in case opr of
|
2018-09-17 14:48:05 +00:00
|
|
|
"=" => Const(lnu,lnut) $ Abs ("uu_", lnt, rhs'') $ term
|
|
|
|
| ":=" => Const(lnu,lnut) $ Abs ("uu_", lnt, rhs'') $ term
|
|
|
|
| "+=" => Const(lnu,lnut) $ Abs ("uu_", lnt, join lnt $ (Bound 0) $ rhs'') $ term
|
2018-08-24 13:49:13 +00:00
|
|
|
| _ => error "corrupted syntax - oops - this should not occur"
|
|
|
|
end
|
|
|
|
in Sign.certify_term thy (fold read_assn S term) end
|
|
|
|
|
2022-12-14 11:02:15 +00:00
|
|
|
fun msg thy txt pos = if Config.get_global thy DOF_core.strict_monitor_checking
|
|
|
|
then ISA_core.err txt pos
|
|
|
|
else ISA_core.warn txt pos
|
|
|
|
|
|
|
|
fun register_oid_cid_in_open_monitors oid pos cid_pos thy =
|
|
|
|
let val {monitor_tab,...} = DOF_core.get_data_global thy
|
|
|
|
val cid_long= fst cid_pos
|
|
|
|
val pos' = snd cid_pos
|
|
|
|
fun is_enabled (n, info) =
|
|
|
|
if exists (DOF_core.is_subclass_global thy cid_long)
|
|
|
|
(DOF_core.get_alphabet info)
|
|
|
|
then SOME n
|
|
|
|
else if Config.get_global thy DOF_core.free_class_in_monitor_strict_checking
|
|
|
|
orelse Config.get_global thy DOF_core.free_class_in_monitor_checking
|
|
|
|
then SOME n
|
|
|
|
else NONE
|
|
|
|
(* filtering those monitors with automata, whose alphabet contains the
|
|
|
|
cid of this oid. The enabled ones were selected and moved to their successor state
|
|
|
|
along the super-class id. The evaluation is in parallel, simulating a product
|
|
|
|
semantics without expanding the subclass relationship. *)
|
|
|
|
fun is_enabled_for_cid moid =
|
|
|
|
let val {accepted_cids, automatas, rejected_cids, ...} =
|
|
|
|
the(Symtab.lookup monitor_tab moid)
|
|
|
|
val indexS= 1 upto (length automatas)
|
|
|
|
val indexed_autoS = automatas ~~ indexS
|
|
|
|
fun check_for_cid (A,n) =
|
|
|
|
let fun direct_super_class _ cid [] = cid
|
|
|
|
| direct_super_class thy cid (x::xs) =
|
|
|
|
if DOF_core.is_subclass_global thy cid x
|
|
|
|
then direct_super_class thy cid xs
|
|
|
|
else direct_super_class thy x xs
|
|
|
|
val accS = (RegExpInterface.enabled A accepted_cids)
|
|
|
|
val accS' = filter (DOF_core.is_subclass_global thy cid_long) accS
|
|
|
|
fun first_super_class cids =
|
|
|
|
case List.getItem cids
|
|
|
|
of SOME (hd,tl) => SOME (direct_super_class thy hd tl)
|
|
|
|
| NONE => NONE
|
|
|
|
val first_accepted = first_super_class accS'
|
|
|
|
val rejectS = filter (DOF_core.is_subclass_global thy cid_long) rejected_cids
|
|
|
|
val first_rejected = first_super_class rejectS
|
|
|
|
in
|
|
|
|
case first_accepted of
|
|
|
|
NONE => (case first_rejected of
|
|
|
|
NONE =>
|
|
|
|
let val msg_intro = ("accepts clause " ^ Int.toString n
|
|
|
|
^ " of monitor " ^ moid
|
|
|
|
^ " not enabled for doc_class: " ^ cid_long)
|
|
|
|
in
|
|
|
|
if Config.get_global thy DOF_core.free_class_in_monitor_strict_checking
|
|
|
|
then ISA_core.err msg_intro pos'
|
|
|
|
else if Config.get_global thy DOF_core.free_class_in_monitor_checking
|
|
|
|
then (ISA_core.warn msg_intro pos';A)
|
|
|
|
else A
|
2018-11-05 20:42:36 +00:00
|
|
|
end
|
2022-12-14 11:02:15 +00:00
|
|
|
| SOME _ => (msg thy ("accepts clause " ^ Int.toString n
|
|
|
|
^ " of monitor " ^ moid
|
|
|
|
^ " rejected doc_class: " ^ cid_long) pos';A))
|
|
|
|
| SOME accepted => (case first_rejected of
|
|
|
|
NONE => RegExpInterface.next A accepted_cids (accepted)
|
|
|
|
| SOME rejected =>
|
|
|
|
if DOF_core.is_subclass_global thy accepted rejected
|
|
|
|
then RegExpInterface.next A accepted_cids (accepted)
|
|
|
|
else (msg thy ("accepts clause " ^ Int.toString n
|
|
|
|
^ " of monitor " ^ moid
|
|
|
|
^ " rejected doc_class: " ^ cid_long) pos';A))
|
|
|
|
end
|
|
|
|
in (moid,map check_for_cid indexed_autoS) end
|
|
|
|
val enabled_monitors = List.mapPartial is_enabled (Symtab.dest monitor_tab)
|
|
|
|
fun conv_attrs (((lhs, pos), opn), rhs) = (markup2string lhs,pos,opn,
|
|
|
|
Syntax.read_term_global thy rhs)
|
|
|
|
val trace_attr = [((("trace", @{here}), "+="), "[("^cid_long^", ''"^oid^"'')]")]
|
|
|
|
val assns' = map conv_attrs trace_attr
|
|
|
|
fun cid_of oid = #cid(the(DOF_core.get_object_global oid thy))
|
|
|
|
fun def_trans_input_term oid =
|
|
|
|
#1 o (calc_update_term {mk_elaboration=false} thy (cid_of oid) assns')
|
|
|
|
fun def_trans_value oid =
|
|
|
|
(#1 o (calc_update_term {mk_elaboration=true} thy (cid_of oid) assns'))
|
|
|
|
#> value (Proof_Context.init_global thy)
|
|
|
|
val _ = if null enabled_monitors then () else writeln "registrating in monitors ..."
|
|
|
|
val _ = app (fn n => writeln(oid^" : "^cid_long^" ==> "^n)) enabled_monitors;
|
|
|
|
(* check that any transition is possible : *)
|
|
|
|
fun inst_class_inv x = DOF_core.get_class_invariant(cid_of x) thy x {is_monitor=false}
|
|
|
|
fun class_inv_checks ctxt = map (fn x => inst_class_inv x ctxt) enabled_monitors
|
|
|
|
val delta_autoS = map is_enabled_for_cid enabled_monitors;
|
|
|
|
fun update_info (n, aS) (tab: DOF_core.monitor_tab) =
|
|
|
|
let val {accepted_cids,rejected_cids,...} = the(Symtab.lookup tab n)
|
|
|
|
in Symtab.update(n, {accepted_cids=accepted_cids,
|
|
|
|
rejected_cids=rejected_cids,
|
|
|
|
automatas=aS}) tab end
|
|
|
|
fun update_trace mon_oid = DOF_core.update_value_global mon_oid (def_trans_input_term mon_oid) (def_trans_value mon_oid)
|
|
|
|
val update_automatons = DOF_core.upd_monitor_tabs(fold update_info delta_autoS)
|
|
|
|
in thy |> (* update traces of all enabled monitors *)
|
|
|
|
fold (update_trace) (enabled_monitors)
|
|
|
|
|> (* check class invariants of enabled monitors *)
|
|
|
|
(fn thy => (class_inv_checks (Context.Theory thy); thy))
|
|
|
|
|> (* update the automata of enabled monitors *)
|
|
|
|
DOF_core.map_data_global(update_automatons)
|
|
|
|
end
|
2018-08-27 12:39:34 +00:00
|
|
|
|
2021-12-14 17:04:04 +00:00
|
|
|
fun check_invariants thy oid =
|
|
|
|
let
|
2022-05-25 15:07:06 +00:00
|
|
|
val docitem_value = the (DOF_core.get_value_global oid thy)
|
2021-12-14 17:04:04 +00:00
|
|
|
val cid = #cid (the (DOF_core.get_object_global oid thy))
|
|
|
|
fun get_all_invariants cid thy =
|
2022-04-07 13:36:01 +00:00
|
|
|
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)
|
2021-12-14 17:04:04 +00:00
|
|
|
val invariants = get_all_invariants cid thy
|
|
|
|
val inv_and_apply_list =
|
|
|
|
let fun mk_inv_and_apply inv value thy =
|
|
|
|
let val ((s, pos), _ (*term*)) = inv
|
|
|
|
val inv_def = Syntax.read_term_global thy (s ^ invariant_suffixN)
|
|
|
|
val inv_def_typ = Term.type_of value
|
|
|
|
in case inv_def of
|
|
|
|
Const (s, Type (st, [_ (*ty*), ty'])) =>
|
|
|
|
((s, pos), Const (s, Type (st,[inv_def_typ, ty'])) $ value)
|
|
|
|
| _ => ((s, pos), inv_def $ value)
|
|
|
|
end
|
2022-05-25 15:07:06 +00:00
|
|
|
in map (fn inv => mk_inv_and_apply inv docitem_value thy) invariants
|
2021-12-14 17:04:04 +00:00
|
|
|
end
|
|
|
|
fun check_invariants' ((inv_name, pos), term) =
|
|
|
|
let val ctxt = Proof_Context.init_global thy
|
2022-12-12 11:01:04 +00:00
|
|
|
val trivial_true = \<^term>\<open>True\<close> |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt |> Thm.trivial
|
2022-05-25 15:07:06 +00:00
|
|
|
val evaluated_term = value ctxt term
|
2021-12-14 17:04:04 +00:00
|
|
|
handle ERROR e =>
|
|
|
|
if (String.isSubstring "Wellsortedness error" e)
|
|
|
|
andalso (Config.get_global thy DOF_core.invariants_checking_with_tactics)
|
2022-12-12 11:01:04 +00:00
|
|
|
then (warning("Invariants checking uses proof tactics");
|
2021-12-14 17:04:04 +00:00
|
|
|
let val prop_term = HOLogic.mk_Trueprop term
|
|
|
|
val thms = Proof_Context.get_thms ctxt (inv_name ^ def_suffixN)
|
|
|
|
(* Get the make definition (def(1) of the record) *)
|
|
|
|
val thms' =
|
|
|
|
(Proof_Context.get_thms ctxt (Long_Name.append cid defsN)) @ thms
|
|
|
|
val _ = Goal.prove ctxt [] [] prop_term
|
|
|
|
(K ((unfold_tac ctxt thms') THEN (auto_tac ctxt)))
|
|
|
|
|> Thm.close_derivation \<^here>
|
2022-03-11 11:30:34 +00:00
|
|
|
handle ERROR e =>
|
2022-12-12 11:01:04 +00:00
|
|
|
let
|
|
|
|
val msg_intro = "Invariant "
|
2022-03-11 11:30:34 +00:00
|
|
|
^ inv_name
|
|
|
|
^ " failed to be checked using proof tactics"
|
2022-12-12 11:01:04 +00:00
|
|
|
^ " with error:\n"
|
|
|
|
in
|
|
|
|
if Config.get_global thy DOF_core.invariants_strict_checking
|
|
|
|
then ISA_core.err (msg_intro ^ e) pos
|
|
|
|
else (ISA_core.warn (msg_intro ^ e) pos; trivial_true) end
|
2021-12-14 17:04:04 +00:00
|
|
|
(* If Goal.prove does not fail, then the evaluation is considered True,
|
|
|
|
else an error is triggered by Goal.prove *)
|
|
|
|
in @{term True} end)
|
2022-12-12 11:01:04 +00:00
|
|
|
else \<^term>\<open>True \<Longrightarrow> True\<close>
|
|
|
|
in case evaluated_term of
|
|
|
|
\<^term>\<open>True\<close> => ((inv_name, pos), term)
|
|
|
|
| \<^term>\<open>True \<Longrightarrow> True\<close> =>
|
|
|
|
let val msg_intro = "Fail to check invariant "
|
|
|
|
^ inv_name
|
|
|
|
^ ".\nMaybe you can try "
|
|
|
|
^ "to activate invariants_checking_with_tactics\n"
|
|
|
|
^ "if your invariant is checked against doc_class algebraic "
|
|
|
|
^ "types like 'doc_class list' or 'doc_class set'"
|
|
|
|
in if Config.get_global thy DOF_core.invariants_strict_checking
|
|
|
|
then ISA_core.err (msg_intro) pos
|
|
|
|
else (ISA_core.warn (msg_intro) pos; ((inv_name, pos), term)) end
|
|
|
|
| _ => let val msg_intro = "Invariant " ^ inv_name ^ " violated"
|
|
|
|
in if Config.get_global thy DOF_core.invariants_strict_checking
|
|
|
|
then ISA_core.err msg_intro pos
|
|
|
|
else (ISA_core.warn msg_intro pos; ((inv_name, pos), term)) end
|
2021-12-14 17:04:04 +00:00
|
|
|
end
|
2022-12-12 11:01:04 +00:00
|
|
|
val _ = map check_invariants' inv_and_apply_list
|
2021-12-14 17:04:04 +00:00
|
|
|
in thy end
|
2018-11-05 20:42:36 +00:00
|
|
|
|
2020-06-16 07:08:36 +00:00
|
|
|
fun create_and_check_docitem is_monitor {is_inline=is_inline} oid pos cid_pos doc_attrs thy =
|
2021-12-14 17:04:04 +00:00
|
|
|
let
|
2022-03-11 11:30:34 +00:00
|
|
|
val id = serial ();
|
2021-10-20 07:10:11 +00:00
|
|
|
val _ = Position.report pos (docref_markup true oid id pos);
|
|
|
|
(* creates a markup label for this position and reports it to the PIDE framework;
|
|
|
|
this label is used as jump-target for point-and-click feature. *)
|
2022-12-14 11:02:15 +00:00
|
|
|
val cid_pos' = check_classref is_monitor cid_pos thy
|
|
|
|
val cid_long = fst cid_pos'
|
2022-12-12 11:01:04 +00:00
|
|
|
val default_cid = cid_long = DOF_core.default_cid
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
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)
|
|
|
|
else NONE
|
2022-12-12 11:01:04 +00:00
|
|
|
val value_terms = if default_cid
|
2022-03-28 16:19:41 +00:00
|
|
|
then let
|
2022-12-12 11:01:04 +00:00
|
|
|
val undefined_value = Free ("Undefined_Value", \<^Type>\<open>unit\<close>)
|
2022-03-28 16:19:41 +00:00
|
|
|
in (undefined_value, undefined_value) end
|
2022-12-12 11:01:04 +00:00
|
|
|
(* Handle initialization of docitem without a class associated,
|
|
|
|
for example when you just want a document element to be referenceable
|
|
|
|
without using the burden of ontology classes.
|
|
|
|
ex: text*[sdf]\<open> Lorem ipsum @{thm refl}\<close> *)
|
2021-10-20 07:10:11 +00:00
|
|
|
else let
|
|
|
|
val defaults_init = create_default_object thy cid_long
|
|
|
|
fun conv (na, _(*ty*), term) =(Binding.name_of na, Binding.pos_of na, "=", term);
|
|
|
|
val S = map conv (DOF_core.get_attribute_defaults cid_long thy);
|
2022-03-28 16:19:41 +00:00
|
|
|
val (defaults, _(*ty*), _) = calc_update_term {mk_elaboration=false}
|
|
|
|
thy cid_long S defaults_init;
|
2021-10-20 07:10:11 +00:00
|
|
|
fun conv_attrs ((lhs, pos), rhs) = (markup2string lhs,pos,"=", Syntax.read_term_global thy rhs)
|
|
|
|
val assns' = map conv_attrs doc_attrs
|
2022-03-28 16:19:41 +00:00
|
|
|
val (input_term, _(*ty*), _) = calc_update_term {mk_elaboration=false}
|
|
|
|
thy cid_long assns' defaults
|
|
|
|
val (value_term', _(*ty*), _) = calc_update_term {mk_elaboration=true}
|
|
|
|
thy cid_long assns' defaults
|
|
|
|
in (input_term, value_term') end
|
2021-10-20 07:10:11 +00:00
|
|
|
val check_inv = (DOF_core.get_class_invariant cid_long thy oid is_monitor)
|
2021-12-14 17:04:04 +00:00
|
|
|
o Context.Theory
|
|
|
|
|
2022-03-28 16:19:41 +00:00
|
|
|
in thy |> DOF_core.define_object_global (oid, {pos = pos,
|
|
|
|
thy_name = Context.theory_name thy,
|
|
|
|
input_term = fst value_terms,
|
2022-05-25 15:07:06 +00:00
|
|
|
value = value (Proof_Context.init_global thy)
|
|
|
|
(snd value_terms),
|
2022-03-28 16:19:41 +00:00
|
|
|
inline = is_inline,
|
|
|
|
id = id,
|
|
|
|
cid = cid_long,
|
|
|
|
vcid = vcid})
|
2022-12-14 11:02:15 +00:00
|
|
|
|> register_oid_cid_in_open_monitors oid pos cid_pos'
|
2022-05-25 15:13:49 +00:00
|
|
|
|> (fn thy => if #is_monitor(is_monitor)
|
|
|
|
then (((DOF_core.get_class_eager_invariant cid_long thy oid) is_monitor
|
|
|
|
o Context.Theory) thy; thy)
|
|
|
|
else thy)
|
2021-10-20 07:10:11 +00:00
|
|
|
|> (fn thy => (check_inv thy; thy))
|
2022-12-12 11:01:04 +00:00
|
|
|
(* Bypass checking of high-level invariants when the class default_cid = "text",
|
|
|
|
the top (default) document class.
|
|
|
|
We want the class default_cid to stay abstract
|
|
|
|
and not have the capability to be defined with attribute, invariants, etc.
|
|
|
|
Hence this bypass handles docitem without a class associated,
|
|
|
|
for example when you just want a document element to be referenceable
|
|
|
|
without using the burden of ontology classes.
|
|
|
|
ex: text*[sdf]\<open> Lorem ipsum @{thm refl}\<close> *)
|
2022-12-22 06:53:42 +00:00
|
|
|
|> (fn thy => if default_cid then thy
|
|
|
|
else if Config.get_global thy DOF_core.invariants_checking
|
|
|
|
then check_invariants thy oid else thy)
|
2021-10-20 07:10:11 +00:00
|
|
|
end
|
2018-08-27 12:39:34 +00:00
|
|
|
|
2022-05-25 15:07:06 +00:00
|
|
|
end (* structure Docitem_Parser *)
|
|
|
|
|
2023-01-23 07:50:36 +00:00
|
|
|
val empty_meta_args = ((("", Position.none), NONE), [])
|
|
|
|
|
|
|
|
fun meta_args_exec (meta_args as (((oid,pos),cid_pos), doc_attrs) : ODL_Meta_Args_Parser.meta_args_t) thy =
|
|
|
|
thy |> (if meta_args = empty_meta_args
|
|
|
|
then (K thy)
|
|
|
|
else Docitem_Parser.create_and_check_docitem
|
2022-05-25 15:07:06 +00:00
|
|
|
{is_monitor = false} {is_inline = false}
|
|
|
|
oid pos (I cid_pos) (I doc_attrs))
|
|
|
|
|
|
|
|
fun value_cmd {assert=assert} meta_args_opt raw_name modes raw_t pos thy =
|
|
|
|
let
|
|
|
|
val thy' = meta_args_exec meta_args_opt thy
|
|
|
|
val name = intern_evaluator thy' raw_name;
|
|
|
|
val t = Syntax.read_term_global thy' raw_t;
|
|
|
|
val term' = DOF_core.transduce_term_global {mk_elaboration=true} (t , pos)
|
|
|
|
(thy');
|
|
|
|
val t' = value_select name (Proof_Context.init_global thy') term';
|
|
|
|
val ty' = Term.type_of t';
|
|
|
|
val ty' = if assert
|
|
|
|
then case ty' of
|
|
|
|
\<^typ>\<open>bool\<close> => ty'
|
|
|
|
| _ => error "Assertion expressions must be boolean."
|
|
|
|
else ty'
|
|
|
|
val t' = if assert
|
|
|
|
then case t' of
|
|
|
|
\<^term>\<open>True\<close> => t'
|
|
|
|
| _ => error "Assertion failed."
|
|
|
|
else t'
|
|
|
|
val ctxt' = Proof_Context.augment t' (Proof_Context.init_global thy');
|
|
|
|
val p = Print_Mode.with_modes modes (fn () =>
|
|
|
|
Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t'), Pretty.fbrk,
|
|
|
|
Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' ty')]) ();
|
|
|
|
val _ = Pretty.writeln p
|
|
|
|
in thy' end;
|
|
|
|
|
|
|
|
val opt_modes =
|
|
|
|
Scan.optional (\<^keyword>\<open>(\<close> |-- Parse.!!! (Scan.repeat1 Parse.name --| \<^keyword>\<open>)\<close>)) [];
|
|
|
|
|
|
|
|
val opt_evaluator =
|
|
|
|
Scan.optional (\<^keyword>\<open>[\<close> |-- Parse.name --| \<^keyword>\<open>]\<close>) "";
|
|
|
|
|
|
|
|
(*
|
|
|
|
We want to have the current position to pass it to transduce_term_global in
|
|
|
|
value_cmd, so we pass the Toplevel.transition
|
|
|
|
*)
|
|
|
|
|
|
|
|
fun pass_trans_to_value_cmd meta_args_opt ((name, modes), t) =
|
|
|
|
let val pos = Position.none
|
|
|
|
in
|
|
|
|
Toplevel.theory (value_cmd {assert=false} meta_args_opt name modes t pos)
|
|
|
|
end
|
|
|
|
|
|
|
|
fun pass_trans_to_assert_value_cmd meta_args_opt ((name, modes), t) =
|
|
|
|
let val pos = Position.none
|
|
|
|
in
|
|
|
|
Toplevel.theory (value_cmd {assert=true} meta_args_opt name modes t pos)
|
|
|
|
end
|
|
|
|
\<comment> \<open>c.f. \<^file>\<open>~~/src/Pure/Isar/isar_cmd.ML\<close>\<close>
|
|
|
|
|
|
|
|
(*
|
|
|
|
term* command uses the same code as term command
|
|
|
|
and adds the possibility to check Term Annotation Antiquotations (TA)
|
|
|
|
with the help of DOF_core.transduce_term_global function
|
|
|
|
*)
|
|
|
|
fun string_of_term s pos ctxt =
|
|
|
|
let
|
|
|
|
val t = Syntax.read_term ctxt s;
|
|
|
|
val T = Term.type_of t;
|
|
|
|
val ctxt' = Proof_Context.augment t ctxt;
|
|
|
|
val _ = DOF_core.transduce_term_global {mk_elaboration=false} (t , pos)
|
|
|
|
(Proof_Context.theory_of ctxt');
|
|
|
|
in
|
|
|
|
Pretty.string_of
|
|
|
|
(Pretty.block [Pretty.quote (Syntax.pretty_term ctxt' t), Pretty.fbrk,
|
|
|
|
Pretty.str "::", Pretty.brk 1, Pretty.quote (Syntax.pretty_typ ctxt' T)])
|
|
|
|
end;
|
|
|
|
|
|
|
|
fun print_item string_of (modes, arg) state =
|
|
|
|
Print_Mode.with_modes modes (fn () => writeln (string_of state arg)) ();
|
|
|
|
|
|
|
|
(*
|
|
|
|
We want to have the current position to pass it to transduce_term_global in
|
|
|
|
string_of_term, so we pass the Toplevel.transition
|
|
|
|
*)
|
|
|
|
|
|
|
|
|
|
|
|
fun print_term meta_args_opt (string_list, string) trans =
|
|
|
|
let
|
|
|
|
val pos = Toplevel.pos_of trans
|
2023-01-23 07:50:36 +00:00
|
|
|
fun prin state _ = string_of_term string pos (Toplevel.context_of state)
|
2022-05-25 15:07:06 +00:00
|
|
|
in
|
|
|
|
Toplevel.theory(fn thy =>
|
|
|
|
(print_item prin (string_list, string) (Toplevel.theory_toplevel thy);
|
|
|
|
thy |> meta_args_exec meta_args_opt )
|
|
|
|
) trans
|
|
|
|
end
|
|
|
|
|
|
|
|
val _ = Toplevel.theory
|
|
|
|
val _ = Toplevel.theory_toplevel
|
|
|
|
|
2022-10-11 19:00:33 +00:00
|
|
|
|
|
|
|
|
|
|
|
(* setup ontology aware commands *)
|
2022-05-25 15:07:06 +00:00
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>term*\<close> "read and print term"
|
2023-01-23 07:50:36 +00:00
|
|
|
(ODL_Meta_Args_Parser.opt_attributes -- (opt_modes -- Parse.term)
|
2022-05-25 15:07:06 +00:00
|
|
|
>> (fn (meta_args_opt, eval_args ) => print_term meta_args_opt eval_args));
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>value*\<close> "evaluate and print term"
|
2023-01-23 07:50:36 +00:00
|
|
|
(ODL_Meta_Args_Parser.opt_attributes -- (opt_evaluator -- opt_modes -- Parse.term)
|
2022-05-25 15:07:06 +00:00
|
|
|
>> (fn (meta_args_opt, eval_args ) => pass_trans_to_value_cmd meta_args_opt eval_args));
|
2018-08-27 12:39:34 +00:00
|
|
|
|
2022-10-11 19:00:33 +00:00
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>assert*\<close> "evaluate and assert term"
|
2023-01-23 07:50:36 +00:00
|
|
|
(ODL_Meta_Args_Parser.opt_attributes -- (opt_evaluator -- opt_modes -- Parse.term)
|
2022-10-11 19:00:33 +00:00
|
|
|
>> (fn (meta_args_opt, eval_args ) => pass_trans_to_assert_value_cmd meta_args_opt eval_args));
|
|
|
|
|
2023-01-11 13:49:29 +00:00
|
|
|
|
|
|
|
(* setup ontology - aware text and ML antiquotations. Due to lexical restrictions, we can not
|
2022-10-11 19:00:33 +00:00
|
|
|
declare them as value* or term*, although we will refer to them this way in papers. *)
|
|
|
|
local
|
|
|
|
fun pretty_term_style ctxt (style: term -> term, t) =
|
2022-12-22 09:55:03 +00:00
|
|
|
Document_Output.pretty_term ctxt (style (DOF_core.check_term ctxt t));
|
2023-01-09 10:34:40 +00:00
|
|
|
fun print_term ctxt t = ML_Syntax.print_term (DOF_core.check_term (Context.proof_of ctxt) t)
|
2022-10-11 19:00:33 +00:00
|
|
|
in
|
2022-05-25 15:07:06 +00:00
|
|
|
val _ = Theory.setup
|
2022-10-11 19:00:33 +00:00
|
|
|
(Document_Output.antiquotation_pretty_source_embedded \<^binding>\<open>value_\<close>
|
2022-05-25 15:07:06 +00:00
|
|
|
(Scan.lift opt_evaluator -- Term_Style.parse -- Args.term)
|
|
|
|
(fn ctxt => fn ((name, style), t) =>
|
2022-12-22 09:55:03 +00:00
|
|
|
Document_Output.pretty_term ctxt (style (value_select' name ctxt t)))
|
2023-01-09 10:34:40 +00:00
|
|
|
#> ML_Antiquotation.inline_embedded \<^binding>\<open>value_\<close>
|
|
|
|
((Scan.lift opt_evaluator -- Args.term)
|
|
|
|
#> (fn ((name, t),(ctxt, ts)) =>
|
|
|
|
(((value_select' name (Context.proof_of ctxt) t)
|
|
|
|
|> (ML_Syntax.atomic o (print_term ctxt))), (ctxt, ts))))
|
2022-10-11 19:00:33 +00:00
|
|
|
#> Document_Output.antiquotation_pretty_source_embedded \<^binding>\<open>term_\<close>
|
2023-01-09 10:34:40 +00:00
|
|
|
(Term_Style.parse -- Args.term) pretty_term_style
|
|
|
|
#> ML_Antiquotation.inline_embedded \<^binding>\<open>term_\<close>
|
|
|
|
(fn (ctxt, ts) => (Args.term >> (ML_Syntax.atomic o (print_term ctxt))) (ctxt, ts)))
|
2022-10-11 19:00:33 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
(* setup evaluators *)
|
|
|
|
val _ = Theory.setup(
|
|
|
|
add_evaluator (\<^binding>\<open>simp\<close>, Code_Simp.dynamic_value) #> snd
|
2022-05-25 15:07:06 +00:00
|
|
|
#> add_evaluator (\<^binding>\<open>nbe\<close>, Nbe.dynamic_value) #> snd
|
|
|
|
#> add_evaluator (\<^binding>\<open>code\<close>, Code_Evaluation.dynamic_value_strict) #> snd);
|
|
|
|
|
|
|
|
|
|
|
|
end; (* structure Value_Command *)
|
|
|
|
|
|
|
|
|
|
|
|
structure Monitor_Command_Parser =
|
|
|
|
struct
|
2018-08-27 12:39:34 +00:00
|
|
|
|
2018-10-08 13:13:47 +00:00
|
|
|
fun update_instance_command (((oid:string,pos),cid_pos),
|
|
|
|
doc_attrs: (((string*Position.T)*string)*string)list) thy
|
|
|
|
: theory =
|
|
|
|
let val cid = case DOF_core.get_object_global oid thy of
|
|
|
|
SOME{pos=pos_decl,cid,id,...} =>
|
|
|
|
let val markup = docref_markup false oid id pos_decl;
|
|
|
|
val ctxt = Proof_Context.init_global thy;
|
|
|
|
val _ = Context_Position.report ctxt pos markup;
|
|
|
|
in cid end
|
|
|
|
| NONE => error("undefined doc_class.")
|
2022-12-14 11:02:15 +00:00
|
|
|
val cid_pos' = Value_Command.Docitem_Parser.check_classref {is_monitor = false}
|
2022-05-25 15:07:06 +00:00
|
|
|
cid_pos thy
|
2022-12-14 11:02:15 +00:00
|
|
|
val cid_long = fst cid_pos'
|
2018-10-08 13:13:47 +00:00
|
|
|
val _ = if cid_long = DOF_core.default_cid orelse cid = cid_long
|
|
|
|
then ()
|
|
|
|
else error("incompatible classes:"^cid^":"^cid_long)
|
|
|
|
|
2019-03-05 08:36:12 +00:00
|
|
|
fun conv_attrs (((lhs, pos), opn), rhs) = ((markup2string lhs),pos,opn,
|
2018-10-08 13:13:47 +00:00
|
|
|
Syntax.read_term_global thy rhs)
|
|
|
|
val assns' = map conv_attrs doc_attrs
|
2022-03-28 16:19:41 +00:00
|
|
|
val def_trans_input_term =
|
2022-05-25 15:07:06 +00:00
|
|
|
#1 o (Value_Command.Docitem_Parser.calc_update_term {mk_elaboration=false}
|
|
|
|
thy cid_long assns')
|
2022-03-28 16:19:41 +00:00
|
|
|
val def_trans_value =
|
2022-05-25 15:07:06 +00:00
|
|
|
#1 o (Value_Command.Docitem_Parser.calc_update_term {mk_elaboration=true}
|
|
|
|
thy cid_long assns')
|
|
|
|
#> Value_Command.value (Proof_Context.init_global thy)
|
2018-12-18 16:09:24 +00:00
|
|
|
fun check_inv thy =((DOF_core.get_class_invariant cid_long thy oid {is_monitor=false}
|
2019-03-05 08:36:12 +00:00
|
|
|
o Context.Theory ) thy ;
|
|
|
|
thy)
|
2018-10-08 13:13:47 +00:00
|
|
|
in
|
2022-03-28 16:19:41 +00:00
|
|
|
thy |> DOF_core.update_value_global oid def_trans_input_term def_trans_value
|
2018-12-18 16:09:24 +00:00
|
|
|
|> check_inv
|
2022-12-22 06:53:42 +00:00
|
|
|
|> (fn thy => if Config.get_global thy DOF_core.invariants_checking
|
|
|
|
then Value_Command.Docitem_Parser.check_invariants thy oid
|
|
|
|
else thy)
|
2018-10-08 13:13:47 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
|
2020-05-19 15:32:25 +00:00
|
|
|
(* General criticism : attributes like "level" were treated here in the kernel instead of dragging
|
|
|
|
them out into the COL -- bu *)
|
2020-04-23 14:08:05 +00:00
|
|
|
|
2022-05-25 15:07:06 +00:00
|
|
|
fun open_monitor_command ((((oid,pos),cid_pos), doc_attrs) : ODL_Meta_Args_Parser.meta_args_t) =
|
|
|
|
let fun o_m_c oid pos cid_pos doc_attrs thy =
|
|
|
|
Value_Command.Docitem_Parser.create_and_check_docitem
|
|
|
|
{is_monitor=true} (* this is a monitor *)
|
|
|
|
{is_inline=false} (* monitors are always inline *)
|
|
|
|
oid pos cid_pos doc_attrs thy
|
2022-05-27 12:46:04 +00:00
|
|
|
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)
|
2022-12-14 11:02:15 +00:00
|
|
|
val aalph = RegExpInterface.alphabet (#rex X)
|
|
|
|
in (aalph, ralph, map (RegExpInterface.rexp_term2da aalph)(#rex X)) end
|
2022-05-27 12:46:04 +00:00
|
|
|
| NONE => error("Internal error: class id undefined. ")
|
|
|
|
end
|
2018-10-08 13:13:47 +00:00
|
|
|
fun create_monitor_entry thy =
|
2022-05-27 12:46:04 +00:00
|
|
|
let val cid = case cid_pos of
|
|
|
|
NONE => ISA_core.err ("You must specified a monitor class.") pos
|
|
|
|
| SOME (cid, _) => cid
|
2022-12-14 11:02:15 +00:00
|
|
|
val (accS, rejectS, aS) = compute_enabled_set cid thy
|
|
|
|
val info = {accepted_cids = accS, rejected_cids = rejectS, automatas = aS }
|
2018-10-08 13:13:47 +00:00
|
|
|
in DOF_core.map_data_global(DOF_core.upd_monitor_tabs(Symtab.update(oid, info )))(thy)
|
|
|
|
end
|
2018-10-08 08:30:53 +00:00
|
|
|
in
|
2022-12-14 11:02:15 +00:00
|
|
|
o_m_c oid pos cid_pos doc_attrs #> create_monitor_entry
|
2018-10-08 08:30:53 +00:00
|
|
|
end;
|
2018-08-27 12:39:34 +00:00
|
|
|
|
|
|
|
|
2018-10-08 13:13:47 +00:00
|
|
|
fun close_monitor_command (args as (((oid:string,pos),cid_pos),
|
|
|
|
doc_attrs: (((string*Position.T)*string)*string)list)) thy =
|
|
|
|
let val {monitor_tab,...} = DOF_core.get_data_global thy
|
2022-12-14 11:02:15 +00:00
|
|
|
fun check_if_final aS = let val i = (find_index (not o RegExpInterface.final) aS) + 1
|
|
|
|
in if i >= 1
|
2022-05-25 15:07:06 +00:00
|
|
|
then
|
|
|
|
Value_Command.Docitem_Parser.msg thy
|
2022-12-14 11:02:15 +00:00
|
|
|
("accepts clause " ^ Int.toString i
|
|
|
|
^ " of monitor " ^ oid
|
|
|
|
^ " not in final state.") pos
|
2018-12-10 13:15:39 +00:00
|
|
|
else ()
|
|
|
|
end
|
2018-10-08 13:13:47 +00:00
|
|
|
val _ = case Symtab.lookup monitor_tab oid of
|
2018-12-10 13:15:39 +00:00
|
|
|
SOME {automatas,...} => check_if_final automatas
|
2018-10-08 13:13:47 +00:00
|
|
|
| NONE => error ("Not belonging to a monitor class: "^oid)
|
|
|
|
val delete_monitor_entry = DOF_core.map_data_global (DOF_core.upd_monitor_tabs (Symtab.delete oid))
|
2018-12-11 15:03:01 +00:00
|
|
|
val {cid=cid_long, id, ...} = the(DOF_core.get_object_global oid thy)
|
|
|
|
val markup = docref_markup false oid id pos;
|
|
|
|
val _ = Context_Position.report (Proof_Context.init_global thy) pos markup;
|
2018-12-04 09:41:34 +00:00
|
|
|
val check_inv = (DOF_core.get_class_invariant cid_long thy oid) {is_monitor=true}
|
2022-05-25 15:13:49 +00:00
|
|
|
o Context.Theory
|
|
|
|
val check_lazy_inv = (DOF_core.get_class_lazy_invariant cid_long thy oid) {is_monitor=true}
|
2018-12-04 09:41:34 +00:00
|
|
|
o Context.Theory
|
2022-05-25 15:13:49 +00:00
|
|
|
in thy |> (fn thy => (check_lazy_inv thy; thy))
|
|
|
|
|> update_instance_command args
|
2018-12-03 21:18:47 +00:00
|
|
|
|> (fn thy => (check_inv thy; thy))
|
2022-12-22 06:53:42 +00:00
|
|
|
|> (fn thy => if Config.get_global thy DOF_core.invariants_checking
|
|
|
|
then Value_Command.Docitem_Parser.check_invariants thy oid
|
|
|
|
else thy)
|
2018-10-08 13:13:47 +00:00
|
|
|
|> delete_monitor_entry
|
|
|
|
end
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2019-02-09 22:05:52 +00:00
|
|
|
|
2022-05-25 15:07:06 +00:00
|
|
|
fun meta_args_2_latex thy ((((lab, _), cid_opt), attr_list) : ODL_Meta_Args_Parser.meta_args_t) =
|
2021-12-18 22:06:51 +00:00
|
|
|
(* for the moment naive, i.e. without textual normalization of
|
|
|
|
attribute names and adapted term printing *)
|
|
|
|
let val l = "label = "^ (enclose "{" "}" lab)
|
|
|
|
(* val _ = writeln("meta_args_2_string lab:"^ lab ^":"^ (@{make_string } cid_opt) ) *)
|
|
|
|
val cid_long = case cid_opt of
|
|
|
|
NONE => (case DOF_core.get_object_global lab thy of
|
|
|
|
NONE => DOF_core.default_cid
|
|
|
|
| SOME X => #cid X)
|
|
|
|
| SOME(cid,_) => DOF_core.parse_cid_global thy cid
|
|
|
|
(* val _ = writeln("meta_args_2_string cid_long:"^ cid_long ) *)
|
|
|
|
val cid_txt = "type = " ^ (enclose "{" "}" cid_long);
|
|
|
|
|
2022-12-02 10:41:31 +00:00
|
|
|
fun ltx_of_term _ _ (c as \<^Const_>\<open>Cons \<^Type>\<open>char\<close> for _ _\<close>) = HOLogic.dest_string c
|
|
|
|
| ltx_of_term _ _ \<^Const_>\<open>Nil _\<close> = ""
|
|
|
|
| ltx_of_term _ _ \<^Const_>\<open>numeral _ for t\<close> = Int.toString(HOLogic.dest_numeral t)
|
|
|
|
| ltx_of_term ctx encl \<^Const_>\<open>Cons _ for t1 t2\<close> =
|
|
|
|
let val inner = (case t2 of
|
|
|
|
\<^Const_>\<open>Nil _\<close> => ltx_of_term ctx true t1
|
|
|
|
| _ => ((ltx_of_term ctx false t1)^", " ^(ltx_of_term ctx false t2)))
|
|
|
|
in if encl then enclose "{" "}" inner else inner end
|
|
|
|
| ltx_of_term _ _ \<^Const_>\<open>None _\<close> = ""
|
|
|
|
| ltx_of_term ctxt _ \<^Const_>\<open>Some _ for t\<close> = ltx_of_term ctxt true t
|
2021-12-18 22:06:51 +00:00
|
|
|
| ltx_of_term ctxt _ t = ""^(Sledgehammer_Util.hackish_string_of_term ctxt t)
|
|
|
|
|
|
|
|
|
|
|
|
fun ltx_of_term_dbg ctx encl term = let
|
|
|
|
val t_str = ML_Syntax.print_term term
|
|
|
|
handle (TERM _) => "Exception TERM in ltx_of_term_dbg (print_term)"
|
|
|
|
val ltx = ltx_of_term ctx encl term
|
|
|
|
val _ = writeln("<STRING>"^(Sledgehammer_Util.hackish_string_of_term ctx term)^"</STRING>")
|
|
|
|
val _ = writeln("<LTX>"^ltx^"</LTX>")
|
|
|
|
val _ = writeln("<TERM>"^t_str^"</TERM>")
|
|
|
|
in ltx end
|
|
|
|
|
|
|
|
|
|
|
|
fun markup2string s = String.concat (List.filter (fn c => c <> Symbol.DEL)
|
|
|
|
(Symbol.explode (YXML.content_of s)))
|
|
|
|
fun ltx_of_markup ctxt s = let
|
|
|
|
val term = (Syntax.check_term ctxt o Syntax.parse_term ctxt) s
|
|
|
|
val str_of_term = ltx_of_term ctxt true term
|
|
|
|
handle _ => "Exception in ltx_of_term"
|
|
|
|
in
|
|
|
|
str_of_term
|
|
|
|
end
|
|
|
|
fun toLong n = #long_name(the(DOF_core.get_attribute_info cid_long (markup2string n) thy))
|
|
|
|
|
|
|
|
val ctxt = Proof_Context.init_global thy
|
|
|
|
val actual_args = map (fn ((lhs,_),rhs) => (toLong lhs, ltx_of_markup ctxt rhs))
|
|
|
|
attr_list
|
|
|
|
val default_args = map (fn (b,_,t) => (toLong (Long_Name.base_name ( Sign.full_name thy b)),
|
|
|
|
ltx_of_term ctxt true t))
|
|
|
|
(DOF_core.get_attribute_defaults cid_long thy)
|
|
|
|
|
|
|
|
val default_args_filtered = filter (fn (a,_) => not (exists (fn b => b = a)
|
|
|
|
(map (fn (c,_) => c) actual_args))) default_args
|
|
|
|
val str_args = map (fn (lhs,rhs) => lhs^" = "^(enclose "{" "}" rhs))
|
|
|
|
(actual_args@default_args_filtered)
|
|
|
|
val label_and_type = String.concat [ l, ",", cid_txt]
|
|
|
|
val str_args = label_and_type::str_args
|
|
|
|
in
|
|
|
|
Latex.string (enclose "[" "]" (String.concat [ label_and_type, ", args={", (commas str_args), "}"]))
|
|
|
|
end
|
|
|
|
|
|
|
|
(* level-attribute information management *)
|
|
|
|
fun gen_enriched_document_cmd {inline} cid_transform attr_transform
|
2022-05-25 15:07:06 +00:00
|
|
|
((((oid,pos),cid_pos), doc_attrs) : ODL_Meta_Args_Parser.meta_args_t) : theory -> theory =
|
|
|
|
Value_Command.Docitem_Parser.create_and_check_docitem {is_monitor = false} {is_inline = inline}
|
2021-12-18 22:06:51 +00:00
|
|
|
oid pos (cid_transform cid_pos) (attr_transform doc_attrs);
|
|
|
|
|
|
|
|
|
|
|
|
(* markup reports and document output *)
|
|
|
|
|
|
|
|
(* {markdown = true} sets the parsing process such that in the text-core
|
|
|
|
markdown elements are accepted. *)
|
|
|
|
|
|
|
|
fun document_output {markdown: bool, markup: Latex.text -> Latex.text} meta_args text ctxt =
|
|
|
|
let
|
|
|
|
val thy = Proof_Context.theory_of ctxt;
|
|
|
|
val _ = Context_Position.reports ctxt (Document_Output.document_reports text);
|
|
|
|
val output_meta = meta_args_2_latex thy meta_args;
|
|
|
|
val output_text = Document_Output.output_document ctxt {markdown = markdown} text;
|
|
|
|
in markup (output_meta @ output_text) end;
|
|
|
|
|
|
|
|
fun document_output_reports name {markdown, body} meta_args text ctxt =
|
|
|
|
let
|
|
|
|
val pos = Input.pos_of text;
|
|
|
|
val _ =
|
|
|
|
Context_Position.reports ctxt
|
|
|
|
[(pos, Markup.language_document (Input.is_delimited text)),
|
|
|
|
(pos, Markup.plain_text)];
|
|
|
|
fun markup xml =
|
|
|
|
let val m = if body then Markup.latex_body else Markup.latex_heading
|
2022-12-01 21:04:56 +00:00
|
|
|
in [XML.Elem (m (Latex.output_name name), xml)] end;
|
2021-12-18 22:06:51 +00:00
|
|
|
in document_output {markdown = markdown, markup = markup} meta_args text ctxt end;
|
|
|
|
|
2021-12-20 20:02:57 +00:00
|
|
|
|
|
|
|
(* document output commands *)
|
|
|
|
|
2021-12-18 22:06:51 +00:00
|
|
|
fun document_command (name, pos) descr mark cmd =
|
2022-12-01 21:48:45 +00:00
|
|
|
Outer_Syntax.command (name, pos) descr
|
|
|
|
(ODL_Meta_Args_Parser.attributes -- Parse.document_source >> (fn (meta_args, text) =>
|
|
|
|
Toplevel.theory' (fn _ => cmd meta_args)
|
|
|
|
(Toplevel.presentation_context #> document_output_reports name mark meta_args text #> SOME)));
|
2019-02-09 22:05:52 +00:00
|
|
|
|
|
|
|
|
2021-12-18 22:06:51 +00:00
|
|
|
(* Core Command Definitions *)
|
2019-02-09 22:05:52 +00:00
|
|
|
|
|
|
|
val _ =
|
2022-12-02 12:50:16 +00:00
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>open_monitor*\<close>
|
2020-04-23 16:30:46 +00:00
|
|
|
"open a document reference monitor"
|
2022-05-25 15:07:06 +00:00
|
|
|
(ODL_Meta_Args_Parser.attributes
|
|
|
|
>> (Toplevel.theory o open_monitor_command));
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
val _ =
|
2022-12-02 12:50:16 +00:00
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>close_monitor*\<close>
|
2020-04-23 16:30:46 +00:00
|
|
|
"close a document reference monitor"
|
2022-05-25 15:07:06 +00:00
|
|
|
(ODL_Meta_Args_Parser.attributes_upd
|
|
|
|
>> (Toplevel.theory o close_monitor_command));
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2018-06-11 15:35:12 +00:00
|
|
|
|
|
|
|
val _ =
|
2022-12-02 12:50:16 +00:00
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>update_instance*\<close>
|
2020-04-23 16:30:46 +00:00
|
|
|
"update meta-attributes of an instance of a document class"
|
2022-05-25 15:07:06 +00:00
|
|
|
(ODL_Meta_Args_Parser.attributes_upd
|
|
|
|
>> (Toplevel.theory o update_instance_command));
|
2018-06-11 15:35:12 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
val _ =
|
2022-12-02 12:50:16 +00:00
|
|
|
document_command \<^command_keyword>\<open>text*\<close> "formal comment (primary style)"
|
2021-12-18 22:06:51 +00:00
|
|
|
{markdown = true, body = true} (gen_enriched_document_cmd {inline=true} I I);
|
2020-05-19 15:32:25 +00:00
|
|
|
|
2021-05-13 20:46:00 +00:00
|
|
|
|
2020-05-19 15:32:25 +00:00
|
|
|
(* This is just a stub at present *)
|
2020-04-12 19:11:54 +00:00
|
|
|
val _ =
|
2022-12-02 12:50:16 +00:00
|
|
|
document_command \<^command_keyword>\<open>text-macro*\<close> "formal comment macro"
|
2021-12-18 22:06:51 +00:00
|
|
|
{markdown = true, body = true}
|
|
|
|
(gen_enriched_document_cmd {inline=false} (* declare as macro *) I I);
|
2020-04-12 19:11:54 +00:00
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
val _ =
|
2022-12-02 12:50:16 +00:00
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>declare_reference*\<close>
|
2018-04-05 10:44:52 +00:00
|
|
|
"declare document reference"
|
2022-05-25 15:07:06 +00:00
|
|
|
(ODL_Meta_Args_Parser.attributes >> (fn (((oid,pos),cid),doc_attrs) =>
|
2018-04-05 10:44:52 +00:00
|
|
|
(Toplevel.theory (DOF_core.declare_object_global oid))));
|
2018-09-11 06:50:51 +00:00
|
|
|
|
2022-05-25 15:07:06 +00:00
|
|
|
end (* structure Monitor_Command_Parser *)
|
2019-04-06 17:58:13 +00:00
|
|
|
\<close>
|
|
|
|
|
2022-03-11 11:30:34 +00:00
|
|
|
|
2020-04-23 16:30:46 +00:00
|
|
|
|
2022-03-28 16:19:41 +00:00
|
|
|
ML\<open>
|
|
|
|
fun print_doc_classes b ctxt =
|
|
|
|
let val {docobj_tab={tab = x, ...},docclass_tab, ...} = DOF_core.get_data 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}) =
|
|
|
|
(case inherits_from of
|
|
|
|
NONE => writeln ("docclass: "^n)
|
|
|
|
| SOME(_,nn) => writeln ("docclass: "^n^" = "^nn^" + ");
|
|
|
|
writeln (" name: "^(Binding.print name));
|
|
|
|
writeln (" virtual: "^(print_virtual virtual));
|
|
|
|
writeln (" origin: "^thy_name);
|
|
|
|
writeln (" attrs: "^commas (map print_attr attribute_decl));
|
|
|
|
writeln (" invs: "^commas (map print_inv invs))
|
|
|
|
);
|
|
|
|
in map print_class (Symtab.dest docclass_tab);
|
|
|
|
writeln "=====================================\n\n\n"
|
|
|
|
end;
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>print_doc_classes\<close> "print document classes"
|
|
|
|
(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 *)
|
|
|
|
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))
|
|
|
|
fun filter_overrides [] = []
|
|
|
|
|filter_overrides ((ln,s)::S) = (ln,s):: filter_overrides(filter(fn(_,s')=> s<>s')S)
|
|
|
|
val hierarchy = map (fn(ln,s)=>ln^"."^s)(filter_overrides(flatten_hrchy brute_hierarchy))
|
|
|
|
val args = String.concatWith "=%\n , " (" label=,type":: hierarchy);
|
|
|
|
val template = "\\newisadof{"^cid_long^"}%\n["^args^"=%\n][1]\n{%\n#1%\n}\n\n";
|
|
|
|
in writeln template end;
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>print_doc_class_template\<close>
|
|
|
|
"print document class latex template"
|
|
|
|
(Parse.string >> (fn b => Toplevel.keep (print_docclass_template b o Toplevel.context_of)));
|
|
|
|
|
|
|
|
fun print_doc_items b ctxt =
|
|
|
|
let val {docobj_tab={tab = x, ...},...}= DOF_core.get_data ctxt;
|
|
|
|
val _ = writeln "=====================================";
|
|
|
|
fun dfg true = "true"
|
|
|
|
|dfg false= "false"
|
|
|
|
fun print_item (n, SOME({cid,vcid,id,pos,thy_name,inline, input_term, value})) =
|
|
|
|
(writeln ("docitem: "^n);
|
|
|
|
writeln (" type: "^cid);
|
|
|
|
case vcid of NONE => () | SOME (s) =>
|
|
|
|
writeln (" virtual type: "^ s);
|
2022-04-04 06:08:47 +00:00
|
|
|
writeln (" origin: "^thy_name);
|
2022-03-28 16:19:41 +00:00
|
|
|
writeln (" inline: "^dfg inline);
|
2022-05-25 15:07:06 +00:00
|
|
|
writeln (" input_term: "^ (Syntax.string_of_term ctxt input_term));
|
|
|
|
writeln (" value: "^ (Syntax.string_of_term ctxt value))
|
2022-03-28 16:19:41 +00:00
|
|
|
)
|
|
|
|
| print_item (n, NONE) =
|
|
|
|
(writeln ("forward reference for docitem: "^n));
|
|
|
|
in map print_item (Symtab.dest x);
|
|
|
|
writeln "=====================================\n\n\n" end;
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>print_doc_items\<close> "print document items"
|
|
|
|
(Parse.opt_bang >> (fn b => Toplevel.keep (print_doc_items b o Toplevel.context_of)));
|
|
|
|
|
|
|
|
fun check_doc_global (strict_checking : bool) ctxt =
|
|
|
|
let val {docobj_tab={tab = x, ...}, monitor_tab, ...} = DOF_core.get_data ctxt;
|
|
|
|
val S = map_filter (fn (s,NONE) => SOME s | _ => NONE) (Symtab.dest x)
|
|
|
|
val T = map fst (Symtab.dest monitor_tab)
|
|
|
|
in if null S
|
|
|
|
then if null T then ()
|
|
|
|
else error("Global consistency error - there are open monitors: "
|
|
|
|
^ String.concatWith "," T)
|
|
|
|
else error("Global consistency error - Unresolved forward references: "
|
|
|
|
^ String.concatWith "," S)
|
|
|
|
end
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>check_doc_global\<close> "check global document consistency"
|
|
|
|
(Parse.opt_bang >> (fn b => Toplevel.keep (check_doc_global b o Toplevel.context_of)));
|
|
|
|
|
|
|
|
\<close>
|
2022-03-11 11:30:34 +00:00
|
|
|
|
2022-03-14 11:23:54 +00:00
|
|
|
\<comment> \<open>c.f. \<^file>\<open>~~/src/Pure/Isar/outer_syntax.ML\<close>\<close>
|
2022-03-11 11:30:34 +00:00
|
|
|
(*
|
|
|
|
The ML* generates an "ontology-aware" version of the SML code-execution command.
|
|
|
|
*)
|
2022-03-14 11:23:54 +00:00
|
|
|
ML\<open>
|
2022-03-11 11:30:34 +00:00
|
|
|
structure ML_star_Command =
|
|
|
|
struct
|
|
|
|
|
2023-01-23 07:50:36 +00:00
|
|
|
fun meta_args_exec (meta_args as (((oid,pos),cid_pos), doc_attrs) : ODL_Meta_Args_Parser.meta_args_t) thy =
|
|
|
|
thy |> (if meta_args = Value_Command.empty_meta_args
|
|
|
|
then (K thy)
|
|
|
|
else Context.map_theory (Value_Command.Docitem_Parser.create_and_check_docitem
|
2022-03-11 11:30:34 +00:00
|
|
|
{is_monitor = false} {is_inline = false}
|
|
|
|
oid pos (I cid_pos) (I doc_attrs))
|
2023-01-23 07:50:36 +00:00
|
|
|
)
|
2022-03-11 11:30:34 +00:00
|
|
|
|
2022-05-25 15:07:06 +00:00
|
|
|
val attributes_opt = Scan.option ODL_Meta_Args_Parser.attributes
|
2022-03-11 11:30:34 +00:00
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command ("ML*", \<^here>) "ODL annotated ML text within theory or local theory"
|
2023-01-23 07:50:36 +00:00
|
|
|
((ODL_Meta_Args_Parser.attributes -- Parse.ML_source)
|
2022-03-11 11:30:34 +00:00
|
|
|
>> (fn (meta_args_opt, source) =>
|
|
|
|
Toplevel.generic_theory
|
2023-01-23 07:50:36 +00:00
|
|
|
((meta_args_exec meta_args_opt)
|
|
|
|
#> (ML_Context.exec (fn () =>
|
2022-03-14 11:23:54 +00:00
|
|
|
(ML_Context.eval_source (ML_Compiler.verbose true ML_Compiler.flags) source))
|
2023-01-23 07:50:36 +00:00
|
|
|
#> Local_Theory.propagate_ml_env))));
|
2022-03-11 11:30:34 +00:00
|
|
|
|
|
|
|
end
|
|
|
|
\<close>
|
|
|
|
|
2019-04-06 17:58:13 +00:00
|
|
|
ML\<open>
|
|
|
|
structure ODL_LTX_Converter =
|
|
|
|
struct
|
|
|
|
|
2022-05-25 15:07:06 +00:00
|
|
|
fun meta_args_2_string thy ((((lab, _), cid_opt), attr_list) : ODL_Meta_Args_Parser.meta_args_t) =
|
2019-04-06 17:58:13 +00:00
|
|
|
(* for the moment naive, i.e. without textual normalization of
|
|
|
|
attribute names and adapted term printing *)
|
2019-04-07 16:16:05 +00:00
|
|
|
let val l = "label = "^ (enclose "{" "}" lab)
|
2020-11-04 14:55:43 +00:00
|
|
|
(* val _ = writeln("meta_args_2_string lab:"^ lab ^":"^ (@{make_string } cid_opt) ) *)
|
2019-04-06 17:58:13 +00:00
|
|
|
val cid_long = case cid_opt of
|
2020-11-03 18:00:33 +00:00
|
|
|
NONE => (case DOF_core.get_object_global lab thy of
|
|
|
|
NONE => DOF_core.default_cid
|
|
|
|
| SOME X => #cid X)
|
2020-02-21 14:39:50 +00:00
|
|
|
| SOME(cid,_) => DOF_core.parse_cid_global thy cid
|
2020-11-04 14:55:43 +00:00
|
|
|
(* val _ = writeln("meta_args_2_string cid_long:"^ cid_long ) *)
|
2019-04-06 17:58:13 +00:00
|
|
|
val cid_txt = "type = " ^ (enclose "{" "}" cid_long);
|
|
|
|
|
2022-12-02 10:41:31 +00:00
|
|
|
fun ltx_of_term _ _ (c as \<^Const_>\<open>Cons \<^Type>\<open>char\<close> for _ _\<close>) = HOLogic.dest_string c
|
|
|
|
| ltx_of_term _ _ \<^Const_>\<open>Nil _\<close> = ""
|
|
|
|
| ltx_of_term _ _ \<^Const_>\<open>numeral _ for t\<close> = Int.toString(HOLogic.dest_numeral t)
|
|
|
|
| ltx_of_term ctx encl \<^Const_>\<open>Cons _ for t1 t2\<close> =
|
|
|
|
let val inner = (case t2 of
|
|
|
|
\<^Const_>\<open>Nil _\<close> => ltx_of_term ctx true t1
|
|
|
|
| _ => ((ltx_of_term ctx false t1)^", " ^(ltx_of_term ctx false t2)))
|
2022-03-11 11:30:34 +00:00
|
|
|
in if encl then enclose "{" "}" inner else inner end
|
2022-12-02 10:41:31 +00:00
|
|
|
| ltx_of_term _ _ \<^Const_>\<open>None _\<close> = ""
|
|
|
|
| ltx_of_term ctxt _ \<^Const_>\<open>Some _ for t\<close> = ltx_of_term ctxt true t
|
2019-06-17 09:10:29 +00:00
|
|
|
| ltx_of_term ctxt _ t = ""^(Sledgehammer_Util.hackish_string_of_term ctxt t)
|
2019-04-06 17:58:13 +00:00
|
|
|
|
|
|
|
|
|
|
|
fun ltx_of_term_dbg ctx encl term = let
|
|
|
|
val t_str = ML_Syntax.print_term term
|
|
|
|
handle (TERM _) => "Exception TERM in ltx_of_term_dbg (print_term)"
|
|
|
|
val ltx = ltx_of_term ctx encl term
|
|
|
|
val _ = writeln("<STRING>"^(Sledgehammer_Util.hackish_string_of_term ctx term)^"</STRING>")
|
|
|
|
val _ = writeln("<LTX>"^ltx^"</LTX>")
|
|
|
|
val _ = writeln("<TERM>"^t_str^"</TERM>")
|
|
|
|
in ltx end
|
|
|
|
|
|
|
|
|
2019-06-20 10:49:01 +00:00
|
|
|
fun markup2string s = String.concat (List.filter (fn c => c <> Symbol.DEL)
|
|
|
|
(Symbol.explode (YXML.content_of s)))
|
2019-04-06 17:58:13 +00:00
|
|
|
fun ltx_of_markup ctxt s = let
|
|
|
|
val term = (Syntax.check_term ctxt o Syntax.parse_term ctxt) s
|
|
|
|
val str_of_term = ltx_of_term ctxt true term
|
|
|
|
handle _ => "Exception in ltx_of_term"
|
|
|
|
in
|
|
|
|
str_of_term
|
|
|
|
end
|
|
|
|
fun toLong n = #long_name(the(DOF_core.get_attribute_info cid_long (markup2string n) thy))
|
|
|
|
|
|
|
|
val ctxt = Proof_Context.init_global thy
|
|
|
|
val actual_args = map (fn ((lhs,_),rhs) => (toLong lhs, ltx_of_markup ctxt rhs))
|
|
|
|
attr_list
|
2019-06-20 10:49:01 +00:00
|
|
|
val default_args = map (fn (b,_,t) => (toLong (Long_Name.base_name ( Sign.full_name thy b)),
|
|
|
|
ltx_of_term ctxt true t))
|
2019-04-06 17:58:13 +00:00
|
|
|
(DOF_core.get_attribute_defaults cid_long thy)
|
|
|
|
|
|
|
|
val default_args_filtered = filter (fn (a,_) => not (exists (fn b => b = a)
|
|
|
|
(map (fn (c,_) => c) actual_args))) default_args
|
|
|
|
val str_args = map (fn (lhs,rhs) => lhs^" = "^(enclose "{" "}" rhs))
|
|
|
|
(actual_args@default_args_filtered)
|
2019-04-07 16:16:05 +00:00
|
|
|
val label_and_type = String.concat [ l, ",", cid_txt]
|
|
|
|
val str_args = label_and_type::str_args
|
2019-04-06 17:58:13 +00:00
|
|
|
in
|
2019-04-07 16:16:05 +00:00
|
|
|
(enclose "[" "]" (String.concat [ label_and_type, ", args={", (commas str_args), "}"]))
|
2019-04-06 17:58:13 +00:00
|
|
|
end
|
2019-05-17 10:05:04 +00:00
|
|
|
|
|
|
|
end
|
2022-05-25 15:07:06 +00:00
|
|
|
|
2019-05-27 09:03:32 +00:00
|
|
|
\<close>
|
2020-11-03 18:00:33 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
|
|
|
|
section\<open> Syntax for Ontological Antiquotations (the '' View'' Part II) \<close>
|
2019-04-18 15:13:32 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
ML\<open>
|
2018-04-04 12:44:21 +00:00
|
|
|
structure OntoLinkParser =
|
|
|
|
struct
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2021-12-18 22:06:51 +00:00
|
|
|
val basic_entity = Document_Output.antiquotation_pretty_source
|
2019-08-15 09:30:42 +00:00
|
|
|
: binding -> 'a context_parser -> (Proof.context -> 'a -> Pretty.T) -> theory -> theory;
|
|
|
|
|
2020-06-16 07:08:36 +00:00
|
|
|
fun check_and_mark ctxt cid_decl (str:{strict_checking: bool}) {inline=inline_req} pos name =
|
2018-02-07 18:44:27 +00:00
|
|
|
let
|
|
|
|
val thy = Proof_Context.theory_of ctxt;
|
|
|
|
in
|
2018-02-09 11:25:15 +00:00
|
|
|
if DOF_core.is_defined_oid_global name thy
|
2020-06-16 07:08:36 +00:00
|
|
|
then let val {pos=pos_decl,id,cid,inline,...} = the(DOF_core.get_object_global name thy)
|
|
|
|
val _ = if not inline_req
|
|
|
|
then if inline then () else error("referred text-element is macro! (try option display)")
|
|
|
|
else if not inline then () else error("referred text-element is no macro!")
|
2018-02-07 18:44:27 +00:00
|
|
|
val markup = docref_markup false name id pos_decl;
|
|
|
|
val _ = Context_Position.report ctxt pos markup;
|
2018-02-28 13:06:52 +00:00
|
|
|
(* this sends a report for a ref application to the PIDE interface ... *)
|
2020-12-01 22:18:13 +00:00
|
|
|
val _ = if not(DOF_core.is_subclass ctxt cid cid_decl)
|
|
|
|
then error("reference ontologically inconsistent: "^cid
|
|
|
|
^" must be subclass of "^cid_decl^ Position.here pos_decl)
|
2018-02-28 13:06:52 +00:00
|
|
|
else ()
|
2019-04-29 20:24:32 +00:00
|
|
|
in () end
|
2018-02-09 11:25:15 +00:00
|
|
|
else if DOF_core.is_declared_oid_global name thy
|
2018-04-04 12:44:21 +00:00
|
|
|
then (if #strict_checking str
|
2019-08-15 09:30:42 +00:00
|
|
|
then warning("declared but undefined document reference: "^name)
|
2019-04-29 20:24:32 +00:00
|
|
|
else ())
|
2019-08-04 07:24:01 +00:00
|
|
|
else error("undefined document reference: "^name)
|
2018-02-07 18:44:27 +00:00
|
|
|
end
|
|
|
|
|
2020-06-16 07:08:36 +00:00
|
|
|
val _ = check_and_mark : Proof.context -> string ->
|
|
|
|
{strict_checking: bool} -> {inline:bool} ->
|
2019-04-29 20:24:32 +00:00
|
|
|
Position.T -> Symtab.key -> unit
|
2018-04-04 12:44:21 +00:00
|
|
|
|
2018-03-29 09:19:07 +00:00
|
|
|
(* generic syntax for doc_class links. *)
|
|
|
|
|
|
|
|
val defineN = "define"
|
|
|
|
val uncheckedN = "unchecked"
|
|
|
|
|
2018-12-07 10:08:13 +00:00
|
|
|
val docitem_modes = Scan.optional (Args.parens (Args.$$$ defineN || Args.$$$ uncheckedN)
|
2018-03-29 09:19:07 +00:00
|
|
|
>> (fn str => if str = defineN
|
|
|
|
then {unchecked = false, define= true}
|
|
|
|
else {unchecked = true, define= false}))
|
2018-04-04 12:44:21 +00:00
|
|
|
{unchecked = false, define= false} (* default *);
|
2018-03-29 09:19:07 +00:00
|
|
|
|
2019-04-29 20:24:32 +00:00
|
|
|
|
2022-07-17 21:46:56 +00:00
|
|
|
val docitem_antiquotation_parser = (Scan.lift (docitem_modes -- Parse.embedded_input))
|
2020-04-09 21:58:58 +00:00
|
|
|
: ({define:bool,unchecked:bool} * Input.source) context_parser;
|
2019-04-29 20:24:32 +00:00
|
|
|
|
|
|
|
|
2020-04-10 16:30:33 +00:00
|
|
|
fun pretty_docitem_antiquotation_generic cid_decl ctxt ({unchecked, define}, src ) =
|
2020-05-19 15:32:25 +00:00
|
|
|
let val (str,pos) = Input.source_content src
|
2020-04-10 16:30:33 +00:00
|
|
|
val inline = Config.get ctxt Document_Antiquotation.thy_output_display
|
2020-06-16 07:08:36 +00:00
|
|
|
val _ = check_and_mark ctxt cid_decl {strict_checking = not unchecked}
|
|
|
|
{inline = inline} pos str
|
2020-04-09 21:58:58 +00:00
|
|
|
in
|
2020-04-10 16:30:33 +00:00
|
|
|
(case (define,inline) of
|
2021-12-18 22:06:51 +00:00
|
|
|
(true,false) => XML.enclose("\\csname isaDof.label\\endcsname[type={"^cid_decl^"}] {")"}"
|
|
|
|
|(false,false)=> XML.enclose("\\csname isaDof.ref\\endcsname[type={"^cid_decl^"}] {")"}"
|
|
|
|
|(true,true) => XML.enclose("\\csname isaDof.macroDef\\endcsname[type={"^cid_decl^"}]{")"}"
|
|
|
|
|(false,true) => XML.enclose("\\csname isaDof.macroExp\\endcsname[type={"^cid_decl^"}]{")"}"
|
2020-04-10 16:30:33 +00:00
|
|
|
)
|
2021-12-18 22:06:51 +00:00
|
|
|
(Latex.text (Input.source_content src))
|
2020-04-09 21:58:58 +00:00
|
|
|
end
|
2019-04-29 20:24:32 +00:00
|
|
|
|
|
|
|
|
|
|
|
fun docitem_antiquotation bind cid =
|
2021-12-18 22:06:51 +00:00
|
|
|
Document_Output.antiquotation_raw bind docitem_antiquotation_parser
|
2019-04-29 20:24:32 +00:00
|
|
|
(pretty_docitem_antiquotation_generic cid);
|
2018-03-29 09:19:07 +00:00
|
|
|
|
2018-04-27 08:34:24 +00:00
|
|
|
|
|
|
|
fun check_and_mark_term ctxt oid =
|
|
|
|
let val thy = Context.theory_of ctxt;
|
|
|
|
in if DOF_core.is_defined_oid_global oid thy
|
|
|
|
then let val {pos=pos_decl,id,cid,value,...} = the(DOF_core.get_object_global oid thy)
|
|
|
|
val markup = docref_markup false oid id pos_decl;
|
|
|
|
val _ = Context_Position.report_generic ctxt pos_decl markup;
|
|
|
|
(* this sends a report for a ref application to the PIDE interface ... *)
|
|
|
|
val _ = if cid = DOF_core.default_cid
|
|
|
|
then error("anonymous "^ DOF_core.default_cid ^ " class has no value" )
|
|
|
|
else ()
|
|
|
|
in value end
|
|
|
|
else error("undefined document reference:"^oid)
|
|
|
|
end
|
2019-04-29 20:24:32 +00:00
|
|
|
|
2018-04-27 08:34:24 +00:00
|
|
|
|
2019-03-12 15:45:04 +00:00
|
|
|
fun ML_antiquotation_docitem_value (ctxt, toks) =
|
2020-04-09 21:58:58 +00:00
|
|
|
(Scan.lift (Args.cartouche_input)
|
|
|
|
>> (fn inp => (ML_Syntax.atomic o ML_Syntax.print_term)
|
|
|
|
((check_and_mark_term ctxt o fst o Input.source_content) inp)))
|
|
|
|
(ctxt, toks)
|
2019-03-12 15:45:04 +00:00
|
|
|
|
2020-04-09 21:58:58 +00:00
|
|
|
(* Setup for general docitems of the global DOF_core.default_cid - class ("text")*)
|
2019-04-29 20:24:32 +00:00
|
|
|
val _ = Theory.setup
|
2020-04-09 21:58:58 +00:00
|
|
|
(docitem_antiquotation \<^binding>\<open>docitem\<close> DOF_core.default_cid #>
|
2019-04-29 20:24:32 +00:00
|
|
|
|
|
|
|
ML_Antiquotation.inline \<^binding>\<open>docitem_value\<close> ML_antiquotation_docitem_value)
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
end (* struct *)
|
2018-09-11 06:50:51 +00:00
|
|
|
\<close>
|
2018-04-27 15:12:42 +00:00
|
|
|
|
2018-12-07 10:08:13 +00:00
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
ML\<open>
|
2018-08-30 10:53:02 +00:00
|
|
|
structure AttributeAccess =
|
2018-08-24 14:58:06 +00:00
|
|
|
struct
|
|
|
|
|
2021-12-18 22:06:51 +00:00
|
|
|
val basic_entity = Document_Output.antiquotation_pretty_source
|
2019-08-15 09:30:42 +00:00
|
|
|
: binding -> 'a context_parser -> (Proof.context -> 'a -> Pretty.T) -> theory -> theory;
|
|
|
|
|
2022-11-24 09:41:50 +00:00
|
|
|
fun compute_trace_ML ctxt oid pos_opt pos' =
|
2018-10-17 10:22:25 +00:00
|
|
|
(* grabs attribute, and converts its HOL-term into (textual) ML representation *)
|
2022-11-24 13:20:29 +00:00
|
|
|
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)
|
|
|
|
in (s', HOLogic.dest_string S) end
|
|
|
|
in map conv (HOLogic.dest_list term) end
|
|
|
|
|
2018-10-16 10:23:36 +00:00
|
|
|
|
2021-04-21 18:24:06 +00:00
|
|
|
val parse_oid = Scan.lift(Parse.position Args.name)
|
|
|
|
val parse_cid = Scan.lift(Parse.position Args.name)
|
2018-12-10 12:13:13 +00:00
|
|
|
val parse_oid' = Term_Style.parse -- parse_oid
|
2020-02-13 10:17:20 +00:00
|
|
|
val parse_cid' = Term_Style.parse -- parse_cid
|
|
|
|
|
2022-08-01 13:53:33 +00:00
|
|
|
|
|
|
|
|
2020-02-13 10:17:20 +00:00
|
|
|
val parse_attribute_access = (parse_oid
|
2018-12-07 10:08:13 +00:00
|
|
|
--| (Scan.lift @{keyword "::"})
|
|
|
|
-- Scan.lift (Parse.position Args.name))
|
2018-12-07 11:09:12 +00:00
|
|
|
: ((string *Position.T) * (string * Position.T)) context_parser
|
|
|
|
|
|
|
|
val parse_attribute_access' = Term_Style.parse -- parse_attribute_access
|
|
|
|
: ((term -> term) *
|
|
|
|
((string * Position.T) * (string * Position.T))) context_parser
|
2018-12-07 10:08:13 +00:00
|
|
|
|
2018-12-07 11:09:12 +00:00
|
|
|
fun attr_2_ML ctxt ((attr:string,pos),(oid:string,pos')) = (ML_Syntax.atomic o ML_Syntax.print_term)
|
2022-11-24 13:20:29 +00:00
|
|
|
(ISA_core.compute_attr_access ctxt attr oid (SOME pos) pos')
|
2018-12-07 10:08:13 +00:00
|
|
|
|
2021-04-21 18:24:06 +00:00
|
|
|
|
|
|
|
fun get_instance_value_2_ML ctxt (oid:string,pos) =
|
2023-01-26 08:43:51 +00:00
|
|
|
let val ctxt' = Context.the_proof ctxt
|
|
|
|
val value = case DOF_core.get_object_local oid ctxt' of
|
|
|
|
SOME({pos=pos_decl,id,value,...}) =>
|
|
|
|
let val markup = docref_markup false oid id pos_decl
|
|
|
|
val _ = Context_Position.report ctxt' pos markup
|
|
|
|
in value end
|
2021-04-21 18:24:06 +00:00
|
|
|
| NONE => error "not an object id"
|
2023-01-26 08:43:51 +00:00
|
|
|
in ML_Syntax.print_term value end
|
2021-04-21 18:24:06 +00:00
|
|
|
|
2018-12-18 13:29:08 +00:00
|
|
|
fun trace_attr_2_ML ctxt (oid:string,pos) =
|
|
|
|
let val print_string_pair = ML_Syntax.print_pair ML_Syntax.print_string ML_Syntax.print_string
|
|
|
|
val toML = (ML_Syntax.atomic o (ML_Syntax.print_list print_string_pair))
|
2022-11-24 09:41:50 +00:00
|
|
|
in toML (compute_trace_ML ctxt oid NONE pos) end
|
2018-12-07 10:08:13 +00:00
|
|
|
|
2020-02-13 10:17:20 +00:00
|
|
|
fun compute_cid_repr ctxt cid pos =
|
|
|
|
if DOF_core.is_defined_cid_local cid ctxt then Const(cid,dummyT)
|
2022-08-01 19:42:32 +00:00
|
|
|
else ISA_core.err ("Undefined Class Identifier:"^cid) pos
|
2020-02-13 10:17:20 +00:00
|
|
|
|
2018-12-10 12:13:13 +00:00
|
|
|
local
|
2018-12-07 12:17:39 +00:00
|
|
|
|
2022-11-24 09:41:50 +00:00
|
|
|
fun pretty_attr_access_style ctxt (style, ((attr,pos),(oid,pos'))) =
|
2022-11-24 13:20:29 +00:00
|
|
|
Document_Output.pretty_term ctxt (style (ISA_core.compute_attr_access (Context.Proof ctxt)
|
2022-11-24 09:41:50 +00:00
|
|
|
attr oid (SOME pos) pos'));
|
2018-12-07 12:17:39 +00:00
|
|
|
fun pretty_trace_style ctxt (style, (oid,pos)) =
|
2022-11-24 13:20:29 +00:00
|
|
|
Document_Output.pretty_term ctxt (style (ISA_core.compute_attr_access (Context.Proof ctxt)
|
2022-11-24 09:41:50 +00:00
|
|
|
"trace" oid NONE pos));
|
2020-02-13 10:17:20 +00:00
|
|
|
fun pretty_cid_style ctxt (style, (cid,pos)) =
|
2021-12-18 22:06:51 +00:00
|
|
|
Document_Output.pretty_term ctxt (style (compute_cid_repr ctxt cid pos));
|
2020-02-13 10:17:20 +00:00
|
|
|
|
2022-08-01 13:53:33 +00:00
|
|
|
(* NEW VERSION: PLEASE INTEGRATE ALL OVER : *)
|
|
|
|
fun context_position_parser parse_con (ctxt, toks) =
|
|
|
|
let val pos = case toks of
|
|
|
|
a :: _ => Token.pos_of a
|
|
|
|
| _ => @{here} \<comment> \<open>a real hack !\<close>
|
|
|
|
val (res, (ctxt', toks')) = parse_con (ctxt, toks)
|
|
|
|
in ((res,pos),(ctxt', toks')) end
|
|
|
|
|
|
|
|
val parse_cid = (context_position_parser Args.typ_abbrev)
|
|
|
|
>> (fn (Type(ss,_),pos) => (pos,ss)
|
|
|
|
|( _,pos) => ISA_core.err "Undefined Class Id" pos);
|
|
|
|
|
|
|
|
|
|
|
|
val parse_cid' = Term_Style.parse -- parse_cid
|
|
|
|
|
|
|
|
fun pretty_cid_style ctxt (style,(pos,cid)) =
|
|
|
|
(*reconversion to term in order to haave access to term print options like: short_names etc...) *)
|
|
|
|
Document_Output.pretty_term ctxt ((compute_cid_repr ctxt cid pos));
|
|
|
|
|
2020-02-13 10:17:20 +00:00
|
|
|
in
|
2018-10-16 10:23:36 +00:00
|
|
|
val _ = Theory.setup
|
2021-04-21 18:24:06 +00:00
|
|
|
(ML_Antiquotation.inline \<^binding>\<open>docitem\<close>
|
|
|
|
(fn (ctxt,toks) => (parse_oid >> get_instance_value_2_ML ctxt) (ctxt, toks)) #>
|
|
|
|
ML_Antiquotation.inline \<^binding>\<open>docitem_attribute\<close>
|
2018-12-07 10:08:13 +00:00
|
|
|
(fn (ctxt,toks) => (parse_attribute_access >> attr_2_ML ctxt) (ctxt, toks)) #>
|
2019-04-29 20:24:32 +00:00
|
|
|
ML_Antiquotation.inline \<^binding>\<open>trace_attribute\<close>
|
2018-12-07 12:17:39 +00:00
|
|
|
(fn (ctxt,toks) => (parse_oid >> trace_attr_2_ML ctxt) (ctxt, toks)) #>
|
2019-04-29 20:24:32 +00:00
|
|
|
basic_entity \<^binding>\<open>trace_attribute\<close> parse_oid' pretty_trace_style #>
|
2020-02-13 10:17:20 +00:00
|
|
|
basic_entity \<^binding>\<open>doc_class\<close> parse_cid' pretty_cid_style #>
|
2022-08-01 13:53:33 +00:00
|
|
|
basic_entity \<^binding>\<open>onto_class\<close> parse_cid' pretty_cid_style #>
|
2019-04-29 20:24:32 +00:00
|
|
|
basic_entity \<^binding>\<open>docitem_attribute\<close> parse_attribute_access' pretty_attr_access_style
|
2018-10-16 10:23:36 +00:00
|
|
|
)
|
2018-12-10 12:13:13 +00:00
|
|
|
end
|
2018-12-07 12:17:39 +00:00
|
|
|
end
|
2018-10-16 10:23:36 +00:00
|
|
|
\<close>
|
2018-08-18 12:44:39 +00:00
|
|
|
|
2019-04-29 20:24:32 +00:00
|
|
|
text\<open> Note that the functions \<^verbatim>\<open>basic_entities\<close> and \<^verbatim>\<open>basic_entity\<close> in
|
|
|
|
@{ML_structure AttributeAccess} are copied from
|
2021-12-18 22:06:51 +00:00
|
|
|
@{file "$ISABELLE_HOME/src/Pure/Thy/document_output.ML"} \<close>
|
2018-12-07 10:08:13 +00:00
|
|
|
|
|
|
|
|
2018-09-11 06:50:51 +00:00
|
|
|
section\<open> Syntax for Ontologies (the '' View'' Part III) \<close>
|
|
|
|
ML\<open>
|
2018-04-04 12:44:21 +00:00
|
|
|
structure OntoParser =
|
|
|
|
struct
|
2018-02-07 18:44:27 +00:00
|
|
|
|
|
|
|
fun read_parent NONE ctxt = (NONE, ctxt)
|
|
|
|
| read_parent (SOME raw_T) ctxt =
|
|
|
|
(case Proof_Context.read_typ_abbrev ctxt raw_T of
|
|
|
|
Type (name, Ts) => (SOME (Ts, name), fold Variable.declare_typ Ts ctxt)
|
|
|
|
| T => error ("Bad parent record specification: " ^ Syntax.string_of_typ ctxt T));
|
|
|
|
|
2018-02-08 15:25:15 +00:00
|
|
|
|
2018-04-27 15:12:42 +00:00
|
|
|
|
|
|
|
|
2018-02-07 18:44:27 +00:00
|
|
|
fun read_fields raw_fields ctxt =
|
2018-04-05 10:09:58 +00:00
|
|
|
let
|
|
|
|
val Ts = Syntax.read_typs ctxt (map (fn ((_, raw_T, _),_) => raw_T) raw_fields);
|
|
|
|
val terms = map ((map_option (Syntax.read_term ctxt)) o snd) raw_fields
|
2018-04-27 15:12:42 +00:00
|
|
|
fun test t1 t2 = Sign.typ_instance (Proof_Context.theory_of ctxt)
|
2022-05-25 15:07:06 +00:00
|
|
|
(t1, Value_Command.Docitem_Parser.generalize_typ 0 t2)
|
2018-04-17 15:39:16 +00:00
|
|
|
fun check_default (ty,SOME trm) =
|
|
|
|
let val ty' = (type_of trm)
|
|
|
|
in if test ty ty'
|
|
|
|
then ()
|
|
|
|
else error("type mismatch:"^
|
|
|
|
(Syntax.string_of_typ ctxt ty')^":"^
|
|
|
|
(Syntax.string_of_typ ctxt ty))
|
|
|
|
end
|
|
|
|
(* BAD STYLE : better would be catching exn. *)
|
|
|
|
|check_default (_,_) = ()
|
2018-04-05 10:09:58 +00:00
|
|
|
val fields = map2 (fn ((x, _, mx),_) => fn T => (x, T, mx)) raw_fields Ts;
|
2018-04-17 15:39:16 +00:00
|
|
|
val _ = map check_default (Ts ~~ terms) (* checking types conform to defaults *)
|
2018-04-05 10:09:58 +00:00
|
|
|
val ctxt' = fold Variable.declare_typ Ts ctxt;
|
|
|
|
in (fields, terms, ctxt') end;
|
2018-02-07 18:44:27 +00:00
|
|
|
|
2022-12-02 12:50:16 +00:00
|
|
|
val trace_attr = ((\<^binding>\<open>trace\<close>, "(doc_class rexp \<times> string) list",Mixfix.NoSyn),
|
2018-10-08 08:30:53 +00:00
|
|
|
SOME "[]"): ((binding * string * mixfix) * string option)
|
|
|
|
|
2021-12-18 22:06:51 +00:00
|
|
|
fun def_cmd (decl, spec, prems, params) lthy =
|
|
|
|
let
|
|
|
|
val ((lhs as Free (x, T), _), lthy') = Specification.definition decl params prems spec lthy;
|
|
|
|
val lhs' = Morphism.term (Local_Theory.target_morphism lthy') lhs;
|
|
|
|
val _ =
|
|
|
|
Proof_Display.print_consts true (Position.thread_data ()) lthy'
|
|
|
|
(Frees.defined (Frees.build (Frees.add_frees lhs'))) [(x, T)]
|
|
|
|
in lthy' end
|
|
|
|
|
2022-12-02 10:41:31 +00:00
|
|
|
fun mk_meta_eq (t, u) = \<^Const>\<open>Pure.eq \<open>fastype_of t\<close> for t u\<close>;
|
2020-04-12 19:11:54 +00:00
|
|
|
|
|
|
|
fun define_cond binding f_sty cond_suffix read_cond (ctxt:local_theory) =
|
|
|
|
let val bdg = Binding.suffix_name cond_suffix binding
|
2021-12-14 17:04:04 +00:00
|
|
|
val eq = mk_meta_eq(Free(Binding.name_of bdg, f_sty),read_cond)
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
val args = (SOME(bdg,NONE,NoSyn), (Binding.empty_atts,eq),[],[])
|
2021-12-18 22:06:51 +00:00
|
|
|
in def_cmd args ctxt end
|
2020-04-12 19:11:54 +00:00
|
|
|
|
|
|
|
fun define_inv cid_long ((lbl, pos), inv) thy =
|
2021-12-14 17:04:04 +00:00
|
|
|
let val bdg = Binding.make (lbl,pos)
|
|
|
|
val inv_term = Syntax.read_term (Proof_Context.init_global thy) inv
|
2023-01-13 07:23:15 +00:00
|
|
|
(* Rewrite selectors types to allow invariants on attributes of the superclasses
|
|
|
|
using the polymorphic type of the class *)
|
|
|
|
fun update_attribute_type thy class_scheme_ty cid_long
|
2021-12-14 17:04:04 +00:00
|
|
|
(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
|
|
|
|
NONE => Const (s, Type(st,[ty, ty']))
|
2023-01-13 07:23:15 +00:00
|
|
|
$ (update_attribute_type thy class_scheme_ty cid_long t)
|
|
|
|
| SOME _ => if DOF_core.is_subclass_global thy cid_long cid
|
|
|
|
then let val Type(st', tys') = ty
|
|
|
|
in if tys' = [\<^typ>\<open>unit\<close>]
|
|
|
|
then Const (s, Type(st,[ty, ty']))
|
|
|
|
$ (update_attribute_type thy class_scheme_ty cid_long t)
|
|
|
|
else Const(s, Type(st,[class_scheme_ty, ty']))
|
|
|
|
$ (update_attribute_type thy class_scheme_ty cid_long t)
|
|
|
|
end
|
|
|
|
else Const (s, Type(st,[ty, ty']))
|
|
|
|
$ (update_attribute_type thy class_scheme_ty cid_long t)
|
2021-12-14 17:04:04 +00:00
|
|
|
end
|
2023-01-13 07:23:15 +00:00
|
|
|
| update_attribute_type thy class_scheme_ty cid_long (t $ t') =
|
|
|
|
(update_attribute_type thy class_scheme_ty cid_long t)
|
|
|
|
$ (update_attribute_type thy class_scheme_ty cid_long t')
|
|
|
|
| update_attribute_type thy class_scheme_ty cid_long (Abs(s, ty, t)) =
|
|
|
|
Abs(s, ty, update_attribute_type thy class_scheme_ty cid_long t)
|
|
|
|
| update_attribute_type _ class_scheme_ty _ (Free(s, ty)) = if s = invariantN
|
2021-12-14 17:04:04 +00:00
|
|
|
then Free (s, class_scheme_ty)
|
|
|
|
else Free (s, ty)
|
2023-01-13 07:23:15 +00:00
|
|
|
| update_attribute_type _ _ _ t = t
|
2022-03-28 16:19:41 +00:00
|
|
|
val inv_ty = Syntax.read_typ (Proof_Context.init_global thy)
|
|
|
|
(Name.aT ^ " " ^ cid_long ^ schemeN)
|
2021-12-14 17:04:04 +00:00
|
|
|
(* Update the type of each attribute update function to match the type of the
|
|
|
|
current class. *)
|
2023-01-13 07:23:15 +00:00
|
|
|
val inv_term' = update_attribute_type thy inv_ty cid_long inv_term
|
2021-12-14 17:04:04 +00:00
|
|
|
val eq_inv_ty = inv_ty --> HOLogic.boolT
|
|
|
|
val abs_term = Term.lambda (Free (invariantN, inv_ty)) inv_term'
|
|
|
|
in thy |> Named_Target.theory_map (define_cond bdg eq_inv_ty invariant_suffixN abs_term) end
|
2020-04-12 19:11:54 +00:00
|
|
|
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
fun add_doc_class_cmd overloaded (raw_params, binding)
|
2020-02-21 18:23:51 +00:00
|
|
|
raw_parent raw_fieldsNdefaults reject_Atoms regexps invariants thy =
|
2018-04-05 10:09:58 +00:00
|
|
|
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;
|
2020-02-21 14:39:50 +00:00
|
|
|
fun cid thy = DOF_core.parse_cid_global thy (Binding.name_of binding)
|
2018-04-05 10:09:58 +00:00
|
|
|
val (parent, ctxt2) = read_parent raw_parent ctxt1;
|
2020-02-21 14:39:50 +00:00
|
|
|
val parent_cid_long = map_optional snd DOF_core.default_cid parent;
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
(* takes class synonyms into account *)
|
2020-02-21 15:33:28 +00:00
|
|
|
val parent' = map_option (map_snd (K (DOF_core.read_cid_global thy parent_cid_long))) parent
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
val parent'_cid_long = map_optional snd DOF_core.default_cid parent';
|
2018-10-08 08:30:53 +00:00
|
|
|
val raw_fieldsNdefaults' = filter (fn((bi,_,_),_) => Binding.name_of bi <> "trace")
|
|
|
|
raw_fieldsNdefaults
|
|
|
|
val _ = if length raw_fieldsNdefaults' <> length raw_fieldsNdefaults
|
|
|
|
then warning("re-declaration of trace attribute in monitor --- ignored")
|
|
|
|
else ()
|
2018-11-19 19:53:59 +00:00
|
|
|
val raw_fieldsNdefaults'' = if null regexps
|
|
|
|
then raw_fieldsNdefaults'
|
|
|
|
else trace_attr::raw_fieldsNdefaults'
|
2018-10-08 08:30:53 +00:00
|
|
|
val (fields, terms, ctxt3) = read_fields raw_fieldsNdefaults'' ctxt2;
|
2018-04-05 10:09:58 +00:00
|
|
|
val fieldsNterms = (map (fn (a,b,_) => (a,b)) fields) ~~ terms
|
|
|
|
val fieldsNterms' = map (fn ((x,y),z) => (x,y,z)) fieldsNterms
|
|
|
|
val params' = map (Proof_Context.check_tfree ctxt3) params;
|
2018-04-20 11:19:50 +00:00
|
|
|
fun check_n_filter thy (bind,ty,mf) =
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
case DOF_core.get_attribute_info parent'_cid_long (Binding.name_of bind) thy of
|
|
|
|
NONE => SOME(bind,ty,mf)
|
|
|
|
| SOME{def_occurrence,long_name,typ,...}
|
|
|
|
=> if ty = typ
|
|
|
|
then (warning("overriding attribute:"
|
|
|
|
^ long_name
|
|
|
|
^ " in doc class:"
|
|
|
|
^ def_occurrence);
|
|
|
|
NONE)
|
|
|
|
else error("no overloading allowed.")
|
|
|
|
val record_fields = map_filter (check_n_filter thy) fields
|
2018-05-28 14:10:20 +00:00
|
|
|
(* adding const symbol representing doc-class for Monitor-RegExps.*)
|
2022-11-24 13:20:29 +00:00
|
|
|
val constant_typ = \<^typ>\<open>doc_class rexp\<close>
|
|
|
|
val constant_term = \<^Const>\<open>Atom \<^typ>\<open>doc_class\<close>\<close>
|
|
|
|
$ (\<^Const>\<open>mk\<close>
|
|
|
|
$ HOLogic.mk_string (Binding.name_of binding))
|
|
|
|
val eq = mk_meta_eq(Free(Binding.name_of binding, constant_typ), constant_term)
|
|
|
|
val args = (SOME(binding,NONE,NoSyn), (Binding.empty_atts,eq),[],[])
|
|
|
|
in thy |> Named_Target.theory_map (def_cmd args)
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
|> (fn thy =>
|
|
|
|
case parent' of
|
|
|
|
NONE => (Record.add_record
|
|
|
|
overloaded (params', binding) parent' (DOF_core.tag_attr::record_fields)
|
|
|
|
#> DOF_core.define_doc_class_global
|
|
|
|
(params', binding) parent fieldsNterms' regexps
|
|
|
|
reject_Atoms invariants {virtual=false}) thy
|
|
|
|
| SOME _ =>
|
|
|
|
if (not o null) record_fields
|
|
|
|
then (Record.add_record overloaded (params', binding) parent' (record_fields)
|
|
|
|
#> DOF_core.define_doc_class_global
|
|
|
|
(params', binding) parent fieldsNterms' regexps
|
|
|
|
reject_Atoms invariants {virtual=false}) thy
|
|
|
|
else (Record.add_record
|
|
|
|
overloaded (params', binding) parent' ([DOF_core.tag_attr])
|
|
|
|
#> DOF_core.define_doc_class_global
|
|
|
|
(params', binding) parent fieldsNterms' regexps
|
|
|
|
reject_Atoms invariants {virtual=true}) thy)
|
|
|
|
|
2019-03-12 15:45:04 +00:00
|
|
|
|> (fn thy => OntoLinkParser.docitem_antiquotation binding (cid thy) thy)
|
2018-11-19 19:53:59 +00:00
|
|
|
(* defines the ontology-checked text antiquotation to this document class *)
|
2020-04-12 19:11:54 +00:00
|
|
|
|> (fn thy => fold(define_inv (cid thy)) (invariants) thy)
|
Fix the record generation in class implementation
- Fix the generation of the record associated with
a class and used for the logic.
The old implementation generated a new attribute
for each attribute defined by a subclass,
even the ones that were overriding ones of the superclass.
The new implementation generates the attributes of the subclass
which are not overriding ones.
Warning:
It implies that overridden attributes in a subclass are not
new attributes added to the theory context.
So the base name of an attribute will refer to the attribute
of the last declared class where it is defined.
If ones wants to refer to atttributes, one should use
long names, even in the invariants of a subclass definition
which overrides the attribute used in the invariant.
For example,
in ~~/src/ontologies/scholarly_paper/scholarly_paper.thy:
doc_class technical = text_section +
definition_list :: "string list" <= "[]"
status :: status <= "description"
formal_results :: "thm list"
invariant L1 :: "λσ::technical. the (level σ) > 0"
type_synonym tc = technical (* technical content *)
doc_class example = text_section +
referentiable :: bool <= True
status :: status <= "description"
short_name :: string <= "''''"
doc_class math_content = tc +
referentiable :: bool <= True
short_name :: string <= "''''"
status :: status <= "semiformal"
mcc :: "math_content_class" <= "thm"
invariant s1 :: "λ σ::math_content. ¬referentiable σ ⟶ short_name σ = ''''"
invariant s2 :: "λ σ::math_content. technical.status σ = semiformal"
The class math_content overrride the attribute status
of the class technical, by using the type synonym tc,
but the base name of this attribute refers
to the attribute of the class example where it is last defined
and not just overridden.
So in the invariant s2 of the class math_content,
we must use the long name of the attribute,
i.e. the base name "status" with its qualifier which refers
to the superclass where it is defined, the class technical.
Type synonyms as qualifiers are not yet supported.
- Qualify classes that only override attributes of their superclass
as vitual classes by adding a virtual attribute.
This attribute is used to discriminate virtual classes and generate
an adequate make function to initialize their associated record.
The implementation uses an hidden attribute (the tag_attribute)
to force the virtual class to be concrete or the logic
by having a full new record definition associated with it.
For example:
doc_class W =
a::"int" <= "1"
doc_class X = W +
a::"int" <= "2"
The class X is tagged as a virtual class and
the record make functions of the classes W and X are:
W.make W_tag_attribute W_a
X.make X_tag_attribute X_a X_tag_attribute
So a record definition is added to the theory context for each class,
even though a virtual class only overrides
attributes of its superclass.
This behavior allows us to support definitions of new default values
for attributes in the subclass, as shown in the example.
- Factorize make name components
- Use Record name components instead of strings to refer to Record
components
- Fix typos
2021-11-17 11:55:37 +00:00
|
|
|
(* The function declare_ISA_class_accessor_and_check_instance uses a prefix
|
|
|
|
because the class name is already bound to "doc_class Regular_Exp.rexp" constant
|
|
|
|
by add_doc_class_cmd function *)
|
|
|
|
|> ISA_core.declare_ISA_class_accessor_and_check_instance binding
|
2021-12-09 08:57:21 +00:00
|
|
|
|> (fn thy => (ISA_core.declare_class_instances_annotation thy binding) thy)
|
2018-04-05 10:09:58 +00:00
|
|
|
end;
|
2020-04-12 19:11:54 +00:00
|
|
|
|
2021-09-29 12:21:13 +00:00
|
|
|
|
|
|
|
(* repackaging argument list *)
|
|
|
|
fun add_doc_class_cmd' (((overloaded, hdr), (parent, attrs)),((rejects,accept_rex),invars)) =
|
|
|
|
(add_doc_class_cmd {overloaded = overloaded} hdr parent attrs rejects accept_rex invars)
|
|
|
|
|
2020-04-09 15:25:09 +00:00
|
|
|
val parse_invariants = Parse.and_list (Args.name_position --| Parse.$$$ "::" -- Parse.term)
|
|
|
|
|
2021-09-29 12:21:13 +00:00
|
|
|
val parse_doc_class = (Parse_Spec.overloaded
|
2019-04-29 20:24:32 +00:00
|
|
|
-- (Parse.type_args_constrained -- Parse.binding)
|
|
|
|
-- (\<^keyword>\<open>=\<close>
|
2020-04-09 15:25:09 +00:00
|
|
|
|-- Scan.option (Parse.typ --| \<^keyword>\<open>+\<close>)
|
2019-04-29 20:24:32 +00:00
|
|
|
-- Scan.repeat1 (Parse.const_binding -- Scan.option (\<^keyword>\<open><=\<close> |-- Parse.term))
|
|
|
|
)
|
2020-04-09 15:25:09 +00:00
|
|
|
-- ( Scan.optional (\<^keyword>\<open>rejects\<close> |-- Parse.enum1 "," Parse.term) []
|
2023-01-12 11:18:58 +00:00
|
|
|
-- Scan.repeats (\<^keyword>\<open>accepts\<close> |-- (Parse.and_list Parse.term))
|
2020-04-09 15:25:09 +00:00
|
|
|
-- Scan.repeats ((\<^keyword>\<open>invariant\<close>) |-- parse_invariants))
|
2021-09-29 12:21:13 +00:00
|
|
|
)
|
|
|
|
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>doc_class\<close>
|
|
|
|
"define document class"
|
|
|
|
(parse_doc_class >> (Toplevel.theory o add_doc_class_cmd'));
|
|
|
|
|
|
|
|
|
|
|
|
(*just an alternative syntax*)
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>onto_class\<close>
|
|
|
|
"define ontological class"
|
|
|
|
(parse_doc_class >> (Toplevel.theory o add_doc_class_cmd'));
|
|
|
|
|
|
|
|
|
2018-04-04 12:44:21 +00:00
|
|
|
|
|
|
|
end (* struct *)
|
2018-09-11 06:50:51 +00:00
|
|
|
\<close>
|
2018-02-08 15:25:15 +00:00
|
|
|
|
2020-12-30 11:47:54 +00:00
|
|
|
|
|
|
|
|
|
|
|
section\<open>Shortcuts, Macros, Environments\<close>
|
|
|
|
text\<open>The features described in this section are actually \<^emph>\<open>not\<close> real ISADOF features, rather a
|
|
|
|
slightly more abstract layer over somewhat buried standard features of the Isabelle document
|
|
|
|
generator ... (Thanks to Makarius) Conceptually, they are \<^emph>\<open>sub-text-elements\<close>. \<close>
|
|
|
|
|
|
|
|
text\<open>This module provides mechanisms to define front-end checked:
|
|
|
|
\<^enum> \<^emph>\<open>shortcuts\<close>, i.e. machine-checked abbreviations without arguments
|
|
|
|
that were mapped to user-defined LaTeX code (Example: \<^verbatim>\<open>\ie\<close>)
|
|
|
|
\<^enum> \<^emph>\<open>macros\<close> with one argument that were mapped to user-defined code. Example: \<^verbatim>\<open>\myurl{bla}\<close>.
|
|
|
|
The argument can be potentially checked and reports can be sent to PIDE;
|
|
|
|
if no such checking is desired, this can be expressed by setting the
|
|
|
|
\<^theory_text>\<open>reportNtest\<close>-parameter to \<^theory_text>\<open>K(K())\<close>.
|
|
|
|
\<^enum> \<^emph>\<open>macros\<close> with two arguments, potentially independently checked. See above.
|
|
|
|
Example: \<^verbatim>\<open>\myurl[ding]{dong}\<close>,
|
|
|
|
\<^enum> \<^emph>\<open>boxes\<close> which are more complex sub-text-elements in the line of the \<^verbatim>\<open>verbatim\<close> or
|
|
|
|
\<^verbatim>\<open>theory_text\<close> environments.
|
|
|
|
|
|
|
|
Note that we deliberately refrained from a code-template definition mechanism for simplicity,
|
|
|
|
so the patterns were just described by strings. No additional ado with quoting/unquoting
|
|
|
|
mechanisms ...
|
|
|
|
\<close>
|
|
|
|
|
|
|
|
ML\<open>
|
|
|
|
structure DOF_lib =
|
|
|
|
struct
|
|
|
|
fun define_shortcut name latexshcut =
|
2021-12-18 22:06:51 +00:00
|
|
|
Document_Output.antiquotation_raw name (Scan.succeed ())
|
2020-12-30 11:47:54 +00:00
|
|
|
(fn _ => fn () => Latex.string latexshcut)
|
|
|
|
|
|
|
|
(* This is a generalization of the Isabelle2020 function "control_antiquotation" from
|
|
|
|
document_antiquotations.ML. (Thanks Makarius!) *)
|
|
|
|
fun define_macro name s1 s2 reportNtest =
|
2021-12-18 22:06:51 +00:00
|
|
|
Document_Output.antiquotation_raw_embedded name (Scan.lift Args.cartouche_input)
|
2020-12-30 11:47:54 +00:00
|
|
|
(fn ctxt =>
|
|
|
|
fn src => let val () = reportNtest ctxt src
|
2021-12-18 22:06:51 +00:00
|
|
|
in src |> XML.enclose s1 s2
|
|
|
|
o Document_Output.output_document ctxt {markdown = false}
|
2020-12-30 11:47:54 +00:00
|
|
|
end);
|
|
|
|
|
|
|
|
local (* hide away really strange local construction *)
|
|
|
|
fun enclose_body2 front body1 middle body2 post =
|
2021-12-18 22:06:51 +00:00
|
|
|
(if front = "" then [] else Latex.string front) @ body1 @
|
|
|
|
(if middle = "" then [] else Latex.string middle) @ body2 @
|
|
|
|
(if post = "" then [] else Latex.string post);
|
2020-12-30 11:47:54 +00:00
|
|
|
in
|
|
|
|
fun define_macro2 name front middle post reportNtest1 reportNtest2 =
|
2021-12-18 22:06:51 +00:00
|
|
|
Document_Output.antiquotation_raw_embedded name (Scan.lift ( Args.cartouche_input
|
2020-12-30 11:47:54 +00:00
|
|
|
-- Args.cartouche_input))
|
|
|
|
(fn ctxt =>
|
|
|
|
fn (src1,src2) => let val () = reportNtest1 ctxt src1
|
|
|
|
val () = reportNtest2 ctxt src2
|
2021-12-18 22:06:51 +00:00
|
|
|
val T1 = Document_Output.output_document ctxt {markdown = false} src1
|
|
|
|
val T2 = Document_Output.output_document ctxt {markdown = false} src2
|
|
|
|
in enclose_body2 front T1 middle T2 post
|
2020-12-30 11:47:54 +00:00
|
|
|
end);
|
|
|
|
end
|
|
|
|
|
|
|
|
fun report_text ctxt text =
|
|
|
|
let val pos = Input.pos_of text in
|
|
|
|
Context_Position.reports ctxt
|
|
|
|
[(pos, Markup.language_text (Input.is_delimited text)),
|
|
|
|
(pos, Markup.raw_text)]
|
|
|
|
end;
|
|
|
|
|
|
|
|
fun report_theory_text ctxt text =
|
|
|
|
let val keywords = Thy_Header.get_keywords' ctxt;
|
|
|
|
val _ = report_text ctxt text;
|
|
|
|
val _ =
|
|
|
|
Input.source_explode text
|
|
|
|
|> Token.tokenize keywords {strict = true}
|
|
|
|
|> maps (Token.reports keywords)
|
|
|
|
|> Context_Position.reports_text ctxt;
|
|
|
|
in () end
|
|
|
|
|
|
|
|
fun prepare_text ctxt =
|
|
|
|
Input.source_content #> #1 #> Document_Antiquotation.prepare_lines ctxt;
|
|
|
|
(* This also produces indent-expansion and changes space to "\_" and the introduction of "\newline",
|
|
|
|
I believe. Otherwise its in Thy_Output.output_source, the compiler from string to LaTeX.text. *)
|
|
|
|
|
|
|
|
fun string_2_text_antiquotation ctxt text =
|
|
|
|
prepare_text ctxt text
|
2021-12-18 22:06:51 +00:00
|
|
|
|> Document_Output.output_source ctxt
|
|
|
|
|> Document_Output.isabelle ctxt
|
2020-12-30 11:47:54 +00:00
|
|
|
|
|
|
|
fun string_2_theory_text_antiquotation ctxt text =
|
|
|
|
let
|
|
|
|
val keywords = Thy_Header.get_keywords' ctxt;
|
|
|
|
in
|
|
|
|
prepare_text ctxt text
|
|
|
|
|> Token.explode0 keywords
|
2021-12-18 22:06:51 +00:00
|
|
|
|> maps (Document_Output.output_token ctxt)
|
|
|
|
|> Document_Output.isabelle ctxt
|
2020-12-30 11:47:54 +00:00
|
|
|
end
|
|
|
|
|
|
|
|
fun gen_text_antiquotation name reportNcheck compile =
|
2022-07-17 21:46:56 +00:00
|
|
|
Document_Output.antiquotation_raw_embedded name (Scan.lift Parse.embedded_input)
|
2020-12-30 11:47:54 +00:00
|
|
|
(fn ctxt => fn text:Input.source =>
|
|
|
|
let
|
|
|
|
val _ = reportNcheck ctxt text;
|
|
|
|
in
|
|
|
|
compile ctxt text
|
|
|
|
end);
|
|
|
|
|
|
|
|
fun std_text_antiquotation name (* redefined in these more abstract terms *) =
|
|
|
|
gen_text_antiquotation name report_text string_2_text_antiquotation
|
|
|
|
|
|
|
|
(* should be the same as (2020):
|
|
|
|
fun text_antiquotation name =
|
2022-10-24 19:30:49 +00:00
|
|
|
Thy_Output.antiquotation_raw_embedded name (Scan.lift Parse.embedded_input)
|
2020-12-30 11:47:54 +00:00
|
|
|
(fn ctxt => fn text =>
|
|
|
|
let
|
|
|
|
val _ = report_text ctxt text;
|
|
|
|
in
|
|
|
|
prepare_text ctxt text
|
|
|
|
|> Thy_Output.output_source ctxt
|
|
|
|
|> Thy_Output.isabelle ctxt
|
|
|
|
end);
|
|
|
|
*)
|
|
|
|
|
|
|
|
fun std_theory_text_antiquotation name (* redefined in these more abstract terms *) =
|
|
|
|
gen_text_antiquotation name report_theory_text string_2_theory_text_antiquotation
|
|
|
|
|
|
|
|
(* should be the same as (2020):
|
|
|
|
fun theory_text_antiquotation name =
|
2022-10-24 19:30:49 +00:00
|
|
|
Thy_Output.antiquotation_raw_embedded name (Scan.lift Parse.embedded_input)
|
2020-12-30 11:47:54 +00:00
|
|
|
(fn ctxt => fn text =>
|
|
|
|
let
|
|
|
|
val keywords = Thy_Header.get_keywords' ctxt;
|
|
|
|
|
|
|
|
val _ = report_text ctxt text;
|
|
|
|
val _ =
|
|
|
|
Input.source_explode text
|
|
|
|
|> Token.tokenize keywords {strict = true}
|
|
|
|
|> maps (Token.reports keywords)
|
|
|
|
|> Context_Position.reports_text ctxt;
|
|
|
|
in
|
|
|
|
prepare_text ctxt text
|
|
|
|
|> Token.explode0 keywords
|
|
|
|
|> maps (Thy_Output.output_token ctxt)
|
|
|
|
|> Thy_Output.isabelle ctxt
|
|
|
|
|> enclose_env ctxt "isarbox"
|
|
|
|
end);
|
|
|
|
*)
|
|
|
|
|
|
|
|
|
|
|
|
fun environment_delim name =
|
2022-12-01 21:04:56 +00:00
|
|
|
("%\n\\begin{" ^ Latex.output_name name ^ "}\n",
|
|
|
|
"\n\\end{" ^ Latex.output_name name ^ "}");
|
2020-12-30 11:47:54 +00:00
|
|
|
|
2021-12-18 22:06:51 +00:00
|
|
|
fun environment_block name = environment_delim name |-> XML.enclose;
|
2020-12-30 11:47:54 +00:00
|
|
|
|
|
|
|
fun enclose_env verbatim ctxt block_env body =
|
|
|
|
if Config.get ctxt Document_Antiquotation.thy_output_display
|
|
|
|
then if verbatim
|
2021-12-18 22:06:51 +00:00
|
|
|
then environment_block block_env body
|
|
|
|
else Latex.environment block_env body
|
|
|
|
else XML.enclose ("\\inline"^block_env ^"{") "}" body;
|
2020-12-30 11:47:54 +00:00
|
|
|
|
|
|
|
end
|
|
|
|
\<close>
|
|
|
|
|
2022-07-17 21:46:56 +00:00
|
|
|
|
2020-12-30 11:47:54 +00:00
|
|
|
ML\<open>
|
|
|
|
local
|
|
|
|
val parse_literal = Parse.alt_string || Parse.cartouche
|
|
|
|
val parse_define_shortcut = Parse.binding -- ((\<^keyword>\<open>\<rightleftharpoons>\<close> || \<^keyword>\<open>==\<close>) |-- parse_literal)
|
|
|
|
val define_shortcuts = fold(uncurry DOF_lib.define_shortcut)
|
|
|
|
in
|
|
|
|
val _ = Outer_Syntax.command \<^command_keyword>\<open>define_shortcut*\<close> "define LaTeX shortcut"
|
|
|
|
(Scan.repeat1 parse_define_shortcut >> (Toplevel.theory o define_shortcuts));
|
|
|
|
end
|
|
|
|
\<close>
|
|
|
|
|
|
|
|
ML\<open>
|
|
|
|
val parse_literal = Parse.alt_string || Parse.cartouche
|
|
|
|
val parse_define_shortcut = Parse.binding
|
|
|
|
-- ((\<^keyword>\<open>\<rightleftharpoons>\<close> || \<^keyword>\<open>==\<close>) |-- parse_literal)
|
|
|
|
--|Parse.underscore
|
|
|
|
-- parse_literal
|
|
|
|
-- (Scan.option (\<^keyword>\<open>(\<close> |-- Parse.ML_source --|\<^keyword>\<open>)\<close>))
|
|
|
|
|
|
|
|
fun define_macro (X,NONE) = (uncurry(uncurry(uncurry DOF_lib.define_macro)))(X,K(K()))
|
|
|
|
|define_macro (X,SOME(src:Input.source)) =
|
|
|
|
let val check_code = K(K()) (* hack *)
|
|
|
|
val _ = warning "Checker code support Not Yet Implemented - use ML"
|
|
|
|
in (uncurry(uncurry(uncurry DOF_lib.define_macro)))(X,check_code)
|
|
|
|
end;
|
|
|
|
|
|
|
|
val _ = Outer_Syntax.command \<^command_keyword>\<open>define_macro*\<close> "define LaTeX shortcut"
|
|
|
|
(Scan.repeat1 parse_define_shortcut >> (Toplevel.theory o (fold define_macro)));
|
|
|
|
|
|
|
|
\<close>
|
|
|
|
|
2022-03-11 11:30:34 +00:00
|
|
|
|
2022-12-04 15:38:56 +00:00
|
|
|
section \<open>Document context: template and ontology\<close>
|
2022-03-11 11:30:34 +00:00
|
|
|
|
2022-12-02 19:05:15 +00:00
|
|
|
ML \<open>
|
2022-12-03 13:44:04 +00:00
|
|
|
signature DOCUMENT_CONTEXT =
|
2022-12-02 19:05:15 +00:00
|
|
|
sig
|
|
|
|
val template_space: Context.generic -> Name_Space.T
|
2022-12-03 23:09:29 +00:00
|
|
|
val ontology_space: Context.generic -> Name_Space.T
|
2022-12-02 19:05:15 +00:00
|
|
|
val print_template: Context.generic -> string -> string
|
2022-12-03 23:09:29 +00:00
|
|
|
val print_ontology: Context.generic -> string -> string
|
|
|
|
val check_template: Context.generic -> xstring * Position.T -> string * string
|
|
|
|
val check_ontology: Context.generic -> xstring * Position.T -> string * string
|
2022-12-02 19:05:15 +00:00
|
|
|
val define_template: binding * string -> theory -> string * theory
|
2022-12-03 23:09:29 +00:00
|
|
|
val define_ontology: binding * string -> theory -> string * theory
|
|
|
|
val use_template: Context.generic -> xstring * Position.T -> unit
|
|
|
|
val use_ontology: Context.generic -> (xstring * Position.T) list -> unit
|
2022-12-02 19:05:15 +00:00
|
|
|
end;
|
|
|
|
|
2022-12-03 13:44:04 +00:00
|
|
|
structure Document_Context: DOCUMENT_CONTEXT =
|
2022-12-02 19:05:15 +00:00
|
|
|
struct
|
|
|
|
|
|
|
|
(* theory data *)
|
|
|
|
|
2022-12-03 23:09:29 +00:00
|
|
|
local
|
|
|
|
|
2022-12-02 19:05:15 +00:00
|
|
|
structure Data = Theory_Data
|
|
|
|
(
|
2022-12-03 23:09:29 +00:00
|
|
|
type T = string Name_Space.table * string Name_Space.table;
|
|
|
|
val empty : T =
|
|
|
|
(Name_Space.empty_table "document_template",
|
|
|
|
Name_Space.empty_table "document_ontology");
|
|
|
|
fun merge ((templates1, ontologies1), (templates2, ontologies2)) =
|
|
|
|
(Name_Space.merge_tables (templates1, templates2),
|
|
|
|
Name_Space.merge_tables (ontologies1, ontologies2));
|
2022-12-02 19:05:15 +00:00
|
|
|
);
|
|
|
|
|
2022-12-03 13:44:04 +00:00
|
|
|
fun naming_context thy =
|
|
|
|
Proof_Context.init_global thy
|
|
|
|
|> Proof_Context.map_naming (Name_Space.root_path #> Name_Space.add_path "Isabelle_DOF")
|
|
|
|
|> Context.Proof;
|
|
|
|
|
2022-12-03 23:09:29 +00:00
|
|
|
fun get_space which = Name_Space.space_of_table o which o Data.get o Context.theory_of;
|
2022-12-02 19:05:15 +00:00
|
|
|
|
2022-12-03 23:09:29 +00:00
|
|
|
fun print which context =
|
|
|
|
Name_Space.markup_extern (Context.proof_of context) (get_space which context)
|
2022-12-02 19:05:15 +00:00
|
|
|
#> uncurry Markup.markup;
|
|
|
|
|
2022-12-03 23:09:29 +00:00
|
|
|
fun check which context arg =
|
|
|
|
Name_Space.check context (which (Data.get (Context.theory_of context))) arg;
|
|
|
|
|
|
|
|
fun define (get, ap) (binding, arg) thy =
|
|
|
|
let
|
|
|
|
val (name, table') =
|
|
|
|
Data.get thy |> get |> Name_Space.define (naming_context thy) true (binding, arg);
|
|
|
|
val thy' = (Data.map o ap) (K table') thy;
|
|
|
|
in (name, thy') end;
|
|
|
|
|
|
|
|
fun strip prfx sffx (path, pos) =
|
|
|
|
(case try (unprefix prfx) (Path.file_name path) of
|
|
|
|
NONE => error ("File name needs to have prefix " ^ quote prfx ^ Position.here pos)
|
|
|
|
| SOME a =>
|
|
|
|
(case try (unsuffix sffx) a of
|
|
|
|
NONE => error ("File name needs to have suffix " ^ quote sffx ^ Position.here pos)
|
|
|
|
| SOME b => b));
|
|
|
|
|
|
|
|
in
|
|
|
|
|
|
|
|
val template_space = get_space fst;
|
|
|
|
val ontology_space = get_space snd;
|
|
|
|
|
|
|
|
val print_template = print fst;
|
|
|
|
val print_ontology = print snd;
|
|
|
|
|
|
|
|
val check_template = check fst;
|
|
|
|
val check_ontology = check snd;
|
|
|
|
|
|
|
|
val define_template = define (fst, apfst);
|
|
|
|
val define_ontology = define (snd, apsnd);
|
2022-12-02 19:05:15 +00:00
|
|
|
|
|
|
|
fun use_template context arg =
|
2022-12-03 23:09:29 +00:00
|
|
|
let val xml = arg |> check_template context |> snd |> XML.string
|
2022-12-04 15:35:55 +00:00
|
|
|
in Export.export (Context.theory_of context) \<^path_binding>\<open>dof/use_template\<close> xml end;
|
2022-12-02 19:05:15 +00:00
|
|
|
|
2022-12-03 23:09:29 +00:00
|
|
|
fun use_ontology context args =
|
2022-12-02 19:05:15 +00:00
|
|
|
let
|
2022-12-03 23:09:29 +00:00
|
|
|
val xml = args
|
2022-12-04 17:03:53 +00:00
|
|
|
|> map (check_ontology context #> fst #> Long_Name.base_name)
|
|
|
|
|> cat_lines |> XML.string;
|
2022-12-04 15:35:55 +00:00
|
|
|
in Export.export (Context.theory_of context) \<^path_binding>\<open>dof/use_ontology\<close> xml end;
|
2022-12-03 23:09:29 +00:00
|
|
|
|
|
|
|
val strip_template = strip "root-" ".tex";
|
|
|
|
val strip_ontology = strip "DOF-" ".sty";
|
|
|
|
|
|
|
|
end;
|
2022-12-02 19:05:15 +00:00
|
|
|
|
|
|
|
|
|
|
|
(* Isar commands *)
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>use_template\<close>
|
|
|
|
"use DOF document template (as defined within theory context)"
|
|
|
|
(Parse.position Parse.name >> (fn arg =>
|
|
|
|
Toplevel.theory (fn thy => (use_template (Context.Theory thy) arg; thy))));
|
|
|
|
|
2022-12-03 23:09:29 +00:00
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>use_ontology\<close>
|
|
|
|
"use DOF document ontologies (as defined within theory context)"
|
|
|
|
(Parse.and_list1 (Parse.position Parse.name) >> (fn args =>
|
|
|
|
Toplevel.theory (fn thy => (use_ontology (Context.Theory thy) args; thy))));
|
|
|
|
|
2022-12-02 19:05:15 +00:00
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>define_template\<close>
|
2022-12-03 23:09:29 +00:00
|
|
|
"define DOF document template (via LaTeX root file)"
|
|
|
|
(Parse.position Resources.provide_parse_file >>
|
|
|
|
(fn (get_file, pos) => Toplevel.theory (fn thy =>
|
|
|
|
let
|
|
|
|
val (file, thy') = get_file thy;
|
|
|
|
val binding = Binding.make (strip_template (#src_path file, pos), pos);
|
|
|
|
val text = cat_lines (#lines file);
|
|
|
|
in #2 (define_template (binding, text) thy') end)));
|
|
|
|
|
|
|
|
val _ =
|
|
|
|
Outer_Syntax.command \<^command_keyword>\<open>define_ontology\<close>
|
|
|
|
"define DOF document ontology (via LaTeX style file)"
|
2022-12-02 19:05:15 +00:00
|
|
|
(Parse.position Resources.provide_parse_file >>
|
|
|
|
(fn (get_file, pos) => Toplevel.theory (fn thy =>
|
|
|
|
let
|
2022-12-03 23:09:29 +00:00
|
|
|
val (file, thy') = get_file thy;
|
|
|
|
val binding = Binding.make (strip_ontology (#src_path file, pos), pos);
|
2022-12-02 19:05:15 +00:00
|
|
|
val text = cat_lines (#lines file);
|
2022-12-03 23:09:29 +00:00
|
|
|
in #2 (define_ontology (binding, text) thy') end)));
|
2022-12-02 19:05:15 +00:00
|
|
|
|
|
|
|
end;
|
|
|
|
\<close>
|
|
|
|
|
|
|
|
define_template "../document-templates/root-eptcs-UNSUPPORTED.tex"
|
|
|
|
define_template "../document-templates/root-lipics-v2021-UNSUPPORTED.tex"
|
|
|
|
define_template "../document-templates/root-lncs.tex"
|
|
|
|
define_template "../document-templates/root-scrartcl.tex"
|
|
|
|
define_template "../document-templates/root-scrreprt-modern.tex"
|
|
|
|
define_template "../document-templates/root-scrreprt.tex"
|
|
|
|
define_template "../document-templates/root-svjour3-UNSUPPORTED.tex"
|
2022-03-11 11:30:34 +00:00
|
|
|
|
2022-12-04 18:13:08 +00:00
|
|
|
|
|
|
|
section \<open>Isabelle/Scala module within session context\<close>
|
|
|
|
|
|
|
|
external_file "../../etc/build.props"
|
|
|
|
external_file "../scala/dof_document_build.scala"
|
|
|
|
external_file "../scala/dof_mkroot.scala"
|
|
|
|
external_file "../scala/dof.scala"
|
|
|
|
external_file "../scala/dof_tools.scala"
|
|
|
|
|
2022-12-05 10:50:12 +00:00
|
|
|
scala_build_generated_files
|
|
|
|
external_files
|
|
|
|
"build.props" (in "../../etc")
|
|
|
|
and
|
|
|
|
"src/scala/dof_document_build.scala"
|
|
|
|
"src/scala/dof_mkroot.scala"
|
|
|
|
"src/scala/dof.scala"
|
|
|
|
"src/scala/dof_tools.scala" (in "../..")
|
2022-12-04 18:13:08 +00:00
|
|
|
|
2019-05-27 09:03:32 +00:00
|
|
|
(*
|
2019-05-23 13:17:24 +00:00
|
|
|
ML\<open>
|
2019-05-28 08:18:40 +00:00
|
|
|
Pretty.text;
|
|
|
|
Pretty.str;
|
|
|
|
Pretty.block_enclose;
|
2020-08-24 12:36:22 +00:00
|
|
|
theory_text_antiquotation in Document_Antiquotations (not exported)
|
2019-05-23 13:17:24 +00:00
|
|
|
\<close>
|
2019-05-28 08:18:40 +00:00
|
|
|
|
|
|
|
ML\<open>Pretty.text_fold; Pretty.unformatted_string_of\<close>
|
|
|
|
ML\<open> (String.concatWith ","); Token.content_of\<close>
|
|
|
|
|
2019-05-27 09:03:32 +00:00
|
|
|
|
2019-05-23 13:17:24 +00:00
|
|
|
ML\<open>
|
|
|
|
Document.state;
|
|
|
|
Session.get_keywords();
|
|
|
|
Parse.command;
|
|
|
|
Parse.tags;
|
|
|
|
\<close>
|
|
|
|
ML\<open>
|
|
|
|
Outer_Syntax.print_commands @{theory};
|
|
|
|
Outer_Syntax.parse_spans;
|
|
|
|
Parse.!!!;
|
|
|
|
|
|
|
|
\<close>
|
2019-05-28 08:18:40 +00:00
|
|
|
*)
|
2020-02-20 12:30:51 +00:00
|
|
|
|
2018-04-28 16:41:34 +00:00
|
|
|
end
|