commit c927ae2e3b71cb4bef29af9da4667e490a7ee784
parent 3feb92c09da38ec622b2f8a1a1c7b4341eb88f1f
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Fri, 26 Aug 2016 22:31:11 +0200
Done most work concerning syntax/parse.
Diffstat:
3 files changed, 185 insertions(+), 72 deletions(-)
diff --git a/structure-options2.rkt b/structure-options2.rkt
@@ -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->datum
- (syntax-parse #'(#:builder)
- [(k:structure-kws)
- #'(k.builder k.instance-or-builder [k.field ...])]))
- '(#:builder #:builder []))
+(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"
@@ -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])))
-\ No newline at end of file
+ [(: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.
+\ No newline at end of file
diff --git a/structure-options2b-test.rkt b/structure-options2b-test.rkt
@@ -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)
+\ No newline at end of file
diff --git a/structure-options2b.rkt b/structure-options2b.rkt
@@ -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-~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-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 (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
