├── .gitignore ├── README.md ├── abstract_lexer ├── Makefile ├── abstract_lexer.ml ├── dune ├── dune-project ├── lexer.mll ├── lexers.ml └── test.dat ├── arrows ├── Makefile ├── arr.ml ├── arrow.ml ├── arrow.mli ├── dune └── dune-project ├── extensible_ast ├── Makefile ├── ast.ml ├── dune └── dune-project └── union_find ├── Makefile ├── dune ├── dune-project ├── test_union_find.ml ├── union_find.ml └── union_find.mli /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | .merlin 3 | *.install 4 | _build 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # OCaml Programming Patterns 2 | 3 | ## Purpose 4 | 5 | This package contains some random programming tricks, "design patterns", 6 | and other helpful or at least inspiring ideas of achieving a high level of 7 | abstraction in OCaml programs that I have come across over time. Some may 8 | demonstrate how to implement concepts of more or less theoretical interest 9 | (e.g. arrows, monads), others show more practical hints on how to structure 10 | code to make it more reusable (e.g. abstract lexers, extensible ASTs). 11 | 12 | ## Contents 13 | 14 | The package currently contains the following: 15 | 16 | - [Abstract Lexer](#abstract-lexer) 17 | - [Extensible ASTs](#extensible-asts) 18 | - [Arrows](#arrows) 19 | - [Union find](#union-find) 20 | 21 | ## Abstract Lexer 22 | 23 | ### Quick introduction to syntactic analysis 24 | 25 | The first step in the process of compilation or interpretation of computer 26 | programs or other formal languages is typically lexical and syntactic analysis, 27 | or in other terms: 28 | 29 | 1. Lexing 30 | 2. Parsing 31 | 32 | The process of lexing transforms a stream of _characters_ (e.g. ANSI, 33 | Unicode, etc.) to a stream of _tokens_, thus providing a more accessible 34 | representation of the elements in the input. This step might, for example, 35 | identify keywords, numbers, operators, etc. The process of parsing assigns 36 | a grammatical structure to these elements, thus grouping them in ways that 37 | allow us to interpret the input more easily. 38 | 39 | ### Purpose of the abstract lexer 40 | 41 | The purpose of the _abstract lexer_ is to fully separate steps one and two 42 | above when using `ocamllex` to generate lexers. 43 | 44 | Programmers typically implement lexers such that they generate a token 45 | stream for a particular parser. This is usually all they need so there is 46 | no problem with that. But sometimes requirements change and we may want to 47 | use different parsers with the same lexer. 48 | 49 | For example, the requirement for one parser might be optimum efficiency. 50 | It may not want to deal with comments in an input file and rather ignore those 51 | already during lexing. We may want to avoid having to implement grammar 52 | rules that take into account comment syntax in that case. Other parsers, 53 | however, might want to keep comments, for example to pretty-print transformed 54 | input without losing this valuable information. 55 | 56 | The _abstract lexer_ achieves this separation by wrapping lexers generated by 57 | `ocamllex` into a functor that abstracts over the types of values ("tokens") 58 | returned by the lexer. 59 | 60 | A lexer specification usually consists of several _rules_ (functions). 61 | These functions take the current state of the lexer, which specifies the 62 | position in the input stream, and try to match one ore more _patterns_ 63 | (regular expressions) at the current location in the input stream. If a 64 | pattern matches, an associated action will be executed. 65 | 66 | Instead of returning a specific parser token from within an action, which 67 | would be the usual thing to do, abstract lexers call a function in the 68 | functor argument and pass it whatever lexeme (or relevant part of a lexeme) 69 | the lexer has just identified. This function may then return a parser token 70 | for whatever parser it is intended for. 71 | 72 | Sometimes lexer rules may also call other lexer rules recursively. In the 73 | abstract lexer design, however, we never call other rules explicitly. 74 | There is hence no explicit recursion. This is important, because some 75 | parsers may want to just let the lexer continue matching further input rather 76 | than return a token, whereas others might want to see a token to relate it 77 | grammatically to others. 78 | 79 | ### Example implementation 80 | 81 | The `abstract_lexer` directory contains the following files: 82 | 83 | - `lexer.mll` 84 | - `lexers.ml` 85 | - `abstract_lexer.ml` 86 | - `test.dat` 87 | 88 | The `ocamllex` file `lexer.mll` demonstrates how to wrap a lexer into a 89 | functor. The signature of the functor argument is `Spec`. This specification 90 | introduces a module for each rule in the lexer (e.g. `Any_char`) containing 91 | an abstract type `t`. All rule actions have to return the same type anyway, 92 | and here this type is completely abstract rather than a particular type of 93 | parser tokens. 94 | 95 | Now we introduce a function for each pattern action, 96 | e.g. `Any_char.handle_char`. It has to take the current `lexbuf` as argument 97 | so that an instance of the lexer can extract additional lexeme information 98 | (e.g. location information if required), or to allow recursive calls to 99 | other lexer rules. We may often want to also pass additional arguments, 100 | e.g. particular parts of the lexeme that we have already extracted. This is 101 | useful if, for example, we attach identifiers to sub-patterns in the lexer 102 | rule. 103 | 104 | The functor in `lexer.mll` is introduced in the header part of the lexer 105 | specification and closed in the trailer, thus wrapping the automatically 106 | generated lexer code into its body. 107 | 108 | An example instance of this lexer is given in file `lexers.ml`. It is called 109 | `Lexers.Alternating` and demonstrates how to specify recursive lexer rules. 110 | This is achieved by making the module `Alternating` itself recursive. 111 | 112 | The file `abstract_lexer.ml` will start lexing from standard input with rule 113 | `Lexers.Alternating.any_char`. Valid example input can be found in 114 | file `test.dat`. You can compile and test the example by going to the 115 | `abstract_lexer` directory and executing: 116 | 117 | ```sh 118 | dune exec ./abstract_lexer.exe < test.dat 119 | ``` 120 | 121 | ### Fazit 122 | 123 | It seems recommendable to write new lexers in an abstract style as demonstrated 124 | above. This will allow you to completely and cleanly separate the stages 125 | of lexical and syntactic analysis. If, for example, future requirements 126 | ask for a new parser, you won't have to pollute old parser specifications 127 | with new tokens and dummy rules. 128 | 129 | The performance impact of this abstraction will generally be neglible, 130 | assuming the lexer is well-written. This requires that as much work as 131 | possible is assigned to the lexing engine rather than to pattern actions. 132 | E.g. rules containing a pattern that matches a single character and which 133 | are called recursively to handle input in this piece-wise fashion should be 134 | rewritten to match one complex pattern and perform one action only instead. 135 | This will generally give a great boost to lexer performance, especially if 136 | it is abstract. 137 | 138 | ## Extensible ASTs 139 | 140 | This simple example shows how to implement extensible abstract syntax trees 141 | (ASTs). It uses polymorphic variants to achieve open recursion and to easily 142 | compose multiple recursive "languages". 143 | 144 | See the file `ast.ml` in directory `extensible_ast`, which you can compile 145 | and run as follows: 146 | 147 | ```sh 148 | dune exec ./ast.exe 149 | ``` 150 | 151 | ## Arrows 152 | 153 | This project in directory `arrows` mostly translates the Haskell-code 154 | presented in the following paper to OCaml: 155 | 156 | > Generalising Monads to Arrows 157 | > John Hughes 158 | > Science of Computer Programming 37, pp67-111, May 2000 159 | 160 | The project contains the following files: 161 | 162 | - `arrow.mli` and `arrow.ml` 163 | - `arr.ml` 164 | 165 | The module `Arrow` has a fully documented API and provides several simple 166 | implementations for arrows, which can be extended to arrows with more 167 | convenience functions. The signature of simple arrows specifies the type 168 | of arrows and the following functions: 169 | 170 | - `arr` - creates arrows from ordinary functions 171 | - `>>>` - the arrow composition operator 172 | - `app` - arrow application 173 | - `run` - a function to "chase arrows" 174 | 175 | The `arr`-function and composition operator are at the core of arrows, but 176 | are not sufficient to give them the same power as e.g. monads. Adding arrow 177 | application restores this power and allows us to enrich them with numerous 178 | other functions that provide useful programming idioms, e.g. for dealing 179 | with tuples or choice. Please refer to the above-mentioned paper for details. 180 | 181 | The simplest arrow implementation in module `SimpleArrow` just uses ordinary 182 | functions as representation of arrows. It suffers from stack overflows 183 | if arrow composition is nested too deeply. The module `SimpleContArrow` 184 | fixes this problem by representing arrows with continuations. Module 185 | `SimpleDataContArrow` uses sum tags for representing the structure of arrows 186 | and their compositions. It also uses continuations to avoid stack overflows. 187 | 188 | The functor `MkArrow` takes a simple arrow and enriches it with more 189 | functions as described in John Hughes' paper. Module `Arrow` finally also 190 | implements monads by showing how we can obtain one from an arrow supporting 191 | arrow application and vice versa, thus proving their equivalence in terms 192 | of expressive power. 193 | 194 | ## Union find 195 | 196 | The example in directory `union_find` demonstrates how to implement the 197 | union-find algorithm. The example uses _Generalized Algebraic Datatypes_ 198 | (GADTs) together with _mutable inline records_ to implement highly efficient 199 | datastructures with fewer indirections and a smaller memory footprint than 200 | usual records and algebraic datatypes would allow. You will need at least 201 | OCaml 4.04 to unbox away unnecessary data. 202 | 203 | You can build and run the code using: 204 | 205 | ```sh 206 | dune exec ./test_union_find.exe 207 | ``` 208 | 209 | ## Contact Information and Contributing 210 | 211 | Please submit bugs reports, feature requests, contributions and similar to 212 | the [GitHub issue tracker](https://github.com/mmottl/ocaml-prog-pats/issues). 213 | 214 | Up-to-date information is available at: 215 | 216 | -------------------------------------------------------------------------------- /abstract_lexer/Makefile: -------------------------------------------------------------------------------- 1 | TARGETS = abstract_lexer.bc 2 | 3 | .PHONY: all clean 4 | 5 | all: 6 | @dune build $(TARGETS) 7 | 8 | clean: 9 | @dune clean 10 | -------------------------------------------------------------------------------- /abstract_lexer/abstract_lexer.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let lexbuf = Lexing.from_channel stdin in 3 | Lexers.Alternating.any_char lexbuf 4 | -------------------------------------------------------------------------------- /abstract_lexer/dune: -------------------------------------------------------------------------------- 1 | (executable (name abstract_lexer) (modes byte exe)) 2 | 3 | (ocamllex lexer) 4 | -------------------------------------------------------------------------------- /abstract_lexer/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | -------------------------------------------------------------------------------- /abstract_lexer/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | 4 | (* The lexer specification consists of all rule specifications *) 5 | module type Spec = sig 6 | (* Each lexer rule gets its own module *) 7 | module Any_char : sig 8 | type t (* Return type of rule *) 9 | 10 | (* One function for each pattern in the rule *) 11 | val handle_char : lexbuf -> char -> t 12 | val handle_eof : lexbuf -> t 13 | end 14 | 15 | module Any_digit : sig 16 | type t 17 | 18 | val handle_digit : lexbuf -> int -> t 19 | val handle_eof : lexbuf -> t 20 | end 21 | end 22 | 23 | (* This is the signature of lexers *) 24 | module type Sig = sig 25 | module Spec : Spec 26 | 27 | open Spec 28 | 29 | val any_char : lexbuf -> Any_char.t 30 | val any_digit : lexbuf -> Any_digit.t 31 | end 32 | 33 | (* This introduces the functor that creates a lexer from a specification *) 34 | module Make (Spec_ : Spec) : Sig with module Spec = Spec_ = struct 35 | module Spec = Spec_ 36 | 37 | open Spec 38 | } 39 | 40 | rule any_char = parse 41 | | _ as c { Any_char.handle_char lexbuf c } 42 | | eof { Any_char.handle_eof lexbuf } 43 | 44 | and any_digit = parse 45 | | ['0'-'9'] as c { Any_digit.handle_digit lexbuf (Char.code c - 48) } 46 | | eof { Any_digit.handle_eof lexbuf } 47 | 48 | { 49 | (* Functor ends here *) 50 | end 51 | } 52 | -------------------------------------------------------------------------------- /abstract_lexer/lexers.ml: -------------------------------------------------------------------------------- 1 | (* This alternating lexer reads a char followed by a digit ad infinitum 2 | until EOF and prints each recognized token *) 3 | 4 | (* This recursive module is needed for recursive lexer rule applications *) 5 | module rec Alternating : 6 | (* Here we specialize the return types for the rules in the specification *) 7 | Lexer.Sig 8 | with type Spec.Any_char.t = unit 9 | with type Spec.Any_digit.t = unit = 10 | Lexer.Make (struct 11 | module Any_char = struct 12 | type t = unit 13 | 14 | let handle_char lexbuf c = print_char c; Alternating.any_digit lexbuf 15 | let handle_eof _lexbuf = () 16 | end 17 | 18 | module Any_digit = struct 19 | type t = unit 20 | 21 | let handle_digit lexbuf d = print_int d; Alternating.any_char lexbuf 22 | let handle_eof _lexbuf = () 23 | end 24 | end) 25 | -------------------------------------------------------------------------------- /abstract_lexer/test.dat: -------------------------------------------------------------------------------- 1 | x1y2z3 2 | -------------------------------------------------------------------------------- /arrows/Makefile: -------------------------------------------------------------------------------- 1 | TARGETS = arr.bc 2 | 3 | .PHONY: all clean 4 | 5 | all: 6 | @dune build $(TARGETS) 7 | 8 | clean: 9 | @dune clean 10 | -------------------------------------------------------------------------------- /arrows/arr.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | open Arrow 3 | 4 | open SimpleContArrow 5 | 6 | let bump = arr succ 7 | 8 | let bump_n_times n = 9 | let rec loop n arrow = 10 | if n <= 0 then arrow 11 | else loop (n - 1) (arrow >>> bump) 12 | in 13 | loop n (arr (fun n -> n)) 14 | 15 | let () = 16 | if Array.length Sys.argv < 2 then 17 | failwith "integer argument needed"; 18 | let n = int_of_string Sys.argv.(1) in 19 | let arrow = bump_n_times n in 20 | let result = run arrow 0 in 21 | printf "%d\n" result 22 | -------------------------------------------------------------------------------- /arrows/arrow.ml: -------------------------------------------------------------------------------- 1 | let id x = x 2 | 3 | (* Simple arrows *) 4 | 5 | module type SIMPLE_ARROW = sig 6 | type ('a, 'b) t 7 | 8 | val arr : ('a -> 'b) -> ('a, 'b) t 9 | val (>>>) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t 10 | val app : unit -> (('a, 'b) t * 'a, 'b) t 11 | val run : ('a, 'b) t -> 'a -> 'b 12 | end 13 | 14 | module SimpleArrow = struct 15 | type ('a, 'b) t = 'a -> 'b 16 | 17 | let arr f = f 18 | let (>>>) f g x = g (f x) 19 | let app () (f, x) = f x 20 | let run = arr 21 | end 22 | 23 | module SimpleContArrow = struct 24 | type ('a, 'b) t = { f : 'z. 'a -> ('b -> 'z) -> 'z } 25 | 26 | let arr f = { f = fun x cont -> cont (f x) } 27 | let (>>>) af ag = { f = fun x cont -> af.f x (fun yf -> ag.f yf cont) } 28 | let app () = { f = fun (af, x) -> af.f x } 29 | let run af x = af.f x id 30 | end 31 | 32 | module type DATA_ARROW = sig 33 | include SIMPLE_ARROW 34 | 35 | val run_cont : ('a, 'b) t -> 'a -> cont : ('b -> 'c) -> 'c 36 | end 37 | 38 | module rec SimpleDataContArrow : DATA_ARROW = struct 39 | type ('a, 'b) t = 40 | | Arr of ('a -> 'b) 41 | | Comp of ('a, 'b) comp 42 | | App of ('a, 'b) app 43 | 44 | and ('a, 'b) comp = 45 | { 46 | comp_open : 'z. ('a, 'b, 'z) comp_scope -> 'z 47 | } 48 | and ('a, 'b, 'z) comp_scope = 49 | { 50 | comp_bind : 'c. ('a, 'c) t -> ('c, 'b) t -> 'z 51 | } 52 | 53 | and ('a, 'b) app = 54 | { 55 | app_open : 'z. ('a, 'b, 'z) app_scope -> 'z 56 | } 57 | and ('a, 'b, 'z) app_scope = 58 | { 59 | app_bind : 60 | 'c. ('a -> ('c, 'b) t * 'c) -> (('c, 'b) t * 'c, 'b) t -> 'z 61 | } 62 | 63 | let arr f = Arr f 64 | 65 | let (>>>) af ag = Comp { comp_open = fun scope -> scope.comp_bind af ag } 66 | 67 | let run_cont a x ~cont = 68 | match a with 69 | | Arr f -> cont (f x) 70 | | Comp comp -> 71 | comp.comp_open 72 | { 73 | comp_bind = fun af ag -> 74 | SimpleDataContArrow.run_cont af x 75 | ~cont:(SimpleDataContArrow.run_cont ag ~cont) 76 | } 77 | | App app -> 78 | app.app_open 79 | { 80 | app_bind = fun unpack af -> 81 | SimpleDataContArrow.run_cont af (unpack x) ~cont 82 | } 83 | 84 | let app () = 85 | App 86 | { 87 | app_open = fun scope -> 88 | let f (af, x) = SimpleDataContArrow.run_cont af x ~cont:id in 89 | scope.app_bind id (Arr f) 90 | } 91 | 92 | let run a x = run_cont a x ~cont:id 93 | end 94 | 95 | module type ARROW = sig 96 | include SIMPLE_ARROW 97 | 98 | type ('a, 'b) either = Left of 'a | Right of 'b 99 | 100 | val first : ('a, 'b) t -> ('a * 'c, 'b * 'c) t 101 | val second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t 102 | 103 | val ( *** ) : ('a, 'b) t -> ('c, 'd) t -> ('a * 'c, 'b * 'd) t 104 | val ( &&& ) : ('a, 'b) t -> ('a, 'c) t -> ('a, 'b * 'c) t 105 | 106 | val liftA2 : ('a -> 'b -> 'c) -> ('d, 'a) t -> ('d, 'b) t -> ('d, 'c) t 107 | 108 | val left : ('a, 'b) t -> (('a, 'c) either, ('b, 'c) either) t 109 | val right : ('a, 'b) t -> (('c, 'a) either, ('c, 'b) either) t 110 | val (<+>) : ('a, 'c) t -> ('b, 'd) t -> (('a, 'b) either, ('c, 'd) either) t 111 | val (|||) : ('a, 'c) t -> ('b, 'c) t -> (('a, 'b) either, 'c) t 112 | 113 | val test : ('a, bool) t -> ('a, ('a, 'a) either) t 114 | end 115 | 116 | module MkArrow (SA : SIMPLE_ARROW) = struct 117 | include SA 118 | 119 | let swap (x, y) = y, x 120 | let first af = arr (fun (a, c) -> af >>> arr (fun b -> b, c), a) >>> app () 121 | let second af = arr swap >>> first af >>> arr swap 122 | let ( *** ) af ag = first af >>> second ag 123 | let ( &&& ) af ag = arr (fun x -> x, x) >>> af *** ag 124 | let liftA2 f af ag = af &&& ag >>> arr (fun (b, c) -> f b c) 125 | 126 | type ('a, 'b) either = Left of 'a | Right of 'b 127 | 128 | let left af = 129 | arr (function 130 | | Left l -> arr (fun () -> l) >>> af >>> arr (fun x -> Left x), () 131 | | Right _ as right -> arr (fun () -> right), ()) 132 | >>> app () 133 | 134 | let mirror = function Left x -> Right x | Right x -> Left x 135 | let right af = arr mirror >>> left af >>> arr mirror 136 | let (<+>) af ag = left af >>> right ag 137 | let (|||) af ag = af <+> ag >>> arr (function Left x | Right x -> x) 138 | 139 | let test acond = 140 | acond &&& arr id >>> arr (fun (b, x) -> if b then Left x else Right x) 141 | end 142 | 143 | module Arrow = MkArrow (SimpleArrow) 144 | module ContArrow = MkArrow (SimpleContArrow) 145 | module DataContArrow = MkArrow (SimpleDataContArrow) 146 | 147 | 148 | (* Kleisli categories *) 149 | 150 | (* Monad specification *) 151 | module type MONAD = sig 152 | type 'a t 153 | val return : 'a -> 'a t 154 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 155 | val run : 'a t -> 'a 156 | end 157 | 158 | (* Functor from arrow with apply operator to monad *) 159 | module MkArrowMonad (SA : SIMPLE_ARROW) = struct 160 | open SA 161 | 162 | type 'a t = (unit, 'a) SA.t 163 | 164 | let return x = arr (fun () -> x) 165 | let (>>=) af g = af >>> arr (fun x -> g x, ()) >>> app () 166 | let run af = SA.run af () 167 | end 168 | 169 | (* Functor from monads to arrows with apply operator *) 170 | module MkKleisli (M : MONAD) = 171 | MkArrow (struct 172 | open M 173 | 174 | type ('a, 'b) t = 'a -> 'b M.t 175 | 176 | let arr f x = return (f x) 177 | let (>>>) f g x = f x >>= g 178 | let app () (f, x) = f x 179 | let run f x = M.run (f x) 180 | end) 181 | -------------------------------------------------------------------------------- /arrows/arrow.mli: -------------------------------------------------------------------------------- 1 | (** {6 Simple arrows} *) 2 | 3 | module type SIMPLE_ARROW = sig 4 | type ('a, 'b) t (** Representation of arrows *) 5 | 6 | val arr : ('a -> 'b) -> ('a, 'b) t 7 | (** [arr f] projects an OCaml-function to a morphism (arrow) in the 8 | category of computations. *) 9 | 10 | val (>>>) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t 11 | (** [af >>> ag] composes the two computations [af] and [ag]. *) 12 | 13 | val app : unit -> (('a, 'b) t * 'a, 'b) t 14 | (** [app ()] @return an arrow that represents a computation which takes 15 | another arrow and a value as argument and returns the result of 16 | applying the latter to the former. *) 17 | 18 | val run : ('a, 'b) t -> 'a -> 'b 19 | (** [run af x] runs the computation represented by arrow [af] on input 20 | [x]. *) 21 | end 22 | 23 | (* Example implementations of simple arrows *) 24 | 25 | module SimpleArrow : SIMPLE_ARROW 26 | 27 | (** Uses continuation-passing internally *) 28 | module SimpleContArrow : SIMPLE_ARROW 29 | 30 | module SimpleDataContArrow : SIMPLE_ARROW 31 | 32 | 33 | (** {6 Enriched arrows} *) 34 | 35 | module type ARROW = sig 36 | include SIMPLE_ARROW 37 | 38 | val first : ('a, 'b) t -> ('a * 'c, 'b * 'c) t 39 | (** [first af] takes a computation [af] accepting argument [a]. 40 | @return a computation, which takes a pair [(a, c)], and returns 41 | the pair [(b, c)], where [b] is the result of running computation 42 | [ag] on [a], and [c] is a passed-through variable. *) 43 | 44 | val second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t 45 | (* [second af] is a dual of [first], and passes the constant variable 46 | as first argument. *) 47 | 48 | val ( *** ) : ('a, 'b) t -> ('c, 'd) t -> ('a * 'c, 'b * 'd) t 49 | (* [af *** ag] @return computation that performs computation [af] and 50 | [ag] on the first and respectively second argument of the input pair, 51 | returning the two results as a pair. *) 52 | 53 | val (&&&) : ('a, 'b) t -> ('a, 'c) t -> ('a, 'b * 'c) t 54 | (* [af &&& ag] @return computation that passes its input to two 55 | computations [af] and [ag] and returns the pair of the results. *) 56 | 57 | val liftA2 : ('a -> 'b -> 'c) -> ('d, 'a) t -> ('d, 'b) t -> ('d, 'c) t 58 | (* [liftA2 f af ag] @return computation that applies the function [f] 59 | to the results of [af] and [ag], which both receive the input. *) 60 | 61 | type ('a, 'b) either = Left of 'a | Right of 'b 62 | 63 | val left : ('a, 'b) t -> (('a, 'c) either, ('b, 'c) either) t 64 | (* [left af] @return computation that applies computation [af] to 65 | [l] if the input is [Left l], returning [Left result] and otherwise 66 | passes [Right r] through unchanged. *) 67 | 68 | val right : ('a, 'b) t -> (('c, 'a) either, ('c, 'b) either) t 69 | (* [right af] is the dual of [left]. *) 70 | 71 | val (<+>) : ('a, 'c) t -> ('b, 'd) t -> (('a, 'b) either, ('c, 'd) either) t 72 | (* [af <+> ag] @return a computation that either performs [af] or 73 | [ag] depending on its input, returning either [Left res_af] or 74 | [Right res_ag] respectively. *) 75 | 76 | val (|||) : ('a, 'c) t -> ('b, 'c) t -> (('a, 'b) either, 'c) t 77 | (* [af ||| ag] @return a computation that either performs [af] or [ag] 78 | depending on input. *) 79 | 80 | val test : ('a, bool) t -> ('a, ('a, 'a) either) t 81 | (* [test acond] @return a computation that tests its input with [acond] 82 | and returns either [Left res] if the predicate is true or [Right res] 83 | otherwise. *) 84 | end 85 | 86 | (** Functor from simple arrows with "apply" to fully-featured arrows *) 87 | module MkArrow (SA : SIMPLE_ARROW) : ARROW with type ('a, 'b) t = ('a, 'b) SA.t 88 | 89 | (** Example implementations of fully-featured arrows *) 90 | 91 | module Arrow : ARROW 92 | 93 | (** Uses continuation-passing internally *) 94 | module ContArrow : ARROW 95 | 96 | module DataContArrow : ARROW 97 | 98 | 99 | (** {6 Kleisli categories} *) 100 | 101 | (** Monad specification *) 102 | module type MONAD = sig 103 | type 'a t 104 | 105 | val return : 'a -> 'a t 106 | val (>>=) : 'a t -> ('a -> 'b t) -> 'b t 107 | 108 | val run : 'a t -> 'a 109 | end 110 | 111 | (** Functor from arrow with apply operator to monad *) 112 | module MkArrowMonad (SA : SIMPLE_ARROW) : MONAD with type 'a t = (unit, 'a) SA.t 113 | 114 | (** Functor from monads to their Kleisli category *) 115 | module MkKleisli (M : MONAD) : ARROW with type ('a, 'b) t = 'a -> 'b M.t 116 | -------------------------------------------------------------------------------- /arrows/dune: -------------------------------------------------------------------------------- 1 | (executable (name arr) (modes byte exe)) 2 | -------------------------------------------------------------------------------- /arrows/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | -------------------------------------------------------------------------------- /extensible_ast/Makefile: -------------------------------------------------------------------------------- 1 | TARGETS = ast.bc 2 | 3 | .PHONY: all clean 4 | 5 | all: 6 | @dune build $(TARGETS) 7 | 8 | clean: 9 | @dune clean 10 | -------------------------------------------------------------------------------- /extensible_ast/ast.ml: -------------------------------------------------------------------------------- 1 | (* No recursion until we close the knot *) 2 | 3 | (* Numbers *) 4 | 5 | type num = [ `Num of int ] 6 | 7 | let eval_num (`Num n) = n 8 | 9 | 10 | (* Addition *) 11 | 12 | type 't add = [ `Add of 't * 't ] 13 | 14 | let eval_add eval (`Add (l, r)) = eval l + eval r 15 | 16 | 17 | (* Subtraction *) 18 | 19 | type 't sub = [ `Sub of 't * 't ] 20 | 21 | let eval_sub eval (`Sub (l, r)) = eval l - eval r 22 | 23 | 24 | (* All of the above, but still an "open" language *) 25 | 26 | type 't all_open = [ num | 't add | 't sub ] 27 | 28 | let eval_all_open eval = function 29 | | #num as t -> eval_num t 30 | | #add as t -> eval_add eval t 31 | | #sub as t -> eval_sub eval t 32 | 33 | 34 | (* Now tying the recursive knot... *) 35 | 36 | type all_closed = all_closed all_open 37 | 38 | let rec eval_all_closed t = eval_all_open eval_all_closed t 39 | 40 | let () = Printf.printf "%d\n" (eval_all_closed (`Add ((`Num 3, `Num 42)))) 41 | -------------------------------------------------------------------------------- /extensible_ast/dune: -------------------------------------------------------------------------------- 1 | (executable (name ast) (modes byte exe)) 2 | -------------------------------------------------------------------------------- /extensible_ast/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | -------------------------------------------------------------------------------- /union_find/Makefile: -------------------------------------------------------------------------------- 1 | TARGETS = test_union_find.bc 2 | 3 | .PHONY: all clean 4 | 5 | all: 6 | @dune build $(TARGETS) 7 | 8 | clean: 9 | @dune clean 10 | -------------------------------------------------------------------------------- /union_find/dune: -------------------------------------------------------------------------------- 1 | (executable (name test_union_find) (modes byte exe)) 2 | -------------------------------------------------------------------------------- /union_find/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | -------------------------------------------------------------------------------- /union_find/test_union_find.ml: -------------------------------------------------------------------------------- 1 | open Printf 2 | 3 | let () = 4 | let s1 = Union_find.create 1 in 5 | let s2 = Union_find.create 2 in 6 | printf "Before their union, sets s1 and s2 are distinct: %B\n" 7 | (Union_find.same_class s1 s2); 8 | Union_find.union s1 s2; 9 | printf "After their union, sets s1 and s2 are distinct: %B\n" 10 | (Union_find.same_class s1 s2) 11 | -------------------------------------------------------------------------------- /union_find/union_find.ml: -------------------------------------------------------------------------------- 1 | (* NOTE: This does not work yet due to an OCaml bug. May get fixed in 2 | OCaml 4.08. *) 3 | 4 | (* type ('a, 'kind) tree = *) 5 | (* | Root : { mutable value : 'a; mutable rank : int } -> ('a, [ `root ]) tree *) 6 | (* | Inner : { mutable parent : 'a node } -> ('a, [ `inner ]) tree *) 7 | (* *) 8 | (* and 'a node = Node : ('a, _) tree -> 'a node [@@ocaml.unboxed] *) 9 | (* *) 10 | (* type 'a t = ('a, [ `inner ]) tree *) 11 | 12 | (**) 13 | 14 | type ('a, 'kind, 'parent) tree = 15 | | Root : { mutable value : 'a; mutable rank : int } -> 16 | ('a, [ `root ], 'parent) tree 17 | | Inner : { mutable parent : 'parent } -> ('a, [ `inner ], 'parent) tree 18 | 19 | type 'a node = Node : ('a, _, 'a node) tree -> 'a node [@@ocaml.unboxed] 20 | 21 | type 'a t = ('a, [ `inner ], 'a node) tree 22 | 23 | let invariant t = 24 | let rec loop (Inner inner) depth = 25 | match inner.parent with 26 | | Node (Inner _ as parent) -> loop parent (depth + 1) 27 | | Node (Root r) -> assert (depth <= r.rank) 28 | in 29 | loop t 0 30 | 31 | let _ = invariant 32 | 33 | let create v = Inner { parent = Node (Root { value = v; rank = 0 }) } 34 | 35 | let rec compress ~repr:(Inner inner as repr) = function 36 | | Node (Root _ as root) -> repr, root 37 | | Node (Inner next_inner as repr) -> 38 | let repr, _ as res = compress ~repr next_inner.parent in 39 | inner.parent <- Node repr; 40 | res 41 | 42 | let compress_inner (Inner inner as repr) = compress ~repr inner.parent 43 | 44 | let get_root (Inner inner) = 45 | match inner.parent with 46 | | Node (Root _ as root) -> root (* Avoids compression call *) 47 | | Node (Inner _ as repr) -> 48 | let repr, root = compress_inner repr in 49 | inner.parent <- Node repr; 50 | root 51 | 52 | let get t = let Root r = get_root t in r.value 53 | 54 | let set t x = let Root r = get_root t in r.value <- x 55 | 56 | let same_class t1 t2 = get_root t1 == get_root t2 57 | 58 | let union t1 t2 = 59 | let Inner inner1 as repr1, (Root r1 as root1) = compress_inner t1 in 60 | let Inner inner2 as repr2, (Root r2 as root2) = compress_inner t2 in 61 | if root1 == root2 then () 62 | else 63 | let n1 = r1.rank in 64 | let n2 = r2.rank in 65 | if n1 < n2 then inner1.parent <- Node repr2 66 | else begin 67 | inner2.parent <- Node repr1; 68 | if n1 = n2 then r1.rank <- r1.rank + 1 69 | end 70 | -------------------------------------------------------------------------------- /union_find/union_find.mli: -------------------------------------------------------------------------------- 1 | (** NOTE: this header file was copied from Jane Street Capital's core_kernel 2 | library, but the implemention is different. *) 3 | 4 | (** Imperative data structure for representing disjoint sets. 5 | 6 | Union find is used to implement an equivalence relation on objects, where 7 | the equivalence relation can dynamically be coarsened by "union"ing two 8 | equivalence classes together. 9 | 10 | All of the operations are effectively (amortized) constant time. 11 | 12 | @see wikipedia. 13 | 14 | This implementation is not thread-safe. 15 | *) 16 | 17 | (** [type 'a t] is the type of objects, where each object is part of an 18 | equivalence class that is associated with a single value of type ['a]. *) 19 | type 'a t 20 | 21 | (** [create v] returns a new object in its own equivalence class that has value [v]. *) 22 | val create : 'a -> 'a t 23 | 24 | (** [get t] returns the value of the class of [t]. *) 25 | val get : 'a t -> 'a 26 | 27 | (** [set t v] sets the value of the class of [t] to [v]. *) 28 | val set : 'a t -> 'a -> unit 29 | 30 | (** [same_class t1 t2] returns true iff [t1] and [t2] are in the same equivalence class. 31 | *) 32 | val same_class : 'a t -> 'a t -> bool 33 | 34 | (** [union t1 t2] makes the class of [t1] and the class of [t2] be the same (if they are 35 | already equal, then nothing changes). The value of the combined class is the value of 36 | [t1] or [t2]; it is unspecified which. After [union t1 t2], it will always be the 37 | case that [same_class t1 t2]. *) 38 | val union: 'a t -> 'a t -> unit 39 | --------------------------------------------------------------------------------