Experimental optics in Reason (avoiding higher-kinded abstractions)

optics.re

let id x => x;
let always x _ => x;
let (>>) f g x => g (f x);
let (<|) f x => f x;

module Option = {
  type t 'a = option 'a;
  let toArray xO => switch xO {
    | None   => [||]
    | Some x => [|x|]
  };
  let map xy xO => switch xO {
    | None   => None
    | Some x => Some (xy x)
  };
  let getOr x xO => switch xO {
    | None   => x
    | Some x => x
  };
};

/* -------------------------------------------------------------------------- */

type op 'v 'ui1 'ui2 'r 'a 'b =
  | Over ('a => 'b)
  | View ('a => 'v)
  | UnIso ('a => 'ui1) ('ui2 => 'b)
  | Fold ('a => 'r => 'r);

type optic' 's 'a 'b 't = {
  optic: 'v 'ui1 'ui2 'r.(op 'v 'ui1 'ui2 'r 's 't =>
                          op 'v 'ui1 'ui2 'r 'a 'b)
};

type optic 's 'a 'b 't = unit => optic' 's 'a 'b 't;

let run o => (o ()).optic;

let (<<) outer inner () => {optic: fun x => run outer (run inner x)};

let over o ab => Over ab |> run o |> fun op => switch op {
  | Over st => st
  | _       => failwith "over"
};

let set o x => over o (always x);

let viewAs xa o => View xa |> run o |> fun op => switch op {
  | View sa => sa
  | _       => failwith "view"
};

let view o => viewAs id o;

let iso sa bt => {
  optic: fun op => switch op {
    | Over ab     => Over (sa >> ab >> bt)
    | View ao     => View (sa >> ao)
    | UnIso au ub => UnIso (sa >> au) (ub >> bt)
    | Fold arr    => Fold (sa >> arr)
  }
};

let unisoAs xs yu o => UnIso xs yu |> run o |> fun op => switch op {
  | UnIso su ut => (su, ut)
  | _           => failwith "uniso"
};

let uniso o => unisoAs id id o;

let invert o => uniso o |> fun (sa, bt) => iso bt sa;

let fold arr o => Fold arr |> run o |> fun op => switch op {
  | Fold srr => srr
  | _        => failwith "fold"
};

let lens sa bst => {
  optic: fun op => switch op {
    | Over ab   => Over (fun s => bst (ab (sa s)) s)
    | View ao   => View (sa >> ao)
    | UnIso _ _ => failwith "lens"
    | Fold arr  => Fold (sa >> arr)
  }
};

let choose x2o => {
  optic: fun op => switch op {
    | Over ab   => Over (fun x => over (x2o x) ab x)
    | View ao   => View (fun x => viewAs ao (x2o x) x)
    | UnIso _ _ => failwith "choose"
    | Fold arr  => Fold (fun x => fold arr (x2o x) x)
  }
};

module Seq (T: {
  type t 'a;
  let map: ('a => 'b) => t 'a => t 'b;
  let fold_left : ('a => 'b => 'a) => 'a => t 'b => 'a;
}) => {
  let traversal = {
    optic: fun op => switch op {
      | Over ab   => Over (T.map ab)
      | View _    => failwith "seqT"
      | UnIso _ _ => failwith "seqT"
      | Fold arr  => Fold (fun s r => T.fold_left (fun r a => arr a r) r s)
    }
  };
};

/* -------------------------------------------------------------------------- */

let swapI () => iso (fun (a, b) => (b, a)) (fun (b, a) => (a, b));

let e1o2 () => lens fst (fun b (_, c) => (b, c));
let e2o2 () => lens snd (fun b (c, _) => (c, b));

let e1o3 () => lens (fun (x, _, _) => x) (fun x ( _, x2, x3) => (x , x2, x3));
let e2o3 () => lens (fun (_, x, _) => x) (fun x (x1,  _, x3) => (x1, x,  x3));
let e3o3 () => lens (fun (_, _, x) => x) (fun x (x1, x2,  _) => (x1, x2, x ));

let ixL i =>
  lens (fun xs => if (i < Array.length xs) {Some xs.(i)} else {None})
       (fun xO xs => {
          let n = Array.length xs;
          if (i <= n) {
            let i1 = min n (i+1);
            Array.concat [ Array.sub xs 0 i,
                           Option.toArray xO,
                           Array.sub xs i1 (n - i1) ];
          } else {
            xs
          }
       });

let removable s sa =>
  lens (Option.map (view sa))
       (Option.map (fun a => Option.getOr s >> set sa a >> fun x => Some x)
        >> Option.getOr (always None));

let arrayT () => {
  module S = Seq {
    type t 'a = array 'a;
    let map = Array.map;
    let fold_left = Array.fold_left;
  };
  S.traversal;
};

let listT () => {
  module S = Seq {
    type t 'a = list 'a;
    let map = List.map;
    let fold_left = List.fold_left;
  };
  S.traversal;
};

/* -------------------------------------------------------------------------- */

let six = fold (+) (arrayT << e1o2) [|(3, "a"), (1, "b")|] 2;
let poly = over (e1o2 << swapI << e1o2) (Printf.sprintf "%d") ((1.0, 1), true);