external val print : 'a -> unit = "print"

let id x = x
let f <<< g = fun x -> f (g x)
let const x _ = x
let x |> f = f x

let fst (x, _) = x
let snd (_, x) = x
let uncurry f (x, y) = f x y

let fork f g x = (f x, g x)

class profunctor 'p begin
  val dimap : forall 'a 'b 'c 'd. ('b -> 'a) -> ('c -> 'd)
              -> 'p 'a 'c -> 'p 'b 'd
end

let lmap g = dimap g id
let rmap x = dimap id x

class profunctor 'p => strong 'p begin
  val first : forall 'a 'b 'c. 'p 'a 'b -> 'p ('a * 'c) ('b * 'c)
  val second : forall 'a 'b 'c. 'p 'a 'b -> 'p ('c * 'a) ('c * 'b)
end

type either 'l 'r = Left of 'l | Right of 'r

let either f g = function
  | Left x -> f x
  | Right y -> g y

class profunctor 'p => choice 'p begin
  val left : forall 'a 'b 'c. 'p 'a 'b
              -> 'p (either 'a 'c) (either 'b 'c)
  val right : forall 'a 'b 'c. 'p 'a 'b
              -> 'p (either 'c 'a) (either 'c 'b)
end

class monoid 'm begin
  val (<>) : 'm -> 'm -> 'm
  val zero : 'm
end

type forget 'r 'a 'b = Forget of 'a -> 'r
let remember (Forget r) = r

instance profunctor (->)
  let dimap f g h = g <<< h <<< f

instance strong (->)
  let first f (x, y) = (f x, y)
  let second f (x, y) = (x, f y)

instance choice (->)
  let left f = either (Left <<< f) Right
  let right f = either Left (Right <<< f)

instance profunctor (forget 'r)
  let dimap f _ (Forget g) = Forget (g <<< f)

instance monoid 'r => choice (forget 'r)
  let left (Forget z) = Forget (either z (const zero))
  let right (Forget z) = Forget (either (const zero) z)

instance strong (forget 'r)
  let first (Forget z) = Forget (z <<< fst)
  let second (Forget z) = Forget (z <<< snd)

let lens get set =
  dimap (fork get id) (uncurry set) <<< first

let view l = remember (l (Forget id))
let over f = f
let set l b = over l (const b)

let x ^. l = view l x
let l ^~ f = over l f

type pair 'a 'b = Pair of 'a * 'b
let fst' (Pair (x, _)) = x
let snd' (Pair (_, x)) = x

let first' x = lens fst' (fun x (Pair (_, y)) -> Pair (x, y)) x
let second' x = lens snd' (fun y (Pair (x, _)) -> Pair (x, y)) x

type proxy 'a = Proxy

type optic 'p 'a 's <- 'p 'a 'a -> 'p 's 's

class
     Amc.row_cons 'r 'k 't 'n
  => has_lens 'r 'k 't 'n
  | 'k 'n -> 'r 't
begin
  val rlens : strong 'p => proxy 'k -> optic 'p 't 'n
end

instance
    Amc.known_string 'key
  * Amc.row_cons 'record 'key 'type 'new
  => has_lens 'record 'key 'type 'new
begin
  let rlens _ =
    let view r =
      let (x, _) = Amc.restrict_row @'key r
      x
    let set x r =
      let (_, r') = Amc.restrict_row @'key r
      Amc.extend_row @'key x r'
    lens view set
end

let r
  : forall 'key -> forall 'record 'type 'new 'p.
     Amc.known_string 'key
   * has_lens 'record 'key 'type 'new
   * strong 'p
  => optic 'p 'type 'new =
  fun x -> rlens @'record (Proxy : proxy 'key) x

let succ = (+ 1)