commit a8e46bb5f454c90cc7046e2e6ffffb026e3dcc09
parent da6dd362b540deaae5a5029df3cfe6cee2b5097d
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Tue, 23 Aug 2016 23:55:21 +0200
WIP on extensible structure options.
Diffstat:
4 files changed, 322 insertions(+), 0 deletions(-)
diff --git a/structure-options.rkt b/structure-options.rkt
@@ -0,0 +1,135 @@
+#lang racket
+
+(require syntax/parse
+ syntax/parse/experimental/eh
+ generic-syntax-expanders
+ syntax/stx
+ (for-syntax syntax/parse
+ racket/syntax
+ syntax/stx
+ racket/pretty)) ;; debug
+
+;; ------------
+;; 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.
+
+(define-expander-type eh-mixin)
+
+(begin-for-syntax
+ (define eh-post-accumulate (make-parameter #f)))
+
+(define-syntax define-eh-alternative-mixin
+ (syntax-parser
+ [(_ name ((~literal pattern) pat) ... (~optional (~seq #:post post)))
+ (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-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))
+
+;; End eh-mixin
+;; ------------
+
+(define-eh-alternative-mixin structure-kw-instance-or-builder
+ (pattern (~optional (~and instance-or-builder
+ (~or (~and instance #:instance)
+ (~and builder #:builder)))
+ #:name "either #:instance or #:builder")))
+
+(define-eh-alternative-mixin structure-kw-predicate
+ (pattern (~optional (~seq #:? predicate:id)
+ #:name "#:? predicate")))
+
+(define-eh-alternative-mixin structure-kw-fields
+ (pattern (~once (~seq [field:id] ...)
+ #:name "[field]"))
+ #:post (~fail #:when (and (attribute instance)
+ (not (stx-null? #'(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 (~seq (structure-kw-all-mixin) ...)))
+
+#;(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 ...))))))))
+
+#;(begin
+ (syntax-parse #'(#:instance #:? p)
+ [(:structure-kws) #'(instance instance-or-builder predicate)])
+
+ (syntax-parse #'(#:builder)
+ [(k:structure-kws) #'(k.builder k.instance-or-builder)])
+
+ (syntax-parse #'()
+ [(:structure-kws) #'()])
+
+ (syntax-parse #'(#:instance #:? p [f1] [f2])
+ [(:structure-kws) #'([field ...] instance)])
+
+ (syntax-parse #'(#:builder [f1] [f2])
+ [(:structure-kws) #'([field ...] builder)]))
+
+#;(syntax-parse #'(#:a)
+ [(:structure-kws) 'err])
+\ No newline at end of file
diff --git a/structure-options2.rkt b/structure-options2.rkt
@@ -0,0 +1,85 @@
+#lang racket
+
+(require "structure-options2b.rkt")
+
+
+(define-eh-alternative-mixin structure-kw-instance-or-builder
+ (pattern (~optional (~and instance-or-builder
+ (~or (~and instance #:instance)
+ (~and builder #:builder)))
+ #:name "either #:instance or #:builder")))
+
+(define-eh-alternative-mixin structure-kw-predicate
+ (pattern (~optional (~seq #:? predicate:id)
+ #:name "#:? predicate")))
+
+(define-eh-alternative-mixin structure-kw-fields
+ (pattern (~once (~seq [field:id] ...)
+ #:name "[field]"))
+ #:post (~fail #:when (and (attribute instance)
+ (not (stx-null? #'(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 ...))))))))
+
+#;(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 ...))))))))
+
+#;(begin
+ (syntax-parse #'(#:instance #:? p)
+ [(:structure-kws) #'(instance instance-or-builder predicate)])
+
+ (syntax-parse #'(#:builder)
+ [(k:structure-kws) #'(k.builder k.instance-or-builder)])
+
+ (syntax-parse #'()
+ [(:structure-kws) #'()])
+
+ (syntax-parse #'(#:instance #:? p [f1] [f2])
+ [(:structure-kws) #'([field ...] instance)])
+
+ (syntax-parse #'(#:builder [f1] [f2])
+ [(:structure-kws) #'([field ...] builder)]))
+
+#;(syntax-parse #'(#:a)
+ [(:structure-kws) 'err])
+\ No newline at end of file
diff --git a/structure-options2b.rkt b/structure-options2b.rkt
@@ -0,0 +1,95 @@
+#lang racket
+
+(require syntax/parse
+ syntax/parse/experimental/eh
+ generic-syntax-expanders
+ syntax/stx
+ (for-syntax syntax/parse
+ racket/syntax
+ syntax/stx
+ racket/pretty)) ;; debug
+
+;; ------------
+;; 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.
+
+(define-expander-type eh-mixin)
+
+(begin-for-syntax
+ (define eh-post-accumulate (make-parameter #f)))
+
+(define-syntax define-eh-alternative-mixin
+ (syntax-parser
+ [(_ name ((~literal pattern) pat) ... (~optional (~seq #:post post)))
+ (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-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 ()
+ [(o . rest)
+ (and (identifier? #'o) (free-identifier=? #'o #'~or))
+ (apply append (stx-map inline-or #'rest))]
+ [x (list #'x)]))
+
+(define-syntax ~no-order
+ (pattern-expander
+ (λ (stx)
+ (syntax-case stx ()
+ [(_ pat ...)
+ ((λ (x) (pretty-write (syntax->datum x)) x)
+ (let ()
+ (define acc '())
+ (define (add-to-acc p)
+ (displayln p)
+ (newline)
+ (set! acc (cons 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)))]))))
+
+;; End eh-mixin
+;; ------------
+\ No newline at end of file
diff --git a/test-reqprov-exp.rkt b/test-reqprov-exp.rkt
@@ -0,0 +1,4 @@
+#lang racket
+
+(require generic-syntax-expanders
+ (expander-in "structure-options.rkt" eh-mixin))
