typeclass.ml

type _ trep = ..
type _ trep +=
   | TInt: int trep
   | TString: string trep
   | TFloat: float trep
   | TList: 'a trep -> 'a list trep
   | TFun: ('a trep * 'b trep) -> ('a -> 'b) trep

(* Emulating type classes *)
module ShowClass = struct
  type _ key = ..
  effect Show: ('a key * 'a) -> string
  effect Resolve: 'a trep -> 'a key
  let resolve trep =
    perform (Resolve trep)
  let show trep s =
    perform (Show (perform (Resolve trep),s))
end

module IntShow = struct
  type _ ShowClass.key += Key : int ShowClass.key
  let handler action =
    try action () with
    | effect (ShowClass.Resolve TInt) c ->
       continue c Key
    | effect (ShowClass.Show (Key, x)) c ->
       continue c (Printf.sprintf "%d" x)
end

module ListShow = struct
  (* The formation of key constructors reflects type class constraints *)
  type _ ShowClass.key += Key : 'a ShowClass.key -> 'a list ShowClass.key
  let rec format k xs = match xs with
    | [] -> ""
    | x :: [] -> perform (ShowClass.Show (k, x))
    | x :: xs -> Printf.sprintf "%s;%s" (perform (ShowClass.Show (k, x))) (format k xs)
  let handler action =
    try action () with
    | effect (ShowClass.Resolve (TList trep)) c ->
       continue c (Key (ShowClass.resolve trep))
    | effect (ShowClass.Show (Key k, xs)) c ->
       continue c (Printf.sprintf "[%s]" (format k xs))
end

let context action = IntShow.handler (fun () -> ListShow.handler action)

let demo () = ShowClass.show (TList TInt) [1;2;3]

let _ = context demo

;;