Last active
November 25, 2018 09:22
-
-
Save leque/9cf9110637f07b465684 to your computer and use it in GitHub Desktop.
Free Applicative Functors in OCaml
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment