2007-09-26 07:55:59 +00:00
|
|
|
|
(*****************************************************************************
|
2016-10-23 23:35:11 +00:00
|
|
|
|
* su4sml --- an SML repository for managing (Secure)UML/OCL models
|
2007-09-26 07:55:59 +00:00
|
|
|
|
* http://projects.brucker.ch/su4sml/
|
|
|
|
|
*
|
|
|
|
|
* rep_transform.ML ---
|
|
|
|
|
* This file is part of su4sml.
|
|
|
|
|
*
|
|
|
|
|
* Copyright (c) 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: ROOT.ML 6662 2007-07-04 06:41:30Z brucker $ *)
|
|
|
|
|
|
2007-11-16 12:24:41 +00:00
|
|
|
|
|
|
|
|
|
(* (JD) some ideas for medium to long-term refactorings:
|
|
|
|
|
*
|
|
|
|
|
* maybe split up into two seperate structures.
|
|
|
|
|
* Rep_Transfrom for generic transformation functions,
|
|
|
|
|
* and Rep_TransformAssociations for transforming associations
|
|
|
|
|
*
|
|
|
|
|
* I could also imagine types like
|
|
|
|
|
* type modelTransformation = Rep.Model -> Rep.Model
|
|
|
|
|
* type classifierTransformation = Rep.Classifier -> Rep.Classifier
|
|
|
|
|
* ...
|
|
|
|
|
* and functions like
|
|
|
|
|
* forAllClassifiers : classifierTransformation -> modelTransformation
|
|
|
|
|
* forMatchingClassifier : (Rep.Classifier -> Bool) -> classifierTransformation -> modelTransformation
|
|
|
|
|
* ...
|
|
|
|
|
*
|
|
|
|
|
*)
|
|
|
|
|
|
2007-09-26 07:55:59 +00:00
|
|
|
|
signature REP_TRANSFORM =
|
|
|
|
|
sig
|
|
|
|
|
|
2008-01-21 19:34:45 +00:00
|
|
|
|
datatype transformFlag = BinaryAssociationsOnly
|
2008-02-08 00:37:09 +00:00
|
|
|
|
type modelTransformation = Rep.Model * transformFlag list
|
|
|
|
|
-> Rep.Model * transformFlag list
|
2008-01-21 19:34:45 +00:00
|
|
|
|
|
|
|
|
|
|
2007-11-16 12:24:41 +00:00
|
|
|
|
(* (JD) maybe not all of the following functions need to be exported.
|
|
|
|
|
*)
|
|
|
|
|
|
2008-02-08 00:37:09 +00:00
|
|
|
|
val transformClassifiersExt : Rep.Model -> Rep.Model
|
2008-02-08 00:25:51 +00:00
|
|
|
|
val transformClassifiers : Rep.Model -> Rep.Classifier list
|
2007-09-26 07:55:59 +00:00
|
|
|
|
val transformFile : string -> Rep.Model
|
|
|
|
|
|
|
|
|
|
(* transforms *)
|
2008-02-08 00:37:09 +00:00
|
|
|
|
val transformAssociationClasses : Rep.Model -> Rep.Model
|
2008-02-08 00:25:51 +00:00
|
|
|
|
val transformAssociationClassesToNAryAssociations: Rep.Model -> Rep.Model
|
2008-02-08 00:37:09 +00:00
|
|
|
|
val transformQualifiers : Rep.Model -> Rep.Model
|
|
|
|
|
val transformAggregation : Rep.Model -> Rep.Model
|
2008-02-08 00:25:51 +00:00
|
|
|
|
(* remove n-ary associations *)
|
2008-02-08 00:37:09 +00:00
|
|
|
|
val transformNAryAssociations : Rep.Model -> Rep.Model
|
2008-02-08 00:25:51 +00:00
|
|
|
|
val transformNAryAssociationsToAssociationClasses : Rep.Model -> Rep.Model
|
|
|
|
|
(* remove multiplicities *)
|
2008-02-08 00:37:09 +00:00
|
|
|
|
val transformMultiplicities : Rep.Model -> Rep.Model
|
2007-09-26 07:55:59 +00:00
|
|
|
|
|
|
|
|
|
(* helper functions *)
|
2008-01-22 17:29:47 +00:00
|
|
|
|
|
2008-02-08 00:37:09 +00:00
|
|
|
|
val updateClassifiersWithConstraints: Rep.Classifier list ->
|
2008-01-21 19:34:45 +00:00
|
|
|
|
Rep_OclType.OclType ->
|
2008-02-08 00:37:09 +00:00
|
|
|
|
Rep.constraint list ->
|
|
|
|
|
Rep.Classifier list
|
|
|
|
|
val get_association : Rep.association list -> Rep_OclType.Path ->
|
|
|
|
|
Rep.association
|
2007-09-26 07:55:59 +00:00
|
|
|
|
(* only one of the below will remain *)
|
2008-02-08 00:37:09 +00:00
|
|
|
|
val get_other_associationends: Rep.association list -> Rep_OclType.Path ->
|
|
|
|
|
Rep_OclType.OclType -> Rep.associationend list
|
|
|
|
|
val get_associationends : Rep.association list -> Rep_OclType.Path ->
|
|
|
|
|
Rep.associationend list
|
|
|
|
|
val associationends_of : Rep.association -> Rep.associationend list
|
2007-11-11 18:16:10 +00:00
|
|
|
|
|
2007-11-27 21:14:59 +00:00
|
|
|
|
exception NotYetImplemented of string
|
|
|
|
|
exception InvalidArguments of string
|
|
|
|
|
|
2007-09-26 07:55:59 +00:00
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
structure Rep_Transform:REP_TRANSFORM =
|
|
|
|
|
struct
|
|
|
|
|
|
2008-01-21 19:34:45 +00:00
|
|
|
|
datatype transformFlag = BinaryAssociationsOnly
|
|
|
|
|
type modelTransformation = Rep_Core.transform_model * transformFlag list
|
|
|
|
|
-> Rep_Core.transform_model * transformFlag list
|
2008-04-02 13:36:30 +00:00
|
|
|
|
open Rep_Helper
|
2008-01-21 19:34:45 +00:00
|
|
|
|
open Transform_Library
|
2007-09-26 07:55:59 +00:00
|
|
|
|
open Rep_OclTerm
|
|
|
|
|
open Rep_OclType
|
|
|
|
|
open Rep_OclHelper
|
|
|
|
|
open Rep_Core
|
|
|
|
|
|
2008-01-24 21:08:57 +00:00
|
|
|
|
|
2007-09-26 07:55:59 +00:00
|
|
|
|
infix |>>
|
|
|
|
|
fun (x |>> f) = (f x)
|
|
|
|
|
|
|
|
|
|
(** thrown when something is not yet implemented *)
|
2007-11-27 21:14:59 +00:00
|
|
|
|
exception NotYetImplemented of string
|
|
|
|
|
exception InvalidArguments of string
|
2007-09-26 07:55:59 +00:00
|
|
|
|
|
|
|
|
|
(***********************************
|
|
|
|
|
******** Usefull functions ********
|
2008-01-21 19:34:45 +00:00
|
|
|
|
<EFBFBD> ***********************************)
|
2007-09-26 07:55:59 +00:00
|
|
|
|
val triv_expr = Rep_OclTerm.Literal ("true",Rep_OclType.Boolean)
|
|
|
|
|
|
2008-01-21 19:34:45 +00:00
|
|
|
|
fun get_association (all_assocs: Rep_Core.association list) (assoc_path:Path):
|
|
|
|
|
association =
|
|
|
|
|
let
|
|
|
|
|
val assoc = filter (fn {name,...}=> name=assoc_path) all_assocs
|
|
|
|
|
in
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(case assoc of
|
|
|
|
|
[x] => x
|
2009-01-03 21:18:36 +00:00
|
|
|
|
| [] => Logger.error ("in get_association: no match found ("^(string_of_path (assoc_path))^")")
|
|
|
|
|
| _ => Logger.error "in get_association: more than 1 match found")
|
2008-01-21 19:34:45 +00:00
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
fun get_other_associationends (all_assocs:association list) (assoc_path:Path)
|
|
|
|
|
(cls_type:Rep_OclType.OclType):associationend list =
|
|
|
|
|
let
|
|
|
|
|
fun all_others ({aend_type,...}:associationend) =
|
|
|
|
|
(collection_type_of_OclType aend_type) <> cls_type
|
|
|
|
|
val association = get_association all_assocs assoc_path
|
|
|
|
|
val aends = filter all_others (#aends association)
|
|
|
|
|
in
|
|
|
|
|
aends
|
|
|
|
|
end
|
2007-09-26 07:55:59 +00:00
|
|
|
|
|
|
|
|
|
fun get_associationends (all_assocs:association list) (assoc_path:Path):associationend list =
|
|
|
|
|
let
|
|
|
|
|
val assoc:association = get_association all_assocs assoc_path
|
|
|
|
|
in
|
|
|
|
|
#aends assoc
|
|
|
|
|
end
|
|
|
|
|
|
2007-11-16 12:24:41 +00:00
|
|
|
|
(* (JD) -> Rep_Core? *)
|
2007-11-11 18:16:10 +00:00
|
|
|
|
fun associationends_of (assoc:association):associationend list =
|
2007-11-18 21:10:46 +00:00
|
|
|
|
let
|
|
|
|
|
val _ = print "associationends_of\n"
|
|
|
|
|
val _ = print ("assocends_of: "^(string_of_path (#name assoc))^"\n")
|
2008-01-28 15:19:02 +00:00
|
|
|
|
val _ = List.app (print o (fn x => x ^"\n") o name_of_aend)
|
|
|
|
|
(#aends assoc)
|
2007-11-18 21:10:46 +00:00
|
|
|
|
in
|
|
|
|
|
#aends assoc
|
|
|
|
|
end
|
2007-11-11 18:16:10 +00:00
|
|
|
|
|
2007-09-26 07:55:59 +00:00
|
|
|
|
(****************************
|
|
|
|
|
******** Transforms ********
|
|
|
|
|
****************************)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** Remove aggregations
|
|
|
|
|
* requires: aggregation
|
|
|
|
|
* generates: constraint
|
|
|
|
|
* removes: aggregation
|
|
|
|
|
*)
|
2008-01-24 21:08:57 +00:00
|
|
|
|
fun transformAggregation (allClassifiers,allAssociations) =
|
|
|
|
|
(allClassifiers,allAssociations) (*dummy*)
|
2007-09-26 07:55:59 +00:00
|
|
|
|
|
|
|
|
|
|
2008-01-28 15:19:02 +00:00
|
|
|
|
(**
|
|
|
|
|
*
|
|
|
|
|
* Remove qualifiers
|
|
|
|
|
* requires: qualified binary associations
|
|
|
|
|
* generates: constraints, binary associations
|
|
|
|
|
* removes: qualifiers
|
|
|
|
|
*)
|
|
|
|
|
fun transformQualifiers ((allClassifiers,allAssociations):transform_model):
|
|
|
|
|
transform_model =
|
|
|
|
|
let
|
2009-01-03 21:18:36 +00:00
|
|
|
|
val _ = Logger.debug2 "transformQualifiers\n"
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(* connects the dummy class to the new qualifier classes *)
|
2008-01-28 15:19:02 +00:00
|
|
|
|
fun handleQualifier assocPath (role,attributes) =
|
|
|
|
|
let
|
|
|
|
|
fun addAttrPair (cls,attr) = addAttribute cls attr
|
|
|
|
|
|
|
|
|
|
val package = qualifier_of_path assocPath
|
|
|
|
|
val dummy = newDummyClass package
|
|
|
|
|
val newClasses = map (newNamedClass package)
|
|
|
|
|
(map name_of_attribute attributes)
|
|
|
|
|
val newClasses = map addAttrPair (ListPair.zip(newClasses,
|
|
|
|
|
attributes))
|
2008-02-07 04:36:01 +00:00
|
|
|
|
val clsRolePairs = map (fn x => (x,NONE)) newClasses
|
|
|
|
|
val (newBinaryAssocs,newOppAends) = binaryAssociations dummy NONE
|
|
|
|
|
clsRolePairs
|
2008-01-28 15:19:02 +00:00
|
|
|
|
in
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(role,dummy, newClasses, newBinaryAssocs, newOppAends)
|
2008-01-28 15:19:02 +00:00
|
|
|
|
end
|
|
|
|
|
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(* connects the original classifiers to the new dummy classes *)
|
|
|
|
|
fun handleSources aends classifiers (role,dummy,newClasses,
|
|
|
|
|
newBinaryAssocs,newOppAends) =
|
|
|
|
|
let
|
|
|
|
|
val [source] = List.filter (fn x => role_of_aend x = role) aends
|
|
|
|
|
val [sourceClass] = List.filter (fn cls => type_of cls =
|
|
|
|
|
type_of_aend source)
|
|
|
|
|
classifiers
|
2008-02-07 04:36:01 +00:00
|
|
|
|
val sourceRole = SOME role
|
|
|
|
|
val [opp] = List.filter (fn x => role_of_aend x <> role) aends
|
|
|
|
|
val dummyRole = SOME (role_of_aend opp)
|
|
|
|
|
val ([dummyAssoc],[dummyAend]) =
|
|
|
|
|
binaryAssociations sourceClass sourceRole [(dummy,dummyRole)]
|
2008-02-06 21:00:26 +00:00
|
|
|
|
in
|
|
|
|
|
(dummyAssoc,dummyAend)
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
(* handled this way, in case of a binary to n-ary transition *)
|
|
|
|
|
fun updateAend ((role,dummy,newClasses,newBinaryAssocs,newOppAends),
|
2008-02-07 04:36:01 +00:00
|
|
|
|
{name,aends,qualifiers,aclass}) =
|
2008-01-28 15:19:02 +00:00
|
|
|
|
let
|
|
|
|
|
fun modAend newType {name,aend_type,multiplicity,ordered,
|
|
|
|
|
init,visibility} =
|
|
|
|
|
{name=name,
|
|
|
|
|
aend_type=newType,
|
|
|
|
|
multiplicity=multiplicity,
|
|
|
|
|
ordered=ordered,
|
|
|
|
|
visibility=visibility,
|
|
|
|
|
init=init}
|
|
|
|
|
|
|
|
|
|
val ([aend],rem) =
|
|
|
|
|
List.partition (fn {name=aendName,aend_type,...} =>
|
|
|
|
|
aendName = (name@[role])) aends
|
|
|
|
|
val modifiedAends = modAend (type_of dummy) aend :: rem
|
|
|
|
|
in
|
2008-02-07 04:36:01 +00:00
|
|
|
|
{name=name,
|
|
|
|
|
aends=modifiedAends,
|
|
|
|
|
qualifiers=[],
|
|
|
|
|
aclass=aclass}
|
2008-01-28 15:19:02 +00:00
|
|
|
|
end
|
|
|
|
|
|
2008-02-07 04:36:01 +00:00
|
|
|
|
fun addAssocs ((role,dummy,newClasses,newBinaryAssocs,newOppAends),
|
|
|
|
|
(collectedAssocs,collectedClassifiers))=
|
|
|
|
|
let
|
|
|
|
|
val modifiedDummy = modifyAssociationsOfClassifier newBinaryAssocs
|
|
|
|
|
[]
|
|
|
|
|
dummy
|
|
|
|
|
val modifiedNewClasses =
|
|
|
|
|
map (fn (x,y) => modifyAssociationsOfClassifier [y] [] x)
|
|
|
|
|
(ListPair.zip(newClasses,
|
|
|
|
|
newBinaryAssocs))
|
|
|
|
|
in
|
|
|
|
|
(newBinaryAssocs@collectedAssocs,
|
|
|
|
|
modifiedDummy::modifiedNewClasses@collectedClassifiers)
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
fun addTranslation (binaryAssoc,classifiers)=
|
|
|
|
|
let
|
|
|
|
|
val (matched,rem) = matchClassifiersAtAend (aends_of_association
|
|
|
|
|
binaryAssoc)
|
|
|
|
|
classifiers
|
|
|
|
|
val matched= map (modifyAssociationsOfClassifier [binaryAssoc]
|
|
|
|
|
[])
|
|
|
|
|
matched
|
|
|
|
|
in
|
|
|
|
|
(matched@rem)
|
|
|
|
|
end
|
|
|
|
|
|
2008-01-28 15:19:02 +00:00
|
|
|
|
fun removeQualifiers (assoc as {name=assocPath,aends,qualifiers,aclass}:
|
2008-02-06 21:00:26 +00:00
|
|
|
|
association,(classifiers,associations)):
|
2008-01-28 15:19:02 +00:00
|
|
|
|
(Classifier list * association list) =
|
|
|
|
|
let
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(** transform an qualifedAendCall into an aendCall:
|
|
|
|
|
* path and sourceType change (dummy1 -> dummy2/target)
|
|
|
|
|
* source needs to be expressed in terms of the original, qualified
|
|
|
|
|
* classifier. (source -> dummy1)
|
|
|
|
|
* if the target is also changed, resultType changes and the entire
|
|
|
|
|
* expression needs to be wrapped for the translation to the
|
|
|
|
|
* original target. (dummy2 -> target)
|
|
|
|
|
*)
|
|
|
|
|
fun updateQualifier oldAssocPath newAssoc sourcePairs qualiTuple
|
|
|
|
|
qualifiers
|
|
|
|
|
(QualifiedAssociationEndCall
|
|
|
|
|
(source,sourceType,qualifierVals,
|
|
|
|
|
path,resultType)) =
|
|
|
|
|
let
|
|
|
|
|
fun modifySource sourcePairs source oppAends qualifierVals
|
|
|
|
|
qualifiers role dummy =
|
|
|
|
|
let
|
|
|
|
|
fun restrict var (oppAend,(qualiVal,qualiType),quali) =
|
|
|
|
|
let
|
|
|
|
|
val aendCall = ocl_aendcall var (path_of_aend
|
|
|
|
|
oppAend)
|
|
|
|
|
(type_of_aend oppAend)
|
|
|
|
|
val qualiPath = path_of_OclType (type_of_aend
|
|
|
|
|
oppAend)@
|
|
|
|
|
[name_of_attribute quali]
|
|
|
|
|
val attCall = ocl_attcall aendCall qualiPath
|
|
|
|
|
qualiType
|
|
|
|
|
in
|
|
|
|
|
ocl_eq attCall qualiVal
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
val [(_,qualis)] = List.filter (fn (name,_) =>
|
|
|
|
|
name=role)
|
|
|
|
|
qualifiers
|
|
|
|
|
val triples = zip3(oppAends,qualifierVals,qualis)
|
|
|
|
|
val sourceType = if is_Collection
|
|
|
|
|
(Rep_OclHelper.type_of source)
|
|
|
|
|
then collection_type_of_OclType (
|
|
|
|
|
Rep_OclHelper.type_of source)
|
|
|
|
|
else Rep_OclHelper.type_of source
|
|
|
|
|
val [(_,sourceAend)] =
|
|
|
|
|
List.filter (fn (_,aend) => type_of_aend aend
|
|
|
|
|
= sourceType)
|
|
|
|
|
sourcePairs
|
|
|
|
|
val translation = ocl_aendcall source (path_of_aend
|
|
|
|
|
sourceAend)
|
|
|
|
|
(Bag dummy)
|
|
|
|
|
val dummyVar = variableFromOclType dummy
|
|
|
|
|
val body = ocl_and_all (map (restrict dummyVar)triples)
|
|
|
|
|
val restriction = ocl_select translation dummyVar
|
|
|
|
|
body
|
|
|
|
|
in
|
|
|
|
|
restriction
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
fun modifySourceType role newAssoc sourceType =
|
|
|
|
|
let
|
|
|
|
|
val [aend] = List.filter (fn x => role_of_aend x<>role)
|
|
|
|
|
(aends_of_association
|
|
|
|
|
newAssoc)
|
|
|
|
|
val newType = type_of_aend aend
|
|
|
|
|
in
|
|
|
|
|
if is_Collection sourceType then
|
|
|
|
|
(case sourceType of
|
|
|
|
|
(Set _) => Set newType
|
|
|
|
|
| (Sequence _) => Sequence newType
|
|
|
|
|
| (OrderedSet _) => OrderedSet newType
|
|
|
|
|
| (Bag _) => Bag newType
|
|
|
|
|
| (Collection _) => Collection newType)
|
|
|
|
|
else newType
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
fun modifyPath role newAssoc =
|
|
|
|
|
let
|
|
|
|
|
val [aend] = List.filter (fn x => role_of_aend x=role)
|
|
|
|
|
(aends_of_association
|
|
|
|
|
newAssoc)
|
|
|
|
|
in
|
|
|
|
|
path_of_aend aend
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
val role = short_name_of_path path
|
|
|
|
|
val [dummyAend] = List.filter (fn x => role_of_aend x <>
|
|
|
|
|
role)
|
|
|
|
|
(aends_of_association
|
|
|
|
|
newAssoc)
|
|
|
|
|
val dummy = type_of_aend dummyAend
|
|
|
|
|
val [(_,_,_,_,oppAends)] =
|
|
|
|
|
List.filter (fn (roleRef,_,_,_,_) => roleRef = role)
|
|
|
|
|
qualiTuple
|
|
|
|
|
in
|
|
|
|
|
if qualifier_of_path path = oldAssocPath then
|
|
|
|
|
AssociationEndCall(modifySource sourcePairs source oppAends
|
|
|
|
|
qualifierVals qualifiers
|
|
|
|
|
role dummy,
|
|
|
|
|
modifySourceType role newAssoc
|
|
|
|
|
sourceType,
|
|
|
|
|
modifyPath role newAssoc,
|
|
|
|
|
resultType)
|
|
|
|
|
else QualifiedAssociationEndCall(source,sourceType,
|
|
|
|
|
qualifierVals,
|
|
|
|
|
path,resultType)
|
|
|
|
|
end
|
|
|
|
|
| updateQualifier oldAssocPath newAssoc sourcePairs oppAends
|
|
|
|
|
qualifiers x = x
|
2008-02-07 04:36:01 +00:00
|
|
|
|
|
|
|
|
|
fun copyAssoc {name,aends,qualifiers,aclass} =
|
|
|
|
|
let
|
|
|
|
|
fun updateAssocOfAend path {name,aend_type,multiplicity,
|
|
|
|
|
init,ordered,visibility} =
|
|
|
|
|
{name=path@[short_name_of_path name],
|
|
|
|
|
aend_type=aend_type,
|
|
|
|
|
multiplicity=multiplicity,
|
|
|
|
|
init=init,
|
|
|
|
|
ordered=ordered,
|
|
|
|
|
visibility=visibility}
|
|
|
|
|
|
|
|
|
|
val newName = qualifier_of_path name@[short_name_of_path
|
|
|
|
|
name ^nextUid()]
|
|
|
|
|
in
|
|
|
|
|
{name=newName,
|
|
|
|
|
aends=map (updateAssocOfAend newName) aends,
|
|
|
|
|
qualifiers=qualifiers,
|
|
|
|
|
aclass=aclass}
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
fun stripQualifier {name,aends,qualifiers,aclass} =
|
|
|
|
|
{name=name,
|
|
|
|
|
aends=aends,
|
|
|
|
|
qualifiers=[],
|
|
|
|
|
aclass=aclass}
|
|
|
|
|
|
2008-02-08 00:25:51 +00:00
|
|
|
|
fun addUniqueness ((role,dummy, newClasses, newBinaryAssocs,
|
|
|
|
|
newOppAends),
|
|
|
|
|
(dummyAssoc,dummyAend)) =
|
|
|
|
|
(role,
|
|
|
|
|
addInvariants [uniquenessOclConstraint
|
|
|
|
|
dummy (dummyAssoc::newBinaryAssocs)] dummy,
|
|
|
|
|
newClasses, newBinaryAssocs,newOppAends)
|
|
|
|
|
|
2008-01-28 15:19:02 +00:00
|
|
|
|
(* generate the new classes and assocs for possibly both
|
|
|
|
|
* aend ends *)
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val qualiTuple = map (handleQualifier assocPath) qualifiers
|
|
|
|
|
(* connect the source to the dummy *)
|
|
|
|
|
val sourcePairs = map (handleSources aends classifiers) qualiTuple
|
2008-02-07 04:36:01 +00:00
|
|
|
|
(* keep the original aend as side-link and remove the mults *)
|
|
|
|
|
val copy = copyAssoc assoc
|
2008-02-08 00:25:51 +00:00
|
|
|
|
val assoc = stripMultiplicities assoc
|
2008-02-07 04:36:01 +00:00
|
|
|
|
val assoc = stripQualifier assoc
|
|
|
|
|
(* update the copied aend to point to the new dummy class,
|
2008-01-28 15:19:02 +00:00
|
|
|
|
* possibly at both ends *)
|
2008-02-07 04:36:01 +00:00
|
|
|
|
val modifiedCopy = foldl updateAend copy qualiTuple
|
2008-02-08 00:25:51 +00:00
|
|
|
|
(* add the uniqueness constraint *)
|
|
|
|
|
val qualiTuple = map addUniqueness (ListPair.zip(qualiTuple,
|
|
|
|
|
sourcePairs))
|
2008-02-07 04:36:01 +00:00
|
|
|
|
(* add the new assocs to the respective classifiers *)
|
|
|
|
|
val (newAssocs, newClassifiers) = foldl addAssocs ([],[])
|
|
|
|
|
qualiTuple
|
|
|
|
|
val (matched,rem) = matchClassifiersAtAend (aends_of_association
|
|
|
|
|
modifiedCopy)
|
|
|
|
|
(newClassifiers@
|
|
|
|
|
classifiers)
|
|
|
|
|
val allClassifiers = map (modifyAssociationsOfClassifier
|
|
|
|
|
[modifiedCopy] []) matched
|
|
|
|
|
@ rem
|
|
|
|
|
val allClassifiers = foldl addTranslation allClassifiers
|
|
|
|
|
(#1 (ListPair.unzip sourcePairs))
|
2008-01-28 15:19:02 +00:00
|
|
|
|
(* update all references to the original qualified pairs *)
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val newAssocs = newAssocs @ (#1 (ListPair.unzip sourcePairs))
|
|
|
|
|
val modifiedClassifiers =
|
2008-02-07 04:36:01 +00:00
|
|
|
|
mapCalls (updateQualifier assocPath modifiedCopy sourcePairs
|
2008-02-06 21:00:26 +00:00
|
|
|
|
qualiTuple qualifiers)
|
2008-02-07 04:36:01 +00:00
|
|
|
|
allClassifiers
|
|
|
|
|
(** val modifiedClassifiers = updateQualifierReferences
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(newClassifiers@classifiers)
|
|
|
|
|
[(assoc,modifiedAssoc)]
|
|
|
|
|
val modifiedClassifiers = updateAssociationReferences
|
|
|
|
|
modifiedClassifiers
|
|
|
|
|
[(assoc,newAssocs)]
|
|
|
|
|
*) in
|
2008-02-07 04:36:01 +00:00
|
|
|
|
(modifiedClassifiers, assoc::modifiedCopy::newAssocs@associations)
|
2008-01-28 15:19:02 +00:00
|
|
|
|
end
|
2008-01-21 19:34:45 +00:00
|
|
|
|
|
2008-01-28 15:19:02 +00:00
|
|
|
|
val (qualified, rem) = List.partition isPureQualifier allAssociations
|
|
|
|
|
val (modifiedClassifiers, modifiedAssociations) =
|
|
|
|
|
foldl removeQualifiers (allClassifiers,[]) qualified
|
|
|
|
|
in
|
|
|
|
|
(modifiedClassifiers, modifiedAssociations@rem)
|
|
|
|
|
end
|
2008-01-21 19:34:45 +00:00
|
|
|
|
|
2008-02-08 00:25:51 +00:00
|
|
|
|
fun transformNAryAssociationsToAssociationClasses (allClassifiers,
|
|
|
|
|
allAssociations) =
|
|
|
|
|
let
|
2009-01-03 21:18:36 +00:00
|
|
|
|
val _ = Logger.debug2 "transformNAryAssociationsTo\
|
2008-02-08 00:25:51 +00:00
|
|
|
|
\AssociationClasses\n"
|
|
|
|
|
fun toAssocClass (assoc as {name,aends,qualifiers,aclass=NONE}) =
|
|
|
|
|
let
|
|
|
|
|
val newAC = newDummyAssociationClass (qualifier_of_path name)
|
|
|
|
|
val newAC = setAssociationOfAssociationClass newAC name
|
|
|
|
|
in
|
|
|
|
|
(setAssociationOfAssociationClass newAC name,
|
|
|
|
|
setAssociationClassOfAssociation assoc (name_of newAC))
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
val (nAry, rem) = List.partition isPureNAryAssoc allAssociations
|
|
|
|
|
val (binary, rem) = List.partition isPureBinAssoc rem
|
|
|
|
|
val (newClassifiers,modifiedAssocs) = ListPair.unzip(map toAssocClass
|
|
|
|
|
(nAry@binary))
|
|
|
|
|
in
|
|
|
|
|
(newClassifiers@allClassifiers,modifiedAssocs@rem)
|
|
|
|
|
end
|
2008-01-21 19:34:45 +00:00
|
|
|
|
|
|
|
|
|
(**
|
|
|
|
|
* Transform an AssociationClass into a Class
|
|
|
|
|
* Strip the association class related information from the association class
|
|
|
|
|
* and turn it into a regular class. Constraints, etc are handled elsewhere;
|
|
|
|
|
* this is purely a conversion function.
|
|
|
|
|
*
|
2007-09-26 07:55:59 +00:00
|
|
|
|
* requires: AssociationClass
|
2008-01-21 19:34:45 +00:00
|
|
|
|
* generates: Class
|
2007-11-11 18:16:10 +00:00
|
|
|
|
* removes: AssociationClass
|
2007-09-26 07:55:59 +00:00
|
|
|
|
*)
|
2008-01-21 19:34:45 +00:00
|
|
|
|
fun transformAssociationClassIntoClass (AssociationClass
|
|
|
|
|
{name,parent,attributes,operations,
|
2008-01-25 14:56:51 +00:00
|
|
|
|
associations,association,
|
2008-01-21 19:34:45 +00:00
|
|
|
|
invariant,stereotypes,interfaces,
|
2008-02-08 00:25:51 +00:00
|
|
|
|
visibility,thyname,
|
|
|
|
|
activity_graphs}) =
|
2008-01-21 19:34:45 +00:00
|
|
|
|
Class { name = name,
|
2008-01-25 14:56:51 +00:00
|
|
|
|
parent = parent,
|
|
|
|
|
attributes = attributes,
|
|
|
|
|
operations = operations,
|
|
|
|
|
associations = associations,
|
|
|
|
|
invariant = invariant,
|
|
|
|
|
stereotypes = stereotypes,
|
|
|
|
|
interfaces = interfaces,
|
|
|
|
|
thyname = thyname,
|
2008-02-01 10:44:04 +00:00
|
|
|
|
visibility = visibility,
|
2008-01-25 14:56:51 +00:00
|
|
|
|
activity_graphs = activity_graphs}
|
2008-01-24 21:08:57 +00:00
|
|
|
|
|
2008-02-08 00:25:51 +00:00
|
|
|
|
fun transformAssociationClassesToNAryAssociations (allClassifiers,
|
|
|
|
|
allAssociations) =
|
|
|
|
|
let
|
2009-01-03 21:18:36 +00:00
|
|
|
|
val _ = Logger.debug2 "transformAssociationClassesTo\
|
2008-02-08 00:25:51 +00:00
|
|
|
|
\NAryAssociations\n"
|
|
|
|
|
fun morph {name,aends,qualifiers,aclass} class =
|
|
|
|
|
let
|
|
|
|
|
val newAend = {name=name@[StringHandling.uncapitalize
|
|
|
|
|
(short_name_of class)],
|
|
|
|
|
aend_type=type_of class,
|
|
|
|
|
multiplicity=[],
|
|
|
|
|
visibility= visibility_of class,
|
|
|
|
|
ordered=false,
|
|
|
|
|
init=NONE}
|
|
|
|
|
in
|
|
|
|
|
{name=name,
|
|
|
|
|
aends=newAend::(map stripMultiplicityOfAend aends),
|
|
|
|
|
qualifiers=qualifiers,
|
|
|
|
|
aclass=NONE}
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
fun aCToNAry (newACAssoc,(localClassifiers,localAssociations)) =
|
|
|
|
|
let
|
|
|
|
|
val (AC,rem) = findClassifier localClassifiers
|
|
|
|
|
(associationClassOfAssociation
|
|
|
|
|
newACAssoc)
|
|
|
|
|
val modifiedAC = transformAssociationClassIntoClass AC
|
|
|
|
|
val modifiedAssoc = morph newACAssoc modifiedAC
|
|
|
|
|
val aends = aends_of_association modifiedAssoc
|
|
|
|
|
val multiplicityConstraints =
|
|
|
|
|
multiplicityOclConstraints modifiedAC
|
|
|
|
|
(map multiplicity_of_aend aends)
|
|
|
|
|
aends
|
|
|
|
|
val uniquenessConstraint =
|
|
|
|
|
uniquenessOclConstraint modifiedAC
|
|
|
|
|
[modifiedAssoc]
|
|
|
|
|
val modifiedAC = addInvariants (uniquenessConstraint::
|
|
|
|
|
multiplicityConstraints) modifiedAC
|
|
|
|
|
in
|
|
|
|
|
(modifiedAC::rem,modifiedAssoc::localAssociations)
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
val (aCs, rem) = List.partition isPureAcAssoc allAssociations
|
|
|
|
|
val (modifiedClassifiers,modifiedAssociations) =
|
|
|
|
|
foldl aCToNAry (allClassifiers,[]) aCs
|
|
|
|
|
in
|
|
|
|
|
(modifiedClassifiers, modifiedAssociations@rem)
|
|
|
|
|
end
|
|
|
|
|
|
2008-01-21 19:34:45 +00:00
|
|
|
|
(**
|
|
|
|
|
* Process an association: add the dummy class, generate the matching-
|
|
|
|
|
* constraint and update the classifiers with that constraint.
|
2007-09-26 07:55:59 +00:00
|
|
|
|
*)
|
2008-01-24 21:08:57 +00:00
|
|
|
|
fun generalTransfromNAryAssociation dummy (association as {name,aends,
|
2008-01-27 15:36:57 +00:00
|
|
|
|
qualifiers=[],
|
2008-01-24 21:08:57 +00:00
|
|
|
|
aclass=NONE},
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(classifiers,processedAssocs)) =
|
2007-09-26 07:55:59 +00:00
|
|
|
|
let
|
2009-01-03 21:18:36 +00:00
|
|
|
|
val _ = Logger.debug2 "generalTransformNAryAssociation\n"
|
2008-01-24 21:08:57 +00:00
|
|
|
|
fun modifyClassifier ((assocs,classifier),classifiers) =
|
2008-01-21 19:34:45 +00:00
|
|
|
|
let
|
2008-01-25 14:56:51 +00:00
|
|
|
|
val ([cls],rem) = List.partition (fn x => name_of x =
|
|
|
|
|
name_of classifier)
|
|
|
|
|
classifiers
|
2008-01-21 19:34:45 +00:00
|
|
|
|
in
|
2008-01-24 21:08:57 +00:00
|
|
|
|
modifyAssociationsOfClassifier assocs [association] cls ::rem
|
2008-01-21 19:34:45 +00:00
|
|
|
|
end
|
|
|
|
|
|
2008-01-24 21:08:57 +00:00
|
|
|
|
fun consistency [] refer [] [] [] = []
|
|
|
|
|
| consistency (source::xs) refer (selfAend::ys) (roles::zs)
|
2008-01-21 19:34:45 +00:00
|
|
|
|
(refRoles::us) =
|
2008-01-24 21:08:57 +00:00
|
|
|
|
consistencyOclConstraint source refer selfAend roles refRoles ::
|
|
|
|
|
(consistency xs refer ys zs us)
|
2008-01-21 19:34:45 +00:00
|
|
|
|
|
|
|
|
|
fun addOcl ((classifier,ocls), classifiers) =
|
|
|
|
|
let
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val ([cls],rem) = List.partition (fn cls => type_of cls =
|
|
|
|
|
type_of classifier)
|
2008-01-25 14:56:51 +00:00
|
|
|
|
classifiers
|
2008-01-21 19:34:45 +00:00
|
|
|
|
in
|
|
|
|
|
addInvariants ocls cls :: rem
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
(* extract participants/members and form associations *)
|
2008-01-24 21:08:57 +00:00
|
|
|
|
val (assocMembers,rem) = matchClassifiersAtAend aends classifiers
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val (newBinaryAssocs,oppRefAends) = orderedBinaryAssociations dummy
|
2008-01-28 15:19:02 +00:00
|
|
|
|
assocMembers
|
|
|
|
|
aends
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val (clsses,roleNames, oppAends, splitAssocs, allNewSplitAssocs) =
|
|
|
|
|
splitNAryAssociation association assocMembers
|
|
|
|
|
val assocMemberPairs = ListPair.zip (map (fn x => [x]) newBinaryAssocs,
|
2008-01-25 14:56:51 +00:00
|
|
|
|
assocMembers)
|
|
|
|
|
val splitMemberPairs = ListPair.zip (splitAssocs,assocMembers)
|
2008-01-21 19:34:45 +00:00
|
|
|
|
|
|
|
|
|
(* update association membership info in classifiers *)
|
2008-01-24 21:08:57 +00:00
|
|
|
|
val modifiedClassifiers = foldl modifyClassifier classifiers
|
|
|
|
|
(assocMemberPairs @ splitMemberPairs)
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val dummy = modifyAssociationsOfClassifier newBinaryAssocs [] dummy
|
2008-01-21 19:34:45 +00:00
|
|
|
|
|
|
|
|
|
(* generate and add OCL constraints *)
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val uniquenessOCL = uniquenessOclConstraint dummy newBinaryAssocs
|
|
|
|
|
val selfAends = matchAendsFromClassifier newBinaryAssocs dummy roleNames
|
|
|
|
|
val refAends = map (matchAends oppRefAends) oppAends
|
2008-01-21 19:34:45 +00:00
|
|
|
|
val namedConsistencyOCLs = consistency clsses dummy selfAends oppAends
|
2008-02-06 21:00:26 +00:00
|
|
|
|
refAends
|
2008-01-21 19:34:45 +00:00
|
|
|
|
val multiplicitiesOCL =
|
2008-02-08 00:25:51 +00:00
|
|
|
|
multiplicityOclConstraints dummy (map multiplicity_of_aend aends)
|
|
|
|
|
oppRefAends
|
2008-01-21 19:34:45 +00:00
|
|
|
|
val dummy = addInvariants (uniquenessOCL::multiplicitiesOCL) dummy
|
|
|
|
|
val modifiedClassifiers = foldl addOcl modifiedClassifiers
|
|
|
|
|
namedConsistencyOCLs
|
|
|
|
|
|
|
|
|
|
(* update references to removed associations *)
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val modifiedClassifiers = updateAssociationReferences
|
|
|
|
|
modifiedClassifiers
|
|
|
|
|
[(association,
|
|
|
|
|
newBinaryAssocs@allNewSplitAssocs)]
|
2007-09-26 07:55:59 +00:00
|
|
|
|
in
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(dummy::modifiedClassifiers, newBinaryAssocs@allNewSplitAssocs@
|
2008-01-25 14:56:51 +00:00
|
|
|
|
processedAssocs)
|
2007-09-26 07:55:59 +00:00
|
|
|
|
end
|
|
|
|
|
|
2008-01-24 21:08:57 +00:00
|
|
|
|
(**
|
|
|
|
|
* Transform an AssociationClass into a Class and an Association
|
|
|
|
|
* requires: AssociationClass
|
|
|
|
|
* generates: Class, Association, constraint
|
|
|
|
|
* removes: AssociationClass
|
|
|
|
|
*)
|
|
|
|
|
fun transformAssociationClasses (allClassifiers,allAssociations) =
|
|
|
|
|
let
|
2009-01-03 21:18:36 +00:00
|
|
|
|
val _ = Logger.debug2 "transformAssociationClasses\n"
|
2008-01-27 15:36:57 +00:00
|
|
|
|
fun transformAssociationClass ({name,aends,qualifiers=[],
|
|
|
|
|
aclass=SOME aClass},
|
2008-01-24 21:08:57 +00:00
|
|
|
|
(classifiers,procAssocs)) =
|
|
|
|
|
let
|
|
|
|
|
val ([dummy],rem) = List.partition (fn x => name_of x = aClass)
|
|
|
|
|
classifiers
|
|
|
|
|
in
|
|
|
|
|
generalTransfromNAryAssociation dummy ({name=name,aends=aends,
|
2008-01-27 15:36:57 +00:00
|
|
|
|
qualifiers=[],aclass=NONE},
|
2008-01-24 21:08:57 +00:00
|
|
|
|
(rem,procAssocs))
|
|
|
|
|
end
|
|
|
|
|
|
2008-02-06 21:00:26 +00:00
|
|
|
|
fun stripAc ({name,aends,qualifiers,aclass=SOME aClass},
|
2008-01-27 15:36:57 +00:00
|
|
|
|
classifiers) =
|
2008-01-24 21:08:57 +00:00
|
|
|
|
let
|
2008-01-25 14:56:51 +00:00
|
|
|
|
val ([ac],rem) = List.partition (fn x => name_of x = aClass)
|
|
|
|
|
classifiers
|
2008-01-24 21:08:57 +00:00
|
|
|
|
in
|
|
|
|
|
transformAssociationClassIntoClass ac ::rem
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
val (acAssocs,rem) = List.partition isPureAcAssoc allAssociations
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val modifiedClassifiers = foldl stripAc allClassifiers acAssocs
|
2008-01-24 21:08:57 +00:00
|
|
|
|
val (modifiedClassifiers,modifiedAssociations) =
|
|
|
|
|
foldl transformAssociationClass (modifiedClassifiers,[]) acAssocs
|
|
|
|
|
in
|
|
|
|
|
(modifiedClassifiers,modifiedAssociations@rem)
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
|
2008-01-21 19:34:45 +00:00
|
|
|
|
(**
|
|
|
|
|
* We need OCL constraints and an additional dummy class to handle the broken
|
|
|
|
|
* relationship. The problem is fixing a particular association instance, as
|
|
|
|
|
* OCL navigation doesn't allow fixing more than one variable of an association
|
|
|
|
|
* tuple. Therefore, a dummy class is added to preserve association instances
|
|
|
|
|
* and allow multiplicity restrictions.
|
|
|
|
|
*
|
|
|
|
|
* requires: "pure" n-ary associations, i.e. no association class.
|
|
|
|
|
* generates: constraints, binary associations, dummy class
|
|
|
|
|
* removes: n-ary associations
|
|
|
|
|
*)
|
|
|
|
|
fun transformNAryAssociations (allClassifiers,allAssociations) =
|
2007-09-26 07:55:59 +00:00
|
|
|
|
let
|
2009-01-03 21:18:36 +00:00
|
|
|
|
val _ = Logger.debug2 "transformNAryAssociations\n"
|
2008-01-24 21:08:57 +00:00
|
|
|
|
fun transformNAryAssociation (association,(classifiers,procAssocs)) =
|
|
|
|
|
generalTransfromNAryAssociation
|
|
|
|
|
(newDummyClass (package_of_association association))
|
|
|
|
|
(association,(classifiers,procAssocs))
|
|
|
|
|
|
2008-01-25 14:56:51 +00:00
|
|
|
|
val (nAryAssocs,rem) = List.partition isPureNAryAssoc allAssociations
|
2008-01-21 19:34:45 +00:00
|
|
|
|
val (modifiedClassifiers,modifiedAssociations) =
|
|
|
|
|
foldl transformNAryAssociation (allClassifiers,[]) nAryAssocs
|
2007-09-26 07:55:59 +00:00
|
|
|
|
in
|
2008-01-21 19:34:45 +00:00
|
|
|
|
(modifiedClassifiers,modifiedAssociations@rem)
|
2007-09-26 07:55:59 +00:00
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
|
2007-11-11 18:16:10 +00:00
|
|
|
|
(**
|
2008-01-21 19:34:45 +00:00
|
|
|
|
* Move multiplicities from association ends to classifier constraints.
|
|
|
|
|
* requires: "pure" binary associations, i.e. no qualifiers, aggregation,
|
|
|
|
|
* association classes, etc.
|
|
|
|
|
* generates: constraints
|
|
|
|
|
* removes: binary association multiplicities
|
2007-09-26 07:55:59 +00:00
|
|
|
|
*)
|
|
|
|
|
|
2008-01-21 19:34:45 +00:00
|
|
|
|
fun transformMultiplicities (allClassifiers,allAssociations) =
|
|
|
|
|
let
|
2009-01-03 21:18:36 +00:00
|
|
|
|
val _ = Logger.debug2 "transformMultiplicities\n"
|
2008-01-21 19:34:45 +00:00
|
|
|
|
fun withinBound selfVar targetType role (low,high)=
|
|
|
|
|
let
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val returnType = Set targetType
|
2008-01-21 19:34:45 +00:00
|
|
|
|
val aendCallSize = ocl_size (ocl_aendcall selfVar role returnType)
|
2008-01-25 14:56:51 +00:00
|
|
|
|
val lowTerm = ocl_geq aendCallSize (Literal(Int.toString low,
|
|
|
|
|
Integer))
|
|
|
|
|
val highTerm = ocl_leq aendCallSize (Literal(Int.toString high,
|
|
|
|
|
Integer))
|
2008-01-21 19:34:45 +00:00
|
|
|
|
in
|
2008-02-06 21:00:26 +00:00
|
|
|
|
ocl_and lowTerm highTerm
|
2008-01-21 19:34:45 +00:00
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
fun binaryConstraint sourceType targetType role multis name =
|
|
|
|
|
let
|
|
|
|
|
val selfVar = self sourceType
|
2008-01-25 14:56:51 +00:00
|
|
|
|
val orTerms = map (withinBound selfVar targetType role) multis
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val term = ocl_or_all orTerms
|
2008-01-21 19:34:45 +00:00
|
|
|
|
in
|
|
|
|
|
(SOME name, term)
|
|
|
|
|
end
|
|
|
|
|
|
2008-01-27 15:36:57 +00:00
|
|
|
|
fun addMultiplicityConstraints (assoc as {name,aends=[a,b],qualifiers=[],
|
|
|
|
|
aclass=NONE},
|
2008-01-21 19:34:45 +00:00
|
|
|
|
localClassifiers) =
|
|
|
|
|
let
|
2009-01-03 21:18:36 +00:00
|
|
|
|
val _ = Logger.debug2 "addMultiplicityConstraints\n"
|
2008-01-24 21:08:57 +00:00
|
|
|
|
val aType = type_of_aend a
|
|
|
|
|
val bType = type_of_aend b
|
2008-01-21 19:34:45 +00:00
|
|
|
|
val aPath = path_of_aend a
|
|
|
|
|
val bPath = path_of_aend b
|
2008-01-24 21:08:57 +00:00
|
|
|
|
val aName = name_of_aend a
|
|
|
|
|
val bName = name_of_aend b
|
2008-02-06 21:00:26 +00:00
|
|
|
|
val aConstrName = "BinaryMultiplicity_"^bName (* opposite *)
|
|
|
|
|
val bConstrName = "BinaryMultiplicity_"^aName
|
2008-01-24 21:08:57 +00:00
|
|
|
|
val modifiedTmp =
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(case (multiplicities_of_aend b) of (* opposite *)
|
2008-01-21 19:34:45 +00:00
|
|
|
|
[] => localClassifiers
|
|
|
|
|
| multis =>
|
|
|
|
|
let
|
2008-01-27 15:36:57 +00:00
|
|
|
|
val aConstraint = binaryConstraint aType bType bPath
|
2008-01-21 19:34:45 +00:00
|
|
|
|
multis aConstrName
|
2008-01-27 15:36:57 +00:00
|
|
|
|
in
|
|
|
|
|
updateClassifiersWithConstraints localClassifiers aType
|
2008-01-21 19:34:45 +00:00
|
|
|
|
[aConstraint]
|
2008-01-27 15:36:57 +00:00
|
|
|
|
end)
|
2008-01-24 21:08:57 +00:00
|
|
|
|
val modifiedClassifiers =
|
2008-02-06 21:00:26 +00:00
|
|
|
|
(case (multiplicities_of_aend a) of
|
2008-01-27 15:36:57 +00:00
|
|
|
|
[] => modifiedTmp
|
|
|
|
|
| multis =>
|
|
|
|
|
let
|
|
|
|
|
val bConstraint = binaryConstraint bType aType
|
|
|
|
|
aPath multis
|
|
|
|
|
bConstrName
|
|
|
|
|
in
|
|
|
|
|
updateClassifiersWithConstraints modifiedTmp bType
|
|
|
|
|
[bConstraint]
|
|
|
|
|
end)
|
|
|
|
|
in
|
|
|
|
|
modifiedClassifiers
|
|
|
|
|
end
|
2008-01-24 21:08:57 +00:00
|
|
|
|
|
2008-01-21 19:34:45 +00:00
|
|
|
|
(* filter the valid associations *)
|
2008-01-24 21:08:57 +00:00
|
|
|
|
val (binaryAssociations,rem) = List.partition isPureBinAssoc
|
|
|
|
|
allAssociations
|
|
|
|
|
|
2008-01-21 19:34:45 +00:00
|
|
|
|
(* add the constraints to the classifiers *)
|
|
|
|
|
val modifiedClassifiers = foldl addMultiplicityConstraints
|
|
|
|
|
allClassifiers binaryAssociations
|
|
|
|
|
|
|
|
|
|
(* update the associationends *)
|
|
|
|
|
val modifiedAssociations = map stripMultiplicities binaryAssociations
|
|
|
|
|
in
|
|
|
|
|
(modifiedClassifiers, modifiedAssociations@rem)
|
|
|
|
|
end
|
|
|
|
|
|
2007-09-26 07:55:59 +00:00
|
|
|
|
(*******************************
|
|
|
|
|
******** Control part ********
|
|
|
|
|
*******************************)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(**
|
|
|
|
|
* Transformations on Classifiers and Associations
|
|
|
|
|
*)
|
2008-01-21 19:34:45 +00:00
|
|
|
|
fun transformClassifiersExt (model:Rep_Core.transform_model):Rep_Core.transform_model =
|
|
|
|
|
(* remove qualifiers *)
|
|
|
|
|
transformQualifiers model |>>
|
|
|
|
|
(* remove association classes *)
|
|
|
|
|
transformAssociationClasses |>>
|
|
|
|
|
(* remove n-ary associations *)
|
2008-02-08 00:25:51 +00:00
|
|
|
|
transformNAryAssociations |>>
|
|
|
|
|
(* remove multiplicities *)
|
|
|
|
|
transformMultiplicities
|
|
|
|
|
|
2007-09-26 07:55:59 +00:00
|
|
|
|
|
|
|
|
|
fun transformClassifiers (model:transform_model):Rep.Classifier list =
|
2008-01-24 21:08:57 +00:00
|
|
|
|
fst (transformClassifiersExt model) (* return classifiers *)
|
2007-09-26 07:55:59 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(**
|
|
|
|
|
* read and transform an .xmi file.
|
|
|
|
|
* @return a list of rep classifiers, or nil in case of problems
|
|
|
|
|
*)
|
2009-01-03 21:18:36 +00:00
|
|
|
|
fun transformFile f:transform_model = (Logger.info ("opening "^f);
|
2008-01-24 21:08:57 +00:00
|
|
|
|
(normalize_ext o transformClassifiersExt o
|
|
|
|
|
RepParser.transformXMI_ext o XmiParser.readFile) f)
|
2007-09-26 07:55:59 +00:00
|
|
|
|
(* handle ex as (IllFormed msg) => raise ex *)
|
|
|
|
|
|
|
|
|
|
exception FileNotFound of string
|
|
|
|
|
|
|
|
|
|
end
|