ppx_typeclass test

monad_test.ml

(* Monads with camlspotter's ppx_typeclass *)
(* see ppx_typeclass http://bitbucket.org/camlspotter/ppx_typeclass/ *)

(* Set-up higher-kinded polymorphism, see https://ocamllabs.github.io/higher/lightweight-higher-kinded-polymorphism.pdf *)
type ('p, 'f) app = .. (* Type-level defunctionalization *)

module Newtype1 (T: sig type 'a t end) () = struct
  type 'a s = 'a T.t
  type t
  type (_, _) app += App : 'a s -> ('a, t) app
  let inj v = App v
  let prj = function
    | App v -> v
    | _ -> assert false
end

module type MonadDict = sig
  type m
  val return : 'a -> ('a, m) app
  val (>>=) : ('a, m) app -> ('a -> ('b, m) app) -> ('b, m) app
end

module Monad = struct
  type 'm d = (module MonadDict with type m = 'm)
  let return (type m) ?_d = match _d with
    | None -> assert false
    | Some _d ->
       let module D = (val (_d : m d)) in D.return
  let (>>=) (type m) ?_d = match _d with
    | None -> assert false
    | Some _d ->
       let module D = (val (_d : m d)) in D.(>>=)
end

(* monad util functions *)
let (>>) (type m) ?(_d: m Monad.d option) (m : ('a, m) app) (n : ('b, m) app) : ('b, m) app =
  Monad.(>>=) ?_d m (fun _ -> n)

let rec replicateM_ ?_d (i : int) m =
  if i = 0 then
    Monad.return ?_d ()
  else
    (>>) ?_d m (replicateM_ ?_d (i-1) m)


open Monad

(* identity monad *)
module T_id = Newtype1(struct type 'a t = 'a end)(struct end)
type idmonad = T_id.t
let runId = T_id.prj

(* integer-state monad *)
module T_istate = Newtype1(struct type 'a t = int -> 'a * int end)(struct end)
type istate = T_istate.t
let get : (int, istate) app = T_istate.inj (fun i -> i, i)
let put i : (unit, istate) app = T_istate.inj (fun _ -> (), i)
let runState m i = fst (T_istate.prj m i)

(* type-class instances *)
module Instance = struct
  let idmonad : idmonad Monad.d =
    (module
       (struct
         type m = idmonad
         let return = T_id.inj
         let (>>=) m f = f (T_id.prj m)
       end))

  let istate : istate Monad.d =
    (module
       (struct
         type m = istate
         let return x = T_istate.inj (fun s -> x,s)
         let (>>=) m f = T_istate.inj (fun s -> match (T_istate.prj m) s with x',s' -> T_istate.prj (f x') s')
       end))
end

let inc () =
  get >>= fun i -> put (i+1)

let _ =
  assert (3 = runId (return 1 >>= fun x -> return (x + 2)));
  assert (10 = runState (replicateM_ 10 (inc ()) >> get) 0);
  print_endline "ok."

num_test.ml

(* see ppx_typeclass http://bitbucket.org/camlspotter/ppx_typeclass/ *)
module type NumT = sig
  type t
  val (+) : t -> t -> t
end

module Num = struct
  type 'a d = (module NumT with type t = 'a)
  let (+) (type a) ?_d = match _d with
    | None -> assert false
    | Some _d ->
      let module D = (val (_d : a d)) in D.(+)
end

module Instance = struct
  let numint : int Num.d =
    (module (struct type t = int let (+) = (+) end))
  let numfloat : float Num.d =
    (module (struct type t = float let (+) = (+.) end))

  (* polyvars can be an instance *)
  let num_mypoly : [`A of int] Num.d =
    (module (struct type t = [`A of int] let (+) (`A(x)) (`A(y)) = `A(x + y) end))

  (* objects also do! *)
  let num_myobj : <f : int> Num.d =
    (module (struct type t = <f : int> let (+) o1 o2 = object method f = o1#f + o2#f end end))

  module type T = sig val f : int end

  (* first class mod. *)
  let num_mymod : (module T) Num.d =
    (module (struct type t = (module T) let (+) (m1 : (module T)) (m2 : (module T)) = let module M1 = (val m1) in let module M2 = (val m2) in (module (struct let f = M1.f + M2.f end) : T) end))
end

open Num

let _ =
assert (1 + 2 = 3);                                                                                                                                                                                                                                    
assert (1. + 2. = 3.);                                                                                                                                                                                                                                 
assert (`A 1 + `A 2 = `A 3);                                                                                                                                                                                                                           
assert ((object method f = 1 end + object method f = 2 end)#f = 3);                                                                                                                                                                                    
assert (let m = (module (struct let f = 1 end) : Instance.T) + (module (struct let f = 2 end) : Instance.T) in let module M = (val m) in M.f = 3);                                                                                                     
()

let _ = print_endline "ok"

ppx_typeclass_test.ml

(* see ppx_typeclass http://bitbucket.org/camlspotter/ppx_typeclass/ *)
let cons ?_tail x =
  match _tail with
  | None -> assert false
  | Some _tail -> x::_tail

module Instance = struct
  let int = [1]
  let string = ["abc"]
  let poly = [fun _ -> if true then `A else `B]
  let obj = [fun o -> ignore o#f ]
end
(* typechecks!! *)
let _ =
  ignore (cons 1);                                                                                                                                                                                                                                       
  ignore (cons "a");                                                                                                                                                                                                                                     
  ignore (cons (fun () -> `B));                                                                                                                                                                                                                          
  ignore (cons (fun o -> ignore o#g));                                                                                                                                                                                                                   
  ()