294 lines
11 KiB
Standard ML
294 lines
11 KiB
Standard ML
(*****************************************************************************
|
|
* su4sml --- a SML repository for managing (Secure)UML/OCL models
|
|
* http://projects.brucker.ch/su4sml/
|
|
*
|
|
* context_declarations.sml ---
|
|
* This file is part of su4sml.
|
|
*
|
|
* Copyright (c) 2005-2007 ETH Zurich, Switzerland
|
|
* 2008-2009 Achim D. Brucker, Germany
|
|
*
|
|
* 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: context_declarations.sml 6727 2007-07-30 08:43:40Z brucker $ *)
|
|
|
|
(** This library provides different functions used in many components of the WFCPO-generator.
|
|
* This operations are used very often and therefore they are accessible over this library.
|
|
* Although they are used frequently, it does make no sense to export them to the standard ocl
|
|
* library because there just important for implementing constraints.
|
|
*)
|
|
signature WFCPOG_LIBRARY =
|
|
sig
|
|
|
|
(** Get the name of a certain precondition.*)
|
|
val name_of_precondition : (string option * Rep_OclTerm.OclTerm) -> string option
|
|
(** Get the name of a certain postcondition.*)
|
|
val name_of_postcondition : (string option * Rep_OclTerm.OclTerm)-> string option
|
|
(** Get the term of a certain precondition.*)
|
|
val term_of_precondition : (string option * Rep_OclTerm.OclTerm) -> Rep_OclTerm.OclTerm
|
|
(** Get the term of a certain postcondition.*)
|
|
val term_of_postcondition : (string option * Rep_OclTerm.OclTerm) -> Rep_OclTerm.OclTerm
|
|
(** Wrap a predicate over an OclTerm.*)
|
|
(* val wrap_predicate : Rep_OclTerm.OclTerm -> string option -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list -> Rep_OclTerm.OclTerm *)
|
|
(** Conjungtion of a list of OclTerms to one single term.*)
|
|
val conjugate_terms : Rep_OclTerm.OclTerm list -> Rep_OclTerm.OclTerm
|
|
(** Conjungtion of a list of HolOclTerms to one single term.*)
|
|
val conjugate_holoclterms : Rep_OclTerm.OclTerm list -> Rep_OclTerm.OclTerm
|
|
(** Disjunction of a list of OclTerms to one single term.*)
|
|
val disjugate_terms : Rep_OclTerm.OclTerm list -> Rep_OclTerm.OclTerm
|
|
(** Get an attribute by name. *)
|
|
val get_attribute : string -> Rep_Core.Classifier -> Rep.Model -> Rep_Core.attribute
|
|
(** Get an associationend by name.*)
|
|
val get_associationend : string -> Rep_Core.Classifier -> Rep.Model -> Rep_Core.associationend
|
|
(** Get an operation by name. *)
|
|
(* val get_operation : string -> Rep_Core.Classifier -> Rep.Model -> Rep_Core.operation *)
|
|
(** *)
|
|
val class_contains_op : Rep_Core.operation -> Rep.Model -> Rep_Core.Classifier -> bool
|
|
(** *)
|
|
val class_has_local_op : string -> Rep.Model -> Rep_Core.Classifier -> bool
|
|
(** Get the class his children *)
|
|
val children_of : Rep_Core.Classifier -> Rep.Model -> Rep_OclType.Path list
|
|
(** Check inheritance tree for a given property and return first classifer fullfilling property.*)
|
|
val go_up_hierarchy : Rep_Core.Classifier -> (Rep_Core.Classifier -> bool) -> Rep.Model -> Rep_Core.Classifier
|
|
(** get the relative path according to the package *)
|
|
val rel_path_of : Rep_OclType.Path -> Rep_OclType.Path -> Rep_OclType.Path
|
|
(** Substitute (string,Type) args as (Variable(s,Type),Type) args.*)
|
|
val args2varargs : (string * Rep_OclType.OclType) list -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType) list
|
|
(** Add self as argument *)
|
|
val selfarg : Rep_OclType.OclType -> (Rep_OclTerm.OclTerm * Rep_OclType.OclType)
|
|
(** Print option *)
|
|
val opt2string : string option -> string
|
|
(** Any kind of exceptions. *)
|
|
val is_Class : Rep_Core.Classifier -> bool
|
|
val is_AssoClass : Rep_Core.Classifier -> bool
|
|
val is_Primi : Rep_Core.Classifier -> bool
|
|
val is_Enum : Rep_Core.Classifier -> bool
|
|
val is_Iface : Rep_Core.Classifier -> bool
|
|
val is_Templ : Rep_Core.Classifier -> bool
|
|
exception WFCPOG_LibraryError of string
|
|
end
|
|
structure WFCPOG_Library:WFCPOG_LIBRARY =
|
|
struct
|
|
|
|
(* SU4SML *)
|
|
open Rep_Helper
|
|
open Rep_Core
|
|
open Rep
|
|
open Rep_OclType
|
|
open Rep_OclTerm
|
|
open OclLibrary
|
|
open Rep2String
|
|
open XMI_DataTypes
|
|
(* OclParser *)
|
|
|
|
|
|
|
|
exception WFCPOG_LibraryError of string
|
|
|
|
|
|
fun opt2string (NONE) = ""
|
|
| opt2string (SOME(s)) = s
|
|
|
|
|
|
fun is_Class (Class{...}) = true
|
|
| is_Class x = false
|
|
|
|
fun is_AssoClass (AssociationClass{...}) = true
|
|
| is_AssoClass x = false
|
|
|
|
fun is_Enum (Enumeration{...}) = true
|
|
| is_Enum x = false
|
|
|
|
fun is_Templ (Template{...}) = true
|
|
| is_Templ x = false
|
|
|
|
fun is_Primi (Primitive{...}) = true
|
|
| is_Primi x = false
|
|
|
|
fun is_Iface (Interface{...}) = true
|
|
| is_Iface x = false
|
|
|
|
fun name_of_precondition ((a:string option),(t:OclTerm)) = a
|
|
|
|
fun name_of_postcondition ((a:string option),(t:OclTerm)) = a
|
|
|
|
fun term_of_precondition ((a:string option),(t:OclTerm)) = t
|
|
|
|
fun term_of_postcondition ((a:string option),(t:OclTerm)) = t
|
|
|
|
(* FixME: adapter for info in subterm *)
|
|
(* fun holocl_adapter path (t:OclTerm) =
|
|
|
|
OperationCall (
|
|
*)
|
|
|
|
fun conjugate_terms [] = raise WFCPOG_LibraryError ("Empty list not conjugateable. \n")
|
|
| conjugate_terms [x:OclTerm] = (x)
|
|
| conjugate_terms ((h:OclTerm)::tail) =
|
|
let
|
|
val x = conjugate_terms tail
|
|
in
|
|
if (type_of_term h = Boolean)
|
|
then (OperationCall(h,type_of_term h,["oclLib","Boolean","and"],[(x,type_of_term x)],Boolean))
|
|
else raise WFCPOG_LibraryError ("type of term is not Boolean. \n")
|
|
end
|
|
|
|
fun conjugate_holoclterms [] = raise WFCPOG_LibraryError ("Empty list not conjugateable. \n")
|
|
| conjugate_holoclterms [x] = x
|
|
| conjugate_holoclterms (h::tail) =
|
|
let
|
|
val x = conjugate_holoclterms tail
|
|
in
|
|
if (type_of_term h = Boolean)
|
|
then (OperationCall(h,type_of_term h,["holOclLib","Boolean","and"],[(x,type_of_term x)],Boolean))
|
|
else raise WFCPOG_LibraryError ("type of term is not Boolean. \n")
|
|
end
|
|
|
|
fun disjugate_terms [] = raise WFCPOG_LibraryError("Empty list not disjugateable. \n")
|
|
| disjugate_terms [x:OclTerm] = (x)
|
|
| disjugate_terms ((h:OclTerm)::tail) =
|
|
let
|
|
val x = disjugate_terms tail
|
|
in
|
|
if (type_of_term h = Boolean)
|
|
then (OperationCall(h,type_of_term h,["oclLib","Boolean","or"],[(x,type_of_term x)],Boolean))
|
|
else raise WFCPOG_LibraryError ("type of term is not Boolean. \n")
|
|
end
|
|
|
|
fun filter_out_none [] = []
|
|
| filter_out_none (NONE::tail) = filter_out_none tail
|
|
| filter_out_none (SOME(x)::tail) = (SOME(x)::(filter_out_none tail))
|
|
|
|
fun class_contains_op oper model classifier =
|
|
let
|
|
val ops = local_operations_of classifier
|
|
in
|
|
List.exists (fn a => if (#name oper) = (#name a)
|
|
andalso (sig_conforms_to (arguments_of_op oper) (arguments_of_op a) model)
|
|
then true
|
|
else false) ops
|
|
end
|
|
|
|
fun class_has_local_op name model classifier =
|
|
let
|
|
val ops = local_operations_of classifier
|
|
in
|
|
List.exists (fn a => (#name a) = name) ops
|
|
end
|
|
|
|
|
|
fun get_operation s classifier model =
|
|
let
|
|
val x = List.find (fn a => if (name_of_op a = s) then true else false) (all_operations_of classifier model)
|
|
in
|
|
case x of
|
|
NONE => raise WFCPOG_LibraryError ("No operation found using 'get_operation'.\n")
|
|
| SOME (x) => x
|
|
end
|
|
|
|
|
|
fun get_attribute s classifier model =
|
|
let
|
|
val x = List.find (fn a => if ((#name a) = s) then true else false) (all_attributes_of classifier model)
|
|
in
|
|
case x of
|
|
NONE =>
|
|
let
|
|
val _ = Logger.info ("No such Attribute: \n In Classifier "^(string_of_path (name_of classifier))^" in attribute "^s)
|
|
in
|
|
raise WFCPOG_LibraryError ("No attribute found using 'get_attribute'.\n")
|
|
end
|
|
| SOME (x) => x
|
|
end
|
|
|
|
fun get_associationend s classifier model =
|
|
let
|
|
val x = List.find (fn a => if ((List.last(#name a)) = s) then true else false) (all_associationends_of classifier model)
|
|
in
|
|
case x of
|
|
NONE =>
|
|
let
|
|
val _ = Logger.info ("No such associationend: \n In Classifier "^(string_of_path (Rep_Core.name_of classifier))^" no associationend called "^(s)^".\n")
|
|
in
|
|
raise WFCPOG_LibraryError ("No attribute found using 'get_attribute'.\n")
|
|
end
|
|
| SOME(x) => x
|
|
end
|
|
|
|
|
|
fun go_up_hierarchy location func (model as (clist,alist)) =
|
|
let
|
|
val parent = parent_of location model
|
|
in
|
|
if (func parent = true)
|
|
then parent
|
|
else
|
|
(if (type_of parent = OclAny)
|
|
then raise WFCPOG_LibraryError ("No such property using 'go_up_hierarchy'.\n")
|
|
else go_up_hierarchy parent func model
|
|
)
|
|
end
|
|
|
|
|
|
|
|
fun children_of class (model as ([],alist)) = []
|
|
| children_of class (model as ((h::tail),alist)) =
|
|
if (parent_of h model = class)
|
|
then (name_of h)::(children_of class ((tail,alist)))
|
|
else (children_of class ((tail,alist)))
|
|
|
|
fun has_children class (model as (clist,alist)) =
|
|
let
|
|
val ch = children_of class model
|
|
in
|
|
if (List.length (ch) = 0)
|
|
then false
|
|
else true
|
|
end
|
|
|
|
|
|
|
|
|
|
|
|
|
|
fun rel_path_of [] name = name
|
|
| rel_path_of [x] [y] = if (x=y) then [] else raise WFCPOG_LibraryError ("rel_path_of only possible for name with same package/prefix.\n")
|
|
| rel_path_of [x] name = if (x = List.hd (name)) then (List.tl (name)) else raise WFCPOG_LibraryError ("rel_path_of only possible for name with same package/prefix")
|
|
| rel_path_of pkg name =
|
|
if (List.hd(pkg) = List.hd(name)) then (rel_path_of (List.tl pkg) (List.tl name)) else raise WFCPOG_LibraryError ("rel_path_of only possible for name with same package/prefix")
|
|
|
|
fun args2varargs [] = []
|
|
| args2varargs ((a,b)::tail) = (Variable(a,b),b)::(args2varargs tail)
|
|
|
|
fun selfarg typ = (Variable("self",typ),typ)
|
|
|
|
end;
|