(*****************************************************************************
 * 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 $ *)

(** Implementation of the Liskov Substitiution Principle. *)
signature WFCPOG_VISIBILITY_CONSTRAINT =
sig
    (** 
     * Checks if the visibility of the class is at least as visible
     * as the most visible member.
     *)
    val model_entity_consistency                  : WFCPOG.wfpo -> Rep.Model -> bool
    (**
     * Checks if the modificators of overriden features are maintained in the subclasses.
     *)
    val model_inheritance_consistency                   : WFCPOG.wfpo -> Rep.Model -> bool
    (**
     * Runtime checking/enforcement in mind:
     * pre-condition, post-conditions, invariants are shall only contain
     * calls to visible features (i.e., public features of other classes,
     * package features of other classes within the same package, 
     * protected features of superclasses, and own private features).
     *)
    val constraint_check_by_runtime_consistency   : WFCPOG.wfpo -> Rep.Model -> bool
    (** 
     * Design by contract in mind: 
     * Here, clients (callers) should be able to check/establish the pre-condition of operations:
     * pre-conditions should only contain feature calls that are at least as visible as 
     * the operation itself.
     *)
    val constraint_design_by_contract_consistency : WFCPOG.wfpo -> Rep.Model -> bool

end
structure WFCPOG_Visibility_Constraint:WFCPOG_VISIBILITY_CONSTRAINT = 
struct

(* su4sml *)
open Rep_Core
open Rep_OclTerm
open Rep_OclType
open Rep2String
open XMI_DataTypes
open Ocl2String
(* oclparser *)
open ModelImport

(* wfcpo-gen *)
open WFCPOG_Library


exception WFCPOG_VisibilityError of string

type Visibility = XMI_DataTypes.VisibilityKind


fun visibility2string public = "public"
  | visibility2string package = "package"
  | visibility2string protected = "protected"
  | visibility2string private = "private"

fun visibility_conforms_to public _ = true
  | visibility_conforms_to package public = false
  | visibility_conforms_to package _ = true
  | visibility_conforms_to protected protected = true
  | visibility_conforms_to protected private = true
  | visibility_conforms_to protected _ = false
  | visibility_conforms_to private private = true
  | visibility_conforms_to private _ = false

fun expr_is_visible_CollPart modif (CollectionItem(term,typ)) model = expr_is_visible modif term model
  | expr_is_visible_CollPart modif (CollectionRange(first,last,typ)) model = 
    (expr_is_visible modif first model) andalso (expr_is_visible modif last model)

and expr_is_visible modif (Literal(s,typ)) model = true 
  | expr_is_visible modif (Variable(s,typ)) model = true
  | expr_is_visible modif (CollectionLiteral(part,typ)) model = 
    List.all (fn a => expr_is_visible_CollPart modif a model) part
  | expr_is_visible modif (If(cond,cond_typ,else_t,else_typ,then_t,then_typ,rtyp)) model = 
    expr_is_visible modif cond model 
    andalso expr_is_visible modif else_t model
    andalso expr_is_visible modif then_t model
  | expr_is_visible modif (AssociationEndCall(src,styp,path,rtyp)) model = 
    let
	val _ = Logger.info ("start expr_is_visible")
	val cl = class_of_term src model
	val att_name = List.last(path)
	val _ = Logger.info ("start get_associationends ")
	val att = get_associationend att_name cl model
	val _ = Logger.info ("end expr_is_visible")
    in
	if (visibility_conforms_to (#visibility att) modif)
	then (expr_is_visible modif src model)
	else false
    end    
  | expr_is_visible modif (x as OperationCall(src,styp,path,args,rtyp)) model = 
    let
	val _ = Logger.debug1 ("WFCPGO_Visibility_Constraint.expr_is_visible : " ^ (ocl2string false x) ^ "\n")
	val typ = type_of_term src
	val cl = class_of_term (Variable("x",typ)) model
	val op_name = List.last(path)
	val _ = Logger.info ("Classifier : " ^ (string_of_path (name_of cl)) ^ "\n")
	val _ = Logger.info ("Op_name : " ^ op_name ^ "\n")
	val oper = get_operation op_name cl model
	val _ = Logger.info ("got operation\n")
	val res = 
	    if (visibility_conforms_to (#visibility oper) modif) 
	    then ((List.all (fn (a,b) => (expr_is_visible modif a model)) args) andalso (expr_is_visible modif src model))
	    else false
	val _ = Logger.debug1 ("WFCPGO_Visibility_Constraint.expr_is_visible\n")
    in
	res 
    end
  | expr_is_visible modif (x as AttributeCall(src,styp,path,rtyp)) model =
    let
	val _ = Logger.info ("expr_is_visible: AttCall \n ")
	val cl = class_of_term src model
	val att_name = List.last(path)
	val att = get_attribute att_name cl model
	val _ = Logger.info ("end expr_is_visible")
    in
	if (visibility_conforms_to (#visibility att) modif)
	then (expr_is_visible modif src model)
	else false
    end
  | expr_is_visible modif (OperationWithType(src,styp,name,ntyp,rtyp)) model = expr_is_visible modif src model
  | expr_is_visible modif (Let(var,vtyp,rhs,rtyp,t_in,ityp)) model =
    (expr_is_visible modif rhs model) andalso (expr_is_visible modif t_in model)
  | expr_is_visible modif (Iterate(iter_vars,rname,rtyp,rterm,src,styp,body,btyp,retyp)) model = 
    (expr_is_visible modif src model) andalso (expr_is_visible modif body model)
  | expr_is_visible modif (Iterator(name,vars,src,styp,body,btyp,rtyp)) model = 
    (expr_is_visible modif src model) andalso (expr_is_visible modif body model)


fun check_entity_classifier class model = 
    let
	val vis_ops = List.map (fn (a:operation) => ((#visibility a),SOME(a),NONE,NONE)) (all_operations_of class model)
	val vis_atts = List.map (fn (a:attribute) => ((#visibility a),NONE,SOME(a),NONE)) (all_attributes_of class model)
 	val vis_assocs = List.map (fn (a:associationend) => ((#visibility a),NONE,NONE,SOME(a))) (all_associationends_of class model)
	val vis_class = visibility_of class
	val check = 
	    List.map (fn ((a:Visibility),x,y,z) => 
			 if (visibility_conforms_to vis_class a)
			 then true
			 else 
			     let
				 val s1 = "SYNTAX ERROR: Visibility consistency\n\n"
				 val s2 = "Classifier " ^ (string_of_path (name_of class)) ^ " is not visible enough.\n"
				 val s3 = "Visibility of classifer: " ^ (visibility2string (visibility_of class)) ^ ".\n"
				 val s4 = case x of
					      SOME(oper) => ("Visibility of operation " ^ (name_of_op oper) ^ " : " ^ (visibility2string a))
					    | _ => ""
				 val s5 = case y of
					      SOME(att) => ("Visibility of attribute " ^ (name_of_att att) ^ " : " ^ (visibility2string a))
					    | _ => ""
				 val s6 = case z of
					      SOME(aend) => ("Visibility of operation " ^ (name_of_aend aend) ^ " : " ^ (visibility2string a))
					    | _ => ""
			     in
				 raise WFCPOG.WFC_FailedMessage (s1^s2^s3^s4^s5^s6)
			     end
		     ) ((vis_ops)@(vis_atts)@(vis_assocs))
    in
	List.all (fn a => a = true) check
    end
    
    
fun check_inheritance_classifier class model =
    let
	(* modified operations *)
        val mod_ops_this = modified_operations_of class model
	val mod_ops_super_this = List.map (fn oper =>
					      let 
						  val op_name = name_of_op oper
						  val super_class = go_up_hierarchy class (class_has_local_op op_name model) model
						  val super_op = get_operation op_name super_class model
					      in
						  (super_class,super_op,oper)
					      end) mod_ops_this
						  
	val check = 
	    List.map (fn (super,sop,this_op) =>
			 if (visibility_conforms_to (#visibility this_op) (#visibility sop))
			 then true
			 else 
			     let
				 val s1 = "SYNTAX ERROR: Visibility inheritance consistency\n\n"
				 val s2 = "Classifier " ^ (string_of_path (name_of class)) ^ " has inconsistent visibility for the overriden operation: " ^ (name_of_op this_op) ^ ".\n"
				 val s3 = "Visibility of the overriden operation : " ^ (visibility2string (#visibility this_op)) ^ ".\n"
				 val s4 = "Visibility of the original operation (located in " ^ (string_of_path (name_of super)) ^ " ) : " ^ (visibility2string (#visibility sop)) ^ ".\n" 
			     in
				 raise WFCPOG.WFC_FailedMessage (s1^s2^s3^s4)
			     end
		     ) mod_ops_super_this
	val _ = Logger.debug1 ("WFCPOG_Visibility_Consistency.check_inheritance_visibility_consistency\n")
    in
	List.all (fn a => a = true) check
    end

					      
fun check_runtime_classifier class model = 
    let
	val ops_pre = List.map (fn a => (a,(precondition_of_op a))) (all_operations_of class model)
	val ops_pre_vis = 
	    List.concat (
	    List.map (fn (a,b) => 
				       let
					   val op_vis = (#visibility a)
				       in
					   List.map (fn (opt_name,expr) => ((name_of_op a),opt_name,(expr_is_visible op_vis expr model))) b
				       end) ops_pre)
	val ops_post = List.map (fn a => (a,(postcondition_of_op a))) (all_operations_of class model)
	val ops_post_vis = 
	    List.concat (
	    List.map (fn (a,b) => 
					let
					    val op_vis = (#visibility a)
					in
					    List.map (fn (opt_name,expr) => ((name_of_op a),opt_name,(expr_is_visible op_vis expr model))) b
					end)  ops_post)
	val invs = all_invariants_of class model
	val invs_vis = List.map (fn (a,b) =>
				    let
					val class_vis = (visibility_of class)
				    in
					(a,expr_is_visible class_vis b model)
				    end) invs
	val check_pre = 
	    List.map (fn (a,b,c) =>
			 if c = true
			 then true
			 else 
			     let
				 val s1 = "SYNTAX ERROR: Visibility runtime consistency\n\n"
				 val s2 = "Classifier " ^ (string_of_path (name_of class)) ^ " has in operation " ^ a ^ " in the precondition " ^ (opt2string b) ^ " inconsistent modificators.\n"
			     in
				 raise WFCPOG.WFC_FailedMessage (s1^s2)
			     end) ops_pre_vis

	val check_post =
	    List.map (fn (a,b,c) =>
			 if c = true
			 then true
			 else
			     let
				 val s1 = "SYNTAX ERROR: Visibility runtime consistency\n\n"
				 val s2 = "Classifier " ^ (string_of_path (name_of class)) ^ " has in operation " ^ a ^ " in the postcondition " ^ (opt2string b) ^ " inconsistent modificators.\n"
			     in
				 raise WFCPOG.WFC_FailedMessage (s1^s2)
			     end) ops_post_vis
	val check_inv = 
	    List.map (fn (a,b) =>
			 if b = true
			 then true
			 else
			     let 
				 val s1 = "SYNTAX ERROR: Visibility runtime consistency\n\n"
				 val s2 = "Classifier " ^ (string_of_path (name_of class)) ^ " has in the invariant " ^ (opt2string(a)) ^ "inconsistent modificators.\n"
			     in
				 raise WFCPOG.WFC_FailedMessage (s1^s2)
			     end) invs_vis
    in
	List.all (fn a => a = true) (check_pre@check_post@check_inv)
    end


fun check_design_classifier class model = 
    let
	val ops_pre = List.map (fn a => (a,(precondition_of_op a))) (all_operations_of class model)
	val ops_pre_vis = 
	    List.concat (
	    List.map (fn (a,b) => 
				       let
					   val op_vis = (#visibility a)
				       in
					   List.map (fn (opt_name,expr) => ((name_of_op a),opt_name,(expr_is_visible op_vis expr model))) b
				       end) ops_pre)
	val check_pre = 
	    List.map (fn (a,b,c) =>
			 if c = true
			 then true
			 else 
			     let
				 val s1 = "SYNTAX ERROR: Visibility design by contract consistency\n\n"
				 val s2 = "Classifier " ^ (string_of_path (name_of class)) ^ " has in operation " ^ a ^ " in the precondition " ^ (opt2string b) ^ " inconsistent modificators.\n"
			     in
				 raise WFCPOG.WFC_FailedMessage (s1^s2)
			     end) ops_pre_vis
    in
	List.all (fn a => a = true) check_pre
    end

fun model_entity_consistency wfc_sel (model as (clist,alist)) =
    let
	val _ = Logger.debug1 ("WFCPOG_Visibility_Constraint.model_entity_consistency\n")
	(* remove OclLibrary *)
	val cl = removeOclLibrary (clist)
        (* visiblity only for Classes and AssocClasses *)
	val classes = List.filter (fn a => (is_Class a) orelse (is_AssoClass a)) cl
	val res = List.all (fn a => a = true) (List.map (fn a => check_entity_classifier a model
							    handle WFCPOG.WFC_FailedMessage s => raise WFCPOG.WFC_FailedException (wfc_sel,s)) classes)
	val _ = Logger.debug1 ("WFCPOG_Visibility_Constraint.model_entity_consistency\n")
    in
	res
    end

fun model_inheritance_consistency wfc_sel (model as (clist,alist)) = 
    let
	val _ = Logger.debug1 ("WFCPOG_Visibility_Constraint.model_inheritance_consistency\n")
	val cl = removeOclLibrary (clist)
	val classes = List.filter (fn a => (is_Class a) orelse (is_AssoClass a)) cl
	val res  = List.all (fn a => a = true) (List.map (fn a => check_inheritance_classifier a model
							     handle WFCPOG.WFC_FailedMessage s => raise WFCPOG.WFC_FailedException (wfc_sel,s)) classes)
	val _ = Logger.debug1 ("WFCPOG_Visibility_Constraint.model_inheritance_consistency\n")
    in
	res

    end

fun constraint_check_by_runtime_consistency wfc_sel (model as (clist,alist)) = 
    let
	val _ = Logger.debug1 ("WFCPOG_Visibility_Constraint.constraint_check_by_runtime_consistency\n")
	val cl = removeOclLibrary clist
	val classes = List.filter (fn a => (is_Class a) orelse (is_AssoClass a)) cl
	val res = List.all (fn a => a = true) (List.map (fn a => check_runtime_classifier a model
							    handle WFCPOG.WFC_FailedMessage s => raise WFCPOG.WFC_FailedException (wfc_sel,s)) classes)
	val _ = Logger.debug1 ("WFCPOG_Visibility_Constraint.constraint_check_by_runtime_consistency\n")
    in
	res
    end

fun constraint_design_by_contract_consistency wfc_sel (model as (clist,alist)) =
    let
	val _ = Logger.debug1 ("WFCPOG_Visibility_Constraint.constraint_design_by_contract_consistency\n")
	val cl = removeOclLibrary clist
	val classes = List.filter (fn a => (is_Class a) orelse (is_AssoClass a)) cl
	val res = List.all (fn a => a = true) (List.map (fn a => check_design_classifier a model
							    handle WFCPOG.WFC_FailedMessage s => raise WFCPOG.WFC_FailedException (wfc_sel,s)) classes)
 	val _ = Logger.debug1 ("WFCPOG_Visibility_Constraint.constraint_design_by_contract_consistency\n")
    in
	res
	
    end
end;