/**
 * This file provides JSON reading and writing predicates.
 *
 * Warranty & Liability
 * To the extent permitted by applicable law and unless explicitly
 * otherwise agreed upon, XLOG Technologies AG makes no warranties
 * regarding the provided information. XLOG Technologies AG assumes
 * no liability that any problems might be solved with the information
 * provided by XLOG Technologies AG.
 *
 * Rights & License
 * All industrial property rights regarding the information - copyright
 * and patent rights in particular - are the sole property of XLOG
 * Technologies AG. If the company was not the originator of some
 * excerpts, XLOG Technologies AG has at least obtained the right to
 * reproduce, change and translate the information.
 *
 * Reproduction is restricted to the whole unaltered document. Reproduction
 * of the information is only allowed for non-commercial uses. Selling,
 * giving away or letting of the execution of the library is prohibited.
 * The library can be distributed as part of your applications and libraries
 * for execution provided this comment remains unchanged.
 *
 * Restrictions
 * Only to be distributed with programs that add significant and primary
 * functionality to the library. Not to be distributed with additional
 * software intended to replace any components of the library.
 *
 * Trademarks
 * Jekejeke is a registered trademark of XLOG Technologies AG.
 */

:- ensure_loaded(library(text/charsio)).
:- ensure_loaded(library(misc/dict)).

/***************************************************************/
/* Some Convenience                                            */
/***************************************************************/

/**
 * json_atom(T, A):
 * The predicate succeeds in A with the atom for the JSON T.
 */
% json_atom(+Json, -Atom)
json_atom(Json, Atom) :- var(Atom), !,
   open_output_atom_stream(K),
   write_json(K, Json),
   close_output_atom_stream(K, Atom).
json_atom(Json, Atom) :-
   open_input_atom_stream(Atom, K),
   sys_receive_token(T, K),
   (T = end_of_file ->
      throw(error(syntax_error(cannot_start_term),_));
      sys_input_json(T, X, K),
      sys_receive_token(S, K),
      (S = end_of_file ->
         true;
         throw(error(syntax_error(end_of_clause_expected),_)))),
   Json = X.

/***************************************************************/
/* Unparse JSON                                                */
/***************************************************************/

/**
 * write_json(T):
 * write_json(S, T):
 * The predicate succeeds. As a side effect the JSON T is written.
 * The binary predicate allows specifying an output stream S.
 */
% write_json(+Term)
write_json(T) :-
   current_output(S),
   sys_print_json(T, S).

% write_json(+Stream, +Term)
write_json(S, T) :-
   sys_print_json(T, S).

% sys_print_json(+Term, +Stream)
sys_print_json(V, _) :- var(V),
   throw(error(instantiation_error,_)).
sys_print_json(X, S) :- atom(X), !,
   sys_string_quoted(X, H),
   put_atom(S, H).
sys_print_json(X, S) :- number(X), !,
   atom_number(H, X),
   put_atom(S, H).
sys_print_json(@(X), S) :- !,
   sys_check_ident(X),
   put_atom(S, X).
sys_print_json([], S) :- !,
   put_atom(S, '[]').
sys_print_json([X|L], S) :- !,
   put_atom(S, '['),
   sys_print_json(X, S),
   sys_print_list(L, S),
   put_atom(S, ']').
sys_print_json({}, S) :- !,
   put_atom(S, '{}').
sys_print_json({M}, S) :- !,
   put_atom(S, '{'),
   sys_print_map(M, S),
   put_atom(S, '}').
sys_print_json(T, _) :-
   throw(error(type_error(json,T),_)).

% sys_check_ident(+Atom)
sys_check_ident(V) :- var(V),
   throw(error(instantiation_error,_)).
sys_check_ident(null) :- !.
sys_check_ident(false) :- !.
sys_check_ident(true) :- !.
sys_check_ident(A) :-
   throw(error(type_error(ident,A),_)).

% sys_print_list(+List, +Stream)
sys_print_list(V, _) :- var(V),
   throw(error(instantiation_error,_)).
sys_print_list([], _) :- !.
sys_print_list([X|L], S) :- !,
   put_atom(S, ', '),
   sys_print_json(X, S),
   sys_print_list(L, S).
sys_print_list(T, _) :-
   throw(error(type_error(list,T),_)).

% sys_print_map(+Map, +Stream)
sys_print_map(V, _) :- var(V),
   throw(error(instantiation_error,_)).
sys_print_map((M,Q), S) :- !,
   sys_print_member(M, S),
   put_atom(S, ', '),
   sys_print_map(Q, S).
sys_print_map(M, S) :-
   sys_print_member(M, S).

% sys_print_member(+Pair, +Stream)
sys_print_member(V, _) :- var(V),
   throw(error(instantiation_error,_)).
sys_print_member(K:V, S) :- !,
   sys_string_quoted(K, H),
   put_atom(S, H),
   put_atom(S, ': '),
   sys_print_json(V, S).
sys_print_member(T, _) :-
   throw(error(type_error(member,T),_)).

/***************************************************************/
/* String Escape                                               */
/***************************************************************/

% sys_string_quoted(+Atom, -Atom)
sys_string_quoted(X, Y) :-
   atom_codes(X, L),
   sys_escape_points(L, R, [0'\"]),
   atom_codes(Y, [0'\"|R]).

% sys_escape_points(+List, -List, +List)
sys_escape_points([X|L]) -->
   sys_escape_point(X),
   sys_escape_points(L).
sys_escape_points([]) --> [].

% sys_escape_point(+Integer, -List, +List)
sys_escape_point(X) --> {sys_is_control(Y, X)}, !, [0'\\, Y].
sys_escape_point(X) --> {sys_is_special(X)}, !, [0'\\, X].
sys_escape_point(X) --> {sys_is_cntrl(X)}, !, sys_escape_point2(X).
sys_escape_point(X) --> {sys_is_invalid(X)}, !, sys_escape_point2(X).
sys_escape_point(X) --> [X].

% sys_escape_point2(+Integer, -List, +List)
sys_escape_point2(X) --> {X =< 0xFFFF}, !,
   {atom_integer(J, 16, X), atom_codes(J, H), length(H, N), M is 4-N},
   [0'\\, 0'u], sys_escape_zeros(M), sys_escape_points2(H).
sys_escape_point2(X) --> {sys_high_surrogate(X, Y), sys_low_surrogate(X, Z)},
   sys_escape_point2(Y), sys_escape_point2(Z).

% sys_is_special(+Code)
sys_is_special(0'\").
sys_is_special(0'\\).
sys_is_special(0'/).

% sys_is_control(+Code, -Code)
sys_is_control(0'b, 0'\b).
sys_is_control(0'f, 0'\f).
sys_is_control(0'n, 0'\n).
sys_is_control(0'r, 0'\r).
sys_is_control(0't, 0'\t).

% sys_high_surrogate(+Integer, -Integer)
sys_high_surrogate(X, Y) :- Y is (X >> 10) + 0xD7C0.

% sys_low_surrogate(+Integer, -Integer)
sys_low_surrogate(X, Y) :- Y is (X /\ 0x3FF) + 0xDC00.

/*************************************************************/
/* Character Utility                                         */
/*************************************************************/

% sys_is_cntrl(+Code)
sys_is_cntrl(C) :- code_category(C, T), member(T, [15,16]).

% sys_is_invalid(+Code)
sys_is_invalid(C) :- code_category(C, T), member(T, [0,18,19]).

% sys_escape_points2(+List, -List, +List)
sys_escape_points2([H|T]) --> !, [H], sys_escape_points2(T).
sys_escape_points2([]) --> [].

% sys_escape_zeros(+Integer, -List, +List)
sys_escape_zeros(0) --> !.
sys_escape_zeros(N) --> [0'0], {M is N-1}, sys_escape_zeros(M).

/***************************************************************/
/* Parse JSON                                                  */
/***************************************************************/

/**
 * read_json(E):
 * read_json(S, E):
 * The predicate succeeds in E with a JSON or end_of_file.
 * As a side effect, the input position is advanced. The binary
 * predicate allows specifying an input stream S.
 */
% read_json(-Term)
read_json(X) :-
   current_input(S),
   read_json(S, X).

% read_json(+Stream, -Term)
read_json(S, X) :-
   sys_receive_token(T, S),
   (T = end_of_file ->
       X = end_of_file;
       sys_input_json(T, Y, S),
       X = Y).

/**
 * sys_input_json(T, Y, S):
 * The predicate succeeds in Y with the next json. The parameter T
 * is the current token and the parameter S is the current stream.
 */
% sys_input_json(+Term, -Term, +Stream)
sys_input_json(atom(A), A, _) :- !.
sys_input_json(number(N), N, _) :- !.
sys_input_json(ident(I), @(I), _) :- !,
   sys_check_ident(I).
sys_input_json('[', L, S) :- !,
   sys_receive_token(T, S),
   sys_input_list(T, L, S).
sys_input_json('{', M, S) :- !,
   sys_receive_token(T, S),
   sys_input_map(T, M, S).
sys_input_json(_, _, _) :-
   throw(error(syntax_error(illegal_json),_)).

% sys_input_list(+Term, -List, +Stream)
sys_input_list(']', [], _) :- !.
sys_input_list(T, [X|L], S) :-
   sys_input_json(T, X, S),
   sys_receive_token(R, S),
   sys_input_rest(R, L, S).

% sys_input_rest(+Term, -List, +Stream)
sys_input_rest(']', [], _) :- !.
sys_input_rest(',', [X|L], S) :- !,
   sys_receive_token(T, S),
   sys_input_json(T, X, S),
   sys_receive_token(R, S),
   sys_input_rest(R, L, S).
sys_input_rest(_, _, _) :-
   throw(error(syntax_error(illegal_array),_)).

% sys_input_map(+Term, -Map, +Stream)
sys_input_map('}', {}, _) :- !.
sys_input_map(T, {M}, S) :-
   sys_input_pair(T, X, S),
   sys_receive_token(R, S),
   sys_input_more(R, X, M, S).

% sys_input_more(+Term, +Pair, -Map, +Stream)
sys_input_more('}', X, X, _) :- !.
sys_input_more(',', X, (X,M), S) :- !,
   sys_receive_token(T, S),
   sys_input_pair(T, Y, S),
   sys_receive_token(R, S),
   sys_input_more(R, Y, M, S).
sys_input_more(_, _, _, _) :-
   throw(error(syntax_error(illegal_object),_)).

% sys_input_pair(+Term, -Term, +Stream)
sys_input_pair(atom(A), A:V, S) :- !,
   sys_receive_token(T, S),
   sys_input_value(T, V, S).
sys_input_pair(_, _, _) :-
   throw(error(syntax_error(illegal_member),_)).

% sys_input_value(+Term, -Term, +Stream)
sys_input_value(':', V, S) :- !,
   sys_receive_token(T, S),
   sys_input_json(T, V, S).
sys_input_value(_, _, _) :-
   throw(error(syntax_error(illegal_json),_)).

/***************************************************************/
/* Tokenizer JSON                                              */
/***************************************************************/

/**
 * sys_receive_token(T, S):
 * The predicate succeeds in T with the next token from the stream S.
 */
% sys_receive_token(-Term, +Stream)
sys_receive_token(T, S) :-
   get_code(S, C),
   sys_receive_token(C, T, S).

% sys_receive_token(+Integer, -Term, +Stream)
sys_receive_token(0'\", atom(A), S) :- !,
   get_code(S, H),
   sys_receive_string(H, L, S),
   atom_codes(A, L).
sys_receive_token(0'-, number(N), S) :- !,
   peek_code(S, H),
   sys_receive_number(H, L, S),
   atom_codes(A, [0'-|L]),
   atom_number(A, N).
sys_receive_token(C, number(N), S) :- sys_json_digit(C), !,
   peek_code(S, H),
   sys_receive_number(H, L, S),
   atom_codes(A, [C|L]),
   atom_number(A, N).
sys_receive_token(C, T, _) :- sys_json_punct(C), !,
   char_code(T, C).
sys_receive_token(C, T, S) :- sys_json_white(C), !,
   get_code(S, H),
   sys_receive_token(H, T, S).
sys_receive_token(C, ident(I), S) :- sys_json_letter(C), !,
   peek_code(S, H),
   sys_receive_name(H, L, S),
   atom_codes(I, [C|L]).
sys_receive_token(-1, end_of_file, _) :- !.
sys_receive_token(_, _, _) :-
   throw(error(syntax_error(illegal_token),_)).

/***************************************************************/
/* Number Tokens JSON                                          */
/***************************************************************/

% sys_receive_number(+Integer, -List, +Stream)
sys_receive_number(0'., [0'.|L], S) :- !,
   get_code(S, _), peek_code(S, H),
   sys_receive_fraction(H, L, S).
sys_receive_number(0'e, [0'e|L], S) :- !,
   get_code(S, _), peek_code(S, H),
   sys_receive_exponent(H, L, S).
sys_receive_number(0'E, [0'E|L], S) :- !,
   get_code(S, _), peek_code(S, H),
   sys_receive_exponent(H, L, S).
sys_receive_number(C, [C|L], S) :- sys_json_digit(C), !,
   get_code(S, _), peek_code(S, H),
   sys_receive_number(H, L, S).
sys_receive_number(_, [], _).

% sys_receive_fraction(+Integer, -List, +Stream)
sys_receive_fraction(0'e, [0'e|L], S) :- !,
   get_code(S, _), peek_code(S, H),
   sys_receive_exponent(H, L, S).
sys_receive_fraction(0'E, [0'E|L], S) :- !,
   get_code(S, _), peek_code(S, H),
   sys_receive_exponent(H, L, S).
sys_receive_fraction(C, [C|L], S) :- sys_json_digit(C), !,
   get_code(S, _), peek_code(S, H),
   sys_receive_fraction(H, L, S).
sys_receive_fraction(_, [], _).

% sys_receive_exponent(+Integer, -List, +Stream)
sys_receive_exponent(0'+, [0'+|L], S) :- !,
   get_code(S, _), peek_code(S, H),
   sys_receive_exponent(H, L, S).
sys_receive_exponent(0'-, [0'-|L], S) :- !,
   get_code(S, _), peek_code(S, H),
   sys_receive_exponent(H, L, S).
sys_receive_exponent(C, [C|L], S) :- sys_json_digit(C), !,
   get_code(S, _), peek_code(S, H),
   sys_receive_exponent(H, L, S).
sys_receive_exponent(_, [], _).

/***************************************************************/
/* String / Name Tokens JSON                                   */
/***************************************************************/

% sys_receive_string(+Integer, -List, +Stream)
sys_receive_string(0'\", [], _) :- !.
sys_receive_string(0'\\, L, S) :- !,
   get_code(S, H),
   sys_receive_escape(H, L, S).
sys_receive_string(C, [C|L], S) :-
   get_code(S, H),
   sys_receive_string(H, L, S).

% sys_receive_escape(+Integer, -List, +Stream)
sys_receive_escape(0'u, [C|L], S) :- !,
   sys_receive_hex(4, R, S),
   atom_codes(I, R), atom_integer(I, 16, C),
   get_code(S, J),
   sys_receive_string(J, L, S).
sys_receive_escape(C, [E|L], S) :-
   sys_is_control(C, E), !,
   get_code(S, H),
   sys_receive_string(H, L, S).
sys_receive_escape(C, [C|L], S) :-
   sys_is_special(C), !,
   get_code(S, H),
   sys_receive_string(H, L, S).
sys_receive_escape(_, _, _) :-
   throw(error(syntax_error(illegal_escape),_)).

% sys_receive_hex(+Integer, -List, +Stream)
sys_receive_hex(0, [], _) :- !.
sys_receive_hex(K, [C|L], S) :-
   get_code(S, C),
   sys_json_hex(C), !,
   J is K-1,
   sys_receive_hex(J, L, S).
sys_receive_hex(_, _, _) :-
   throw(error(syntax_error(illegal_escape),_)).

% sys_receive_name(+Integer, -List, +Stream)
sys_receive_name(C, [C|L], S) :- sys_json_letter(C), !,
   get_code(S, _), peek_code(S, H),
   sys_receive_name(H, L, S).
sys_receive_name(_, [], _).

/***************************************************************/
/* Code Classify JSON                                          */
/***************************************************************/

% sys_json_digit(+Code)
sys_json_digit(C) :- 0'0 =< C, C =< 0'9.

% sys_json_punct(+Code)
sys_json_punct(0'[).
sys_json_punct(0']).
sys_json_punct(0',).
sys_json_punct(0'{).
sys_json_punct(0'}).
sys_json_punct(0':).

% sys_json_white(+Code)
sys_json_white(0' ).
sys_json_white(0'\n).
sys_json_white(0'\r).
sys_json_white(0'\t).

% sys_json_hex(+Code)
sys_json_hex(C) :- 0'0 =< C, C =< 0'9, !.
sys_json_hex(C) :- 0'A =< C, C =< 0'F, !.
sys_json_hex(C) :- 0'a =< C, C =< 0'f.

% sys_json_letter(+Code)
sys_json_letter(C) :- 0'a =< C, C =< 0'z.

/****************************************************************/
/* Error Texts                                                  */
/****************************************************************/

% strings(+Atom, +Atom, -Atom)
:- multifile(strings/3).
strings('type_error.json', de, 'Argument sollte JSON Data sein, gefunden ~q.').
strings('type_error.member', de, 'Argument sollte JSON Member sein, gefunden ~q.').
strings('type_error.ident', de, 'Argument sollte JSON Ident sein, gefunden ~q.').

strings('syntax_error.illegal_json', de, 'Kein JSON Data.').
strings('syntax_error.illegal_array', de, 'Kein JSON Array.').
strings('syntax_error.illegal_member', de, 'Kein JSON Member.').
strings('syntax_error.illegal_object', de, 'Kein JSON Objekt.').
strings('syntax_error.illegal_token', de, 'Kein JSON Token.').

strings('type_error.json', de, 'Argument should be some JSON data, gefunden ~q.').
strings('type_error.member', de, 'Argument should be a JSON member, gefunden ~q.').
strings('type_error.ident', '', 'Argument should be a JSON ident, found ~q.').

strings('syntax_error.illegal_json', '', 'Not some JSON data.').
strings('syntax_error.illegal_array', '', 'Not a JSON array.').
strings('syntax_error.illegal_member', '', 'Not a JSON member.').
strings('syntax_error.illegal_object', '', 'Not a JSON object.').
strings('syntax_error.illegal_token', '', 'Not a JSON token.').