├── .github └── workflows │ └── gh-pages.yml ├── .gitignore ├── .ocamlformat ├── LICENSE ├── Makefile ├── README.md ├── dune-project ├── examples ├── nat.mlt └── recursion.mlt ├── src ├── 00-utils │ ├── dune │ ├── error.ml │ ├── list.ml │ ├── location.ml │ ├── print.ml │ └── symbol.ml ├── 01-language │ ├── ast.ml │ ├── const.ml │ ├── dune │ └── primitives.ml ├── 02-parser │ ├── dune │ ├── grammar.mly │ ├── lexer.mll │ └── sugaredAst.ml ├── 03-desugarer │ ├── desugarer.ml │ └── dune ├── 04-typechecker │ ├── dune │ ├── primitives.ml │ └── typechecker.ml ├── 05-backends │ ├── interpreter │ │ ├── cli │ │ │ ├── cliInterpreter.ml │ │ │ ├── cliInterpreter.mli │ │ │ └── dune │ │ ├── core │ │ │ ├── dune │ │ │ ├── interpreter.ml │ │ │ └── primitives.ml │ │ └── web │ │ │ ├── dune │ │ │ ├── redexSelectorTM.ml │ │ │ ├── webInterpreter.ml │ │ │ └── webInterpreter.mli │ └── sig │ │ ├── cli │ │ ├── cliBackend.ml │ │ └── dune │ │ ├── core │ │ ├── backend.ml │ │ └── dune │ │ └── web │ │ ├── dune │ │ └── webBackend.ml └── 06-user-interface │ ├── cli │ ├── cli.ml │ └── dune │ ├── core │ ├── dune │ ├── loader.ml │ └── stdlib.mlt │ └── web │ ├── dune │ ├── model.ml │ ├── view.ml │ └── web.ml ├── tests ├── dune ├── duplicate_variant_tydef_sum.mlt ├── invalid_match_type.mlt ├── less_than_function.mlt ├── lexer.mlt ├── malformed_type_application.mlt ├── nat.mlt ├── non_linear_pattern.mlt ├── occurs_check.mlt ├── orelse_andalso.mlt ├── patterns.mlt ├── polymorphism.mlt ├── polymorphism_id_id.mlt ├── recursion.mlt ├── run_tests.t ├── shadow_label.mlt ├── shadow_type.mlt ├── test_equality.mlt ├── test_less_then.mlt ├── test_precedence_and_associativity.mlt ├── test_stdlib.mlt ├── tydef.mlt ├── type_annotations.mlt ├── typing.mlt └── use_undefined_type.mlt └── web └── index.html /.github/workflows/gh-pages.yml: -------------------------------------------------------------------------------- 1 | name: github pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - main 7 | 8 | jobs: 9 | deploy: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@v4 13 | 14 | - name: Setup OCaml 15 | uses: ocaml/setup-ocaml@v3 16 | with: 17 | ocaml-compiler: 4.14.x 18 | 19 | - name: Install Opam packages 20 | run: opam install menhir vdom ocamlformat=0.27.0 21 | 22 | - name: Build 23 | run: opam exec -- make release 24 | 25 | - name: Test 26 | run: opam exec -- make test 27 | 28 | - name: Deploy 29 | uses: peaceiris/actions-gh-pages@v3 30 | with: 31 | github_token: ${{ secrets.GITHUB_TOKEN }} 32 | publish_dir: ./web 33 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | _build 3 | cli.exe 4 | .devcontainer 5 | .vscode 6 | .merlin 7 | web/web.bc.js 8 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.27.0 -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2024 Matija Pretnar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | default: format 2 | dune build 3 | 4 | format: 5 | dune build @fmt --auto-promote 6 | 7 | release: format 8 | dune build --profile release 9 | 10 | test: default 11 | dune test 12 | 13 | clean: 14 | dune clean 15 | 16 | .PHONY: default format release test clean 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Millet 2 | 3 | Do you, like me, test theoretical programming language concepts by building your own programming language? Do you, like me, do it by copying and modifying your most recent language because you are too lazy to build everything from scratch? Do you, like me, end up with a mess? Then Millet is for you. It is a pure ML-like language with simple and modular codebase that you can use as a template for your next language. 4 | 5 | ## How to install and run Millet? 6 | 7 | Install dependencies by 8 | 9 | opam install menhir vdom ocamlformat=0.27.0 10 | 11 | and build Millet by running (requires OCaml >= 4.14.0) 12 | 13 | make 14 | 15 | and you can clean up by running 16 | 17 | make clean 18 | 19 | Millet gives you two options to run programs: 20 | 21 | - The first option is a web interface, accessible at `web/index.html`, which allows you to load one of the built-in examples or enter your own program, and then interactively click through all its (non-deterministic and asynchronous) reductions or introduce external interrupts. The web interface is also available at . 22 | 23 | - The second option is a command line executable run as 24 | 25 | ./cli.exe file1.mlt file2.mlt ... 26 | 27 | which loads all the commands in all the listed files and starts evaluating the given program, displaying all outgoing signals and the terminal configuration (if there is one). Non-deterministic reductions are chosen randomly and there is no option of introducing external interrupts. If you do not want to load the standard library, run Millet with the `--no-stdlib` option. 28 | 29 | ## How to use Millet as a template? 30 | 31 | The easiest way is to first create an empty repository: 32 | 33 | mkdir the-best-language 34 | cd the-best-language 35 | git init 36 | 37 | Next, add Millet's remote repository: 38 | 39 | git remote add millet git@github.com:matijapretnar/millet.git 40 | git fetch millet 41 | 42 | Then, create two branches, one for your main development and one for tracking Millet: 43 | 44 | git branch --no-track main millet/main 45 | git branch --track millet millet/main 46 | git checkout main 47 | 48 | Now, each time Millet updates, you can run 49 | 50 | git checkout millet 51 | git pull 52 | git checkout main 53 | git merge millet 54 | 55 | to pull latest changes and merge them into your main development. 56 | 57 | ## Why the name Millet? 58 | 59 | Millet uses fine-grain call-by-value core calculus, and there is no finer grain than [millet](https://en.wikipedia.org/wiki/Millet). Plus, the `.mlt` extension fits nicely into the ML family. 60 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (using menhir 2.1) 3 | (cram enable) 4 | -------------------------------------------------------------------------------- /examples/nat.mlt: -------------------------------------------------------------------------------- 1 | type nat = 2 | | Zero 3 | | Succ of nat 4 | 5 | let rec add m n = 6 | match m with 7 | | Zero -> n 8 | | Succ m' -> Succ (add m' n) 9 | 10 | let rec multiply m n = 11 | match m with 12 | | Zero -> Zero 13 | | Succ m' -> add n (multiply m' n) 14 | 15 | let rec to_int = 16 | function 17 | | Zero -> 0 18 | | Succ m -> to_int m + 1 19 | 20 | let rec from_int n = 21 | if n = 0 then Zero else Succ (from_int (n - 1)) 22 | 23 | run 24 | let six = from_int 6 in 25 | let seven = Succ six in 26 | let forty_two = multiply six seven in 27 | to_int forty_two 28 | -------------------------------------------------------------------------------- /examples/recursion.mlt: -------------------------------------------------------------------------------- 1 | let rec fact n = 2 | if n = 0 then 1 else n * fact (n - 1) 3 | 4 | let fib n = 5 | let rec aux n a b = 6 | if n = 0 then a else aux (n - 1) b (a + b) 7 | in 8 | aux n 0 1 9 | 10 | let rec gcd m n = 11 | match n with 12 | | 0 -> m 13 | | _ -> gcd n (m mod n) 14 | 15 | run (gcd (fib 10) (fact 10)) 16 | -------------------------------------------------------------------------------- /src/00-utils/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name utils)) 3 | -------------------------------------------------------------------------------- /src/00-utils/error.ml: -------------------------------------------------------------------------------- 1 | (** Error reporting *) 2 | 3 | type t = Location.t option * string * string 4 | 5 | let print (loc, error_kind, msg) = Print.error ?loc error_kind "%s" msg 6 | 7 | exception Error of t 8 | 9 | (** [error ~loc error_kind fmt] raises an [Error] of kind [error_kind] with a 10 | message [fmt] at a location [loc]. The [kfprintf] magic allows us to 11 | construct the [fmt] using a format string before raising the exception. *) 12 | let error ?loc error_kind = 13 | let k _ = 14 | let msg = Format.flush_str_formatter () in 15 | raise (Error (loc, error_kind, msg)) 16 | in 17 | fun fmt -> Format.kfprintf k Format.str_formatter ("@[" ^^ fmt ^^ "@]") 18 | 19 | let fatal ?loc fmt = error ?loc "Fatal error" fmt 20 | let syntax ~loc fmt = error ~loc "Syntax error" fmt 21 | let typing ?loc fmt = error ?loc "Typing error" fmt 22 | let runtime ?loc fmt = error ?loc "Runtime error" fmt 23 | -------------------------------------------------------------------------------- /src/00-utils/list.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.List 2 | 3 | let fold_map f s xs = 4 | let aux (s, reversed_ys) x = 5 | let s', y = f s x in 6 | (s', y :: reversed_ys) 7 | in 8 | let s', reversed_ys = fold_left aux (s, []) xs in 9 | (s', rev reversed_ys) 10 | -------------------------------------------------------------------------------- /src/00-utils/location.ml: -------------------------------------------------------------------------------- 1 | (** Source code locations *) 2 | 3 | type t = { filename : string; line : int; column : int } 4 | 5 | let print { filename; line; column } ppf = 6 | if String.length filename != 0 then 7 | Format.fprintf ppf "file %S, line %d, char %d" filename line column 8 | else Format.fprintf ppf "line %d, char %d" (line - 1) column 9 | 10 | let of_lexeme position = 11 | let filename = position.Lexing.pos_fname 12 | and line = position.Lexing.pos_lnum 13 | and column = position.Lexing.pos_cnum - position.Lexing.pos_bol + 1 in 14 | { filename; line; column } 15 | -------------------------------------------------------------------------------- /src/00-utils/print.ml: -------------------------------------------------------------------------------- 1 | (** Pretty-printing functions *) 2 | 3 | let message ?loc ~header fmt = 4 | match loc with 5 | | Some loc -> 6 | Format.fprintf Format.err_formatter 7 | ("%s (%t):@," ^^ fmt ^^ "@.") 8 | header (Location.print loc) 9 | | _ -> Format.fprintf Format.err_formatter ("%s: " ^^ fmt ^^ "@.") header 10 | 11 | let error ?loc err_kind fmt = message ?loc ~header:err_kind fmt 12 | let check ?loc fmt = message ?loc ~header:"Check" fmt 13 | let warning ?loc fmt = message ?loc ~header:"Warning" fmt 14 | let debug ?loc fmt = message ?loc ~header:"Debug" fmt 15 | 16 | let print ?(at_level = min_int) ?(max_level = max_int) ppf = 17 | if at_level <= max_level then Format.fprintf ppf 18 | else fun fmt -> Format.fprintf ppf ("(" ^^ fmt ^^ ")") 19 | 20 | let rec print_sequence sep pp vs ppf = 21 | match vs with 22 | | [] -> () 23 | | [ v ] -> pp v ppf 24 | | v :: vs -> 25 | Format.fprintf ppf "%t%s@,%t" (pp v) sep (print_sequence sep pp vs) 26 | 27 | let rec print_cases pp vs ppf = 28 | match vs with 29 | | [] -> () 30 | | [ v ] -> pp v ppf 31 | | v :: vs -> Format.fprintf ppf "%t@,| %t" (pp v) (print_cases pp vs) 32 | 33 | let print_field fpp vpp (f, v) ppf = print ppf "%t = %t" (fpp f) (vpp v) 34 | 35 | let print_tuple pp lst ppf = 36 | match lst with 37 | | [] -> print ppf "()" 38 | | lst -> print ppf "(@[%t@])" (print_sequence ", " pp lst) 39 | 40 | let print_record fpp vpp assoc ppf = 41 | print ppf "{@[%t@]}" (print_sequence "; " (print_field fpp vpp) assoc) 42 | -------------------------------------------------------------------------------- /src/00-utils/symbol.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | type t 3 | 4 | val compare : t -> t -> int 5 | val fresh : string -> t 6 | val refresh : t -> t 7 | val print : t -> Format.formatter -> unit 8 | end 9 | 10 | module Make () : S = struct 11 | type t = int * string 12 | 13 | let compare (n1, _) (n2, _) = Int.compare n1 n2 14 | let count = ref (-1) 15 | 16 | let fresh ann = 17 | incr count; 18 | (!count, ann) 19 | 20 | let refresh (_, ann) = fresh ann 21 | let print (_n, ann) ppf = Format.fprintf ppf "%s" ann 22 | end 23 | 24 | let rec subscript i = 25 | let last = 26 | List.nth 27 | [ 28 | "\226\130\128"; 29 | "\226\130\129"; 30 | "\226\130\130"; 31 | "\226\130\131"; 32 | "\226\130\132"; 33 | "\226\130\133"; 34 | "\226\130\134"; 35 | "\226\130\135"; 36 | "\226\130\136"; 37 | "\226\130\137"; 38 | ] 39 | (i mod 10) 40 | in 41 | if i < 10 then last else subscript (i / 10) ^ last 42 | 43 | let greek_letters = 44 | [| 45 | "α"; 46 | "β"; 47 | "γ"; 48 | "δ"; 49 | "ε"; 50 | "ζ"; 51 | "η"; 52 | "θ"; 53 | "ι"; 54 | "κ"; 55 | "λ"; 56 | "μ"; 57 | "ν"; 58 | "ξ"; 59 | "ο"; 60 | "π"; 61 | "ρ"; 62 | "σ"; 63 | "τ"; 64 | |] 65 | 66 | let type_symbol n = 67 | if n < Array.length greek_letters then greek_letters.(n) 68 | else "τ" ^ subscript (n - Array.length greek_letters) 69 | -------------------------------------------------------------------------------- /src/01-language/ast.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module TyName = Symbol.Make () 3 | 4 | type ty_name = TyName.t 5 | 6 | module TyNameMap = Map.Make (TyName) 7 | 8 | let bool_ty_name = TyName.fresh "bool" 9 | let int_ty_name = TyName.fresh "int" 10 | let unit_ty_name = TyName.fresh "unit" 11 | let string_ty_name = TyName.fresh "string" 12 | let float_ty_name = TyName.fresh "float" 13 | let list_ty_name = TyName.fresh "list" 14 | let empty_ty_name = TyName.fresh "empty" 15 | 16 | module TyParam = Symbol.Make () 17 | 18 | type ty_param = TyParam.t 19 | 20 | module TyParamMap = Map.Make (TyParam) 21 | module TyParamSet = Set.Make (TyParam) 22 | 23 | type ty = 24 | | TyConst of Const.ty 25 | | TyApply of ty_name * ty list (** [(ty1, ty2, ..., tyn) type_name] *) 26 | | TyParam of ty_param (** ['a] *) 27 | | TyArrow of ty * ty (** [ty1 -> ty2] *) 28 | | TyTuple of ty list (** [ty1 * ty2 * ... * tyn] *) 29 | 30 | let rec print_ty ?max_level print_param p ppf = 31 | let print ?at_level = Print.print ?max_level ?at_level ppf in 32 | match p with 33 | | TyConst c -> print "%t" (Const.print_ty c) 34 | | TyApply (ty_name, []) -> print "%t" (TyName.print ty_name) 35 | | TyApply (ty_name, [ ty ]) -> 36 | print ~at_level:1 "%t %t" 37 | (print_ty ~max_level:1 print_param ty) 38 | (TyName.print ty_name) 39 | | TyApply (ty_name, tys) -> 40 | print ~at_level:1 "%t %t" 41 | (Print.print_tuple (print_ty print_param) tys) 42 | (TyName.print ty_name) 43 | | TyParam a -> print "%t" (print_param a) 44 | | TyArrow (ty1, ty2) -> 45 | print ~at_level:3 "%t → %t" 46 | (print_ty ~max_level:2 print_param ty1) 47 | (print_ty ~max_level:3 print_param ty2) 48 | | TyTuple [] -> print "unit" 49 | | TyTuple tys -> 50 | print ~at_level:2 "%t" 51 | (Print.print_sequence " × " (print_ty ~max_level:1 print_param) tys) 52 | 53 | let new_print_param () = 54 | let names = ref TyParamMap.empty in 55 | let counter = ref 0 in 56 | let print_param param ppf = 57 | let symbol = 58 | match TyParamMap.find_opt param !names with 59 | | Some symbol -> symbol 60 | | None -> 61 | let symbol = Symbol.type_symbol !counter in 62 | incr counter; 63 | names := TyParamMap.add param symbol !names; 64 | symbol 65 | in 66 | Print.print ppf "%s" symbol 67 | in 68 | print_param 69 | 70 | let print_ty_scheme (_params, ty) ppf = 71 | let print_param = new_print_param () in 72 | Print.print ppf "@[%t@]" (print_ty print_param ty) 73 | 74 | let rec substitute_ty subst = function 75 | | TyConst _ as ty -> ty 76 | | TyParam a as ty -> ( 77 | match TyParamMap.find_opt a subst with None -> ty | Some ty' -> ty') 78 | | TyApply (ty_name, tys) -> 79 | TyApply (ty_name, List.map (substitute_ty subst) tys) 80 | | TyTuple tys -> TyTuple (List.map (substitute_ty subst) tys) 81 | | TyArrow (ty1, ty2) -> 82 | TyArrow (substitute_ty subst ty1, substitute_ty subst ty2) 83 | 84 | let rec free_vars = function 85 | | TyConst _ -> TyParamSet.empty 86 | | TyParam a -> TyParamSet.singleton a 87 | | TyApply (_, tys) -> 88 | List.fold_left 89 | (fun vars ty -> TyParamSet.union vars (free_vars ty)) 90 | TyParamSet.empty tys 91 | | TyTuple tys -> 92 | List.fold_left 93 | (fun vars ty -> TyParamSet.union vars (free_vars ty)) 94 | TyParamSet.empty tys 95 | | TyArrow (ty1, ty2) -> TyParamSet.union (free_vars ty1) (free_vars ty2) 96 | 97 | module Variable = Symbol.Make () 98 | module VariableMap = Map.Make (Variable) 99 | module Label = Symbol.Make () 100 | 101 | type variable = Variable.t 102 | type label = Label.t 103 | 104 | let nil_label_string = "$nil$" 105 | let nil_label = Label.fresh nil_label_string 106 | let cons_label_string = "$cons$" 107 | let cons_label = Label.fresh cons_label_string 108 | 109 | type pattern = 110 | | PVar of variable 111 | | PAnnotated of pattern * ty 112 | | PAs of pattern * variable 113 | | PTuple of pattern list 114 | | PVariant of label * pattern option 115 | | PConst of Const.t 116 | | PNonbinding 117 | 118 | type expression = 119 | | Var of variable 120 | | Const of Const.t 121 | | Annotated of expression * ty 122 | | Tuple of expression list 123 | | Variant of label * expression option 124 | | Lambda of abstraction 125 | | RecLambda of variable * abstraction 126 | 127 | and computation = 128 | | Return of expression 129 | | Do of computation * abstraction 130 | | Match of expression * abstraction list 131 | | Apply of expression * expression 132 | 133 | and abstraction = pattern * computation 134 | 135 | type ty_def = TySum of (label * ty option) list | TyInline of ty 136 | 137 | type command = 138 | | TyDef of (ty_param list * ty_name * ty_def) list 139 | | TopLet of variable * expression 140 | | TopDo of computation 141 | 142 | let rec print_pattern ?max_level p ppf = 143 | let print ?at_level = Print.print ?max_level ?at_level ppf in 144 | match p with 145 | | PVar x -> print "%t" (Variable.print x) 146 | | PAs (p, x) -> print "%t as %t" (print_pattern p) (Variable.print x) 147 | | PAnnotated (p, _ty) -> print_pattern ?max_level p ppf 148 | | PConst c -> Const.print c ppf 149 | | PTuple lst -> Print.print_tuple print_pattern lst ppf 150 | | PVariant (lbl, None) when lbl = nil_label -> print "[]" 151 | | PVariant (lbl, None) -> print "%t" (Label.print lbl) 152 | | PVariant (lbl, Some (PTuple [ v1; v2 ])) when lbl = cons_label -> 153 | print "%t::%t" (print_pattern v1) (print_pattern v2) 154 | | PVariant (lbl, Some p) -> 155 | print ~at_level:1 "%t @[%t@]" (Label.print lbl) (print_pattern p) 156 | | PNonbinding -> print "_" 157 | 158 | let rec print_expression ?max_level e ppf = 159 | let print ?at_level = Print.print ?max_level ?at_level ppf in 160 | match e with 161 | | Var x -> print "%t" (Variable.print x) 162 | | Const c -> print "%t" (Const.print c) 163 | | Annotated (t, _ty) -> print_expression ?max_level t ppf 164 | | Tuple lst -> Print.print_tuple print_expression lst ppf 165 | | Variant (lbl, None) when lbl = nil_label -> print "[]" 166 | | Variant (lbl, None) -> print "%t" (Label.print lbl) 167 | | Variant (lbl, Some (Tuple [ v1; v2 ])) when lbl = cons_label -> 168 | print ~at_level:1 "%t::%t" 169 | (print_expression ~max_level:0 v1) 170 | (print_expression ~max_level:1 v2) 171 | | Variant (lbl, Some e) -> 172 | print ~at_level:1 "%t @[%t@]" (Label.print lbl) 173 | (print_expression ~max_level:0 e) 174 | | Lambda a -> print ~at_level:2 "fun %t" (print_abstraction a) 175 | | RecLambda (f, _ty) -> print ~at_level:2 "rec %t ..." (Variable.print f) 176 | 177 | and print_computation ?max_level c ppf = 178 | let print ?at_level = Print.print ?max_level ?at_level ppf in 179 | match c with 180 | | Return e -> print ~at_level:1 "return %t" (print_expression ~max_level:0 e) 181 | | Do (c1, (PNonbinding, c2)) -> 182 | print "@[%t;@ %t@]" (print_computation c1) (print_computation c2) 183 | | Do (c1, (pat, c2)) -> 184 | print "@[let@[@ %t =@ %t@] in@ %t@]" (print_pattern pat) 185 | (print_computation c1) (print_computation c2) 186 | | Match (e, lst) -> 187 | print "match %t with (@[%t@])" (print_expression e) 188 | (Print.print_sequence " | " print_case lst) 189 | | Apply (e1, e2) -> 190 | print ~at_level:1 "@[%t@ %t@]" 191 | (print_expression ~max_level:1 e1) 192 | (print_expression ~max_level:0 e2) 193 | 194 | and print_abstraction (p, c) ppf = 195 | Format.fprintf ppf "%t ↦ %t" (print_pattern p) (print_computation c) 196 | 197 | and print_case a ppf = Format.fprintf ppf "%t" (print_abstraction a) 198 | 199 | let string_of_expression e = 200 | print_expression e Format.str_formatter; 201 | Format.flush_str_formatter () 202 | 203 | let string_of_computation c = 204 | print_computation c Format.str_formatter; 205 | Format.flush_str_formatter () 206 | -------------------------------------------------------------------------------- /src/01-language/const.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | type t = Integer of int | String of string | Boolean of bool | Float of float 4 | type ty = IntegerTy | StringTy | BooleanTy | FloatTy 5 | 6 | let of_integer n = Integer n 7 | let of_string s = String s 8 | let of_boolean b = Boolean b 9 | let of_float f = Float f 10 | let of_true = of_boolean true 11 | let of_false = of_boolean false 12 | 13 | let print c ppf = 14 | match c with 15 | | Integer k -> Format.fprintf ppf "%d" k 16 | | String s -> Format.fprintf ppf "%S" s 17 | | Boolean b -> Format.fprintf ppf "%B" b 18 | | Float f -> Format.fprintf ppf "%F" f 19 | 20 | let print_ty c ppf = 21 | match c with 22 | | IntegerTy -> Format.fprintf ppf "int" 23 | | StringTy -> Format.fprintf ppf "string" 24 | | BooleanTy -> Format.fprintf ppf "bool" 25 | | FloatTy -> Format.fprintf ppf "float" 26 | 27 | let infer_ty = function 28 | | Integer _ -> IntegerTy 29 | | String _ -> StringTy 30 | | Boolean _ -> BooleanTy 31 | | Float _ -> FloatTy 32 | 33 | type comparison = Less | Equal | Greater 34 | 35 | let compare c1 c2 = 36 | let cmp x y = 37 | let r = Stdlib.compare x y in 38 | if r < 0 then Less else if r > 0 then Greater else Equal 39 | in 40 | match (c1, c2) with 41 | | Integer n1, Integer n2 -> cmp n1 n2 42 | | String s1, String s2 -> cmp s1 s2 43 | | Boolean b1, Boolean b2 -> cmp b1 b2 44 | | Float x1, Float x2 -> cmp x1 x2 45 | | _ -> Error.runtime "Incomparable constants %t and %t" (print c1) (print c2) 46 | 47 | let equal c1 c2 = compare c1 c2 = Equal 48 | -------------------------------------------------------------------------------- /src/01-language/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name language) 3 | (libraries utils)) 4 | -------------------------------------------------------------------------------- /src/01-language/primitives.ml: -------------------------------------------------------------------------------- 1 | type primitive = 2 | | CompareEq 3 | | CompareLt 4 | | CompareGt 5 | | CompareLe 6 | | CompareGe 7 | | CompareNe 8 | | IntegerAdd 9 | | IntegerMul 10 | | IntegerSub 11 | | IntegerDiv 12 | | IntegerMod 13 | | IntegerNeg 14 | | FloatAdd 15 | | FloatMul 16 | | FloatSub 17 | | FloatDiv 18 | | FloatPow 19 | | FloatNeg 20 | | ToString 21 | 22 | (* Keep this list up to date with the type above, otherwise the missing primitives will not be loaded *) 23 | let primitives = 24 | [ 25 | CompareEq; 26 | CompareLt; 27 | CompareGt; 28 | CompareLe; 29 | CompareGe; 30 | CompareNe; 31 | IntegerAdd; 32 | IntegerMul; 33 | IntegerSub; 34 | IntegerDiv; 35 | IntegerMod; 36 | IntegerNeg; 37 | FloatAdd; 38 | FloatMul; 39 | FloatSub; 40 | FloatDiv; 41 | FloatPow; 42 | FloatNeg; 43 | ToString; 44 | ] 45 | 46 | let primitive_name = function 47 | | CompareEq -> "__compare_eq__" 48 | | CompareLt -> "__compare_lt__" 49 | | CompareGt -> "__compare_gt__" 50 | | CompareLe -> "__compare_le__" 51 | | CompareGe -> "__compare_ge__" 52 | | CompareNe -> "__compare_ne__" 53 | | IntegerAdd -> "__integer_add__" 54 | | IntegerMul -> "__integer_mul__" 55 | | IntegerSub -> "__integer_sub__" 56 | | IntegerDiv -> "__integer_div__" 57 | | IntegerMod -> "__integer_mod__" 58 | | IntegerNeg -> "__integer_neg__" 59 | | FloatAdd -> "__float_add__" 60 | | FloatMul -> "__float_mul__" 61 | | FloatSub -> "__float_sub__" 62 | | FloatDiv -> "__float_div__" 63 | | FloatPow -> "__float_pow__" 64 | | FloatNeg -> "__float_neg__" 65 | | ToString -> "to_string" 66 | -------------------------------------------------------------------------------- /src/02-parser/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parser) 3 | (libraries language)) 4 | 5 | (ocamllex lexer) 6 | 7 | (menhir 8 | (modules grammar)) 9 | -------------------------------------------------------------------------------- /src/02-parser/grammar.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open SugaredAst 3 | open Utils 4 | %} 5 | 6 | %token LPAREN RPAREN LBRACK RBRACK 7 | %token COLON COMMA SEMI EQUAL CONS 8 | %token BEGIN END 9 | %token LNAME 10 | %token UNDERSCORE AS 11 | %token INT 12 | %token STRING 13 | %token BOOL 14 | %token FLOAT 15 | %token UNAME 16 | %token PARAM 17 | %token TYPE ARROW OF 18 | %token MATCH WITH FUNCTION 19 | %token RUN LET REC AND IN 20 | %token FUN BAR BARBAR 21 | %token IF THEN ELSE 22 | %token PLUS STAR MINUS MINUSDOT 23 | %token LSL LSR ASR 24 | %token MOD OR 25 | %token AMPER AMPERAMPER 26 | %token LAND LOR LXOR 27 | %token PREFIXOP INFIXOP0 INFIXOP1 INFIXOP2 INFIXOP3 INFIXOP4 28 | %token EOF 29 | 30 | %nonassoc ARROW IN 31 | %right SEMI 32 | %nonassoc ELSE 33 | %right OR BARBAR 34 | %right AMPER AMPERAMPER 35 | %left INFIXOP0 EQUAL 36 | %right INFIXOP1 37 | %right CONS 38 | %left INFIXOP2 PLUS MINUS MINUSDOT 39 | %left INFIXOP3 STAR MOD LAND LOR LXOR 40 | %right INFIXOP4 LSL LSR ASR 41 | 42 | %start payload 43 | %start commands 44 | 45 | %% 46 | 47 | (* Toplevel syntax *) 48 | 49 | (* If you're going to "optimize" this, please make sure we don't require ;; at the 50 | end of the file. *) 51 | commands: 52 | | EOF 53 | { [] } 54 | | cmd = command cmds = commands 55 | { cmd :: cmds } 56 | 57 | (* Things that can be defined on toplevel. *) 58 | command: mark_position(plain_command) { $1 } 59 | plain_command: 60 | | TYPE defs = separated_nonempty_list(AND, ty_def) 61 | { TyDef defs } 62 | | LET x = ident t = lambdas0(EQUAL) 63 | { TopLet (x, t) } 64 | | LET REC def = let_rec_def 65 | { let (f, t) = def in TopLetRec (f, t) } 66 | | RUN trm = term 67 | { TopDo trm } 68 | 69 | payload: 70 | | trm = term EOF 71 | { trm } 72 | 73 | (* Main syntax tree *) 74 | 75 | term: mark_position(plain_term) { $1 } 76 | plain_term: 77 | | MATCH t = term WITH cases = cases0(case) (* END *) 78 | { Match (t, cases) } 79 | | FUNCTION cases = cases(case) (* END *) 80 | { Function cases } 81 | | FUN t = lambdas1(ARROW) 82 | { t.it } 83 | | LET def = let_def IN t2 = term 84 | { let (p, t1) = def in Let (p, t1, t2) } 85 | | LET REC def = let_rec_def IN t2 = term 86 | { let (f, t1) = def in LetRec (f, t1, t2) } 87 | | t1 = term SEMI t2 = term 88 | { Let ({it= PNonbinding; at= t1.at}, t1, t2) } 89 | | IF t_cond = comma_term THEN t_true = term ELSE t_false = term 90 | { Conditional (t_cond, t_true, t_false) } 91 | | t = plain_comma_term 92 | { t } 93 | 94 | comma_term: mark_position(plain_comma_term) { $1 } 95 | plain_comma_term: 96 | | t = binop_term COMMA ts = separated_list(COMMA, binop_term) 97 | { Tuple (t :: ts) } 98 | | t = plain_binop_term 99 | { t } 100 | 101 | binop_term: mark_position(plain_binop_term) { $1 } 102 | plain_binop_term: 103 | | t1 = binop_term op = binop t2 = binop_term 104 | { Apply ({it= Apply ({it= Var op; at=Location.of_lexeme $startpos}, t1); at=Location.of_lexeme $startpos}, t2) } 105 | | t1 = binop_term CONS t2 = binop_term 106 | { let tuple = {it= Tuple [t1; t2]; at= Location.of_lexeme $startpos} in 107 | Variant (cons_label, Some tuple) } 108 | | t = plain_uminus_term 109 | { t } 110 | 111 | uminus_term: mark_position(plain_uminus_term) { $1 } 112 | plain_uminus_term: 113 | | MINUS t = uminus_term 114 | { let op_loc = Location.of_lexeme $startpos($1) in 115 | Apply ({it= Var "(~-)"; at= op_loc}, t) } 116 | | MINUSDOT t = uminus_term 117 | { let op_loc = Location.of_lexeme $startpos($1) in 118 | Apply ({it= Var "(~-.)"; at= op_loc}, t) } 119 | | t = plain_app_term 120 | { t } 121 | 122 | plain_app_term: 123 | | t = prefix_term ts = prefix_term+ 124 | { 125 | match t.it, ts with 126 | | Variant (lbl, None), [t] -> Variant (lbl, Some t) 127 | | Variant (lbl, _), _ -> Error.syntax ~loc:(t.at) "Label %s applied to too many argument" lbl 128 | | _, _ -> 129 | let apply t1 t2 = {it= Apply(t1, t2); at= t1.at} in 130 | (List.fold_left apply t ts).it 131 | } 132 | | t = plain_prefix_term 133 | { t } 134 | 135 | prefix_term: mark_position(plain_prefix_term) { $1 } 136 | plain_prefix_term: 137 | | op = prefixop t = simple_term 138 | { 139 | let op_loc = Location.of_lexeme $startpos(op) in 140 | Apply ({it= Var op; at= op_loc}, t) 141 | } 142 | | t = plain_simple_term 143 | { t } 144 | 145 | simple_term: mark_position(plain_simple_term) { $1 } 146 | plain_simple_term: 147 | | x = ident 148 | { Var x } 149 | | lbl = UNAME 150 | { Variant (lbl, None) } 151 | | cst = const 152 | { Const cst } 153 | | LBRACK ts = separated_list(SEMI, comma_term) RBRACK 154 | { 155 | let nil = {it= Variant (nil_label, None); at= Location.of_lexeme $endpos} in 156 | let cons t ts = 157 | let loc = t.at in 158 | let tuple = {it= Tuple [t; ts];at= loc} in 159 | {it= Variant (cons_label, Some tuple); at= loc} 160 | in 161 | (List.fold_right cons ts nil).it 162 | } 163 | | LPAREN RPAREN 164 | { Tuple [] } 165 | | LPAREN t = term COLON ty = ty RPAREN 166 | { Annotated (t, ty) } 167 | | LPAREN t = plain_term RPAREN 168 | { t } 169 | | BEGIN t = plain_term END 170 | { t } 171 | 172 | (* Auxilliary definitions *) 173 | 174 | const: 175 | | n = INT 176 | { Language.Const.of_integer n } 177 | | str = STRING 178 | { Language.Const.of_string str } 179 | | b = BOOL 180 | { Language.Const.of_boolean b } 181 | | f = FLOAT 182 | { Language.Const.of_float f } 183 | 184 | case: 185 | | p = pattern ARROW t = term 186 | { (p, t) } 187 | 188 | lambdas0(SEP): 189 | | SEP t = term 190 | { t } 191 | | p = simple_pattern t = lambdas0(SEP) 192 | { {it= Lambda (p, t); at= Location.of_lexeme $startpos} } 193 | | COLON ty = ty SEP t = term 194 | { {it= Annotated (t, ty); at= Location.of_lexeme $startpos} } 195 | 196 | lambdas1(SEP): 197 | | p = simple_pattern t = lambdas0(SEP) 198 | { {it= Lambda (p, t); at= Location.of_lexeme $startpos} } 199 | 200 | let_def: 201 | | p = pattern EQUAL t = term 202 | { (p, t) } 203 | | p = pattern COLON ty= ty EQUAL t = term 204 | { (p, {it= Annotated(t, ty); at= Location.of_lexeme $startpos}) } 205 | | x = mark_position(ident) t = lambdas1(EQUAL) 206 | { ({it= PVar x.it; at= x.at}, t) } 207 | 208 | let_rec_def: 209 | | f = ident t = lambdas0(EQUAL) 210 | { (f, t) } 211 | 212 | pattern: mark_position(plain_pattern) { $1 } 213 | plain_pattern: 214 | | p = comma_pattern 215 | { p.it } 216 | | p = pattern AS x = lname 217 | { PAs (p, x) } 218 | 219 | comma_pattern: mark_position(plain_comma_pattern) { $1 } 220 | plain_comma_pattern: 221 | | ps = separated_nonempty_list(COMMA, cons_pattern) 222 | { match ps with [p] -> p.it | ps -> PTuple ps } 223 | 224 | cons_pattern: mark_position(plain_cons_pattern) { $1 } 225 | plain_cons_pattern: 226 | | p = variant_pattern 227 | { p.it } 228 | | p1 = variant_pattern CONS p2 = cons_pattern 229 | { let ptuple = {it= PTuple [p1; p2]; at= Location.of_lexeme $startpos} in 230 | PVariant (cons_label, Some ptuple) } 231 | 232 | variant_pattern: mark_position(plain_variant_pattern) { $1 } 233 | plain_variant_pattern: 234 | | lbl = UNAME p = simple_pattern 235 | { PVariant (lbl, Some p) } 236 | | p = simple_pattern 237 | { p.it } 238 | 239 | simple_pattern: mark_position(plain_simple_pattern) { $1 } 240 | plain_simple_pattern: 241 | | x = ident 242 | { PVar x } 243 | | lbl = UNAME 244 | { PVariant (lbl, None) } 245 | | UNDERSCORE 246 | { PNonbinding } 247 | | cst = const 248 | { PConst cst } 249 | | LBRACK ts = separated_list(SEMI, pattern) RBRACK 250 | { 251 | let nil = {it= PVariant (nil_label, None);at= Location.of_lexeme $endpos} in 252 | let cons t ts = 253 | let loc = t.at in 254 | let tuple = {it= PTuple [t; ts]; at= loc} in 255 | {it= PVariant (cons_label, Some tuple); at= loc} 256 | in 257 | (List.fold_right cons ts nil).it 258 | } 259 | | LPAREN RPAREN 260 | { PTuple [] } 261 | | LPAREN p = pattern COLON t = ty RPAREN 262 | { PAnnotated (p, t) } 263 | | LPAREN p = pattern RPAREN 264 | { p.it } 265 | 266 | lname: 267 | | x = LNAME 268 | { x } 269 | 270 | tyname: 271 | | t = lname 272 | { t } 273 | 274 | ident: 275 | | x = lname 276 | { x } 277 | | LPAREN op = binop RPAREN 278 | { op } 279 | | LPAREN op = prefixop RPAREN 280 | { op } 281 | 282 | %inline binop: 283 | | op = binop_symbol 284 | { "(" ^ op ^ ")" } 285 | 286 | %inline binop_symbol: 287 | | OR 288 | { "or" } 289 | | BARBAR 290 | { "||" } 291 | | AMPER 292 | { "&" } 293 | | AMPERAMPER 294 | { "&&" } 295 | | op = INFIXOP0 296 | { op } 297 | | op = INFIXOP1 298 | { op } 299 | | op = INFIXOP2 300 | { op } 301 | | PLUS 302 | { "+" } 303 | | MINUSDOT 304 | { "-." } 305 | | MINUS 306 | { "-" } 307 | | EQUAL 308 | { "=" } 309 | | op = INFIXOP3 310 | { op } 311 | | STAR 312 | { "*" } 313 | | op = INFIXOP4 314 | { op } 315 | | MOD 316 | { "mod" } 317 | | LAND 318 | { "land" } 319 | | LOR 320 | { "lor" } 321 | | LXOR 322 | { "lxor" } 323 | | LSL 324 | { "lsl" } 325 | | LSR 326 | { "lsr" } 327 | | ASR 328 | { "asr" } 329 | 330 | %inline prefixop: 331 | | op = PREFIXOP 332 | { "(" ^ op ^ ")" } 333 | 334 | cases0(case): 335 | | BAR? cs = separated_list(BAR, case) 336 | { cs } 337 | 338 | cases(case): 339 | | BAR? cs = separated_nonempty_list(BAR, case) 340 | { cs } 341 | 342 | mark_position(X): 343 | x = X 344 | { {it= x; at= Location.of_lexeme $startpos}} 345 | 346 | params: 347 | | 348 | { [] } 349 | | p = PARAM 350 | { [p] } 351 | | LPAREN ps = separated_nonempty_list(COMMA, PARAM) RPAREN 352 | { ps } 353 | 354 | ty_def: 355 | | ps = params t = tyname EQUAL x = defined_ty 356 | { (ps, t, x) } 357 | 358 | defined_ty: 359 | | variants = cases(sum_case) 360 | { TySum variants } 361 | | t = ty 362 | { TyInline t } 363 | 364 | ty: mark_position(plain_ty) { $1 } 365 | plain_ty: 366 | | t1 = ty_apply ARROW t2 = ty 367 | { TyArrow (t1, t2) } 368 | | t = plain_prod_ty 369 | { t } 370 | 371 | plain_prod_ty: 372 | | ts = separated_nonempty_list(STAR, ty_apply) 373 | { 374 | match ts with 375 | | [] -> assert false 376 | | [t] -> t.it 377 | | _ -> TyTuple ts 378 | } 379 | 380 | ty_apply: mark_position(plain_ty_apply) { $1 } 381 | plain_ty_apply: 382 | | LPAREN t = ty COMMA ts = separated_nonempty_list(COMMA, ty) RPAREN t2 = tyname 383 | { TyApply (t2, (t :: ts)) } 384 | | t = ty_apply t2 = tyname 385 | { TyApply (t2, [t]) } 386 | | t = plain_simple_ty 387 | { t } 388 | 389 | plain_simple_ty: 390 | | t = tyname 391 | { TyApply (t, []) } 392 | | t = PARAM 393 | { TyParam t } 394 | | LPAREN t = ty RPAREN 395 | { t.it } 396 | 397 | sum_case: 398 | | lbl = UNAME 399 | { (lbl, None) } 400 | | lbl = UNAME OF t = ty 401 | { (lbl, Some t) } 402 | 403 | %% 404 | -------------------------------------------------------------------------------- /src/02-parser/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Grammar 3 | open Utils 4 | 5 | module StringMap = Map.Make (String) 6 | 7 | let reserved = StringMap.of_seq @@ List.to_seq [ 8 | ("and", AND); 9 | ("as", AS); 10 | ("asr", ASR); 11 | ("begin", BEGIN); 12 | ("else", ELSE); 13 | ("end", END); 14 | ("false", BOOL false); 15 | ("fun", FUN); 16 | ("function", FUNCTION); 17 | ("if", IF); 18 | ("in", IN); 19 | ("land", LAND); 20 | ("let", LET); 21 | ("lor", LOR); 22 | ("lsl", LSL); 23 | ("lsr", LSR); 24 | ("lxor", LXOR); 25 | ("match", MATCH); 26 | ("mod", MOD); 27 | ("of", OF); 28 | ("or", OR); 29 | ("rec", REC); 30 | ("run", RUN); 31 | ("then", THEN); 32 | ("true", BOOL true); 33 | ("type", TYPE); 34 | ("with", WITH); 35 | ] 36 | 37 | let escaped_characters = [ 38 | ("\"", "\""); 39 | ("\\", "\\"); 40 | ("\'", "'"); 41 | ("n", "\n"); 42 | ("t", "\t"); 43 | ("b", "\b"); 44 | ("r", "\r"); 45 | (" ", " "); 46 | ] 47 | 48 | } 49 | 50 | let lname = ( ['a'-'z'] ['_' 'a'-'z' 'A'-'Z' '0'-'9' '\'']* 51 | | ['_' 'a'-'z'] ['_' 'a'-'z' 'A'-'Z' '0'-'9' '\'']+) 52 | 53 | let uname = ['A'-'Z'] ['_' 'a'-'z' 'A'-'Z' '0'-'9' '\'']* 54 | 55 | let hexdig = ['0'-'9' 'a'-'f' 'A'-'F'] 56 | 57 | let int = ['0'-'9'] ['0'-'9' '_']* 58 | 59 | let xxxint = 60 | ( ("0x" | "0X") hexdig (hexdig | '_')* 61 | | ("0o" | "0O") ['0'-'7'] ['0'-'7' '_']* 62 | | ("0b" | "0B") ['0' '1'] ['0' '1' '_']*) 63 | 64 | let float = 65 | '-'? ['0'-'9'] ['0'-'9' '_']* 66 | (('.' ['0'-'9' '_']*) (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? | 67 | ('.' ['0'-'9' '_']*)? (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)) 68 | 69 | let operatorchar = ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '.' '<' '=' '>' '?' '@' '^' '|' '~'] 70 | 71 | let prefixop = ['~' '?' '!'] operatorchar* 72 | let infixop0 = ['=' '<' '>' '|' '&' '$'] operatorchar* 73 | let infixop1 = ['@' '^'] operatorchar* 74 | let infixop2 = ['+' '-'] operatorchar* 75 | let infixop3 = ['*' '/' '%'] operatorchar* 76 | let infixop4 = "**" operatorchar* 77 | 78 | rule token = parse 79 | | '\n' { Lexing.new_line lexbuf; token lexbuf } 80 | | [' ' '\r' '\t'] { token lexbuf } 81 | | "(*" { comment 0 lexbuf } 82 | | int { INT (int_of_string (Lexing.lexeme lexbuf)) } 83 | | xxxint { try 84 | INT (int_of_string (Lexing.lexeme lexbuf)) 85 | with Failure _ -> Error.syntax ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) "Invalid integer constant" 86 | } 87 | | float { FLOAT (float_of_string(Lexing.lexeme lexbuf)) } 88 | | '"' { STRING (string "" lexbuf) } 89 | | lname { let s = Lexing.lexeme lexbuf in 90 | match StringMap.find_opt s reserved with 91 | | Some t -> t 92 | | None -> LNAME s 93 | } 94 | | uname { UNAME (Lexing.lexeme lexbuf) } 95 | | '\'' lname { let str = Lexing.lexeme lexbuf in 96 | PARAM (String.sub str 1 (String.length str - 1)) } 97 | | '_' { UNDERSCORE } 98 | | '(' { LPAREN } 99 | | ')' { RPAREN } 100 | | '[' { LBRACK } 101 | | ']' { RBRACK } 102 | | "::" { CONS } 103 | | ':' { COLON } 104 | | ',' { COMMA } 105 | | '|' { BAR } 106 | | "||" { BARBAR } 107 | | ';' { SEMI } 108 | | "->" { ARROW } 109 | | '=' { EQUAL } 110 | | '*' { STAR } 111 | | '+' { PLUS } 112 | | '-' { MINUS } 113 | | "-." { MINUSDOT } 114 | | '&' { AMPER } 115 | | "&&" { AMPERAMPER } 116 | | prefixop { PREFIXOP(Lexing.lexeme lexbuf) } 117 | | ":=" { INFIXOP0(":=") } 118 | | infixop0 { INFIXOP0(Lexing.lexeme lexbuf) } 119 | | infixop1 { INFIXOP1(Lexing.lexeme lexbuf) } 120 | | infixop2 { INFIXOP2(Lexing.lexeme lexbuf) } 121 | (* infixop4 comes before infixop3 because ** would otherwise match infixop3 *) 122 | | infixop4 { INFIXOP4(Lexing.lexeme lexbuf) } 123 | | infixop3 { INFIXOP3(Lexing.lexeme lexbuf) } 124 | | eof { EOF } 125 | 126 | and comment n = parse 127 | | "*)" { if n = 0 then token lexbuf else comment (n - 1) lexbuf } 128 | | "(*" { comment (n + 1) lexbuf } 129 | | '\n' { Lexing.new_line lexbuf; comment n lexbuf } 130 | | _ { comment n lexbuf } 131 | | eof { Error.syntax ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) "Unterminated comment" } 132 | 133 | and string acc = parse 134 | | '"' { acc } 135 | | '\\' { let esc = escaped lexbuf in string (acc ^ esc) lexbuf } 136 | | [^'"' '\\']* { string (acc ^ (Lexing.lexeme lexbuf)) lexbuf } 137 | | eof { Error.syntax ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) "Unterminated string %s" acc} 138 | 139 | and escaped = parse 140 | | _ { let str = Lexing.lexeme lexbuf in 141 | try List.assoc str escaped_characters 142 | with Not_found -> Error.syntax ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) "Unknown escaped character %s" str 143 | } 144 | 145 | { 146 | let read_file parser fn = 147 | try 148 | let fh = open_in fn in 149 | let lex = Lexing.from_channel fh in 150 | lex.Lexing.lex_curr_p <- {lex.Lexing.lex_curr_p with Lexing.pos_fname = fn}; 151 | try 152 | let terms = parser lex in 153 | close_in fh; 154 | terms 155 | with 156 | (* Close the file in case of any parsing errors. *) 157 | Error.Error err -> close_in fh; raise (Error.Error err) 158 | with 159 | (* Any errors when opening or closing a file are fatal. *) 160 | Sys_error msg -> Error.fatal "%s" msg 161 | } 162 | -------------------------------------------------------------------------------- /src/02-parser/sugaredAst.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | 3 | type ty_name = string 4 | 5 | let bool_ty_name = "bool" 6 | let int_ty_name = "int" 7 | let unit_ty_name = "unit" 8 | let string_ty_name = "string" 9 | let float_ty_name = "float" 10 | let list_ty_name = "list" 11 | let empty_ty_name = "empty" 12 | 13 | type 'a annotated = { it : 'a; at : Location.t } 14 | type ty_param = string 15 | 16 | type ty = plain_ty annotated 17 | 18 | and plain_ty = 19 | | TyConst of Language.Const.ty 20 | | TyApply of ty_name * ty list (** [(ty1, ty2, ..., tyn) type_name] *) 21 | | TyParam of ty_param (** ['a] *) 22 | | TyArrow of ty * ty (** [ty1 -> ty2] *) 23 | | TyTuple of ty list (** [ty1 * ty2 * ... * tyn] *) 24 | 25 | type variable = string 26 | type label = string 27 | type operation = string 28 | 29 | let nil_label = Language.Ast.nil_label_string 30 | let cons_label = Language.Ast.cons_label_string 31 | 32 | type pattern = plain_pattern annotated 33 | 34 | and plain_pattern = 35 | | PVar of variable 36 | | PAnnotated of pattern * ty 37 | | PAs of pattern * variable 38 | | PTuple of pattern list 39 | | PVariant of label * pattern option 40 | | PConst of Language.Const.t 41 | | PNonbinding 42 | 43 | type term = plain_term annotated 44 | 45 | and plain_term = 46 | | Var of variable (** variables *) 47 | | Const of Language.Const.t (** integers, strings, booleans, and floats *) 48 | | Annotated of term * ty 49 | | Tuple of term list (** [(t1, t2, ..., tn)] *) 50 | | Variant of label * term option (** [Label] or [Label t] *) 51 | | Lambda of abstraction (** [fun p1 p2 ... pn -> t] *) 52 | | Function of abstraction list (** [function p1 -> t1 | ... | pn -> tn] *) 53 | | Let of pattern * term * term (** [let p = t1 in t2] *) 54 | | LetRec of variable * term * term (** [let rec f = t1 in t2] *) 55 | | Match of term * abstraction list 56 | (** [match t with p1 -> t1 | ... | pn -> tn] *) 57 | | Conditional of term * term * term (** [if t then t1 else t2] *) 58 | | Apply of term * term (** [t1 t2] *) 59 | 60 | and abstraction = pattern * term 61 | and guarded_abstraction = pattern * term option * term 62 | 63 | type ty_def = 64 | | TySum of (label * ty option) list 65 | (** [Label1 of ty1 | Label2 of ty2 | ... | Labeln of tyn | Label' | 66 | Label''] *) 67 | | TyInline of ty (** [ty] *) 68 | 69 | type command = plain_command annotated 70 | 71 | and plain_command = 72 | | TyDef of (ty_param list * ty_name * ty_def) list 73 | (** [type ('a...1) t1 = def1 and ... and ('a...n) tn = defn] *) 74 | | TopLet of variable * term (** [let x = t] *) 75 | | TopLetRec of variable * term (** [let rec f = t] *) 76 | | TopDo of term (** [do t] *) 77 | -------------------------------------------------------------------------------- /src/03-desugarer/desugarer.ml: -------------------------------------------------------------------------------- 1 | (** Desugaring of syntax into the core language. *) 2 | 3 | open Utils 4 | module Sugared = Parser.SugaredAst 5 | module Untyped = Language.Ast 6 | module Const = Language.Const 7 | module StringMap = Map.Make (String) 8 | 9 | let add_unique ~loc kind str symb string_map = 10 | StringMap.update str 11 | (function 12 | | None -> Some symb 13 | | Some _ -> Error.syntax ~loc "%s %s defined multiple times." kind str) 14 | string_map 15 | 16 | type state = { 17 | ty_names : Untyped.ty_name StringMap.t; 18 | ty_params : Untyped.ty_param StringMap.t; 19 | variables : Untyped.variable StringMap.t; 20 | labels : Untyped.label StringMap.t; 21 | } 22 | 23 | let initial_state = 24 | { 25 | ty_names = 26 | StringMap.empty 27 | |> StringMap.add Sugared.bool_ty_name Untyped.bool_ty_name 28 | |> StringMap.add Sugared.int_ty_name Untyped.int_ty_name 29 | |> StringMap.add Sugared.unit_ty_name Untyped.unit_ty_name 30 | |> StringMap.add Sugared.string_ty_name Untyped.string_ty_name 31 | |> StringMap.add Sugared.float_ty_name Untyped.float_ty_name 32 | |> StringMap.add Sugared.empty_ty_name Untyped.empty_ty_name 33 | |> StringMap.add Sugared.list_ty_name Untyped.list_ty_name; 34 | ty_params = StringMap.empty; 35 | variables = StringMap.empty; 36 | labels = 37 | StringMap.empty 38 | |> StringMap.add Sugared.nil_label Untyped.nil_label 39 | |> StringMap.add Sugared.cons_label Untyped.cons_label; 40 | } 41 | 42 | let find_symbol ~loc map name = 43 | match StringMap.find_opt name map with 44 | | None -> Error.syntax ~loc "Unknown name --%s--" name 45 | | Some symbol -> symbol 46 | 47 | let lookup_ty_name ~loc state = find_symbol ~loc state.ty_names 48 | let lookup_ty_param ~loc state = find_symbol ~loc state.ty_params 49 | let lookup_variable ~loc state = find_symbol ~loc state.variables 50 | let lookup_label ~loc state = find_symbol ~loc state.labels 51 | 52 | let rec desugar_ty state { Sugared.it = plain_ty; at = loc } = 53 | desugar_plain_ty ~loc state plain_ty 54 | 55 | and desugar_plain_ty ~loc state = function 56 | | Sugared.TyApply (ty_name, tys) -> 57 | let ty_name' = lookup_ty_name ~loc state ty_name in 58 | let tys' = List.map (desugar_ty state) tys in 59 | Untyped.TyApply (ty_name', tys') 60 | | Sugared.TyParam ty_param -> 61 | let ty_param' = lookup_ty_param ~loc state ty_param in 62 | Untyped.TyParam ty_param' 63 | | Sugared.TyArrow (ty1, ty2) -> 64 | let ty1' = desugar_ty state ty1 in 65 | let ty2' = desugar_ty state ty2 in 66 | Untyped.TyArrow (ty1', ty2') 67 | | Sugared.TyTuple tys -> 68 | let tys' = List.map (desugar_ty state) tys in 69 | Untyped.TyTuple tys' 70 | | Sugared.TyConst c -> Untyped.TyConst c 71 | 72 | let rec desugar_pattern state vars { Sugared.it = pat; at = loc } = 73 | let vars, pat' = desugar_plain_pattern ~loc state vars pat in 74 | (vars, pat') 75 | 76 | and desugar_plain_pattern ~loc state vars = function 77 | | Sugared.PVar x -> 78 | let x' = Untyped.Variable.fresh x in 79 | (StringMap.singleton x x', Untyped.PVar x') 80 | | Sugared.PAnnotated (pat, ty) -> 81 | let vars, pat' = desugar_pattern state vars pat 82 | and ty' = desugar_ty state ty in 83 | (vars, Untyped.PAnnotated (pat', ty')) 84 | | Sugared.PAs (pat, x) -> 85 | let vars, pat' = desugar_pattern state vars pat in 86 | let x' = Untyped.Variable.fresh x in 87 | (add_unique ~loc "Variable" x x' vars, Untyped.PAs (pat', x')) 88 | | Sugared.PTuple ps -> 89 | let aux p (vars, ps') = 90 | let vars', p' = desugar_pattern state vars p in 91 | (StringMap.fold (add_unique ~loc "Variable") vars' vars, p' :: ps') 92 | in 93 | let vars, ps' = List.fold_right aux ps (StringMap.empty, []) in 94 | (vars, Untyped.PTuple ps') 95 | | Sugared.PVariant (lbl, None) -> 96 | let lbl' = lookup_label ~loc state lbl in 97 | (StringMap.empty, Untyped.PVariant (lbl', None)) 98 | | Sugared.PVariant (lbl, Some pat) -> 99 | let lbl' = lookup_label ~loc state lbl in 100 | let vars, pat' = desugar_pattern state vars pat in 101 | (vars, Untyped.PVariant (lbl', Some pat')) 102 | | Sugared.PConst c -> (StringMap.empty, Untyped.PConst c) 103 | | Sugared.PNonbinding -> (StringMap.empty, Untyped.PNonbinding) 104 | 105 | let add_fresh_variables state vars = 106 | let aux x x' variables = StringMap.add x x' variables in 107 | let variables' = StringMap.fold aux vars state.variables in 108 | { state with variables = variables' } 109 | 110 | let rec desugar_expression state { Sugared.it = term; at = loc } = 111 | let binds, expr = desugar_plain_expression ~loc state term in 112 | (binds, expr) 113 | 114 | and desugar_plain_expression ~loc state = function 115 | | Sugared.Var x -> 116 | let x' = lookup_variable ~loc state x in 117 | ([], Untyped.Var x') 118 | | Sugared.Const k -> ([], Untyped.Const k) 119 | | Sugared.Annotated (term, ty) -> 120 | let binds, expr = desugar_expression state term in 121 | let ty' = desugar_ty state ty in 122 | (binds, Untyped.Annotated (expr, ty')) 123 | | Sugared.Lambda a -> 124 | let a' = desugar_abstraction state a in 125 | ([], Untyped.Lambda a') 126 | | Sugared.Function cases -> 127 | let x = Untyped.Variable.fresh "arg" in 128 | let cases' = List.map (desugar_abstraction state) cases in 129 | ( [], 130 | Untyped.Lambda (Untyped.PVar x, Untyped.Match (Untyped.Var x, cases')) 131 | ) 132 | | Sugared.Tuple ts -> 133 | let binds, es = desugar_expressions state ts in 134 | (binds, Untyped.Tuple es) 135 | | Sugared.Variant (lbl, None) -> 136 | let lbl' = lookup_label ~loc state lbl in 137 | ([], Untyped.Variant (lbl', None)) 138 | | Sugared.Variant (lbl, Some term) -> 139 | let lbl' = lookup_label ~loc state lbl in 140 | let binds, expr = desugar_expression state term in 141 | (binds, Untyped.Variant (lbl', Some expr)) 142 | | ( Sugared.Apply _ | Sugared.Match _ | Sugared.Let _ | Sugared.LetRec _ 143 | | Sugared.Conditional _ ) as term -> 144 | let x = Untyped.Variable.fresh "b" in 145 | let comp = desugar_computation state { Sugared.it = term; at = loc } in 146 | let hoist = (Untyped.PVar x, comp) in 147 | ([ hoist ], Untyped.Var x) 148 | 149 | and desugar_computation state { Sugared.it = term; at = loc } = 150 | let binds, comp = desugar_plain_computation ~loc state term in 151 | List.fold_right (fun (p, c1) c2 -> Untyped.Do (c1, (p, c2))) binds comp 152 | 153 | and desugar_plain_computation ~loc state = 154 | let if_then_else e c1 c2 = 155 | let true_p = Untyped.PConst Const.of_true in 156 | let false_p = Untyped.PConst Const.of_false in 157 | Untyped.Match (e, [ (true_p, c1); (false_p, c2) ]) 158 | in 159 | function 160 | | Sugared.Apply 161 | ({ it = Sugared.Var "(&&)"; _ }, { it = Sugared.Tuple [ t1; t2 ]; _ }) -> 162 | let binds1, e1 = desugar_expression state t1 in 163 | let c1 = desugar_computation state t2 in 164 | let c2 = Untyped.Return (Untyped.Const (Const.Boolean false)) in 165 | (binds1, if_then_else e1 c1 c2) 166 | | Sugared.Apply 167 | ({ it = Sugared.Var "(||)"; _ }, { it = Sugared.Tuple [ t1; t2 ]; _ }) -> 168 | let binds1, e1 = desugar_expression state t1 in 169 | let c1 = Untyped.Return (Untyped.Const (Const.Boolean true)) in 170 | let c2 = desugar_computation state t2 in 171 | (binds1, if_then_else e1 c1 c2) 172 | | Sugared.Apply (t1, t2) -> 173 | let binds1, e1 = desugar_expression state t1 in 174 | let binds2, e2 = desugar_expression state t2 in 175 | (binds1 @ binds2, Untyped.Apply (e1, e2)) 176 | | Sugared.Match (t, cs) -> 177 | let binds, e = desugar_expression state t in 178 | let cs' = List.map (desugar_abstraction state) cs in 179 | (binds, Untyped.Match (e, cs')) 180 | | Sugared.Conditional (t, t1, t2) -> 181 | let binds, e = desugar_expression state t in 182 | let c1 = desugar_computation state t1 in 183 | let c2 = desugar_computation state t2 in 184 | (binds, if_then_else e c1 c2) 185 | | Sugared.Let (pat, term1, term2) -> 186 | let c1 = desugar_computation state term1 in 187 | let c2 = desugar_abstraction state (pat, term2) in 188 | ([], Untyped.Do (c1, c2)) 189 | | Sugared.LetRec (x, term1, term2) -> 190 | let state', f, comp1 = desugar_let_rec_def state (x, term1) in 191 | let c = desugar_computation state' term2 in 192 | ([], Untyped.Do (Untyped.Return comp1, (Untyped.PVar f, c))) 193 | (* The remaining cases are expressions, which we list explicitly to catch any 194 | future changeSugared. *) 195 | | ( Sugared.Var _ | Sugared.Const _ | Sugared.Annotated _ | Sugared.Tuple _ 196 | | Sugared.Variant _ | Sugared.Lambda _ | Sugared.Function _ ) as term -> 197 | let binds, expr = desugar_expression state { it = term; at = loc } in 198 | (binds, Untyped.Return expr) 199 | 200 | and desugar_abstraction state (pat, term) = 201 | let vars, pat' = desugar_pattern state StringMap.empty pat in 202 | let state' = add_fresh_variables state vars in 203 | let comp = desugar_computation state' term in 204 | (pat', comp) 205 | 206 | and desugar_guarded_abstraction state (pat, term1, term2) = 207 | let vars, pat' = desugar_pattern state StringMap.empty pat in 208 | let state' = add_fresh_variables state vars in 209 | let comp1 = desugar_computation state' term1 210 | and comp2 = desugar_computation state' term2 in 211 | (pat', comp1, comp2) 212 | 213 | and desugar_promise_abstraction ~loc state abs2 = 214 | match desugar_abstraction state abs2 with 215 | | Untyped.PVar p, comp' -> (p, comp') 216 | | Untyped.PNonbinding, comp' -> 217 | let p = Untyped.Variable.fresh "_" in 218 | (p, comp') 219 | | _ -> Error.syntax ~loc "Variable or underscore expected" 220 | 221 | and desugar_let_rec_def state (f, { it = exp; at = loc }) = 222 | let f' = Untyped.Variable.fresh f in 223 | let state' = add_fresh_variables state (StringMap.singleton f f') in 224 | let abs' = 225 | match exp with 226 | | Sugared.Lambda a -> desugar_abstraction state' a 227 | | Sugared.Function cs -> 228 | let x = Untyped.Variable.fresh "rf" in 229 | let cs = List.map (desugar_abstraction state') cs in 230 | let new_match = Untyped.Match (Untyped.Var x, cs) in 231 | (Untyped.PVar x, new_match) 232 | | _ -> 233 | Error.syntax ~loc 234 | "This kind of expression is not allowed in a recursive definition" 235 | in 236 | let expr = Untyped.RecLambda (f', abs') in 237 | (state', f', expr) 238 | 239 | and desugar_expressions state = function 240 | | [] -> ([], []) 241 | | t :: ts -> 242 | let binds, e = desugar_expression state t in 243 | let ws, es = desugar_expressions state ts in 244 | (binds @ ws, e :: es) 245 | 246 | let desugar_pure_expression state term = 247 | let binds, expr = desugar_expression state term in 248 | match binds with 249 | | [] -> expr 250 | | _ -> Error.syntax ~loc:term.at "Only pure expressions are allowed" 251 | 252 | let add_label ~loc state label label' = 253 | let labels' = add_unique ~loc "Label" label label' state.labels in 254 | { state with labels = labels' } 255 | 256 | let add_fresh_ty_names ~loc state vars = 257 | let aux ty_names (x, x') = add_unique ~loc "Type" x x' ty_names in 258 | let ty_names' = List.fold_left aux state.ty_names vars in 259 | { state with ty_names = ty_names' } 260 | 261 | let add_fresh_ty_params state vars = 262 | let aux ty_params (x, x') = StringMap.add x x' ty_params in 263 | let ty_params' = List.fold_left aux state.ty_params vars in 264 | { state with ty_params = ty_params' } 265 | 266 | let desugar_ty_def ~loc state = function 267 | | Sugared.TyInline ty -> (state, Untyped.TyInline (desugar_ty state ty)) 268 | | Sugared.TySum variants -> 269 | let aux state (label, ty) = 270 | let label' = Untyped.Label.fresh label in 271 | let ty' = Option.map (desugar_ty state) ty in 272 | let state' = add_label ~loc state label label' in 273 | (state', (label', ty')) 274 | in 275 | let state', variants' = List.fold_map aux state variants in 276 | (state', Untyped.TySum variants') 277 | 278 | let desugar_command state { Sugared.it = cmd; at = loc } = 279 | match cmd with 280 | | Sugared.TyDef defs -> 281 | let def_name (_, ty_name, _) = 282 | let ty_name' = Untyped.TyName.fresh ty_name in 283 | (ty_name, ty_name') 284 | in 285 | let new_names = List.map def_name defs in 286 | let state' = add_fresh_ty_names ~loc state new_names in 287 | let aux (params, _, ty_def) (_, ty_name') (state', defs) = 288 | let params' = List.map (fun a -> (a, Untyped.TyParam.fresh a)) params in 289 | let state'' = add_fresh_ty_params state' params' in 290 | let state''', ty_def' = desugar_ty_def ~loc state'' ty_def in 291 | (state''', (List.map snd params', ty_name', ty_def') :: defs) 292 | in 293 | let state'', defs' = List.fold_right2 aux defs new_names (state', []) in 294 | (state'', Untyped.TyDef defs') 295 | | Sugared.TopLet (x, term) -> 296 | let x' = Untyped.Variable.fresh x in 297 | let state' = add_fresh_variables state (StringMap.singleton x x') in 298 | let expr = desugar_pure_expression state' term in 299 | (state', Untyped.TopLet (x', expr)) 300 | | Sugared.TopDo term -> 301 | let comp = desugar_computation state term in 302 | (state, Untyped.TopDo comp) 303 | | Sugared.TopLetRec (f, term) -> 304 | let state', f, expr = desugar_let_rec_def state (f, term) in 305 | (state', Untyped.TopLet (f, expr)) 306 | 307 | let load_primitive state x prim = 308 | let str = Language.Primitives.primitive_name prim in 309 | add_fresh_variables state (StringMap.singleton str x) 310 | -------------------------------------------------------------------------------- /src/03-desugarer/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name desugarer) 3 | (libraries parser)) 4 | -------------------------------------------------------------------------------- /src/04-typechecker/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name typechecker) 3 | (libraries language)) 4 | -------------------------------------------------------------------------------- /src/04-typechecker/primitives.ml: -------------------------------------------------------------------------------- 1 | module Ast = Language.Ast 2 | module Const = Language.Const 3 | module Primitives = Language.Primitives 4 | 5 | let poly_type ty = 6 | let a = Ast.TyParam.fresh "poly" in 7 | ([ a ], ty (Ast.TyParam a)) 8 | 9 | let unary_integer_op_ty = 10 | ([], Ast.TyArrow (Ast.TyConst Const.IntegerTy, Ast.TyConst Const.IntegerTy)) 11 | 12 | let binary_integer_op_ty = 13 | ( [], 14 | Ast.TyArrow 15 | ( Ast.TyTuple [ Ast.TyConst Const.IntegerTy; Ast.TyConst Const.IntegerTy ], 16 | Ast.TyConst Const.IntegerTy ) ) 17 | 18 | let unary_float_op_ty = 19 | ([], Ast.TyArrow (Ast.TyConst Const.FloatTy, Ast.TyConst Const.FloatTy)) 20 | 21 | let binary_float_op_ty = 22 | ( [], 23 | Ast.TyArrow 24 | ( Ast.TyTuple [ Ast.TyConst Const.FloatTy; Ast.TyConst Const.FloatTy ], 25 | Ast.TyConst Const.FloatTy ) ) 26 | 27 | let comparison_ty = 28 | poly_type (fun a -> 29 | Ast.TyArrow (Ast.TyTuple [ a; a ], Ast.TyConst Const.BooleanTy)) 30 | 31 | let primitive_type_scheme = function 32 | | Primitives.CompareEq -> comparison_ty 33 | | Primitives.CompareLt -> comparison_ty 34 | | Primitives.CompareGt -> comparison_ty 35 | | Primitives.CompareLe -> comparison_ty 36 | | Primitives.CompareGe -> comparison_ty 37 | | Primitives.CompareNe -> comparison_ty 38 | | Primitives.IntegerAdd -> binary_integer_op_ty 39 | | Primitives.IntegerMul -> binary_integer_op_ty 40 | | Primitives.IntegerSub -> binary_integer_op_ty 41 | | Primitives.IntegerDiv -> binary_integer_op_ty 42 | | Primitives.IntegerMod -> binary_integer_op_ty 43 | | Primitives.IntegerNeg -> unary_integer_op_ty 44 | | Primitives.FloatAdd -> binary_float_op_ty 45 | | Primitives.FloatMul -> binary_float_op_ty 46 | | Primitives.FloatSub -> binary_float_op_ty 47 | | Primitives.FloatDiv -> binary_float_op_ty 48 | | Primitives.FloatPow -> binary_float_op_ty 49 | | Primitives.FloatNeg -> unary_float_op_ty 50 | | Primitives.ToString -> 51 | poly_type (fun a -> Ast.TyArrow (a, Ast.TyConst Const.StringTy)) 52 | -------------------------------------------------------------------------------- /src/04-typechecker/typechecker.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Language.Ast 3 | module Const = Language.Const 4 | 5 | type state = { 6 | variables : (Ast.ty_param list * Ast.ty) Ast.VariableMap.t; 7 | type_definitions : (Ast.ty_param list * Ast.ty_def) Ast.TyNameMap.t; 8 | } 9 | 10 | let initial_state = 11 | { 12 | variables = Ast.VariableMap.empty; 13 | type_definitions = 14 | (Ast.TyNameMap.empty 15 | |> Ast.TyNameMap.add Ast.bool_ty_name 16 | ([], Ast.TyInline (Ast.TyConst Const.BooleanTy)) 17 | |> Ast.TyNameMap.add Ast.int_ty_name 18 | ([], Ast.TyInline (Ast.TyConst Const.IntegerTy)) 19 | |> Ast.TyNameMap.add Ast.unit_ty_name ([], Ast.TyInline (Ast.TyTuple [])) 20 | |> Ast.TyNameMap.add Ast.string_ty_name 21 | ([], Ast.TyInline (Ast.TyConst Const.StringTy)) 22 | |> Ast.TyNameMap.add Ast.float_ty_name 23 | ([], Ast.TyInline (Ast.TyConst Const.FloatTy)) 24 | |> Ast.TyNameMap.add Ast.empty_ty_name ([], Ast.TySum []) 25 | |> 26 | let a = Ast.TyParam.fresh "list" in 27 | Ast.TyNameMap.add Ast.list_ty_name 28 | ( [ a ], 29 | Ast.TySum 30 | [ 31 | (Ast.nil_label, None); 32 | ( Ast.cons_label, 33 | Some 34 | (Ast.TyTuple 35 | [ 36 | Ast.TyParam a; 37 | Ast.TyApply (Ast.list_ty_name, [ Ast.TyParam a ]); 38 | ]) ); 39 | ] )); 40 | } 41 | 42 | let rec check_ty state = function 43 | | Ast.TyConst _ -> () 44 | | TyApply (ty_name, tys) -> 45 | let params, _ = Ast.TyNameMap.find ty_name state.type_definitions in 46 | let expected, actual = (List.length params, List.length tys) in 47 | if expected <> actual then 48 | Error.typing "Type %t expects %d arguments but got %d." 49 | (Ast.TyName.print ty_name) expected actual 50 | else List.iter (check_ty state) tys 51 | | TyParam _ -> () 52 | | TyArrow (ty1, ty2) -> 53 | check_ty state ty1; 54 | check_ty state ty2 55 | | TyTuple tys -> List.iter (check_ty state) tys 56 | 57 | let check_variant state (_label, arg_ty) = 58 | match arg_ty with None -> () | Some ty -> check_ty state ty 59 | 60 | let check_ty_def state = function 61 | | Ast.TySum defs -> List.iter (check_variant state) defs 62 | | Ast.TyInline ty -> check_ty state ty 63 | 64 | let fresh_ty () = 65 | let a = Ast.TyParam.fresh "ty" in 66 | Ast.TyParam a 67 | 68 | let extend_variables state vars = 69 | List.fold_left 70 | (fun state (x, ty) -> 71 | { state with variables = Ast.VariableMap.add x ([], ty) state.variables }) 72 | state vars 73 | 74 | let refreshing_subst params = 75 | List.fold_left 76 | (fun subst param -> 77 | let ty = fresh_ty () in 78 | Ast.TyParamMap.add param ty subst) 79 | Ast.TyParamMap.empty params 80 | 81 | let infer_variant state lbl = 82 | let rec find = function 83 | | [] -> assert false 84 | | (_, (_, Ast.TyInline _)) :: ty_defs -> find ty_defs 85 | | (ty_name, (params, Ast.TySum variants)) :: ty_defs -> ( 86 | match List.assoc_opt lbl variants with 87 | | None -> find ty_defs 88 | | Some ty -> (ty_name, params, ty)) 89 | in 90 | let ty_name, params, ty = 91 | find (Ast.TyNameMap.bindings state.type_definitions) 92 | in 93 | let subst = refreshing_subst params in 94 | let args = List.map (fun param -> Ast.TyParamMap.find param subst) params 95 | and ty' = Option.map (Ast.substitute_ty subst) ty in 96 | (ty', Ast.TyApply (ty_name, args)) 97 | 98 | let rec infer_pattern state = function 99 | | Ast.PVar x -> 100 | let ty = fresh_ty () in 101 | (ty, [ (x, ty) ], []) 102 | | Ast.PAs (pat, x) -> 103 | let ty, vars, eqs = infer_pattern state pat in 104 | (ty, (x, ty) :: vars, eqs) 105 | | Ast.PAnnotated (pat, ty) -> 106 | let ty', vars, eqs = infer_pattern state pat in 107 | (ty, vars, (ty, ty') :: eqs) 108 | | Ast.PConst c -> (Ast.TyConst (Const.infer_ty c), [], []) 109 | | Ast.PNonbinding -> 110 | let ty = fresh_ty () in 111 | (ty, [], []) 112 | | Ast.PTuple pats -> 113 | let fold pat (tys, vars, eqs) = 114 | let ty', vars', eqs' = infer_pattern state pat in 115 | (ty' :: tys, vars' @ vars, eqs' @ eqs) 116 | in 117 | let tys, vars, eqs = List.fold_right fold pats ([], [], []) in 118 | (Ast.TyTuple tys, vars, eqs) 119 | | Ast.PVariant (lbl, pat) -> ( 120 | let ty_in, ty_out = infer_variant state lbl in 121 | match (ty_in, pat) with 122 | | None, None -> (ty_out, [], []) 123 | | Some ty_in, Some pat -> 124 | let ty, vars, eqs = infer_pattern state pat in 125 | (ty_out, vars, (ty_in, ty) :: eqs) 126 | | None, Some _ | Some _, None -> 127 | Error.typing "Variant optional argument mismatch") 128 | 129 | let rec infer_expression state = function 130 | | Ast.Var x -> 131 | let params, ty = Ast.VariableMap.find x state.variables in 132 | let subst = refreshing_subst params in 133 | (Ast.substitute_ty subst ty, []) 134 | | Ast.Const c -> (Ast.TyConst (Const.infer_ty c), []) 135 | | Ast.Annotated (expr, ty) -> 136 | let ty', eqs = infer_expression state expr in 137 | (ty, (ty, ty') :: eqs) 138 | | Ast.Tuple exprs -> 139 | let fold expr (tys, eqs) = 140 | let ty', eqs' = infer_expression state expr in 141 | (ty' :: tys, eqs' @ eqs) 142 | in 143 | let tys, eqs = List.fold_right fold exprs ([], []) in 144 | (Ast.TyTuple tys, eqs) 145 | | Ast.Lambda abs -> 146 | let ty, ty', eqs = infer_abstraction state abs in 147 | (Ast.TyArrow (ty, ty'), eqs) 148 | | Ast.RecLambda (f, abs) -> 149 | let f_ty = fresh_ty () in 150 | let state' = extend_variables state [ (f, f_ty) ] in 151 | let ty, ty', eqs = infer_abstraction state' abs in 152 | let out_ty = Ast.TyArrow (ty, ty') in 153 | (out_ty, (f_ty, out_ty) :: eqs) 154 | | Ast.Variant (lbl, expr) -> ( 155 | let ty_in, ty_out = infer_variant state lbl in 156 | match (ty_in, expr) with 157 | | None, None -> (ty_out, []) 158 | | Some ty_in, Some expr -> 159 | let ty, eqs = infer_expression state expr in 160 | (ty_out, (ty_in, ty) :: eqs) 161 | | None, Some _ | Some _, None -> 162 | Error.typing "Variant optional argument mismatch") 163 | 164 | and infer_computation state = function 165 | | Ast.Return expr -> 166 | let ty, eqs = infer_expression state expr in 167 | (ty, eqs) 168 | | Ast.Do (comp1, comp2) -> 169 | let ty1, eqs1 = infer_computation state comp1 in 170 | let ty1', ty2, eqs2 = infer_abstraction state comp2 in 171 | (ty2, ((ty1, ty1') :: eqs1) @ eqs2) 172 | | Ast.Apply (e1, e2) -> 173 | let t1, eqs1 = infer_expression state e1 174 | and t2, eqs2 = infer_expression state e2 175 | and a = fresh_ty () in 176 | (a, ((t1, Ast.TyArrow (t2, a)) :: eqs1) @ eqs2) 177 | | Ast.Match (e, cases) -> 178 | let ty1, eqs = infer_expression state e and ty2 = fresh_ty () in 179 | let fold eqs abs = 180 | let ty1', ty2', eqs' = infer_abstraction state abs in 181 | ((ty1, ty1') :: (ty2, ty2') :: eqs') @ eqs 182 | in 183 | (ty2, List.fold_left fold eqs cases) 184 | 185 | and infer_abstraction state (pat, comp) = 186 | let ty, vars, eqs = infer_pattern state pat in 187 | let state' = extend_variables state vars in 188 | let ty', eqs' = infer_computation state' comp in 189 | (ty, ty', eqs @ eqs') 190 | 191 | let subst_equations sbst = 192 | let subst_equation (t1, t2) = 193 | (Ast.substitute_ty sbst t1, Ast.substitute_ty sbst t2) 194 | in 195 | List.map subst_equation 196 | 197 | let add_subst a t sbst = Ast.TyParamMap.add a (Ast.substitute_ty sbst t) sbst 198 | 199 | let rec occurs a = function 200 | | Ast.TyParam a' -> a = a' 201 | | Ast.TyConst _ -> false 202 | | Ast.TyArrow (ty1, ty2) -> occurs a ty1 || occurs a ty2 203 | | Ast.TyApply (_, tys) -> List.exists (occurs a) tys 204 | | Ast.TyTuple tys -> List.exists (occurs a) tys 205 | 206 | let is_transparent_type state ty_name = 207 | match Ast.TyNameMap.find ty_name state.type_definitions with 208 | | _, Ast.TySum _ -> false 209 | | _, Ast.TyInline _ -> true 210 | 211 | let unfold state ty_name args = 212 | match Ast.TyNameMap.find ty_name state.type_definitions with 213 | | _, Ast.TySum _ -> assert false 214 | | params, Ast.TyInline ty -> 215 | let subst = 216 | List.combine params args |> List.to_seq |> Ast.TyParamMap.of_seq 217 | in 218 | Ast.substitute_ty subst ty 219 | 220 | let rec unify state = function 221 | | [] -> Ast.TyParamMap.empty 222 | | (t1, t2) :: eqs when t1 = t2 -> unify state eqs 223 | | (Ast.TyApply (ty_name1, args1), Ast.TyApply (ty_name2, args2)) :: eqs 224 | when ty_name1 = ty_name2 -> 225 | unify state (List.combine args1 args2 @ eqs) 226 | | (Ast.TyApply (ty_name, args), ty) :: eqs 227 | when is_transparent_type state ty_name -> 228 | unify state ((unfold state ty_name args, ty) :: eqs) 229 | | (ty, Ast.TyApply (ty_name, args)) :: eqs 230 | when is_transparent_type state ty_name -> 231 | unify state ((ty, unfold state ty_name args) :: eqs) 232 | | (Ast.TyTuple tys1, Ast.TyTuple tys2) :: eqs 233 | when List.length tys1 = List.length tys2 -> 234 | unify state (List.combine tys1 tys2 @ eqs) 235 | | (Ast.TyArrow (t1, t1'), Ast.TyArrow (t2, t2')) :: eqs -> 236 | unify state ((t1, t2) :: (t1', t2') :: eqs) 237 | | (Ast.TyParam a, t) :: eqs when not (occurs a t) -> 238 | add_subst a t 239 | (unify state (subst_equations (Ast.TyParamMap.singleton a t) eqs)) 240 | | (t, Ast.TyParam a) :: eqs when not (occurs a t) -> 241 | add_subst a t 242 | (unify state (subst_equations (Ast.TyParamMap.singleton a t) eqs)) 243 | | (t1, t2) :: _ -> 244 | let print_param = Ast.new_print_param () in 245 | Error.typing "Cannot unify %t = %t" 246 | (Ast.print_ty print_param t1) 247 | (Ast.print_ty print_param t2) 248 | 249 | let infer state e = 250 | let t, eqs = infer_computation state e in 251 | let sbst = unify state eqs in 252 | let t' = Ast.substitute_ty sbst t in 253 | t' 254 | 255 | let add_external_function x ty_sch state = 256 | { state with variables = Ast.VariableMap.add x ty_sch state.variables } 257 | 258 | let add_top_definition state x expr = 259 | let ty, eqs = infer_expression state expr in 260 | let subst = unify state eqs in 261 | let ty' = Ast.substitute_ty subst ty in 262 | let free_vars = Ast.free_vars ty' |> Ast.TyParamSet.elements in 263 | let ty_sch = (free_vars, ty') in 264 | add_external_function x ty_sch state 265 | 266 | let add_type_definitions state ty_defs = 267 | let state' = 268 | List.fold_left 269 | (fun state (params, ty_name, ty_def) -> 270 | { 271 | state with 272 | type_definitions = 273 | Ast.TyNameMap.add ty_name (params, ty_def) state.type_definitions; 274 | }) 275 | state ty_defs 276 | in 277 | List.iter (fun (_, _, ty_def) -> check_ty_def state' ty_def) ty_defs; 278 | state' 279 | 280 | let load_primitive state x prim = 281 | let ty_sch = Primitives.primitive_type_scheme prim in 282 | add_external_function x ty_sch state 283 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/cli/cliInterpreter.ml: -------------------------------------------------------------------------------- 1 | include Interpreter 2 | 3 | let view_run_state (run_state : Interpreter.run_state) = 4 | match run_state with 5 | | { computations = Ast.Return exp :: _; _ } -> 6 | Format.printf "return %t@." (Ast.print_expression ~max_level:0 exp) 7 | | _ -> () 8 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/cli/cliInterpreter.mli: -------------------------------------------------------------------------------- 1 | include CliBackend.S 2 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/cli/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cliInterpreter) 3 | (libraries cliBackend interpreter)) 4 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name interpreter) 3 | (libraries language)) 4 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/core/interpreter.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Language.Ast 3 | module Const = Language.Const 4 | 5 | type environment = { 6 | variables : Ast.expression Ast.VariableMap.t; 7 | builtin_functions : (Ast.expression -> Ast.computation) Ast.VariableMap.t; 8 | } 9 | 10 | let initial_environment = 11 | { 12 | variables = Ast.VariableMap.empty; 13 | builtin_functions = Ast.VariableMap.empty; 14 | } 15 | 16 | exception PatternMismatch 17 | 18 | type computation_redex = Match | ApplyFun | DoReturn 19 | 20 | type computation_reduction = 21 | | DoCtx of computation_reduction 22 | | ComputationRedex of computation_redex 23 | 24 | let rec eval_tuple env = function 25 | | Ast.Tuple exprs -> exprs 26 | | Ast.Var x -> eval_tuple env (Ast.VariableMap.find x env.variables) 27 | | expr -> 28 | Error.runtime "Tuple expected but got %t" (Ast.print_expression expr) 29 | 30 | let rec eval_variant env = function 31 | | Ast.Variant (lbl, expr) -> (lbl, expr) 32 | | Ast.Var x -> eval_variant env (Ast.VariableMap.find x env.variables) 33 | | expr -> 34 | Error.runtime "Variant expected but got %t" (Ast.print_expression expr) 35 | 36 | let rec eval_const env = function 37 | | Ast.Const c -> c 38 | | Ast.Var x -> eval_const env (Ast.VariableMap.find x env.variables) 39 | | expr -> 40 | Error.runtime "Const expected but got %t" (Ast.print_expression expr) 41 | 42 | let rec match_pattern_with_expression env pat expr = 43 | match pat with 44 | | Ast.PVar x -> Ast.VariableMap.singleton x expr 45 | | Ast.PAnnotated (pat, _) -> match_pattern_with_expression env pat expr 46 | | Ast.PAs (pat, x) -> 47 | let subst = match_pattern_with_expression env pat expr in 48 | Ast.VariableMap.add x expr subst 49 | | Ast.PTuple pats -> 50 | let exprs = eval_tuple env expr in 51 | List.fold_left2 52 | (fun subst pat expr -> 53 | let subst' = match_pattern_with_expression env pat expr in 54 | Ast.VariableMap.union (fun _ _ _ -> assert false) subst subst') 55 | Ast.VariableMap.empty pats exprs 56 | | Ast.PVariant (label, pat) -> ( 57 | match (pat, eval_variant env expr) with 58 | | None, (label', None) when label = label' -> Ast.VariableMap.empty 59 | | Some pat, (label', Some expr) when label = label' -> 60 | match_pattern_with_expression env pat expr 61 | | _, _ -> raise PatternMismatch) 62 | | Ast.PConst c when Const.equal c (eval_const env expr) -> 63 | Ast.VariableMap.empty 64 | | Ast.PNonbinding -> Ast.VariableMap.empty 65 | | _ -> raise PatternMismatch 66 | 67 | let rec remove_pattern_bound_variables subst = function 68 | | Ast.PVar x -> Ast.VariableMap.remove x subst 69 | | Ast.PAnnotated (pat, _) -> remove_pattern_bound_variables subst pat 70 | | Ast.PAs (pat, x) -> 71 | let subst = remove_pattern_bound_variables subst pat in 72 | Ast.VariableMap.remove x subst 73 | | Ast.PTuple pats -> List.fold_left remove_pattern_bound_variables subst pats 74 | | Ast.PVariant (_, None) -> subst 75 | | Ast.PVariant (_, Some pat) -> remove_pattern_bound_variables subst pat 76 | | Ast.PConst _ -> subst 77 | | Ast.PNonbinding -> subst 78 | 79 | let rec refresh_pattern = function 80 | | Ast.PVar x -> 81 | let x' = Ast.Variable.refresh x in 82 | (Ast.PVar x', [ (x, x') ]) 83 | | Ast.PAnnotated (pat, _) -> refresh_pattern pat 84 | | Ast.PAs (pat, x) -> 85 | let pat', vars = refresh_pattern pat in 86 | let x' = Ast.Variable.refresh x in 87 | (Ast.PAs (pat', x'), (x, x') :: vars) 88 | | Ast.PTuple pats -> 89 | let fold pat (pats', vars) = 90 | let pat', vars' = refresh_pattern pat in 91 | (pat' :: pats', vars' @ vars) 92 | in 93 | let pats', vars = List.fold_right fold pats ([], []) in 94 | (Ast.PTuple pats', vars) 95 | | Ast.PVariant (lbl, Some pat) -> 96 | let pat', vars = refresh_pattern pat in 97 | (PVariant (lbl, Some pat'), vars) 98 | | (PVariant (_, None) | PConst _ | PNonbinding) as pat -> (pat, []) 99 | 100 | let rec refresh_expression vars = function 101 | | Ast.Var x as expr -> ( 102 | match List.assoc_opt x vars with None -> expr | Some x' -> Var x') 103 | | Ast.Const _ as expr -> expr 104 | | Ast.Annotated (expr, ty) -> Ast.Annotated (refresh_expression vars expr, ty) 105 | | Ast.Tuple exprs -> Ast.Tuple (List.map (refresh_expression vars) exprs) 106 | | Ast.Variant (label, expr) -> 107 | Ast.Variant (label, Option.map (refresh_expression vars) expr) 108 | | Ast.Lambda abs -> Ast.Lambda (refresh_abstraction vars abs) 109 | | Ast.RecLambda (x, abs) -> 110 | let x' = Ast.Variable.refresh x in 111 | Ast.RecLambda (x', refresh_abstraction ((x, x') :: vars) abs) 112 | 113 | and refresh_computation vars = function 114 | | Ast.Return expr -> Ast.Return (refresh_expression vars expr) 115 | | Ast.Do (comp, abs) -> 116 | Ast.Do (refresh_computation vars comp, refresh_abstraction vars abs) 117 | | Ast.Match (expr, cases) -> 118 | Ast.Match 119 | (refresh_expression vars expr, List.map (refresh_abstraction vars) cases) 120 | | Ast.Apply (expr1, expr2) -> 121 | Ast.Apply (refresh_expression vars expr1, refresh_expression vars expr2) 122 | 123 | and refresh_abstraction vars (pat, comp) = 124 | let pat', vars' = refresh_pattern pat in 125 | (pat', refresh_computation (vars @ vars') comp) 126 | 127 | let rec substitute_expression subst = function 128 | | Ast.Var x as expr -> ( 129 | match Ast.VariableMap.find_opt x subst with 130 | | None -> expr 131 | | Some expr -> expr) 132 | | Ast.Const _ as expr -> expr 133 | | Ast.Annotated (expr, ty) -> Annotated (substitute_expression subst expr, ty) 134 | | Ast.Tuple exprs -> Tuple (List.map (substitute_expression subst) exprs) 135 | | Ast.Variant (label, expr) -> 136 | Variant (label, Option.map (substitute_expression subst) expr) 137 | | Ast.Lambda abs -> Lambda (substitute_abstraction subst abs) 138 | | Ast.RecLambda (x, abs) -> RecLambda (x, substitute_abstraction subst abs) 139 | 140 | and substitute_computation subst = function 141 | | Ast.Return expr -> Ast.Return (substitute_expression subst expr) 142 | | Ast.Do (comp, abs) -> 143 | Ast.Do 144 | (substitute_computation subst comp, substitute_abstraction subst abs) 145 | | Ast.Match (expr, cases) -> 146 | Ast.Match 147 | ( substitute_expression subst expr, 148 | List.map (substitute_abstraction subst) cases ) 149 | | Ast.Apply (expr1, expr2) -> 150 | Ast.Apply 151 | (substitute_expression subst expr1, substitute_expression subst expr2) 152 | 153 | and substitute_abstraction subst (pat, comp) = 154 | let subst' = remove_pattern_bound_variables subst pat in 155 | (pat, substitute_computation subst' comp) 156 | 157 | let substitute subst comp = 158 | let subst = Ast.VariableMap.map (refresh_expression []) subst in 159 | substitute_computation subst comp 160 | 161 | let rec eval_function env = function 162 | | Ast.Lambda (pat, comp) -> 163 | fun arg -> 164 | let subst = match_pattern_with_expression env pat arg in 165 | substitute subst comp 166 | | Ast.RecLambda (f, (pat, comp)) as expr -> 167 | fun arg -> 168 | let subst = 169 | match_pattern_with_expression env pat arg 170 | |> Ast.VariableMap.add f expr 171 | in 172 | substitute subst comp 173 | | Ast.Var x -> ( 174 | match Ast.VariableMap.find_opt x env.variables with 175 | | Some expr -> eval_function env expr 176 | | None -> Ast.VariableMap.find x env.builtin_functions) 177 | | expr -> 178 | Error.runtime "Function expected but got %t" (Ast.print_expression expr) 179 | 180 | let step_in_context step env redCtx ctx term = 181 | let terms' = step env term in 182 | List.map (fun (red, term') -> (redCtx red, fun () -> ctx (term' ()))) terms' 183 | 184 | let rec step_computation env = function 185 | | Ast.Return _ -> [] 186 | | Ast.Match (expr, cases) -> 187 | let rec find_case = function 188 | | (pat, comp) :: cases -> ( 189 | match match_pattern_with_expression env pat expr with 190 | | subst -> 191 | [ (ComputationRedex Match, fun () -> substitute subst comp) ] 192 | | exception PatternMismatch -> find_case cases) 193 | | [] -> [] 194 | in 195 | find_case cases 196 | | Ast.Apply (expr1, expr2) -> 197 | let f = eval_function env expr1 in 198 | [ (ComputationRedex ApplyFun, fun () -> f expr2) ] 199 | | Ast.Do (comp1, comp2) -> ( 200 | let comps1' = 201 | step_in_context step_computation env 202 | (fun red -> DoCtx red) 203 | (fun comp1' -> Ast.Do (comp1', comp2)) 204 | comp1 205 | in 206 | match comp1 with 207 | | Ast.Return expr -> 208 | let pat, comp2' = comp2 in 209 | let subst = match_pattern_with_expression env pat expr in 210 | (ComputationRedex DoReturn, fun () -> substitute subst comp2') 211 | :: comps1' 212 | | _ -> comps1') 213 | 214 | type load_state = { 215 | environment : environment; 216 | computations : Ast.computation list; 217 | } 218 | 219 | let initial_load_state = 220 | { environment = initial_environment; computations = [] } 221 | 222 | let load_primitive load_state x prim = 223 | { 224 | load_state with 225 | environment = 226 | { 227 | load_state.environment with 228 | builtin_functions = 229 | Ast.VariableMap.add x 230 | (Primitives.primitive_function prim) 231 | load_state.environment.builtin_functions; 232 | }; 233 | } 234 | 235 | let load_ty_def load_state _ = load_state 236 | 237 | let load_top_let load_state x expr = 238 | { 239 | load_state with 240 | environment = 241 | { 242 | load_state.environment with 243 | variables = Ast.VariableMap.add x expr load_state.environment.variables; 244 | }; 245 | } 246 | 247 | let load_top_do load_state comp = 248 | { load_state with computations = load_state.computations @ [ comp ] } 249 | 250 | type run_state = load_state 251 | type step_label = ComputationReduction of computation_reduction | Return 252 | type step = { label : step_label; next_state : unit -> run_state } 253 | 254 | let run load_state = load_state 255 | 256 | let steps = function 257 | | { computations = []; _ } -> [] 258 | | { computations = Ast.Return _ :: comps; environment } -> 259 | [ 260 | { 261 | label = Return; 262 | next_state = (fun () -> { computations = comps; environment }); 263 | }; 264 | ] 265 | | { computations = comp :: comps; environment } -> 266 | List.map 267 | (fun (red, comp') -> 268 | { 269 | label = ComputationReduction red; 270 | next_state = 271 | (fun () -> { computations = comp' () :: comps; environment }); 272 | }) 273 | (step_computation environment comp) 274 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/core/primitives.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Language.Ast 3 | module Const = Language.Const 4 | module Primitives = Language.Primitives 5 | 6 | let binary_function f = function 7 | | Ast.Tuple [ expr1; expr2 ] -> f expr1 expr2 8 | | expr -> Error.runtime "Pair expected but got %t" (Ast.print_expression expr) 9 | 10 | let get_int = function 11 | | Ast.Const (Const.Integer n) -> n 12 | | expr -> 13 | Error.runtime "Integer expected but got %t" (Ast.print_expression expr) 14 | 15 | let get_float = function 16 | | Ast.Const (Const.Float n) -> n 17 | | expr -> 18 | Error.runtime "Float expected but got %t" (Ast.print_expression expr) 19 | 20 | let int_to f expr = 21 | let n = get_int expr in 22 | f n 23 | 24 | let int_int_to f expr = 25 | binary_function 26 | (fun expr1 expr2 -> 27 | let n1 = get_int expr1 in 28 | let n2 = get_int expr2 in 29 | f n1 n2) 30 | expr 31 | 32 | let float_to f expr = 33 | let n = get_float expr in 34 | f n 35 | 36 | let float_float_to f expr = 37 | binary_function 38 | (fun expr1 expr2 -> 39 | let n1 = get_float expr1 in 40 | let n2 = get_float expr2 in 41 | f n1 n2) 42 | expr 43 | 44 | let int_to_int f = 45 | int_to (fun n -> Ast.Return (Ast.Const (Const.Integer (f n)))) 46 | 47 | let int_int_to_int f = 48 | int_int_to (fun n1 n2 -> Ast.Return (Ast.Const (Const.Integer (f n1 n2)))) 49 | 50 | let float_to_float f = 51 | float_to (fun n -> Ast.Return (Ast.Const (Const.Float (f n)))) 52 | 53 | let float_float_to_float f = 54 | float_float_to (fun n1 n2 -> Ast.Return (Ast.Const (Const.Float (f n1 n2)))) 55 | 56 | let rec comparable_expression = function 57 | | Ast.Var _ -> true 58 | | Const _ -> true 59 | | Annotated (e, _) -> comparable_expression e 60 | | Tuple es -> List.for_all comparable_expression es 61 | | Variant (_, e) -> Option.fold ~none:true ~some:comparable_expression e 62 | | Lambda _ -> false 63 | | RecLambda _ -> false 64 | 65 | let comparison f = 66 | binary_function (fun e1 e2 -> 67 | if not (comparable_expression e1) then 68 | Error.runtime "Incomparable expression %t" 69 | (Ast.print_expression ~max_level:0 e1) 70 | else if not (comparable_expression e2) then 71 | Error.runtime "Incomparable expression %t" 72 | (Ast.print_expression ~max_level:0 e2) 73 | else Ast.Return (Ast.Const (Const.Boolean (f e1 e2)))) 74 | 75 | let primitive_function = function 76 | | Primitives.CompareEq -> comparison ( = ) 77 | | Primitives.CompareLt -> comparison ( < ) 78 | | Primitives.CompareGt -> comparison ( > ) 79 | | Primitives.CompareLe -> comparison ( <= ) 80 | | Primitives.CompareGe -> comparison ( >= ) 81 | | Primitives.CompareNe -> comparison ( <> ) 82 | | Primitives.IntegerAdd -> int_int_to_int ( + ) 83 | | Primitives.IntegerMul -> int_int_to_int ( * ) 84 | | Primitives.IntegerSub -> int_int_to_int ( - ) 85 | | Primitives.IntegerDiv -> int_int_to_int ( / ) 86 | | Primitives.IntegerMod -> int_int_to_int ( mod ) 87 | | Primitives.IntegerNeg -> int_to_int ( ~- ) 88 | | Primitives.FloatAdd -> float_float_to_float ( +. ) 89 | | Primitives.FloatMul -> float_float_to_float ( *. ) 90 | | Primitives.FloatSub -> float_float_to_float ( -. ) 91 | | Primitives.FloatDiv -> float_float_to_float ( /. ) 92 | | Primitives.FloatPow -> float_float_to_float ( ** ) 93 | | Primitives.FloatNeg -> float_to_float ( ~-. ) 94 | | Primitives.ToString -> 95 | fun expr -> 96 | Ast.Return (Ast.Const (Const.String (Ast.string_of_expression expr))) 97 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/web/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name webInterpreter) 3 | (libraries webBackend interpreter)) 4 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/web/redexSelectorTM.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Language.Ast 3 | 4 | let tag_marker = "###" 5 | let print_mark ppf = Format.pp_print_as ppf 0 tag_marker 6 | 7 | let print_computation_redex ?max_level red c ppf = 8 | let print ?at_level = Print.print ?max_level ?at_level ppf in 9 | match (red, c) with 10 | | Interpreter.DoReturn, Ast.Do (c1, (pat, c2)) -> 11 | print "@[%tlet@[@ %t =@ %t@]%t in@ %t@]" print_mark 12 | (Ast.print_pattern pat) (Ast.print_computation c1) print_mark 13 | (Ast.print_computation c2) 14 | | _, comp -> 15 | print "%t%t%t" print_mark 16 | (fun ppf -> Ast.print_computation ?max_level comp ppf) 17 | print_mark 18 | 19 | let rec print_computation_reduction ?max_level red c ppf = 20 | let print ?at_level = Print.print ?max_level ?at_level ppf in 21 | match (red, c) with 22 | | Interpreter.DoCtx red, Ast.Do (c1, (Ast.PNonbinding, c2)) -> 23 | print "@[%t;@ %t@]" 24 | (print_computation_reduction red c1) 25 | (Ast.print_computation c2) 26 | | DoCtx red, Ast.Do (c1, (pat, c2)) -> 27 | print "@[let@[@ %t =@ %t@] in@ %t@]" (Ast.print_pattern pat) 28 | (print_computation_reduction red c1) 29 | (Ast.print_computation c2) 30 | | ComputationRedex redex, c -> print_computation_redex ?max_level redex c ppf 31 | | _, _ -> assert false 32 | 33 | let split_string sep str = 34 | let sep_len = String.length sep and str_len = String.length str in 35 | let sub_start = ref 0 and sub_end = ref 0 and subs = ref [] in 36 | while !sub_end <= str_len - sep_len do 37 | if String.sub str !sub_end sep_len = sep then ( 38 | subs := String.sub str !sub_start (!sub_end - !sub_start) :: !subs; 39 | sub_start := !sub_end + sep_len; 40 | sub_end := !sub_start) 41 | else incr sub_end 42 | done; 43 | if !sub_start <= str_len then 44 | subs := String.sub str !sub_start (str_len - !sub_start) :: !subs; 45 | List.rev !subs 46 | 47 | let view_computation_with_redexes red comp = 48 | (match red with 49 | | None -> Ast.print_computation comp Format.str_formatter 50 | | Some red -> print_computation_reduction red comp Format.str_formatter); 51 | match split_string tag_marker (Format.flush_str_formatter ()) with 52 | | [ code ] -> [ Vdom.text code ] 53 | | [ pre; redex; post ] -> 54 | [ 55 | Vdom.text pre; 56 | Vdom.elt "strong" ~a:[ Vdom.class_ "has-text-info" ] [ Vdom.text redex ]; 57 | Vdom.text post; 58 | ] 59 | | _ -> assert false 60 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/web/webInterpreter.ml: -------------------------------------------------------------------------------- 1 | include Interpreter 2 | open Vdom 3 | 4 | let view_computation_redex = function 5 | | Interpreter.Match -> "match" 6 | | Interpreter.ApplyFun -> "applyFun" 7 | | Interpreter.DoReturn -> "doReturn" 8 | 9 | let rec view_computation_reduction = function 10 | | Interpreter.DoCtx red -> view_computation_reduction red 11 | | Interpreter.ComputationRedex redex -> view_computation_redex redex 12 | 13 | let view_step_label = function 14 | | Interpreter.ComputationReduction reduction -> 15 | text (view_computation_reduction reduction) 16 | | Interpreter.Return -> text "return" 17 | 18 | let view_run_state (run_state : run_state) step_label = 19 | match run_state with 20 | | { computations = comp :: _; _ } -> 21 | let reduction = 22 | match step_label with 23 | | Some (ComputationReduction red) -> Some red 24 | | Some Interpreter.Return -> None 25 | | None -> None 26 | in 27 | 28 | let computation_tree = 29 | RedexSelectorTM.view_computation_with_redexes reduction comp 30 | in 31 | div ~a:[ class_ "box" ] [ elt "pre" computation_tree ] 32 | | { computations = []; _ } -> 33 | div ~a:[ class_ "box" ] [ elt "pre" [ text "done" ] ] 34 | -------------------------------------------------------------------------------- /src/05-backends/interpreter/web/webInterpreter.mli: -------------------------------------------------------------------------------- 1 | include WebBackend.S 2 | -------------------------------------------------------------------------------- /src/05-backends/sig/cli/cliBackend.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | include Backend.S 3 | 4 | val view_run_state : run_state -> unit 5 | end 6 | -------------------------------------------------------------------------------- /src/05-backends/sig/cli/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name cliBackend) 3 | (libraries backend)) 4 | -------------------------------------------------------------------------------- /src/05-backends/sig/core/backend.ml: -------------------------------------------------------------------------------- 1 | module Ast = Language.Ast 2 | 3 | module type S = sig 4 | type load_state 5 | 6 | val initial_load_state : load_state 7 | 8 | val load_primitive : 9 | load_state -> Ast.variable -> Language.Primitives.primitive -> load_state 10 | 11 | val load_ty_def : 12 | load_state -> 13 | (Ast.ty_param list * Ast.ty_name * Ast.ty_def) list -> 14 | load_state 15 | 16 | val load_top_let : load_state -> Ast.variable -> Ast.expression -> load_state 17 | val load_top_do : load_state -> Ast.computation -> load_state 18 | 19 | type run_state 20 | type step_label 21 | type step = { label : step_label; next_state : unit -> run_state } 22 | 23 | val run : load_state -> run_state 24 | val steps : run_state -> step list 25 | end 26 | -------------------------------------------------------------------------------- /src/05-backends/sig/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name backend) 3 | (libraries language)) 4 | -------------------------------------------------------------------------------- /src/05-backends/sig/web/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name webBackend) 3 | (libraries vdom backend)) 4 | -------------------------------------------------------------------------------- /src/05-backends/sig/web/webBackend.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | include Backend.S 3 | 4 | val view_step_label : step_label -> 'a Vdom.vdom 5 | val view_run_state : run_state -> step_label option -> 'a Vdom.vdom 6 | end 7 | -------------------------------------------------------------------------------- /src/06-user-interface/cli/cli.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Language.Ast 3 | module Backend = CliInterpreter 4 | module Loader = Loader.Loader (Backend) 5 | 6 | type config = { filenames : string list; use_stdlib : bool } 7 | 8 | let parse_args_to_config () = 9 | let filenames = ref [] and use_stdlib = ref true in 10 | let usage = "Run Millet as '" ^ Sys.argv.(0) ^ " [filename.mlt] ...'" 11 | and anonymous filename = filenames := filename :: !filenames 12 | and options = 13 | Arg.align 14 | [ 15 | ( "--no-stdlib", 16 | Arg.Clear use_stdlib, 17 | " Do not load the standard library" ); 18 | ] 19 | in 20 | Arg.parse options anonymous usage; 21 | { filenames = List.rev !filenames; use_stdlib = !use_stdlib } 22 | 23 | let rec run (state : Backend.run_state) = 24 | Backend.view_run_state state; 25 | match Backend.steps state with 26 | | [] -> () 27 | | steps -> 28 | let i = Random.int (List.length steps) in 29 | let step = List.nth steps i in 30 | let state' = step.next_state () in 31 | run state' 32 | 33 | let main () = 34 | let config = parse_args_to_config () in 35 | try 36 | Random.self_init (); 37 | let state = 38 | if config.use_stdlib then 39 | Loader.load_source Loader.initial_state Loader.stdlib_source 40 | else Loader.initial_state 41 | in 42 | let state' = List.fold_left Loader.load_file state config.filenames in 43 | let run_state = Backend.run state'.backend in 44 | run run_state 45 | with Error.Error error -> 46 | Error.print error; 47 | exit 1 48 | 49 | let _ = main () 50 | -------------------------------------------------------------------------------- /src/06-user-interface/cli/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name cli) 3 | (libraries cliInterpreter loader) 4 | (promote 5 | (until-clean) 6 | (into ../../..))) 7 | -------------------------------------------------------------------------------- /src/06-user-interface/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name loader) 3 | (libraries desugarer typechecker backend)) 4 | 5 | ;; This is a neat trick to include the standard library inside the binary, borrowed from 6 | ;; (https://gitlab.inria.fr/fpottier/menhir/-/blob/673f63e0f2c4ba7046ffae2504eb9ea29ad6d88c/src/dune) 7 | ;; We generate the file "stdlib_mlt.ml" which contains a string with the contents of "stdlib.mlt" 8 | 9 | (rule 10 | (with-stdout-to 11 | stdlib_mlt.ml 12 | (progn 13 | (echo "let contents = {|") 14 | (cat stdlib.mlt) 15 | (echo "|}")))) 16 | -------------------------------------------------------------------------------- /src/06-user-interface/core/loader.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Language.Ast 3 | 4 | module Loader (Backend : Backend.S) = struct 5 | type state = { 6 | desugarer : Desugarer.state; 7 | backend : Backend.load_state; 8 | typechecker : Typechecker.state; 9 | } 10 | 11 | let load_primitive state prim = 12 | let x = Ast.Variable.fresh (Language.Primitives.primitive_name prim) in 13 | let desugarer_state' = Desugarer.load_primitive state.desugarer x prim in 14 | let typechecker_state' = 15 | Typechecker.load_primitive state.typechecker x prim 16 | in 17 | let backend_state' = Backend.load_primitive state.backend x prim in 18 | { 19 | desugarer = desugarer_state'; 20 | typechecker = typechecker_state'; 21 | backend = backend_state'; 22 | } 23 | 24 | let initial_state = 25 | let initial_state_without_primitives = 26 | { 27 | desugarer = Desugarer.initial_state; 28 | typechecker = Typechecker.initial_state; 29 | backend = Backend.initial_load_state; 30 | } 31 | in 32 | 33 | List.fold_left load_primitive initial_state_without_primitives 34 | Language.Primitives.primitives 35 | 36 | let parse_commands lexbuf = 37 | try Parser.Grammar.commands Parser.Lexer.token lexbuf with 38 | | Parser.Grammar.Error -> 39 | Error.syntax 40 | ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) 41 | "parser error" 42 | | Failure failmsg when failmsg = "lexing: empty token" -> 43 | Error.syntax 44 | ~loc:(Location.of_lexeme (Lexing.lexeme_start_p lexbuf)) 45 | "unrecognised symbol." 46 | 47 | let execute_command state = function 48 | | Ast.TyDef ty_defs -> 49 | let typechecker_state' = 50 | Typechecker.add_type_definitions state.typechecker ty_defs 51 | in 52 | let backend_state' = Backend.load_ty_def state.backend ty_defs in 53 | { 54 | state with 55 | typechecker = typechecker_state'; 56 | backend = backend_state'; 57 | } 58 | | Ast.TopLet (x, expr) -> 59 | let typechecker_state' = 60 | Typechecker.add_top_definition state.typechecker x expr 61 | in 62 | let backend_state' = Backend.load_top_let state.backend x expr in 63 | { 64 | state with 65 | typechecker = typechecker_state'; 66 | backend = backend_state'; 67 | } 68 | | Ast.TopDo comp -> 69 | let _ = Typechecker.infer state.typechecker comp in 70 | let backend_state' = Backend.load_top_do state.backend comp in 71 | { state with backend = backend_state' } 72 | 73 | let load_commands state cmds = 74 | let desugarer_state', cmds' = 75 | List.fold_map Desugarer.desugar_command state.desugarer cmds 76 | in 77 | let state' = { state with desugarer = desugarer_state' } in 78 | List.fold_left execute_command state' cmds' 79 | 80 | let load_source state source = 81 | let lexbuf = Lexing.from_string source in 82 | let cmds = parse_commands lexbuf in 83 | load_commands state cmds 84 | 85 | let load_file state source = 86 | let cmds = Parser.Lexer.read_file parse_commands source in 87 | load_commands state cmds 88 | 89 | (** The module Stdlib_mlt is automatically generated from stdlib.mlt. Check 90 | the dune file for details. *) 91 | let stdlib_source = Stdlib_mlt.contents 92 | end 93 | -------------------------------------------------------------------------------- /src/06-user-interface/core/stdlib.mlt: -------------------------------------------------------------------------------- 1 | let ( = ) x y = __compare_eq__ (x, y) 2 | let ( < ) x y = __compare_lt__ (x, y) 3 | let ( > ) x y = __compare_gt__ (x, y) 4 | let ( <= ) x y = __compare_le__ (x, y) 5 | let ( >= ) x y = __compare_ge__ (x, y) 6 | let ( <> ) x y = __compare_ne__ (x, y) 7 | let ( + ) x y = __integer_add__ (x, y) 8 | let ( * ) x y = __integer_mul__ (x, y) 9 | let ( - ) x y = __integer_sub__ (x, y) 10 | let ( / ) x y = __integer_div__ (x, y) 11 | let ( mod ) x y = __integer_mod__ (x, y) 12 | let ( ~- ) x = __integer_neg__ x 13 | let ( +. ) x y = __float_add__ (x, y) 14 | let ( *. ) x y = __float_mul__ (x, y) 15 | let ( -. ) x y = __float_sub__ (x, y) 16 | let ( /. ) x y = __float_div__ (x, y) 17 | let ( ** ) x y = __float_pow__ (x, y) 18 | let ( ~-. ) x = __float_neg__ x 19 | 20 | let absurd void = (match void with) 21 | 22 | (* Booleans *) 23 | let not x = if x then false else true 24 | 25 | type 'a option = None | Some of 'a 26 | 27 | let rec assoc x = function 28 | | [] -> None 29 | | (key, v) :: lst -> if x = key then Some v else assoc x lst 30 | 31 | let rec range m n = 32 | if m > n then 33 | [] 34 | else 35 | m :: range (m + 1) n 36 | 37 | let reverse lst = 38 | let rec reverse_acc acc = function 39 | | [] -> acc 40 | | x :: xs -> reverse_acc (x :: acc) xs 41 | in 42 | reverse_acc [] lst 43 | 44 | let rec map f = function 45 | | [] -> [] 46 | | x :: xs -> 47 | let y = f x in 48 | let ys = map f xs in 49 | y :: ys 50 | 51 | let hd = function 52 | | x :: _ -> x 53 | 54 | let tl = function 55 | | x :: xs -> xs 56 | 57 | let take f k = 58 | let r = range 0 k in map f r 59 | 60 | let rec fold_left f acc = function 61 | | [] -> acc 62 | | y :: ys -> 63 | let acc' = f acc y in 64 | fold_left f acc' ys 65 | 66 | let rec fold_right f xs acc = 67 | match xs with 68 | | [] -> acc 69 | | x :: xs -> 70 | let acc' = fold_right f xs acc in 71 | f x acc' 72 | 73 | let rec iter f = function 74 | | [] -> () 75 | | x :: xs -> f x; iter f xs 76 | 77 | let rec forall p = function 78 | | [] -> true 79 | | x :: xs -> if p x then forall p xs else false 80 | 81 | let rec exists p = function 82 | | [] -> false 83 | | x :: xs -> if p x then true else exists p xs 84 | 85 | let mem x = exists (fun x' -> x = x') 86 | let rec filter p = function 87 | | [] -> [] 88 | | x :: xs -> 89 | if p x then (x :: filter p xs) else filter p xs 90 | 91 | let complement xs ys = filter (fun x -> not (mem x ys)) xs 92 | let intersection xs ys = filter (fun x -> mem x ys) xs 93 | let rec zip xs ys = 94 | match (xs, ys) with 95 | | ([], []) -> [] 96 | | (x :: xs, y :: ys) -> (x, y) :: (zip xs ys) 97 | 98 | let rec unzip = function 99 | | [] -> ([], []) 100 | | (x, y) :: xys -> 101 | let xs, ys = unzip xys in 102 | (x :: xs, y :: ys) 103 | 104 | let rec (@) xs ys = 105 | match xs with 106 | | [] -> ys 107 | | x :: xs -> x :: (xs @ ys) 108 | 109 | let rec length = function 110 | | [] -> 0 111 | | x :: xs -> length xs + 1 112 | 113 | let rec nth (x::xs) n = 114 | if n = 0 then x else nth xs (n - 1) 115 | 116 | (* Basic functions *) 117 | let abs x = if x < 0 then -x else x 118 | let min x y = if x < y then x else y 119 | let max x y = if x < y then y else x 120 | let rec gcd m n = 121 | match n with 122 | | 0 -> m 123 | | _ -> let g = gcd n in g (m mod n) 124 | 125 | let rec lcm m n = 126 | let d = gcd m n in (m * n) / d 127 | 128 | let odd x = (x mod 2) = 1 129 | let even x = (x mod 2) = 0 130 | let id x = x 131 | let compose f g x = f (g x) 132 | let (|>) x f = f x 133 | let ignore _ = () 134 | let fst (x, _) = x 135 | let snd (_, y) = y 136 | 137 | let return x = x 138 | -------------------------------------------------------------------------------- /src/06-user-interface/web/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name web) 3 | (libraries webInterpreter loader) 4 | (modes js) 5 | (link_flags -no-check-prims) 6 | (promote 7 | (until-clean) 8 | (into ../../../web) 9 | (only web.bc.js))) 10 | 11 | ;; This is an expanded form of the trick used in src/core/dune to generate the module 12 | ;; Examples_mlt with the examples to include in the web interface. 13 | 14 | (rule 15 | (with-stdout-to 16 | examples_mlt.ml 17 | (progn 18 | (echo "let examples = [") 19 | ;; We need to repeat the following three lines for each included example. 20 | ;; The first line gives the name of the example and the second gives its source. 21 | (echo "({|Recursive functions on integers|}, {|") 22 | (cat ../../../examples/recursion.mlt) 23 | (echo "|});") 24 | (echo "({|Natural numbers as an inductive type|}, {|") 25 | (cat ../../../examples/nat.mlt) 26 | (echo "|});") 27 | (echo "]")))) 28 | -------------------------------------------------------------------------------- /src/06-user-interface/web/model.ml: -------------------------------------------------------------------------------- 1 | open Utils 2 | module Ast = Language.Ast 3 | module Backend = WebInterpreter 4 | module Loader = Loader.Loader (Backend) 5 | 6 | type edit_model = { use_stdlib : bool; unparsed_code : string } 7 | 8 | let edit_init = { use_stdlib = true; unparsed_code = "" } 9 | 10 | type edit_msg = UseStdlib of bool | ChangeSource of string 11 | 12 | let edit_update edit_model = function 13 | | UseStdlib use_stdlib -> { edit_model with use_stdlib } 14 | | ChangeSource input -> { edit_model with unparsed_code = input } 15 | 16 | type run_model = { 17 | run_state : Backend.run_state; 18 | history : Backend.run_state list; 19 | selected_step_index : int option; 20 | (* You may be wondering why we keep an index rather than the selected step itself. 21 | The selected step is displayed when the user moves the mouse over the step button, 22 | so on a onmouseover event. However, in the common case, when the user is on the button 23 | and is clicking it to proceed, this event is not triggered and so the step is not updated. 24 | For that reason, it is easiest to keep track of the selected button index, which does not 25 | change when the user clicks the button. *) 26 | random_step_size : int; 27 | } 28 | 29 | let run_init run_state = 30 | { run_state; history = []; selected_step_index = None; random_step_size = 1 } 31 | 32 | type run_msg = 33 | | SelectStepIndex of int option 34 | | MakeStep of Backend.step 35 | | RandomStep 36 | | ChangeRandomStepSize of int 37 | | Back 38 | 39 | let run_model_make_step run_model (step : Backend.step) = 40 | { 41 | run_model with 42 | run_state = step.next_state (); 43 | history = run_model.run_state :: run_model.history; 44 | } 45 | 46 | let rec run_model_make_random_steps run_model num_steps = 47 | match (num_steps, Backend.steps run_model.run_state) with 48 | | 0, _ | _, [] -> run_model 49 | | _, steps -> 50 | let i = Random.int (List.length steps) in 51 | let step = List.nth steps i in 52 | let run_model' = run_model_make_step run_model step in 53 | run_model_make_random_steps run_model' (num_steps - 1) 54 | 55 | let run_update run_model = function 56 | | SelectStepIndex selected_step_index -> 57 | { run_model with selected_step_index } 58 | | MakeStep step -> run_model_make_step run_model step 59 | | RandomStep -> 60 | run_model_make_random_steps run_model run_model.random_step_size 61 | | Back -> ( 62 | match run_model.history with 63 | | run_state' :: history' -> 64 | { run_model with run_state = run_state'; history = history' } 65 | | _ -> run_model) 66 | | ChangeRandomStepSize random_step_size -> { run_model with random_step_size } 67 | 68 | type model = { edit_model : edit_model; run_model : (run_model, string) result } 69 | 70 | let init = { edit_model = edit_init; run_model = Error "" } 71 | 72 | type msg = EditMsg of edit_msg | RunCode | RunMsg of run_msg | EditCode 73 | 74 | let update model = function 75 | | EditMsg edit_msg -> 76 | { model with edit_model = edit_update model.edit_model edit_msg } 77 | | RunMsg run_msg -> ( 78 | match model.run_model with 79 | | Ok run_model -> 80 | { model with run_model = Ok (run_update run_model run_msg) } 81 | | Error _ -> model) 82 | | RunCode -> 83 | let run_model = 84 | try 85 | let source = 86 | (if model.edit_model.use_stdlib then Loader.stdlib_source else "") 87 | ^ "\n\n\n" ^ model.edit_model.unparsed_code 88 | in 89 | let state = Loader.load_source Loader.initial_state source in 90 | let run_state = Backend.run state.backend in 91 | let run_model = run_init run_state in 92 | Ok run_model 93 | with Error.Error (_, _, msg) -> Error msg 94 | in 95 | { model with run_model } 96 | | EditCode -> { model with run_model = Error "" } 97 | -------------------------------------------------------------------------------- /src/06-user-interface/web/view.ml: -------------------------------------------------------------------------------- 1 | open Vdom 2 | module Ast = Language.Ast 3 | 4 | (* Auxiliary definitions *) 5 | let panel ?(a = []) heading blocks = 6 | div ~a:(class_ "panel" :: a) 7 | (elt "p" ~a:[ class_ "panel-heading" ] [ text heading ] :: blocks) 8 | 9 | let panel_block = div ~a:[ class_ "panel-block" ] 10 | 11 | let button txt msg = 12 | input [] ~a:[ onclick (fun _ -> msg); type_button; value txt ] 13 | 14 | let disabled_button txt = input [] ~a:[ type_button; value txt; disabled true ] 15 | 16 | let select ?(a = []) empty_description msg describe_choice selected choices = 17 | let view_choice choice = 18 | elt "option" 19 | ~a:[ bool_prop "selected" (selected choice) ] 20 | [ text (describe_choice choice) ] 21 | in 22 | div ~a 23 | [ 24 | elt "select" 25 | ~a:[ onchange_index (fun i -> msg (List.nth choices (i - 1))) ] 26 | (elt "option" 27 | ~a: 28 | [ 29 | disabled true; 30 | bool_prop "selected" 31 | (List.for_all (fun choice -> not (selected choice)) choices); 32 | ] 33 | [ text empty_description ] 34 | :: List.map view_choice choices); 35 | ] 36 | 37 | let nil = text "" 38 | 39 | let view_contents main aside = 40 | div 41 | ~a:[ class_ "contents columns" ] 42 | [ 43 | div ~a:[ class_ "main column is-three-quarters" ] main; 44 | div ~a:[ class_ "aside column is-one-quarter" ] aside; 45 | ] 46 | 47 | (* Edit view *) 48 | 49 | let view_editor (model : Model.edit_model) = 50 | div 51 | ~a:[ class_ "box" ] 52 | [ 53 | elt "textarea" 54 | ~a: 55 | [ 56 | class_ "textarea has-fixed-size"; 57 | oninput (fun input -> Model.ChangeSource input); 58 | int_prop "rows" 59 | (max 10 60 | (String.split_on_char '\n' model.unparsed_code |> List.length)); 61 | ] 62 | [ text model.unparsed_code ]; 63 | ] 64 | 65 | (* let _view (model : Model.model) = 66 | match model.loaded_code with 67 | | Ok code -> 68 | div 69 | [ 70 | input ~a:[type_ "range"; int_attr "min" 0; int_attr "max" 10; int_attr "step" 2; onmousedown (fun event -> Model.ParseInterrupt (string_of_int event.x))] []; 71 | (* elt "progress" ~a:[type_ "range"; value (string_of_int model.random_step_size); int_attr "max" 10; oninput (fun input -> Model.ChangeStepSize input)] []; *) 72 | editor model; 73 | actions model code; 74 | view_operations code.snapshot.operations; 75 | view_process code.snapshot.process; 76 | ] 77 | | Error msg -> div [ editor model; text msg ] *) 78 | 79 | let view_compiler (model : Model.model) = 80 | let use_stdlib = 81 | elt "label" 82 | ~a:[ class_ "panel-block" ] 83 | [ 84 | input 85 | ~a: 86 | [ 87 | type_ "checkbox"; 88 | onchange_checked (fun use_stdlib -> 89 | Model.EditMsg (Model.UseStdlib use_stdlib)); 90 | bool_prop "checked" model.edit_model.use_stdlib; 91 | ] 92 | []; 93 | text "Load standard library"; 94 | ] 95 | in 96 | let load_example = 97 | div 98 | ~a:[ class_ "panel-block" ] 99 | [ 100 | div 101 | ~a:[ class_ "field" ] 102 | [ 103 | div 104 | ~a:[ class_ "control is-expanded" ] 105 | [ 106 | select 107 | ~a:[ class_ "select is-fullwidth" ] 108 | "Load example" 109 | (fun (_, source) -> Model.EditMsg (ChangeSource source)) 110 | (fun (title, _) -> title) 111 | (fun _ -> false) 112 | (* The module Examples_mlt is semi-automatically generated from examples/*.mlt. Check the dune file for details. *) 113 | Examples_mlt.examples; 114 | ]; 115 | ]; 116 | ] 117 | and run_process = 118 | panel_block 119 | [ 120 | elt "button" 121 | ~a: 122 | [ 123 | class_ "button is-info is-fullwidth"; 124 | onclick (fun _ -> Model.RunCode); 125 | (* disabled (Result.is_error model.loaded_code); *) 126 | ] 127 | [ text "Compile & run" ]; 128 | (match model.run_model with 129 | | Error msg -> elt "p" ~a:[ class_ "help is-danger" ] [ text msg ] 130 | | Ok _ -> nil); 131 | ] 132 | in 133 | panel "Code options" [ use_stdlib; load_example; run_process ] 134 | 135 | let edit_view (model : Model.model) = 136 | view_contents 137 | [ 138 | map 139 | (fun edit_msg -> Model.EditMsg edit_msg) 140 | (view_editor model.edit_model); 141 | ] 142 | [ view_compiler model ] 143 | 144 | (* Run view *) 145 | 146 | let view_steps (run_model : Model.run_model) steps = 147 | let view_edit_source = 148 | panel_block 149 | [ 150 | elt "button" 151 | ~a: 152 | [ 153 | class_ "button is-outlined is-fullwidth is-small is-danger"; 154 | onclick (fun _ -> Model.EditCode); 155 | attr "title" 156 | "Re-editing source code will abort current evaluation"; 157 | ] 158 | [ text "Re-edit source code" ]; 159 | ] 160 | and view_undo_last_step = 161 | panel_block 162 | [ 163 | elt "button" 164 | ~a: 165 | [ 166 | class_ "button is-outlined is-fullwidth is-small"; 167 | onclick (fun _ -> Model.RunMsg Model.Back); 168 | disabled (run_model.history = []); 169 | ] 170 | [ text "Undo last step" ]; 171 | ] 172 | and view_step i step = 173 | panel_block 174 | [ 175 | elt "button" 176 | ~a: 177 | [ 178 | class_ "button is-outlined is-fullwidth"; 179 | onclick (fun _ -> Model.RunMsg (Model.MakeStep step)); 180 | onmousemove (fun _ -> 181 | Model.RunMsg (Model.SelectStepIndex (Some i))); 182 | ] 183 | [ 184 | Vdom.map 185 | (fun step -> Model.RunMsg (Model.MakeStep step)) 186 | (Model.Backend.view_step_label step.label); 187 | ]; 188 | ] 189 | and view_random_steps steps = 190 | div 191 | ~a:[ class_ "panel-block" ] 192 | [ 193 | div 194 | ~a:[ class_ "field has-addons" ] 195 | [ 196 | div 197 | ~a:[ class_ "control is-expanded" ] 198 | [ 199 | select 200 | ~a:[ class_ "select is-fullwidth is-info" ] 201 | "Step size" 202 | (fun step_size -> 203 | Model.RunMsg (Model.ChangeRandomStepSize step_size)) 204 | string_of_int 205 | (fun step_size -> step_size = run_model.random_step_size) 206 | [ 1; 2; 4; 8; 16; 32; 64; 128; 256; 512; 1024 ]; 207 | ]; 208 | div 209 | ~a:[ class_ "control" ] 210 | [ 211 | elt "button" 212 | ~a: 213 | [ 214 | class_ "button is-info"; 215 | onclick (fun _ -> Model.RunMsg Model.RandomStep); 216 | disabled (steps = []); 217 | ] 218 | [ text "random steps" ]; 219 | ]; 220 | ]; 221 | (if steps = [] then 222 | elt "p" 223 | ~a:[ class_ "help" ] 224 | [ 225 | text "Computation has terminated, no further steps are possible."; 226 | ] 227 | else text ""); 228 | ] 229 | in 230 | panel "Interaction" 231 | ~a:[ onmousemove (fun _ -> Model.RunMsg (Model.SelectStepIndex None)) ] 232 | (view_edit_source :: view_undo_last_step :: view_random_steps steps 233 | :: List.mapi view_step steps) 234 | 235 | let run_view (run_model : Model.run_model) = 236 | let steps = Model.Backend.steps run_model.run_state in 237 | let selected_step = 238 | Option.map (List.nth steps) run_model.selected_step_index 239 | in 240 | view_contents 241 | [ 242 | Model.Backend.view_run_state run_model.run_state 243 | (Option.map (fun step -> step.WebInterpreter.label) selected_step); 244 | ] 245 | [ view_steps run_model steps ] 246 | 247 | let view_navbar = 248 | let view_title = 249 | div 250 | ~a:[ class_ "navbar-brand" ] 251 | [ 252 | elt "a" 253 | ~a:[ class_ "navbar-item" ] 254 | [ elt "p" ~a:[ class_ "title" ] [ text "Millet" ] ]; 255 | ] 256 | in 257 | 258 | elt "navbar" ~a:[ class_ "navbar" ] [ view_title ] 259 | 260 | let view (model : Model.model) = 261 | div 262 | [ 263 | view_navbar; 264 | (match model.run_model with 265 | | Error _ -> edit_view model 266 | | Ok run_model -> run_view run_model); 267 | ] 268 | -------------------------------------------------------------------------------- /src/06-user-interface/web/web.ml: -------------------------------------------------------------------------------- 1 | let app = 2 | Vdom.simple_app ~init:Model.init ~view:View.view ~update:Model.update () 3 | 4 | let run () = 5 | Vdom_blit.run app |> Vdom_blit.dom 6 | |> Js_browser.Element.append_child 7 | (match 8 | Js_browser.Document.get_element_by_id Js_browser.document "container" 9 | with 10 | | Some element -> element 11 | | None -> Js_browser.Document.document_element Js_browser.document) 12 | 13 | let () = Js_browser.Window.set_onload Js_browser.window run 14 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps 3 | ../cli.exe 4 | (source_tree .))) 5 | -------------------------------------------------------------------------------- /tests/duplicate_variant_tydef_sum.mlt: -------------------------------------------------------------------------------- 1 | (* Duplicate variants are not allowed in a sum type. *) 2 | 3 | type cow = Horn of int | Horn of string 4 | -------------------------------------------------------------------------------- /tests/invalid_match_type.mlt: -------------------------------------------------------------------------------- 1 | type a = A 2 | type b = B 3 | 4 | run let a = [A] in 5 | match a with 6 | | B -> () 7 | -------------------------------------------------------------------------------- /tests/less_than_function.mlt: -------------------------------------------------------------------------------- 1 | run (fun x -> x) < (fun x -> 2 * x) 2 | -------------------------------------------------------------------------------- /tests/lexer.mlt: -------------------------------------------------------------------------------- 1 | (* Tests for lexer. *) 2 | 3 | run let _a = 10 in _a 4 | run let a' = 20 in a' 5 | run let a'b' = 30 in a'b' 6 | run let a''' = 40 in a''' 7 | 8 | run -1_000_000_000 9 | run 42 10 | run (-0b101010) 11 | run 0b101010 12 | run 0B101010 13 | run 0xabcdef 14 | run 0XAbCdEf 15 | run 0o76510 16 | run 0O76510 17 | 18 | run 3.141592 19 | run 4.141_592 20 | run -51592e-4 21 | run 61592E-4 22 | run -0.00314e+3___ -------------------------------------------------------------------------------- /tests/malformed_type_application.mlt: -------------------------------------------------------------------------------- 1 | (* Malformed type application *) 2 | 3 | type 'a foo = 'a * 'a 4 | type bar = (int, int) foo -------------------------------------------------------------------------------- /tests/nat.mlt: -------------------------------------------------------------------------------- 1 | type nat = 2 | | Zero 3 | | Succ of nat 4 | 5 | let rec add m n = 6 | match m with 7 | | Zero -> n 8 | | Succ m' -> Succ (add m' n) 9 | 10 | let rec multiply m n = 11 | match m with 12 | | Zero -> Zero 13 | | Succ m' -> add n (multiply m' n) 14 | 15 | let rec to_int = 16 | function 17 | | Zero -> 0 18 | | Succ m -> to_int m + 1 19 | 20 | let rec from_int n = 21 | if n = 0 then Zero else Succ (from_int (n - 1)) 22 | 23 | run 24 | let six = from_int 6 in 25 | let seven = Succ six in 26 | let forty_two = multiply six seven in 27 | to_int forty_two 28 | -------------------------------------------------------------------------------- /tests/non_linear_pattern.mlt: -------------------------------------------------------------------------------- 1 | (* A pattern must be linear. *) 2 | 3 | run let (a,a) = (10, 20) in a 4 | -------------------------------------------------------------------------------- /tests/occurs_check.mlt: -------------------------------------------------------------------------------- 1 | run let rec f x = f in f 2 | -------------------------------------------------------------------------------- /tests/orelse_andalso.mlt: -------------------------------------------------------------------------------- 1 | (* The primitives && || are not supported. 2 | 3 | run (false && (1 / 0 = 5)) 4 | 5 | run (true || (1 / 0 = 5)) 6 | 7 | run (false && false) 8 | run (false && true) 9 | run (true && false) 10 | run (true && true) 11 | 12 | run (false || false) 13 | run (false || true) 14 | run (true || false) 15 | run (true || true) *) -------------------------------------------------------------------------------- /tests/patterns.mlt: -------------------------------------------------------------------------------- 1 | run let a = 5 in a 2 | run let (a,b) = (1,2) in (a,b) 3 | run let x :: y = [1;2;3;4] in (x,y) 4 | run let _ :: y = [1;2;3;4] in y 5 | 6 | type 'a cow = Moo of 'a 7 | 8 | run let (Moo x) = Moo 10 in x 9 | 10 | run let ((Moo x) as y) = Moo 10 in (x,y) 11 | run let ((x as y) as z) = 42 in (x,y,z) 12 | run let ((x,y,z) as a) = (1,2,3) in (x,y,z,a) 13 | run let ((x as y), z) = ("foo", "bar") in (x,y,z) 14 | -------------------------------------------------------------------------------- /tests/polymorphism.mlt: -------------------------------------------------------------------------------- 1 | (* The following expression is currently not supported 2 | ```let a = (let f x = x in (f 5, f "foo")```) because: 3 | - Expressions of the form ```let a = , where is not a pure 4 | expressions, are not supported. 5 | - Expressions similar to ```let f x = x in (f 5, f "foo")``` are not 6 | supported. Type checking fails with error 7 | "Typing error: Cannot unify int = string". 8 | *) 9 | 10 | let f x = x 11 | run (f 5, f "foo") 12 | 13 | let g x y = (fun x y -> x) x y 14 | 15 | run (g 4 "foo", g "foo" 4) 16 | 17 | let u = [] 18 | 19 | run (1 :: u, "foo" :: u) 20 | 21 | let v = [[]] 22 | 23 | run ([] :: v, [2] :: v) 24 | 25 | run (fun x -> let h t u = u in h x x) 26 | 27 | run (fun x -> let h t u = t in h x x) 28 | 29 | let rec u x = u x -------------------------------------------------------------------------------- /tests/polymorphism_id_id.mlt: -------------------------------------------------------------------------------- 1 | let u x = x 2 | run let v = u u in 3 | (v 42, v "foo") -------------------------------------------------------------------------------- /tests/recursion.mlt: -------------------------------------------------------------------------------- 1 | let rec fact n = 2 | if n = 0 then 1 else n * fact (n - 1) 3 | 4 | let fib n = 5 | let rec aux n a b = 6 | if n = 0 then a else aux (n - 1) b (a + b) 7 | in 8 | aux n 0 1 9 | 10 | let rec gcd m n = 11 | match n with 12 | | 0 -> m 13 | | _ -> gcd n (m mod n) 14 | 15 | run (gcd (fib 10) (fact 10)) 16 | -------------------------------------------------------------------------------- /tests/run_tests.t: -------------------------------------------------------------------------------- 1 | $ for f in *.mlt 2 | > do 3 | > echo "======================================================================" 4 | > echo $f 5 | > echo "======================================================================" 6 | > ../cli.exe $f 7 | > : # this command is here to suppress potential non-zero exit codes in the output 8 | > done 9 | ====================================================================== 10 | duplicate_variant_tydef_sum.mlt 11 | ====================================================================== 12 | Syntax error (file "duplicate_variant_tydef_sum.mlt", line 3, char 1): 13 | Label Horn defined multiple times. 14 | ====================================================================== 15 | invalid_match_type.mlt 16 | ====================================================================== 17 | Typing error: Cannot unify a list = b 18 | ====================================================================== 19 | less_than_function.mlt 20 | ====================================================================== 21 | Runtime error: Incomparable expression (fun x ↦ return x) 22 | ====================================================================== 23 | lexer.mlt 24 | ====================================================================== 25 | return 10 26 | return 20 27 | return 30 28 | return 40 29 | return -1000000000 30 | return 42 31 | return -42 32 | return 42 33 | return 42 34 | return 11259375 35 | return 11259375 36 | return 32072 37 | return 32072 38 | return 3.141592 39 | return 4.141592 40 | return -5.1592 41 | return 6.1592 42 | return -3.14 43 | ====================================================================== 44 | malformed_type_application.mlt 45 | ====================================================================== 46 | Typing error: Type foo expects 1 arguments but got 2. 47 | ====================================================================== 48 | nat.mlt 49 | ====================================================================== 50 | return 42 51 | ====================================================================== 52 | non_linear_pattern.mlt 53 | ====================================================================== 54 | Syntax error (file "non_linear_pattern.mlt", line 3, char 9): 55 | Variable a defined multiple times. 56 | ====================================================================== 57 | occurs_check.mlt 58 | ====================================================================== 59 | Typing error: Cannot unify α = β → α 60 | ====================================================================== 61 | orelse_andalso.mlt 62 | ====================================================================== 63 | ====================================================================== 64 | patterns.mlt 65 | ====================================================================== 66 | return 5 67 | return (1, 2) 68 | return (1, 2::3::4::[]) 69 | return (2::3::4::[]) 70 | return 10 71 | return (10, Moo 10) 72 | return (42, 42, 42) 73 | return (1, 2, 3, (1, 2, 3)) 74 | return ("foo", "foo", "bar") 75 | ====================================================================== 76 | polymorphism.mlt 77 | ====================================================================== 78 | return (5, "foo") 79 | return (4, "foo") 80 | return (1::u, "foo"::u) 81 | return ([]::v, (2::[])::v) 82 | return (fun x ↦ let h = return (fun t ↦ return (fun u ↦ return u)) in 83 | let b = h x in b x) 84 | return (fun x ↦ let h = return (fun t ↦ return (fun u ↦ return t)) in 85 | let b = h x in b x) 86 | ====================================================================== 87 | polymorphism_id_id.mlt 88 | ====================================================================== 89 | Typing error: Cannot unify int = string 90 | ====================================================================== 91 | recursion.mlt 92 | ====================================================================== 93 | return 5 94 | ====================================================================== 95 | shadow_label.mlt 96 | ====================================================================== 97 | Syntax error (file "shadow_label.mlt", line 2, char 1): 98 | Label Horn defined multiple times. 99 | ====================================================================== 100 | shadow_type.mlt 101 | ====================================================================== 102 | Syntax error (file "shadow_type.mlt", line 3, char 1): 103 | Type cow defined multiple times. 104 | ====================================================================== 105 | test_equality.mlt 106 | ====================================================================== 107 | return true 108 | return false 109 | return true 110 | return false 111 | return false 112 | return true 113 | ====================================================================== 114 | test_less_then.mlt 115 | ====================================================================== 116 | return false 117 | return true 118 | return false 119 | return false 120 | return true 121 | return false 122 | return false 123 | return "composite values" 124 | return true 125 | return false 126 | ====================================================================== 127 | test_precedence_and_associativity.mlt 128 | ====================================================================== 129 | return 1 130 | return 2 131 | return 5 132 | return 1 133 | return 5 134 | return 3 135 | return 27. 136 | return true 137 | return 22 138 | ====================================================================== 139 | test_stdlib.mlt 140 | ====================================================================== 141 | return "test less" 142 | return true 143 | return false 144 | return false 145 | return "test equal" 146 | return true 147 | return true 148 | return "test tilda_minus" 149 | return -1 150 | return -3.14159 151 | return -1. 152 | return "test integer operations" 153 | return 4 154 | return 4 155 | return 19 156 | return 65 157 | return 33 158 | return 0 159 | return 2 160 | return 0 161 | return "test float operations" 162 | return 8. 163 | return 5.84 164 | return 8.478 165 | return 0.44 166 | return 1.16296296296 167 | return infinity 168 | return "13" 169 | return "(1, 2, 3)::[]" 170 | return "(1, 2, 3)" 171 | return "fun x \226\134\166 return x" 172 | return "test some and none" 173 | return None 174 | return (Some 3) 175 | return "test ignore" 176 | return () 177 | return "test not" 178 | return false 179 | return "test compare" 180 | return true 181 | return true 182 | return true 183 | return true 184 | return true 185 | return "test range" 186 | return (4::5::6::7::8::9::[]) 187 | return "test map" 188 | return (1::4::9::16::25::[]) 189 | return "test take" 190 | return 5 191 | return (2::5::8::11::14::17::20::23::26::29::32::35::38::41::44::47::50::53::56::59::62::[]) 192 | return "test fold_left and fold_right" 193 | return 89 194 | return 161 195 | return "test forall, exists and mem" 196 | return false 197 | return true 198 | return false 199 | return "test filter" 200 | return (4::5::[]) 201 | return "test complement and intersection" 202 | return (1::3::5::6::[]) 203 | return (2::4::[]) 204 | return "test zip and unzip" 205 | return ((1, "a")::(2, "b")::(3, "c")::[]) 206 | return (1::2::3::[], "a"::"b"::"c"::[]) 207 | return "test reverse" 208 | return (5::4::3::2::1::[]) 209 | return "test concatenate lists" 210 | return (1::2::3::4::5::6::[]) 211 | return "test length, hd and tl" 212 | return 5 213 | return 1 214 | return (2::3::4::[]) 215 | return "test abs, min and max" 216 | return (5, 5, 5) 217 | return 1 218 | return 2 219 | return "test gcd and lcm" 220 | return 4 221 | return 24 222 | return "test odd and even" 223 | return false 224 | return true 225 | return "test id" 226 | return 5 227 | return id 228 | return "test compose and reverse apply" 229 | return 196 230 | return 7 231 | return "test fst and snd" 232 | return "foo" 233 | return 4 234 | ====================================================================== 235 | tydef.mlt 236 | ====================================================================== 237 | return Tail 238 | return (Node (10, Empty, Node (20, Empty, Empty))) 239 | ====================================================================== 240 | type_annotations.mlt 241 | ====================================================================== 242 | return (fun y ↦ return (fun z ↦ let b = let b = z y in b true in return b)) 243 | ====================================================================== 244 | typing.mlt 245 | ====================================================================== 246 | return (fun y ↦ return y) 247 | return h 248 | ====================================================================== 249 | use_undefined_type.mlt 250 | ====================================================================== 251 | Syntax error (file "use_undefined_type.mlt", line 1, char 19): 252 | Unknown name --bar-- 253 | -------------------------------------------------------------------------------- /tests/shadow_label.mlt: -------------------------------------------------------------------------------- 1 | type cow = Horn of int 2 | type bull = Tail of string | Horn of bull 3 | -------------------------------------------------------------------------------- /tests/shadow_type.mlt: -------------------------------------------------------------------------------- 1 | type cow = Horn of int 2 | type bull = Tail of string 3 | type cow = Hoof of bool 4 | -------------------------------------------------------------------------------- /tests/test_equality.mlt: -------------------------------------------------------------------------------- 1 | run 1 = 1 2 | run 1 = 2 3 | run (1,2) = (1,2) 4 | run (2,1) = (1,2) 5 | run [1;2;3] = [] 6 | run [1;2;3] = [1;2;3] 7 | 8 | (* Nested structures *) 9 | (* Records are currently not supported. 10 | 11 | type ('a,'b) rabbit = { eye : 'a; tail : 'b list } 12 | 13 | run (let x = ([1,2], {eye = 7; tail = []}) in 14 | let y = ([1,3], {eye = 7; tail = []}) in 15 | ("nested", x = x, x = y, y = y)) 16 | *) 17 | 18 | let f x y = x = y -------------------------------------------------------------------------------- /tests/test_less_then.mlt: -------------------------------------------------------------------------------- 1 | run 1 < 1 2 | run 1 < 2 3 | run 2 < 1 4 | run 1.0 < 1.0 5 | run 1.0 < 2.0 6 | run 2.0 < 1.0 7 | run (1.0 /. 0.0) < 1.0 8 | 9 | (* Composite values. *) 10 | run "composite values" 11 | run (1, "foo", []) < (1, "foo", [[]]) (* should be true *) 12 | run (1, "foo", [[]]) < (1, "foo", []) (* should be false *) 13 | 14 | (* records *) 15 | (* Records are currently not supported. 16 | 17 | run "records" 18 | type ('a, 'b) cow = { horn : 'a ; tail : 'b } ;; 19 | 20 | ({horn = 7; tail = "long"} < {horn = 7; tail = "short"}) ;; (* should be true *) 21 | ({horn = 7; tail = "short"} < {horn = 7; tail = "long"}) ;; (* should be false *) 22 | ({horn = 7; tail = "long"} < {tail = "short"; horn = 7}) ;; (* should be true *) 23 | ({horn = 8; tail = "long"} < {tail = "short"; horn = 7}) ;; (* should be false *) 24 | ({horn = [1;2]; tail = 0} < {tail = 0; horn = [3]}) ;; (* should be true *) 25 | ({tail = 0; horn = [3]} > {horn = [3]; tail = 0}) ;; (* should be false *) 26 | *) -------------------------------------------------------------------------------- /tests/test_precedence_and_associativity.mlt: -------------------------------------------------------------------------------- 1 | (* Test associativity. *) 2 | 3 | run 8 / 4 / 2 4 | 5 | run 12 mod 5 mod 3 6 | 7 | (* Test precedence. *) 8 | 9 | run 3 * 1 + 2 10 | 11 | run 3 * 1 - 2 12 | 13 | run 2 + 3 * 1 14 | 15 | run 5 / 2 + 1 16 | 17 | run 3. ** 2. *. 3. 18 | 19 | run 5 mod 3 = 2 20 | 21 | let double = fun x -> x * 2 22 | run double 10 + 2 -------------------------------------------------------------------------------- /tests/test_stdlib.mlt: -------------------------------------------------------------------------------- 1 | (* Check every thing in the standard library. *) 2 | 3 | run "test less" 4 | 5 | run 1 < 2 6 | 7 | run true < false 8 | 9 | run (1,true) < (0,false) 10 | 11 | (* More comprehensive checking of < can be found in test_less_than.eff *) 12 | 13 | run "test equal" 14 | 15 | run 1 = 1 16 | 17 | run 1.0 = 1.0 18 | 19 | (* More comprehensive checking of = can be found in test_equality.eff *) 20 | 21 | (* Assert is not supported. 22 | 23 | run "test assert" 24 | 25 | run assert ("a" = "a");; 26 | 27 | run assert (1.0 /. 0.0 = infinity);; 28 | 29 | run assert (-. 1.0 /. 0.0 = neg_infinity);; 30 | 31 | run assert (0.0 /. 0.0 = nan);; 32 | *) 33 | 34 | run "test tilda_minus" 35 | 36 | run ~-1 37 | 38 | run ~-. 3.14159 39 | 40 | run ~-. 1.0 41 | 42 | run "test integer operations" 43 | 44 | run 2 + 2 45 | 46 | run 2 * 2 47 | 48 | run 42 - 23 49 | 50 | run 42 - ~-23 51 | 52 | run 100 / 3 53 | 54 | (* run 1 / 0 *) (* Raises Division_by_0. *) 55 | 56 | (* run 0 / 0 *) (* Raises Division_by_0. *) 57 | 58 | run 0 / 1 59 | 60 | run 5 mod 3 61 | 62 | run 0 mod 1 63 | 64 | (* run 0 mod 0 *) (* Raises Division_by_0. *) 65 | 66 | (* run 1 mod 0 *) (* Raises Division_by_0. *) 67 | 68 | run "test float operations" 69 | 70 | run 2. ** 3. 71 | 72 | run 3.14 +. 2.7 73 | 74 | run 3.14 *. 2.7 75 | 76 | run 3.14 -. 2.7 77 | 78 | run 3.14 /. 2.7 79 | 80 | run 1.0 /. 0.0 81 | 82 | (* String concatenation is not supported. 83 | 84 | run "test string concatenation" 85 | 86 | run "cherry" ^ "pie" *) 87 | 88 | (* Casting is not supported. 89 | 90 | run "test casting" 91 | 92 | run string_of_float 12. 93 | 94 | run string_of_float 12.0 95 | 96 | run string_of_float -12.000009 97 | 98 | run string_of_int 0 99 | 100 | run string_of_int -18 101 | *) 102 | 103 | run to_string 13 104 | 105 | run to_string [1,2,3] 106 | 107 | run to_string (1,2,3) 108 | 109 | run to_string (fun x -> x) 110 | 111 | (* Casting is not supported. 112 | 113 | run int_of_float ~-.1.5 114 | 115 | run int_of_float 12.0001 116 | 117 | run float_of_int 42 118 | *) 119 | 120 | run "test some and none" 121 | 122 | run None 123 | 124 | run Some 3 125 | 126 | run "test ignore" 127 | 128 | run ignore (2 + 3) 129 | 130 | run "test not" 131 | 132 | run not true 133 | 134 | run "test compare" 135 | 136 | run 3 > 2 137 | 138 | run "foo" > "bar" 139 | 140 | run 1 <= 1 141 | 142 | run 2 >= 1 143 | 144 | run 2 <> 3 145 | 146 | run "test range" 147 | 148 | run range 4 9 149 | 150 | run "test map" 151 | 152 | run map (fun x -> x * x) [1;2;3;4;5] 153 | 154 | run "test take" 155 | 156 | run 3 * 1 + 2 157 | 158 | run take (fun k -> 3 * k + 2) 20 159 | 160 | run "test fold_left and fold_right" 161 | 162 | run fold_left (fun a y -> 2 * a + y) 1 [1;2;3;4;5] 163 | 164 | run fold_right (fun y a -> 2 * a + y) [1;2;3;4;5] 1 165 | 166 | (* Concatenation and check are not supported. 167 | let test_iter = (fun k -> check ("iter " ^ to_string k)) [1;2;3;4;5];; 168 | *) 169 | 170 | run "test forall, exists and mem" 171 | 172 | run forall (fun k -> k mod 3 = 2) [1;2;3;4;5] 173 | 174 | run exists (fun k -> k mod 3 = 2) [1;2;3;4;5] 175 | 176 | run mem "foo" ["bar"; "baz"] 177 | 178 | run "test filter" 179 | 180 | run filter (fun k -> k > 3) [1;2;3;4;5] 181 | 182 | run "test complement and intersection" 183 | 184 | run complement [1; 2; 3; 4; 5; 6] [2; 4; 8] 185 | 186 | run intersection [1; 2; 3; 4; 5; 6] [2; 4; 8] 187 | 188 | run "test zip and unzip" 189 | 190 | run zip [1;2;3] ["a"; "b"; "c"] 191 | 192 | (* Check is not supported. 193 | run check (zip [1;2;3;4;5;6] ["a"; "b"; "c"]) 194 | *) 195 | 196 | run unzip [(1, "a"); (2, "b"); (3, "c")] 197 | 198 | run "test reverse" 199 | 200 | run reverse [1;2;3;4;5] 201 | 202 | run "test concatenate lists" 203 | 204 | run [1;2;3] @ [4;5;6] 205 | 206 | run "test length, hd and tl" 207 | 208 | run length [1;2;3;4;5] 209 | 210 | run hd [1;2;3;4] 211 | 212 | (* Check is not supported. 213 | check (hd []);; 214 | *) 215 | 216 | run tl [1;2;3;4] 217 | 218 | (* Check is not supported. 219 | check (tl []);; 220 | *) 221 | 222 | run "test abs, min and max" 223 | 224 | run abs 5, abs (~-5), abs(-5) 225 | 226 | run min 1 2 227 | 228 | run max 1 2 229 | 230 | run "test gcd and lcm" 231 | 232 | run gcd 12 8 233 | 234 | run lcm 12 8 235 | 236 | run "test odd and even" 237 | 238 | run odd 42 239 | 240 | run even 42 241 | 242 | run "test id" 243 | 244 | run id 5 245 | 246 | run id id 247 | 248 | run "test compose and reverse apply" 249 | 250 | run compose (fun k -> k * k) (fun j -> j +4) 10 251 | 252 | run (3 |> (fun x -> x)) |> (+) 4 253 | 254 | run "test fst and snd" 255 | 256 | run fst ("foo", 4) 257 | 258 | run snd ("foo", 4) 259 | 260 | (* Check is not supported. 261 | 262 | run check (perform (Print "Does this work?")) (* `perform` is not supported. *) 263 | 264 | run check (print "How about now?") (* `print` is not supported. *) 265 | 266 | run check (print 12) 267 | 268 | run check (perform Read) 269 | 270 | run check (failwith "The cows are home.") (* `failwith` is not supported. *) 271 | 272 | *) -------------------------------------------------------------------------------- /tests/tydef.mlt: -------------------------------------------------------------------------------- 1 | type baire = int -> int 2 | 3 | type 'a tree = Empty | Node of 'a * 'a tree * 'a tree 4 | 5 | (* Records are currently not supported. 6 | type complex = {re : float; im : float} 7 | *) 8 | 9 | type ('k,'v) assoc = ('k * 'v) list 10 | 11 | 12 | (* Mutually recursive types. *) 13 | type cow = bull -> int 14 | 15 | and bull = 16 | | Tail 17 | | Legs of bull list 18 | | Horns of cow 19 | 20 | 21 | run Tail 22 | 23 | (* Records are currently not supported. 24 | run {re = 1.2; im = 2.4} 25 | *) 26 | 27 | run (Node (10, Empty, Node (20, Empty, Empty))) -------------------------------------------------------------------------------- /tests/type_annotations.mlt: -------------------------------------------------------------------------------- 1 | (* functions *) 2 | 3 | let f (x: int) = x 4 | 5 | let f (x: int) : int = x 6 | 7 | let f (x: bool) (y: int) (z: int -> bool -> int) : int = z y x 8 | run f true 9 | 10 | let f x : int*int = (x, x) 11 | 12 | let g (x: 'a) = x 13 | let g (x: 'a) : 'a = 12 14 | let g (x: 'a) y : 'a = y 15 | 16 | (* Parsing of the following two expressions fails. 17 | Reported error "Syntax error ... Unknown name --b--" 18 | let g x : 'a*'b = (x, x) 19 | let g (x: 'a) (y: 'b) : 'a*'b = (x, y) *) 20 | 21 | let g x : 'a*'a = (x, x) 22 | 23 | let f = function 24 | | (x: int) -> x 25 | 26 | (* variants *) 27 | type ('a,'b) cow = Small of 'a | Large of 'b 28 | 29 | let f (x : ('a, 'b) cow) : int = 30 | match x with 31 | | Small x -> x 32 | | Large x -> 100 33 | 34 | let f x : int = 35 | match x with 36 | | Small s -> 100 37 | | Large (l :int) -> 100 38 | 39 | (* records *) 40 | (* Records are not supported. 41 | type ('a,'b) bull = {small : 'a; large : 'b} 42 | 43 | let f {small= (x: int); large= (y: int)} = x 44 | *) 45 | 46 | (* other *) 47 | let x = ([] : int list) -------------------------------------------------------------------------------- /tests/typing.mlt: -------------------------------------------------------------------------------- 1 | (* Basic types *) 2 | let b = 3 3 | let b = true 4 | let b = "foo" 5 | let b = () 6 | let b = 4.2 7 | 8 | 9 | (* Tuples *) 10 | let t = (3,4) 11 | let t = ([], "foo") 12 | 13 | (* variants *) 14 | type ('a,'b) cow = Small of 'a | Large of 'b 15 | let v = Small "brown" 16 | let v = Large "white" 17 | let v = (fun cow -> match cow with Small k -> Large (k + 3) | Large s -> Small ("foo"::s)) 18 | 19 | (* records *) 20 | (* Records are not supported. 21 | type ('a,'b) bull = {small : 'a; large : 'b};; 22 | {small = 5; large = "foo"};; 23 | (fun {small=k} -> k + 2);; 24 | (fun {large=l} -> [] :: l);; 25 | *) 26 | 27 | 28 | (* Polymorphism *) 29 | 30 | let f = (fun x -> x) 31 | run (fun x -> x) (fun y -> y) 32 | let f = (fun x -> (x, x)) 33 | let f = ((fun x -> x), []) 34 | 35 | (* let f = ((fun x -> x), (fun x -> x) (fun y -> y)) *) 36 | 37 | let f = (fun x y -> x) 38 | let v = [[[]]] 39 | let f = (fun x y -> (fun a -> a) x) 40 | 41 | let rec h x = x 42 | run h -------------------------------------------------------------------------------- /tests/use_undefined_type.mlt: -------------------------------------------------------------------------------- 1 | type foo = One of bar | Two of int 2 | 3 | type bar = int -> int -------------------------------------------------------------------------------- /web/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Millet 8 | 9 | 10 | 23 | 24 | 25 | 26 |
27 |
28 |
29 |
30 | 31 | 32 | --------------------------------------------------------------------------------