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

Implemented ~global-or, ~global-and and ~global-counter, but they don't work properly due to backtracking.

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-26 20:15:03 +02:00
parent 95f455a89d
commit 3feb92c09d
3 changed files with 160 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
structure-options2.rkt
View File

@ -6,12 +6,11 @@
rackunit rackunit
racket/format racket/format
phc-toolkit/untyped phc-toolkit/untyped
"structure-options2b.rkt"
(for-syntax syntax/parse (for-syntax syntax/parse
syntax/stx syntax/stx
racket/format)) racket/format))
(require "structure-options2b.rkt")
(provide structure-kw-instance-or-builder-mixin (provide structure-kw-instance-or-builder-mixin
structure-kw-predicate-mixin structure-kw-predicate-mixin
structure-kw-fields-mixin structure-kw-fields-mixin
@ -41,11 +40,7 @@
(define-eh-alternative-mixin structure-kw-fields (define-eh-alternative-mixin structure-kw-fields
(pattern (pattern
(~optional (~and (~optional/else
(~seq clause42 ...)
;; can't use #f, because of the bug
;; https://github.com/racket/racket/issues/1437
(~bind [clause42-match? 1])
(~or (~seq (~or-bug [field:id] field:id) …+ (~or (~seq (~or-bug [field:id] field:id) …+
(~post-fail no-values-err #:when (attribute instance))) (~post-fail no-values-err #:when (attribute instance)))
(~seq [field:id : type] …+ (~seq [field:id : type] …+
@ -55,22 +50,12 @@
(~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])
…+ …+
(~post-fail values-err #:when (attribute builder))))) (~post-fail values-err #:when (attribute builder))))
#:defaults ([(field 1) #'()] #:defaults ([(field 1) (list)]
[(clause42 1) #'()] [(value 1) (list)]
[clause42-match? [(type 1) (list)])
(begin (syntax-parse #'dummy #:else-post-fail empty-err #:when (and (not (attribute builder))
[(~and dummy (not (attribute instance)))
(~post-check (~fail #:when
(and (= (attribute clause42-match?) 0)
(and (not (attribute builder))
(not (attribute instance))))
empty-err)))
#'()])
0)])
#;(~post-fail empty-err
#:when (and (not (attribute builder))
(not (attribute instance))))
#:name (~a "field or [field] or [field : type] for #:builder," #:name (~a "field or [field] or [field : type] for #:builder,"
" [field value] or [field : type value]" " [field value] or [field : type value]"
" or [field value : type] for #:instance")))) " or [field value : type] for #:instance"))))
@ -85,16 +70,20 @@
(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->datum
(syntax-parse #'(#:instance #:? p) (syntax-parse #'(#:instance #:? p)
[(:structure-kws) #'(instance instance-or-builder predicate)])) [(:structure-kws)
'(#:instance #:instance p)) #'(instance instance-or-builder
predicate
[field ...]
[value ...])]))
'(#:instance #:instance p [] []))
(check-equal? (syntax->datum (check-equal? (syntax->datum
(syntax-parse #'(#:builder) (syntax-parse #'(#:builder)
[(k:structure-kws) #'(k.builder k.instance-or-builder)])) [(k:structure-kws)
'(#:builder #:builder)) #'(k.builder k.instance-or-builder [k.field ...])]))
'(#:builder #: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"
@ -110,7 +99,6 @@ 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->datum
(syntax-parse #'(#:builder #:? p [f1] [f2]) (syntax-parse #'(#:builder #:? p [f1] [f2])
@ -123,7 +111,7 @@ builder-style field declarations"
'(#f [f1 f2])) '(#f [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])))

15
structure-options2b-test.rkt Normal file
View File

@ -0,0 +1,15 @@
#lang racket
(require "structure-options2b.rkt"
racket/require
syntax/parse
(subtract-in syntax/stx phc-toolkit/untyped)
rackunit
racket/format
phc-toolkit/untyped
(for-syntax syntax/parse
syntax/stx
racket/format))
(syntax-parse #'(1 #:kw 3)
[{~no-order {~once {~global-counter #:kw }} }

126
structure-options2b.rkt
View File

@ -3,12 +3,13 @@
(require syntax/parse (require syntax/parse
syntax/parse/experimental/eh syntax/parse/experimental/eh
generic-syntax-expanders generic-syntax-expanders
phc-toolkit/untyped
(for-syntax syntax/parse (for-syntax syntax/parse
racket/syntax racket/syntax
phc-toolkit/untyped phc-toolkit/untyped
racket/list racket/list
generic-syntax-expanders generic-syntax-expanders
racket/pretty)) racket/contract))
(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
@ -17,7 +18,11 @@
~no-order ~no-order
~post-check ~post-check
~post-fail ~post-fail
~nop) ~nop
~optional/else
~global-or
~global-and
~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
@ -25,8 +30,24 @@
(define-expander-type eh-mixin) (define-expander-type eh-mixin)
(define-for-syntax eh-post-accumulate (make-parameter #f)) (define-syntax-rule (define-dynamic-accumulator-parameter parameter-name name!)
(begin
(define-for-syntax parameter-name (make-parameter #f))
(define-for-syntax (name! name . args)
(unless (parameter-name)
(raise-syntax-error name
(string-append (symbol->string name)
" used outside of ~no-order")))
(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-for-syntax clause-counter (make-parameter #f)) (define-for-syntax clause-counter (make-parameter #f))
(define-for-syntax (get-new-clause!)
(string->symbol (format "clause~a" ((clause-counter)))))
(define-syntax define-eh-alternative-mixin (define-syntax define-eh-alternative-mixin
(syntax-parser (syntax-parser
@ -36,10 +57,7 @@
(define-temp-ids "~a/clause" (pat ...)) (define-temp-ids "~a/clause" (pat ...))
#'(define-eh-mixin-expander mixin #'(define-eh-mixin-expander mixin
(λ (_) (λ (_)
(quote-syntax (~or pat ...)) (quote-syntax (~or pat ...)))))]))
#;#`(~or #,(parameterize ([current-no-order-clause #'pat/clause])
(quote-syntax pat))
...))))]))
;; ---------- ;; ----------
@ -57,64 +75,65 @@
(λ (stx) (λ (stx)
(syntax-case stx () (syntax-case stx ()
[(self pat ...) [(self pat ...)
((λ (x) (pretty-write (syntax->datum x)) (newline) x)
(let () (let ()
(define acc '())
(define counter 0) (define counter 0)
(define (increment-counter) (define (increment-counter)
(begin0 counter (begin0 counter
(set! counter (add1 counter)))) (set! counter (add1 counter))))
(define (add-to-acc p) (define post-acc '())
(set! acc (cons p 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 (define alts
(parameterize ([eh-post-accumulate add-to-acc] (parameterize ([eh-post-accumulate add-to-post!]
[eh-pre-declarations add-to-pre!]
[clause-counter increment-counter]) [clause-counter increment-counter])
(inline-or (expand-all-eh-mixin-expanders #'(~or pat ...))))) (inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
(define pre-acc-bindings (hash-map pre-acc
(λ (s bv) #`(define . #,bv))))
#`(~delimit-cut #`(~delimit-cut
(~and (~seq (~or . #,alts) (... ...)) (~and (~do #,@pre-acc-bindings)
(~seq (~or . #,alts) (... ...))
~! ~!
#,@acc))))])))) #,@post-acc)))]))))
(define-syntax ~nop (define-syntax ~nop
(pattern-expander (pattern-expander
(λ/syntax-case (_) () #'(~do)))) (λ/syntax-case (_) () #'(~do))))
(define-for-syntax (eh-post-accumulate! name p)
(unless (eh-post-accumulate)
(raise-syntax-error
name
(string-append (symbol->string name) " used outside of ~no-order")))
((eh-post-accumulate) p))
(define-eh-mixin-expander ~post-check (define-eh-mixin-expander ~post-check
(λ (stx) (λ (stx)
(syntax-case stx () (syntax-case stx ()
[(_ pat post) [(_ pat post)
(begin (begin (eh-post-accumulate! '~post-check #'post)
(eh-post-accumulate! '~post-check #'post)
#'pat)] #'pat)]
[(_ post) [(_ post)
(begin (begin (eh-post-accumulate! '~post-check #'post)
(eh-post-accumulate! '~post-check #'post)
#'(~nop))]))) #'(~nop))])))
(define-eh-mixin-expander ~post-fail (define-for-syntax (post-fail stx)
(let ()
(define (parse stx)
(syntax-case stx () (syntax-case stx ()
[(_ message #:when condition) [(_ message #:when condition)
(begin (begin
(define/with-syntax clause-present (define/with-syntax clause-present (get-new-clause!))
(string->symbol (format "clause~a" ((clause-counter))))) (eh-post-accumulate! '~post-fail
(eh-post-accumulate!
'~post-fail
#`(~fail #:when (and (attribute clause-present) #`(~fail #:when (and (attribute clause-present)
condition) condition)
message)) message))
#'(~bind [clause-present #t]))] #'(~bind [clause-present #t]))]
[(self #:when condition message) [(self #:when condition message)
(parse #'(self message #:when condition))])) (post-fail #'(self message #:when condition))]))
parse))
(define-eh-mixin-expander ~post-fail post-fail)
(define-syntax ~mutex (define-syntax ~mutex
(pattern-expander (pattern-expander
@ -122,3 +141,42 @@
(syntax-case stx () (syntax-case stx ()
[(self (mutex:id ...) pat ...) [(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-eh-mixin-expander ~optional/else
(syntax-parser
[(_ pat
(~optional (~seq #:defaults (default-binding ...))
#:defaults ([(default-binding 1) (list)]))
(~seq #:else-post-fail (~or (~seq message #:when condition)
(~seq #:when condition message)))
...
(~optional (~seq #:name name)))
#:with clause-whole (get-new-clause!)
#:with clause-present (get-new-clause!)
(for ([message (in-syntax #'(message ...))]
[condition (in-syntax #'(condition ...))])
(eh-post-accumulate! '~optional/else
#`(~fail #:when (and (eq? (attr clause-present) 0)
#,condition)
#,message)))
#`(~optional (~and pat
;(~seq clause-whole (... ...))
;; can't use #f, because of the bug
;; https://github.com/racket/racket/issues/1437
(~bind [clause-present 1]))
#:defaults (default-binding ...
;[(clause-whole 1) #'()]
[clause-present 0])
#,@(if (attribute name) #'(#:name name) #'()))]))