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

Works, but needs cleanup for the ~optional.

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-25 22:30:58 +02:00
parent 777f9712f4
commit 95f455a89d
2 changed files with 90 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
structure-options2.rkt
View File

@ -27,15 +27,53 @@
(pattern (~optional (~seq #:? predicate:id)
#:name "#:? predicate")))
(define-and-for-syntax instance-no-values-error
(define-and-for-syntax no-values-err
(~a "The #:instance keyword implies the use of [field value],"
" [field : type value] or [field value : type]."))
(define-and-for-syntax values-err
(~a "The #:builder keyword implies the use of [field], field"
" or [field : type]."))
(define-and-for-syntax empty-err
(~a "If no fields are specified, then either #:builder or #:instance"
" must be present"))
(define-eh-alternative-mixin structure-kw-fields
(pattern (~once (~seq [field:id] ...
(~post-fail instance-no-values-error
#:when (and (attribute instance)
(not (stx-null? #'(field ...))))))
#:name "[field]")))
(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"))))
(define-eh-alternative-mixin structure-kw-all
(pattern (~or (structure-kw-instance-or-builder-mixin)
@ -45,28 +83,9 @@
;; ---------
(define-splicing-syntax-class structure-kws
(pattern #;(~no-order (structure-kw-all-mixin))
(~delimit-cut
(~and
(~seq
(~or
(~optional
(~and
instance-or-builder
(~or (~and instance #:instance) (~and builder #:builder)))
#:name
"either #:instance or #:builder")
(~optional (~seq #:? predicate:id) #:name "#:? predicate")
(~optional (~seq (field:id) ...+ (~bind [clause178673 #t]))
#:name "[field]"))
...)
~!
(~fail
#:when
(and (attribute clause178673)
(and (attribute instance)))
instance-no-values-error)))))
(pattern (~no-order (structure-kw-all-mixin))))
#|
(check-equal? (syntax->datum
(syntax-parse #'(#:instance #:? p)
[(:structure-kws) #'(instance instance-or-builder predicate)]))
@ -77,24 +96,34 @@
[(k:structure-kws) #'(k.builder k.instance-or-builder)]))
'(#:builder #:builder))
(check-equal? (syntax->datum
(syntax-parse #'()
[(:structure-kws) #'()]))
'())
(test-exn
"Check that () is rejected, as it has neither #:instance nor #:builder"
(regexp (regexp-quote empty-err))
(λ ()
(syntax-parse #'()
[(:structure-kws) #'()])))
;; This one is appropriately rejected :)
(check-exn (regexp (regexp-quote instance-no-values-error))
(λ ()
(syntax-parse #'(#:instance [f1] [f2])
[(:structure-kws) #'([field ...] instance)])))
(test-exn
"Check that (#:instance [f1] [f2]) is rejected, as #:instance conflicts with
builder-style field declarations"
(regexp (regexp-quote no-values-err))
(λ ()
(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 #'([f1] [f2]); #:? p
[(:structure-kws) (cons (attribute builder)
(syntax->datum #'([field ...])))])
'(#f [f1 f2]))
;; This one is appropriately rejected
(check-exn #px"unexpected term"
(λ ()
(syntax-parse #'(#:a)
[(:structure-kws) 'err])))
#;(check-exn #px"unexpected term"
(λ ()
(syntax-parse #'(#:instance #:a)
[(:structure-kws) 'err])))

57
structure-options2b.rkt
View File

@ -16,7 +16,8 @@
(expander-out eh-mixin)
~no-order
~post-check
~post-fail)
~post-fail
~nop)
;; ------------
;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
@ -25,7 +26,7 @@
(define-expander-type eh-mixin)
(define-for-syntax eh-post-accumulate (make-parameter #f))
#;(define-for-syntax current-no-order-clause (make-parameter #f))
(define-for-syntax clause-counter (make-parameter #f))
(define-syntax define-eh-alternative-mixin
(syntax-parser
@ -49,28 +50,8 @@
(apply append (stx-map inline-or #'rest))]
[x (list #'x)]))
#;(define-for-syntax (expand-no-order-clauses/tree x)
(cond
[(syntax? x) (datum->syntax x
(expand-no-order-clauses/tree (syntax-e x))
x
x)]))
#;(define-for-syntax (expand-no-order-clauses stx)
(syntax-case stx (~or)
[(~or pat ...) (append-map expand-no-order-clauses
(syntax->list #'(pat ...)))]
[(exp . args)
(let ([slv (syntax-local-value #'exp (λ _ #f))])
(and slv (expander? slv) (eh-mixin-expander? slv)))
(let* ([slv (syntax-local-value #'exp (λ _ #f))]
[transformer (expander-transformer slv)])
(expand-no-order-clauses (transformer stx)))]
[pat (parameterize ([current-no-order-clause #`#,(gensym 'clause)])
(list (expand-all-eh-mixin-expanders #'pat)))]))
;; TODO: ~no-order should also be a eh-mixin-expander, so that nested ~post-fail
;; are caught
;; TODO: ~no-order should also be a eh-mixin-expander, so that when there are
;; nested ~no-order, the ~post-fail is caught by the nearest ~no-order.
(define-syntax ~no-order
(pattern-expander
(λ (stx)
@ -79,17 +60,25 @@
((λ (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 #;(replace-context #'self p) acc)))
(set! acc (cons p acc)))
(define alts
(parameterize ([eh-post-accumulate add-to-acc])
#;(expand-no-order-clauses #'(~or pat ...))
(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))))]))))
(define-syntax ~nop
(pattern-expander
(λ/syntax-case (_) () #'(~do))))
(define-for-syntax (eh-post-accumulate! name p)
(unless (eh-post-accumulate)
(raise-syntax-error
@ -107,7 +96,7 @@
[(_ post)
(begin
(eh-post-accumulate! '~post-check #'post)
#'(~do))])))
#'(~nop))])))
(define-eh-mixin-expander ~post-fail
(let ()
@ -115,18 +104,14 @@
(syntax-case stx ()
[(_ message #:when condition)
(begin
#;(unless (current-no-order-clause)
(raise-syntax-error
'~post-fail
"~post-fail cannot be used directly as an ellipsis-head pattern"))
(define/with-syntax clause-present (gensym 'clause))
(define/with-syntax clause-present
(string->symbol (format "clause~a" ((clause-counter)))))
(eh-post-accumulate!
'~post-fail
#`(~fail #:when (and (attribute (~bind [clause-present #t])
#;#,(current-no-order-clause))
#`(~fail #:when (and (attribute clause-present)
condition)
message))
#'(~do))]
#'(~bind [clause-present #t]))]
[(self #:when condition message)
(parse #'(self message #:when condition))]))
parse))