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 * 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> * Copyright (C) 2001-2005 Achim D. Brucker <brucker@inf.ethz.ch>
* Burkhart Wolff <bwolff@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, fun update_thyname tname (Class{name,parent,attributes,operations,invariant,
stereotypes,interfaces,associationends,activity_graphs,...}) stereotypes,interfaces,associationends,activity_graphs,...})
= Class{name=name,parent=parent,attributes=attributes,operations=operations, = Class{name=name,parent=parent,attributes=attributes,operations=operations,
associationends=associationends,invariant=invariant,stereotypes=stereotypes, associationends=associationends,invariant=invariant,stereotypes=stereotypes,
interfaces=interfaces,thyname=(SOME tname),activity_graphs=activity_graphs } interfaces=interfaces,thyname=(SOME tname),activity_graphs=activity_graphs }
| update_thyname tname (Interface{name,parents,operations,stereotypes,invariant,...}) | update_thyname tname (Interface{name,parents,operations,stereotypes,invariant,...})
= Interface{name=name,parents=parents,operations=operations,stereotypes=stereotypes, = Interface{name=name,parents=parents,operations=operations,stereotypes=stereotypes,
invariant=invariant,thyname=(SOME tname)} 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, = Primitive{name=name,parent=parent,operations=operations,
associationends=associationends,invariant=invariant, associationends=associationends,invariant=invariant,
stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)} stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)}
fun type_of (Class{name,...}) = name fun type_of (Class{name,...}) = name
| type_of (Interface{name,...}) = name | type_of (Interface{name,...}) = name
| type_of (Enumeration{name,...}) = name | type_of (Enumeration{name,...}) = name
| type_of (Primitive{name,...}) = name | type_of (Primitive{name,...}) = name
| type_of (Template{classifier,...}) = type_of classifier | type_of (Template{classifier,...}) = type_of classifier
fun name_of (Class{name,...}) = path_of_OclType name fun name_of (Class{name,...}) = path_of_OclType name
| name_of (Interface{name,...}) = path_of_OclType name | name_of (Interface{name,...}) = path_of_OclType name
| name_of (Enumeration{name,...}) = path_of_OclType name | name_of (Enumeration{name,...}) = path_of_OclType name
| name_of (Primitive{name,...}) = path_of_OclType name | name_of (Primitive{name,...}) = path_of_OclType name
| name_of _ = error "no name represenation for this classifier" | name_of _ = error "in Rep.name_of: Classifier has no name represenation"
fun short_name_of C = case (name_of C) of 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 | p => (hd o rev) p
fun stereotypes_of (Class{stereotypes,...}) = stereotypes fun stereotypes_of (Class{stereotypes,...}) = stereotypes
| stereotypes_of (Interface{stereotypes,...}) = stereotypes | stereotypes_of (Interface{stereotypes,...}) = stereotypes
| stereotypes_of (Enumeration{stereotypes,...}) = stereotypes | stereotypes_of (Enumeration{stereotypes,...}) = stereotypes
| stereotypes_of (Primitive{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 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 [] else []
| package_of (Interface{name,...}) = if (length (path_of_OclType name)) > 1 | 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 [] else []
| package_of (Enumeration{name,...}) = if (length (path_of_OclType name)) > 1 | 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 [] else []
| package_of (Primitive{name,...}) = if (length (path_of_OclType name)) > 1 | 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 [] else []
| package_of (Template{classifier,...}) = package_of classifier | package_of (Template{classifier,...}) = package_of classifier
fun parent_name_of (C as Class{parent,...}) = fun parent_name_of (C as Class{parent,...}) =
(case parent of NONE => name_of OclAnyC (case parent of NONE => name_of OclAnyC
|SOME p => path_of_OclType p ) | SOME p => path_of_OclType p )
| parent_name_of (Interface{...}) = | parent_name_of (Interface{...}) = error "in Rep.parent_name_of: \
error "parent_name_of <Interface> not supported" \unsupported argument type Interface"
| parent_name_of (E as Enumeration{parent,...}) = | 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") ^" has no parent")
| SOME p => path_of_OclType p ) | SOME p => path_of_OclType p )
| parent_name_of (D as Primitive{parent,...}) = | parent_name_of (D as Primitive{parent,...}) =
(case parent of NONE => name_of OclAnyC (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 ) | 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 fun short_parent_name_of C = case (parent_name_of C) of
[] => error "empty type in short parent name" [] => error "in Rep.short_parent_name_of: empty type"
| p => (hd o rev) p | p => (hd o rev) p
fun parent_package_of (Class{parent,...}) = fun parent_package_of (Class{parent,...}) =
(case parent of NONE => package_of OclAnyC (case parent of NONE => package_of OclAnyC
| SOME q => let val p = path_of_OclType q in | SOME q => let val p = path_of_OclType q in
if (length p) > 1 if (length p) > 1
then (take (((length p) -1),p)) then (take (((length p) -1),p))
else [] else []
end) end)
| parent_package_of (Interface{...}) = | parent_package_of (Interface{...}) =
error "parent_package_of <Interface> not supported" error "in Rep.parent_package_of: unsupported argument type Interface"
| parent_package_of (Enumeration{parent,...}) = | parent_package_of (E as Enumeration{parent,...}) =
(case parent of NONE => error "Enumeration has no 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 | SOME q => let val p = path_of_OclType q in
if (length p) > 1 if (length p) > 1
then (take (((length p) -1),p)) then (take (((length p) -1),p))
@ -511,29 +521,31 @@ fun parent_package_of (Class{parent,...}) =
then (take (((length p) -1),p)) then (take (((length p) -1),p))
else [] else []
end) end)
| parent_package_of (Template{...}) =
error "in Rep.parent_package_of: unsupported argument type Template"
fun attributes_of (Class{attributes,...}) = attributes fun attributes_of (Class{attributes,...}) = attributes
| attributes_of (Interface{...}) = | attributes_of (Interface{...}) =
error "attributes_of <Interface> not supported" error "in Rep.attributes_of: argument is Interface"
| attributes_of (Enumeration{...}) = | attributes_of (Enumeration{...}) =
error "attributes_of <Enumeration> not supported" error "in Rep.attributes_of: argument is Enumeration"
| attributes_of (Primitive{...}) = [] | attributes_of (Primitive{...}) = []
(* error "attributes_of <Primitive> not supported" *) (* error "attributes_of <Primitive> not supported" *)
| attributes_of (Template{parameter,classifier}) = attributes_of classifier | attributes_of (Template{parameter,classifier}) = attributes_of classifier
fun operations_of (Class{operations,...}) = operations fun operations_of (Class{operations,...}) = operations
| operations_of (Interface{...}) = | operations_of (Interface{operations,...}) = operations
error "operations_of <Interface> not supported" | operations_of (Enumeration{operations,...}) = operations
| operations_of (Enumeration{...}) = | operations_of (Primitive{operations,...}) = operations
error "operations_of <Enumeration> not supported"
| operations_of (Primitive{operations,...}) = operations
| operations_of (Template{parameter,classifier}) = operations_of classifier | operations_of (Template{parameter,classifier}) = operations_of classifier
fun p_invariant_of (Class{invariant,...}) = invariant fun p_invariant_of (Class{invariant,...}) = invariant
| p_invariant_of (Interface{invariant,...}) = invariant | p_invariant_of (Interface{invariant,...}) = invariant
| p_invariant_of (Enumeration{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 fun invariant_of C = case p_invariant_of C of
[] => [(NONE, Rep_OclTerm.Literal ("true",Rep_OclType.Boolean))] [] => [(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 (case thyname of SOME tname => tname
| NONE => error ("Primitive "^((string_of_path o name_of) P)^ | NONE => error ("Primitive "^((string_of_path o name_of) P)^
" has no thyname")) " 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 (* source *)
* OclTerm * OclType (* iterator-body *) * OclTerm * OclType (* iterator-body *)
* OclType (* result type *) * OclType (* result type *)
and CollectionPart = CollectionItem of OclTerm * OclType and CollectionPart = CollectionItem of OclTerm * OclType
| CollectionRange of OclTerm (* first *) | CollectionRange of OclTerm (* first *)
* OclTerm (* last *) * OclTerm (* last *)
* OclType * OclType
end end

24
src/rep_parser.sml
View File

@ -29,11 +29,9 @@ structure RepParser :
val readFile : string -> Rep.Classifier list val readFile : string -> Rep.Classifier list
val test: (string * string list) -> OS.Process.status val test: (string * string list) -> OS.Process.status
(* generic exception if something is wrong *) (* generic exception if something is wrong *)
exception IllFormed of string
end = end =
struct struct
open library open library
exception IllFormed of string
open Xmi_IDTable open Xmi_IDTable
@ -162,7 +160,7 @@ fun transform_expression t (XMI.LiteralExp {symbol,expression_type}) =
find_classifier_type t expression_type find_classifier_type t expression_type
) )
end 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}) = and transform_collection_part t (XMI.CollectionItem {item,expression_type}) =
Rep_OclTerm.CollectionItem (transform_expression t item, Rep_OclTerm.CollectionItem (transform_expression t item,
find_classifier_type t expression_type) 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) = fun transform_constraint t ({xmiid,name,body,...}:XMI.Constraint) =
let val n_name = case name of let val n_name = case name of
(SOME s) => if (s = "") then NONE else (SOME(s)) (SOME s) => if (s = "") then NONE else (SOME(s))
|NONE => NONE | NONE => NONE
in in
(n_name,transform_expression t body) (n_name,transform_expression t body)
handle NotYetImplemented => (print "Warning: in RepParser.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr)) handle ex => (print ("Warning: in RepParser.transform_constraint: \
| IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr)) \Could not parse Constraint: "^General.exnMessage ex^"\n");
| XmiParser.IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr)) (NONE, triv_expr))
end end
fun transform_bodyconstraint result_type t ({xmiid,name,body,...}:XMI.Constraint) = 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)], equal,[(body,body_type)],
Rep_OclType.Boolean)) Rep_OclType.Boolean))
end end
handle NotYetImplemented => (print "Warning: in RepParser.transform_constraint: Something is not yet implemented.\n";(NONE, triv_expr)) handle ex => (print ("Warning: in RepParser.transform_bodyconstraint: \
| IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr)) \Could not parse Constraint: "^General.exnMessage ex^"\n");
| XmiParser.IllFormed msg => (print ("Warning: in RepParser.transform_constraint: Could not parse Constraint: "^msg^"\n");(NONE, triv_expr)) (NONE, triv_expr))
fun transform_parameter t {xmiid,name,kind,type_id} = fun transform_parameter t {xmiid,name,kind,type_id} =
(name, find_classifier_type t 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, outgoing = outgoing,
incoming = incoming, incoming = incoming,
kind = kind } 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 *) (* 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 *) (* operation to be called in order to check whether the guard is true *)
fun transform_guard t (XMI.mk_Guard g) = 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 thyname = NONE
} }
end 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. *) (** 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 | OrderedSet of OrderedSet
| Void of Void | Void of Void
exception IllFormed of string
fun classifier_stereotype_of (Class{stereotype,...}) = stereotype fun classifier_stereotype_of (Class{stereotype,...}) = stereotype
| classifier_stereotype_of (AssociationClass{stereotype,...}) = stereotype | classifier_stereotype_of (AssociationClass{stereotype,...}) = stereotype

55
src/xmi_idtable.sml
View File

@ -26,7 +26,6 @@
structure Xmi_IDTable = structure Xmi_IDTable =
struct struct
open library open library
exception IllFormed of string
datatype HashTableEntry = Package of Rep_OclType.Path datatype HashTableEntry = Package of Rep_OclType.Path
| Type of (Rep_OclType.OclType * | Type of (Rep_OclType.OclType *
@ -51,73 +50,73 @@ fun find_tagdefinition t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of TagDefinition x => x of TagDefinition x => x
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected TagDefinition "^xmiid^" in table") handle Option => error ("expected TagDefinition "^xmiid^" in table")
fun find_state t xmiid = fun find_state t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of State x => x of State x => x
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected State "^xmiid^" in table") handle Option => error ("expected State "^xmiid^" in table")
fun find_event t xmiid = fun find_event t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Event x => x of Event x => x
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected Event "^xmiid^" in table") handle Option => error ("expected Event "^xmiid^" in table")
fun find_transition t xmiid = fun find_transition t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Transition x => x of Transition x => x
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected Transition "^xmiid^" in table") handle Option => error ("expected Transition "^xmiid^" in table")
fun find_dependency t xmiid = fun find_dependency t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Dependency x => x of Dependency x => x
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected Dependency "^xmiid^" in table") handle Option => error ("expected Dependency "^xmiid^" in table")
fun find_generalization t xmiid = fun find_generalization t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Generalization x => x of Generalization x => x
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected Generalization "^xmiid^" in table") handle Option => error ("expected Generalization "^xmiid^" in table")
fun find_stereotype t xmiid = fun find_stereotype t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Stereotype x => x of Stereotype x => x
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected Stereotype "^xmiid^" in table") handle Option => error ("expected Stereotype "^xmiid^" in table")
fun find_attribute t xmiid = fun find_attribute t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Attribute x => x of Attribute x => x
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected Attribute "^xmiid^" in table") handle Option => error ("expected Attribute "^xmiid^" in table")
fun find_operation t xmiid = fun find_operation t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Operation x => x of Operation x => x
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected Operation "^xmiid^" in table") handle Option => error ("expected Operation "^xmiid^" in table")
fun find_type t xmiid = fun find_type t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Type x => x of Type x => x
| _ => raise Option) | _ => 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 = fun find_aends t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of (Type (c,xs,_,_)) => xs of (Type (c,xs,_,_)) => xs
| _ => raise Option) | _ => 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 = fun find_variable_dec t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Variable x => x of Variable x => x
| _ => raise Option) | _ => 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) 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) (case valOf (HashTable.find t xmiid)
of Package path => path of Package path => path
| _ => raise Option) | _ => 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 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 = fun find_constraint t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Constraint c => c of Constraint c => c
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected Constraint "^xmiid^" in table") handle Option => error ("expected Constraint "^xmiid^" in table")
fun find_associationend t xmiid = fun find_associationend t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of AssociationEnd ae => ae of AssociationEnd ae => ae
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected AssociationEnd "^xmiid^" in table") handle Option => error ("expected AssociationEnd "^xmiid^" in table")
fun filter_exists t cs = fun filter_exists t cs =
@ -178,21 +177,21 @@ fun find_classifier t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Type (_,_,c,_) => c of Type (_,_,c,_) => c
| _ => raise Option) | _ => 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 = fun find_classifierInState_classifier t cis_id =
(case valOf (HashTable.find t cis_id) (case valOf (HashTable.find t cis_id)
of ClassifierInState c => find_classifier t c of ClassifierInState c => find_classifier t c
| Type (_,_,c,_) => c | Type (_,_,c,_) => c
| _ => raise Option) | _ => raise Option)
handle Option => raise IllFormed ("expected ClassifierInState " handle Option => error ("expected ClassifierInState "
^cis_id^" in table") ^cis_id^" in table")
fun find_activity_graph_of t xmiid = fun find_activity_graph_of t xmiid =
(case valOf (HashTable.find t xmiid) (case valOf (HashTable.find t xmiid)
of Type (_,_,_,ag) => ag of Type (_,_,_,ag) => ag
| _ => raise Option) | _ => 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 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.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.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) | 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 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) = 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, table (context, Type (c,xs,aes,
XMI.mk_ActivityGraph ag::ags)) XMI.mk_ActivityGraph ag::ags))
| _ => raise Option) | _ => 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); List.app (insert_transition table) (#transitions ag);
insert_state table (#top ag) insert_state table (#top ag)
end 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 "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 "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 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 else Rep_OclType.Classifier path
(* This function is called before the associations are handled, *) (* This function is called before the associations are handled, *)
(* so we do not have to take care of them now... *) (* 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) = | class_taggedvalues_of table (XMI.AssociationClass c) =
map (fn x => (find_tagdefinition table (#tag_type x),#dataValue x)) map (fn x => (find_tagdefinition table (#tag_type x),#dataValue x))
(#taggedValue c) (#taggedValue c)
| class_taggedvalues_of table _ = raise IllFormed "in class_taggedvalues_of: \ | class_taggedvalues_of table _ = error "in class_taggedvalues_of: \
\argument doesn't support tagged values" \argument doesn't support tagged values"
(* returns the value of the given tag *) (* 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) = | class_taggedvalue_of table tag (XMI.AssociationClass c) =
Option.map #2 ((List.find (fn (x,y) => x=tag)) Option.map #2 ((List.find (fn (x,y) => x=tag))
(class_taggedvalues_of table (XMI.AssociationClass c))) (class_taggedvalues_of table (XMI.AssociationClass c)))
| class_taggedvalue_of table tag _ = raise IllFormed "in class_taggedvalues_of: \ | class_taggedvalue_of table tag _ = error "in class_taggedvalues_of: \
\argument doesn't support tagged values" \argument doesn't support tagged values"
(* returns a list of tag-value pairs *) (* returns a list of tag-value pairs *)

92
src/xmi_ocl.sml
View File

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

11
src/xmi_state_machines.sml
View File

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

44
src/xmltree.sml
View File

@ -22,6 +22,7 @@
* 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. * 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
******************************************************************************) ******************************************************************************)
(** datatypes and functions for XML trees. *)
structure XmlTree : sig structure XmlTree : sig
type Attribute type Attribute
type Tag = string * Attribute list type Tag = string * Attribute list
@ -38,11 +39,9 @@ structure XmlTree : sig
val optional_value_of : string -> Attribute list -> string option val optional_value_of : string -> Attribute list -> string option
val value_of : string -> Attribute list -> string val value_of : string -> Attribute list -> string
val has_attribute : string -> Tree -> bool val has_attribute : string -> Tree -> bool
exception IllFormed of string
end = struct end = struct
open library open library
infix 1 |> infix 1 |>
exception IllFormed = Fail
(** A name-value pair. *) (** A name-value pair. *)
type Attribute = (string * string) 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. *) (** Tags consist of element names, and a list of attribute name-value pairs. *)
type Tag = string * Attribute list 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 datatype Tree = Node of Tag * Tree list
| Text of string | Text of string
val filter_nodes = List.filter (fn Node x => true val filter_nodes = List.filter (fn Node x => true
| _ => false) | _ => false)
val filter_text = List.filter (fn Text x => true val filter_text = List.filter (fn Text x => true
| _ => false) | _ => 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"
fun tagname (Node ((elem,atts),trees)) = elem fun tagname (Node ((elem,atts),trees)) = elem
| tagname (Text _) = "" | 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) 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) 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 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_some string trees = (List.find (fn x => string = tagname x) trees)
fun find string trees = valOf (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 " handle Option => error ("in XmlTree.find: no element "^string)
^string)
fun some_id' atts = let val xmiid = atts |> optional_value_of "xmi.id" 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 some_id tree = some_id' (attributes tree)
fun value_of string atts = XmlTree.value_of string atts 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) fun find_child string tree = find string (node_children tree)
handle IllFormed msg => raise IllFormed (msg^" inside node "^ handle ex => error ((General.exnMessage ex)^" inside node "^(tagname tree)^(some_id tree)^"\n")
(tagname tree)^(some_id tree)^"\n")
fun dfs string tree = if tagname tree = string fun dfs string tree = if tagname tree = string
then SOME tree 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 exists string trees = List.exists (fn x => string = tagname x) trees
fun has_child string tree = exists string (node_children tree) fun has_child string tree = exists string (node_children tree)
fun follow string trees = node_children (find string trees) 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 skip string tree = node_children (find_child string tree)
fun followM string trees = follow string trees handle IllFormed msg => nil fun skipM string tree = if has_child string tree
fun skipM string tree = skip string tree handle IllFormed msg => nil then skip string tree
else nil
fun is (tree,string) = string = tagname tree fun is (tree,string) = string = tagname tree
infix 2 is infix 2 is
fun assert string tree = if tree is string then tree 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") (tagname tree)^(some_id tree)^"\n")
(* navigate to association ends with multiplicity 1..* *) (* navigate to association ends with multiplicity 1..* *)

6
src/xmltree_hooks.sml
View File

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