OCaml in-memory "database" -- I use this for component-based game-objects.

database.ml

(* Database provides key-generation and table-instantiation,
 * so that a key can be associated to various properties.
 *)

(* This is for a fully-controlled specification...
 *
 * module Db = Database.Make (Database.IntKey)
 * module Prop = Db.MultiInherit
 * module PropHash = Prop.Table(Database.Hash)
 * module Size = (val PropHash.create ~default:0 () : Db.Sig with type t = int)
 *
 * module Size = (val Db.MultiInherit.Hashtbl.create ~default:0 ())
 *
 *  -- or even this, if we don't have any inheritance at all
 * module Size = (val Db.Hashtbl.create ~default:0 ())
 *
 *
 *)

(* Signature for database keys, which are commonly integers or GUIDs *)
module type KEY = sig
  type t
  val zero: t
  val hash: 'a -> t
  val incr: t ref -> unit
  val alt: t -> t          (* alt is the mapping to transient-data keys *)
  val invalid: t -> bool
  val to_string: t -> string
end

module IntKey : KEY = struct
  type t = int
  let zero = 0
  let hash = Hashtbl.hash
  let incr = incr
  let alt x = x lor 0x40000000
  let invalid x = x < 0
  let to_string x = string_of_int x
end

(* Abstraction of a "store" -- an associative map from key to data 'a. *)
module type STORE = sig
  type 'a t
  type key
  val create: ?size:int -> unit -> 'a t
  val get: 'a t -> key -> 'a
  val set: 'a t -> key -> 'a -> unit (* XXX what about immutable sets? *)
  val del: 'a t -> key -> unit
  val iter: 'a t -> (key -> 'a -> unit) -> unit
  val fold: 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b
end

(* Functor of Key to Store -- a type passed into the Table functor *)
module type KEYED_STORE = functor (Key:KEY) -> (STORE with type key = Key.t)

(* Adaptation of Hashtbl to the common STORE signature *)
module Hash (Key:KEY) : (STORE with type key = Key.t) = struct
  type key = Key.t
  type 'a t = (key,'a) Hashtbl.t
  let create ?(size=13) () = Hashtbl.create size
  let get = Hashtbl.find (* must return found value or raise Not_found *)
  let set = Hashtbl.replace
  let del = Hashtbl.remove
  let iter h f = Hashtbl.iter f h
  let fold h f init = Hashtbl.fold f h init
end


module Id (Key:KEY) = struct

  (* -- ID Generation -- *)

  exception IdOverflow

  let uniq_transient = ref Key.zero
  let uniq_persistent = ref Key.zero

  (* For Key.t = int, persistent IDs are positive integers 0 .. max_int *)
  let persistent_id () =
    let id = !uniq_persistent in
      if Key.invalid id then raise IdOverflow
      else Key.incr uniq_persistent;
      id

  (* For Key.t = int, transient IDs are negative integers min_int .. -1 *)
  let transient_id () =
    let id = !uniq_transient in
      Key.incr uniq_transient;
      Key.alt id


  (* -- ID/Name Mapping -- *)

  (* 'id' maps hash-generated number to an ID *)
  let (id:(Key.t,Key.t) Hashtbl.t) = Hashtbl.create 13

  (* 'name' maps a string to an ID *)
  let (name:(Key.t,string) Hashtbl.t) = Hashtbl.create 13

  let find_id_by_name n =
    let hashId = Key.hash n in
    (* TODO at least verify that namestrings also match in a 'debug' mode *)
      Hashtbl.find id hashId

  (* Generates a new id if one doesn't already exist for this name *)
  let get_id_by_name n =
    let hashId = Key.hash n in
    try Hashtbl.find id hashId (* should verify that namestrings match *)
    with Not_found ->
      let nId = persistent_id () in
      Hashtbl.replace id hashId nId;
      Hashtbl.replace name nId n;
      nId

  let get_name hashId =
    try Hashtbl.find name hashId
    with Not_found -> "<unknown>"

  let string_of_id id = Key.to_string id

end


module InheritSingle (Key:KEY) = struct

  let (parents:(Key.t, Key.t) Hashtbl.t) = Hashtbl.create 13

  let get_parent id = Hashtbl.find parents id
  let set_parent id parent = Hashtbl.replace parents id parent
  let del_parent id = Hashtbl.remove parents id

  module Get (Store:STORE with type key = Key.t) = struct
    let rec get (s:'a Store.t) (id:Store.key) =
      try Store.get s id
      with Not_found -> get s (get_parent id)

    (* ancestry of component: list of direct and inherited, oldest first *)
    let get_all (s:'a Store.t) (id:Store.key) =
      let rec aux accum i =
        let a =
          try (Store.get s i)::accum
          with Not_found -> accum
        in
        try let next = get_parent i in aux a next
        with Not_found -> a
      in aux [] id
  end

end

module InheritMulti (Key:KEY) = struct

  let (parents:(Key.t, Key.t list) Hashtbl.t) = Hashtbl.create 13

  let get_parents id =
    try Hashtbl.find parents id with Not_found -> []

  let set_parents id alist =
    Hashtbl.replace parents id alist

  let add_parents id alist =
    set_parents id ((get_parents id) @ alist)

  let del_parent id parent =
    let existing = get_parents id in
    set_parents id (List.filter (fun e -> e <> parent) existing)

  module Get (Store:STORE with type key = Key.t) = struct
    (* local utility function to return the first successful result of
     * 'fn' applied to the input list; otherwise re-raise Not_found *)
    let rec first fn = function
      | h::t -> (try fn h with Not_found -> first fn t)
      | _ -> raise Not_found

    let rec get (s:'a Store.t) (id:Store.key) =
      try Store.get s id
      with Not_found -> first (get s) (get_parents id)

    (* ancestry of component: list of direct and inherited, oldest first *)
    let get_all (s:'a Store.t) (id:Store.key) =
      let rec aux accum i =
        let a =
          try (Store.get s i)::accum
          with Not_found -> accum
        in
        try let next = get_parents i in List.fold_left aux a next
        with Not_found -> a
      in aux [] id


  end

end

(* specialize on Key, then we can select inheritance... then instantiate
 * table... *)
module Make (Key:KEY) = struct

  type key = Key.t

  (* this would allow a common ID space...
   * with separate ancestry heirarchies in whatever divisions we desired...
   * and table implementations to further specialize.
   * Of course I get the same effect as a database of one inheritance model
   *   by extracting out a single interface...
   *)

  (* Exempli Gratis:
   *  module IntDb = Database.Make (Database.IntKey)
   *  module Db = IntDb.NoInherit
   *  module Prop = IntDb.MultiInherit
   *  module Offset = (val (Prop.Table(Hash).create ~default:0 ~inheritance:false ()))
   *  module Size = (val (Db.Table(Hash).create ~default:0 ()))
   *  module Offset = (val (Prop.Hashtbl.create ~default:0 ~inheritance:false ()))
   *  module Size = (val (Db.Hashtbl.create ~default:0 ()))
   *)

  include Id(Key)

  module type Sig = sig
    type t
    val get : Key.t -> t             (* return property for id *)
    val get_personal : Key.t -> t    (* will only return a non-inherited property *)
    val get_inheritable : Key.t -> t (* uses inheritance even if table defaults to non-inherited *)
    val get_all : Key.t -> t list    (* list of direct and inherited properties *)
    val set : Key.t -> t -> unit
    val s : t -> Key.t -> Key.t      (* alternative 'set' which is 'pipe'-compatible *)
    val del : Key.t -> unit
    val iter : (Key.t -> t -> unit) -> unit
    val fold : (Key.t -> t -> 'a -> 'a) -> 'a -> 'a
  end

  (* Parts of Sig which are type-agnostic; common between all tables *)
  module type COMMON = sig
    val del : Key.t -> unit
  end

  (* Registration of components at Database level, for id-wise operations
   * like a total delete by id... *)
  let tables : (module COMMON) list ref = ref []
  let register_table m =
    tables := m :: !tables
  let delete id =
    List.iter (fun m -> let module M = (val m:COMMON) in M.del id) !tables
    (* -remove id from inheritance? *)
    (* -add id to recycle FIFO? *)


  let d_size = 13  (* default size for pre-allocated tables *)

  module type GET = functor (Store:(STORE with type key = Key.t)) -> sig
    val get : 'a Store.t -> Store.key -> 'a
    val get_all : 'a Store.t -> Store.key -> 'a list
  end

  module TableImpl (Get:GET) = struct
    module Table (KStore:KEYED_STORE) = struct
      module Store = KStore(Key) (* FIXME let module...? *)
      let create (type s) ?(size=d_size) ?default ?(nhrt=true) () =

        (* Instantiate a table... *)
        let h = Store.create ~size () in

        (* And a base interface to it... *)
        let module T = struct
          module G = Get(Store) (* FIXME let module G = ... in? why no worky? *)
          type t = s
          let get_personal (id:Key.t) = Store.get h id
          let get_inheritable (id:Key.t) = G.get h id
          let get = get_personal
          let get_all (id:Key.t) = G.get_all h id
          let set id (v:t) = Store.set h id v
          let s (v:t) id = Store.set h id v; id
          let del id = Store.del h id
          let iter f = Store.iter h f
          let fold f init = Store.fold h f init
        end in

        (* Modify the interface based on optional parameters... *)
        match (nhrt,default) with
        | (false, Some x) ->
            let module Td = struct
              (*
              include AddDefault(T,struct value=x end)
              let get = get_personal
              *)
              include T
              let get_personal (id:Key.t) = try T.get_personal id with Not_found -> x
              let get_inheritable (id:Key.t) = try T.get_inheritable id with Not_found -> x
              let get = get_personal
            end in
            register_table (module Td:COMMON);
            (module Td : Sig with type t = s)

        | (true, Some x) ->
            let module Td = struct
              include T
              let get_personal (id:Key.t) = try T.get_personal id with Not_found -> x
              let get_inheritable (id:Key.t) = try T.get_inheritable id with Not_found -> x
              let get = get_inheritable
            end in
            register_table (module Td:COMMON);
            (module Td : Sig with type t = s)

        | (false, None) ->
            register_table (module T:COMMON);
            (module T : Sig with type t = s)

        | (true, None) ->
            let module Td = struct
              include T
              let get = get_inheritable
            end in
            register_table (module Td:COMMON);
            (module Td : Sig with type t = s)
    end
  end

  (* For no-inheritance ... *)
  module Get (Store:STORE with type key = Key.t) = struct
    let get (s:'a Store.t) (id:Store.key) = Store.get s id
    let get_all s id = try [get s id] with Not_found -> []
  end
  include TableImpl(Get)
  module Hashtbl = Table(Hash)

  (*
  module NoInherit = struct
    (* TODO here, Get is just the normal Store.get *)
    include TableImpl(Get)
  end
  *)
  module SingleInherit = struct
    include InheritSingle(Key)
    include TableImpl(Get)
    module Hashtbl = Table(Hash)
  end
  module MultiInherit = struct
    include InheritMulti(Key)
    include TableImpl(Get)
    module Hashtbl = Table(Hash)
  end

end

database.mli

module type KEY =
  sig
    type t
    val zero : t
    val hash : 'a -> t
    val incr : t ref -> unit
    val alt : t -> t
    val invalid : t -> bool
    val to_string : t -> string
  end
module type STORE =
  sig
    type 'a t
    type key
    val create : ?size:int -> unit -> 'a t
    val get : 'a t -> key -> 'a
    val set : 'a t -> key -> 'a -> unit
    val del : 'a t -> key -> unit
    val iter : 'a t -> (key -> 'a -> unit) -> unit
    val fold : 'a t -> (key -> 'a -> 'b -> 'b) -> 'b -> 'b
  end
module type KEYED_STORE = functor (Key : KEY) -> (STORE with type key = Key.t)

module IntKey : KEY
module Hash : KEYED_STORE

module Make :
  functor (Key : KEY) ->
    sig
      type key = Key.t
      exception IdOverflow
      val persistent_id : unit -> key
      val transient_id : unit -> key
      val find_id_by_name : 'a -> key
      val get_id_by_name : string -> key
      val get_name : key -> string
      val string_of_id : key -> string
      val delete : key -> unit
      module type Sig =
        sig
          type t
          val get : key -> t             (* get, obeying table's inheritance setting *)
          val get_personal : key -> t    (* ignore inheritance *)
          val get_inheritable : key -> t (* permit inheritance (overriding default) *)
          val get_all : key -> t list    (* for a stacked component *)
          val set : key -> t -> unit     (* set value on key; stacking is possible *)
          val s : t -> key -> key        (* set, but an alternate calling signature *)
          val del : key -> unit          (* delete this component from key *)
          val iter : (key -> t -> unit) -> unit
          val fold : (key -> t -> 'a -> 'a) -> 'a -> 'a
        end
      module type COMMON =
        sig
          val del : key -> unit
        end
      module Table :
        functor (KStore : KEYED_STORE) ->
          sig
            val create :
              ?size:int ->
              ?default:'a ->
              ?nhrt:bool -> unit -> (module Sig with type t = 'a)
          end
      module Hashtbl :
        sig
          val create :
            ?size:int ->
            ?default:'a ->
            ?nhrt:bool -> unit -> (module Sig with type t = 'a)
        end
      module SingleInherit :
        sig
          val get_parent : key -> key
          val set_parent : key -> key -> unit
          val del_parent : key -> unit
          module Table :
            functor (KStore : KEYED_STORE) ->
              sig
                val create :
                  ?size:int ->
                  ?default:'a ->
                  ?nhrt:bool -> unit -> (module Sig with type t = 'a)
              end
          module Hashtbl :
            sig
              val create :
                ?size:int ->
                ?default:'a ->
                ?nhrt:bool -> unit -> (module Sig with type t = 'a)
            end
        end
      module MultiInherit :
        sig
          val get_parents : key -> key list
          val set_parents : key -> key list -> unit
          val add_parents : key -> key list -> unit
          val del_parent : key -> key -> unit
          module Table :
            functor (KStore : KEYED_STORE) ->
              sig
                val create :
                  ?size:int ->
                  ?default:'a ->
                  ?nhrt:bool -> unit -> (module Sig with type t = 'a)
              end
          module Hashtbl :
            sig
              val create :
                ?size:int ->
                ?default:'a ->
                ?nhrt:bool -> unit -> (module Sig with type t = 'a)
            end
        end
    end