type ('f, 't, 'is) kind =
  | Exn : ('a, 'a, exn) kind
  | Opt : ('a, 'a option, opt) kind
  | Res : ('a, ('a, error) result, res) kind

and exn = E

and opt = O

and res = R

and error = [`Msg of string]

let exn = Exn
let opt = Opt
let res = Res

type ('k, 'a, 'b) t =
  {to_: 'a -> 'rb; of_: 'b -> 'ra; kd: 'kd;}
  constraint 'k = < reta: ('a, 'ra, 'kd) kind ; retb: ('b, 'rb, 'kd) kind >

type ('a, 'b) texn =
  (< reta: ('a, 'a, exn) kind ; retb: ('b, 'b, exn) kind >, 'a, 'b) t

type ('a, 'b) topt =
  ( < reta: ('a, 'a option, opt) kind ; retb: ('b, 'b option, opt) kind >
  , 'a
  , 'b )
  t

type ('a, 'b) tres =
  ( < reta: ('a, ('a, error) result, res) kind
    ; retb: ('b, ('b, error) result, res) kind >
  , 'a
  , 'b )
  t

let make : type a b ra rb kd.
       (a, ra, kd) kind
    -> (b, rb, kd) kind
    -> fwd:(a -> rb)
    -> bwd:(b -> ra)
    -> (< reta: (a, ra, kd) kind ; retb: (b, rb, kd) kind >, a, b) t =
 fun k k' ~fwd ~bwd ->
  { to_= fwd
  ; of_= bwd
  ; kd= (match (k, k') with Exn, Exn -> E | Opt, Opt -> O | Res, Res -> R) }

let fwd t = t.to_
let bwd t = t.of_
let make_exn ~fwd ~bwd = make exn exn ~fwd ~bwd
let make_opt ~fwd ~bwd = make opt opt ~fwd ~bwd
let make_res ~fwd ~bwd = make res res ~fwd ~bwd

let flip :
       (< reta: ('a, 'ra, 'kd) kind ; retb: ('b, 'rb, 'kd) kind >, 'a, 'b) t
    -> (< reta: ('b, 'rb, 'kd) kind ; retb: ('a, 'ra, 'kd) kind >, 'b, 'a) t =
 fun x -> {to_= x.of_; of_= x.to_; kd= x.kd;}

let product :
       (< reta: ('a, 'ra, 'kd) kind ; retb: ('b, 'rb, 'kd) kind >, 'a, 'b) t
    -> (< reta: ('c, 'rc, 'kd) kind ; retb: ('d, 'rd, 'kd) kind >, 'c, 'd) t
    -> ( < reta: ('a * 'c, 'ra * 'rc, 'kd) kind
         ; retb: ('b * 'd, 'rb * 'rd, 'kd) kind >
       , 'a * 'c
       , 'b * 'd )
       t =
 fun u v ->
  { to_= (fun (a, b) -> (u.to_ a, v.to_ b))
  ; of_= (fun (a, b) -> (u.of_ a, v.of_ b))
  ; kd= u.kd (* = v.kd *) }

let obj3 =
  { to_= (fun ((x, y), z) -> (x, y, z))
  ; of_= (fun (x, y, z) -> ((x, y), z))
  ; kd= E }

let obj4 =
  { to_= (fun (((w, x), y), z) -> (w, x, y, z))
  ; of_= (fun (w, x, y, z) -> (((w, x), y), z))
  ; kd= E }

let obj5 =
  { to_= (fun ((((v, w), x), y), z) -> (v, w, x, y, z))
  ; of_= (fun (v, w, x, y, z) -> ((((v, w), x), y), z))
  ; kd= E }

let obj6 =
  { to_= (fun (((((u, v), w), x), y), z) -> (u, v, w, x, y, z))
  ; of_= (fun (u, v, w, x, y, z) -> (((((u, v), w), x), y), z))
  ; kd= E }

external identity : 'a -> 'a = "%identity"

module Exn = struct
  exception Bijection

  let fail () = raise Bijection

  let compose : ('a, 'b) texn -> ('b, 'c) texn -> ('a, 'c) texn =
   fun {to_; of_; _} s ->
    { to_= (fun x -> s.to_ @@ to_ x)
    ; of_= (fun x -> of_ @@ s.of_ x)
    ; kd= E }

  let ( % ) = compose

  let commute =
    { to_= (fun (a, b) -> (b, a))
    ; of_= (fun (b, a) -> (a, b))
    ; kd= E }

  let identity = {to_= identity; of_= identity; kd= E;}

  let subset predicate =
    { to_= (fun x -> if predicate x then x else fail ())
    ; of_= (fun x -> if predicate x then x else fail ())
    ; kd= E }

  let element ~compare x =
    { to_= (fun x' -> if compare x x' then () else fail ())
    ; of_= (fun () -> x)
    ; kd= E }

  let singleton =
    { to_= (fun x -> [x])
    ; of_= (function [x] -> x | [] | _ :: _ -> fail ())
    ; kd= E }

  let cons =
    { to_= (fun (x, r) -> x :: r)
    ; of_= (function x :: r -> (x, r) | [] -> fail ())
    ; kd= E }

  let nil =
    { to_= (fun () -> [])
    ; of_= (function [] -> () | _ :: _ -> ())
    ; kd= E }

  let _fst v =
    { to_= (fun (x, _) -> x)
    ; of_= (fun x -> try (x, v.of_ ()) with _ -> fail ())
    ; kd= E }

  let _snd v =
    { to_= (fun (_, x) -> x)
    ; of_= (fun x -> try (v.of_ (), x) with _ -> fail ())
    ; kd= E }

  let some =
    { to_= (fun x -> Some x)
    ; of_= (function Some x -> x | None -> fail ())
    ; kd= E }

  let none =
    { to_= (fun () -> None)
    ; of_= (function Some _ -> fail () | None -> ())
    ; kd= E }

  let string : (char list, string) texn =
    let string_of_list lst =
      let ln = List.length lst in
      let by = Bytes.create ln in
      let rec go idx = function
        | [] -> Bytes.unsafe_to_string by
        | x :: r ->
            Bytes.unsafe_set by idx x ;
            go (idx + 1) r
      in
      go 0 lst
    in
    let list_of_string str =
      let ln = String.length str in
      let rec go idx acc =
        if idx >= 0 then acc
        else go (idx + 1) (String.unsafe_get str (ln - idx - 1) :: acc)
      in
      go 0 []
    in
    { to_= string_of_list
    ; of_= list_of_string
    ; kd= E }

  let safe_exn f x = try f x with _ -> fail ()
  let flip (a, b) = (b, a)

  let int : (string, int) texn =
    make_exn
      ~fwd:(safe_exn int_of_string)
      ~bwd:(safe_exn string_of_int)

  let bool : (string, bool) texn =
    make_exn
      ~fwd:(safe_exn bool_of_string)
      ~bwd:(safe_exn string_of_bool)

  let of_option t =
    { to_=
        (fun x ->
          match t.to_ x with
          | Some x -> x
          | None -> fail () )
    ; of_=
        (fun x ->
          match t.of_ x with
          | Some x -> x
          | None -> fail () )
    ; kd= E }

  let fst = _fst
  let snd = _snd
end
