Object Emulation

(*

OCaml translation of the ideas explained in http://fumieval.hatenablog.com/entry/2014/09/22/144401

To emulate the higher kinded polymorphism, the technique used explained in https://ocamllabs.github.io/higher/lightweight-higher-kinded-polymorphism.pdf

*)

module StateMonad = struct
  type ('s, 'a) m = 's -> 's * 'a
  
  let run m s = m s
  
  let bind : ('s, 'a) m -> ('a -> ('s, 'b) m) -> ('s, 'b) m = fun m f ->
    fun s ->
      let s, a = m s in
      f a s
  
  let (>>=) = bind
  
  let return : 'a -> ('s, 'a) m = fun a ->
    fun s -> s, a
  
  let get : ('s, 's) m = fun s -> s, s    
  let set : 's -> ('s, unit) m = fun s ->
    fun _s -> (s, ())
  
  let rec sum = function
    | [] -> return ()
    | x::xs -> 
        get >>= fun s ->
        set (s + x) >>= fun () ->
        sum xs
  
  let () = 
    let res, () = run (sum [1;2;3;4;5;6;7;8;9;10]) 0 in
    assert (res = 55)
end

module StateWithMethodsByGADT = struct

  include StateMonad

  type ('s, _) get_set = 
    | Get : ('s, 's) get_set
    | Set : 's  -> ('s, unit) get_set

  let handle : type a s . (s, a) get_set -> s -> s * a = function
    | Get ->    fun s -> (s, s)
    | Set s' -> fun _s -> (s', ())

  let rec sum = function
    | [] -> 
        return ()
    | x::xs ->
        handle Get >>= fun v ->
        handle (Set (v + x)) >>= fun () ->
        sum xs

  let () = 
    let res, () = run (sum [1;2;3;4;5;6;7;8;9;10]) 0 in
    assert (res = 55)
end

module TheTreasure = struct
  
  type ('a, 'b) app
  
  module Object = struct
  
    type ('m, 'n) t = { o : 'x. ('x, 'm) app -> (('x * ('m, 'n) t), 'n) app }
  
    let run : ('m, 'n) t -> ('x, 'm) app -> (('x * ('m, 'n) t), 'n) app = 
      fun t mx -> t.o mx
  end
  
  module Identity = struct
    type 'a t = Identity of 'a
  
    type identity
  
    external inj : 'a t -> ('a, identity) app = "%identity"
    external prj : ('a, identity) app -> 'a t = "%identity"
  end
  
  module GetSet = struct
      
    type ('s, _) t = 
      | Get : ('s, 's) t
      | Set : 's  -> ('s, unit) t
  
    type getSet
  
    external inj : ('s, 'a) t -> ('a, ('s, getSet) app) app = "%identity"
    external prj : ('a, ('s, getSet) app) app -> ('s, 'a) t = "%identity"
  end
  
  open Object
  open Identity
  open GetSet
  
  module rec V : sig
    val variable : 's -> (('s, getSet) app, identity) Object.t
  end = struct
  
    let variable = fun s -> { Object.o = fun m -> H.handle s m }
  
  end
  
  and H : sig
    val  handle : 's -> ('x, ('s, getSet) app) app 
      -> (('x * (('s, getSet) app, identity) Object.t), identity) app
  end = struct
    open Identity
  
    let handle : type x s . s -> (x, (s, getSet) app) app 
                     -> ((x * ((s, getSet) app, identity) Object.t), identity) app =
    fun s m -> 
      match GetSet.prj m with
      | Get -> Identity.inj (Identity (s, V.variable s))
      | Set s' -> Identity.inj (Identity ((), V.variable s'))
  end
  
  open V
  open H
  
  let run : ('m, 'n) Object.t -> ('x, 'm) app -> (('x * ('m, 'n) Object.t), 'n) app  = fun o m -> o.o m

end