custom.ml 4.49 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14
module type T = sig
  type t

  (* Debugging *)
  val dump: Format.formatter -> t -> unit
  val check: t -> unit (* Check internal invariants *)

  (* Data structures *)
  val equal: t -> t -> bool
  val hash: t -> int
  val compare:t -> t -> int
end

module Dummy = struct
15 16 17 18 19
  let dump ppf _ = failwith "dump not implemented"
  let check _ = failwith "check not implemented"
  let equal t1 t2 = failwith "equal not implemented"
  let hash t = failwith "hash not implemented"
  let compare t1 t2 = failwith "compare not implemented"
20 21 22 23 24 25 26 27 28 29 30 31 32
end

let dump_list ?(sep="; ") f ppf l =
  Format.pp_print_string ppf "[ ";
  (match l with 
     | [] -> ()
     | [hd] -> f ppf hd
     | hd::tl -> 
	 f ppf hd; 
	 List.iter (fun x -> Format.pp_print_string ppf sep; f ppf x) tl
  );
  Format.pp_print_string ppf " ]"

33 34
let dump_array ?(sep="; ") f ppf a = dump_list ~sep f ppf (Array.to_list a)

35 36 37 38
module String : T with type t = string = struct
  type t = string
  let dump = Format.pp_print_string
  let check s = ()
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53

  let rec compare_string_aux s1 s2 l =
    if (l == 0) then 0 
    else
      let l = pred l in
      let c1 = Char.code (String.unsafe_get s1 l)
      and c2 = Char.code (String.unsafe_get s2 l) in
      if c1 != c2 then c2 - c1 else compare_string_aux s1 s2 l

  let compare s1 s2 =
    let l1 = String.length s1 and l2 = String.length s2 in
    if l1 != l2 then l2 - l1 else compare_string_aux s1 s2 l1


  let equal x y = compare x y = 0
54

55 56 57 58 59 60 61 62 63 64
  (* From btype.ml *)
  let hash s =
    let accu = ref 0 in
    for i = 0 to String.length s - 1 do
      accu := 223 * !accu + Char.code s.[i]
    done;
    (* reduce to 31 bits *)
    accu := !accu land (1 lsl 31 - 1);
    (* make it signed for 64 bits architectures *)
    if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
end

module Int : T with type t = int = struct
  type t = int
  let dump = Format.pp_print_int
  let check s = ()
  let equal : t -> t -> bool = (=)
  let compare : t -> t -> int = Pervasives.compare
  let hash x = x
end

module Bool : T with type t = bool = struct
  type t = bool
  let dump = Format.pp_print_bool
  let check s = ()
  let equal : t -> t -> bool = (=)
  let compare : t -> t -> int = Pervasives.compare
  let hash x = if x then 1 else 0
end

85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
module Array(X : T) = struct
  module Elem = X
  type t = X.t array
  let dump = dump_array X.dump
  let check a = Array.iter X.check a

  let rec compare_elems a1 a2 i l =
    if (i = l) then 0
    else
      let c = X.compare a1.(i) a2.(i) in
      if c <> 0 then c else compare_elems a1 a2 (succ i) l

  let compare a1 a2 =
    let l1 = Array.length a1 and l2 = Array.length a2 in
    let c = Pervasives.compare l1 l2 in if c <> 0 then c
    else compare_elems a1 a2 0 l1

  let equal a1 a2 = compare a1 a2 == 0

  let hash a =
    let h = ref (Array.length a) in
    Array.iter (fun x -> h := 17 * !h + X.hash x) a;
    !h
end

110
module List(X : T) = struct
111 112 113 114
  module Elem : T with type t = X.t = X
  type t = Elem.t list
  let dump = dump_list Elem.dump
  let check l = List.iter Elem.check l
115 116 117 118

  let rec equal l1 l2 =
    (l1 == l2) ||
    match (l1,l2) with
119
      | x1::l1, x2::l2 -> (Elem.equal x1 x2) && (equal l1 l2)
120 121 122 123
      | _ -> false

  let rec hash accu = function
    | [] -> 1 + accu
124
    | x::l -> hash (17 * accu + Elem.hash x) l
125 126 127 128 129 130 131

  let hash l = hash 1 l

  let rec compare l1 l2 =
    if l1 == l2 then 0 
    else match (l1,l2) with
      | x1::l1, x2::l2 -> 
132
	  let c = Elem.compare x1 x2 in if c <> 0 then c
133 134 135 136 137 138 139 140 141 142 143 144 145
	  else compare l1 l2
      | [],_ -> -1
      | _ -> 1
end

module Pair(X : T)(Y : T) = struct
  type t = X.t * Y.t
  let dump ppf (x,y) = Format.fprintf ppf "(%a,%a)" X.dump x Y.dump y
  let check (x,y) = X.check x; Y.check y
  let compare (x1,y1) (x2,y2) =
    let c = X.compare x1 x2 in if c <> 0 then c
    else Y.compare y1 y2
  let equal (x1,y1) (x2,y2) = (X.equal x1 x2) && (Y.equal y1 y2)
146
  let hash (x,y) = X.hash x + 65599 * Y.hash y
147
end
148

149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
type ('a,'b) choice = Left of 'a | Right of 'b

module Sum(X : T)(Y : T) = struct
  type t = (X.t,Y.t) choice
  let equal t1 t2 =
    match t1,t2 with
      | Left t1, Left t2 -> X.equal t1 t2
      | Right t1, Right t2 -> Y.equal t1 t2
      | _ -> false
  let hash = function
    | Left t1 -> 1 + 3 * X.hash t1
    | Right t2 -> 2 + 3 * Y.hash t2
  let compare t1 t2 =
    match t1,t2 with
      | Left t1, Left t2 -> X.compare t1 t2 
      | Right t1, Right t2 -> Y.compare t1 t2
      | Left _, Right _ -> -1
      | Right _, Left _ -> 1
  let check t = ()
  let dump ppf = function
    | Left t -> Format.fprintf ppf "L%a" X.dump t
    | Right t -> Format.fprintf ppf "R%a" Y.dump t
171
end