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

WIP on ~no-order. Before cleaning up implementation of ~post-fail.

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-25 17:10:43 +02:00
parent a8e46bb5f4
commit 777f9712f4
2 changed files with 172 additions and 113 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
structure-options2.rkt
View File

@ -1,7 +1,21 @@
#lang racket
(require 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))
(require "structure-options2b.rkt")
(provide structure-kw-instance-or-builder-mixin
structure-kw-predicate-mixin
structure-kw-fields-mixin
structure-kw-all-mixin)
(define-eh-alternative-mixin structure-kw-instance-or-builder
(pattern (~optional (~and instance-or-builder
@ -13,73 +27,74 @@
(pattern (~optional (~seq #:? predicate:id)
#:name "#:? predicate")))
(define-and-for-syntax instance-no-values-error
(~a "The #:instance keyword implies the use of [field value],"
" [field : type value] or [field value : type]."))
(define-eh-alternative-mixin structure-kw-fields
(pattern (~once (~seq [field:id] ...)
#:name "[field]"))
#:post (~fail #:when (and (attribute instance)
(not (stx-null? #'(field ...))))))
(pattern (~once (~seq [field:id] ...
(~post-fail instance-no-values-error
#:when (and (attribute instance)
(not (stx-null? #'(field ...))))))
#:name "[field]")))
(define-eh-alternative-mixin structure-kw-all
(pattern (~or (structure-kw-instance-or-builder-mixin)
(structure-kw-predicate-mixin)
(structure-kw-fields-mixin))))
;; ---------
#;(define-splicing-syntax-class-with-eh-mixins structure-kws
(pattern (~no-order (structure-kw-all-mixin) ...)))
(define-splicing-syntax-class structure-kws
#;(pattern (~no-order (structure-kw-all-mixin)))
(pattern (~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")
(~once (~seq (field:id) ...) #:name "[field]"))
...)
(~fail #:when (and (attribute instance) (not (stx-null? #'(field ...))))))))
(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)))))
#;(define-splicing-syntax-class
structure-kws
(pattern
(~and
(~seq
(~or
(~or
(~or
(~optional
(~and
instance-or-builder
(~or (~and instance #:instance) (~and builder #:builder)))
#:name
"either #:instance or #:builder"))
(~or (~optional (~seq #:? predicate:id)
#:name "#:? predicate"))
(~or (~once (~and (~seq (field:id) ...))
#:name "[field] …"))))
...)
(~fail #:when (and (attribute instance)
(not (stx-null? #'(field ...))))))))
(check-equal? (syntax->datum
(syntax-parse #'(#:instance #:? p)
[(:structure-kws) #'(instance instance-or-builder predicate)]))
'(#:instance #:instance p))
#;(begin
(syntax-parse #'(#:instance #:? p)
[(:structure-kws) #'(instance instance-or-builder predicate)])
(check-equal? (syntax->datum
(syntax-parse #'(#:builder)
[(k:structure-kws) #'(k.builder k.instance-or-builder)]))
'(#:builder #:builder))
(syntax-parse #'(#:builder)
[(k:structure-kws) #'(k.builder k.instance-or-builder)])
(check-equal? (syntax->datum
(syntax-parse #'()
[(:structure-kws) #'()]))
'())
(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)])))
(syntax-parse #'(#:instance #:? p [f1] [f2])
[(:structure-kws) #'([field ...] instance)])
(check-equal? (syntax->datum
(syntax-parse #'(#:builder #:? p [f1] [f2])
[(:structure-kws) #'([field ...] builder)]))
'([f1 f2] #:builder))
(syntax-parse #'(#:builder [f1] [f2])
[(:structure-kws) #'([field ...] builder)]))
#;(syntax-parse #'(#:a)
[(:structure-kws) 'err])
;; This one is appropriately rejected
(check-exn #px"unexpected term"
(λ ()
(syntax-parse #'(#:a)
[(:structure-kws) 'err])))

160
structure-options2b.rkt
View File

@ -3,67 +3,44 @@
(require syntax/parse
syntax/parse/experimental/eh
generic-syntax-expanders
syntax/stx
(for-syntax syntax/parse
racket/syntax
syntax/stx
racket/pretty)) ;; debug
phc-toolkit/untyped
racket/list
generic-syntax-expanders
racket/pretty))
(provide ;define-splicing-syntax-class-with-eh-mixins
;define-syntax-class-with-eh-mixins
define-eh-alternative-mixin
(expander-out eh-mixin)
~no-order
~post-check
~post-fail)
;; ------------
;; eh-mixin — TODO: move to phc-toolkit once the PR #7 for reqprov in
;; generic-syntax-expander is merged. Look for "End eh-mixin" below for the end.
;; generic-syntax-expander is merged.
(define-expander-type eh-mixin)
(begin-for-syntax
(define eh-post-accumulate (make-parameter #f)))
(define-for-syntax eh-post-accumulate (make-parameter #f))
#;(define-for-syntax current-no-order-clause (make-parameter #f))
(define-syntax define-eh-alternative-mixin
(syntax-parser
[(_ name ((~literal pattern) pat) ... (~optional (~seq #:post post)))
[(_ name ((~literal pattern) pat) ...)
(let ()
(define/with-syntax mixin (format-id #'name "~a-mixin" #'name))
;(display "post:") (displayln (attribute post))
#`(begin
(define-eh-mixin-expander mixin
(λ (_)
#,@(if (attribute post)
#'((unless (eh-post-accumulate)
(raise-syntax-error
'define-eh-alternative-mixin
"#:post used outside of ~no-order"))
((eh-post-accumulate) (quote-syntax post)))
#'())
(quote-syntax (~or pat ...))))
#;(define-eh-alternative-set name
#,@(stx-map (λ (p)
#`(pattern #,(expand-all-eh-mixin-expanders p)))
#'(pat ...)))))]))
(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))
...))))]))
(define-for-syntax (define-?-syntax-class-with-eh-mixins original-form)
(syntax-parser
[(_ signature {~and opts {~not ({~literal pattern} . _)}} ...
({~literal pattern} pat . pat-opts) ...)
;((λ (x) (pretty-write (syntax->datum x)) x)
#`(#,original-form
signature opts ...
#,@(stx-map (λ (p po)
#`(pattern #,(expand-all-eh-mixin-expanders p) . #,po))
#'(pat ...)
#'(pat-opts ...)))]))
(define-syntax define-splicing-syntax-class-with-eh-mixins
(define-?-syntax-class-with-eh-mixins #'define-splicing-syntax-class))
(define-syntax define-syntax-class-with-eh-mixins
(define-?-syntax-class-with-eh-mixins #'define-syntax-class))
(provide define-splicing-syntax-class-with-eh-mixins
define-syntax-class-with-eh-mixins
define-eh-alternative-mixin
(expander-out eh-mixin))
;; ----------
(define-for-syntax (inline-or stx)
(syntax-case stx ()
@ -72,24 +49,91 @@
(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
(define-syntax ~no-order
(pattern-expander
(λ (stx)
(syntax-case stx ()
[(_ pat ...)
((λ (x) (pretty-write (syntax->datum x)) x)
[(self pat ...)
((λ (x) (pretty-write (syntax->datum x)) (newline) x)
(let ()
(define acc '())
(define (add-to-acc p)
(displayln p)
(newline)
(set! acc (cons p acc)))
(set! acc (cons p #;(replace-context #'self p) acc)))
(define alts
(parameterize ([eh-post-accumulate add-to-acc])
(expand-all-eh-mixin-expanders
#'(~or pat ...))))
#`(~and (~seq (~or . #,(inline-or alts)) (... ...))
#,@acc)))]))))
#;(expand-no-order-clauses #'(~or pat ...))
(inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
#`(~delimit-cut
(~and (~seq (~or . #,alts) (... ...))
~!
#,@acc))))]))))
;; End eh-mixin
;; ------------
(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)]
[(_ post)
(begin
(eh-post-accumulate! '~post-check #'post)
#'(~do))])))
(define-eh-mixin-expander ~post-fail
(let ()
(define (parse stx)
(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))
(eh-post-accumulate!
'~post-fail
#`(~fail #:when (and (attribute (~bind [clause-present #t])
#;#,(current-no-order-clause))
condition)
message))
#'(~do))]
[(self #:when condition message)
(parse #'(self message #:when condition))]))
parse))
(define-syntax ~mutex
(pattern-expander
(λ (stx)
(syntax-case stx ()
[(self (mutex:id ...) pat ...)
#'(???)]))))