├── .gitignore ├── Dockerfile ├── Makefile ├── bin ├── jbuild ├── luml.ml ├── mkstdlib.ml └── shell.ml ├── jbuild ├── lib ├── ast.ml ├── compile.ml ├── config │ ├── discover.ml │ └── jbuild ├── exhaustive.ml ├── jbuild ├── lexer.mll ├── lua.c ├── lua.ml ├── parser.mly ├── parser_utils.ml ├── parsing.ml ├── project.ml ├── project.mli └── typer.ml ├── license.md ├── luml.opam ├── readme.md ├── stdlib ├── .gitignore ├── base.prelude ├── lume.proj └── src │ ├── base.ml │ ├── default.prelude │ ├── file.ml │ ├── list.ml │ ├── option.ml │ ├── result.ml │ └── string.ml └── test ├── error_tests.ml ├── exhaustive_tests.ml ├── helpers.ml ├── jbuild ├── lua_tests.ml ├── luml_test.ml ├── parsing_tests.ml └── typing_tests.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | .vscode 4 | merle.install 5 | *.swp 6 | release 7 | *.install 8 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam 2 | 3 | RUN eval `opam config env` && opam update && opam depext conf-m4.1 && opam install jbuilder core alcotest menhir ansiterminal lambda-term ocamlgraph 4 | RUN sudo apt update && sudo apt-get install lua5.3-dev make 5 | 6 | USER opam 7 | ADD --chown=opam:nogroup jbuild ./jbuild 8 | RUN mkdir lib && mkdir test && mkdir test/config 9 | ADD --chown=opam:nogroup lib/*.ml? lib/*.ml lib/*.c ./lib/ 10 | ADD --chown=opam:nogroup lib/jbuild ./lib/jbuild 11 | ADD --chown=opam:nogroup lib/config/*.ml ./lib/config/ 12 | ADD --chown=opam:nogroup lib/config/jbuild ./lib/config/jbuild 13 | ADD --chown=opam:nogroup test/*.ml ./test/ 14 | ADD --chown=opam:nogroup test/jbuild ./test/jbuild 15 | ADD --chown=opam:nogroup bin/*.ml ./bin/ 16 | ADD --chown=opam:nogroup bin/jbuild ./bin/jbuild 17 | ADD --chown=opam:nogroup stdlib/* ./stdlib/ 18 | ADD luml.opam ./luml.opam 19 | ADD jbuild ./jbuild 20 | ADD Makefile ./Makefile 21 | ENV PATH="/home/opam/.opam/4.05.0/bin:${PATH}" 22 | RUN make install 23 | 24 | CMD ["/bin/sh", "--login", "c", "make install"] 25 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | jbuilder build @install 3 | 4 | deps: 5 | opam install ./luml.opam --deps-only --yes 6 | 7 | run: 8 | jbuilder exec luml 9 | 10 | test: build _dummy 11 | jbuilder runtest --no-buffer -j 1 12 | 13 | format: 14 | ocamlformat -i lib/*.ml 15 | ocamlformat -i bin/*.ml 16 | ocamlformat -i test/*.ml 17 | 18 | utop: 19 | jbuilder utop lib 20 | 21 | release: _dummy build 22 | rm -r release 23 | mkdir -p release/bin 24 | mkdir -p release/lib/luml/stdlib 25 | _build/default/bin/mkstdlib.exe 26 | cp _build/default/bin/luml.exe release/bin/luml 27 | cp -r stdlib/* release/lib/luml/stdlib 28 | 29 | install: release 30 | sudo cp release/bin/* /usr/local/bin 31 | sudo mkdir -p /usr/local/lib/luml/stdlib 32 | sudo cp -r release/lib/luml/stdlib/* /usr/local/lib/luml/stdlib 33 | 34 | 35 | _dummy: 36 | -------------------------------------------------------------------------------- /bin/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executables ( 4 | (names (luml mkstdlib)) 5 | (public_names (luml mkstdlib)) 6 | (libraries (lib lambda-term lwt core_kernel)) 7 | (preprocess 8 | (pps (lwt.ppx))) 9 | )) 10 | -------------------------------------------------------------------------------- /bin/luml.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | let build args = 4 | (* Find a luml.project file *) 5 | let project = 6 | Sexplib.Sexp.load_sexp_conv_exn "luml.project" 7 | Lib.Project.Project.t_of_sexp 8 | in 9 | Lib.Project.build_project project 10 | 11 | let print_usage () = 12 | print_endline 13 | "Usage:\n\n \ 14 | luml -> run the interactive shell\n \ 15 | luml build -> run a project build\n \ 16 | luml help -> print this help text\n \ 17 | " 18 | 19 | let run_shell () = 20 | (* See if we are running standalone or in a project *) 21 | if Sys.file_exists "luml.project" then 22 | let project = build [] in 23 | Lwt_main.run (Shell.run_shell ~project ()) 24 | else print_endline "No 'luml.project' file - running standalone shell" ; 25 | Lwt_main.run (Shell.run_shell ()) 26 | 27 | let () = 28 | match Array.to_list Sys.argv with 29 | | [_path] -> run_shell () 30 | | _ :: "build" :: rest -> 31 | let _ = build rest in 32 | () 33 | | [_; "help"] -> print_usage () 34 | | _ -> print_usage () 35 | -------------------------------------------------------------------------------- /bin/mkstdlib.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | print_endline "Building stdlib" ; 3 | Lib.Project.build_tree ["stdlib/src"] [] "stdlib/build" ; 4 | Lib.Project.link ["stdlib/build"] "stdlib/build/stdlib.lua" 5 | -------------------------------------------------------------------------------- /bin/shell.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | 3 | open Lexing 4 | open Printf 5 | 6 | open Lwt 7 | open React 8 | open LTerm_style 9 | open LTerm_text 10 | open LTerm_geom 11 | 12 | open Lib.Ast 13 | open Lib.Lexer 14 | open Lib.Parsing 15 | 16 | let print_position outx lexbuf = 17 | let pos = lexbuf.lex_curr_p in 18 | fprintf outx "%s:%d:%d" pos.pos_fname 19 | pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) 20 | 21 | let make_prompt state = 22 | let prompt = "[luml]" in 23 | eval [ B_fg(index 14); S prompt; B_fg(index 38); S " => "] 24 | 25 | let make_err err = 26 | eval [ B_fg(index 1); S err; ] 27 | 28 | let make_value typ_ value = 29 | eval [ B_fg(index 2); S typ_; S " == "; S value ] 30 | 31 | class read_line ~term ~history ~symbols = object(self) 32 | inherit LTerm_read_line.read_line ~history () 33 | inherit [Zed_utf8.t] LTerm_read_line.term term 34 | 35 | method! completion = 36 | let prefix = Zed_rope.to_string self#input_prev in 37 | let symbols = List.filter ~f: (fun symbol -> Zed_utf8.starts_with symbol prefix) symbols in 38 | self#set_completion 0 (List.map ~f: (fun symbol -> (symbol, "")) symbols) 39 | 40 | 41 | initializer 42 | self#set_prompt (S.const (make_prompt state)) 43 | end 44 | 45 | (* Simple state machine to determine expressions vs statements *) 46 | let is_expr command = 47 | let open Lib.Parser in 48 | let buf = Lexing.from_string command in 49 | let rec next () = 50 | match Lib.Lexer.read buf with 51 | | WS -> next () 52 | | tok -> tok in 53 | let rec binding () = 54 | match next () with 55 | | EQUALS -> false 56 | | IDENT _ -> binding () 57 | | _ -> true 58 | in 59 | let infix_close () = 60 | match next () with 61 | | RIGHT_PARENS -> binding () 62 | | _ -> false 63 | in 64 | let infix_binding () = 65 | match next () with 66 | | INFIX _ -> infix_close () 67 | | INFIXR _ -> infix_close () 68 | | CONS_OP -> infix_close () 69 | | _ -> true 70 | in 71 | (* Initial state- type def or (possible) binding *) 72 | match next () with 73 | | TYPE -> false 74 | | TYPEDEF -> false 75 | | IDENT _ -> binding () 76 | | LEFT_PARENS -> infix_binding () 77 | | _ -> true 78 | 79 | let get_type_str env name = 80 | let _, type_ = String.Map.find_exn env.Lib.Typer.Env.symbols name in 81 | Type.format type_ 82 | 83 | let rec loop term history lua env = 84 | Lwt.catch (fun () -> 85 | (* Gather symbols from environment *) 86 | let local_symbols = String.Map.keys env.Lib.Typer.Env.symbols in 87 | let imported_symbols = env.Lib.Typer.Env.qualified_imports |> List.map ~f: (fun (_, name) -> name) in 88 | let foreign_symbols = 89 | env.Lib.Typer.Env.modules 90 | |> List.map ~f: (fun (mod_name, module_) -> 91 | module_.Lib.Ast.Module.bindings 92 | |> List.map ~f: (fun (binding: Lib.Ast.Binding.t) -> mod_name ^ "." ^ binding.name)) 93 | |> List.concat in 94 | let symbols = List.concat [foreign_symbols; imported_symbols; local_symbols] 95 | |> List.rev 96 | |> List.dedup_and_sort ~compare: (String.compare) in 97 | (new read_line ~term ~history:(LTerm_history.contents history) ~symbols)#run 98 | >|= fun command -> Some command) 99 | (function 100 | | Sys.Break -> return None 101 | | exn -> Lwt.fail exn) 102 | >>= function 103 | | Some command -> 104 | begin 105 | LTerm_history.add history command; 106 | (* we keep the env, but create a fresh mod each time *) 107 | let mod_ = Lib.Ast.Module.empty in 108 | (* Determine whether we want to record a statement or eval an expression *) 109 | let use_result, command = if is_expr command then 110 | (true, "result = " ^ command) 111 | else 112 | (false, command) in 113 | 114 | let parsed_buf = command 115 | |> Lexing.from_string 116 | |> parse_single_with_error in 117 | 118 | let env, term_res = (match parsed_buf with 119 | | Ok None -> 120 | env, LTerm.eprint "[Nothing entered]" 121 | 122 | | Ok (Some statement) -> 123 | (try let (env, mod_) = statement 124 | |> Lib.Ast.Statement.post_process 125 | |> List.fold_left ~f: (fun (env, mod_) statement -> 126 | Lib.Typer.from_statement failwith (env, mod_) statement) 127 | ~init: (env, mod_) in 128 | let lua_code = Lib.Compile.make_module mod_ ^ "\nfor k, v in pairs(__empty__) do _G[k] = v\n end" in 129 | 130 | Lib.Lua.exec_lua lua lua_code; 131 | (match use_result with 132 | 133 | | true -> Lib.Lua.exec_lua lua "merle_output = Base.toString(result);"; 134 | let output_value = Lib.Lua.get_global_string lua "merle_output" in 135 | let type_str = get_type_str env "result" in 136 | env, 137 | LTerm.printls (make_value type_str output_value) 138 | | false -> env, LTerm.print "") 139 | with 140 | CompileError err -> env, LTerm.printls (make_err (Error.format_error err))) 141 | 142 | | Error err -> 143 | env, LTerm.printls (make_err (Error.format_error err))) in 144 | 145 | term_res >>= fun () -> loop term history lua env 146 | end 147 | | None -> 148 | loop term history lua env 149 | 150 | let from_statements (env: Lib.Typer.Env.t) statements = 151 | let resolver name = 152 | let n, m = List.find_exn ~f: (fun (n, m) -> n = name) env.modules in 153 | m in 154 | 155 | List.fold_left 156 | ~f: (Lib.Typer.from_statement resolver) 157 | ~init: (env, Lib.Ast.Module.empty) 158 | statements 159 | 160 | let load_modules deps_dirs main prelude = 161 | let mlo_files = deps_dirs |> List.concat_map ~f: (Lib.Project.gather ".mlo") in 162 | let loader = Fn.compose Lib.Project.CompiledModule.t_of_sexp Sexp.load_sexp in 163 | let built_modules = List.map ~f: loader mlo_files in 164 | let lua_code = In_channel.read_all main in 165 | let prelude = In_channel.read_all prelude in 166 | (built_modules, lua_code, prelude) 167 | 168 | let rec gather_prelude lexbuf = 169 | let reader = Lib.Parsing.reader () in 170 | let rec inner lexbuf = 171 | match parse_with_error reader lexbuf with 172 | | Ok None -> [] 173 | | Ok (Some statement) -> statement :: inner lexbuf 174 | | Error err -> failwith ("Got an error: " ^ (Error.format_error err)) in 175 | inner lexbuf 176 | 177 | let apply_prelude lexbuf lua modules env = 178 | let statements = gather_prelude lexbuf in 179 | let env, mod_ = from_statements env statements in 180 | let lua_code = Lib.Compile.make_module mod_ in 181 | Lib.Lua.exec_lua lua (lua_code ^ "\nfor k, v in pairs(__empty__) do _G[k] = v end"); 182 | env 183 | 184 | let init_env lua (env: Lib.Typer.Env.t) (project : Lib.Project.Project.t option): Lib.Typer.Env.t = 185 | let stdlib_path = 186 | (* 187 | Sys.argv 188 | |> Array.to_list 189 | |> List.hd_exn 190 | |> Filename.dirname 191 | |> Str.split (Str.regexp_string (Filename.dir_sep)) 192 | |> List.rev 193 | |> (fun x -> List.drop x 1) 194 | |> List.rev 195 | |> (fun x -> x @ ["lib"; "luml"; "stdlib"]) 196 | |> String.concat ~sep: Filename.dir_sep in 197 | *) 198 | "/usr/local/lib/luml/stdlib" in 199 | let prelude_path = stdlib_path ^ Filename.dir_sep ^ "base.prelude" in 200 | let prelude_build_path = stdlib_path ^ Filename.dir_sep ^ "build" in 201 | let prelude_build_artefact = prelude_build_path ^ Filename.dir_sep ^ "stdlib.lua" in 202 | 203 | let mods, prelude, raw_mods = match project with 204 | | Some project -> 205 | let artefact_path = "build/" ^ project.name ^ "/" ^ project.name ^ ".lua" in 206 | let build_path = "build/" ^ project.name in 207 | 208 | let open Lib.Project.CompiledModule in 209 | let raw_mods, code, prelude = load_modules [prelude_build_path; build_path] artefact_path prelude_path in 210 | let mods = List.map ~f: (fun m -> (m.name, Option.value_exn m.module_)) raw_mods in 211 | Lib.Lua.exec_lua lua ("local result = (function () " ^ code ^ "end)()\nfor k, v in pairs(result) do _G[k] = v end"); 212 | mods, prelude, raw_mods 213 | | None -> 214 | let open Lib.Project.CompiledModule in 215 | let raw_mods, code, prelude = load_modules [prelude_build_path] prelude_build_artefact prelude_path in 216 | let mods = List.map ~f: (fun m -> (m.name, Option.value_exn m.module_)) raw_mods in 217 | (* Exec prebuilt Lua code as a chunk and inject all modules into the global environment *) 218 | Lib.Lua.exec_lua lua ("local result = (function () " ^ code ^ "end)()\nfor k, v in pairs(result) do _G[k] = v end"); 219 | mods, prelude, raw_mods in 220 | (* Inject all modules into the environment so we know how to type them *) 221 | 222 | let env = { env with modules = mods } in 223 | (* Apply the stdlib prelude *) 224 | apply_prelude (Lexing.from_string prelude) lua raw_mods env 225 | 226 | let run_shell ?project () = 227 | Lazy.force LTerm.stdout 228 | >>= (fun term -> 229 | let lua = Lib.Lua.new_lua () in 230 | let env = Lib.Typer.Env.empty in 231 | let env = init_env lua env project in 232 | loop term (LTerm_history.create []) lua env) 233 | 234 | -------------------------------------------------------------------------------- /jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | -------------------------------------------------------------------------------- /lib/ast.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Printf 3 | 4 | module Pos = struct 5 | type t = {file: string; line: int; char: int} [@@deriving sexp] 6 | end 7 | 8 | module Source = struct 9 | type t = None | Pos of Pos.t [@@deriving sexp] 10 | end 11 | 12 | (* To produce Core Erlang compatible identifiers, we need to know a little 13 | bit about what type it refers to. All functions in Merle are single arity; 14 | top level functions are constructed as zero-arity functions when compiled *) 15 | module IdentType = struct 16 | type t = Unknown | OuterFun | OuterVal | Var [@@deriving sexp] 17 | end 18 | 19 | module Identifier = struct 20 | type t = {name: string; type_: IdentType.t ref; module_: string option ref} 21 | [@@deriving sexp] 22 | 23 | let make name type_ = 24 | if String.contains name '.' && not (String.contains name '(') then 25 | let parts = String.split ~on:'.' name |> List.rev in 26 | match parts with 27 | | [] -> failwith ("Bad module identifier " ^ name) 28 | | ident_name :: mod_parts -> 29 | let module_ = ref (Some (mod_parts |> String.concat ~sep:".")) in 30 | {name= ident_name; type_; module_} 31 | else {name; type_; module_= ref None} 32 | end 33 | 34 | module rec TypeArg : sig 35 | type t = {id: int; name: string option; instance: Type.t option ref} 36 | [@@deriving sexp] 37 | 38 | val id_counter : int ref 39 | 40 | val make : unit -> t 41 | end = struct 42 | type t = {id: int; name: string option; instance: Type.t option ref} 43 | [@@deriving sexp] 44 | 45 | let id_counter = ref 0 46 | 47 | let make () = 48 | id_counter := !id_counter + 1 ; 49 | {id= !id_counter; name= None; instance= ref None} 50 | end 51 | 52 | and Variant : sig 53 | type t = {name: string; args: Type.t list} [@@deriving sexp] 54 | end = struct 55 | type t = {name: string; args: Type.t list} [@@deriving sexp] 56 | end 57 | 58 | and Adt : sig 59 | type t = {name: string; args: Type.t list; variants: Variant.t list} 60 | [@@deriving sexp] 61 | end = struct 62 | type t = {name: string; args: Type.t list; variants: Variant.t list} 63 | [@@deriving sexp] 64 | end 65 | 66 | and SelfRef : sig 67 | type t = {name: string; args: Type.t list} [@@deriving sexp] 68 | end = struct 69 | type t = {name: string; args: Type.t list} [@@deriving sexp] 70 | end 71 | 72 | and UserType : sig 73 | type t = {name: string; args: Type.t list; type_: Type.t option} 74 | [@@deriving sexp] 75 | end = struct 76 | type t = {name: string; args: Type.t list; type_: Type.t option} 77 | [@@deriving sexp] 78 | end 79 | 80 | and Record : sig 81 | type t = {fields: (string * Type.t) list} [@@deriving sexp] 82 | end = struct 83 | type t = {fields: (string * Type.t) list} [@@deriving sexp] 84 | end 85 | 86 | and PolyRecord : sig 87 | type t = {fields: (string * Type.t) list; poly: t option ref} 88 | [@@deriving sexp] 89 | 90 | val get_base : t -> t 91 | end = struct 92 | type t = {fields: (string * Type.t) list; poly: t option ref} 93 | [@@deriving sexp] 94 | 95 | let rec get_base r = 96 | match !(r.poly) with Some poly -> get_base poly | None -> r 97 | end 98 | 99 | and Alias : sig 100 | type t = {name: string; type_: Type.t; args: Type.t list} [@@deriving sexp] 101 | end = struct 102 | type t = {name: string; type_: Type.t; args: Type.t list} [@@deriving sexp] 103 | end 104 | 105 | and Type : sig 106 | type t = 107 | | Arrow of (t * t) 108 | | Int 109 | | Float 110 | | String 111 | | Bool 112 | | TypeArg of TypeArg.t 113 | | Tuple of t list 114 | | List of t 115 | | Adt of Adt.t 116 | | SelfRef of SelfRef.t 117 | | Record of Record.t 118 | | PolyRecord of PolyRecord.t 119 | | Alias of Alias.t 120 | | UserType of UserType.t 121 | | Unit 122 | [@@deriving sexp] 123 | 124 | type type_map = string Int.Map.t 125 | 126 | val format : ?ugly_args:bool -> t -> string 127 | 128 | val copy : t -> Type.t list -> t 129 | end = struct 130 | type t = 131 | | Arrow of (t * t) 132 | | Int 133 | | Float 134 | | String 135 | | Bool 136 | | TypeArg of TypeArg.t 137 | | Tuple of t list 138 | | List of t 139 | | Adt of Adt.t 140 | | SelfRef of SelfRef.t 141 | | Record of Record.t 142 | | PolyRecord of PolyRecord.t 143 | | Alias of Alias.t 144 | | UserType of UserType.t 145 | | Unit 146 | [@@deriving sexp] 147 | 148 | type type_map = string Int.Map.t 149 | 150 | let format ?ugly_args t = 151 | let rec inner (arg_map: type_map) targ_index t = 152 | let add_parens str = 153 | if String.contains str ' ' then 154 | "(" ^ str ^ ")" 155 | else 156 | str in 157 | let only x = (arg_map, targ_index, x) in 158 | let add_arg id = 159 | let name = 97 + targ_index |> Caml.Char.chr |> Caml.Char.escaped in 160 | (Int.Map.set arg_map ~key:id ~data:name, targ_index + 1, name) 161 | in 162 | match t with 163 | | Unit -> only "()" 164 | | Int -> only "Int" 165 | | Float -> only "Float" 166 | | String -> only "String" 167 | | Bool -> only "Bool" 168 | | UserType {name; args} -> 169 | let arg_str = 170 | List.map ~f:(inner arg_map targ_index) args 171 | |> List.map ~f:(fun (_, _, v) -> v) 172 | in 173 | only 174 | ( [""; name] @ arg_str 175 | |> String.concat ~sep:" " ) 176 | | Alias {name; args} -> 177 | let arg_str = 178 | List.map ~f:(inner arg_map targ_index) args 179 | |> List.map ~f:(fun (_, _, v) -> v) 180 | in 181 | only (name :: arg_str |> String.concat ~sep:" ") 182 | | TypeArg {TypeArg.name; instance; id} -> ( 183 | match (!instance, name) with 184 | | Some inst, _ -> inner arg_map targ_index inst 185 | | None, None -> 186 | if ugly_args = None then 187 | match Int.Map.mem arg_map id with 188 | | true -> only (Map.find arg_map id |> Option.value ~default:"_") 189 | | false -> add_arg id 190 | else only @@ "Arg: " ^ string_of_int id 191 | | None, Some name -> 192 | only @@ name 193 | ^ 194 | if ugly_args = None then "" else "[Arg: " ^ string_of_int id ^ "]" 195 | ) 196 | | Arrow (arg, ret) -> 197 | let arg_map, targ_index, arg_str = inner arg_map targ_index arg in 198 | let arg_map, targ_index, ret_str = inner arg_map targ_index ret in 199 | (* TODO we should have a 'populated type' function to work around type args *) 200 | let arg_str = 201 | match arg with 202 | | Arrow _ -> add_parens arg_str 203 | | TypeArg a -> ( 204 | match !(a.instance) with 205 | | Some (Arrow _) -> add_parens arg_str 206 | | _ -> arg_str ) 207 | | _ -> arg_str 208 | in 209 | (arg_map, targ_index, arg_str ^ " -> " ^ ret_str) 210 | | List t -> 211 | let _, _, t_str = inner arg_map targ_index t in 212 | only (sprintf "List %s" t_str) 213 | | Tuple types -> 214 | (* todo - need to fold this, not map, so we can preserve the type arg env *) 215 | types 216 | |> List.fold_left 217 | ~f:(fun (arg_map, targ_index, acc) x -> 218 | let arg_map, targ_index, s = inner arg_map targ_index x in 219 | (arg_map, targ_index, acc @ [s]) ) 220 | ~init:(arg_map, targ_index, []) 221 | |> (fun (_, _, s) -> s) 222 | |> String.concat ~sep:", " |> sprintf "(%s)" |> only 223 | | Adt {name; args; variants} -> 224 | let arg_list = 225 | args 226 | |> List.map ~f:(inner arg_map targ_index) 227 | |> List.map ~f:(fun (_, _, t) -> t) 228 | |> List.filter ~f:(( <> ) "") 229 | |> List.map ~f: add_parens 230 | |> String.concat ~sep:" " 231 | in 232 | (* 233 | let variant_list = 234 | List.map 235 | ~f: (fun {Variant.name; args} -> 236 | let variant_args = 237 | args 238 | |> List.map ~f: (fun x -> 239 | let _, _, s = inner arg_map targ_index x in 240 | s ) 241 | |> String.concat ~sep: " " 242 | in 243 | name ^ (if (String.length variant_args) > 0 then (" " ^ variant_args) else "")) 244 | variants 245 | |> String.concat ~sep: " | " 246 | in *) 247 | (* TODO - perhaps if we had a 'verbose' flag we would show all the variants *) 248 | only 249 | @@ ( [name; arg_list] 250 | |> List.filter ~f:(( <> ) "") 251 | |> String.concat ~sep:" " ) 252 | | SelfRef {name} -> only name 253 | | Record {fields} -> 254 | (* let end_ = if poly then ", .. }" else " }" in *) 255 | let fieldstr = 256 | fields 257 | |> List.map ~f:(fun (name, t) -> 258 | let _, _, type_ = inner arg_map targ_index t in 259 | sprintf "%s : %s" name type_ ) 260 | |> String.concat ~sep:", " 261 | in 262 | only @@ "{ " ^ fieldstr ^ " }" 263 | | PolyRecord pr -> 264 | let fields = (PolyRecord.get_base pr).fields in 265 | let fieldstr = 266 | fields 267 | |> List.fold_left 268 | ~f:(fun (arg_map, targ_index, acc) (name, t) -> 269 | let arg_map, targ_index, type_ = 270 | inner arg_map targ_index t 271 | in 272 | let str = sprintf "%s : %s" name type_ in 273 | (arg_map, targ_index, acc @ [str]) ) 274 | ~init:(arg_map, targ_index, []) 275 | |> (fun (_, _, args) -> args) 276 | |> String.concat ~sep:", " 277 | in 278 | only @@ "{ " ^ fieldstr ^ ", .. }" 279 | in 280 | let _, _, str = inner Int.Map.empty 0 t in 281 | str 282 | 283 | let copy t non_free = 284 | let rec get_instance_type t = 285 | match t with 286 | | Type.TypeArg {TypeArg.instance} -> ( 287 | match !instance with Some inst -> get_instance_type inst | _ -> t ) 288 | | _ -> t 289 | in 290 | let non_free_fresh = List.map ~f:get_instance_type non_free in 291 | let type_map = Int.Map.empty in 292 | let rec inner type_ map = 293 | match get_instance_type type_ with 294 | | TypeArg {TypeArg.name; instance; id} -> ( 295 | match 296 | (* already in symbol map? *) 297 | ( Int.Map.mem map id 298 | , List.exists 299 | ~f:(function Type.TypeArg t -> id = t.id | _ -> false) 300 | non_free_fresh ) 301 | with 302 | | true, _ -> (Int.Map.find_exn map id, map) 303 | | _, true -> (type_, map) 304 | | false, false -> 305 | match !instance with 306 | | Some t -> 307 | failwith "Non-generic instance found where it shouldn't be" 308 | (* this shouldn't happen, ever *) 309 | | None -> 310 | let t = TypeArg (TypeArg.make ()) in 311 | (t, Map.set map ~key:id ~data:t) 312 | (* ignore name for now... *) ) 313 | | Arrow (expr, arg) -> 314 | let expr2, map2 = inner expr map in 315 | let arg2, map3 = inner arg map2 in 316 | (Arrow (expr2, arg2), map3) 317 | | Tuple args -> 318 | let args, map = 319 | List.fold_left 320 | ~f:(fun (acc, map) el -> 321 | let t, map = inner el map in 322 | (t :: acc, map) ) 323 | ~init:([], map) args 324 | in 325 | (Tuple (List.rev args), map) 326 | | List t -> 327 | let arg, map = inner t map in 328 | (List arg, map) 329 | | Record r -> 330 | let args, map = 331 | List.fold_left 332 | ~f:(fun (acc, map) (field, t) -> 333 | let t, map = inner t map in 334 | ((field, t) :: acc, map) ) 335 | ~init:([], map) r.fields 336 | in 337 | (Record {fields= args}, map) 338 | | PolyRecord r -> 339 | if 340 | List.exists 341 | ~f:(function 342 | | Type.PolyRecord pr -> pr = PolyRecord.get_base r 343 | | _ -> false) 344 | non_free_fresh 345 | then (Type.PolyRecord r, map) 346 | else 347 | let args, map = 348 | List.fold_left 349 | ~f:(fun (acc, map) (field, t) -> 350 | let t, map = inner t map in 351 | ((field, t) :: acc, map) ) 352 | ~init:([], map) (PolyRecord.get_base r).fields 353 | in 354 | (PolyRecord {fields= args; poly= ref None}, map) 355 | | SelfRef {name; args} -> 356 | let args, map = 357 | List.fold_left 358 | ~f:(fun (acc, map) el -> 359 | let t, map = inner el map in 360 | (t :: acc, map) ) 361 | ~init:([], map) args 362 | in 363 | (SelfRef {name; args}, map) 364 | | Adt t -> 365 | let args, map = 366 | List.fold_left 367 | ~f:(fun (acc, map) el -> 368 | let t, map = inner el map in 369 | (t :: acc, map) ) 370 | ~init:([], map) t.Adt.args 371 | in 372 | let variants, map = 373 | List.fold_left 374 | ~f:(fun (acc, map) el -> 375 | let args, map = 376 | List.fold_left 377 | ~f:(fun (acc, map) el -> 378 | let t, map = inner el map in 379 | (t :: acc, map) ) 380 | ~init:([], map) el.Variant.args 381 | in 382 | ({el with args= List.rev args} :: acc, map) ) 383 | ~init:([], map) t.Adt.variants 384 | in 385 | ( Adt 386 | {t with Adt.args= List.rev args; Adt.variants= List.rev variants} 387 | , map ) 388 | | default -> (default, map) 389 | in 390 | let t, map = inner t type_map in 391 | t 392 | end 393 | 394 | module rec Lambda : sig 395 | type t = {arg: string; body: Node.t} [@@deriving sexp] 396 | end = struct 397 | type t = {arg: string; body: Node.t} [@@deriving sexp] 398 | end 399 | 400 | and Apply : sig 401 | type t = {expr: Node.t; arg: Node.t} [@@deriving sexp] 402 | end = struct 403 | type t = {expr: Node.t; arg: Node.t} [@@deriving sexp] 404 | end 405 | 406 | and Call : sig 407 | type t = {module_: string; fun_: string; args: Node.t list} [@@deriving sexp] 408 | end = struct 409 | type t = {module_: string; fun_: string; args: Node.t list} [@@deriving sexp] 410 | end 411 | 412 | and Let : sig 413 | type t = {name: string; bound_expr: Node.t; expr: Node.t} [@@deriving sexp] 414 | end = struct 415 | type t = {name: string; bound_expr: Node.t; expr: Node.t} [@@deriving sexp] 416 | end 417 | 418 | and AdtConstructor : sig 419 | type t = {type_: string; name: string; args: Node.t list} [@@deriving sexp] 420 | end = struct 421 | type t = {type_: string; name: string; args: Node.t list} [@@deriving sexp] 422 | end 423 | 424 | and Literal : sig 425 | type t = 426 | | Int of int 427 | | Float of float 428 | | String of string 429 | | Boolean of bool 430 | | Tuple of Node.t list 431 | | Record of (string * Node.t) list 432 | | ConsCell of (Node.t * Node.t) 433 | | EmptyList 434 | [@@deriving sexp] 435 | end = struct 436 | type t = 437 | | Int of int 438 | | Float of float 439 | | String of string 440 | | Boolean of bool 441 | | Tuple of Node.t list 442 | | Record of (string * Node.t) list 443 | | ConsCell of (Node.t * Node.t) 444 | | EmptyList 445 | [@@deriving sexp] 446 | end 447 | 448 | and Match : sig 449 | type t = {expr: Node.t; clauses: MatchClause.t list} [@@deriving sexp] 450 | end = struct 451 | type t = {expr: Node.t; clauses: MatchClause.t list} [@@deriving sexp] 452 | end 453 | 454 | and MatchClause : sig 455 | type t = {pattern: MatchPattern.t; result: Node.t} [@@deriving sexp] 456 | end = struct 457 | type t = {pattern: MatchPattern.t; result: Node.t} [@@deriving sexp] 458 | end 459 | 460 | and MatchPattern : sig 461 | type t = 462 | | Int of int 463 | | Float of float 464 | | String of string 465 | | Boolean of bool 466 | | Tuple of t list 467 | | Cons of (t * t) 468 | | EmptyList 469 | | Binding of string 470 | | Record of (string * t) list 471 | | Constructor of (string * t list) 472 | [@@deriving sexp] 473 | 474 | val cons_to_list : t -> t list 475 | end = struct 476 | type t = 477 | | Int of int 478 | | Float of float 479 | | String of string 480 | | Boolean of bool 481 | | Tuple of t list 482 | | Cons of (t * t) 483 | | EmptyList 484 | | Binding of string 485 | | Record of (string * t) list 486 | | Constructor of (string * t list) 487 | [@@deriving sexp] 488 | 489 | let rec cons_to_list x = 490 | match x with 491 | | EmptyList -> [EmptyList] 492 | | Binding b -> [x] 493 | | Cons (pat, tail) -> pat :: cons_to_list tail 494 | | _ -> failwith "Bad match pattern in tail position" 495 | end 496 | 497 | and RecordAccess : sig 498 | type t = Node.t * string [@@deriving sexp] 499 | end = struct 500 | type t = Node.t * string [@@deriving sexp] 501 | end 502 | 503 | and RecordUpdate : sig 504 | type t = Node.t * (string * Node.t) list [@@deriving sexp] 505 | end = struct 506 | type t = Node.t * (string * Node.t) list [@@deriving sexp] 507 | end 508 | 509 | and Expr : sig 510 | type t = 511 | | Identifier of Identifier.t 512 | | Lambda of Lambda.t 513 | | Literal of Literal.t 514 | | Apply of Apply.t 515 | | Call of Call.t 516 | | Let of Let.t 517 | | Match of Match.t 518 | | RecordAccess of RecordAccess.t 519 | | RecordUpdate of RecordUpdate.t 520 | | AdtConstructor of AdtConstructor.t 521 | | Unit 522 | [@@deriving sexp] 523 | 524 | val format : Node.t -> string 525 | end = struct 526 | type t = 527 | | Identifier of Identifier.t 528 | | Lambda of Lambda.t 529 | | Literal of Literal.t 530 | | Apply of Apply.t 531 | | Call of Call.t 532 | | Let of Let.t 533 | | Match of Match.t 534 | | RecordAccess of RecordAccess.t 535 | | RecordUpdate of RecordUpdate.t 536 | | AdtConstructor of AdtConstructor.t 537 | | Unit 538 | [@@deriving sexp] 539 | 540 | let format e = 541 | let rec formati indent e = 542 | match e.Node.expr with 543 | | Identifier {name; type_} -> name 544 | | Lambda {Lambda.arg; body} -> 545 | "(\\" ^ arg ^ " -> " ^ formati indent body ^ ")" 546 | | Apply {Apply.expr; arg} -> 547 | "(" ^ formati indent expr ^ " " ^ formati indent arg ^ ")" 548 | | Literal (Literal.Boolean b) -> string_of_bool b 549 | | Literal (Literal.Int i) -> string_of_int i 550 | | Literal (Literal.Float f) -> string_of_float f 551 | | Literal (Literal.String s) -> "<<" ^ s ^ ">>" 552 | | Literal (Literal.Tuple items) -> 553 | let parts = List.map ~f:(formati indent) items in 554 | sprintf "(%s)" (String.concat parts ~sep:", ") 555 | | Call {Call.module_; fun_; args} -> sprintf "%s:%s" module_ fun_ 556 | | Let {Let.name; bound_expr; expr} -> 557 | sprintf "let %s = %s in %s" name 558 | (formati indent bound_expr) 559 | (formati indent expr) 560 | | Match {Match.expr; clauses} -> 561 | sprintf "match %s with ???" (formati indent expr) 562 | | AdtConstructor {type_; name; args} -> 563 | let arg_vals = 564 | List.map ~f:(formati indent) args |> String.concat ~sep:", " 565 | in 566 | sprintf "%s.%s %s" type_ name arg_vals 567 | | _ -> "unknown" 568 | in 569 | formati 0 e 570 | end 571 | 572 | and Node : sig 573 | type t = {expr: Expr.t; source: Source.t} [@@deriving sexp] 574 | 575 | val make : Expr.t -> Source.t -> t 576 | end = struct 577 | type t = {expr: Expr.t; source: Source.t} [@@deriving sexp] 578 | 579 | let make expr source = {expr; source} 580 | end 581 | 582 | module Error = struct 583 | type error_type = 584 | | Syntax of string 585 | | TypeMismatch of (Type.t * Type.t) 586 | | TypeSignatureMismatch of (Type.t * Type.t) 587 | | IdentifierNotFound of string 588 | | TypeNotFound of string 589 | | Inexhaustive of string 590 | | TypeParamMissing of string 591 | | CyclicalType of string 592 | | FieldMismatch of string 593 | 594 | type t = {source: Source.t; error: error_type} 595 | 596 | let format_src (src: Source.t) : string = 597 | match src with 598 | | None -> "(no pos)" 599 | | Pos pos -> sprintf "%d:%d" pos.line pos.char 600 | 601 | let format_error err = 602 | let src = format_src err.source in 603 | match err.error with 604 | | Syntax e -> src ^ ": Syntax error: " ^ e 605 | | IdentifierNotFound t -> src ^ ":Unknown identifier: '" ^ t ^ "'" 606 | | TypeMismatch (t1, t2) -> 607 | sprintf "%s: Type mismatch: expected '%s' but found '%s'" src 608 | (Type.format t1) (Type.format t2) 609 | | Inexhaustive s -> sprintf "%s: Inexhaustive pattern match %s" src s 610 | | TypeParamMissing s -> 611 | sprintf "%s: Type parameter '%s' used in definition but not listed" src 612 | s 613 | | CyclicalType s -> sprintf "%s: Cyclical type error - %s" src s 614 | | FieldMismatch s -> sprintf "%s: Field mismatch error - %s" src s 615 | | TypeNotFound f -> sprintf "%s: Type not found - %s" src f 616 | | TypeSignatureMismatch (t1, t2) -> 617 | sprintf 618 | "%s: Type signature mismatch: expected '%s' but type signature \ 619 | given of '%s'" 620 | src (Type.format t1) (Type.format t2) 621 | end 622 | 623 | exception CompileError of Error.t 624 | 625 | module TypedNode = struct 626 | type t = {node: Node.t; type_: Type.t} [@@deriving sexp] 627 | 628 | let make node type_ = {node; type_} 629 | end 630 | 631 | module Binding = struct 632 | type t = {name: string; expr: TypedNode.t} [@@deriving sexp] 633 | 634 | let make name expr = {name; expr} 635 | end 636 | 637 | module NamedType = struct 638 | type t = {name: string; type_: Type.t} [@@deriving sexp] 639 | end 640 | 641 | module Import = struct 642 | type t = {module_: string; qualified: string list} [@@deriving sexp] 643 | end 644 | 645 | module Module = struct 646 | type t = 647 | { name: string 648 | ; imports: Import.t list 649 | ; bindings: Binding.t list 650 | ; verbatim: string 651 | ; types: NamedType.t list } 652 | [@@deriving sexp] 653 | 654 | let empty = 655 | {name= "__empty__"; imports= []; bindings= []; types= []; verbatim= ""} 656 | 657 | let rec find_constructor types variant_name : (Adt.t * Variant.t) option = 658 | match types with 659 | | [] -> None 660 | | {NamedType.type_} :: rest -> 661 | match type_ with 662 | | Type.Adt adt -> ( 663 | try 664 | let variant = 665 | List.find_exn 666 | ~f:(fun {Variant.name} -> name = variant_name) 667 | adt.variants 668 | in 669 | Some (adt, variant) 670 | with Not_found -> find_constructor rest variant_name ) 671 | | _ -> find_constructor rest variant_name 672 | end 673 | 674 | module Statement = struct 675 | type t = 676 | | Let of {name: string; expr: Node.t} 677 | | TypeSignature of {name: string; type_: Type.t} 678 | | Module of {name: string} 679 | | Import of Import.t 680 | | Type of {name: string; type_: Type.t} 681 | | Verbatim of {name: string; code: string} 682 | [@@deriving sexp] 683 | 684 | let format = function 685 | | Let {name; expr} -> sprintf "let %s = %s" name (Expr.format expr) 686 | | TypeSignature {name; type_} -> 687 | sprintf "val %s : %s" name (Type.format type_) 688 | | Module {name} -> sprintf "module %s" name 689 | | Type {name; type_} -> sprintf "type %s" name 690 | | Import {module_} -> sprintf "import %s" module_ 691 | | Verbatim {name} -> sprintf "[%% %s verbatim code block %%]" name 692 | 693 | let rec make_variant argc name type_ v = 694 | match v with 695 | | [] -> 696 | let rec make_args i = 697 | match i with 698 | | 0 -> [] 699 | | x -> sprintf "arg%d" (x - 1) :: make_args (x - 1) 700 | in 701 | let args = 702 | make_args argc |> List.rev 703 | |> List.map ~f:(fun a -> 704 | Expr.Identifier 705 | { Identifier.name= a 706 | ; type_= ref IdentType.Var 707 | ; module_= ref None } ) 708 | |> List.map ~f:(fun expr -> Node.make expr Source.None) 709 | in 710 | Node.make (Expr.AdtConstructor {type_; name; args}) Source.None 711 | | arg :: rest -> 712 | let arg = sprintf "arg%d" argc in 713 | let body = make_variant (argc + 1) name type_ rest in 714 | let expr = Expr.Lambda {arg; body} in 715 | Node.make expr Source.None 716 | 717 | let post_process (statement: t) = 718 | match statement with 719 | | Type {name; type_} -> ( 720 | let type_name = name in 721 | match type_ with 722 | | Type.Adt {variants} -> 723 | let adt_funs = 724 | variants 725 | |> List.map ~f:(fun {Variant.args; name} -> 726 | let expr = make_variant 0 name type_name args in 727 | Let {name; expr} ) 728 | in 729 | statement :: adt_funs 730 | | _ -> [statement] ) 731 | | _ -> [statement] 732 | end 733 | 734 | module TestExpressions = struct 735 | let test_node expr = Node.make expr Source.None 736 | 737 | let lambda arg body = test_node @@ Expr.Lambda {Lambda.arg; body} 738 | 739 | let var f = 740 | test_node @@ Expr.Identifier (Identifier.make f (ref IdentType.Var)) 741 | 742 | let lit_int i = test_node @@ Expr.Literal (Literal.Int i) 743 | 744 | let lit_bool b = test_node @@ Expr.Literal (Literal.Boolean b) 745 | 746 | let apply expr arg = test_node @@ Expr.Apply {Apply.expr; arg} 747 | 748 | let call module_ fun_ args = test_node @@ Expr.Call {Call.module_; fun_; args} 749 | end 750 | -------------------------------------------------------------------------------- /lib/compile.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | open Printf 3 | 4 | let ( <| ) f x = f x 5 | 6 | let sym_count = ref 1 7 | 8 | let gen_sym () = 9 | sym_count := !sym_count + 1 ; 10 | sprintf "sym_%d" !sym_count 11 | 12 | let map_infix_char c = 13 | match c with 14 | | '(' -> "LP" 15 | | ')' -> "RP" 16 | | '>' -> "GT" 17 | | '<' -> "LT" 18 | | '|' -> "BR" 19 | | '+' -> "PL" 20 | | '-' -> "MI" 21 | | '=' -> "EQ" 22 | | ':' -> "CO" 23 | | '/' -> "FS" 24 | | '*' -> "AX" 25 | | '.' -> "DT" 26 | | '&' -> "AM" 27 | | a -> failwith ("Non-infixable char" ^ string_of_int (int_of_char c)) 28 | 29 | let sub_infix infix = 30 | match String.sub infix 0 1 with 31 | | "(" -> 32 | let rec to_list c = 33 | match c with 34 | | "" -> [] 35 | | c -> c.[0] :: to_list (String.sub c 1 (String.length c - 1)) 36 | in 37 | infix |> to_list |> List.map map_infix_char |> String.concat "_" 38 | | _ -> infix 39 | 40 | let rec make_literal = function 41 | | Literal.Int i -> string_of_int i 42 | | Literal.Float f -> string_of_float f 43 | | Literal.Boolean true -> "true" 44 | | Literal.Boolean false -> "false" 45 | | Literal.String s -> "\"" ^ s ^ "\"" (* TODO - quote this *) 46 | | Literal.Tuple t -> tuple t 47 | | Literal.ConsCell (this, rest) -> 48 | let this_val = make_expr this in 49 | let rest_val = 50 | match rest.expr with 51 | | Expr.Literal Literal.EmptyList -> "{}" 52 | | _ -> make_expr rest 53 | in 54 | sprintf "{ value = %s, next = %s }" this_val rest_val 55 | | Literal.EmptyList -> "{}" 56 | | Literal.Record fields -> 57 | let fstring = 58 | List.map 59 | (fun (name, expr) -> sprintf "%s = %s" name (make_expr expr)) 60 | fields 61 | |> String.concat ", " 62 | in 63 | "{" ^ fstring ^ ", _type='record'}" 64 | 65 | and make_lambda {Lambda.arg; body} = 66 | sprintf "function (%s) return (%s) end\n" arg (make_expr body) 67 | 68 | and tuple t = 69 | let parts = List.map make_expr t in 70 | "{" ^ String.concat ", " parts ^ ", _type='tuple'}" 71 | 72 | and make_binop op args = 73 | let exprs = List.map make_expr args in 74 | match exprs with 75 | | [] -> failwith "Cannot call a binop with less than two args!" 76 | | [_one] -> failwith "Cannot call a binop with less than two args!" 77 | | initial :: rest -> 78 | sprintf "((%s) %s (%s))" initial op (String.concat "," rest) 79 | 80 | and make_call {Call.module_; fun_; args} = 81 | match (module_, fun_) with 82 | | "lua", "+" -> make_binop "+" args 83 | | "lua", "-" -> make_binop "-" args 84 | | "lua", "*" -> make_binop "*" args 85 | | "lua", "/" -> make_binop "/" args 86 | | "lua", "+." -> make_binop "+" args 87 | | "lua", "==" -> make_binop "==" args 88 | | "lua", "~=" -> make_binop "~=" args 89 | | "lua", ">" -> make_binop ">" args 90 | | "lua", "<" -> make_binop "<" args 91 | | "lua", "%" -> make_binop "%" args 92 | | "lua", "and" -> make_binop "and" args 93 | | "lua", "or" -> make_binop "or" args 94 | | "lua", _ -> 95 | List.map make_expr args |> String.concat "," |> sprintf "%s(%s)" fun_ 96 | | _ -> 97 | List.map make_expr args |> String.concat "," 98 | |> sprintf "%s.%s(%s)" module_ fun_ 99 | 100 | and make_apply {Apply.expr; arg} = 101 | sprintf "(%s)(%s)" (make_expr expr) (make_expr arg) 102 | 103 | and make_let {Let.name; bound_expr; expr} = 104 | let bexpr_var = make_expr bound_expr in 105 | let expr_var = make_expr expr in 106 | sprintf 107 | "((function () local %s = (%s) local __result__ = (%s) return __result__ \ 108 | end)())" 109 | (sub_infix name) bexpr_var expr_var 110 | 111 | and make_match {Match.expr; clauses} = 112 | let expr_str = make_expr expr in 113 | let name = gen_sym () in 114 | let patterns = List.map (make_clauses name) clauses in 115 | (* wrap in a function so we can short circuit with `return` *) 116 | sprintf "(function (%s) \n\t%s \n\tend\n)(%s)" name 117 | (String.concat "\n\t" patterns) 118 | expr_str 119 | 120 | and make_clauses name {MatchClause.pattern; MatchClause.result} = 121 | let skip_ident = gen_sym () in 122 | let rec make_checks name pat = 123 | match pat with 124 | | MatchPattern.Boolean b -> 125 | ([], [sprintf "(%s == %s)" name (string_of_bool b)]) 126 | | MatchPattern.Int v -> ([], [sprintf "(%s == %s)" name (string_of_int v)]) 127 | | MatchPattern.Float f -> 128 | ([], [sprintf "(%s == %s)" name (string_of_float f)]) 129 | | MatchPattern.String s -> 130 | (* TODO - need to escape strings *) 131 | ([], [sprintf "(%s == \"%s\")" name s]) 132 | | MatchPattern.Tuple t_items -> 133 | List.mapi 134 | (fun index pat -> 135 | let new_name = gen_sym () in 136 | (* Lua indexes from 1, not 0... *) 137 | let binding = 138 | sprintf "local %s = %s[%s]" new_name name 139 | (string_of_int (index + 1)) 140 | in 141 | let bindings, checks = make_checks new_name pat in 142 | (bindings @ [binding], checks) ) 143 | t_items 144 | |> List.fold_left (fun (a, b) (x, y) -> (x @ a, b @ y)) ([], []) 145 | | MatchPattern.Binding b -> 146 | let binding = sprintf "local %s = %s" b name in 147 | ([binding], ["true"]) 148 | | MatchPattern.Cons (value, next) -> 149 | let val_name = gen_sym () in 150 | let val_binding = 151 | sprintf "if %s.value == nil then goto %s end\n\tlocal %s = %s.value" 152 | name skip_ident val_name name 153 | in 154 | let next_name = gen_sym () in 155 | let next_binding = sprintf "local %s = %s.next" next_name name in 156 | let bindings1, checks1 = make_checks val_name value in 157 | let bindings2, checks2 = make_checks next_name next in 158 | (bindings1 @ bindings2 @ [next_binding; val_binding], checks1 @ checks2) 159 | | MatchPattern.EmptyList -> ([], [sprintf "%s.value == nil" name]) 160 | | MatchPattern.Record items -> 161 | List.map 162 | (fun (field, pat) -> 163 | let new_name = gen_sym () in 164 | let binding = sprintf "local %s = (%s).%s" new_name name field in 165 | let bindings, checks = make_checks new_name pat in 166 | (bindings @ [binding], checks) ) 167 | items 168 | |> List.fold_left (fun (a, b) (x, y) -> (x @ a, b @ y)) ([], []) 169 | | MatchPattern.Constructor (cname, args) -> 170 | let args = MatchPattern.String cname :: args in 171 | (* These are very similar to tuples, but with an initial string argument 172 | with the name of the ADT *) 173 | List.mapi 174 | (fun index pat -> 175 | let new_name = gen_sym () in 176 | (* Lua indexes from 1, not 0... *) 177 | let binding = 178 | sprintf "local %s = %s[%s]" new_name name 179 | (string_of_int (index + 1)) 180 | in 181 | let bindings, checks = make_checks new_name pat in 182 | (bindings @ [binding], checks) ) 183 | args 184 | |> List.fold_left (fun (a, b) (x, y) -> (x @ a, b @ y)) ([], []) 185 | in 186 | let bindings, checks = make_checks name pattern in 187 | let binding_str = String.concat " " (List.rev bindings) in 188 | let check_str = String.concat " and " checks in 189 | let res = make_expr result in 190 | sprintf "do %s\n\tif %s then return %s end end ::%s::" binding_str check_str 191 | res skip_ident 192 | 193 | and make_adtcons {AdtConstructor.type_; name; args} = 194 | (* TODO - we should definitely be qualifying it like this *) 195 | (* let type_string = sprintf "\"%s.%s\"" type_ name in *) 196 | let type_string = sprintf "\"%s\"" name in 197 | let arg_vals = List.map make_expr args in 198 | let inner = 199 | "_type=\"adt\"" :: type_string :: arg_vals 200 | |> List.filter (fun x -> x <> "") 201 | |> String.concat ", " 202 | in 203 | "{" ^ inner ^ "}" 204 | 205 | and make_recordaccess (expr, field) = 206 | let expr_string = make_expr expr in 207 | sprintf "(%s).%s" expr_string field 208 | 209 | and make_recordupdate (expr, fields) = 210 | let expr_string = make_expr expr in 211 | (* TODO - we shouldn't bother copying the old fields *) 212 | let copy_string = 213 | sprintf 214 | "\n \ 215 | local new_table = {}\n \ 216 | for k, v in pairs(%s) do\n \ 217 | new_table[k] = v\n \ 218 | end\n \ 219 | " 220 | expr_string 221 | in 222 | let new_fields = 223 | List.map 224 | (fun (f, e) -> 225 | let new_field_expr = make_expr e in 226 | sprintf "new_table.%s = %s" f new_field_expr ) 227 | fields 228 | |> String.concat "\n" 229 | in 230 | sprintf "((function() %s %s return new_table end)())" copy_string new_fields 231 | 232 | and make_expr (node: Node.t) = 233 | match node.expr with 234 | | Literal l -> make_literal l 235 | | Lambda l -> make_lambda l 236 | | Call c -> make_call c 237 | | Identifier {module_= {contents= Some m}; name} -> m ^ "." ^ sub_infix name 238 | | Identifier {name} -> sub_infix name 239 | | Apply a -> make_apply a 240 | | Let l -> make_let l 241 | | Match m -> make_match m 242 | | AdtConstructor c -> make_adtcons c 243 | | RecordAccess a -> make_recordaccess a 244 | | RecordUpdate u -> make_recordupdate u 245 | | Unit -> "nil" 246 | 247 | let real_type t = 248 | match t with 249 | | Ast.Type.TypeArg arg -> ( 250 | match !(arg.instance) with Some something -> something | _ -> t ) 251 | | _ -> t 252 | 253 | let make_fun_version name (version: TypedNode.t) = 254 | let name = sub_infix name in 255 | sprintf "local %s %s = %s\n" name name (make_expr version.node) 256 | 257 | let get_binding_arity t = match real_type t with Type.Arrow _ -> 1 | _ -> 0 258 | 259 | let make_export (binding: Binding.t) = 260 | sprintf "%s = %s" (sub_infix binding.name) (sub_infix binding.name) 261 | 262 | let make_binding (binding: Binding.t) = 263 | make_fun_version binding.name binding.expr 264 | 265 | let make_module (module_: Module.t) = 266 | let bindings = List.map make_binding module_.bindings |> List.rev in 267 | let exports = List.map make_export module_.bindings in 268 | let binding_list = String.concat "\n " bindings in 269 | let export_list = String.concat "," exports in 270 | sprintf "local %s = (function() \n %s \n %s\n return {%s} end)()" 271 | module_.name module_.verbatim binding_list export_list 272 | -------------------------------------------------------------------------------- /lib/config/discover.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Stdio 3 | 4 | module C = Configurator 5 | 6 | let possibles : (string list) = 7 | ["lua"; "lua5.3"; "lua5.2"] 8 | 9 | let write_sexp fn sexp = 10 | Out_channel.write_all fn ~data:(Sexp.to_string sexp) 11 | 12 | let find_package (pc : C.Pkg_config.t) default = 13 | let rec inner possibles = 14 | match possibles with 15 | | [] -> default 16 | | hd :: t -> 17 | (match C.Pkg_config.query pc ~package: hd with 18 | | Some pkg -> pkg 19 | | None -> inner t) 20 | in 21 | inner possibles 22 | 23 | let () = 24 | C.main ~name:"lua" (fun c -> 25 | let default : C.Pkg_config.package_conf = 26 | { libs = [] 27 | ; cflags = [] 28 | } 29 | in 30 | let conf = 31 | match C.Pkg_config.get c with 32 | | None -> default 33 | | Some pc -> 34 | find_package pc default 35 | in 36 | 37 | write_sexp "c_flags.sexp" (sexp_of_list sexp_of_string ("-Wno-discarded-qualifiers" :: conf.cflags)); 38 | write_sexp "c_library_flags.sexp" (sexp_of_list sexp_of_string conf.libs)) 39 | -------------------------------------------------------------------------------- /lib/config/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executable 4 | ((name discover) 5 | (libraries (base stdio configurator)))) 6 | -------------------------------------------------------------------------------- /lib/exhaustive.ml: -------------------------------------------------------------------------------- 1 | open Ast.MatchPattern 2 | open Ast 3 | 4 | type node = {value: string; child: tree; sibling: tree; span: int; args: int} 5 | 6 | and tree = Empty | Node of node 7 | 8 | type path_element = Child of string | Sibling of string 9 | 10 | let rec debug_path path = 11 | match path with 12 | | h :: t -> ( 13 | match h with 14 | | Child s -> "Child " ^ s ^ " -> " ^ debug_path t 15 | | Sibling s -> "Sibling " ^ s ^ " -> " ^ debug_path t ) 16 | | [] -> "ø" 17 | 18 | type path = path_element list 19 | 20 | let debug_pat pat : string = 21 | let rec inner pat level = 22 | match pat with 23 | | Empty -> "ø" 24 | | Node {value; child; sibling; span; args} -> 25 | value ^ " -> " 26 | ^ inner sibling (level + String.length value + 4) 27 | ^ "\n" ^ String.make level ' ' ^ "|- " 28 | ^ inner child (level + 3) 29 | in 30 | inner pat 0 31 | 32 | let andThen f node = match node with Node n -> f n | Empty -> Empty 33 | 34 | let rec get_in_tree path tree = 35 | match path with 36 | | [] -> tree 37 | | el :: rest -> 38 | match el with 39 | | Child v -> 40 | tree 41 | |> andThen (fun n -> 42 | n.child 43 | |> andThen (fun child -> 44 | if v = n.value || n.value = "Binding" then 45 | get_in_tree rest (Node child) 46 | else Empty ) ) 47 | | Sibling v -> 48 | tree 49 | |> andThen (fun n -> 50 | n.sibling 51 | |> andThen (fun sibling -> 52 | if v = n.value || n.value = "Binding" then 53 | get_in_tree rest (Node sibling) 54 | else Empty ) ) 55 | 56 | let rec isExhaustive pat pats path noSpan = 57 | match pat with 58 | | Empty -> false 59 | | Node {value; child; sibling; span; args} -> 60 | let childrenExhaustive = 61 | match args > 0 with 62 | | true -> isExhaustive child pats (path @ [Child value]) false 63 | | false -> true 64 | in 65 | let siblingExhaustive = 66 | match sibling with 67 | | Empty -> true 68 | | Node n -> isExhaustive sibling pats (path @ [Sibling value]) false 69 | in 70 | let spanExhaustive = 71 | match (span > 0, noSpan) with 72 | (* TODO - if any of the 'spans' are a capture, we've captured everything *) 73 | (* TODO - check this isn't short cutting sibling checks - shouldn't be tho *) 74 | | true, false -> 75 | (* Get all variants that match the same path *) 76 | let variantsAll = List.map (get_in_tree path) pats in 77 | let variants = 78 | variantsAll 79 | |> List.filter (fun x -> isExhaustive x pats path true) 80 | in 81 | let values = 82 | List.map 83 | (fun x -> match x with Empty -> "" | Node n -> n.value) 84 | variants 85 | |> List.filter (( != ) "") 86 | |> List.sort_uniq String.compare 87 | in 88 | let any_bindings = List.exists (( = ) "Binding") values in 89 | (* 90 | print_endline (String.concat ", " values); 91 | print_endline ("Any bindings?" ^ (string_of_bool any_bindings)); 92 | print_endline (debug_path path); *) 93 | List.length values = span || any_bindings 94 | | _ -> true 95 | in 96 | spanExhaustive && siblingExhaustive && childrenExhaustive 97 | 98 | let rec make_tuple_pat types els = 99 | match els with 100 | | [] -> Empty 101 | | h :: t -> Node {(build_tree types h) with sibling= make_tuple_pat types t} 102 | 103 | and make_record_pat types els = 104 | match els with 105 | | [] -> Empty 106 | | (name, h) :: t -> 107 | (* TODO - I'm pretty sure this strategy is bogus *) 108 | let child = build_tree types h in 109 | let child = 110 | { child with 111 | sibling= make_record_pat types t; value= name ^ "=" ^ child.value } 112 | in 113 | Node child 114 | 115 | and build_tree types pat = 116 | match pat with 117 | | Int i -> 118 | { value= "Int " ^ string_of_int i 119 | ; args= 0 120 | ; span= max_int 121 | ; child= Empty 122 | ; sibling= Empty } 123 | | Float f -> 124 | { value= "Float " ^ string_of_float f 125 | ; args= 0 126 | ; span= max_int 127 | ; child= Empty 128 | ; sibling= Empty } 129 | | String s -> 130 | { value= "String " ^ s 131 | ; args= 0 132 | ; span= max_int 133 | ; child= Empty 134 | ; sibling= Empty } 135 | | Binding _ -> 136 | {value= "Binding"; args= 0; span= 0; child= Empty; sibling= Empty} 137 | | Boolean b -> 138 | { value= "Bool " ^ string_of_bool b 139 | ; args= 0 140 | ; span= 2 141 | ; child= Empty 142 | ; sibling= Empty } 143 | | Tuple t -> 144 | { value= "Tuple" 145 | ; args= List.length t 146 | ; span= 0 147 | ; sibling= Empty 148 | ; child= make_tuple_pat types t } 149 | | EmptyList -> 150 | {value= "EmptyList"; args= 0; span= 2; child= Empty; sibling= Empty} 151 | | Record items -> 152 | { value= "Record" 153 | ; span= 0 154 | ; args= List.length items 155 | ; sibling= Empty 156 | ; child= make_record_pat types items } 157 | | Cons (h, t) -> 158 | let value = build_tree types h in 159 | { value= "Cons" 160 | ; args= 2 161 | ; span= 2 162 | ; sibling= Empty 163 | ; child= Node {value with sibling= Node (build_tree types t)} } 164 | | Constructor (name, args) -> 165 | (* We need to find both the type and the particular variant: 166 | - the type so we know how many variants (SPAN); 167 | - the variant so we know how many args it takes (ARGS) *) 168 | let adt, variant = 169 | match Module.find_constructor types name with 170 | | Some res -> res 171 | | None -> failwith "Bad constructor during exhaustive check" 172 | in 173 | let argc, span = 174 | (List.length adt.variants, List.length variant.Variant.args) 175 | in 176 | { value= "Constructor " ^ name 177 | ; span 178 | ; args= argc 179 | ; sibling= Empty 180 | ; child= make_tuple_pat types args } 181 | 182 | let check_match types m = 183 | let tree = List.map (fun x -> Node (build_tree types x)) m in 184 | (* let _ = tree |> List.iter (fun t -> debug_pat t |> print_endline; print_newline ();) in *) 185 | let head = List.hd tree in 186 | isExhaustive head tree [] false 187 | 188 | let rec find_match {Ast.Node.expr; source} (types: NamedType.t list) = 189 | let option_or x y = match x with Some thing -> Some thing | None -> y in 190 | match expr with 191 | | Ast.Expr.Let {bound_expr; expr} -> 192 | find_match bound_expr types |> option_or (find_match expr types) 193 | | Ast.Expr.Match {clauses} -> 194 | if 195 | check_match types 196 | (List.map (function {Ast.MatchClause.pattern} -> pattern) clauses) 197 | = false 198 | then 199 | Some 200 | {Ast.Error.error= Ast.Error.Inexhaustive "Missing patterns"; source} 201 | else None 202 | | Ast.Expr.Lambda {body} -> find_match body types 203 | | _ -> None 204 | 205 | let rec check_bindings (bindings: Ast.Binding.t list) 206 | (types: Ast.NamedType.t list) = 207 | match bindings with 208 | | [] -> None 209 | | h :: t -> 210 | match find_match h.expr.node types with Some err -> Some err | _ -> None 211 | 212 | let check_module (mod_: Ast.Module.t) = 213 | match check_bindings mod_.bindings mod_.types with 214 | | Some err -> Error err 215 | | None -> Ok mod_ 216 | -------------------------------------------------------------------------------- /lib/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (library ( 4 | (name lib) 5 | (c_names (lua)) 6 | (c_flags (:include c_flags.sexp)) 7 | (flags (:standard -warn-error +8)) 8 | (c_library_flags (:include c_library_flags.sexp)) 9 | (preprocess (pps (ppx_jane))) 10 | (libraries (str core ANSITerminal ocamlgraph)))) 11 | 12 | (rule 13 | ((targets (c_flags.sexp 14 | c_library_flags.sexp)) 15 | (deps (config/discover.exe)) 16 | (action (run ${<} -ocamlc ${OCAMLC})))) 17 | 18 | (ocamllex (lexer)) 19 | 20 | (menhir 21 | ((flags ("-v" "--strict" "--explain")) 22 | (modules (parser)))) 23 | -------------------------------------------------------------------------------- /lib/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Parser 4 | 5 | exception SyntaxError of string 6 | 7 | let next_line lexbuf = 8 | let pos = lexbuf.lex_curr_p in 9 | lexbuf.lex_curr_p <- 10 | { pos with pos_bol = lexbuf.lex_curr_pos; 11 | pos_lnum = pos.pos_lnum + 1 12 | } 13 | 14 | let drop_initial str = 15 | String.sub str 1 ((String.length str) - 1) 16 | 17 | let make_field_magic drop str = 18 | let drop_len = (String.length drop) + 1 in 19 | let base = String.sub str drop_len ((String.length str) - drop_len) in 20 | let first = String.sub base 0 1 in 21 | let rest = String.sub base 1 ((String.length base) - 1) in 22 | (first |> String.lowercase_ascii) ^ rest 23 | 24 | 25 | let split_verbatim str = 26 | let open Str in 27 | let open String in 28 | let splitter = split (regexp "[ \n\r\t]") in 29 | match splitter str with 30 | | hd :: tail -> 31 | let code = tail |> concat " " in 32 | let code = sub code 0 ((length code) - 2) in 33 | let type_ = sub hd 2 ((length hd) - 2) in 34 | VERBATIM (type_, code) 35 | | _ -> failwith "Bad verbatim definition" 36 | 37 | } 38 | 39 | let int = '-'? ['0'-'9'] ['0'-'9']* 40 | let digit = ['0'-'9'] 41 | let frac = "." digit* 42 | let exp = ['e' 'E'] ['-' '+']? digit+ 43 | let float = digit* frac? exp? 44 | 45 | let white = [' ' '\t']+ 46 | let newline = '\r' | '\n' | "\r\n" 47 | let whitespace_only_line = white* newline 48 | 49 | let ident = ['a'-'z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* 50 | let dot_ident = '.' ['a'-'z'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* 51 | let up_ident = ['A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* 52 | let up_ident_dot = ['A'-'Z'] ['a'-'z' 'A'-'Z' '0'-'9' '_' '.']* 53 | let accessor = '#' "get" up_ident 54 | let setter = '#' "set" up_ident 55 | let updater = '#' "update" up_ident 56 | 57 | 58 | let callref = ['@'] ['a'-'z' 'A'-'Z' '0'-'9' '_' '.' '+' '-' '=' '*' '/' '%' '>' '<' '~']* 59 | 60 | 61 | let verbatim = '[' '%' ['a'-'z']* "\\S"* _* '%' ']' 62 | 63 | let begin_statement = "^\\S" 64 | 65 | let comment = "--" ([^ '\r' '\n'])* 66 | 67 | rule read = 68 | parse 69 | | newline { next_line lexbuf; LINE_START } 70 | | comment { read lexbuf } 71 | | whitespace_only_line { next_line lexbuf; LINE_START } 72 | | white { WS } 73 | | verbatim { (split_verbatim (Lexing.lexeme lexbuf)) } 74 | | int { INT (int_of_string (Lexing.lexeme lexbuf)) } 75 | | "+." { INFIX "+." } 76 | | "*." { INFIX "*." } 77 | | float { FLOAT (float_of_string (Lexing.lexeme lexbuf)) } 78 | | ".." { POLY } 79 | | "true" { TRUE } 80 | | "false" { FALSE } 81 | | "match" { MATCH } 82 | | "with" { WITH } 83 | | '"' { read_string (Buffer.create 17) lexbuf } 84 | | "()" { UNIT } 85 | | '(' { LEFT_PARENS } 86 | | ')' { RIGHT_PARENS } 87 | | '{' { LEFT_BRACE } 88 | | '}' { RIGHT_BRACE } 89 | | '[' { LEFT_BRACK } 90 | | ']' { RIGHT_BRACK } 91 | | ':' { COLON } 92 | | ',' { COMMA } 93 | | '|' { PIPE } 94 | | "module" { MODULE } 95 | | "import" { IMPORT } 96 | | "let" { LET } 97 | | "match" { MATCH } 98 | | "with" { WITH } 99 | | "in" { IN } 100 | | "Int" { INT_TYPE } 101 | | "Float" { FLOAT_TYPE } 102 | | "Bool" { BOOLEAN_TYPE } 103 | | "type" { TYPE } 104 | | "typedef" { TYPEDEF } 105 | | "end" { ENDER } 106 | | callref { CALLREF (drop_initial (Lexing.lexeme lexbuf)) } 107 | | "==" { INFIX "==" } 108 | | "/=" { INFIX "/=" } 109 | | "++" { INFIX "++" } 110 | | "&&" { INFIX "&&" } 111 | | "||" { INFIX "||" } 112 | | "<|" { INFIXR "<|" } 113 | | ">>" { INFIX ">>" } 114 | | '=' { EQUALS } 115 | | "->" { ARROW } 116 | | '\\' { LAMBDA } 117 | | "::" { CONS_OP } 118 | | dot_ident{ DOT_IDENT (drop_initial (Lexing.lexeme lexbuf)) } 119 | | accessor { ACCESSOR (make_field_magic "get" (Lexing.lexeme lexbuf))} 120 | | setter { SETTER (make_field_magic "set" (Lexing.lexeme lexbuf))} 121 | | updater { UPDATER (make_field_magic "update" (Lexing.lexeme lexbuf))} 122 | | ident { IDENT (Lexing.lexeme lexbuf)} 123 | | "|>" { INFIX "|>" } 124 | | "<|" { INFIX "<|" } 125 | | up_ident { UPPER_IDENT (Lexing.lexeme lexbuf)} 126 | | up_ident_dot { UPPER_IDENT_DOT (Lexing.lexeme lexbuf) } (* TODO - check valid *) 127 | | '+' { INFIX "+" } 128 | | '-' { INFIX "-" } 129 | | '*' { INFIX "*" } 130 | | '/' { INFIX "/" } 131 | | '>' { INFIX ">" } 132 | | '<' { INFIX "<" } 133 | | eof { EOF } 134 | | _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf))} 135 | 136 | 137 | and read_string buf = 138 | parse 139 | | '"' { STRING (Buffer.contents buf) } 140 | | '\\' '/' { Buffer.add_char buf '/'; read_string buf lexbuf } 141 | | '\\' '\\' { Buffer.add_char buf '\\'; read_string buf lexbuf } 142 | | '\\' 'b' { Buffer.add_char buf '\b'; read_string buf lexbuf } 143 | | '\\' 'f' { Buffer.add_char buf '\012'; read_string buf lexbuf } 144 | | '\\' 'n' { Buffer.add_char buf '\n'; read_string buf lexbuf } 145 | | '\\' 'r' { Buffer.add_char buf '\r'; read_string buf lexbuf } 146 | | '\\' 't' { Buffer.add_char buf '\t'; read_string buf lexbuf } 147 | | [^ '"' '\\']+ 148 | { Buffer.add_string buf (Lexing.lexeme lexbuf); 149 | read_string buf lexbuf 150 | } 151 | | _ { raise (SyntaxError ("Illegal string character: " ^ Lexing.lexeme lexbuf)) } 152 | | eof { raise (SyntaxError ("String is not terminated")) } 153 | -------------------------------------------------------------------------------- /lib/lua.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | 10 | CAMLprim value 11 | caml_new_lua(value code) { 12 | lua_State *L = luaL_newstate(); /* opens Lua */ 13 | luaL_openlibs(L); 14 | 15 | return (value) L; 16 | } 17 | 18 | void 19 | caml_close_lua(value lua) { 20 | lua_State *L = (lua_State*) lua; 21 | lua_close(L); 22 | } 23 | 24 | CAMLprim value 25 | caml_exec_lua(value lua, value code) { 26 | int error; 27 | lua_State *L = (lua_State*) lua; 28 | char *val = String_val(code); 29 | 30 | error = luaL_loadbuffer(L, val, strlen(val), "line") || 31 | lua_pcall(L, 0, 0, 0); 32 | 33 | if (error) { 34 | printf("Got an error :(\n"); 35 | fprintf(stdout, "Message: %s\n", lua_tostring(L, -1)); 36 | lua_pop(L, 1); /* pop error message from the stack */ 37 | } 38 | 39 | return 0; 40 | } 41 | 42 | CAMLprim value 43 | caml_get_string(value lua, value name) { 44 | char *object_name = String_val(name); 45 | lua_State *L = (lua_State*) lua; 46 | lua_getglobal(L, object_name); 47 | char *string_value = lua_tostring(L, -1); 48 | return caml_copy_string(string_value); 49 | } 50 | -------------------------------------------------------------------------------- /lib/lua.ml: -------------------------------------------------------------------------------- 1 | type lua 2 | 3 | external run_lua : lua -> string -> unit = "caml_exec_lua" 4 | 5 | external new_lua : unit -> lua = "caml_new_lua" 6 | 7 | external get_global_string : lua -> string -> string = "caml_get_string" 8 | 9 | let exec_lua lua code = run_lua lua code 10 | -------------------------------------------------------------------------------- /lib/parser.mly: -------------------------------------------------------------------------------- 1 | %{ open Ast %} 2 | 3 | %token INT 4 | %token FLOAT 5 | %token STRING 6 | %token IDENT 7 | %token DOT_IDENT 8 | %token UPPER_IDENT 9 | %token UPPER_IDENT_DOT 10 | %token CALLREF 11 | %token LINE_START 12 | %token INDENT0 13 | %token WS 14 | %token EQUALS 15 | %token LET 16 | %token MATCH 17 | %token MODULE 18 | %token IMPORT 19 | %token WITH 20 | %token IN 21 | %token INT_TYPE 22 | %token FLOAT_TYPE 23 | %token BOOLEAN_TYPE 24 | %token TRUE 25 | %token FALSE 26 | %token LEFT_PARENS 27 | %token RIGHT_PARENS 28 | %token LEFT_BRACE 29 | %token RIGHT_BRACE 30 | %token LEFT_BRACK 31 | %token RIGHT_BRACK 32 | %token POLY 33 | %token COLON 34 | %token CONS_OP 35 | %token COMMA 36 | %token LAMBDA 37 | %token PIPE 38 | %token ARROW 39 | %token ENDER 40 | %token EOF 41 | %token TYPE 42 | %token UNIT 43 | %token TYPEDEF 44 | %token INFIX 45 | %token INFIXR 46 | %token VERBATIM 47 | %token ACCESSOR 48 | %token SETTER 49 | %token UPDATER 50 | 51 | %nonassoc IN 52 | %right CONS_OP 53 | %left INFIX 54 | %right INFIXR 55 | 56 | %{ open Ast %} 57 | %{ open Parser_utils %} 58 | 59 | %start prog 60 | 61 | %% 62 | 63 | prog: 64 | | EOF { None } 65 | | s = statement { Some s } 66 | | WS { failwith "Ignored token found" } 67 | | LINE_START { failwith "Ignored token found" } 68 | ; 69 | 70 | 71 | statement: 72 | | MODULE; name = module_name; end_statement 73 | { Statement.Module { name = name; } } 74 | | IMPORT; name = module_name; qualified = qualified_imports; end_statement 75 | { Statement.Import { Import.module_ = name; qualified } } 76 | | name = ident; EQUALS; expression = expr; end_statement 77 | { Statement.Let { name = name; expr = expression } } 78 | | name = ident; args = arglist; EQUALS; expression = expr; end_statement 79 | { Statement.Let { name = name; expr = curry_function args expression (pos $startpos) } } 80 | | name = ident; COLON; type_ = type_expr; end_statement 81 | { Statement.TypeSignature { name; type_; } } 82 | | TYPE; name = UPPER_IDENT; args = type_arg_list; EQUALS; variants = variant_list; end_statement 83 | { Statement.Type { name = name; type_ = Type.Adt ({ Adt.name; args; variants }) |> match_up_typeargs args } } 84 | | TYPEDEF; name = UPPER_IDENT; args = type_arg_list; EQUALS; type_ = type_expr; end_statement 85 | { 86 | let type_ = match_up_typeargs args type_ in 87 | Statement.Type { name = name; type_ = Type.Alias { name = name; type_; args } } } 88 | | v = VERBATIM; end_statement 89 | { let name, code = v in 90 | Statement.Verbatim { name; code } } 91 | 92 | qualified_imports: 93 | | { [] } 94 | | LEFT_PARENS; idents = separated_nonempty_list(COMMA, ident); RIGHT_PARENS { idents } 95 | 96 | module_name: 97 | | n = UPPER_IDENT { n } 98 | | n = UPPER_IDENT_DOT { n } 99 | 100 | end_statement: 101 | | INDENT0 { true } 102 | | EOF { true } 103 | 104 | ident: 105 | | s=IDENT { s } 106 | | LEFT_PARENS s=INFIX RIGHT_PARENS { "(" ^ s ^ ")" } 107 | | LEFT_PARENS s=INFIXR RIGHT_PARENS { "(" ^ s ^ ")" } 108 | | LEFT_PARENS CONS_OP RIGHT_PARENS { "(::)" } 109 | | u=UPPER_IDENT { u } 110 | | u=UPPER_IDENT_DOT { u } 111 | 112 | expr: 113 | | m = most_expr %prec IN { m } 114 | | LET; name = IDENT; args = arglist; EQUALS; expression = expr; IN; result = expr; end_statement 115 | { Node.make (Expr.Let { name = name; bound_expr = curry_function args expression (pos $startpos); expr = result }) (pos $startpos) } 116 | 117 | most_expr: 118 | | e = simple_expr { e } 119 | | m = match_ { m } 120 | | head=most_expr; CONS_OP; tail=most_expr; 121 | { Node.make (Expr.Literal (Literal.ConsCell (head, tail))) (pos $startpos) } 122 | | LAMBDA; args = arglist; ARROW; expression = expr 123 | { curry_function args expression (pos $startpos)} 124 | | callref = CALLREF; args = expr_list { make_call callref args (pos $startpos) } 125 | (* TODO - we write this out as a 'match' node but we should mark it as a let somehow for error reporting *) 126 | | LET; pattern = match_pattern; EQUALS; input=most_expr; IN; expr=expr; 127 | { Node.make (Expr.Match { Match.expr = input; clauses = [{ MatchClause.pattern = pattern; result = expr}]}) (pos $startpos)} 128 | 129 | simple_expr: 130 | | e = very_simple_expr; { e } 131 | | e1 = most_expr; i=INFIX; arg = most_expr; 132 | { let infix = Node.make (Expr.Identifier 133 | (Identifier.make ("(" ^ i ^ ")") (ref IdentType.Unknown))) 134 | (pos $startpos) in 135 | make_apply infix ([arg; e1]) (pos $startpos)} 136 | | e1 = most_expr; i=INFIXR; arg = most_expr; 137 | { let infix = Node.make (Expr.Identifier 138 | (Identifier.make ("(" ^ i ^ ")") (ref IdentType.Unknown))) 139 | (pos $startpos) in 140 | make_apply infix ([arg; e1]) (pos $startpos)} 141 | 142 | | callable = very_simple_expr; args = expr_list; 143 | { make_apply callable (List.rev args) (pos $startpos) } 144 | 145 | very_simple_expr: 146 | | UNIT { Node.make Expr.Unit (pos $startpos) } 147 | | LEFT_PARENS; e = expr; RIGHT_PARENS { e } 148 | | i = INT { Node.make (Expr.Literal (Literal.Int i)) (pos $startpos) } 149 | | f = FLOAT { Node.make (Expr.Literal (Literal.Float f)) (pos $startpos) } 150 | | TRUE { Node.make (Expr.Literal (Literal.Boolean true)) (pos $startpos) } 151 | | FALSE { Node.make (Expr.Literal (Literal.Boolean false)) (pos $startpos) } 152 | | s = STRING { Node.make (Expr.Literal (Literal.String s)) (pos $startpos) } 153 | | symbol = ident { Node.make (Expr.Identifier (Identifier.make symbol (ref IdentType.Unknown))) (pos $startpos) } 154 | | l = list_expr { l } 155 | | r = record { r } 156 | | expr = very_simple_expr; i = DOT_IDENT; { Node.make (Expr.RecordAccess (expr, i)) (pos $startpos) } 157 | | field = ACCESSOR { 158 | let ident_name, ident = gen_ident (pos $startpos) in 159 | let accessor = Node.make (Expr.RecordAccess (ident, field)) (pos $startpos) in 160 | Node.make (Expr.Lambda { arg = ident_name; body = accessor }) (pos $startpos) 161 | } 162 | | field = SETTER { 163 | let record_name, record = gen_ident (pos $startpos) in 164 | let value_name, value = gen_ident (pos $startpos) in 165 | let setter = Node.make (Expr.RecordUpdate (record, [(field, value)])) (pos $startpos) in 166 | let setNode = Node.make (Expr.Lambda { arg = record_name; body = setter }) (pos $startpos) in 167 | Node.make (Expr.Lambda { arg = value_name ; body = setNode }) (pos $startpos) 168 | } 169 | | field = UPDATER { 170 | let record_name, record = gen_ident (pos $startpos) in 171 | let fun_name, fun_ident = gen_ident (pos $startpos) in 172 | let accessor = Node.make (Expr.RecordAccess (record, field)) (pos $startpos) in 173 | let updated_value = Node.make (Expr.Apply { arg = accessor; expr = fun_ident }) (pos $startpos) in 174 | let setter = Node.make (Expr.RecordUpdate (record, [(field, updated_value)])) (pos $startpos) in 175 | let setNode = Node.make (Expr.Lambda { arg = record_name; body = setter }) (pos $startpos) in 176 | Node.make (Expr.Lambda { arg = fun_name; body = setNode }) (pos $startpos) 177 | } 178 | 179 | | r = record_update { r } 180 | | t = tuple { t } 181 | 182 | match_: 183 | MATCH; input = most_expr; WITH; clauses = match_clauses; ENDER 184 | { Node.make (Expr.Match { Match.expr = input; clauses = clauses } ) (pos $startpos) } 185 | 186 | match_clauses: 187 | items = separated_nonempty_list(PIPE, match_clause) { items } 188 | 189 | match_clause: 190 | pat = match_pattern; ARROW; result = most_expr 191 | { { MatchClause.pattern = pat; result; } } 192 | 193 | match_pattern: 194 | | p = simple_pattern { p } 195 | | t = tuple_pat { t } 196 | | c = cons_pat { c } 197 | | l = list_pat { l } 198 | | r = record_pat { r } 199 | | constructor = constructor_pat { constructor } 200 | 201 | 202 | simple_pattern: 203 | | i = INT { MatchPattern.Int i } 204 | | f = FLOAT { MatchPattern.Float f } 205 | | TRUE { MatchPattern.Boolean true } 206 | | FALSE { MatchPattern.Boolean false } 207 | | symbol = IDENT { MatchPattern.Binding symbol } 208 | | c = simple_constructor_pat { c } 209 | | LEFT_PARENS; pat = match_pattern; RIGHT_PARENS; { pat } 210 | | s = STRING { MatchPattern.String s } 211 | 212 | tuple_pat: 213 | | items = tuple_pat_items; { MatchPattern.Tuple items } 214 | 215 | tuple_pat_items: 216 | | p1 = simple_pattern; COMMA; p2 = simple_pattern; {[p1; p2]} 217 | | p1 = simple_pattern; COMMA; items = tuple_pat_items { p1 :: items } 218 | 219 | constructor_pat: 220 | | name = UPPER_IDENT; items = nonempty_list(simple_pattern); 221 | { MatchPattern.Constructor (name, items) } 222 | 223 | simple_constructor_pat: 224 | | name = UPPER_IDENT; 225 | { MatchPattern.Constructor (name, []) } 226 | 227 | cons_pat: 228 | | h = simple_pattern; CONS_OP; t = match_pattern 229 | { MatchPattern.Cons (h, t) } 230 | 231 | list_pat: LEFT_BRACK; items = separated_list(COMMA, simple_pattern); RIGHT_BRACK; 232 | { make_match_cons_literal (List.rev items) } 233 | 234 | record_pat: 235 | | LEFT_BRACE; items=separated_list(COMMA, record_match_field); RIGHT_BRACE { MatchPattern.Record items } 236 | 237 | record_match_field: 238 | | name = IDENT; EQUALS; pat = simple_pattern 239 | { ( name, pat ) } 240 | 241 | 242 | tuple: 243 | | LEFT_PARENS; items = tuple_items; RIGHT_PARENS 244 | { Node.make (Expr.Literal (Literal.Tuple items)) (pos $startpos) } 245 | 246 | (* Tuples must be a least n2 *) 247 | tuple_items: 248 | | e = simple_expr; COMMA; e2 = simple_expr; { [e; e2]} 249 | | e = simple_expr; COMMA; items = tuple_items { e :: items } 250 | 251 | record: 252 | | LEFT_BRACE; items = separated_list(COMMA, record_item); RIGHT_BRACE; 253 | { Node.make (Expr.Literal (Literal.Record items)) (pos $startpos)} 254 | 255 | record_item: 256 | | name = IDENT; EQUALS; e = simple_expr { (name, e) } 257 | 258 | record_update: 259 | | LEFT_BRACE; e = simple_expr; PIPE; items = separated_nonempty_list(COMMA, record_item); RIGHT_BRACE; 260 | { Node.make (Expr.RecordUpdate (e, items)) (pos $startpos)} 261 | 262 | list_expr: LEFT_BRACK; items = separated_list(COMMA, simple_expr); RIGHT_BRACK; 263 | { make_cons_literal items (pos $startpos) } 264 | 265 | 266 | expr_list: 267 | | e = very_simple_expr; exprs = expr_list 268 | { e :: exprs } 269 | | e = very_simple_expr 270 | { [e] } 271 | 272 | arglist: 273 | | arg = IDENT; args = arglist 274 | { arg :: args } 275 | | arg = IDENT 276 | { [arg] } 277 | 278 | type_expr: 279 | | t = separated_nonempty_list(ARROW, arrow_top_type) 280 | { make_fun_type t } 281 | | t = tuple_type { t } 282 | 283 | arrow_top_type: 284 | | t = simple_type { t } 285 | | name = UPPER_IDENT; args = nonempty_list(simple_type) 286 | { match name with 287 | (* TODO - should error if more than one type arg passed to hd! *) 288 | | "List" -> Type.List (List.hd args) 289 | | _ -> Type.UserType { name; args; type_ = None } } 290 | 291 | 292 | simple_type: 293 | | INT_TYPE { Type.Int } 294 | | FLOAT_TYPE { Type.Float } 295 | | BOOLEAN_TYPE { Type.Bool } 296 | | name = IDENT 297 | { let t = (TypeArg.make ()) in 298 | Type.TypeArg { t with TypeArg.name = Some name } } 299 | | LEFT_PARENS; t = type_expr; RIGHT_PARENS { t } 300 | | name = UPPER_IDENT; { 301 | match name with 302 | | "String" -> Type.String 303 | | _ -> Type.UserType { name; args = []; type_ = None } } 304 | | r = record_type { r } 305 | 306 | record_type: 307 | | LEFT_BRACE; fields = separated_nonempty_list(COMMA, record_field_type); PIPE; POLY; RIGHT_BRACE; 308 | { Type.PolyRecord { fields; poly = ref None } } 309 | | LEFT_BRACE; fields = separated_nonempty_list(COMMA, record_field_type); RIGHT_BRACE; 310 | { Type.Record { fields } } 311 | 312 | record_field_type: 313 | name = IDENT; COLON; t = simple_type { ( name, t ) } 314 | 315 | tuple_type: 316 | | parts = tuple_type_parts; { Type.Tuple parts } 317 | 318 | tuple_type_parts: 319 | | t1 = simple_type; COMMA; t2 = simple_type { [t1; t2 ] } 320 | | t = simple_type; COMMA; rest = tuple_type_parts { t :: rest } 321 | 322 | type_arg_list: 323 | types = list(IDENT) 324 | { types |> List.map (fun name -> 325 | let t = (TypeArg.make () ) in 326 | Type.TypeArg { t with TypeArg.name = Some name }) } 327 | 328 | variant_list: 329 | types = separated_list(PIPE, variant_def) { types } 330 | 331 | variant_def: 332 | | name = UPPER_IDENT; args = variant_def_list 333 | { { Variant.name = name; args } } 334 | 335 | variant_def_list: 336 | | /* empty */ { [] } 337 | | e = simple_type; rest = variant_def_list { e :: rest } 338 | -------------------------------------------------------------------------------- /lib/parser_utils.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Ast 3 | 4 | 5 | (* the failure cases for both these funs should normally be impossible *) 6 | let rec curry_function args expr source = 7 | match args with 8 | | [arg] -> Node.make (Expr.Lambda {arg; body= expr}) source 9 | | arg :: rest -> 10 | Node.make 11 | (Expr.Lambda {arg; body= curry_function rest expr source}) 12 | source 13 | | [] -> raise (failwith "Attempted to curry a zero-arg fun") 14 | 15 | let rec make_apply expr args src = 16 | match args with 17 | | [arg] -> Node.make (Expr.Apply {expr; arg}) src 18 | | arg :: rest -> 19 | Node.make (Expr.Apply {expr= make_apply expr rest src; arg}) src 20 | | [] -> raise (failwith "Attempted to apply with zero args") 21 | 22 | let make_call callref args position = 23 | match callref |> String.split_on_chars ~on: ['.'] |> List.rev with 24 | | fun_ :: module_parts -> 25 | let module_ = String.concat ~sep: "." module_parts in 26 | Node.make (Expr.Call {module_; fun_; args}) position 27 | | _ -> failwith "Bad call expr" 28 | 29 | let make_fun_type args = 30 | let module TArgMap = Map.Make (String) in 31 | let check_arg arg targ_map = 32 | match arg with 33 | | Type.TypeArg {TypeArg.name} -> ( 34 | let name = match name with Some v -> v | None -> "" in 35 | match TArgMap.mem targ_map name with 36 | | true -> (TArgMap.find_exn targ_map name, targ_map) 37 | | false -> (arg, TArgMap.set targ_map name arg) ) 38 | | _ -> (arg, targ_map) 39 | in 40 | let rec inner args targ_map = 41 | (* normalise all type args *) 42 | match args with 43 | | [arg] -> 44 | let arg, _ = check_arg arg targ_map in 45 | arg 46 | | arg :: rest -> 47 | let arg, targ_map = check_arg arg targ_map in 48 | Type.Arrow (arg, inner rest targ_map) 49 | | [] -> raise (failwith "Attempted to create funtype with 0 arity") 50 | in 51 | inner args TArgMap.empty 52 | 53 | let rec make_cons_literal items position = 54 | match items with 55 | | [] -> Node.make (Expr.Literal Literal.EmptyList) position 56 | | item :: rest -> 57 | Node.make 58 | (Expr.Literal 59 | (Literal.ConsCell (item, make_cons_literal rest position))) 60 | position 61 | 62 | let rec make_match_cons_literal items = 63 | match items with 64 | | [] -> MatchPattern.EmptyList 65 | | item :: rest -> MatchPattern.Cons (item, make_match_cons_literal rest) 66 | 67 | (* Switch out any typeargs defined for the type *) 68 | let rec match_up_typeargs (args: Type.t list) (type_: Type.t) = 69 | match type_ with 70 | | Adt adt -> 71 | (* First let's match against any typeargs in the list *) 72 | let adt_args = List.map ~f: (match_up_typeargs args) adt.args in 73 | (* Now let's match up against all variants *) 74 | let variants = 75 | List.map 76 | ~f: (fun variant -> 77 | let v_args = 78 | List.map ~f: (match_up_typeargs args) variant.Variant.args 79 | in 80 | {variant with args= v_args} ) 81 | adt.variants 82 | in 83 | Type.Adt {adt with args= adt_args; variants} 84 | | SelfRef {name; args} -> 85 | let args = List.map ~f: (match_up_typeargs args) args in 86 | Type.SelfRef {name; args} 87 | | Tuple parts -> Type.Tuple (List.map ~f: (match_up_typeargs args) parts) 88 | | UserType user_type -> 89 | let user_type_args = List.map ~f: (match_up_typeargs args) user_type.args in 90 | UserType {user_type with args= user_type_args} 91 | | Record record -> 92 | Type.Record 93 | { fields= 94 | List.map 95 | ~f: (fun (name, f) -> (name, match_up_typeargs args f)) 96 | record.fields } 97 | | PolyRecord record -> 98 | Type.PolyRecord 99 | { fields= 100 | List.map 101 | ~f: (fun (name, f) -> (name, match_up_typeargs args f)) 102 | record.fields 103 | ; poly= record.poly } 104 | | List t -> Type.List (match_up_typeargs args t) 105 | | Type.TypeArg arg -> ( 106 | try 107 | List.find_exn 108 | ~f: (function 109 | | Type.TypeArg targ -> targ.TypeArg.name = arg.TypeArg.name 110 | | _ -> failwith "Bad typearg type") 111 | args 112 | with Not_found -> 113 | raise 114 | (CompileError 115 | { Ast.Error.source= None 116 | ; error= 117 | Ast.Error.TypeParamMissing 118 | (match arg.name with Some n -> n | _ -> "?") }) ) 119 | | Type.Arrow (arg, expr) -> 120 | let arg = match_up_typeargs args arg in 121 | let expr = match_up_typeargs args expr in 122 | Type.Arrow (arg, expr) 123 | | other -> other 124 | 125 | let gen_ident pos = 126 | let alphanum = "abcdefghijklmnopqrstuvwxyz" in 127 | let len = String.length alphanum in 128 | let name = List.range 0 12 129 | |> List.map ~f: (fun _ -> String.get alphanum (Random.int len)) 130 | |> String.of_char_list in 131 | (name, Node.make (Expr.Identifier (Identifier.make name (ref IdentType.Unknown))) pos) 132 | 133 | let pos p = 134 | Ast.Source.Pos 135 | { Ast.Pos.file= p.Lexing.pos_fname 136 | ; char= p.pos_cnum - p.pos_bol 137 | ; line= p.pos_lnum } 138 | -------------------------------------------------------------------------------- /lib/parsing.ml: -------------------------------------------------------------------------------- 1 | open Ast 2 | open Lexing 3 | open Lexer 4 | 5 | let rec read_until_non_ws q lexbuf = 6 | match Lexer.read lexbuf with 7 | | WS -> Lexer.read lexbuf 8 | | LINE_START -> read_until_non_ws q lexbuf 9 | | other -> Queue.push other q ; Parser.INDENT0 10 | 11 | let reader () = 12 | let q = Queue.create () in 13 | let rec read lexbuf = 14 | match Queue.length q > 0 with 15 | | true -> Queue.pop q 16 | | false -> 17 | match Lexer.read lexbuf with 18 | | WS -> read lexbuf 19 | | LINE_START -> read_until_non_ws q lexbuf 20 | | other -> other 21 | in 22 | read 23 | 24 | let parse_with_error reader lexbuf = 25 | try Ok (Parser.prog reader lexbuf) with 26 | | SyntaxError msg -> 27 | let pos = lexbuf.lex_curr_p in 28 | Error 29 | { Error.source= 30 | Source.Pos 31 | { file= "__no_file__" 32 | ; line= pos.pos_lnum 33 | ; char= pos.pos_cnum - pos.pos_bol + 1 } 34 | ; error= Error.Syntax msg } 35 | | Parser.Error -> 36 | let pos = lexbuf.lex_curr_p in 37 | Error 38 | { Error.source= 39 | Source.Pos 40 | { file= "__no_file__" 41 | ; line= pos.pos_lnum 42 | ; char= pos.pos_cnum - pos.pos_bol + 1 } 43 | ; error= 44 | Error.Syntax ("Unexpected token '" ^ Lexing.lexeme lexbuf ^ "'") } 45 | | CompileError err -> Error err 46 | 47 | let parse_single_with_error lexbuf = parse_with_error (reader ()) lexbuf 48 | 49 | let parse_all_with_error lexbuf = 50 | let r = reader () in 51 | let rec inner statements = 52 | match parse_with_error r lexbuf with 53 | | Ok None -> Ok (List.rev statements) 54 | | Ok (Some statement) -> inner (statement :: statements) 55 | | Error err -> Error err 56 | in 57 | inner [] 58 | -------------------------------------------------------------------------------- /lib/project.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | (* Handle the building of source trees *) 4 | 5 | module Project = struct 6 | type t = 7 | {name: string; prelude: string sexp_option; output: string sexp_option} 8 | [@@deriving sexp] 9 | end 10 | 11 | module CompiledModule = struct 12 | type t = 13 | { name: string 14 | ; imports: string list 15 | ; statements: Ast.Statement.t list 16 | ; module_: Ast.Module.t option 17 | ; result: string option } 18 | [@@deriving sexp] 19 | end 20 | 21 | let rec gather extension dir = 22 | Caml.Sys.readdir dir |> Array.to_list 23 | |> List.concat_map ~f:(fun f -> 24 | let path = Filename.concat dir f in 25 | if Sys.is_directory path = `Yes then gather extension path 26 | else if Filename.check_suffix path extension then [path] 27 | else [] ) 28 | 29 | let parse_file f = 30 | In_channel.read_lines f |> String.concat ~sep:"\n" |> Lexing.from_string 31 | |> Parsing.parse_all_with_error 32 | 33 | let abort fn error = 34 | let open ANSITerminal in 35 | eprintf [Foreground Red] "Error: couldn't compile '%s':\n%s\n\n" fn 36 | (Ast.Error.format_error error) ; 37 | exit 1 38 | 39 | let rec parse_files = function 40 | | [] -> [] 41 | | h :: t -> 42 | match parse_file h with 43 | | Error err -> abort h err 44 | | Ok sts -> (h, sts) :: parse_files t 45 | 46 | let gather_imports (statements: Ast.Statement.t list) : string list = 47 | List.filter_map statements (function 48 | | Ast.Statement.Import import -> Some import.module_ 49 | | _ -> None ) 50 | 51 | let rec gather_mod_name = function 52 | | Ast.Statement.Module module_ :: _ -> module_.name 53 | | _ :: t -> gather_mod_name t 54 | | [] -> failwith "No module name" 55 | 56 | let rec init_module (fn, sts) : CompiledModule.t = 57 | let imports = gather_imports sts in 58 | let mod_name = gather_mod_name sts in 59 | {name= mod_name; statements= sts; module_= None; imports; result= None} 60 | 61 | let module_resolver mods name = 62 | let (mod_ : CompiledModule.t) = 63 | List.find_exn ~f:(fun m -> m.CompiledModule.name = name) mods 64 | in 65 | mod_.module_ |> Option.value_exn 66 | 67 | let type_module (built: CompiledModule.t list) (mod_: CompiledModule.t) : 68 | CompiledModule.t list = 69 | match 70 | Typer.type_statements mod_.statements 71 | ~module_resolver:(module_resolver built) 72 | with 73 | | Error err -> abort mod_.name err 74 | | Ok (env, typed_mod) -> {mod_ with module_= Some typed_mod} :: built 75 | 76 | let rec type_modules (mods: CompiledModule.t list) : CompiledModule.t list = 77 | List.fold_left ~f:type_module ~init:[] mods |> List.rev 78 | 79 | let compile_module mods (mod_: CompiledModule.t) : CompiledModule.t list = 80 | let result = Some (Compile.make_module (Option.value_exn mod_.module_)) in 81 | {mod_ with result} :: mods 82 | 83 | let rec compile_modules (mods: CompiledModule.t list) : CompiledModule.t list = 84 | List.fold_left ~init:[] ~f:compile_module mods 85 | 86 | let dependency_order (modules: CompiledModule.t list) = 87 | let module G = Graph.Imperative.Digraph.Abstract (struct 88 | type t = string 89 | end) in 90 | let module TP = Graph.Topological.Make (G) in 91 | let graph = G.create () in 92 | (* Create all vertices and store in a map *) 93 | let node_set = 94 | List.fold_left 95 | ~f:(fun acc (module_: CompiledModule.t) -> 96 | match String.Map.mem acc module_.name with 97 | | true -> acc 98 | | false -> 99 | let vec = G.V.create module_.name in 100 | G.add_vertex graph vec ; 101 | String.Map.set acc module_.name vec ) 102 | ~init:String.Map.empty modules 103 | in 104 | (* Add all edges - imperatively, hence iter *) 105 | List.iter modules ~f:(fun {name; imports} -> 106 | List.iter imports ~f:(fun import -> 107 | let v1 = String.Map.find_exn node_set name in 108 | let v2 = String.Map.find_exn node_set import in 109 | G.add_edge graph v1 v2 ) ) ; 110 | match modules with 111 | | [] -> [] 112 | | [mod_] -> [mod_.name] 113 | | _ -> TP.fold List.cons graph [] |> List.map ~f:G.V.label 114 | 115 | let build_tree ?(prelude: string option) src_dirs build_dirs output_dir = 116 | (* gather .ml files in src_dirs *) 117 | let source_files = src_dirs |> List.concat_map ~f:(gather ".ml") in 118 | (* gather .mlo files in build dirs*) 119 | let mlo_files = build_dirs |> List.concat_map ~f:(gather ".mlo") in 120 | let loader = Fn.compose CompiledModule.t_of_sexp Sexp.load_sexp in 121 | let built_modules = List.map ~f:loader mlo_files in 122 | (* TODO - determine if we have builds more recent than src *) 123 | (* TODO - can we avoid parsing source if the mlo_files are more recent? *) 124 | (* run an initial parse on new src to build, aborting if any syntax errors *) 125 | let parsed_statements = parse_files source_files in 126 | (* If we have a prelude, open it and prepend its statements to each module *) 127 | let prelude_statements = 128 | match prelude with 129 | | Some filename -> parse_file filename |> Result.ok |> Option.value_exn 130 | | _ -> [] 131 | in 132 | let parsed_statements = 133 | parsed_statements 134 | |> List.map ~f:(fun (name, statements) -> 135 | let statements = 136 | List.concat_map ~f:Ast.Statement.post_process statements 137 | in 138 | (name, prelude_statements @ statements) ) 139 | in 140 | (* TODO - determine dependencies from already built artefacts too *) 141 | (* TODO be aware of conflicts *) 142 | (* TODO determine if any dependencies now dirty and build artefacts require rebuilding *) 143 | (* Construct module objects from parsed statements *) 144 | let parsed_modules = List.map ~f:init_module parsed_statements in 145 | let all_modules = parsed_modules @ built_modules in 146 | (* Determine dependency order *) 147 | let deps_order = dependency_order all_modules in 148 | let ordered_modules = 149 | List.map deps_order (fun mod_name -> 150 | List.find_exn all_modules ~f:(fun {CompiledModule.name} -> 151 | mod_name = name ) ) 152 | in 153 | let typed_modules = type_modules ordered_modules in 154 | (* TODO - exhaustive check here!! *) 155 | let compiled_modules = 156 | compile_modules typed_modules 157 | |> List.filter ~f:(fun {CompiledModule.name} -> 158 | List.exists parsed_modules (fun mod_ -> 159 | mod_.CompiledModule.name = name ) ) 160 | in 161 | List.iter 162 | ~f:(fun m -> 163 | print_endline ("Compiled " ^ m.name) ; 164 | let filename = Filename.concat output_dir (m.name ^ ".mlo") in 165 | m |> CompiledModule.sexp_of_t |> Sexp.save_hum filename ) 166 | compiled_modules 167 | 168 | let link build_dirs output = 169 | let mlo_files = build_dirs |> List.concat_map ~f:(gather ".mlo") in 170 | let loader = Fn.compose CompiledModule.t_of_sexp Sexp.load_sexp in 171 | let modules = List.map ~f:loader mlo_files in 172 | let deps_order = dependency_order modules in 173 | let ordered_modules = 174 | List.map deps_order (fun mod_name -> 175 | let mod_ = 176 | List.find_exn modules ~f:(fun {CompiledModule.name} -> 177 | mod_name = name ) 178 | in 179 | Option.value_exn mod_.result ) 180 | in 181 | let mod_exports = 182 | deps_order |> List.map ~f:(fun s -> s ^ "=" ^ s) |> String.concat ~sep:"," 183 | in 184 | let module_export = "\n\n return {" ^ mod_exports ^ "}" in 185 | module_export 186 | |> ( ^ ) (String.concat ~sep:"\n\n" ordered_modules) 187 | |> Out_channel.write_all output 188 | 189 | let build_project (project: Project.t) = 190 | let () = Unix.mkdir_p ("build/" ^ project.name) in 191 | let prelude, prelude_dirs = 192 | match project.prelude with 193 | | None -> 194 | ( "/usr/local/lib/luml/stdlib/base.prelude" 195 | , ["/usr/local/lib/luml/stdlib/build"] ) 196 | | Some prelude -> (prelude, []) 197 | in 198 | build_tree ~prelude ["src"] ("build" :: prelude_dirs) 199 | ("build/" ^ project.name) ; 200 | link ("build" :: prelude_dirs) 201 | ("build/" ^ project.name ^ "/" ^ project.name ^ ".lua") ; 202 | project 203 | -------------------------------------------------------------------------------- /lib/project.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module CompiledModule : sig 4 | type t = { 5 | name: string; 6 | imports: string list; 7 | statements: Ast.Statement.t list; 8 | module_: Ast.Module.t option; 9 | result: string option} [@@deriving sexp] 10 | end 11 | 12 | module Project : sig 13 | type t = { 14 | name: string; 15 | prelude: string sexp_option; 16 | output: string sexp_option 17 | } [@@deriving sexp] 18 | end 19 | 20 | val gather : string -> string -> string list 21 | val build_tree : ?prelude:(string) -> string list -> string list -> string -> unit 22 | val link : string list -> string -> unit 23 | val module_resolver : CompiledModule.t list -> string -> Ast.Module.t 24 | val build_project : Project.t -> Project.t 25 | -------------------------------------------------------------------------------- /lib/typer.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Ast 3 | 4 | let rec get_instance_type t = 5 | match t with 6 | | Type.TypeArg {TypeArg.instance} -> ( 7 | match !instance with Some inst -> get_instance_type inst | _ -> t ) 8 | | _ -> t 9 | 10 | module Env = struct 11 | type t = 12 | { symbols: (int * Type.t) String.Map.t 13 | ; signatures: (string * Type.t) list 14 | ; modules: (string * Module.t) list 15 | ; qualified_imports: (string * string) list 16 | ; types: Ast.NamedType.t list 17 | ; non_free: Type.t list 18 | ; type_refs: string list 19 | ; argi: int } 20 | 21 | (* construct and return a new empty type arg *) 22 | let new_arg env name level = 23 | let arg = Type.TypeArg (TypeArg.make ()) in 24 | let symbols = String.Map.set env.symbols name (level, arg) in 25 | ({env with argi= env.argi + 1; symbols}, arg) 26 | 27 | (* add a symbol directly into the env *) 28 | let add name binding_type env = 29 | {env with symbols= String.Map.set env.symbols name binding_type} 30 | 31 | let add_non_free t env = 32 | {env with non_free= get_instance_type t :: env.non_free} 33 | 34 | let get_mod_type module_ name node env = 35 | try 36 | let _, mod_ = List.find_exn ~f:(fun (n, _) -> n = module_) env.modules in 37 | let (binding : Ast.Binding.t) = 38 | List.find_exn 39 | ~f:(fun (b: Ast.Binding.t) -> b.name = name) 40 | mod_.bindings 41 | in 42 | (0, Type.copy binding.expr.type_ env.non_free) 43 | with Not_found -> 44 | raise 45 | (CompileError 46 | { Error.error= IdentifierNotFound (module_ ^ "." ^ name) 47 | ; source= node.Node.source }) 48 | 49 | (* TODO - get_type and get_user_type are really confusing *) 50 | let get_user_type (n: string) (env: t) = 51 | try List.find_exn ~f:(fun {Ast.NamedType.name} -> n = name) env.types 52 | with Not_found -> 53 | (* Qualified import? *) 54 | try 55 | let mod_name, type_name = 56 | List.find_exn ~f:(fun (_, name) -> n = name) env.qualified_imports 57 | in 58 | let _, mod_ = 59 | List.find_exn ~f:(fun (n, _) -> n = mod_name) env.modules 60 | in 61 | (* Now we know that this symbol really belongs to an external module, 62 | mutation the module reference on this identifier *) 63 | List.find_exn 64 | ~f:(fun {Ast.NamedType.name} -> name = type_name) 65 | mod_.Module.types 66 | with Not_found -> 67 | raise 68 | (CompileError {Error.error= TypeNotFound n; Error.source= Source.None}) 69 | 70 | let get_type ident node env = 71 | try 72 | let level, type_ = String.Map.find_exn env.symbols ident in 73 | (level, Type.copy type_ env.non_free) 74 | with Not_found -> 75 | raise 76 | (CompileError 77 | { Error.error= IdentifierNotFound ident 78 | ; Error.source= node.Node.source }) 79 | 80 | let empty = 81 | { argi= 0 82 | ; signatures= [] 83 | ; symbols= String.Map.empty 84 | ; non_free= [] 85 | ; types= [] 86 | ; modules= [] 87 | ; qualified_imports= [] 88 | ; type_refs= [] } 89 | end 90 | 91 | let rec occurs_in (ta: TypeArg.t) (t: Type.t) = 92 | let t = get_instance_type t in 93 | match t with 94 | | TypeArg t -> t = ta 95 | | Tuple args -> List.exists ~f:(occurs_in ta) args 96 | | List t -> occurs_in ta t 97 | | _ -> false 98 | 99 | let rec unify ?source:((source: Source.t) = None) t1 t2 = 100 | let it1 = get_instance_type t1 in 101 | let it2 = get_instance_type t2 in 102 | match (it1, it2) with 103 | | Type.TypeArg a1, a2 -> 104 | if it1 != it2 && occurs_in a1 a2 then 105 | raise 106 | (CompileError 107 | {Error.error= Error.CyclicalType "recursive type detected"; source}) ; 108 | ( match it2 == it1 with 109 | | false -> a1.TypeArg.instance := Some it2 110 | | true -> () ) ; 111 | it2 112 | | _, Type.TypeArg _ -> unify t2 t1 ~source 113 | | Type.Tuple items1, Type.Tuple items2 -> 114 | Type.Tuple 115 | ( List.zip_exn items1 items2 116 | |> List.map ~f:(fun (i1, i2) -> unify i1 i2 ~source) ) 117 | | Type.Arrow (a1a, a1r), Type.Arrow (a2a, a2r) -> 118 | let a3a = unify a1a a2a ~source in 119 | let a3r = unify a1r a2r ~source in 120 | let result = Type.Arrow (a3a, a3r) in 121 | result 122 | | Type.List l1, Type.List l2 -> 123 | let l3 = unify l1 l2 ~source in 124 | Type.List l3 125 | | Type.Adt a1, Type.Adt a2 -> 126 | (* Check name *) 127 | if a1.name <> a2.name then 128 | raise (CompileError {error= Error.TypeMismatch (t1, t2); source}) ; 129 | (* Check type args *) 130 | if List.length a1.args != List.length a2.args then 131 | raise (CompileError {error= Error.TypeMismatch (t1, t2); source}) ; 132 | let args = 133 | List.zip_exn a1.args a2.args 134 | |> List.map ~f:(fun (i1, i2) -> unify i1 i2 ~source) 135 | in 136 | Type.Adt {name= a1.name; args; variants= a1.variants} 137 | | Type.SelfRef ref, Type.Adt adt -> 138 | (* Very naive check! We possibly need a way of checking that the types really do match, 139 | * without falling down the infinite recursion hole *) 140 | (* We do, at least, check any supplied arguments *) 141 | let args = 142 | List.zip_exn ref.args adt.args 143 | |> List.map ~f:(fun (i1, i2) -> unify i1 i2 ~source) 144 | in 145 | if ref.name <> adt.name then 146 | raise (CompileError {error= Error.TypeMismatch (t1, t2); source}) 147 | else Type.Adt {adt with args} 148 | | Type.Adt adt, Type.SelfRef ref -> unify t2 t1 ~source 149 | | Type.PolyRecord r1, Type.PolyRecord r2 -> 150 | (* Unify two poly records - this means finding the base of each and creating a new base linked to it *) 151 | (* TODO - check types and ensure only one of each type! *) 152 | let b1, b2 = (PolyRecord.get_base r1, PolyRecord.get_base r2) in 153 | (* Unify all of r1 on r2 *) 154 | (* Unify all of r2 on r1 *) 155 | let new_base_fields = 156 | List.fold_left 157 | ~f:(fun acc (name, t1) -> 158 | ( match List.find ~f:(fun (n, _) -> n = name) b2.fields with 159 | | Some (_, t2) -> (name, unify t1 t2) 160 | | None -> (name, t1) ) 161 | :: acc ) 162 | ~init:[] b1.fields 163 | in 164 | let new_base_fields = 165 | List.fold_left 166 | ~f:(fun acc (name, t1) -> 167 | if List.exists ~f:(fun (n, _) -> n = name) acc then acc 168 | else 169 | ( match List.find ~f:(fun (n, _) -> n = name) b1.fields with 170 | | Some (_, t2) -> (name, unify t1 t2) 171 | | None -> (name, t1) ) 172 | :: acc ) 173 | ~init:new_base_fields b2.fields 174 | in 175 | let new_record = {PolyRecord.fields= new_base_fields; poly= ref None} in 176 | b1.poly := Some new_record ; 177 | b2.poly := Some new_record ; 178 | Type.PolyRecord b1 179 | | Type.PolyRecord r1, Type.Record r2 -> 180 | (* Try to unify to a poly record - that means we only require the 181 | * subset of r1 in r2, not a full matching set *) 182 | List.iter 183 | ~f:(fun (name, t1) -> 184 | try 185 | let _, t2 = List.find_exn ~f:(fun (n, _) -> n = name) r2.fields in 186 | let _ = unify t1 t2 in 187 | () 188 | with Not_found_s _ -> 189 | raise 190 | (CompileError 191 | { error= Error.FieldMismatch ("unknown field '" ^ name ^ "'") 192 | ; source }) ) 193 | (PolyRecord.get_base r1).fields ; 194 | Type.Record r2 195 | | Type.Record _, Type.PolyRecord _ -> unify ~source t2 t1 196 | | Type.Record r1, Type.Record r2 -> 197 | (* Non-poly records require everything to match *) 198 | let r1set = 199 | List.map ~f:(fun (n, _) -> n) r1.fields 200 | |> List.sort String.compare |> String.concat ~sep:"," 201 | in 202 | let r2set = 203 | List.map ~f:(fun (n, _) -> n) r2.fields 204 | |> List.sort String.compare |> String.concat ~sep:"," 205 | in 206 | (* TODO - proper field mismatch error *) 207 | if r1set <> r2set then 208 | raise 209 | (CompileError 210 | {error= Error.FieldMismatch (r1set ^ " versus " ^ r2set); source}) ; 211 | List.iter 212 | ~f:(fun (name, t1) -> 213 | let _, t2 = List.find_exn ~f:(fun (n, _) -> n = name) r2.fields in 214 | let _ = unify t1 t2 in 215 | () ) 216 | r1.fields ; 217 | Type.Record r2 218 | | Type.Alias a1, Type.Alias a2 -> unify a1.type_ a2.type_ 219 | | Type.Alias a1, t2 -> unify a1.type_ t2 220 | | t1, Type.Alias a2 -> unify t1 a2.type_ 221 | | _ -> 222 | match it1 == it2 with 223 | | true -> it2 224 | | false -> 225 | raise (CompileError {error= Error.TypeMismatch (t1, t2); source}) 226 | 227 | let rec pattern_type env pattern = 228 | let open MatchPattern in 229 | match pattern with 230 | | Int _ -> (env, Type.Int) 231 | | Boolean _ -> (env, Type.Bool) 232 | | String _ -> (env, Type.String) 233 | | Float _ -> (env, Type.Float) 234 | | Tuple items -> 235 | let env, types = 236 | List.fold_left 237 | ~f:(fun (env, types) pat -> 238 | let env, t = pattern_type env pat in 239 | (env, t :: types) ) 240 | ~init:(env, []) items 241 | in 242 | (env, Type.Tuple (List.rev types)) 243 | | Record items -> 244 | let env, types = 245 | List.fold_left 246 | ~f:(fun (env, types) (name, pat) -> 247 | let env, t = pattern_type env pat in 248 | (env, (name, t) :: types) ) 249 | ~init:(env, []) items 250 | in 251 | (env, Type.PolyRecord {fields= types; poly= ref None}) 252 | | Cons _ -> ( 253 | (* Flatten AST cons to a list, ignoring a binding in the tail position *) 254 | (* FIXME - the tail position should explicitly be a list, may need to be non_free (?) *) 255 | let cells = MatchPattern.cons_to_list pattern in 256 | match List.rev cells with 257 | | tail :: heads -> 258 | (* unify the tail immediately with a list type *) 259 | let env, t = pattern_type env tail in 260 | let t = unify t @@ Type.List (Type.TypeArg (TypeArg.make ())) in 261 | let env, cell_type = 262 | List.fold_left 263 | ~f:(fun (env, acc_t) pat -> 264 | let env, t = pattern_type env pat in 265 | let t2 = unify acc_t (Type.List t) in 266 | (env, t2) ) 267 | ~init:(env, t) heads 268 | in 269 | (env, cell_type) 270 | | _ -> failwith "Bad cons cell" ) 271 | | EmptyList -> (env, Type.List (Type.TypeArg (TypeArg.make ()))) 272 | | Constructor (name, args) -> ( 273 | Ast.Module.find_constructor env.Env.types name 274 | |> function 275 | | None -> 276 | raise 277 | (CompileError 278 | { Error.error= IdentifierNotFound name 279 | ; Error.source= Source.None }) 280 | | Some (adt, t) -> 281 | (* Bomb out if there's an arg count mismatch *) 282 | (* TODO this should be a proper compile error *) 283 | if List.length t.Variant.args <> List.length args then 284 | failwith "Bad constructor length" ; 285 | let env, arg_types = 286 | List.fold_left 287 | ~f:(fun (env, types) pat -> 288 | let env, t = pattern_type env pat in 289 | (env, t :: types) ) 290 | ~init:(env, []) args 291 | in 292 | let arg_types = List.rev arg_types in 293 | let _ = 294 | List.zip_exn t.Variant.args arg_types 295 | |> List.map ~f:(fun (x, y) -> unify x y) 296 | in 297 | (env, Type.Adt adt) ) 298 | | Binding b -> 299 | let ta = Type.TypeArg (TypeArg.make ()) in 300 | let env = Env.add b (1, ta) env in 301 | let env = Env.add_non_free ta env in 302 | (Env.add b (1, ta) env, ta) 303 | 304 | let rec analyse program env = 305 | match program.Node.expr with 306 | | Expr.Unit -> 307 | (env, Type.Unit) 308 | | Expr.Lambda {Lambda.arg; body} -> 309 | (* we know nothing about the type arg at this point in time *) 310 | let local_env, arg_type = Env.new_arg env arg 1 in 311 | let local_env = Env.add_non_free arg_type local_env in 312 | (* within the env, the type arg will also need to be within the non-generic list for the lambda *) 313 | let env2, return_type = analyse body local_env in 314 | (env, Type.Arrow (arg_type, return_type)) 315 | | Expr.Identifier {module_= {contents= Some module_}; name; type_} -> 316 | (* Symbol relates to another module*) 317 | let _, type_ = Env.get_mod_type module_ name program env in 318 | (env, type_) 319 | | Expr.Identifier {name; module_; type_} -> ( 320 | try 321 | (* update ident type now we know about its environment... *) 322 | let level, typeof_ = Env.get_type name program env in 323 | match (level, typeof_) with 324 | (* Outervalue ?? *) 325 | | 0, Type.Arrow _ -> 326 | type_ := IdentType.OuterFun ; 327 | (env, typeof_) 328 | | 0, _ -> 329 | type_ := IdentType.OuterVal ; 330 | (env, typeof_) 331 | | _ -> 332 | type_ := IdentType.Var ; 333 | (env, typeof_) 334 | with err -> 335 | try 336 | let mod_, _ = 337 | List.find_exn ~f:(fun (_, n) -> n = name) env.qualified_imports 338 | in 339 | (* Now we know that this symbol really belongs to an external module, 340 | mutation the module reference on this identifier *) 341 | module_ := Some mod_ ; 342 | let _, t = Env.get_mod_type mod_ name program env in 343 | (env, t) 344 | with Not_found -> raise err ) 345 | | Expr.Literal (Literal.Int _) -> (env, Type.Int) 346 | | Expr.Literal (Literal.Float _) -> (env, Type.Float) 347 | | Expr.Literal (Literal.Boolean _) -> (env, Type.Bool) 348 | | Expr.Literal (Literal.String _) -> (env, Type.String) 349 | | Expr.Literal (Literal.Tuple items) -> 350 | let folder (env, items) x = 351 | let env, t = analyse x env in 352 | (env, items @ [t]) 353 | in 354 | let env, items = List.fold_left ~f:folder ~init:(env, []) items in 355 | (env, Type.Tuple items) 356 | | Expr.Literal (Literal.Record items) -> 357 | let mapper (name, x) = 358 | let _, t = analyse x env in 359 | (name, t) 360 | in 361 | let record_type = Type.Record {fields= List.map ~f:mapper items} in 362 | (env, record_type) 363 | | Expr.Apply {Apply.expr; arg} -> ( 364 | let env1, ft = analyse expr env in 365 | let env2, at = analyse arg env1 in 366 | let _, rt = Env.new_arg env2 "_" 1 in 367 | let rt2 = unify ft (Type.Arrow (at, rt)) ~source:program.Node.source in 368 | match rt2 with 369 | | Type.Arrow (_, rt3) -> (env, rt3) 370 | | Type.TypeArg a -> ( 371 | match !(a.instance) with Some x -> (env, rt2) | None -> (env, rt2) ) 372 | | _ -> raise (failwith "bad arrow unification") ) 373 | | Expr.Call {Call.module_; fun_; args} -> 374 | (* analyse args *) 375 | let _args = List.map ~f:(fun a -> analyse a env) args in 376 | let _, rt = Env.new_arg env "_" 1 in 377 | (env, rt) 378 | | Expr.Let {Let.name; bound_expr; expr} -> 379 | (* TODO - ensure bound funs have copied envs to avoid 380 | issues with generalisation *) 381 | let env, bt = analyse bound_expr env in 382 | let env = Env.add name (1, bt) env in 383 | analyse expr env 384 | | Expr.Match {Match.expr; Match.clauses} -> 385 | let env, input_type = analyse expr env in 386 | let env = Env.add_non_free input_type env in 387 | (* now match the input type with each clause *) 388 | let _, result_type = 389 | List.fold_left 390 | ~f:(fun (acc_input_type, acc_res_type) cl -> 391 | (* TODO we need to inject things into the env from the pattern!!! *) 392 | let env, pat_type = pattern_type env cl.MatchClause.pattern in 393 | let input_type = 394 | unify pat_type acc_input_type ~source:program.Node.source 395 | in 396 | let _, res_type = analyse cl.MatchClause.result env in 397 | let res_type = 398 | unify res_type acc_res_type ~source:program.Node.source 399 | in 400 | (input_type, res_type) ) 401 | ~init:(input_type, Type.TypeArg (TypeArg.make ())) 402 | clauses 403 | in 404 | (env, result_type) 405 | | Expr.Literal (Literal.ConsCell (c, rest)) -> 406 | (* Fold the cons cell down to the bottom and check the types unify *) 407 | (* TODO -> there's some sort of issue with the unification here *) 408 | let env, this_type = analyse c env in 409 | let rest_type = 410 | match rest.expr with 411 | | Expr.Literal Literal.EmptyList -> Type.List this_type 412 | | _ -> 413 | let _, rt = analyse rest env in 414 | rt 415 | in 416 | let ret_type = 417 | unify rest_type (Type.List this_type) ~source:program.Node.source 418 | in 419 | (env, ret_type) 420 | | Expr.Literal Literal.EmptyList -> 421 | (env, Type.List (Type.TypeArg (TypeArg.make ()))) 422 | | Expr.AdtConstructor {type_; name; args} -> ( 423 | (* See if the ADT is defined in the environment *) 424 | (* NEED TO COPY THE BASE ADT TYPE / VARIANTS (?) *) 425 | let {Ast.NamedType.type_} = Env.get_user_type type_ env in 426 | match type_ with 427 | | Type.Adt adt -> 428 | let env, arg_types = 429 | List.fold_left 430 | ~f:(fun (env, args) a -> 431 | let env, rt = analyse a env in 432 | (env, rt :: args) ) 433 | ~init:(env, []) args 434 | in 435 | let variant = 436 | List.find_exn ~f:(fun v -> v.Variant.name = name) adt.Adt.variants 437 | in 438 | let env = 439 | List.fold_left 440 | ~f:(fun env a -> Env.add_non_free a env) 441 | ~init:env variant.Variant.args 442 | in 443 | let _ = 444 | List.map2 445 | ~f:(unify ~source:program.Node.source) 446 | variant.Variant.args (List.rev arg_types) 447 | in 448 | ( env 449 | , Type.Adt 450 | {name= adt.Adt.name; args= adt.args; variants= adt.Adt.variants} 451 | ) 452 | | _ -> raise (failwith "Unknown variant for ADT") ) 453 | | Expr.RecordAccess (expr, field) -> 454 | let env, expr_type = analyse expr env in 455 | let env, field_type = Env.new_arg env "_" 1 in 456 | let access_type = 457 | Type.PolyRecord {fields= [(field, field_type)]; poly= ref None} 458 | in 459 | let unified = unify ~source:expr.Node.source expr_type access_type in 460 | (env, field_type) 461 | | Expr.RecordUpdate (expr, update_fields) -> 462 | let env, original_t = analyse expr env in 463 | (* TODO - we should unify traditionally so we can cope with typeargs, 464 | presumably constructing a poly record and unifying with it should do the trick (?) *) 465 | let (env, new_fields) = 466 | List.fold_left 467 | ~f:(fun (env, fields) (field, new_expr) -> 468 | let env, new_t = analyse new_expr env in 469 | let clean_fields = 470 | fields |> List.filter ~f:(fun (f, _) -> f <> field) 471 | in 472 | (env, (field, new_t) :: clean_fields )) 473 | ~init:(env, []) update_fields 474 | in 475 | let new_t = Type.PolyRecord {fields= new_fields; poly= ref None} in 476 | (* Do we really want to unify? We only really want to check that fields exist! *) 477 | (* let _ = unify ~source:expr.Node.source new_t original_t in *) 478 | (env, new_t) 479 | 480 | (* TODO - proper error for this *) 481 | 482 | let get_type_sig name env = 483 | let rec find = function 484 | | [] -> None 485 | | (n, t) :: rest -> 486 | match n = name with true -> Some t | false -> find rest 487 | in 488 | find env.Env.signatures 489 | 490 | let rec unify_targs type_ targ_map env = 491 | let arg_folder (types, targ_map) i = 492 | let type_, targ_map = unify_targs i targ_map env in 493 | (types @ [type_], targ_map) 494 | in 495 | match type_ with 496 | | Type.Arrow (arg, expr) -> 497 | let arg, targ_map = unify_targs arg targ_map env in 498 | let expr, targ_map = unify_targs expr targ_map env in 499 | (Type.Arrow (arg, expr), targ_map) 500 | | Type.TypeArg {name= Some name; instance; id} -> ( 501 | match String.Map.mem targ_map name with 502 | | true -> (String.Map.find_exn targ_map name, targ_map) 503 | | false -> (type_, String.Map.set targ_map name type_) ) 504 | | Type.List listT -> 505 | let arg, targ_map = unify_targs listT targ_map env in 506 | (Type.List arg, targ_map) 507 | | Type.Record record -> 508 | let fields, targ_map = 509 | List.fold_left 510 | ~f:(fun (fields, targ_arg) (f, t) -> 511 | let t, targ_map = unify_targs t targ_map env in 512 | let field = (f, t) in 513 | (field :: fields, targ_map) ) 514 | ~init:([], targ_map) record.fields 515 | in 516 | (Type.Record {fields}, targ_map) 517 | | Type.PolyRecord record -> 518 | let fields, targ_map = 519 | List.fold_left 520 | ~f:(fun (fields, targ_arg) (f, t) -> 521 | let t, targ_map = unify_targs t targ_map env in 522 | let field = (f, t) in 523 | (field :: fields, targ_map) ) 524 | ~init:([], targ_map) (PolyRecord.get_base record).fields 525 | in 526 | (Type.PolyRecord {fields; poly= ref None}, targ_map) 527 | | Type.UserType {name; args} -> 528 | if List.exists ~f:(( = ) name) env.Env.type_refs then 529 | let args, targ_map = 530 | List.fold_left ~f:arg_folder ~init:([], targ_map) args 531 | in 532 | (Type.SelfRef {name; args}, targ_map) 533 | else 534 | let type_ = Env.get_user_type name env in 535 | (* Try and unify the type args *) 536 | let args, targ_map = 537 | List.fold_left ~f:arg_folder ~init:([], targ_map) args 538 | in 539 | (* TODO - bomb out if wrong number of constructor args... *) 540 | let type_ = 541 | match type_.type_ with 542 | | Type.Adt adt -> Type.Adt {adt with args} 543 | | Type.Alias alias -> 544 | (* TODO: Probably need to make sure this is copied ? *) 545 | let args_ = List.map2 ~f:unify alias.args args in 546 | (* TODO - may need to put targ_map out of this scope! *) 547 | let t, targ_map = unify_targs alias.type_ targ_map env in 548 | Type.Alias {alias with args; type_= t} 549 | | Type.TypeArg arg -> Type.TypeArg arg 550 | | t -> failwith ("Can't match user type to type" ^ Type.format t) 551 | in 552 | (type_, targ_map) 553 | | Type.Tuple els -> 554 | let types, targ_map = 555 | List.fold_left ~f:arg_folder ~init:([], targ_map) els 556 | in 557 | (Type.Tuple types, targ_map) 558 | | Type.Adt adt -> 559 | let variants, targ_map = 560 | List.fold_left 561 | ~f:(fun (vars, targ_map) {Variant.name; args} -> 562 | let args, targ_map = 563 | List.fold_left ~f:arg_folder ~init:([], targ_map) args 564 | in 565 | (vars @ [{Variant.name; args}], targ_map) ) 566 | ~init:([], targ_map) adt.Adt.variants 567 | in 568 | (Type.Adt {adt with variants}, targ_map) 569 | | _ -> (type_, targ_map) 570 | 571 | let unify_signature (env, mod_) sig_type = 572 | (* type args need to be unified by name *) 573 | let map = String.Map.empty in 574 | unify_targs sig_type map env 575 | 576 | type module_resolver = string -> Module.t 577 | 578 | let from_statement (resolve_module: module_resolver) (env, mod_) statement = 579 | let ( >>= ) = Option.( >>= ) in 580 | match statement with 581 | | Statement.Let {name; expr} -> 582 | let rec_type = Type.TypeArg (TypeArg.make ()) in 583 | let env_with_rec = 584 | Env.add name (1, rec_type) env |> Env.add_non_free rec_type 585 | in 586 | let new_env, binding_type = analyse expr env_with_rec in 587 | let _ = unify rec_type binding_type in 588 | let maybe_sig = get_type_sig name new_env in 589 | let final_type = 590 | maybe_sig 591 | >>= (fun t -> 592 | try 593 | let _ = unify t binding_type in 594 | Some t 595 | with CompileError _ -> 596 | raise 597 | (CompileError 598 | { Error.source= expr.source 599 | ; error= Error.TypeSignatureMismatch (binding_type, t) }) 600 | ) 601 | |> Option.value ~default:binding_type 602 | in 603 | (* We discard the env we've built up and simply add the final type of the binding to the name *) 604 | let ret_env = Env.add name (0, final_type) env in 605 | let typed_binding = TypedNode.make expr (get_instance_type final_type) in 606 | let binding = Ast.Binding.make name typed_binding in 607 | (ret_env, {mod_ with Module.bindings= binding :: mod_.Module.bindings}) 608 | | Statement.TypeSignature {name; type_} -> 609 | let type_, _ = unify_signature (env, mod_) type_ in 610 | ({env with Env.signatures= (name, type_) :: env.signatures}, mod_) 611 | | Statement.Type {name; type_} -> 612 | let map = String.Map.empty in 613 | let ref_env = {env with type_refs= name :: env.type_refs} in 614 | let type_, _ = unify_targs type_ map ref_env in 615 | let new_type = {Ast.NamedType.name; type_} in 616 | let mod_ = {mod_ with types= new_type :: mod_.types} in 617 | let env = {env with Env.types= new_type :: env.types} in 618 | (env, mod_) 619 | | Statement.Module ms -> (env, {mod_ with Ast.Module.name= ms.name}) 620 | | Statement.Import import -> 621 | let resolved_module = resolve_module import.module_ in 622 | (* fold env importing qualified imports *) 623 | let qualified_imports = 624 | env.qualified_imports 625 | @ List.map ~f:(fun n -> (import.module_, n)) import.qualified 626 | in 627 | ( { env with 628 | modules= (import.module_, resolved_module) :: env.modules 629 | ; qualified_imports } 630 | , {mod_ with imports= import :: mod_.imports} ) 631 | | Statement.Verbatim {name= "lua"; code} -> 632 | (env, {mod_ with verbatim= mod_.verbatim ^ code}) 633 | | Statement.Verbatim {name} -> 634 | failwith ("Unknown verbatim block type: " ^ name) 635 | 636 | let from_statements ?(module_resolver: module_resolver option) statements = 637 | let module_resolver = 638 | module_resolver 639 | |> function 640 | | Some v -> v 641 | | _ -> 642 | fun _ -> failwith "Cannot import module: no module resolver provided" 643 | in 644 | let env, mod_ = 645 | List.fold_left 646 | ~f:(from_statement module_resolver) 647 | ~init:(Env.empty, Ast.Module.empty) 648 | statements 649 | in 650 | match mod_.name with 651 | | "__empty__" -> (env, {mod_ with name= "Main"}) 652 | | _ -> (env, mod_) 653 | 654 | let type_statements ?module_resolver statements = 655 | let module_resolver = 656 | module_resolver 657 | |> function 658 | | Some v -> v 659 | | _ -> 660 | fun _ -> failwith "Cannot import module: no module resolver provided" 661 | in 662 | try Ok (from_statements ~module_resolver statements) 663 | with CompileError err -> Error err 664 | -------------------------------------------------------------------------------- /license.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 David J. Jeffrey 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 | -------------------------------------------------------------------------------- /luml.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "luml" 3 | version: "0.0.1" 4 | maintainer: "Dave Jeffrey " 5 | build: [ 6 | ["jbuilder" "build" "-p" name "-j" jobs] 7 | ] 8 | depends: [ 9 | "jbuilder" "alcotest" "core_kernel" "menhir" "ANSITerminal" "ocamlgraph" "lambda-term" 10 | ] 11 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # Luml 2 | 3 | Luml is a type-inferred language in the tradition of Elm, OCaml, F# etc, 4 | which cross-compiles to Lua with the intention of being used as an 5 | embedded scripted language, or stand-alone using the Lua interpreter 6 | or LuaJit. It is implemented in OCaml. 7 | 8 | This isn't intended for any production use and won't see any future development; it is left here as a historical curiosity and as an example of implementing a type-inferred language and cross compiler in OCaml. 9 | 10 | ## Installation 11 | 12 | ### macOS 13 | 14 | `curl -Ls https://git.io/f4y8I | bash` 15 | 16 | Test installation by running `luml` to access the REPL. 17 | -------------------------------------------------------------------------------- /stdlib/.gitignore: -------------------------------------------------------------------------------- 1 | build 2 | -------------------------------------------------------------------------------- /stdlib/base.prelude: -------------------------------------------------------------------------------- 1 | import Base ((+), (-), (*), (/), (+.), (*.), (|>), (<|), (==), (/=), (&&), (||), (++), (<), (>), (>>), mod, range, toString, log, flip, always, fst, snd) 2 | import List 3 | import String 4 | import Option (Some, None, Option) 5 | import Result (Result) 6 | 7 | -------------------------------------------------------------------------------- /stdlib/lume.proj: -------------------------------------------------------------------------------- 1 | ( 2 | (name "stdlib") 3 | ) -------------------------------------------------------------------------------- /stdlib/src/base.ml: -------------------------------------------------------------------------------- 1 | module Base 2 | 3 | [%lua 4 | 5 | local _toString 6 | _toString = function(value) 7 | local t = type(value) 8 | if t == 'function' then 9 | return '' 10 | elseif t == 'nil' then 11 | return 'unit' 12 | elseif t == 'table' then 13 | if value._type == 'tuple' then 14 | local acc = '' 15 | for key, v in ipairs(value) do 16 | if acc ~= '' then 17 | acc = acc .. ', ' 18 | end 19 | acc = acc .. _toString(v) 20 | end 21 | return '(' .. acc .. ')' 22 | elseif value._type == 'adt' then 23 | local acc = '' 24 | for key, v in ipairs(value) do 25 | if acc ~= '' then 26 | acc = acc .. ' ' 27 | end 28 | local sub = _toString(v) 29 | if string.find(sub, " ") ~= nil then 30 | sub = '(' .. sub .. ')' 31 | end 32 | acc = acc .. sub 33 | end 34 | return acc 35 | elseif value._type == 'record' then 36 | local acc = '{' 37 | for key, v in pairs(value) do 38 | if key ~= '_type' then 39 | if acc ~= '{' then 40 | acc = acc .. ',' 41 | end 42 | acc = acc .. key .. '=' .. _toString(v) 43 | end 44 | end 45 | return acc .. '}' 46 | elseif value.value ~= nil then 47 | local acc = '' 48 | local el = value 49 | while el.value ~= nil do 50 | if acc ~= '' then 51 | acc = acc .. ', ' 52 | end 53 | 54 | acc = acc .. _toString(el.value) 55 | el = el.next 56 | end 57 | 58 | return '[' .. acc .. ']' 59 | elseif t == 'string' then 60 | return '"' .. value .. '"' 61 | end 62 | 63 | return "[]" 64 | else 65 | return tostring(value) 66 | end 67 | end 68 | 69 | _catString = function(a, b) 70 | return a .. b 71 | end 72 | 73 | %] 74 | 75 | (+) : Int -> Int -> Int 76 | (+) a b = @lua.+ a b 77 | 78 | (-) : Int -> Int -> Int 79 | (-) a b = @lua.- a b 80 | 81 | (*) : Int -> Int -> Int 82 | (*) a b = @lua.* a b 83 | 84 | -- Integer division. In Lua 5.3 we get //, 85 | -- but for backwards-compatability we emulate it 86 | (/) : Int -> Int -> Int 87 | (/) a b = @math.floor (@lua./ a b) 88 | 89 | (+.) : Float -> Float -> Float 90 | (+.) a b = @lua.+ a b 91 | 92 | (*.) : Float -> Float -> Float 93 | (*.) a b = @lua.* a b 94 | 95 | (|>) : a -> (a -> b) -> b 96 | (|>) x f = 97 | f x 98 | 99 | (<|) : (a -> b) -> a -> b 100 | (<|) f x = 101 | f x 102 | 103 | (::) a b = a :: b 104 | 105 | (==) : a -> a -> Bool 106 | (==) a b = @lua.== a b 107 | 108 | (/=) : a -> a -> Bool 109 | (/=) a b = @lua.~= a b 110 | 111 | (&&) : Bool -> Bool -> Bool 112 | (&&) a b = @lua.and a b 113 | 114 | (||) : Bool -> Bool -> Bool 115 | (||) a b = @lua.or a b 116 | 117 | (++) : String -> String -> String 118 | (++) a b = @lua._catString a b 119 | 120 | (>) : a -> a -> Bool 121 | (>) a b = 122 | @lua.> a b 123 | 124 | (<) : a -> a -> Bool 125 | (<) a b = 126 | @lua.< a b 127 | 128 | mod : Int -> Int -> Int 129 | mod a b = @lua.% a b 130 | 131 | range : Int -> Int -> List Int 132 | range a z = 133 | match a == z with 134 | true -> [] 135 | | false -> a :: (range (a+1) z) 136 | end 137 | 138 | toString : a -> String 139 | toString x = @lua._toString x 140 | 141 | always : a -> b -> a 142 | always value x = value 143 | 144 | log : String -> a -> a 145 | log tag value = @lua.print (tag ++ ": " ++ (toString value)) 146 | 147 | flip : (a -> b -> c) -> b -> a -> c 148 | flip f a b = 149 | f b a 150 | 151 | (>>) f g x = 152 | g (f x) 153 | 154 | fst : (a, b) -> a 155 | fst x = 156 | let (first, _) = x in first 157 | 158 | snd : (a, b) -> b 159 | snd x = 160 | let (_, second) = x in second 161 | -------------------------------------------------------------------------------- /stdlib/src/default.prelude: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/merle-lang/luml/9e705adb273a0c260613d86acb0959ba758e3954/stdlib/src/default.prelude -------------------------------------------------------------------------------- /stdlib/src/file.ml: -------------------------------------------------------------------------------- 1 | module File 2 | 3 | import Base (toString) 4 | import Result (Result) 5 | 6 | [%lua 7 | 8 | local __read_file = function(filename) 9 | local file = io.open(filename, "rb") 10 | if not file then return {false, "File does not exist"} end 11 | local content = file:read "*a" 12 | file:close() 13 | return {true, content} 14 | end 15 | 16 | %] 17 | 18 | read : String -> Result String String 19 | read filename = 20 | match (@lua.__read_file filename) with 21 | (true, data) -> Result.OK data 22 | | (false, error) -> Result.Error error 23 | | other -> Result.Error (toString other) 24 | end 25 | -------------------------------------------------------------------------------- /stdlib/src/list.ml: -------------------------------------------------------------------------------- 1 | module List 2 | 3 | import Base ((::), (|>), (+), (==), (&&), always) 4 | import Option (Option) 5 | 6 | foldl : (a -> b -> b) -> b -> List a -> b 7 | foldl f init items = 8 | match items with 9 | [] -> init 10 | | h :: t -> 11 | let nextAcc = (f h init) in 12 | foldl f nextAcc t 13 | end 14 | 15 | reverse : List a -> List a 16 | reverse = foldl (::) [] 17 | 18 | map : (a -> b) -> List a -> List b 19 | map f items = 20 | foldl (\i acc -> (f i) :: acc) [] items 21 | |> reverse 22 | 23 | mapi : (Int -> a -> b) -> List a -> List b 24 | mapi f items = 25 | let (_, result) = foldl (\item acc -> 26 | let (i, accItems) = acc in 27 | (i + 1, ((f i item) :: accItems))) 28 | (0, []) items 29 | in reverse result 30 | 31 | get_ i items counter = 32 | match items with 33 | [] -> Option.None 34 | | item :: rest -> 35 | match i == counter with 36 | true -> Option.Some item 37 | | false -> get_ i rest (counter + 1) 38 | end 39 | end 40 | 41 | get : Int -> List a -> Option a 42 | get i items = 43 | get_ i items 0 44 | 45 | hd : List a -> Option a 46 | hd = get 0 47 | 48 | filter : (a -> Bool) -> List a -> List a 49 | filter pred = 50 | foldl (\item acc -> 51 | match pred item with 52 | true -> item :: acc 53 | | false -> acc 54 | end) 55 | [] 56 | 57 | length : List a -> Int 58 | length = 59 | foldl (always ((+) 1)) 0 60 | 61 | concat : List a -> List a -> List a 62 | concat l1 l2 = 63 | foldl (::) (reverse l1) l2 64 | |> reverse 65 | 66 | all : (a -> Bool) -> List a -> Bool 67 | all pred items = 68 | foldl (\item acc -> (pred item) && acc) true items 69 | 70 | -------------------------------------------------------------------------------- /stdlib/src/option.ml: -------------------------------------------------------------------------------- 1 | module Option 2 | 3 | type Option a = Some a | None 4 | 5 | default d o = 6 | match o with 7 | Some x -> x 8 | | None -> d 9 | end -------------------------------------------------------------------------------- /stdlib/src/result.ml: -------------------------------------------------------------------------------- 1 | module Result 2 | 3 | -- Result type 4 | 5 | type Result error value = OK value | Error error 6 | 7 | map f result = 8 | match result with 9 | OK something -> OK (f something) 10 | | Error _ -> result 11 | end 12 | -------------------------------------------------------------------------------- /stdlib/src/string.ml: -------------------------------------------------------------------------------- 1 | module String 2 | 3 | import Base ((++)) 4 | 5 | -- Join parts of strings together 6 | join : String -> List String -> String 7 | join delim parts = 8 | match parts with 9 | [] -> "" 10 | | [hd] -> hd 11 | | hd :: tail -> hd ++ delim ++ (join delim tail) 12 | end -------------------------------------------------------------------------------- /test/error_tests.ml: -------------------------------------------------------------------------------- 1 | open Lib 2 | open Helpers 3 | 4 | let adt_missing_param_error () = 5 | let open Lib.Ast.Error in 6 | "type Maybe = Just a | Nothing" 7 | |> exec_code 8 | |> must_fail (function 9 | | { error = TypeParamMissing _} -> () 10 | | _ -> Alcotest.fail "Expected error") 11 | 12 | let adt_unknown_error () = 13 | let open Lib.Ast.Error in 14 | [ "main x ="; 15 | " match x with"; 16 | " WorAdt v -> true"; 17 | " end" 18 | ] |> String.concat "\n" 19 | |> exec_code 20 | |> must_fail (function 21 | | { error = IdentifierNotFound _ } -> () 22 | | err -> 23 | Alcotest.fail 24 | ("Expected IdentifierNotFound, got " ^ (format_error err))) 25 | 26 | let cyclical_type_error () = 27 | let open Lib.Ast.Error in 28 | "append x y = (x, y) :: y" 29 | |> exec_code 30 | |> must_fail (function 31 | | { error = CyclicalType _ } -> () 32 | | err -> 33 | Alcotest.fail ("Expected CyclicalType, got " ^ (format_error err))) 34 | 35 | 36 | let test_set = [ 37 | "Type param missing error", `Slow, adt_missing_param_error; 38 | "Unknown ADT error", `Slow, adt_unknown_error; 39 | "Cyclical type error", `Slow, cyclical_type_error; 40 | ] -------------------------------------------------------------------------------- /test/exhaustive_tests.ml: -------------------------------------------------------------------------------- 1 | open Lib 2 | open Helpers 3 | 4 | 5 | let exhaustive_bools () = 6 | exec_code "main x = match x with true -> 1 end" 7 | |> must_fail (function 8 | | {Lib.Ast.Error.error = Lib.Ast.Error.Inexhaustive _} -> () 9 | | _ -> Alcotest.fail "Expected type error") 10 | 11 | let exhaustive_captures () = 12 | let code = "main = match 2 with 1 -> 1 | x -> 2 end" in 13 | exec_with_type_and_res code "main" "main" 14 | |> must_succeed (fun (res_string, type_str) -> 15 | Alcotest.(check string) "Result should be 2" "2" res_string) 16 | 17 | let exhaustive_tuples () = 18 | exec_code 19 | "main x = 20 | match x with 21 | (true, false) -> 22 | true 23 | | (x, false) -> false end" 24 | |> must_fail (function 25 | | {Lib.Ast.Error.error = Lib.Ast.Error.Inexhaustive _} -> () 26 | | _ -> Alcotest.fail "Expected type error") 27 | 28 | let exhaustive_lists () = 29 | let code = 30 | "main x = 31 | match x with 32 | [] -> false 33 | | h :: t -> true 34 | end" in 35 | exec_with_type_and_res code "main" "main" 36 | |> must_succeed (fun (res_string, type_str) -> 37 | Alcotest.(check string) "Type should match" "List a -> Bool" type_str) 38 | 39 | let exhaustive_generic_captures () = 40 | let code = "main x = match x with a -> 1 end" in 41 | exec_with_type_and_res code "main" "main" 42 | |> must_succeed (fun (res_string, type_str) -> 43 | Alcotest.(check string) "Type should match" "a -> Int" type_str) 44 | 45 | let exhaustive_records () = 46 | exec_code 47 | "main x = 48 | match x with 49 | { age = true } -> true 50 | end" 51 | |> must_fail (function 52 | | {Lib.Ast.Error.error = Lib.Ast.Error.Inexhaustive _}-> () 53 | | e -> Alcotest.fail @@ Lib.Ast.Error.format_error e); 54 | 55 | let code = "main x = 56 | match x with 57 | { age = true } -> true 58 | | { age = false } -> false 59 | end" in 60 | exec_with_type_and_res code "main" "main" 61 | |> must_succeed (fun (res_string, type_str) -> 62 | Alcotest.(check string) "Type should match" "{ age : Bool, .. } -> Bool" type_str) 63 | 64 | 65 | 66 | 67 | let test_set = [ 68 | "Exhaustiveness - booleans", `Slow, exhaustive_bools; 69 | "Exhaustiveness - generic captures", `Slow, exhaustive_generic_captures; 70 | "Exhaustiveness - captures", `Slow, exhaustive_captures; 71 | "Exhaustiveness - tuples", `Slow, exhaustive_tuples; 72 | "Exhaustiveness - lists", `Slow, exhaustive_lists; 73 | "Exhaustiveness - records", `Slow, exhaustive_records; 74 | ] 75 | -------------------------------------------------------------------------------- /test/helpers.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open Lib 3 | 4 | let get_type_str env name = 5 | let _, type_ = String.Map.find_exn env.Lib.Typer.Env.symbols name in 6 | Ast.Type.format type_ 7 | 8 | let (>>=) res f = 9 | match res with 10 | | Ok data -> f data 11 | | Error err -> Error err 12 | 13 | let (<*>) res f = 14 | match res with 15 | | Ok data -> Ok (f data) 16 | | Error err -> Error err 17 | 18 | let safe_type (env, mod_) statement = 19 | try Ok (Lib.Typer.from_statements statement) 20 | with 21 | Ast.CompileError err -> Error err 22 | 23 | let exec_code code = 24 | let (env, mod_) = ( Lib.Typer.Env.empty, 25 | Lib.Ast.Module.empty 26 | ) in 27 | code 28 | |> Lexing.from_string 29 | |> Parsing.parse_all_with_error 30 | <*> List.map ~f: Ast.Statement.post_process 31 | <*> List.concat 32 | >>= safe_type (env, mod_) 33 | >>= fun (env, mod_) -> Exhaustive.check_module mod_ 34 | >>= fun (mod_) -> 35 | begin 36 | let lua_code = Lib.Compile.make_module mod_ in 37 | let lua = Lib.Lua.new_lua () in 38 | Lib.Lua.exec_lua lua (lua_code ^ "\nTESTS = Main\n"); 39 | Ok (lua, env) 40 | end 41 | 42 | let exec_with_type_and_res code fun_name type_name = 43 | exec_code code (* define module globally *) 44 | >>= (fun (lua, env) -> 45 | Lib.Lua.exec_lua lua ("__RESULT__=tostring(TESTS." ^ fun_name ^ ")"); 46 | let res_string = Lib.Lua.get_global_string lua "__RESULT__" and 47 | type_str = get_type_str env type_name in 48 | Ok (res_string, type_str)) 49 | 50 | let must_succeed f res = 51 | match res with 52 | | Ok value -> f value 53 | | Error err -> Alcotest.fail (Ast.Error.format_error err) 54 | 55 | let must_fail f res = 56 | match res with 57 | | Ok value -> Alcotest.fail "Code compile did not fail" 58 | | Error err -> f err 59 | -------------------------------------------------------------------------------- /test/jbuild: -------------------------------------------------------------------------------- 1 | (jbuild_version 1) 2 | 3 | (executable ( 4 | (name luml_test) 5 | (libraries (lib alcotest)) 6 | )) 7 | 8 | (alias ( 9 | (name runtest) 10 | (deps (luml_test.exe)) 11 | (action (run ${<} --verbose)) 12 | )) 13 | -------------------------------------------------------------------------------- /test/lua_tests.ml: -------------------------------------------------------------------------------- 1 | open Lib 2 | open Helpers 3 | 4 | let infix_plus () = 5 | let code = "(+) : Int -> Int -> Int 6 | (+) x y = @lua.+ x y 7 | result = 12 + 13" in 8 | 9 | exec_with_type_and_res code "result" "(+)" 10 | |> must_succeed (fun (res_string, type_str) -> 11 | Alcotest.(check string) "Infix (+) Result" res_string "25"; 12 | Alcotest.(check string) "Infix (+) Type" type_str "Int -> Int -> Int") 13 | 14 | let infix_minus () = 15 | let code = "(-) : Int -> Int -> Int 16 | (-) x y = @lua.- x y 17 | result = 13 - 4" in 18 | exec_with_type_and_res code "result" "(-)" 19 | |> must_succeed (fun (res_string, type_str) -> 20 | Alcotest.(check string) "Infix (-) Result" "9" res_string; 21 | Alcotest.(check string) "Infix (+) Type" type_str "Int -> Int -> Int") 22 | 23 | let test_set = [ 24 | "Infix (+)", `Slow, infix_plus; 25 | "Infix (-)", `Slow, infix_minus; 26 | ] -------------------------------------------------------------------------------- /test/luml_test.ml: -------------------------------------------------------------------------------- 1 | (* luml Test Suite Entry Point *) 2 | 3 | let () = 4 | Alcotest.run "luml Compiler" [ 5 | "Typing Tests", Typing_tests.test_set; 6 | "Lua Compile Tests", Lua_tests.test_set; 7 | "Exhaustiveness tests", Exhaustive_tests.test_set; 8 | "Error Tests", Error_tests.test_set; 9 | "Parsing Tests", Parsing_tests.test_set; 10 | ] 11 | -------------------------------------------------------------------------------- /test/parsing_tests.ml: -------------------------------------------------------------------------------- 1 | open Lib 2 | open Helpers 3 | 4 | let breaks () = 5 | let code = "(+) : Int -> Int -> Int\n(+) x y =\n @lua.+ x y\nadd10 = (+) 10" in 6 | (*add10 = (+) 10 in *) 7 | exec_with_type_and_res code "add10" "add10" 8 | |> must_succeed (fun (res_string, type_str) -> 9 | Alcotest.(check string) "Inferred Breaks" type_str "Int -> Int") 10 | 11 | let test_set = [ 12 | "Basic inference of breaks", `Slow, breaks; 13 | ] 14 | -------------------------------------------------------------------------------- /test/typing_tests.ml: -------------------------------------------------------------------------------- 1 | open Lib 2 | open Helpers 3 | 4 | 5 | let infer_recur () = 6 | let code = "map f l = match l with [] -> [] | h :: t -> (f h) :: map f t end" in 7 | exec_with_type_and_res code "map" "map" 8 | |> must_succeed (fun (res_string, type_str) -> 9 | Alcotest.(check string) 10 | "List Map Type" 11 | "(a -> b) -> List a -> List b" 12 | type_str) 13 | 14 | let infer_recur2 () = 15 | let code = "foldl f init items = 16 | match items with 17 | [] -> init 18 | | h :: t -> foldl f (f init h) t 19 | end 20 | map f = foldl (\\acc i -> (f i) :: acc) []" in 21 | 22 | exec_with_type_and_res code "map" "map" 23 | |> must_succeed (fun (res_string, type_str) -> 24 | Alcotest.(check string) 25 | "Foldl version of map" 26 | "(a -> b) -> List a -> List b" 27 | type_str) 28 | 29 | 30 | let adt () = 31 | let code = "type Jim = Bob String | Steve (Int -> String)\nhello = Steve\nmain = hello (\\x -> \"nope\")" in 32 | exec_with_type_and_res code "hello" "hello" 33 | |> must_succeed (fun (res_string, type_str) -> 34 | Alcotest.(check string) "Constructor yields correct type" type_str "(Int -> String) -> Jim") 35 | 36 | let poly_constructor () = 37 | let code = "type Option a = Some a | None\nmain = Some 42" in 38 | exec_with_type_and_res code "main" "main" 39 | |> must_succeed (fun (res_string, type_str) -> 40 | Alcotest.(check string) "Constructor yields correct type" type_str "Option Int") 41 | 42 | 43 | let adt_match () = 44 | let code = "type AdtTest = Only Int\nmain = match (Only 10) with Only 10 -> 10|Only x -> 0 end\n" in 45 | exec_with_type_and_res code "main" "main" 46 | |> must_succeed (fun (res_string, type_str) -> 47 | Alcotest.(check string) "Constructor result is 10" "10" res_string) 48 | 49 | let poly_adt_unification () = 50 | let code = "type Test a = Test a\ncompare : a -> a -> Bool\ncompare x y = @lua.+ x y\nmain = compare (Test 42) (Test false)" in 51 | let res = exec_code code in 52 | must_fail (function 53 | | {Lib.Ast.Error.error = Lib.Ast.Error.TypeMismatch _} -> () 54 | | _ -> Alcotest.fail "Expected type error") res 55 | 56 | let adt_type_sig () = 57 | let open Lib.Ast.Error in 58 | let code = 59 | [ "type WorAdt = WorAdt Int"; 60 | "pairWorAdt : WorAdt -> (WorAdt, WorAdt)"; 61 | "pairWorAdt x = (x, x)" 62 | ] |> String.concat "\n" in 63 | exec_with_type_and_res code "pairWorAdt" "pairWorAdt" 64 | |> must_succeed (fun (res_string, type_str) -> 65 | Alcotest.(check string) 66 | "Should have adopted the type from the sig" 67 | "WorAdt -> (WorAdt, WorAdt)" 68 | type_str); 69 | (* Is the signature respected? *) 70 | code ^ "\nmain = pairWorAdt 15" 71 | |> exec_code 72 | |> must_fail (function 73 | | { error = TypeMismatch _ } -> () 74 | | err -> 75 | Alcotest.fail 76 | ("Expected TypeMismatch, got " ^ (format_error err))) 77 | 78 | let adt_type_sig_with_args () = 79 | let open Lib.Ast.Error in 80 | let code = 81 | [ "type WorAdt a = WorAdt a"; 82 | "pairWorAdt : (WorAdt String) -> ((WorAdt String), (WorAdt String))"; 83 | "pairWorAdt x = (x, x)" 84 | ] |> String.concat "\n" in 85 | let success = "\nmain = pairWorAdt (WorAdt \"aye that'll dee\")" in 86 | exec_with_type_and_res (code ^ success) "main" "main" 87 | |> must_succeed (fun (res_string, type_str) -> 88 | Alcotest.(check string) 89 | "Type should match" 90 | "(WorAdt String, WorAdt String)" 91 | type_str); 92 | (* Is the signature respected? *) 93 | code ^ "\nmain = pairWorAdt (WorAdt true)" 94 | |> exec_code 95 | |> must_fail (function 96 | | { error = TypeMismatch _ } -> () 97 | | err -> 98 | Alcotest.fail 99 | ("Expected TypeMismatch, got " ^ (format_error err))) 100 | 101 | let adt_type_sig_with_args_list () = 102 | let open Lib.Ast.Error in 103 | let code = 104 | [ "type WorAdt a = WorAdt a"; 105 | "listWorAdt : (WorAdt String) -> List (WorAdt String)"; 106 | "listWorAdt x = [x]" 107 | ] |> String.concat "\n" in 108 | let success = "\nmain = listWorAdt (WorAdt \"aye that'll dee\")" in 109 | exec_with_type_and_res (code ^ success) "main" "main" 110 | |> must_succeed (fun (res_string, type_str) -> 111 | Alcotest.(check string) 112 | "Type should match" 113 | "List WorAdt String" 114 | type_str) 115 | 116 | let record_update_unify () = 117 | let code = "main x = { x | num = 42 }" in 118 | exec_with_type_and_res code "main" "main" 119 | |> must_succeed (fun (res_string, type_str) -> 120 | Alcotest.(check string) 121 | "Type should match" 122 | "{ num : Int, .. } -> { num : Int, .. }" 123 | type_str) 124 | 125 | let record_type_sig () = 126 | let code = 127 | [ "main : { name : String } -> { name : String }"; 128 | "main x = { x | name = \"michael\"}" ] |> String.concat "\n" in 129 | let fail = 130 | "\nres = main { name = \"steve\", age = 42 }" in 131 | exec_with_type_and_res code "main" "main" 132 | |> must_succeed (fun (res_string, type_str) -> 133 | Alcotest.(check string) 134 | "Type should match" 135 | "{ name : String } -> { name : String }" 136 | type_str); 137 | let open Lib.Ast.Error in 138 | (code ^ fail) 139 | |> exec_code 140 | |> must_fail (function 141 | | { error = FieldMismatch _ } -> () 142 | | err -> 143 | Alcotest.fail 144 | ("Exepected FieldMismatch, got " ^ (format_error err))) 145 | 146 | let typedef_test () = 147 | let code = 148 | [ "typedef DoubleInt = (Int, Int)"; 149 | "main : Int -> Int -> DoubleInt"; 150 | "main x y = (x, y)" ] |> String.concat "\n" in 151 | exec_with_type_and_res code "main" "main" 152 | |> must_succeed (fun (res_string, type_str) -> 153 | Alcotest.(check string) 154 | "Type should match" 155 | "Int -> Int -> DoubleInt" 156 | type_str) 157 | 158 | let polytypedef_tuple_test () = 159 | let open Lib.Ast.Error in 160 | [ "typedef Pair a = (a, a)"; 161 | "main : Int -> String -> Pair Int"; 162 | "main x y = (x, y)" ] |> String.concat "\n" 163 | |> exec_code 164 | |> must_fail (function 165 | | { error = TypeSignatureMismatch _ } -> () 166 | | err -> 167 | Alcotest.fail 168 | ("Expected TypeSignatureMismatch, got " ^ (format_error err))); 169 | let code = [ "typedef Pair a = (a, a)"; 170 | "main : Int -> Int -> Pair Int"; 171 | "main x y = (x, y)" ] |> String.concat "\n" in 172 | exec_with_type_and_res code "main" "main" 173 | |> must_succeed (fun (res_string, type_str) -> 174 | Alcotest.(check string) 175 | "Type should match" 176 | "Int -> Int -> Pair Int" 177 | type_str) 178 | 179 | 180 | 181 | let polytypedef_record_test () = 182 | let open Lib.Ast.Error in 183 | [ "typedef MyRecord a = { value : a}"; 184 | "main : String -> MyRecord Int"; 185 | "main x = { value = x }" ] |> String.concat "\n" 186 | |> exec_code 187 | |> must_fail (function 188 | | { error = TypeSignatureMismatch _ } -> () 189 | | err -> 190 | Alcotest.fail 191 | ("Expected TypeMismatch, got " ^ (format_error err))); 192 | 193 | let code = 194 | [ "typedef MyRecord a = { value : a }"; 195 | "main : Int -> MyRecord Int"; 196 | "main x = { value = x }" ] |> String.concat "\n" in 197 | exec_with_type_and_res code "main" "main" 198 | |> must_succeed (fun (res_string, type_str) -> 199 | Alcotest.(check string) 200 | "Type should match" 201 | "Int -> MyRecord Int" 202 | type_str) 203 | 204 | let polytypedef_list_test () = 205 | let open Lib.Ast.Error in 206 | [ "typedef MyType a = ((List a), a)"; 207 | "main : String -> MyType Int"; 208 | "main x = ([x], 5)" ] |> String.concat "\n" 209 | |> exec_code 210 | |> must_fail (function 211 | | { error = TypeMismatch _ } -> () 212 | | err -> 213 | Alcotest.fail 214 | ("Expected TypeMismatch, got " ^ (format_error err))); 215 | 216 | let code = [ "typedef MyType a = ((List a), a)"; 217 | "main : Int -> MyType Int"; 218 | "main x = ([x], x)" ] |> String.concat "\n" in 219 | 220 | exec_with_type_and_res code "main" "main" 221 | |> must_succeed (fun (res_string, type_str) -> 222 | Alcotest.(check string) 223 | "Type should match" 224 | "Int -> MyType Int" 225 | type_str) 226 | 227 | let recursive_type_def () = 228 | let open Lib.Ast.Error in 229 | [ "type Cons a = Cons (a, (Cons a)) | Nil"; 230 | "main x = Cons (true, (Cons (42, Nil)))"] |> String.concat "\n" 231 | |> exec_code 232 | |> must_fail (function 233 | | { error = TypeMismatch _ } -> () 234 | | err -> 235 | Alcotest.fail 236 | ("Expected TypeMismatch, got " ^ (format_error err))) 237 | 238 | let test_set = [ 239 | "Inference with recursive funs", `Slow, infer_recur; 240 | "Inference with recursive funs 2", `Slow, infer_recur2; 241 | "Adt Constructor", `Slow, adt; 242 | "Poly constructor", `Slow, poly_constructor; 243 | "Adt match", `Slow, adt_match; 244 | "Poly Adt Unification", `Slow, poly_adt_unification; 245 | "ADT in type sig", `Slow, adt_type_sig; 246 | "ADT with args in type sig", `Slow, adt_type_sig_with_args; 247 | "ADT with args in List type sig", `Slow, adt_type_sig_with_args_list; 248 | "Record update unification", `Slow, record_update_unify; 249 | "Record type sig", `Slow, record_type_sig; 250 | "Typedef", `Slow, typedef_test; 251 | "Poly typedef tuple", `Slow, polytypedef_tuple_test; 252 | "Poly typedef record", `Slow, polytypedef_record_test; 253 | "Recursive type def", `Slow, recursive_type_def; 254 | ] 255 | --------------------------------------------------------------------------------