{ json.a68 - JSON support.

  Copyright (C) 2026 Jose E. Marchesi

  This program is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  This program 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
  General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with this program.  If not, see
  <https://www.gnu.org/licenses/>. }

module JSON =
    access Utils
def
    { JSON values.

      Numbers and boolean values are handled as obvious.
      The "null" JSON value is expressed as an empty union.

      JSON arrays are ordered collections of elements, which are other
      JSON values.

      JSON objects are unordered collections of fields, which are
      name/value pairs. }

    pub mode JSON_Val = union (void,bool,int,string,ref JSON_Arr,ref JSON_Obj),
             JSON_Arr = struct (ref JSON_Elm elements),
             JSON_Obj = struct (ref JSON_Fld fields),
             JSON_Elm = struct (JSON_Val value, ref JSON_Elm next),
             JSON_Fld = struct (JSON_Val name, value, ref JSON_Fld next);

    { Nihils. }

    pub ref JSON_Val json_no_val = nil,
        ref JSON_Elm json_no_elm = nil;
        ref JSON_Fld json_no_fld = nil;

    { The following procedures are intended to be used as
      initialization values for JSON_Val variable initializations or
      ascriptions. }

    pub proc json_new_obj = JSON_Val: heap JSON_Obj,
             json_new_arr = JSON_Val: heap JSON_Arr;

    { Error handling procedure.

      The default version aborts with an assert, but users of this
      library can set it to handler of their own. }

    pub proc(string)void json_error := (string msg) void: (assert(false));

    { Return the number of elements in a JSON array.  Return 0 for
      other kind of objects. }

    pub op LEN = (JSON_Val v) int:
       (v
        | (ref JSON_Arr a):
             (int len := 0; json_foreach_elem(a, (ref JSON_Val v) void: len +:= 1); len)
        | 0);

    { The operator -> gets a JSON value, which must be an object, and
      a field name, and returns a name referring to the field of that
      name stored in the object.  If there is no such a field, one is
      created with associated value "empty".

      This operator can be used to easily create a JSON object and
      refer to its fields.  For example:

        JSON_Val obj = json_new_obj;
        obj->"name" := "Frau Korinna Georgina";
        obj->"address" := "Pleasance Road 233";
        obj->"age" := 50;

        register_address (obj->"address");

      If the given JSON value is not an object then this procedure
      calls the json error handling routine. }

    pub prio -> = 9;
    pub op -> = (JSON_Val v, string fname) ref JSON_Val:
       case v
       in (ref JSON_Obj o):
             begin ref JSON_Fld field := fields of o, bool found := false;
                   while (field :/=: json_no_fld) AND NOT found
                   do if json_str(name of field) = fname
                      then found := true
                      else field := next of field
                      fi
                   od;
                   if field :=: json_no_fld
                   then { Create a new field with a new "null" element and
                              link to the object. }
                        field := heap JSON_Fld := (fname, empty, fields of o);
                        ref ref JSON_Fld (fields of o) := field
                   fi;
                   value of field
             end
       out puts(json_to_string(v) + "'n");
           json_error("internal error: ->: operator expects a JSON object");
           skip
       esac;

    { This version of -> gets a JSON value, which must be an array,
      and a one-based index, and returns the element stored at that
      position in the array.  If the given position is out of bounds
      then "empty" is returned. }

    pub op -> = (JSON_Val v, int pos) JSON_Val:
       case v
       in (ref JSON_Arr a):
             begin ref JSON_Elm elem := elements of a, int i := 1;
                   while i < pos AND (elem :/=: json_no_elm)
                   do elem := next of elem;
                      i +:= 1
                   od;
                   (elem :=: json_no_elm | empty | value of elem)
             end
       esac;

    { Return a string with the written form of the given JSON value. }

    pub proc json_to_string = (JSON_Val val) string:
       case val
       in (void): "null",
          (bool b): (b | "true" | "false"),
          (int i): itoa (i, 10),
          (string s): """" + s + """",
          (ref JSON_Arr a): "[" + (ref JSON_Elm elem := elements of a, string res;
                                   for i while elem :/=: json_no_elm
                                   do (i > 1 | res +:= ",");
                                      res +:= json_to_string(value of elem);
                                      elem := next of elem
                                   od;
                                   res) + "]",
          (ref JSON_Obj o): "{" + (ref JSON_Fld field := fields of o, string res;
                                   for i while field :/=: json_no_fld
                                   do (i > 1 | res +:= ",");
                                      res +:= json_to_string(name of field);
                                      res +:= ":";
                                      res +:= json_to_string(value of field);
                                      field := next of field
                                   od;
                                   res) + "}"
       esac;

    { Parse a JSON object reading at most MAXCHARS characters from the
      file descriptor FD.

      In case of a parse error the callback ERROR is invoked with a
      description of the problem passed as an argument, and this
      procedure returns immediately. }

    pub proc json_from_fd = (int maxchars, int fd,
                             proc(string)void error) JSON_Val:
    begin
          { Simple stream of characters with EOF and error detection. }

          char ungetch := eof_char, ch;
          int usedchars;

          proc getachar = char:
          begin if usedchars > maxchars then ch := eof_char
                elif ungetch /= eof_char
                then ch := ungetch; ungetch := eof_char
                else ch := fgetc(fd); usedchars +:= 1
                fi;
                ch
          end;

          proc ungetachar = (char c) void:
             ungetch := c;

          { A few utility routines. }

          proc expect = (string s) void:
             for i to UPB s
             do char c = s[i];
                if getachar = eof_char orel ch /= c
                then parse_error("expected ''" + c + "''")
                fi
             od;

          proc parse_error = (string msg) void:
             if ch = eof_char
             then json_error(msg + ", found end of file")
             else json_error(msg + ", found ''" + ch + "''")
             fi;

          { Parse a single JSON value. }

          proc parse_value = (int charsleft) JSON_Val:
          begin
                proc parse_number = int:
                begin int num := 0;
                      while num := num * 10 + ABS ch - ABS "0";
                            isdigit(getachar)
                      do ~ od;
                      ungetachar(ch);
                      num
                end;

                proc parse_string = string:
                begin string res;
                      while getachar /= """"
                      do if ch = eof_char then json_error("while parsing string")
                         elif ch = "\"
                         then ch = getachar;
                              if ch = eof_char then json_error("unterminated string escape")
                              elif ch = "n" then res +:= "'n"
                              elif ch = "t" then res +:= "'t"
                              elif ch = "r" then res +:= "'r"
                              elif ch = """" then res +:= """"
                              elif ch = "\" then res +:= ch
                              else json_error("invalid string escape \" + ch)
                              fi
                         else res +:= ch
                         fi
                      od;
                      res
                end;

                proc parse_array = ref JSON_Arr:
                begin ref JSON_Elm elems;
                      for i while getachar /= "]"
                      do ungetachar(ch);
                         if i > 1 then ungetachar(ch); expect(",") fi;
                         JSON_Val val = parse_value (charsleft - usedchars);
                         { Array elements should keep written order. }
                         elems := (elems :=: json_no_elm
                                   | heap JSON_Elm := (val, nil)
                                   | (ref JSON_Elm e := elems;
                                      while next of e :/=: json_no_elm
                                      do e := next of e od;
                                      next of e := heap JSON_Elm := (val, nil);
                                      elems))
                      od;
                      (ch = eof_char | parse_error("unclosed array in JSON string"));
                      heap JSON_Arr res;
                      elements of res := elems;
                      res
                end;

                proc parse_object = ref JSON_Obj:
                begin ref JSON_Fld fields;
                      for i while getachar /= "}"
                      do ungetachar(ch);
                         if i > 1 then expect(",") fi;
                         JSON_Val name = parse_value(charsleft - usedchars);
                         expect(":");
                         JSON_Val value = parse_value(charsleft - usedchars);
                         fields := heap JSON_Fld := (name, value, fields)
                      od;
                      (ch = eof_char | parse_error("unclosed object in JSON string"));
                      heap JSON_Obj res;
                      fields of res := fields;
                      res
                end;

                getachar;
                (ch = "t" | expect("rue"); true
                 |: ch = "f" | expect("alse"); false
                 |: isdigit (ch) | parse_number
                 |: ch = """" | parse_string
                 |: ch = "["  | parse_array
                 |: ch = "{"  | parse_object
                 |  parse_error("invalid JSON"); skip)
          end;

          parse_value(maxchars)
    end;

    { Determine whether the given JSON value is the "null" value. }

    pub proc json_is_null = (JSON_Val v) bool:
       (v | (void): true | false);

    { Extract algol 68 values from JSON values. }

    pub proc json_int = (JSON_Val v) int:
       (v | (int i): i | json_error("expected integer in json str"); skip);

    pub proc json_str = (JSON_Val v) string:
       (v | (string s): s | json_error("expected string in json str"); skip);

    { Invoke a callback H for each element in the given JSON array V.
      The elements are traversed in order.  If V is not an array then
      this procedure does nothing. }

    pub proc json_foreach_elem = (JSON_Val v, proc(ref JSON_Val)void h) void:
       case v
       in (ref JSON_Arr a):
             (ref JSON_Elm elem := elements of a;
              while elem :/=: json_no_elm
              do h (value of elem);
                 elem := next of elem
              od)
       esac;

    { Encode a given string STR as a JSON string literal. }

    pub proc json_escape_string = (string str) string:
    begin string res;
          for i to ELEMS str
          do char newline = REPR 10, tab = REPR 9, c = str[i];
             (c = "\" | res +:= "\\"
              |: c = newline | res +:= "\n"
              |: c = tab | res +:= "\t"
              | res +:= c)
          od;
          res
    end;

    skip
fed
