Add typed wire input and native executable builds
This commit is contained in:
11 files changed
+857
-8
No files matched your search
+353
@@ -0,0 +1,353 @@
|
||||
type value =
|
||||
| WUnit
|
||||
| WInt of int
|
||||
| WBool of bool
|
||||
| WString of string
|
||||
| WTuple of value list
|
||||
| WRecord of (string * value) list
|
||||
| WCollection of (int * value) list
|
||||
|
||||
type op = WInsert of int * value | WRemove of int | WReplace of int * value
|
||||
|
||||
type state = {
|
||||
text : string;
|
||||
mutable position : int;
|
||||
mutable line : int;
|
||||
mutable column : int;
|
||||
}
|
||||
|
||||
let failure state message =
|
||||
Delta_runtime.Failure (Printf.sprintf "line %d, column %d: %s" state.line state.column message)
|
||||
|
||||
let failure_at state line column message =
|
||||
Delta_runtime.Failure (Printf.sprintf "line %d, column %d: %s" line column message)
|
||||
|
||||
let at_end state = state.position >= String.length state.text
|
||||
|
||||
let peek state = if at_end state then '\000' else state.text.[state.position]
|
||||
|
||||
let advance state =
|
||||
(if peek state = '\n' then (
|
||||
state.line <- state.line + 1;
|
||||
state.column <- 1)
|
||||
else state.column <- state.column + 1);
|
||||
state.position <- state.position + 1
|
||||
|
||||
let rec skip_space state =
|
||||
if not (at_end state) then
|
||||
match peek state with
|
||||
| ' ' | '\t' | '\r' | '\n' ->
|
||||
advance state;
|
||||
skip_space state
|
||||
| _ -> ()
|
||||
|
||||
let expect state character =
|
||||
if peek state = character then (
|
||||
advance state;
|
||||
true)
|
||||
else false
|
||||
|
||||
let is_digit character = character >= '0' && character <= '9'
|
||||
|
||||
let is_symbol_start character =
|
||||
(character >= 'a' && character <= 'z')
|
||||
|| (character >= 'A' && character <= 'Z')
|
||||
|| character = '_'
|
||||
|
||||
let is_symbol_char character = is_symbol_start character || is_digit character || character = '\''
|
||||
|
||||
let read_symbol state =
|
||||
let start = state.position in
|
||||
let rec scan () =
|
||||
if not (at_end state) && is_symbol_char (peek state) then (
|
||||
advance state;
|
||||
scan ())
|
||||
in
|
||||
scan ();
|
||||
String.sub state.text start (state.position - start)
|
||||
|
||||
let read_string state =
|
||||
advance state;
|
||||
let buffer = Buffer.create 16 in
|
||||
let rec scan () =
|
||||
if at_end state then failure state "unterminated string"
|
||||
else
|
||||
let character = peek state in
|
||||
if character = '"' then (
|
||||
advance state;
|
||||
Delta_runtime.Success (Buffer.contents buffer))
|
||||
else if character = '\\' then (
|
||||
advance state;
|
||||
let escaped =
|
||||
if at_end state then '\000'
|
||||
else
|
||||
let next = peek state in
|
||||
advance state;
|
||||
next
|
||||
in
|
||||
match escaped with
|
||||
| 'n' ->
|
||||
Buffer.add_char buffer '\n';
|
||||
scan ()
|
||||
| 't' ->
|
||||
Buffer.add_char buffer '\t';
|
||||
scan ()
|
||||
| 'r' ->
|
||||
Buffer.add_char buffer '\r';
|
||||
scan ()
|
||||
| '"' ->
|
||||
Buffer.add_char buffer '"';
|
||||
scan ()
|
||||
| '\\' ->
|
||||
Buffer.add_char buffer '\\';
|
||||
scan ()
|
||||
| other -> failure state (Printf.sprintf "unknown escape sequence \\%c" other))
|
||||
else if character = '\n' then failure state "unterminated string"
|
||||
else (
|
||||
Buffer.add_char buffer character;
|
||||
advance state;
|
||||
scan ())
|
||||
in
|
||||
scan ()
|
||||
|
||||
let read_integer state =
|
||||
let start = state.position in
|
||||
if peek state = '-' then advance state;
|
||||
if not (is_digit (peek state)) then failure state "expected an integer"
|
||||
else (
|
||||
let rec scan () =
|
||||
if is_digit (peek state) then (
|
||||
advance state;
|
||||
scan ())
|
||||
in
|
||||
scan ();
|
||||
let text = String.sub state.text start (state.position - start) in
|
||||
try Delta_runtime.Success (int_of_string text)
|
||||
with Failure _ -> failure state (Printf.sprintf "integer %s does not fit in a machine integer" text))
|
||||
|
||||
let rec read_value state =
|
||||
skip_space state;
|
||||
if at_end state then failure state "expected a value"
|
||||
else
|
||||
match peek state with
|
||||
| '(' -> read_compound state
|
||||
| '"' -> (
|
||||
match read_string state with
|
||||
| Delta_runtime.Success text -> Delta_runtime.Success (WString text)
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message)
|
||||
| character when is_digit character || character = '-' -> (
|
||||
match read_integer state with
|
||||
| Delta_runtime.Success number -> Delta_runtime.Success (WInt number)
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message)
|
||||
| character when is_symbol_start character ->
|
||||
let symbol = read_symbol state in
|
||||
if symbol = "true" then Delta_runtime.Success (WBool true)
|
||||
else if symbol = "false" then Delta_runtime.Success (WBool false)
|
||||
else if symbol = "unit" then Delta_runtime.Success WUnit
|
||||
else failure state (Printf.sprintf "unknown scalar `%s`" symbol)
|
||||
| character -> failure state (Printf.sprintf "unexpected character %C" character)
|
||||
|
||||
and read_compound state =
|
||||
ignore (expect state '(');
|
||||
skip_space state;
|
||||
if not (is_symbol_start (peek state)) then failure state "expected a tagged value"
|
||||
else
|
||||
let tag_line = state.line in
|
||||
let tag_column = state.column in
|
||||
let tag = read_symbol state in
|
||||
match tag with
|
||||
| "tuple" ->
|
||||
let rec items acc =
|
||||
skip_space state;
|
||||
if expect state ')' then Delta_runtime.Success (WTuple (List.rev acc))
|
||||
else (
|
||||
match read_value state with
|
||||
| Delta_runtime.Success value -> items (value :: acc)
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message)
|
||||
in
|
||||
items []
|
||||
| "record" ->
|
||||
let rec fields acc =
|
||||
skip_space state;
|
||||
if expect state ')' then Delta_runtime.Success (WRecord (List.rev acc))
|
||||
else if peek state <> '(' then failure state "expected a record field"
|
||||
else (
|
||||
ignore (expect state '(');
|
||||
skip_space state;
|
||||
if not (is_symbol_start (peek state)) then failure state "expected a field label"
|
||||
else
|
||||
let label = read_symbol state in
|
||||
match read_value state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success value ->
|
||||
skip_space state;
|
||||
if not (expect state ')') then failure state "expected `)` after a record field"
|
||||
else fields ((label, value) :: acc))
|
||||
in
|
||||
fields []
|
||||
| "collection" ->
|
||||
let rec entries acc =
|
||||
skip_space state;
|
||||
if expect state ')' then Delta_runtime.Success (WCollection (List.rev acc))
|
||||
else if peek state <> '(' then failure state "expected a collection entry"
|
||||
else (
|
||||
ignore (expect state '(');
|
||||
match read_integer state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success key -> (
|
||||
match read_value state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success value ->
|
||||
skip_space state;
|
||||
if not (expect state ')') then failure state "expected `)` after a collection entry"
|
||||
else entries ((key, value) :: acc)))
|
||||
in
|
||||
entries []
|
||||
| other -> failure_at state tag_line tag_column (Printf.sprintf "unknown tag `%s`" other)
|
||||
|
||||
let to_string value =
|
||||
let rec render value =
|
||||
match value with
|
||||
| WUnit -> "unit"
|
||||
| WInt number -> string_of_int number
|
||||
| WBool true -> "true"
|
||||
| WBool false -> "false"
|
||||
| WString text ->
|
||||
let buffer = Buffer.create (String.length text + 2) in
|
||||
Buffer.add_char buffer '"';
|
||||
String.iter
|
||||
(fun character ->
|
||||
match character with
|
||||
| '"' -> Buffer.add_string buffer "\\\""
|
||||
| '\\' -> Buffer.add_string buffer "\\\\"
|
||||
| '\n' -> Buffer.add_string buffer "\\n"
|
||||
| '\t' -> Buffer.add_string buffer "\\t"
|
||||
| '\r' -> Buffer.add_string buffer "\\r"
|
||||
| other -> Buffer.add_char buffer other)
|
||||
text;
|
||||
Buffer.add_char buffer '"';
|
||||
Buffer.contents buffer
|
||||
| WTuple items -> "(tuple " ^ String.concat " " (List.map render items) ^ ")"
|
||||
| WRecord fields ->
|
||||
"(record "
|
||||
^ String.concat " " (List.map (fun (label, value) -> "(" ^ label ^ " " ^ render value ^ ")") fields)
|
||||
^ ")"
|
||||
| WCollection entries ->
|
||||
"(collection "
|
||||
^ String.concat " "
|
||||
(List.rev (List.rev_map (fun (key, value) -> Printf.sprintf "(%d %s)" key (render value)) entries))
|
||||
^ ")"
|
||||
in
|
||||
render value
|
||||
|
||||
let field_value label fields =
|
||||
let matches = List.filter (fun (candidate, _) -> candidate = label) fields in
|
||||
match matches with
|
||||
| [] -> Delta_runtime.Failure (Printf.sprintf "missing field `%s`" label)
|
||||
| [ (_, value) ] -> Delta_runtime.Success value
|
||||
| _ -> Delta_runtime.Failure (Printf.sprintf "duplicate field `%s`" label)
|
||||
|
||||
let parse_value text =
|
||||
let state = { text = text; position = 0; line = 1; column = 1 } in
|
||||
match read_value state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success value ->
|
||||
skip_space state;
|
||||
if at_end state then Delta_runtime.Success value
|
||||
else failure state "unexpected trailing input"
|
||||
|
||||
let parse_input text =
|
||||
let state = { text = text; position = 0; line = 1; column = 1 } in
|
||||
let rec entries acc =
|
||||
skip_space state;
|
||||
if at_end state then Delta_runtime.Success (List.rev acc)
|
||||
else if peek state <> '(' then failure state "expected `(key value)`"
|
||||
else (
|
||||
ignore (expect state '(');
|
||||
match read_integer state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success key -> (
|
||||
match read_value state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success value ->
|
||||
skip_space state;
|
||||
if not (expect state ')') then failure state "expected `)` after an input entry"
|
||||
else entries ((key, value) :: acc)))
|
||||
in
|
||||
entries []
|
||||
|
||||
let parse_operation state =
|
||||
ignore (expect state '(');
|
||||
skip_space state;
|
||||
let tag = read_symbol state in
|
||||
skip_space state;
|
||||
match tag with
|
||||
| "insert" -> (
|
||||
match read_integer state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success key -> (
|
||||
match read_value state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success value ->
|
||||
skip_space state;
|
||||
if not (expect state ')') then failure state "expected `)` after an insert"
|
||||
else Delta_runtime.Success (WInsert (key, value))))
|
||||
| "remove" -> (
|
||||
match read_integer state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success key ->
|
||||
skip_space state;
|
||||
if not (expect state ')') then failure state "expected `)` after a remove"
|
||||
else Delta_runtime.Success (WRemove key))
|
||||
| "replace" -> (
|
||||
match read_integer state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success key -> (
|
||||
match read_value state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success value ->
|
||||
skip_space state;
|
||||
if not (expect state ')') then failure state "expected `)` after a replace"
|
||||
else Delta_runtime.Success (WReplace (key, value))))
|
||||
| other -> failure state (Printf.sprintf "unknown update operation `%s`" other)
|
||||
|
||||
let parse_updates text =
|
||||
let state = { text = text; position = 0; line = 1; column = 1 } in
|
||||
let rec batches acc =
|
||||
skip_space state;
|
||||
if at_end state then Delta_runtime.Success (List.rev acc)
|
||||
else if peek state <> '(' then failure state "expected `(batch ...)`"
|
||||
else (
|
||||
ignore (expect state '(');
|
||||
skip_space state;
|
||||
let tag_line = state.line in
|
||||
let tag_column = state.column in
|
||||
let tag = read_symbol state in
|
||||
if tag <> "batch" then
|
||||
failure_at state tag_line tag_column (Printf.sprintf "expected `batch` but found `%s`" tag)
|
||||
else
|
||||
let rec operations acc =
|
||||
skip_space state;
|
||||
if expect state ')' then Delta_runtime.Success (List.rev acc)
|
||||
else if peek state <> '(' then failure state "expected an update operation"
|
||||
else
|
||||
match parse_operation state with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success operation -> operations (operation :: acc)
|
||||
in
|
||||
match operations [] with
|
||||
| Delta_runtime.Failure message -> Delta_runtime.Failure message
|
||||
| Delta_runtime.Success operations -> batches (operations :: acc))
|
||||
in
|
||||
batches []
|
||||
|
||||
let read_file path =
|
||||
try
|
||||
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;
|
||||
Delta_runtime.Success text
|
||||
with
|
||||
| Sys_error message -> Delta_runtime.Failure message
|
||||
| End_of_file -> Delta_runtime.Failure (Printf.sprintf "could not read %s" path)
|
||||
Reference in new issue
Block a user