Version française
Home     About     Download     Resources     Contact us    
Browse thread
Functorized stdlib ???
[ Home ] [ Index: by date | by threads ]
[ Search: ]

[ Message by date: previous | next ] [ Message in thread: previous | next ] [ Thread: previous | next ]
Date: -- (:)
From: bravier@d...
Subject: Functorized stdlib ???

961004
(* ========================================================================= *)
Here is a suggestion about the standard ocaml library Hashtbl.

This module is very useful but it happens to uses the polymorphic
equality ( = ) : 'a -> 'a -> bool.

Unfortunately, there are cases where you want a hash-table with another
equality predicate, for example you might want physical equality ( == ).

This is precisely what functors are for !

Here is first a short example building a min function from an order
(the order is possibly polymorphic)

(* ========================================================================= *)
(* short_example.ml *)
(* ========================================================================= *)
module type ORDER =
sig
   type 'a t
   val ( <= ) : 'a t -> 'a t -> bool
end

module Min (Order : ORDER) =
struct
   let min x y = if (Order.( <= ) x y) then x else y
end

(* ========================================================================= *)
module OrderPoly =
struct
   type 'a t = 'a
   let ( <= ) = ( <= )
end

module MinPoly = Min (OrderPoly)

(* ========================================================================= *)
module OrderString =
struct
   type 'a t = string
   let ( <= ) x y = String.length x <= String.length y
end

module MinString = Min (OrderString)

(* ========================================================================= *)

let _ =
begin
   Printf.printf "minpoly   3.14 2.71 = %.2f\n" (MinPoly.min 3.14 2.71);
   Printf.printf "minpoly   b    az   = %s\n"   (MinPoly.min "b" "az");
   Printf.printf "minstring b    az   = %s\n"   (MinString.min "b" "az");
   ()
end

(* ========================================================================= *)

And here, applied to hash-tables to get polymorphic
(or, if needed, monomorphic) hash-tables :

(* ========================================================================= *)
(* File h.mli *)
(* ========================================================================= *)
module type EQUALITY =
  sig
    type 'a t
    val ( = ) : 'a t -> 'a t -> bool
    val hash_param : int -> int -> 'a t -> int
  end

module type H =
    sig
      type 'a equality
      type ('a, 'b) t
      val create : int -> ('a, 'b) t
      val clear : ('a, 'b) t -> unit
      val add : ('a equality, 'b) t -> 'a equality -> 'b -> unit
      val remove : ('a equality, 'b) t -> 'a equality -> unit
      val find : ('a equality, 'b) t -> 'a equality -> 'b
      val find_all : ('a equality, 'b) t -> 'a equality -> 'b list
      val iter : ('a equality -> 'b -> 'c) -> ('a equality, 'b) t -> unit
    end

module H (Equality : EQUALITY) : (H with type 'a equality = 'a Equality.t)

(* ========================================================================= *)
module HEqual : (H with type 'a equality = 'a)
module HEq : (H with type 'a equality = 'a)

(* ========================================================================= *)

(* ========================================================================= *)
(* File h.ml : contains stdlib/hashtbl.ml mostly unmodified *) 
(* ========================================================================= *)
module type EQUALITY =
sig
   type 'a t
   val ( = ) : 'a t -> 'a t -> bool
   val hash_param : int -> int -> 'a t -> int
end

module type H =
    sig
      type 'a equality
      type ('a, 'b) t
      val create : int -> ('a, 'b) t
      val clear : ('a, 'b) t -> unit
      val add : ('a equality, 'b) t -> 'a equality -> 'b -> unit
      val remove : ('a equality, 'b) t -> 'a equality -> unit
      val find : ('a equality, 'b) t -> 'a equality -> 'b
      val find_all : ('a equality, 'b) t -> 'a equality -> 'b list
      val iter : ('a equality -> 'b -> 'c) -> ('a equality, 'b) t -> unit
    end

(* ========================================================================= *)
module H (Equality : EQUALITY) =
struct
   let ( -- ) = ( = )
   and ( = ) = Equality.( = )
   and hash_param = Equality.hash_param
   type 'a equality = 'a Equality.t
(* ========================================================================= *)


(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id: hashtbl.ml,v 1.5 1996/04/30 14:50:09 xleroy Exp $ *)

(* Hash tables *)

(* We do dynamic hashing, and we double the size of the table when
   buckets become too long, but without re-hashing the elements. *)

type ('a, 'b) t =
  { mutable max_len: int;                    (* max length of a bucket *)
    mutable data: ('a, 'b) bucketlist array } (* the buckets *)

and ('a, 'b) bucketlist =
    Empty
  | Cons of 'a * 'b * ('a, 'b) bucketlist

let create initial_size =
  { max_len = 2; data = Array.create initial_size Empty }

let clear h =
  for i = 0 to Array.length h.data - 1 do
    h.data.(i) <- Empty
  done

let resize h =
  let n = Array.length h.data in
  let newdata = Array.create (n+n) Empty in
    Array.blit h.data 0 newdata 0 n;
    Array.blit h.data 0 newdata n n;
    h.data <- newdata;
    h.max_len <- 2 * h.max_len

let rec bucket_too_long n bucket =
  if n < 0 then true else
    match bucket with
      Empty -> false
    | Cons(_,_,rest) -> bucket_too_long (pred n) rest

(* CHANGE : removed external declaration of hash_param *)

let add h key info =
  let i = (hash_param 10 100 key) mod (Array.length h.data) in
  let bucket = Cons(key, info, h.data.(i)) in
    h.data.(i) <- bucket;
    if bucket_too_long h.max_len bucket then resize h

let remove h key =
  let rec remove_bucket = function
      Empty ->
        Empty
    | Cons(k, i, next) ->
        if k = key then next else Cons(k, i, remove_bucket next) in
  let i = (hash_param 10 100 key) mod (Array.length h.data) in
    h.data.(i) <- remove_bucket h.data.(i)

let find h key =
  match h.data.((hash_param 10 100 key) mod (Array.length h.data)) with
    Empty -> raise Not_found
  | Cons(k1, d1, rest1) ->
      if key = k1 then d1 else
      match rest1 with
        Empty -> raise Not_found
      | Cons(k2, d2, rest2) ->
          if key = k2 then d2 else
          match rest2 with
            Empty -> raise Not_found
          | Cons(k3, d3, rest3) ->
              if key = k3 then d3 else begin
                let rec find = function
                    Empty ->
                      raise Not_found
                  | Cons(k, d, rest) ->
                      if key = k then d else find rest
                in find rest3
              end

let find_all h key =
  let rec find_in_bucket = function
    Empty ->
      []
  | Cons(k, d, rest) ->
      if k = key then d :: find_in_bucket rest else find_in_bucket rest in
  find_in_bucket h.data.((hash_param 10 100 key) mod (Array.length h.data))

let iter f h =
  let d = h.data in
  let len = Array.length d in
  for i = 0 to len - 1 do
    let rec do_bucket = function
        Empty ->
          ()
      | Cons(k, d, rest) ->
          if (hash_param 10 100 k) mod len -- i (* CHANGE -- instead of == *)
          then begin f k d; do_bucket rest end
          else do_bucket rest in
    do_bucket d.(i)
  done

let hash x = hash_param 50 500 x
(* ========================================================================= *)
(* original stdlib/hashtbl.ml ends here *)
(* ========================================================================= *)
end

(* ========================================================================= *)
module EqualityEqual =
struct
   type 'a t = 'a
   let ( = ) = ( = )
   let hash_param = Hashtbl.hash_param
end

module HEqual = H (EqualityEqual)

(* ========================================================================= *)
module EqualityEq =
struct
   type 'a t = 'a
   let ( = ) = ( == )

   (* just to try *)
   (*
   let hash_param _ _ x = 0
   *)
   (* or more realistic *)
   (**)
   external hash_eq : 'a -> int = "ML_hash_eq"
   let hash_param _ _ = hash_eq
   (**)
end

module HEq = H (EqualityEq)

(* ========================================================================= *)

/* ========================================================================= */
/* file h_c.c : found inspiration in byterun/hash.c */
/* ========================================================================= */
#include <mlvalues.h>

value ML_hash_eq (value v) { return Val_long (v & 0x3FFFFFFF); }
  /* The & has two purposes: ensure that the return value is positive
     and give the same result on 32 bit and 64 bit architectures. */
   
/* ========================================================================= */

(* ========================================================================= *)
(* file test_h.ml *)
(* ========================================================================= *)
module HEqual = H.HEqual
module Hashtbl = HEqual            (* backward compatibility is possible *)

let tequal = HEqual.create 127
let _ =
begin
   HEqual.add tequal 1 "one";
   ()
end
let dummy = HEqual.find tequal 1   (* "one" *)

(* ========================================================================= *)
module HEq = H.HEq

let a1 = "a"
and a2 = "a"                       (* a1 = a2 but a1 != a2 *)

let teq = HEq.create 127
let _ =
begin
   HEq.add teq a1 1;
   HEq.add teq a2 2;
   ()
end
let dummy = HEq.find teq a1        (* 1 *)
let dummy = HEq.find teq a2        (* 2 *)

(* ========================================================================= *)

It seems to me that functors and polymorphism might/should go together well.

At any rate I would like a way to conceive modules and functors that
do not forbid polymorphism because, if you look at the short example :

module type ORDER =
sig
   type 'a t
   val ( <= ) : 'a t -> 'a t -> bool
end

It is really conter-intuitive since I have to parameterize the type t
with 'a before any use of type t.

What I first wrote (which does not work in the end) was :

module type ORDER_first =
sig
   type t
   val ( <= ) : 'a t -> 'a t -> bool
end

this is what I meant but OrderPoly was not of module type ORDER_first,
that's why I finally had to choose type 'a t.

Unfortunately this is no real solution since a predicate over
couples, say (fun (x1,y1) (x2, y2) -> y1 <= y2) : 'a * 'b -> 'a * 'b -> bool
will not fit in module type ORDER whose type 'a t has only one parameter.

Well, well, if somebody has clues ...

By the way, this technique of using paramerized types can also be used
to modify the Set module of stdlib to get a polymorphic set type
(just change type t into type 'obj t and type elt into type 'obj elt !)

This does not seem much but it enables the user to share code (as I do not
know whether applying functors duplicates code or not) and most of all, to
use only one module (no need to create modules all over the code ...)

Please, feel free to be controversial :-)

(* ========================================================================= *)
Thierry Bravier
Dassault Aviation.
DGT / DTN / ELO / EAV
78, Quai Marcel Dassault
F-92214 Saint-Cloud Cedex
France

Telephone : (33) 01 47 11 53 07
Telecopie : (33) 01 47 11 52 83
E-Mail :    bravier@dassault-avion.fr

(* ========================================================================= *)