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)

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 lens 's 't 'a 'b <- forall 'p. strong 'p => 'p 'a 'b -> 'p 's 't
type lens' 's 'a <- lens 's 's 'a 'a

class Amc.row_cons 'record 'key 'type 'new => has_lens 'record 'key 'type 'new | 'key 'new -> 'record 'type begin
  val rlens : forall 'p. strong 'p => proxy 'key -> 'p 'type 'type -> 'p 'new 'new
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 => 'p 'type 'type -> 'p 'new 'new =
  fun x -> rlens @'record (Proxy : proxy 'key) x

let x :: xs = Cons (x, xs)
let lens_list () = (fun x -> r @"foo" x) :: (fun x -> r @"bar" x) :: Nil @(lens' _ _)

let map f xs = [ f x | with x <- xs ]

let x = { foo = 1, bar = 2 }
let xs = map (`view` x) (lens_list ())