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

qualifiers added to parsing 

git-svn-id: https://projects.brucker.ch/su4sml/svn/su4sml/trunk@7182 3260e6d1-4efc-4170-b0a7-36055960796d
This commit is contained in:
Martin Bill 2008-01-27 15:36:57 +00:00
parent 06de357c70
commit 9b4f60df57
12 changed files with 1529 additions and 1413 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

181
su4sml/src/ocl_parser/model_import.sml
View File

@ -125,91 +125,108 @@ fun parseOCL oclFile =
fun removePackages (uml,ocl) packageList =
let
(* billk_tag
* filter package and update associations
* fun filter_package model p = filter (fn cl => not (Rep_Core.package_of cl = p)) model
*)
fun filter_package (all_classifiers,all_associations) p =
let
(* FIXME: correct handling for reflexive assocs + !isNavigable *)
fun valid_assoc {name,aends,aclass} = case aends of
[] => false
| [x] => false
| _ => true
fun update_association cls_name {name,aends,aclass}:Rep_Core.association =
let
val cls_path = Rep_OclType.path_of_OclType cls_name
val modified_aclass = if (cls_path = (valOf aclass))
then
NONE
else
aclass
val modified_aends = filter (fn {aend_type,...} => not (aend_type = cls_name)) aends
in
{name=name,
aends=modified_aends,
aclass=modified_aclass}
end
fun update_associationends ((Rep_Core.Class {name,associations,...}),assocs):Rep_Core.association list =
let
val assocs = map (get_association all_associations) associations
val modified_assocs = map (update_association name) assocs
in
filter valid_assoc modified_assocs
end
| update_associationends ((Rep_Core.AssociationClass{name,associations,association,...}),assocs) =
let
(* update_association also handles the aclass update *)
val assocs = map (get_association all_associations) (association::associations)
val modified_assocs = map (update_association name) assocs
in
filter valid_assoc modified_assocs
end
| update_associationends ((Rep_Core.Primitive{name,associations,...}),assocs) =
let
val assocs = map (get_association all_associations) associations
val modified_assocs = map (update_association name) assocs
in
filter valid_assoc modified_assocs
end
| update_associationends ((Rep_Core.Template{parameter,classifier}),assocs) =
(* FIXME: sound? *)
update_associationends (classifier,assocs)
| update_associationends (_,assocs) =
assocs
(* filter package and update associations
* fun filter_package model p = filter (fn cl => not
* (Rep_Core.package_of cl = p)) model *)
fun filter_package (all_classifiers,all_associations) p =
let
(* FIXME: correct handling for reflexive assocs + !isNavigable *)
fun valid_assoc {name,aends,qualifiers,aclass} =
List.length aends > 1
val (kept_classifiers,removed_cls) = partition (fn cl => not (Rep_Core.package_of cl = p)) all_classifiers
val kept_associations = case removed_cls of
[] => all_associations
| xs => foldl update_associationends all_associations xs
in
(kept_classifiers,kept_associations)
end
fun filter_cl_package cl p = filter (fn cl => not (package_of_context cl = p)) cl
val _ = trace high "### Excluding Packages ###\n"
val uml =
let
fun stringToPath s = (String.tokens (fn s => (s = (#":"))) s)
in
foldr (fn (p,m) => filter_package m (stringToPath p)) uml packageList
end
val ocl =
let
fun stringToPath s = (String.tokens (fn s => (s = (#":"))) s)
in
foldr (fn (p,m) => filter_cl_package m (stringToPath p)) ocl packageList
end
val _ = trace high ("### Finished excluding Packages ("
^(Int.toString(length (#1 uml)))
^ " Classifiers found and "
^(Int.toString(length (#2 uml)))
^ " Associations found and "
^(Int.toString(length ocl))
^" Constraints Found) ###\n\n")
fun update_association cls_name {name,aends,qualifiers,aclass}
:Rep_Core.association =
let
val cls_path = Rep_OclType.path_of_OclType cls_name
val modified_aclass = if (cls_path = (valOf aclass))
then NONE
else aclass
val modified_aends = filter (fn {aend_type,...} =>
not (aend_type = cls_name))
aends
in
{name=name,
aends=modified_aends,
qualifiers=qualifiers (*FIXME?*),
aclass=modified_aclass}
end
fun update_associationends ((Rep_Core.Class {name,associations,
...}),assocs):
Rep_Core.association list =
let
val assocs = map (get_association all_associations)
associations
val modified_assocs = map (update_association name) assocs
in
filter valid_assoc modified_assocs
end
| update_associationends ((Rep_Core.AssociationClass
{name, associations,association,
...}),assocs) =
let
(* update_association also handles the aclass update *)
val assocs = map (get_association all_associations)
(association::associations)
val modified_assocs = map (update_association name) assocs
in
filter valid_assoc modified_assocs
end
| update_associationends ((Rep_Core.Primitive
{name,associations,...}),assocs)=
let
val assocs = map (get_association all_associations)
associations
val modified_assocs = map (update_association name) assocs
in
filter valid_assoc modified_assocs
end
| update_associationends ((Rep_Core.Template
{parameter,classifier}),assocs) =
(* FIXME: sound? *)
update_associationends (classifier,assocs)
| update_associationends (_,assocs) =
assocs
val (kept_classifiers,removed_cls) =
List.partition (fn cl => not (Rep_Core.package_of cl = p))
all_classifiers
val kept_associations =
(case removed_cls of
[] => all_associations
| xs => foldl update_associationends all_associations xs)
in
(kept_classifiers,kept_associations)
end
fun filter_cl_package cl p =
List.filter (fn cl => not (package_of_context cl = p)) cl
val _ = trace high "### Excluding Packages ###\n"
val uml =
let
fun stringToPath s = (String.tokens (fn s => (s = (#":"))) s)
in
foldr (fn (p,m) => filter_package m (stringToPath p))
uml packageList
end
val ocl =
let
fun stringToPath s = (String.tokens (fn s => (s = (#":"))) s)
in
foldr (fn (p,m) => filter_cl_package m (stringToPath p))
ocl packageList
end
val _ = trace high ("### Finished excluding Packages ("
^(Int.toString(length (#1 uml)))
^ " Classifiers found and "
^(Int.toString(length (#2 uml)))
^ " Associations found and "
^(Int.toString(length ocl))
^" Constraints Found) ###\n\n")
in
(uml,ocl)
(uml,ocl)
end
fun removeOclLibrary model =
let
fun filter_template model =

1114
su4sml/src/rep_core.sml
View File

File diff suppressed because it is too large Load Diff

523
su4sml/src/rep_parser.sml
View File

@ -207,62 +207,69 @@ fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint
val body = transform_expression t body
val body_type = result_type
in
(SOME "body",Rep_OclTerm.OperationCall (result, result_type,
equal,[(body,body_type)],
Rep_OclType.Boolean))
(SOME "body",Rep_OclTerm.OperationCall (result, result_type,
equal,[(body,body_type)],
Rep_OclType.Boolean))
end
handle ex => (print ("Warning: in RepParser.transform_bodyconstraint: \
\Could not parse Constraint: "^General.exnMessage ex^"\n"^
\Could not parse Constraint: "^
General.exnMessage ex^"\n"^
"using the trivial constraint 'true' instead");
(NONE, triv_expr))
fun transform_parameter t {xmiid,name,kind,type_id} =
(name, find_classifier_type t type_id
handle _ => (warn ("no type found for parameter '"^name^
"', defaulting to OclVoid");
Rep_OclType.OclVoid)
)
fun transform_operation t {xmiid,name,isQuery,parameter,visibility,
constraints,ownerScope} =
let val result_type = case filter (fn x => #kind x = XMI.Return) parameter
of [] => (warn ("no return type found for operation '"^name^
"', defaulting to OclVoid");
Rep_OclType.OclVoid)
| [x] => (find_classifier_type t (#type_id x)
handle _ => (warn ("return parameter for operation '"^name^
"' has no declared type, defaulting to OclVoid");
Rep_OclType.OclVoid))
| x::y::_ => let val ret_type = find_classifier_type t (#type_id x)
handle _ => (warn ("return parameter for operation '"^name^
"' has no declared type, defaulting to OclVoid");
Rep_OclType.OclVoid)
in
(warn ("operation '"^name^
"' has multiple return parameters. Using only '"^
(Rep_OclType.string_of_OclType ret_type)^"'.");
ret_type)
end
val checked_constraints = filter_exists t constraints
let val result_type = (
case filter (fn x => #kind x = XMI.Return) parameter
of [] => (warn ("no return type found for operation '"^name^
"', defaulting to OclVoid");
Rep_OclType.OclVoid)
| [x] => (find_classifier_type t (#type_id x)
handle _ => (warn ("return parameter for \
\operation '"^name^
"' has no declared type, \
\defaulting to OclVoid");
Rep_OclType.OclVoid))
| x::y::_ =>
let
val ret_type = find_classifier_type t (#type_id x)
handle _ => (warn ("return parameter for operation '"
^name^"' has no declared type, \
\defaulting to OclVoid");
Rep_OclType.OclVoid)
in
(warn ("operation '"^name^
"' has multiple return parameters. Using only '"^
(Rep_OclType.string_of_OclType ret_type)^"'.");
ret_type)
end)
val checked_constraints = filter_exists t constraints
in
{name=name,
arguments = (map (transform_parameter t)
(filter (fn x => #kind x <> XMI.Return) parameter)),
precondition = (map ((transform_constraint t) o (find_constraint t))
(filter_precondition t checked_constraints)),
postcondition = List.concat [map ((transform_constraint t) o
(find_constraint t))
(filter_postcondition t constraints),
map ((transform_bodyconstraint result_type t) o
(find_constraint t))
(filter_bodyconstraint t checked_constraints)],
result = result_type,
body = [],
visibility = visibility,
scope = ownerScope,
isQuery = isQuery (* FIX *)
}
{name=name,
arguments = (map (transform_parameter t)
(filter (fn x => #kind x <> XMI.Return) parameter)),
precondition = (map ((transform_constraint t) o (find_constraint t))
(filter_precondition t checked_constraints)),
postcondition = List.concat
[map ((transform_constraint t)o(find_constraint t))
(filter_postcondition t constraints),
map ((transform_bodyconstraint result_type t) o
(find_constraint t))
(filter_bodyconstraint t checked_constraints)],
result = result_type,
body = [],
visibility = visibility,
scope = ownerScope,
isQuery = isQuery (* FIX *)
}
end
@ -285,39 +292,35 @@ fun transform_attribute t ({xmiid,name,type_id,changeability,visibility,ordering
}
end
(* old
fun transform_aend t ({xmiid,name,ordering,multiplicity,participant_id,
isNavigable,aggregation,changeability,visibility,targetScope})
= {name = Option.getOpt(name,
(lowercase o XMI.classifier_name_of o
find_classifier t) participant_id),
aend_type = find_classifier_type t participant_id,
multiplicity = multiplicity,
ordered = if ordering = XMI.Ordered then true else false,
visibility = visibility,
init = NONE (* FIX *)
}
*)
fun transform_aend t assoc_path ({xmiid,name,association,ordering,multiplicity,participant_id,
isNavigable,aggregation,changeability,visibility,targetScope}:XMI.AssociationEnd):Rep.associationend =
fun transform_aend t assocPath ({xmiid,name,association,ordering,multiplicity,
participant_id,isNavigable,aggregation,
qualifier,changeability,visibility,
targetScope}:XMI.AssociationEnd):
(Rep.associationend * (string * Rep.attribute list)) =
let
val participant = find_classifier t participant_id
val participant_type = find_classifier_type t participant_id
val participant_name = XMI.classifier_name_of participant
val aend_path = if (isSome name)
then assoc_path@[valOf name]
else assoc_path@[StringHandling.uncapitalize participant_name]
val participant = find_classifier t participant_id
val participantType = find_classifier_type t participant_id
val role = if (isSome name) then valOf name
else
let
val participantName = XMI.classifier_name_of participant
in
StringHandling.uncapitalize participantName
end
val aendPath = assocPath@[role]
in
{name = aend_path,
aend_type = participant_type,
multiplicity = multiplicity,
ordered = if ordering = XMI.Ordered then true else false,
visibility = visibility,
init = NONE (* FIXME *)
}:associationend
({name = aendPath,
aend_type = participantType,
multiplicity = multiplicity,
ordered = if ordering = XMI.Ordered then true else false,
visibility = visibility,
init = NONE (* FIXME *)
}:associationend,
(role, map (transform_attribute t) qualifier)
)
end
val filter_named_aends = List.filter (fn {name=SOME _,...}:XMI.AssociationEnd => true
| _ => false)
@ -533,214 +536,74 @@ fun transform_classifier t (XMI.Class {xmiid,name,isActive,visibility,isLeaf,
end
| transform_classifier t (_) = error "Not supported Classifier type found."
(* billk_tag *)
(** transform an XMI.Association into a Rep.association *)
fun transform_association t ({xmiid,name,connection}:XMI.Association):Rep.association =
fun transform_association t ({xmiid,name,connection}:XMI.Association):
Rep.association =
let
val _ = trace function_calls "transform_association\n"
val _ = trace function_arguments ("transform_association xmiid: "^xmiid^"\n")
val association_path = find_association_path t xmiid
val _ = print ("transform_association path: "^(string_of_path association_path) ^"\n")
val _ = print ("transform_association path length: "^(Int.toString (List.length association_path)) ^"\n")
val association_ends = map (transform_aend t association_path) connection
val _ = trace function_calls "transform_association\n"
val _ = trace function_arguments ("transform_association xmiid: "
^xmiid^"\n")
val associationPath = find_association_path t xmiid
val _ = print ("transform_association path: "^(string_of_path
associationPath)^
"\n")
val _ = print ("transform_association path length: "^
(Int.toString (List.length associationPath)) ^"\n")
val (associationEnds,qualifierPairs) =
ListPair.unzip (map (transform_aend t associationPath) connection)
in
{name = association_path (* path_of_association *),
aends = association_ends,
aclass = NONE (* regular association *)}
{name = associationPath (* path_of_association *),
aends = associationEnds,
qualifiers = qualifierPairs,
aclass = NONE (* regular association *)}
end
fun transformAssociationFromAssociationClass t (XMI.AssociationClass ac) =
fun transformAssociationFromAssociationClass t (XMI.AssociationClass
{xmiid,connection,...}):
Rep.association =
let
val _ = trace function_calls "transformAssociationFromAassociationClass\n"
val xmiid = #xmiid ac
val connection = #connection ac
val id = xmiid^"_association"
val association_path = find_association_path t id
val _ = trace low ("transform_association path: "^(string_of_path association_path) ^"\n")
val _ = trace low ("transform_association path length: "^(Int.toString (List.length association_path)) ^"\n")
val association_ends = map (transform_aend t association_path) connection
val aClass = SOME (path_of_OclType (find_classifier_type t xmiid))
val _ = trace function_calls "transformAssociationFromAassociation\
\Class\n"
val id = xmiid^"_association"
val associationPath = find_association_path t id
val _ = trace low ("transform_association path: "^
(string_of_path associationPath)^"\n")
val _ = trace low ("transform_association path length: "^
(Int.toString (List.length associationPath)) ^"\n")
val (associationEnds,qualifierPairs) =
ListPair.unzip (map (transform_aend t associationPath) connection)
val aClass = SOME (path_of_OclType (find_classifier_type t xmiid))
in
{name = association_path (* path_of_association *),
aends = association_ends,
aclass = aClass}
{name = associationPath (* path_of_association *),
aends = associationEnds,
qualifiers = qualifierPairs,
aclass = aClass}:Rep.association
end
(** recursively transform all classes in the package. *)
fun transform_package t (XMI.Package p) :transform_model=
let (* we do not transform the ocl library *)
val _ = trace function_calls "transform_package\n"
val filteredPackages =
filter (fn (XMI.Package x) =>
((#name x <> "oclLib") andalso (#name x <> "UML_OCL")))
(#packages p)
val aClasses = filter (fn (XMI.AssociationClass _ ) => true
| _ => false ) (#classifiers p)
val local_associations = map (transform_association t) (#associations p) @
(map (transformAssociationFromAssociationClass t) aClasses)
val local_classifiers = map (transform_classifier t) (#classifiers p)
val (res_classifiers,res_associations) = ListPair.unzip (map (transform_package t) filteredPackages)
val associations = local_associations @ (List.concat res_associations)
val classifiers =local_classifiers @ (List.concat res_classifiers)
fun transform_package t (XMI.Package p) :transform_model =
let
(* we do not transform the ocl library *)
val _ = trace function_calls "transform_package\n"
val filteredPackages =
filter (fn (XMI.Package x) =>
((#name x <> "oclLib") andalso (#name x <> "UML_OCL")))
(#packages p)
val aClasses = filter (fn (XMI.AssociationClass _ ) => true
| _ => false ) (#classifiers p)
val local_associations =
map (transform_association t) (#associations p) @
(map (transformAssociationFromAssociationClass t) aClasses)
val local_classifiers = map (transform_classifier t) (#classifiers p)
val (res_classifiers,res_associations) =
ListPair.unzip (map (transform_package t) filteredPackages)
val associations = local_associations @ (List.concat res_associations)
val classifiers =local_classifiers @ (List.concat res_classifiers)
in
(classifiers, associations )
(classifiers, associations )
end
(***********************
(* billk_tag *)
(* recursively transforms all associations in the package p. *)
fun transform_associations t (XMI.Package p) =
(List.app (transform_associations t) (#packages p);
List.app (transform_assocation t) (#associations p);
List.app (transform_associationclass_as_association t)
(List.filter (fn (XMI.AssociationClass x) => true
| _ => false)
(#classifiers p))
)
(* billk_tag *)
(* The new class retains the original xmi-id. *)
fun transform_association_class_into_class table (XMI.AssociationClass ac) =
XMI.Class { xmiid = #xmiid ac,
name = #name ac,
isActive = #isActive ac,
visibility = #visibility ac,
isLeaf = #isLeaf ac,
generalizations = #generalizations ac,
attributes = #attributes ac,
operations = #operations ac,
invariant = #invariant ac,
stereotype = #stereotype ac,
taggedValue = #taggedValue ac,
clientDependency = #clientDependency ac,
supplierDependency = #supplierDependency ac,
classifierInState = [], (* FIXME: better dummy? *)
activity_graphs = [], (* FIXME: better dummy? *)
state_machines = []} (* FIXME: better dummy? *)
(* billk_tag *)
fun transform_association_class_into_association table (XMI.AssociationClass ac) =
let
val new_aend= {xmiid = #xmiid ac ^ "0",
name = SOME (#name ac),
isNavigable = true,
ordering = XMI.Unordered,
aggregation = XMI.NoAggregation,
targetScope = XMI.InstanceScope,
multiplicity = [(1,1)], (* injective *)
changeability = XMI.Changeable,
visibility = #visibility ac,
participant_id = #xmiid ac (* the new class retains the id *)
}:XMI.AssociationEnd
in
{xmiid = #xmiid ac ^ "1",
name = NONE, (* FIXME: proper value? *)
connection = new_aend :: (#connection ac)}:XMI.Association
end
(* billk_tag *)
fun transform_association_classes table (XMI.Package p) =
let
val (association_classes,other_classifiers) = List.partition (fn (XMI.AssociationClass x) => true
| _ => false)
(#classifiers p)
in
XMI.Package {xmiid = #xmiid p,
name = #name p,
visibility = #visibility p,
packages = map (transform_association_classes table) (#packages p),
classifiers = map (transform_association_class_into_class table) association_classes @ other_classifiers ,
state_machines = #state_machines p,
activity_graphs = #activity_graphs p,
associations = map (transform_association_class_into_association table) association_classes @ (#associations p),
generalizations = #generalizations p,
constraints = #constraints p,
stereotypes = #stereotypes p,
dependencies = #dependencies p,
tag_definitions = #tag_definitions p,
stereotype = #stereotype p,
taggedValue = #taggedValue p,
events = #events p}
end
(* billk_tag *)
(* multiplicities -> constraints *)
fun transform_multiplicities table (XMI.Package p) =
XMI.Package {xmiid = #xmiid p,
name = #name p,
visibility = #visibility p,
packages = #packages p,
classifiers = #classifiers p,
state_machines = #state_machines p,
activity_graphs = #activity_graphs p,
associations = map (transform_association_multiplicities table) (#associations p),
generalizations = #generalizations p,
constraints = #constraints p,
stereotypes = #stereotypes p,
dependencies = #dependencies p,
tag_definitions = #tag_definitions p,
stereotype = #stereotype p,
taggedValue = #taggedValue p,
events = #events p}
fun add_constraint_to_class table (Rep_Core.Class cls) (name:string option,constr:OclTerm) =
let
val cls_type = find_classifier_type table (#xmiid cls)
val aends = find_aends table (#xmiid cls)
val agraphs = find_activity_graph_of table (#xmiid cls)
val modified_cls = {xmiid = #xmiid cls,
name = #name cls,
isActive = #isActive cls,
visibility = #visibility cls,
isLeaf = #isLeaf cls,
generalizations = #generalizations cls,
attributes = #attributes cls,
operations = #operations cls,
invariant =(name,constr)::(#invariant cls) ,
stereotype = #stereotype cls,
taggedValue = #taggedValue cls,
clientDependency = #clientDependency cls,
supplierDependency = #supplierDependency cls,
classifierInState = #classifierInState cls,
activity_graphs = #activity_graphs cls,
state_machines = #state_machines cls}
in
HashTable.insert table (#xmiid cls,Type (cls_type,aends,modified_cls,agraphs))
end
fun generate_n_ary_constraint table (ac:XMI.Association) =
let
(* use side-effects to manipulate the table *)
val association_xmiids = map #xmiid (#connection ac)
val classifiers = map (find_classifier table) association_xmiids
val multiplicities = map #multiplicity (#connection ac)
fun generate_local_match_constraint others (XMI.Class cls)=
let
val aend = name_of classifier
val var = Rep_OclTerm.Variable ("n"^(#xmiid cls), type_of cls)
fun get_collection cls = ocl_aendcall var aend (Collection (Classifier (name_of classifier)))
fun collection_equality coll1 coll2 = ocl_and (ocl_includes coll1 coll2) (ocl_includes coll2 coll1)
val sample = get_collection (head others)
fun append_match (current,partial_expression) = ocl_and partial_expression (collection_equality sample (get_collection current))
fun match_ocl_expression = foldr1 append_match (tail others)
fun nest_allInstances (current, partial:OclTerm):OclTerm = ocl_forAll (ocl_allInstances current) ("n"^(#xmiid current)) partial
in
foldr nest_allInstances match_ocl_expression others
end
(* multipliciteis are handled when they are removed later on *)
fun iterate_over_connection done (cls::todo)=
( add_constraint_to_class table cls (generate_local_match_constraint (done@todo) cls);
iterate_over_connection (cls::done) todo;
())
| iterate_over_connection done []= ()
in
ac
end
*********)
(** transform a UML model into a list of Rep classes.
*
@ -756,66 +619,70 @@ fun generate_n_ary_constraint table (ac:XMI.Association) =
* 3. traverse again, transforming all remaining model elements,
* i.e., classes with their operations, attributes,
* constraints, etc *)
fun transformXMI_ext ({classifiers,constraints,packages,
stereotypes,variable_declarations,state_machines, activity_graphs}):transform_model=
let val (xmiid_table: (string,HashTableEntry) HashTable.hash_table) =
HashTable.mkTable (HashString.hashString, (op =)) (101, Option)
(* hack: insert a dummy type into the table *)
val _ = HashTable.insert xmiid_table ("DummyT",
Type (Rep_OclType.DummyT,
nil,
nil,
XMI.Primitive{name="DummyT",
xmiid="DummyT",
operations=[],
generalizations=[],
invariant=[],
taggedValue=[]},
nil))
val _ = HashTable.insert xmiid_table ("-1",UniqueName(123456)) (* arbitrary startnumber *)
(* for some reasons, there are model elements outside of the top-level *)
(* model the xmi-file. So we have to handle them here seperately: *)
val _ = map (insert_classifier xmiid_table nil) classifiers
val _ = map (insert_constraint xmiid_table) constraints
val _ = map (insert_stereotype xmiid_table) stereotypes
val _ = map (insert_variable_dec xmiid_table) variable_declarations
(* "hd packages" is supposed to be the first model in the xmi-file *)
val model = hd packages
fun test2 (classifiers,associations) =
let
val _ = print "test2\n"
val _ = print "classifiers\n"
val _ = map (print o (fn x => x^"\n") o string_of_path o name_of) classifiers
val _ = print "associations\n"
val _ = map (print o (fn x => x^"\n") o string_of_path o (fn {name,aends,aclass} => name)) associations
val _ = print "operations\n"
fun printClassifier cls =
let
val _ = print ("output of transformXMI_ext:\n")
val _ = print ("classifier: "^ (string_of_path (name_of cls)) ^"\n")
val _ = print ("associations: \n")
val _ = map (print o(fn x => x ^ "\n") o string_of_path ) (associations_of cls)
val _ = print ("operations: \n")
val _ = map (print o (fn {name,...} => name)) (operations_of cls)
in
print "\n"
end
val _ = map printClassifier classifiers
in
trace function_calls "\n### transformXMI_ext done\n\n";
(classifiers,associations)
end
fun transformXMI_ext ({classifiers,constraints,packages,stereotypes,
variable_declarations,state_machines,
activity_graphs}):transform_model =
let
val (xmiid_table: (string,HashTableEntry) HashTable.hash_table) =
HashTable.mkTable (HashString.hashString, (op =)) (101, Option)
(* hack: insert a dummy type into the table *)
val _ = HashTable.insert xmiid_table
("DummyT",
Type (Rep_OclType.DummyT,nil,nil,
XMI.Primitive{name="DummyT",
xmiid="DummyT",
operations=[],
generalizations=[],
invariant=[],
taggedValue=[]},
nil))
(* arbitrary startnumber *)
val _ = HashTable.insert xmiid_table ("-1",UniqueName(123456))
(* for some reasons, there are model elements outside of the top-level *) (* model the xmi-file. So we have to handle them here seperately: *)
val _ = map (insert_classifier xmiid_table nil) classifiers
val _ = map (insert_constraint xmiid_table) constraints
val _ = map (insert_stereotype xmiid_table) stereotypes
val _ = map (insert_variable_dec xmiid_table) variable_declarations
(* "hd packages" is supposed to be the first model in the xmi-file *)
val model = hd packages
fun test2 (classifiers,associations) =
let
val _ = print "test2\n"
val _ = print "classifiers\n"
val _ = map (print o (fn x => x^"\n") o string_of_path o name_of)
classifiers
val _ = print "associations\n"
val _ = map (print o (fn x => x^"\n") o string_of_path o
(fn {name,aends,qualifiers,aclass} => name))
associations
val _ = print "operations\n"
fun printClassifier cls =
let
val _ = print ("output of transformXMI_ext:\n")
val _ = print ("classifier: "^ (string_of_path (name_of cls))
^"\n")
val _ = print ("associations: \n")
val _ = map (print o(fn x => x ^ "\n") o string_of_path )
(associations_of cls)
val _ = print ("operations: \n")
val _ = map (print o (fn {name,...} => name))
(operations_of cls)
in
print "\n"
end
val _ = map printClassifier classifiers
in
trace function_calls "\n### transformXMI_ext done\n\n";
(classifiers,associations)
end
in
trace function_calls "### transformXMI: populate hash table\n";
insert_model xmiid_table model (* fill xmi.id table *);
trace function_calls "### transformXMI: fix associations\n";
fix_associations xmiid_table model (* handle associations *);
trace function_calls "### transformXMI: transform XMI into Rep\n";
test2 (transform_package xmiid_table model) (* transform classifiers *)
trace function_calls "### transformXMI: populate hash table\n";
insert_model xmiid_table model (* fill xmi.id table *);
trace function_calls "### transformXMI: fix associations\n";
fix_associations xmiid_table model (* handle associations *);
trace function_calls "### transformXMI: transform XMI into Rep\n";
test2 (transform_package xmiid_table model) (* transform classifiers *)
end
fun transformXMI x:Classifier list = fst (transformXMI_ext x)

163
su4sml/src/rep_su2holocl.sml
View File

@ -283,60 +283,65 @@ fun create_secured {name, body,precondition, postcondition, arguments, result,
* generates constructors, destructors, setters, getters, and "secured" operations.
*)
fun add_operations c =
let val self_type = Classifier (name_of c)
val res = result (Classifier (name_of c))
val constructor = {name="new",
precondition=nil,
(* post: result.oclIsNew() and result->modiefiedOnly() *)
postcondition=[(SOME "generated_constructor",
ocl_and (ocl_isNew (result self_type))
(ocl_modifiedOnly (ocl_set [res] (self_type))))
],
body = [],
arguments=nil,
result=Classifier (name_of c),
isQuery=false,
scope=ClassifierScope,
visibility=public}
val destructor = {name="delete",
precondition=nil,
body=nil,
(* post: self.oclIsUndefined() and self@pre->modifiedOnly() *)
postcondition=[(SOME "generated_destructor",
ocl_and (ocl_isUndefined (self self_type))
(ocl_modifiedOnly
(ocl_set [atpre (self self_type)]
self_type)))
],
arguments=nil,
result=OclVoid,
isQuery=false,
scope=InstanceScope,
visibility=public}
val getters = map (create_getter c) (attributes_of c)
val setters = map (create_setter c) (attributes_of c)
val sec_ops = map create_secured (operations_of c)
val generated_ops = [constructor,destructor]@getters@setters@sec_ops
let
val self_type = Classifier (name_of c)
val res = result (Classifier (name_of c))
val constructor =
{name="new",
precondition=nil,
(* post: result.oclIsNew() and result->modiefiedOnly() *)
postcondition=[(SOME "generated_constructor",
ocl_and (ocl_isNew (result self_type))
(ocl_modifiedOnly (ocl_set [res]
(self_type))))
],
body = [],
arguments=nil,
result=Classifier (name_of c),
isQuery=false,
scope=ClassifierScope,
visibility=public}
val destructor =
{name="delete",
precondition=nil,
body=nil,
(* post: self.oclIsUndefined() and self@pre->modifiedOnly() *)
postcondition=[(SOME "generated_destructor",
ocl_and (ocl_isUndefined (self self_type))
(ocl_modifiedOnly
(ocl_set [atpre (self self_type)]
self_type)))
],
arguments=nil,
result=OclVoid,
isQuery=false,
scope=InstanceScope,
visibility=public}
val getters = map (create_getter c) (attributes_of c)
val setters = map (create_setter c) (attributes_of c)
val sec_ops = map create_secured (operations_of c)
val generated_ops = [constructor,destructor]@getters@setters@sec_ops
in
List.foldl (uncurry addOperation) c generated_ops
List.foldl (uncurry addOperation) c generated_ops
end
(* billk_tag: associationend -> path + associations *)
val identity_role_association =
{name=["AuthorizationEnvironment","IdentityRoleAssociation"],
aends=[{name=["AuthorizationEnvironment","Association","identity"],
aend_type=Classifier ["AuthorizationEnvironment","Identity"],
init=NONE,
multiplicity=[(0,~1)],
ordered=false,
visibility=public},
{name=["AuthorizationEnvironment","Association","roles"],
aend_type=Classifier ["AuthorizationEnvironment","Role"],
init=NONE,multiplicity=[(0,~1)],
ordered=false,
visibility=public}
],
aend_type=Classifier ["AuthorizationEnvironment","Identity"],
init=NONE,
multiplicity=[(0,~1)],
ordered=false,
visibility=public},
{name=["AuthorizationEnvironment","Association","roles"],
aend_type=Classifier ["AuthorizationEnvironment","Role"],
init=NONE,multiplicity=[(0,~1)],
ordered=false,
visibility=public}
],
qualifiers=[],
aclass=NONE}
val identity_principal_association =
@ -353,34 +358,40 @@ val identity_principal_association =
ordered=false,
visibility=public}
],
qualifiers=[],
aclass=NONE}
val context_principal_association =
{name=["AuthorizationEnvironment","ContextPrincipalAssociation"],
aends=[{name=["AuthorizationEnvironment","ContextPrincipalAssociation","principal"],
aend_type=Classifier ["AuthorizationEnvironment","Principal"],
init=NONE,
multiplicity=[(1,1)],
ordered=false,
visibility=public},
{name=["AuthorizationEnvironment","ContextPrincipalAssociation","context"],
aend_type=Classifier ["AuthorizationEnvironment","Context"],
init=NONE,
multiplicity=[(0,~1)],
ordered=false,
visibility=public}
],
aends=[{name=["AuthorizationEnvironment","ContextPrincipalAssociation",
"principal"],
aend_type=Classifier ["AuthorizationEnvironment","Principal"],
init=NONE,
multiplicity=[(1,1)],
ordered=false,
visibility=public},
{name=["AuthorizationEnvironment","ContextPrincipalAssociation",
"context"],
aend_type=Classifier ["AuthorizationEnvironment","Context"],
init=NONE,
multiplicity=[(0,~1)],
ordered=false,
visibility=public}
],
qualifiers=[],
aclass=NONE}
val role =
Class {activity_graphs=[],
(* associationends=[{aend_type=Classifier
["AuthorizationEnvironment","Identity"],
init=NONE,multiplicity=[(0,~1)],
name="identity",
ordered=false,
visibility=public}],
*) associations=[["AuthorizationEnvironment","IdentityRoleAssociation"]],
(* associationends=[{aend_type=Classifier
["AuthorizationEnvironment","Identity"],
init=NONE,multiplicity=[(0,~1)],
name="identity",
ordered=false,
visibility=public}],
*)
associations=[["AuthorizationEnvironment",
"IdentityRoleAssociation"]],
attributes=[{attr_type=String,
init=NONE,name="name",
scope=InstanceScope,
@ -543,12 +554,16 @@ fun create_sec_postconds sc c = c
fun transform (model:Rep.Model,sc) =
let
val transformed_design_model = (map add_operations (#1 model),#2 model)
val transformed_model = create_sec_postconds sc transformed_design_model
val auth_env = map (normalize (#2 transformed_model)) (define_roles sc::define_role_hierarchy sc::static_auth_env)
val transformedDesignModel = (map add_operations (#1 model),#2 model)
val transformedModel = create_sec_postconds sc transformedDesignModel
val authEnv = map (normalize (#2 transformedModel))
(define_roles sc::define_role_hierarchy sc::
static_auth_env)
in
((#1 transformed_model) @ auth_env,identity_role_association::identity_principal_association::
context_principal_association::(#2 transformed_model))
((#1 transformedModel) @ authEnv,identity_role_association::
identity_principal_association::
context_principal_association::
(#2 transformedModel))
end
end

50
su4sml/src/rep_transform.sml
View File

@ -234,8 +234,9 @@ fun transformAssociationClassIntoClass (AssociationClass
* constraint and update the classifiers with that constraint.
*)
fun generalTransfromNAryAssociation dummy (association as {name,aends,
qualifiers=[],
aclass=NONE},
(classifiers,processedAssocs)) =
(classifiers,processedAssocs)) =
let
val _ = trace function_calls "transformNAryAssociation\n"
fun modifyClassifier ((assocs,classifier),classifiers) =
@ -307,18 +308,20 @@ fun generalTransfromNAryAssociation dummy (association as {name,aends,
fun transformAssociationClasses (allClassifiers,allAssociations) =
let
val _ = trace function_calls "transformAssociationClasses\n"
fun transformAssociationClass ({name,aends,aclass=SOME aClass},
fun transformAssociationClass ({name,aends,qualifiers=[],
aclass=SOME aClass},
(classifiers,procAssocs)) =
let
val ([dummy],rem) = List.partition (fn x => name_of x = aClass)
classifiers
in
generalTransfromNAryAssociation dummy ({name=name,aends=aends,
aclass=NONE},
qualifiers=[],aclass=NONE},
(rem,procAssocs))
end
fun stripAcAssoc ({name,aends,aclass=SOME aClass},classifiers) =
fun stripAcAssoc ({name,aends,qualifiers,aclass=SOME aClass},
classifiers) =
let
val ([ac],rem) = List.partition (fn x => name_of x = aClass)
classifiers
@ -394,7 +397,8 @@ fun transformMultiplicities (allClassifiers,allAssociations) =
(SOME name, term)
end
fun addMultiplicityConstraints (assoc as {name,aends=[a,b],aclass=NONE},
fun addMultiplicityConstraints (assoc as {name,aends=[a,b],qualifiers=[],
aclass=NONE},
localClassifiers) =
let
val _ = trace function_calls "addMultiplicityConstraints\n"
@ -411,27 +415,27 @@ fun transformMultiplicities (allClassifiers,allAssociations) =
[] => localClassifiers
| multis =>
let
val aConstraint = binaryConstraint aType bType bPath
val aConstraint = binaryConstraint aType bType bPath
multis aConstrName
in
updateClassifiersWithConstraints localClassifiers aType
in
updateClassifiersWithConstraints localClassifiers aType
[aConstraint]
end)
end)
val modifiedClassifiers =
(case (multiplicities_of_aend b) of
[] => modifiedTmp
| multis =>
let
val bConstraint = binaryConstraint bType aType
aPath multis
bConstrName
in
updateClassifiersWithConstraints modifiedTmp bType
[bConstraint]
end)
in
modifiedClassifiers
end
(case (multiplicities_of_aend b) of
[] => modifiedTmp
| multis =>
let
val bConstraint = binaryConstraint bType aType
aPath multis
bConstrName
in
updateClassifiersWithConstraints modifiedTmp bType
[bConstraint]
end)
in
modifiedClassifiers
end
(* filter the valid associations *)
val (binaryAssociations,rem) = List.partition isPureBinAssoc

114
su4sml/src/secure_uml.sml
View File

@ -271,10 +271,13 @@ fun assocConnectsToSecureUml cs (a:Rep.associationend) =
*)
fun removeSecureUmlAends (Rep.Class {name=class_name,...},(assocs,removed_assocs)):(Rep.association list * Rep.association list) =
let
fun remove_aend ({name,aclass,aends}:Rep.association):Rep.association =
fun remove_aend ({name,aclass,qualifiers,aends}:Rep.association):
Rep.association =
{name = name,
aclass = aclass,
aends = filter (fn {aend_type,...} => not (aend_type = class_name)) aends
qualifiers=qualifiers,
aends = filter (fn {aend_type,...} => not (aend_type = class_name))
aends
}
fun non_emtpy ({aends,...}:Rep.association) = List.length aends >= 2 (* FIXME: reflexive association -> 2 aends? *)
val reduced_assocs = map remove_aend assocs
@ -282,14 +285,19 @@ fun removeSecureUmlAends (Rep.Class {name=class_name,...},(assocs,removed_assocs
in
(modified_assocs,newly_removed_assocs @ removed_assocs)
end
| removeSecureUmlAends (Rep.AssociationClass {name=class_name,...},(assocs,removed_assocs)):(Rep.association list * Rep.association list) =
| removeSecureUmlAends (Rep.AssociationClass {name=class_name,...},
(assocs,removed_assocs)):
(Rep.association list * Rep.association list) =
let
fun remove_aend ({name,aclass,aends}:Rep.association):Rep.association =
{name = name,
aclass = aclass,
aends = filter (fn {aend_type,...} => not (aend_type = class_name)) aends
}
fun non_emtpy ({aends,...}:Rep.association) = List.length aends >= 2 (* FIXME: reflexive association -> 2 aends? *)
fun remove_aend ({name,aclass,qualifiers,aends}:Rep.association):
Rep.association =
{name = name,
aclass = aclass,
qualifiers=qualifiers,
aends = filter (fn {aend_type,...} => not (aend_type = class_name))
aends
}
fun non_emtpy ({aends,...}:Rep.association) = List.length aends >= 2 (* FIXME: reflexive association -> 2 aends? *)
val reduced_assocs = map remove_aend assocs
val (modified_assocs,newly_removed_assocs) = List.partition non_emtpy reduced_assocs
(* FIXME: proper handling for aclass? *)
@ -313,24 +321,28 @@ fun parse (model as (cs,assocs):Rep.Model) =
(* remove classes with SecureUML stereotypes from the association list
* and update affected classes if the association ceases to exist
*)
fun updateClassifierAssociations rem_assocs (Rep.Class {name, parent, attributes, operations,
associations, invariant, stereotypes,
interfaces, thyname, activity_graphs}) =
fun updateClassifierAssociations rem_assocs (Rep.Class
{name,parent,attributes,
operations,associations,
invariant, stereotypes,
interfaces, thyname,
activity_graphs}) =
let
val assoc_names = map (fn {name,aends,aclass} => name) rem_assocs
fun non_emtpy path = not (List.exists (fn aname => aname = path) assoc_names)
in
Rep.Class {name = name,
parent = parent,
attributes = attributes,
operations = operations,
associations = filter non_emtpy associations,
invariant = invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname,
activity_graphs = activity_graphs
}
val assoc_names = map (fn {name,aends,qualifiers,aclass} => name)
rem_assocs
fun non_emtpy path = not (List.exists (fn aname => aname = path)
assoc_names)
in
Rep.Class {name = name,
parent = parent,
attributes = attributes,
operations = operations,
associations = filter non_emtpy associations,
invariant = invariant,
stereotypes = stereotypes,
interfaces = interfaces,
thyname = thyname,
activity_graphs = activity_graphs}
end
| updateClassifierAssociations rem_assocs (Rep.AssociationClass {name, parent, attributes,
operations, associations,
@ -338,8 +350,10 @@ fun parse (model as (cs,assocs):Rep.Model) =
stereotypes, interfaces,
thyname, activity_graphs}) =
let
val assoc_names = map (fn {name,aends,aclass} => name) rem_assocs
fun non_emtpy path = not (List.exists (fn aname => aname = path) assoc_names)
val assoc_names = map (fn {name,aends,qualifiers,aclass} => name)
rem_assocs
fun non_emtpy path = not (List.exists (fn aname => aname = path)
assoc_names)
in
Rep.AssociationClass {name = name,
parent = parent,
@ -355,27 +369,31 @@ fun parse (model as (cs,assocs):Rep.Model) =
}
end
val (modified_assocs,removed_assocs) = case secureumlstereotypes of [] => (assocs,[])
| xs => foldl removeSecureUmlAends (assocs,[]) xs
val modified_classifiers = case removed_assocs of [] => non_secureumlstereotypes
| xs => map (updateClassifierAssociations xs) non_secureumlstereotypes
val (modified_assocs,removed_assocs) =
(case secureumlstereotypes of
[] => (assocs,[])
| xs => foldl removeSecureUmlAends (assocs,[]) xs)
val modified_classifiers =
(case removed_assocs of
[] => non_secureumlstereotypes
| xs => map (updateClassifierAssociations xs) non_secureumlstereotypes)
in
(
(* map (removeSecureUmlAends cs)
(List.filter (classifier_has_no_stereotype ["secuml.permission",
"secuml.role",
"secuml.subject",
"secuml.actiontype"])
cs),
*) (modified_classifiers,modified_assocs),
{ config_type = "SecureUML",
permissions = map (mkPermission model) (filter_permission cs),
subjects = map mkSubject (filter_subject cs),
roles = map mkRole (filter_role cs),
rh = map (fn x => (Rep.string_of_path (Rep.name_of x),
Rep.string_of_path (Rep.parent_name_of x)))
(List.filter classifier_has_parent (filter_role cs)),
sa = map (mkSubjectAssignment model) (filter_subject cs)})
(
(* map (removeSecureUmlAends cs)
(List.filter (classifier_has_no_stereotype ["secuml.permission",
"secuml.role",
"secuml.subject",
"secuml.actiontype"])
cs),
*) (modified_classifiers,modified_assocs),
{ config_type = "SecureUML",
permissions = map (mkPermission model) (filter_permission cs),
subjects = map mkSubject (filter_subject cs),
roles = map mkRole (filter_role cs),
rh = map (fn x => (Rep.string_of_path (Rep.name_of x),
Rep.string_of_path (Rep.parent_name_of x)))
(List.filter classifier_has_parent (filter_role cs)),
sa = map (mkSubjectAssignment model) (filter_subject cs)})
end
handle ex => (error_msg "in SecureUML.parse: security configuration \
\could not be parsed";

3
su4sml/src/test-suite.sml
View File

@ -80,7 +80,7 @@ val testcases = [
uml = prefix^"company/company.zargo",
ocl = prefix^"company/company.ocl",
result = initResult
}:testcase (*,
}:testcase,
{
name = "ebank",
uml = prefix^"ebank/ebank.zargo",
@ -135,7 +135,6 @@ val testcases = [
ocl = "",
result = initResult
}:testcase
*)
]

139
su4sml/src/transform_library.sml
View File

@ -27,6 +27,22 @@ val consistencyOclConstraint: Rep_Core.Classifier ->
Rep_Core.associationend list ->
(Rep_Core.Classifier * Rep_Core.constraint list)
(**
* Works through the list of classifiers and updates uses of oldAssoc
* to the appropriate association in newAssocs.
*
* @params {classifiers,(oldAssoc,newAssocs)}
* @param classifiers
* @param oldAssoc the association that has been removed from the model
* @param newAssocs the associations that have replaced oldAssoc
* @return the list of classifiers with references to the old association
* removed
*)
val updateAssociationReferences: Rep_Core.Classifier list ->
(Rep_Core.association *
Rep_Core.association list) list ->
Rep_Core.Classifier list
(**
* @params {association,assocMembers}
* @param association n-ary association that should be split into it's binary
@ -102,6 +118,7 @@ val fixAends: Rep_OclTerm.OclTerm -> Rep_Core.associationend list
-> (Rep_OclTerm.OclTerm * Rep_OclTerm.OclTerm list)
val isPureNAryAssoc: Rep_Core.association -> bool
val isPureQualifier: Rep_Core.association -> bool
val isPureAcAssoc: Rep_Core.association -> bool
(**
* returns true iif assoc is purely a binary association, without any
@ -214,19 +231,21 @@ fun nextUid () = (uid := !uid + 1; "_S"^(Int.toString (!uid)))
fun get_short_name (path:Path):string =
List.last path
fun stripMultiplicities ({name,aends,aclass}:association):association =
fun stripMultiplicities ({name,aends,qualifiers,aclass}:association):
association =
let
fun handleAend {name,aend_type,multiplicity,visibility,
ordered,init} =
{name=name,
aend_type=aend_type,
multiplicity=[],
visibility=visibility,
ordered=ordered,
init=init}
{name=name,
aend_type=aend_type,
multiplicity=[],
visibility=visibility,
ordered=ordered,
init=init}
in
{name = name,
aends = map handleAend aends,
qualifiers = [] (* FIXME: sensible?*),
aclass = aclass}
end
@ -250,9 +269,9 @@ fun association_of_aend ({name,aend_type,...}:associationend) =
fun package_of_aend ({name,aend_type,...}:associationend) =
List.take(name, List.length name - 2)
fun name_of_association ({name,aends,aclass}:association) = name
fun name_of_association ({name,aends,qualifiers,aclass}:association) = name
fun package_of_association ({name,aends,aclass}:association) =
fun package_of_association ({name,aends,qualifiers,aclass}:association) =
List.take(name, List.length name - 1)
(* (JD) -> Rep_Core? *)
@ -276,18 +295,20 @@ fun quantifyForAll variables body =
end
fun isPureBinAssoc {name,aends=[a,b],aclass=NONE} =
let
(* TODO: update when qualifiers added *)
val _ = trace function_calls "isPureBinAssoc\n"
in
true
end
fun isPureBinAssoc {name,aends=[a,b],qualifiers=[],aclass=NONE} = true
| isPureBinAssoc _ = false
fun isPureNAryAssoc _ = false (*FIXME*)
fun isPureNAryAssoc {name,aends,qualifiers=[],aclass=NONE} =
List.length aends > 1
| isPureNAryAssoc _ = false
fun isPureAcAssoc _ = false (*FIXME*)
fun isPureQualifier {name,aends,qualifiers,aclass=NONE} =
List.length qualifiers > 1
| isPureQualifier _ = false
fun isPureAcAssoc {name,aends,qualifiers=[],aclass=SOME ac} =
List.length aends > 1
| isPureAcAssoc _ = false
fun newDummyClass package =
Class{name=Classifier (package@["Dummy"^ nextUid ()]),
@ -313,6 +334,13 @@ fun removeAssociations oldAssocs associations =
associations (* FIXME *)
end
fun updateAssociationReferences classifiers [] = classifiers
| updateAssociationReferences classifiers ((oldAssoc,newAssocs)::rem) =
let
in
classifiers (*FIXME*)
end
fun updateClassifiersWithConstraints classifiers oclType constraints =
let
val (match,rem) = List.partition (fn cls => type_of cls = oclType)
@ -464,35 +492,35 @@ fun modifyAssociationsOfClassifier (newAssociations:association list)
fun uniquenessOclConstraint (source:Classifier) (associations:association list) =
let
fun assocAendCalls (self:OclTerm) (iter:OclTerm) {name,aends,aclass} =
fun assocAendCalls (self:OclTerm) (iter:OclTerm) {name,aends,qualifiers,
aclass} =
let
val [{name,aend_type,...}] = filter (fn {aend_type,name,multiplicity,ordered,visibility,init} =>
Rep_OclHelper.type_of self
<> aend_type)
aends
val [{name,aend_type,...}] =
filter (fn {aend_type,name,multiplicity,ordered,visibility,
init} => Rep_OclHelper.type_of self <> aend_type)
aends
val selfCall = ocl_aendcall self name (Collection aend_type)
val iterCall = ocl_aendcall iter name (Collection aend_type)
in
ocl_eq selfCall iterCall
end
val _ = trace function_calls "uniquenessOclConstraint\n"
val selfVar = self (type_of source)
val iterVar = Variable ("other"^nextUid (),type_of source)
val aendCalls = map (assocAendCalls selfVar iterVar) associations
val oclBody = ocl_implies (ocl_and_all aendCalls) (ocl_eq selfVar
iterVar)
iterVar)
val constr = quantifyForAll [iterVar] oclBody
in
(SOME "Uniqueness", constr)
end
fun binaryAssociations (source:Classifier) (targets:Classifier list) aends:
(association list * associationend list)=
let
val _ = trace function_calls "binaryAssociations\n"
fun generateAssociation target =
fun generateAssociation target: (association * associationend)=
let
val assocName = package_of source @
["BinaryAssoc"^nextUid ()]
@ -511,6 +539,7 @@ fun binaryAssociations (source:Classifier) (targets:Classifier list) aends:
visibility=XMI_DataTypes.public,
init=NONE},
oppAend],
qualifiers=[],
aclass=NONE},
oppAend)
end
@ -532,13 +561,15 @@ fun binaryAssociations (source:Classifier) (targets:Classifier list) aends:
oppAendName = refName)
pairs
in
oppAend :: (order rem aends)
(oppAend :: (order rem aends))
end
val pairs = map generateAssociation targets
val pairs:(association * associationend) list =
map generateAssociation targets
val orderedPairs:(association * associationend) list = order pairs aends
in
ListPair.unzip (order pairs aends)
ListPair.unzip orderedPairs: (association list * associationend list)
end
fun variableFromAend ({name,aend_type,...}:associationend) =
@ -623,19 +654,19 @@ fun consistencyOclConstraint source reference selfAend roles refRoles =
(ListPair.zip (roles,refRoles)))
end
fun splitNAryAssociation (association as {name=qualifier::assocName,
fun splitNAryAssociation (association as {name=assocPath::assocName,qualifiers,
aends,aclass}) classifiers =
let
val _ = trace function_calls "splitNAryAssociation\n"
fun updateClassifier ((clsType,newAssocs),classifiers) =
let
val ([cls],rem) = List.partition (fn x => type_of x = clsType )
classifiers
val modifiedCls = modifyAssociationsOfClassifier newAssocs
val ([cls],rem) = List.partition (fn x => type_of x = clsType )
classifiers
val modifiedCls = modifyAssociationsOfClassifier newAssocs
[association]
cls
in
modifiedCls::rem
modifiedCls::rem
end
fun iterate done [] = []
@ -666,11 +697,12 @@ fun splitNAryAssociation (association as {name=qualifier::assocName,
visibility=XMI_DataTypes.public,
init=NONE},
oppAend],
qualifiers=[],
aclass=NONE}
in
(oppAend,binaryAssoc)
end
val (oppAends,binaryAssocs) = ListPair.unzip (map (makeAssoc aend)
(done@xs))
val role = short_name_of_path name
@ -707,8 +739,8 @@ fun splitNAryAssociation (association as {name=qualifier::assocName,
(* generate new associations *)
val pairs = iterate [] aends
val (types,roleNames,oppAends,splitAssocs) = unzip4 (order pairs
classifiers)
classifiers)
(* update associations in classifiers to the new names *)
val modifiedClassifiers = foldl updateClassifier classifiers
(ListPair.zip (types,splitAssocs))
@ -758,36 +790,5 @@ fun matchAendsAtClassifier oppRefAends pairs =
end
fun binaryAssociations source targets aends =
let
val _ = trace function_calls "binaryAssociations\n"
fun generateAssociation target =
let
val assocName = package_of source@["BinaryAssoc"^(nextUid ())]
val targetAend = {name=assocName@[short_name_of target],
aend_type=type_of target,
multiplicity=[(1,1)],
ordered=false,
visibility=XMI_DataTypes.public,
init=NONE}
in
({name= assocName,
aends=[{name=assocName@[short_name_of source],
aend_type=type_of source,
multiplicity=[],
ordered=false,
visibility=XMI_DataTypes.public,
init=NONE},
targetAend],
aclass=NONE},
targetAend)
end
val (assocs,refAends) = ListPair.unzip (map generateAssociation targets)
val oppAends = matchAends refAends aends
in
(assocs, oppAends)
end
end

39
su4sml/src/xmi_core.sml
View File

@ -241,12 +241,14 @@ type Set = Collection
type Bag = Collection
type OrderedSet = Collection
type Enumeration = { xmiid : string,
name : string,
operations: Operation list,
generalizations: string list,
literals: string list, (* names of literals *)
invariant: string list}
type Enumeration = {
xmiid : string,
name : string,
operations: Operation list,
generalizations: string list,
literals: string list (* names of literals *),
invariant: string list
}
type Void = {xmiid: string,
name : string }
@ -259,17 +261,20 @@ type Void = {xmiid: string,
* stereotypes <<association>>, <<global>>, <<local>>,
* <<parameter>>, <<self>>
* --------------------------------------------------------------------------*)
type AssociationEnd = { xmiid : string,
name : string option,
association: string (* xmiid of enclosing association *),
isNavigable: bool,
ordering : OrderingKind,
aggregation : AggregationKind,
targetScope: ScopeKind,
multiplicity : Multiplicity,
changeability: ChangeableKind,
visibility : VisibilityKind,
participant_id : string (* xmi.idref to class *) }
type AssociationEnd = {
xmiid : string,
name : string option,
association: string (* xmiid of enclosing association *),
isNavigable: bool,
ordering : OrderingKind,
aggregation : AggregationKind,
targetScope: ScopeKind,
multiplicity : Multiplicity,
changeability: ChangeableKind,
qualifier: Attribute list,
visibility : VisibilityKind,
participant_id : string (* xmi.idref to class *)
}
(* from UML 1.5 Core: --------------------------------------------------------
* An association defines a semantic relationship between classifiers.

68
su4sml/src/xmi_idtable.sml
View File

@ -663,74 +663,30 @@ fun fixAssociationFromAsssociationClass table (XMI.AssociationClass{xmiid,
end
(**
* Handel the broken association references, meaning update the
* Handel the broken association references, meaning updating the
* association path list for classes and association classes.
* Since classifiers do not store their belonging aends, we traverse the
* associations:
* We skip the aends and instead process the set of associations. For
* each association, we traverse the connection part and search for the
* classifier listed as participant_id. Then we simply add the assoc-
* iation path to the found classifier.
* each association, we traverse the connection part and search for
* the classifier listed as participant_id. Then we simply add the
* association path to the found classifier.
* For the classifiers part of an association class's class, no association
* construct is present in the package p, while those constructs are already
* in the hashtable. To traverse them as well, we extract all association
* classes and reconstruct the associations.
*)
fun fix_associations t (XMI.Package p)=
fun fix_associations t (XMI.Package p) =
let
val associationClasses = filter (fn (XMI.AssociationClass x) => true
| _ => false) (#classifiers p)
val associationClasses = filter (fn (XMI.AssociationClass x) => true
| _ => false) (#classifiers p)
in
(* All association ends are stored in associations, so we will
* traverse them an update affected Classes and AssociationClasses *)
(List.app (fix_associations t) (#packages p);
List.app (fix_association t) (#associations p);
List.app (fixAssociationFromAsssociationClass t) associationClasses
)
(* All association ends are stored in associations, so we will
* traverse them an update affected Classes and AssociationClasses *)
(List.app (fix_associations t) (#packages p);
List.app (fix_association t) (#associations p);
List.app (fixAssociationFromAsssociationClass t) associationClasses)
end
(* billk_tag *)
(* old: *)
(**
* split an association into association ends, and put the association ends
* ends into the xmi.id table under the corresponding (i.e., opposite)
* classifier.
* 1. split the association into a list of two (or more) association ends
* 2. pair each association end with the participant_id's of all other
* association ends: when a class is a participant in an association,
* this association end is a feature of all _other_ participants in the
* association
* 3. insert the mapping xmi.id of class to association end into the
* hashtable
* 4. insert mapping xmi.id of association end to path into the hashtable
*)
(* orig:
fun insert_assocation t (assoc:XMI.Association) =
let val aends = #connection assoc
fun all_others x xs = List.filter
(fn (y:XMI.AssociationEnd) => y <> x) xs
fun pair_with ae aes =
map (fn (x:XMI.AssociationEnd) => (#participant_id x, ae)) aes
val mappings = List.concat (map (fn x => pair_with x (all_others x aends)) aends)
fun add_aend_to_type (id,ae) =
if not (Option.isSome (HashTable.find t id)) then () else
let val type_of_id = find_classifier_type t id
val cls_of_id = find_classifier t id
val aends_of_id = ae::(find_aends t id)
val ags_of_id = find_activity_graph_of t id
in
(HashTable.insert t (id,Type (type_of_id,aends_of_id,cls_of_id,ags_of_id));
HashTable.insert t (#xmiid ae, AssociationEnd ae))
end
in
List.app add_aend_to_type mappings
end
(* recursively transforms all associations in the package p. *)
fun transform_associations t (XMI.Package p) =
(List.app (transform_associations t) (#packages p);
List.app (transform_association t) (#associations p))
*)
end

529
su4sml/src/xmi_parser.sml
View File

@ -127,11 +127,11 @@ 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 =
@ -173,30 +173,268 @@ fun mkRange tree =
in
(int_value_of "lower" atts, int_value_of "upper" atts)
end
fun mkMultiplicity tree =
assert "UML:Multiplicity" tree
|> get "UML:Multiplicity.range"
|> map mkRange
(* find the xmi.idref attribute of an element pointed to by name *)
fun xmiidref_to name tree = tree |> get_one name
|> xmiidref
(* find the type of an OCl sub-expression *)
fun expression_type tree = tree |> xmiidref_to "OCL.Expressions.OclExpression.type"
handle _ => "DummyT"
(* hack: return a reference to a dummy*)
(* type if the real type is not found *)
(* this is a hack. This will still throw an exception in xmi2mdr, because the *)
(* expression_type should be the xmiid of oclLib.Boolean, which we do not know *)
val triv_expr = XMI.LiteralExp {symbol = "true",
expression_type = "bool" }
(* FIX: this is only a dummy implementation *)
fun mkCollectionLiteralPart x = (xmiidref x)
fun mkLiteralExp string tree =
XMI.LiteralExp
{ symbol = tree |> attributes |> value_of string,
expression_type = tree |> expression_type
}
fun mkOCLExpression (tree as Node(("UML15OCL.Expressions.BooleanLiteralExp",
atts),_)) =
mkLiteralExp "booleanSymbol" tree
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.IntegerLiteralExp",
atts),_)) =
mkLiteralExp "integerSymbol" tree
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.StringLiteralExp",
atts),_)) =
mkLiteralExp "stringSymbol" tree
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.RealLiteralExp",
atts),_)) =
mkLiteralExp "realSymbol" tree
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.CollectionLiteralExp",
atts),_))
= XMI.CollectionLiteralExp
{ parts = nil,
(* map mkCollectionLiteralPart (follow "OCL.Expressions.\
\CollectionLiteralExp.parts" trees),*)
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.OperationCallExp",
atts),_))
= XMI.OperationCallExp
{ source = (tree |> get_one "OCL.Expressions.\
\PropertyCallExp.source"
|> mkOCLExpression)
(* This hack is necessary to support TYPE::allInstances() as parsed *)
(* by dresden-ocl. *)
handle ex =>
XMI.LiteralExp
{ symbol = "",
expression_type = tree |> get_one "OCL.Expressions.\
\FeatureCallExp.\
\srcType"
|> xmiidref
},
arguments = tree |> get "OCL.Expressions.OperationCallExp.arguments"
|> map mkOCLExpression,
referredOperation = tree |> xmiidref_to "OCL.Expressions.\
\OperationCallExp.\
\referredOperation",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.OclOperationWith\
\TypeArgExp",atts),_))
= XMI.OperationWithTypeArgExp
{ source = tree |> get_one "OCL.Expressions.PropertyCallExp.\
\source"
|> mkOCLExpression,
name = atts |> name,
typeArgument = tree |> xmiidref_to "OCL.Expressions.OclOperation\
\WithTypeArgExp.typeArgument",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.AttributeCallExp",
atts),_))
= XMI.AttributeCallExp
{ source = tree |> get_one "OCL.Expressions.PropertyCall\
\Exp.source"
|> mkOCLExpression,
referredAttribute = tree |> xmiidref_to "OCL.Expressions.Attribute\
\CallExp.referred\
\Attribute",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.AssociationEndCall\
\Exp",atts),_))
= XMI.AssociationEndCallExp
{ source = tree |> get_one "OCL.Expressions.PropertyCallExp.source"
|> mkOCLExpression,
referredAssociationEnd = tree |> xmiidref_to
"OCL.Expressions.AssociationEndCall\
\Exp.referredAssociationEnd",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.AssociationClassCall\
\Exp",atts),_))
= error ("AssociationClassCallExp is not yet implemented"^some_id tree)
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.VariableExp",atts),_))
= XMI.VariableExp
{ referredVariable = tree |> xmiidref_to
"OCL.Expressions.VariableExp.referred\
\Variable",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.IfExp",atts),_))
= XMI.IfExp
{ condition = tree |> get_one "OCL.Expressions.IfExp.condition"
|> mkOCLExpression,
thenExpression = tree |> get_one "OCL.Expressions.IfExp.then\
\Expression"
|> mkOCLExpression,
elseExpression = tree |> get_one "OCL.Expressions.IfExp.else\
\Expression"
|> mkOCLExpression,
expression_type = tree |> expression_type }
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.LetExp",atts),_))
= XMI.LetExp
{ variable = let val vard = tree |> get_one "OCL.Expressions.Let\
\Exp.variable"
val atts = vard |> attributes
in
{ xmiid = atts |> xmiid,
name = atts |> name,
declaration_type = vard |> xmiidref_to
"OCL.Expressions.Variable\
\Declaration.type",
init = vard |> get_one
"OCL.Expressions.VariableDeclaration.\
\initExpression"
|> mkOCLExpression
|> SOME
}
end,
inExpression = tree |> get_one "OCL.Expressions.LetExp.in"
|> mkOCLExpression,
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.IterateExp",atts),_))
= XMI.IterateExp
{ result = tree |> get_one "OCL.Expressions.IterateExp.result"
|> mkVariableDec,
iterators = tree |> get_many "OCL.Expressions.LoopExp.iterators"
|> map mkVariableDec,
body = tree |> get_one "OCL.Expressions.LoopExp.body"
|> mkOCLExpression,
source = tree |> get_one "OCL.Expressions.PropertyCallExp.\
\source"
|> mkOCLExpression,
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.IteratorExp",atts),_))
= XMI.IteratorExp
{ name = atts |> name,
iterators = tree |> get_many "OCL.Expressions.LoopExp.iterators"
|> map mkVariableDec,
body = tree |> get_one "OCL.Expressions.LoopExp.body"
|> mkOCLExpression,
source = tree |> get_one "OCL.Expressions.PropertyCallExp.source"
|> mkOCLExpression,
expression_type = tree |> expression_type
}
| mkOCLExpression tree =
error ("unknown OCLExpression type \""^(tagname tree)^"\""^some_id tree^
".")
and mkVariableDec vtree =
let val atts = vtree |> assert "UML15OCL.Expressions.VariableDeclaration"
|> attributes
in
{ xmiid = atts |> xmiid,
name = atts |> name,
init = vtree |> get_optional "OCL.Expressions.VariableDeclaration.\
\initExpression"
|> map_optional mkOCLExpression,
declaration_type = vtree |> get_one "OCL.Expressions.Variable\
\Declaration.type"
|> xmiidref
}
end
(* handle IllFormed msg => error ("in mkVariableDec: "^msg)*)
fun mkTaggedValue tree =
let val atts = tree |> assert "UML:TaggedValue" |> attributes
in
{ xmiid = atts |> xmiid,
dataValue= tree |> find_child "UML:TaggedValue.dataValue"
|> children
|> map text
|> String.concat,
tag_type = tree |> get_one "UML:TaggedValue.type"
|> assert "UML:TagDefinition"
|> xmiidref
}
end
(*handle IllFormed msg => error ("in mkTaggedValue: "^msg)*)
fun mkAttribute tree =
let val atts = tree |> assert "UML:Attribute" |> attributes
in
{ xmiid = atts |> xmiid,
name = atts |> name,
visibility = atts |> visibility,
changeability = atts |> changeability,
ordering = atts |> ordering,
initialValue = tree |> get_optional "UML:Attribute.initialValue"
|> map_optional (get_optional
"OCL.Expressions.\
\ExpressionInOcl.bodyExpression")
|> Option.join
|> map_optional mkOCLExpression,
type_id = tree |> get_optional "UML:StructuralFeature.type"
|> map_optional xmiidref
|> get_optional_or_default "",
multiplicity = tree |> get_optional "UML:StructuralFeature.multiplicity"
|> map_optional mkMultiplicity
|> get_optional_or_default [(1,1)],
targetScope = atts |> target_scope,
ownerScope = atts |> owner_scope,
stereotype = tree |> get "UML:ModelElement.stereotype"
|> map xmiidref ,
taggedValue = tree |> get "UML:ModelElement.taggedValue"
|> map mkTaggedValue
}
end
(*handle IllFormed msg => error ("in mkAttribute: "^msg)*)
fun mkQualifier tree =
get_maybe "UML:Attribute" tree
|> map mkAttribute
fun mkAssociationEnd association tree:XMI_Core.AssociationEnd =
let val atts = tree |> assert "UML:AssociationEnd" |> attributes
in
{ xmiid = atts |> xmiid,
name = atts |> optional_value_of "name",
association = association,
isNavigable = atts |> bool_value_of "isNavigable" ,
ordering = atts |> ordering,
aggregation = atts |> aggregation,
targetScope = atts |> target_scope,
multiplicity = tree |> get_optional "UML:AssociationEnd.multiplicity"
|> map_optional mkMultiplicity
|> get_optional_or_default [(0,~1)],
changeability = atts |> changeability,
visibility = atts |> visibility,
participant_id = tree |> get_one "UML:AssociationEnd.participant"
|> xmiidref
}
{ xmiid = atts |> xmiid,
name = atts |> optional_value_of "name",
association = association,
isNavigable = atts |> bool_value_of "isNavigable" ,
ordering = atts |> ordering,
aggregation = atts |> aggregation,
targetScope = atts |> target_scope,
multiplicity = tree |> get_optional "UML:AssociationEnd.\
\multiplicity"
|> map_optional mkMultiplicity
|> get_optional_or_default [(0,~1)],
changeability = atts |> changeability,
qualifier = tree |> get_optional "UML.AssociationEnd.qualifier"
|> map_optional mkQualifier
|> get_optional_or_default [],
visibility = atts |> visibility,
participant_id = tree |> get_one "UML:AssociationEnd.participant"
|> xmiidref
}
end
(*handle IllFormed msg => error ("in mkAssociationEnd: "^msg)*)
@ -211,17 +449,18 @@ fun mkAssociationEndFromAssociationClass association tree :XMI.AssociationEnd =
(* class itsel, we simply add a suffix *)
xmiid = (atts |> xmiid)^"_aend",
(* rep_parser already takes care of naming the association end *)
name = NONE,
association = association,
isNavigable = true,
ordering = XMI_DataTypes.Unordered,
aggregation = XMI_DataTypes.Aggregate,
targetScope = XMI_DataTypes.InstanceScope,
multiplicity = [(0,~1)] (* FIX: is this always the correct multiplicity? *),
changeability = XMI_DataTypes.Changeable,
visibility = XMI_DataTypes.public,
participant_id = atts |> xmiid
}
name = NONE,
association = association,
isNavigable = true,
ordering = XMI_DataTypes.Unordered,
aggregation = XMI_DataTypes.Aggregate,
targetScope = XMI_DataTypes.InstanceScope,
multiplicity = [(0,~1)] (* FIX: is this always the correct multiplicity? *),
qualifier = [],
changeability = XMI_DataTypes.Changeable,
visibility = XMI_DataTypes.public,
participant_id = atts |> xmiid
}
end
(* FIX: this is a hack to handle AssociationClasses. *)
@ -243,179 +482,23 @@ fun mkAssociationFromAssociationClass tree =
fun mkAssociation tree =
let
val _ = trace function_calls "mkAssociation\n"
val atts = tree |> assert "UML:Association" |> attributes
val id = atts |> xmiid
(* FIXME: empty string is returned as (SOME "") instead of NONE *)
val name_tmp = atts |> optional_value_of "name"
val name = if (isSome name_tmp) andalso ((valOf name_tmp) = "")
then
NONE
else
name_tmp
val _ = trace function_calls "mkAssociation\n"
val atts = tree |> assert "UML:Association" |> attributes
val id = atts |> xmiid
(* FIXME: empty string is returned as (SOME "") instead of NONE *)
val name_tmp = atts |> optional_value_of "name"
val name = if (isSome name_tmp) andalso ((valOf name_tmp) = "")
then NONE
else name_tmp
in
{ xmiid = id,
name = name,
connection = tree |> get_many "UML:Association.connection"
|> map (mkAssociationEnd id)
}
{ xmiid = id,
name = name,
connection = tree |> get_many "UML:Association.connection"
|> map (mkAssociationEnd id)
}
end
(* 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
(* find the type of an OCl sub-expression *)
fun expression_type tree = tree |> xmiidref_to "OCL.Expressions.OclExpression.type"
handle _ => "DummyT"
(* hack: return a reference to a dummy*)
(* type if the real type is not found *)
(* this is a hack. This will still throw an exception in xmi2mdr, because the *)
(* expression_type should be the xmiid of oclLib.Boolean, which we do not know *)
val triv_expr = XMI.LiteralExp {symbol = "true",
expression_type = "bool" }
(* FIX: this is only a dummy implementation *)
fun mkCollectionLiteralPart x = (xmiidref x)
fun mkLiteralExp string tree = XMI.LiteralExp
{ symbol = tree |> attributes |> value_of string,
expression_type = tree |> expression_type
}
fun mkOCLExpression (tree as Node(("UML15OCL.Expressions.BooleanLiteralExp",atts),_)) =
mkLiteralExp "booleanSymbol" tree
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.IntegerLiteralExp",atts),_)) =
mkLiteralExp "integerSymbol" tree
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.StringLiteralExp",atts),_)) =
mkLiteralExp "stringSymbol" tree
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.RealLiteralExp",atts),_)) =
mkLiteralExp "realSymbol" tree
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.CollectionLiteralExp",atts),_))
= XMI.CollectionLiteralExp
{ parts = nil,
(* map mkCollectionLiteralPart (follow "OCL.Expressions.CollectionLiteralExp.parts" trees), *)
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.OperationCallExp",atts),_))
= XMI.OperationCallExp
{ source = (tree |> get_one "OCL.Expressions.PropertyCallExp.source"
|> mkOCLExpression)
(* This hack is necessary to support TYPE::allInstances() as parsed *)
(* by dresden-ocl. *)
handle ex =>
XMI.LiteralExp
{ symbol = "",
expression_type = tree |> get_one "OCL.Expressions.FeatureCallExp.srcType"
|> xmiidref
},
arguments = tree |> get "OCL.Expressions.OperationCallExp.arguments"
|> map mkOCLExpression,
referredOperation = tree |> xmiidref_to "OCL.Expressions.OperationCallExp.referredOperation",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.OclOperationWithTypeArgExp",atts),_))
= XMI.OperationWithTypeArgExp
{ source = tree |> get_one "OCL.Expressions.PropertyCallExp.source"
|> mkOCLExpression,
name = atts |> name,
typeArgument = tree |> xmiidref_to "OCL.Expressions.OclOperationWithTypeArgExp.typeArgument",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.AttributeCallExp",atts),_))
= XMI.AttributeCallExp
{ source = tree |> get_one "OCL.Expressions.PropertyCallExp.source"
|> mkOCLExpression,
referredAttribute = tree |> xmiidref_to
"OCL.Expressions.AttributeCallExp.referredAttribute",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.AssociationEndCallExp",atts),_))
= XMI.AssociationEndCallExp
{ source = tree |> get_one "OCL.Expressions.PropertyCallExp.source"
|> mkOCLExpression,
referredAssociationEnd = tree |> xmiidref_to
"OCL.Expressions.AssociationEndCallExp.referredAssociationEnd",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.AssociationClassCallExp",atts),_))
= error ("AssociationClassCallExp is not yet implemented"^some_id tree)
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.VariableExp",atts),_))
= XMI.VariableExp
{ referredVariable = tree |> xmiidref_to
"OCL.Expressions.VariableExp.referredVariable",
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.IfExp",atts),_))
= XMI.IfExp
{ condition = tree |> get_one "OCL.Expressions.IfExp.condition"
|> mkOCLExpression,
thenExpression = tree |> get_one "OCL.Expressions.IfExp.thenExpression"
|> mkOCLExpression,
elseExpression = tree |> get_one "OCL.Expressions.IfExp.elseExpression"
|> mkOCLExpression,
expression_type = tree |> expression_type }
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.LetExp",atts),_))
= XMI.LetExp
{ variable = let val vard = tree |> get_one "OCL.Expressions.LetExp.variable"
val atts = vard |> attributes
in
{ xmiid = atts |> xmiid,
name = atts |> name,
declaration_type = vard |> xmiidref_to
"OCL.Expressions.VariableDeclaration.type",
init = vard |> get_one
"OCL.Expressions.VariableDeclaration.initExpression"
|> mkOCLExpression
|> SOME
}
end,
inExpression = tree |> get_one "OCL.Expressions.LetExp.in"
|> mkOCLExpression,
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.IterateExp",atts),_))
= XMI.IterateExp
{ result = tree |> get_one "OCL.Expressions.IterateExp.result"
|> mkVariableDec,
iterators = tree |> get_many "OCL.Expressions.LoopExp.iterators"
|> map mkVariableDec,
body = tree |> get_one "OCL.Expressions.LoopExp.body"
|> mkOCLExpression,
source = tree |> get_one "OCL.Expressions.PropertyCallExp.source"
|> mkOCLExpression,
expression_type = tree |> expression_type
}
| mkOCLExpression (tree as Node(("UML15OCL.Expressions.IteratorExp",atts),_))
= XMI.IteratorExp
{ name = atts |> name,
iterators = tree |> get_many "OCL.Expressions.LoopExp.iterators"
|> map mkVariableDec,
body = tree |> get_one "OCL.Expressions.LoopExp.body"
|> mkOCLExpression,
source = tree |> get_one "OCL.Expressions.PropertyCallExp.source"
|> mkOCLExpression,
expression_type = tree |> expression_type
}
| mkOCLExpression tree =
error ("unknown OCLExpression type \""^(tagname tree)^"\""^some_id tree^".")
and mkVariableDec vtree =
let val atts = vtree |> assert "UML15OCL.Expressions.VariableDeclaration"
|> attributes
in
{ xmiid = atts |> xmiid,
name = atts |> name,
init = vtree |> get_optional "OCL.Expressions.VariableDeclaration.initExpression"
|> map_optional mkOCLExpression,
declaration_type = vtree |> get_one "OCL.Expressions.VariableDeclaration.type"
|> xmiidref
}
end
(* handle IllFormed msg => error ("in mkVariableDec: "^msg)*)
val filterAssociations = filter "UML:Association"
val filterAssociationClasses = filter "UML:AssociationClass"
@ -512,50 +595,6 @@ fun mkOperation tree =
end
(*handle IllFormed msg => error ("in mkOperation: "^msg)*)
fun mkTaggedValue tree =
let val atts = tree |> assert "UML:TaggedValue" |> attributes
in
{ xmiid = atts |> xmiid,
dataValue= tree |> find_child "UML:TaggedValue.dataValue"
|> children
|> map text
|> String.concat,
tag_type = tree |> get_one "UML:TaggedValue.type"
|> assert "UML:TagDefinition"
|> xmiidref
}
end
(*handle IllFormed msg => error ("in mkTaggedValue: "^msg)*)
fun mkAttribute tree =
let val atts = tree |> assert "UML:Attribute" |> attributes
in
{ xmiid = atts |> xmiid,
name = atts |> name,
visibility = atts |> visibility,
changeability = atts |> changeability,
ordering = atts |> ordering,
initialValue = tree |> get_optional "UML:Attribute.initialValue"
|> map_optional (get_optional "OCL.Expressions.ExpressionInOcl.bodyExpression")
|> Option.join
|> map_optional mkOCLExpression,
type_id = tree |> get_optional "UML:StructuralFeature.type"
|> map_optional xmiidref
|> get_optional_or_default "",
multiplicity = tree |> get_optional "UML:StructuralFeature.multiplicity"
|> map_optional mkMultiplicity
|> get_optional_or_default [(1,1)],
targetScope = atts |> target_scope,
ownerScope = atts |> owner_scope,
stereotype = tree |> get "UML:ModelElement.stereotype"
|> map xmiidref ,
taggedValue = tree |> get "UML:ModelElement.taggedValue"
|> map mkTaggedValue
}
end
(*handle IllFormed msg => error ("in mkAttribute: "^msg)*)
fun mkTagDefinition tree =
let val atts = tree |> assert "UML:TagDefinition" |> attributes
in

19
su4sml/src/xmltree_helper.sml
View File

@ -56,23 +56,24 @@ structure XmlTreeHelper : sig
val exists : string -> XmlTree.Tree list -> bool
val has_child : string -> XmlTree.Tree -> bool
val value_of : string -> XmlTree.Attribute list -> string
(* val follow : string -> XmlTree.Tree list -> XmlTree.Tree list *)
(* val followM : string -> XmlTree.Tree list -> XmlTree.Tree list *)
(* val skipM : string -> XmlTree.Tree -> XmlTree.Tree list *)
(* val follow : string -> XmlTree.Tree list -> XmlTree.Tree list *)
(* val followM : string -> XmlTree.Tree list -> XmlTree.Tree list *)
(* val skipM : string -> XmlTree.Tree -> XmlTree.Tree list *)
val assert : string -> XmlTree.Tree -> XmlTree.Tree
val is : XmlTree.Tree * string -> bool
(* val follow_all : string -> XmlTree.Tree list -> XmlTree.Tree list list *)
(* val apply_on : string -> (Attribute list -> 'a) -> XmlTree.Tree -> 'a*)
(* val follow_all : string -> XmlTree.Tree list -> XmlTree.Tree list list *)
(* val apply_on : string -> (Attribute list -> 'a) -> XmlTree.Tree -> 'a*)
val some_id : XmlTree.Tree -> string
val some_id': XmlTree.Attribute list -> string
end =
struct
struct
open library
open XmlTree
infix 1 |>
fun filter string trees = List.filter (fn x => string = tagname x)
trees
fun filter string trees = List.filter (fn x => string = tagname x) trees
fun filter_children string tree = filter string (node_children tree)