[Ocaml-lib-devel] properties of symbols

[Christoph B. <c_...@in...>]

Hi,

under Lisp there are to very useful functions `put' and
`get'. Emacs, C-h f put RET ->

put is a built-in function.
(put SYMBOL PROPNAME VALUE)

Store SYMBOL's PROPNAME property with value VALUE.
It can be retrieved with `(get SYMBOL PROPNAME)'.

Eg:

(put 'car 'ccm 1500)
(put 'car 'color 'silver)
(put 'car 'owner "Joe")

(get 'car 'owner)
=> "Joe"

This functionality is something different than hashtabels.
A Hashtable has a type ('a,'b) Hashtbl.t and 'b is fix.

With static typed OCaml it's tricky to implement put and get, but it's
possible. I needed something like this and Alain Frisch referred me to this
old mail 

  http://caml.inria.fr/archives/200105/msg00175.html

This message describes a cute idea how to implement properties in OCaml.

The shown  implementation has two bugs and is slow for symbols
with a lot of properties. I fixed theses issues and here is my
code. Differences are

  * there is no `prop := None' bug (maybe others)
  * it uses a hashtable to find the unit->unit functions (should be much faster)
  * Symbols can be created from strings, variants, ints, ...
  * properties can have trigger-functions, one for get and one for put. These
    function will be called on each reading or modifying of the property. 
    This is maybe more than someone wants, but it's cheap to implement.

I think ExtLib is the right place to provide such a module.

Regards,
Christoph Bauer

(* symbols.mli *)

(** Symbols with properties of various types. *)

module type KEY_TYPE = sig type t end
(** 

  KEYTYPE abstracts from the concret type of a symbol.
  
*)



module Make :
  functor (Key_type : KEY_TYPE) ->
    sig
      type 'a property 
      type symbol 
      val make : Key_type.t -> symbol
	(** [make key] creates a symbol. *)
      val key_of_symbol : symbol -> Key_type.t
	(** [key_of_symbol symbol] returns the key of a symbol. *)

      val make_property :
        ?put_trigger:(symbol -> 'a -> unit) ->
        ?get_trigger:(symbol -> 'a -> unit) -> unit -> 'a property
	(** [make_property ?put_tigger ?get_trigger ()] creates a new property.
	     [put symbol this_property] calls the [put_trigger] (if specified) 
	  and [get symbol this_property] calls the [get_trigger]. *)

      val put : symbol -> 'a property -> 'a -> unit
	(** [put symbol prop value] puts a property with value [value] to a symbol.
	  [put] calls the put_trigger for property.
	*)
      val get : symbol -> 'a property -> 'a
	(** [get symbol property] returns the value of the property of the symbol.  
	  [get] calls the get_trigger for property.
	*)
    end


(** [StringSymbol = Make(String)] *)
module StringSymbol :
  sig
    type 'a property 
    type symbol 
    val symbol_table : (String.t, symbol) Hashtbl.t
    val make : String.t -> symbol
    val key_of_symbol : symbol -> String.t
    val make_property :
      ?put_trigger:(symbol -> 'a -> unit) ->
      ?get_trigger:(symbol -> 'a -> unit) -> unit -> 'a property
    val put : symbol -> 'a property -> 'a -> unit
    val get : symbol -> 'a property -> 'a
  end

(* symbols.ml *)

module type KEY_TYPE =
sig
  type t
end

	    
let some_of = 
  function 
      Some x -> x
    | None -> invalid_arg "some_of"

module Make(Key_type: KEY_TYPE) =
  struct
    type 'a  property = {
      id : int;
      mutable value : 'a option;
      get_trigger : (symbol -> 'a ->  unit) option; (* maybe mutable ? *)
      put_trigger : (symbol -> 'a -> unit) option; (* maybe mutable ? *)
    }
    and symbol = {
      name : Key_type.t;
      mutable properties : (int, unit->unit) Hashtbl.t;
    }
	
    let symbol_table = Hashtbl.create 127
    let make name = 
      try Hashtbl.find symbol_table name 
      with Not_found ->
	let s = { name = name; properties = Hashtbl.create 13 } in
	  Hashtbl.add symbol_table name s;
	  s
	    
    let key_of_symbol symbol = symbol.name
				    
    let pcounter = ref ~-1
    let make_property ?put_trigger ?get_trigger () =  (* not thread safe *)
      incr pcounter;
      { 
	id = !pcounter; 
	value = None;
	get_trigger = get_trigger;
	put_trigger = put_trigger;
      }
	
    let put symbol prop value =
      Hashtbl.add symbol.properties prop.id (fun () -> prop.value <- Some value);
      match prop.put_trigger with
	  Some g -> g symbol value
	| None -> ()

	    
    let get symbol prop =
      let f = Hashtbl.find symbol.properties prop.id in
	f ();
	(match prop.get_trigger with
	     Some g -> g symbol (some_of prop.value);
	   | None -> ());
	some_of prop.value
  end

module StringSymbol = Make(String)


(* symbol_test.ml *)

module Symbol = Symbol.StringSymbol

let () = 
  let symbol = Symbol.make "hello" in
  let string_property = Symbol.make_property 
			  ~get_trigger:  (fun s v -> print_endline ("get on `" ^ Symbol.key_of_symbol s ^ "' returns `" ^ v ^ "'")) () 
  and int_property = Symbol.make_property
		       ~put_trigger: (fun s v -> print_endline ("put `" ^ string_of_int v ^ "' to `" ^ Symbol.key_of_symbol s ^ "'")) () 
  and bool_property = Symbol.make_property () in
    Symbol.put symbol string_property "test";
    Symbol.put symbol int_property 42;
    Symbol.put symbol bool_property true;
    let s = Symbol.get symbol string_property
    and i = Symbol.get symbol int_property
    and b = Symbol.get symbol bool_property in
      print_endline 
	("s=" ^ s ^ "\n" 
	 ^ "i=" ^ string_of_int i ^ "\n"
	 ^ "b=" ^ if b then "true" else "false")



-- 
beginfig(1)u=3cm;draw fullcircle scaled 2u;x0=x1=y1=x2=y3=0;-y0=y2=x3=1u;
filldraw z0..{left}z1{left}..z2{curl 1}..z3..z0..cycle;def t(expr p)=fullcircle
scaled .25u shifted(0,p*u);enddef;unfill t(.5);fill t(-.5);endfig;bye