scheme JSON decoder, uses list operations on string->list instead of streams. dicts map to gambit scheme tables

json-decoder.scm

(load "~~/lib/syntax-case")

(define-syntax let-values
  (syntax-rules 
    ()
    ((_ (mvbinding ...) . body)
     (let-values foo (mvbinding ...) . body))
    ((_ name () . body)
     (let name () . body))
    ((_ name ((vars mv) . mvbindings) . body)
     (call-with-values 
       (lambda () mv)
       (lambda temp
         (apply (let-values name mvbindings
                   (lambda vars
                     (let-syntax
                       ((name 
                          (syntax-rules
                            ()
                            ((let-values arg . args)
                             (call-with-values 
                               (lambda () arg)
                               (lambda temp
                                 (apply (name . args) temp)))))))
                     . body)))
         temp))))))

(define (take n lst)
  (let recur ((n n) (lst lst) (acc '()))
    (if (or
          (null? lst)
          (< n 1))
      (reverse acc)
      (recur (- n 1) (cdr lst) (cons (car lst) acc)))))

(define (take-while f lst)
  (let recur ((lst lst) (acc '()))
    (if (or
          (null? lst)
          (not (f (car lst))))
      (reverse acc)
      (recur (cdr lst) (cons (car lst) acc)))))

(define (take-until f lst)
  (take-while 
    (lambda e (not (apply f e))) lst))

(define (take-until-char char lst)
  (take-until (lambda (e) (eq? e char)) lst))

(define (drop n lst)
  (if (or
        (null? lst)
        (< n 1))
    lst
    (drop (- n 1) (cdr lst))))

(define (drop-while f lst)
  (if (or
        (null? lst)
        (not (f (car lst))))
    lst
    (drop-while f (cdr lst))))

(define (drop-until f lst)
  (drop-while
    (lambda e (not (apply f e))) lst))

(define (drop-until-char char lst)
  (drop-until (lambda (e) (eq? e char)) lst))

(define (decode-string stream)
  (let ((used (take-until-char #\' (cdr stream)))
        (rest (cdr (drop-until-char #\' (cdr stream)))))
    (values (list->string used) rest)))

(define (char-number? char)
  (or (and (char>=? char #\0) (char<=? char #\9))
      (char=? char #\.)))

(define (decode-number stream)
  (let ((used (take-while char-number? stream))
        (rest (drop-while char-number? stream)))
    (values (string->number (list->string used)) rest)))

(define (decode-negative-number stream)
  (let-values 
    (((decoded rest)
      (decode-number (cdr stream))))
    (values (* -1 decoded) rest)))

(define (decode-const stream expected return)
  (let ((used (take (length expected) stream))
        (rest (drop (length expected) stream)))
    (if (equal? used expected)
      (values return rest)
      (raise 'decode-const-expected-not-return))))

(define (decode-object stream)
  (let loop ((sofar '())
             (rest (drop-while char-whitespace? (cdr stream)))
             (current (car (drop-while char-whitespace? (cdr stream)))))
    (if (eq? current #\})
      (values (list->table (reverse sofar)) (cdr rest))
      (let-values
        (((decoded-key more-key)
          (decode-value rest)))
        (let-values
          (((decoded-value more-value)
            (decode-value (drop-while
                            char-whitespace?
                            (cdr (drop-until-char #\: more-key))))))
          (let ((remaining
                  (if (null? 
                        (drop-until-char
                          #\,
                          (take-until-char #\} more-value)))
                    (drop-until-char #\} more-value)
                    (drop-while
                      char-whitespace?
                      (cdr (drop-until-char #\, more-value))))))
            (loop
              (cons
                (cons decoded-key decoded-value)
                sofar)
              remaining
              (car remaining))))))))

(define (decode-array stream)
  (let loop ((sofar '())
             (rest (drop-while char-whitespace? (cdr stream)))
             (current (car (drop-while char-whitespace? (cdr stream)))))
    (if (eq? current #\])
      (values (reverse sofar) (cdr rest))
      (let-values
        (((decoded more)
          (decode-value rest)))
        (let ((remaining
                (if (null? 
                      (drop-until-char 
                        #\,
                        (take-until-char #\] more)))
                  (drop-until-char #\] more)
                  (drop-while
                    char-whitespace?
                    (cdr (drop-until-char #\, more))))))
          (loop
            (cons decoded sofar)
            remaining
            (car remaining)))))))

(define (decode-value stream)
  (let ((current (car stream)))
    (cond
      ((eq? current #\{) (decode-object stream))
      ((eq? current #\[) (decode-array stream))
      ((eq? current #\') (decode-string stream))
      ((eq? current #\f) (decode-const stream (string->list "false") #f))
      ((eq? current #\t) (decode-const stream (string->list "true") #t))
      ((eq? current #\n) (decode-const stream (string->list "null") '()))
      ((and 
         (eq? current #\-)
         (char-number? (cadr stream))) (decode-negative-number stream))
      ((char-number? current) (decode-number stream))
      (else (raise 'invalid-decode-value)))))

(define (decode-json str)
  (let-values 
    (((decoded more)
      (decode-value (string->list str))))
    decoded))