├── .github └── workflows │ └── test.yml ├── .gitignore ├── .ocamlformat ├── Dockerfile ├── LICENSE ├── README.md ├── backend ├── aNormal.ml ├── alpha.ml ├── assoc.ml ├── beta.ml ├── closure.ml ├── constant.ml ├── dune ├── elim.ml ├── inline.ml ├── js.ml ├── kNormal.ml ├── llvm.ml └── prim.ml ├── desugaring └── dune ├── docs └── tutorial.org ├── driver.ml ├── dune ├── dune-project ├── editor ├── dune ├── home.html ├── index.html └── jstina.ml ├── eff.koka ├── eff.ml ├── errors ├── dune └── errors.ml ├── examples ├── a.tina ├── b.tina ├── c.tina ├── d.tina ├── demo.tina ├── e.tina ├── f.tina ├── g.tina ├── h.tina ├── i.tina ├── j.tina ├── k.tina ├── l.tina ├── m.tina ├── n.tina ├── next.tina ├── o.tina ├── p.tina ├── q.tina ├── r.tina ├── s.tina ├── t.tina ├── test.tina ├── typing.tina ├── u.tina └── what.tina ├── features.org ├── file.js ├── file.tina ├── new.js ├── new.tina ├── parsing ├── Makefile ├── README.md ├── dune ├── grammar.mly ├── lexer.mll ├── parserEntry.ml ├── parserMessages.messages └── parserMessages.messages.old ├── repl.ml ├── runtime.js ├── runtime ├── desugarCase.ml ├── desugarData.ml ├── desugarEffect.ml ├── dune ├── eval.ml ├── eval2.ml ├── value.ml └── value2.ml ├── settings ├── dune └── settings.ml ├── shell ├── dune └── shell.ml ├── syntax ├── ast.ml ├── dune ├── loc.ml ├── loc.mli ├── naming.ml ├── tast.ml └── type.ml ├── tests ├── dune ├── parser_tests.ml └── tests.ml ├── tina.opam ├── type.tina ├── typing ├── ctx.ml ├── dune └── typecheck.ml └── utility ├── dune └── utility.ml /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Tina 2 | 3 | on: 4 | - pull_request 5 | - push 6 | 7 | jobs: 8 | build: 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | os: 13 | - ubuntu-latest 14 | ocaml-version: 15 | - 4.12.0 16 | 17 | runs-on: ${{ matrix.os }} 18 | 19 | steps: 20 | - name: Checkout code 21 | uses: actions/checkout@v2 22 | 23 | - name: Use OCaml ${{ matrix.ocaml-version }} 24 | uses: avsm/setup-ocaml@v1 25 | with: 26 | ocaml-version: ${{ matrix.ocaml-version }} 27 | 28 | - run: opam pin add tina.dev -n . 29 | 30 | - run: opam depext -yt tina 31 | 32 | - run: opam install -t . --deps-only 33 | 34 | - run: opam exec -- dune build 35 | 36 | - run: opam exec -- dune runtest 37 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | # emacs files 3 | *~ 4 | 5 | *.annot 6 | *.cmo 7 | *.cma 8 | *.cmi 9 | *.a 10 | *.o 11 | *.cmx 12 | *.cmxs 13 | *.cmxa 14 | *.out 15 | 16 | # ocamlbuild working directory 17 | _build/ 18 | 19 | # ocamlbuild targets 20 | *.byte 21 | *.native 22 | 23 | # oasis generated files 24 | setup.data 25 | setup.log 26 | 27 | # Merlin configuring file for Vim and Emacs 28 | .merlin 29 | 30 | # Dune generated files 31 | *.install 32 | 33 | # Local OPAM switch 34 | _opam/ -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.18.0 -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/Dockerfile -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 Oghenevwogaga Ebresafe 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | # Tina Programming Language 4 | 5 | 6 | ![Build](https://github.com/ebresafegaga/tina/actions/workflows/test.yml/badge.svg) 7 | 8 | ## Welcome to Tina 9 | 10 | Tina is a programming language based algebraic effects and handlers. 11 | This implementation contains an interpreter and two compilers (JavaScript and LLVM) 12 | 13 | While algebraic effects and handlers might be the central concept 14 | aroun Tina, it also supports other features such as pattern matching, 15 | closures, algebraic data types, and a type system. 16 | 17 | This is a work in progress. 18 | 19 | 20 | ## Contributing to Tina 21 | 22 | Everyone is free to contribute! 23 | 24 | ## Getting Started 25 | 26 | There is an online playground comming soon! 27 | 28 | ## Building 29 | 30 | Building Tina is relatively straight forward once you have the 31 | required toolchains installed. 32 | 33 | You would need: 34 | - Dune 35 | - OCaml (>= 4.12) 36 | - Opam 37 | 38 | Steps to build 39 | - Clone this repo: 40 | ``` 41 | $ git clone https://github.com/ebresafegaga/tina 42 | ``` 43 | 44 | - Pin it to the this version 45 | ``` 46 | $ opam pin add tina.dev -n . 47 | ``` 48 | 49 | - Install native dependecies 50 | ``` 51 | $ opam depext -yt tina 52 | ``` 53 | 54 | - Install library dependecies 55 | ``` 56 | $ opam install -t . --deps-only 57 | ``` 58 | 59 | - Build the whole project 60 | ``` 61 | $ dune build 62 | ``` 63 | 64 | -------------------------------------------------------------------------------- /backend/aNormal.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/aNormal.ml -------------------------------------------------------------------------------- /backend/alpha.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/alpha.ml -------------------------------------------------------------------------------- /backend/assoc.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/assoc.ml -------------------------------------------------------------------------------- /backend/beta.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/beta.ml -------------------------------------------------------------------------------- /backend/closure.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/closure.ml -------------------------------------------------------------------------------- /backend/constant.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/constant.ml -------------------------------------------------------------------------------- /backend/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name backend) 3 | (libraries utility syntax errors desugaring runtime)) 4 | -------------------------------------------------------------------------------- /backend/elim.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/elim.ml -------------------------------------------------------------------------------- /backend/inline.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/inline.ml -------------------------------------------------------------------------------- /backend/js.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Naming 3 | open Runtime 4 | open Utility 5 | module A = KNormal 6 | 7 | type expression = 8 | | LitBool of bool 9 | | LitInteger of int 10 | | LitFloat of float 11 | | LitString of string 12 | | Variable of string 13 | | Application of expression * expression list 14 | | Fn of VarName.t list * statement list 15 | | Record of (VarName.t * expression) list 16 | | RecordIndex of expression * VarName.t 17 | 18 | and statement = 19 | | Ignore of expression 20 | | If of expression * statement list * statement list 21 | | Return of expression option 22 | | Let of VarName.t * expression 23 | 24 | type toplevel = Def of string * expression | Expression of expression 25 | 26 | type statements = statement list 27 | 28 | let levels = ref ([] : statements list) 29 | 30 | let add_current_level statement = 31 | match !levels with 32 | | [] -> levels := [ [ statement ] ] 33 | | x :: xs -> 34 | let x = statement :: x in 35 | let lvl = x :: xs in 36 | levels := lvl 37 | 38 | let incr_level () = levels := [] :: !levels 39 | 40 | let remove_level () = 41 | match !levels with 42 | | [] -> [] 43 | | x :: xs -> 44 | levels := xs; 45 | x 46 | 47 | let variable name = Variable (VarName.to_string name) 48 | 49 | let rec gexpr = function 50 | | A.Variable name -> variable name 51 | | A.LitBool b -> LitBool b 52 | | A.LitInteger i -> LitInteger i 53 | | A.LitFloat f -> LitFloat f 54 | | A.LitString s -> LitString s 55 | | A.Fn (args, e) -> 56 | incr_level (); 57 | Fn (args, gstate e) 58 | | A.Application (f, args) -> 59 | let args = args |> List.map variable in 60 | let f = variable f in 61 | Application (f, args) 62 | | A.Record fields -> 63 | let var = FieldName.to_string >> VarName.of_string in 64 | let fields = List.map (fun (v, e) -> (var v, variable e)) fields in 65 | Record fields 66 | | A.RecordIndex (name, index) -> 67 | let name = variable name in 68 | let var = FieldName.to_string >> VarName.of_string in 69 | RecordIndex (name, var index) 70 | | A.Absurd (s, _e) -> 71 | let absurd = Variable "absurd" in 72 | Application (absurd, [ LitString s ]) 73 | (* these are statements in javascript *) 74 | | A.Let (x, expr, body) -> 75 | let l = Let (x, gexpr expr) in 76 | add_current_level l; 77 | gexpr body 78 | | A.If _ as iff -> 79 | (* let name = VarName.fresh "if" in *) 80 | let exp = Fn ([], gstate iff) in 81 | (* let stm = Let (name, Application (exp, [])) in *) 82 | (* add_current_level stm; *) 83 | Application (exp, []) 84 | 85 | and gstate expr = 86 | match expr with 87 | | A.LitBool _ | A.LitFloat _ | A.LitString _ | A.LitInteger _ | A.Variable _ 88 | | A.Application _ | Record _ | RecordIndex _ | A.Absurd _ | A.Fn _ -> 89 | [ Return (Some (gexpr expr)) ] 90 | | A.Let (x, expr, body) -> Let (x, gexpr expr) :: gstate body 91 | | A.If (p, pt, pf) -> 92 | let p = variable p in 93 | [ If (p, gstate pt, gstate pf) ] 94 | 95 | and gcomp expr = 96 | match expr with 97 | | A.LitBool _ | A.LitFloat _ | A.LitString _ | A.LitInteger _ | A.Variable _ 98 | | A.Application _ | Record _ | RecordIndex _ | A.Absurd _ | A.Fn _ -> 99 | [ Ignore (gexpr expr) ] 100 | | A.Let (x, expr, body) -> Let (x, gexpr expr) :: gstate body 101 | | A.If (p, pt, pf) -> 102 | let p = variable p in 103 | [ If (p, gstate pt, gstate pf) ] 104 | 105 | let handle_top = function 106 | | A.Def (name, expr) -> Def (VarName.to_string name, gexpr expr) 107 | | A.Expression e -> Expression (gexpr e) 108 | 109 | let handle_toplevel = List.map handle_top 110 | 111 | let pp_list es f = es |> List.map f |> String.concat ", " 112 | 113 | let combine_statement es = es |> String.concat "; " 114 | 115 | let rec gen_expression = function 116 | | LitInteger i -> string_of_int i 117 | | LitBool b -> string_of_bool b 118 | | LitFloat f -> string_of_float f 119 | | LitString s -> Printf.sprintf {|"%s"|} s 120 | | Variable s -> s 121 | | Application (f, args) -> 122 | Printf.sprintf "(%s) (%s)" (gen_expression f) (pp_list args gen_expression) 123 | | Fn (args, body) -> 124 | Printf.sprintf {| (%s) => { %s } |} 125 | (pp_list args VarName.to_string) 126 | (combine_statement (List.map gen_statement body)) 127 | | Record fields -> 128 | Printf.sprintf "{ %s }" 129 | (pp_list fields (fun (name, expr) -> 130 | Printf.sprintf "%s: %s" (VarName.to_string name) 131 | (gen_expression expr))) 132 | | RecordIndex (expr, index) -> 133 | Printf.sprintf "%s[%s]" (gen_expression expr) (VarName.to_string index) 134 | 135 | and gen_statement = function 136 | | Return (Some e) -> Printf.sprintf "return %s;" (gen_expression e) 137 | | Return None -> "return;" 138 | | If (p, pt, pf) -> 139 | Printf.sprintf 140 | {| if (%s) { 141 | %s 142 | } else { 143 | %s 144 | } |} 145 | (gen_expression p) 146 | (combine_statement (List.map gen_statement pt)) 147 | (combine_statement (List.map gen_statement pf)) 148 | | Let (x, e) -> 149 | Printf.sprintf "let %s = %s" (VarName.to_string x) (gen_expression e) 150 | | Ignore e -> Printf.sprintf "%s;" (gen_expression e) 151 | 152 | let gen_toplevel = function 153 | | Def (name, expr) -> (* make const for constant values and function for function definations *) 154 | Printf.sprintf "const %s = %s; %s" name (gen_expression expr) 155 | (combine_statement (List.map gen_statement @@ remove_level ())) 156 | | Expression e -> 157 | Printf.sprintf "%s; %s;" (gen_expression e) 158 | (combine_statement (List.map gen_statement @@ remove_level ())) 159 | -------------------------------------------------------------------------------- /backend/kNormal.ml: -------------------------------------------------------------------------------- 1 | open Utility 2 | open Syntax 3 | open Naming 4 | open Runtime 5 | 6 | module A = DesugarCase 7 | 8 | type t = 9 | | LitBool of bool 10 | | LitInteger of int 11 | | LitFloat of float 12 | | LitString of string 13 | | Variable of VarName.t 14 | | If of VarName.t * t * t 15 | | Application of VarName.t * VarName.t list 16 | | Let of VarName.t * t * t 17 | | Fn of VarName.t list * t 18 | | Record of (FieldName.t * VarName.t) list 19 | | RecordIndex of VarName.t * FieldName.t 20 | | Absurd of string * t 21 | 22 | type toplevel = Def of VarName.t * t | Expression of t 23 | 24 | (* this function does all the magic *) 25 | let insert_let expr k = 26 | match expr with 27 | | Variable x -> k x 28 | | _ -> 29 | let x = VarName.fresh "x" in 30 | let e = k x in 31 | Let (x, expr, e) 32 | 33 | let rec g0 = function 34 | | A.LitBool (_loc, b) -> LitBool b 35 | | A.LitInteger (_loc, i) -> LitInteger i 36 | | A.LitFloat (_loc, f) -> LitFloat f 37 | | A.LitString (_loc, s) -> LitString s 38 | | A.Variable (_loc, x) -> Variable x 39 | | A.If (_loc, p, pt, pf) -> 40 | insert_let (g0 p) 41 | (fun x -> 42 | If (x, (g0 pt), (g0 pf))) 43 | | A.Application (_loc, f, args) -> 44 | insert_let (g0 f) 45 | (fun f -> 46 | sequence args 47 | (fun args -> 48 | Application (f, args))) 49 | | A.Let (_loc, x, expr, body) -> Let (x, g0 expr, g0 body) 50 | | A.Fn (_loc, args, body) -> Fn (args, g0 body) 51 | | A.Record (_loc, fields) -> 52 | let tags, exprs = List.split fields in 53 | sequence exprs 54 | (fun xs -> 55 | Record (List.combine tags xs)) 56 | | A.RecordIndex (_loc, expr, index) -> 57 | insert_let (g0 expr) 58 | (fun x -> 59 | RecordIndex (x, index)) 60 | | A.Absurd (s, e) -> Absurd (s, g0 e) 61 | 62 | (* A.t list -> (VarName.t list -> t) -> t*) 63 | and sequence es k = 64 | match es with 65 | | [] -> k [] 66 | | e :: es -> 67 | insert_let (g0 e) 68 | (fun x -> 69 | sequence es 70 | (fun xs -> 71 | k (x :: xs))) 72 | 73 | (* flatten nested let bindings *) 74 | let rec g1 = function 75 | | If (p, pt, pf) -> If (p, g1 pt, g1 pf) 76 | | Fn (args, body) -> Fn (args, g1 body) 77 | | Let (x, expr, body) -> 78 | let rec insert = function 79 | | Let (y, yexpr, ybody) -> Let (y, yexpr, insert ybody) 80 | | e -> Let (x, e, g1 body) 81 | in 82 | insert (g1 expr) 83 | | e -> e 84 | 85 | 86 | let g = g0 >> g1 87 | 88 | let handle_top = function 89 | | A.Def (_loc, name, body) -> Def (name, g body) 90 | | A.Expression e -> Expression (g e) 91 | 92 | let handle_toplevel = List.map handle_top 93 | 94 | (* boilerplate pretty pprinting stuff *) 95 | 96 | let pp_list es f = es |> List.map f |> String.concat ", " 97 | 98 | let rec pp_expression = function 99 | | LitBool (b) -> Bool.to_string b 100 | | LitInteger ( i) -> Int.to_string i 101 | | LitFloat ( f) -> Float.to_string f 102 | | LitString ( s) -> s 103 | | Variable ( v) -> VarName.to_string v 104 | | If ( pred, tru, fals) -> 105 | Printf.sprintf "if %s then %s else %s" 106 | (VarName.to_string pred) 107 | (pp_expression tru) 108 | (pp_expression fals) 109 | | Application ( rand, es) -> 110 | Printf.sprintf "%s (%s)" 111 | (VarName.to_string rand) 112 | (pp_list es VarName.to_string) 113 | | Let ( var, value, body) -> 114 | Printf.sprintf "let %s = %s; %s" 115 | (VarName.to_string var) 116 | (pp_expression value) 117 | (pp_expression body) 118 | | Fn ( names, body) -> 119 | Printf.sprintf "fn (%s) %s" 120 | (pp_list names VarName.to_string) 121 | (pp_expression body) 122 | | Record ( fes) -> 123 | let f (field, expr) = 124 | Printf.sprintf "%s: %s" 125 | (FieldName.to_string field) 126 | (VarName.to_string expr) 127 | in 128 | Printf.sprintf "{%s}" 129 | (pp_list fes f) 130 | | RecordIndex ( expr, name) -> 131 | Printf.sprintf "%s.%s" 132 | (VarName.to_string expr) 133 | (FieldName.to_string name) 134 | | Absurd (s, e) -> 135 | Printf.sprintf "absurd (%s, %s)" s (pp_expression e) 136 | 137 | let pp_toplevel = function 138 | | Def ( name, expr) -> 139 | Printf.sprintf "def %s = %s" 140 | (VarName.to_string name) 141 | (pp_expression expr) 142 | | Expression expr -> pp_expression expr 143 | -------------------------------------------------------------------------------- /backend/llvm.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/llvm.ml -------------------------------------------------------------------------------- /backend/prim.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/backend/prim.ml -------------------------------------------------------------------------------- /desugaring/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name desugaring) 3 | (libraries )) 4 | -------------------------------------------------------------------------------- /docs/tutorial.org: -------------------------------------------------------------------------------- 1 | Computational effects, in general, are any observable change a 2 | function makes to its enclosing enviroment; this includes I/O 3 | operations, network request, database connections, mutable states, 4 | generating random variables, and basically anything that interacts 5 | with the "real world". The idea of a pure function pervades functional 6 | programming. A pure function is one which is free of computational 7 | effect and, it can be viewed as a mathematical function in that 8 | sense. The beuaty and rationale behind pure functions is something 9 | known as local reasoning: since a function returns the same value for 10 | each input we can easily write correct programs and maybe prove them 11 | correct. Another benefit of pure functions is that in a multithreading 12 | setting, we don't need to use lock, mutexes, or write barriers to 13 | access variable; since values are not changing we don't need to deal 14 | with horrible race conditions. Clearly, pure functions are a 15 | desireable thing, but there is a little problem: we write programs 16 | solely for their effects. To solve this problem, we need to a means of 17 | combination for computational effects and pure function. Regardless of 18 | how ironic they sound when put together, there are clever solutions to 19 | this problem already. One of such solutions involve monads which has 20 | roots in category theory. In this paper, we focus on bringing 21 | computaional effects to pure functions using albegraic effects and 22 | effect handlers. 23 | -------------------------------------------------------------------------------- /driver.ml: -------------------------------------------------------------------------------- 1 | 2 | let () = Repl.run () 3 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name driver) 3 | ;; (flags -ccopt -static) 4 | (modes byte exe) 5 | (libraries utility syntax parsing typing backend runtime)) 6 | 7 | (env 8 | (dev 9 | (flags 10 | (:standard -warn-error -A)))) 11 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.8) 2 | (using menhir 2.1) 3 | (generate_opam_files true) 4 | 5 | (name tina) 6 | (version dev) 7 | (source (github ebresafegaga/tina)) 8 | (authors "Oghenevwogaga Ebresafe") 9 | ; (license BSD2) 10 | (maintainers "ebresafegaga@gmail.com") 11 | 12 | (package 13 | (name tina) 14 | (synopsis "Tina, an educational programming language with first-class types and abilities.") 15 | (depends 16 | menhir 17 | js_of_ocaml 18 | js_of_ocaml-ppx 19 | js_of_ocaml-compiler 20 | brr 21 | alcotest 22 | (ocaml (>= 4.08.1)))) 23 | -------------------------------------------------------------------------------- /editor/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name jstina) 3 | (modes js) 4 | (preprocess 5 | (pps js_of_ocaml-ppx)) 6 | (libraries 7 | utility 8 | ;syntax 9 | ;parser 10 | ;backend 11 | ;runtime 12 | shell 13 | settings 14 | js_of_ocaml 15 | js_of_ocaml-compiler) 16 | 17 | ; (promote 18 | ; (until-clean) 19 | ; (into .) 20 | ; (only jstina.bc.js)) 21 | ) 22 | -------------------------------------------------------------------------------- /editor/home.html: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/editor/home.html -------------------------------------------------------------------------------- /editor/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Tina Programming Language 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 92 | 93 | 94 | 95 | 108 |
109 |
110 | 118 | 119 | 120 | 129 | 130 |
131 | 132 | 133 | 134 | 135 | 136 | 137 |
138 |
139 |
140 | 141 | 168 |
169 | 170 | 171 | 172 | -------------------------------------------------------------------------------- /editor/jstina.ml: -------------------------------------------------------------------------------- 1 | open Js_of_ocaml 2 | 3 | let js_formatter _format echo = 4 | let buffer = ref "" in 5 | let out s p n = buffer := !buffer ^ String.sub s p n in 6 | let flush () = 7 | (Js.Unsafe.fun_call echo [| Js.Unsafe.inject (Js.string !buffer) |] : unit); 8 | buffer := "" 9 | in 10 | Format.make_formatter out flush 11 | 12 | (* Export the interface to Javascript. *) 13 | let () = 14 | Js.export "jstina" 15 | (object%js 16 | method initialize echo = 17 | Settings.output_formatter := js_formatter "[;#00a8ff;#192a56]" echo; 18 | Settings.error_formatter := js_formatter "[b;#e84118;#192a56]" echo; 19 | Format.fprintf !Settings.output_formatter "Tina %s@." Settings.version 20 | 21 | method executeSource source = 22 | Shell.execute_source (Js.to_string source) 23 | 24 | method loadSource source = Shell.execute_source (Js.to_string source) 25 | 26 | method compileJS source = Shell.compile_js (Js.to_string source) 27 | end) 28 | -------------------------------------------------------------------------------- /eff.koka: -------------------------------------------------------------------------------- 1 | effect state { 2 | fun get() : a 3 | fun set( x : a ) : () 4 | } 5 | 6 | fun pstate( init : b, action : () -> > (a, b) ) : () -> (a, b) { 7 | fn () { 8 | with handler { 9 | return(x) { fn (st) { (x,st) } } 10 | fun get() { fn (st) { resume (st) (st) } } 11 | fun set(i) { fn (idk) { resume () (i) } } 12 | } 13 | action () (init) 14 | } 15 | } 16 | 17 | fun main () { 18 | } 19 | 20 | -------------------------------------------------------------------------------- /eff.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | effect Add : int * int -> int 4 | 5 | let comp () = 6 | let a = perform @@ Add (5, 6) in 7 | let b = perform @@ Add (2, 2) in 8 | a + b 9 | 10 | let () = 11 | let result = 12 | match comp () with 13 | | v -> v 14 | | effect (Add (a, b)) k -> continue k (a+b) 15 | in 16 | print_int result 17 | *) 18 | -------------------------------------------------------------------------------- /errors/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name errors) 3 | (libraries)) 4 | -------------------------------------------------------------------------------- /errors/errors.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | exception RuntimeError of string 4 | 5 | let runtime s = raise @@ RuntimeError s 6 | 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /examples/a.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | handle ( 4 | handle (handle (let a = do Get (); a) { 5 | return x -> x, 6 | Get () k -> 7 | let v = do N (); 8 | k (v) 9 | }) { 10 | return x -> x, 11 | N () k -> 12 | let a = do Id ("me"); 13 | let v = do Add (1, 2); 14 | v 15 | }) { 16 | return any -> any, 17 | Id (v) k -> k (v), 18 | Add (a, b) k -> k ((a, b)) 19 | } -------------------------------------------------------------------------------- /examples/b.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | handle (let y = do N ("ogaga", 20); 4 | let b = do S (); 5 | "hello " + y + " you are " + b + " years old ") { 6 | return x -> x, 7 | N (a, b) k -> k (a), 8 | S () k -> k (20) 9 | } 10 | 11 | 12 | handle (let a = do Number (); 13 | let b = do Number (); 14 | a +b ) { 15 | return a -> a, 16 | Number () k -> 17 | let c = k (10); 18 | let d = k (20); 19 | c 20 | } 21 | 22 | 23 | handle (let a = do Get (); 24 | if a then "t" else "false") { 25 | return x -> x, 26 | Get () k -> k (true) 27 | } 28 | 29 | handle (let a = do Get (); 30 | case (a) { 0 -> "yay", y -> y } ) { 31 | return x -> x, 32 | Get () k -> 99234 33 | } 34 | 35 | 36 | {- 37 | handle 10 { 38 | return x -> x, 39 | } 40 | -} 41 | 42 | handle (let k = do K (); 43 | k) { 44 | return x -> x, 45 | K () k -> k ("my k") 46 | } 47 | 48 | handle (handle do N () { 49 | return y -> y, }) { 50 | return x -> x, 51 | N () k -> k (1) 52 | } 53 | 54 | handle (handle (handle do N () { 55 | return y -> y, }) { 56 | return x -> x, 57 | }) { 58 | return z -> z, 59 | N () k -> k ("fuck yeah") 60 | } 61 | 62 | 63 | def b = handle do Read () { 64 | return x -> x, 65 | Read () k -> 66 | let r = k (13); 67 | let s = k (12); 68 | let b = (fn (xs) xs); 69 | "ogaga" 70 | } 71 | 72 | 73 | 74 | datatype p = { claim a String, claim b Nat} 75 | 76 | def v = p { a: "og", b: 10 } 77 | -------------------------------------------------------------------------------- /examples/c.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | ((fn (a) fn (b) b) (10)) (let x = 11; x) 4 | 5 | def g = fn (a) fn (b) b 6 | 7 | def f = g (10) 8 | 9 | -- let f = g (10); f ("i") 10 | 11 | g (10) ("og") 12 | 13 | -- g ("str") (2) 14 | 15 | handle (let v = do Add (5, 6); v) { 16 | return x -> x, 17 | Add (a, b) k -> 10 18 | } -------------------------------------------------------------------------------- /examples/d.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | def name = 12 4 | 5 | name 6 | 7 | def tuple (a, b) = (a, b) 8 | 9 | def id (x) = x 10 | 11 | tuple ("ogaga", name) 12 | 13 | id (10) 14 | 15 | if true then 10 else "no" -------------------------------------------------------------------------------- /examples/demo.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | -- basic features 6 | 7 | -- recursive functions 8 | 9 | def fib (n) = 10 | case (n) { 11 | 1 -> 0, 12 | 2 -> 1, 13 | n -> fib (n - 1) + fib (n - 2) 14 | } 15 | 16 | "Fib numbers" 17 | fib (1) 18 | fib (2) 19 | fib (3) 20 | fib (4) 21 | fib (5) 22 | fib (10) 23 | 24 | 25 | datatype subject = 26 | { claim name String, 27 | claim code Nat, 28 | claim other String } 29 | 30 | def o = subject { name: "MAT 423", code: 423, other: "no other" } 31 | 32 | def math = subject { name: "MAT 423", code: 423, other: o} 33 | 34 | case (math) { 35 | subject { name: n, code: c, other: subject {name: n1, code: c1}} -> (n, c, n1, c1) 36 | } 37 | 38 | datatype level = L100 | L200 | L300 | L400 | L500 39 | 40 | def l = L100 41 | 42 | case (l) { 43 | L100 -> 100, 44 | L200 -> 200, 45 | L300 -> 300, 46 | L400 -> 400, 47 | L500 -> 500 48 | } 49 | 50 | 51 | -- basic features 52 | 53 | -- booleans 54 | 55 | true 56 | 57 | false 58 | 59 | -- integers 60 | 61 | 10 62 | 63 | -- floats 64 | 65 | 23.34 66 | 67 | -- string 68 | 69 | "this is a string" 70 | 71 | -- tuples 72 | 73 | def t = (10, 343) 74 | 75 | -- first-class functions (or closures) 76 | 77 | def add = 78 | fn (x) 79 | fn (y) x + y 80 | 81 | -- top level definitions 82 | 83 | 84 | def name = "ogaga" 85 | 86 | def age = 20 87 | 88 | -- toplevel function definition 89 | 90 | def pair_up (x, y) = (x, y) 91 | 92 | def identity (x) = x 93 | 94 | -- function application 95 | 96 | def og = identity ("og") 97 | 98 | -- pattern matching 99 | 100 | def is_me (p) = 101 | case (p) { 102 | "not me" -> "this would not be matched", 103 | "ogaga" -> "this is me" 104 | } 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | -- type checking 115 | 116 | -- Tina uses a bidirectional type checker so it can do type inference 117 | 118 | claim a Int 119 | def a = 10 120 | 121 | claim b String 122 | def b = "this is a string" 123 | 124 | claim c Float 125 | def c = 1.2222 126 | 127 | claim add (Int, Int -> Int) 128 | def add (x, y) = x + y 129 | 130 | claim pair (String, Int) 131 | def pair = ("str", 34) 132 | 133 | 134 | datatype Name = Ogaga | Afoke | Fejiro (Float) | Yoma (Nat, String) | Vovwero (Nat, Nat) 135 | 136 | def o = Ogaga 137 | 138 | def y = Yoma (10, "ooo") 139 | 140 | def v = Vovwero (23, 2) 141 | 142 | case (v) { 143 | Vovwero (Fejiro (x, y), b) -> (x, y, b), 144 | Fejiro (f) -> f, 145 | Ogaga -> "ogaga", 146 | Afoke -> "afoks", 147 | Yoma (a, b) -> (b, a) 148 | } 149 | 150 | datatype person = 151 | { claim name String, 152 | claim age Nat } 153 | 154 | 155 | def p = person { name: Yoma (23, "elim"), age: 24 } 156 | 157 | p.name 158 | 159 | 160 | -- algebraic effects 161 | 162 | 163 | def invoke () = 164 | let a = do Number1 (); 165 | let b = do Number2 (); 166 | (a, b) 167 | 168 | handle invoke () { 169 | return a -> a, 170 | Number1 () k -> k (1), 171 | Number2 () k -> k (2) 172 | } 173 | 174 | 175 | {- 176 | 177 | let a = 10; 178 | let b = 20; 179 | (a, b) 180 | 181 | -} 182 | 183 | def decide () = if do Decide () then "ogaga" else "afoke" 184 | 185 | def id (x) = do Hey (x) 186 | 187 | handle id (10) { 188 | return x -> x, 189 | Hey (v) k -> (v, "ahhh") 190 | } 191 | 192 | handle decide () { 193 | return c -> c, 194 | Decide () k -> k (true) 195 | } 196 | 197 | 198 | -- js compilation 199 | 200 | 201 | 202 | datatype subject = 203 | { claim name String, 204 | claim code Nat, 205 | claim other String } 206 | 207 | def o = subject { name: "MAT 423", code: 423, other: "no other" } 208 | 209 | def math = subject { name: "MAT 423", code: 423, other: o} 210 | 211 | case (math) { 212 | subject { name: n, code: c, other: subject {name: n1, code: c1}} -> (n, c, n1, c1) 213 | } 214 | 215 | datatype level = L100 | L200 | L300 | L400 | L500 216 | 217 | def l = L100 218 | 219 | case (l) { 220 | L100 -> 100, 221 | L200 -> 200, 222 | L300 -> 300, 223 | L400 -> 400, 224 | L500 -> 500 225 | } 226 | 227 | 228 | datatype Name = Ogaga | Afoke | Fejiro (Float) | Yoma (Nat, String) | Vovwero (Nat, Nat) 229 | 230 | def o = Ogaga 231 | 232 | def y = Yoma (10, "ooo") 233 | 234 | def v = Vovwero (23, 2) 235 | 236 | case (v) { 237 | Vovwero (Fejiro (x, y), b) -> (x, y, b), 238 | Fejiro (f) -> f, 239 | Ogaga -> "ogaga", 240 | Afoke -> "afoks", 241 | Yoma (a, b) -> (b, a) 242 | } 243 | 244 | datatype person = 245 | { claim name String, 246 | claim age Nat } 247 | 248 | 249 | def p = person { name: Yoma (23, "elim"), age: 24 } 250 | 251 | p.name -------------------------------------------------------------------------------- /examples/e.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | datatype person = { claim name String, claim age Nat } 4 | 5 | def e = person {name: "ogag", age:12 } 6 | 7 | case (e) { 8 | person {name: e, age:a } -> (e, a) 9 | } 10 | 11 | def k = fn (a) fn (e) a 12 | 13 | def s = fn (esv) fn (es) fn (e) esv (e) (es (e)) 14 | 15 | def i = s (k) (k) 16 | 17 | i (1000) -------------------------------------------------------------------------------- /examples/f.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | handle (handle do N () { 4 | return y -> y, 5 | }) { 6 | return x -> x, 7 | N () k -> 8 | let name = "tinu"; 9 | let c = "afoke"; 10 | let d = k (1); 11 | 1000 12 | } 13 | 14 | def f (x) = do Comp (x) 15 | 16 | -- def g (x) = x 17 | 18 | handle do Comp ((void)) { 19 | return c -> "should not be printed", 20 | Comp (v) k -> (v, "a mil") 21 | } 22 | 23 | datatype e = Og | Ogaga (Nat, Nat) 24 | 25 | Og 26 | 27 | Ogaga (45, 45) -------------------------------------------------------------------------------- /examples/g.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | def get () = do Get (1, 4) 4 | -- there's something wrong 5 | 6 | handle ( 7 | handle get () { 8 | return x -> x, 9 | Get () k -> "fail", 10 | Get (a, b) k -> do Set (20) 11 | } 12 | ) { 13 | return x -> x, 14 | Set (v) k -> k (v) 15 | } -------------------------------------------------------------------------------- /examples/h.tina: -------------------------------------------------------------------------------- 1 | 2 | let name = "ogaga"; 3 | let og = 12; 4 | og -------------------------------------------------------------------------------- /examples/i.tina: -------------------------------------------------------------------------------- 1 | 2 | () 3 | 4 | 32.44 5 | 6 | 10 7 | 8 | "abc" 9 | 10 | fn (x) x 11 | 12 | datatype person = { claim age Nat, 13 | claim name String } 14 | 15 | def p = person { age: 12, name: "ogaga" } 16 | 17 | p.name 18 | 19 | case (p) { 20 | person { age: a, name: n } -> a, 21 | n -> "should not be evaluated" 22 | } 23 | 24 | datatype student = 25 | L100 | L200 | L300 | L300 | 26 | L400 | Other (String) 27 | 28 | def o = Other ("masters") 29 | 30 | 31 | case (o) { 32 | L100 -> "100 level", 33 | L200 -> "200 level", 34 | L300 -> "300 level", 35 | L400 -> "400 level", 36 | Other (s) -> s 37 | } 38 | 39 | def t = (1, 2) 40 | 41 | t -------------------------------------------------------------------------------- /examples/j.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- this is a comment 4 | 5 | {- 6 | 7 | this is a comment 8 | do anything here 9 | 10 | -} -------------------------------------------------------------------------------- /examples/k.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | let name = "deborah"; 4 | let b = 10; 5 | name 6 | -- let age = 20; 7 | 8 | -- https://drive.google.com/file/d/1uTU5d6hOaqhxsAE3N7sIRqHSvs6daVCF/view?usp=sharing 9 | 10 | -- https://drive.google.com/file/d/16LRHq6RlIuRto088s0PxYsMLGUF2rbJi/view?usp=sharing 11 | 12 | -- https://drive.google.com/file/d/10URAITCwQIbKTN_kzF_GZzAdnmi3VBm3/view?usp=sharing -------------------------------------------------------------------------------- /examples/l.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | handle (let a = do Number (); 5 | let b = do Number (); 6 | (a, b) ) { 7 | return a -> "nothing", 8 | Number () k -> k (1) 9 | } 10 | 11 | -------------------------------------------------------------------------------- /examples/m.tina: -------------------------------------------------------------------------------- 1 | 2 | handle ( 3 | let a = do A (); 4 | let b = do B (); 5 | let c = do C ("some val"); 6 | if do Decide () then do Comp () else (a, c)) { 7 | return x -> 8 | case (x) { 9 | ("ogaga", afoke, "some val") -> "yes, ", 10 | n -> n 11 | }, 12 | A () k -> k ("ogaga"), 13 | B () k -> k ("afoke"), 14 | C (value) k -> k (value), 15 | Decide () k -> k (true), 16 | Comp () k -> k ("this is it y'all") 17 | } 18 | 19 | handle (if do N () then "tru" else "fal") { 20 | return x -> x, 21 | N () k -> k (false) 22 | } -------------------------------------------------------------------------------- /examples/n.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- let a = 20; do Bot (a) 4 | 5 | if false then 10 else do Cry () 6 | 7 | 8 | -- def get () = do Get () 9 | let a = do Help ("i need a GitHub Copilot access"); -------------------------------------------------------------------------------- /examples/next.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- functions at the top level 4 | -- function application 5 | 6 | -- case expression is a computation 7 | 8 | case 0 { 9 | 0 -> do None (), 10 | any -> () 11 | } 12 | 13 | -- function application should sequence arguments 14 | 15 | 16 | -- if expression is a computation 17 | 18 | - record index is a computation 19 | 20 | -- sequence is a computation (can easily be transformed into a let) -------------------------------------------------------------------------------- /examples/o.tina: -------------------------------------------------------------------------------- 1 | 2 | {- 3 | 4 | let a = 10; 5 | let b = 20; 6 | (a, b) 7 | 8 | -} 9 | 10 | def decide () = if do Decide () then "ogaga" else "afoke" 11 | 12 | def id (x) = do Hey (x) 13 | 14 | handle id (10) { 15 | return x -> x, 16 | Hey (v) k -> (v, "ahhh") 17 | } 18 | 19 | handle decide () { 20 | return c -> c, 21 | Decide () k -> k (true) 22 | } 23 | 24 | -------------------------------------------------------------------------------- /examples/p.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | def id (x) = x 4 | 5 | -- we need to sequence the arguments of functions 6 | 7 | handle ( (do F ())(10) ) { 8 | return x -> x, 9 | F () k -> k (id) 10 | } -------------------------------------------------------------------------------- /examples/q.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | def invoke () = 4 | let a = do Number1 (); 5 | let b = do Number2 (); 6 | (a, b) 7 | 8 | handle invoke () { 9 | return a -> a, 10 | Number1 () k -> k (1), 11 | Number2 () k -> k (2) 12 | } 13 | -------------------------------------------------------------------------------- /examples/r.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | def something () = 4 | do Some () 5 | 6 | def try (x) = 7 | handle something () { 8 | return x -> x, 9 | Some () resume -> resume (x) 10 | } 11 | 12 | try (10) 13 | 14 | def fact (n) = 15 | case (n) { 16 | 0 -> 1 17 | } 18 | 19 | fact (10) -------------------------------------------------------------------------------- /examples/s.tina: -------------------------------------------------------------------------------- 1 | 2 | datatype Name = Ogaga | Afoke | Fejiro (Float) | Yoma (Nat, String) | Vovwero (Nat, Nat) 3 | 4 | def o = Ogaga 5 | 6 | def y = Yoma (10, "ooo") 7 | 8 | def v = Vovwero (23, 2) 9 | 10 | case (v) { 11 | Vovwero (Fejiro (x, y), b) -> (x, y, b), 12 | Fejiro (f) -> f, 13 | Ogaga -> "ogaga", 14 | Afoke -> "afoks", 15 | Yoma (a, b) -> (b, a) 16 | } 17 | 18 | datatype person = 19 | { claim name String, 20 | claim age Nat } 21 | 22 | 23 | def p = person { name: Yoma (23, "elim"), age: 24 } 24 | 25 | p.name -------------------------------------------------------------------------------- /examples/t.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | datatype subject = 5 | { claim name String, 6 | claim code Nat, 7 | claim other String } 8 | 9 | def o = subject { name: "MAT 423", code: 423, other: "no other" } 10 | 11 | def math = subject { name: "MAT 423", code: 423, other: o} 12 | 13 | case (math) { 14 | subject { name: n, code: c, other: subject {name: n1, code: c1}} -> (n, c, n1, c1) 15 | } 16 | 17 | datatype level = L100 | L200 | L300 | L400 | L500 18 | 19 | def l = L100 20 | 21 | case (l) { 22 | L100 -> 100, 23 | L200 -> 200, 24 | L300 -> 300, 25 | L400 -> 400, 26 | L500 -> 500 27 | } -------------------------------------------------------------------------------- /examples/test.tina: -------------------------------------------------------------------------------- 1 | 2 | 34 3 | 4 | 5 | claim A Nat 6 | def A = (341) 7 | 8 | fn (x, y) x 9 | 10 | fn () 34 11 | 12 | fn (var) "something" 13 | 14 | (fn (x, y) "nope") (34, 5) 15 | 16 | (34) 17 | 18 | ("wewe") 19 | 20 | claim B String 21 | def B = "something" 22 | 23 | if true then "de" else "ther" 24 | 25 | claim F (Nat, Nat -> Nat) 26 | def F (a, b) = 27 | b 28 | 29 | def car () = 30 | let a = F (1, fn (v) v); 31 | a () 32 | 33 | def T (a, y) = 34 | let b = 23; 35 | 36 | (fn () 34) 37 | 38 | 39 | data Name = 40 | { claim A Nat, 41 | claim B (String, Nat -> Nat) } 42 | 43 | (the Nat 24) 44 | 45 | def B = 46 | let a = 10; 47 | 23; 48 | 54; 49 | "stringer" 50 | 51 | a.A 52 | 53 | b.c.D 54 | 55 | Person { name: "ogaga", age: 10 } 56 | 57 | 58 | claim plus (Nat, Nat -> Nat) 59 | def plus (x, y) = x + y 60 | 61 | def create_pos (x, y) = Loc { start: x, end_: y } 62 | 63 | Other { a: Person {v: 10, b: 3.4}, 64 | c: fn (x, y) x } 65 | 66 | case ( case 23 { x -> x} ) { 67 | Name { a: b} -> 23, 68 | x -> x 69 | } 70 | 71 | def a = 34 72 | 73 | a 74 | 75 | case Person { name: "ogaga", age: Number { value: 20 } } { 76 | Person { name: x, age: Number { value: v} } -> v 77 | } 78 | 79 | (((fn (x) fn (y) x) (23)) (67)) 80 | 81 | 82 | 83 | 84 | (((fn (x) fn (y) x) (23)) (67)) 85 | 86 | 45 87 | 88 | 67 89 | 90 | "34" 91 | 92 | def name = 35 93 | 94 | name 95 | 96 | def func (x, y) = 34 97 | 98 | func (1, 2) 99 | 100 | fn (x) x 101 | 102 | def ogaga = Name { a: func, b : 29, other: (fn (c) c) } 103 | 104 | case (ogaga) { 105 | Name { a: f, b: idc, other: g } -> f (idc, "this must be returned") 106 | } 107 | 108 | def safe = Name { a: func, b : 29, rest: Oga { safe: 45} } 109 | 110 | ogaga.a 111 | 112 | ogaga.other 113 | 114 | true 115 | 116 | false 117 | 118 | datatype roomate = Anderson(Nat, Nat) | Ogaga | Ifeoluwa 119 | 120 | Ifeoluwa 121 | 122 | def a = Anderson ("something", 34) 123 | 124 | def b = Ogaga 125 | 126 | b 127 | 128 | 129 | case (a) { 130 | Ogaga -> "ogagaaa", 131 | Anderson (s, other) -> s 132 | } 133 | 134 | 135 | 6 + 5 136 | 137 | 30 + 45 138 | 139 | def fib (n) = 140 | case (n) { 141 | 1 -> 0, 142 | 2 -> 1, 143 | n -> fib (n - 1) + fib (n - 2) 144 | } 145 | 146 | "Fib numbers" 147 | fib (1) 148 | fib (2) 149 | fib (3) 150 | fib (4) 151 | fib (5) 152 | fib (10) 153 | 154 | 155 | 156 | 157 | datatype Person = 158 | { claim name String, 159 | claim age Nat, 160 | claim other String } 161 | 162 | def gaga = Person { name: "ogaga", age: 20, other: "likes programming" } 163 | 164 | def test = 165 | let Person {name:n, age:a, other:o } = gaga; 166 | case (a) { 167 | 10 -> "no", 168 | 20 -> "yes", 169 | n -> "never" 170 | } 171 | 172 | -17.9 173 | 174 | def name = "chidera" 175 | def age = 25 176 | 177 | name + " is " + age + " years old." 178 | 179 | 180 | 10 + 10 181 | 182 | "ogaga" 183 | 184 | def comp = do Name () 185 | 186 | handle "afoke " { 187 | return x -> x + 1000, 188 | } 189 | 190 | handle (do Name ()) { 191 | return y -> y, 192 | Name () k -> "hey" 193 | } 194 | 195 | let x = "ebresafe"; x 196 | 197 | let b = do Name ("dd"); 198 | handle (b) { 199 | return x -> x, 200 | Name (o) k -> k ("lol") 201 | } -------------------------------------------------------------------------------- /examples/typing.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | datatype name = Ogaga | Afoke 4 | 5 | 6 | claim me nam 7 | def me = Ogaga 8 | 9 | claim tuple (Nat, Nat -> Nat) 10 | def tuple (x, y) = y 11 | 12 | claim id (Nat -> Nat) 13 | def id = fn (x) x -------------------------------------------------------------------------------- /examples/u.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | -- if (fn (x) x) (10) then true else false 4 | 5 | 6 | -- def f (x) = x 7 | 8 | -- if f (10) then true else false 9 | 10 | 11 | 12 | -- (fn (xx) xx, 23, c) 13 | 14 | datatype me = { claim ogaga String } 15 | 16 | -- g (f (let x = 10; let y = "ole"; x)).ogaga 17 | 18 | f (if f (x) then 10 else 34) -------------------------------------------------------------------------------- /examples/what.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | define caser (a, b, c) = 5 | case 23 6 | 34 -> kkk, 7 | Some (1, 3) -> 3333 8 | end 9 | end 10 | 11 | fun (x, c) -> "something" 12 | 13 | define name = 23 14 | 15 | f(1, 2) 16 | 17 | (10) 18 | 19 | datatype name = { 20 | claim name String 21 | claim age Nat 22 | } 23 | 24 | ability Name (String, Nat) 25 | 26 | do Name ("ogaga", 23) 27 | 28 | let b = do Name ("ogaga", 34) 29 | handle comp { 30 | Return k -> x 31 | Name (a, b) k -> 32 | } 33 | 34 | fn (n) { n } -------------------------------------------------------------------------------- /features.org: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | * actual rec bindings using subsituition 5 | * give the programmer the ability to use `absurd` and `return` 6 | * new anonymous function syntax 7 | `fn (x) { ... }` 8 | * is case a computation? 9 | * resume keyword instead of binding a comtinuation function? 10 | * an abstraction to implement tina functions from ocaml 11 | * equality operators 12 | * list and arrays 13 | * fix ambuguity in parsing variable/record pattern as the expression to match on, a in case expression. 14 | i.e currently, `case v { ... }` wold try to parse as `case (v { ... })` 15 | instead of `case (v) { ... }` 16 | * new syntax to differentiate let bindings from computation let sequencing 17 | `let x <- return x` 18 | `let y <- do Comp (); 19 | let s <- do X (); 20 | return x` 21 | * one current flaw of Tina is we don't handle bindings correctly 22 | 23 | * Recursive functions now 24 | 25 | * things to fix in the parser 26 | - fn { } syntax 27 | - changing type to use Type.t 28 | - record to use { name: value ... } with out requirng the name 29 | - absurd, return keyword 30 | 31 | * we also need a pass for transforming primitive operator-like functions into their runtime 32 | functions (e.g comparision functions, numerical operations functiona) 33 | 34 | * we need a desugaring pass to remove wierd things like `Sequence` and `Annotation` 35 | 36 | 37 | 38 | - rec functions 39 | - new syntax 40 | - type system 41 | - fix interpreter 42 | -------------------------------------------------------------------------------- /file.js: -------------------------------------------------------------------------------- 1 | const o = x_5(x_17); 2 | let x_230 = x_220(x_221, x_229); 3 | let x_229 = x_223(x_227, x_228); 4 | let x_228 = 0; 5 | let x_227 = (comp_0, ks_0) => { 6 | let x_224 = comp_0[0]; 7 | let x_225 = 0; 8 | let x_226 = equal(x_224, x_225); 9 | if (x_226) { 10 | let l_0 = comp_0[1]; 11 | let idk1_0 = comp_0[2]; 12 | let idk2_0 = comp_0[3]; 13 | return absurd("Unhandled effect"); 14 | } else { 15 | return absurd("Pattern match failure"); 16 | } 17 | }; 18 | const y = x_25(x_37); 19 | let x_223 = (e1_0, e2_0) => { 20 | let x_222 = 0; 21 | return { 0: x_222, 1: e1_0, 2: e2_0 }; 22 | }; 23 | const v = x_45(x_57); 24 | let x_221 = (x_0, ks_0) => { 25 | return x_0; 26 | }; 27 | const ebresafe = x_63(x_75); 28 | let x_220 = (e1_0, e2_0) => { 29 | let x_219 = 0; 30 | return { 0: x_219, 1: e1_0, 2: e2_0 }; 31 | }; 32 | const class_ = x_84(x_96); 33 | let x_218 = (ks_0) => { 34 | let x_203 = ks_0[0]; 35 | let x_204 = 0; 36 | let x_205 = equal(x_203, x_204); 37 | if (x_205) { 38 | let k_0 = ks_0[1]; 39 | let ks__0 = ks_0[2]; 40 | let fn_0 = (x_0, ks___0) => { 41 | let x_213 = 10; 42 | let x_214 = x_0(x_213); 43 | let x_216 = (e1_0, e2_0) => { 44 | let x_215 = 0; 45 | return { 0: x_215, 1: e1_0, 2: e2_0 }; 46 | }; 47 | let x_217 = x_216(k_0, ks_0); 48 | return x_214(x_217); 49 | }; 50 | let x_209 = (___ks____0) => { 51 | let x_206 = ___ks____0[0]; 52 | let x_207 = 0; 53 | let x_208 = equal(x_206, x_207); 54 | if (x_208) { 55 | let ___k____0 = ___ks____0[1]; 56 | let ___ks____0 = ___ks____0[2]; 57 | return ___k____0(fib, ___ks____0); 58 | } else { 59 | return absurd("Pattern match failure"); 60 | } 61 | }; 62 | let x_211 = (e1_0, e2_0) => { 63 | let x_210 = 0; 64 | return { 0: x_210, 1: e1_0, 2: e2_0 }; 65 | }; 66 | let x_212 = x_211(fn_0, ks_prime_0); 67 | return x_209(x_212); 68 | } else { 69 | return absurd("Pattern match failure"); 70 | } 71 | }; 72 | const og = x_107(x_119); 73 | const sum = x_145(x_157); 74 | const fib = x_190(x_202); 75 | x_218(x_230); 76 | -------------------------------------------------------------------------------- /file.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | datatype Name = Ogaga | Afoke | Fejiro (Float) | Yoma (Int, String) | Vovwero (Int, Int) 6 | 7 | claim o Name 8 | def o = Ogaga 9 | 10 | claim y Name 11 | def y = Yoma (10, "ooo") 12 | 13 | claim v Name 14 | def v = Vovwero (23, 2) 15 | 16 | 17 | -- these are github pilot auto generated lol 18 | 19 | claim ebresafe (Name, Name, Name) 20 | def ebresafe = (o, y, v) 21 | 22 | -- i defined this 23 | datatype expr = 24 | { claim name String, 25 | claim age Int, 26 | claim class Int } 27 | 28 | 29 | -- function to get the class from an expr 30 | claim class (expr -> Int) 31 | def class (e) = case (e) { 32 | expr -> e.class, 33 | _ -> 0 34 | } 35 | 36 | -- function to decide if a name if Ogaga 37 | claim og (String -> Int) 38 | def og (n) = case (n) { 39 | "ogaga" -> 1, 40 | _ -> 0 41 | } 42 | 43 | -- function to sum two values from a pair 44 | claim sum ((Int, Int) -> Int) 45 | def sum (p) = case (p) { 46 | (a, b) -> a + b, 47 | _ -> 0 48 | } 49 | 50 | -- function to calculate fibonacci 51 | claim fib (Int -> Int) 52 | def fib (n) = case (n) { 53 | 0 -> 0, 54 | 1 -> 1, 55 | _ -> fib (n - 1) + fib (n - 2) 56 | } 57 | 58 | fib (10) 59 | 60 | -- function to calculte factorial 61 | claim fact (Int -> Int) 62 | def fact (n) = case (n) { 63 | 0 -> 1, 64 | _ -> n * fact (n - 1) 65 | } 66 | 67 | -- function to get the k-means from a vector as input 68 | -------------------------------------------------------------------------------- /new.js: -------------------------------------------------------------------------------- 1 | const id = (x) => { return (y) => { let x_0 = 0; return { 0: x_0, 1: x, 2: y }; } ; } ; -------------------------------------------------------------------------------- /new.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | def id (x) = 4 | fn (y) (x, y) -------------------------------------------------------------------------------- /parsing/Makefile: -------------------------------------------------------------------------------- 1 | 2 | 3 | automaton: 4 | menhir grammar.mly --dump 5 | 6 | messages: grammar.mly 7 | menhir --list-errors grammar.mly > messages 8 | 9 | conflicts: 10 | menhir grammar.mly --explain 11 | 12 | clean: 13 | rm grammar.ml grammar.mli grammar.automaton grammar.conflicts 14 | -------------------------------------------------------------------------------- /parsing/README.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/parsing/README.md -------------------------------------------------------------------------------- /parsing/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parsing) 3 | (libraries menhirLib utility syntax errors)) 4 | 5 | (ocamllex lexer) 6 | 7 | (menhir 8 | (modules grammar) 9 | (flags --table)) 10 | 11 | ;; This section deals with the .messages file. 12 | 13 | ;; The following rule generates "parserMessages.ml" based on the source file 14 | ;; "parserMessages.messages". It requires the completeness check to have been 15 | ;; performed first. (If desired, this check could be disabled.) 16 | 17 | (rule 18 | (deps parserMessages.check) 19 | (action 20 | (with-stdout-to 21 | parserMessages.ml 22 | (run 23 | menhir 24 | %{dep:grammar.mly} 25 | --compile-errors 26 | %{dep:parserMessages.messages})))) 27 | 28 | ;; This rule generates a file "parserMessages.auto.messages" that contains a 29 | ;; list of all error states. It is used by the completeness check. 30 | 31 | (rule 32 | (with-stdout-to 33 | parserMessages.auto.messages 34 | (run menhir %{dep:grammar.mly} --list-errors))) 35 | 36 | ;; This rule implements the completeness check. It checks that every error 37 | ;; state listed in the auto-generated file "parserMessages.auto.messages" 38 | ;; is also listed in the file "parserMessages.messages" that is maintained 39 | ;; by the programmer. 40 | 41 | (rule 42 | (with-stdout-to 43 | parserMessages.check 44 | (run 45 | menhir 46 | %{dep:grammar.mly} 47 | --compare-errors 48 | %{dep:parserMessages.auto.messages} 49 | --compare-errors 50 | %{dep:parserMessages.messages}))) 51 | -------------------------------------------------------------------------------- /parsing/grammar.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Syntax 3 | open Ast 4 | open Naming 5 | open Errors 6 | 7 | let ty_of_record_def = function 8 | | RecordDef (_, _, fields) -> 9 | Type.TyRecord fields 10 | | _ -> Errors.runtime "expected a record def" 11 | 12 | 13 | let ty_of_variant_def = function 14 | | VariantDef (_loc, _name, fields) -> 15 | let conv s = s |> VarName.to_string |> DataName.of_string in 16 | let fields = 17 | fields 18 | |> List.map (fun (var, ty) -> 19 | { Type.label = conv var; fields = ty }) 20 | in 21 | Type.TyVariant fields 22 | | _ -> Errors.runtime "expected a variant definition" 23 | 24 | let type_synonyms : (string * Type.t) list ref = ref [] 25 | let add_synonym name ty = 26 | type_synonyms := (name, ty) :: !type_synonyms 27 | 28 | let get_type_synonym name = 29 | match List.assoc_opt name !type_synonyms with 30 | | Some value -> Some value 31 | | None -> None 32 | 33 | let empty_variants : VarName.t list ref = ref [] 34 | let non_empty_variants : VarName.t list ref = ref [] 35 | let collect_empty_variants = function 36 | | VariantDef (_loc, _name, body) -> 37 | let mt, non_mt = 38 | body 39 | |> List.partition_map (function name, [] -> Either.Left name | name, _ -> Either.Right name) 40 | in 41 | empty_variants := mt @ !empty_variants; 42 | non_empty_variants := non_mt @ !non_empty_variants 43 | | _ -> () 44 | let is_empty_variant x = List.mem x !empty_variants 45 | let is_non_empty_variant x = List.mem x !non_empty_variants 46 | 47 | let is_variable = function 48 | | Variable (_, var) -> Some var 49 | | _ -> None 50 | 51 | %} 52 | 53 | %token INT 54 | %token FLOAT 55 | %token ID 56 | %token STRING 57 | %token TRUE 58 | %token FALSE 59 | 60 | %token LBRACE RBRACE LPAREN RPAREN LBRACK RBRACK 61 | %token COMMA 62 | %token COLON SEMICOLON DOT 63 | %token EQUALS BAR 64 | 65 | %token CLAIM DEF 66 | %token THE 67 | %token DATA 68 | 69 | %token CASE ARROW 70 | %token LET MUT FN END 71 | %token COLONEQUALS 72 | 73 | %token IF THEN ELSE 74 | 75 | %token PLUS STAR MINUS DIV 76 | 77 | %token GT LT GTEQUALS LTEQUALS 78 | 79 | %token TY_NAT TY_STRING TY_FLOAT TY_INT 80 | 81 | %token TK_TODO 82 | 83 | %token DO HANDLE ABILITY RETURN 84 | 85 | %token EOF 86 | 87 | %left PLUS MINUS 88 | %left MULT DIV 89 | 90 | %start toplevel 91 | 92 | %type toplevel 93 | %type ty 94 | %type claim 95 | %type def 96 | %type record_decl 97 | %type expression 98 | %type maybe_empty_expr 99 | 100 | %% 101 | 102 | toplevel: 103 | | tops = list(top); EOF { tops } 104 | 105 | top: 106 | | c = claim { c } 107 | | d = def { d } 108 | | r = record_decl { r } 109 | | v = variant_decl { v } 110 | | a = ability { a } 111 | | e = expression { Expression e } 112 | 113 | claim: 114 | | CLAIM; id = ID; t = ty; 115 | { Claim ($loc, VarName.of_string id, t) } 116 | 117 | ability: 118 | | ABILITY; id = ID; LPAREN; tys = separated_list(COMMA, ty); RPAREN 119 | { AbilityDef ($loc, VarName.of_string id, tys) } 120 | 121 | def: 122 | | DEF; id = ID; EQUALS; body = expression 123 | { Def ($loc, VarName.of_string id, body) } 124 | | DEF; id = ID; args = arg_list; EQUALS; body = expression; 125 | { Def ($loc, VarName.of_string id, Fn ($loc, args, body)) } 126 | 127 | record_claim: 128 | | CLAIM; id = ID; t = ty; { (FieldName.of_string id, t) } 129 | 130 | record_decl: 131 | | DATA; id = ID; EQUALS; LBRACE; claims = separated_nonempty_list(COMMA, record_claim); RBRACE 132 | { let def = RecordDef ($loc, DataName.of_string id, claims) in 133 | let ty = ty_of_record_def def in 134 | add_synonym id ty; 135 | def } 136 | 137 | 138 | single_variant: 139 | | name = ID { (VarName.of_string name, []) } 140 | | name = ID; LPAREN; tys = separated_nonempty_list(COMMA, ty); RPAREN 141 | { (VarName.of_string name, tys) } 142 | 143 | variant_decl: 144 | | DATA; name = ID; EQUALS; body = separated_nonempty_list(BAR, single_variant); 145 | { let variant_def = VariantDef ($loc, DataName.of_string name, body) in 146 | collect_empty_variants variant_def; 147 | let ty = ty_of_variant_def variant_def in 148 | add_synonym name ty; 149 | variant_def } 150 | 151 | record_expr_body: 152 | | field = ID; COLON; e = expression; { (FieldName.of_string field, e) } 153 | 154 | record_pattern_expr: 155 | | field = ID; COLON; p = pattern; { (FieldName.of_string field, p) } 156 | 157 | ty: 158 | | TY_NAT { TyNat } 159 | | TY_STRING { TyString } 160 | | TY_FLOAT { TyFloat } 161 | | TY_INT { TyInt } 162 | | LPAREN; t = ty; RPAREN { t } 163 | | LPAREN; body = separated_nonempty_list(COMMA, ty); RPAREN 164 | { TyTuple (body) } 165 | | LPAREN a = separated_nonempty_list(COMMA, ty); ARROW; b = ty; RPAREN 166 | { TyArrow (a, b) } 167 | | LPAREN; RPAREN; ARROW; b = ty; RPAREN 168 | { TyArrow ([], b) } 169 | | id = ID 170 | { match get_type_synonym id with 171 | | None -> 172 | let msg = Printf.sprintf "Unbound type name %s" id in 173 | Errors.runtime msg 174 | | Some ty -> ty } 175 | 176 | 177 | arg_list: 178 | | LPAREN; params=separated_list(COMMA,param); RPAREN 179 | { List.map VarName.of_string params } 180 | 181 | (* we can add optional type annotations for 182 | fn or normal defs from here *) 183 | param: 184 | | id = ID; { id } 185 | 186 | expr_list: 187 | | LPAREN; params=separated_list(COMMA,expression); RPAREN { params } 188 | 189 | maybe_empty_expr: 190 | | (* empty *) { LitUnit ($loc) } 191 | | e = expression { e } 192 | 193 | case_expr_body: 194 | | pat = pattern; ARROW; e = expression 195 | { (pat, e) } 196 | 197 | pattern: 198 | | i = INT { PInteger (i) } 199 | | TRUE { PBool (true) } 200 | | FALSE { PBool (false) } 201 | | s = STRING { PString (s) } 202 | | LPAREN; p = pattern; RPAREN; { p } 203 | | LPAREN; body = separated_nonempty_list(COMMA, pattern); RPAREN 204 | { PTuple (body) } 205 | | id = ID 206 | { let name = VarName.of_string id in 207 | if is_empty_variant name then 208 | PVariant (name, []) 209 | else 210 | PVariable (name) 211 | } 212 | | rec_name = ID; LBRACE; body = separated_nonempty_list(COMMA, record_pattern_expr); RBRACE; 213 | { PRecord (DataName.of_string rec_name, body) } 214 | | variant_name = ID; LPAREN; body = separated_nonempty_list(COMMA, pattern); RPAREN; 215 | { PVariant (VarName.of_string variant_name, body) } 216 | 217 | expression: 218 | | name = ID 219 | { if is_empty_variant (VarName.of_string name) then 220 | Variant ($loc, DataName.of_string name, []) 221 | else 222 | Variable ($loc, VarName.of_string name) } 223 | | LPAREN; RPAREN { LitUnit ($loc) } 224 | 225 | | value = INT { LitInteger ($loc, value) } 226 | | value = FLOAT { LitFloat ($loc, value) } 227 | | value = STRING { LitString ($loc, value) } 228 | | TRUE { LitBool ($loc, true) } 229 | | FALSE { LitBool ($loc, false) } 230 | | TK_TODO { LitTodo ($loc) } 231 | 232 | | IF; pred = expression; THEN pred_true = expression; ELSE pred_false = expression 233 | { If ($loc, pred, pred_true, pred_false) } 234 | | LET; pat = pattern; EQUALS; value = expression; SEMICOLON; body = maybe_empty_expr 235 | { Let ($loc, pat, value, body) } 236 | | FN; args = arg_list; body = expression; 237 | { Fn ($loc, args, body) } 238 | | THE; t = ty; e = expression; 239 | { Annotated ($loc, e, t) } 240 | | f = expression; args = expr_list; 241 | { match is_variable f with 242 | | Some var -> 243 | if is_non_empty_variant var then 244 | Variant ($loc, DataName.of_string (VarName.to_string var), args) 245 | else 246 | Application ($loc, f, args) 247 | | None -> 248 | Application ($loc, f, args) } 249 | | e1 = expression; SEMICOLON; e2 = expression 250 | { Sequence ($loc, e1, e2) } 251 | | record = expression; DOT; field = ID; 252 | { RecordIndex ($loc, record, FieldName.of_string field) } 253 | | name = ID; LBRACE; body = separated_nonempty_list(COMMA, record_expr_body); RBRACE 254 | { Record ($loc, DataName.of_string name, body) } 255 | | CASE; e = expression; LBRACE; body = separated_nonempty_list(COMMA, case_expr_body); RBRACE 256 | { Case ($loc, e, body) } 257 | | e1 = expression; op = operator; e2 = expression 258 | { let o = Variable ($loc, VarName.of_string op) in 259 | Application ($loc, o, [e1; e2]) } 260 | | LPAREN; e = expression; RPAREN { e } 261 | | LPAREN; body = separated_nonempty_list(COMMA, expression); RPAREN { Tuple ($loc, body) } 262 | | DO; name = ID; LPAREN; body = separated_list(COMMA, expression); RPAREN 263 | { Do ($loc, VarName.of_string name, body) } 264 | | HANDLE; e = expression; LBRACE; 265 | ret = return_clause; COMMA; 266 | body=separated_list(COMMA, handler_clause) RBRACE 267 | { Handle ($loc, e, ret :: body) } 268 | 269 | return_clause: 270 | | RETURN; id = ID; ARROW; e = expression; { Return (VarName.of_string id, e) } 271 | 272 | handler_clause: 273 | | name = ID; LPAREN; body = separated_list(COMMA, ID); RPAREN; kvar = ID; ARROW; e = expression 274 | { let body = List.map VarName.of_string body in 275 | Operation (VarName.of_string name, body, VarName.of_string kvar, e) } 276 | 277 | 278 | %inline operator: 279 | | PLUS { "+" } 280 | | MINUS { "-" } 281 | | STAR { "*" } 282 | | DIV { "/" } 283 | -------------------------------------------------------------------------------- /parsing/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Grammar 4 | 5 | exception SyntaxError of Lexing.position * string 6 | 7 | let next_line lexbuf = 8 | let pos = lexbuf.lex_curr_p in 9 | lexbuf.lex_curr_p <- 10 | { pos with 11 | pos_bol = lexbuf.lex_curr_pos; 12 | pos_lnum = pos.pos_lnum + 1 } 13 | } 14 | 15 | 16 | let digit = ['0'-'9'] 17 | let alpha = ['a'-'z' 'A'-'Z'] 18 | 19 | let int = '-'? digit+ 20 | let frac = '.' digit* 21 | let float = '-'? digit* frac? 22 | 23 | let whitespace = [' ' '\t']+ 24 | let newline = '\r' | '\n' | "\r\n" 25 | let id = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* 26 | 27 | rule read_token = parse 28 | | "true" { TRUE } 29 | | "false" { FALSE } 30 | | "(" { LPAREN } 31 | | ")" { RPAREN } 32 | | "{" { LBRACE } 33 | | "}" { RBRACE } 34 | | "[" { LBRACK } 35 | | "]" { RBRACK } 36 | | "," { COMMA } 37 | | ":" { COLON } 38 | | ";" { SEMICOLON } 39 | | "." { DOT } 40 | | "=" { EQUALS } 41 | | "|" { BAR } 42 | | "claim" { CLAIM } 43 | | "def" { DEF } 44 | | "the" { THE } 45 | | "datatype" { DATA } 46 | | "case" { CASE } 47 | | "end" { END } 48 | | "->" { ARROW } 49 | | "let" { LET } 50 | | "mut" { MUT } 51 | | "fn" { FN } 52 | | ":=" { COLONEQUALS } 53 | | "if" { IF } 54 | | "then" { THEN } 55 | | "else" { ELSE } 56 | | "do" { DO } 57 | | "handle" { HANDLE } 58 | | "ability" { ABILITY } 59 | | "return" { RETURN } 60 | | "+" { PLUS } 61 | | "*" { STAR } 62 | | "-" { MINUS } 63 | | "/" { DIV } 64 | | ">" { GT } 65 | | ">=" { GTEQUALS } 66 | | "<" { LT } 67 | | "<=" { LTEQUALS } 68 | | "Nat" { TY_NAT } 69 | | "Float" { TY_FLOAT } 70 | | "String" { TY_STRING } 71 | | "Int" { TY_INT } 72 | | "TODO" { TK_TODO } 73 | | '"' { read_string (Buffer.create 17) lexbuf } 74 | | whitespace { read_token lexbuf } 75 | | newline { next_line lexbuf; read_token lexbuf } 76 | | "--" { read_single_line_comment lexbuf } 77 | | "{-" { read_multi_line_comment lexbuf } 78 | | id { ID (Lexing.lexeme lexbuf) } 79 | | int { INT (int_of_string (Lexing.lexeme lexbuf)) } 80 | | float { FLOAT (float_of_string (Lexing.lexeme lexbuf)) } 81 | | eof { EOF } 82 | 83 | and read_string buf = parse 84 | | '"' { STRING (Buffer.contents buf) } 85 | | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } 86 | | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } 87 | | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } 88 | | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } 89 | | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } 90 | | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } 91 | | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } 92 | | [^ '"' '\\']+ 93 | { Buffer.add_string buf (Lexing.lexeme lexbuf); 94 | read_string buf lexbuf 95 | } 96 | | _ { raise (SyntaxError (lexbuf.lex_curr_p, "Illegal string character: " ^ Lexing.lexeme lexbuf)) } 97 | | eof { raise (SyntaxError (lexbuf.lex_curr_p, "String is not terminated")) } 98 | 99 | and read_single_line_comment = parse 100 | | newline { next_line lexbuf; read_token lexbuf } 101 | | eof { EOF } 102 | | _ { read_single_line_comment lexbuf } 103 | 104 | and read_multi_line_comment = parse 105 | | "-}" { read_token lexbuf } 106 | | newline { next_line lexbuf; read_multi_line_comment lexbuf } 107 | | eof { raise (SyntaxError (lexbuf.lex_curr_p, "Lexer - Unexpected EOF - please terminate your comment.")) } 108 | | _ { read_multi_line_comment lexbuf } -------------------------------------------------------------------------------- /parsing/parserEntry.ml: -------------------------------------------------------------------------------- 1 | open Lexing 2 | 3 | (* open Syntax for using Loc.t maybe? *) 4 | module E = MenhirLib.ErrorReports 5 | module L = MenhirLib.LexerUtil 6 | module I = Grammar.MenhirInterpreter 7 | module A = Syntax.Ast 8 | 9 | (* TODO: replace Lexing.position with Loc.t from 10 | Syntax *) 11 | type parse_error = 12 | | LexingError of string * Lexing.position 13 | | SyntaxError of string option * Lexing.position * Lexing.position 14 | 15 | exception Error of parse_error 16 | 17 | (* [env checkpoint] extracts a parser environment out of a checkpoint, 18 | which must be of the form [HandlingError env]. *) 19 | let env checkpoint = 20 | match checkpoint with 21 | | I.HandlingError env -> env 22 | | _ -> assert false 23 | 24 | (* [state checkpoint] extracts the number of the current state out of a 25 | checkpoint. *) 26 | let state checkpoint : int = 27 | match I.top (env checkpoint) with 28 | | Some (I.Element (s, _, _, _)) -> I.number s 29 | | None -> 30 | (* The parser is in its initial state. The incremental API 31 | currently lacks a way of finding out the number of the initial 32 | state. It is usually 0, so we return 0. *) 33 | 0 34 | 35 | (* [show text (pos1, pos2)] displays a range of the input text [text] 36 | delimited by the positions [pos1] and [pos2]. *) 37 | let show text positions = 38 | E.extract text positions 39 | |> E.sanitize 40 | |> E.compress 41 | |> E.shorten 20 (* max width 43 *) 42 | 43 | (* [get text checkpoint i] extracts and shows the range of the input text that 44 | corresponds to the [i]-th stack cell. The top stack cell is numbered zero. *) 45 | let get text checkpoint i = 46 | match I.get i (env checkpoint) with 47 | | Some (I.Element (_, _, pos1, pos2)) -> 48 | show text (pos1, pos2) 49 | | None -> 50 | (* The index is out of range. This should not happen if [$i] 51 | keywords are correctly inside the syntax error message 52 | database. The integer [i] should always be a valid offset 53 | into the known suffix of the stack. *) 54 | "???" 55 | 56 | (* [succeed v] is invoked when the parser has succeeded and produced a 57 | semantic value [v]. *) 58 | let succeed v = v 59 | 60 | (* [fail text buffer checkpoint] is invoked when parser has encountered a 61 | syntax error. *) 62 | let fail text buffer checkpoint = 63 | (* the format for this string: File \%s\, line %d, characters %d-%d:\n *) 64 | let location = L.range (E.last buffer) in 65 | (* Fetch an error message from the database. *) 66 | let message = ParserMessages.message (state checkpoint) in 67 | let message = E.expand (get text checkpoint) message in 68 | let msg = Printf.sprintf "%s at %s" message location in 69 | Errors.runtime msg 70 | 71 | let parse lexbuf = 72 | let text = lexbuf.lex_buffer |> Bytes.to_string in 73 | (* Wrap the lexer and lexbuf together into a supplier, that is, a 74 | function of type [unit -> token * position * position]. *) 75 | let supplier = I.lexer_lexbuf_to_supplier Lexer.read_token lexbuf in 76 | (* Equip the supplier with a two-place buffer that records the positions 77 | of the last two tokens. This is useful when a syntax error occurs, as 78 | these are the token just before and just after the error. *) 79 | let buffer, supplier = E.wrap_supplier supplier in 80 | let checkpoint = Grammar.Incremental.toplevel lexbuf.lex_curr_p in 81 | I.loop_handle succeed (fail text buffer) supplier checkpoint 82 | 83 | let parse_from_file file = 84 | file 85 | |> open_in 86 | |> Lexing.from_channel 87 | |> parse 88 | 89 | let pp_token = 90 | let module G = Grammar in 91 | function 92 | | G.INT i -> Int.to_string i 93 | | G.FLOAT f -> Float.to_string f 94 | | G.ID id -> Printf.sprintf "ID %s" id 95 | | G.STRING s -> Printf.sprintf "STRING %s" s 96 | | G.TRUE -> "TRUE" | G.FALSE -> "FALSE" 97 | | G.LBRACE -> "LBRACE" | G.RBRACE -> "RBRACE" 98 | | G.LPAREN -> "LPAREN" | G.RPAREN -> "RPAREN" 99 | | G.LBRACK -> "LBRACK" | G.RBRACK -> "RBRACK" 100 | | G.COMMA -> "COMMA" | G.COLON -> "COLON" | G.SEMICOLON -> "SEMICOLON" 101 | | G.EQUALS -> "EQUALS" | G.BAR -> "BAR" | G.CLAIM -> "CLAIM" 102 | | G.DEF -> "DEF" | G.DATA -> "DATATYPE" | G.CASE -> "CASE" 103 | | G.ABILITY -> "ABILITY" (* to use *) 104 | | G.ARROW -> "ARROW" | G.LET -> "LET" | G.FN -> "FN" 105 | | G.MUT -> "MUT" (* to use *) 106 | | G.END -> "END" (* to use *) 107 | | G.COLONEQUALS -> "COLONEQUALS" (* to use *) 108 | | G.IF -> "IF" | G.THEN -> "THEN" 109 | | G.ELSE -> "ELSE" | G.PLUS -> "PLUS" 110 | | G.STAR -> "STAR" | G.MINUS -> "MINUS" 111 | | G.DIV -> "DIV" | G.GT -> "GT" 112 | | G.LT -> "LT" | G.GTEQUALS -> "GTEQUALS" 113 | | G.LTEQUALS -> "LTEQUALS" | G.TY_NAT -> "TYNAT" 114 | | G.TY_INT -> "TYINT" | G.TY_FLOAT -> "TYFLOAT" 115 | | G.TY_STRING -> "TYSTRING" | G.TK_TODO -> "TKTODO" 116 | | G.THE -> "THE" | G.DOT -> "DOT" | G.EOF -> "EOF" 117 | | G.HANDLE -> "HANDLE" | G.DO -> "DO" | G.RETURN -> "RETURN" 118 | -------------------------------------------------------------------------------- /repl.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Runtime 3 | open Backend 4 | open Typing 5 | module P = Parsing.ParserEntry 6 | 7 | (* THE TINA REPL *) 8 | 9 | let state = 10 | object 11 | val loaded_files : string list ref = ref [] 12 | 13 | val dump : bool ref = ref false 14 | 15 | method get_files () = !loaded_files 16 | 17 | method add_file file = loaded_files := !loaded_files @ [ file ] 18 | 19 | method get_dump () = !dump 20 | 21 | method start_dump () = dump := true 22 | 23 | method end_dump () = dump := false 24 | 25 | method clear () = 26 | loaded_files := []; 27 | dump := false 28 | end 29 | 30 | let prompt = "tina*> " 31 | 32 | let print_to_repl = print_endline 33 | 34 | let print_prompt () = print_string prompt 35 | 36 | let read_line () = read_line () |> String.trim 37 | 38 | let print_error msg = print_to_repl msg 39 | 40 | let print_list lst = lst |> List.iter print_to_repl 41 | 42 | let is_command s = s.[0] = ':' 43 | 44 | let eval lexbuf = 45 | let syntax = lexbuf |> P.parse in 46 | syntax 47 | |> DesugarEffect.handle_toplevel 48 | |> List.map (fun expr -> 49 | if state#get_dump () then ( 50 | expr |> DesugarEffect.pp_toplevel |> print_endline; 51 | expr) 52 | else expr) 53 | |> Eval2.process_toplevel |> String.concat "\n" |> print_to_repl; 54 | syntax 55 | |> Typecheck.handle_toplevel 56 | |> Ctx.pp_ctx 57 | |> String.concat "\n" |> print_to_repl 58 | 59 | let rec process_command input = 60 | let commands = String.split_on_char ' ' input in 61 | (* print_int (List.length commands); *) 62 | (* print_list commands; *) 63 | match commands with 64 | | [] -> repl () 65 | | ":load" :: args -> 66 | process_load args; 67 | repl () 68 | | ":list" :: _args -> 69 | print_list @@ state#get_files (); 70 | repl () 71 | | ":reload" :: _args -> 72 | let files = state#get_files () in 73 | state#clear (); 74 | process_load files; 75 | repl () 76 | | ":clear" :: _args -> 77 | state#clear (); 78 | repl () 79 | | ":quit" :: _args -> 80 | print_to_repl "Bye Bye!"; 81 | exit 0 82 | | ":dump" :: "start" :: _args -> 83 | print_to_repl "dumping started ...\n"; 84 | state#start_dump (); 85 | repl () 86 | | ":dump" :: "end" :: _args -> 87 | print_to_repl "dumping ending ...\n"; 88 | state#end_dump (); 89 | repl () 90 | | ":desugar" :: "data" :: files -> 91 | process_desugar_data files; 92 | repl () 93 | | ":desugar" :: "knormal" :: files -> 94 | process_desugar_knormal files; 95 | repl () 96 | | ":desugar" :: "case" :: files -> 97 | process_desugar_case files; 98 | repl () 99 | | [ ":compile"; "js"; tina; js ] -> 100 | process_js_compile tina js; 101 | repl () 102 | | invalid :: _args -> 103 | let msg = Printf.sprintf "invalid command %s" invalid in 104 | print_error msg; 105 | repl () 106 | 107 | and process_js_compile tina js = 108 | let js = open_out js in 109 | let tina = open_in tina in 110 | let process channel = 111 | channel |> Lexing.from_channel |> P.parse |> DesugarEffect.handle_toplevel |> DesugarData.handle_toplevel 112 | |> DesugarCase.handle_toplevel |> KNormal.handle_toplevel 113 | |> Js.handle_toplevel |> List.map Js.gen_toplevel |> String.concat "\n" 114 | in 115 | let js_code = process tina in 116 | Printf.fprintf js "%s" js_code; 117 | close_out js; 118 | close_in tina 119 | 120 | and process_load = function 121 | | [] -> () 122 | | file :: files -> ( 123 | (* Printf.printf "about to open file %s \n" file;*) 124 | match open_in file with 125 | | channel -> 126 | state#add_file file; 127 | (try process_file channel 128 | with Errors.RuntimeError m -> print_error m); 129 | process_load files 130 | | exception Sys_error msg -> 131 | print_error msg; 132 | process_load files) 133 | 134 | and process_desugar_knormal = 135 | let process_knormal channel = 136 | channel |> Lexing.from_channel |> P.parse |> DesugarEffect.handle_toplevel |> DesugarData.handle_toplevel 137 | |> DesugarCase.handle_toplevel |> KNormal.handle_toplevel 138 | |> List.map KNormal.pp_toplevel 139 | |> String.concat "\n" |> print_to_repl 140 | in 141 | function 142 | | [] -> () 143 | | file :: files -> ( 144 | match open_in file with 145 | | channel -> 146 | (try process_knormal channel 147 | with Errors.RuntimeError m -> print_error m); 148 | process_desugar_knormal files 149 | | exception Sys_error msg -> 150 | print_error msg; 151 | process_desugar_knormal files) 152 | 153 | and process_desugar_data = 154 | let process_data channel = 155 | channel |> Lexing.from_channel |> P.parse |> DesugarEffect.handle_toplevel |> DesugarData.handle_toplevel 156 | (* |> DesugarCase.handle_toplevel *) 157 | |> List.map DesugarData.pp_toplevel 158 | |> String.concat "\n" |> print_to_repl 159 | in 160 | function 161 | | [] -> () 162 | | file :: files -> ( 163 | match open_in file with 164 | | channel -> 165 | (try process_data channel 166 | with Errors.RuntimeError m -> print_error m); 167 | process_desugar_data files 168 | | exception Sys_error msg -> 169 | print_error msg; 170 | process_desugar_data files) 171 | 172 | and process_desugar_case = 173 | let process_data channel = 174 | channel |> Lexing.from_channel |> P.parse |> DesugarEffect.handle_toplevel |> DesugarData.handle_toplevel 175 | |> DesugarCase.handle_toplevel 176 | |> List.map DesugarCase.pp_toplevel 177 | |> String.concat "\n" |> print_to_repl 178 | in 179 | function 180 | | [] -> () 181 | | file :: files -> ( 182 | match open_in file with 183 | | channel -> 184 | (try process_data channel 185 | with Errors.RuntimeError m -> print_error m); 186 | process_desugar_data files 187 | | exception Sys_error msg -> 188 | print_error msg; 189 | process_desugar_data files) 190 | 191 | and process_file channel = channel |> Lexing.from_channel |> eval 192 | 193 | and process_line input = 194 | let _files = state#get_files () in 195 | input |> Lexing.from_string |> eval 196 | 197 | and repl () = 198 | print_prompt (); 199 | let line = read_line () in 200 | match line with 201 | | "" -> repl () 202 | | _ -> 203 | (if is_command line then process_command line 204 | else try process_line line with Errors.RuntimeError m -> print_error m); 205 | repl () 206 | 207 | let run () = 208 | print_to_repl "Welcome to Tina: programming with typed algebraic effects \n"; 209 | repl () 210 | -------------------------------------------------------------------------------- /runtime.js: -------------------------------------------------------------------------------- 1 | function absurd(s) { 2 | throw new Error(s); 3 | } 4 | 5 | // for now this is just an equaliy for constant types 6 | // this would break down when objects or lists enter the picture 7 | function equal(a, b) { 8 | return a === b; 9 | } 10 | 11 | function hoist() { 12 | console.log(b); 13 | let b = 19; 14 | return b; 15 | } 16 | 17 | 18 | x_4(x_16); 19 | let x_16 = x_6(x_7, x_15); 20 | let x_15 = x_9(x_13, x_14); 21 | let x_14 = 0; 22 | 23 | let x_13 = (comp_0, ks_0) => { 24 | let x_10 = comp_0[0]; 25 | let x_11 = 0; 26 | let x_12 = equal(x_10, x_11); 27 | if (x_12) { 28 | let l_0 = comp_0[1]; 29 | let idk1_0 = comp_0[2]; 30 | let idk2_0 = comp_0[3]; 31 | return absurd("Unhandled effect"); 32 | } else { 33 | return absurd("Pattern match failure"); 34 | } 35 | }; 36 | -------------------------------------------------------------------------------- /runtime/desugarCase.ml: -------------------------------------------------------------------------------- 1 | (* 2 | DESUGARING CASE EPXRESIONS TO IF EXPRESIONS 3 | 4 | - first we transform the recursive patterns to normal pattern match 5 | with nested cases in the body to handle arbitrary levels of the 6 | recursive pattern 7 | 8 | - next, we transform multiple clauses to two clauses: 9 | one for the head case and a variable case. in the body of 10 | the head case, we pattern match on the variable and repeat 11 | the same procedure for the rest clauses until we're done. 12 | 13 | - now we have only two clauses, for each case, so this can 14 | be straight forwardly transformed into and if expression. 15 | 16 | notes: 17 | - we might need a new data structure to represent the 18 | transformed ast, without case expressions 19 | 20 | - the transformation functions need to work nicely recursively 21 | 22 | Some (10, x) ~> 23 | Some (x, y) -> 24 | 25 | we need to implement a generic equality operation 26 | *) 27 | 28 | open Syntax 29 | open Naming 30 | open Utility 31 | 32 | let d = Loc.dummy 33 | let fresh = VarName.fresh 34 | 35 | module A = DesugarData 36 | 37 | type t = 38 | | LitBool of Loc.t * bool 39 | | LitInteger of Loc.t * int 40 | | LitFloat of Loc.t * float 41 | | LitString of Loc.t * string 42 | | Variable of Loc.t * VarName.t 43 | | If of Loc.t * t * t * t 44 | | Application of Loc.t * t * t list 45 | | Let of Loc.t * VarName.t * t * t 46 | | Fn of Loc.t * VarName.t list * t 47 | | Record of Loc.t * (FieldName.t * t) list 48 | | RecordIndex of Loc.t * t * FieldName.t 49 | | Absurd of string * t 50 | 51 | type toplevel = Def of Loc.t * VarName.t * t | Expression of t 52 | 53 | let is_pvariable = function 54 | | A.PVariable _ -> true 55 | | _ -> false 56 | 57 | let is_simple_pattern = function 58 | | A.PVariable _ | A.PString _ 59 | | A.PInteger _ | A.PBool _ -> true 60 | | A.PRecord _ -> false 61 | 62 | let rec freshen pats = 63 | match pats with 64 | | A.PVariable name :: pats -> 65 | let row, frech = freshen pats in 66 | A.PVariable name :: row, frech 67 | | pat :: pats -> 68 | let var = fresh "fresh" in 69 | let row, frech = freshen pats in 70 | (A.PVariable var :: row), (var, pat) :: frech 71 | | [] -> [], [] 72 | 73 | (** [g body frontier] consumes a [body] expression and a [frontier] 74 | which is represented a list of an association of variable and 75 | patterns. This is basically used to assign fresh variables name to 76 | recursive/nested patterns (and later pattern match on the variable) 77 | in order to un-nest recursive/nested patterns. *) 78 | let rec g body frontier = 79 | let g = g body in 80 | let variable name = A.Variable (d, name) in 81 | let case expr clauses = A.Case (d, expr, clauses) in 82 | match frontier with 83 | | [] -> body 84 | | (name, A.PVariable x) :: frontier -> 85 | case (variable name) 86 | [A.PVariable x, g frontier] 87 | | (name, A.PBool b) :: frontier -> 88 | case (variable name) 89 | [A.PBool b, g frontier] 90 | | (name, A.PInteger i) :: frontier -> 91 | case (variable name) 92 | [A.PInteger i, g frontier] 93 | | (name, A.PString s) :: frontier -> 94 | case (variable name) 95 | [A.PString s, g frontier] 96 | | (name, A.PRecord pats) :: frontier -> 97 | let tag = List.hd pats in 98 | let pats = List.tl pats in 99 | let names = List.map fst pats in 100 | let pats = List.map snd pats in 101 | let pats, front = freshen pats in 102 | let frontier = front @ frontier in 103 | let name_pat = tag :: List.combine names pats in 104 | case (variable name) 105 | [A.PRecord name_pat, g frontier] 106 | 107 | (** [top pat body] is like the entry point to the [g] transformation. 108 | It assumes [pat] is not the outer pattern of a case expression. 109 | So it transforms patterns the way [g] should. *) 110 | let rec top pat body = 111 | match pat with 112 | | A.PVariable _ 113 | | A.PBool _ 114 | | A.PInteger _ 115 | | A.PString _ -> pat, g body [] 116 | | A.PRecord pats when pats |> List.for_all (snd >> is_pvariable) -> pat, g body [] 117 | | A.PRecord pats -> 118 | (* don't reduce the first pattern in pat because it is the tag *) 119 | let tag = List.hd pats in 120 | let pats = List.tl pats in 121 | let names = List.map fst pats in 122 | let pats = List.map snd pats in 123 | let pats, frontier = freshen pats in 124 | let name_pat = List.combine names pats in 125 | A.PRecord (tag :: name_pat), g body frontier (* add the tag back *) 126 | 127 | let if' p pt pf = If (Loc.dummy, p, pt, pf) 128 | let app f args = Application (Loc.dummy, f, args) 129 | let let' name expr body = Let (Loc.dummy, name, expr, body) 130 | let var name = Variable (d, VarName.of_string name) 131 | let record_index record name = RecordIndex (d, record, FieldName.of_string name) 132 | let equal = var "equal" 133 | 134 | let expr_of_pat = function 135 | | A.PBool b -> LitBool (d, b) 136 | | A.PInteger i -> LitInteger (d, i) 137 | | A.PString s -> LitString (d, s) 138 | | A.PVariable _ | A.PRecord _ -> Errors.runtime "expr_of_pat: expected a constant pat" 139 | 140 | let var_of_pat = function 141 | | A.PVariable v -> v 142 | | _ -> Errors.runtime "var_of_pat: expected a variable pattern" 143 | 144 | let rec transform0 expr = 145 | match expr with 146 | | A.Case (loc, expr, clauses) -> 147 | let clauses = 148 | clauses 149 | |> List.map (fun (pattern, body) -> 150 | let body = transform0 body in 151 | top pattern body) 152 | in 153 | A.Case (loc, transform0 expr, clauses) 154 | | A.LitBool _ 155 | | A.LitInteger _ 156 | | A.LitFloat _ 157 | | A.LitString _ 158 | | A.Variable _ -> expr 159 | | A.If (loc, p, pt, pf) -> A.If (loc, transform0 p, transform0 pt, transform0 pf) 160 | | A.Application (loc, f, args) -> 161 | let args = args |> List.map transform0 in 162 | A.Application (loc, transform0 f, args) 163 | | A.Let (loc, A.PVariable name, expr, body) -> 164 | A.Let (loc, A.PVariable name, transform0 expr, transform0 body) 165 | | A.Let (loc, pat, expr, body) -> 166 | (* transform a let with pattern to a case expression *) 167 | let e = A.Case (loc, expr, [pat, body]) in 168 | transform0 e 169 | | A.Fn (loc, vars, body) -> A.Fn (loc, vars, transform0 body) 170 | | A.Annotated (loc, e, ty) -> A.Annotated (loc, transform0 e, ty) 171 | | A.Sequence (loc, a, b) -> A.Sequence (loc, transform0 a, transform0 b) 172 | | A.Record (loc, fields) -> 173 | let fields = fields |> List.map (fun (name, e) -> name, transform0 e) in 174 | A.Record (loc, fields) 175 | | A.RecordIndex (loc, expr, name) -> A.RecordIndex (loc, transform0 expr, name) 176 | | A.Absurd (s, e) -> A.Absurd (s, e) 177 | 178 | let rec transform1 expr = 179 | match expr with 180 | | A.Variable (loc, name) -> Variable (loc, name) 181 | | A.LitBool (loc, b) -> LitBool (loc, b) 182 | | A.LitInteger (loc, i) -> LitInteger (loc, i) 183 | | A.LitFloat (loc, f) -> LitFloat (loc, f) 184 | | A.LitString (loc, s) -> LitString (loc, s) 185 | | A.If (loc, p, pt, pf) -> If (loc, transform1 p, transform1 pt, transform1 pf) 186 | | A.Application (loc, f, args) -> 187 | let args = args |> List.map transform1 in 188 | Application (loc, transform1 f, args) 189 | | A.Let (loc, var, expr, body) -> 190 | (* assumes all patterns are now variables *) 191 | let var = var_of_pat var in 192 | Let (loc, var, transform1 expr, transform1 body) 193 | | A.Fn (loc, vars, body) -> Fn (loc, vars, transform1 body) 194 | | A.Annotated (_, e, _) -> transform1 e 195 | | A.Sequence (_loc, a, b) -> 196 | let' (fresh "seq") (transform1 a) 197 | (transform1 b) 198 | | A.Case (_loc, expr, clauses) -> case (transform1 expr) clauses 199 | | A.Record (loc, names) -> 200 | let names = names |> List.map (fun (name, e) -> name, transform1 e) in 201 | Record (loc, names) 202 | | A.RecordIndex (loc, expr, index) -> 203 | RecordIndex (loc, transform1 expr, index) 204 | | A.Absurd (s, e) -> Absurd (s, transform1 e) 205 | 206 | and case e clauses = 207 | match clauses with 208 | | [] -> Absurd ("Pattern match failure", LitInteger (d, 0)) 209 | | (A.PVariable x, body) :: _rest -> 210 | (* if' (LitBool (d, true)) 211 | (let' x e (transform1 body)) 212 | (case e rest) *) 213 | (let' x e (transform1 body)) (* it's a pattern variable - it's always going to match *) 214 | | (A.PInteger q, body) :: rest -> 215 | let q = LitInteger (d, q) in 216 | let predicate = app equal [q; e] in 217 | if' predicate 218 | (transform1 body) 219 | (case e rest) 220 | | (A.PString s, body) :: rest -> 221 | let s = LitString (d, s) in 222 | let predicate = app equal [s; e] in 223 | if' predicate 224 | (transform1 body) 225 | (case e rest) 226 | | (A.PBool b, body) :: rest -> 227 | let b = LitBool (d, b) in 228 | let predicate = app equal [b; e] in 229 | if' predicate 230 | (transform1 body) 231 | (case e rest) 232 | | (A.PRecord pats, body) :: rest -> 233 | let e_0 = record_index e "0" in 234 | let v_0 = pats |> List.map snd |> List.hd |> expr_of_pat in 235 | let pats = pats |> List.tl |> List.map (fun (n, p) -> FieldName.to_string n, var_of_pat p) in 236 | (* instead of disturbing the current lexical scope with potentially unused 237 | (variable) bindings, we can substitue each variable usage in `body` with 238 | the coresponding record-index operation. *) 239 | let predicate_true = 240 | List.fold_right (fun (field, variable) s -> let' variable (record_index e field) s) 241 | pats 242 | (transform1 body) 243 | in 244 | let predicate = app equal [e_0; v_0] in 245 | if' predicate 246 | predicate_true 247 | (case e rest) 248 | 249 | (* tbh this second pass is *very* unecessary; 250 | the first pass is the real deal. in fact, 251 | the seperation of the two passes is the source 252 | of the bug in this pattern matching compiler. 253 | 254 | how? why? which bug? 255 | 256 | bug: there is no backtracking for a failure when 257 | compiling a nested pattern case. when one of the 258 | inner pattern fails, it should continue by checking 259 | the next pattern-expression clause. the current 260 | implementation doesn't. 261 | why?: first of all, the two transforms operate on *different* 262 | syntax trees. also, `transform0` doesn't have access to 263 | the next branch (i.e pattern-expression clause), so what 264 | should it do when a nested pattern its un-nesting fails? 265 | NOTHING. because it doens't have access to this contextual 266 | information. 267 | 268 | so please fix this bug (if you understand, of course.) *) 269 | let g = transform0 >> transform1 270 | 271 | let rec handle_toplevel = function 272 | | [] -> [] 273 | | A.Def (loc, name, expr) :: rest -> Def (loc, name, g expr) :: handle_toplevel rest 274 | | A.Expression e :: rest -> Expression (g e) :: handle_toplevel rest 275 | | (A.VariantDef _ | A.RecordDef _ | A.AbilityDef _ | A.Claim _) :: rest -> handle_toplevel rest 276 | 277 | (* boilerplate pretty pprinting stuff *) 278 | 279 | let pp_list es f = es |> List.map f |> String.concat ", " 280 | 281 | let rec pp_expression = function 282 | | LitBool (_loc, b) -> Bool.to_string b 283 | | LitInteger (_loc, i) -> Int.to_string i 284 | | LitFloat (_loc, f) -> Float.to_string f 285 | | LitString (_loc, s) -> s 286 | | Variable (_loc, v) -> VarName.to_string v 287 | | If (_loc, pred, tru, fals) -> 288 | Printf.sprintf "if %s then %s else %s" 289 | (pp_expression pred) 290 | (pp_expression tru) 291 | (pp_expression fals) 292 | | Application (_loc, rand, es) -> 293 | Printf.sprintf "%s (%s)" 294 | (pp_expression rand) 295 | (pp_list es pp_expression) 296 | | Let (_loc, var, value, body) -> 297 | Printf.sprintf "let %s = %s; %s" 298 | (VarName.to_string var) 299 | (pp_expression value) 300 | (pp_expression body) 301 | | Fn (_loc, names, body) -> 302 | Printf.sprintf "fn (%s) %s" 303 | (pp_list names VarName.to_string) 304 | (pp_expression body) 305 | | Record (_loc, fes) -> 306 | let f (field, expr) = 307 | Printf.sprintf "%s: %s" 308 | (FieldName.to_string field) 309 | (pp_expression expr) 310 | in 311 | Printf.sprintf "{%s}" 312 | (pp_list fes f) 313 | | RecordIndex (_loc, expr, name) -> 314 | Printf.sprintf "%s.%s" 315 | (pp_expression expr) 316 | (FieldName.to_string name) 317 | | Absurd (s, e) -> 318 | Printf.sprintf "absurd (%s, %s)" s (pp_expression e) 319 | 320 | let pp_toplevel = function 321 | | Def (_loc, name, expr) -> 322 | Printf.sprintf "def %s = %s" 323 | (VarName.to_string name) 324 | (pp_expression expr) 325 | | Expression expr -> pp_expression expr -------------------------------------------------------------------------------- /runtime/desugarData.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | (* transform all tuple and variant patterns and expressions 4 | into record patterns and expressions 5 | 6 | { 0 : ... 7 | 1 : ... 8 | 2 : ... 9 | . 10 | . 11 | . 12 | n : ... } 13 | 14 | field 0 is a tag, field 1 to n represent the field 15 | that they hold 16 | *) 17 | 18 | open Syntax 19 | open Naming 20 | open Utility 21 | 22 | module A = DesugarEffect 23 | 24 | (* contaains bindings of varinats names to positional indexes *) 25 | let variant_table : (DataName.t * int) list ref = ref [] 26 | let lookup_variant name = 27 | match List.assoc name !variant_table with 28 | | value -> value 29 | | exception Not_found -> 30 | Errors.runtime @@ Printf.sprintf "desugar datatypes: the variant name %s undefined" 31 | (DataName.to_string name) 32 | 33 | let record_table : (FieldName.t * int) list ref = ref [] 34 | let lookup_record name = 35 | match List.assoc name !record_table with 36 | | value -> value 37 | | exception Not_found -> 38 | Errors.runtime @@ Printf.sprintf "desugar datatypes: the record name %s undefined" 39 | (FieldName.to_string name) 40 | 41 | type pattern = 42 | | PInteger of int 43 | | PString of string 44 | | PBool of bool 45 | | PVariable of VarName.t 46 | | PRecord of (FieldName.t * pattern) list 47 | 48 | type t = 49 | 50 | | LitBool of Loc.t * bool 51 | | LitInteger of Loc.t * int 52 | | LitFloat of Loc.t * float 53 | | LitString of Loc.t * string 54 | 55 | | Variable of Loc.t * VarName.t 56 | | If of Loc.t * t * t * t 57 | | Application of Loc.t * t * t list 58 | | Let of Loc.t * pattern * t * t 59 | | Fn of Loc.t * VarName.t list * t 60 | | Annotated of Loc.t * t * Type.t 61 | | Sequence of Loc.t * t * t 62 | | Case of Loc.t * t * (pattern * t) list 63 | | Record of Loc.t * (FieldName.t * t) list 64 | | RecordIndex of Loc.t * t * FieldName.t 65 | | Absurd of string * t 66 | 67 | type toplevel = 68 | | Claim of Loc.t * VarName.t * Type.t 69 | | Def of Loc.t * VarName.t * t 70 | | VariantDef of Loc.t * DataName.t * (VarName.t * Type.t list) list 71 | | RecordDef of Loc.t * DataName.t * (FieldName.t * Type.t) list 72 | | AbilityDef of Loc.t * VarName.t * Type.t list 73 | | Expression of t 74 | 75 | 76 | (* [reduce_to_record f g xs tag] takes a contructor function [f], a 77 | transformation function [g] a list of transformable items [xs], and a 78 | [tag] which is already tranformed. it then created an a list of pairs 79 | of transformed items tagged with a field name. the list starts with [(0, tag)] 80 | then all the other transformed items folllow, paired up with their respective 81 | index. the constructor function [f] is then applied to this a-list to get whatever 82 | expression we desire. *) 83 | let transform f g xs tag = 84 | let len = 1 + List.length xs in (* add one to accomodate the tag *) 85 | let names = List.init len (string_of_int >> FieldName.of_string) in 86 | let fields = tag :: List.map g xs in (* add the tag to the fields *) 87 | let fields = List.combine names fields in 88 | f fields 89 | 90 | let reduce_to_precord = transform (fun p -> PRecord p) 91 | 92 | (* we can also decide to take an arbitrary `Loc.t` 93 | instead of using `Loc.dummy` *) 94 | let reduce_to_erecord = transform (fun e -> Record (Loc.dummy, e)) 95 | 96 | let rec g_pat = function 97 | | A.PVariable name -> PVariable name 98 | | A.PBool b -> PBool b 99 | | A.PString s -> PString s 100 | | A.PInteger i -> PInteger i 101 | | A.PRecord (_name, pats) -> 102 | let tag = (PInteger 0) in 103 | let pats = List.map snd pats in (* forget about field names *) 104 | reduce_to_precord g_pat pats tag 105 | | A.PVariant (name, pats) -> 106 | let name = name |> VarName.to_string |> DataName.of_string in 107 | let index = lookup_variant name in 108 | let tag = PInteger index in 109 | reduce_to_precord g_pat pats tag 110 | | A.PTuple pats -> 111 | let tag = PInteger 0 in 112 | reduce_to_precord g_pat pats tag 113 | 114 | let rec g expr = 115 | match expr with 116 | | A.Tuple (loc, fields) -> 117 | let tag = LitInteger (loc, 0) in 118 | reduce_to_erecord g fields tag 119 | | A.Variant (loc, name, fields) -> 120 | let index = lookup_variant name in 121 | let tag = LitInteger (loc, index) in 122 | reduce_to_erecord g fields tag 123 | | A.Record (loc, _name, fields) -> 124 | (* we need to transform all uses of fields to their integer positions *) 125 | let fields = List.map snd fields in 126 | let tag = LitInteger (loc, 0) in 127 | reduce_to_erecord g fields tag 128 | | A.LitTodo loc -> Absurd ("Unreplaced TODO", LitInteger (loc, 0)) 129 | | A.LitUnit loc -> LitInteger (loc, 0) (* zero is unit *) 130 | | A.LitBool (loc, b) -> LitBool (loc, b) 131 | | A.LitInteger (loc, i) -> LitInteger (loc, i) 132 | | A.LitFloat (loc, f) -> LitFloat (loc, f) 133 | | A.LitString (loc, s) -> LitString (loc, s) 134 | | A.Variable (loc, name) -> Variable (loc, name) 135 | | A.If (loc, p, pt, pf) -> If (loc, g p, g pt, g pf) 136 | | A.Application (loc, f, args) -> 137 | let args = List.map g args in 138 | Application (loc, g f, args) 139 | | A.Let (loc, pat, expr, body) -> 140 | Let (loc, g_pat pat, g expr, g body) 141 | | A.Fn (loc, vars, body) -> Fn (loc, vars, g body) 142 | | A.Annotated (loc, expr, ty) -> Annotated (loc, g expr, ty) 143 | | A.Sequence (loc, a, b) -> Sequence (loc, g a, g b) 144 | | A.Absurd (s, e) -> Absurd (s, g e) 145 | 146 | | A.Case (loc, expr, clauses) -> 147 | let clauses = clauses |> List.map (fun (p, e) -> g_pat p, g e) in 148 | Case (loc, g expr, clauses) 149 | | A.RecordIndex (loc, expr, name) -> 150 | let index = lookup_record name |> string_of_int |> FieldName.of_string in 151 | RecordIndex (loc, g expr, index) 152 | 153 | let toplevel = function 154 | | A.Claim (loc, name, ty) -> Claim (loc, name, ty) 155 | | A.Def (loc, name, expr) -> Def (loc, name, g expr) 156 | | A.VariantDef (loc, name, body) -> 157 | let names = List.map (fst >> VarName.to_string >> DataName.of_string) body in 158 | let len = List.length body in 159 | let indices = List.init len Fun.id in 160 | let tbl = List.combine names indices in 161 | variant_table := tbl @ !variant_table; 162 | VariantDef (loc, name, body) 163 | | A.RecordDef (loc, name, body) -> 164 | let names = List.map fst body in 165 | let len = List.length body in 166 | let indices = List.map succ @@ List.init len Fun.id in 167 | let tbl = List.combine names indices in 168 | record_table := tbl @ !record_table; 169 | RecordDef (loc, name, body) 170 | | A.AbilityDef (loc, name, tys) -> AbilityDef (loc, name, tys) 171 | | A.Expression e -> Expression (g e) 172 | 173 | let handle_toplevel = List.map toplevel 174 | 175 | (* 176 | we need a table to map variants name to their correspomding integr values 177 | *) 178 | 179 | (* | TAG | ... 180 | for variants the tag is an integer representing it's position in the variants definition 181 | for tuples the tag is 0 182 | for records is also zero *) 183 | 184 | 185 | let pp_list es f = es |> List.map f |> String.concat ", " 186 | 187 | let rec pp_pattern = function 188 | | PInteger i -> Int.to_string i 189 | | PString s -> s 190 | | PVariable name -> VarName.to_string name 191 | | PBool b -> Bool.to_string b 192 | | PRecord es -> 193 | Printf.sprintf "{%s}" @@ 194 | pp_list es (fun (name, pattern) -> Printf.sprintf "%s: %s" (FieldName.to_string name) (pp_pattern pattern)) 195 | 196 | let rec pp_expression = function 197 | | LitBool (_loc, b) -> Bool.to_string b 198 | | LitInteger (_loc, i) -> Int.to_string i 199 | | LitFloat (_loc, f) -> Float.to_string f 200 | | LitString (_loc, s) -> s 201 | | Variable (_loc, v) -> VarName.to_string v 202 | | If (_loc, pred, tru, fals) -> 203 | Printf.sprintf "if %s then %s else %s" 204 | (pp_expression pred) 205 | (pp_expression tru) 206 | (pp_expression fals) 207 | | Application (_loc, rand, es) -> 208 | Printf.sprintf "%s (%s)" 209 | (pp_expression rand) 210 | (pp_list es pp_expression) 211 | | Let (_loc, var, value, body) -> 212 | Printf.sprintf "let %s = %s; %s" 213 | (pp_pattern var) 214 | (pp_expression value) 215 | (pp_expression body) 216 | | Fn (_loc, names, body) -> 217 | Printf.sprintf "fn (%s) %s" 218 | (pp_list names VarName.to_string) 219 | (pp_expression body) 220 | | Annotated (_loc, expr, ty) -> 221 | Printf.sprintf "(the %s %s)" 222 | (pp_expression expr) 223 | (Type.pp_ty ty) 224 | | Sequence (_loc, a, b) -> 225 | Printf.sprintf "%s; %s;" 226 | (pp_expression a) 227 | (pp_expression b) 228 | | Case (_loc, expr, pes) -> (* pes - pattern, expression S *) 229 | let f (pat, expr) = 230 | Printf.sprintf "%s -> %s" 231 | (pp_pattern pat) 232 | (pp_expression expr) 233 | in 234 | Printf.sprintf "case %s { %s }" 235 | (pp_expression expr) 236 | (pp_list pes f) 237 | | Record (_loc, fes) -> (* fes - field, expression S *) 238 | let f (field, expr) = 239 | Printf.sprintf "%s: %s" 240 | (FieldName.to_string field) 241 | (pp_expression expr) 242 | in 243 | Printf.sprintf "{%s}" 244 | (pp_list fes f) 245 | | RecordIndex (_loc, expr, name) -> 246 | Printf.sprintf "%s.%s" 247 | (pp_expression expr) 248 | (FieldName.to_string name) 249 | | Absurd (s, e) -> 250 | Printf.sprintf "absurd (%s, %s)" s (pp_expression e) 251 | 252 | let pp_toplevel = function 253 | | Claim (_loc, name, ty) -> 254 | Printf.sprintf 255 | "claim %s %s" 256 | (VarName.to_string name) 257 | (Type.pp_ty ty) 258 | | Def (_loc, name, expr) -> (* TODO: add a special case for fn *) 259 | Printf.sprintf "def %s = %s" 260 | (VarName.to_string name) 261 | (pp_expression expr) 262 | | Expression expr -> pp_expression expr 263 | | VariantDef _ | RecordDef _ | AbilityDef _ -> "" (* for now *) 264 | -------------------------------------------------------------------------------- /runtime/desugarEffect.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Naming 3 | 4 | module A = Ast 5 | module T = Type 6 | 7 | (* these are all boilerplate code. i should really be using polymorphic variants.*) 8 | type pattern = 9 | | PInteger of int 10 | | PString of string 11 | | PBool of bool 12 | | PVariable of VarName.t 13 | | PRecord of DataName.t * (FieldName.t * pattern) list 14 | | PVariant of VarName.t * pattern list 15 | | PTuple of pattern list 16 | 17 | type t = 18 | | LitTodo of Loc.t 19 | | LitUnit of Loc.t 20 | | LitBool of Loc.t * bool 21 | | LitInteger of Loc.t * int 22 | | LitFloat of Loc.t * float 23 | | LitString of Loc.t * string 24 | | Variable of Loc.t * VarName.t 25 | | If of Loc.t * t * t * t 26 | | Application of Loc.t * t * t list 27 | | Let of Loc.t * pattern * t * t 28 | | Fn of Loc.t * VarName.t list * t 29 | | Annotated of Loc.t * t * T.t 30 | | Sequence of Loc.t * t * t 31 | | Case of Loc.t * t * (pattern * t) list 32 | | Record of Loc.t * DataName.t * (FieldName.t * t) list 33 | | RecordIndex of Loc.t * t * FieldName.t 34 | | Tuple of Loc.t * t list 35 | | Variant of Loc.t * DataName.t * t list 36 | | Absurd of string * t 37 | 38 | type toplevel = 39 | | Claim of Loc.t * VarName.t * T.t 40 | | Def of Loc.t * VarName.t * t 41 | | VariantDef of Loc.t * DataName.t * (VarName.t * T.t list) list 42 | | RecordDef of Loc.t * DataName.t * (FieldName.t * T.t) list 43 | | AbilityDef of Loc.t * VarName.t * T.t list 44 | | Expression of t 45 | 46 | 47 | let rec pat_to_t = function 48 | | A.PInteger i -> PInteger i 49 | | A.PString s -> PString s 50 | | A.PBool b -> PBool b 51 | | A.PVariable v -> PVariable v 52 | | A.PTuple pats -> 53 | let pats = List.map pat_to_t pats in 54 | PTuple pats 55 | | A.PVariant (name, pats) -> 56 | let pats = List.map pat_to_t pats in 57 | PVariant (name, pats) 58 | | A.PRecord (name, pats) -> 59 | let pats = List.map (fun (n, p) -> n, pat_to_t p) pats in 60 | PRecord (name, pats) 61 | 62 | let rec expr_to_t = function 63 | | A.Variable (loc, name) -> Variable (loc, name) 64 | | A.LitUnit loc -> LitUnit loc 65 | | A.LitInteger (loc, i) -> LitInteger (loc, i) 66 | | A.LitBool (loc, b) -> LitBool (loc, b) 67 | | A.LitFloat (loc, f) -> LitFloat (loc, f) 68 | | A.LitString (loc, s) -> LitString (loc, s) 69 | | A.Annotated (loc, e, ty) -> Annotated (loc, expr_to_t e, ty) 70 | | A.If (loc, p, pt, pf) -> If (loc, expr_to_t p, expr_to_t pt, expr_to_t pf) 71 | | A.Let (loc, pat, expr, body) -> Let (loc, pat_to_t pat, expr_to_t expr, expr_to_t body) 72 | | A.Fn (loc, names, body) -> Fn (loc, names, expr_to_t body) 73 | | A.Application (loc, operator, operands) -> Application (loc, expr_to_t operator, List.map expr_to_t operands) 74 | | A.Record (loc, name, body) -> 75 | let body = List.map (fun (n, e) -> n, expr_to_t e) body in 76 | Record (loc, name, body) 77 | | A.RecordIndex (loc, record, field) -> RecordIndex (loc, expr_to_t record, field) 78 | | A.Case (loc, expr, cases) -> 79 | let cases = List.map (fun (p, e) -> pat_to_t p, expr_to_t e) cases in 80 | Case (loc, expr_to_t expr, cases) 81 | | A.Tuple (loc, exprs) -> Tuple (loc, List.map expr_to_t exprs) 82 | | A.Sequence (loc, e1, e2) -> Sequence (loc, expr_to_t e1, expr_to_t e2) 83 | | A.Variant (loc, name, args) -> Variant (loc, name, List.map expr_to_t args) 84 | | A.LitTodo loc -> LitTodo loc 85 | | A.Absurd (s, e) -> Absurd (s, expr_to_t e) 86 | | A.Do _ | A.Handle _ -> assert false 87 | 88 | 89 | let pp_list es f = es |> List.map f |> String.concat ", " 90 | 91 | let rec pp_pattern = function 92 | | PInteger i -> Int.to_string i 93 | | PString s -> s 94 | | PVariable name -> VarName.to_string name 95 | | PTuple es -> Printf.sprintf "(%s)" (pp_list es pp_pattern) 96 | | PBool b -> Bool.to_string b 97 | | PVariant (name, es) -> Printf.sprintf "%s { %s }" (VarName.to_string name) (pp_list es pp_pattern) 98 | | PRecord (name, es) -> 99 | Printf.sprintf "%s {%s}" (DataName.to_string name) @@ 100 | pp_list es (fun (name, pattern) -> Printf.sprintf "%s: %s" (FieldName.to_string name) (pp_pattern pattern)) 101 | 102 | let rec pp_expression = function 103 | | LitTodo _loc -> "TODO" 104 | | LitUnit _loc -> "()" 105 | | LitBool (_loc, b) -> Bool.to_string b 106 | | LitInteger (_loc, i) -> Int.to_string i 107 | | LitFloat (_loc, f) -> Float.to_string f 108 | | LitString (_loc, s) -> s 109 | | Variable (_loc, v) -> VarName.to_string v 110 | | If (_loc, pred, tru, fals) -> 111 | Printf.sprintf "if %s then %s else %s" 112 | (pp_expression pred) 113 | (pp_expression tru) 114 | (pp_expression fals) 115 | | Application (_loc, rand, es) -> 116 | Printf.sprintf "%s (%s)" 117 | (pp_expression rand) 118 | (pp_list es pp_expression) 119 | | Let (_loc, var, value, body) -> 120 | Printf.sprintf "let %s = %s; %s" 121 | (pp_pattern var) 122 | (pp_expression value) 123 | (pp_expression body) 124 | | Fn (_loc, names, body) -> 125 | Printf.sprintf "fn (%s) %s" 126 | (pp_list names VarName.to_string) 127 | (pp_expression body) 128 | | Annotated (_loc, expr, ty) -> 129 | Printf.sprintf "(the %s %s)" 130 | (pp_expression expr) 131 | (T.pp_ty ty) 132 | | Sequence (_loc, a, b) -> 133 | Printf.sprintf "%s; %s;" 134 | (pp_expression a) 135 | (pp_expression b) 136 | | Case (_loc, expr, pes) -> (* pes - pattern, expression S *) 137 | let f (pat, expr) = 138 | Printf.sprintf "%s -> %s" 139 | (pp_pattern pat) 140 | (pp_expression expr) 141 | in 142 | Printf.sprintf "case %s { %s }" 143 | (pp_expression expr) 144 | (pp_list pes f) 145 | | Tuple (_loc, es) -> 146 | Printf.sprintf "(%s)" (pp_list es pp_expression) 147 | | Record (_loc, name, fes) -> (* fes - field, expression S *) 148 | let f (field, expr) = 149 | Printf.sprintf "%s: %s" 150 | (FieldName.to_string field) 151 | (pp_expression expr) 152 | in 153 | Printf.sprintf "%s {%s}" 154 | (DataName.to_string name) 155 | (pp_list fes f) 156 | | RecordIndex (_loc, expr, name) -> 157 | Printf.sprintf "%s.%s" 158 | (pp_expression expr) 159 | (FieldName.to_string name) 160 | | Variant (_loc, name, []) -> DataName.to_string name 161 | | Variant (_loc, name, args) -> 162 | Printf.sprintf "%s (%s)" (DataName.to_string name) (pp_list args pp_expression) 163 | | Absurd (s, e) -> 164 | Printf.sprintf "absurd (%s, %s)" s (pp_expression e) 165 | 166 | let pp_toplevel = function 167 | | Claim (_loc, name, ty) -> 168 | Printf.sprintf 169 | "claim %s %s" 170 | (VarName.to_string name) 171 | (T.pp_ty ty) 172 | | Def (_loc, name, expr) -> (* TODO: add a special case for fn *) 173 | Printf.sprintf "def %s = %s" 174 | (VarName.to_string name) 175 | (pp_expression expr) 176 | | Expression expr -> pp_expression expr 177 | | VariantDef _ | RecordDef _ | AbilityDef _ -> "" (* for now *) 178 | 179 | (* end of boilerplate *) 180 | 181 | (* computations are represented as functions that take 182 | a stack of functions, which alternate `k` and `h` continuations. 183 | `k` continuations represent how we would normally return a value. 184 | `h` coninutations represent how to handle an effect. *) 185 | 186 | (* 187 | for more details on this cps translation see: 188 | 189 | [1] https://dhil.net/research/papers/generalised_continuations-jfp2020.pdf 190 | [2] https://homepages.inf.ed.ac.uk/slindley/papers/handlers-cps.pdf 191 | [3] https://www.cs.uoregon.edu/research/summerschool/summer18/lectures/bauer_notes.pdf 192 | [4] https://raw.githubusercontent.com/matijapretnar/eff/master/docs/handlers-tutorial.pdf 193 | *) 194 | 195 | (* i what to use this as a marker for 196 | computations that have been created. 197 | what i *really* want to do is keep 198 | metadata with the syntax, but oh well... *) 199 | let d' = Lexing.{ 200 | pos_fname = "comp--00"; 201 | pos_lnum = -9; 202 | pos_bol = -8; 203 | pos_cnum = -7; 204 | } 205 | let d = (d', d') 206 | 207 | let is_cps_computation = function 208 | | Fn (loc, _, _) -> loc = d 209 | | _ -> false 210 | 211 | (* let d = Loc.dummy *) 212 | 213 | let fresh_var = 214 | let state = ref 0 in 215 | fun id -> 216 | let s = Printf.sprintf "%s_%d" id !state in 217 | VarName.of_string s 218 | 219 | let nil = LitUnit Loc.dummy 220 | 221 | let cons = 222 | let e1 = fresh_var "e1" 223 | and e2 = fresh_var "e2" in 224 | Fn (d, 225 | [e1; e2], 226 | Tuple (d, 227 | [Variable (d, e1); 228 | Variable (d, e2)])) 229 | 230 | let rest = 231 | let pair = fresh_var "pair" 232 | and hd = fresh_var "hd" 233 | and tl = fresh_var "tl" in 234 | Fn (d, 235 | [pair], 236 | Case (d, Variable (d, pair), 237 | [PTuple [PVariable hd; PVariable tl], 238 | Variable (d, tl)])) 239 | 240 | let first = 241 | let pair = fresh_var "pair" 242 | and hd = fresh_var "hd" 243 | and tl = fresh_var "tl" in 244 | Fn (d, 245 | [pair], 246 | Case (d, Variable (d, pair), 247 | [PTuple [PVariable hd; PVariable tl], 248 | Variable (d, hd)])) 249 | 250 | let rec get_return_clause l = 251 | match l with 252 | | [] -> 253 | (* this should indicte a bug in the parser *) 254 | failwith "get_return_clause failed: no return clause in the handler" 255 | | A.Return (name, body) :: _ -> `Return (name, body) 256 | | _ :: rest -> get_return_clause rest 257 | 258 | let rec get_operation_clauses l = 259 | match l with 260 | | [] -> [] 261 | | A.Return _ :: rest -> get_operation_clauses rest 262 | | A.Operation (label, vars, kvar, body) :: rest -> 263 | `Operation (label, vars, kvar, body) :: get_operation_clauses rest 264 | 265 | (* GENERAL RULE OF THUMB TO AVOID UNWEIEDLY BUGS: 266 | ALWAYS APPLY THE DESUGARING FUNCTION `g` BEFORE 267 | CALLING `return` *) 268 | 269 | (* implicitly lift *values* into *computations* 270 | this is not available to the users just to keep 271 | things simple *) 272 | let rec return expr = 273 | let k = fresh_var "___k___" in (* i just put the the wierdest variable name i could think of *) 274 | let ks' = fresh_var "___ks'___" in 275 | let ks = fresh_var "___ks___" in 276 | match expr with 277 | (* | Let (l, p, body, expr) -> Let (l, p, body, expr) *) 278 | (* | Fn _ -> expr *) 279 | 280 | (* applications result in a computation that doesn't start with a function, 281 | but when eventually reduced, it produces a function that *should* be marked 282 | as a computation. *) 283 | | Application _ -> expr 284 | | expr when is_cps_computation expr -> expr 285 | | expr -> 286 | (* print_endline "yes"; *) 287 | let e = Fn (d, [ks], 288 | Case (d, Variable (d, ks), 289 | [PTuple [PVariable k; PVariable ks'], 290 | Application (d, Variable (d, k), [expr; Variable (d, ks')])])) 291 | in 292 | (* print_endline (pp_expression e); *) 293 | e 294 | 295 | (* rants: - applications, if .. then .. else .. are *computations*! - 296 | in this setting, whenever we get a "should not be evaluated by me" 297 | error from the interpreter, we are probably using a computation as 298 | a value - turns out, returning from a handler clauses calls the 299 | continuation associated with that clause and calling the actual 300 | continuation does something *very* scary... - also, a function 301 | body is a computation ... we might say we want to intercept every 302 | function call in the `g` function, but what about function 303 | application with variables?? (fucking first-class functions!) 304 | 305 | solutions: - we need to re-write the evaluator to explicity its 306 | closures, and the evaluator should be aware of this `g` transform - 307 | there is probably a bug with the handler case in this `g` transform 308 | 309 | also: - a handler returns a computation *) 310 | 311 | (* what's left? 312 | 1. some computations are still treated like values -- this is unfair. 313 | 2. function application needs to sequence its arguments. 314 | 315 | --------------------------------------- 316 | 317 | bugs? 318 | 319 | 1. closure seem not to be working (pattern matching on arg as `ks`) 320 | 321 | *) 322 | 323 | let rec g = function 324 | | A.LitBool (loc, b) -> LitBool (loc, b) 325 | | A.LitFloat (loc, f) -> LitFloat (loc, f) 326 | | A.LitInteger (loc, i) -> LitInteger (loc, i) 327 | | A.LitTodo loc -> LitTodo loc 328 | | A.LitString (loc, s) -> LitString (loc, s) 329 | | A.LitUnit loc -> LitUnit loc 330 | | A.Variable (loc, v) -> Variable (loc, v) 331 | | A.Variant (loc, name, args) -> Variant (loc, name, List.map g args) 332 | | A.Tuple (loc, elems) -> Tuple (loc, List.map g elems) 333 | | A.Record (loc, name, args) -> 334 | let args = List.map (fun (n, e) -> n, g e) args in 335 | Record (loc, name, args) 336 | 337 | (* btw this is also a computation *) 338 | | A.RecordIndex (loc, expr, name) -> RecordIndex (loc, g expr, name) 339 | 340 | | A.Annotated (loc, expr, ty) -> Annotated (loc, g expr, ty) 341 | 342 | (* this is also a computation (can easily be translated into a let) *) 343 | | A.Sequence (loc, a, b) -> Sequence (loc, g a, g b) 344 | 345 | | A.Fn (loc, vars, body) -> 346 | Fn (loc, vars, return (g body)) 347 | 348 | | A.Do (_loc, label, args) -> 349 | let args = Tuple (d, List.map g args) in 350 | let ks = fresh_var "ks" 351 | and k = fresh_var "k" 352 | and h = fresh_var "h" in 353 | let tag = LitString (d, VarName.to_string label) in 354 | let x, ks2 = fresh_var "x", fresh_var "ks" in 355 | let ks' = fresh_var "ks'" in 356 | Fn 357 | (d, 358 | [ks], 359 | Let (d, PTuple [PVariable k; PTuple [PVariable h; PVariable ks']], Variable (d, ks), 360 | Application (d, Variable (d, h), [Tuple (d, [tag; args; 361 | Fn (d, [x], 362 | Fn (d, [ks2], 363 | Application (d, Variable (d, k), 364 | [Variable (d, x); 365 | Application (d, cons, 366 | [Variable (d, h); 367 | Variable (d, ks2)])])))]); 368 | Variable (d, ks')]))) 369 | | A.Let (_loc, pat, expr, body) -> 370 | let get_variable = function 371 | | A.PVariable x -> x 372 | | _ -> failwith "can only bind a variable with a let pattern before g transform" 373 | in 374 | let x = get_variable pat in 375 | let ks, k, ks', f, ks'' = 376 | fresh_var "ks", fresh_var "k", 377 | fresh_var "ks'", fresh_var "f", 378 | fresh_var "ks''" 379 | in 380 | let e = Fn 381 | (d, 382 | [ks], 383 | Let (d, PTuple [PVariable k; PVariable ks'], Variable (d, ks), 384 | Let (d, PVariable f, Fn (d, [x; ks''], 385 | Application (d, return (g body), [Application (d, cons, [Variable (d, k); 386 | Variable (d, ks'')])]) ), 387 | Application (d, return (g expr) , [Application (d, cons, [Variable (d, f); 388 | Variable (d, ks')])])))) 389 | in 390 | (* print_string "the let: "; 391 | print_endline (pp_expression e); 392 | print_endline "after let" ; *) 393 | e 394 | | A.Handle (_loc, expr, clauses) -> 395 | let ks, k1, z, k2 = fresh_var "ks", fresh_var "k1", fresh_var "z", fresh_var "k2" in 396 | let ret = 397 | let `Return (name, body) = get_return_clause clauses in 398 | let h, ks' = fresh_var "h", fresh_var "ks'" in 399 | (* print_endline "here"; 400 | print_endline (pp_expression (g body)); *) 401 | Fn 402 | (d, 403 | [name; ks], 404 | Let (d, PTuple [PVariable h; PVariable ks'], Variable (d, ks), 405 | Application (d, return (g body), [Variable (d, ks')]))) 406 | in 407 | let g_clause ks clause = 408 | let `Operation (label, vars, kvar, body) = clause in 409 | let label = VarName.to_string label in 410 | let pvars = vars |> List.map (fun var -> PVariable var) in 411 | let pat = PTuple [PString label; PTuple pvars; PVariable kvar] in 412 | (* print_endline "here we go"; 413 | print_endline (pp_expression (return @@ g body)); 414 | there are some subtleties here 415 | we need to return only when we know body is a value 416 | before the transform *) 417 | 418 | let body = Application (d, return (g body), [Variable (d, ks)]) in 419 | (pat, body) 420 | in 421 | let cases = 422 | clauses 423 | |> get_operation_clauses 424 | |> List.map (g_clause k1) 425 | in 426 | let foward (label, arg, kvar) ks = 427 | let k', h', ks', f, x, ks'' = 428 | fresh_var "k'", fresh_var "h'", 429 | fresh_var "ks'", fresh_var "f", 430 | fresh_var "x", fresh_var "ks''" 431 | in 432 | Let (d, PTuple [PVariable k'; PTuple [PVariable h'; PVariable ks']], Variable (d, ks), 433 | Let (d, PVariable f, 434 | Fn (d, [x], 435 | Fn (d, [ks''], Application (d, Application (d, Variable (d, kvar), 436 | [Variable (d, x)]), 437 | [Application (d, cons, [Variable (d, k'); 438 | Application (d, cons, 439 | [Variable(d, h'); Variable (d, ks'')])])]))), 440 | Application (d, Variable (d, h'), [ Tuple (d, [label; arg; Variable (d, f)]); Variable (d, ks')]))) 441 | in 442 | let cases = cases in 443 | let op_clauses = 444 | let label, args, kvar = 445 | fresh_var "label", fresh_var "args", 446 | fresh_var "kvar" 447 | in 448 | Fn (d, [z; k1], 449 | Case (d, Variable (d, z), cases @ 450 | [PTuple [PVariable label; PVariable args; PVariable kvar], 451 | foward (Variable (d, label), Variable (d, args), kvar) k1])) 452 | in 453 | Fn (d, [k2], Application (d, g expr, [Application (d, cons, [ret; Application 454 | (d, cons, [op_clauses; Variable (d, k2)])])])) 455 | 456 | (* these are actually computation. idk for now *) 457 | | A.Case (loc, expr, clauses) -> 458 | let clauses = List.map (fun (pat, expr) -> pat_to_t pat, g expr) clauses in 459 | Case (loc, g expr, clauses) 460 | | A.If (_loc, p, pt, pf) -> 461 | let ks, k, ks', f = fresh_var "ks", fresh_var "k", fresh_var "ks'", fresh_var "f" in 462 | let x, ks'' = fresh_var "x", fresh_var "ks''" in 463 | (* If (loc, g p, g pt, g pf) 464 | Application (d, return (g body), 465 | [Application (d, cons, [Variable (d, k); Variable (d, ks'')])] 466 | *) 467 | let e = Fn 468 | (d, 469 | [ks], 470 | Let (d, PTuple [PVariable k; PVariable ks'], Variable (d, ks), 471 | Let (d, PVariable f, Fn (d, [x; ks''], 472 | Application (d, If (d, Variable (d, x), return (g pt), return (g pf)), 473 | [Application (d, cons, [Variable (d, k); Variable (d, ks'')])])), 474 | Application (d, return (g p) , [Application (d, cons, [Variable (d, f); 475 | Variable (d, ks')])])))) 476 | in 477 | e 478 | | A.Application (_loc, f, args) -> 479 | let ks, k, ks', fn = fresh_var "ks", fresh_var "k", fresh_var "ks'", fresh_var "fn" in 480 | let x, ks'' = fresh_var "x", fresh_var "ks''" in 481 | let args' = List.map expr_to_t args in 482 | let e = Fn 483 | (d, 484 | [ks], 485 | Let (d, PTuple [PVariable k; PVariable ks'], Variable (d, ks), 486 | Let (d, PVariable fn, Fn (d, [x; ks''], 487 | Application (d, Application (d, Variable (d, x), args'), 488 | [Application (d, cons, [Variable (d, k); Variable (d, ks'')])])), 489 | Application (d, return (g f) , [Application (d, cons, [Variable (d, fn); 490 | Variable (d, ks')])])))) 491 | in 492 | (* let e = Application (loc, expr_to_t f, args') in *) 493 | (* print_endline "application"; 494 | print_endline @@ pp_expression e; *) 495 | e 496 | | A.Absurd (s, e) -> Absurd (s, expr_to_t e) 497 | 498 | (* this should always be the body of a plain expression body of a handler clause *) 499 | (* A.Plain x what if i transform x, just like the plain case here? *) 500 | (* let ks = fresh_var "ks" in 501 | A.Fn (d, 502 | [ks], 503 | A.Application 504 | (d, 505 | A.Application (d, first, [A.Variable (d, ks)]), 506 | [e; A.Application (d, rest, [A.Variable (d, ks)])])) *) 507 | (* A.Plain e *) 508 | 509 | 510 | (* 511 | Tuple (d, vars) 512 | 513 | P = label:string, (args ...), k 514 | *) 515 | 516 | let const = 517 | let x, ks = fresh_var "x", fresh_var "ks" in 518 | Fn (d, [x; ks], Variable (d, x)) 519 | 520 | let handler = 521 | let comp, ks = fresh_var "comp", fresh_var "ks" in 522 | let l, idk1, idk2 = fresh_var "l", fresh_var "idk1", fresh_var "idk2" in 523 | Fn (d, [comp; ks], 524 | (Let (d, PTuple [PVariable l; PVariable idk1; PVariable idk2], 525 | Variable (d, comp), 526 | Absurd ("Unhandled effect", Variable (d, l))))) 527 | 528 | let handler_l = Application (d, cons, [handler; nil]) 529 | 530 | let handlers = Application (d, cons, [const; handler_l]) 531 | 532 | let handle_comp computation = 533 | (* let gs = pp_expression (g computation) in 534 | let after_gs = pp_expression @@ ret (g computation) computation in 535 | print_endline "before g "; print_endline gs; 536 | print_endline "after g"; print_endline after_gs; *) 537 | Application (d, return (g computation), [handlers]) 538 | 539 | let handle_toplevel l = 540 | let f = function 541 | | A.Def (loc, name, expr) -> Def (loc, name, handle_comp expr) 542 | | A.Expression (e) -> Expression (handle_comp e) 543 | | A.Claim (loc, name, ty) -> Claim (loc, name, ty) 544 | | A.VariantDef (loc, name, body) -> VariantDef (loc, name, body) 545 | | A.AbilityDef (loc, name, args) -> AbilityDef (loc, name, args) 546 | | A.RecordDef (loc, name, body) -> RecordDef (loc, name, body) 547 | in 548 | List.map f l 549 | 550 | (* the major problem now is that returning from a handler clause 551 | without calling the continuation doesn't work *) 552 | 553 | (* okay, i know whats wrong. 554 | the body expression on the clause is expected to be a computation, but 555 | in the `sc` transform we leave expressions just the way they are. 556 | for this to work, we have to lift expressions that are not computations 557 | using the plain constructor. 558 | 559 | this is basically selective lifting. 560 | i.e if we have a `Let` we wouldn't lift it 561 | but if we have a variable, or an integer, 562 | we would lift it using `Plain` 563 | 564 | a variable *cannot* be a computation; lambdas are the only syntactic 565 | construct that can generate a computation (its arguments are values), 566 | hence their elimination form must be handled with care. 567 | 568 | i'm certain this would work. 569 | 570 | *) 571 | -------------------------------------------------------------------------------- /runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name runtime) 3 | (libraries errors utility syntax)) 4 | -------------------------------------------------------------------------------- /runtime/eval.ml: -------------------------------------------------------------------------------- 1 | 2 | open Syntax 3 | open Naming 4 | open Utility 5 | 6 | module A = Ast 7 | module V = Value 8 | 9 | (* Enviroment mangement *) 10 | module type S = sig 11 | include Map.S 12 | val lookup : key -> 'a t -> 'a option 13 | end 14 | 15 | module Env : S with type key := VarName.t = struct 16 | include Map.Make (VarName) 17 | let lookup = find_opt 18 | end 19 | 20 | (* Pattern matching handling *) 21 | exception PatternFailure of string 22 | 23 | let rec pattern_binder pattern value env = 24 | let length_check l1 l2 = 25 | let len1, len2 = List.length l1, List.length l2 in 26 | let msg = Printf.sprintf 27 | "can't match because the length of a tuple or variant arguments aren't equal. want: %d, got: %d. pattern: %s, expression %s" 28 | len1 len2 (A.pp_list l1 A.pp_pattern) (A.pp_list l2 V.pp_value) 29 | in 30 | if len1 <> len2 31 | then raise @@ PatternFailure msg 32 | in 33 | match pattern, value with 34 | | A.PVariable name, value -> Env.add name value env 35 | | A.PInteger i, V.VInteger i' when i = i' -> env 36 | | A.PString s, V.VString s' when s = s' -> env 37 | | A.PBool b, V.VBool b' when b = b' -> env 38 | | A.PRecord (name, body), V.VRecord (name', body') when name = name' -> 39 | let extender (n, p) env = 40 | match List.assoc_opt n body' with 41 | | Some v -> pattern_binder p v env 42 | | None -> failwith "Field does not exist" (* TODO: use Result monad *) 43 | in 44 | List.fold_right extender body env 45 | | A.PVariant (name, body), V.VVariant (name', body') when name = name' -> 46 | length_check body body'; 47 | List.fold_right2 (fun p v env -> pattern_binder p v env) body body' env 48 | | A.PTuple patterns, V.VTuple values -> 49 | length_check patterns values; 50 | List.fold_right2 pattern_binder patterns values env 51 | | pattern, value -> 52 | let msg = Printf.sprintf "The value %s doens't match the pattern %s" 53 | (A.pp_pattern pattern) (V.pp_value value) 54 | in 55 | raise @@ PatternFailure msg 56 | 57 | let rec eval env = function 58 | | A.Absurd (s, _e) -> Error s 59 | | A.Variant (_loc, name, args) -> 60 | let name = name |> DataName.to_string |> VarName.of_string in 61 | let open Result in 62 | let* args = 63 | args 64 | |> List.map (eval env) 65 | |> Result.sequenceA 66 | in 67 | Ok (V.VVariant (name, args)) 68 | | A.Variable (_loc, name) -> ( 69 | match Env.lookup name env with 70 | | Some x -> Ok x 71 | | None -> Error (Printf.sprintf "Unbound Variable %s" (VarName.to_string name))) 72 | | A.LitUnit _loc -> Ok V.VUnit 73 | | A.LitInteger (_loc, i) -> Ok (V.VInteger i) 74 | | A.LitBool (_loc, b) -> Ok (V.VBool b) 75 | | A.LitFloat (_loc, f) -> Ok (V.VFloat f) 76 | | A.LitString (_loc, s) -> Ok (V.VString s) 77 | | A.Annotated (_loc, e, _) -> eval env e 78 | | A.If (_loc, e', pt, pf) -> 79 | let open Result in 80 | let* e = eval env e' in 81 | (match e with 82 | | V.VBool true -> eval env pt 83 | | V.VBool false -> eval env pf 84 | | v -> 85 | Error 86 | (Printf.sprintf 87 | "expected a bool type at an if expression, but got expression %s. Also note true-case: %s, false-case %s" 88 | (V.pp_value v) (A.pp_expression pt) (A.pp_expression pf))) 89 | | A.Let (_loc, pat, expr, body) -> 90 | let open Result in 91 | let* value = eval env expr in 92 | let env = pattern_binder pat value env in 93 | eval env body 94 | | A.Fn (_loc, names, body) as f -> 95 | let clo values = 96 | let expected, got = List.length names, List.length values in 97 | (* This check might not be valid if I change 98 | the representation of closures to use frames. *) 99 | if expected <> got then 100 | Error (Printf.sprintf "function %s: expected %d arguments, but got %d. the arguments are %s" 101 | (A.pp_expression f) expected got (A.pp_list values V.pp_value)) 102 | else 103 | let env = List.fold_right2 Env.add names values env in 104 | eval env body 105 | in 106 | Ok (V.VClosure clo) 107 | | A.Application (_loc, operator, operands') -> ( 108 | let open Result in 109 | let* operands = 110 | operands' 111 | |> List.map (eval env) 112 | |> Result.sequenceA 113 | in 114 | match eval env operator with 115 | | Ok (V.VClosure f) -> f operands 116 | | Ok _ -> 117 | Error 118 | (Printf.sprintf "This expression %s, is not a function, so it cannot be applied to %s" 119 | (A.pp_expression operator) (A.pp_list operands' A.pp_expression)) 120 | | Error s -> Error s) 121 | | A.Record (_loc, name, body) -> 122 | let open Result in 123 | let names, exprs = List.split body in 124 | let* values = exprs |> List.map (eval env) |> Result.sequenceA in 125 | let body = List.combine names values in 126 | Ok (V.VRecord (name, body)) 127 | | A.RecordIndex (_loc, record, field) -> ( 128 | let open Result in 129 | let* record = eval env record in 130 | match record with 131 | | V.VRecord (_, fields) -> ( 132 | match List.assoc_opt field fields with 133 | | Some value -> Ok value 134 | | None -> Error "That field is not defied on the record") 135 | | _ -> Error "Not a record") 136 | | A.Case (_loc, expr, cases) -> 137 | let open Result in 138 | let* value = eval env expr in 139 | let rec eval_cases = function 140 | | [] -> Error "Pattern match failure" 141 | | x :: xs -> 142 | let p, e = x in 143 | match pattern_binder p value env with 144 | | env -> eval env e 145 | | exception PatternFailure _ -> eval_cases xs 146 | in 147 | eval_cases cases 148 | | A.Tuple (_loc, exprs) -> 149 | let open Result in 150 | let* result = exprs |> List.map (eval env) |> Result.sequenceA in 151 | Ok (V.VTuple result) 152 | | A.Sequence (_loc, _e1, _e2) -> Error "Sequence expressions not yet implemented" 153 | | A.LitTodo _loc -> Error "Not yet supported" 154 | (* | A.Do _ | A.Handle _ -> failwith "should not be evaluated by me" *) 155 | 156 | let guard_values_by_len n f values = 157 | let arg_len = List.length values in 158 | if n <> arg_len then 159 | Error "Invalid number of arguments" 160 | else 161 | Ok (f values) 162 | 163 | let is_fn = function A.Fn _ -> true | _ -> false 164 | 165 | let rec process_toplevel env = function 166 | | [] -> [] 167 | | A.Claim (_loc, _, _) :: rest -> process_toplevel env rest 168 | | A.Def (_loc, name, body) :: rest when is_fn body -> 169 | let env' = ref env in 170 | let body_value = 171 | V.VClosure (fun values -> 172 | match eval !env' body with 173 | | Ok (V.VClosure f) -> f values 174 | | Ok _ -> Error "This value is not a function so it can't be applied" 175 | | Error s -> Error s) 176 | in 177 | env' := Env.add name body_value !env'; 178 | process_toplevel !env' rest 179 | | A.Def (_loc, name, body) :: rest -> 180 | let body_value = eval env body in 181 | (match body_value with 182 | | Ok value -> 183 | let env = Env.add name value env in 184 | process_toplevel env rest 185 | | Error s -> Printf.sprintf "Error: %s" s :: process_toplevel env rest) 186 | | A.Expression e :: rest -> 187 | (match eval env e with 188 | | Ok value -> (V.pp_value value) :: process_toplevel env rest 189 | | Error s -> Printf.sprintf "Error: %s" s :: process_toplevel env rest) 190 | | A.RecordDef (_loc, _, _) :: rest -> process_toplevel env rest 191 | | A.AbilityDef _ :: rest -> process_toplevel env rest (* do nothing for now *) 192 | | A.VariantDef (_loc, _name, body) :: rest -> 193 | let variant_extend (name, l) env = 194 | match l with 195 | | [] -> Env.add name (V.VVariant (name, [])) env 196 | | _ :: _ -> 197 | let clo = guard_values_by_len (List.length l) (fun values -> V.VVariant (name, values)) in 198 | Env.add name (V.VClosure clo) env 199 | in 200 | let env = List.fold_right variant_extend body env in 201 | process_toplevel env rest 202 | 203 | let operator op = 204 | let clo = function 205 | | [V.VInteger x; V.VInteger y] -> Ok (V.VInteger (op x y)) 206 | | [a; b] -> Error (Printf.sprintf "dont know how to use op on %s and %s" (V.pp_value a) (V.pp_value b)) 207 | | _ -> Error "Invalid Number of arguemnts" 208 | in 209 | V.VClosure clo 210 | 211 | let generic_plus = 212 | let clo = function 213 | | [V.VInteger x; V.VInteger y] -> Ok (V.VInteger (x + y)) 214 | | [V.VInteger x; V.VString y] -> 215 | Ok (V.VString (Printf.sprintf "%d%s" x y)) 216 | | [V.VString y; V.VInteger x] -> 217 | Ok (V.VString (Printf.sprintf "%s%d" y x )) 218 | | [V.VString y; V.VString x] -> 219 | Ok (V.VString (Printf.sprintf "%s%s" y x )) 220 | | [a; b] -> Error (Printf.sprintf "dont know how to add %s and %s" (V.pp_value a) (V.pp_value b)) 221 | | _ -> Error "Invalid Number of arguemnts" 222 | in 223 | V.VClosure clo 224 | 225 | let addition = operator (+) 226 | let minus = operator (-) 227 | let times = operator ( * ) 228 | let div = operator (/) 229 | 230 | let global_env = 231 | [ "+", generic_plus; 232 | "-", minus; 233 | "*", times; 234 | "/", div; ] 235 | |> List.map (fun (name, value) -> (VarName.of_string name, value)) 236 | |> List.to_seq 237 | |> Env.of_seq 238 | 239 | let process_toplevel = process_toplevel global_env 240 | 241 | 242 | -------------------------------------------------------------------------------- /runtime/eval2.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Naming 3 | open Utility 4 | open Errors 5 | 6 | module A = DesugarEffect 7 | 8 | let rec pat_freevars = function 9 | | A.PInteger _ | A.PString _ 10 | | A.PBool _ -> [] 11 | | A.PVariable v -> [v] 12 | | A.PTuple pats -> 13 | pats 14 | |> List.map pat_freevars 15 | |> List.concat 16 | | A.PVariant (_, pats) -> 17 | pats 18 | |> List.map pat_freevars 19 | |> List.concat 20 | | A.PRecord (_, pats) -> 21 | pats 22 | |> List.map snd 23 | |> List.map pat_freevars 24 | |> List.concat 25 | 26 | (* expression[value/variable]*) 27 | let rec subst value variable e = 28 | let s = subst value variable in 29 | match e with 30 | | A.Variable (_loc, name) when name = variable -> value 31 | | A.Variable _ | A.LitUnit _ 32 | | A.LitInteger _ | A.LitBool _ | A.LitFloat _ 33 | | A.LitString _ | A.LitTodo _ -> e 34 | | A.Annotated (loc, e, ty) -> A.Annotated (loc, s e, ty) 35 | | A.If (loc, p, pt, pf) -> A.If (loc, s p, s pt, s pf) 36 | 37 | | A.Let (loc, pat, expr, body) -> 38 | let free = pat_freevars pat in 39 | let mem = List.mem variable free in 40 | if mem then 41 | A.Let (loc, pat, s expr, body) (* lexical scoping! *) 42 | else 43 | A.Let (loc, pat, s expr, s body) 44 | 45 | | A.Fn (loc, names, body) -> 46 | let mem = List.mem variable names in 47 | if mem then A.Fn (loc, names, body) else A.Fn (loc, names, s body) (* lexical scoping *) 48 | 49 | | A.Application (loc, operator, operands) -> A.Application (loc, s operator, List.map s operands) 50 | | A.Record (loc, name, body) -> 51 | let body = List.map (fun (fn, e) -> (fn, s e)) body in 52 | A.Record (loc, name, body) 53 | | A.RecordIndex (loc, record, field) -> A.RecordIndex (loc, s record, field) 54 | 55 | | A.Case (loc, expr, cases) -> 56 | let cases = 57 | cases 58 | |> List.map (fun (pat, e) -> 59 | let free = pat_freevars pat in 60 | let mem = List.mem variable free in 61 | if mem then (pat, e) else (pat, s e)) (* again, lexical scoping *) 62 | in 63 | A.Case (loc, s expr, cases) 64 | 65 | | A.Tuple (loc, exprs) -> A.Tuple (loc, List.map s exprs) 66 | | A.Variant (loc, name, exprs) -> A.Variant (loc, name, List.map s exprs) 67 | | A.Sequence (loc, e1, e2) -> A.Sequence (loc, s e1, s e2) 68 | | A.Absurd (label, e) -> A.Absurd (label, s e) 69 | (* | A.Plain e -> s e 70 | | A.Do (loc, name, exprs) -> A.Do (loc, name, List.map s exprs) 71 | | A.Handle (loc, expr, clauses) -> 72 | let f = function 73 | | A.Return (name, body) -> A.Return (name, s body) 74 | | A.Operation (name, args, kvar, body) -> A.Operation (name, args, kvar, s body) 75 | in 76 | let clauses = clauses |> List.map f in 77 | A.Handle (loc, s expr, clauses) *) 78 | 79 | let subst_list = List.fold_right (fun (x, v) e -> subst x v e) 80 | 81 | (* let print_env env = 82 | let e = env |> Env.to_seq |> List.of_seq in 83 | let env_str = A.pp_list e (fun (n, v) -> Printf.sprintf "%s=%s" (VarName.to_string n) (pp_value v)) in 84 | print_string "in the enviroment "; 85 | print_endline env_str *) 86 | 87 | exception PatternFailure of string 88 | 89 | let rec is_value = function 90 | | A.Absurd _ 91 | | A.Variable _ 92 | | A.LitUnit _ 93 | | A.LitInteger _ 94 | | A.LitBool _ 95 | | A.LitFloat _ 96 | | A.LitString _ -> true 97 | | A.Annotated (_, e, _) -> is_value e 98 | | A.If _ -> false 99 | | A.Let _ -> false 100 | | A.Fn _ -> true 101 | | A.Application _ -> false 102 | | A.Record _ -> true 103 | | A.RecordIndex _ -> false 104 | | A.Case _ -> false 105 | | A.Tuple _ -> true 106 | (* | A.Plain e -> is_value e *) 107 | | A.Sequence _ -> false 108 | | A.LitTodo _ -> true 109 | | A.Variant _ -> true 110 | (* | A.Do _ | A.Handle _ -> failwith "should not be evaluated by me" *) 111 | 112 | let rec eval = function 113 | | A.Variable (_loc, name) -> 114 | Errors.runtime @@ Printf.sprintf "Unbound Variable %s" @@ VarName.to_string name 115 | | A.LitUnit loc -> A.LitUnit loc 116 | | A.LitInteger (loc, i) -> A.LitInteger (loc, i) 117 | | A.LitBool (loc, b) -> A.LitBool (loc, b) 118 | | A.LitFloat (loc, f) -> A.LitFloat (loc, f) 119 | | A.LitString (loc, s) -> A.LitString (loc, s) 120 | | A.Annotated (_loc, e, _) -> eval e 121 | 122 | | A.If (_loc, A.LitBool (_, b), pt, pf) -> ( 123 | match b with 124 | | true -> eval pt 125 | | false -> eval pf) 126 | | A.If (_loc, p, _pt, _pf) when is_value p -> 127 | Errors.runtime @@ Printf.sprintf "expected a bool at an if expression but got %s" @@ A.pp_expression p 128 | | A.If (loc, p, pt, pf) -> eval @@ A.If (loc, eval p, pt, pf) 129 | 130 | | A.Let (_loc, pat, expr, body) -> 131 | let sub = pattern_binder pat expr in 132 | eval (subst_list sub body) 133 | | A.Fn (loc, names, body) -> A.Fn (loc, names, body) 134 | 135 | | A.Application (_loc, (A.Fn (_, vars, _) as f), args) when List.length args <> List.length vars -> 136 | let expected, got = List.length vars, List.length args in 137 | let msg = 138 | Printf.sprintf "This function %s expected %d argument(s), but got %d" 139 | (A.pp_expression f) expected got 140 | in 141 | Errors.runtime msg 142 | | A.Application (_loc, A.Fn (_, vars, body), args) -> eval @@ subst_list (List.combine args vars) body 143 | | A.Application (loc, Variable (_, v), [A.LitInteger (_, i); A.LitInteger (_, i')]) 144 | when VarName.to_string v = "+" -> 145 | A.return @@ A.LitInteger (loc, i + i') (* we should really be returning this as a computation *) 146 | | A.Application (_loc, f, _args) when is_value f -> 147 | Errors.runtime @@ Printf.sprintf "this value %s is not a function so it can't be applied" (A.pp_expression f) 148 | | A.Application (loc, f, args) -> eval @@ A.Application (loc, eval f, args) 149 | 150 | | A.Record (loc, name, body) -> A.Record (loc, name, body) 151 | 152 | | A.RecordIndex (_loc, A.Record (_, _name, fields), field) -> ( 153 | match List.assoc_opt field fields with 154 | | Some value -> value 155 | | None -> 156 | Errors.runtime @@ 157 | Printf.sprintf "That field name %s is not defined on the record" 158 | (FieldName.to_string field)) 159 | | A.RecordIndex (_loc, record, _field) when is_value record -> Errors.runtime "Expected a record at an index expression" 160 | | A.RecordIndex (loc, record, field) -> eval @@ A.RecordIndex (loc, eval record, field) 161 | 162 | 163 | | A.Variant (loc, name, args) when List.for_all is_value args -> A.Variant (loc, name, args) 164 | | A.Variant (loc, name, args) -> A.Variant (loc, name, List.map eval args) 165 | 166 | | A.Case (_loc, expr, cases) -> 167 | 168 | let rec eval_cases msg = function 169 | | [] -> Errors.runtime msg 170 | | x :: xs -> 171 | let p, e = x in 172 | match pattern_binder p expr with 173 | | sub -> eval (subst_list sub e) 174 | | exception PatternFailure msg' -> 175 | let msg = Printf.sprintf "%s | %s" msg msg' in 176 | eval_cases msg xs 177 | in 178 | eval_cases "" cases 179 | 180 | | A.Tuple (loc, exprs) -> A.Tuple (loc, exprs) 181 | (* | A.Plain e -> eval e *) 182 | | A.Sequence (_loc, _e1, _e2) -> Errors.runtime "Sequence expressions not yet implemented" 183 | | A.Absurd (s, e) -> 184 | let msg = Printf.sprintf "%s, %s" s (A.pp_expression e) in 185 | Errors.runtime msg 186 | | A.LitTodo _loc -> Errors.runtime "Not yet supported" 187 | (* | A.Do _ | A.Handle _ -> Errors.runtime "effects are not supported by this evaluator" *) 188 | 189 | and pattern_binder pattern value = 190 | let length_check l1 l2 = 191 | let len1, len2 = List.length l1, List.length l2 in 192 | let msg = Printf.sprintf 193 | "can't match because the length of a tuple or variant arguments aren't equal. want: %d, got: %d. pattern: %s, expression %s" 194 | len1 len2 (A.pp_list l1 A.pp_pattern) (A.pp_list l2 A.pp_expression) 195 | in 196 | if len1 <> len2 197 | then raise @@ PatternFailure msg 198 | in 199 | match pattern, value with 200 | | A.PVariable name, value -> [value, name] 201 | | A.PInteger i, A.LitInteger (_, i') when i = i' -> [] 202 | | A.PString s, A.LitString (_, s') when s = s' -> [] 203 | | A.PBool b, A.LitBool (_, b') when b = b' -> [] 204 | | A.PRecord (name, body), A.Record (_, name', body') when name = name' -> 205 | let extender (n, p) env = 206 | match List.assoc_opt n body' with 207 | | Some v -> pattern_binder p v @ env 208 | | None -> failwith "Field does not exist" (* TODO: use Result monad *) 209 | in 210 | List.fold_right extender body [] 211 | | A.PVariant (name, patterns), A.Variant (_, name', values) 212 | when VarName.to_string name = DataName.to_string name' -> 213 | length_check patterns values; 214 | List.fold_right2 (fun p v env -> pattern_binder p v @ env) patterns values [] 215 | | A.PTuple patterns, A.Tuple (_, values) -> 216 | length_check patterns values; 217 | List.fold_right2 (fun p v env -> pattern_binder p v @ env) patterns values [] 218 | | _pattern, expression when is_value expression -> 219 | let msg = Printf.sprintf "The pattern %s doens't match the expression %s" 220 | (A.pp_pattern pattern) (A.pp_expression expression) 221 | in 222 | raise @@ PatternFailure msg 223 | | pattern, expression -> pattern_binder pattern (eval expression) 224 | 225 | let rec subst_toplevel names = function 226 | | A.Def (loc, name, body) :: rest -> 227 | let x = subst_list names body in 228 | let names' = (x, name) :: names in 229 | A.Def (loc, name, x) :: subst_toplevel names' rest 230 | | A.Expression e :: rest -> 231 | A.Expression (subst_list names e) :: subst_toplevel names rest 232 | 233 | (* trivial cases *) 234 | | [] -> [] 235 | | A.Claim _ as c :: rest -> c :: subst_toplevel names rest 236 | | A.RecordDef _ as rd :: rest -> rd :: subst_toplevel names rest 237 | | A.AbilityDef _ as ad :: rest -> ad :: subst_toplevel names rest 238 | | A.VariantDef _ as vd :: rest -> vd :: subst_toplevel names rest 239 | 240 | let rec process_toplevel = function 241 | | [] -> [] 242 | | A.Claim (_loc, _, _) :: rest -> process_toplevel rest 243 | | A.Def (_loc, name, body) :: rest -> 244 | let env = [eval body, name] in 245 | let tops = subst_toplevel env rest in 246 | process_toplevel tops 247 | | A.Expression e :: rest -> 248 | A.pp_expression (eval e) :: process_toplevel rest 249 | | A.RecordDef (_loc, _, _) :: rest -> process_toplevel rest 250 | | A.AbilityDef _ :: rest -> process_toplevel rest (* do nothing for now *) 251 | | A.VariantDef (_loc, _name, _body) :: rest -> process_toplevel rest 252 | (* | A.VariantDef (_loc, _name, body) :: rest -> 253 | let variant_extend (name, l) env = 254 | match l with 255 | | [] -> Env.add name (V.VVariant (name, [])) env 256 | | _ :: _ -> 257 | let clo = guard_values_by_len (List.length l) (fun values -> V.VVariant (name, values)) in 258 | Env.add name (V.VClosure clo) env 259 | in 260 | let env = List.fold_right variant_extend body env in 261 | process_toplevel env rest *) 262 | 263 | -------------------------------------------------------------------------------- /runtime/value.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Naming 3 | 4 | type value = 5 | | VUnit 6 | | VInteger of int 7 | | VString of string 8 | | VFloat of float 9 | | VBool of bool 10 | | VTuple of value list 11 | | VClosure of (value list -> (value, string) result) 12 | | VRecord of DataName.t * (FieldName.t * value) list 13 | | VVariant of VarName.t * value list 14 | 15 | let rec pp_value v = 16 | let pp_value_list values sep = values |> List.map pp_value |> String.concat sep in 17 | match v with 18 | | VUnit -> "(void)" 19 | | VInteger i -> Int.to_string i 20 | | VString s -> Printf.sprintf "%s%s%s" {|"|} s {|"|} 21 | | VFloat f -> Float.to_string f 22 | | VBool b -> Bool.to_string b 23 | | VClosure _clo -> "" (* unfortunately, we can't inspect _clo *) 24 | | VRecord (name, fields) -> 25 | let fields_pp = 26 | fields 27 | |> List.map (fun (name, value) -> Printf.sprintf " %s: %s" (FieldName.to_string name) (pp_value value)) 28 | |> String.concat "," 29 | in 30 | Printf.sprintf "%s {%s }" (DataName.to_string name) fields_pp 31 | 32 | | VVariant (name, []) -> VarName.to_string name 33 | | VVariant (name, values) -> Printf.sprintf "%s (%s)" (VarName.to_string name) (pp_value_list values ", ") 34 | | VTuple (values) -> Printf.sprintf "(%s)" (pp_value_list values ", ") 35 | 36 | 37 | 38 | (* a binary search tree *) -------------------------------------------------------------------------------- /runtime/value2.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ebresafegaga/tina/555e44a77fee234492013644428cb46fbd625440/runtime/value2.ml -------------------------------------------------------------------------------- /settings/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name settings) 3 | (libraries )) 4 | -------------------------------------------------------------------------------- /settings/settings.ml: -------------------------------------------------------------------------------- 1 | let version = "0.8" 2 | 3 | let output_formatter = ref Format.std_formatter 4 | 5 | let error_formatter = ref Format.err_formatter 6 | -------------------------------------------------------------------------------- /shell/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name shell) 3 | (libraries utility typing settings syntax parsing backend runtime)) 4 | -------------------------------------------------------------------------------- /shell/shell.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Runtime 3 | open Backend 4 | open Typing 5 | module P = Parsing.ParserEntry 6 | 7 | let eval source = 8 | let syntax = source |> Lexing.from_string |> P.parse in 9 | let ty = 10 | syntax |> Typecheck.handle_toplevel |> Ctx.pp_ctx |> String.concat "\n" 11 | in 12 | let term = syntax (* |> DesugarEffect.handle_toplevel*) |> Eval.process_toplevel |> String.concat "\n" in 13 | Printf.sprintf "%s \n %s" term ty 14 | 15 | let eval source = 16 | match eval source with 17 | | result -> Format.fprintf !Settings.output_formatter "%s@." result 18 | | exception Errors.RuntimeError msg -> 19 | Format.fprintf !Settings.error_formatter "%s@." msg 20 | 21 | let execute_source = eval 22 | 23 | let load_source = eval 24 | 25 | let compile_js source = 26 | let process src = 27 | src |> Lexing.from_string |> P.parse |> DesugarEffect.handle_toplevel 28 | |> DesugarData.handle_toplevel |> DesugarCase.handle_toplevel 29 | |> KNormal.handle_toplevel |> Js.handle_toplevel |> List.map Js.gen_toplevel 30 | |> String.concat "\n" 31 | in 32 | let js_code = process source in 33 | Format.fprintf !Settings.error_formatter "%s@." js_code 34 | 35 | let complie_llvm = () 36 | -------------------------------------------------------------------------------- /syntax/ast.ml: -------------------------------------------------------------------------------- 1 | 2 | open Naming 3 | 4 | (* TODO: add locations to pattern *) 5 | type pattern = 6 | | PInteger of int 7 | | PString of string 8 | | PBool of bool 9 | (* | Pfloat of float 10 | | PUnit *) 11 | | PVariable of VarName.t 12 | | PRecord of DataName.t * (FieldName.t * pattern) list 13 | | PVariant of VarName.t * pattern list 14 | | PTuple of pattern list 15 | 16 | (* we need a variable type which enacpsulates 17 | VarName.t DefName.t ... *) 18 | (* type identifier = V of VarName.t | D of DefName.t | F of FieldName.t *) 19 | 20 | (* module Identifier = struct 21 | type t = Global of DefName.t | Local of VarName.t 22 | end *) 23 | 24 | type expression = 25 | | LitTodo of Loc.t 26 | | LitUnit of Loc.t 27 | | LitBool of Loc.t * bool 28 | | LitInteger of Loc.t * int 29 | | LitFloat of Loc.t * float 30 | | LitString of Loc.t * string 31 | 32 | | Variable of Loc.t * VarName.t 33 | | If of Loc.t * expression * expression * expression 34 | | Application of Loc.t * expression * expression list 35 | | Let of Loc.t * pattern * expression * expression 36 | (* LetMut maybe? *) 37 | | Fn of Loc.t * VarName.t list * expression 38 | | Annotated of Loc.t * expression * Type.t 39 | | Sequence of Loc.t * expression * expression 40 | | Case of Loc.t * expression * (pattern * expression) list (* tbi *) 41 | | Record of Loc.t * DataName.t * (FieldName.t * expression) list 42 | | RecordIndex of Loc.t * expression * FieldName.t 43 | | Tuple of Loc.t * expression list 44 | | Variant of Loc.t * DataName.t * expression list 45 | (* list? tuples? *) 46 | | Do of Loc.t * VarName.t * expression list 47 | | Handle of Loc.t * expression * handler_clauses list (* must always have a return clause *) 48 | | Absurd of string * expression 49 | 50 | and handler_clauses = 51 | | Return of VarName.t * expression 52 | | Operation of VarName.t * VarName.t list * VarName.t * expression (* ability name, values gotten, cont-var name*) 53 | 54 | type toplevel = 55 | | Claim of Loc.t * VarName.t * Type.t 56 | | Def of Loc.t * VarName.t * expression 57 | | VariantDef of Loc.t * DataName.t * (VarName.t * Type.t list) list 58 | | RecordDef of Loc.t * DataName.t * (FieldName.t * Type.t) list 59 | | AbilityDef of Loc.t * VarName.t * Type.t list 60 | | Expression of expression 61 | 62 | 63 | (* pretty printing facilities for the the ast *) 64 | 65 | 66 | 67 | let pp_list es f = es |> List.map f |> String.concat ", " 68 | 69 | let rec pp_pattern = function 70 | | PInteger i -> Int.to_string i 71 | | PString s -> s 72 | | PVariable name -> VarName.to_string name 73 | | PTuple es -> Printf.sprintf "(%s)" (pp_list es pp_pattern) 74 | | PBool b -> Bool.to_string b 75 | | PVariant (name, es) -> Printf.sprintf "%s { %s }" (VarName.to_string name) (pp_list es pp_pattern) 76 | | PRecord (name, es) -> 77 | Printf.sprintf "%s {%s}" (DataName.to_string name) @@ 78 | pp_list es (fun (name, pattern) -> Printf.sprintf "%s: %s" (FieldName.to_string name) (pp_pattern pattern)) 79 | 80 | let rec pp_expression = function 81 | | LitTodo _loc -> "TODO" 82 | | LitUnit _loc -> "()" 83 | | LitBool (_loc, b) -> Bool.to_string b 84 | | LitInteger (_loc, i) -> Int.to_string i 85 | | LitFloat (_loc, f) -> Float.to_string f 86 | | LitString (_loc, s) -> s 87 | | Variable (_loc, v) -> VarName.to_string v 88 | | If (_loc, pred, tru, fals) -> 89 | Printf.sprintf "if %s then %s else %s" 90 | (pp_expression pred) 91 | (pp_expression tru) 92 | (pp_expression fals) 93 | | Application (_loc, rand, es) -> 94 | Printf.sprintf "%s (%s)" 95 | (pp_expression rand) 96 | (pp_list es pp_expression) 97 | | Let (_loc, var, value, body) -> 98 | Printf.sprintf "let %s = %s; %s" 99 | (pp_pattern var) 100 | (pp_expression value) 101 | (pp_expression body) 102 | | Fn (_loc, names, body) -> 103 | Printf.sprintf "fn (%s) %s" 104 | (pp_list names VarName.to_string) 105 | (pp_expression body) 106 | | Annotated (_loc, expr, ty) -> 107 | Printf.sprintf "(the %s %s)" 108 | (pp_expression expr) 109 | (Type.pp_ty ty) 110 | | Sequence (_loc, a, b) -> 111 | Printf.sprintf "%s; %s;" 112 | (pp_expression a) 113 | (pp_expression b) 114 | | Case (_loc, expr, pes) -> (* pes - pattern, expression S *) 115 | let f (pat, expr) = 116 | Printf.sprintf "%s -> %s" 117 | (pp_pattern pat) 118 | (pp_expression expr) 119 | in 120 | Printf.sprintf "case %s { %s }" 121 | (pp_expression expr) 122 | (pp_list pes f) 123 | | Tuple (_loc, es) -> 124 | Printf.sprintf "(%s)" (pp_list es pp_expression) 125 | | Record (_loc, name, fes) -> (* fes - field, expression S *) 126 | let f (field, expr) = 127 | Printf.sprintf "%s: %s" 128 | (FieldName.to_string field) 129 | (pp_expression expr) 130 | in 131 | Printf.sprintf "%s {%s}" 132 | (DataName.to_string name) 133 | (pp_list fes f) 134 | | RecordIndex (_loc, expr, name) -> 135 | Printf.sprintf "%s.%s" 136 | (pp_expression expr) 137 | (FieldName.to_string name) 138 | | Variant (_loc, name, []) -> DataName.to_string name 139 | | Variant (_loc, name, args) -> 140 | Printf.sprintf "%s (%s)" (DataName.to_string name) (pp_list args pp_expression) 141 | | Do _ | Handle _ -> "" 142 | | Absurd (s, e) -> 143 | Printf.sprintf "absurd (%s, %s)" s (pp_expression e) 144 | 145 | let pp_toplevel = function 146 | | Claim (_loc, name, ty) -> 147 | Printf.sprintf 148 | "claim %s %s" 149 | (VarName.to_string name) 150 | (Type.pp_ty ty) 151 | | Def (_loc, name, expr) -> (* TODO: add a special case for fn *) 152 | Printf.sprintf "def %s = %s" 153 | (VarName.to_string name) 154 | (pp_expression expr) 155 | | Expression expr -> pp_expression expr 156 | | VariantDef _ | RecordDef _ | AbilityDef _ -> "" (* for now *) 157 | 158 | 159 | let rec is_value = function 160 | | Variable _ 161 | | LitUnit _ 162 | | LitInteger _ 163 | | LitBool _ 164 | | LitFloat _ 165 | | LitString _ -> true 166 | | Annotated (_, e, _) -> is_value e 167 | | If _ -> true 168 | | Let _ -> false 169 | | Fn _ -> true 170 | | Application _ -> false 171 | | Record _ -> true 172 | | RecordIndex _ -> true 173 | | Case _ -> true 174 | | Tuple _ -> true 175 | | Sequence _ -> false 176 | | LitTodo _ -> true 177 | | Variant _ -> true 178 | | Absurd _ -> false (* hack *) 179 | | Do _ | Handle _ -> false 180 | 181 | -------------------------------------------------------------------------------- /syntax/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name syntax) 3 | ; (preprocess (pps ppx_deriving.show)) 4 | (libraries utility)) 5 | -------------------------------------------------------------------------------- /syntax/loc.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | type position = { 4 | pos_fname : string; <-- the file name 5 | pos_lnum : int; <-- the line number 6 | pos_bol : int; <-- offset from the begining of the file (in chars, i.e no of chars) 7 | pos_cnum : int; 8 | } 9 | 10 | pos_cnum is the offset of the position (number of characters between the beginning of the lexbuf and the position). 11 | The difference between pos_cnum and pos_bol is the character offset within the line (i.e. the column number, 12 | assuming each character is one column wide). 13 | 14 | *) 15 | 16 | type t = Lexing.position * Lexing.position 17 | 18 | let pp_pos loc = 19 | Format.sprintf "Line:%d Position:%d" loc.Lexing.pos_lnum 20 | (loc.Lexing.pos_cnum - loc.Lexing.pos_bol + 1) 21 | 22 | let pp ((s, e): t) = 23 | Format.sprintf "(%s, %s)" (pp_pos s) (pp_pos e) 24 | 25 | let dummy : t = (Lexing.dummy_pos, Lexing.dummy_pos) 26 | 27 | (* other utilities go here *) 28 | -------------------------------------------------------------------------------- /syntax/loc.mli: -------------------------------------------------------------------------------- 1 | 2 | type t = Lexing.position * Lexing.position 3 | 4 | val dummy : t 5 | 6 | val pp : t -> string -------------------------------------------------------------------------------- /syntax/naming.ml: -------------------------------------------------------------------------------- 1 | 2 | module type ID = sig 3 | type t 4 | val of_string : string -> t 5 | val to_string : t -> string 6 | val ( = ) : t -> t -> bool 7 | 8 | val compare : t -> t -> int 9 | val pp : t -> string 10 | val fresh: string -> t 11 | end 12 | 13 | module StringID = struct 14 | type t = string 15 | let of_string x = x 16 | let to_string x = x 17 | let ( = ) = String.equal 18 | let compare x y = if x = y then 0 else if x > y then 1 else -1 19 | let pp = to_string 20 | let fresh = 21 | let state = ref 0 in 22 | fun s -> 23 | let v = Printf.sprintf "%s_%d" s !state in 24 | incr state; 25 | of_string v 26 | end 27 | 28 | module VarName : ID = StringID 29 | module PVarName : ID = StringID 30 | module DefName : ID = StringID 31 | module FieldName : ID = StringID 32 | module DataName : ID = StringID 33 | module CtorName : ID = StringID 34 | -------------------------------------------------------------------------------- /syntax/tast.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | (* the typed abtract syntax tree *) 4 | -------------------------------------------------------------------------------- /syntax/type.ml: -------------------------------------------------------------------------------- 1 | open Naming 2 | 3 | type kind = KType | KComp | KEffect | KHandler 4 | 5 | type t = 6 | (* A = Bool | Str | Nat | Int | Float | Unit | Arr 7 | | Record | Tuple | Variant *) 8 | | TyBool 9 | | TyString 10 | | TyNat 11 | | TyInt 12 | | TyFloat 13 | | TyUnit 14 | | TyArrow of t list * t (* a ... -> b *) 15 | | TyRecord of record 16 | | TyTuple of t list 17 | | TyVariant of variant list 18 | | TyEffect of record (* E = {l ...} *) 19 | | TyComp of { pure: t; impure: t } (* C = A ! E *) 20 | | TyHandler of t * t (* H = M ~> N*) 21 | 22 | and variant = { label: DataName.t; fields: t list } 23 | 24 | and record = (FieldName.t * t) list 25 | 26 | let tyequal : t -> t -> bool = (=) (* for now *) 27 | 28 | (* this is majorly used for effect record types 29 | for example int <: int!{ get : unit -> int } 30 | 31 | claim g int!{get : unit -> int} 32 | def g = 10 33 | 34 | this should type check correctly 35 | 36 | *) 37 | let subtype : t -> t -> bool = (=) (* for now, also *) 38 | 39 | let pp_list es f ~sep = es |> List.map f |> String.concat sep 40 | 41 | let rec pp_ty = function 42 | | TyNat -> "Nat" 43 | | TyString -> "String" 44 | | TyInt -> "Int" 45 | | TyFloat -> "Float" 46 | | TyBool -> "Bool" 47 | | TyUnit -> "Unit" 48 | | TyTuple ts -> Printf.sprintf "(%s)" (pp_list ts pp_ty ~sep:", ") 49 | | TyRecord ts -> 50 | Printf.sprintf "{%s}" @@ 51 | pp_list ts (fun (n, t) -> Printf.sprintf "claim %s %s" (FieldName.to_string n) (pp_ty t)) 52 | ~sep:", " 53 | | TyVariant elems -> 54 | let e = Printf.sprintf "%s" @@ 55 | pp_list elems (fun {label; fields} -> 56 | Printf.sprintf "%s (%s)" (DataName.to_string label) (pp_list fields pp_ty ~sep:", ")) 57 | ~sep:"| " 58 | in 59 | Printf.sprintf "< %s >" e 60 | | TyArrow (ts, t) -> Printf.sprintf "(%s) -> %s" (pp_list ts pp_ty ~sep:", ") (pp_ty t) 61 | | _ -> "" 62 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | 2 | (executable 3 | (name tests) 4 | (libraries parsing syntax alcotest)) 5 | -------------------------------------------------------------------------------- /tests/parser_tests.ml: -------------------------------------------------------------------------------- 1 | open Parsing 2 | open Syntax 3 | 4 | module G = Grammar 5 | module P = ParserEntry 6 | module A = Ast 7 | 8 | (* useful functions *) 9 | let tokenize str = 10 | let lb = Lexing.from_string str in 11 | let rec loop () = 12 | match Lexer.read_token lb with 13 | | Grammar.EOF -> [] 14 | | token -> token :: loop () 15 | | exception Lexer.SyntaxError _ -> [] (* for now *) 16 | in 17 | loop () 18 | 19 | let parse str = 20 | let lexbuf = Lexing.from_string str in 21 | G.toplevel Lexer.read_token lexbuf 22 | 23 | let token_testable = 24 | let pp formatter token = Format.fprintf formatter "%s" (P.pp_token token) in 25 | Alcotest.testable pp (=) 26 | 27 | let expression_testable = 28 | let pp fmt expr = Format.fprintf fmt "%s" (A.pp_expression expr) in 29 | Alcotest.testable pp (=) 30 | 31 | let toplevel_testable = 32 | let pp fmt tl = Format.fprintf fmt "%s" (A.pp_toplevel tl) in 33 | Alcotest.testable pp (=) 34 | 35 | let token_test str token error () = 36 | Alcotest.check (Alcotest.list token_testable) error 37 | [token] 38 | (tokenize str) 39 | 40 | let token_test_case case_name test_list = 41 | let tests = test_list |> List.map (fun (name, test) -> Alcotest.test_case name `Quick test) in 42 | case_name, tests 43 | 44 | let token_test str token () = 45 | let msg = Printf.sprintf "input %s should result in token %s" str (P.pp_token token) in 46 | Alcotest.check (Alcotest.list token_testable) msg 47 | [token] 48 | (tokenize str) 49 | 50 | let token_list_test str tokens () = 51 | let recieved_tokens = tokenize str in 52 | List.combine recieved_tokens tokens 53 | |> List.iter (fun (recieved, actual) -> 54 | let msg = 55 | Printf.sprintf "Expected %s, but got %s" 56 | (P.pp_token recieved) 57 | (P.pp_token actual) 58 | in 59 | Alcotest.check token_testable msg recieved actual) 60 | 61 | let lex_claim_test = token_test "claim" G.CLAIM 62 | 63 | let lex_claim_test_case = token_test_case "claim-case" [("lex claim only", lex_claim_test)] 64 | 65 | let lex_int_test = token_test "234" (G.INT 234) 66 | 67 | let lex_int_test2 = token_test "92333" (G.INT 92333) 68 | 69 | let lex_int_test3 = token_test "-89" (G.INT (-89)) 70 | 71 | let lex_int_test_case = 72 | token_test_case "int-token-case" 73 | ["lex int token 234", lex_int_test; 74 | "lex int token 92333", lex_int_test2; 75 | "lex int token -89", lex_int_test3 ] 76 | 77 | let lex_float_test = token_test "2.18282" (G.FLOAT 2.18282) 78 | 79 | let lex_float_test2 = token_test "3.142" (G.FLOAT 3.142) 80 | 81 | let lex_float_test3 = token_test "-17.29" (G.FLOAT (-17.29)) 82 | let lex_float_test4 = token_test ".227" (G.FLOAT (0.227)) 83 | 84 | let lex_float_test5 = token_test "0.0023" (G.FLOAT 0.0023) 85 | 86 | let lex_float_test_case = 87 | token_test_case "float-token-case" 88 | [ "lex float token 2.18282", lex_float_test; 89 | "lex float token 18282", lex_float_test2; 90 | "lex float token -17.29", lex_float_test3; 91 | "lex float token .227", lex_float_test4; 92 | "lex float token 0.0023", lex_float_test5] 93 | 94 | let lex_id_test = token_test "simple" (G.ID "simple") 95 | 96 | let lex_id_test2 = token_test "_bASic12" (G.ID "_bASic12") 97 | 98 | let lex_id_test_case = 99 | token_test_case "id-token-case" 100 | [ "lex id token simple", lex_id_test; 101 | "lex id token _bASic12", lex_id_test2] 102 | 103 | let lex_string_test = token_test {|"fancy str"|} (G.STRING {|"fancy str"|}) 104 | 105 | let lex_string_test_case = 106 | token_test_case "string-token-case" 107 | ["lex string token \"fancy str\"" , lex_id_test] 108 | 109 | let lex_bool_test = token_test {|true|} G.TRUE 110 | 111 | let lex_bool_test2 = token_test {|false|} G.FALSE 112 | 113 | let lex_bool_test_case = 114 | token_test_case "bool-token-case" 115 | [ "lex true token", lex_bool_test; 116 | "lex false token", lex_bool_test2] 117 | 118 | 119 | let lex_def_test = token_test "def" G.DEF 120 | 121 | let lex_def_test_case = 122 | token_test_case "def-case" ["lex def token", lex_def_test] 123 | 124 | 125 | let lex_datatype_test = token_test "datatype" G.DATA 126 | 127 | let lex_datatype_test_case = 128 | token_test_case "datatype-case" ["lex datatype keyword", lex_datatype_test] 129 | 130 | 131 | let lex_case_test = token_test "case" G.CASE 132 | 133 | let lex_case_test_case = 134 | token_test_case "case-tokens-case" ["lex case token", lex_case_test] 135 | 136 | let lex_ability_test = token_test "ability" G.ABILITY 137 | 138 | let lex_ability_test_case = 139 | token_test_case "ability-case" ["lex ability token", lex_ability_test] 140 | 141 | let lex_let_test = token_test "let" G.LET 142 | 143 | let lex_let_test_case = 144 | token_test_case "let-case" ["lex let token", lex_let_test] 145 | 146 | let lex_fn_test = token_test "fn" G.FN 147 | 148 | let lex_fn_test_case = 149 | token_test_case "fn-case" ["lex fn token", lex_fn_test] 150 | 151 | let lex_mut_test = token_test "mut" G.MUT 152 | 153 | let lex_mut_test_case = 154 | token_test_case "mut-case" ["lex mut token", lex_mut_test] 155 | 156 | let lex_end_test = token_test "end" G.END 157 | 158 | let lex_end_test_case = 159 | token_test_case "end-case" ["lex end token", lex_end_test] 160 | 161 | 162 | let lex_if_test = token_test "if" G.IF 163 | 164 | let lex_if_test_case = 165 | token_test_case "if-case" ["lex if token", lex_if_test] 166 | 167 | let lex_else_test = token_test "else" G.ELSE 168 | 169 | let lex_else_test_case = 170 | token_test_case "else-case" ["lex else token", lex_else_test] 171 | 172 | let lex_then_test = token_test "then" G.THEN 173 | let lex_then_test_case = 174 | token_test_case "then-case" ["lex then token", lex_then_test] 175 | 176 | let lex_the_test = token_test "the" G.THE 177 | 178 | let lex_the_test_case = token_test_case "the-case" ["lex the token", lex_the_test] 179 | 180 | let program_test = 181 | let sample = {| 182 | def test = 183 | let Person {age:a, other:o } = gaga; 184 | case (a) { 185 | 10 -> "no" 186 | } 187 | |} 188 | in 189 | token_list_test sample 190 | [ G.DEF; G.ID "test"; G.EQUALS; G.LET; G.ID "Person"; 191 | G.LBRACE; G.ID "age"; G.COLON; G.ID "a" ; G.COMMA; 192 | G.ID "other"; G.COLON; G.ID "o"; G.RBRACE; 193 | G.EQUALS; G.ID "gaga" ; G.SEMICOLON; 194 | G.CASE; G.LPAREN; G.ID "a"; G.RPAREN; G.LBRACE; 195 | G.INT 10; G.ARROW; G.STRING "no" ; G.RBRACE] 196 | 197 | let lex_program_test_case = 198 | token_test_case "program-case" 199 | ["test def, case, ids, string, int used in a program", program_test] 200 | 201 | let operators_test = 202 | let sample = "><+>=<=-*/->{}[]().:=" in 203 | token_list_test sample 204 | [G.GT; G.LT; G.PLUS; G.GTEQUALS; G.LTEQUALS; 205 | G.MINUS; G.STAR; G.DIV; G.ARROW; G.LBRACE; G.RBRACE; 206 | G.LBRACK; G.RBRACK; G.LPAREN; G.RPAREN; G.DOT; G.COLONEQUALS] 207 | 208 | let lex_operators_test_case = 209 | token_test_case "operators/symbol-case" 210 | ["all operators and symbols", operators_test] 211 | 212 | let lex_types_test = 213 | let sample = "Nat String Int Float" in 214 | token_list_test sample 215 | [G.TY_NAT; G.TY_STRING; G.TY_INT; G.TY_FLOAT] 216 | 217 | let lex_types_test_case = 218 | token_test_case "types-case" 219 | ["base types", lex_types_test] 220 | 221 | 222 | let program = {| 223 | let x = 10; 224 | x 225 | |} 226 | 227 | let all_test_cases = 228 | [lex_claim_test_case; 229 | lex_int_test_case; 230 | lex_float_test_case; 231 | lex_id_test_case; 232 | lex_string_test_case; 233 | lex_bool_test_case; 234 | lex_def_test_case; 235 | lex_datatype_test_case; 236 | lex_case_test_case; 237 | lex_ability_test_case; 238 | lex_let_test_case; 239 | lex_fn_test_case; 240 | lex_mut_test_case; 241 | lex_end_test_case; 242 | lex_if_test_case; 243 | lex_else_test_case; 244 | lex_then_test_case; 245 | lex_program_test_case; 246 | lex_operators_test_case; 247 | lex_types_test_case; 248 | lex_the_test_case] 249 | -------------------------------------------------------------------------------- /tests/tests.ml: -------------------------------------------------------------------------------- 1 | 2 | module PT = Parser_tests 3 | 4 | let all_test_cases = 5 | PT.all_test_cases (* @ PT.test_cases *) 6 | 7 | let () = 8 | Alcotest.run "Parser Tests" all_test_cases 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /tina.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "dev" 4 | synopsis: 5 | "Tina, an educational programming language with first-class types and abilities." 6 | maintainer: ["ebresafegaga@gmail.com"] 7 | authors: ["Oghenevwogaga Ebresafe"] 8 | homepage: "https://github.com/ebresafegaga/tina" 9 | bug-reports: "https://github.com/ebresafegaga/tina/issues" 10 | depends: [ 11 | "dune" {>= "2.8"} 12 | "menhir" 13 | "js_of_ocaml" 14 | "js_of_ocaml-ppx" 15 | "js_of_ocaml-compiler" 16 | "brr" 17 | "alcotest" 18 | "ocaml" {>= "4.08.1"} 19 | "odoc" {with-doc} 20 | ] 21 | build: [ 22 | ["dune" "subst"] {dev} 23 | [ 24 | "dune" 25 | "build" 26 | "-p" 27 | name 28 | "-j" 29 | jobs 30 | "@install" 31 | "@runtest" {with-test} 32 | "@doc" {with-doc} 33 | ] 34 | ] 35 | dev-repo: "git+https://github.com/ebresafegaga/tina.git" 36 | -------------------------------------------------------------------------------- /type.tina: -------------------------------------------------------------------------------- 1 | 2 | 3 | claim f (String -> Int) 4 | def f (x) = 5 | case (x) { 6 | x -> x 7 | } 8 | 9 | claim b (String -> (Int, String)) 10 | def b (str) = 11 | let s = ""; 12 | let c = 10; (c, s) -------------------------------------------------------------------------------- /typing/ctx.ml: -------------------------------------------------------------------------------- 1 | 2 | 3 | open Syntax 4 | open Naming 5 | 6 | module T = Type 7 | 8 | type t = (VarName.t * Type.t) list 9 | 10 | let assume ctx x t = (x, t) :: ctx 11 | 12 | let assume_list ctx xs ts = 13 | List.fold_right2 (fun name ty ctx -> assume ctx name ty) xs ts ctx 14 | (* let alist = List.combine xs ts in 15 | alist @ ctx *) 16 | 17 | let lookup ctx x = 18 | match List.assoc x ctx with 19 | | value -> value 20 | | exception Not_found -> 21 | let msg = Printf.sprintf "Unbound Variable %s" (VarName.to_string x) in 22 | Errors.runtime msg 23 | 24 | let lookup_claim ctx x = 25 | match List.assoc x ctx with 26 | | value -> value 27 | | exception Not_found -> 28 | let msg = Printf.sprintf "You must specify a type for the toplevel declaration %s" (VarName.to_string x) in 29 | Errors.runtime msg 30 | 31 | let is_recordty = function 32 | | T.TyRecord _ -> true 33 | | _ -> false 34 | 35 | (* (FieldName.t * t) list *) 36 | let rec lookup_record ctx name = 37 | let name' = name |> DataName.to_string |> VarName.of_string in 38 | match ctx with 39 | | [] -> 40 | let msg = Printf.sprintf "Unknown Record %s" (VarName.to_string name') in 41 | Errors.runtime msg 42 | | (x, t) :: ctx when x = name' -> 43 | (match t with 44 | | T.TyRecord r -> r 45 | | _ -> lookup_record ctx name) 46 | | (_x, _t) :: ctx -> lookup_record ctx name 47 | 48 | let rec lookup_variant ctx name = 49 | let name' = name |> DataName.to_string |> VarName.of_string in 50 | match ctx with 51 | | [] -> 52 | let msg = Printf.sprintf "Unknown Variant %s" (VarName.to_string name') in 53 | Errors.runtime msg 54 | | (x, t) :: ctx when x = name' -> 55 | (match t with 56 | | T.TyVariant v -> v, (v |> List.find (fun { T.label; _ } -> label = name)).fields 57 | | _ -> lookup_variant ctx name) 58 | | (_x, _t) :: ctx -> lookup_variant ctx name 59 | 60 | let is_bound ctx name = lookup ctx name |> ignore 61 | 62 | let empty = [] 63 | 64 | let default = 65 | ["+", T.TyArrow ([T.TyInt; T.TyInt], T.TyInt); 66 | "-", T.TyArrow ([T.TyInt; T.TyInt], T.TyInt); 67 | "*", T.TyArrow ([T.TyInt; T.TyInt], T.TyInt)] 68 | 69 | |> List.map (fun (n, t) -> VarName.of_string n, t) 70 | 71 | let pp_ctx = 72 | List.map (fun (name, ty) -> 73 | Printf.sprintf "%s : %s" (VarName.to_string name) (T.pp_ty ty)) 74 | -------------------------------------------------------------------------------- /typing/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name typing) 3 | (libraries utility syntax errors)) 4 | -------------------------------------------------------------------------------- /typing/typecheck.ml: -------------------------------------------------------------------------------- 1 | open Syntax 2 | open Naming 3 | module A = Ast 4 | module T = Type 5 | 6 | let report_expected_at ~expected ~got ~loc = 7 | let msg = 8 | Printf.sprintf "Expected a %s but got a %s at %s" (T.pp_ty expected) 9 | (T.pp_ty got) (Loc.pp loc) 10 | in 11 | Errors.runtime msg 12 | 13 | let report_error_at msg loc = 14 | let msg = Printf.sprintf "%s at %s" msg (Loc.pp loc) in 15 | Errors.runtime msg 16 | 17 | let rec bind_pattern_ty ctx pattern ty ~loc = 18 | match pattern, ty with 19 | | A.PVariable name, ty -> Ctx.assume ctx name ty 20 | | A.PInteger _, T.TyInt -> ctx 21 | | A.PInteger _, ty -> report_expected_at ~expected:T.TyInt ~got:ty ~loc 22 | | A.PBool _, T.TyBool -> ctx 23 | | A.PBool _, ty -> report_expected_at ~expected:T.TyBool ~got:ty ~loc 24 | | A.PString _, T.TyString -> ctx 25 | | A.PString _, ty -> report_expected_at ~expected:T.TyString ~got:ty ~loc 26 | | A.PTuple pats, T.TyTuple tys -> 27 | List.fold_right2 (fun pat ty s_ctx -> bind_pattern_ty s_ctx pat ty ~loc) pats tys ctx 28 | | A.PTuple _, ty -> 29 | let msg = Printf.sprintf "the type of this pattern should not be %s, it has a tuple type" (T.pp_ty ty) in 30 | report_error_at msg loc 31 | | A.PRecord (name, fields), T.TyRecord fields_ty -> 32 | let name_var = name |> DataName.to_string |> VarName.of_string in 33 | Ctx.is_bound ctx name_var; 34 | let pats = List.map snd fields in 35 | let tys = List.map snd fields_ty in 36 | List.fold_right2 (fun pat ty s_ctx -> bind_pattern_ty s_ctx pat ty ~loc) pats tys ctx 37 | | A.PRecord _, ty -> 38 | let msg = Printf.sprintf "the type of this pattern should not be %s, it has a record type" (T.pp_ty ty) in 39 | report_error_at msg loc 40 | | A.PVariant (name, pats), T.TyVariant vs -> 41 | Ctx.is_bound ctx name; 42 | let name = name |> VarName.to_string |> DataName.of_string in 43 | let v = vs |> List.find (fun { T.label; _ } -> label = name) in 44 | let tys = v.fields in 45 | List.fold_right2 (fun pat ty s_ctx -> bind_pattern_ty s_ctx pat ty ~loc) pats tys ctx 46 | | A.PVariant _, ty -> 47 | let msg = Printf.sprintf "the type of this pattern should not be %s, it has a variant type" (T.pp_ty ty) in 48 | report_error_at msg loc 49 | 50 | let rec synth ctx term = 51 | match term with 52 | | A.LitTodo _ | A.Absurd _ -> 53 | Errors.runtime "can't infer a type for TODO or absurd" 54 | | A.Variable (_loc, name) -> Ctx.lookup ctx name 55 | | A.LitUnit _loc -> T.TyUnit 56 | | A.LitBool (_loc, _b) -> T.TyBool 57 | | A.LitFloat (_loc, _f) -> T.TyFloat 58 | | A.LitInteger (_loc, _i) -> T.TyInt 59 | | A.LitString (_loc, _s) -> T.TyString 60 | | A.If (loc, _p, _pt, _pf) -> 61 | report_error_at "Can't infer a type for the if expression" loc 62 | | A.Sequence (loc, _, _) -> 63 | report_error_at "Can't infer a type for the sequence expression" loc 64 | | A.Fn (loc, _, _) -> 65 | report_error_at "Can't infer the type of the function" loc 66 | | A.Application (loc, f, args) -> ( 67 | let f_ty = synth ctx f in 68 | match f_ty with 69 | | T.TyArrow (args_ty, ret_ty) -> 70 | List.combine args args_ty |> List.iter (fun (a, t) -> check ctx a t); 71 | ret_ty 72 | | _ -> report_error_at "Expected a function" loc) 73 | | A.Annotated (_loc, term, ty) -> 74 | check ctx term ty; 75 | ty 76 | | A.Tuple (_loc, es) -> 77 | let ts = List.map (synth ctx) es in 78 | T.TyTuple ts 79 | | A.Record (_loc, name, fields) -> 80 | let fields_ty = Ctx.lookup_record ctx name in 81 | (* check that all labels of fields_ty is present in fields *) 82 | fields_ty 83 | |> List.iter (fun (label, ty) -> 84 | match List.assoc label fields with 85 | | expr -> check ctx expr ty 86 | | exception Not_found -> 87 | let msg = 88 | Printf.sprintf "This record is expected to have field %s" 89 | (FieldName.to_string label) 90 | in 91 | Errors.runtime msg); 92 | T.TyRecord fields_ty 93 | | A.RecordIndex (loc, record, name) -> ( 94 | let rec_ty = synth ctx record in 95 | match rec_ty with 96 | | T.TyRecord fields -> ( 97 | match List.assoc_opt name fields with 98 | | Some t -> t 99 | | None -> 100 | let msg = Printf.sprintf "The field name %s is not defined on this record" (FieldName.to_string name) in 101 | Errors.runtime msg) 102 | | _ -> report_error_at "expected a record type" loc) 103 | | A.Variant (loc, name, es) -> 104 | let vt, ts = Ctx.lookup_variant ctx name in 105 | if List.length ts <> List.length es then 106 | report_error_at "Variant argument length mismatch" loc 107 | else 108 | List.combine es ts 109 | |> List.iter (fun (e, t) -> check ctx e t); 110 | T.TyVariant vt 111 | | A.Let (loc, pattern, expr, body) -> tc_pattern ctx expr pattern body ~loc 112 | | A.Case (loc, _, _) -> report_error_at "Can't infer the type of the case expression" loc 113 | | Do _ | Handle _ -> Errors.runtime "not yet supported by the type checker" 114 | 115 | and check ctx term ty = 116 | match term with 117 | | A.LitBool (loc, _) -> ( 118 | match ty with 119 | | T.TyBool -> () 120 | | _ -> report_expected_at ~expected:ty ~got:T.TyBool ~loc) 121 | | A.LitInteger (loc, _) -> ( 122 | match ty with 123 | | T.TyInt -> () 124 | | _ -> report_expected_at ~expected:ty ~got:T.TyInt ~loc) 125 | | A.LitString (loc, _) -> ( 126 | match ty with 127 | | T.TyString -> () 128 | | _ -> report_expected_at ~expected:ty ~got:T.TyString ~loc) 129 | | A.LitFloat (loc, _) -> ( 130 | match ty with 131 | | T.TyFloat -> () 132 | | _ -> report_expected_at ~expected:ty ~got:T.TyFloat ~loc) 133 | | A.LitUnit loc -> ( 134 | match ty with 135 | | T.TyUnit -> () 136 | | _ -> report_expected_at ~expected:ty ~got:T.TyUnit ~loc) 137 | | A.Variable (loc, name) -> 138 | let ty_i = Ctx.lookup ctx name in 139 | let msg = 140 | Printf.sprintf "Expected a %s but got a %s" (T.pp_ty ty) (T.pp_ty ty_i) 141 | in 142 | if not (T.tyequal ty ty_i) then report_error_at msg loc 143 | | A.Absurd _ | LitTodo _ -> () 144 | | A.If (_loc, p, pt, pf) -> 145 | check ctx p T.TyBool; 146 | check ctx pt ty; 147 | check ctx pf ty 148 | | A.Fn (loc, args, body) -> ( 149 | match ty with 150 | | T.TyArrow (args_ty, ret_ty) when List.length args_ty = List.length args -> 151 | let body_ctx = Ctx.assume_list ctx args args_ty in 152 | check body_ctx body ret_ty 153 | | T.TyArrow _ -> report_error_at "Function argument mismatch" loc 154 | | _ -> 155 | report_error_at "A function expression must have a function type" loc) 156 | | A.Sequence (_loc, a, b) -> 157 | check ctx a T.TyUnit; 158 | check ctx b ty 159 | | A.Application (loc, _, _) -> 160 | let t_app = synth ctx term in 161 | if not (T.tyequal ty t_app) then 162 | report_expected_at ~expected:ty ~got:t_app ~loc 163 | | A.Record (loc, _, _) -> 164 | let t_rec = synth ctx term in 165 | if not (T.tyequal ty t_rec) then 166 | report_expected_at ~expected:ty ~got:t_rec ~loc 167 | | A.RecordIndex (loc, _, _) -> 168 | let t_rec = synth ctx term in 169 | if not (T.tyequal ty t_rec) then 170 | report_expected_at ~expected:ty ~got:t_rec ~loc 171 | | A.Annotated (loc, _, _) -> 172 | let t_rec = synth ctx term in 173 | if not (T.tyequal ty t_rec) then 174 | report_expected_at ~expected:ty ~got:t_rec ~loc 175 | | A.Variant (loc, _, _) -> 176 | let t_vrt = synth ctx term in 177 | if not (T.tyequal ty t_vrt) then 178 | report_expected_at ~expected:ty ~got:t_vrt ~loc 179 | | A.Tuple (loc, _) -> 180 | let t_rec = synth ctx term in 181 | if not (T.tyequal ty t_rec) then 182 | report_expected_at ~expected:ty ~got:t_rec ~loc 183 | | A.Let (loc, _, _, _) -> 184 | let t_rec = synth ctx term in 185 | if not (T.tyequal ty t_rec) then 186 | report_expected_at ~expected:ty ~got:t_rec ~loc 187 | | A.Case (loc, expr, clauses) -> 188 | clauses |> List.iter (fun (pattern, body) -> 189 | let t1 = (tc_pattern ctx expr pattern body ~loc) in 190 | if not (T.tyequal ty t1) then 191 | report_expected_at ~expected:ty ~got:t1 ~loc) 192 | | Do _ | Handle _ -> Errors.runtime "not yet supported by the type checker" 193 | 194 | and tc_pattern ctx expr pattern body ~loc = 195 | let expr_ty = synth ctx expr in 196 | let body_ctx = bind_pattern_ty ctx pattern expr_ty ~loc in 197 | synth body_ctx body 198 | 199 | let handle_top ctx top = 200 | match top with 201 | | A.VariantDef (_, _name, fields) -> 202 | let fields' = 203 | fields 204 | |> List.map (fun (v, fields) -> 205 | let label = v |> VarName.to_string |> DataName.of_string in 206 | { T.label; fields }) 207 | in 208 | let ty = T.TyVariant fields' in 209 | let ctx_new = List.map (fun (name, _) -> name, ty) fields in 210 | ctx_new @ ctx 211 | | A.RecordDef (_, name, body) -> 212 | let ty = T.TyRecord body in 213 | let name = name |> DataName.to_string |> VarName.of_string in 214 | Ctx.assume ctx name ty 215 | | AbilityDef _ -> ctx 216 | | Claim (_, name, ty) -> Ctx.assume ctx name ty 217 | | Def (_, name, expr) -> 218 | let ty = Ctx.lookup_claim ctx name in 219 | check ctx expr ty; 220 | ctx 221 | | Expression e -> 222 | let ty = synth ctx e in 223 | let e = VarName.of_string @@ A.pp_expression e in 224 | Ctx.assume ctx e ty 225 | 226 | let handle_toplevel = List.fold_left handle_top Ctx.default 227 | -------------------------------------------------------------------------------- /utility/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name utility) 3 | (libraries )) -------------------------------------------------------------------------------- /utility/utility.ml: -------------------------------------------------------------------------------- 1 | 2 | module Result = struct 3 | include Result 4 | 5 | let (let*) = bind 6 | let ( let+ ) = map 7 | 8 | let rec sequenceA xs = 9 | match xs with 10 | | [] -> Ok [] 11 | | x :: xs -> 12 | let* x = x in 13 | let* xs = sequenceA xs in 14 | Ok (x :: xs) 15 | 16 | end 17 | 18 | module List = struct 19 | include List 20 | 21 | let rec from_exclusive n m = 22 | if n < m then 23 | n :: from_exclusive (n+1) m 24 | else 25 | [] 26 | end 27 | 28 | 29 | let (>>) f g x = x |> f |> g 30 | 31 | --------------------------------------------------------------------------------