Source

edn / edn-impl.scm

(import chicken scheme)
(use utf8 utf8-srfi-14 srfi-1 clojurian-syntax matchable data-structures)
(use (except comparse as-string))
(use (prefix numbers numbers-))

(define (symbol-result-parser convert)
  (lambda (ns sym)
    (if ns
        (convert (string-append ns "/" sym))
        (convert sym))))

(define (number-result-parser str arbitrary-precision?)
  (if arbitrary-precision?
      (numbers-string->number str)
      (string->number str)))

(define ((collection-result-parser tag) items)
  (cons tag items))

(define edn-parsers
  (make-parameter
   `((true    . ,(constantly #t))
     (false   . ,(constantly #f))
     (nil     . ,(constantly 'nil))
     (string  . ,identity)
     (char    . ,identity)
     (symbol  . ,(symbol-result-parser string->symbol))
     (keyword . ,(symbol-result-parser string->keyword))
     (integer . ,number-result-parser)
     (float   . ,number-result-parser)
     (list    . ,(collection-result-parser 'list))
     (vector  . ,(collection-result-parser 'vector))
     (map     . ,(collection-result-parser 'map))
     (set     . ,(collection-result-parser 'set)))))

(define (parser-ref name)
  (or (alist-ref name (edn-parsers))
      (error "Undefined parser" name (map car (edn-parsers)))))

(define (result-parser name . args)
  (result (apply (parser-ref name) args)))

(define (parser-error message . args)
  (lambda _ (apply error message args)))

(define (as-string parser)
  (sequence* ((parts parser))
    (result (apply conc (remove boolean? (flatten parts))))))

(define (in* char-set)
  (satisfies (lambda (x) (char-set-contains? char-set x))))

(define whitespace
  (zero-or-more
   (in* (char-set-union
         char-set:whitespace
         (char-set #\,)))))

(define edn-nil
  (preceded-by (char-seq "nil")
               (result-parser 'nil)))

(define edn-true
  (preceded-by (char-seq "true")
               (result-parser 'true)))

(define edn-false
  (preceded-by (char-seq "false")
               (result-parser 'false)))

(define edn-boolean
  (any-of edn-true edn-false))

(define escapes
  '((#\\ . #\\)
    (#\/ . #\/)
    (#\" . #\")
    (#\b . #\backspace)
    (#\f . #\page)
    (#\n . #\newline)
    (#\r . #\return)
    (#\t . #\tab)))

(define char-set:escape
  (list->char-set (map car escapes)))

(define escape
  (bind (in* char-set:escape)
        (lambda (e)
          (result (alist-ref e escapes)))))

(define string-char
  (any-of (preceded-by (is #\\) escape)
          (none-of* (is #\") item)))

(define edn-string
  (bind (->> (enclosed-by (is #\")
                          (zero-or-more string-char)
                          (any-of (is #\") (parser-error "Unterminated string")))
             (as-string))
        (lambda (s)
          (result-parser 'string s))))

(define char-set:named-char
  (ucs-range->char-set #x61 #x7b))

(define named-chars
  '(("newline" . #\newline)
    ("return"  . #\return)
    ("space"   . #\space)
    ("tab"     . #\tab)))

(define edn-char
  (bind (->> (sequence item (zero-or-more (in* char-set:named-char)))
             (as-string)
             (preceded-by (is #\\)))
        (lambda (char)
          (result-parser 'char
                         (if (= 1 (string-length char))
                             (string-ref char 0)
                             (or (alist-ref char named-chars equal?)
                                 (error "Invalid char" char)))))))

(define char-set:edn-symbol-special
  (string->char-set ".*+!-_?$%&=/"))

(define char-set:edn-symbol
  (char-set-union
   char-set:letter+digit
   char-set:edn-symbol-special
   (string->char-set "#:")))

(define char-set:edn-symbol-head
  (char-set-union
   char-set:letter
   char-set:edn-symbol-special))

(define char-set:edn-ambiguous-symbol-head
  (char-set #\. #\+ #\-))

(define (valid-symbol-head? c)
  (char-set-contains? char-set:edn-symbol-head c))

(define (ambiguous-symbol-head? c)
  (char-set-contains? char-set:edn-ambiguous-symbol-head c))

(define (ensure-valid-symbol sym error input)
  (if (or (equal? "/" sym)
          (let ((head (string-ref sym 0)))
            (valid-symbol-head?
             (if (and (ambiguous-symbol-head? head)
                      (> (string-length sym) 1))
                 (string-ref sym 1)
                 head))))
      sym
      (error input)))

(define (result-parser-symbolic parser-name error)
  (lambda (input)
    (match (string-split input "/" #t)
      (("" "")
       (result-parser parser-name #f "/"))
      ((name)
       (result-parser parser-name
                      #f
                      (ensure-valid-symbol name error input)))
      ((or ("" _) (_ ""))
       (error input))
      ((ns name)
       (result-parser parser-name
                      (ensure-valid-symbol ns error input)
                      (ensure-valid-symbol name error input)))
      (else
       (error input)))))

(define symbol
  (as-string (one-or-more (in* char-set:edn-symbol))))

(define edn-symbol
  (bind symbol
        (result-parser-symbolic
         'symbol
         (lambda (symbol)
           (error "Invalid symbol" symbol)))))

(define edn-keyword
  (bind (preceded-by (is #\:) symbol)
        (result-parser-symbolic
         'keyword
         (lambda (keyword)
           (error "Invalid keyword"
                  (string-append ":" keyword))))))

(define digits
  (one-or-more (in* char-set:digit)))

(define integer
  (as-string (sequence (maybe (in #\- #\+)) digits)))

(define number-suffix
  (maybe (as-string symbol)))

(define edn-integer
  (sequence* ((number integer)
              (suffix number-suffix))
    (let* ((arbitrary-precision?
            (match suffix
              (#f  #f)
              ("N" #t)
              (else (error "Invalid integer"
                           (string-append number suffix))))))
      (result-parser 'integer number arbitrary-precision?))))

(define fraction
  (sequence (is #\.) digits))

(define exponent
  (sequence (in #\e #\E) (maybe (in #\+ #\-)) digits))

(define edn-float
  (sequence* ((number (->> (any-of (sequence fraction exponent)
                                   fraction
                                   exponent)
                           (sequence integer)
                           (any-of (bind (followed-by integer (is #\M))
                                         (lambda (int)
                                           (result (string-append int ".0")))))
                           (as-string)))
              (suffix number-suffix))
    (let ((arbitrary-precision?
           (match suffix
             (#f  #f)
             ("M" #t)
             (else (error "Invalid float"
                          (string-append number suffix))))))
      (result-parser 'float number arbitrary-precision?))))

(define edn-element
  (recursive-parser
   (preceded-by
    whitespace
    (any-of edn-list
            edn-vector
            edn-map
            edn-set
            edn-tag
            edn-nil
            edn-boolean
            edn-string
            edn-char
            edn-float
            edn-integer
            edn-keyword
            edn-symbol))))

(define (collection-parser result-parser-name open close #!optional items-parser)
  (sequence* ((_ (is open))
              (items (or items-parser (zero-or-more (edn-element))))
              (closed? (maybe (preceded-by whitespace (is close)))))
    (if closed?
        (result-parser result-parser-name items)
        (error (string-append "Unterminated "
                              (symbol->string result-parser-name))))))

(define edn-list
  (collection-parser 'list #\( #\)))

(define edn-vector
  (collection-parser 'vector #\[ #\]))

(define edn-map
  (collection-parser 'map #\{ #\}
                     (zero-or-more
                      (any-of
                       (sequence* ((key (edn-element))
                                   (val (edn-element)))
                         (result (cons key val)))
                       (bind (edn-element)
                             (lambda (key)
                               (error "Missing value for key" key)))))))

(define edn-set
  (preceded-by
   (is #\#)
   (collection-parser 'set #\{ #\})))

(define (make-edn-tag value namespace name)
  `(tag ,(cons namespace name) ,value))

(define edn-tags
  (make-parameter
   `((#f (#f . ,make-edn-tag)
         (inst . ,make-edn-tag)
         (uuid . ,make-edn-tag)))))

(define (register-edn-tag! namespace name handler)
  (edn-tags
   (alist-update!
    namespace
    (alist-update!
     name
     (lambda (v _ _) (handler v))
     (or (alist-ref namespace (edn-tags)) '()))
    (edn-tags))))

(define handle-unknown-edn-tags?
  (make-parameter #t))

(define (maybe-string->symbol s)
  (if (string? s) (string->symbol s) s))

(define (tag-ref* ns name)
  (and-let* ((ns-tags (alist-ref ns (edn-tags))))
    (alist-ref name ns-tags)))

(define (tag-ref ns name)
  (or (tag-ref* ns name)
      (and (handle-unknown-edn-tags?)
           (tag-ref* #f #f))
      (error "Undefined tag" ns name)))

(define edn-tag
  (bind (preceded-by
         (is #\#)
         (lambda (input)
           (parameterize ((edn-parsers `((symbol . ,list))))
             (edn-symbol input))))
        (lambda (tag)
          (let* ((tag (map maybe-string->symbol tag))
                 (tag-parser (apply tag-ref tag)))
            (bind (any-of (edn-element)
                          (parser-error "Missing tag element"))
                  (lambda (el)
                    (result (apply tag-parser el tag))))))))


(define (read-edn #!optional (input (current-input-port)))
  (parse (edn-element) input))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.