Free Applicative Functors in OCaml

freeap.ml

open Higher

(*
  See `Free Applicative Functors' http://arxiv.org/abs/1403.0749
 *)
type (_, _) t =
  | Pure : 'a -> ('a, 'f) t
  | Apply : ('a -> 'b, 'f) t * ('a, 'f) app -> ('b, 'f) t

let pure v = Pure v

let rec (<$>) : 'a 'b. ('a -> 'b) -> ('a, 'f) t -> ('b, 'f) t =
  fun f -> function
    | Pure v -> Pure (f v)
    | Apply (ga, v) -> Apply ((fun g x -> f (g x)) <$> ga, v)

let map f a = f <$> a

let rec (<*>) : 'a 'b. ('a -> 'b, 'f) t -> ('a, 'f) t -> ('b, 'f) t =
  fun fa xa ->
    match fa with
    | Pure f -> f <$> xa
    | Apply (ga, v) ->
        Apply ((fun g x y -> g y x) <$> ga <*> xa, v)

let app f a = f <*> a

let id x = x

let lift v =
  Apply (pure id, v)

(* List *)
module L = Newtype1(struct type 'a t = 'a list end)

let llift v = v |> L.inj |> lift

let flat_map f xs = List.flatten (List.map f xs)

let rec run_list : 'a. ('a, L.t) t -> 'a list = function
  | Pure v -> [v]
  | Apply (fs, vs) ->
      let fs = run_list fs in
      let vs = L.prj vs in
      fs |> flat_map (fun f -> vs |> List.map f)

let rec map2 f xs ys =
  match xs, ys with
  | [], _ | _, [] -> []
  | x::xs, y::ys -> f x y :: map2 f xs ys

(* ZipList *)
let rec run_zip_list : 'a. ('a, L.t) t -> 'a list = function
  | Pure v -> let rec vs = v::vs in vs
  | Apply (fs, vs) ->
      map2 (@@)
        (run_zip_list fs)
        (L.prj vs)

let pl x =
  x |> [%derive.show: (int * int) list] |> print_endline

let la =
  (fun x y -> (x, y)) <$> llift [1; 2; 3] <*> llift [5; 6; 7]

let () = run_zip_list la |> pl
let () = run_list la |> pl

(* Option *)
module O = Newtype1(struct type 'a t = 'a option end)

let olift v = v |> O.inj |> lift

let rec run_option : 'a. ('a, O.t) t -> 'a option = function
  | Pure v -> Some v
  | Apply (f, v) ->
      match run_option f, O.prj v with
      | None, _
      | _, None -> None
      | Some f, Some v -> Some (f v)

let po v =
  v |> [%derive.show: string option] |> print_endline

let () = run_option begin
  Printf.sprintf "%d, %f" <$> olift (Some 42) <*> olift (Some 3.14)
end |> po

let () = run_option begin
  Printf.sprintf "%d, %f" <$> olift (Some 42) <*> olift None
end |> po

let () = run_option begin
  Printf.sprintf "%d, %f" <$> olift None <*> olift (Some 3.14)
end |> po