From c927ae2e3b71cb4bef29af9da4667e490a7ee784 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 26 Aug 2016 22:31:11 +0200 Subject: [PATCH] Done most work concerning syntax/parse. --- structure-options2.rkt | 94 ++++++++++++++++++++------- structure-options2b-test.rkt | 36 ++++++++++- structure-options2b.rkt | 120 ++++++++++++++++++++++------------- 3 files changed, 181 insertions(+), 69 deletions(-) diff --git a/structure-options2.rkt b/structure-options2.rkt index f48498a..ed79f0b 100644 --- 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-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]))) \ 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 index 78a1772..a3278da 100644 --- 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 index 96288bd..052b6d5 100644 --- 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-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