Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
module type Monad = sig
type 'a t
val return : 'a -> 'a t
val bind : 'a t -> ('a -> 'b t) -> 'b t
end
include struct
module type HKT_Magic_0 = sig
module M : Monad
type nonrec a
type return_type
type ('a, 'b) eq = Eq : ('a, 'a) eq
val eq : (return_type, a -> a M.t) eq
end
let return (type return_type a)
(module M : HKT_Magic_0 with type a = a and type return_type = return_type)
=
let Eq = M.eq in
let open M in
(fun v -> M.return v : return_type)
end
include struct
module type HKT_Magic_1 = sig
module M : Monad
type nonrec b
type nonrec c
type return_type
type ('a, 'b) eq = Eq : ('a, 'a) eq
val eq : (return_type, b M.t -> (b -> c M.t) -> c M.t) eq
end
let bind (type return_type c b)
(module M : HKT_Magic_1
with type b = b
and type c = c
and type return_type = return_type) =
let Eq = M.eq in
let open M in
(fun v f -> M.bind v f : return_type)
end
include struct
module type HKT_Magic_2 = sig
module M : Monad
type nonrec d
type nonrec e
type return_type
type ('a, 'b) eq = Eq : ('a, 'a) eq
val eq : (return_type, (d -> e) -> d M.t -> e M.t) eq
end
let map (type return_type e d)
(module M : HKT_Magic_2
with type d = d
and type e = e
and type return_type = return_type) =
let Eq = M.eq in
let open M in
(fun f v -> M.bind v (fun v -> M.return (f v)) : return_type)
end
module Option = struct
include Option
let return = some
end
let return_option v =
return
(fun (type a) ->
let module M = Option in
(module struct
module M = M
type ('a, 'b) eq = Eq : ('a, 'a) eq
type nonrec a = a
type nonrec return_type = a -> a M.t
let eq = Eq
end : HKT_Magic_0
with type a = a
and type return_type = a -> a M.t))
v
let return_lwt v =
return
(fun (type a) ->
let module M = Lwt in
(module struct
module M = M
type ('a, 'b) eq = Eq : ('a, 'a) eq
type nonrec a = a
type nonrec return_type = a -> a M.t
let eq = Eq
end : HKT_Magic_0
with type a = a
and type return_type = a -> a M.t))
v
let bind_option v f =
bind
(fun (type c b) ->
let module M = Option in
(module struct
module M = M
type ('a, 'b) eq = Eq : ('a, 'a) eq
type nonrec b = b
type nonrec c = c
type nonrec return_type = b M.t -> (b -> c M.t) -> c M.t
let eq = Eq
end : HKT_Magic_1
with type b = b
and type c = c
and type return_type = b M.t -> (b -> c M.t) -> c M.t))
v f
let bind_lwt v f =
bind
(fun (type c b) ->
let module M = Lwt in
(module struct
module M = M
type ('a, 'b) eq = Eq : ('a, 'a) eq
type nonrec b = b
type nonrec c = c
type nonrec return_type = b M.t -> (b -> c M.t) -> c M.t
let eq = Eq
end : HKT_Magic_1
with type b = b
and type c = c
and type return_type = b M.t -> (b -> c M.t) -> c M.t))
v f
let apply f a = f a
let some_6 =
apply map
(fun (type e d) ->
let module M = Option in
(module struct
module M = M
type ('a, 'b) eq = Eq : ('a, 'a) eq
type nonrec d = d
type nonrec e = e
type nonrec return_type = (d -> e) -> d M.t -> e M.t
let eq = Eq
end : HKT_Magic_2
with type d = d
and type e = e
and type return_type = (d -> e) -> d M.t -> e M.t))
(( + ) 1) (Some 5 [@explicit_arity])
let apply f a b c = f a b c
let some_7 =
apply map
(fun (type e d) ->
let module M = Option in
(module struct
module M = M
type ('a, 'b) eq = Eq : ('a, 'a) eq
type nonrec d = d
type nonrec e = e
type nonrec return_type = (d -> e) -> d M.t -> e M.t
let eq = Eq
end : HKT_Magic_2
with type d = d
and type e = e
and type return_type = (d -> e) -> d M.t -> e M.t))
(( + ) 1) (Some 7 [@explicit_arity])
include struct
module type HKT_Magic_3 = sig
module M : Monad
type nonrec b
type nonrec c
type return_type
type ('a, 'b) eq = Eq : ('a, 'a) eq
val eq : (return_type, b M.t -> (b -> c M.t) -> c M.t) eq
end
type nonrec ('b, 'c) hkt_magic_4 = {
run_4 :
'return_type.
(module HKT_Magic_3
with type b = 'b
and type c = 'c
and type return_type = 'return_type) ->
'return_type;
}
[@@ocaml.unboxed]
let apply_bind (bind : ('b, 'c) hkt_magic_4) md v f =
(bind [@hkt_applied]).run_4 md v f
end
module type Type = sig
type t
end
include struct
module type HKT_Magic_5 = sig
module T : Type
type return_type
type ('a, 'b) eq = Eq : ('a, 'a) eq
val eq : (return_type, T.t -> T.t -> T.t) eq
end
type nonrec hkt_magic_6 = {
run_6 :
'return_type.
(module HKT_Magic_5 with type return_type = 'return_type) -> 'return_type;
}
[@@ocaml.unboxed]
let poly (f : hkt_magic_6) =
( (f [@hkt_applied]).run_6
(let module T = Int in
(module struct
module T = T
type ('a, 'b) eq = Eq : ('a, 'a) eq
type nonrec return_type = T.t -> T.t -> T.t
let eq = Eq
end : HKT_Magic_5
with type return_type = T.t -> T.t -> T.t))
1 2,
(f [@hkt_applied]).run_6
(let module T = Bool in
(module struct
module T = T
type ('a, 'b) eq = Eq : ('a, 'a) eq
type nonrec return_type = T.t -> T.t -> T.t
let eq = Eq
end : HKT_Magic_5
with type return_type = T.t -> T.t -> T.t))
true false )
end
include struct
module type HKT_Magic_7 = sig
module T : Type
type return_type
type ('a, 'b) eq = Eq : ('a, 'a) eq
val eq : (return_type, T.t -> T.t -> T.t) eq
end
let choose_fst (type return_type)
(T : (module HKT_Magic_7 with type return_type = return_type)) =
let module T = (val T) in
match T.eq with
| Eq ->
let open T in
(fun (x : T.t) (_y : T.t) -> x : return_type)
end
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment