├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── clarity.opam ├── descr ├── dune-project ├── lib.odocl ├── lib ├── clarity.ml ├── classes │ ├── align.ml │ ├── align.mli │ ├── applicative.ml │ ├── applicative.mli │ ├── foldable.ml │ ├── foldable.mli │ ├── functor.ml │ ├── functor.mli │ ├── monad.ml │ ├── monad.mli │ ├── monoid.ml │ ├── monoid.mli │ ├── semigroup.ml │ ├── semigroup.mli │ ├── traversable.ml │ └── traversable.mli ├── dune └── types │ ├── clarity_list.ml │ ├── clarity_list.mli │ ├── either.ml │ ├── either.mli │ ├── fn.ml │ ├── fn.mli │ ├── id.ml │ ├── id.mli │ ├── option.ml │ ├── option.mli │ ├── these.ml │ ├── these.mli │ ├── validation.ml │ ├── validation.mli │ ├── vector │ ├── vector.ml │ ├── vector.mli │ └── vector_internal.ml │ ├── void.ml │ └── void.mli └── tests ├── dune ├── main.ml └── vector.ml /.gitignore: -------------------------------------------------------------------------------- 1 | # dune files 2 | _build/ 3 | clarity.install 4 | */.merlin 5 | 6 | # documentation dir 7 | lib.docdir 8 | 9 | .vscode/ 10 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2017, github.com/IndiscriminateCoding 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | dune build 3 | 4 | install: 5 | dune install 6 | 7 | uninstall: 8 | dune uninstall 9 | 10 | doc: 11 | ocamlbuild -I lib -I lib/classes -I lib/types -I lib/vector lib.docdir/index.html 12 | 13 | clean: 14 | rm -rf _build/ lib.docdir clarity.install lib/.merlin 15 | 16 | tests: clean 17 | dune runtest --no-buffer 18 | 19 | .PHONY: build install uninstall doc clean tests 20 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Clarity - functional programming library for OCaml 2 | ### Description 3 | 4 | The goal of this project is to make pure functional programming idioms as useful as possible given OCaml's absence of higher-kinded types and typeclasses. 5 | 6 | ### Main features are: 7 | 8 | * Standard "classes" like Functor-Applicative-Monad 9 | * Concrete instances like Reader-Writer-State 10 | * Useful data types like Either, These or Vector 11 | 12 | ### Design notes 13 | 14 | * All concrete datatypes also have its constructors defined as values where name is prefixed with underscore. Sometimes it's more convenient to use "curried", first-class version of a constructor, e.g. following two are equivalent: 15 | ```ocaml 16 | let long = List.map (fun x -> Some x) a 17 | let short = List.map _Some x 18 | ``` 19 | * Applicative operator `ap` and its infix version `(<~>)` are "lazy" by its second argument. This allows for an applicative to "fail-fast" and don't compute unneeded values. "Strict" versions are called `ap'` and `(<*>)` respectively. "Laziness" here is just (unit -> 'a) closure, so you can use function combinators from Fn module for convenience: 20 | ```ocaml 21 | open Clarity 22 | open Option 23 | 24 | (* 25 | val (<*>) : ('a -> 'b) t -> 'a t -> 'b t 26 | val (<~>) : ('a -> 'b) t -> (unit -> 'a t) -> 'b t 27 | 28 | val serialize : int -> int -> string -> string 29 | val idx : int option 30 | val long_computation : int -> int option 31 | val title : string option 32 | *) 33 | 34 | open Fn 35 | 36 | let res : string Option.t = 37 | map serialize idx 38 | <~> defer long_computation 1024 39 | <*> title 40 | ``` 41 | * Right folds are also "lazy" by "accumulator" argument of a folding function. Strict right fold is called `foldr'`. This allows for shortcut when function no more needs data. For example, here is `any` function from Foldable module that checks if at least one element of a Foldable satisfies given predicate: 42 | ```ocaml 43 | let any p = foldr (fun x a -> p x || a ()) (const false) 44 | ``` 45 | 46 | ### Documentation 47 | 48 | You can find ocamldoc [here](https://indiscriminatecoding.github.io/clarity-docs/). 49 | 50 | ### Manual installation 51 | 52 | $ make && make install 53 | 54 | -------------------------------------------------------------------------------- /clarity.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | version: "0.4.0" 3 | maintainer: "joyprophecy@gmail.com" 4 | author: "joyprophecy@gmail.com" 5 | homepage: "https://github.com/IndiscriminateCoding/clarity" 6 | bug-reports: "https://github.com/IndiscriminateCoding/clarity/issues" 7 | dev-repo: "https://github.com/IndiscriminateCoding/clarity.git" 8 | license: "BSD3" 9 | available: [ ocaml-version >= "4.04.0" ] 10 | depends: [ "dune" {build} ] 11 | build: [ 12 | [ "dune" "subst" ] {pinned} 13 | [ "dune" "build" "-p" name "-j" jobs ] 14 | ] 15 | -------------------------------------------------------------------------------- /descr: -------------------------------------------------------------------------------- 1 | Functional programming library 2 | 3 | The goal of this project is to make pure functional programming idioms as useful as possible given OCaml's absence of higher-kinded types and typeclasses. 4 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.1) 2 | (name clarity) 3 | -------------------------------------------------------------------------------- /lib.odocl: -------------------------------------------------------------------------------- 1 | Align 2 | Applicative 3 | Clarity_list 4 | Either 5 | Fn 6 | Foldable 7 | Functor 8 | Id 9 | Monad 10 | Monoid 11 | Option 12 | Semigroup 13 | These 14 | Traversable 15 | Validation 16 | Vector 17 | Void 18 | -------------------------------------------------------------------------------- /lib/clarity.ml: -------------------------------------------------------------------------------- 1 | (* Re-export shadowed stdlib modules *) 2 | module Caml = struct 3 | module List = List 4 | end 5 | 6 | module Align = Align 7 | module Applicative = Applicative 8 | module Either = Either 9 | module Fn = Fn 10 | module Foldable = Foldable 11 | module Functor = Functor 12 | module Id = Id 13 | module List = Clarity_list 14 | module Monad = Monad 15 | module Monoid = Monoid 16 | module Option = Option 17 | module Semigroup = Semigroup 18 | module These = These 19 | module Traversable = Traversable 20 | module Validation = Validation 21 | module Vector = Vector 22 | module Void = Void 23 | 24 | (* This modules is exported for testing purposes only *) 25 | module Internal = struct 26 | module Vector = Vector_internal 27 | end 28 | 29 | -------------------------------------------------------------------------------- /lib/classes/align.ml: -------------------------------------------------------------------------------- 1 | open Fn 2 | 3 | module type Basic = sig 4 | type 'a t 5 | val align_as : ('a -> 'b -> 'c) -> ('a -> 'c) -> ('b -> 'c) -> 'a t -> 'b t -> 'c t 6 | end 7 | 8 | module type Basic2 = sig 9 | type ('p, 'a) t 10 | val align_as : 11 | ('a -> 'b -> 'c) -> ('a -> 'c) -> ('b -> 'c) -> ('p, 'a) t -> ('p, 'b) t -> ('p, 'c) t 12 | end 13 | 14 | module type Basic3 = sig 15 | type ('p, 'q, 'a) t 16 | val align_as : ('a -> 'b -> 'c) -> ('a -> 'c) -> ('b -> 'c) -> 17 | ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, 'c) t 18 | end 19 | 20 | module type S = sig 21 | include Basic 22 | val align_with : (('a, 'b) These.t -> 'c) -> 'a t -> 'b t -> 'c t 23 | val align : 'a t -> 'b t -> ('a, 'b) These.t t 24 | val falign : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t 25 | val pad_zip_with : ('a option -> 'b option -> 'c) -> 'a t -> 'b t -> 'c t 26 | val pad_zip : 'a t -> 'b t -> ('a option * 'b option) t 27 | end 28 | 29 | module type S2 = sig 30 | include Basic2 31 | val align_with : (('a, 'b) These.t -> 'c) -> ('p, 'a) t -> ('p, 'b) t -> ('p, 'c) t 32 | val align : ('p, 'a) t -> ('p, 'b) t -> ('p, ('a, 'b) These.t) t 33 | val falign : ('a -> 'a -> 'a) -> ('p, 'a) t -> ('p, 'a) t -> ('p, 'a) t 34 | val pad_zip_with : ('a option -> 'b option -> 'c) -> ('p, 'a) t -> ('p, 'b) t -> ('p, 'c) t 35 | val pad_zip : ('p, 'a) t -> ('p, 'b) t -> ('p, 'a option * 'b option) t 36 | end 37 | 38 | module type S3 = sig 39 | include Basic3 40 | val align_with : (('a, 'b) These.t -> 'c) -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, 'c) t 41 | val align : ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, ('a, 'b) These.t) t 42 | val falign : ('a -> 'a -> 'a) -> ('p, 'q, 'a) t -> ('p, 'q, 'a) t -> ('p, 'q, 'a) t 43 | val pad_zip_with : 44 | ('a option -> 'b option -> 'c) -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, 'c) t 45 | val pad_zip : ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, 'a option * 'b option) t 46 | end 47 | 48 | module Make3 (A : Basic3) = struct 49 | include A 50 | let align_with f = align_as 51 | (fun a b -> f (These.Both (a, b))) 52 | (f % These._Left) 53 | (f % These._Right) 54 | let align a = align_as These._Both These._Left These._Right a 55 | let falign f = align_as f id id 56 | let pad_zip_with f = align_as 57 | (fun a b -> f (Some a) (Some b)) 58 | (fun a -> f (Some a) None) 59 | (fun b -> f None (Some b)) 60 | let pad_zip x = pad_zip_with (curry id) x 61 | end 62 | 63 | module Make2 (A : Basic2) = Make3(struct 64 | type (_, 'p, 'a) t = ('p, 'a) A.t 65 | include (A : Basic2 with type ('p, 'a) t := ('p, 'a) A.t) 66 | end) 67 | 68 | module Make (A : Basic) = Make2(struct 69 | type (_, 'a) t = 'a A.t 70 | include (A : Basic with type 'a t := 'a A.t) 71 | end) 72 | 73 | -------------------------------------------------------------------------------- /lib/classes/align.mli: -------------------------------------------------------------------------------- 1 | (** Zip datatypes with non-uniform shapes using These.t *) 2 | 3 | module type Basic = sig 4 | type 'a t 5 | val align_as : ('a -> 'b -> 'c) -> ('a -> 'c) -> ('b -> 'c) -> 'a t -> 'b t -> 'c t 6 | end 7 | 8 | module type Basic2 = sig 9 | type ('p, 'a) t 10 | val align_as : 11 | ('a -> 'b -> 'c) -> ('a -> 'c) -> ('b -> 'c) -> ('p, 'a) t -> ('p, 'b) t -> ('p, 'c) t 12 | end 13 | 14 | module type Basic3 = sig 15 | type ('p, 'q, 'a) t 16 | val align_as : ('a -> 'b -> 'c) -> ('a -> 'c) -> ('b -> 'c) -> 17 | ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, 'c) t 18 | end 19 | 20 | module type S = sig 21 | include Basic 22 | val align_with : (('a, 'b) These.t -> 'c) -> 'a t -> 'b t -> 'c t 23 | val align : 'a t -> 'b t -> ('a, 'b) These.t t 24 | val falign : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t 25 | val pad_zip_with : ('a option -> 'b option -> 'c) -> 'a t -> 'b t -> 'c t 26 | val pad_zip : 'a t -> 'b t -> ('a option * 'b option) t 27 | end 28 | 29 | module type S2 = sig 30 | include Basic2 31 | val align_with : (('a, 'b) These.t -> 'c) -> ('p, 'a) t -> ('p, 'b) t -> ('p, 'c) t 32 | val align : ('p, 'a) t -> ('p, 'b) t -> ('p, ('a, 'b) These.t) t 33 | val falign : ('a -> 'a -> 'a) -> ('p, 'a) t -> ('p, 'a) t -> ('p, 'a) t 34 | val pad_zip_with : ('a option -> 'b option -> 'c) -> ('p, 'a) t -> ('p, 'b) t -> ('p, 'c) t 35 | val pad_zip : ('p, 'a) t -> ('p, 'b) t -> ('p, 'a option * 'b option) t 36 | end 37 | 38 | module type S3 = sig 39 | include Basic3 40 | val align_with : (('a, 'b) These.t -> 'c) -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, 'c) t 41 | val align : ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, ('a, 'b) These.t) t 42 | val falign : ('a -> 'a -> 'a) -> ('p, 'q, 'a) t -> ('p, 'q, 'a) t -> ('p, 'q, 'a) t 43 | val pad_zip_with : 44 | ('a option -> 'b option -> 'c) -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, 'c) t 45 | val pad_zip : ('p, 'q, 'a) t -> ('p, 'q, 'b) t -> ('p, 'q, 'a option * 'b option) t 46 | end 47 | 48 | module Make (A : Basic) : S with type 'a t := 'a A.t 49 | module Make2 (A : Basic2) : S2 with type ('p, 'a) t := ('p, 'a) A.t 50 | module Make3 (A : Basic3) : S3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) A.t 51 | -------------------------------------------------------------------------------- /lib/classes/applicative.ml: -------------------------------------------------------------------------------- 1 | module type Basic = sig 2 | include Functor.Basic 3 | val pure : 'a -> 'a t 4 | val ap : ('a -> 'b) t -> (unit -> 'a t) -> 'b t 5 | end 6 | 7 | module type Basic2 = sig 8 | include Functor.Basic2 9 | val pure : 'a -> ('p, 'a) t 10 | val ap : ('p, 'a -> 'b) t -> (unit -> ('p, 'a) t) -> ('p, 'b) t 11 | end 12 | 13 | module type Basic3 = sig 14 | include Functor.Basic3 15 | val pure : 'a -> ('p, 'q, 'a) t 16 | val ap : 17 | ('p, 'q, 'a -> 'b) t -> 18 | (unit -> ('p, 'q, 'a) t) -> ('p, 'q, 'b) t 19 | end 20 | 21 | module type S = sig 22 | type _ t 23 | include Basic with type 'a t := 'a t 24 | include Functor.S with type 'a t := 'a t 25 | val ap' : ('a -> 'b) t -> 'a t -> 'b t 26 | val (<*>) : ('a -> 'b) t -> 'a t -> 'b t 27 | val (<~>) : ('a -> 'b) t -> (unit -> 'a t) -> 'b t 28 | val discard_left : 'a t -> (unit -> 'b t) -> 'b t 29 | val discard_right : 'a t -> (unit -> 'b t) -> 'a t 30 | val repeat : int -> 'a t -> 'a list t 31 | val repeat_ : int -> 'a t -> unit t 32 | val forever : 'a t -> 'b t 33 | end 34 | 35 | module type S2 = sig 36 | type (_, _) t 37 | include Basic2 with type ('p, 'a) t := ('p, 'a) t 38 | include Functor.S2 with type ('p, 'a) t := ('p, 'a) t 39 | val ap' : ('p, 'a -> 'b) t -> ('p, 'a) t -> ('p, 'b) t 40 | val (<*>) : ('p, 'a -> 'b) t -> ('p, 'a) t -> ('p, 'b) t 41 | val (<~>) : ('p, 'a -> 'b) t -> (unit -> ('p, 'a) t) -> ('p, 'b) t 42 | val discard_left : ('p, 'a) t -> (unit -> ('p, 'b) t) -> ('p, 'b) t 43 | val discard_right : ('p, 'a) t -> (unit -> ('p, 'b) t) -> ('p, 'a) t 44 | val repeat : int -> ('p, 'a) t -> ('p, 'a list) t 45 | val repeat_ : int -> ('p, 'a) t -> ('p, unit) t 46 | val forever : ('p, 'a) t -> ('p, 'b) t 47 | end 48 | 49 | module type S3 = sig 50 | type (_, _, _) t 51 | include Basic3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) t 52 | include Functor.S3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) t 53 | val ap' : ('p, 'q, 'a -> 'b) t -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t 54 | val (<*>) : ('p, 'q, 'a -> 'b) t -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t 55 | val (<~>) : 56 | ('p, 'q, 'a -> 'b) t -> (unit -> ('p, 'q, 'a) t) -> ('p, 'q, 'b) t 57 | val discard_left : 58 | ('p, 'q, 'a) t -> (unit -> ('p, 'q, 'b) t) -> ('p, 'q, 'b) t 59 | val discard_right : 60 | ('p, 'q, 'a) t -> (unit -> ('p, 'q, 'b) t) -> ('p, 'q, 'a) t 61 | val repeat : int -> ('p, 'q, 'a) t -> ('p, 'q, 'a list) t 62 | val repeat_ : int -> ('p, 'q, 'a) t -> ('p, 'q, unit) t 63 | val forever : ('p, 'q, 'a) t -> ('p, 'q, 'b) t 64 | end 65 | 66 | module Make3 (A : Basic3) = struct 67 | open Fn 68 | include Functor.Make3(A) 69 | include A 70 | 71 | let (<~>) = ap 72 | let ap' f x = ap f (const x) 73 | let (<*>) = ap' 74 | let discard_left l r = map (flip const) l <~> r 75 | let discard_right l r = map const l <~> r 76 | let repeat cnt x = 77 | let rec r cnt (xl : ('a, 'b, 'c list) t) = 78 | if cnt <= 0 79 | then xl 80 | else r (cnt - 1) (map (fun h t -> h :: t) x <*> xl) in 81 | r cnt (pure []) 82 | let repeat_ cnt x = 83 | let rec r cnt xl = 84 | if cnt <= 0 85 | then xl 86 | else r (cnt - 1) (discard_left x (const xl)) in 87 | r cnt (pure ()) 88 | let rec forever x = discard_left x (defer forever x) 89 | end 90 | 91 | module Make2 (A : Basic2) = Make3(struct 92 | type (_, 'p, 'a) t = ('p, 'a) A.t 93 | include (A : Basic2 with type ('p, 'a) t := ('p, 'a) A.t) 94 | end) 95 | 96 | module Make (A : Basic) = Make2(struct 97 | type (_, 'a) t = 'a A.t 98 | include (A : Basic with type 'a t := 'a A.t) 99 | end) 100 | 101 | -------------------------------------------------------------------------------- /lib/classes/applicative.mli: -------------------------------------------------------------------------------- 1 | (** Applicative functors *) 2 | 3 | module type Basic = sig 4 | include Functor.Basic 5 | val pure : 'a -> 'a t 6 | val ap : ('a -> 'b) t -> (unit -> 'a t) -> 'b t 7 | end 8 | 9 | module type Basic2 = sig 10 | include Functor.Basic2 11 | val pure : 'a -> ('p, 'a) t 12 | val ap : ('p, 'a -> 'b) t -> (unit -> ('p, 'a) t) -> ('p, 'b) t 13 | end 14 | 15 | module type Basic3 = sig 16 | include Functor.Basic3 17 | val pure : 'a -> ('p, 'q, 'a) t 18 | val ap : ('p, 'q, 'a -> 'b) t -> (unit -> ('p, 'q, 'a) t) -> ('p, 'q, 'b) t 19 | end 20 | 21 | module type S = sig 22 | type _ t 23 | include Basic with type 'a t := 'a t 24 | include Functor.S with type 'a t := 'a t 25 | val ap' : ('a -> 'b) t -> 'a t -> 'b t 26 | val (<*>) : ('a -> 'b) t -> 'a t -> 'b t 27 | val (<~>) : ('a -> 'b) t -> (unit -> 'a t) -> 'b t 28 | val discard_left : 'a t -> (unit -> 'b t) -> 'b t 29 | val discard_right : 'a t -> (unit -> 'b t) -> 'a t 30 | val repeat : int -> 'a t -> 'a list t 31 | val repeat_ : int -> 'a t -> unit t 32 | val forever : 'a t -> 'b t 33 | end 34 | 35 | module type S2 = sig 36 | type (_, _) t 37 | include Basic2 with type ('p, 'a) t := ('p, 'a) t 38 | include Functor.S2 with type ('p, 'a) t := ('p, 'a) t 39 | val ap' : ('p, 'a -> 'b) t -> ('p, 'a) t -> ('p, 'b) t 40 | val (<*>) : ('p, 'a -> 'b) t -> ('p, 'a) t -> ('p, 'b) t 41 | val (<~>) : ('p, 'a -> 'b) t -> (unit -> ('p, 'a) t) -> ('p, 'b) t 42 | val discard_left : ('p, 'a) t -> (unit -> ('p, 'b) t) -> ('p, 'b) t 43 | val discard_right : ('p, 'a) t -> (unit -> ('p, 'b) t) -> ('p, 'a) t 44 | val repeat : int -> ('p, 'a) t -> ('p, 'a list) t 45 | val repeat_ : int -> ('p, 'a) t -> ('p, unit) t 46 | val forever : ('p, 'a) t -> ('p, 'b) t 47 | end 48 | 49 | module type S3 = sig 50 | type (_, _, _) t 51 | include Basic3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) t 52 | include Functor.S3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) t 53 | val ap' : ('p, 'q, 'a -> 'b) t -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t 54 | val (<*>) : ('p, 'q, 'a -> 'b) t -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t 55 | val (<~>) : 56 | ('p, 'q, 'a -> 'b) t -> (unit -> ('p, 'q, 'a) t) -> ('p, 'q, 'b) t 57 | val discard_left : 58 | ('p, 'q, 'a) t -> (unit -> ('p, 'q, 'b) t) -> ('p, 'q, 'b) t 59 | val discard_right : 60 | ('p, 'q, 'a) t -> (unit -> ('p, 'q, 'b) t) -> ('p, 'q, 'a) t 61 | val repeat : int -> ('p, 'q, 'a) t -> ('p, 'q, 'a list) t 62 | val repeat_ : int -> ('p, 'q, 'a) t -> ('p, 'q, unit) t 63 | val forever : ('p, 'q, 'a) t -> ('p, 'q, 'b) t 64 | end 65 | 66 | module Make (A : Basic) : S with type 'a t := 'a A.t 67 | module Make2 (A : Basic2) : S2 with type ('p, 'a) t := ('p, 'a) A.t 68 | module Make3 (A : Basic3) : S3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) A.t 69 | 70 | -------------------------------------------------------------------------------- /lib/classes/foldable.ml: -------------------------------------------------------------------------------- 1 | module type Basic = sig 2 | type _ t 3 | 4 | val foldl : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a 5 | val foldr : ('a -> (unit -> 'b) -> 'b) -> (unit -> 'b) -> 'a t -> 'b 6 | end 7 | 8 | module type S = sig 9 | include Basic 10 | 11 | val foldr' : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b 12 | val fold_map : 13 | (module Monoid.S with type t = 'm) -> ('a -> 'm) -> 'a t -> 'm 14 | val any : ('a -> bool) -> 'a t -> bool 15 | val all : ('a -> bool) -> 'a t -> bool 16 | val find : ('a -> bool) -> 'a t -> 'a option 17 | end 18 | 19 | module Make (F : Basic) = struct 20 | open Fn 21 | include F 22 | 23 | let foldr' f a = foldr (fun x a -> f x (a ())) (const a) 24 | let fold_map (type m) m f = 25 | let module M = (val m : Monoid.S with type t = m) in 26 | foldl (fun a x -> M.append a (f x)) M.zero 27 | let any p = foldr (fun x a -> p x || a ()) (const false) 28 | let all p = foldr (fun x a -> p x && a ()) (const true) 29 | let find p = foldr (fun x a -> if p x then Some x else a ()) (const None) 30 | end 31 | 32 | module type M = sig 33 | type _ t 34 | type _ m 35 | 36 | val foldr_m : ('a -> 'b -> 'b m) -> 'b -> 'a t -> 'b m 37 | val foldl_m : ('b -> 'a -> 'b m) -> 'b -> 'a t -> 'b m 38 | end 39 | 40 | module type M2 = sig 41 | type _ t 42 | type (_, _) m 43 | 44 | val foldr_m : ('a -> 'b -> ('u, 'b) m) -> 'b -> 'a t -> ('u, 'b) m 45 | val foldl_m : ('b -> 'a -> ('u, 'b) m) -> 'b -> 'a t -> ('u, 'b) m 46 | end 47 | 48 | module type M3 = sig 49 | type _ t 50 | type (_, _, _) m 51 | 52 | val foldr_m : ('a -> 'b -> ('u, 'v, 'b) m) -> 'b -> 'a t -> ('u, 'v, 'b) m 53 | val foldl_m : ('b -> 'a -> ('u, 'v, 'b) m) -> 'b -> 'a t -> ('u, 'v, 'b) m 54 | end 55 | 56 | -------------------------------------------------------------------------------- /lib/classes/foldable.mli: -------------------------------------------------------------------------------- 1 | (** Foldable signatures *) 2 | 3 | module type Basic = sig 4 | type _ t 5 | 6 | val foldl : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a 7 | val foldr : ('a -> (unit -> 'b) -> 'b) -> (unit -> 'b) -> 'a t -> 'b 8 | end 9 | 10 | module type S = sig 11 | include Basic 12 | 13 | val foldr' : ('a -> 'b -> 'b) -> 'b -> 'a t -> 'b 14 | val fold_map : 15 | (module Monoid.S with type t = 'm) -> ('a -> 'm) -> 'a t -> 'm 16 | val any : ('a -> bool) -> 'a t -> bool 17 | val all : ('a -> bool) -> 'a t -> bool 18 | val find : ('a -> bool) -> 'a t -> 'a option 19 | end 20 | 21 | module Make (F : Basic) : S with type 'a t := 'a F.t 22 | 23 | module type M = sig 24 | type _ t 25 | type _ m 26 | 27 | val foldr_m : ('a -> 'b -> 'b m) -> 'b -> 'a t -> 'b m 28 | val foldl_m : ('b -> 'a -> 'b m) -> 'b -> 'a t -> 'b m 29 | end 30 | 31 | module type M2 = sig 32 | type _ t 33 | type (_, _) m 34 | 35 | val foldr_m : ('a -> 'b -> ('u, 'b) m) -> 'b -> 'a t -> ('u, 'b) m 36 | val foldl_m : ('b -> 'a -> ('u, 'b) m) -> 'b -> 'a t -> ('u, 'b) m 37 | end 38 | 39 | module type M3 = sig 40 | type _ t 41 | type (_, _, _) m 42 | 43 | val foldr_m : ('a -> 'b -> ('u, 'v, 'b) m) -> 'b -> 'a t -> ('u, 'v, 'b) m 44 | val foldl_m : ('b -> 'a -> ('u, 'v, 'b) m) -> 'b -> 'a t -> ('u, 'v, 'b) m 45 | end 46 | 47 | -------------------------------------------------------------------------------- /lib/classes/functor.ml: -------------------------------------------------------------------------------- 1 | module type Basic = sig 2 | type _ t 3 | val map : ('a -> 'b) -> 'a t -> 'b t 4 | end 5 | 6 | module type Basic2 = sig 7 | type (_, _) t 8 | val map : ('a -> 'b) -> ('p, 'a) t -> ('p, 'b) t 9 | end 10 | 11 | module type Basic3 = sig 12 | type (_, _, _) t 13 | val map : ('a -> 'b) -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t 14 | end 15 | 16 | module type S = sig 17 | include Basic 18 | val (>|=) : 'a t -> ('a -> 'b) -> 'b t 19 | val replace : 'a -> 'b t -> 'a t 20 | val void : 'a t -> unit t 21 | end 22 | 23 | module type S2 = sig 24 | include Basic2 25 | val (>|=) : ('p, 'a) t -> ('a -> 'b) -> ('p, 'b) t 26 | val replace : 'a -> ('p, 'b) t -> ('p, 'a) t 27 | val void : ('p, 'a) t -> ('p, unit) t 28 | end 29 | 30 | module type S3 = sig 31 | include Basic3 32 | val (>|=) : ('p, 'q, 'a) t -> ('a -> 'b) -> ('p, 'q, 'b) t 33 | val replace : 'a -> ('p, 'q, 'b) t -> ('p, 'q, 'a) t 34 | val void : ('p, 'q, 'a) t -> ('p, 'q, unit) t 35 | end 36 | 37 | module Make3 (F : Basic3) = struct 38 | include F 39 | open Fn 40 | 41 | let (>|=) x f = map f x 42 | let replace x = map (const x) 43 | let void x = replace () x 44 | end 45 | 46 | module Make2 (F : Basic2) = Make3(struct 47 | type (_, 'p, 'a) t = ('p, 'a) F.t 48 | include (F : Basic2 with type ('p, 'a) t := ('p, 'a) F.t) 49 | end) 50 | 51 | module Make (F : Basic) = Make2(struct 52 | type (_, 'a) t = 'a F.t 53 | include (F : Basic with type 'a t := 'a F.t) 54 | end) 55 | 56 | -------------------------------------------------------------------------------- /lib/classes/functor.mli: -------------------------------------------------------------------------------- 1 | (** Functors *) 2 | 3 | module type Basic = sig 4 | type _ t 5 | val map : ('a -> 'b) -> 'a t -> 'b t 6 | end 7 | 8 | module type Basic2 = sig 9 | type (_, _) t 10 | val map : ('a -> 'b) -> ('p, 'a) t -> ('p, 'b) t 11 | end 12 | 13 | module type Basic3 = sig 14 | type (_, _, _) t 15 | val map : ('a -> 'b) -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t 16 | end 17 | 18 | module type S = sig 19 | include Basic 20 | val (>|=) : 'a t -> ('a -> 'b) -> 'b t 21 | val replace : 'a -> 'b t -> 'a t 22 | val void : 'a t -> unit t 23 | end 24 | 25 | module type S2 = sig 26 | include Basic2 27 | val (>|=) : ('p, 'a) t -> ('a -> 'b) -> ('p, 'b) t 28 | val replace : 'a -> ('p, 'b) t -> ('p, 'a) t 29 | val void : ('p, 'a) t -> ('p, unit) t 30 | end 31 | 32 | module type S3 = sig 33 | include Basic3 34 | val (>|=) : ('p, 'q, 'a) t -> ('a -> 'b) -> ('p, 'q, 'b) t 35 | val replace : 'a -> ('p, 'q, 'b) t -> ('p, 'q, 'a) t 36 | val void : ('p, 'q, 'a) t -> ('p, 'q, unit) t 37 | end 38 | 39 | module Make (F : Basic) : S with type 'a t := 'a F.t 40 | module Make2 (F : Basic2) : S2 with type ('p, 'a) t := ('p, 'a) F.t 41 | module Make3 (F : Basic3) : S3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) F.t 42 | 43 | -------------------------------------------------------------------------------- /lib/classes/monad.ml: -------------------------------------------------------------------------------- 1 | module type Basic = sig 2 | include Applicative.Basic 3 | val bind : ('a -> 'b t) -> 'a t -> 'b t 4 | end 5 | 6 | module type Basic2 = sig 7 | include Applicative.Basic2 8 | val bind : ('a -> ('p, 'b) t) -> ('p, 'a) t -> ('p, 'b) t 9 | end 10 | 11 | module type Basic3 = sig 12 | include Applicative.Basic3 13 | val bind : ('a -> ('p, 'q, 'b) t) -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t 14 | end 15 | 16 | module type S = sig 17 | type _ t 18 | include Basic with type 'a t := 'a t 19 | include Applicative.S with type 'a t := 'a t 20 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 21 | val join : 'a t t -> 'a t 22 | val mcompose : ('b -> 'c t) -> ('a -> 'b t) -> 'a -> 'c t 23 | end 24 | 25 | module type S2 = sig 26 | type (_, _) t 27 | include Basic2 with type ('p, 'a) t := ('p, 'a) t 28 | include Applicative.S2 with type ('p, 'a) t := ('p, 'a) t 29 | val (>>=) : ('p, 'a) t -> ('a -> ('p, 'b) t) -> ('p, 'b) t 30 | val join : ('p, ('p, 'a) t) t -> ('p, 'a) t 31 | val mcompose : ('b -> ('p, 'c) t) -> ('a -> ('p, 'b) t) -> 'a -> ('p, 'c) t 32 | end 33 | 34 | module type S3 = sig 35 | type (_, _, _) t 36 | include Basic3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) t 37 | include Applicative.S3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) t 38 | val (>>=) : ('p, 'q, 'a) t -> ('a -> ('p, 'q, 'b) t) -> ('p, 'q, 'b) t 39 | val join : ('p, 'q, ('p, 'q, 'a) t) t -> ('p, 'q, 'a) t 40 | val mcompose : 41 | ('b -> ('p, 'q, 'c) t) -> ('a -> ('p, 'q, 'b) t) -> 'a -> ('p, 'q, 'c) t 42 | end 43 | 44 | module Make3 (M : Basic3) = struct 45 | include Applicative.Make3(M) 46 | include M 47 | 48 | let (>>=) x f = bind f x 49 | let join x = x >>= Fn.id 50 | let mcompose f g x = g x >>= f 51 | end 52 | 53 | module Make2 (M : Basic2) = Make3(struct 54 | type (_, 'p, 'a) t = ('p, 'a) M.t 55 | include (M : Basic2 with type ('p, 'a) t := ('p, 'a) M.t) 56 | end) 57 | 58 | module Make (M : Basic) = Make2(struct 59 | type (_, 'a) t = 'a M.t 60 | include (M : Basic with type 'a t := 'a M.t) 61 | end) 62 | 63 | -------------------------------------------------------------------------------- /lib/classes/monad.mli: -------------------------------------------------------------------------------- 1 | (** Monads *) 2 | 3 | module type Basic = sig 4 | include Applicative.Basic 5 | val bind : ('a -> 'b t) -> 'a t -> 'b t 6 | end 7 | 8 | module type Basic2 = sig 9 | include Applicative.Basic2 10 | val bind : ('a -> ('p, 'b) t) -> ('p, 'a) t -> ('p, 'b) t 11 | end 12 | 13 | module type Basic3 = sig 14 | include Applicative.Basic3 15 | val bind : ('a -> ('p, 'q, 'b) t) -> ('p, 'q, 'a) t -> ('p, 'q, 'b) t 16 | end 17 | 18 | module type S = sig 19 | type _ t 20 | include Basic with type 'a t := 'a t 21 | include Applicative.S with type 'a t := 'a t 22 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 23 | val join : 'a t t -> 'a t 24 | val mcompose : ('b -> 'c t) -> ('a -> 'b t) -> 'a -> 'c t 25 | end 26 | 27 | module type S2 = sig 28 | type (_, _) t 29 | include Basic2 with type ('p, 'a) t := ('p, 'a) t 30 | include Applicative.S2 with type ('p, 'a) t := ('p, 'a) t 31 | val (>>=) : ('p, 'a) t -> ('a -> ('p, 'b) t) -> ('p, 'b) t 32 | val join : ('p, ('p, 'a) t) t -> ('p, 'a) t 33 | val mcompose : 34 | ('b -> ('p, 'c) t) -> ('a -> ('p, 'b) t) -> 'a -> ('p, 'c) t 35 | end 36 | 37 | module type S3 = sig 38 | type (_, _, _) t 39 | include Basic3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) t 40 | include Applicative.S3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) t 41 | val (>>=) : ('p, 'q, 'a) t -> ('a -> ('p, 'q, 'b) t) -> ('p, 'q, 'b) t 42 | val join : ('p, 'q, ('p, 'q, 'a) t) t -> ('p, 'q, 'a) t 43 | val mcompose : 44 | ('b -> ('p, 'q, 'c) t) -> ('a -> ('p, 'q, 'b) t) -> 'a -> ('p, 'q, 'c) t 45 | end 46 | 47 | module Make (M : Basic) : S with type 'a t := 'a M.t 48 | module Make2 (M : Basic2) : S2 with type ('p, 'a) t := ('p, 'a) M.t 49 | module Make3 (M : Basic3) : S3 with type ('p, 'q, 'a) t := ('p, 'q, 'a) M.t 50 | 51 | -------------------------------------------------------------------------------- /lib/classes/monoid.ml: -------------------------------------------------------------------------------- 1 | open Fn 2 | 3 | module type S = sig 4 | include Semigroup.S 5 | val zero : t 6 | end 7 | 8 | module Int = struct 9 | module Min = struct 10 | type t = int 11 | let append = min 12 | let zero = max_int 13 | end 14 | module Max = struct 15 | type t = int 16 | let append = max 17 | let zero = min_int 18 | end 19 | module Sum = struct 20 | type t = int 21 | let append = (+) 22 | let zero = 0 23 | end 24 | module Product = struct 25 | type t = int 26 | let append = ( * ) 27 | let zero = 1 28 | end 29 | end 30 | 31 | module All = struct 32 | type t = bool 33 | let append = (&&) 34 | let zero = true 35 | end 36 | 37 | module Any = struct 38 | type t = bool 39 | let append = (||) 40 | let zero = false 41 | end 42 | 43 | module Dual (M : S) = struct 44 | type t = M.t 45 | let append = flip M.append 46 | let zero = M.zero 47 | end 48 | 49 | module Endo (T : sig type t end) = struct 50 | type t = T.t -> T.t 51 | let append = compose 52 | let zero = id 53 | end 54 | 55 | module Pair (M1 : S)(M2 : S) = struct 56 | type t = M1.t * M2.t 57 | let append (a, b) (x, y) = M1.append a x, M2.append b y 58 | let zero = M1.zero, M2.zero 59 | end 60 | 61 | module Opt (S : Semigroup.S) = struct 62 | type t = S.t option 63 | let append = curry 64 | (function 65 | | Some a, Some b -> Some (S.append a b) 66 | | _, (Some _ as x) | (Some _ as x), _ -> x 67 | | _ -> None) 68 | let zero = None 69 | end 70 | 71 | -------------------------------------------------------------------------------- /lib/classes/monoid.mli: -------------------------------------------------------------------------------- 1 | (** Monoids *) 2 | 3 | module type S = sig 4 | type t 5 | val append : t -> t -> t 6 | val zero : t 7 | end 8 | 9 | module Int : sig 10 | module Min : S with type t = int 11 | module Max : S with type t = int 12 | module Sum : S with type t = int 13 | module Product : S with type t = int 14 | end 15 | 16 | module All : S with type t = bool 17 | module Any : S with type t = bool 18 | 19 | module Dual (M : S) : S with type t = M.t 20 | 21 | module Endo (T : sig type t end) : S with type t = T.t -> T.t 22 | 23 | module Pair (M1 : S)(M2 : S) : S with type t = M1.t * M2.t 24 | 25 | module Opt (S : Semigroup.S) : S with type t = S.t option 26 | 27 | -------------------------------------------------------------------------------- /lib/classes/semigroup.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | val append : t -> t -> t 4 | end 5 | 6 | module First (T : sig type t end) = struct 7 | type t = T.t 8 | let append x _ = x 9 | end 10 | 11 | module Last (T : sig type t end) = struct 12 | type t = T.t 13 | let append _ x = x 14 | end 15 | 16 | -------------------------------------------------------------------------------- /lib/classes/semigroup.mli: -------------------------------------------------------------------------------- 1 | (** Semigroups *) 2 | 3 | module type S = sig 4 | type t 5 | val append : t -> t -> t 6 | end 7 | 8 | module First (T : sig type t end) : S with type t = T.t 9 | module Last (T : sig type t end) : S with type t = T.t 10 | 11 | -------------------------------------------------------------------------------- /lib/classes/traversable.ml: -------------------------------------------------------------------------------- 1 | module type Basic = sig 2 | type _ t 3 | type _ f 4 | val traverse : ('a -> 'b f) -> 'a t -> 'b t f 5 | val traverse_ : ('a -> 'b f) -> 'a t -> unit f 6 | end 7 | 8 | module type Basic2 = sig 9 | type _ t 10 | type (_, _) f 11 | val traverse : ('a -> ('u, 'b) f) -> 'a t -> ('u, 'b t) f 12 | val traverse_ : ('a -> ('u, 'b) f) -> 'a t -> ('u, unit) f 13 | end 14 | 15 | module type Basic3 = sig 16 | type _ t 17 | type (_, _, _) f 18 | val traverse : ('a -> ('u, 'v, 'b) f) -> 'a t -> ('u, 'v, 'b t) f 19 | val traverse_ : ('a -> ('u, 'v, 'b) f) -> 'a t -> ('u, 'v, unit) f 20 | end 21 | 22 | module type S = sig 23 | include Basic 24 | val sequence : 'a f t -> 'a t f 25 | val sequence_ : 'a f t -> unit f 26 | end 27 | 28 | module type S2 = sig 29 | include Basic2 30 | val sequence : ('u, 'a) f t -> ('u, 'a t) f 31 | val sequence_ : ('u, 'a) f t -> ('u, unit) f 32 | end 33 | 34 | module type S3 = sig 35 | include Basic3 36 | val sequence : ('a, 'b, 'c) f t -> ('a, 'b, 'c t) f 37 | val sequence_ : ('a, 'b, 'c) f t -> ('a, 'b, unit) f 38 | end 39 | 40 | module Make3 (T : Basic3) = struct 41 | open Fn 42 | include T 43 | 44 | let sequence x = traverse id x 45 | let sequence_ x = traverse_ id x 46 | end 47 | 48 | module Make2 (T : Basic2) = Make3(struct 49 | type 'a t = 'a T.t 50 | type (_, 'p, 'a) f = ('p, 'a) T.f 51 | include (T : Basic2 with 52 | type ('p, 'a) f := ('p, 'a) T.f and 53 | type 'a t := 'a T.t) 54 | end) 55 | 56 | module Make (T : Basic) = Make2(struct 57 | type 'a t = 'a T.t 58 | type (_, 'a) f = 'a T.f 59 | include (T : Basic with 60 | type 'a f := 'a T.f and 61 | type 'a t := 'a T.t) 62 | end) 63 | 64 | -------------------------------------------------------------------------------- /lib/classes/traversable.mli: -------------------------------------------------------------------------------- 1 | (** Traversable signatures *) 2 | 3 | module type Basic = sig 4 | type _ t 5 | type _ f 6 | val traverse : ('a -> 'b f) -> 'a t -> 'b t f 7 | val traverse_ : ('a -> 'b f) -> 'a t -> unit f 8 | end 9 | 10 | module type Basic2 = sig 11 | type _ t 12 | type (_, _) f 13 | val traverse : ('a -> ('u, 'b) f) -> 'a t -> ('u, 'b t) f 14 | val traverse_ : ('a -> ('u, 'b) f) -> 'a t -> ('u, unit) f 15 | end 16 | 17 | module type Basic3 = sig 18 | type _ t 19 | type (_, _, _) f 20 | val traverse : ('a -> ('u, 'v, 'b) f) -> 'a t -> ('u, 'v, 'b t) f 21 | val traverse_ : ('a -> ('u, 'v, 'b) f) -> 'a t -> ('u, 'v, unit) f 22 | end 23 | 24 | module type S = sig 25 | include Basic 26 | val sequence : 'a f t -> 'a t f 27 | val sequence_ : 'a f t -> unit f 28 | end 29 | 30 | module type S2 = sig 31 | include Basic2 32 | val sequence : ('u, 'a) f t -> ('u, 'a t) f 33 | val sequence_ : ('u, 'a) f t -> ('u, unit) f 34 | end 35 | 36 | module type S3 = sig 37 | include Basic3 38 | val sequence : ('a, 'b, 'c) f t -> ('a, 'b, 'c t) f 39 | val sequence_ : ('a, 'b, 'c) f t -> ('a, 'b, unit) f 40 | end 41 | 42 | module Make (T : Basic) : S with 43 | type 'a t := 'a T.t and 44 | type 'a f := 'a T.f 45 | 46 | module Make2 (T : Basic2) : S2 with 47 | type 'a t := 'a T.t and 48 | type ('u, 'a) f := ('u, 'a) T.f 49 | 50 | module Make3 (T : Basic3) : S3 with 51 | type 'a t := 'a T.t and 52 | type ('u, 'v, 'a) f := ('u, 'v, 'a) T.f 53 | 54 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name clarity) 3 | (public_name clarity) 4 | (ocamlc_flags (-w +44+45 -strict-sequence -principal)) 5 | (ocamlopt_flags (-O2 -w +44+45 -strict-sequence -principal))) 6 | (include_subdirs unqualified) 7 | -------------------------------------------------------------------------------- /lib/types/clarity_list.ml: -------------------------------------------------------------------------------- 1 | open Fn 2 | 3 | type 'a t = 'a list 4 | 5 | let _Cons h t = h :: t 6 | let _Nil = [] 7 | 8 | let iter = List.iter 9 | let rev = List.rev 10 | let rev_append = List.rev_append 11 | let rev_map = List.rev_map 12 | let rev_mapi f l = 13 | let i = ref (-1) in 14 | rev_map (fun x -> incr i; f !i x) l 15 | let length = List.length 16 | let append l = rev_append (rev l) 17 | let mapi f = rev_mapi f % rev 18 | let filter = List.filter 19 | 20 | let intersperse x = 21 | let rec prepend acc = function 22 | | [] -> acc 23 | | h :: t -> prepend (x :: h :: acc) t in 24 | function 25 | | [] -> [] 26 | | h :: t -> h :: prepend [] (rev t) 27 | 28 | include Monad.Make(struct 29 | type nonrec 'a t = 'a t 30 | 31 | let map f = rev_map f % rev 32 | let pure x = [ x ] 33 | let bind f x = 34 | let rec loop a = function 35 | | [] -> a 36 | | h :: t -> loop (a % append (f h)) t in 37 | loop id x [] 38 | let ap f x = 39 | if f = [] 40 | then [] 41 | else let x = x () in 42 | flip bind f @@ fun f -> 43 | flip bind x @@ fun x -> 44 | pure (f x) 45 | end) 46 | 47 | include Align.Make(struct 48 | type nonrec 'a t = 'a t 49 | 50 | let align_as both left right a b = 51 | let rec loop a = function 52 | | [], [] -> a 53 | | [] as l, x :: r -> loop (right x :: a) (l, r) 54 | | x :: l, ([] as r) -> loop (left x :: a) (l, r) 55 | | x :: l, y :: r -> loop (both x y :: a) (l, r) in 56 | rev (loop [] (a, b)) 57 | end) 58 | 59 | include Foldable.Make(struct 60 | type nonrec 'a t = 'a t 61 | 62 | let rec foldl f a = function 63 | | [] -> a 64 | | h :: t -> foldl f (f a h) t 65 | let rec foldr f a = function 66 | | [] -> a () 67 | | h :: t -> f h (defer (foldr f a) t) 68 | end) 69 | 70 | let foldr' f a x = foldl (flip f) a (rev x) 71 | 72 | module A3 (A : Applicative.Basic3) = Traversable.Make3(struct 73 | type nonrec 'a t = 'a t 74 | type ('u, 'v, 'a) f = ('u, 'v, 'a) A.t 75 | 76 | module Ap = Applicative.Make3(A) 77 | 78 | let traverse f = 79 | let cf x l = 80 | let open! Ap in 81 | ap (map _Cons (f x)) l in 82 | foldr cf (defer Ap.pure []) 83 | let traverse_ f = 84 | foldr (Ap.discard_left % f) (defer Ap.pure ()) 85 | end) 86 | 87 | module A2 (A : Applicative.Basic2) = A3(struct 88 | type (_, 'p, 'a) t = ('p, 'a) A.t 89 | include (A : Applicative.Basic2 with type ('p, 'a) t := ('p, 'a) A.t) 90 | end) 91 | 92 | module A (A : Applicative.Basic) = A2(struct 93 | type (_, 'a) t = 'a A.t 94 | include (A : Applicative.Basic with type 'a t := 'a A.t) 95 | end) 96 | 97 | module M3 (M : Monad.Basic3) = struct 98 | include A3(M) 99 | 100 | let foldr_m f a l = 101 | let g k x z = M.bind k (f x z) in 102 | foldl g M.pure l a 103 | 104 | let foldl_m f a l = 105 | let g x k z = M.bind (fun x -> k () x) (f z x) in 106 | foldr g (const M.pure) l a 107 | end 108 | 109 | module M2 (M : Monad.Basic2) = M3(struct 110 | type (_, 'p, 'a) t = ('p, 'a) M.t 111 | include (M : Monad.Basic2 with type ('p, 'a) t := ('p, 'a) M.t) 112 | end) 113 | 114 | module M (M : Monad.Basic) = M2(struct 115 | type (_, 'a) t = 'a M.t 116 | include (M : Monad.Basic with type 'a t := 'a M.t) 117 | end) 118 | 119 | -------------------------------------------------------------------------------- /lib/types/clarity_list.mli: -------------------------------------------------------------------------------- 1 | (** List data type *) 2 | 3 | type 'a t = 'a list 4 | 5 | val _Cons : 'a -> 'a list -> 'a list 6 | val _Nil : 'a list 7 | 8 | val iter : ('a -> unit) -> 'a t -> unit 9 | val append : 'a t -> 'a t -> 'a t 10 | val length : 'a t -> int 11 | val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t 12 | val filter : ('a -> bool) -> 'a t -> 'a t 13 | val intersperse : 'a -> 'a list -> 'a list 14 | 15 | val rev : 'a t -> 'a t 16 | 17 | include Monad.S with type 'a t := 'a t 18 | include Foldable.S with type 'a t := 'a t 19 | include Align.S with type 'a t := 'a t 20 | 21 | module A : functor (A : Applicative.Basic) -> Traversable.S with 22 | type 'a t := 'a t and 23 | type 'a f := 'a A.t 24 | module A2 : functor (A : Applicative.Basic2) -> Traversable.S2 with 25 | type 'a t := 'a t and 26 | type ('u, 'a) f := ('u, 'a) A.t 27 | module A3 : functor (A : Applicative.Basic3) -> Traversable.S3 with 28 | type 'a t := 'a t and 29 | type ('u, 'v, 'a) f := ('u, 'v, 'a) A.t 30 | 31 | module M : functor (M : Monad.Basic) -> sig 32 | include Traversable.S with 33 | type 'a t := 'a t and 34 | type 'a f := 'a M.t 35 | include Foldable.M with 36 | type 'a t := 'a t and 37 | type 'a m := 'a M.t 38 | end 39 | module M2 : functor (M : Monad.Basic2) -> sig 40 | include Traversable.S2 with 41 | type 'a t := 'a t and 42 | type ('u, 'a) f := ('u, 'a) M.t 43 | include Foldable.M2 with 44 | type 'a t := 'a t and 45 | type ('u, 'a) m := ('u, 'a) M.t 46 | end 47 | module M3 : functor (M : Monad.Basic3) -> sig 48 | include Traversable.S3 with 49 | type 'a t := 'a t and 50 | type ('u, 'v, 'a) f := ('u, 'v, 'a) M.t 51 | include Foldable.M3 with 52 | type 'a t := 'a t and 53 | type ('u, 'v, 'a) m := ('u, 'v, 'a) M.t 54 | end 55 | 56 | -------------------------------------------------------------------------------- /lib/types/either.ml: -------------------------------------------------------------------------------- 1 | open Fn 2 | 3 | type ('l, 'r) t = 4 | Left of 'l | Right of 'r 5 | 6 | let _Left x = Left x 7 | let _Right x = Right x 8 | 9 | let bimap l r = function 10 | | Left x -> Left (l x) 11 | | Right x -> Right (r x) 12 | 13 | include Monad.Make2(struct 14 | type nonrec ('l, 'r) t = ('l, 'r) t 15 | 16 | let map f x = bimap id f x 17 | 18 | let pure x = Right x 19 | let ap = function 20 | | Left _ as l -> const l 21 | | Right f -> fun x -> map f (x ()) 22 | 23 | let bind f = function 24 | | Left _ as l -> l 25 | | Right r -> f r 26 | end) 27 | 28 | let fold l r = function 29 | | Left x -> l x 30 | | Right x -> r x 31 | 32 | let swap = function 33 | | Left x -> Right x 34 | | Right x -> Left x 35 | 36 | let maybe_left = function 37 | | Left x -> Some x 38 | | Right _ -> None 39 | 40 | let maybe_right = function 41 | | Right x -> Some x 42 | | Left _ -> None 43 | 44 | -------------------------------------------------------------------------------- /lib/types/either.mli: -------------------------------------------------------------------------------- 1 | (** Either.t represents value of two exclusive possibilities *) 2 | type ('l, 'r) t = 3 | Left of 'l | Right of 'r 4 | 5 | val _Left : 'a -> ('a, 'b) t 6 | val _Right : 'a -> ('b, 'a) t 7 | 8 | include Monad.S2 with type ('l, 'r) t := ('l, 'r) t 9 | 10 | val bimap : ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) t -> ('b, 'd) t 11 | val fold : ('a -> 'b) -> ('c -> 'b) -> ('a, 'c) t -> 'b 12 | val swap : ('a, 'b) t -> ('b, 'a) t 13 | val maybe_left : ('a, 'b) t -> 'a option 14 | val maybe_right : ('a, 'b) t -> 'b option 15 | 16 | -------------------------------------------------------------------------------- /lib/types/fn.ml: -------------------------------------------------------------------------------- 1 | let curry f a b = f (a, b) 2 | let uncurry f (a, b) = f a b 3 | external id : 'a -> 'a = "%identity" 4 | let const a _ = a 5 | let compose f g x = f (g x) 6 | let (%) = compose 7 | let flip f a b = f b a 8 | let defer f x = fun _ -> f x 9 | 10 | -------------------------------------------------------------------------------- /lib/types/fn.mli: -------------------------------------------------------------------------------- 1 | (** Various function combinators *) 2 | 3 | val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c 4 | val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c 5 | external id : 'a -> 'a = "%identity" 6 | val const : 'a -> 'b -> 'a 7 | val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b 8 | val (%) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b 9 | val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c 10 | val defer : ('a -> 'b) -> 'a -> 'c -> 'b 11 | 12 | -------------------------------------------------------------------------------- /lib/types/id.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a 2 | 3 | let map f = f 4 | let pure x = x 5 | let ap f x = f (x ()) 6 | let bind f = f 7 | 8 | 9 | -------------------------------------------------------------------------------- /lib/types/id.mli: -------------------------------------------------------------------------------- 1 | (** Identity type *) 2 | type 'a t = 'a 3 | 4 | include Monad.Basic with type 'a t := 'a t 5 | 6 | -------------------------------------------------------------------------------- /lib/types/option.ml: -------------------------------------------------------------------------------- 1 | open Fn 2 | 3 | type 'a t = 'a option 4 | 5 | let _None = None 6 | let _Some x = Some x 7 | 8 | include Monad.Make(struct 9 | type nonrec 'a t = 'a t 10 | 11 | let map f = function 12 | | None -> None 13 | | Some x -> Some (f x) 14 | 15 | let pure x = Some x 16 | let ap = function 17 | | None -> const None 18 | | Some f -> fun x -> map f (x ()) 19 | 20 | let bind f = function 21 | | None -> None 22 | | Some x -> f x 23 | end) 24 | 25 | let fold s n = function 26 | | None -> n () 27 | | Some x -> s x 28 | 29 | let fold' s n = fold s (const n) 30 | 31 | let get_or_else x = fold' id x 32 | 33 | let to_right e = fold' Either._Right (Either.Left e) 34 | let to_left e = fold' Either._Left (Either.Right e) 35 | 36 | let iter f = fold' f () 37 | -------------------------------------------------------------------------------- /lib/types/option.mli: -------------------------------------------------------------------------------- 1 | (** Monad instance for an option type *) 2 | type 'a t = 'a option 3 | 4 | val _None : 'a t 5 | val _Some : 'a -> 'a t 6 | 7 | include Monad.S with type 'a t := 'a t 8 | 9 | val fold : ('a -> 'b) -> (unit -> 'b) -> 'a t -> 'b 10 | val fold' : ('a -> 'b) -> 'b -> 'a t -> 'b 11 | val get_or_else : 'a -> 'a t -> 'a 12 | val to_right : 'l -> 'r t -> ('l, 'r) Either.t 13 | val to_left : 'r -> 'l t -> ('l, 'r) Either.t 14 | val iter : ('a -> unit) -> 'a t -> unit 15 | -------------------------------------------------------------------------------- /lib/types/these.ml: -------------------------------------------------------------------------------- 1 | type ('l, 'r) t = 2 | | Left of 'l 3 | | Right of 'r 4 | | Both of 'l * 'r 5 | 6 | let _Left x = Left x 7 | let _Right x = Right x 8 | let _Both l r = Both (l, r) 9 | 10 | let bimap lf rf = function 11 | | Left l -> Left (lf l) 12 | | Right r -> Right (rf r) 13 | | Both (l, r) -> Both (lf l, rf r) 14 | 15 | module Make (S : Semigroup.S) = struct 16 | type nonrec 'a t = (S.t, 'a) t 17 | include Monad.Make(struct 18 | type nonrec 'a t = 'a t 19 | 20 | let pure x = Right x 21 | let bind f = function 22 | | Left _ as l -> l 23 | | Right r -> f r 24 | | Both (l, x) -> 25 | begin match f x with 26 | | Left l' -> Left (S.append l l') 27 | | Right r -> Both (l, r) 28 | | Both (l', r) -> Both (S.append l l', r) 29 | end 30 | 31 | let ap f x = 32 | match f with 33 | | Left _ as l -> l 34 | | Right f -> 35 | begin match x () with 36 | | Left _ as b -> b 37 | | Right x -> Right (f x) 38 | | Both (l, x) -> Both (l, f x) 39 | end 40 | | Both (a, f) -> 41 | begin match x () with 42 | | Left b -> Left (S.append a b) 43 | | Right x -> Both (a, f x) 44 | | Both (b, x) -> Both (S.append a b, f x) 45 | end 46 | 47 | let map f = function 48 | | Left _ as l -> l 49 | | Right r -> Right (f r) 50 | | Both (l, r) -> Both (l, f r) 51 | end) 52 | end 53 | 54 | let fold lf rf bf = function 55 | | Left l -> lf l 56 | | Right r -> rf r 57 | | Both (l, r) -> bf l r 58 | 59 | let swap = function 60 | | Left a -> Right a 61 | | Right a -> Left a 62 | | Both (a, b) -> Both (b, a) 63 | 64 | let maybe_left = function 65 | | Left x -> Some x 66 | | _ -> None 67 | 68 | let maybe_right = function 69 | | Right x -> Some x 70 | | _ -> None 71 | 72 | let maybe_both = function 73 | | Both (l, r) -> Some (l, r) 74 | | _ -> None 75 | 76 | -------------------------------------------------------------------------------- /lib/types/these.mli: -------------------------------------------------------------------------------- 1 | (** Values of two non-exclusive variants *) 2 | type ('l, 'r) t = 3 | Left of 'l | Right of 'r | Both of 'l * 'r 4 | 5 | val _Left : 'a -> ('a, 'b) t 6 | val _Right : 'a -> ('b, 'a) t 7 | val _Both : 'a -> 'b -> ('a, 'b) t 8 | 9 | (** Monad instance requires Semigroup to combine Left values *) 10 | module Make (S : Semigroup.S) : Monad.S with type 'a t = (S.t, 'a) t 11 | 12 | val bimap : ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) t -> ('b, 'd) t 13 | val fold : ('a -> 'b) -> ('c -> 'b) -> ('a -> 'c -> 'b) -> ('a, 'c) t -> 'b 14 | val swap : ('a, 'b) t -> ('b, 'a) t 15 | val maybe_left : ('a, 'b) t -> 'a option 16 | val maybe_right : ('a, 'b) t -> 'b option 17 | val maybe_both : ('a, 'b) t -> ('a * 'b) option 18 | 19 | -------------------------------------------------------------------------------- /lib/types/validation.ml: -------------------------------------------------------------------------------- 1 | module Make (S : Semigroup.S) = struct 2 | open Either 3 | 4 | type 'a t = (S.t, 'a) Either.t 5 | 6 | include Applicative.Make(struct 7 | type nonrec 'a t = 'a t 8 | 9 | let pure = pure 10 | let map = map 11 | let ap f x = 12 | match f, x () with 13 | | Right f, Right x -> Right (f x) 14 | | Left a, Left b -> Left (S.append a b) 15 | | Left _ as l, _ | _, (Left _ as l) -> l 16 | end) 17 | 18 | let map_errors f = bimap f Fn.id 19 | let fail = _Left 20 | let fold = fold 21 | let maybe_errors = maybe_left 22 | let maybe_result = maybe_right 23 | external to_either : 'a t -> (S.t, 'a) Either.t = "%identity" 24 | external of_either : (S.t, 'a) Either.t -> 'a t = "%identity" 25 | end 26 | 27 | -------------------------------------------------------------------------------- /lib/types/validation.mli: -------------------------------------------------------------------------------- 1 | (** A data-type like Either but with an error-accumulating Applicative *) 2 | 3 | module Make (S : Semigroup.S) : sig 4 | include Applicative.S 5 | 6 | val fail : S.t -> 'a t 7 | val map_errors : (S.t -> S.t) -> 'a t -> 'a t 8 | 9 | val fold : (S.t -> 'b) -> ('a -> 'b) -> 'a t -> 'b 10 | 11 | val maybe_errors : 'a t -> S.t option 12 | val maybe_result : 'a t -> 'a option 13 | 14 | external to_either : 'a t -> (S.t, 'a) Either.t = "%identity" 15 | external of_either : (S.t, 'a) Either.t -> 'a t = "%identity" 16 | end 17 | 18 | -------------------------------------------------------------------------------- /lib/types/vector/vector.ml: -------------------------------------------------------------------------------- 1 | include Vector_internal 2 | 3 | -------------------------------------------------------------------------------- /lib/types/vector/vector.mli: -------------------------------------------------------------------------------- 1 | (** Efficient persistent vectors based on RRB-Trees 2 | 3 | RRB (Relaxed Radix-Balanced) Trees allows "effectively constant" 4 | operations like getting element / updating at index, appending and 5 | splitting. *) 6 | 7 | type _ t 8 | 9 | (** Efficient construction of vectors using mutable, one-by-one appending of elements *) 10 | module Builder : sig 11 | type 'a vector = 'a t 12 | type _ t 13 | 14 | (** Creates new empty builder. *) 15 | val empty : unit -> 'a t 16 | 17 | (** Create copy of this builder. *) 18 | val copy : 'a t -> 'a t 19 | 20 | (** Put element to builder. *) 21 | val put : 'a t -> 'a -> unit 22 | 23 | (** Clear builder. *) 24 | val clear : 'a t -> unit 25 | 26 | (** Get vector of current elements in builder. *) 27 | val result : 'a t -> 'a vector 28 | end 29 | 30 | exception Out_of_bounds of { index : int; size : int } 31 | 32 | (** Empty vector. *) 33 | val empty : 'a t 34 | 35 | (** Prepend one element to vector. "Effectively constant". *) 36 | val cons : 'a -> 'a t -> 'a t 37 | 38 | (** Apppend one element to vector. "Effectively constant". *) 39 | val snoc : 'a t -> 'a -> 'a t 40 | 41 | (** The length of a vector. *) 42 | val length : 'a t -> int 43 | 44 | (** [init l f] creates vector of length [l] where value at position [i] is 45 | initialized with [f i]. *) 46 | val init : int -> (int -> 'a) -> 'a t 47 | 48 | (** Concatenates two vectors. "Effectively constant". *) 49 | val append : 'a t -> 'a t -> 'a t 50 | 51 | (** [get v i] returns the element of a [v] at position [i]. "Effectively 52 | constant". 53 | 54 | Raise [Out_of_bounds] when [i] is outside of [v] bounds. *) 55 | val get : 'a t -> int -> 'a 56 | 57 | (** [update v i x] returns new vector initialized with values of [v] where 58 | value at index [i] is replaced with [x]. "Effectively constant". 59 | 60 | Raise [Out_of_bounds] when [i] is outside of [v] bounds. *) 61 | val update : 'a t -> int -> 'a -> 'a t 62 | 63 | (** [split_at v i] returns pair of a vectors where first element is the prefix 64 | of [v] of length [i] and second is the suffix of [v] starting at [i]. 65 | "Effectively constant". 66 | 67 | Raise [Out_of_bounds] when [i] is negative. *) 68 | val split_at : 'a t -> int -> 'a t * 'a t 69 | 70 | (** [take v i] returns the prefix of [v] of length [i]. "Effectively 71 | constant". 72 | 73 | Raise [Out_of_bounds] when [i] is negative. *) 74 | val take : 'a t -> int -> 'a t 75 | 76 | (** [drop v i] returns the suffix of [v] starting at [i]. "Effectively 77 | constant". 78 | 79 | Raise [Out_of_bounds] when [i] is negative. *) 80 | val drop : 'a t -> int -> 'a t 81 | 82 | (** [iter f v] iterates over [v] applying [f] to each element. *) 83 | val iter : ('a -> unit) -> 'a t -> unit 84 | 85 | (** Converts list to vector *) 86 | val of_list : 'a list -> 'a t 87 | 88 | (** Converts vector to list *) 89 | val to_list : 'a t -> 'a list 90 | 91 | include Monad.S with type 'a t := 'a t 92 | include Foldable.S with type 'a t := 'a t 93 | include Align.S with type 'a t := 'a t 94 | 95 | module A : functor (A : Applicative.Basic) -> Traversable.S with 96 | type 'a t := 'a t and 97 | type 'a f := 'a A.t 98 | module A2 : functor (A : Applicative.Basic2) -> Traversable.S2 with 99 | type 'a t := 'a t and 100 | type ('u, 'a) f := ('u, 'a) A.t 101 | module A3 : functor (A : Applicative.Basic3) -> Traversable.S3 with 102 | type 'a t := 'a t and 103 | type ('u, 'v, 'a) f := ('u, 'v, 'a) A.t 104 | 105 | module M : functor (M : Monad.Basic) -> sig 106 | include Traversable.S with 107 | type 'a t := 'a t and 108 | type 'a f := 'a M.t 109 | include Foldable.M with 110 | type 'a t := 'a t and 111 | type 'a m := 'a M.t 112 | end 113 | module M2 : functor (M : Monad.Basic2) -> sig 114 | include Traversable.S2 with 115 | type 'a t := 'a t and 116 | type ('u, 'a) f := ('u, 'a) M.t 117 | include Foldable.M2 with 118 | type 'a t := 'a t and 119 | type ('u, 'a) m := ('u, 'a) M.t 120 | end 121 | module M3 : functor (M : Monad.Basic3) -> sig 122 | include Traversable.S3 with 123 | type 'a t := 'a t and 124 | type ('u, 'v, 'a) f := ('u, 'v, 'a) M.t 125 | include Foldable.M3 with 126 | type 'a t := 'a t and 127 | type ('u, 'v, 'a) m := ('u, 'v, 'a) M.t 128 | end 129 | 130 | -------------------------------------------------------------------------------- /lib/types/vector/vector_internal.ml: -------------------------------------------------------------------------------- 1 | open Fn 2 | 3 | module Arr = struct 4 | type 'a t = 'a array 5 | 6 | let set = Array.set 7 | let get = Array.get 8 | let len = Array.length 9 | let make = Array.make 10 | let copy = Array.copy 11 | let iter = Array.iter 12 | let foldl = Array.fold_left 13 | let foldr' f a x = Array.fold_right f x a 14 | let blit = Array.blit 15 | 16 | let foldr : type a x . (x -> (unit -> a) -> a) -> (unit -> a) -> x t -> a = 17 | fun f a x -> 18 | let rec loop (a : unit -> a) idx = 19 | if idx = len x 20 | then a () 21 | else f (get x idx) (fun () -> loop a (idx + 1)) in 22 | loop a 0 23 | end 24 | 25 | (* Array pair as a single data-type *) 26 | module AP = struct 27 | type 'a t = 'a array * 'a array 28 | 29 | let len (l, r) = Arr.len l + Arr.len r 30 | 31 | let get (l, r) i = 32 | if i < Arr.len l 33 | then Arr.get l i 34 | else Arr.get r (i - Arr.len l) 35 | 36 | let set (l, r) i x = 37 | if i < Arr.len l 38 | then Arr.set l i x 39 | else Arr.set r (i - Arr.len l) x 40 | 41 | let fold f a (l, r) = 42 | Arr.foldl f (Arr.foldl f a l) r 43 | end 44 | 45 | (* ceiling of a division *) 46 | let ceil_div a b = 1 + (a - 1) / b 47 | 48 | let _BITS = 5 49 | let _BRANCHING = 1 lsl _BITS 50 | let _EXTRA_STEPS = 2 51 | let _SKIP_SIZE = _BRANCHING - ceil_div _EXTRA_STEPS 2 52 | 53 | let check_depth = 54 | let max_depth = if Sys.int_size = 31 then 6 else 12 in 55 | fun d -> 56 | if d > max_depth then failwith "clarity-vector-too-large" 57 | 58 | type 'a t = 59 | | Leaf of 'a array 60 | | R_node of int array * 'a t array 61 | | B_node of 'a t array 62 | 63 | (* Depth of a tree *) 64 | let depth x = 65 | let rec loop : type a . int -> a t -> int = 66 | fun a -> function 67 | | Leaf _ -> a 68 | | R_node (_, n) | B_node n -> 69 | assert (Arr.len n > 0); 70 | loop (a + 1) (Arr.get n 0) in 71 | loop 0 x 72 | 73 | let rec length = function 74 | | Leaf x -> Arr.len x 75 | | R_node (i, v) -> 76 | assert (Arr.len i = Arr.len v); 77 | Arr.get i (Arr.len i - 1) 78 | | B_node v as node -> 79 | assert (Arr.len v > 0); 80 | let d = depth node in 81 | check_depth d; 82 | let item_sz = 1 lsl (d * _BITS) in 83 | item_sz * (Arr.len v - 1) + length (Arr.get v (Arr.len v - 1)) 84 | 85 | let update_lengths = function 86 | | Leaf _ | B_node _ -> () 87 | | R_node (is, vs) -> 88 | assert (Arr.len is = Arr.len vs); 89 | let sum = ref 0 in 90 | for i = 0 to Arr.len vs - 1 do 91 | sum := !sum + length (Arr.get vs i); 92 | Arr.set is i !sum 93 | done 94 | 95 | let mk_rnode arr = 96 | let res = R_node (Arr.make (Arr.len arr) 0, arr) in 97 | update_lengths res; 98 | res 99 | 100 | (* returns index of a slot and new 'index' value *) 101 | let rr_search : int array -> int -> int -> int * int = 102 | fun sizes depth idx -> 103 | assert (Arr.len sizes > 0); 104 | assert (idx <= Arr.get sizes (Arr.len sizes - 1)); 105 | check_depth depth; 106 | let start = idx lsr (_BITS * depth) in 107 | assert (start < Arr.len sizes); 108 | let rec loop n = 109 | assert (n < Arr.len sizes); 110 | let sz = Arr.get sizes n in 111 | if sz > idx 112 | then n 113 | else loop (n + 1) in 114 | let slot = loop start in 115 | let new_idx = 116 | if slot = 0 117 | then idx 118 | else idx - Arr.get sizes (slot - 1) in 119 | slot, new_idx 120 | 121 | let radix_search : int -> int -> int * int = 122 | fun depth idx -> 123 | check_depth depth; 124 | let shift = _BITS * depth in 125 | let slot = idx lsr shift in 126 | slot, idx - slot lsl shift 127 | 128 | (* Max node count allowed to contain such subnodes *) 129 | let max_nodes_allowed subnodes = 130 | _EXTRA_STEPS + (subnodes - 1) / _BRANCHING + 1 131 | 132 | let empty = Leaf [||] 133 | 134 | let get_leaf = function 135 | | Leaf x -> x 136 | | _ -> assert false 137 | 138 | let get_rnode = function 139 | | R_node (i, v) -> i, v 140 | | B_node v -> 141 | let sizes = Arr.make (Arr.len v) 0 in 142 | update_lengths (R_node (sizes, v)); 143 | sizes, v 144 | | _ -> assert false 145 | 146 | let get_bnode = function 147 | | B_node x -> x 148 | | _ -> assert false 149 | 150 | let node_len : type a . a t -> int = 151 | function 152 | | Leaf x -> Arr.len x 153 | | R_node (_, x) | B_node x -> Arr.len x 154 | 155 | (* Concatenation is complex; move it to separate module *) 156 | module Concatenation = struct 157 | (* Compute lengths of _new_ subnodes and store it in a provided array pair 158 | * Shared nodes will have values unchanged 159 | *) 160 | let assign_subnode_lengths : type a . a t AP.t -> int AP.t -> unit = 161 | fun src dst -> 162 | let dst_idx = ref 0 in 163 | let src_idx = ref 0 in 164 | let size = ref 0 in 165 | let not_done = 166 | let need = AP.len src - AP.len dst in 167 | fun () -> 168 | let need = if !size = 0 then need else need + 1 in 169 | let diff = !src_idx - !dst_idx in 170 | assert (diff <= need); 171 | diff <> need in 172 | let get () = 173 | assert (!src_idx < AP.len src); 174 | let res = AP.get src !src_idx in 175 | incr src_idx; 176 | res in 177 | let push (i : int) = 178 | assert (!dst_idx < AP.len dst); 179 | match () with 180 | | _ when i >= _SKIP_SIZE && !size = 0 -> 181 | (* AP.set dst !dst_idx i; *) 182 | incr dst_idx 183 | | _ when !size + i > _BRANCHING && !size < _SKIP_SIZE -> 184 | AP.set dst !dst_idx _BRANCHING; 185 | incr dst_idx; 186 | size := !size + i - _BRANCHING 187 | | _ when !size + i > _BRANCHING -> 188 | AP.set dst !dst_idx !size; 189 | incr dst_idx; 190 | size := i 191 | | _ -> 192 | size := !size + i in 193 | while not_done () do 194 | push (node_len (get ())) 195 | done; 196 | if !size <> 0 197 | then begin 198 | AP.set dst !dst_idx !size; 199 | incr dst_idx end (* ; 200 | for i = 0 to AP.len dst - !dst_idx - 1 do 201 | let node = AP.get src (!src_idx + i) in 202 | AP.set dst (!dst_idx + i)(node_len node) 203 | done *) 204 | 205 | (* copy subnode data according to 'lengths' array *) 206 | let copy_subnode_data : type a . a t AP.t -> a t AP.t -> int AP.t -> unit = 207 | fun (lnodes, _ as src_v) dst_v lengths -> 208 | let 209 | (copy_to_node : a t -> int -> a t -> int -> int -> unit), 210 | (new_node : int -> a t) = 211 | assert (Arr.len lnodes > 0); 212 | match Arr.get lnodes 0 with 213 | | Leaf x -> 214 | assert (Arr.len x > 0); 215 | (fun src src_off dst -> 216 | Arr.blit (get_leaf src) src_off (get_leaf dst)) 217 | , fun n -> Leaf (Arr.make n (Arr.get x 0)) 218 | | node -> 219 | let l, x = get_rnode node in 220 | assert (Arr.len l = Arr.len x); 221 | assert (Arr.len x > 0); 222 | (fun src src_off dst -> 223 | let dst_ = snd (get_rnode dst) in 224 | let src_ = snd (get_rnode src) in 225 | Arr.blit src_ src_off dst_) 226 | , fun n -> 227 | R_node (Arr.make n (Arr.get l 0), Arr.make n (Arr.get x 0)) in 228 | let src_idx = ref 0 in 229 | let src_off = ref 0 in 230 | for i = 0 to AP.len lengths - 1 do 231 | let new_len = AP.get lengths i in 232 | if new_len = 0 then ( 233 | (* shared chunk *) 234 | assert (!src_off = 0); 235 | AP.set dst_v i (AP.get src_v !src_idx); 236 | incr src_idx; 237 | ) else ( 238 | let nn = new_node new_len in 239 | let rec loop = function 240 | | n when n = new_len -> () 241 | | nn_off -> 242 | let src_node = AP.get src_v !src_idx in 243 | let sz = min (new_len - nn_off) (node_len src_node - !src_off) in 244 | copy_to_node src_node !src_off nn nn_off sz; 245 | src_off := !src_off + sz; 246 | if !src_off = node_len src_node 247 | then (src_off := 0; incr src_idx); 248 | loop (nn_off + sz) in 249 | loop 0; 250 | AP.set dst_v i nn 251 | ) 252 | done 253 | 254 | (* compute indices after copying data *) 255 | let compute_indices : type a . a t array -> int array -> int array -> unit = 256 | fun xv xi lengths -> 257 | assert (Arr.len xv = Arr.len xi); 258 | assert (Arr.len xv = Arr.len lengths); 259 | let sum = ref 0 in 260 | for i = 0 to Arr.len lengths - 1 do 261 | let len = Arr.get lengths i in 262 | let node = Arr.get xv i in 263 | if len <> 0 then update_lengths node; 264 | sum := !sum + length node; 265 | Arr.set xi i !sum 266 | done 267 | 268 | (* Merge two nodes of the same depth *) 269 | let merge : 'a t -> 'a t -> 'a t = 270 | fun l r -> 271 | let _, lv = get_rnode l in 272 | let _, rv = get_rnode r in 273 | assert (Arr.len lv > 0); 274 | let nodes = Arr.len lv + Arr.len rv in 275 | let subnodes = 276 | let sum a x = a + node_len x in 277 | Arr.foldl sum (Arr.foldl sum 0 lv) rv in 278 | let max_nodes = max_nodes_allowed subnodes in 279 | if max_nodes >= nodes 280 | then (* no balancing required *) 281 | mk_rnode (if node_len r = 0 then [| l |] else [| l; r |]) 282 | else begin 283 | let len_l, len_r = 284 | if max_nodes <= _BRANCHING 285 | then max_nodes, 0 286 | else _BRANCHING, max_nodes - _BRANCHING in 287 | let length_l = Arr.make len_l 0 in 288 | let length_r = Arr.make len_r 0 in 289 | let lengths = length_l, length_r in 290 | assign_subnode_lengths (lv, rv) lengths; 291 | let node_l = Arr.make len_l empty in 292 | let node_r = Arr.make len_r empty in 293 | let new_nodes = node_l, node_r in 294 | copy_subnode_data (lv, rv) new_nodes lengths; 295 | compute_indices node_l length_l length_l; 296 | compute_indices node_r length_r length_r; 297 | let lres = R_node (fst lengths, fst new_nodes) in 298 | let res = 299 | if len_r = 0 300 | then [| lres |] 301 | else 302 | let rres = R_node (snd lengths, snd new_nodes) in 303 | [| lres; rres |] in 304 | mk_rnode res 305 | end 306 | 307 | let leftmost = function 308 | | R_node (_, x) | B_node x -> 309 | Arr.get x 0 310 | | Leaf _ -> assert false 311 | 312 | let rightmost = function 313 | | R_node (_, x) | B_node x -> 314 | Arr.get x (Arr.len x - 1) 315 | | Leaf _ -> assert false 316 | 317 | (* append vectors of the same depth and return vector that is one-level 318 | greater *) 319 | let rec append_same : type a . a t -> a t -> int -> a t = 320 | fun l r n -> 321 | assert (depth l = n); 322 | assert (depth r = n); 323 | match n with 324 | | 0 -> 325 | assert (node_len l > 0); 326 | assert (node_len r > 0); 327 | (match l, r with 328 | | Leaf _, Leaf _ -> () 329 | | _ -> assert false); 330 | mk_rnode [| l; r |] 331 | | 1 -> merge l r 332 | | n -> 333 | let _, lv = get_rnode l in 334 | let _, rv = get_rnode r in 335 | assert (Arr.len lv > 0); 336 | assert (Arr.len rv > 0); 337 | let intermediate = append_same (rightmost l) (leftmost r) (n - 1) in 338 | let _, iv = get_rnode intermediate in 339 | let overall = node_len l + node_len r - 2 + node_len intermediate in 340 | let ll, lr = 341 | if overall > _BRANCHING 342 | then _BRANCHING, overall - _BRANCHING 343 | else overall, 0 in 344 | let lnode = Arr.make ll empty in 345 | let rnode = Arr.make lr empty in 346 | let ap = lnode, rnode in 347 | let idx = ref 0 in 348 | (* TODO: use blit-like function *) 349 | for i = 0 to Arr.len lv - 2 do 350 | AP.set ap !idx (Arr.get lv i); 351 | incr idx 352 | done; 353 | for i = 0 to Arr.len iv - 1 do 354 | AP.set ap !idx (Arr.get iv i); 355 | incr idx 356 | done; 357 | for i = 1 to Arr.len rv - 1 do 358 | AP.set ap !idx (Arr.get rv i); 359 | incr idx 360 | done; 361 | let l = R_node (Arr.make ll 0, lnode) in 362 | let r = R_node (Arr.make lr 0, rnode) in 363 | update_lengths l; 364 | update_lengths r; 365 | merge l r 366 | 367 | let append : type a . a t -> a t -> a t = 368 | fun l r -> 369 | match l, r with 370 | | Leaf [||], x | x, Leaf [||] -> x 371 | | _ -> 372 | let dl = depth l in 373 | let dr = depth r in 374 | let rec add_layers x = function 375 | | 0 -> x 376 | | n -> add_layers (mk_rnode [| x |]) (n - 1) in 377 | let res = 378 | match () with 379 | | _ when dl = dr -> append_same l r dl 380 | | _ when dl < dr -> append_same (add_layers l (dr - dl)) r dr 381 | | _ (* when dl > dr *) -> append_same l (add_layers r (dl - dr)) dl in 382 | match res with 383 | | R_node (_, vs) when Arr.len vs = 1 -> 384 | Arr.get vs 0 385 | | _ -> res 386 | end 387 | 388 | let append = Concatenation.append 389 | 390 | let cons x v = append (Leaf [| x |]) v 391 | let snoc v x = append v (Leaf [| x |]) 392 | 393 | exception Out_of_bounds of { index : int; size : int } 394 | 395 | let check_bounds n index = 396 | let size = length n in 397 | if size - 1 < index || index < 0 398 | then raise (Out_of_bounds { index; size }) 399 | 400 | let get : type a . a t -> int -> a = 401 | fun n i -> 402 | check_bounds n i; 403 | let rec loop n i = function 404 | | 0 -> Arr.get (get_leaf n) i 405 | | d -> 406 | begin match n with 407 | | Leaf _ -> assert false 408 | | R_node (is, vs) -> 409 | let slot, new_i = rr_search is d i in 410 | loop (Arr.get vs slot) new_i (d - 1) 411 | | B_node vs -> 412 | let slot, new_i = radix_search d i in 413 | loop (Arr.get vs slot) new_i (d - 1) end in 414 | loop n i (depth n) 415 | 416 | let update : type a . a t -> int -> a -> a t = 417 | fun n i x -> 418 | check_bounds n i; 419 | let rec loop n i = function 420 | | 0 -> 421 | let res = Arr.copy (get_leaf n) in 422 | Arr.set res i x; 423 | Leaf res 424 | | d -> 425 | begin match n with 426 | | Leaf _ -> assert false 427 | | R_node (is, vs) -> 428 | let slot, new_i = rr_search is d i in 429 | let upd = loop (Arr.get vs slot) new_i (d - 1) in 430 | let res = Arr.copy vs in 431 | Arr.set res slot upd; 432 | R_node (is, res) 433 | | B_node vs -> 434 | let slot, new_i = radix_search d i in 435 | let upd = loop (Arr.get vs slot) new_i (d - 1) in 436 | let res = Arr.copy vs in 437 | Arr.set res slot upd; 438 | B_node res end in 439 | loop n i (depth n) 440 | 441 | let split_at : type a . a t -> int -> a t * a t = 442 | fun n i -> 443 | let size = length n in 444 | if i < 0 then raise (Out_of_bounds { index = i; size }); 445 | let rec loop n i = function 446 | | 0 -> 447 | begin match i with 448 | | 0 -> None, Some n 449 | | i when node_len n = i -> Some n, None 450 | | i -> 451 | let a = get_leaf n in 452 | let al = Arr.make i (Arr.get a 0) in 453 | let ar = Arr.make (Arr.len a - i) (Arr.get a i) in 454 | Arr.blit a 1 al 1 (i - 1); 455 | Arr.blit a (i + 1) ar 1 (Arr.len a - i - 1); 456 | Some (Leaf al), Some (Leaf ar) end 457 | | d -> 458 | begin match n with 459 | | Leaf _ -> assert false 460 | | node when i = 0 -> None, Some node 461 | | node when i >= length node -> Some node, None 462 | | node -> 463 | let is, vs = get_rnode node in 464 | assert (Arr.len is = Arr.len vs); 465 | assert (Arr.len is > 0); 466 | let slot, new_i = rr_search is d i in 467 | let l, r = loop (Arr.get vs slot) new_i (d - 1) in 468 | let len_l = if l = None then slot else slot + 1 in 469 | let len_r = Arr.len vs - if r = None then slot + 1 else slot in 470 | let nl = 471 | Some ( 472 | let lv = Arr.make len_l (Arr.get vs 0) in 473 | for j = 1 to slot - 1 do 474 | Arr.set lv j (Arr.get vs j) 475 | done; 476 | begin match l with 477 | | None -> () 478 | | Some x -> Arr.set lv slot x end; 479 | mk_rnode lv 480 | ) in 481 | let nr = 482 | Some ( 483 | let rv = Arr.make len_r (Arr.get vs 0) in 484 | begin match r with 485 | | None -> 486 | for j = 0 to len_r - 1 do 487 | Arr.set rv j (Arr.get vs (j + slot)) 488 | done 489 | | Some x -> 490 | Arr.set rv 0 x; 491 | for j = 1 to len_r - 1 do 492 | Arr.set rv j (Arr.get vs (j + slot)) 493 | done end; 494 | mk_rnode rv 495 | ) in 496 | nl, nr end in 497 | let l, r = loop n i (depth n) in 498 | let get = function 499 | | Some x -> x 500 | | None -> empty in 501 | get l, get r 502 | 503 | let take : type a . a t -> int -> a t = 504 | fun n i -> 505 | let sz = length n in 506 | fst (split_at n (if i > sz then sz else i)) 507 | 508 | let drop : type a . a t -> int -> a t = 509 | fun n i -> 510 | let sz = length n in 511 | snd (split_at n (if i > sz then sz else i)) 512 | 513 | let rec iter f = function 514 | | Leaf x -> Arr.iter f x 515 | | R_node (_, x) | B_node x -> Arr.iter (iter f) x 516 | 517 | module Builder = struct 518 | type 'a vector = 'a t 519 | type 'a chunk = 520 | { mutable cnt : int 521 | ; vec : 'a vector 522 | } 523 | type 'a t = 'a chunk list ref 524 | 525 | let copy : 'a t -> 'a t = fun x -> 526 | match !x with 527 | | [] -> ref [] 528 | | { cnt; vec } :: t -> ref ({ cnt = cnt; vec = vec } :: t) 529 | 530 | let rec push_node n (x : 'a t) : unit = 531 | match !x with 532 | | [] -> x := [ { cnt = 1; vec = B_node (Arr.make _BRANCHING n) } ] 533 | | { cnt; vec = B_node arr } as h :: _ when cnt < _BRANCHING -> 534 | Arr.set arr cnt n; 535 | h.cnt <- cnt + 1 536 | | { cnt; vec } :: t -> 537 | assert (cnt = _BRANCHING); 538 | let tail = ref t in 539 | push_node vec tail; 540 | x := { cnt = 1; vec = B_node (Arr.make _BRANCHING n) } :: !tail 541 | 542 | let put (x : 'a t) e : unit = 543 | match !x with 544 | | [] -> 545 | x := [{ cnt = 1; vec = Leaf (Arr.make _BRANCHING e) }] 546 | | { cnt; vec = Leaf arr } as h :: _ when cnt < _BRANCHING -> 547 | Arr.set arr cnt e; 548 | h.cnt <- cnt + 1 549 | | { cnt; vec } :: t -> 550 | assert (cnt = _BRANCHING); 551 | let tail = ref t in 552 | push_node vec tail; 553 | x := { cnt = 1; vec = Leaf (Arr.make _BRANCHING e) } :: !tail 554 | 555 | let rec result (x : 'a t) : 'a vector = 556 | let realloc_array a n = 557 | assert (Arr.len a > n); 558 | let res = Arr.make n (Arr.get a 0) in 559 | for i = 1 to n - 1 do 560 | Arr.set res i (Arr.get a i) 561 | done; 562 | res in 563 | let realloc = function 564 | | { cnt; vec } when cnt = _BRANCHING -> vec 565 | | { cnt; vec = Leaf x } -> Leaf (realloc_array x cnt) 566 | | { cnt; vec = B_node x } -> B_node (realloc_array x cnt) 567 | | _ -> assert false in 568 | match !x with 569 | | [] -> empty 570 | | [ x ] -> realloc x 571 | | h :: t -> 572 | let tail = ref t in 573 | push_node (realloc h) tail; 574 | result tail 575 | 576 | let empty () = ref [] 577 | let clear b = b := [] 578 | end 579 | 580 | let init : type a . int -> (int -> a) -> a t = 581 | fun l f -> 582 | let b = Builder.empty () in 583 | for i = 1 to l do 584 | Builder.put b (f i) 585 | done; 586 | Builder.result b 587 | 588 | include Monad.Make(struct 589 | type nonrec 'a t = 'a t 590 | 591 | let pure x = Leaf [| x |] 592 | 593 | let bind f x = 594 | let b = Builder.empty () in 595 | iter (fun y -> iter (Builder.put b) (f y)) x; 596 | Builder.result b 597 | 598 | let ap f x = 599 | if f = empty 600 | then empty 601 | else let x = x () in 602 | let b = Builder.empty () in 603 | iter (fun f -> iter (Builder.put b % f) x) f; 604 | Builder.result b 605 | 606 | let map f x = ap (pure f) (const x) 607 | end) 608 | 609 | include Foldable.Make(struct 610 | type nonrec 'a t = 'a t 611 | 612 | let rec foldl f a = function 613 | | Leaf x -> Arr.foldl f a x 614 | | R_node (_, x) | B_node x -> Arr.foldl (foldl f) a x 615 | 616 | let rec foldr f a = function 617 | | Leaf x -> Arr.foldr f a x 618 | | R_node (_, x) | B_node x -> Arr.foldr (fun x a -> foldr f a x) a x 619 | end) 620 | 621 | let rec foldr' f a = function 622 | | Leaf x -> Arr.foldr' f a x 623 | | R_node (_, x) | B_node x -> Arr.foldr' (fun x a -> foldr' f a x) a x 624 | 625 | let to_list x = foldr' Clarity_list._Cons [] x 626 | let of_list x = 627 | let b = Builder.empty () in 628 | Clarity_list.iter (Builder.put b) x; 629 | Builder.result b 630 | 631 | include Align.Make(struct 632 | type nonrec 'a t = 'a t 633 | 634 | let align_as both left right a b = 635 | let la = length a in 636 | let lb = length b in 637 | let build = Builder.empty () in 638 | for i = 0 to min la lb - 1 do 639 | Builder.put build (both (get a i) (get b i)) 640 | done; 641 | if la > lb 642 | then for i = lb to la - 1 do 643 | Builder.put build @@ left (get a i) 644 | done else if la < lb 645 | then for i = la to lb - 1 do 646 | Builder.put build @@ right (get b i) 647 | done; 648 | Builder.result build 649 | end) 650 | 651 | module A3 (A : Applicative.Basic3) = Traversable.Make3(struct 652 | type nonrec 'a t = 'a t 653 | type ('u, 'v, 'a) f = ('u, 'v, 'a) A.t 654 | 655 | module Ap = Applicative.Make3(A) 656 | 657 | let traverse f x = 658 | let cf x l = 659 | let open! Ap in 660 | ap (map (fun h t -> h :: t) (f x)) l in 661 | let ls = foldr cf (defer Ap.pure []) x in 662 | Ap.map of_list ls 663 | 664 | let traverse_ f = 665 | foldr (Ap.discard_left % f) (defer Ap.pure ()) 666 | end) 667 | 668 | module A2 (A : Applicative.Basic2) = A3(struct 669 | type (_, 'p, 'a) t = ('p, 'a) A.t 670 | include (A : Applicative.Basic2 with type ('p, 'a) t := ('p, 'a) A.t) 671 | end) 672 | 673 | module A (A : Applicative.Basic) = A2(struct 674 | type (_, 'a) t = 'a A.t 675 | include (A : Applicative.Basic with type 'a t := 'a A.t) 676 | end) 677 | 678 | module M3 (M : Monad.Basic3) = struct 679 | include A3(M) 680 | 681 | let foldr_m f a l = 682 | let g k x z = M.bind k (f x z) in 683 | foldl g M.pure l a 684 | 685 | let foldl_m f a l = 686 | let g x k z = M.bind (fun x -> k () x) (f z x) in 687 | foldr g (const M.pure) l a 688 | end 689 | 690 | module M2 (M : Monad.Basic2) = M3(struct 691 | type (_, 'p, 'a) t = ('p, 'a) M.t 692 | include (M : Monad.Basic2 with type ('p, 'a) t := ('p, 'a) M.t) 693 | end) 694 | 695 | module M (M : Monad.Basic) = M2(struct 696 | type (_, 'a) t = 'a M.t 697 | include (M : Monad.Basic with type 'a t := 'a M.t) 698 | end) 699 | 700 | -------------------------------------------------------------------------------- /lib/types/void.ml: -------------------------------------------------------------------------------- 1 | type t = { absurd : 'a . 'a } 2 | 3 | let absurd x = x.absurd 4 | 5 | -------------------------------------------------------------------------------- /lib/types/void.mli: -------------------------------------------------------------------------------- 1 | (** Void.t is a logically uninhabited data type. *) 2 | type t 3 | 4 | (** 5 | Since Void.t values don't exist, it's logically possible to create value 6 | of any type 7 | *) 8 | val absurd : t -> 'a 9 | 10 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries clarity) 4 | (ocamlopt_flags (-O2 -w +44+45 -strict-sequence -principal))) 5 | (alias 6 | (name runtest) 7 | (action (run ./main.exe))) 8 | -------------------------------------------------------------------------------- /tests/main.ml: -------------------------------------------------------------------------------- 1 | include Vector 2 | 3 | -------------------------------------------------------------------------------- /tests/vector.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | open! Clarity 4 | open Internal.Vector 5 | 6 | module A = Array 7 | 8 | let ok s = printf "Vector.%s OK\n" s; flush stdout 9 | 10 | let rec check_bnode check_size = function 11 | | B_node vs -> 12 | if check_size 13 | then assert (A.length vs = _BRANCHING); 14 | for i = 0 to A.length vs - 2 do 15 | check_bnode true (A.get vs i) 16 | done; 17 | check_bnode false (A.get vs (A.length vs - 1)) 18 | | Leaf x -> 19 | if check_size 20 | then assert (A.length x = _BRANCHING) 21 | | _ -> assert false 22 | 23 | let rec check_indices = function 24 | | Leaf _ -> () 25 | | B_node _ as bnode -> check_bnode false bnode 26 | | R_node (is, vs) -> 27 | assert (A.length is = A.length vs); 28 | assert (A.length is <= _BRANCHING); 29 | assert (A.length is > 0); 30 | let size = ref 0 in 31 | for i = 0 to A.length is - 1 do 32 | let node = A.get vs i in 33 | size := !size + length node; 34 | assert (A.get is i = !size); 35 | A.iter check_indices vs 36 | done 37 | 38 | module Concat = struct 39 | let mk = 40 | let n = ref 0 in 41 | fun l -> 42 | Leaf (A.init l (fun _ -> incr n; !n)) 43 | let mk n = mk_rnode (A.init n (fun _ -> mk 25)) 44 | let mk n = mk_rnode (A.init n (fun _ -> mk 27)) 45 | let src_a = mk 11 46 | let src_b = mk 15 47 | 48 | let src_a = append src_a src_a 49 | let src_b = append src_b src_b 50 | let src_a = map (fun x -> x) src_a 51 | let src_b = append src_b src_a 52 | let src_a = append src_a src_b 53 | let src_b = map (fun x -> x) src_b 54 | let src_a = append src_b src_a 55 | let src_a = append src_a src_a 56 | 57 | let dst = append src_a src_b 58 | 59 | ;; check_indices src_a 60 | ;; check_indices src_b 61 | ;; check_indices dst 62 | 63 | let dst_lst = to_list dst 64 | ;; assert (to_list src_a @ to_list src_b = dst_lst) 65 | ;; assert (List.length dst_lst = length dst) 66 | ;; ok "Concat" 67 | end 68 | 69 | module Concat2 = struct 70 | let mk = 71 | let n = ref 0 in 72 | fun l -> 73 | Leaf (A.init l (fun _ -> incr n; !n)) 74 | 75 | ;; 76 | for a = 1 to _BRANCHING - 1 do 77 | for b = 1 to _BRANCHING - 1 do 78 | for c = 1 to _BRANCHING - 1 do 79 | let mk n = mk_rnode (A.init n (fun _ -> mk c)) in 80 | let src_a = mk b in 81 | let src_b = mk a in 82 | let src_a = append src_a src_b in 83 | let src_b = append src_b src_a in 84 | let src_a = map (fun x -> x) src_a in 85 | let src_a = append src_a src_b in 86 | let src_b = append src_b src_a in 87 | let src_b = map (fun x -> x) src_b in 88 | let src_a = append src_a src_b in 89 | let src_b = append src_b src_a in 90 | check_indices src_b 91 | done 92 | done 93 | done 94 | 95 | ;; ok "Concat2" 96 | end 97 | 98 | module RR_search = struct 99 | (* rr_search test *) 100 | let sizes = [| 31; 62; 94 |] 101 | let depth = 1 102 | let idx = 91 103 | let slot, new_idx = rr_search sizes depth idx 104 | 105 | ;; assert (slot = 2) 106 | ;; assert (new_idx = 29) 107 | 108 | ;; ok "RR_search" 109 | end 110 | 111 | module Get = struct 112 | let mk = 113 | let n = ref (-1) in 114 | fun l -> 115 | Leaf (A.init l (fun _ -> incr n; !n)) 116 | let mk n = mk_rnode (A.init n (fun _ -> mk 32)) 117 | let mk n = mk_rnode (A.init n (fun _ -> mk 30)) 118 | let mk n = mk_rnode (A.init n (fun _ -> mk 7)) 119 | let src = mk 27 120 | 121 | let idx = ref 0 122 | ;; iter (fun x -> assert (x = get src !idx); incr idx) src 123 | 124 | ;; try 125 | ignore @@ get src (length src); 126 | assert false 127 | with 128 | | Out_of_bounds _ -> () 129 | | _ -> assert false 130 | 131 | ;; try 132 | ignore @@ get src (-1); 133 | assert false 134 | with 135 | | Out_of_bounds _ -> () 136 | | _ -> assert false 137 | 138 | ;; ok "Get" 139 | end 140 | 141 | module Update = struct 142 | let mk = 143 | let n = ref (-1) in 144 | fun l -> 145 | Leaf (A.init l (fun _ -> incr n; !n)) 146 | let mk n = mk_rnode (A.init n (fun _ -> mk 3)) 147 | let mk n = mk_rnode (A.init n (fun _ -> mk 2)) 148 | let mk n = mk_rnode (A.init n (fun _ -> mk 4)) 149 | let src = mk 3 150 | 151 | let src = update src 10 10000 152 | let upd_val = -123 153 | ;; for i = 0 to length src - 1 do 154 | assert (get (update src i upd_val) i = upd_val) 155 | done 156 | 157 | ;; ok "Update" 158 | end 159 | 160 | module Map = struct 161 | (* map test *) 162 | let mk = 163 | let n = ref (-1) in 164 | fun l -> 165 | Leaf (A.init l (fun _ -> incr n; !n)) 166 | let mk n = mk_rnode (A.init n (fun _ -> mk 4)) 167 | let mk n = mk_rnode (A.init n (fun _ -> mk 8)) 168 | let mk n = mk_rnode (A.init n (fun _ -> mk 4)) 169 | let mk n = mk_rnode (A.init n (fun _ -> mk 8)) 170 | 171 | let src = mk 1 172 | let dst = map (fun x -> x * 100000) src 173 | ;; assert (length src = _BRANCHING lsl _BITS) 174 | ;; assert (length dst = _BRANCHING lsl _BITS) 175 | 176 | let idx = ref 0 177 | ;; iter (fun x -> assert (x = 100000 * get src !idx); incr idx) dst 178 | ;; check_bnode true dst 179 | ;; assert (depth dst = 1) 180 | 181 | ;; ok "Map" 182 | end 183 | 184 | module Split_at = struct 185 | let mk = 186 | let n = ref (-1) in 187 | fun l -> 188 | Leaf (A.init l (fun _ -> incr n; !n)) 189 | let mk n = mk_rnode (A.init n (fun _ -> mk 5)) 190 | let mk n = mk_rnode (A.init n (fun _ -> mk 4)) 191 | let mk n = mk_rnode (A.init n (fun _ -> mk 8)) 192 | let mk n = mk_rnode (A.init n (fun _ -> mk 7)) 193 | 194 | let src = mk 1 195 | 196 | ;; for n = 0 to length src do 197 | let l, r = split_at src n in 198 | let src2 = append l r in 199 | let l, r = split_at src2 n in 200 | assert (l = take src2 n); 201 | assert (r = drop src2 n); 202 | assert (length l + length r = length src); 203 | 204 | let idx = ref 0 in 205 | iter (fun x -> assert (x = get src !idx); incr idx) l; 206 | iter (fun x -> assert (x = get src !idx); incr idx) r; 207 | check_indices l; 208 | check_indices r 209 | done 210 | 211 | ;; ignore @@ split_at src (length src + 1000) 212 | 213 | ;; ok "Split_at" 214 | end 215 | 216 | module Align = struct 217 | open These 218 | let lefts x = 219 | foldl 220 | (fun a -> function Left l | Both (l, _) -> l :: a | _ -> a) 221 | [] 222 | x 223 | |> List.rev 224 | let rights x = 225 | foldl 226 | (fun a -> function Right r | Both (_, r) -> r :: a | _ -> a) 227 | [] 228 | x 229 | |> List.rev 230 | 231 | let mk = 232 | let n = ref (-1) in 233 | fun l -> 234 | Leaf (A.init l (fun _ -> incr n; !n)) 235 | let mk n = mk_rnode (A.init n (fun _ -> mk 5)) 236 | let mk n = mk_rnode (A.init n (fun _ -> mk 4)) 237 | let mk n = mk_rnode (A.init n (fun _ -> mk 8)) 238 | 239 | let a = mk 5 240 | let b = mk 3 241 | ;; assert (length a > length b) 242 | 243 | let c = align a b 244 | 245 | ;; assert (to_list a = lefts c) 246 | ;; assert (to_list b = rights c) 247 | 248 | ;; ok "Align" 249 | end 250 | 251 | module Bind = struct 252 | let mk = 253 | let n = ref (-1) in 254 | fun l -> 255 | Leaf (A.init l (fun _ -> incr n; !n)) 256 | let mk n = mk_rnode (A.init n (fun _ -> mk 5)) 257 | let mk n = mk_rnode (A.init n (fun _ -> mk 4)) 258 | 259 | ;; 260 | for i = 1 to 16 do 261 | for j = 1 to 16 do 262 | let a = mk i in 263 | let b = 264 | a >>= fun x -> 265 | of_list @@ List.join @@ List.repeat j [ x ] in 266 | assert (length b = length a * j) 267 | done 268 | done 269 | 270 | ;; ok "Bind" 271 | end 272 | 273 | module Init = struct 274 | for l = 0 to 10 do 275 | assert(length (init l (fun _ -> 0)) = l) 276 | done 277 | 278 | ;; ok "Init" 279 | end 280 | 281 | --------------------------------------------------------------------------------