Amateurfunctor optics in 1ML --- WORK-IN-PROGRESS!

amateurfunctor-optics.1ml

;; Amateurfunctor optics in 1ML --- WORK-IN-PROGRESS!
;;
;; Background:
;;
;;   https://people.mpi-sws.org/~rossberg/1ml/
;;   http://r6.ca/blog/20120623T104901Z.html
;;
;; Run as:
;;
;;   ./1ml prelude.1ml amateurfunctor-optics.1ml

type fn a b = a -> b;

flip f x y = f y x;
snd (_, b) = b;
cross f g (a, b) = (f a, g b);

;;

type SEMIGROUP = {
  type t;
  concat: t -> t -> t;
};

type MONOID = {
  include SEMIGROUP;
  empty: t;
};

Sum: MONOID = {
  type t = int;
  empty = 0;
  concat = curry ( + );
};

Product: MONOID = {
  type t = int;
  empty = 1;
  concat = curry ( * );
};

;;

type FUNCTOR = {
  type t a;
  map 'a 'b: (a -> b) -> t a -> t b;
};

type POINTED = {
  include FUNCTOR;
  pure 'a: a -> t a;
};

type APPLICATIVE = {
  include POINTED;
  apply 'a 'b: t (fn a b) -> t a -> t b;
};

type MONAD = {
  include APPLICATIVE;
  bind 'a 'b: (a -> t b) -> t a -> t b;
};

;;

Constant (c: type): FUNCTOR = {
  type t _ = c;
  map = curry snd;
};

ConcatOf (M: MONOID): APPLICATIVE = {
  type t _ = M.t;
  map _ m = m;
  pure _ = M.empty;
  apply = M.concat;
};

Identity: MONAD = {
  type t a = a;
  pure = id;
  map = id;
  apply = id;
  bind = id;
};

State (s: type): MONAD = {
  type t a = s -> (a, s);
  pure = curry id;
  map xy xS = xS >> cross xy id;
  apply xyS xS = xyS >> uncurry (flip map xS);
  bind xyS xS = xS >> uncurry xyS;
};

;;

type lens      a b s t = (F: FUNCTOR)     => (a -> F.t b) -> s -> F.t t;
type traversal a b s t = (F: APPLICATIVE) => (a -> F.t b) -> s -> F.t t;

viewAs ab (lens: lens _ _ _ _) = lens (Constant _) ab;
view = viewAs id;
over ab (lens: traversal _ _ _ _) = lens Identity ab;

concatAs (M: MONOID) ab (traversal: traversal _ _ _ _) =
  traversal (ConcatOf M) ab;

concat (M: MONOID) = concatAs M id;

(<-<) (l1:      lens _ _ _ _, l2:      lens _ _ _ _) (F: FUNCTOR)     = l1 F << l2 F;
(<*<) (t1: traversal _ _ _ _, t2: traversal _ _ _ _) (F: APPLICATIVE) = t1 F << t2 F;

;;

e1 (F: FUNCTOR) abF (l, r) = F.map (fun l => (l, r)) (abF l);
e2 (F: FUNCTOR) abF (l, r) = F.map (fun r => (l, r)) (abF r);

;;

elems (F: APPLICATIVE) xyF xs =
  foldr xs (F.pure nil) (fun x ysF => F.apply (F.apply (F.pure cons) (xyF x)) ysF);

;;

e12 = e1 <-< e2;

foo = view e12 ((10, "foo"), true);

bar = over (fun x => (x, x)) e12 ((10, "foo"), true);

;;

baz = concat Sum (e1 <*< elems <*< e2) (cons ("foo", 101) (cons ("bar", 42) nil), "baz");