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)