A declarative racket DSL for extracting data from JSON

godot-api-spec.rkt

#lang racket

(require (for-syntax syntax/parse
                     racket/syntax
                     racket/string
                     racket/match
                     syntax/parse/class/paren-shape))
(provide make-godot-parser define-godot-bindings)

(module+ test
  (require rackunit))

(define (check-all-keys-present obj fields)
  (for ([key (hash-keys obj)])
    (unless (set-member? fields key)
      (error (format "found unknown key ~a (expected: ~a)"
                     key fields)
             obj))))

(begin-for-syntax
  (define (is-predicate stx)
    (string-suffix?
     (symbol->string (syntax-e stx))
     "?"))
  (define (jsonify stx)
    (define stx-str (symbol->string (syntax-e stx)))
    (define stx_str (string-replace stx-str "-" "_"))
    (define stx_sym (string->symbol stx_str))
    (datum->syntax stx stx_sym))

  (define (split-prefix-dot-field stx)
    (define stx-str (symbol->string (syntax-e stx)))
    (unless (string-prefix? stx-str ".")
      (raise-syntax-error #f
       "expected pre-dotted field .field (multiple components not supported)" stx))
    (define components (string-split stx-str "."))
    (match components
      [(list field-obj)
       (begin
         (define field-obj-sym (string->symbol field-obj))
         (datum->syntax stx field-obj-sym))]
      [else
       (raise-syntax-error #f
        "expected pre-dotted field .field (multiple components not supported)" stx)]))

  (define (split-dotted-field stx)
    (define stx-str (symbol->string (syntax-e stx)))
    (define components (string-split stx-str "."))
    (match components
      [(list base-obj field-obj)
       (begin
         (define base-obj-sym (string->symbol base-obj))
         (define field-obj-sym (string->symbol field-obj))
         (values
          (datum->syntax stx base-obj-sym)
          (datum->syntax stx field-obj-sym)))]
      [else
       (raise-syntax-error
        #f
        "expected dotted field obj.field (multiple components not supported)" stx)]))

  (define-syntax-class predicate?
    (pattern id:id
      #:fail-when (not (is-predicate #'id)) "expected a predicate (symbol ending in '?')"))
  (define-syntax-class godot-field-name-spec
    (pattern name:id
      #:with key (jsonify #'name)
      #:attr extractor
      (lambda (cls-obj)
        #`(hash-ref #,cls-obj 'key)))
    (pattern [~brackets name:id #:optional]
      #:with key (jsonify #'name)
      #:attr extractor
      (lambda (cls-obj)
        #`(hash-ref #,cls-obj 'key #f)))
    (pattern [~brackets name:id #:optional default:expr]
      #:with key (jsonify #'name)
      #:attr extractor
      (lambda (cls-obj)
        #`(hash-ref #,cls-obj 'key default))))
  (define-syntax-class godot-field-spec
    #:datum-literals (:)
    (pattern field-name:godot-field-name-spec
      #:with field #'field-name.name
      #:with name #'field-name.name
      #:with key (jsonify #'name)
      #:attr extractor      
      (lambda (cls-obj)
        (define field-obj-extractor (attribute field-name.extractor))
        (with-syntax ([hash-ref-expr (field-obj-extractor cls-obj)])
          (list
           #`[name hash-ref-expr]))))
    (pattern (~parens field-name:godot-field-name-spec : ty?:predicate?)
      #:with field #'field-name.name
      #:with name #'field-name.name
      #:with key (jsonify #'name)
      #:attr extractor      
      (lambda (cls-obj)
        (define error-message
          (format "expected ~a satisfying ~a" (syntax-e #'name) (syntax-e #'ty?)))
        (define field-obj-extractor (attribute field-name.extractor))
        (with-syntax ([hash-ref-expr (field-obj-extractor cls-obj)])
            (list
             #`[name hash-ref-expr]
             #`[_ (unless (or (not name) (ty? name))
                 (error #,error-message name))]))))
    (pattern (~parens field-name:godot-field-name-spec : [~brackets ty:godot-pattern])
      #:with field #'field-name.name
      #:with name #'field-name.name
      #:with key (jsonify #'name)
      #:with name-list (format-id #'name "~a-list" #'name)
      #:with name-obj (format-id #'name "~a-obj" #'name)
      #:attr extractor
      (lambda (cls-obj)
        (define field-name-extractor (attribute field-name.extractor))
        (define ty-extractor (attribute ty.extractor))
        (define name-obj #'name-obj)
        (with-syntax ([hash-ref-expr (field-name-extractor cls-obj)]
                      [extractor-expr (ty-extractor name-obj)])
          (list
           #`(name-list hash-ref-expr)
           #`(name
               (for/list ([#,name-obj (in-list (or name-list (list)))])
                 extractor-expr))))))
    (pattern (~parens field-name:godot-field-name-spec : ty:godot-pattern)
      #:with field #'field-name.name
      #:with name #'field-name.name
      #:with key (jsonify #'name)
      #:with name-raw (format-id #'name "~a-raw" #'name)
      #:attr extractor
      (lambda (cls-obj)
        (define field-name-extractor (attribute field-name.extractor))
        (define ty-extractor (attribute ty.extractor))
        (with-syntax ([hash-ref-expr (field-name-extractor cls-obj)]
                      [extractor-expr (ty-extractor #'name-raw)])
          (list
           #`(name-raw hash-ref-expr)
           #`(name extractor-expr))))))
  (define-syntax-class godot-pattern
    #:datum-literals (:)
    (pattern ty?:predicate?
      #:attr extractor
      (lambda (cls-obj)
        (define error-message
          (format "expected an object satisfying ~a" (syntax-e #'ty?)))
        #`(if (ty? #,cls-obj) #,cls-obj (error #,error-message #,cls-obj))))
    (pattern ty:id
      #:with extract-ty (format-id #'ty "extract-~a" #'ty)
      #:attr extractor
      (lambda (cls-obj)
        #`(extract-ty #,cls-obj)))
    (pattern [~brackets ty:godot-pattern]
      #:attr extractor
      (lambda (cls-list)
        (define cls-obj (format-id cls-list "~a-obj" cls-list))
        (define extractor (attribute ty.extractor))
        (with-syntax
            ([extractor-expr (extractor cls-obj)])
          #`(for/list ([#,cls-obj (in-list (or #,cls-list (list)))])
              extractor-expr))))
    (pattern [~brackets dotted-field:id : ty:godot-pattern]
      #:attr extractor
      (lambda (cls-list)
        (define cls-obj (format-id cls-list "~a-obj" cls-list))
        (define extractor (attribute ty.extractor))
        (define obj-field (split-prefix-dot-field #'dotted-field))
        (with-syntax
            ([extractor-expr (extractor cls-obj)]
             [obj-field (jsonify obj-field)])
          #`(for/hash ([#,cls-obj (in-list (or #,cls-list (list)))])
                       (define key (hash-ref #,cls-obj 'obj-field))
              (define value extractor-expr)
              (values key value)))))
    (pattern (~parens [~brackets obj:id : ty:godot-pattern] :
                      {~braces obj.field:id : obj-binding:id})
      #:fail-when (not (equal? (syntax->datum #'obj-binding)
                               (syntax->datum #'obj)))
      "RHS of hash pattern must match name in LHS"
      #:attr extractor
      (lambda (cls-list)
        (define cls-obj (format-id cls-list "~a-obj" cls-list))
        (define extractor (attribute ty.extractor))
        (define-values (obj-base obj-field) (split-dotted-field #'obj.field))
        (unless (equal? (syntax->datum obj-base)
                        (syntax->datum #'obj))
          (raise-syntax-error #f "base of dotted field must match name in LHS"
                              obj-base))
        (with-syntax
            ([extractor-expr (extractor cls-obj)]
             [obj-field (jsonify obj-field)])
          #`(for/hash ([#,cls-obj (in-list (or #,cls-list (list)))])
              (define key (hash-ref #,cls-obj 'obj-field))
              (define value extractor-expr)
              (values key value)))))
    (pattern {~braces field-spec:godot-field-spec ...}
      #:attr extractor
      (lambda (cls-obj)
        (define extractors (attribute field-spec.extractor))
        (define field-defs (apply append (map (lambda (f) (f cls-obj)) extractors)))
        (with-syntax
            ([(field-def ...) field-defs])
          #`(let* (field-def ...)
              (check-all-keys-present
               #,cls-obj
               (set 'field-spec.key ...))
              (hash (~@ 'field-spec.field field-spec.field) ...)))))
    (pattern (~parens {~braces field-spec:godot-field-spec ...} : ty:id)
      #:attr extractor
      (lambda (cls-obj)
        (define extractors (attribute field-spec.extractor))
        (define field-defs (apply append (map (lambda (f) (f cls-obj)) extractors)))
        (with-syntax
            ([(field-def ...) field-defs]
             [make-ty (format-id #'ty "make-~a" #'ty)])
          #`(let* (field-def ...)
              (check-all-keys-present
               #,cls-obj
               (set 'field-spec.key ...))
              (make-ty field-spec.field ...)))))))

(define-syntax (make-godot-parser stx)
  (syntax-parse stx
    [(_ pat:godot-pattern)
     (define cls #'cls)
     (with-syntax ([expr ((attribute pat.extractor) cls)])
       #`(lambda (#,cls)
           expr))
     ]))

(define-syntax (define-godot-bindings stx)
  (syntax-parse stx
    [(_ dotted-id:id pat:godot-pattern)
     (define-values (base-obj base-field) (split-dotted-field #'dotted-id))
     (define cls #'cls)
     (with-syntax ([base_field (jsonify base-field)]
                   [expr ((attribute pat.extractor) cls)])
       #`(define #,base-field
           (let ([#,cls (hash-ref #,base-obj 'base_field)])
               expr)))]))

(module+ test
  (check-exn
   #rx"found unknown key x.*"
   (lambda () ((make-godot-parser {}) #hash((x . 'y)))))

  (check-exn
   #rx"expected x satisfying string?.*"
   (lambda ()
     ((make-godot-parser {(x : string?)}) #hash((x . 'y)))))

  (check-exn
   #rx"expected an object satisfying string?.*"
   (lambda ()
     ((make-godot-parser {(x : string?)
                      (y : [string?])})
      #hash((x . "random")
            (y . ["hello" "world" y])))))
  (check-equal?
   ((make-godot-parser ([x : {(y : string?)}] : {x.y : x}))
    '[#hash((y . "hello"))
      #hash((y . "world"))])
   #hash(("hello" . #hash((y . "hello")))
         ("world" . #hash((y . "world"))))))