Add native build and compiler driver

.gitignore

@@ -0,0 +1,10 @@
+_build/
+/deltac
+_bench_out/
+bench/bench_results.txt
+*.annot
+*.cm[iox]
+*.cma
+*.cmxa
+*.o
+*.a

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

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))
+```

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.

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" ]

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 "<none>" 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)

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

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

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

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)

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

src/main.ml

@@ -0,0 +1,149 @@
+let version = "0.1.0"
+
+let usage =
+  String.concat "\n"
+    [
+      "usage: deltac <command> [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

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

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

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

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

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" "<none>: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 = "<none>: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)