Artifact ab0965236d5b1e8d6f0dae9156f5e5eaa9618fa0:

• File json/parser.fs — part of check-in [030abcc712] at 2019-01-21 14:03:31 on branch trunk — Integrate importer into normal command line (user: bernd size: 9149)

\ JSON parser to import Google+

\ Copyright (C) 2018   Bernd Paysan

\ This program is free software: you can redistribute it and/or modify
\ it under the terms of the GNU Affero 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 Affero General Public License for more details.

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

require ../tools.fs
scope: regexps
require regexp.fs
}scope

also regexps
Charclass [blT] bl +char 'T' +char
: iso-?date ( addr u -- flag )
    (( \( \d \d \d \d \) ` - \( \d \d \) ` - \( \d \d \)
    {{ [blT] c?
    \( \d \d \) ` : \( \d \d \) ` : \( \d \d \)
    {{ ` . \( {++ \d \d \d ++} \) || \( \) }}
    {{ ` Z \( \) \( \) ||
       {{ ` + \( || \( ` - }} \d \d `? : \d \d \)
    }} || \( \) \( \) \( \) \( \) \( \) }} \$ )) ;
: iso-date>ticks ( -- ticks )
    \1 s>number drop \2 s>number drop \3 s>number drop ymd2day unix-day0 -
    #24 *
    \4 s>number drop + #60 * \5 s>number drop +
    \8 2 umin s>number drop   #60 *
    \8 dup 2 - /string s>unumber? 2drop over 0< IF - ELSE + THEN -
    #60 * \6 s>number drop +
    #1000000000 um*
    \7 s>unumber? 2drop
    case \7 nip
	3 of  #1000000 um*  endof
	6 of  #1000    um*  endof
	0 swap
    endcase  d+
    d>64 ;
previous

Defer ?date
Defer date>ticks

: iso-date
    ['] iso-?date is ?date
    ['] iso-date>ticks is date>ticks ;

$Variable key$ \ key string
256 cells buffer: json-tokens
5 stack: jsons-recognizer
1 stack: json-recognizer

' noop ' lit, dup rectype: rectype-bool
' noop ' lit, dup rectype: rectype-nil

s" JSON error" exception Value json-throw
s" JSON key not found" exception Value json-key-throw
s" JSON class not found" exception Value json-class-throw

: json-err  cr order json-throw throw ;

0 Value schema-scope
0 Value outer-class
0 Value schema-wid

Defer process-element  ' noop is process-element
Defer process-elements ' noop is process-elements

require g+-schema.fs
require fb-schema.fs
require twitter-schema.fs
require diaspora-schema.fs

$10 stack: element-stack
$10 stack: key-stack
$10 stack: array-stack
0 Value array-item
0 Value last-type
0 Value previous-type

: set-val ( value -- )
    key$ $@ find-name ?dup-IF  (int-to)  EXIT  THEN
    json-err ;

: set-int ( value -- )
    key$ $@ find-name ?dup-IF  (int-to)  EXIT  THEN
    '%' key$ $@ + 1- c!  key$ $@ find-name ?dup-IF
	>r s>f r> (int-to) EXIT  THEN
    '!' key$ $@ + 1- c!  key$ $@ find-name ?dup-IF
	>r #1000000000 um* d>64 r> (int-to) EXIT  THEN
    json-err ;

Defer next-element

: next-element# ( element -- )
    array-item ?dup-IF  >r
	case previous-type
	    rectype-name   of                   endof
	    rectype-num    of        r@ >stack  endof
	    rectype-dnum   of  drop  r@ >stack  endof
	    rectype-string of  s>number? 0= IF json-err THEN
		drop r@ >stack  endof
	    rectype-float  of  f>s   r@ >stack  endof
	    rectype-bool   of        r@ >stack  endof
	    rectype-nil    of        r@ >stack  endof
	endcase  rdrop
    THEN ;

: f>stack ( r stack -- )
    { f^ r } r 1 floats rot $+! ;

: next-element% ( element -- )
    array-item ?dup-IF  >r
	case previous-type
	    rectype-name   of                    endof
	    rectype-float  of        r@ f>stack  endof
	    rectype-string of  over >r >float r> free throw
		0= IF json-err THEN  r@ f>stack  endof
	    rectype-num    of  s>f   r@ f>stack  endof
	    rectype-dnum   of  d>f   r@ f>stack  endof
	    rectype-bool   of  s>f   r@ f>stack  endof
	    rectype-nil    of  s>f   r@ f>stack  endof
	endcase  rdrop
    THEN ;

: next-element$ ( element -- )
    array-item ?dup-IF  >r
	case previous-type
	    rectype-name   of                    endof
	    rectype-string of  over >r $make r> free throw  r@ >stack  endof
	    rectype-num    of  [: 0 .r ;] $tmp $make r@ >stack  endof
	    rectype-dnum   of  [: 0 d.r ;] $tmp $make r@ >stack  endof
	    rectype-float  of  ['] f. $tmp -trailing $make  r@ >stack  endof
	    rectype-bool   of  IF "true" ELSE "false" THEN $make r@ >stack  endof
	    rectype-nil    of  r@ >stack  endof
	endcase  rdrop
    THEN ;

' next-element$ is next-element

: begin-element ( -- )
    \ '"' emit key$ $. .\" \": {" cr
    key$ $@ schema-scope find-name-in
    ?dup-IF  name>int >body >r
	[: key$ $. ." -class" ;] $tmp schema-scope find-name-in
	?dup-IF
	    name>int execute new
	    dup array-item ?dup-IF
		>stack
	    ELSE
		s" {}" key$ $+! set-val
	    THEN
	    >o r> element-stack >stack
	    key$ @ key-stack >stack key$ off
	    get-order r> swap 1+ set-order
	    array-item array-stack >stack 0 to array-item
	ELSE
	    cr key$ $. json-class-throw throw
	THEN
    ELSE
	key$ $@len IF
	    cr key$ $. json-key-throw throw
	THEN
    THEN ;

: end-array ( -- )
    next-element
    array-stack stack> to array-item ;
: end-element ( -- )
    key$ $free  key-stack stack> key$ !
    previous element-stack stack> >o rdrop  end-array ;
: begin-array ( -- )
    array-item array-stack >stack
    [: key$ $. ." []" ;] $tmp find-name ?dup-IF
	name>int execute to array-item
	['] next-element$ is next-element  EXIT  THEN
    [: key$ $. ." []#" ;] $tmp find-name ?dup-IF
	name>int execute to array-item
	['] next-element# is next-element  EXIT  THEN
    [: key$ $. ." []%" ;] $tmp find-name ?dup-IF
	name>int execute to array-item
	['] next-element% is next-element  EXIT  THEN
    json-err ;

: key-find? ( char -- nt )
    key$ $@ + 1- c! key$ $@ find-name ;

: json-string! ( addr u -- )
    over >r
    '$' key$ c$+! key$ $@ find-name ?dup-IF  (int-to) r> free throw  EXIT  THEN
    \ workaround if you mean number but wrote string
    '&' key-find? ?dup-IF
	>r s>number?  IF  r> (int-to) r> free throw  EXIT  THEN  json-err  THEN
    '#' key-find? ?dup-IF
	>r s>number?  IF  drop r> (int-to) r> free throw  EXIT  THEN  json-err  THEN
    '!' key-find? ?dup-IF  drop
	?date IF  date>ticks set-val r> free throw  EXIT  THEN  json-err  THEN
    '%' key-find? ?dup-IF  drop
	>float IF  set-val r> free throw  EXIT  THEN  json-err  THEN
    r> free throw json-err ;

: eval-json ( .. tag -- )
    case
	rectype-name   of  name?int execute       endof
	rectype-string of  json-string!           endof
	rectype-num    of  '#' key$ c$+! set-int  endof
	rectype-dnum   of  '&' key$ c$+! set-val  endof
	rectype-float  of  '%' key$ c$+! set-val  endof
	rectype-bool   of  '?' key$ c$+! set-val  endof
	rectype-nil    of  drop                   endof \ default is null, anyhow
	json-err
    endcase ;

: key-value ( addr u -- ) over >r key$ $! r> free throw
    parse-name jsons-recognizer recognize eval-json ;

' begin-element '{' cells json-tokens + !
' end-element   '}' cells json-tokens + !
' next-element  ',' cells json-tokens + !
' begin-array   '[' cells json-tokens + !
' end-array     ']' cells json-tokens + !
' key-value     ':' cells json-tokens + !

: rec-json ( addr u -- )
    1 = IF
	c@ cells json-tokens + @
	dup IF  rectype-name  EXIT  THEN
    THEN
    drop rectype-null ;

256 buffer: stop-chars
bl 1+ 0 [do] 1 stop-chars [i] + c! [loop]
"{}[],:\"" bounds [do] 1 stop-chars [i] c@ + c! [loop]

: parse-json ( -- addr u )
    source >in @ safe/string
    dup 0 U+DO  over c@ bl u> ?LEAVE  1 safe/string  LOOP
    over c@ stop-chars + c@  IF  1 umin  ELSE
	dup 1 U+DO  over I + c@ stop-chars + c@  IF  drop I  LEAVE  THEN  LOOP
    THEN
    2dup + source drop - >in ! 2dup input-lexeme! ;

cs-scope: bools
false rectype-bool 2constant false
true  rectype-bool 2constant true
0     rectype-nil  2constant null
}scope

: rec-bool ( addr u -- ... )
    ['] bools >body find-name-in ?dup-IF
	name>int execute
    ELSE  rectype-null  THEN ;

' rec-bool ' rec-num ' rec-float ' rec-string ' rec-json
5 jsons-recognizer set-stack

: rec-jsons ( addr u -- ... json-type )
    last-type to previous-type
    jsons-recognizer recognize dup to last-type ;

' rec-jsons 1 json-recognizer set-stack

: json-load ( addr u -- o )
    outer-class new >o
    o element-stack >stack  0 key-stack >stack  0 array-stack >stack
    get-order n>r schema-wid 1 set-order
    forth-recognizer >r  json-recognizer to forth-recognizer
    action-of parse-name >r ['] parse-json is parse-name
    ['] included catch
    r> is parse-name  r> to forth-recognizer  nr> set-order
    throw process-element o o> ;

: json-load-dir ( addr u -- )
    2dup open-dir throw { dd } fpath dup $@len >r also-path dd
    [: { dd | nn } !time
	BEGIN
	    pad $100 dd read-dir throw  WHILE
		pad swap 2dup "*.json" filename-match IF
		    json-load entries[] >stack  1 +to nn
		    nn #37 mod 0= IF
			nn [: ." read " 6 .r ."  postings" ;]
			warning-color color-execute
			#-20 0 at-deltaxy
		    THEN
		ELSE  2drop  THEN
	REPEAT  drop
	nn [: ." read " 6 .r ."  postings in " .time ;]
	success-color color-execute cr ;] catch
    r> fpath $!len  dd close-dir throw  throw ;