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

78
structure-options2.rkt
View File

@ -6,12 +6,11 @@
rackunit
racket/format
phc-toolkit/untyped
"structure-options2b.rkt"
(for-syntax syntax/parse
syntax/stx
racket/format))
(require "structure-options2b.rkt")
(provide structure-kw-instance-or-builder-mixin
structure-kw-predicate-mixin
structure-kw-fields-mixin
@ -41,39 +40,25 @@
(define-eh-alternative-mixin structure-kw-fields
(pattern
(~optional (~and
(~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) …+
(~post-fail no-values-err #:when (attribute instance)))
(~seq [field:id : type] …+
(~post-fail no-values-err #:when (attribute instance)))
(~seq [field:id value:expr] …+
(~post-fail values-err #:when (attribute builder)))
(~seq (~or-bug [field:id value:expr : type]
[field:id : type value:expr])
…+
(~post-fail values-err #:when (attribute builder)))))
#:defaults ([(field 1) #'()]
[(clause42 1) #'()]
[clause42-match?
(begin (syntax-parse #'dummy
[(~and dummy
(~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,"
" [field value] or [field : type value]"
" or [field value : type] for #:instance"))))
(~optional/else
(~or (~seq (~or-bug [field:id] field:id) …+
(~post-fail no-values-err #:when (attribute instance)))
(~seq [field:id : type] …+
(~post-fail no-values-err #:when (attribute instance)))
(~seq [field:id value:expr] …+
(~post-fail values-err #:when (attribute builder)))
(~seq (~or-bug [field:id value:expr : type]
[field:id : type value:expr])
…+
(~post-fail values-err #:when (attribute builder))))
#:defaults ([(field 1) (list)]
[(value 1) (list)]
[(type 1) (list)])
#:else-post-fail empty-err #:when (and (not (attribute builder))
(not (attribute instance)))
#:name (~a "field or [field] or [field : type] for #:builder,"
" [field value] or [field : type value]"
" or [field value : type] for #:instance"))))
(define-eh-alternative-mixin structure-kw-all
(pattern (~or (structure-kw-instance-or-builder-mixin)
@ -85,16 +70,20 @@
(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)]))
'(#:instance #: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)]))
'(#:builder #:builder))
[(k:structure-kws)
#'(k.builder k.instance-or-builder [k.field ...])]))
'(#:builder #:builder []))
(test-exn
"Check that () is rejected, as it has neither #:instance nor #:builder"
@ -110,7 +99,6 @@ builder-style field declarations"
(λ ()
(syntax-parse #'(#:instance [f1] [f2])
[(:structure-kws) #'([field ...] instance)])))
|#
(check-equal? (syntax->datum
(syntax-parse #'(#:builder #:? p [f1] [f2])
@ -123,7 +111,7 @@ builder-style field declarations"
'(#f [f1 f2]))
;; This one is appropriately rejected
#;(check-exn #px"unexpected term"
(λ ()
(syntax-parse #'(#:instance #:a)
[(:structure-kws) 'err])))
(check-exn #px"unexpected term"
(λ ()
(syntax-parse #'(#:instance #:a)
[(: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 }} }

166
structure-options2b.rkt
View File

@ -3,12 +3,13 @@
(require syntax/parse
syntax/parse/experimental/eh
generic-syntax-expanders
phc-toolkit/untyped
(for-syntax syntax/parse
racket/syntax
phc-toolkit/untyped
racket/list
generic-syntax-expanders
racket/pretty))
racket/contract))
(provide ;define-splicing-syntax-class-with-eh-mixins
;define-syntax-class-with-eh-mixins
@ -17,7 +18,11 @@
~no-order
~post-check
~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
@ -25,8 +30,24 @@
(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 (get-new-clause!)
(string->symbol (format "clause~a" ((clause-counter)))))
(define-syntax define-eh-alternative-mixin
(syntax-parser
@ -36,10 +57,7 @@
(define-temp-ids "~a/clause" (pat ...))
#'(define-eh-mixin-expander mixin
(λ (_)
(quote-syntax (~or pat ...))
#;#`(~or #,(parameterize ([current-no-order-clause #'pat/clause])
(quote-syntax pat))
...))))]))
(quote-syntax (~or pat ...)))))]))
;; ----------
@ -57,64 +75,65 @@
(λ (stx)
(syntax-case stx ()
[(self pat ...)
((λ (x) (pretty-write (syntax->datum x)) (newline) x)
(let ()
(define acc '())
(define counter 0)
(define (increment-counter)
(begin0 counter
(set! counter (add1 counter))))
(define (add-to-acc p)
(set! acc (cons p acc)))
(define alts
(parameterize ([eh-post-accumulate add-to-acc]
[clause-counter increment-counter])
(inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
#`(~delimit-cut
(~and (~seq (~or . #,alts) (... ...))
~!
#,@acc))))]))))
(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)))]))))
(define-syntax ~nop
(pattern-expander
(λ/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
(λ (stx)
(syntax-case stx ()
[(_ pat post)
(begin
(eh-post-accumulate! '~post-check #'post)
#'pat)]
(begin (eh-post-accumulate! '~post-check #'post)
#'pat)]
[(_ post)
(begin
(eh-post-accumulate! '~post-check #'post)
#'(~nop))])))
(begin (eh-post-accumulate! '~post-check #'post)
#'(~nop))])))
(define-eh-mixin-expander ~post-fail
(let ()
(define (parse stx)
(syntax-case stx ()
[(_ message #:when condition)
(begin
(define/with-syntax clause-present
(string->symbol (format "clause~a" ((clause-counter)))))
(eh-post-accumulate!
'~post-fail
#`(~fail #:when (and (attribute clause-present)
condition)
message))
#'(~bind [clause-present #t]))]
[(self #:when condition message)
(parse #'(self message #:when condition))]))
parse))
(define-for-syntax (post-fail stx)
(syntax-case stx ()
[(_ message #:when condition)
(begin
(define/with-syntax clause-present (get-new-clause!))
(eh-post-accumulate! '~post-fail
#`(~fail #:when (and (attribute clause-present)
condition)
message))
#'(~bind [clause-present #t]))]
[(self #:when condition message)
(post-fail #'(self message #:when condition))]))
(define-eh-mixin-expander ~post-fail post-fail)
(define-syntax ~mutex
(pattern-expander
@ -122,3 +141,42 @@
(syntax-case stx ()
[(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) #'()))]))