HOL-OCL
/
su4sml
1
0
Fork 0
Code Issues Pull Requests Releases Activity

git-svn-id: https://projects.brucker.ch/su4sml/svn/infsec-import/trunk/src/su4sml@6030 3260e6d1-4efc-4170-b0a7-36055960796d

This commit is contained in:
Jürgen Doser 2007-02-05 17:44:37 +00:00
parent 588d1c50a9
commit 83fd9e3a27
11 changed files with 298 additions and 287 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
src/rep_core.sml
View File

@ -1,7 +1,7 @@
(*****************************************************************************
* su4sml - a SecureUML repository for SML
*
* mdr_core.sig - generic meta data repository import signature for su4sml
* rep_core.sml - core repository datastructures for su4sml
* Copyright (C) 2001-2005 Achim D. Brucker <brucker@inf.ethz.ch>
* Burkhart Wolff <bwolff@inf.ethz.ch>
*
@ -410,9 +410,9 @@ fun string_of_path (path:Rep_OclType.Path) = case path of
fun update_thyname tname (Class{name,parent,attributes,operations,invariant,
stereotypes,interfaces,associationends,activity_graphs,...})
= Class{name=name,parent=parent,attributes=attributes,operations=operations,
associationends=associationends,invariant=invariant,stereotypes=stereotypes,
interfaces=interfaces,thyname=(SOME tname),activity_graphs=activity_graphs }
= Class{name=name,parent=parent,attributes=attributes,operations=operations,
associationends=associationends,invariant=invariant,stereotypes=stereotypes,
interfaces=interfaces,thyname=(SOME tname),activity_graphs=activity_graphs }
| update_thyname tname (Interface{name,parents,operations,stereotypes,invariant,...})
= Interface{name=name,parents=parents,operations=operations,stereotypes=stereotypes,
invariant=invariant,thyname=(SOME tname)}
@ -426,78 +426,88 @@ fun update_thyname tname (Class{name,parent,attributes,operations,invariant,
= Primitive{name=name,parent=parent,operations=operations,
associationends=associationends,invariant=invariant,
stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)}
fun type_of (Class{name,...}) = name
| type_of (Interface{name,...}) = name
| type_of (Enumeration{name,...}) = name
| type_of (Primitive{name,...}) = name
| type_of (Primitive{name,...}) = name
| type_of (Template{classifier,...}) = type_of classifier
fun name_of (Class{name,...}) = path_of_OclType name
| name_of (Interface{name,...}) = path_of_OclType name
| name_of (Enumeration{name,...}) = path_of_OclType name
| name_of (Primitive{name,...}) = path_of_OclType name
| name_of _ = error "no name represenation for this classifier"
| name_of (Primitive{name,...}) = path_of_OclType name
| name_of _ = error "in Rep.name_of: Classifier has no name represenation"
fun short_name_of C = case (name_of C) of
[] => error "empty type in short name"
[] => error "in Rep.short_name_of: empty type"
| p => (hd o rev) p
fun stereotypes_of (Class{stereotypes,...}) = stereotypes
| stereotypes_of (Interface{stereotypes,...}) = stereotypes
| stereotypes_of (Enumeration{stereotypes,...}) = stereotypes
| stereotypes_of (Primitive{stereotypes,...}) = stereotypes
| stereotypes_of (Template _) = error "in Rep.stereotypes_of: \
\unsupported argument type Template"
fun package_of (Class{name,...}) = if (length (path_of_OclType name)) > 1
then take (((length (path_of_OclType name)) -1),(path_of_OclType name))
then take (((length (path_of_OclType name)) -1),
(path_of_OclType name))
else []
| package_of (Interface{name,...}) = if (length (path_of_OclType name)) > 1
then take (((length (path_of_OclType name)) -1),(path_of_OclType name))
then take (((length (path_of_OclType name)) -1),
(path_of_OclType name))
else []
| package_of (Enumeration{name,...}) = if (length (path_of_OclType name)) > 1
then take (((length (path_of_OclType name)) -1),(path_of_OclType name))
then take (((length (path_of_OclType name)) -1),
(path_of_OclType name))
else []
| package_of (Primitive{name,...}) = if (length (path_of_OclType name)) > 1
then take (((length (path_of_OclType name)) -1),(path_of_OclType name))
then take (((length (path_of_OclType name)) -1),
(path_of_OclType name))
else []
| package_of (Template{classifier,...}) = package_of classifier
fun parent_name_of (C as Class{parent,...}) =
(case parent of NONE => name_of OclAnyC
|SOME p => path_of_OclType p )
| parent_name_of (Interface{...}) =
error "parent_name_of <Interface> not supported"
| SOME p => path_of_OclType p )
| parent_name_of (Interface{...}) = error "in Rep.parent_name_of: \
\unsupported argument type Interface"
| parent_name_of (E as Enumeration{parent,...}) =
(case parent of NONE => error ("Enumeration "^((string_of_path o name_of) E)
(case parent of NONE => error ("in Rep.parent_name_of: Enumeration "^
((string_of_path o name_of) E)
^" has no parent")
| SOME p => path_of_OclType p )
| parent_name_of (D as Primitive{parent,...}) =
(case parent of NONE => name_of OclAnyC
(* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *)
(* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *)
| SOME p => path_of_OclType p )
| parent_name_of (Template _) = error "in Rep.parent_name_of: \
\unsupported argument type Template"
fun short_parent_name_of C = case (parent_name_of C) of
[] => error "empty type in short parent name"
| p => (hd o rev) p
[] => error "in Rep.short_parent_name_of: empty type"
| p => (hd o rev) p
fun parent_package_of (Class{parent,...}) =
(case parent of NONE => package_of OclAnyC
| SOME q => let val p = path_of_OclType q in
if (length p) > 1
then (take (((length p) -1),p))
else []
end)
if (length p) > 1
then (take (((length p) -1),p))
else []
end)
| parent_package_of (Interface{...}) =
error "parent_package_of <Interface> not supported"
| parent_package_of (Enumeration{parent,...}) =
(case parent of NONE => error "Enumeration has no parent"
error "in Rep.parent_package_of: unsupported argument type Interface"
| parent_package_of (E as Enumeration{parent,...}) =
(case parent of NONE => error ("in Rep.parent_package_of: Enumeration "^
(string_of_path o name_of) E^
" has no parent")
| SOME q => let val p = path_of_OclType q in
if (length p) > 1
then (take (((length p) -1),p))
@ -511,29 +521,31 @@ fun parent_package_of (Class{parent,...}) =
then (take (((length p) -1),p))
else []
end)
| parent_package_of (Template{...}) =
error "in Rep.parent_package_of: unsupported argument type Template"
fun attributes_of (Class{attributes,...}) = attributes
| attributes_of (Interface{...}) =
error "attributes_of <Interface> not supported"
error "in Rep.attributes_of: argument is Interface"
| attributes_of (Enumeration{...}) =
error "attributes_of <Enumeration> not supported"
error "in Rep.attributes_of: argument is Enumeration"
| attributes_of (Primitive{...}) = []
(* error "attributes_of <Primitive> not supported" *)
| attributes_of (Template{parameter,classifier}) = attributes_of classifier
fun operations_of (Class{operations,...}) = operations
| operations_of (Interface{...}) =
error "operations_of <Interface> not supported"
| operations_of (Enumeration{...}) =
error "operations_of <Enumeration> not supported"
| operations_of (Primitive{operations,...}) = operations
fun operations_of (Class{operations,...}) = operations
| operations_of (Interface{operations,...}) = operations
| operations_of (Enumeration{operations,...}) = operations
| operations_of (Primitive{operations,...}) = operations
| operations_of (Template{parameter,classifier}) = operations_of classifier
fun p_invariant_of (Class{invariant,...}) = invariant
| p_invariant_of (Interface{invariant,...}) = invariant
| p_invariant_of (Enumeration{invariant,...}) = invariant
| p_invariant_of (Primitive{invariant,...}) = invariant
| p_invariant_of (Primitive{invariant,...}) = invariant
| p_invariant_of (Template _) = error "in Rep.p_invariant_of: \
\unsupported argument type Template"
fun invariant_of C = case p_invariant_of C of
[] => [(NONE, Rep_OclTerm.Literal ("true",Rep_OclType.Boolean))]
@ -583,7 +595,9 @@ fun thy_name_of (C as Class{thyname,...}) =
(case thyname of SOME tname => tname
| NONE => error ("Primitive "^((string_of_path o name_of) P)^
" has no thyname"))
| thy_name_of (Template _) = error "in Rep.thy_name_of: \
\unsupported argument type Template"

10
src/rep_ocl.sml
View File

@ -183,12 +183,10 @@ datatype OclTerm =
* OclTerm * OclType (* source *)
* OclTerm * OclType (* iterator-body *)
* OclType (* result type *)
and CollectionPart = CollectionItem of OclTerm * OclType
| CollectionRange of OclTerm (* first *)
* OclTerm (* last *)
* OclType
and CollectionPart = CollectionItem of OclTerm * OclType
| CollectionRange of OclTerm (* first *)
* OclTerm (* last *)
* OclType
end

24
src/rep_parser.sml
View File

@ -29,11 +29,9 @@ structure RepParser :
val readFile : string -> Rep.Classifier list
val test: (string * string list) -> OS.Process.status
(* generic exception if something is wrong *)
exception IllFormed of string
end =
struct
open library
exception IllFormed of string
open Xmi_IDTable
@ -162,7 +160,7 @@ fun transform_expression t (XMI.LiteralExp {symbol,expression_type}) =
find_classifier_type t expression_type
)
end
| transform_expression t _ = raise Fail "unsupported OCL expression type"
| transform_expression t _ = error "unsupported OCL expression type"
and transform_collection_part t (XMI.CollectionItem {item,expression_type}) =
Rep_OclTerm.CollectionItem (transform_expression t item,
find_classifier_type t expression_type)
@ -175,12 +173,12 @@ and transform_collection_part t (XMI.CollectionItem {item,expression_type}) =
fun transform_constraint t ({xmiid,name,body,...}:XMI.Constraint) =
let val n_name = case name of
(SOME s) => if (s = "") then NONE else (SOME(s))
|NONE => NONE
| NONE => NONE
in
(n_name,transform_expression t body)
handle NotYetImplemented => (print "Warning: in RepParser.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr))
| IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| XmiParser.IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
handle ex => (print ("Warning: in RepParser.transform_constraint: \
\Could not parse Constraint: "^General.exnMessage ex^"\n");
(NONE, triv_expr))
end
fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint) =
@ -193,9 +191,9 @@ fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint
equal,[(body,body_type)],
Rep_OclType.Boolean))
end
handle NotYetImplemented => (print "Warning: in RepParser.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr))
| IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
| XmiParser.IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr))
handle ex => (print ("Warning: in RepParser.transform_bodyconstraint: \
\Could not parse Constraint: "^General.exnMessage ex^"\n");
(NONE, triv_expr))
fun transform_parameter t {xmiid,name,kind,type_id} =
(name, find_classifier_type t type_id)
@ -287,7 +285,9 @@ fun transform_state t (XMI.CompositeState {xmiid,outgoing,incoming,subvertex,
outgoing = outgoing,
incoming = incoming,
kind = kind }
| transform_state t _ = raise Fail ("in transform_state: unsupported StateVertex type (Subactivity states, object flow states and sync states are not supported).")
| transform_state t _ = error ("in transform_state: unsupported StateVertex type \
\(Subactivity states, object flow states and \
\sync states are not supported).")
(* a primitive hack: we take the body of the guard g as the name of an *)
(* operation to be called in order to check whether the guard is true *)
fun transform_guard t (XMI.mk_Guard g) =
@ -431,7 +431,7 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
thyname = NONE
}
end
| transform_classifier t (_) = raise Fail "Not supported Classifier type found."
| transform_classifier t (_) = error "Not supported Classifier type found."
(** recursively transform all classes in the package. *)

1
src/xmi_core.sml
View File

@ -319,7 +319,6 @@ datatype Classifier = Primitive of Primitive
| OrderedSet of OrderedSet
| Void of Void
exception IllFormed of string
fun classifier_stereotype_of (Class{stereotype,...}) = stereotype
| classifier_stereotype_of (AssociationClass{stereotype,...}) = stereotype

55
src/xmi_idtable.sml
View File

@ -26,7 +26,6 @@
structure Xmi_IDTable =
struct
open library
exception IllFormed of string
datatype HashTableEntry = Package of Rep_OclType.Path
| Type of (Rep_OclType.OclType *
@ -51,73 +50,73 @@ fun find_tagdefinition t xmiid =
(case valOf (HashTable.find t xmiid)
of TagDefinition x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected TagDefinition "^xmiid^" in table")
handle Option => error ("expected TagDefinition "^xmiid^" in table")
fun find_state t xmiid =
(case valOf (HashTable.find t xmiid)
of State x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected State "^xmiid^" in table")
handle Option => error ("expected State "^xmiid^" in table")
fun find_event t xmiid =
(case valOf (HashTable.find t xmiid)
of Event x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected Event "^xmiid^" in table")
handle Option => error ("expected Event "^xmiid^" in table")
fun find_transition t xmiid =
(case valOf (HashTable.find t xmiid)
of Transition x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected Transition "^xmiid^" in table")
handle Option => error ("expected Transition "^xmiid^" in table")
fun find_dependency t xmiid =
(case valOf (HashTable.find t xmiid)
of Dependency x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected Dependency "^xmiid^" in table")
handle Option => error ("expected Dependency "^xmiid^" in table")
fun find_generalization t xmiid =
(case valOf (HashTable.find t xmiid)
of Generalization x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected Generalization "^xmiid^" in table")
handle Option => error ("expected Generalization "^xmiid^" in table")
fun find_stereotype t xmiid =
(case valOf (HashTable.find t xmiid)
of Stereotype x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected Stereotype "^xmiid^" in table")
handle Option => error ("expected Stereotype "^xmiid^" in table")
fun find_attribute t xmiid =
(case valOf (HashTable.find t xmiid)
of Attribute x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected Attribute "^xmiid^" in table")
handle Option => error ("expected Attribute "^xmiid^" in table")
fun find_operation t xmiid =
(case valOf (HashTable.find t xmiid)
of Operation x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected Operation "^xmiid^" in table")
handle Option => error ("expected Operation "^xmiid^" in table")
fun find_type t xmiid =
(case valOf (HashTable.find t xmiid)
of Type x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected Type "^xmiid^" in table (find_type)")
handle Option => error ("expected Type "^xmiid^" in table (find_type)")
fun find_aends t xmiid =
(case valOf (HashTable.find t xmiid)
of (Type (c,xs,_,_)) => xs
| _ => raise Option)
handle Option => raise IllFormed ("expected Type "^xmiid^" in table (find_aends)")
handle Option => error ("expected Type "^xmiid^" in table (find_aends)")
fun find_variable_dec t xmiid =
(case valOf (HashTable.find t xmiid)
of Variable x => x
| _ => raise Option)
handle Option => raise IllFormed ("expected VariableDeclaration "^xmiid^" in table")
handle Option => error ("expected VariableDeclaration "^xmiid^" in table")
fun find_parent t xmiid = #2 (find_generalization t xmiid)
@ -125,22 +124,22 @@ fun find_package t xmiid =
(case valOf (HashTable.find t xmiid)
of Package path => path
| _ => raise Option)
handle Option => raise IllFormed ("expected Path "^xmiid^" in table")
handle Option => error ("expected Path "^xmiid^" in table")
fun path_of_classifier (Rep_OclType.Classifier x) = x
| path_of_classifier _ = raise IllFormed ("path_of_classifier called on non-Classifier argument")
| path_of_classifier _ = error ("path_of_classifier called on non-Classifier argument")
fun find_constraint t xmiid =
(case valOf (HashTable.find t xmiid)
of Constraint c => c
| _ => raise Option)
handle Option => raise IllFormed ("expected Constraint "^xmiid^" in table")
handle Option => error ("expected Constraint "^xmiid^" in table")
fun find_associationend t xmiid =
(case valOf (HashTable.find t xmiid)
of AssociationEnd ae => ae
| _ => raise Option)
handle Option => raise IllFormed ("expected AssociationEnd "^xmiid^" in table")
handle Option => error ("expected AssociationEnd "^xmiid^" in table")
fun filter_exists t cs =
@ -178,21 +177,21 @@ fun find_classifier t xmiid =
(case valOf (HashTable.find t xmiid)
of Type (_,_,c,_) => c
| _ => raise Option)
handle Option => raise IllFormed ("expected Classifier "^xmiid^" in table (in find_classifer)")
handle Option => error ("expected Classifier "^xmiid^" in table (in find_classifer)")
fun find_classifierInState_classifier t cis_id =
(case valOf (HashTable.find t cis_id)
of ClassifierInState c => find_classifier t c
| Type (_,_,c,_) => c
| _ => raise Option)
handle Option => raise IllFormed ("expected ClassifierInState "
handle Option => error ("expected ClassifierInState "
^cis_id^" in table")
fun find_activity_graph_of t xmiid =
(case valOf (HashTable.find t xmiid)
of Type (_,_,_,ag) => ag
| _ => raise Option)
handle Option => raise IllFormed ("expected Classifier "^xmiid^" in table (in find_activity_graph_of)")
handle Option => error ("expected Classifier "^xmiid^" in table (in find_activity_graph_of)")
fun find_classifier_type t xmiid
@ -212,9 +211,9 @@ fun find_classifier_type t xmiid
| Rep_OclType.Set (Rep_OclType.Classifier [x]) => Rep_OclType.Set (find_classifier_type t x)
| Rep_OclType.Bag (Rep_OclType.Classifier [x]) => Rep_OclType.Bag (find_classifier_type t x)
| Rep_OclType.OrderedSet (Rep_OclType.Classifier [x]) => Rep_OclType.OrderedSet (find_classifier_type t x)
| _ => raise IllFormed ("unexpected Classifier-Type "^xmiid^" in table")
| _ => error ("unexpected Classifier-Type "^xmiid^" in table")
end
handle Option => raise IllFormed ("expected Classifier "^xmiid^" in table (in find_classifier_type)")
handle Option => error ("expected Classifier "^xmiid^" in table (in find_classifier_type)")
fun insert_constraint table (c:XMI.Constraint) =
@ -262,7 +261,7 @@ fun insert_activity_graph table (XMI.mk_ActivityGraph ag) =
table (context, Type (c,xs,aes,
XMI.mk_ActivityGraph ag::ags))
| _ => raise Option)
handle Option => raise IllFormed ("expected Type "^context^" in table (insert_activity_graph)");
handle Option => error ("expected Type "^context^" in table (insert_activity_graph)");
List.app (insert_transition table) (#transitions ag);
insert_state table (#top ag)
end
@ -296,7 +295,7 @@ fun insert_classifier table package_prefix class =
else if String.isPrefix "Set(" name then Rep_OclType.Set (Rep_OclType.Classifier [XMI.classifier_elementtype_of class])
else if String.isPrefix "Bag(" name then Rep_OclType.Bag (Rep_OclType.Classifier [XMI.classifier_elementtype_of class])
else if String.isPrefix "OrderedSet(" name then Rep_OclType.OrderedSet (Rep_OclType.Classifier [XMI.classifier_elementtype_of class])
else raise IllFormed ("didn't recognize ocltype "^name)
else error ("didn't recognize ocltype "^name)
else Rep_OclType.Classifier path
(* This function is called before the associations are handled, *)
(* so we do not have to take care of them now... *)
@ -374,8 +373,8 @@ fun class_taggedvalues_of table (XMI.Class c) =
| class_taggedvalues_of table (XMI.AssociationClass c) =
map (fn x => (find_tagdefinition table (#tag_type x),#dataValue x))
(#taggedValue c)
| class_taggedvalues_of table _ = raise IllFormed "in class_taggedvalues_of: \
\argument doesn't support tagged values"
| class_taggedvalues_of table _ = error "in class_taggedvalues_of: \
\argument doesn't support tagged values"
(* returns the value of the given tag *)
@ -385,8 +384,8 @@ fun class_taggedvalue_of table tag (XMI.Class c) =
| class_taggedvalue_of table tag (XMI.AssociationClass c) =
Option.map #2 ((List.find (fn (x,y) => x=tag))
(class_taggedvalues_of table (XMI.AssociationClass c)))
| class_taggedvalue_of table tag _ = raise IllFormed "in class_taggedvalues_of: \
\argument doesn't support tagged values"
| class_taggedvalue_of table tag _ = error "in class_taggedvalues_of: \
\argument doesn't support tagged values"
(* returns a list of tag-value pairs *)

92
src/xmi_ocl.sml
View File

@ -32,54 +32,54 @@
structure XMI_OCL =
struct
(* FIX: LiteralExp should probably be renamed to PrimitiveLiteralExp *)
(* FIX: there should be also EnumLiteralExp and TupleLiteralExp *)
datatype OCLExpression = LiteralExp of { symbol : string,
expression_type : string }
| CollectionLiteralExp of { parts: CollectionLiteralPart list,
expression_type : string}
| IfExp of { condition : OCLExpression,
thenExpression : OCLExpression,
elseExpression : OCLExpression,
expression_type : string }
| AssociationEndCallExp of { source : OCLExpression,
referredAssociationEnd : string,
expression_type : string }
| AssociationClassCallExp of { source : OCLExpression,
referredAssociationClass : string,
expression_type : string }
| AttributeCallExp of { source : OCLExpression,
referredAttribute : string,
expression_type : string }
| OperationCallExp of { source : OCLExpression,
arguments : OCLExpression list,
referredOperation : string,
expression_type : string }
| OperationWithTypeArgExp of { source :OCLExpression,
name : string,
typeArgument: string,
expression_type: string}
| VariableExp of { referredVariable: string,
expression_type : string }
| LetExp of { variable : VariableDeclaration,
inExpression : OCLExpression,
expression_type : string }
| IterateExp of { iterators : VariableDeclaration list,
result : VariableDeclaration ,
body : OCLExpression,
source : OCLExpression,
expression_type : string}
| IteratorExp of { name : string,
iterators : VariableDeclaration list,
body : OCLExpression,
source : OCLExpression,
expression_type : string}
and CollectionLiteralPart = CollectionItem of { item : OCLExpression,
expression_type: string }
| CollectionRange of { first: OCLExpression,
last: OCLExpression,
expression_type: string}
datatype OCLExpression = LiteralExp of { symbol : string,
expression_type : string }
| CollectionLiteralExp of { parts: CollectionLiteralPart list,
expression_type : string}
| IfExp of { condition : OCLExpression,
thenExpression : OCLExpression,
elseExpression : OCLExpression,
expression_type : string }
| AssociationEndCallExp of { source : OCLExpression,
referredAssociationEnd : string,
expression_type : string }
| AssociationClassCallExp of { source : OCLExpression,
referredAssociationClass : string,
expression_type : string }
| AttributeCallExp of { source : OCLExpression,
referredAttribute : string,
expression_type : string }
| OperationCallExp of { source : OCLExpression,
arguments : OCLExpression list,
referredOperation : string,
expression_type : string }
| OperationWithTypeArgExp of { source :OCLExpression,
name : string,
typeArgument: string,
expression_type: string}
| VariableExp of { referredVariable: string,
expression_type : string }
| LetExp of { variable : VariableDeclaration,
inExpression : OCLExpression,
expression_type : string }
| IterateExp of { iterators : VariableDeclaration list,
result : VariableDeclaration ,
body : OCLExpression,
source : OCLExpression,
expression_type : string}
| IteratorExp of { name : string,
iterators : VariableDeclaration list,
body : OCLExpression,
source : OCLExpression,
expression_type : string}
and CollectionLiteralPart = CollectionItem of { item : OCLExpression,
expression_type: string }
| CollectionRange of { first: OCLExpression,
last: OCLExpression,
expression_type: string}
(* from OCL 2.0 Expressions: -------------------------------------------------
* A VariableDeclaration declares a variable name and binds it to a type. The
* variable can be used in expressions where the variable is in scope. This

220
src/xmi_parser.sml
View File

@ -24,8 +24,6 @@
structure XmiParser : sig
val readFile: string -> XMI.XmiContent
(* generic exception if something is wrong *)
exception IllFormed of string
end =
struct
open library
@ -42,9 +40,9 @@ fun bool_value_of string atts =
let val att = value_of string atts
in
(valOf o Bool.fromString) att
handle Option => raise IllFormed ("boolean attribute \""^string^
"\" has non-boolean value \""^att^
"\" (xmi.id = "^(value_of "xmi.id" atts)^")")
handle Option => error ("boolean attribute \""^string^
"\" has non-boolean value \""^att^
"\" (xmi.id = "^(value_of "xmi.id" atts)^")")
end
@ -52,9 +50,9 @@ fun int_value_of string atts =
let val att = value_of string atts
in
(valOf o Int.fromString) att
handle Option => raise IllFormed ("integer attribute \""^string^
"\" has non-integer value \""^att^
"\" (xmi.id = "^(value_of "xmi.id" atts)^")")
handle Option => error ("integer attribute \""^string^
"\" has non-integer value \""^att^
"\" (xmi.id = "^(value_of "xmi.id" atts)^")")
end
val language = value_of "language"
@ -66,10 +64,10 @@ fun xmiidref t = t |> attributes |> value_of "xmi.idref"
fun optional_name_or_empty atts = atts |> optional_value_of "name"
|> get_optional_or_default ""
fun unknown_attribute_value atts att s = raise IllFormed ("attribute \""^att^
"\" has unknown value \""^s^
"\" (xmi.id = "^(atts |> xmiid)^")")
fun unknown_attribute_value atts att s = error ("attribute \""^att^
"\" has unknown value \""^s^
"\" (xmi.id = "^(atts |> xmiid)^")")
fun visibility atts =
let val att = optional_value_of "visibility" atts
in
@ -80,7 +78,7 @@ fun visibility atts =
| NONE => XMI.public
| SOME string => unknown_attribute_value atts "visibility" string
end
fun target_scope atts =
let val att = optional_value_of "targetScope" atts
@ -112,23 +110,23 @@ fun ordering atts =
fun aggregation atts =
let val att = optional_value_of "aggregation" atts
in
case att of SOME "none" => XMI.NoAggregation
| SOME "aggregate" => XMI.Aggregate
| SOME "composite" => XMI.Composite
| NONE => XMI.NoAggregation
| SOME x => unknown_attribute_value atts "aggregation" x
case att of SOME "none" => XMI.NoAggregation
| SOME "aggregate" => XMI.Aggregate
| SOME "composite" => XMI.Composite
| NONE => XMI.NoAggregation
| SOME x => unknown_attribute_value atts "aggregation" x
end
fun changeability atts =
let val att = optional_value_of "changeability" atts in
case att of
SOME "changeable" => XMI.Changeable
| SOME "frozen" => XMI.Frozen
| SOME "addonly" => XMI.AddOnly
| NONE => XMI.Changeable
| SOME x => unknown_attribute_value atts "changeability" x
case att of
SOME "changeable" => XMI.Changeable
| SOME "frozen" => XMI.Frozen
| SOME "addonly" => XMI.AddOnly
| NONE => XMI.Changeable
| SOME x => unknown_attribute_value atts "changeability" x
end
fun kind atts =
let val att = atts |> optional_value_of "kind"
|> get_optional_or_default "inout"
@ -182,7 +180,7 @@ fun mkAssociationEnd tree =
|> xmiidref
}
end
(*handle IllFormed msg => raise IllFormed ("in mkAssociationEnd: "^msg)*)
(*handle IllFormed msg => error ("in mkAssociationEnd: "^msg)*)
(* FIX: this is a hack to handle AssociationClasses like Associations. *)
@ -198,7 +196,7 @@ fun mkAssociationFromAssociationClass tree =
|> map mkAssociationEnd
}
end
(*handle IllFormed msg => raise IllFormed ("in mkAssociation: "^msg)*)
(*handle IllFormed msg => error ("in mkAssociation: "^msg)*)
fun mkAssociation tree =
@ -210,8 +208,8 @@ fun mkAssociation tree =
|> map mkAssociationEnd
}
end
(* handle IllFormed msg => raise IllFormed ("in mkAssociation: "^msg)*)
(* handle IllFormed msg => error ("in mkAssociation: "^msg)*)
(* find the xmi.idref attribute of an element pointed to by name *)
fun xmiidref_to name tree = tree |> get_one name
|> xmiidref
@ -262,7 +260,7 @@ fun mkOCLExpression (tree as Node(("UML15OCL.Expressions.BooleanLiteralExp",atts
|> mkOCLExpression)
(* This hack is necessary to support TYPE::allInstances() as parsed *)
(* by dresden-ocl. *)
handle IllFormed msg =>
handle ex =>
XMI.LiteralExp
{ symbol = "",
expression_type = tree |> get_one "OCL.Expressions.FeatureCallExp.srcType"
@ -298,7 +296,7 @@ fun mkOCLExpression (tree as Node(("UML15OCL.Expressions.BooleanLiteralExp",atts
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.AssociationClassCallExp",atts),_))
= raise IllFormed ("AssociationClassCallExp is not yet implemented"^some_id tree)
= error ("AssociationClassCallExp is not yet implemented"^some_id tree)
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.VariableExp",atts),_))
= XMI.VariableExp
{ referredVariable = tree |> xmiidref_to
@ -358,7 +356,7 @@ fun mkOCLExpression (tree as Node(("UML15OCL.Expressions.BooleanLiteralExp",atts
expression_type = tree |> expression_type
}
| mkOCLExpression tree =
raise IllFormed ("unknown OCLExpression type \""^(tagname tree)^"\""^some_id tree^".")
error ("unknown OCLExpression type \""^(tagname tree)^"\""^some_id tree^".")
and mkVariableDec vtree =
let val atts = vtree |> assert "UML15OCL.Expressions.VariableDeclaration"
|> attributes
@ -371,16 +369,16 @@ and mkVariableDec vtree =
|> xmiidref
}
end
(* handle IllFormed msg => raise IllFormed ("in mkVariableDec: "^msg)*)
(* handle IllFormed msg => error ("in mkVariableDec: "^msg)*)
fun getAssociations t = (map mkAssociation (filter "UML:Association" t))@
(map mkAssociationFromAssociationClass
(filter "UML:AssociationClass" t))
(*handle _ => raise IllFormed ("Error in getAssociations") *)
(*handle _ => error ("Error in getAssociations") *)
fun filterConstraints trees = List.filter (fn x => (tagname o (get_one "UML:Constraint.body")) x
= "UML15OCL.Expressions.ExpressionInOcl")
(filter "UML:Constraint" trees)
@ -392,7 +390,7 @@ val filterPackages = fn trees => append (filter "UML:Package" trees)
val filterStateMachines = filter "UML:StateMachine"
val filterActivityGraphs= filter "UML:ActivityGraph"
val filterEvents = fn x => append (filter "UML:CallEvent" x)
(filter "UML:SignalEvent" x)(* add SignalEvents? *)
(filter "UML:SignalEvent" x)(* add SignalEvents? *)
(* there may be other kinds of dependencies, but we do not parse them atm *)
val filterDependencies = filter "UML:Abstraction"
@ -402,18 +400,18 @@ val filterTagDefinitions = filter "UML:TagDefinition"
(* FIX: other classifiers *)
fun filterClassifiers trees =
List.filter (fn x => let val elem = tagname x in
elem = "UML:Class" orelse
elem = "UML:Primitive" orelse
elem = "UML:DataType" orelse
elem = "UML:Interface" orelse
elem = "UML:Enumeration" orelse
elem = "UML15OCL.Types.SequenceType" orelse
elem = "UML15OCL.Types.BagType" orelse
elem = "UML15OCL.Types.SetType" orelse
elem = "UML15OCL.Types.CollectionType" orelse
elem = "UML15OCL.Types.VoidType" orelse
elem = "UML:AssociationClass"
end) trees
elem = "UML:Class" orelse
elem = "UML:Primitive" orelse
elem = "UML:DataType" orelse
elem = "UML:Interface" orelse
elem = "UML:Enumeration" orelse
elem = "UML15OCL.Types.SequenceType" orelse
elem = "UML15OCL.Types.BagType" orelse
elem = "UML15OCL.Types.SetType" orelse
elem = "UML15OCL.Types.CollectionType" orelse
elem = "UML15OCL.Types.VoidType" orelse
elem = "UML:AssociationClass"
end) trees
fun mkDependency tree =
let val atts = tree |> assert "UML:Abstraction" |> attributes
@ -427,7 +425,7 @@ fun mkDependency tree =
|> xmiidref
}
end
(*handle IllFormed msg => raise IllFormed ("in mkDependency: "^msg) *)
(*handle IllFormed msg => error ("in mkDependency: "^msg) *)
fun mkConstraint tree =
let val atts = tree |> assert "UML:Constraint" |> attributes
@ -442,7 +440,7 @@ fun mkConstraint tree =
|> mkOCLExpression
}
end
(*handle IllFormed msg => raise IllFormed ("in mkConstraint: "^msg)*)
(*handle IllFormed msg => error ("in mkConstraint: "^msg)*)
fun mkParameter tree =
@ -455,7 +453,7 @@ fun mkParameter tree =
|> xmiidref
}
end
(*handle IllFormed msg => raise IllFormed ("in mkParameter: "^msg)*)
(*handle IllFormed msg => error ("in mkParameter: "^msg)*)
fun mkOperation tree =
let val atts = tree |> assert "UML:Operation" |> attributes
@ -466,12 +464,12 @@ fun mkOperation tree =
isQuery = atts |> bool_value_of "isQuery",
ownerScope = atts |> owner_scope,
parameter = tree |> get "UML:BehavioralFeature.parameter"
|> map mkParameter,
|> map mkParameter,
constraints = tree |> get_maybe "UML:ModelElement.constraint"
|> map xmiidref
}
end
(*handle IllFormed msg => raise IllFormed ("in mkOperation: "^msg)*)
(*handle IllFormed msg => error ("in mkOperation: "^msg)*)
fun mkTaggedValue tree =
@ -487,7 +485,7 @@ fun mkTaggedValue tree =
|> xmiidref
}
end
(*handle IllFormed msg => raise IllFormed ("in mkTaggedValue: "^msg)*)
(*handle IllFormed msg => error ("in mkTaggedValue: "^msg)*)
fun mkAttribute tree =
let val atts = tree |> assert "UML:Attribute" |> attributes
@ -514,7 +512,7 @@ fun mkAttribute tree =
|> map mkTaggedValue
}
end
(*handle IllFormed msg => raise IllFormed ("in mkAttribute: "^msg)*)
(*handle IllFormed msg => error ("in mkAttribute: "^msg)*)
fun mkTagDefinition tree =
let val atts = tree |> assert "UML:TagDefinition" |> attributes
@ -525,31 +523,31 @@ fun mkTagDefinition tree =
|> mkMultiplicity
}
end
(*handle IllFormed msg => raise IllFormed ("in mkTagDefinition: "^msg)*)
(*handle IllFormed msg => error ("in mkTagDefinition: "^msg)*)
fun mkStereotypeR tree =
let val atts = tree |> assert "UML:Stereotype" |> attributes
in
tree |> xmiidref
end
(*handle IllFormed msg => raise IllFormed ("in mkStereotype: "^msg)*)
(*handle IllFormed msg => error ("in mkStereotype: "^msg)*)
fun mkAction tree =
let val atts = tree |> attributes
val expr = tree |> get_one "UML:Action.script"
val expr_atts = expr |> attributes
in
XMI.mk_Procedure
{ xmiid = atts |> xmiid,
name = atts |> optional_name_or_empty,
isSpecification = atts |> bool_value_of "isSpecification" ,
isAsynchronous = atts |> bool_value_of "isAsynchronous" ,
language = expr_atts |> language,
body = expr_atts |> body ,
expression = "" (* FIXME: is this even useful? *)}
end
(*handle IllFormed msg => raise IllFormed ("in mkAction: "^msg)*)
let val atts = tree |> attributes
val expr = tree |> get_one "UML:Action.script"
val expr_atts = expr |> attributes
in
XMI.mk_Procedure
{ xmiid = atts |> xmiid,
name = atts |> optional_name_or_empty,
isSpecification = atts |> bool_value_of "isSpecification" ,
isAsynchronous = atts |> bool_value_of "isAsynchronous" ,
language = expr_atts |> language,
body = expr_atts |> body ,
expression = "" (* FIXME: is this even useful? *)}
end
(*handle IllFormed msg => error ("in mkAction: "^msg)*)
(* This works for ArgoUML, i.e. 1.4 metamodels... *)
fun mkProcedure tree =
let val elem = tagname tree
@ -562,8 +560,8 @@ fun mkProcedure tree =
elem = "UML:TerminateAction" orelse
elem = "UML:UninterpretedAction"
then mkAction tree
else raise IllFormed ("unknown Action type \""^elem^"\""^(some_id tree)^".")
end
else error ("unknown Action type \""^elem^"\""^(some_id tree)^".")
end
fun mkGuard tree =
let val atts = tree |> assert "UML:Guard"
@ -580,8 +578,8 @@ fun mkGuard tree =
expr is "UML:BooleanExpression"
then expr_atts |> language
else
raise IllFormed ("unknown expression type \""^(tagname expr)^
"\""^some_id expr^"."),
error ("unknown expression type \""^(tagname expr)^
"\""^some_id expr^"."),
body = if expr is "UML:BooleanExpression" then
SOME (expr_atts |> body)
else NONE,
@ -589,7 +587,7 @@ fun mkGuard tree =
then SOME (mkOCLExpression expr)
else NONE}
end
(*handle IllFormed msg => raise IllFormed ("in mkGuard: "^msg)*)
(*handle IllFormed msg => error ("in mkGuard: "^msg)*)
fun mkTransition tree =
@ -602,18 +600,18 @@ fun mkTransition tree =
|> xmiidref,
target = tree |> get_one "UML:Transition.target"
|> xmiidref,
guard = tree |> get_optional "UML:Transition.guard"
guard = tree |> get_optional "UML:Transition.guard"
|> map_optional mkGuard,
trigger = tree |> get_optional "UML:Transition.trigger"
trigger = tree |> get_optional "UML:Transition.trigger"
|> map_optional xmiidref,
effect = tree |> get_optional "UML:Transition.effect"
effect = tree |> get_optional "UML:Transition.effect"
|> map_optional mkProcedure,
taggedValue = tree |> get "UML:ModelElement.taggedValue"
|> map mkTaggedValue
}
end
(*handle IllFormed msg => raise IllFormed ("in mkTransition: "^msg)*)
(*handle IllFormed msg => error ("in mkTransition: "^msg)*)
fun mkState tree =
@ -661,7 +659,7 @@ fun mkState tree =
isConcurrent = atts |> bool_value_of "isConcurrent",
isDynamic = atts |> bool_value_of "isDynamic",
outgoing = outgoing, incoming = incoming,
subvertex = getSubvertex tree,
subvertex = getSubvertex tree,
entry = entry,
exit = exit,
doActivity = do_act,
@ -722,7 +720,7 @@ fun mkState tree =
outgoing = outgoing,incoming = incoming,
taggedValue = tagval}
| s => raise IllFormed ("unknown StateVertex type \""^s^"\""^some_id tree^".")
| s => error ("unknown StateVertex type \""^s^"\""^some_id tree^".")
end
and mkStateMachine tree =
let val atts = tree |> assert "UML:StateMachine" |> attributes
@ -738,7 +736,7 @@ and mkStateMachine tree =
|> map mkTransition
}
end
(*handle IllFormed msg => raise IllFormed ("in mkStateMachine: "^msg)*)
(*handle IllFormed msg => error ("in mkStateMachine: "^msg)*)
fun mkActivityGraph tree =
@ -755,8 +753,8 @@ fun mkActivityGraph tree =
|> map mkTransition,
partition = nil}
end
(*handle IllFormed msg => raise IllFormed ("in mkActivityGraph: "^msg)*)
(*handle IllFormed msg => error ("in mkActivityGraph: "^msg)*)
fun mkClass atts tree =
XMI.Class
{ xmiid = atts |> xmiid,
@ -792,9 +790,9 @@ fun mkClass atts tree =
|> filter "UML:ActivityGraph"
|> map mkActivityGraph
}
(*handle IllFormed msg => raise IllFormed ("Error in mkClass "^(name atts)^
": "^msg)*)
(*handle IllFormed msg => error ("Error in mkClass "^(name atts)^
": "^msg)*)
fun mkAssociationClass atts tree
= XMI.AssociationClass
{ xmiid = atts |> xmiid,
@ -823,7 +821,7 @@ fun mkAssociationClass atts tree
connection = tree |> get_many "UML:Association.connection"
|> map mkAssociationEnd
}
(*handle IllFormed msg => raise IllFormed ("in mkAssociationClass: "^msg)*)
(*handle IllFormed msg => error ("in mkAssociationClass: "^msg)*)
fun mkPrimitive atts tree
@ -838,7 +836,7 @@ fun mkPrimitive atts tree
invariant = tree |> get "UML:ModelElement.constraint"
|> map xmiidref
}
(* handle IllFormed msg => raise IllFormed ("in mkPrimitive: "^msg)*)
(* handle IllFormed msg => error ("in mkPrimitive: "^msg)*)
fun mkInterface atts tree
= XMI.Interface
@ -856,12 +854,12 @@ fun mkInterface atts tree
supplierDependency = tree |> get "UML:ModelElement.supplierDependency"
|> map xmiidref
}
(*handle IllFormed msg => raise IllFormed ("in mkInterface: "^msg)*)
(*handle IllFormed msg => error ("in mkInterface: "^msg)*)
fun mkEnumerationLiteral tree =
tree |> assert "UML:EnumerationLiteral"
|> attributes |> name
(*handle IllFormed msg => raise IllFormed ("in mkOperation: "^msg)*)
(*handle IllFormed msg => error ("in mkOperation: "^msg)*)
fun mkEnumeration atts tree
@ -878,13 +876,13 @@ fun mkEnumeration atts tree
literals = tree |> get "UML:Enumeration.literal"
|> map mkEnumerationLiteral
}
(* handle IllFormed msg => raise IllFormed ("in mkEnumeration: "^msg)*)
(* handle IllFormed msg => error ("in mkEnumeration: "^msg)*)
fun mkVoid atts tree = XMI.Void { xmiid = atts |> xmiid,
name = atts |> name
}
(* handle IllFormed msg => raise IllFormed ("in mkVoid: "^msg)*)
(* handle IllFormed msg => error ("in mkVoid: "^msg)*)
fun mkGenericCollection atts tree =
{ xmiid = atts |> xmiid,
@ -897,9 +895,9 @@ fun mkGenericCollection atts tree =
elementtype = tree |> get_one "OCL.Types.CollectionType.elementType"
|> xmiidref
}
(* handle IllFormed msg => raise IllFormed ("in mkGenericCollection: "^msg) *)
(* handle IllFormed msg => error ("in mkGenericCollection: "^msg) *)
fun mkCollection atts tree = XMI.Collection (mkGenericCollection atts tree)
fun mkSequence atts tree = XMI.Sequence (mkGenericCollection atts tree)
fun mkSet atts tree = XMI.Set (mkGenericCollection atts tree)
@ -917,7 +915,7 @@ fun mkStereotype tree =
stereotypeConstraint = NONE (* FIXME, not supported by ArgoUML 0.22 *)
}
end
(* handle IllFormed msg => raise IllFormed ("in mkStereotype: "^msg)*)
(* handle IllFormed msg => error ("in mkStereotype: "^msg)*)
fun mkClassifier tree =
@ -937,10 +935,10 @@ fun mkClassifier tree =
| "UML15OCL.Types.SetType" => mkSet atts tree
| "UML15OCL.Types.BagType" => mkBag atts tree
| "UML15OCL.Types.OrderedSetType" => mkOrderedSet atts tree
| _ => raise IllFormed ("unknown Classifier type \""^elem^
"\""^some_id tree^".")
| _ => error ("unknown Classifier type \""^elem^
"\""^some_id tree^".")
end
fun mkGeneralization tree =
@ -978,7 +976,7 @@ fun mkEvent tree =
in
case elem of "UML:CallEvent" => mkCallEvent atts tree
| "UML:SignalEvent" => mkSignalEvent atts tree
| _ => raise IllFormed ("unknown Event type \""^elem^"\""^some_id tree^".")
| _ => error ("unknown Event type \""^elem^"\""^some_id tree^".")
end
@ -1016,8 +1014,8 @@ fun mkPackage tree =
events = trees |> filterEvents |> map mkEvent
}
end
else raise IllFormed "no UML:Model or UML:Package found"
else error "no UML:Model or UML:Package found"
fun mkXmiContent tree =
let val trees = node_children (assert "XMI.content" tree)
@ -1042,8 +1040,8 @@ val emptyXmiContent = { packages = nil,
state_machines = nil}
fun findXmiContent tree = valOf (dfs "XMI.content" tree)
handle Option => raise IllFormed "no XMI.content found"
handle Option => error "no XMI.content found"
fun readFile f = (mkXmiContent o findXmiContent o XmlTreeParser.readFile) f
handle ex => (error_msg ("Error during parsing of "^f^": \n\t"^General.exnMessage ex);
raise ex)

11
src/xmi_state_machines.sml
View File

@ -1,7 +1,7 @@
(*****************************************************************************
* su4sml - a SecureUML repository for SML
*
* xmi_umlcore.sig - XMI-UML-Core datatypes for the import interface for su4sml
* xmi_state_machines.sml - XMI-UML-StateMachine datatypes for the import interface for su4sml
* Copyright (C) 2005 Achim D. Brucker <brucker@inf.ethz.ch>
* Jürgen Doser <doserj@inf.ethz.ch>
* Burkhart Wolff
@ -38,7 +38,6 @@ end
structure XMI_StateMachines =
struct
open XMI_ExtensionMechanisms XMI_CommonBehavior
exception IllFormed of string
type StateVertex_Id = string
type Transition_Id = string
@ -160,7 +159,7 @@ datatype StateVertex =
exit : Procedure option,
doActivity : Procedure option,
taggedValue : TaggedValue list,
incoming : Transition_Id list }
incoming : Transition_Id list }
| PseudoState of { xmiid : string,
name : string,
stereotype : Stereotype_Id list,
@ -168,15 +167,15 @@ datatype StateVertex =
kind : PseudoStateVars,
taggedValue : TaggedValue list,
outgoing : Transition_Id list,
incoming : Transition_Id list }
incoming : Transition_Id list }
| SyncState of { xmiid : string,
name : string,
stereotype : Stereotype_Id list,
isSpecification : bool,
outgoing : Transition_Id list,
incoming : Transition_Id list,
incoming : Transition_Id list,
taggedValue : TaggedValue list,
bound : int}
bound : int}
(* | StubState *)
and StateMachine = mk_StateMachine of
{xmiid : string,

44
src/xmltree.sml
View File

@ -22,6 +22,7 @@
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************)
(** datatypes and functions for XML trees. *)
structure XmlTree : sig
type Attribute
type Tag = string * Attribute list
@ -38,11 +39,9 @@ structure XmlTree : sig
val optional_value_of : string -> Attribute list -> string option
val value_of : string -> Attribute list -> string
val has_attribute : string -> Tree -> bool
exception IllFormed of string
end = struct
open library
infix 1 |>
exception IllFormed = Fail
(** A name-value pair. *)
type Attribute = (string * string)
@ -50,33 +49,34 @@ type Attribute = (string * string)
(** Tags consist of element names, and a list of attribute name-value pairs. *)
type Tag = string * Attribute list
(** A Node in an XML tree is either a tag with substrees, or plain text. *)
datatype Tree = Node of Tag * Tree list
| Text of string
val filter_nodes = List.filter (fn Node x => true
| _ => false)
| _ => false)
val filter_text = List.filter (fn Text x => true
| _ => false)
fun text (Text s) = s
| text _ = raise IllFormed "in XmlTree.text: argument is a Node element"
fun attributes (Node ((elem,atts),trees)) = atts
| attributes _ = raise IllFormed "in attributes_of: argument is a Text-Node"
fun children (Node ((elem,atts),trees)) = trees
| children _ = raise IllFormed "in XmlTree.children: argument is a Text-Node"
fun node_children (Node ((elem,atts),trees)) = filter_nodes trees
| node_children _ = raise IllFormed "in XmlTree.node_children: argument is a Text-Node"
fun text_children (Node ((elem,atts),trees)) = filter_text trees
| text_children _ = raise IllFormed "in XmlTree.text_children: argument is a Text-Node"
| _ => false)
fun tagname (Node ((elem,atts),trees)) = elem
| tagname (Text _) = ""
fun text (Text s) = s
| text x = error ("in XmlTree.text: argument is a Node element (<"^tagname x^">).")
fun attributes (Node ((elem,atts),trees)) = atts
| attributes _ = error "in attributes_of: argument is a Text-Node"
fun children (Node ((elem,atts),trees)) = trees
| children _ = error "in XmlTree.children: argument is a Text-Node"
fun node_children (Node ((elem,atts),trees)) = filter_nodes trees
| node_children _ = error "in XmlTree.node_children: argument is a Text-Node"
fun text_children (Node ((elem,atts),trees)) = filter_text trees
| text_children _ = error "in XmlTree.text_children: argument is a Text-Node"
fun optional_value_of string atts = Option.map #2 (List.find (fn (x,_) => x = string) atts)
@ -84,6 +84,6 @@ fun has_attribute string tree = Option.isSome (optional_value_of string (attribu
fun value_of string atts = valOf (optional_value_of string atts)
handle Option => raise IllFormed ("in value_of: did not find attribute "^string)
handle Option => error ("in XmlTree.value_of: argument has no attribute "^string)
end

22
src/xmltree_helper.sml
View File

@ -62,8 +62,7 @@ fun filter_children string tree = filter string (node_children tree)
fun find_some string trees = (List.find (fn x => string = tagname x) trees)
fun find string trees = valOf (List.find (fn x => string = tagname x) trees)
handle Option => raise IllFormed ("in XmlTree.find: no element "
^string)
handle Option => error ("in XmlTree.find: no element "^string)
fun some_id' atts = let val xmiid = atts |> optional_value_of "xmi.id"
@ -83,28 +82,33 @@ fun some_id' atts = let val xmiid = atts |> optional_value_of "xmi.id"
fun some_id tree = some_id' (attributes tree)
fun value_of string atts = XmlTree.value_of string atts
handle IllFormed msg => raise IllFormed (msg^(some_id' atts))
handle ex => error ((General.exnMessage ex)^(some_id' atts))
fun find_child string tree = find string (node_children tree)
handle IllFormed msg => raise IllFormed (msg^" inside node "^
(tagname tree)^(some_id tree)^"\n")
handle ex => error ((General.exnMessage ex)^" inside node "^(tagname tree)^(some_id tree)^"\n")
fun dfs string tree = if tagname tree = string
then SOME tree
else Option.join (List.find Option.isSome (List.map (dfs string) (node_children tree)))
else Option.join (List.find Option.isSome (List.map (dfs string) (node_children tree)))
fun exists string trees = List.exists (fn x => string = tagname x) trees
fun has_child string tree = exists string (node_children tree)
fun follow string trees = node_children (find string trees)
fun followM string trees = if exists string trees
then follow string trees
else nil
fun skip string tree = node_children (find_child string tree)
fun followM string trees = follow string trees handle IllFormed msg => nil
fun skipM string tree = skip string tree handle IllFormed msg => nil
fun skipM string tree = if has_child string tree
then skip string tree
else nil
fun is (tree,string) = string = tagname tree
infix 2 is
fun assert string tree = if tree is string then tree
else raise IllFormed ("expected "^string^" but found "^
else error ("expected "^string^" but found "^
(tagname tree)^(some_id tree)^"\n")
(* navigate to association ends with multiplicity 1..* *)

6
src/xmltree_hooks.sml
View File

@ -25,7 +25,7 @@
structure XmlTreeHooks : Hooks =
struct
open IgnoreHooks XmlTree UniChar HookData
open IgnoreHooks XmlTree UniChar HookData library
type AppData = Dtd.Dtd * Tree list * (Tag * Tree list) list
type AppFinal = Tree
@ -55,7 +55,7 @@ fun hookStartTag ((dtd,content, stack), (_,elem,atts,_,empty)) =
else (dtd,nil,((elemName,attNames),content)::stack)
end
fun hookEndTag ((dtd,_,nil),_) = raise IllFormed "in hookEndTag: illformed XML"
fun hookEndTag ((dtd,_,nil),_) = error "in hookEndTag: illformed XML"
| hookEndTag ((dtd,content,(tag,content')::stack),_) =
(dtd,Node (tag,rev content)::content',stack)
@ -69,7 +69,7 @@ fun hookCharRef ((dtd,content,stack),(_,c,_)) = (* FIX *)
(dtd,content,stack)
fun hookFinish (dtd,[elem],nil) = elem
| hookFinish _ = raise IllFormed "in hookFinish: illformed XML"
| hookFinish _ = error "in hookFinish: illformed XML"
fun print_message (pos,msg) =