├── src ├── dune ├── selective.mli ├── selective.ml └── selective_intf.ml ├── dune-project ├── CHANGES.md ├── test ├── tests.ml └── dune ├── .gitignore ├── .ocamlformat ├── Makefile ├── example ├── dune ├── list_selective.ml ├── task.ml └── sexp_parser.ml ├── README.md ├── LICENSE └── selective.opam /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name selective) 3 | (libraries base)) 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.5) 2 | (name selective) 3 | 4 | (using fmt 1.0) 5 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 0.1.0 (20/02/2019) 2 | ------------------ 3 | 4 | First release. 5 | -------------------------------------------------------------------------------- /test/tests.ml: -------------------------------------------------------------------------------- 1 | let%expect_test _ = 2 | print_endline "Hello, world!"; 3 | [%expect {| Hello, world! |}] 4 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name selective_tests) 3 | (libraries selective) 4 | (inline_tests) 5 | (preprocess (pps ppx_expect))) 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # dune build directory 2 | _build/ 3 | 4 | # installation files for opam 5 | *.install 6 | 7 | # Merlin configuring file for Vim and Emacs 8 | .merlin 9 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | break-sequences=true 2 | doc-comments=before 3 | field-space=loose 4 | let-and=sparse 5 | sequence-style=terminator 6 | type-decl=sparse 7 | wrap-comments=true 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | default: test 2 | 3 | build: 4 | dune build @all 5 | 6 | test: 7 | dune runtest 8 | 9 | clean: 10 | dune clean 11 | 12 | .PHONY: default build test clean 13 | -------------------------------------------------------------------------------- /src/selective.mli: -------------------------------------------------------------------------------- 1 | (** Selective functors *) 2 | 3 | module type Basic = Selective_intf.Basic 4 | 5 | module type S = Selective_intf.S 6 | 7 | module Make (S : Basic) : S with type 'a t = 'a S.t 8 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name selective_example) 3 | (libraries base stdio selective expect_test_helpers_kernel) 4 | (inline_tests) 5 | (preprocess (pps ppx_jane))) 6 | 7 | (install 8 | (section doc) 9 | (files task.ml sexp_parser.ml)) 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Selective applicative functors 2 | 3 | This is a study of selective applicative functors, an abstraction between `Applicative` and `Monad`. 4 | The idea was first [prototyped in Haskell](https://github.com/snowleopard/selective), and now we are 5 | exploring its translation to OCaml. 6 | 7 | ## Further reading 8 | 9 | * A paper introducing selective functors: https://www.staff.ncl.ac.uk/andrey.mokhov/selective-functors.pdf. 10 | -------------------------------------------------------------------------------- /src/selective.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | include Selective_intf 3 | 4 | module Make (S : Basic) = struct 5 | include S 6 | include Applicative.Make (S) 7 | 8 | let ( <*? ) x f = S.select x f 9 | 10 | let branch x l r = 11 | map x ~f:(Either.map ~first:Fn.id ~second:Either.first) 12 | <*? map l ~f:(Fn.compose Either.second) 13 | <*? r 14 | 15 | let ifS x t f = 16 | branch 17 | (map x ~f:(fun b -> if b then Either.First () else Either.Second ())) 18 | (map t ~f:Fn.const) (map f ~f:Fn.const) 19 | 20 | let whenS x act = ifS x act (return ()) 21 | 22 | let ( <||> ) a b = ifS a (return true) b 23 | 24 | let ( <&&> ) a b = ifS a b (return false) 25 | end 26 | -------------------------------------------------------------------------------- /example/list_selective.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | let listSelect fs = function 4 | | Either.First a -> List.map fs ~f:(fun f -> f a) 5 | | Either.Second b -> [b] 6 | 7 | (* ListSelective.select [Either.First 1; Either.Second 2] [(fun x -> x * 10); 8 | (fun x -> x * 20)] - : int ListSelective.t = [10; 20; 2] *) 9 | module ListSelective : Selective.S with type 'a t = 'a list = 10 | Selective.Make (struct 11 | type 'a t = 'a list 12 | 13 | let return x = [x] 14 | 15 | let apply fs xs = 16 | List.concat_map xs ~f:(fun x -> List.map fs ~f:(fun f -> f x)) 17 | 18 | let map = `Custom List.map 19 | 20 | let select xs fs = List.concat_map xs ~f:(fun x -> listSelect fs x) 21 | end) 22 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Andrey Mokhov 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /selective.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "jeremie@dimino.org" 3 | authors: ["Andrey Mokhov " 4 | "Jeremie Dimino "] 5 | homepage: "https://github.com/snowleopard/selective-ocaml" 6 | bug-reports: "https://github.com/snowleopard/selective-ocaml/issues" 7 | dev-repo: "git+https://github.com/snowleopard/selective-ocaml.git" 8 | doc: "https://snowleopard.github.io/selective-ocaml/" 9 | license: "MIT" 10 | depends: [ 11 | "ocaml" {>= "4.02"} 12 | "dune" {build & >= "1.5"} 13 | "base" {>= "v0.11.1" & < "v0.12.0"} 14 | "stdio" {with-test & >= "v0.11.1" & < "v0.12.0"} 15 | "ppx_jane" {with-test & >= "v0.11.1" & < "v0.12.0"} 16 | "expect_test_helpers_kernel" {with-test & >= "v0.11.1" & < "v0.12.0"} 17 | ] 18 | build: [ 19 | ["dune" "build" "-p" name "-j" jobs] 20 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 21 | ] 22 | synopsis: "Selective applicative functors in OCaml" 23 | description: """ 24 | This is a study of selective applicative functors, an abstraction 25 | between Applicative and Monad. The idea was first prototyped in 26 | Haskell, and now we are exploring its translation to OCaml. 27 | 28 | See examples in the doc directory. 29 | """ 30 | -------------------------------------------------------------------------------- /example/task.ml: -------------------------------------------------------------------------------- 1 | (* Work in progress, prototyped in https://try.ocamlpro.com/. To be modified 2 | for Base. *) 3 | 4 | open Base 5 | 6 | module type Task = sig 7 | type k 8 | 9 | type v 10 | 11 | module Make (S : Selective.S) : sig 12 | val run : (k -> v S.t) -> v S.t 13 | end 14 | end 15 | 16 | module Example : Task with type k = string and type v = int = struct 17 | type k = string 18 | 19 | type v = int 20 | 21 | module Make (S : Selective.S) = struct 22 | let run fetch = 23 | S.ifS 24 | (S.map (fetch "condition") ~f:(fun x -> x = 0)) 25 | (fetch "zero") (fetch "non-zero") 26 | end 27 | end 28 | 29 | module type Monoid = sig 30 | type t 31 | 32 | val empty : t 33 | 34 | val append : t -> t -> t 35 | end 36 | 37 | module Const (M : Monoid) = struct 38 | type 'a t = Const of M.t 39 | 40 | let return _ = Const M.empty 41 | 42 | let apply (Const x) (Const y) = Const (M.append x y) 43 | 44 | let map = `Define_using_apply 45 | 46 | let select (Const x) (Const y) = Const (M.append x y) 47 | end 48 | 49 | module Dependencies (Task : Task) : sig 50 | val deps : Task.k list 51 | end = struct 52 | module Ks = Const (struct 53 | type t = Task.k list 54 | 55 | let empty = [] 56 | 57 | let append = List.append 58 | end) 59 | 60 | module M = Task.Make (Selective.Make (Ks)) 61 | 62 | let deps = 63 | let (Ks.Const x) = M.run (fun k -> Ks.Const [k]) in 64 | x 65 | end 66 | 67 | let%expect_test "task" = 68 | let module D = Dependencies (Example) in 69 | List.iter D.deps ~f:Stdio.print_endline; 70 | [%expect {| 71 | condition 72 | zero 73 | non-zero 74 | |}] 75 | -------------------------------------------------------------------------------- /src/selective_intf.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | 3 | module type Basic = sig 4 | include Applicative.Basic 5 | 6 | (** Selective applicative functors. You can think of [select] as a selective 7 | function application: you apply a function only when given a value 8 | [First a]. Otherwise, you can skip the function and associated effects and 9 | return the [b] from [Second b]. 10 | 11 | Note that it is not a requirement for selective functors to skip 12 | unnecessary effects. It may be counterintuitive, but this makes them more 13 | useful. Why? Typically, when executing a selective computation, you would 14 | want to skip the effects (saving work); but on the other hand, if your 15 | goal is to statically analyse a given selective computation and extract 16 | the set of all possible effects (without actually executing them), then 17 | you do not want to skip any effects, because that defeats the purpose of 18 | static analysis. 19 | 20 | The type signature of [select] is reminiscent of both [<*>] and [>>=], 21 | and indeed a selective functor is in some sense a composition of an 22 | applicative functor and the [Either] monad. *) 23 | val select : ('a, 'b) Either.t t -> ('a -> 'b) t -> 'b t 24 | end 25 | 26 | module type S = sig 27 | include Applicative.S 28 | 29 | val select : ('a, 'b) Either.t t -> ('a -> 'b) t -> 'b t 30 | 31 | (** An operator alias for [select], which is sometimes convenient. It tries 32 | to follow the notational convention for [Applicative] operators. The 33 | angle bracket pointing to the left means we always use the corresponding 34 | value. The value on the right, however, may be unnecessary, hence the 35 | question mark. *) 36 | val ( <*? ) : ('a, 'b) Either.t t -> ('a -> 'b) t -> 'b t 37 | 38 | (** The [branch] function is a natural generalisation of [select]: instead of 39 | skipping an unnecessary effect, it chooses which of the two given 40 | effectful functions to apply to a given argument; the other effect is 41 | unnecessary. *) 42 | val branch : ('a, 'b) Either.t t -> ('a -> 'c) t -> ('b -> 'c) t -> 'c t 43 | 44 | (** Branch on a Boolean value, skipping unnecessary effects. *) 45 | val ifS : bool t -> 'a t -> 'a t -> 'a t 46 | 47 | (** Conditionally perform an effect. *) 48 | val whenS : bool t -> unit t -> unit t 49 | 50 | (** A lifted version of lazy Boolean OR. *) 51 | val ( <||> ) : bool t -> bool t -> bool t 52 | 53 | (** A lifted version of lazy Boolean AND. *) 54 | val ( <&&> ) : bool t -> bool t -> bool t 55 | end 56 | -------------------------------------------------------------------------------- /example/sexp_parser.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open! Expect_test_helpers_kernel 3 | 4 | module Grammar = struct 5 | type t = entry list 6 | 7 | and entry = 8 | | Keyword of string 9 | | Atom 10 | | List of t 11 | | Repeat of t 12 | [@@deriving sexp] 13 | end 14 | 15 | module Parser : sig 16 | (** Type of a parser producing a value of type ['a] from an input composed of 17 | a sequence of s-expressions *) 18 | type 'a t 19 | 20 | include Selective.S with type 'a t := 'a t 21 | 22 | (** Expect the next element to be the following atom *) 23 | val keyword : string -> unit t 24 | 25 | (** Expect the next element to be an atom and return its contents *) 26 | val atom : string t 27 | 28 | (** [enter t] expects the next element to be a list and parse its contents 29 | with [t]. *) 30 | val enter : 'a t -> 'a t 31 | 32 | (** Consume all the input with the following parser *) 33 | val repeat : 'a t -> 'a list t 34 | 35 | (** Test whether the next element of the input is a list *) 36 | val is_list : bool t 37 | 38 | val parse : 'a t -> Sexp.t list -> 'a 39 | 40 | val grammar : _ t -> Grammar.t 41 | 42 | module Let_syntax : sig 43 | val return : 'a -> 'a t 44 | 45 | val map : 'a t -> f:('a -> 'b) -> 'b t 46 | 47 | val both : 'a t -> 'b t -> ('a * 'b) t 48 | end 49 | end = struct 50 | module M = struct 51 | type 'a t = 52 | | Return : 'a -> 'a t 53 | | Apply : ('a -> 'b) t * 'a t -> 'b t 54 | | Select : ('a, 'b) Either.t t * ('a -> 'b) t -> 'b t 55 | | Keyword : string -> unit t 56 | | Atom : string t 57 | | Enter : 'a t -> 'a t 58 | | Is_list : bool t 59 | | Repeat : 'a t -> 'a list t 60 | 61 | let return x = Return x 62 | 63 | let apply f t = Apply (f, t) 64 | 65 | let select t f = Select (t, f) 66 | 67 | let map = `Define_using_apply 68 | end 69 | 70 | open M 71 | include Selective.Make (M) 72 | 73 | module Let_syntax = struct 74 | let return = return 75 | 76 | let map = map 77 | 78 | let both = both 79 | end 80 | 81 | let keyword s = Keyword s 82 | 83 | let atom = Atom 84 | 85 | let enter s = Enter s 86 | 87 | let is_list = Is_list 88 | 89 | let repeat t = Repeat t 90 | 91 | let rec parse : type a. a t -> Sexp.t list -> a * Sexp.t list = 92 | fun t sexps -> 93 | match t with 94 | | Return x -> (x, sexps) 95 | | Apply (f, t) -> 96 | let f, sexps = parse f sexps in 97 | let t, sexps = parse t sexps in 98 | (f t, sexps) 99 | | Select (t, f) -> ( 100 | let t, sexps = parse t sexps in 101 | match t with 102 | | First x -> 103 | let f, sexps = parse f sexps in 104 | (f x, sexps) 105 | | Second y -> (y, sexps) ) 106 | | Keyword s -> ( 107 | match sexps with 108 | | Atom x :: rest when String.equal x s -> ((), rest) 109 | | _ -> Printf.ksprintf failwith "keyword %s expected" s ) 110 | | Enter t -> ( 111 | match sexps with 112 | | List l :: rest -> 113 | let x, sexps = parse t l in 114 | if not (List.is_empty sexps) then 115 | failwith "remaninig elements at end of list"; 116 | (x, rest) 117 | | _ -> raise_s [%message "list expected" ~sexps:(sexps : Sexp.t list)] ) 118 | | Is_list -> ( 119 | match sexps with List _ :: _ -> (true, sexps) | _ -> (false, sexps) ) 120 | | Atom -> ( 121 | match sexps with 122 | | Atom x :: rest -> (x, rest) 123 | | _ -> failwith "atom expected" ) 124 | | Repeat t -> 125 | let rec loop acc = function 126 | | [] -> List.rev acc 127 | | sexps -> 128 | let x, sexps = parse t sexps in 129 | loop (x :: acc) sexps 130 | in 131 | (loop [] sexps, []) 132 | 133 | let parse t sexps = 134 | let x, sexps = parse t sexps in 135 | if not (List.is_empty sexps) then 136 | failwith "remaining elements at end of input"; 137 | x 138 | 139 | let rec grammar : type a. a t -> Grammar.t = function 140 | | Return _ -> [] 141 | | Apply (f, t) -> grammar f @ grammar t 142 | | Select (t, f) -> grammar t @ grammar f 143 | | Keyword s -> [Keyword s] 144 | | Enter t -> [List (grammar t)] 145 | | Is_list -> [] 146 | | Atom -> [Atom] 147 | | Repeat t -> [Repeat (grammar t)] 148 | end 149 | 150 | module Test = struct 151 | open Parser 152 | 153 | type hello_to = 154 | | These of string list 155 | | World 156 | [@@deriving sexp] 157 | 158 | let expr = 159 | enter 160 | (let%map () = keyword "hello" 161 | and y = 162 | ifS is_list 163 | (let%map x = enter (repeat atom) in 164 | These x) 165 | (let%map () = keyword "world!" in 166 | World) 167 | in 168 | y) 169 | 170 | let%expect_test _ = 171 | let v = parse expr [List [Atom "hello"; Atom "world!"]] in 172 | print_s [%sexp (v : hello_to)]; 173 | [%expect {| World |}] 174 | 175 | let%expect_test _ = 176 | let v = 177 | parse expr [List [Atom "hello"; List [Atom "bob"; Atom "alice"]]] 178 | in 179 | print_s [%sexp (v : hello_to)]; 180 | [%expect {| (These (bob alice)) |}] 181 | 182 | let%expect_test _ = 183 | print_s [%sexp (grammar expr : Grammar.t)]; 184 | [%expect 185 | {| ((List ((Keyword hello) (List ((Repeat (Atom)))) (Keyword world!)))) 186 | |}] 187 | end 188 | --------------------------------------------------------------------------------