(*oops-struct-1*)

(* This oops environment does not allow: send "msg" obj args
   but only allows: send "msg" obj. That is args is disallowed
   therefore everything is of type 'a rather than ('a,'b). 
   Things are neater, but more restrictive *)

structure oops:OOPS = 
struct
 datatype 'a method = Method of (string * ('a -> 'a));
 (* Name of method, function *)

 datatype 'a flavor = Flavor of ('a * ('a method)list);
 (* Instance variables, list of methods *)

 datatype 'a instance = Instance of ('a flavor * 'a ref);
 (* Instance flavor, instance variables *)

 fun defflavor instance_vars = Flavor(instance_vars,[]);

 fun defmethod name flavour f = 
     let val m = Method(name,f)
         val (Flavor(ivars,methods)) = flavour
     in Flavor(ivars,m::methods) end;

 fun make_instance flavour =
     let val Flavor(ivars,_) = flavour in Instance(flavour,ref ivars) end;
    
 exception not_found;
 fun find_method  msg [] = raise not_found
    |find_method msg ((Method(name,f))::x) = 
       if msg=name then f else find_method msg x;

 fun send message object =
     let val Instance(flavour,ivars) = object
         val Flavor(_,methods) = flavour
         val f = find_method message methods
     in ivars:=f (!ivars); object end;

 fun setf object values = 
     let val Instance(_,ivars) = object in ivars := values; object end;
(* Allow the instance variables to be modified via an assignment *)

 fun describe object =
     let val Instance(flavour,ivars) = object
         val Flavor(_,methods) = flavour
     in (!ivars,map (fn a => let val Method(n,_) = a in n end) methods) end;

 fun inst_vars (Instance(_,ivars)) = !ivars;

end;