167 lines
6.5 KiB
Racket
167 lines
6.5 KiB
Racket
#lang racket
|
|
|
|
(require extensible-parser-specifications
|
|
racket/require
|
|
syntax/parse
|
|
rackunit
|
|
racket/format
|
|
phc-toolkit/untyped
|
|
(for-syntax syntax/parse
|
|
racket/format))
|
|
|
|
(provide structure-kw-instance-or-builder-mixin
|
|
structure-kw-predicate-mixin
|
|
structure-kw-fields-mixin
|
|
structure-kw-all-mixin
|
|
structure-kws)
|
|
|
|
(define-eh-alternative-mixin structure-kw-instance-or-builder-mixin
|
|
(pattern
|
|
{~optional {~and instance-or-builder
|
|
{~or {~global-or instance #:instance}
|
|
{~global-or builder #:builder}}}
|
|
#:name "either #:instance or #:builder"}))
|
|
|
|
(define-eh-alternative-mixin structure-kw-predicate-mixin
|
|
(pattern {~optional {~seq #:? predicate:id}
|
|
#:name "#:? predicate"}))
|
|
|
|
(define-and-for-syntax no-values-err
|
|
(~a "The #:instance keyword implies the use of [field value],"
|
|
" [field : type value] or [field value : type]."))
|
|
|
|
(define-and-for-syntax values-err
|
|
(~a "The #:builder keyword implies the use of [field], field"
|
|
" or [field : type]."))
|
|
|
|
(define-and-for-syntax empty-err
|
|
(~a "If no fields are specified, then either #:builder or #:instance"
|
|
" must be present"))
|
|
|
|
(define-eh-alternative-mixin structure-kw-fields-mixin
|
|
(pattern
|
|
{~optional/else
|
|
{~or {~seq {~or-bug [field:id] field:id} …+
|
|
{~global-or builder}
|
|
{~global-or no-types}
|
|
{~post-fail no-values-err #:when (attribute instance)}}
|
|
{~seq [field:id : type] …+
|
|
{~global-or builder}
|
|
{~global-or types}
|
|
{~post-fail no-values-err #:when (attribute instance)}}
|
|
{~seq [field:id value:expr] …+
|
|
{~global-or instance}
|
|
{~global-or no-types}
|
|
{~post-fail values-err #:when (attribute builder)}}
|
|
{~seq {~or-bug [field:id value:expr : type]
|
|
[field:id : type value:expr]}
|
|
…+
|
|
{~global-or instance}
|
|
{~global-or types}
|
|
{~post-fail values-err #:when (attribute builder)}}}
|
|
#:defaults ([(field 1) (list)]
|
|
[(value 1) (list)]
|
|
[(type 1) (list)])
|
|
#:else-post-fail empty-err #:when (and (not (attribute builder))
|
|
(not (attribute instance)))
|
|
#:name (~a "field or [field] or [field : type] for #:builder,"
|
|
" [field value] or [field : type value]"
|
|
" or [field value : type] for #:instance")}))
|
|
|
|
(define-eh-alternative-mixin structure-kw-all-mixin
|
|
(pattern {~or {structure-kw-instance-or-builder-mixin}
|
|
{structure-kw-predicate-mixin}
|
|
{structure-kw-fields-mixin}}))
|
|
|
|
(define-splicing-syntax-class structure-kws
|
|
(pattern {~seq-no-order {structure-kw-all-mixin}}))
|
|
|
|
;; ---------
|
|
|
|
(check-equal? (syntax-parse #'(#:instance #:? p)
|
|
[(:structure-kws)
|
|
(list* (attribute instance)
|
|
(syntax->datum
|
|
#'(instance-or-builder
|
|
predicate
|
|
[field ...]
|
|
[value ...])))])
|
|
'(#t #:instance p [] []))
|
|
|
|
(check-equal? (syntax-parse #'(#:builder)
|
|
[(k:structure-kws)
|
|
(list* (attribute k.builder)
|
|
(syntax->datum
|
|
#'(k.instance-or-builder [k.field ...])))])
|
|
'(#t #:builder []))
|
|
|
|
(test-exn
|
|
"Check that () is rejected, as it has neither #:instance nor #:builder"
|
|
(regexp (regexp-quote empty-err))
|
|
(λ ()
|
|
(syntax-parse #'()
|
|
[(:structure-kws) #'()])))
|
|
|
|
(test-exn
|
|
"Check that (#:instance [f1] [f2]) is rejected, as #:instance conflicts with
|
|
builder-style field declarations"
|
|
(regexp (regexp-quote no-values-err))
|
|
(λ ()
|
|
(syntax-parse #'(#:instance [f1] [f2])
|
|
[(:structure-kws) #'([field ...] instance)])))
|
|
|
|
(check-equal? (syntax-parse #'(#:builder #:? p [f1] [f2])
|
|
[(:structure-kws) (list* (attribute builder)
|
|
(syntax->datum #'([field ...])))])
|
|
'(#t [f1 f2]))
|
|
|
|
(check-equal? (syntax-parse #'([f1] [f2] #:? p)
|
|
[(:structure-kws) (cons (attribute builder)
|
|
(syntax->datum #'([field ...])))])
|
|
'(#t [f1 f2]))
|
|
|
|
;; This one is appropriately rejected
|
|
(check-exn #px"unexpected term"
|
|
(λ ()
|
|
(syntax-parse #'(#:instance #:a)
|
|
[(:structure-kws) 'err])))
|
|
|
|
(define instance-or-builder?
|
|
(syntax-parser [(:structure-kws) (list (attr instance) (attr builder))]))
|
|
|
|
(check-equal? '(#t #f) (instance-or-builder? #'(#:instance)))
|
|
(check-equal? '(#f #t) (instance-or-builder? #'(#:builder)))
|
|
(check-equal? '(#f #t) (instance-or-builder? #'(f1)))
|
|
(check-equal? '(#f #t) (instance-or-builder? #'([f1])))
|
|
(check-equal? '(#f #t) (instance-or-builder? #'([f1] f2)))
|
|
(check-equal? '(#f #t) (instance-or-builder? #'([f1 : type])))
|
|
(check-equal? '(#t #f) (instance-or-builder? #'([f1 value])))
|
|
(check-equal? '(#t #f) (instance-or-builder? #'([f1 : type value])))
|
|
(check-equal? '(#t #f) (instance-or-builder? #'([f1 value : type])))
|
|
(check-equal? '(#f #t) (instance-or-builder? #'(f1 #:builder)))
|
|
(check-equal? '(#f #t) (instance-or-builder? #'([f1] #:builder)))
|
|
(check-equal? '(#f #t) (instance-or-builder? #'([f1] f2 #:builder)))
|
|
(check-equal? '(#f #t) (instance-or-builder? #'([f1 : type] #:builder)))
|
|
(check-equal? '(#t #f) (instance-or-builder? #'([f1 value] #:instance)))
|
|
(check-equal? '(#t #f) (instance-or-builder? #'([f1 : type value] #:instance)))
|
|
(check-equal? '(#t #f) (instance-or-builder? #'([f1 value : type] #:instance)))
|
|
|
|
;; TODO: use (reified-syntax-class-attributes r) to make a simplified version
|
|
;; of a macro, which just accepts all the attributes. Another macro can
|
|
;; then forward all the attributes at once, with minimal meta-level 1 cost
|
|
;; (obviously, constructing the wrappers etx. will have some metal-level 2 cost)
|
|
;;
|
|
;; Wrapper:
|
|
;; (define-syntax (real-macro-name stx)
|
|
;; (syntax-parse stx
|
|
;; [(~reflect whole some-reified-splicing-syntax-class)
|
|
;; (simplified-macro-implementation (attribute attr0) ...)]))
|
|
;; Implementation
|
|
;; (define-for-syntax (simplified-macro-implementation val0 ...)
|
|
;; (syntax-parse #'dummy
|
|
;; [(~bind [(attr0 depth) val0] ...)
|
|
;; body]))
|
|
;;
|
|
;; For speed, we could just copy the whole implementation in real-macro-name's
|
|
;; definition, instead of calling simplified-macro-implementation.
|