guileのPEGパーサーでJSONをalist形式に変換

guile_json_peg.scm

(use-modules (ice-9 peg))

(define-peg-string-patterns
  "True <-- 'true'
False <-- 'false'
Null <-- 'null'
WS < (' ' / '\n' / '\r' / '\t')*
Number <-- Minus? IntegralPart FractionalPart? ExponentPart?
Minus <- '-'
IntegralPart <- '0' / [1-9] [0-9]*
FractionalPart <- '.' [0-9]*
ExponentPart <- ('e' / 'E') ('+' / '-')? [0-9]+
String <-- DQ ((!DQ !'\\' .) / Escape)* DQ
Escape <- '\\' [\"\\/bfnrt]
Object <-- EmptyObject / (LB (Key Value) ObjectNext RB)
ObjectNext <-- (CM Key Value)*
EmptyObject <-- LB WS RB
Key <-- WS String WS CL
Array <-- EmptyArray / (LS Value ArrayNext RS)
ArrayNext <-- (CM Value)*
EmptyArray <-- LS RS
Value <- WS (Object / Array / String / Number / True / False / Null) WS
LB < '{'
RB < '}'
LS < '['
RS < ']'
CL < ':'
CM < ','
DQ < '\"'
")

;; TODO \u + 4 hex digits

(define (->scm tree)
  (cond
   ((eq? (car tree) 'True) #t)
   ((eq? (car tree) 'False) #f)
   ((eq? (car tree) 'Null) 'null)
   ((eq? (car tree) 'String) (cadr tree))
   ((eq? (car tree) 'Number) (string->number
                              (cadr tree)))
   ((eq? (car tree) 'Key) (cadadr tree))
   ((eq? (car tree) 'Array) (array->scm tree))
   ((eq? (car tree) 'Object) (object->scm tree))))

(define (array->scm tree)
  (if (eq? (cadr tree) 'EmptyArray) '()
      (cons (->scm (cadr tree)) (arraynext->scm (caddr tree)))))

(define (arraynext->scm tree)
  (if (eq? tree 'ArrayNext) '()
      (map ->scm (cdr tree))))

(define (key-value->scm tree)
  (let ((key (->scm (car tree)))
        (value (->scm (cadr tree))))
    `(,key . ,value)))

(define (object->scm tree)
  (if (eq? (cadr tree) 'EmptyObject) '()
      (let ((key-value (cadr tree)))
        (cons (key-value->scm key-value) (objectnext->scm (caddr tree))))))

(define (objectnext->scm tree)
  (if (eq? tree 'ObjectNext) '()
      (if (eq? (caadr tree) 'Key)
          (cons (key-value->scm (cdr tree)) '())
          (let ((key-values (cdr tree)))
            (map key-value->scm  key-values)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; example

;; (define example-json "{\"key1\": \"Hello!!!\", \"key2\": 1234, \"key3\": true, \"key4\": false, \"key5\": null, \"key6\": [1, 2, 3, 4, -5], \"key7\": [[\"foo\", \"bar\", \"baz\"], [\"hoge\", \"fuga\", \"piyo\"]], \"key8\": {\"key8-1\": true, \"key8-2\": false}}")
;; (use-modules (ice-9 pretty-print))
;; (define tree (peg:tree (match-pattern Value example-json)))
;; (pretty-print (->scm tree))
;; ;;output =>
;; (("key1" . "Hello!!!")
;;  ("key2" . 1234)
;;  ("key3" . #t)
;;  ("key4" . #f)
;;  ("key5" . null)
;;  ("key6" 1 2 3 4 -5)
;;  ("key7"
;;   ("foo" "bar" "baz")
;;   ("hoge" "fuga" "piyo"))
;;  ("key8" ("key8-1" . #t) ("key8-2" . #f)))