Done most work concerning syntax/parse.
This commit is contained in:
Georges Dupéron
parent
3feb92c09d
commit
c927ae2e3b
|
|
@ -17,10 +17,11 @@
|
|||
structure-kw-all-mixin)
|
||||
|
||||
(define-eh-alternative-mixin structure-kw-instance-or-builder
|
||||
(pattern (~optional (~and instance-or-builder
|
||||
(~or (~and instance #:instance)
|
||||
(~and builder #:builder)))
|
||||
#:name "either #:instance or #:builder")))
|
||||
(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
|
||||
(pattern (~optional (~seq #:? predicate:id)
|
||||
|
|
@ -42,14 +43,18 @@
|
|||
(pattern
|
||||
(~optional/else
|
||||
(~or (~seq (~or-bug [field:id] field:id) …+
|
||||
(~global-or builder)
|
||||
(~post-fail no-values-err #:when (attribute instance)))
|
||||
(~seq [field:id : type] …+
|
||||
(~global-or builder)
|
||||
(~post-fail no-values-err #:when (attribute instance)))
|
||||
(~seq [field:id value:expr] …+
|
||||
(~global-or instance)
|
||||
(~post-fail values-err #:when (attribute builder)))
|
||||
(~seq (~or-bug [field:id value:expr : type]
|
||||
[field:id : type value:expr])
|
||||
…+
|
||||
(~global-or instance)
|
||||
(~post-fail values-err #:when (attribute builder))))
|
||||
#:defaults ([(field 1) (list)]
|
||||
[(value 1) (list)]
|
||||
|
|
@ -70,20 +75,22 @@
|
|||
(define-splicing-syntax-class structure-kws
|
||||
(pattern (~no-order (structure-kw-all-mixin))))
|
||||
|
||||
(check-equal? (syntax->datum
|
||||
(syntax-parse #'(#:instance #:? p)
|
||||
[(:structure-kws)
|
||||
#'(instance instance-or-builder
|
||||
predicate
|
||||
[field ...]
|
||||
[value ...])]))
|
||||
'(#:instance #:instance p [] []))
|
||||
(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->datum
|
||||
(syntax-parse #'(#:builder)
|
||||
[(k:structure-kws)
|
||||
#'(k.builder k.instance-or-builder [k.field ...])]))
|
||||
'(#:builder #:builder []))
|
||||
(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"
|
||||
|
|
@ -100,18 +107,57 @@ builder-style field declarations"
|
|||
(syntax-parse #'(#:instance [f1] [f2])
|
||||
[(:structure-kws) #'([field ...] instance)])))
|
||||
|
||||
(check-equal? (syntax->datum
|
||||
(syntax-parse #'(#:builder #:? p [f1] [f2])
|
||||
[(:structure-kws) #'([field ...] builder)]))
|
||||
'([f1 f2] #:builder))
|
||||
(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
|
||||
(check-equal? (syntax-parse #'([f1] [f2] #:? p)
|
||||
[(:structure-kws) (cons (attribute builder)
|
||||
(syntax->datum #'([field ...])))])
|
||||
'(#f [f1 f2]))
|
||||
'(#t [f1 f2]))
|
||||
|
||||
;; This one is appropriately rejected
|
||||
(check-exn #px"unexpected term"
|
||||
(λ ()
|
||||
(syntax-parse #'(#:instance #:a)
|
||||
[(:structure-kws) 'err])))
|
||||
[(: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.
|
||||
|
|
@ -11,5 +11,37 @@
|
|||
syntax/stx
|
||||
racket/format))
|
||||
|
||||
(syntax-parse #'(1 #:kw 3)
|
||||
[{~no-order {~once {~global-counter #:kw }} }
|
||||
(check-equal? (syntax-parse #'(1 "ab" #:kw "ab" 3 4 5)
|
||||
[({~no-order {~once {~global-counter cnt 'occurrencea #:kw}}
|
||||
{~global-counter cnt 'occurrenceb :number}
|
||||
"ab"})
|
||||
(attribute cnt)])
|
||||
5)
|
||||
|
||||
(check-equal? (syntax-parse #'(1 "ab" #:kw "ab" 3 4 5)
|
||||
[({~no-order {~once {~global-or kw-or-number #t #:kw}}
|
||||
{~global-or kw-or-number #t :number}
|
||||
"ab"})
|
||||
(attribute kw-or-number)])
|
||||
#t)
|
||||
|
||||
(check-equal? (syntax-parse #'(1 "ab" "ab" 3 4 5)
|
||||
[({~no-order {~optional {~global-or kw #t #:kw}}
|
||||
{~global-or kw #f :number}
|
||||
"ab"})
|
||||
(attribute kw)])
|
||||
#f)
|
||||
|
||||
(check-equal? (syntax-parse #'(1 "ab" #:kw "ab" 3 4 5)
|
||||
[({~no-order {~optional {~global-and kw-and-not-number #t #:kw}}
|
||||
{~global-and kw-and-not-number #f :number}
|
||||
"ab"})
|
||||
(attribute kw-and-not-number)])
|
||||
#f)
|
||||
|
||||
(check-equal? (syntax-parse #'("ab" #:kw "ab")
|
||||
[({~no-order {~optional {~global-and kw-and-not-number #t #:kw}}
|
||||
{~global-and kw-and-not-number #f :number}
|
||||
"ab"})
|
||||
(attribute kw-and-not-number)])
|
||||
#t)
|
||||
|
|
@ -5,11 +5,13 @@
|
|||
generic-syntax-expanders
|
||||
phc-toolkit/untyped
|
||||
(for-syntax syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
racket/syntax
|
||||
phc-toolkit/untyped
|
||||
racket/list
|
||||
generic-syntax-expanders
|
||||
racket/contract))
|
||||
racket/function
|
||||
racket/pretty))
|
||||
|
||||
(provide ;define-splicing-syntax-class-with-eh-mixins
|
||||
;define-syntax-class-with-eh-mixins
|
||||
|
|
@ -22,7 +24,10 @@
|
|||
~optional/else
|
||||
~global-or
|
||||
~global-and
|
||||
~global-counter)
|
||||
~global-counter
|
||||
aggregate-global-or
|
||||
aggregate-global-and
|
||||
aggregate-global-counter)
|
||||
|
||||
;; ------------
|
||||
;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
|
||||
|
|
@ -41,7 +46,7 @@
|
|||
(apply (parameter-name) args))))
|
||||
|
||||
(define-dynamic-accumulator-parameter eh-post-accumulate eh-post-accumulate!)
|
||||
(define-dynamic-accumulator-parameter eh-pre-declarations eh-pre-declare!)
|
||||
(define-dynamic-accumulator-parameter eh-post-group eh-post-group!)
|
||||
|
||||
;; ----
|
||||
|
||||
|
|
@ -75,36 +80,42 @@
|
|||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(self pat ...)
|
||||
(let ()
|
||||
(define counter 0)
|
||||
(define (increment-counter)
|
||||
(begin0 counter
|
||||
(set! counter (add1 counter))))
|
||||
(define post-acc '())
|
||||
(define (add-to-post! v) (set! post-acc (cons v post-acc)))
|
||||
;; pre-acc gathers some bindings that have to be pre-declared
|
||||
(define pre-acc (make-hash))
|
||||
(define/contract (add-to-pre! s v) (-> symbol? any/c identifier?)
|
||||
(define not-found (gensym))
|
||||
(define ref (hash-ref pre-acc s #f))
|
||||
(if ref
|
||||
(car ref)
|
||||
(let ([id (datum->syntax (syntax-local-introduce #'here) s)])
|
||||
(hash-set! pre-acc s (cons id v))
|
||||
id)))
|
||||
;(define-values (pre-acc add-to-pre) (make-mutable-accumulator))
|
||||
(define alts
|
||||
(parameterize ([eh-post-accumulate add-to-post!]
|
||||
[eh-pre-declarations add-to-pre!]
|
||||
[clause-counter increment-counter])
|
||||
(inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
|
||||
(define pre-acc-bindings (hash-map pre-acc
|
||||
(λ (s bv) #`(define . #,bv))))
|
||||
#`(~delimit-cut
|
||||
(~and (~do #,@pre-acc-bindings)
|
||||
(~seq (~or . #,alts) (... ...))
|
||||
~!
|
||||
#,@post-acc)))]))))
|
||||
((λ (x) #;(pretty-write (syntax->datum x)) x)
|
||||
(let ()
|
||||
(define counter 0)
|
||||
(define (increment-counter)
|
||||
(begin0 counter
|
||||
(set! counter (add1 counter))))
|
||||
;; post-acc gathers some a-patterns which will be added after the
|
||||
;; (~seq (~or ) ...)
|
||||
(define post-acc '())
|
||||
(define (add-to-post! v) (set! post-acc (cons v post-acc)))
|
||||
;; post-groups-acc gathers some attributes that have to be grouped
|
||||
(define post-groups-acc '())
|
||||
(define (add-to-post-groups! . v)
|
||||
(set! post-groups-acc (cons v post-groups-acc)))
|
||||
;; expand EH alternatives:
|
||||
(define alts
|
||||
(parameterize ([eh-post-accumulate add-to-post!]
|
||||
[eh-post-group add-to-post-groups!]
|
||||
[clause-counter increment-counter])
|
||||
(inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
|
||||
(define post-group-bindings
|
||||
(for/list ([group (group-by car post-groups-acc free-identifier=?)])
|
||||
;; each item in `group` is a four-element list:
|
||||
;; (list result-id aggregate-function attribute)
|
||||
(define/with-syntax name (first (car group))
|
||||
#;(syntax-local-introduce
|
||||
(datum->syntax #'here
|
||||
(first (car group)))))
|
||||
(define/with-syntax f (second (car group)))
|
||||
#`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
|
||||
group))]))
|
||||
#`(~delimit-cut
|
||||
(~and (~seq (~or . #,alts) (... ...))
|
||||
~!
|
||||
(~bind #,@post-group-bindings)
|
||||
#,@post-acc))))]))))
|
||||
|
||||
(define-syntax ~nop
|
||||
(pattern-expander
|
||||
|
|
@ -142,17 +153,40 @@
|
|||
[(self (mutex:id ...) pat ...)
|
||||
#'(???)]))))
|
||||
|
||||
(define-syntax-rule (define-~global ~global-name init f)
|
||||
(define-eh-mixin-expander ~global-name
|
||||
(λ/syntax-case (_ name v pat) ()
|
||||
(eh-pre-declare! '~bool-or (syntax-e #'name) init)
|
||||
#`(~and (~do (define tmp name))
|
||||
(~do (define name (#,f tmp v)))
|
||||
pat))))
|
||||
(define-syntax/parse (define-~global global-name (~optional default) f)
|
||||
(define use-default-v? (syntax-e #'default-v?))
|
||||
(template
|
||||
(define-eh-mixin-expander global-name
|
||||
(syntax-parser
|
||||
[(_ (?? (~or [name v] (~and name (~bind [v default])))
|
||||
[name v])
|
||||
. pat)
|
||||
(define/with-syntax clause-value (get-new-clause!))
|
||||
(eh-post-group! '~global-name
|
||||
#'name ;(syntax-e #'name)
|
||||
#'f
|
||||
#'clause-value)
|
||||
;; protect the values inside an immutable box, so that a #f can be
|
||||
;; distinguished from a failed match.
|
||||
#'(~and (~bind [clause-value (box-immutable v)])
|
||||
. pat)]))))
|
||||
|
||||
(define-~global ~global-or #f (λ (acc v) (or acc v)))
|
||||
(define-~global ~global-and #t (λ (acc v) (and acc v)))
|
||||
(define-~global ~global-counter 0 add1)
|
||||
(define (aggregate-global-or . bs)
|
||||
(ormap unbox ;; remove the layer of protection
|
||||
(filter identity ;; remove failed bindings
|
||||
(flatten bs)))) ;; don't care about ellipsis nesting
|
||||
(define-~global ~global-or #'#t aggregate-global-or)
|
||||
|
||||
(define (aggregate-global-and . bs)
|
||||
(andmap unbox ;; remove the layer of protection
|
||||
(filter identity ;; remove failed bindings
|
||||
(flatten bs)))) ;; don't care about ellipsis nesting
|
||||
(define-~global ~global-and aggregate-global-and)
|
||||
|
||||
(define (aggregate-global-counter . bs)
|
||||
(length (filter identity ;; remove failed bindings
|
||||
(flatten bs)))) ;; don't care about ellipsis nesting
|
||||
(define-~global ~global-counter #''occurrence aggregate-global-counter)
|
||||
|
||||
(define-eh-mixin-expander ~optional/else
|
||||
(syntax-parser
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user