reader.c

Go to the documentation of this file.

/* -*- C -*-
 * Serene programming language
 * Copyright (C) 2019-2026 Sameer Rahmani <lxsameer@lxsameer.com>
 *
 * This library is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this library.  If not, see <https://www.gnu.org/licenses/>.
 */
 
#include "serene/ir/reader.h"
 
#include <stdio.h>
#include <string.h>
 
#include "serene/rt/context.h"
#include "serene/rt/core.h"
#include "serene/rt/engine.h"
#include "serene/rt/errors.h"
#include "serene/rt/fiber.h"
#include "serene/rt/impl/array_list.h"
#include "serene/rt/mm/interface.h"
#include "serene/utils.h"
#include "serene/vendor/utf8.h"
 
#define UNEXPECTED_CHAR_MSG_LEN 48
#define CHAR_BUFF_SIZE          5
 
#define C_LAMBDA 0x03BB
 
#define DEBUG_BUF_MAX_SIZE      4096
#define METADATA_STR_DEBUG_SIZE 48
 
static inline bool is_atom_char(utf8_int32_t c);
 
// -----------------------------------------------------------------------------
// Utilities
// -----------------------------------------------------------------------------
 
static inline utf8_int32_t peek(srn_sexp_parser_t *p) {
  utf8_int32_t c;
  utf8codepoint((const utf8_int8_t *)p->buffer + p->pos, &c);
  return c;
}
 
static inline utf8_int32_t advance(srn_sexp_parser_t *p) {
  utf8_int32_t c;
  const utf8_int8_t *next = utf8codepoint((const utf8_int8_t *)p->buffer + p->pos, &c);
  p->pos                  = (size_t)(next - (const utf8_int8_t *)p->buffer);
  return c;
}
 
/// The codepoint one past the current one, without moving `p`. `peek` only ever reads
/// at `p->pos` itself, so this is what tells a signed number ('-5') from a bare symbol
/// ('-'): decode the current codepoint just to find where it ends, then decode the one
/// after it.
static inline utf8_int32_t peek_next(srn_sexp_parser_t *p) {
  utf8_int32_t current;
  const utf8_int8_t *after_current =
    utf8codepoint((const utf8_int8_t *)p->buffer + p->pos, &current);
  // The terminator is the last byte the reader may look at, there is nothing
  // after it to decode.
  if (current == '\0') {
    return '\0';
  }
  utf8_int32_t next;
  utf8codepoint(after_current, &next);
  return next;
}
 
static inline bool is_whitespace(utf8_int32_t c) {
  return (c == ' ' || c == '\t' || c == '\n' || c == '\r' || c == '\f' || c == '\v') != 0;
}
 
/* static inline bool is_alpha(utf8_int32_t c) { */
/*   return ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')) != 0; */
/* } */
 
static inline bool is_digit(utf8_int32_t c) { return c >= '0' && c <= '9'; }
 
static inline bool is_at_end(srn_sexp_parser_t *p) { return peek(p) == '\0'; }
 
static inline void read_comment(srn_sexp_parser_t *p) {
  while (!is_at_end(p) && peek(p) != '\n') {
    advance(p);
  }
}
 
static inline void skip_whitespace(srn_sexp_parser_t *p) {
  while (!is_at_end(p)) {
    if (is_whitespace(peek(p))) {
      advance(p);
    } else if (peek(p) == ';') {
      read_comment(p);
    } else {
      break;
    }
  }
}
 
static inline bool is_atom_start(utf8_int32_t c) { return (!is_digit(c) && is_atom_char(c)) != 0; }
 
static inline bool is_number_start(utf8_int32_t c, utf8_int32_t next) {
  return (is_digit(c) || ((c == '-' || c == '+') && is_digit(next))) != 0;
}
 
static inline bool is_atom_char(utf8_int32_t c) {
  if (c == '\0' || is_whitespace(c)) {
    return false;
  }
  switch (c) {
  case '(':
  case ')':
  case '[':
  case ']':
  case '{':
  case '}':
  case '"':
  case ';':
    return false;
  default:
    return true;
  }
}
 
static inline srn_error_t *
parse_error(srn_sexp_parser_t *parser, const utf8_int32_t c, const char *msg) {
  srn_src_location_t *loc = ALLOC(parser->ctx, srn_src_location_t);
  PANIC_IF_NULL(loc);
  loc->buffer_id = parser->buffer_id;
  loc->offset    = parser->pos;
  loc->len       = 1;
 
  srn_metadata_t *metadata = ALLOC(parser->ctx, srn_metadata_t);
  PANIC_IF_NULL(metadata);
  metadata->loc      = loc;
  metadata->raw_expr = nullptr;
  metadata->ir_type  = IR_TYPE_IR_READER;
 
  char *error_msg;
 
  if (msg == nullptr) {
    char char_buf[CHAR_BUFF_SIZE] = {0};
    error_msg                     = ALLOCN(parser->ctx, char, UNEXPECTED_CHAR_MSG_LEN);
    utf8catcodepoint(char_buf, c, sizeof(char_buf) - 1);
    SNPRINTF(
      error_msg, UNEXPECTED_CHAR_MSG_LEN - 1, "Unexpected char '%s' at offset %u", char_buf,
      parser->pos
    );
  } else {
    size_t len = strlen(msg);
    error_msg  = ALLOCN_OR_PANIC(parser->ctx, char, len + 1);
    memcpy(error_msg, msg, len + 1);
  }
 
  srn_error_t *err = ALLOC(parser->ctx, srn_error_t);
  PANIC_IF_NULL(err);
  err->layer       = SRN_ERR_PARSE_LAYER;
  err->tag         = IR_PARSE_ERROR;
  err->msg         = error_msg;
  err->as.metadata = metadata;
  return err;
}
 
// -----------------------------------------------------------------------------
// Node builders
// -----------------------------------------------------------------------------
srn_sexp_node_t *srn_sexp_make_atom(srn_context_t *ctx, const char *name) {
  // NOTE: We assume name is allocated in an block, we just take it
  PANIC_IF_NULL(name);
  srn_sexp_atom_t *atom = ALLOC_OR_PANIC(ctx, srn_sexp_atom_t);
  srn_sexp_node_t *n    = srn_sexp_make_node(ctx, SRN_SEXP_ATOM);
 
  atom->name = (char *)name;
  n->as.atom = atom;
  return n;
}
 
srn_sexp_node_t *srn_sexp_make_str(srn_context_t *ctx, const char *data) {
  // NOTE: We assume data is allocated in an block, we just take it
  srn_sexp_str_t *s  = ALLOC_OR_PANIC(ctx, srn_sexp_str_t);
  srn_sexp_node_t *n = srn_sexp_make_node(ctx, SRN_SEXP_STR);
 
  s->data      = (char *)data;
  n->as.string = s;
 
  return n;
}
 
srn_sexp_node_t *srn_sexp_make_num(srn_context_t *ctx, const char *text) {
  // NOTE: We assume text is allocated in a block, we just take it
  PANIC_IF_NULL(text);
  srn_sexp_num_t *num = ALLOC_OR_PANIC(ctx, srn_sexp_num_t);
  srn_sexp_node_t *n  = srn_sexp_make_node(ctx, SRN_SEXP_NUM);
 
  num->text = (char *)text;
  n->as.num = num;
 
  return n;
}
 
srn_sexp_node_t *
srn_sexp_make_cons(srn_context_t *ctx, srn_sexp_node_t *head, srn_sexp_node_t *tail) {
  PANIC_IF_NULL(head);
 
  srn_sexp_cons_t *c = ALLOC_OR_PANIC(ctx, srn_sexp_cons_t);
  srn_sexp_node_t *n = srn_sexp_make_node(ctx, SRN_SEXP_CONS);
 
  c->head    = head;
  c->tail    = tail;
  n->as.cons = c;
 
  return n;
}
 
srn_sexp_node_t *srn_sexp_make_list(srn_context_t *ctx) {
  srn_sexp_list_t *l = ALLOC_OR_PANIC(ctx, srn_sexp_list_t);
  srn_sexp_node_t *n = srn_sexp_make_node(ctx, SRN_SEXP_LIST);
 
  l->head    = nullptr;
  l->len     = 0;
  n->as.list = l;
 
  return n;
}
srn_sexp_node_t *srn_sexp_make_node(srn_context_t *ctx, srn_sexp_node_type_e type) {
  auto n      = ALLOC_OR_PANIC(ctx, srn_sexp_node_t);
  n->type     = type;
  n->metadata = nullptr;
  return n;
}
 
// -----------------------------------------------------------------------------
// Readers
// -----------------------------------------------------------------------------
 
// Note to myself. A nested call (read_expr and what it dispatches to) reports a parse
// error by writing through it. That write has to reach the caller, so it must be `srn_error_t **`,
// not `srn_error_t *`. A plain pointer is passed by value in C, so an assignment like
// `err = parse_error(...)` inside the callee would only change the callee's own local copy and the
// caller's `err` would never see it.
static srn_sexp_node_t *read_list(srn_sexp_parser_t *parser, srn_error_t **err) {
  auto start = parser->pos;
 
  advance(parser); // consume '('
 
  skip_whitespace(parser);
 
  auto list                     = srn_sexp_make_list(parser->ctx);
  srn_sexp_node_t *current_tail = nullptr;
 
  while (!is_at_end(parser) && peek(parser) != ')') {
    srn_sexp_node_t *elem = read_expr(parser, err);
 
    if (*err != nullptr) {
      // We have a parse error, the error is already set via `err`
      return nullptr;
    }
 
    // Since elem might be the last element in the list tail is nullptr
    auto cons = srn_sexp_make_cons(parser->ctx, elem, nullptr);
 
    if (list->as.list->head == nullptr) {
      // empty list
      list->as.list->head = cons;
    } else {
      current_tail->as.cons->tail = cons;
    }
 
    current_tail = cons;
    list->as.list->len++;
 
    skip_whitespace(parser);
  }
 
  if (is_at_end(parser)) {
    *err = parse_error(parser, '\0', "Unterminated list, expected ')'");
    return nullptr;
  }
 
  advance(parser); // consume ')'
 
  srn_src_location_t *loc = ALLOC(parser->ctx, srn_src_location_t);
  PANIC_IF_NULL(loc);
  loc->buffer_id = parser->buffer_id;
  loc->offset    = start;
  loc->len       = parser->pos - start;
 
  srn_metadata_t *meta = ALLOC(parser->ctx, srn_metadata_t);
  meta->loc            = loc;
  meta->raw_expr       = list;
  meta->ir_type        = IR_TYPE_IR_READER;
  list->metadata       = meta;
 
  return list;
}
 
static srn_sexp_node_t *read_seq(srn_sexp_parser_t *parser, srn_error_t **err) {
  auto start = parser->pos;
 
  advance(parser); // consume '['
  array_list_t *elems = ALLOC(parser->ctx, array_list_t);
  PANIC_IF_NULL(elems);
  *elems = array_list_empty(parser->ctx);
 
  skip_whitespace(parser);
 
  while (!is_at_end(parser) && peek(parser) != ']') {
    srn_sexp_node_t *elem = read_expr(parser, err);
 
    if (*err != nullptr) {
      // We have a parse error
      return nullptr;
    }
 
    srn_error_t *push_err = array_list_push(elems, elem);
    if (push_err != nullptr) {
      *err = push_err;
      return nullptr;
    }
 
    skip_whitespace(parser);
  }
 
  if (is_at_end(parser)) {
    *err = parse_error(parser, '\0', "Unterminated list, expected ')'");
    return nullptr;
  }
 
  advance(parser); // consume ']'
 
  srn_src_location_t *loc = ALLOC(parser->ctx, srn_src_location_t);
  PANIC_IF_NULL(loc);
  loc->buffer_id = parser->buffer_id;
  loc->offset    = start;
  loc->len       = parser->pos - start;
 
  srn_sexp_node_t *node = ALLOC(parser->ctx, srn_sexp_node_t);
  PANIC_IF_NULL(node);
 
  srn_metadata_t *meta = ALLOC(parser->ctx, srn_metadata_t);
  meta->loc            = loc;
  meta->raw_expr       = node;
  meta->ir_type        = IR_TYPE_IR_READER;
 
  node->type     = SRN_SEXP_SEQ;
  node->metadata = meta;
  node->as.seq   = elems;
 
  return node;
}
 
static srn_sexp_node_t *read_atom(srn_sexp_parser_t *parser, srn_error_t **err) {
  UNUSED(err);
  auto start = parser->pos;
 
  while (!is_at_end(parser) && is_atom_char(peek(parser))) {
    advance(parser);
  }
 
  size_t len = parser->pos - start;
  char *name = ALLOCN_OR_PANIC(parser->ctx, char, len + 1);
 
  memcpy(name, (const char *)parser->buffer + start, len);
  name[len] = '\0';
 
  auto node = srn_sexp_make_atom(parser->ctx, name);
 
  srn_src_location_t *loc = ALLOC(parser->ctx, srn_src_location_t);
  PANIC_IF_NULL(loc);
  loc->buffer_id = parser->buffer_id;
  loc->offset    = start;
  loc->len       = parser->pos - start;
 
  srn_metadata_t *meta = ALLOC(parser->ctx, srn_metadata_t);
  PANIC_IF_NULL(meta);
  meta->loc      = loc;
  meta->raw_expr = node;
  meta->ir_type  = IR_TYPE_IR_READER;
 
  node->metadata = meta;
 
  return node;
}
 
/**
 * A number literal: an optional leading sign, digits, an optional '.'-separated
 * fractional part, and an optional 'e'/'E' exponent. Kept as the raw source text (see
 * srn_sexp_num_t), the reader only recognises the shape.
 */
static srn_sexp_node_t *read_number(srn_sexp_parser_t *parser, srn_error_t **err) {
  auto start = parser->pos;
 
  if (peek(parser) == '-' || peek(parser) == '+') {
    advance(parser);
  }
 
  while (!is_at_end(parser) && is_digit(peek(parser))) {
    advance(parser);
  }
 
  if (peek(parser) == '.' && is_digit(peek_next(parser))) {
    advance(parser); // consume '.'
    while (!is_at_end(parser) && is_digit(peek(parser))) {
      advance(parser);
    }
  }
 
  if (peek(parser) == 'e' || peek(parser) == 'E') {
    auto mark = parser->pos;
    advance(parser); // consume 'e'/'E'
 
    if (peek(parser) == '-' || peek(parser) == '+') {
      advance(parser);
    }
 
    if (is_digit(peek(parser))) {
      while (!is_at_end(parser) && is_digit(peek(parser))) {
        advance(parser);
      }
    } else {
      // Not actually an exponent (e.g. "1e" or "1efoo"), back out to before the
      // 'e'/'E' so it is left for the atom-char check below.
      parser->pos = mark;
    }
  }
 
  if (!is_at_end(parser) && is_atom_char(peek(parser))) {
    *err = parse_error(parser, peek(parser), "Malformed number literal");
    return nullptr;
  }
 
  size_t len = parser->pos - start;
  char *text = ALLOCN_OR_PANIC(parser->ctx, char, len + 1);
 
  memcpy(text, (const char *)parser->buffer + start, len);
  text[len] = '\0';
 
  auto node = srn_sexp_make_num(parser->ctx, text);
 
  srn_src_location_t *loc = ALLOC(parser->ctx, srn_src_location_t);
  PANIC_IF_NULL(loc);
  loc->buffer_id = parser->buffer_id;
  loc->offset    = start;
  loc->len       = parser->pos - start;
 
  srn_metadata_t *meta = ALLOC(parser->ctx, srn_metadata_t);
  PANIC_IF_NULL(meta);
  meta->loc      = loc;
  meta->raw_expr = node;
  meta->ir_type  = IR_TYPE_IR_READER;
 
  node->metadata = meta;
 
  return node;
}
 
static srn_sexp_node_t *read_string(srn_sexp_parser_t *parser, srn_error_t **err) {
  auto start = parser->pos;
 
  advance(parser); // consume opening '"'
 
  // Upper bound: raw byte count between the quotes can't exceed total buffer length.
  // Allocate that much, escape sequences only shrink the output.
  size_t cap = parser->len - parser->pos + 1;
  char *data = ALLOCN_OR_PANIC(parser->ctx, char, cap);
  size_t out = 0;
 
  while (!is_at_end(parser) && peek(parser) != '"') {
    utf8_int32_t c = advance(parser);
 
    if (c == '\\') {
      if (is_at_end(parser)) {
        break;
      }
 
      utf8_int32_t escaped = advance(parser);
      switch (escaped) {
      case '"':
        data[out++] = '"';
        break;
      case '\\':
        data[out++] = '\\';
        break;
      case 'n':
        data[out++] = '\n';
        break;
      case 't':
        data[out++] = '\t';
        break;
      case 'r':
        data[out++] = '\r';
        break;
      default: {
        data[out++] = '\\';
        // Re-encode the unrecognised codepoint as UTF-8. utf8catcodepoint returns the
        // advanced write pointer, not a byte count, so the bytes written is the
        // difference between it and where we started writing.
        char *dst  = data + out;
        char *next = (char *)utf8catcodepoint((utf8_int8_t *)dst, escaped, cap - out - 1);
        // The buffer was validated on entry, so a well formed codepoint
        // re-encodes to the same number of bytes it was read from and always
        // fits in `cap`.
        PANIC_IF_NULL(next);
        out += (size_t)(next - dst);
        break;
      }
      }
    } else {
      char *dst  = data + out;
      char *next = (char *)utf8catcodepoint((utf8_int8_t *)dst, c, cap - out - 1);
      PANIC_IF_NULL(next);
      out += (size_t)(next - dst);
    }
  }
 
  if (is_at_end(parser)) {
    *err = parse_error(parser, '\0', "Unterminated string, expected '\"'");
    return nullptr;
  }
 
  advance(parser); // consume closing '"'
  data[out] = '\0';
 
  auto node = srn_sexp_make_str(parser->ctx, data);
 
  srn_src_location_t *loc = ALLOC(parser->ctx, srn_src_location_t);
  PANIC_IF_NULL(loc);
  loc->buffer_id = parser->buffer_id;
  loc->offset    = start;
  loc->len       = parser->pos - start;
 
  srn_metadata_t *meta = ALLOC(parser->ctx, srn_metadata_t);
  PANIC_IF_NULL(meta);
  meta->loc      = loc;
  meta->raw_expr = node;
  meta->ir_type  = IR_TYPE_IR_READER;
 
  node->metadata = meta;
 
  return node;
}
 
srn_sexp_node_t *read_expr(srn_sexp_parser_t *parser, srn_error_t **err) {
  skip_whitespace(parser);
 
  utf8_int32_t c = peek(parser);
 
  if (c == '(') {
    return read_list(parser, err);
  }
 
  // Checked before is_atom_start: a sign like '-' is itself a valid atom-start
  // character (see is_atom_char), so "-5" would otherwise be read as the atom "-5"
  // never reaching read_number at all.
  if (is_number_start(c, peek_next(parser))) {
    return read_number(parser, err);
  }
 
  if (is_atom_start(c)) {
    return read_atom(parser, err);
  }
 
  if (c == '"') {
    return read_string(parser, err);
  }
 
  if (c == '[') {
    return read_seq(parser, err);
  }
 
  *err = parse_error(parser, c, nullptr);
  return nullptr;
}
 
srn_fiber_result_t read_from_buffer(srn_context_t *ctx, void *arg) {
  UNUSED(ctx);
  reader_fiber_arg_t *fiber_arg = arg;
 
  srn_sexp_parser_t *parser = fiber_arg->parser;
 
  auto sexps       = array_list_empty(parser->ctx);
  srn_error_t *err = nullptr;
 
  // Every decode below trusts the lead byte of a sequence and reads the
  // continuation bytes without looking for the terminator, so the whole buffer
  // is checked once here. A sequence cut short by the end of the buffer, a
  // continuation byte with no lead byte, and an overlong encoding are all
  // rejected, which also guarantees that re-encoding a codepoint never needs
  // more bytes than it was read from.
  const utf8_int8_t *bad = utf8nvalid((const utf8_int8_t *)parser->buffer, parser->len);
  if (bad != nullptr) {
    parser->pos = (uint32_t)(bad - (const utf8_int8_t *)parser->buffer);
    return parse_error(parser, '\0', "Malformed UTF-8 sequence");
  }
 
  // Whitespace and comments after the last expression are not an expression,
  // so they are consumed here rather than handed to `read_expr`.
  for (;;) {
    skip_whitespace(parser);
    if (is_at_end(parser)) {
      break;
    }
 
    auto expr = read_expr(parser, &err);
 
    if (err != nullptr) {
      return err;
    }
 
    err = array_list_push(&sexps, expr);
    if (err != nullptr) {
      return err;
    }
    srn_fiber_yield();
  }
 
  srn_sexp_tree_t *tree = ALLOC_OR_PANIC(parser->ctx, srn_sexp_tree_t);
  tree->maybe_error     = nullptr;
  tree->reading_context = parser->reading_context;
  tree->exprs           = sexps;
  fiber_arg->tree       = tree;
 
  return nullptr;
}
 
srn_sexp_tree_t *
srn_sexp_read_from_string(srn_context_t *ctx, void *reading_context, const char *buf) {
  // TODO(lxsameer): Extend the source manager to support sparse buffers and add the given
  // buffer here as a sparse buffer for the given namespace i guess
  return nullptr;
}
 
srn_sexp_tree_t *
srn_sexp_read_from_file(srn_context_t *ctx, void *reading_context, const char *path) {
  srn_sexp_tree_t *result = ALLOC_OR_PANIC(ctx, srn_sexp_tree_t);
 
  srn_sm_t *sm               = ctx->engine->source_manager;
  srn_sm_maybe_id_t maybe_id = srn_sm_read_buffer_file(sm, path, false);
 
  if (HAS_ERROR(maybe_id)) {
    PUSH_AND_MOVE(sm->ctx, maybe_id, *result);
    return result;
  }
 
  srn_sm_buffer_t *buf = srn_sm_get_buffer(sm, maybe_id.id);
  PANIC_IF_NULL(buf);
 
  if (buf->data == nullptr || buf->len == 0) {
    result->maybe_error     = nullptr;
    result->exprs           = array_list_empty(ctx);
    result->reading_context = reading_context;
    return result;
  }
 
  srn_sexp_parser_t parser = {
    .ctx             = ctx,
    .reading_context = reading_context,
    .buffer_id       = maybe_id.id,
    .buffer          = srn_sm_buffer_data(buf),
    .len             = srn_sm_buffer_len(buf),
    .pos             = 0,
  };
 
  reader_fiber_arg_t fiber_arg = {
    .parser = &parser,
    // This will be the output
    .tree = nullptr,
  };
 
  srn_fiber_t *fiber              = srn_fiber_spawn(ctx, read_from_buffer, &fiber_arg);
  srn_fiber_result_t fiber_result = srn_fiber_wait_for(fiber);
 
  if (fiber_result != nullptr) {
    result->maybe_error = (srn_error_t *)fiber_result;
    PUSH_TRACE(sm->ctx, *result);
    return result;
  }
 
  result = fiber_arg.tree;
  return result;
}
 
// -----------------------------------------------------------------------------
// Debug stuff
// -----------------------------------------------------------------------------
 
static inline const char *node_type_debug_name(srn_sexp_node_type_e type) {
  switch (type) {
  case SRN_SEXP_ATOM:
    return "ATOM";
  case SRN_SEXP_CONS:
    return "CONS";
  case SRN_SEXP_LIST:
    return "LIST";
  case SRN_SEXP_NUM:
    return "NUM";
  case SRN_SEXP_SEQ:
    return "SEQ";
  case SRN_SEXP_STR:
    return "STR";
  }
  return "UNKNOWN";
}
 
/**
 * Append `fragment` to the end of the `out` debug buffer (a `DEBUG_BUF_MAX_SIZE` buffer,
 * treated as a growing C string). Returns an error instead of overflowing the buffer.
 */
static srn_error_t *debug_buf_append(const srn_context_t *ctx, char *out, const char *fragment) {
  size_t used = strlen(out);
  size_t len  = strlen(fragment);
 
  if (used + len + 1 > DEBUG_BUF_MAX_SIZE) {
    return ERR(
      ctx, STRING_LENGTH_LIMIT_EXCEEDED, "Debug string exceeds the maximum debug buffer size"
    );
  }
 
  memcpy(out + used, fragment, len + 1);
  return nullptr;
}
 
static srn_error_t *
debug_buf_append_location(const srn_context_t *ctx, char *out, const srn_metadata_t *metadata) {
  char buf[METADATA_STR_DEBUG_SIZE] = {0};
 
  if (metadata != nullptr && metadata->loc != nullptr) {
    (void)snprintf(
      buf, sizeof(buf), "%" PRIu16 ":%" PRIu32 ":%" PRIu32, metadata->loc->buffer_id,
      metadata->loc->offset, metadata->loc->len
    );
  } else {
    (void)snprintf(buf, sizeof(buf), "?:?:?");
  }
 
  return debug_buf_append(ctx, out, buf);
}
 
static srn_error_t *
node_to_debug_strig(const srn_context_t *ctx, srn_sexp_node_t *node, char *out) {
  srn_error_t *err = debug_buf_append(ctx, out, "<");
  if (err != nullptr) {
    return err;
  }
 
  err = debug_buf_append(ctx, out, node_type_debug_name(node->type));
  if (err != nullptr) {
    return err;
  }
 
  err = debug_buf_append(ctx, out, "|");
  if (err != nullptr) {
    return err;
  }
 
  switch (node->type) {
  case SRN_SEXP_ATOM:
    err = debug_buf_append(ctx, out, node->as.atom->name);
    break;
 
  case SRN_SEXP_STR:
    err = debug_buf_append(ctx, out, node->as.string->data);
    break;
 
  case SRN_SEXP_NUM:
    err = debug_buf_append(ctx, out, node->as.num->text);
    break;
 
  case SRN_SEXP_CONS:
    err = node_to_debug_strig(ctx, node->as.cons->head, out);
 
    if (err == nullptr) {
      err = debug_buf_append(ctx, out, " . ");
    }
 
    if (err == nullptr) {
      if (node->as.cons->tail != nullptr) {
        err = node_to_debug_strig(ctx, node->as.cons->tail, out);
      } else {
        err = debug_buf_append(ctx, out, "nil");
      }
    }
    break;
 
  case SRN_SEXP_LIST: {
    srn_sexp_node_t *cons_node = node->as.list->head;
    bool first                 = true;
 
    while (cons_node != nullptr && err == nullptr) {
      if (!first) {
        err = debug_buf_append(ctx, out, " ");
      }
      first = false;
 
      if (err == nullptr) {
        err = node_to_debug_strig(ctx, cons_node->as.cons->head, out);
      }
 
      if (err == nullptr) {
        cons_node = cons_node->as.cons->tail;
      }
    }
    break;
  }
 
  case SRN_SEXP_SEQ: {
    for (size_t i = 0; i < node->as.seq->len && err == nullptr; i++) {
      if (i > 0) {
        err = debug_buf_append(ctx, out, " ");
      }
 
      if (err == nullptr) {
        array_list_maybe_element_t maybe = array_list_get(node->as.seq, i);
 
        if (HAS_ERROR(maybe)) {
          err = maybe.maybe_error;
        } else {
          err = node_to_debug_strig(ctx, (srn_sexp_node_t *)maybe.data, out);
        }
      }
    }
    break;
  }
  }
 
  if (err != nullptr) {
    return err;
  }
 
  err = debug_buf_append(ctx, out, "|");
  if (err != nullptr) {
    return err;
  }
 
  err = debug_buf_append_location(ctx, out, node->metadata);
  if (err != nullptr) {
    return err;
  }
 
  return debug_buf_append(ctx, out, ">");
}
 
static srn_error_t *
sexp_tree_reducer(array_list_t *exprs_array, size_t n, void *expr, void *state) {
  UNUSED(n);
  srn_sexp_node_t *node = expr;
  auto err              = node_to_debug_strig(exprs_array->ctx, node, state);
  return err;
}
 
const char *srn_sexp_to_debug_string(srn_context_t *ctx, srn_sexp_tree_t *tree) {
  // Since this function is for debugging purposes we set a hard limit on the buffer
  char *buf = srn_mm_malloc(ctx->engine->mm, sizeof(char) * DEBUG_BUF_MAX_SIZE);
  PANIC_IF_NULL(buf);
  buf[0] = '\0';
 
  auto err = array_list_reduce(&tree->exprs, sexp_tree_reducer, buf);
  PANIC_IF(err != nullptr, srn_error_to_string(ctx, err));
 
  return buf;
}