ocaml-elaboration.ml

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