Skip to content

Instantly share code, notes, and snippets.

@camlspotter
Last active August 29, 2015 14:06
Show Gist options
  • Save camlspotter/21515eae59901834c747 to your computer and use it in GitHub Desktop.
Save camlspotter/21515eae59901834c747 to your computer and use it in GitHub Desktop.
(*
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment