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

Split code into separate files

Browse Source
This commit is contained in:
Georges Dupéron 2016-08-29 12:11:15 +02:00
parent 68a7178b7e
commit f5078752aa
7 changed files with 286 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

244
main.rkt
View File

@ -1,224 +1,26 @@
#lang racket
#lang racket/base
(require syntax/parse
syntax/parse/experimental/eh
generic-syntax-expanders
phc-toolkit/untyped
(for-syntax syntax/parse
syntax/parse/experimental/template
racket/syntax
phc-toolkit/untyped
racket/list
generic-syntax-expanders
racket/function
racket/pretty))
(require generic-syntax-expanders
"private/parameters.rkt"
"private/no-order.rkt"
"private/post.rkt"
"private/global.rkt"
"private/optional.rkt")
(provide ;define-splicing-syntax-class-with-eh-mixins
;define-syntax-class-with-eh-mixins
define-eh-alternative-mixin
(expander-out eh-mixin)
~seq-no-order
~post-check
~post-fail
~nop
~optional/else
~global-or
~global-and
~global-counter
aggregate-global-or
aggregate-global-and
aggregate-global-counter)
(provide #;define-splicing-syntax-class-with-eh-mixins
#;define-syntax-class-with-eh-mixins
define-eh-alternative-mixin
(expander-out eh-mixin)
~seq-no-order
~no-order
~post-check
~post-fail
~nop
~optional/else
~global-or
~global-and
~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
;; generic-syntax-expander is merged.
(define-expander-type eh-mixin)
(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 ~seq-no-order")))
(apply (parameter-name) args))))
(define-dynamic-accumulator-parameter eh-post-accumulate eh-post-accumulate!)
(define-dynamic-accumulator-parameter eh-post-group eh-post-group!)
;; ----
(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
[(_ name ((~literal pattern) pat) ...)
(let ()
(define-temp-ids "~a/clause" (pat ...))
#'(define-eh-mixin-expander name
(λ (_)
(quote-syntax (~or pat ...)))))]))
;; ----------
(define-for-syntax (inline-or stx)
(syntax-case stx ()
[(o . rest)
(and (identifier? #'o) (free-identifier=? #'o #'~or))
(apply append (stx-map inline-or #'rest))]
[x (list #'x)]))
;; TODO: ~seq-no-order should also be a eh-mixin-expander, so that when there
;; are nested ~seq-no-order, the ~post-fail is caught by the nearest
;; ~seq-no-order.
(define-syntax ~seq-no-order
(pattern-expander
(λ (stx)
(syntax-case stx ()
[(self pat ...)
((λ (x) #;(pretty-write (syntax->datum x)) x)
(let ()
(define counter 0)
(define (increment-counter)
(begin0 counter
(set! counter (add1 counter))))
;; post-acc gathers some a-patterns which will be added after the
;; (~seq (~or ) ...)
(define post-acc '())
(define (add-to-post! v) (set! post-acc (cons v post-acc)))
;; post-groups-acc gathers some attributes that have to be grouped
(define post-groups-acc '())
(define (add-to-post-groups! . v)
(set! post-groups-acc (cons v post-groups-acc)))
;; expand EH alternatives:
(define alts
(parameterize ([eh-post-accumulate add-to-post!]
[eh-post-group add-to-post-groups!]
[clause-counter increment-counter])
(inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
(define post-group-bindings
(for/list ([group (group-by car
post-groups-acc
free-identifier=?)])
;; each item in `group` is a four-element list:
;; (list result-id aggregate-function attribute)
(define/with-syntax name (first (car group))
#;(syntax-local-introduce
(datum->syntax #'here
(first (car group)))))
(define/with-syntax f (second (car group)))
#`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
group))]))
#`(~delimit-cut
(~and (~seq (~or . #,alts) (... ...))
~!
(~bind #,@post-group-bindings)
#,@post-acc))))]))))
(define-syntax ~no-order
(pattern-expander
(λ/syntax-case (_ . rest) ()
#'({~seq-no-order . rest}))))
(define-syntax ~nop
(pattern-expander
(λ/syntax-case (_) () #'(~do))))
(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)
#'(~nop))])))
(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
(λ (stx)
(syntax-case stx ()
[(self (mutex:id ...) pat ...)
#'(???)]))))
(define-syntax/parse (define-~global global-name (~optional default) f)
(define use-default-v? (syntax-e #'default-v?))
(template
(define-eh-mixin-expander global-name
(syntax-parser
[(_ (?? (~or [name v] (~and name (~bind [v default])))
[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 (aggregate-global-or . bs)
(ormap unbox ;; remove the layer of protection
(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
(cons (box-immutable 'none) ;; default value when no bindings matched
(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
(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) #'()))]))

11
private/global-mutex.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket/base
(require syntax/parse
(for-syntax racket/base))
(define-syntax ~mutex
(pattern-expander
(λ (stx)
(syntax-case stx ()
[(self (mutex:id ...) pat ...)
#'(NotImplementedYet...)]))))

57
private/global.rkt Normal file
View File

@ -0,0 +1,57 @@
#lang racket/base
(require racket/function
racket/list
syntax/parse
phc-toolkit/untyped
(for-syntax racket/base
syntax/parse
syntax/parse/experimental/template
racket/syntax
phc-toolkit/untyped)
"parameters.rkt"
"no-order.rkt")
(provide ~global-or
~global-and
~global-counter
aggregate-global-or
aggregate-global-and
aggregate-global-counter)
(define-syntax/parse (define-~global global-name (~optional default) f)
(define use-default-v? (syntax-e #'default-v?))
(template
(define-eh-mixin-expander global-name
(syntax-parser
[(_ (?? (~or [name v] (~and name (~bind [v default])))
[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 (aggregate-global-or . bs)
(ormap unbox ;; remove the layer of protection
(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
(cons (box-immutable 'none) ;; default value when no bindings matched
(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)

88
private/no-order.rkt Normal file
View File

@ -0,0 +1,88 @@
#lang racket/base
(require syntax/parse
;syntax/parse/experimental/eh
generic-syntax-expanders
phc-toolkit/untyped
(for-syntax racket/base
syntax/parse
racket/syntax
phc-toolkit/untyped
racket/list
racket/pretty)
"parameters.rkt")
(provide define-eh-alternative-mixin
~seq-no-order
~no-order
(expander-out eh-mixin))
(define-expander-type eh-mixin)
(define-syntax define-eh-alternative-mixin
(syntax-parser
[(_ name ((~literal pattern) pat) ...)
(let ()
(define-temp-ids "~a/clause" (pat ...))
#'(define-eh-mixin-expander name
(λ (_)
(quote-syntax (~or pat ...)))))]))
(define-for-syntax (inline-or stx)
(syntax-case stx ()
[(o . rest)
(and (identifier? #'o) (free-identifier=? #'o #'~or))
(apply append (stx-map inline-or #'rest))]
[x (list #'x)]))
;; TODO: ~seq-no-order should also be a eh-mixin-expander, so that when there
;; are nested ~seq-no-order, the ~post-fail is caught by the nearest
;; ~seq-no-order.
(define-syntax ~seq-no-order
(pattern-expander
(λ (stx)
(syntax-case stx ()
[(self pat ...)
((λ (x) #;(pretty-write (syntax->datum x)) x)
(let ()
(define counter 0)
(define (increment-counter)
(begin0 counter
(set! counter (add1 counter))))
;; post-acc gathers some a-patterns which will be added after the
;; (~seq (~or ) ...)
(define post-acc '())
(define (add-to-post! v) (set! post-acc (cons v post-acc)))
;; post-groups-acc gathers some attributes that have to be grouped
(define post-groups-acc '())
(define (add-to-post-groups! . v)
(set! post-groups-acc (cons v post-groups-acc)))
;; expand EH alternatives:
(define alts
(parameterize ([eh-post-accumulate add-to-post!]
[eh-post-group add-to-post-groups!]
[clause-counter increment-counter])
(inline-or (expand-all-eh-mixin-expanders #'(~or pat ...)))))
(define post-group-bindings
(for/list ([group (group-by car
post-groups-acc
free-identifier=?)])
;; each item in `group` is a four-element list:
;; (list result-id aggregate-function attribute)
(define/with-syntax name (first (car group))
#;(syntax-local-introduce
(datum->syntax #'here
(first (car group)))))
(define/with-syntax f (second (car group)))
#`[name (f . #,(map (λ (i) #`(attribute #,(third i)))
group))]))
#`(~delimit-cut
(~and (~seq (~or . #,alts) (... ...))
~!
(~bind #,@post-group-bindings)
#,@post-acc))))]))))
(define-syntax ~no-order
(pattern-expander
(λ/syntax-case (_ . rest) ()
#'({~seq-no-order . rest}))))

38
private/optional.rkt Normal file
View File

@ -0,0 +1,38 @@
#lang racket/base
(require syntax/parse
phc-toolkit/untyped
(for-syntax racket/base
syntax/parse
phc-toolkit/untyped)
"parameters.rkt"
"no-order.rkt")
(provide ~optional/else)
(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) #'()))]))

27
private/parameters.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang racket/base
(require (for-syntax racket/base))
(provide (for-syntax eh-post-accumulate
eh-post-accumulate!
eh-post-group
eh-post-group!
clause-counter
get-new-clause!))
(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 ~seq-no-order")))
(apply (parameter-name) args))))
(define-dynamic-accumulator-parameter eh-post-accumulate eh-post-accumulate!)
(define-dynamic-accumulator-parameter eh-post-group eh-post-group!)
(define-for-syntax clause-counter (make-parameter #f))
(define-for-syntax (get-new-clause!)
(string->symbol (format "clause~a" ((clause-counter)))))

42
private/post.rkt Normal file
View File

@ -0,0 +1,42 @@
#lang racket/base
(require syntax/parse
(for-syntax racket/base
syntax/parse
racket/syntax
phc-toolkit/untyped)
"parameters.rkt"
"no-order.rkt")
(provide ~nop
~post-check
~post-fail)
(define-syntax ~nop
(pattern-expander
(λ/syntax-case (_) () #'(~do))))
(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)
#'(~nop))])))
(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)