A stab at generics in OCaml

generics.ml

(* Generics for OCaml
 *
 * This is a huge hack. It doesn't work with higher-kinded types. It, well,
 * hardly works for anything but the provided samples :-P
 *)

(* Standard Generic representation types *)
(* Unit *)
type u = U
(* Sum types ('Plus') *)
type ('a, 'b) p = L of 'a | R of 'b
(* Product types ('Mul') *)
type ('a, 'b) m = M of 'a * 'b

(* Value-level representation of rep types. See later... *)
type _ rep =
  | RU : u rep
  | RP : (string * 'a rep) * (string * 'b rep) -> (('a, 'b) p) rep
  | RM : 'a rep * 'b rep -> (('a, 'b) m) rep

module type GENERIC = sig
    (* Type represented *)
    type a
    (* Type representation *)
    type repA

    (* Hack: value-level representation of repA for runtime interpretation purposes *)
    val repV : repA rep

    (* Conversions *)
    val fromA : a -> repA
    val toA : repA -> a
end

(* Generic instance for built-in bool *)
module GBool : (GENERIC with type a = bool and type repA = (u, u) p) = struct
    type a = bool
    type repA = (u, u) p

    (* Note it's impossible to define a repV which is incompatible with given repA :-) *)
    let repV = RP (("false", RU), ("true", RU))

    let fromA = function
      | false -> L U
      | true -> R U

    let toA = function
      | L U -> false
      | R U -> true
end

(* A generic 'eq' *)
module GEq = functor(A: GENERIC) -> struct
    let eq (a: A.a) (b: A.a): bool =
        let rec helperU U U =
            true

        and helperP :
            type a b. ((string * a rep) * (string * b rep)) -> (a, b) p -> (a, b) p -> bool =
            fun ((_, ta), (_, tb)) pa pb -> match (pa, pb) with
              | (L la, L lb) -> helper ta la lb
              | (R ra, R rb) -> helper tb ra rb
              | (_, _) -> false

        and helperM :
            type a b. (a rep * b rep) -> (a, b) m -> (a, b) m -> bool =
            fun (ta, tb) (M (ma1, mb1)) (M (ma2, mb2)) ->
                helper ta ma1 ma2 && helper tb mb1 mb2

        and helper :
            type a. a rep -> a -> a -> bool =
            fun t ha hb -> match t with
              | RU -> helperU ha hb
              | RP (ia, ib) -> helperP (ia, ib) ha hb
              | RM (ia, ib) -> helperM (ia, ib) ha hb
        in

        helper A.repV (A.fromA a) (A.fromA b)
end

(* A generic 'show' *)
module GShow = functor(A: GENERIC) -> struct
    let show (a: A.a): string =
        let rec helperU U =
            ""

        and helperP :
            type a b. ((string * a rep) * (string * b rep)) -> (a, b) p -> string =
            fun ((na, ta), (nb, tb)) p ->
                let handle n s =
                    if String.length s = 0
                    then n
                    else Printf.sprintf "(%s %s)" n s
                in
                match p with
                  | L lp -> handle na (helper ta lp)
                  | R rp -> handle nb (helper tb rp)

        and helperM :
            type a b. (a rep * b rep) -> (a, b) m -> string =
            fun (ta, tb) (M (ma, mb)) ->
                Printf.sprintf "(%s) (%s)" (helper ta ma) (helper tb mb)

        and helper :
            type a. a rep -> a -> string =
            fun t ha -> match t with
              | RU -> helperU ha
              | RP (ia, ib) -> helperP (ia, ib) ha
              | RM (ia, ib) -> helperM (ia, ib) ha
        in

        helper A.repV (A.fromA a)
end

(* Demo *)
let main () =
    let module EqBool = GEq(GBool) in
    let module ShowBool = GShow(GBool) in
    let eq = EqBool.eq
    and show = ShowBool.show in

    let do_test_eq a b =
        Printf.printf "eq %s %s = %s\n" (show a) (show b) (show (eq a b))
    in

    do_test_eq true true;
    do_test_eq true false;
    do_test_eq false true;
    do_test_eq false false

;;

main ()