suzanne.soy/extensible-parser-specifications
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Done most work concerning syntax/parse.

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-26 22:31:11 +02:00
parent 3feb92c09d
commit c927ae2e3b
3 changed files with 181 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
structure-options2.rkt
View File

@ -17,10 +17,11 @@
structure-kw-all-mixin) structure-kw-all-mixin)
(define-eh-alternative-mixin structure-kw-instance-or-builder (define-eh-alternative-mixin structure-kw-instance-or-builder
(pattern (~optional (~and instance-or-builder (pattern
(~or (~and instance #:instance) (~optional (~and instance-or-builder
(~and builder #:builder))) (~or (~global-or instance #:instance)
#:name "either #:instance or #:builder"))) (~global-or builder #:builder)))
#:name "either #:instance or #:builder")))
(define-eh-alternative-mixin structure-kw-predicate (define-eh-alternative-mixin structure-kw-predicate
(pattern (~optional (~seq #:? predicate:id) (pattern (~optional (~seq #:? predicate:id)
@ -42,14 +43,18 @@
(pattern (pattern
(~optional/else (~optional/else
(~or (~seq (~or-bug [field:id] field:id) …+ (~or (~seq (~or-bug [field:id] field:id) …+
(~global-or builder)
(~post-fail no-values-err #:when (attribute instance))) (~post-fail no-values-err #:when (attribute instance)))
(~seq [field:id : type] …+ (~seq [field:id : type] …+
(~global-or builder)
(~post-fail no-values-err #:when (attribute instance))) (~post-fail no-values-err #:when (attribute instance)))
(~seq [field:id value:expr] …+ (~seq [field:id value:expr] …+
(~global-or instance)
(~post-fail values-err #:when (attribute builder))) (~post-fail values-err #:when (attribute builder)))
(~seq (~or-bug [field:id value:expr : type] (~seq (~or-bug [field:id value:expr : type]
[field:id : type value:expr]) [field:id : type value:expr])
…+ …+
(~global-or instance)
(~post-fail values-err #:when (attribute builder)))) (~post-fail values-err #:when (attribute builder))))
#:defaults ([(field 1) (list)] #:defaults ([(field 1) (list)]
[(value 1) (list)] [(value 1) (list)]
@ -70,20 +75,22 @@
(define-splicing-syntax-class structure-kws (define-splicing-syntax-class structure-kws
(pattern (~no-order (structure-kw-all-mixin)))) (pattern (~no-order (structure-kw-all-mixin))))
(check-equal? (syntax->datum (check-equal? (syntax-parse #'(#:instance #:? p)
(syntax-parse #'(#:instance #:? p) [(:structure-kws)
[(:structure-kws) (list* (attribute instance)
#'(instance instance-or-builder (syntax->datum
predicate #'(instance-or-builder
[field ...] predicate
[value ...])])) [field ...]
'(#:instance #:instance p [] [])) [value ...])))])
'(#t #:instance p [] []))
(check-equal? (syntax->datum (check-equal? (syntax-parse #'(#:builder)
(syntax-parse #'(#:builder) [(k:structure-kws)
[(k:structure-kws) (list* (attribute k.builder)
#'(k.builder k.instance-or-builder [k.field ...])])) (syntax->datum
'(#:builder #:builder [])) #'(k.instance-or-builder [k.field ...])))])
'(#t #:builder []))
(test-exn (test-exn
"Check that () is rejected, as it has neither #:instance nor #:builder" "Check that () is rejected, as it has neither #:instance nor #:builder"
@ -100,18 +107,57 @@ builder-style field declarations"
(syntax-parse #'(#:instance [f1] [f2]) (syntax-parse #'(#:instance [f1] [f2])
[(:structure-kws) #'([field ...] instance)]))) [(:structure-kws) #'([field ...] instance)])))
(check-equal? (syntax->datum (check-equal? (syntax-parse #'(#:builder #:? p [f1] [f2])
(syntax-parse #'(#:builder #:? p [f1] [f2]) [(:structure-kws) (list* (attribute builder)
[(:structure-kws) #'([field ...] builder)])) (syntax->datum #'([field ...])))])
'([f1 f2] #:builder)) '(#t [f1 f2]))
(check-equal? (syntax-parse #'([f1] [f2]); #:? p (check-equal? (syntax-parse #'([f1] [f2] #:? p)
[(:structure-kws) (cons (attribute builder) [(:structure-kws) (cons (attribute builder)
(syntax->datum #'([field ...])))]) (syntax->datum #'([field ...])))])
'(#f [f1 f2])) '(#t [f1 f2]))
;; This one is appropriately rejected ;; This one is appropriately rejected
(check-exn #px"unexpected term" (check-exn #px"unexpected term"
(λ () (λ ()
(syntax-parse #'(#:instance #:a) (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.

36
structure-options2b-test.rkt
View File

@ -11,5 +11,37 @@
syntax/stx syntax/stx
racket/format)) racket/format))
(syntax-parse #'(1 #:kw 3) (check-equal? (syntax-parse #'(1 "ab" #:kw "ab" 3 4 5)
[{~no-order {~once {~global-counter #:kw }} } [({~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)

120
structure-options2b.rkt
View File

@ -5,11 +5,13 @@
generic-syntax-expanders generic-syntax-expanders
phc-toolkit/untyped phc-toolkit/untyped
(for-syntax syntax/parse (for-syntax syntax/parse
syntax/parse/experimental/template
racket/syntax racket/syntax
phc-toolkit/untyped phc-toolkit/untyped
racket/list racket/list
generic-syntax-expanders generic-syntax-expanders
racket/contract)) racket/function
racket/pretty))
(provide ;define-splicing-syntax-class-with-eh-mixins (provide ;define-splicing-syntax-class-with-eh-mixins
;define-syntax-class-with-eh-mixins ;define-syntax-class-with-eh-mixins
@ -22,7 +24,10 @@
~optional/else ~optional/else
~global-or ~global-or
~global-and ~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 ;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
@ -41,7 +46,7 @@
(apply (parameter-name) args)))) (apply (parameter-name) args))))
(define-dynamic-accumulator-parameter eh-post-accumulate eh-post-accumulate!) (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) (λ (stx)
(syntax-case stx () (syntax-case stx ()
[(self pat ...) [(self pat ...)
(let () ((λ (x) #;(pretty-write (syntax->datum x)) x)
(define counter 0) (let ()
(define (increment-counter) (define counter 0)
(begin0 counter (define (increment-counter)
(set! counter (add1 counter)))) (begin0 counter
(define post-acc '()) (set! counter (add1 counter))))
(define (add-to-post! v) (set! post-acc (cons v post-acc))) ;; post-acc gathers some a-patterns which will be added after the
;; pre-acc gathers some bindings that have to be pre-declared ;; (~seq (~or ) ...)
(define pre-acc (make-hash)) (define post-acc '())
(define/contract (add-to-pre! s v) (-> symbol? any/c identifier?) (define (add-to-post! v) (set! post-acc (cons v post-acc)))
(define not-found (gensym)) ;; post-groups-acc gathers some attributes that have to be grouped
(define ref (hash-ref pre-acc s #f)) (define post-groups-acc '())
(if ref (define (add-to-post-groups! . v)
(car ref) (set! post-groups-acc (cons v post-groups-acc)))
(let ([id (datum->syntax (syntax-local-introduce #'here) s)]) ;; expand EH alternatives:
(hash-set! pre-acc s (cons id v)) (define alts
id))) (parameterize ([eh-post-accumulate add-to-post!]
;(define-values (pre-acc add-to-pre) (make-mutable-accumulator)) [eh-post-group add-to-post-groups!]
(define alts [clause-counter increment-counter])
(parameterize ([eh-post-accumulate add-to-post!] (inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
[eh-pre-declarations add-to-pre!] (define post-group-bindings
[clause-counter increment-counter]) (for/list ([group (group-by car post-groups-acc free-identifier=?)])
(inline-or (expand-all-eh-mixin-expanders #'(~or pat ...))))) ;; each item in `group` is a four-element list:
(define pre-acc-bindings (hash-map pre-acc ;; (list result-id aggregate-function attribute)
(λ (s bv) #`(define . #,bv)))) (define/with-syntax name (first (car group))
#`(~delimit-cut #;(syntax-local-introduce
(~and (~do #,@pre-acc-bindings) (datum->syntax #'here
(~seq (~or . #,alts) (... ...)) (first (car group)))))
~! (define/with-syntax f (second (car group)))
#,@post-acc)))])))) #`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
group))]))
#`(~delimit-cut
(~and (~seq (~or . #,alts) (... ...))
~!
(~bind #,@post-group-bindings)
#,@post-acc))))]))))
(define-syntax ~nop (define-syntax ~nop
(pattern-expander (pattern-expander
@ -142,17 +153,40 @@
[(self (mutex:id ...) pat ...) [(self (mutex:id ...) pat ...)
#'(???)])))) #'(???)]))))
(define-syntax-rule (define-~global ~global-name init f) (define-syntax/parse (define-~global global-name (~optional default) f)
(define-eh-mixin-expander ~global-name (define use-default-v? (syntax-e #'default-v?))
(λ/syntax-case (_ name v pat) () (template
(eh-pre-declare! '~bool-or (syntax-e #'name) init) (define-eh-mixin-expander global-name
#`(~and (~do (define tmp name)) (syntax-parser
(~do (define name (#,f tmp v))) [(_ (?? (~or [name v] (~and name (~bind [v default])))
pat)))) [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 (aggregate-global-or . bs)
(define-~global ~global-and #t (λ (acc v) (and acc v))) (ormap unbox ;; remove the layer of protection
(define-~global ~global-counter 0 add1) (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 (define-eh-mixin-expander ~optional/else
(syntax-parser (syntax-parser