HOL-OCL
/
su4sml
1
0
Fork 0
Code Issues Pull Requests Releases Activity
su4sml/su4sml/src/wfcpog/refine_constraint.sml

411 lines
18 KiB
Standard ML
Raw Blame History

(*****************************************************************************
* 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
*
* 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 $ *)
signature WFCPOG_REFINE_CONSTRAINT =
sig
type RFM_args
structure WFCPOG_RFM_Data :
sig
type T = RFM_args
val get : WFCPOG.wfpo -> T
val put : T -> WFCPOG.wfpo -> WFCPOG.wfpo
val map : (T -> T) -> WFCPOG.wfpo -> WFCPOG.wfpo
end
val print_refine_args : RFM_args -> string
val check_syntax : WFCPOG.wfpo -> Rep.Model -> bool
val generate_pos : WFCPOG.wfpo -> Rep.Model -> (Rep_OclType.Path * Rep_OclTerm.OclTerm) list
end
structure WFCPOG_Refine_Constraint : WFCPOG_REFINE_CONSTRAINT =
struct
(* su4sml *)
open Rep_Helper
open Rep_Core
open Rep_OclTerm
open Rep_OclType
open Rep2String
open ModelImport
open Rep_HolOcl_Namespace
open Rep_HolOcl_Helper
(* wfcpo-gen *)
open WFCPOG_Library
exception ClassGroupError of Rep_Core.Classifier list * string
exception OpGroupError of Rep_Core.operation list * string
type RFM_args = {
key : int,
rfm_tuple : (Rep_OclType.Path * Rep_OclType.Path)
}
structure WFCPOG_RFM_Data = WFCPOG_DataFun
(struct
type T = RFM_args;
val empty = ({key=10,rfm_tuple=([]:Path,[]:Path)});
fun copy T = T;
fun extend T = T;
end);
fun print_refine_args (args:RFM_args) =
let
val tuple = (#rfm_tuple args)
in
(String.concat ["Refine rmf_tuple with args: abstract package = ",(string_of_path (#1 tuple)),", concrete package = ",(string_of_path (#2 tuple)),".\n"])
end
fun rm x [] = []
| rm x [b] = if (x = b) then [] else [b]
| rm x (h::tail) = if (x = h) then (rm x tail) else (h::(rm x tail))
fun group_cl [] [] = []
| group_cl [] toC = []
| group_cl FromC [] =
let
val s1 = "SYNTAX ERROR: OO Refinement syntax check\n\n"
val s2 = "Classifiers " ^(String.concat (List.map (fn a => ((string_of_path (name_of a))^", ")) FromC))^" of abstract package have no corresponding classifiers in concrete package.\n"
in
raise WFCPOG.WFC_FailedMessage (s1^s2)
end
| group_cl (h1::t1) list =
let
val _ = trace function_calls ("WFCPOG_Refine_Constraint.group_cl \n")
val _ = trace wgen ("Class: " ^ string_of_path (name_of h1) ^ "\n")
val x = List.filter (fn a => ((List.last (name_of a)) = (List.last (name_of h1)))) list
val res =
case (List.length(x)) of
0 =>
let
val s1 = "SYNTAX ERROR: OO Refinement syntax check\n\n"
val s2 = "Classifier " ^ (string_of_path (name_of h1)) ^ " of abstract package has no corresponding classifier in concrete package.\n"
in
raise WFCPOG.WFC_FailedMessage (s1^s2)
end
| 1 => (h1,hd(x))::(group_cl t1 (rm (hd(x)) list))
| x =>
let
val s1 = "SYNTAX ERROR: OO Refinement syntax check\n\n"
val s2 = "Something extremely strange happened. It seemed that the concrete package has two classifiers with the same name!. \nPLEASE CHECK THE CLASSIFIERS OF THE CONCRETE PACKAGE FOR THE OCCURENCE OF DUPLICATES.\n"
in
raise WFCPOG.WFC_FailedMessage (s1^s2)
end
val _ = trace function_ends ("WFCPOG_Refine_Constraint.group_cl \n")
in
res
end
fun group_op class_name [] [] = []
| group_op class_name fromOps [] =
let
val s1 = "SYNTAX ERROR: OO Refinement syntax check\n\n"
val s2 = "The abstract classifier "^class_name^" its operations " ^(String.concat (List.map (fn a => ((name_of_op a)^", ")) fromOps))^" have no corresponding operations in the concrete classifier.\n"
in
raise WFCPOG.WFC_FailedMessage (s1^s2)
end
| group_op class_name [] toOps = []
| group_op class_name ((h1:operation)::t1) list =
let
(* TODO: Check also signature because of the overloaded operations! *)
val _ = trace function_calls ("WFCPOG_Refine_Constraint.group_op \n")
val x = (List.filter (fn a => ((name_of_op a) = (name_of_op h1))) list)
val res =
case (List.length(x)) of
0 =>
let
val s1 = "SYNTAX ERROR: OO Refinement syntax check\n\n"
val s2 = "The abstract classifier "^class_name^" its operation " ^(name_of_op h1)^ " has no corresponding operation in the concrete classifier.\n"
in
raise WFCPOG.WFC_FailedMessage (s1^s2)
end
| 1 => (h1,List.hd(x))::(group_op class_name t1 (rm (List.hd(x)) list))
| x =>
let
val s1 = "SYNTAX ERROR: OO Refinement syntax check\n\n"
val s2 = "Something extremely strange happened. It seemed that the classifier "^class_name^"has two operations with the same name!. \nPLEASE CHECK THE CLASSIFIERS OF THE CONCRETE PACKAGE FOR THE OCCURENCE OF DUPLICATES.\n"
in
raise WFCPOG.WFC_FailedMessage (s1^s2)
end
val _ = trace function_ends ("WFCPOG_Refine_Constraint.group_op \n")
in
res
end
(* RETURN: (Classifier * Classifer) list *)
fun map_public_classes fromPath toPath (model as (clist,alist)) =
let
val _ = trace function_calls ("WFCPOG_Refine_Constraint.map_public_classes\n")
val abs_c = List.filter (is_visible_cl) (List.filter (fn a => if (package_of a = fromPath) then true else false) (clist))
val _ = trace wgen ("abstract public classes: \n")
val _ = List.map (fn a => trace wgen (" - " ^ (string_of_path (name_of a))^"\n")) abs_c
val _ = trace wgen ("map_public_classes 2 \n")
val _ = trace wgen ("Package " ^ string_of_path (fromPath) ^ " contains " ^ Int.toString (List.length(abs_c)) ^ " public classes.\n")
val conc_c = List.filter (is_visible_cl) (List.filter (fn a => if (package_of a = toPath) then true else false) (clist))
val _ = trace wgen ("concrete public classes: \n")
val _ = List.map (fn a => trace wgen (" - " ^ (string_of_path (name_of a))^"\n")) conc_c
val _ = trace wgen ("Package " ^ string_of_path (toPath) ^ " contains " ^ Int.toString (List.length(conc_c)) ^ " public classes.\n")
val _ = trace wgen ("map_public_classes 3 \n")
val res = group_cl abs_c conc_c
(*
handle WFCPOG.WFC_FailedMessage s =>
let
val s1 = ("SYNTAX ERROR: Class consistency \n\n")
val s2 = ("The following public classes are not included in the refined class:\n\n")
val s3 = (String.concat (List.map (fn a => (" * " ^ (string_of_path (name_of a)) ^ "\n")) clist))
in
raise WFCPOG.WFC_FailedMessage (s1^s2^s3)
end
val _ = trace function_calls ("WFCPOG_Refine_Constraint.map_public_classes\n")
*)
in
res
end
fun map_public_ops [] = [[]]
| map_public_ops ((f,t)::tail) =
let
val _ = trace function_calls ("Refine_Constraint.map_public_ops\n")
val f_ops = List.filter (is_visible_op) (local_operations_of f)
val t_ops = List.filter (is_visible_op) (local_operations_of t)
val _ = trace wgen ("Number of operations of f_class(" ^ (string_of_path (name_of f)) ^ ") = " ^ Int.toString (List.length(f_ops)) ^ "\n")
val _ = trace wgen ("Number of operations of t_class(" ^ (string_of_path (name_of t)) ^ ") = " ^ Int.toString (List.length(t_ops)) ^ "\n")
val res =
[(List.map (fn (a,b) => (f,t,a,b)) (group_op (List.last (Rep_Core.name_of f)) f_ops t_ops
handle OpGroupError (oplist,s) =>
let
val s1 = ("SYNTAX ERROR: Operation consistency \n\n")
val s2 = ("FromClass = " ^ (string_of_path (name_of f)) ^ "\n")
val s3 = ("ToClass = " ^ (string_of_path (name_of t)) ^ "\n")
val s4 = ("The following public operations are not included in the refined classes:\n\n")
val s5 = (String.concat (List.map (fn a => (" * " ^ (operation2string a) ^ "\n")) oplist))
in
raise WFCPOG.WFC_FailedMessage (s1^s2^s3^s4^s5)
end
))]
@(map_public_ops tail)
val _ = trace function_ends ("Refine_Constraint.map_public_op\n")
in
res
end
fun map_types [] fP tP model = []
| map_types ((h1:Classifier,h2:Classifier,h3:operation,h4:operation)::tail) fP tP model =
let
val _ = trace function_calls ("WFCPOG_Refine_Constrain.map_types\n")
val _ = trace wgen ("map_types: f_cl = " ^ string_of_path (name_of h1) ^ "\n")
val _ = trace wgen ("map_types: t_cl = " ^ string_of_path (name_of h2) ^ "\n")
val _ = trace wgen ("map_types: f_op = " ^ name_of_op h3 ^ "\n")
val _ = trace wgen ("map_types: t_op = " ^ name_of_op h4 ^ "\n")
(* classifier of return type *)
(* TODO: remove next trace lines *)
val _ = trace wgen ("Length of model: " ^ Int.toString (List.length(#1 model))^ ".\n")
val ret_fC = class_of_type (#result (h3)) model
val _ = trace wgen ("map_types 2 \n")
(* name of classifier of return type *)
val ret_namefC = name_of ret_fC
val _ = trace wgen ("map_types_3: " ^ string_of_path (ret_namefC) ^ "\n")
val _ = trace wgen ("map_types_4: " ^ string_of_path fP ^ "\n")
(* relative path of return type *)
val new_path = substitute_package fP tP ret_namefC
val _ = trace wgen ("map_types_5: name of return type: " ^ string_of_path (ret_namefC) ^ "\n")
val c1 = class_of (new_path) (model)
handle _ =>
let
val s1 = ("\n\n#####################################################################\n")
val s2 = ("#####################################################################\n\n")
val s3 = ("SYNTAX ERROR: Map types \n\n")
val s4 = ("The return type of the operation " ^ (operation2string h3) ^ " is inconsistent.\n")
val s4 = ("The refining package has no corresponding class.\n")
val s5 = ("Existing FromClass = " ^ (string_of_path (name_of h1)) ^ "\n")
val s6 = ("Inexisting ToClass = " ^ (string_of_path (name_of h2)) ^ "\n")
in
raise WFCPOG.WFC_FailedMessage (s1^s2^s3^s4^s5^s6)
end
(* name of the arguments *)
val _ = trace wgen ("map_types_6: " ^ string_of_path (name_of c1) ^ "\n")
val arg_class_name1 = List.map (fn (a,b) => (name_of (class_of_type b model))) (arguments_of_op (h3))
val _ = trace wgen ("map_types_7: \n")
val c2 = List.map (fn a =>
let
val rel_path = substitute_package fP tP a
in
class_of (rel_path) (model)
handle _ =>
let
val s1 = ("\n\n########################################################\n")
val s2 = ("########################################################\n\n")
val s3 = ("SYNTAX ERROR: Map types \n\n")
val s4 = ("One of the arguments type of the operation " ^ (operation2string h3) ^ " is inconsistent.\n")
val s5 = ("The refining package has no corresponding class.\n")
val s6 = ("Existing FromClass = " ^ (string_of_path (name_of h1)) ^ "\n")
val s7 = ("Inexisting ToClass = " ^ (string_of_path (name_of h2)) ^ "\n")
in
raise WFCPOG.WFC_FailedMessage (s1^s2^s3^s4^s5^s6^s7)
end
end
) arg_class_name1
val _ = trace wgen ("map_types_8: \n")
val res = (true)::(map_types tail fP tP model)
val _ = trace function_ends ("WFCPOG_Refine_Constrain.map_types\n")
in
res
end
fun check_syntax_help (model:Rep.Model as (clist,alist)) fromPath toPath =
let
val _ = trace function_calls ("WFCPOG_Refine_Constraint.check_syntax_help\n")
(* check public classes of the two packages *)
val x = map_public_classes fromPath toPath model
val _ = trace wgen ("check syntax 2 \n")
(* check public methods of the public classes *)
val y = List.concat (map_public_ops x)
val _ = trace wgen ("check syntax 3 \n")
(* check types of the public operations of public classes *)
val z = map_types y fromPath toPath model
val _ = trace wgen ("check syntax 4 \n")
val res = List.all (fn a => a) z
val _ = trace function_ends ("WFCPOG_Refine_Constraint.check_syntax_help\n")
in
res
end
fun check_syntax wfpo (model:Rep.Model as (clist,alist)) =
let
val _ = trace function_calls ("WFCPOG_Refine_Constraint.check_syntax\n")
val data = WFCPOG_RFM_Data.get wfpo
val _ = trace wgen (print_refine_args data)
val packages = (#rfm_tuple data)
val from = (#1 packages)
val to = (#2 packages)
val model_packages = all_packages_of_model model
val _ = trace wgen ("Packages of model: "^(String.concat (List.map (fn a => ((string_of_path a)^", ")) model_packages))^".\n")
val _ = trace wgen ("Abstract Package = "^(string_of_path from)^", contains "^(Int.toString (List.length(from)))^" strings.\n")
val _ = trace wgen ("Concrete Package = "^(string_of_path to)^", contains "^(Int.toString(List.length(from)))^" strings.\n")
val check = if ((member from model_packages) andalso (member to model_packages))
then check_syntax_help model from to
handle WFCPOG.WFC_FailedMessage s => raise WFCPOG.WFC_FailedException (wfpo,s)
else
let
val s1 = ("\n\n########################################################\n")
val s2 = ("########################################################\n\n")
val s3 = ("SYNTAX ERROR: check_syntax\n\n")
val s4 = ("No classifier where found with the package name of the abstract or concrete path.\n")
in
raise WFCPOG.WFC_FailedException (wfpo,s1^s2^s3^s4)
end
val _ = trace function_ends ("WFCPOG_Refine_Constraint.check_syntax\n")
in
check
end
(*
fun refine_operation abs_oper conc_oper abs_class conc_class model =
let
val _ = trace function_calls ("WFCPOG_Refine_Constraint.refine_classifier\n")
val state = Variable("mystate",OclState)
val op_term = get_holocl_operation ("abs") abs_oper abs_class model
val refine = OperationCall (op_term,DummyT,["holOclLib","Boolean","OclLocalValid"],[(state,OclState)],Boolean)
val _ = trace function_ends ("WFCPOG_Refine_Constraint.refine_classifier\n")
in
(["po_refine_"^(string_of_path (name_of abs_class))^"_"^(string_of_path (name_of conc_class))^"_"^(name_of_op abs_oper)],refine)
end
*)
fun refine_operation abs_oper conc_oper abs_class conc_class model =
let
val _ = trace function_calls ("WFCPOG_Refine_Constraint.refine_classifier\n")
val R = get_holocl_abstraction_relation abs_class conc_class model
val S = get_holocl_operation ("abs") abs_oper abs_class model
val T = get_holocl_operation ("conc") conc_oper conc_class model
val refine = OperationCall(S,DummyT,["holOclLib","methodology","refinement","OclForwardRefinement"],[(T,DummyT),(R,DummyT)],Boolean)
val _ = trace function_ends ("WFCPOG_Refine_Constraint.refine_classifier\n")
in
(["po_refine_"^(string_of_path (name_of abs_class))^"_"^(string_of_path (name_of conc_class))^"_"^(name_of_op abs_oper)],refine)
end
fun refine_classifier abs_class conc_class model =
let
val _ = trace function_calls ("WFCPOG_Refine_Constraint.refine_classifier\n")
val abs_ops = List.filter (is_visible_op) (local_operations_of abs_class)
val conc_ops = List.filter (is_visible_op) (local_operations_of conc_class)
val gops = group_op (List.last (Rep_Core.name_of abs_class)) abs_ops conc_ops
val res = List.map (fn (a,b) => refine_operation a b abs_class conc_class model) (gops)
val _ = trace function_ends ("WFCPOG_Refine_Constraint.refine_classifier\n")
in
res
end
fun refine_package abs_path conc_path (model as (clist,alist)) =
let
val _ = trace function_calls ("WFCPOG_Refine_Constraint.refine_package\n")
val abs_classes = List.filter (fn a => (package_of a = abs_path) andalso (is_visible_cl a)) (clist)
val conc_classes = List.filter (fn a => (package_of a = conc_path) andalso (is_visible_cl a)) (clist)
val cl_grouped = group_cl abs_classes conc_classes
val res = (List.concat (List.map (fn (a,b) => refine_classifier a b model) cl_grouped))
val _ = trace function_ends ("WFCPOG_Refine_Constraint.refine_package\n")
in
res
end
fun generate_pos wfpo (model as (clist,alist)) =
let
val _ = trace function_calls ("WFCPOG_Refine_Constraint.generate_pos\n")
val _ = trace wgen ("remove OclLib ...\n")
val classes = removeOclLibrary clist
val _ = trace wgen ("oclLib removed ...\n")
val _ = trace wgen ("Extract args ...\n")
val rfm_args = WFCPOG_RFM_Data.get wfpo
val packages = (#rfm_tuple rfm_args)
val _ = trace wgen("Args extracted ...\n")
val res = refine_package (#1 packages) (#2 packages) model
val _ = trace function_ends ("WFCPOG_Refine_Constraint.generate_pos\n")
in
res
end
end;
Reference in New Issue View Git Blame Copy Permalink