ozzloy's example

gistfile1.txt

#! /usr/bin/env racket
#lang racket/base

(require parser-tools/yacc
         parser-tools/lex
         (prefix-in : parser-tools/lex-sre))

(define-empty-tokens empty-tokens-group
  (EOF
   TRUE
   OPEN-OBJECT))

(define json-lexer
  (lexer-src-pos
   [(eof) (token-EOF)]
   ["{" (token-OPEN-OBJECT)]
   ["true" (token-TRUE)]))

(define (lex-json json)
  (define input
    (cond [(string? json) (open-input-string json)]
          [(input-port? json) json]
          [else (error "lex-json accepts input-ports or strings")]))
  (port-count-lines! input)
  (lambda () (json-lexer input)))

(require syntax/readerr)

(define json-parser
  (parser
   (src-pos)
   (start start)
   (end EOF)
   (error (lambda (tok-ok? tok-name tok-value start-pos end-pos)
            (raise-read-error "~a is not valid at top level"
                              "???"
                              (position-line start-pos)
                              (position-col start-pos)
                              (position-offset start-pos)
                              (and (number? (position-offset start-pos))
                                   (number? (position-offset end-pos))
                                   (- (position-offset end-pos) (position-offset start-pos))))))
   (tokens empty-tokens-group)
   (grammar
    [start
     [(object) `(JSON ,$1)]]
    [object
     [(OPEN-OBJECT value) `(OBJECT ,$2)]]
    [value
     [(TRUE) '(TRUE)]])))

(define (parse-json json)
  (json-parser (lex-json json)))

(require rackunit)

(define ((single-srcloc-fail position) e)
  (and (exn:fail:read? e)
       (let ([srclocs (exn:fail:read-srclocs e)])
         (and
          (equal? (length srclocs) 1)
          (equal? (srcloc-position (list-ref srclocs 0)) position)))))

(check-exn (single-srcloc-fail 1) (lambda () (parse-json "true"))
           "true is not valid at top level")