├── .gitignore ├── .merlin ├── .travis.yml ├── Makefile ├── README.md ├── ast.ml ├── images ├── bkg.png └── blacktocat.png ├── index.html ├── infer.ml ├── javascripts └── main.js ├── params.json ├── parser.mly ├── repl.ml ├── scanner.mll ├── stylesheets ├── github-dark.css └── stylesheet.css └── test.ml /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.swp 3 | *.out 4 | *.cm* 5 | _build 6 | _tests 7 | *.log 8 | *.cache 9 | *.native 10 | *.byte 11 | repl 12 | test 13 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S _build/ 2 | B _build/ 3 | PKG alcotest 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | before_install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-ocaml.sh 4 | install: 5 | - bash -ex .travis-ocaml.sh 6 | - eval $(opam config env) 7 | - opam install ocamlfind alcotest 8 | script: make test 9 | env: 10 | - OCAML_VERSION=latest OPAMYES=1 11 | notifications: 12 | email: false 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ocamlbuild -j 0 -r repl.native 3 | @mv repl.native repl 4 | 5 | .PHONY: test 6 | test: 7 | ocamlbuild -j 0 -r -pkg alcotest -use-ocamlfind test.native 8 | @mv ./test.native test 9 | @./test 10 | 11 | 12 | .PHONY: clean 13 | clean: 14 | ocamlbuild -clean 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Hindley Milner Type Inference 2 | === 3 | 4 | [![Build Status](https://travis-ci.org/prakhar1989/type-inference.svg?branch=master)](https://travis-ci.org/prakhar1989/type-inference) 5 | 6 | The [Hindley Milner Type Inference](https://en.wikipedia.org/wiki/Hindley%E2%80%93Milner_type_system) or Algorithm W is a type-inference algorithm that infers types in a programming language. 7 | 8 | This repository contains a working implementation written in OCaml to demonstrate type-inference on a small functional language. 9 | 10 | ### Demo 11 | 12 | 13 | 14 | 15 | ### λ-calculus 16 | 17 | The language that this implementation works on is a small subset called the [lambda calculus](https://en.wikipedia.org/wiki/Lambda_calculus). In essence, the lambda calculus allows one to express any computation purely in terms of anonymous functions and application of these functions. 18 | ```ocaml 19 | > (fun x -> x * x) (* function declaration *) 20 | > (fun x -> x * x) 10 (* function application *) 21 | ``` 22 | In pure lambda calculus, [numerals](https://en.wikipedia.org/wiki/Church_encoding#Church_numerals) and [booleans](https://en.wikipedia.org/wiki/Church_encoding#Church_Booleans) are also expressed in terms of functions but to make it easy, the language supports integer and boolean literals, alongwith binary operations such as addition, multiplication, boolean and etc. 23 | 24 | ##### Types 25 | 26 | Before we jump on to the type-inference algorithm, we need to define the types in our language. There are three primitive types that our language supports - 27 | 28 | - `int`: An integer type for integer literals. Binary operations such as `+` and `*`, work only on integers and return an integer type. 29 | - `bool`: Our language has boolean literals `true` and `false`, both of which have a `bool` type. To operate on bools `&&` and `||` are provided. Lastly, two additional operators `>` and `<` work on any type, but return a bool type. 30 | - `T -> U`: The function type where the `T` is the type of the input and `U` is the return type of the function. So for example, a square function above has a type `int -> int`. 31 | 32 | ### REPL 33 | The project ships with an interactive Read-Eval-Print-Loop (REPL) that you can use to play with the algorithm. To build the REPL, you need OCaml installed. 34 | 35 | If you prefer [Docker](https://www.docker.com/), there's an image that you can use to try out the REPL. Simply run 36 | ```shell 37 | $ docker run -w /home/opam/type-inference -it prakhar1989/type-infer /bin/bash 38 | ``` 39 | 40 | Compile the REPL with `make` and if all goes well, you should be good to go. 41 | ``` 42 | $ ./repl 43 | 44 | Welcome to the REPL. 45 | Type in expressions and let Hindley-Milner Type Inference run its magic. 46 | 47 | Out of ideas? Try out a simple lambda expression: (fun x -> x + 10) 48 | 49 | > 10 + 20 > 40 50 | bool 51 | > (fun x -> (x && true) || false) 52 | (bool -> bool) 53 | > (fun x -> x + 10) 20 54 | int 55 | > (fun f -> f 3) 56 | ((int -> 'a) -> 'a) 57 | > (fun f -> (fun g -> (fun x -> f (g x)))) 58 | (('a -> 'b) -> (('c -> 'a) -> ('c -> 'b))) 59 | ``` 60 | 61 | ### Tests 62 | 63 | To run the tests, you need [Alcotest](https://github.com/mirage/alcotest) package installed. Install it by running `opam install alcotest`. 64 | 65 | ``` 66 | $ make test 67 | ``` 68 | 69 | ### Thanks 70 | Huge thanks to these [lecture notes](http://www.cs.cornell.edu/courses/cs3110/2011sp/lectures/lec26-type-inference/type-inference.htm) for providing an understandable breakdown of the algorithm. 71 | -------------------------------------------------------------------------------- /ast.ml: -------------------------------------------------------------------------------- 1 | type id = string 2 | 3 | type op = Add | Mul | Gt | Lt | And | Or 4 | 5 | module CharMap = Map.Make(String) 6 | 7 | type genericMap = int CharMap.t 8 | 9 | type primitiveType = 10 | | TNum 11 | | TBool 12 | | T of string 13 | | TFun of primitiveType * primitiveType 14 | ;; 15 | 16 | type expr = 17 | | NumLit of int 18 | | BoolLit of bool 19 | | Val of string 20 | | Binop of expr * op * expr 21 | | Fun of id * expr 22 | | App of expr * expr 23 | ;; 24 | 25 | (* annotated expr -> expr with types *) 26 | type aexpr = 27 | | ANumLit of int * primitiveType 28 | | ABoolLit of bool * primitiveType 29 | | AVal of string * primitiveType 30 | | ABinop of aexpr * op * aexpr * primitiveType 31 | | AFun of id * aexpr * primitiveType 32 | | AApp of aexpr * aexpr * primitiveType 33 | ;; 34 | 35 | let string_of_op (op: op) = 36 | match op with 37 | | Add -> "+" | Mul -> "*" | Lt -> "<" | Gt -> ">" 38 | | Or -> "||" | And -> "&&" 39 | ;; 40 | 41 | let string_of_type (t: primitiveType) = 42 | let rec aux (t: primitiveType) (chr: int) (map: genericMap) = 43 | match t with 44 | | TNum -> "int", chr, map 45 | | TBool -> "bool", chr, map 46 | | T(x) -> 47 | let gen_chr, new_chr, new_map = if CharMap.mem x map 48 | then Char.escaped (Char.chr (CharMap.find x map)), chr, map 49 | else 50 | let c = Char.escaped (Char.chr chr) in 51 | c, (chr + 1), CharMap.add x chr map 52 | in 53 | Printf.sprintf "'%s" gen_chr, new_chr, new_map 54 | | TFun(t1, t2) -> let (st1, c1, m1) = aux t1 chr map in 55 | let (st2, c2, m2) = aux t2 c1 m1 in 56 | (Printf.sprintf "(%s -> %s)" st1 st2), c2, m2 in 57 | let s, _, _ = aux t 97 CharMap.empty in s 58 | ;; 59 | 60 | let rec string_of_aexpr (ae: aexpr): string = 61 | match ae with 62 | | ANumLit(x, t) -> Printf.sprintf "(%s: %s)" (string_of_int x) (string_of_type t) 63 | | ABoolLit(b, t) -> Printf.sprintf "(%s: %s)" (string_of_bool b) (string_of_type t) 64 | | AVal(x, t) -> Printf.sprintf "(%s: %s)" x (string_of_type t) 65 | | ABinop(e1, op, e2, t) -> 66 | let s1 = string_of_aexpr e1 in let s2 = string_of_aexpr e2 in 67 | let sop = string_of_op op in let st = string_of_type t in 68 | Printf.sprintf "(%s %s %s: %s)" s1 sop s2 st 69 | | AFun(id, ae, t) -> 70 | let s1 = string_of_aexpr ae in 71 | let st = string_of_type t in 72 | Printf.sprintf "(fun %s -> %s): %s" id s1 st 73 | | AApp(e1, e2, t) -> 74 | let s1 = string_of_aexpr e1 and 75 | s2 = string_of_aexpr e2 and st = string_of_type t in 76 | Printf.sprintf "(%s %s): %s" s1 s2 st 77 | ;; 78 | 79 | let rec string_of_expr (e: expr): string = 80 | match e with 81 | | NumLit(x) -> string_of_int x 82 | | BoolLit(b) -> string_of_bool b 83 | | Val(s) -> s 84 | | Binop(e1, op, e2) -> 85 | let s1 = string_of_expr e1 and s2 = string_of_expr e2 in 86 | let sop = string_of_op op in 87 | Printf.sprintf "(%s %s %s)" s1 sop s2 88 | | Fun(id, e) -> 89 | let s1 = string_of_expr e in Printf.sprintf "(fun %s -> %s)" id s1 90 | | App(e1, e2) -> 91 | let s1 = string_of_expr e1 and s2 = string_of_expr e2 in 92 | Printf.sprintf "(%s %s)" s1 s2 93 | ;; 94 | -------------------------------------------------------------------------------- /images/bkg.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/prakhar1989/type-inference/1b31cc9dc05fca41d089517e54edbf66a8012512/images/bkg.png -------------------------------------------------------------------------------- /images/blacktocat.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/prakhar1989/type-inference/1b31cc9dc05fca41d089517e54edbf66a8012512/images/blacktocat.png -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | Type-inference by prakhar1989 12 | 13 | 14 | 15 | 16 |
17 |
18 |

Type-inference

19 |

The Hindley Milner Type Inference Algorithm

20 | 21 |
22 | Download as .zip 23 | Download as .tar.gz 24 | View on GitHub 25 |
26 |
27 |
28 | 29 |
30 |
31 |

32 | Hindley Milner Type Inference

33 | 34 |

Build Status

35 | 36 |

The Hindley Milner Type Inference or Algorithm W is a type-inference algorithm that infers types in a programming language.

37 | 38 |

This repository contains a working implementation written in OCaml to demonstrate type-inference on a small functional language.

39 | 40 |

41 | Demo

42 | 43 |

44 | 45 |

46 | λ-calculus

47 | 48 |

The language that this implementation works on is a small subset called the lambda calculus. In essence, the lambda calculus allows one to express any computation purely in terms of anonymous functions and application of these functions.

49 | 50 |
> (fun x -> x * x)          (* function declaration *)
 51 | > (fun x -> x * x) 10       (* function application *)
52 | 53 |

In pure lambda calculus, numerals and booleans are also expressed in terms of functions but to make it easy, the language supports integer and boolean literals, alongwith binary operations such as addition, multiplication, boolean and etc.

54 | 55 |
56 | Types
57 | 58 |

Before we jump on to the type-inference algorithm, we need to define the types in our language. There are three primitive types that our language supports -

59 | 60 | 68 | 69 |

70 | REPL

71 | 72 |

The project ships with an interactive Read-Eval-Print-Loop (REPL) that you can use to play with the algorithm. To build the REPL, you need OCaml installed.

73 | 74 |

If you prefer Docker, there's an image that you can use to try out the REPL. Simply run

75 | 76 |
$ docker run -w /home/opam/type-inference -it prakhar1989/type-infer /bin/bash
77 | 78 |

Compile the REPL with make and if all goes well, you should be good to go.

79 | 80 |
$ ./repl
 81 | 
 82 | Welcome to the REPL.
 83 | Type in expressions and let Hindley-Milner Type Inference run its magic.
 84 | 
 85 | Out of ideas? Try out a simple lambda expression: (fun x -> x + 10)
 86 | 
 87 | > 10 + 20 > 40
 88 | bool
 89 | > (fun x -> (x && true) || false)
 90 | (bool -> bool)
 91 | > (fun x -> x + 10) 20
 92 | int
 93 | > (fun f -> f 3)
 94 | ((int -> 'a) -> 'a)
 95 | >  (fun f -> (fun g -> (fun x -> f (g x))))
 96 | (('a -> 'b) -> (('c -> 'a) -> ('c -> 'b)))
 97 | 
98 | 99 |

100 | Tests

101 | 102 |

To run the tests, you need Alcotest package installed. Install it by running opam install alcotest.

103 | 104 |
$ make test
105 | 
106 | 107 |

108 | Thanks

109 | 110 |

Huge thanks to these lecture notes for providing an understandable breakdown of the algorithm.

111 |
112 |
113 | 114 | 115 | 116 | 117 | -------------------------------------------------------------------------------- /infer.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | 3 | (*******************************************************************| 4 | |********************** Environment ****************************| 5 | |*******************************************************************| 6 | | - The environment is a map that holds type information of | 7 | | variables (in our case values) | 8 | | - A good practice is to have a local environment and global | 9 | | environment. This helps in implementing proper scoping rules. | 10 | |*******************************************************************) 11 | module NameMap = Map.Make(String) 12 | type environment = primitiveType NameMap.t 13 | 14 | (* Unknown type, resolved type. eg.[(T, TNum); (U, TBool)] *) 15 | type substitutions = (id * primitiveType) list 16 | 17 | let type_variable = ref (Char.code 'a') 18 | 19 | (* generates a new unknown type placeholder. 20 | returns T(string) of the generated alphabet *) 21 | let gen_new_type () = 22 | let c1 = !type_variable in 23 | incr type_variable; T(Char.escaped (Char.chr c1)) 24 | ;; 25 | 26 | (*******************************************************************| 27 | |****************** Annotate Expressions ***********************| 28 | |*******************************************************************| 29 | | Arguments: | 30 | | e -> An expression that has to be annotated | 31 | | env -> An environment map that holds type information of | 32 | | user defined variables(in our case values) | 33 | |*******************************************************************| 34 | | Returns: | 35 | | returns an annotated expression of type aexpr that holds | 36 | | type information for the given expression. | 37 | |*******************************************************************| 38 | | - This method takes every expression/sub-expression in the | 39 | | program and assigns some type information to it. | 40 | | - This type information maybe something concrete like a TNum | 41 | | or it could be a unique parameterized type(placeholder) such | 42 | | as 'a. | 43 | | - Concrete types are usually assigned when you encounter | 44 | | simple literals like 10, true and "hello" and also when the | 45 | | user has explicity annotated his program with types. | 46 | | - Whereas, a random type placeholder is assigned when no | 47 | | explicit information is available. | 48 | | - It may not seem so, but this is a very important function. | 49 | | It is a fundamental step in approaching and understanding | 50 | | the HMT algorithm that will follow further. | 51 | | - HMT algorithm not only infers types of variables and | 52 | | functions defined by user but also of every expression and | 53 | | sub-expression since most of the inference happens from | 54 | | analyzing these expressions only. | 55 | | - Hence, this function preps our program for the next steps of | 56 | | HMT. | 57 | |*******************************************************************) 58 | let rec annotate_expr (e: expr) (env: environment) : aexpr = 59 | match e with 60 | | NumLit(n) -> ANumLit(n, TNum) 61 | | BoolLit(b) -> ABoolLit(b, TBool) 62 | | Val(x) -> if NameMap.mem x env 63 | then AVal(x, NameMap.find x env) 64 | else raise (failwith "variable not defined") 65 | | Binop(e1, op, e2) -> 66 | let et1 = annotate_expr e1 env 67 | and et2 = annotate_expr e2 env 68 | and new_type = gen_new_type () in 69 | ABinop(et1, op, et2, new_type) 70 | | Fun(id, e) -> 71 | let ae = annotate_expr e env in 72 | let t = NameMap.find id env in 73 | AFun(id, ae, TFun(t, gen_new_type ())) 74 | | App(fn, arg) -> 75 | let afn = annotate_expr fn env in 76 | let aarg = annotate_expr arg env in 77 | AApp(afn, aarg, gen_new_type ()) 78 | 79 | (* returns the type of an annotated expression *) 80 | and type_of (ae: aexpr): primitiveType = 81 | match ae with 82 | | ANumLit(_, t) | ABoolLit(_, t) -> t 83 | | AVal(_, t) -> t 84 | | ABinop(_, _, _, t) -> t 85 | | AFun(_, _, t) -> t 86 | | AApp(_, _, t) -> t 87 | ;; 88 | 89 | (*********************************************************************| 90 | |*************************** Collect *****************************| 91 | |*********************************************************************| 92 | | Arguments: | 93 | | ae -> an annotated expression from which a bunch of constraints | 94 | | have to obtained. | 95 | |*********************************************************************| 96 | | Returns: | 97 | | returns a list of contraints. | 98 | |*********************************************************************| 99 | | - A constraint is a tuple of two primitiveTypes. A strict equality | 100 | | is being imposed on the two types. | 101 | | - Constraints are generated from the expresssion being analyzed, | 102 | | for e.g. for the expression ABinop(x, Add, y, t) we can constrain | 103 | | the types of x, y, and t to be TNum. | 104 | | - To obtain maximum information from expressions and generate | 105 | | better constraints operators should not be over-loaded. | 106 | | - In short, most of the type checking rules will be added here in | 107 | | the form of constraints. | 108 | | - Further, if an expression contains sub-expressions, then | 109 | | constraints need to be obtained recursively from the | 110 | | subexpressions as well. | 111 | | - Lastly, constraints obtained from sub-expressions should be to | 112 | | the left of the constraints obtained from the current expression | 113 | | since constraints obtained from current expression holds more | 114 | | information than constraints from subexpressions and also later | 115 | | on we will be working with these constraints from right to left. | 116 | |*********************************************************************) 117 | let rec collect_expr (ae: aexpr) : (primitiveType * primitiveType) list = 118 | match ae with 119 | | ANumLit(_) | ABoolLit(_) -> [] (* no constraints to impose on literals *) 120 | | AVal(_) -> [] (* single occurence of val gives us no info *) 121 | | ABinop(ae1, op, ae2, t) -> 122 | let et1 = type_of ae1 and et2 = type_of ae2 in 123 | 124 | (* impose constraints based on binary operator *) 125 | let opc = match op with 126 | | Add | Mul -> [(et1, TNum); (et2, TNum); (t, TNum)] 127 | (* we return et1, et2 since these are generic operators *) 128 | | Gt | Lt -> [(et1, et2); (t, TBool)] 129 | | And | Or -> [(et1, TBool); (et2, TBool); (t, TBool)] 130 | in 131 | (* opc appended at the rightmost since we apply substitutions right to left *) 132 | (collect_expr ae1) @ (collect_expr ae2) @ opc 133 | | AFun(id, ae, t) -> (match t with 134 | | TFun(idt, ret_type) -> (collect_expr ae) @ [(type_of ae, ret_type)] 135 | | _ -> raise (failwith "not a function")) 136 | 137 | (* 1. In application expressions, the first expression should be of TFun type or it 138 | could be a unknown type placeholder. Otherwise it's an error. 139 | 2. Case 1: TFun(argt, ret_type) 140 | - In this case the parameter type of the function should be same as that of 141 | the argument passed in the function. 142 | - Second, the return type of the function, will be equal to the return type 143 | of the function application expression. 144 | 3. Case 2: T(_) (unknown type placeholder) 145 | - Since we do not know the type information of the first expression in an 146 | application expression, we cannot use the above approach. 147 | - But we do know that the first expression has to be a function. Also a function 148 | whose parameter type is same as that of argument type and that has a return type 149 | same as that of the entire expression. 150 | - Thus we use this information to impose a contraint on the unknown type placeholder. 151 | *) 152 | | AApp(fn, arg, t) -> (match (type_of fn) with 153 | | TFun(argt, ret_type) -> (collect_expr fn) @ (collect_expr arg) @ [(t, ret_type); (argt, type_of arg)] 154 | | T(_) -> (collect_expr fn) @ (collect_expr arg) @ [(type_of fn, TFun(type_of arg, t))] 155 | | _ -> raise (failwith "incorrect function application")) 156 | ;; 157 | 158 | 159 | (******************************************************************| 160 | |********************** Unification ***************************| 161 | |********************** Algorithm ***************************| 162 | |******************************************************************) 163 | 164 | 165 | (******************************************************************| 166 | |********************** Substitute ****************************| 167 | |******************************************************************| 168 | |Arguments: | 169 | | t -> type in which substitutions have to be made. | 170 | | (x, u) -> (type placeholder, resolved substitution) | 171 | |******************************************************************| 172 | |Returns: | 173 | | returns a valid substitution for t if present, else t as it is.| 174 | |******************************************************************| 175 | |- In this method we are given a substitution rule that asks us to | 176 | | replace all occurences of type placeholder x with u, in t. | 177 | |- We are required to apply this substitution to t recursively, so | 178 | | if t is a composite type that contains multiple occurrences of | 179 | | x then at every position of x, a u is to be substituted. | 180 | |- e.g. u -> TNum, x -> 'a, t -> TFun('a, TBool). After | 181 | | substitution we will end up with TFun(TNum, TBool). | 182 | *******************************************************************) 183 | let rec substitute (u: primitiveType) (x: id) (t: primitiveType) : primitiveType = 184 | match t with 185 | | TNum | TBool -> t 186 | | T(c) -> if c = x then u else t 187 | | TFun(t1, t2) -> TFun(substitute u x t1, substitute u x t2) 188 | ;; 189 | 190 | (******************************************************************| 191 | |************************* Apply ****************************| 192 | |******************************************************************| 193 | | Arguments: | 194 | | subs -> list of substitution rules. | 195 | | t -> type in which substiutions have to be made. | 196 | |******************************************************************| 197 | | Returns: | 198 | | returns t after all the substitutions have been made in it | 199 | | given by all the substitution rules in subs. | 200 | |******************************************************************| 201 | | - Works from right to left | 202 | | - Effectively what this function does is that it uses | 203 | | substitution rules generated from the unification algorithm and| 204 | | applies it to t. Internally it calls the substitute function | 205 | | which does the actual substitution and returns the resultant | 206 | | type after substitutions. | 207 | | - Substitution rules: (type placeholder, primitiveType), where we| 208 | | have to replace each occurence of the type placeholder with the| 209 | | given primitive type. | 210 | |******************************************************************) 211 | let apply (subs: substitutions) (t: primitiveType) : primitiveType = 212 | List.fold_right (fun (x, u) t -> substitute u x t) subs t 213 | ;; 214 | 215 | 216 | (******************************************************************| 217 | |*************************** Unify ****************************| 218 | |******************************************************************| 219 | | Arguments: | 220 | | constraints -> list of constraints (tuple of 2 types) | 221 | |******************************************************************| 222 | | Returns: | 223 | | returns a list of substitutions | 224 | |******************************************************************| 225 | | - The unify function takes a bunch of constraints it obtained | 226 | | from the collect method and turns them into substitutions. | 227 | | - It is crucial to remember that these constraints are dependent | 228 | | on each other, therefore we have separate function unify_one | 229 | | and unify. | 230 | | - Since constraints on the right have more precedence we start | 231 | | from the rightmost constraint and unify it by calling the | 232 | | unify_one function. unify_one transforms the constraint to a | 233 | | substitution. More details given below. | 234 | | - Now these substitutions will be applied to both types of the | 235 | | second rightmost constraint following which they will be | 236 | | unified by again calling the unify_one function. | 237 | | - This process of unification(unify_one) and substitution(apply) | 238 | | goes on till all the constraints have been accounted for. | 239 | | - In the end we get a complete list of substitutions that helps | 240 | | resolve types of all expressions in our program. | 241 | |******************************************************************) 242 | let rec unify (constraints: (primitiveType * primitiveType) list) : substitutions = 243 | match constraints with 244 | | [] -> [] 245 | | (x, y) :: xs -> 246 | (* generate substitutions of the rest of the list *) 247 | let t2 = unify xs in 248 | (* resolve the LHS and RHS of the constraints from the previous substitutions *) 249 | let t1 = unify_one (apply t2 x) (apply t2 y) in 250 | t1 @ t2 251 | 252 | (******************************************************************| 253 | |************************* Unify One ***************************| 254 | |******************************************************************| 255 | | Arguments: | 256 | | t1, t2 -> two types (one pair) that need to be unified. | 257 | |******************************************************************| 258 | | Returns: | 259 | | returns a substitution rule for the two types if one of them | 260 | | is a parameterized type else nothing. | 261 | |******************************************************************| 262 | | - A constraint is converted to a substitution here. | 263 | | - As mentioned several times before a substitution is nothing | 264 | | but a resolution rule for a type placeholder. | 265 | | - If a constraint yields multiple type resolutions then the | 266 | | resolutions should be broken up into a list of constraints and | 267 | | be passed to the unify function. | 268 | | - If both types are concrete then we need not create a new | 269 | | substitution rule. | 270 | | - If the types are concrete but dont match then that indicates a | 271 | | type mismatch. Errors can be as elaborate as required. | 272 | |******************************************************************) 273 | and unify_one (t1: primitiveType) (t2: primitiveType) : substitutions = 274 | match t1, t2 with 275 | | TNum, TNum | TBool, TBool -> [] 276 | | T(x), z | z, T(x) -> [(x, z)] 277 | 278 | (* This case is particularly useful when you are calling a function that returns a function *) 279 | | TFun(a, b), TFun(x, y) -> unify [(a, x); (b, y)] 280 | | _ -> raise (failwith "mismatched types") 281 | ;; 282 | 283 | (* applies a final set of substitutions on the annotated expr *) 284 | let rec apply_expr (subs: substitutions) (ae: aexpr): aexpr = 285 | match ae with 286 | | ABoolLit(b, t) -> ABoolLit(b, apply subs t) 287 | | ANumLit(n, t) -> ANumLit(n, apply subs t) 288 | | AVal(s, t) -> AVal(s, apply subs t) 289 | | ABinop(e1, op, e2, t) -> ABinop(apply_expr subs e1, op, apply_expr subs e2, apply subs t) 290 | | AFun(id, e, t) -> AFun(id, apply_expr subs e, apply subs t) 291 | | AApp(fn, arg, t) -> AApp(apply_expr subs fn, apply_expr subs arg, apply subs t) 292 | ;; 293 | 294 | (* runs HMTI step-by-step 295 | 1. annotate expression with placeholder types 296 | 2. generate constraints 297 | 3. unify types based on constraints 298 | 4. run the final set of substitutions on still unresolved types 299 | 5. obtain a final annotated expression with resolved types *) 300 | let infer (env: environment) (e: expr) : aexpr = 301 | let annotated_expr = annotate_expr e env in 302 | let constraints = collect_expr annotated_expr in 303 | let subs = unify constraints in 304 | (* reset the type counter after completing inference *) 305 | type_variable := (Char.code 'a'); 306 | apply_expr subs annotated_expr 307 | ;; 308 | -------------------------------------------------------------------------------- /javascripts/main.js: -------------------------------------------------------------------------------- 1 | console.log('This would be the main JS file.'); 2 | -------------------------------------------------------------------------------- /params.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "Type-inference", 3 | "tagline": "The Hindley Milner Type Inference Algorithm", 4 | "body": "Hindley Milner Type Inference\r\n===\r\n\r\n[![Build Status](https://travis-ci.org/prakhar1989/type-inference.svg?branch=master)](https://travis-ci.org/prakhar1989/type-inference)\r\n\r\nThe [Hindley Milner Type Inference](https://en.wikipedia.org/wiki/Hindley%E2%80%93Milner_type_system) or Algorithm W is a type-inference algorithm that infers types in a programming language.\r\n\r\nThis repository contains a working implementation written in OCaml to demonstrate type-inference on a small functional language.\r\n\r\n### Demo\r\n\r\n\r\n\r\n\r\n### λ-calculus\r\n\r\nThe language that this implementation works on is a small subset called the [lambda calculus](https://en.wikipedia.org/wiki/Lambda_calculus). In essence, the lambda calculus allows one to express any computation purely in terms of anonymous functions and application of these functions.\r\n```ocaml\r\n> (fun x -> x * x) (* function declaration *)\r\n> (fun x -> x * x) 10 (* function application *)\r\n```\r\nIn pure lambda calculus, [numerals](https://en.wikipedia.org/wiki/Church_encoding#Church_numerals) and [booleans](https://en.wikipedia.org/wiki/Church_encoding#Church_Booleans) are also expressed in terms of functions but to make it easy, the language supports integer and boolean literals, alongwith binary operations such as addition, multiplication, boolean and etc.\r\n\r\n##### Types\r\n\r\nBefore we jump on to the type-inference algorithm, we need to define the types in our language. There are three primitive types that our language supports -\r\n\r\n- `int`: An integer type for integer literals. Binary operations such as `+` and `*`, work only on integers and return an integer type.\r\n- `bool`: Our language has boolean literals `true` and `false`, both of which have a `bool` type. To operate on bools `&&` and `||` are provided. Lastly, two additional operators `>` and `<` work on any type, but return a bool type.\r\n- `T -> U`: The function type where the `T` is the type of the input and `U` is the return type of the function. So for example, a square function above has a type `int -> int`.\r\n\r\n### REPL\r\nThe project ships with an interactive Read-Eval-Print-Loop (REPL) that you can use to play with the algorithm. To build the REPL, you need OCaml installed. \r\n\r\nIf you prefer [Docker](https://www.docker.com/), there's an image that you can use to try out the REPL. Simply run\r\n```shell\r\n$ docker run -w /home/opam/type-inference -it prakhar1989/type-infer /bin/bash\r\n```\r\n\r\nCompile the REPL with `make` and if all goes well, you should be good to go. \r\n```\r\n$ ./repl\r\n\r\nWelcome to the REPL.\r\nType in expressions and let Hindley-Milner Type Inference run its magic.\r\n\r\nOut of ideas? Try out a simple lambda expression: (fun x -> x + 10)\r\n\r\n> 10 + 20 > 40\r\nbool\r\n> (fun x -> (x && true) || false)\r\n(bool -> bool)\r\n> (fun x -> x + 10) 20\r\nint\r\n> (fun f -> f 3)\r\n((int -> 'a) -> 'a)\r\n> (fun f -> (fun g -> (fun x -> f (g x))))\r\n(('a -> 'b) -> (('c -> 'a) -> ('c -> 'b)))\r\n```\r\n\r\n### Tests\r\n\r\nTo run the tests, you need [Alcotest](https://github.com/mirage/alcotest) package installed. Install it by running `opam install alcotest`.\r\n\r\n```\r\n$ make test\r\n```\r\n\r\n### Thanks\r\nHuge thanks to these [lecture notes](http://www.cs.cornell.edu/courses/cs3110/2011sp/lectures/lec26-type-inference/type-inference.htm) for providing an understandable breakdown of the algorithm.", 5 | "note": "Don't delete this file! It's used internally to help with page regeneration." 6 | } -------------------------------------------------------------------------------- /parser.mly: -------------------------------------------------------------------------------- 1 | %{ open Ast %} 2 | 3 | /* Tokens */ 4 | 5 | %token EOL FUN THINARROW GT LT LPAREN RPAREN 6 | %token TRUE FALSE AND OR 7 | %token PLUS TIMES APP 8 | %token NUMBER 9 | %token ID 10 | 11 | %nonassoc LPAREN ID NUMBER TRUE FALSE 12 | %left APP 13 | %left AND OR 14 | %left LT GT 15 | %left PLUS 16 | %left TIMES 17 | 18 | %start main 19 | %type main 20 | %% 21 | 22 | main: 23 | | expr EOL { $1 } 24 | 25 | expr: 26 | | ID { Val($1) } 27 | | TRUE { BoolLit(true) } 28 | | FALSE { BoolLit(false) } 29 | | NUMBER { NumLit($1) } 30 | | expr PLUS expr { Binop($1, Add, $3) } 31 | | expr TIMES expr { Binop($1, Mul, $3) } 32 | | expr LT expr { Binop($1, Lt, $3) } 33 | | expr GT expr { Binop($1, Gt, $3) } 34 | | expr AND expr { Binop($1, And, $3) } 35 | | expr OR expr { Binop($1, Or, $3) } 36 | | LPAREN FUN ID THINARROW expr RPAREN { Fun($3, $5) } 37 | | expr expr %prec APP { App($1, $2) } 38 | | LPAREN expr RPAREN { $2 } 39 | -------------------------------------------------------------------------------- /repl.ml: -------------------------------------------------------------------------------- 1 | (* REPL *) 2 | open Ast 3 | 4 | let parse (s: string) : Ast.expr = 5 | Parser.main Scanner.token (Lexing.from_string s) 6 | ;; 7 | 8 | module NameMap = Map.Make(String) 9 | 10 | let rec get_ids (e: expr): id list = 11 | let rec dedup = function 12 | | [] -> [] 13 | | x :: y :: xs when x = y -> y :: dedup xs 14 | | x :: xs -> x :: dedup xs in 15 | let ids = match e with 16 | | NumLit(_) | BoolLit(_) -> [] 17 | | Val(x) -> [x] 18 | | Fun(x, y) -> [x] @ (get_ids y) 19 | | Binop(e1, _, e2) -> (get_ids e1) @ (get_ids e2) 20 | | App(fn, arg) -> (get_ids fn) @ (get_ids arg) in 21 | dedup ids 22 | ;; 23 | 24 | let infer (e: Ast.expr): Ast.aexpr = 25 | let vals = get_ids e in 26 | let env = List.fold_left (fun m x -> NameMap.add x (Infer.gen_new_type ()) m) NameMap.empty vals in 27 | Infer.infer env e 28 | ;; 29 | 30 | let rec repl () = 31 | print_string "> "; 32 | let input = read_line () in 33 | if input = "" then () else 34 | try 35 | let e = parse input in 36 | let aexpr = infer e in 37 | print_endline (string_of_type (Infer.type_of aexpr)); 38 | repl (); 39 | with 40 | | Failure(msg) -> 41 | if msg = "lexing: empty token" then repl () 42 | else print_endline msg; repl () 43 | | _ -> print_endline "Error"; repl () 44 | ;; 45 | 46 | 47 | let intro () = 48 | let template = format_of_string " 49 | Welcome to the REPL. 50 | Type in expressions and let Hindley-Milner Type Inference run its magic. 51 | 52 | Out of ideas? Try out a simple lambda expression: (fun x -> x + 10) 53 | 54 | " in 55 | Printf.printf template 56 | ;; 57 | 58 | intro(); repl (); 59 | -------------------------------------------------------------------------------- /scanner.mll: -------------------------------------------------------------------------------- 1 | { open Parser } 2 | 3 | rule token = parse 4 | | [' ' '\r' '\t'] { token lexbuf } 5 | | ['\n'] { EOL } 6 | | "true" { TRUE } 7 | | "false" { FALSE } 8 | | "fun" { FUN } 9 | | "+" { PLUS } 10 | | "*" { TIMES } 11 | | ['0'-'9']+ as n { NUMBER(int_of_string(n)) } 12 | | ['a'-'z'] as x { ID(Char.escaped(x)) } 13 | | "->" { THINARROW } 14 | | ">" { GT } 15 | | "&&" { AND } 16 | | "||" { OR } 17 | | "<" { LT } 18 | | '(' { LPAREN } 19 | | ')' { RPAREN } 20 | | '#' { comment lexbuf } 21 | | eof { EOL } 22 | 23 | and comment = parse 24 | | '\n' { token lexbuf } 25 | | _ { comment lexbuf } 26 | -------------------------------------------------------------------------------- /stylesheets/github-dark.css: -------------------------------------------------------------------------------- 1 | /* 2 | The MIT License (MIT) 3 | 4 | Copyright (c) 2016 GitHub, Inc. 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in all 14 | copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 22 | SOFTWARE. 23 | 24 | */ 25 | 26 | .pl-c /* comment */ { 27 | color: #969896; 28 | } 29 | 30 | .pl-c1 /* constant, variable.other.constant, support, meta.property-name, support.constant, support.variable, meta.module-reference, markup.raw, meta.diff.header */, 31 | .pl-s .pl-v /* string variable */ { 32 | color: #0099cd; 33 | } 34 | 35 | .pl-e /* entity */, 36 | .pl-en /* entity.name */ { 37 | color: #9774cb; 38 | } 39 | 40 | .pl-smi /* variable.parameter.function, storage.modifier.package, storage.modifier.import, storage.type.java, variable.other */, 41 | .pl-s .pl-s1 /* string source */ { 42 | color: #ddd; 43 | } 44 | 45 | .pl-ent /* entity.name.tag */ { 46 | color: #7bcc72; 47 | } 48 | 49 | .pl-k /* keyword, storage, storage.type */ { 50 | color: #cc2372; 51 | } 52 | 53 | .pl-s /* string */, 54 | .pl-pds /* punctuation.definition.string, string.regexp.character-class */, 55 | .pl-s .pl-pse .pl-s1 /* string punctuation.section.embedded source */, 56 | .pl-sr /* string.regexp */, 57 | .pl-sr .pl-cce /* string.regexp constant.character.escape */, 58 | .pl-sr .pl-sre /* string.regexp source.ruby.embedded */, 59 | .pl-sr .pl-sra /* string.regexp string.regexp.arbitrary-repitition */ { 60 | color: #3c66e2; 61 | } 62 | 63 | .pl-v /* variable */ { 64 | color: #fb8764; 65 | } 66 | 67 | .pl-id /* invalid.deprecated */ { 68 | color: #e63525; 69 | } 70 | 71 | .pl-ii /* invalid.illegal */ { 72 | color: #f8f8f8; 73 | background-color: #e63525; 74 | } 75 | 76 | .pl-sr .pl-cce /* string.regexp constant.character.escape */ { 77 | font-weight: bold; 78 | color: #7bcc72; 79 | } 80 | 81 | .pl-ml /* markup.list */ { 82 | color: #c26b2b; 83 | } 84 | 85 | .pl-mh /* markup.heading */, 86 | .pl-mh .pl-en /* markup.heading entity.name */, 87 | .pl-ms /* meta.separator */ { 88 | font-weight: bold; 89 | color: #264ec5; 90 | } 91 | 92 | .pl-mq /* markup.quote */ { 93 | color: #00acac; 94 | } 95 | 96 | .pl-mi /* markup.italic */ { 97 | font-style: italic; 98 | color: #ddd; 99 | } 100 | 101 | .pl-mb /* markup.bold */ { 102 | font-weight: bold; 103 | color: #ddd; 104 | } 105 | 106 | .pl-md /* markup.deleted, meta.diff.header.from-file */ { 107 | color: #bd2c00; 108 | background-color: #ffecec; 109 | } 110 | 111 | .pl-mi1 /* markup.inserted, meta.diff.header.to-file */ { 112 | color: #55a532; 113 | background-color: #eaffea; 114 | } 115 | 116 | .pl-mdr /* meta.diff.range */ { 117 | font-weight: bold; 118 | color: #9774cb; 119 | } 120 | 121 | .pl-mo /* meta.output */ { 122 | color: #264ec5; 123 | } 124 | 125 | -------------------------------------------------------------------------------- /stylesheets/stylesheet.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 0; 3 | padding: 0; 4 | background: #151515 url("../images/bkg.png") 0 0; 5 | color: #eaeaea; 6 | font: 16px; 7 | line-height: 1.5; 8 | font-family: Monaco, "Bitstream Vera Sans Mono", "Lucida Console", Terminal, monospace; 9 | } 10 | 11 | /* General & 'Reset' Stuff */ 12 | 13 | .container { 14 | width: 90%; 15 | max-width: 600px; 16 | margin: 0 auto; 17 | } 18 | 19 | section { 20 | display: block; 21 | margin: 0 0 20px 0; 22 | } 23 | 24 | h1, h2, h3, h4, h5, h6 { 25 | margin: 0 0 20px; 26 | } 27 | 28 | li { 29 | line-height: 1.4 ; 30 | } 31 | 32 | /* Header,
33 | header - container 34 | h1 - project name 35 | h2 - project description 36 | */ 37 | 38 | header { 39 | background: rgba(0, 0, 0, 0.1); 40 | width: 100%; 41 | border-bottom: 1px dashed #b5e853; 42 | padding: 20px 0; 43 | margin: 0 0 40px 0; 44 | } 45 | 46 | header h1 { 47 | font-size: 30px; 48 | line-height: 1.5; 49 | margin: 0 0 0 -40px; 50 | font-weight: bold; 51 | font-family: Monaco, "Bitstream Vera Sans Mono", "Lucida Console", Terminal, monospace; 52 | color: #b5e853; 53 | text-shadow: 0 1px 1px rgba(0, 0, 0, 0.1), 54 | 0 0 5px rgba(181, 232, 83, 0.1), 55 | 0 0 10px rgba(181, 232, 83, 0.1); 56 | letter-spacing: -1px; 57 | -webkit-font-smoothing: antialiased; 58 | } 59 | 60 | header h1:before { 61 | content: "./ "; 62 | font-size: 24px; 63 | } 64 | 65 | header h2 { 66 | font-size: 18px; 67 | font-weight: 300; 68 | color: #666; 69 | } 70 | 71 | #downloads .btn { 72 | display: inline-block; 73 | text-align: center; 74 | margin: 0; 75 | } 76 | 77 | /* Main Content 78 | */ 79 | 80 | #main_content { 81 | width: 100%; 82 | -webkit-font-smoothing: antialiased; 83 | } 84 | section img { 85 | max-width: 100% 86 | } 87 | 88 | h1, h2, h3, h4, h5, h6 { 89 | font-weight: normal; 90 | font-family: Monaco, "Bitstream Vera Sans Mono", "Lucida Console", Terminal, monospace; 91 | color: #b5e853; 92 | letter-spacing: -0.03em; 93 | text-shadow: 0 1px 1px rgba(0, 0, 0, 0.1), 94 | 0 0 5px rgba(181, 232, 83, 0.1), 95 | 0 0 10px rgba(181, 232, 83, 0.1); 96 | } 97 | 98 | #main_content h1 { 99 | font-size: 30px; 100 | } 101 | 102 | #main_content h2 { 103 | font-size: 24px; 104 | } 105 | 106 | #main_content h3 { 107 | font-size: 18px; 108 | } 109 | 110 | #main_content h4 { 111 | font-size: 14px; 112 | } 113 | 114 | #main_content h5 { 115 | font-size: 12px; 116 | text-transform: uppercase; 117 | margin: 0 0 5px 0; 118 | } 119 | 120 | #main_content h6 { 121 | font-size: 12px; 122 | text-transform: uppercase; 123 | color: #999; 124 | margin: 0 0 5px 0; 125 | } 126 | 127 | dt { 128 | font-style: italic; 129 | font-weight: bold; 130 | } 131 | 132 | ul li { 133 | list-style: none; 134 | } 135 | 136 | ul li:before { 137 | content: ">>"; 138 | font-family: Monaco, "Bitstream Vera Sans Mono", "Lucida Console", Terminal, monospace; 139 | font-size: 13px; 140 | color: #b5e853; 141 | margin-left: -37px; 142 | margin-right: 21px; 143 | line-height: 16px; 144 | } 145 | 146 | blockquote { 147 | color: #aaa; 148 | padding-left: 10px; 149 | border-left: 1px dotted #666; 150 | } 151 | 152 | pre { 153 | background: rgba(0, 0, 0, 0.9); 154 | border: 1px solid rgba(255, 255, 255, 0.15); 155 | padding: 10px; 156 | font-size: 14px; 157 | color: #b5e853; 158 | border-radius: 2px; 159 | -moz-border-radius: 2px; 160 | -webkit-border-radius: 2px; 161 | text-wrap: normal; 162 | overflow: auto; 163 | overflow-y: hidden; 164 | } 165 | 166 | table { 167 | width: 100%; 168 | margin: 0 0 20px 0; 169 | } 170 | 171 | th { 172 | text-align: left; 173 | border-bottom: 1px dashed #b5e853; 174 | padding: 5px 10px; 175 | } 176 | 177 | td { 178 | padding: 5px 10px; 179 | } 180 | 181 | hr { 182 | height: 0; 183 | border: 0; 184 | border-bottom: 1px dashed #b5e853; 185 | color: #b5e853; 186 | } 187 | 188 | /* Buttons 189 | */ 190 | 191 | .btn { 192 | display: inline-block; 193 | background: -webkit-linear-gradient(top, rgba(40, 40, 40, 0.3), rgba(35, 35, 35, 0.3) 50%, rgba(10, 10, 10, 0.3) 50%, rgba(0, 0, 0, 0.3)); 194 | padding: 8px 18px; 195 | border-radius: 50px; 196 | border: 2px solid rgba(0, 0, 0, 0.7); 197 | border-bottom: 2px solid rgba(0, 0, 0, 0.7); 198 | border-top: 2px solid rgba(0, 0, 0, 1); 199 | color: rgba(255, 255, 255, 0.8); 200 | font-family: Helvetica, Arial, sans-serif; 201 | font-weight: bold; 202 | font-size: 13px; 203 | text-decoration: none; 204 | text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.75); 205 | box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.05); 206 | } 207 | 208 | .btn:hover { 209 | background: -webkit-linear-gradient(top, rgba(40, 40, 40, 0.6), rgba(35, 35, 35, 0.6) 50%, rgba(10, 10, 10, 0.8) 50%, rgba(0, 0, 0, 0.8)); 210 | } 211 | 212 | .btn .icon { 213 | display: inline-block; 214 | width: 16px; 215 | height: 16px; 216 | margin: 1px 8px 0 0; 217 | float: left; 218 | } 219 | 220 | .btn-github .icon { 221 | opacity: 0.6; 222 | background: url("../images/blacktocat.png") 0 0 no-repeat; 223 | } 224 | 225 | /* Links 226 | a, a:hover, a:visited 227 | */ 228 | 229 | a { 230 | color: #63c0f5; 231 | text-shadow: 0 0 5px rgba(104, 182, 255, 0.5); 232 | } 233 | 234 | /* Clearfix */ 235 | 236 | .cf:before, .cf:after { 237 | content:""; 238 | display:table; 239 | } 240 | 241 | .cf:after { 242 | clear:both; 243 | } 244 | 245 | .cf { 246 | zoom:1; 247 | } -------------------------------------------------------------------------------- /test.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | 3 | module NameMap = Map.Make(String) 4 | 5 | let rec get_ids (e: expr): id list = 6 | let rec dedup = function 7 | | [] -> [] 8 | | x :: y :: xs when x = y -> y :: dedup xs 9 | | x :: xs -> x :: dedup xs in 10 | let ids = match e with 11 | | NumLit(_) | BoolLit(_) -> [] 12 | | Val(x) -> [x] 13 | | Fun(x, y) -> [x] @ (get_ids y) 14 | | Binop(e1, _, e2) -> (get_ids e1) @ (get_ids e2) 15 | | App(fn, arg) -> (get_ids fn) @ (get_ids arg) in 16 | dedup ids 17 | ;; 18 | 19 | let debug (e: expr): string = 20 | let ids = get_ids e in 21 | let env = ListLabels.fold_left ~init:NameMap.empty ids 22 | ~f:(fun m x -> NameMap.add x (Infer.gen_new_type ()) m) in 23 | let aexpr = Infer.infer env e in 24 | string_of_type (Infer.type_of aexpr) 25 | ;; 26 | 27 | let testcases = [| 28 | NumLit(10); 29 | BoolLit(true); 30 | 31 | Binop(NumLit(10), Add, NumLit(2)); 32 | Binop(BoolLit(true), Or, BoolLit(false)); 33 | 34 | Binop(Binop(Val("x"), Add, Val("y")), Mul, Val("z")); 35 | Binop(Binop(Val("x"), Add, Val("y")), Gt, Val("z")); 36 | Binop(Binop(Val("x"), Gt, Val("y")), Lt, Val("z")); 37 | Binop(Binop(Val("x"), Mul, Val("y")), Lt, Binop(Val("z"), Add, Val("w"))); 38 | 39 | Fun("x", Binop(Val("x"), Add, NumLit(10))); 40 | Fun("x", Binop(NumLit(20), Gt,Binop(Val("x"), Add, NumLit(10)))); 41 | 42 | App(Fun("x", Binop(Val("x"), Add, NumLit(10))), NumLit(10)); 43 | Fun("f", Fun("g", Fun("x", App(Val("f"), App(Val("g"), Val("x")))))); 44 | |];; 45 | 46 | let literals_check () = 47 | begin 48 | Alcotest.(check string) "Integer" "int" (debug testcases.(0)); 49 | Alcotest.(check string) "Boolean" "bool" (debug testcases.(1)); 50 | end 51 | ;; 52 | 53 | let simple_expr_check () = 54 | begin 55 | Alcotest.(check string) "Integer" "int" (debug testcases.(2)); 56 | Alcotest.(check string) "Boolean" "bool" (debug testcases.(3)); 57 | end 58 | ;; 59 | 60 | let var_expr_check () = 61 | begin 62 | Alcotest.(check string) "x + y + z" "int" (debug testcases.(4)); 63 | Alcotest.(check string) "x + y > z" "bool" (debug testcases.(5)); 64 | Alcotest.(check string) "(x > y) < z" "bool" (debug testcases.(6)); 65 | Alcotest.(check string) "(x * y) < (z + w)" "bool" (debug testcases.(7)); 66 | end 67 | ;; 68 | 69 | let func_decl_check () = 70 | begin 71 | Alcotest.(check string) "fun x -> x + 10" "(int -> int)" (debug testcases.(8)); 72 | Alcotest.(check string) "fun x -> (20 > (x + 10))" "(int -> bool)" (debug testcases.(9)); 73 | end 74 | ;; 75 | 76 | 77 | let func_appl_check () = 78 | begin 79 | Alcotest.(check string) "(fun x -> x + 10) 10" "int" (debug testcases.(10)); 80 | Alcotest.(check string) "compose function" "(('a -> 'b) -> (('c -> 'a) -> ('c -> 'b)))" (debug testcases.(11)); 81 | end 82 | ;; 83 | 84 | let infer_set = [ 85 | "Literals", `Quick, literals_check; 86 | "Simple Expr", `Quick, simple_expr_check; 87 | "Variable Expr", `Quick, var_expr_check; 88 | "Function Declarations", `Quick, func_decl_check; 89 | "Function Application", `Quick, func_appl_check; 90 | ] 91 | 92 | (* Run it *) 93 | let () = 94 | Alcotest.run "Type-inference testcases" [ 95 | "test_1", infer_set; 96 | ] 97 | ;; 98 | --------------------------------------------------------------------------------