type ('s, 't, 'a, 'b) lens = ('s -> 'a) * ('b -> 's -> 't)
type ('s, 'a) lens' = ('s, 's, 'a, 'a) lens

let lens ~view ~set = view, set
let view (get, _) = get
let set (_, put) = put
let over (get, put) ~f source = put (f (get source)) source

let compose (outer_get, outer_put) (inner_get, inner_put) =
  (fun source -> inner_get (outer_get source)),
  (fun value source -> outer_put (inner_put value (outer_get source)) source)

let _1 = (fun (left, _) -> left), (fun left (_, right) -> left, right)
let _2 = (fun (_, right) -> right), (fun right (left, _) -> left, right)
let _id = (fun value -> value), (fun value _ -> value)

let split = function
  | head :: tail -> head, tail
  | [] -> invalid_arg "Fieldglass: empty list"

let _hd =
  (fun source -> fst (split source)),
  (fun head source -> head :: snd (split source))

let _tl =
  (fun source -> snd (split source)),
  (fun tail source -> fst (split source) :: tail)

module Infix = struct
  let ( ^. ) source focus = view focus source
  let ( ^~ ) = set
  let ( ^% ) focus f = over focus ~f
  let ( ^> ) = compose
  let ( ^< ) inner outer = compose outer inner
end