From f5078752aa084c26e3e2ad35893a1a0f481a6d30 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 29 Aug 2016 12:11:15 +0200 Subject: [PATCH] Split code into separate files --- main.rkt | 244 ++++----------------------------------- private/global-mutex.rkt | 11 ++ private/global.rkt | 57 +++++++++ private/no-order.rkt | 88 ++++++++++++++ private/optional.rkt | 38 ++++++ private/parameters.rkt | 27 +++++ private/post.rkt | 42 +++++++ 7 files changed, 286 insertions(+), 221 deletions(-) create mode 100644 private/global-mutex.rkt create mode 100644 private/global.rkt create mode 100644 private/no-order.rkt create mode 100644 private/optional.rkt create mode 100644 private/parameters.rkt create mode 100644 private/post.rkt diff --git a/main.rkt b/main.rkt index aa4be57..402f5c2 100644 --- a/main.rkt +++ b/main.rkt @@ -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) #'()))])) \ No newline at end of file diff --git a/private/global-mutex.rkt b/private/global-mutex.rkt new file mode 100644 index 0000000..a011a0a --- /dev/null +++ b/private/global-mutex.rkt @@ -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...)])))) \ No newline at end of file diff --git a/private/global.rkt b/private/global.rkt new file mode 100644 index 0000000..5562e8b --- /dev/null +++ b/private/global.rkt @@ -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) + diff --git a/private/no-order.rkt b/private/no-order.rkt new file mode 100644 index 0000000..b3a6b17 --- /dev/null +++ b/private/no-order.rkt @@ -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})))) \ No newline at end of file diff --git a/private/optional.rkt b/private/optional.rkt new file mode 100644 index 0000000..14e8f9b --- /dev/null +++ b/private/optional.rkt @@ -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) #'()))])) \ No newline at end of file diff --git a/private/parameters.rkt b/private/parameters.rkt new file mode 100644 index 0000000..947053c --- /dev/null +++ b/private/parameters.rkt @@ -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))))) \ No newline at end of file diff --git a/private/post.rkt b/private/post.rkt new file mode 100644 index 0000000..3d8a31a --- /dev/null +++ b/private/post.rkt @@ -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) \ No newline at end of file