(***************************************************************************** * su4sml --- a SML repository for managing (Secure)UML/OCL models * http://projects.brucker.ch/su4sml/ * * rep_core.sml --- core repository datastructures for su4sml * This file is part of su4sml. * * Copyright (c) 2005-2007, ETH Zurich, Switzerland * * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are * met: * * * Redistributions of source code must retain the above copyright * notice, this list of conditions and the following disclaimer. * * * Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials provided * with the distribution. * * * Neither the name of the copyright holders nor the names of its * contributors may be used to endorse or promote products derived * from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ******************************************************************************) (* $Id$ *) (** Repository datatypes and helper functions for classifiers. *) signature REP_CORE = sig type Scope type Visibility type operation = { name : string, precondition : (string option * Rep_OclTerm.OclTerm) list, postcondition : (string option * Rep_OclTerm.OclTerm) list, body : (string option * Rep_OclTerm.OclTerm) list, arguments : (string * Rep_OclType.OclType) list, result : Rep_OclType.OclType, isQuery : bool, scope : Scope, visibility : Visibility } type associationend = {name : string, aend_type : Rep_OclType.OclType, multiplicity: (int * int) list, ordered: bool, visibility: Visibility, init: Rep_OclTerm.OclTerm option } type attribute = { name : string, attr_type : Rep_OclType.OclType, visibility : Visibility, scope: Scope, stereotypes: string list, init : Rep_OclTerm.OclTerm option } datatype Classifier = Class of { name : Rep_OclType.OclType, parent : Rep_OclType.OclType option, attributes : attribute list, operations : operation list, associationends : associationend list, invariant : (string option * Rep_OclTerm.OclTerm) list, stereotypes : string list, interfaces : Rep_OclType.OclType list, thyname : string option, activity_graphs : Rep_ActivityGraph.ActivityGraph list } | Interface of (* not supported yet *) { name : Rep_OclType.OclType, parents : Rep_OclType.OclType list, operations : operation list, stereotypes : string list, invariant : (string option * Rep_OclTerm.OclTerm) list, thyname : string option } | Enumeration of (* not really supported yet? *) { name : Rep_OclType.OclType, parent : Rep_OclType.OclType option, operations : operation list, literals : string list, invariant : (string option * Rep_OclTerm.OclTerm) list, stereotypes : string list, interfaces : Rep_OclType.OclType list, thyname : string option } | Primitive of (* not really supported yet *) { name : Rep_OclType.OclType, parent : Rep_OclType.OclType option, operations : operation list, associationends : associationend list, invariant : (string option * Rep_OclTerm.OclTerm) list, stereotypes : string list, interfaces : Rep_OclType.OclType list, thyname : string option } | Template of { parameter : Rep_OclType.OclType, classifier : Classifier } val OclAnyC : Classifier val normalize : Classifier -> Classifier val normalize_init : Classifier -> Classifier val name_of : Classifier -> Rep_OclType.Path val type_of : Classifier -> Rep_OclType.OclType val package_of : Classifier -> Rep_OclType.Path val short_name_of : Classifier -> string val parent_name_of : Classifier -> Rep_OclType.Path val parent_interface_names_of : Classifier -> Rep_OclType.Path list val parent_package_of : Classifier -> Rep_OclType.Path val short_parent_name_of : Classifier -> string val parent_interfaces_of : Classifier -> Rep_OclType.OclType list val thy_name_of : Classifier -> string val attributes_of : Classifier -> attribute list val associationends_of: Classifier -> associationend list val operations_of : Classifier -> operation list val invariant_of : Classifier -> (string option * Rep_OclTerm.OclTerm) list val stereotypes_of : Classifier -> string list val string_of_path : string list -> string val activity_graphs_of: Classifier -> Rep_ActivityGraph.ActivityGraph list val arguments_of_op : operation -> (string * Rep_OclType.OclType) list val precondition_of_op : operation -> (string option * Rep_OclTerm.OclTerm) list val body_of_op : operation -> (string option * Rep_OclTerm.OclTerm) list val result_of_op : operation -> Rep_OclType.OclType val postcondition_of_op : operation -> (string option * Rep_OclTerm.OclTerm) list val name_of_op : operation -> string val mangled_name_of_op : operation -> string val class_of : Rep_OclType.Path -> Classifier list -> Classifier val parent_of : Classifier -> Classifier list -> Classifier val parents_of : Classifier -> Classifier list -> Rep_OclType.Path list val operation_of : Classifier list -> Rep_OclType.Path -> operation option val topsort_cl : Classifier list -> Classifier list val connected_classifiers_of : Classifier -> Classifier list -> Classifier list val assoc_to_attr_type : associationend -> Rep_OclType.OclType val update_thyname : string -> Classifier -> Classifier val update_invariant : (string option * Rep_OclTerm.OclTerm) list -> Classifier -> Classifier val update_operations : operation list -> Classifier -> Classifier val update_precondition : (string option * Rep_OclTerm.OclTerm) list -> operation -> operation val update_postcondition : (string option * Rep_OclTerm.OclTerm) list -> operation -> operation end structure Rep_Core : REP_CORE = struct open library open Rep_OclType type Visibility = XMI_DataTypes.VisibilityKind type Scope = XMI_DataTypes.ScopeKind type operation = { name : string, precondition : (string option * Rep_OclTerm.OclTerm) list, postcondition : (string option * Rep_OclTerm.OclTerm) list, body : (string option * Rep_OclTerm.OclTerm) list, arguments : (string * Rep_OclType.OclType) list, result : Rep_OclType.OclType, isQuery : bool, visibility : Visibility, scope : Scope } type associationend = { name : string, aend_type : Rep_OclType.OclType, multiplicity : (int*int) list, visibility : Visibility, ordered : bool, init : Rep_OclTerm.OclTerm option } type attribute = { name : string, attr_type : Rep_OclType.OclType, visibility : Visibility, scope : Scope, stereotypes : string list, init : Rep_OclTerm.OclTerm option } datatype Classifier = Class of { name : Rep_OclType.OclType, parent : Rep_OclType.OclType option, attributes : attribute list, operations : operation list, associationends : associationend list, invariant : (string option * Rep_OclTerm.OclTerm) list, stereotypes : string list, interfaces : Rep_OclType.OclType list, thyname : string option, activity_graphs : Rep_ActivityGraph.ActivityGraph list } | Interface of (* not supported yet *) { name : Rep_OclType.OclType, parents : Rep_OclType.OclType list, operations : operation list, stereotypes : string list, invariant : (string option * Rep_OclTerm.OclTerm) list, thyname : string option } | Enumeration of (* not really supported yet? *) { name : Rep_OclType.OclType, parent : Rep_OclType.OclType option, operations : operation list, literals : string list, invariant : (string option * Rep_OclTerm.OclTerm) list, stereotypes : string list, interfaces : Rep_OclType.OclType list, thyname : string option } | Primitive of (* not really supported yet *) { name : Rep_OclType.OclType, parent : Rep_OclType.OclType option, operations : operation list, associationends : associationend list, invariant : (string option * Rep_OclTerm.OclTerm) list, stereotypes : string list, interfaces : Rep_OclType.OclType list, thyname : string option } | Template of { parameter : Rep_OclType.OclType, classifier : Classifier } (* convert an association end into the corresponding collection type *) fun assoc_to_attr_type {name,aend_type,multiplicity,ordered,visibility,init} = case multiplicity of [(0,1)] => aend_type | [(1,1)] => aend_type | _ =>if ordered then Rep_OclType.Sequence aend_type (* OrderedSet? *) else Rep_OclType.Set aend_type (* convert an association end into an attribute of the *) (* corresponding collection type *) fun assoc_to_attr (assoc:associationend) = {name = #name assoc, attr_type = assoc_to_attr_type assoc, visibility = #visibility assoc, scope = XMI.InstanceScope, stereotypes = nil, init = #init assoc} (* convert a multiplicity range into an invariant of the form *) (* size > lowerBound and size < upperBound ) *) fun range_to_inv cls_name aend (a,b) = let val cls = Rep_OclType.Classifier cls_name val attr_type = assoc_to_attr_type aend val attr_name = cls_name@[#name aend] val literal_a = Rep_OclTerm.Literal (Int.toString a, Rep_OclType.Integer) val literal_b = Rep_OclTerm.Literal (Int.toString b, Rep_OclType.Integer) val self = Rep_OclTerm.Variable ("self",cls) val attribute = Rep_OclTerm.AttributeCall (self,cls,attr_name,attr_type) val attribute_size = Rep_OclTerm.OperationCall (attribute,attr_type, ["oclLib","Collection","size"],[], Rep_OclType.Integer) val lower_bound = Rep_OclTerm.OperationCall (attribute_size,Rep_OclType.Integer, ["oclLib","Real",">="], [(literal_a,Rep_OclType.Integer)],Rep_OclType.Boolean) val upper_bound = Rep_OclTerm.OperationCall (attribute_size,Rep_OclType.Integer, ["oclLib","Real","<="], [(literal_b,Rep_OclType.Integer)],Rep_OclType.Boolean) val equal = Rep_OclTerm.OperationCall (attribute_size,Rep_OclType.Integer, ["oclLib","OclAny","="], [(literal_a,Rep_OclType.Integer)],Rep_OclType.Boolean) in if a = b then equal else if b = ~1 then lower_bound else Rep_OclTerm.OperationCall (lower_bound,Rep_OclType.Boolean, ["oclLib","Boolean","and"], [(upper_bound,Rep_OclType.Boolean)], Rep_OclType.Boolean) end (* calculate the invariants of an association end: *) (* 1. multiplicity constraints *) (* 2. consistency constraints between opposing association ends *) (* i.e., A.b.a->includes(A) *) (* FIXME: 2. is not implemented yet... *) fun assoc_to_inv cls_name (aend:associationend) = let val inv_name = "multconstraint_for_aend_"^(#name aend) val range_constraints = case (#multiplicity aend) of [(0,1)] => [] | [(1,1)] => let val attr_name = cls_name@[#name aend] val attr_type = assoc_to_attr_type aend val cls = Rep_OclType.Classifier cls_name val self = Rep_OclTerm.Variable ("self",cls) val attribute = Rep_OclTerm.AttributeCall (self,cls,attr_name,attr_type) in [Rep_OclTerm.OperationCall (attribute,attr_type, ["oclIsDefined"],[], Rep_OclType.Boolean)] end | _ => map (range_to_inv cls_name aend) (#multiplicity aend) fun ocl_or (x,y) = Rep_OclTerm.OperationCall (x,Rep_OclType.Boolean, ["oclLib","Boolean","or"], [(y,Rep_OclType.Boolean)],Rep_OclType.Boolean) in if range_constraints = [] then (SOME inv_name, Rep_OclTerm.Literal ("true",Rep_OclType.Boolean)) else (SOME inv_name, foldr1 ocl_or range_constraints) end (* convert association ends into attributes + invariants *) fun normalize (Class {name,parent,attributes,operations,associationends,invariant, stereotypes,interfaces,thyname,activity_graphs}) = Class {name = name, parent = parent, attributes = (append (map assoc_to_attr associationends) attributes), operations = operations, associationends = nil, invariant = append (map (assoc_to_inv (path_of_OclType name)) associationends) invariant, stereotypes = stereotypes, interfaces = interfaces, thyname = thyname, activity_graphs=activity_graphs} | normalize (Primitive p) = (* Primitive's do not have attributes, so we have to convert *) (* them into Classes... *) if (#associationends p) = [] then Primitive p else normalize (Class {name = #name p, parent = #parent p, attributes=[], operations = #operations p, invariant = #invariant p, associationends = #associationends p, stereotypes = #stereotypes p, interfaces = #interfaces p, thyname = #thyname p, activity_graphs=nil}) | normalize c = c fun rm_init_attr (attr:attribute) = { name = #name attr, attr_type = #attr_type attr, visibility = #visibility attr, scope = #scope attr, stereotypes = #stereotypes attr, init = NONE }:attribute fun init_to_inv cls_name (attr:attribute) = case (#init attr) of NONE => (SOME ("init_"^(#name attr)), Rep_OclTerm.Literal ("true",Rep_OclType.Boolean)) | SOME(init) => let val attr_name = cls_name@[#name attr] val attr_type = #attr_type attr val cls = Rep_OclType.Classifier cls_name val self = Rep_OclTerm.Variable ("self",cls) val attribute = Rep_OclTerm.AttributeCall (self,cls,attr_name,attr_type) in (SOME ("init_"^(#name attr)), Rep_OclTerm.OperationCall (Rep_OclTerm.OperationCall (self,cls, ["oclLib","OclAny","oclIsNew"],[],Rep_OclType.Boolean),Rep_OclType.Boolean, ["oclLib","Boolean","implies"], [(Rep_OclTerm.OperationCall (attribute, attr_type,["oclLib","OclAny","="], [(init,attr_type)],Rep_OclType.Boolean),Rep_OclType.Boolean)], Rep_OclType.Boolean) ) end fun normalize_init (Class {name,parent,attributes,operations,associationends,invariant, stereotypes,interfaces,thyname,activity_graphs}) = Class {name = name, parent = parent, attributes = (map rm_init_attr attributes), operations = operations, associationends = nil, invariant = append (map (init_to_inv (path_of_OclType name)) attributes) invariant, stereotypes = stereotypes, interfaces = interfaces, thyname = thyname, activity_graphs=activity_graphs} | normalize_init c = c val OclAnyC = Class{name=Rep_OclType.OclAny,parent=NONE,attributes=[], operations=[], interfaces=[], invariant=[],stereotypes=[], associationends=[], thyname=NONE, activity_graphs=nil} fun string_of_path (path:Rep_OclType.Path) = case path of [] => "" | p => foldr1 (fn (a,b) => a^"."^b) p fun update_thyname tname (Class{name,parent,attributes,operations,invariant, stereotypes,interfaces,associationends,activity_graphs,...}) = Class{name=name,parent=parent,attributes=attributes,operations=operations, associationends=associationends,invariant=invariant,stereotypes=stereotypes, interfaces=interfaces,thyname=(SOME tname),activity_graphs=activity_graphs } | update_thyname tname (Interface{name,parents,operations,stereotypes,invariant,...}) = Interface{name=name,parents=parents,operations=operations,stereotypes=stereotypes, invariant=invariant,thyname=(SOME tname)} | update_thyname tname (Enumeration{name,parent,operations,literals,invariant, stereotypes,interfaces,...}) = Enumeration{name=name,parent=parent,operations=operations,literals=literals, invariant=invariant,stereotypes=stereotypes,interfaces=interfaces, thyname=(SOME tname)} | update_thyname tname (Primitive{name,parent,operations,associationends,invariant, stereotypes,interfaces,...}) = Primitive{name=name,parent=parent,operations=operations, associationends=associationends,invariant=invariant, stereotypes=stereotypes,interfaces=interfaces,thyname=(SOME tname)} fun update_invariant invariant' (Class{name,parent,attributes,operations,invariant, stereotypes,interfaces,associationends,activity_graphs,thyname}) = Class{name=name,parent=parent,attributes=attributes,operations=operations, associationends=associationends,invariant=invariant',stereotypes=stereotypes, interfaces=interfaces,thyname=thyname,activity_graphs=activity_graphs } | update_invariant invariant' (Interface{name,parents,operations,stereotypes,invariant,thyname}) = Interface{name=name,parents=parents,operations=operations,stereotypes=stereotypes, invariant=invariant',thyname=thyname} | update_invariant invariant' (Enumeration{name,parent,operations,literals,invariant, stereotypes,interfaces,thyname}) = Enumeration{name=name,parent=parent,operations=operations,literals=literals, invariant=invariant',stereotypes=stereotypes,interfaces=interfaces, thyname=thyname} | update_invariant invariant' (Primitive{name,parent,operations,associationends,invariant, stereotypes,interfaces,thyname}) = Primitive{name=name,parent=parent,operations=operations, associationends=associationends,invariant=invariant', stereotypes=stereotypes,interfaces=interfaces,thyname=thyname} fun update_operations operations' (Class{name,parent,attributes,invariant,operations, stereotypes,interfaces,associationends,activity_graphs,thyname}) = Class{name=name,parent=parent,attributes=attributes,invariant=invariant, associationends=associationends,operations=operations',stereotypes=stereotypes, interfaces=interfaces,thyname=thyname,activity_graphs=activity_graphs } | update_operations operations' (Interface{name,parents,invariant,stereotypes,operations,thyname}) = Interface{name=name,parents=parents,invariant=invariant,stereotypes=stereotypes, operations=operations',thyname=thyname} | update_operations operations' (Enumeration{name,parent,invariant,literals,operations, stereotypes,interfaces,thyname}) = Enumeration{name=name,parent=parent,invariant=invariant,literals=literals, operations=operations',stereotypes=stereotypes,interfaces=interfaces, thyname=thyname} | update_operations operations' (Primitive{name,parent,invariant,associationends,operations, stereotypes,interfaces,thyname}) = Primitive{name=name,parent=parent,invariant=invariant, associationends=associationends,operations=operations', stereotypes=stereotypes,interfaces=interfaces,thyname=thyname} fun update_precondition pre' ({name,precondition,postcondition,body,arguments,result,isQuery,scope,visibility}:operation) = ({name=name,precondition=pre',postcondition=postcondition, arguments=arguments,body=body,result=result,isQuery=isQuery,scope=scope, visibility=visibility}:operation) fun update_postcondition post' ({name,precondition,postcondition,body,arguments,result,isQuery,scope,visibility}:operation) = ({name=name,precondition=precondition,postcondition=post', arguments=arguments,body=body,result=result,isQuery=isQuery,scope=scope, visibility=visibility}:operation) fun type_of (Class{name,...}) = name | type_of (Interface{name,...}) = name | type_of (Enumeration{name,...}) = name | type_of (Primitive{name,...}) = name | type_of (Template{classifier,...}) = type_of classifier fun name_of (Class{name,...}) = path_of_OclType name | name_of (Interface{name,...}) = path_of_OclType name | name_of (Enumeration{name,...}) = path_of_OclType name | name_of (Primitive{name,...}) = path_of_OclType name | name_of (Template{classifier,...}) = name_of classifier fun short_name_of C = case (name_of C) of [] => error "in Rep.short_name_of: empty type" | p => (hd o rev) p fun stereotypes_of (Class{stereotypes,...}) = stereotypes | stereotypes_of (Interface{stereotypes,...}) = stereotypes | stereotypes_of (Enumeration{stereotypes,...}) = stereotypes | stereotypes_of (Primitive{stereotypes,...}) = stereotypes | stereotypes_of (Template _) = error "in Rep.stereotypes_of: \ \unsupported argument type Template" fun package_of (Class{name,...}) = if (length (path_of_OclType name)) > 1 then take (((length (path_of_OclType name)) -1), (path_of_OclType name)) else [] | package_of (Interface{name,...}) = if (length (path_of_OclType name)) > 1 then take (((length (path_of_OclType name)) -1), (path_of_OclType name)) else [] | package_of (Enumeration{name,...}) = if (length (path_of_OclType name)) > 1 then take (((length (path_of_OclType name)) -1), (path_of_OclType name)) else [] | package_of (Primitive{name,...}) = if (length (path_of_OclType name)) > 1 then take (((length (path_of_OclType name)) -1), (path_of_OclType name)) else [] | package_of (Template{classifier,...}) = package_of classifier fun parent_name_of (C as Class{parent,...}) = (case parent of NONE => name_of OclAnyC | SOME p => path_of_OclType p ) | parent_name_of (Interface{...}) = error "in Rep.parent_name_of: \ \unsupported argument type Interface" | parent_name_of (E as Enumeration{parent,...}) = (case parent of NONE => error ("in Rep.parent_name_of: Enumeration "^ ((string_of_path o name_of) E) ^" has no parent") | SOME p => path_of_OclType p ) | parent_name_of (D as Primitive{parent,...}) = (case parent of NONE => name_of OclAnyC (* error ("Primitive "^((string_of_path o name_of) D)^" has no parent") *) | SOME p => path_of_OclType p ) | parent_name_of (Template _) = error "in Rep.parent_name_of: \ \unsupported argument type Template" fun short_parent_name_of C = case (parent_name_of C) of [] => error "in Rep.short_parent_name_of: empty type" | p => (hd o rev) p fun parent_package_of (Class{parent,...}) = (case parent of NONE => package_of OclAnyC | SOME q => let val p = path_of_OclType q in if (length p) > 1 then (take (((length p) -1),p)) else [] end) | parent_package_of (Interface{...}) = error "in Rep.parent_package_of: unsupported argument type Interface" | parent_package_of (E as Enumeration{parent,...}) = (case parent of NONE => error ("in Rep.parent_package_of: Enumeration "^ (string_of_path o name_of) E^ " has no parent") | SOME q => let val p = path_of_OclType q in if (length p) > 1 then (take (((length p) -1),p)) else [] end ) | parent_package_of (Primitive{parent,...}) = (case parent of NONE => package_of OclAnyC (* NONE => error "Primitive has no parent" *) | SOME q => let val p = path_of_OclType q in if (length p) > 1 then (take (((length p) -1),p)) else [] end) | parent_package_of (Template{...}) = error "in Rep.parent_package_of: unsupported argument type Template" (* Get parent interfaces of a Classifier. *) fun parent_interfaces_of (Interface{parents,...}) = parents | parent_interfaces_of (Class{interfaces,...}) = interfaces | parent_interfaces_of (Enumeration{interfaces,...}) = interfaces | parent_interfaces_of (Primitive{interfaces,...}) = interfaces | parent_interfaces_of (Template{...}) = error "parent_interfaces_of