commit 582b2c8451202f5cc4633e71f1aef8e3cd7011be Author: milner Date: Wed Jan 4 10:18:00 2017 +0000 Add native build and compiler driver diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..7c78b53 --- /dev/null +++ b/.gitignore @@ -0,0 +1,10 @@ +_build/ +/deltac +_bench_out/ +bench/bench_results.txt +*.annot +*.cm[iox] +*.cma +*.cmxa +*.o +*.a diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..5fe9412 --- /dev/null +++ b/Makefile @@ -0,0 +1,164 @@ +PREFIX ?= /usr/local +DESTDIR ?= + +BINDIR = $(PREFIX)/bin +LIBDIR = $(PREFIX)/lib/delta + +OCAMLC ?= ocamlc +OCAMLOPT ?= ocamlopt +OCAMLDEP ?= ocamldep +OCAMLLEX ?= ocamllex +OCAMLYACC ?= ocamlyacc +INSTALL ?= install +RM = rm -f + +SRC_DIR = src +RUNTIME_DIR = runtime +TEST_DIR = test +BENCH_DIR = bench +BUILD = _build + +SRC_ML = $(wildcard $(SRC_DIR)/*.ml) +LIB_ML = $(filter-out $(SRC_DIR)/main.ml,$(SRC_ML)) +RT_ML = $(wildcard $(RUNTIME_DIR)/*.ml) +TEST_ML = $(wildcard $(TEST_DIR)/*.ml) +BENCH_ML = $(wildcard $(BENCH_DIR)/*.ml) + +LIB_CMX = $(patsubst $(SRC_DIR)/%.ml,$(BUILD)/%.cmx,$(LIB_ML)) +RT_CMX = $(patsubst $(RUNTIME_DIR)/%.ml,$(BUILD)/%.cmx,$(RT_ML)) +TEST_CMX = $(patsubst $(TEST_DIR)/%.ml,$(BUILD)/%.cmx,$(TEST_ML)) + +LIB_ARCHIVE = $(BUILD)/delta.cmxa +RUNTIME_ARCHIVE = $(BUILD)/delta_runtime.cmxa +RUNTIME_BYTE = $(BUILD)/delta_runtime.cma +RUNTIME_NATIVE = $(BUILD)/delta_runtime.a +RUNTIME_ARTIFACTS = $(RUNTIME_ARCHIVE) $(RUNTIME_NATIVE) $(RUNTIME_BYTE) \ + $(patsubst $(RUNTIME_DIR)/%.ml,$(BUILD)/%.cmi,$(RT_ML)) $(RT_CMX) + +ifeq ($(strip $(RT_ML)),) +RUNTIME_ARCHIVE = +RUNTIME_NATIVE = +RUNTIME_ARTIFACTS = +endif + +TEST_EXE = $(BUILD)/test_main +BENCH_EXE = $(BUILD)/bench + +FLAGS = -I $(BUILD) -I +unix +LIBS = unix.cmxa + +.PHONY: all clean test bench install uninstall + +all: deltac $(LIB_ARCHIVE) $(RUNTIME_ARCHIVE) $(TEST_EXE) + +$(BUILD): + mkdir -p $(BUILD) + +$(BUILD)/%.cmi: $(SRC_DIR)/%.mli | $(BUILD) + $(OCAMLC) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmo: $(SRC_DIR)/%.ml | $(BUILD) + $(OCAMLC) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmx: $(SRC_DIR)/%.ml | $(BUILD) + $(OCAMLOPT) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmi: $(RUNTIME_DIR)/%.mli | $(BUILD) + $(OCAMLC) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmo: $(RUNTIME_DIR)/%.ml | $(BUILD) + $(OCAMLC) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmx: $(RUNTIME_DIR)/%.ml | $(BUILD) + $(OCAMLOPT) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmi: $(TEST_DIR)/%.mli | $(BUILD) + $(OCAMLC) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmx: $(TEST_DIR)/%.ml | $(BUILD) + $(OCAMLOPT) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmx: $(BENCH_DIR)/%.ml | $(BUILD) + $(OCAMLOPT) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmx: $(BUILD)/%.ml | $(BUILD) + $(OCAMLOPT) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmo: $(BUILD)/%.ml | $(BUILD) + $(OCAMLC) $(FLAGS) -c $< -o $@ + +$(BUILD)/%.cmi: $(BUILD)/%.mli | $(BUILD) + $(OCAMLC) $(FLAGS) -c $< -o $@ + +GEN = +ifneq ($(wildcard $(SRC_DIR)/lexer.mll),) +GEN += $(BUILD)/lexer.ml +endif +ifneq ($(wildcard $(SRC_DIR)/parser.mly),) +GEN += $(BUILD)/parser.ml $(BUILD)/parser.mli +endif + +$(BUILD)/lexer.ml: $(SRC_DIR)/lexer.mll | $(BUILD) + $(OCAMLLEX) -o $@ $< + +$(BUILD)/parser.ml: $(SRC_DIR)/parser.mly | $(BUILD) + $(OCAMLYACC) -b $(BUILD)/parser $< + +$(BUILD)/parser.mli: $(BUILD)/parser.ml ; + +DEP_INCLUDES = -I $(SRC_DIR) $(if $(wildcard $(RUNTIME_DIR)),-I $(RUNTIME_DIR),) $(if $(wildcard $(TEST_DIR)),-I $(TEST_DIR),) -I $(BUILD) + +INTERFACES = $(wildcard $(SRC_DIR)/*.mli) $(wildcard $(RUNTIME_DIR)/*.mli) $(wildcard $(TEST_DIR)/*.mli) + +$(BUILD)/deps.d: $(SRC_ML) $(INTERFACES) $(RT_ML) $(TEST_ML) $(BENCH_ML) $(GEN) | $(BUILD) + $(OCAMLDEP) $(DEP_INCLUDES) $(SRC_ML) $(INTERFACES) $(RT_ML) $(TEST_ML) $(BENCH_ML) $(GEN) > $(BUILD)/deps.tmp + sed -e 's|$(SRC_DIR)/|$(BUILD)/|g' -e 's|$(RUNTIME_DIR)/|$(BUILD)/|g' \ + -e 's|$(TEST_DIR)/|$(BUILD)/|g' -e 's|$(BENCH_DIR)/|$(BUILD)/|g' \ + $(BUILD)/deps.tmp > $@ + $(RM) $(BUILD)/deps.tmp + +-include $(BUILD)/deps.d + +$(BUILD)/order.mk: $(SRC_ML) $(RT_ML) $(TEST_ML) | $(BUILD) + { echo -n "LIB_ORDER = " ; $(OCAMLDEP) -sort $(LIB_ML) | sed -e 's|$(SRC_DIR)/\([^ ]*\)\.ml|$(BUILD)/\1.cmx|g' ; echo ; } > $@ + { echo -n "RT_ORDER = " ; $(OCAMLDEP) -sort $(RT_ML) | sed -e 's|$(RUNTIME_DIR)/\([^ ]*\)\.ml|$(BUILD)/\1.cmx|g' ; echo ; } >> $@ + +-include $(BUILD)/order.mk + +$(LIB_ARCHIVE): $(LIB_CMX) $(BUILD)/order.mk + $(OCAMLOPT) -a -o $@ $(LIB_ORDER) + +deltac: $(BUILD)/main.cmx $(LIB_ARCHIVE) $(RUNTIME_ARCHIVE) + $(OCAMLOPT) $(FLAGS) -o $@ $(LIBS) $(LIB_ARCHIVE) $(RUNTIME_ARCHIVE) $(BUILD)/main.cmx + +$(RUNTIME_ARCHIVE) $(RUNTIME_NATIVE): $(RT_CMX) +ifeq ($(strip $(RT_ML)),) + @echo "no runtime sources" +else + $(OCAMLOPT) -a -o $@ $(RT_CMX) +endif + +ifeq ($(strip $(TEST_ML)),) +TEST_EXE = +else +$(TEST_EXE): $(TEST_CMX) $(LIB_ARCHIVE) $(RUNTIME_ARCHIVE) + $(OCAMLOPT) $(FLAGS) -o $@ $(LIBS) $(LIB_ARCHIVE) $(RUNTIME_ARCHIVE) $(TEST_CMX) +endif + +test: $(TEST_EXE) + DELTA_ROOT=$(CURDIR) DELTA_BUILD_DIR=$(CURDIR)/$(BUILD) ./$(TEST_EXE) + +bench: $(BENCH_EXE) + DELTA_ROOT=$(CURDIR) DELTA_BUILD_DIR=$(CURDIR)/$(BUILD) ./$(BENCH_EXE) + +install: deltac $(RUNTIME_ARCHIVE) + $(INSTALL) -d $(DESTDIR)$(BINDIR) $(DESTDIR)$(LIBDIR) + $(INSTALL) -m 755 deltac $(DESTDIR)$(BINDIR)/deltac + $(INSTALL) -m 644 $(RUNTIME_ARTIFACTS) $(DESTDIR)$(LIBDIR)/ + +uninstall: + $(RM) $(DESTDIR)$(BINDIR)/deltac + $(RM) $(patsubst $(BUILD)/%,$(DESTDIR)$(LIBDIR)/%,$(RUNTIME_ARTIFACTS)) + +clean: + rm -rf $(BUILD) deltac diff --git a/README.md b/README.md new file mode 100644 index 0000000..41ac814 --- /dev/null +++ b/README.md @@ -0,0 +1,26 @@ +# delta + +OCaml compiler for a small pure functional language of keyed collection +queries + +Collections are unordered finite maps from signed machine integers to values. +`map` preserves keys; `filter` keeps the keys of the rows it retains. Results +are printed in key order, so presentation is deterministic + +## Language + +```ocaml +type order = { + customer : string; + total : int; +} + +input orders : collection order + +let tax n = n * 20 / 100 + +query expensive_orders = + orders + |> filter (fun o -> o.total > 1000) + |> map (fun o -> (o.customer, tax o.total)) +``` diff --git a/descr b/descr new file mode 100644 index 0000000..a8a3b3b --- /dev/null +++ b/descr @@ -0,0 +1,7 @@ +delta +A compiler for a small pure functional query language. Source programs declare +record types, one keyed input collection, pure scalar helper functions and one +collection query. The compiler infers types, specialises helpers, normalises to +ANF, builds a collection dependency plan, and emits OCaml source containing +query specific initialization and incremental update code. A reference +interpreter and an incremental plan executor are used as correctness oracles. diff --git a/opam b/opam new file mode 100644 index 0000000..3b350d9 --- /dev/null +++ b/opam @@ -0,0 +1,17 @@ +opam-version: "1.2" +name: "delta" +version: "0.1.0" +maintainer: "deltac@localhost" +build: [ + [make] +] +install: [ + [make "install" "PREFIX=%{prefix}%"] +] +remove: [ + [make "uninstall" "PREFIX=%{prefix}%"] +] +depends: [ + "ocaml" {>= "4.04.0" & < "4.08.0"} +] +available: [ ocaml-version >= "4.04.0" ] diff --git a/src/diagnostic.ml b/src/diagnostic.ml new file mode 100644 index 0000000..79f628f --- /dev/null +++ b/src/diagnostic.ml @@ -0,0 +1,58 @@ +type t = { + file : string; + span : Location.span; + message : string; +} + +exception Error of t + +let current_file = ref "" + +let set_file file = current_file := file + +let file_label () = if !current_file = "" then "" else !current_file + +let file () = file_label () + +let error span fmt = + Printf.ksprintf + (fun message -> raise (Error { file = file_label (); span = span; message = message })) + fmt + +let make span message = { file = file_label (); span = span; message = message } + +let header d = + if Location.is_none d.span then Printf.sprintf "%s: error: %s" d.file d.message + else Printf.sprintf "%s:%d:%d: error: %s" d.file d.span.Location.start.Location.line + d.span.Location.start.Location.col d.message + +let to_string d = header d + +let source_line text line = + if line <= 0 then None + else + let lines = String.split_on_char '\n' text in + let rec nth items index = + match items with + | [] -> None + | head :: tail -> if index = 1 then Some head else nth tail (index - 1) + in + nth lines line + +let render source d = + let head = header d in + match source with + | None -> head + | Some text -> ( + match source_line text d.span.Location.start.Location.line with + | None -> head + | Some line -> + let col = max 1 d.span.Location.start.Location.col in + let width = + if d.span.Location.stop.Location.line = d.span.Location.start.Location.line then + max 1 (d.span.Location.stop.Location.col - col) + else max 1 (String.length line - col + 1) + in + let padding = String.make (col - 1) ' ' in + let carets = String.make width '^' in + Printf.sprintf "%s\n %s\n %s%s" head line padding carets) diff --git a/src/diagnostic.mli b/src/diagnostic.mli new file mode 100644 index 0000000..66b0310 --- /dev/null +++ b/src/diagnostic.mli @@ -0,0 +1,14 @@ +type t = { + file : string; + span : Location.span; + message : string; +} + +exception Error of t + +val set_file : string -> unit +val file : unit -> string +val error : Location.span -> ('a, unit, string, 'a) format4 -> 'a +val make : Location.span -> string -> t +val to_string : t -> string +val render : string option -> t -> string diff --git a/src/ident.ml b/src/ident.ml new file mode 100644 index 0000000..2df832c --- /dev/null +++ b/src/ident.ml @@ -0,0 +1,31 @@ +type t = { + name : string; + stamp : int; + span : Location.span; +} + +let next_stamp = ref 0 + +let create name span = + incr next_stamp; + { name = name; stamp = !next_stamp; span = span } + +let fresh = create + +let name id = id.name + +let stamp id = id.stamp + +let span id = id.span + +let equal a b = a.stamp = b.stamp + +let compare a b = compare a.stamp b.stamp + +let to_string id = Printf.sprintf "%s#%d" id.name id.stamp + +let display id = id.name + +let with_name id name = { id with name = name } + +let reset () = next_stamp := 0 diff --git a/src/ident.mli b/src/ident.mli new file mode 100644 index 0000000..52d2d53 --- /dev/null +++ b/src/ident.mli @@ -0,0 +1,13 @@ +type t + +val create : string -> Location.span -> t +val fresh : string -> Location.span -> t +val name : t -> string +val stamp : t -> int +val span : t -> Location.span +val equal : t -> t -> bool +val compare : t -> t -> int +val to_string : t -> string +val display : t -> string +val with_name : t -> string -> t +val reset : unit -> unit diff --git a/src/location.ml b/src/location.ml new file mode 100644 index 0000000..507893a --- /dev/null +++ b/src/location.ml @@ -0,0 +1,42 @@ +type pos = { + line : int; + col : int; + offset : int; +} + +type span = { + start : pos; + stop : pos; +} + +let none = { + start = { line = 0; col = 0; offset = 0 }; + stop = { line = 0; col = 0; offset = 0 }; +} + +let is_none span = + span.start.line = 0 && span.start.col = 0 && span.stop.line = 0 && span.stop.col = 0 + +let make start stop = { start = start; stop = stop } + +let point pos = { start = pos; stop = pos } + +let merge a b = + if is_none a then b + else if is_none b then a + else { start = a.start; stop = b.stop } + +let pos_of_lexing pos = + { line = pos.Lexing.pos_lnum; col = pos.Lexing.pos_cnum - pos.Lexing.pos_bol + 1; offset = pos.Lexing.pos_cnum } + +let span_of_lexing start stop = { start = pos_of_lexing start; stop = pos_of_lexing stop } + +let pos_to_string pos = Printf.sprintf "%d:%d" pos.line pos.col + +let to_string span = + if is_none span then "0:0" + else Printf.sprintf "%d:%d-%d:%d" span.start.line span.start.col span.stop.line span.stop.col + +let size span = + if is_none span then 0 + else (span.stop.offset - span.start.offset) diff --git a/src/location.mli b/src/location.mli new file mode 100644 index 0000000..b77635f --- /dev/null +++ b/src/location.mli @@ -0,0 +1,21 @@ +type pos = { + line : int; + col : int; + offset : int; +} + +type span = { + start : pos; + stop : pos; +} + +val none : span +val is_none : span -> bool +val make : pos -> pos -> span +val point : pos -> span +val merge : span -> span -> span +val pos_of_lexing : Lexing.position -> pos +val span_of_lexing : Lexing.position -> Lexing.position -> span +val pos_to_string : pos -> string +val to_string : span -> string +val size : span -> int diff --git a/src/main.ml b/src/main.ml new file mode 100644 index 0000000..7e6c0d1 --- /dev/null +++ b/src/main.ml @@ -0,0 +1,149 @@ +let version = "0.1.0" + +let usage = + String.concat "\n" + [ + "usage: deltac [options]"; + ""; + "commands:"; + " check FILE report errors in FILE"; + " dump --typed|--anf|--delta FILE print a compiler stage dump"; + " emit FILE -o OUTPUT.ml write generated OCaml source"; + " build FILE -o EXECUTABLE compile FILE to a native executable"; + ""; + "options:"; + " -o FILE output path for emit and build"; + " --version print the compiler version"; + " --help print this message"; + ""; + ] + +type command = + | Check of string + | Dump of string * string + | Emit of string * string + | Build of string * string + | Version + | Help + +let usage_error message = + prerr_endline ("deltac: " ^ message); + prerr_string usage; + exit 2 + +let parse_options args = + let rec loop files stage output rest = + match rest with + | [] -> (List.rev files, stage, output) + | "-o" :: value :: rest -> loop files stage (Some value) rest + | [ "-o" ] -> usage_error "option -o requires an argument" + | flag :: rest when flag = "--typed" || flag = "--anf" || flag = "--delta" -> + if stage <> None then usage_error "only one dump stage may be given" + else loop files (Some (String.sub flag 2 (String.length flag - 2))) output rest + | arg :: _ when String.length arg > 0 && arg.[0] = '-' -> usage_error ("unknown option " ^ arg) + | file :: rest -> loop (file :: files) stage output rest + in + loop [] None None args + +let single_file command files = + match files with + | [ file ] -> file + | [] -> usage_error (command ^ " requires a file") + | _ -> usage_error (command ^ " accepts exactly one file") + +let parse_command () = + let argv = Array.to_list Sys.argv in + match argv with + | _ :: "check" :: rest -> + let files, _, _ = parse_options rest in + Check (single_file "check" files) + | _ :: "dump" :: rest -> + let files, stage, _ = parse_options rest in + let stage = + match stage with + | Some stage -> stage + | None -> usage_error "dump requires --typed, --anf or --delta" + in + Dump (stage, single_file "dump" files) + | _ :: "emit" :: rest -> + let files, _, output = parse_options rest in + let file = single_file "emit" files in + let output = match output with Some output -> output | None -> usage_error "emit requires -o OUTPUT.ml" in + Emit (file, output) + | _ :: "build" :: rest -> + let files, _, output = parse_options rest in + let file = single_file "build" files in + let output = match output with Some output -> output | None -> usage_error "build requires -o EXECUTABLE" in + Build (file, output) + | _ :: ("--version" | "-version") :: _ -> Version + | _ :: ("--help" | "-help" | "help") :: _ -> Help + | [ _ ] -> usage_error "a command is required" + | _ :: unknown :: _ -> usage_error ("unknown command " ^ unknown) + | [] -> usage_error "a command is required" + +let load_source path = + Diagnostic.set_file path; + Native.read_file path + +let frontend_unavailable () = + Diagnostic.error Location.none "the delta source frontend is not implemented in this revision" + +let check path = + ignore (load_source path); + frontend_unavailable () + +let dump stage path = + ignore (load_source path); + ignore stage; + frontend_unavailable () + +let emit path output = + ignore (load_source path); + ignore output; + frontend_unavailable () + +let build path output = + ignore (load_source path); + ignore output; + frontend_unavailable () + +let source_of file = try Some (Native.read_file file) with _ -> None + +let report diagnostic = + prerr_endline (Diagnostic.render (source_of diagnostic.Diagnostic.file) diagnostic) + +let execute () = + match parse_command () with + | Help -> + print_string usage; + 0 + | Version -> + print_endline version; + 0 + | Check path -> + check path; + 0 + | Dump (stage, path) -> + dump stage path; + 0 + | Emit (path, output) -> + emit path output; + 0 + | Build (path, output) -> + build path output; + 0 + +let () = + let status = + try execute () with + | Diagnostic.Error diagnostic -> + report diagnostic; + 1 + | Sys_error message -> + prerr_endline ("deltac: " ^ message); + 1 + | Unix.Unix_error (error, fn, arg) -> + prerr_endline (Printf.sprintf "deltac: %s failed on %s: %s" fn arg (Unix.error_message error)); + 1 + in + exit status diff --git a/src/native.ml b/src/native.ml new file mode 100644 index 0000000..fe3a0bd --- /dev/null +++ b/src/native.ml @@ -0,0 +1,110 @@ +let read_file path = + let channel = open_in_bin path in + let length = in_channel_length channel in + let text = really_input_string channel length in + close_in channel; + text + +let env_opt name = try Some (Sys.getenv name) with Not_found -> None + +let file_exists path = Sys.file_exists path + +let normalize path = + let absolute = if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path else path in + let parts = String.split_on_char '/' absolute in + let step acc part = + match (part, acc) with + | "", acc -> acc + | ".", acc -> acc + | "..", (_ :: rest) -> rest + | "..", [] -> [] + | part, acc -> part :: acc + in + "/" ^ String.concat "/" (List.rev (List.fold_left step [] parts)) + +let which name = + if String.contains name '/' then (if file_exists name then Some (normalize name) else None) + else + let path = try Sys.getenv "PATH" with Not_found -> "" in + let rec search dirs = + match dirs with + | [] -> None + | dir :: rest -> + let candidate = Filename.concat (if dir = "" then "." else dir) name in + if file_exists candidate then Some (normalize candidate) else search rest + in + search (String.split_on_char ':' path) + +let executable_dir () = + let exe = Sys.executable_name in + match which (Filename.basename exe) with + | Some resolved -> Filename.dirname resolved + | None -> Filename.dirname (normalize exe) + +let first_some items = + let rec loop = function + | [] -> None + | item :: rest -> ( match item with Some _ -> item | None -> loop rest) + in + loop items + +let runtime_dir () = + match env_opt "DELTA_RUNTIME_DIR" with + | Some dir -> dir + | None -> + let here = executable_dir () in + let candidates = + [ + Filename.concat here "_build"; + normalize (Filename.concat here "../../lib/delta"); + normalize (Filename.concat here "../lib/delta"); + Filename.concat here "lib/delta"; + ] + in + let marked candidate = file_exists (Filename.concat candidate "delta_runtime.cmxa") in + let matches = List.map (fun candidate -> if marked candidate then Some candidate else None) candidates in + (match first_some matches with + | Some candidate -> candidate + | None -> ( match candidates with candidate :: _ -> candidate | [] -> here)) + +let temp_dir () = + let base = Filename.temp_file "deltac" "" in + Sys.remove base; + Unix.mkdir base 0o700; + base + +let remove_dir path = + let rec remove path = + if Sys.is_directory path then ( + let entries = Sys.readdir path in + Array.iter (fun entry -> remove (Filename.concat path entry)) entries; + Unix.rmdir path) + else Sys.remove path + in + try remove path with _ -> () + +let run argv = + let log = Filename.temp_file "deltac" ".log" in + let fd = Unix.openfile log [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in + let pid = + try Unix.create_process argv.(0) argv Unix.stdin fd fd + with error -> + Unix.close fd; + (try Sys.remove log with _ -> ()); + raise error + in + let status = snd (Unix.waitpid [] pid) in + Unix.close fd; + let text = try read_file log with _ -> "" in + (try Sys.remove log with _ -> ()); + (status, text) + +let compile ~runtime_dir ~source ~output = + let archive = Filename.concat runtime_dir "delta_runtime.cmxa" in + let argv = [| "ocamlopt"; "-I"; runtime_dir; "-o"; output; archive; source |] in + if file_exists output then Sys.remove output; + let status, text = run argv in + match status with + | Unix.WEXITED 0 when file_exists output -> None + | Unix.WEXITED 0 -> Some (text ^ "\nocamlopt did not produce " ^ output) + | _ -> Some text diff --git a/src/native.mli b/src/native.mli new file mode 100644 index 0000000..cd0a804 --- /dev/null +++ b/src/native.mli @@ -0,0 +1,11 @@ +val read_file : string -> string +val env_opt : string -> string option +val file_exists : string -> bool +val normalize : string -> string +val which : string -> string option +val executable_dir : unit -> string +val runtime_dir : unit -> string +val temp_dir : unit -> string +val remove_dir : string -> unit +val run : string array -> Unix.process_status * string +val compile : runtime_dir:string -> source:string -> output:string -> string option diff --git a/test/test_harness.ml b/test/test_harness.ml new file mode 100644 index 0000000..08f1ee9 --- /dev/null +++ b/test/test_harness.ml @@ -0,0 +1,65 @@ +type case = string * (unit -> unit) + +let failures = ref 0 + +let cases = ref 0 + +let check name condition = + incr cases; + if condition then Printf.printf "ok %s\n" name + else ( + incr failures; + Printf.printf "FAIL %s\n" name) + +let fail name message = + incr cases; + incr failures; + Printf.printf "FAIL %s: %s\n" name message + +let check_equal_int name expected actual = + incr cases; + if expected = actual then Printf.printf "ok %s\n" name + else ( + incr failures; + Printf.printf "FAIL %s: expected %d, got %d\n" name expected actual) + +let check_equal_string name expected actual = + incr cases; + if expected = actual then Printf.printf "ok %s\n" name + else ( + incr failures; + Printf.printf "FAIL %s: expected %S, got %S\n" name expected actual) + +let check_true name message condition = + if condition then (incr cases; Printf.printf "ok %s\n" name) + else fail name message + +let expect_diagnostic name thunk = + incr cases; + try + thunk (); + incr failures; + Printf.printf "FAIL %s: expected a diagnostic error\n" name + with + | Diagnostic.Error diagnostic -> + if diagnostic.Diagnostic.message = "" then ( + incr failures; + Printf.printf "FAIL %s: empty diagnostic message\n" name) + else Printf.printf "ok %s\n" name + | error -> + incr failures; + Printf.printf "FAIL %s: unexpected exception %s\n" name (Printexc.to_string error) + +let run_case (name, thunk) = + try thunk () with + | exception_ -> + incr failures; + Printf.printf "FAIL %s: raised %s\n" name (Printexc.to_string exception_) + +let run_suite suite cases = + print_endline ("--- " ^ suite ^ " ---"); + List.iter run_case cases + +let failure_count () = !failures + +let case_count () = !cases diff --git a/test/test_harness.mli b/test/test_harness.mli new file mode 100644 index 0000000..1f23d82 --- /dev/null +++ b/test/test_harness.mli @@ -0,0 +1,11 @@ +type case = string * (unit -> unit) + +val check : string -> bool -> unit +val fail : string -> string -> unit +val check_equal_int : string -> int -> int -> unit +val check_equal_string : string -> string -> string -> unit +val check_true : string -> string -> bool -> unit +val expect_diagnostic : string -> (unit -> unit) -> unit +val run_suite : string -> case list -> unit +val failure_count : unit -> int +val case_count : unit -> int diff --git a/test/test_main.ml b/test/test_main.ml new file mode 100644 index 0000000..3baedae --- /dev/null +++ b/test/test_main.ml @@ -0,0 +1,84 @@ +open Test_harness + +let position line col offset = { Location.line = line; col = col; offset = offset } + +let span line1 col1 line2 col2 = + Location.make (position line1 col1 0) (position line2 col2 10) + +let location_cases = + let open Location in + [ + ( "merge of two spans uses first start and second stop", + fun () -> + check_equal_string "merged span" "1:2-3:4" + (to_string (merge (span 1 2 1 5) (span 3 1 3 4))) ); + ("merge with none returns the other span", fun () -> + check_equal_string "none merge" "2:3-2:3" (to_string (merge none (point (position 2 3 7))))); + ("is_none distinguishes the empty span", fun () -> + check "none is none" (is_none none); + check "point is not none" (not (is_none (point (position 1 1 0))))); + ("size measures offsets", fun () -> + check_equal_int "size" 10 (size (span 1 1 2 1))); + ("pos_to_string renders line and column", fun () -> + check_equal_string "pos" "12:34" (pos_to_string (position 12 34 100))); + ] + +let ident_cases = + [ + ( "fresh identifiers get distinct stamps", + fun () -> + Ident.reset (); + let a = Ident.fresh "x" Location.none in + let b = Ident.fresh "x" Location.none in + check "distinct" (not (Ident.equal a b)); + check_equal_int "compare is stamp order" (-1) (Ident.compare a b) ); + ( "display keeps the source name while to_string is unique", + fun () -> + Ident.reset (); + let a = Ident.fresh "row" Location.none in + check_equal_string "display" "row" (Ident.display a); + check_equal_string "to_string" "row#1" (Ident.to_string a) ); + ( "reset restarts numbering deterministically", + fun () -> + Ident.reset (); + let first = Ident.fresh "x" Location.none in + Ident.reset (); + let second = Ident.fresh "x" Location.none in + check_equal_int "same stamp after reset" (Ident.stamp first) (Ident.stamp second) ); + ( "identifiers carry their source span", + fun () -> + Ident.reset (); + let a = Ident.fresh "x" (span 4 5 4 6) in + check_equal_string "span" "4:5-4:6" (Location.to_string (Ident.span a)) ); + ] + +let diagnostic_cases = + [ + ( "diagnostic renders file line column and message", + fun () -> + let d = Diagnostic.make (span 2 3 2 4) "unknown variable total" in + check_equal_string "to_string" ":2:3: error: unknown variable total" + (Diagnostic.to_string d) ); + ( "diagnostic renders a source excerpt with carets", + fun () -> + let d = Diagnostic.make (span 2 5 2 9) "bad field" in + let rendered = Diagnostic.render (Some "let a = 1\nlet b = a.bad\n") d in + check_true "rendered contains header" rendered + (rendered = ":2:5: error: bad field\n let b = a.bad\n ^^^^") ); + ( "error raises with the current file", + fun () -> + Diagnostic.set_file "sample.delta"; + (try + Diagnostic.error (span 1 1 1 2) "boom"; + fail "raises" "expected an error" + with Diagnostic.Error d -> + check_equal_string "file" "sample.delta" d.Diagnostic.file); + Diagnostic.set_file "" ); + ] + +let () = + Test_harness.run_suite "location" location_cases; + Test_harness.run_suite "ident" ident_cases; + Test_harness.run_suite "diagnostic" diagnostic_cases; + Printf.printf "%d cases, %d failures\n" (Test_harness.case_count ()) (Test_harness.failure_count ()); + exit (if Test_harness.failure_count () = 0 then 0 else 1)