what the fuck? you can just do this????

What_the_type.ml

module type TYPE = sig
  type t
end

type 't module' = (module TYPE with type t = 't)
type 'a first = 'b constraint 'a = 'b * _
type 'a second = 'c constraint 'a = _ * 'c

module Runtype = struct
  type 'a t =
    | Singleton : 'a module' -> 'a t
    | Choice : ('a t, 'b t) Either.t -> ('a, 'b) Either.t t
    | Pair : ('a t * 'b t) -> ('a * 'b) t
    | Function : ('a t -> 'b t) -> ('a -> 'b) t

  (* injections *)

  let singleton : type a. a module' -> a t =
    fun module' -> Singleton module'
  ;;

  let choice
    : type a b. (a t, b t) Either.t -> (a, b) Either.t t
    =
    fun chosen -> Choice chosen
  ;;

  let pair : type a b. a t -> b t -> (a * b) t =
    fun left right -> Pair (left, right)
  ;;

  let function' : type a b. (a t -> b t) -> (a -> b) t =
    fun f -> Function f
  ;;

  (* projections *)

  let module_of : type a. a t -> a module' =
    fun ty ->
    (module struct
      type t = a
    end)
  ;;

  let first : type a b. (a * b) t -> a t = function
    | Pair (left, _) -> left
    | Singleton (module M) ->
      Singleton
        (module struct
          type t = M.t first
        end)
  ;;

  let second : type a b. (a * b) t -> b t = function
    | Pair (_, right) -> right
    | Singleton (module M) ->
      Singleton
        (module struct
          type t = M.t second
        end)
  ;;

  let apply : type a b. (a -> b) t -> a t -> b t =
    fun func arg ->
    match func with
    | Function f -> f arg
    | Singleton (module F) ->
      Singleton
        (module struct
          type t = b
        end)
  ;;

  let branch
    : type a b c.
      (a, b) Either.t t -> (a -> c) t -> (b -> c) t -> c t
    =
    fun choice fl fr ->
    match choice with
    | Choice (Left left) -> apply fl left
    | Choice (Right right) -> apply fr right
    | Singleton _ ->
      Singleton
        (module struct
          type t = c
        end)
  ;;

  let select : type a b. (a, b) Either.t t -> (a -> b) t -> b t =
    fun choice f -> branch choice f (Function (fun t -> t))
  ;;

  (* I KNOW WHAT YOU ARE THINKING. A FREAKING MONAD??? *)

  let map : type a b. (a -> b) -> a t -> b t =
    fun f t ->
    match t with
    | _ ->
      Singleton
        (module struct
          type t = b
        end)
  ;;

  let lift : type a. a -> a t =
    fun _ ->
    Singleton
      (module struct
        type t = a
      end)
  ;;

  let join : type a. a t t -> a t = function
    | Singleton _ ->
      Singleton
        (module struct
          type t = a
        end)
  ;;

  let bind : type a b. a t -> (a -> b t) -> b t =
    fun t f -> join (map f t)
  ;;

  let map_binary
    : type a b c. (a -> b -> c) -> a t -> b t -> c t
    =
    fun f left right -> bind (map f left) (Fun.flip map right)
  ;;
end

let int = Runtype.singleton (module Int)
let string = Runtype.singleton (module String)

let to_list : type a. a Runtype.t -> a list Runtype.t =
  fun item ->
  Runtype.singleton
    (module struct
      type t = a list
    end)
;;

let to_option : type a. a Runtype.t -> a option Runtype.t =
  fun item ->
  Runtype.singleton
    (module struct
      type t = a option
    end)
;;

let list_int = Runtype.(apply (function' to_list) int)
let option_string = Runtype.(apply (function' to_option) string)