(*
 * Env library
 * Copyright (C) 2006 Julien SIGNOLES
 * 
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Library General Public
 * License version 2, as published by the Free Software Foundation.
 * 
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 * 
 * See the GNU Library General Public License version 2 for more details
 *)

module type COMPARABLE = sig
  type t
  val compare: t -> t -> int
  val equal: t -> t -> bool
  val hash: t -> int
end

module type MAP = sig
  type key
  type 'a t
  val empty: 'a t
  val is_empty: 'a t -> bool
  val add: key -> 'a -> 'a t -> 'a t
  val remove: key -> 'a t -> 'a t
  val find: key -> 'a t -> 'a
  val mem: key -> 'a t -> bool
  val iter: (key -> 'a -> unit) -> 'a t -> unit
  val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
end

module type HASHTBL = sig
  type key
  type 'a t
  val create: int -> 'a t
  val length: 'a t -> int
  val add: 'a t -> key -> 'a -> unit
  val remove: 'a t -> key -> unit
  val find: 'a t -> key -> 'a
  val find_all: 'a t -> key -> 'a list
  val mem: 'a t -> key -> bool
  val iter: (key -> 'a -> unit) -> 'a t -> unit
  val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b   
end

module type TBL = sig
  type key
  type kind = Persistent | Imperative
  type 'a t
  val create: kind -> 'a t
  val is_empty: 'a t -> bool
  val copy: 'a t -> 'a t
  val add: key -> 'a -> 'a t -> 'a t
  val remove: key -> 'a t -> 'a t
  val find: key -> 'a t -> 'a
  val find_all: key -> 'a t -> 'a list
  val mem: key -> 'a t -> bool
  val iter: (key -> 'a -> unit) -> 'a t -> unit
  val iter_all: (key -> 'a -> unit) -> 'a t -> unit
  val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
  val fold_all: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
end

module type S = sig
  include TBL
  exception Empty
  val push: kind -> 'a t -> 'a t
  val pop: 'a t -> 'a t
  val top: 'a t -> 'a t
end

(** Generic operations on tables, whether imperative or persistent. *)
module Build_Tbl(M : MAP)(H : HASHTBL with type key = M.key) : sig

  include TBL with type key = M.key

  (** Internal function used if the current binding of a key changes. *)
  val swap_visibility: key -> 'a t -> 'a t

end = struct

  type kind = Persistent | Imperative

  type key = M.key

  (** Mutability is only used by imperative tables (hash tables):
      see function [swap_visibility]. *)
  type 'a value = { data: 'a; mutable visible: bool }

  type 'a t =
    | Per of 'a value list M.t
    | Imp of 'a value H.t 
        (* Hash tables already has the list of all data associated to a key. *)

  let create = function
    | Persistent -> Per M.empty
    | Imperative -> Imp (H.create 17)

  let copy = function
    | Per _ as t -> t
    | Imp tbl -> 
        (* Do not share the field [visible], so do not use [H.copy]. 
           Morever preserve order of bindings in the new table. *)
        let tbl' = H.create (2 * H.length tbl + 1) in
        let l = H.fold (fun k v acc -> (k, v) :: acc) tbl [] in
        List.iter (fun (k,v) -> H.add tbl' k { v with visible = v.visible }) l;
        Imp tbl'

  let compute m h = function
    | Per tbl -> m tbl
    | Imp tbl -> h tbl

  let is_empty tbl = compute M.is_empty (fun t -> H.length t = 0) tbl

  let mem k = compute (M.mem k) (fun t -> H.mem t k)

  let gen_iter f = compute (M.iter (fun k -> List.iter (f k))) (H.iter f)

  let iter f = gen_iter (fun k v -> if v.visible then f k v.data)

  let iter_all f = gen_iter (fun k v -> f k v.data)

  let gen_fold f tbl acc =
    let mfold f tbl acc =
      M.fold 
        (fun k l acc -> List.fold_left (fun acc v -> f k v acc) acc l) tbl acc
    in
    compute (fun tbl -> mfold f tbl acc) (fun tbl -> H.fold f tbl acc) tbl

  let fold f = 
    gen_fold (fun k v acc -> if v.visible then f k v.data acc else acc)

  let fold_all f = gen_fold (fun k v -> f k v.data)
    
  let remove k = function
    | Per tbl -> Per (M.remove k tbl)
    | Imp tbl as t -> H.remove tbl k; t
    
  let find k = function
    | Per tbl ->     
        (match M.find k tbl with
         | [] -> assert false
         | v :: _ -> v.data)
    | Imp tbl -> 
        (H.find tbl k).data

  let find_all k = function
    | Per tbl -> 
        (try List.map (fun v -> v.data) (M.find k tbl) with Not_found -> [])
    | Imp tbl -> 
        List.map (fun v -> v.data) (H.find_all tbl k)

  let swap_visibility k = function
    | Per tbl ->
        Per (match M.find k tbl with
             | [] -> assert false
             | v :: l -> M.add k ({ v with visible = not v.visible } :: l) tbl)
    | Imp tbl as t -> 
        let v = H.find tbl k in
        v.visible <- not v.visible;
              t

  let add k d tbl =
    let v = { data = d; visible = true } in
    match tbl with
    | Per tbl ->
        Per (try
               let l = M.find k tbl in
               M.add k (v :: l) tbl
             with Not_found ->
               M.add k [ v ] tbl)
    | Imp tbl as t -> 
        H.add tbl k v; 
        t

end

module Build(Map : MAP)(Hashtbl : HASHTBL with type key = Map.key) = struct

  module Tbl = Build_Tbl(Map)(Hashtbl)

  type kind = Tbl.kind = Persistent | Imperative

  type key = Tbl.key

  (** Persistent stack of tables. *)
  type 'a t = 'a Tbl.t list

  let create kind = [ Tbl.create kind ]

  let rec is_empty = function
    | [] -> true
    | tbl :: stack -> Tbl.is_empty tbl && is_empty stack

  (* No partial application for polymorphism *)
  let copy env = List.map Tbl.copy env

  let push kind env = Tbl.create kind :: env

  exception Empty

  (** Swap the visibility of the current binding of [k], if any, in an
      environment. *)
  let rec swap_visibility k = function
    | [] -> []
    | tbl :: stack -> 
        try 
          Tbl.swap_visibility k tbl :: stack
        with Not_found -> 
          tbl :: swap_visibility k stack

  let pop = function
    | [] -> raise Empty
    | tbl :: stack -> Tbl.fold (fun k _ -> swap_visibility k) tbl stack

  let top = function
    | [] -> raise Empty
    | tbl :: _ -> [ tbl ]

  let add k d = function
    | [] -> raise Empty
    | _ :: _ as stack -> 
        match swap_visibility k stack with
        | [] -> assert false
        | tbl :: stack -> Tbl.add k d tbl :: stack

  let rec find k = function
    | [] -> raise Not_found
    | tbl :: stack -> try Tbl.find k tbl with Not_found -> find k stack

  let rec find_all k = function
    | [] -> []
    | tbl :: stack -> 
        List.fold_right 
          (fun v acc -> v :: acc) 
          (Tbl.find_all k tbl) 
          (find_all k stack) 

  let rec mem k = function
    | [] -> false
    | tbl :: stack -> Tbl.mem k tbl || mem k stack

  let rec remove k = function
    | [] -> []
    | tbl :: stack ->
        if Tbl.mem k tbl then
          let tbl = Tbl.remove k tbl in
          swap_visibility k (tbl :: stack)
        else
          tbl :: remove k stack

  let iter f = List.iter (Tbl.iter f)

  let iter_all f = List.iter (Tbl.iter_all f)

  let gen_fold f stack acc =
    List.fold_left (fun acc tbl -> f tbl acc) acc stack

  let fold f = gen_fold (Tbl.fold f)

  let fold_all f = gen_fold (Tbl.fold_all f)

end

module Make(Key : COMPARABLE) = Build(Map.Make(Key))(Hashtbl.Make(Key))

This document was generated using caml2html