alist.ml

type (_, _) eq =
  | Eq : ('a, 'a) eq
  | NEq : (_, _) eq

module type Eq = sig
  type 'a key
  type 'a value
  val eq : 'a key -> 'b key -> ('a, 'b) eq
end

module Make (E : Eq) = struct
  type 'a key = 'a E.key
  type 'a value = 'a E.value
  type t = Nil | Cons : 'a key * 'a value * t -> t

  let empty = Nil
  let cons k v list = Cons (k, v, list)

  let rec mem : type a . a key -> t -> bool =
    fun key -> function
      | Nil -> false
      | Cons (k, _, rest) ->
        match E.eq key k with
        | NEq -> mem key rest
        | Eq -> true

  let length list =
    let rec count len = function
      | Nil -> len
      | Cons (_, _, rest) -> count (len + 1) rest in
    count 0 list

  let rec find : type a . a key -> t -> a value option =
    fun key -> function
      | Nil -> None
      | Cons (k, v, rest) ->
        match E.eq key k with
        | NEq -> find key rest
        | Eq -> Some v

  let rec append a b = match a with
    | Nil -> b
    | Cons (k, v, rest) -> Cons (k, v, append rest b)

  let rev list =
    let rec loop acc = function
      | Nil -> acc
      | Cons (k, v, rest) -> loop (Cons (k, v, acc)) rest in
    loop list

  type 'a polymorphic_op = {
    f : 'b . 'b key -> 'b value -> 'a;
  }

  let rec fold f init = function
    | Nil -> init
    | Cons (k, v, rest) -> fold f (f.f k v init) rest

  type poly = Wrap : 'a key * 'a value -> poly

  let rec map f = function
    | Nil -> Nil
    | Cons (k, v, rest) ->
      let Wrap (k', v') = f.f k v in
      Cons (k', v', map f rest)
end

type _ ty =
  | Int : int ty
  | Float : float ty
  | String : string ty

module M = struct
  type 'a key = 'a ty
  type 'a value = 'a
  let eq : type a b . a key -> b key -> (a, b) eq =
    fun a b ->
    match a, b with
    | Int, Int -> Eq
    | Float, Float -> Eq
    | String, String -> Eq
    | _, _ -> NEq
end

module X = Make (M)

let zeros =
  X.Nil
  |> X.cons Int 0
  |> X.cons Float 0.0
  |> X.cons String ""