From 68947269aea7268156c4cf1f0e1e11a3bc360592 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 15 Nov 2018 17:25:01 -0800 Subject: [PATCH] back out `br` libs --- sugar/unstable/case.rkt | 16 +++--- sugar/unstable/class.rkt | 104 +++++++++++++++++++++------------------ sugar/unstable/js.rkt | 29 +++++------ sugar/unstable/stub.rkt | 42 +++++++++------- 4 files changed, 106 insertions(+), 85 deletions(-) diff --git a/sugar/unstable/case.rkt b/sugar/unstable/case.rkt index 69c8d02..404e006 100644 --- a/sugar/unstable/case.rkt +++ b/sugar/unstable/case.rkt @@ -1,9 +1,10 @@ #lang racket/base -(require (for-syntax racket/base racket/syntax br/syntax) br/define) +(require (for-syntax racket/base racket/syntax)) (provide (all-defined-out)) -(define-macro (define-case-macro ID PRED) - #'(define-macro-cases ID +(define-syntax-rule (define-case-macro ID PRED) + (define-syntax (ID stx) + (syntax-case stx () [(_ TEST-VAL [(MATCH0 . MATCH-VALS) . RESULT] (... ...) [else . ELSE-RESULT]) #'(cond [(PRED TEST-VAL '(MATCH0 . MATCH-VALS)) . RESULT] (... ...) @@ -11,7 +12,7 @@ [(_ TEST-VAL MATCH-CLAUSE (... ...)) #'(ID TEST-VAL MATCH-CLAUSE (... ...) - [else (error 'ID (format "no match for ~a" TEST-VAL))])])) + [else (error 'ID (format "no match for ~a" TEST-VAL))])]))) ;; like case but strictly uses `eq?` comparison (as opposed to `equal?`) (define-case-macro caseq memq) @@ -19,6 +20,7 @@ (require sugar/debug) -(define-macro-cases cond-report - [(_ [COND . BODY] ... [else . ELSE-BODY]) #'(cond [(report COND) (report (let () (void) . BODY))] ... [else . ELSE-BODY])] - [(_ [COND . BODY] ... ) #'(cond-report [COND . BODY] ... [else (void)])]) \ No newline at end of file +(define-syntax (cond-report stx) + (syntax-case stx () + [(_ [COND . BODY] ... [else . ELSE-BODY]) #'(cond [(report COND) (report (let () (void) . BODY))] ... [else . ELSE-BODY])] + [(_ [COND . BODY] ... ) #'(cond-report [COND . BODY] ... [else (void)])])) \ No newline at end of file diff --git a/sugar/unstable/class.rkt b/sugar/unstable/class.rkt index 2ae7195..5c802a7 100644 --- a/sugar/unstable/class.rkt +++ b/sugar/unstable/class.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require (for-syntax racket/base racket/syntax br/syntax) br/define racket/class) +(require (for-syntax racket/base racket/syntax) racket/class) (provide (all-defined-out)) (define string% @@ -17,69 +17,79 @@ (super-new) (define/public (addContent val) (make-object string% val)))) -(define-macro (as-method ID) - (with-pattern ([PRIVATE-ID (generate-temporary #'ID)]) - #'(begin - (public [PRIVATE-ID ID]) - (define (PRIVATE-ID . args) (apply ID this args))))) +(define-syntax (as-method stx) + (syntax-case stx () + [(_ ID) (with-syntax ([PRIVATE-ID (generate-temporary #'ID)]) + #'(begin + (public [PRIVATE-ID ID]) + (define (PRIVATE-ID . args) (apply ID this args))))])) -(define-macro (as-methods ID ...) - #'(begin (as-method ID) ...)) +(define-syntax-rule (as-methods ID ...) + (begin (as-method ID) ...)) -(define-macro (define-instance ID (MAKER BASE-CLASS . ARGS)) - (with-pattern ([ID-CLASS (prefix-id #'BASE-CLASS ":" #'ID)]) - #'(define ID (let ([ID-CLASS (class BASE-CLASS (super-new))]) - (MAKER ID-CLASS . ARGS))))) +(define-syntax (define-instance stx) + (syntax-case stx () + [(_ ID (MAKER BASE-CLASS . ARGS)) + (with-syntax ([ID-CLASS (format-id stx "~a:~a" (syntax->datum #'BASE-CLASS) (syntax->datum #'ID))]) + #'(define ID (let ([ID-CLASS (class BASE-CLASS (super-new))]) + (MAKER ID-CLASS . ARGS))))])) -(define-macro (define-class-predicates ID) - (with-pattern ([+ID (prefix-id "+" #'ID)] - [ID? (suffix-id #'ID "?")]) - #'(begin (define (ID? x) (is-a? x ID)) - (define (+ID . args) (apply make-object ID args))))) +(define-syntax (define-class-predicates stx) + (syntax-case stx () + [(_ ID) + (with-syntax ([+ID (format-id #'ID "+~a" (syntax->datum #'ID))] + [ID? (format-id #'ID "~a?" (syntax->datum #'ID))]) + #'(begin (define (ID? x) (is-a? x ID)) + (define (+ID . args) (apply make-object ID args))))])) -(define-macro (define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY) - #'(begin - (define ID (class* SUPERCLASS INTERFACES (init-field . INIT-ARGS) . BODY)) - (define-class-predicates ID))) +(define-syntax-rule (define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY) + (begin + (define ID (class* SUPERCLASS INTERFACES (init-field . INIT-ARGS) . BODY)) + (define-class-predicates ID))) -(define-macro (define-subclass/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY) - #'(define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) (super-new) . BODY)) +(define-syntax-rule (define-subclass/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY) + (define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) (super-new) . BODY)) -(define-macro (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY) - #'(define-subclass*/interfaces SUPERCLASS () (ID . INIT-ARGS) . BODY)) +(define-syntax-rule (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY) + (define-subclass*/interfaces SUPERCLASS () (ID . INIT-ARGS) . BODY)) -(define-macro (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY) - #'(define-subclass* SUPERCLASS (ID . INIT-ARGS) (super-new) . BODY)) +(define-syntax-rule (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY) + (define-subclass* SUPERCLASS (ID . INIT-ARGS) (super-new) . BODY)) -(define-macro (push-field! FIELD O EXPR) - #'(set-field! FIELD O (cons EXPR (get-field FIELD O)))) +(define-syntax-rule (push-field! FIELD O EXPR) + (set-field! FIELD O (cons EXPR (get-field FIELD O)))) -(define-macro (push-end-field! FIELD O EXPR) - #'(set-field! FIELD O (append (get-field FIELD O) (list EXPR)))) +(define-syntax-rule (push-end-field! FIELD O EXPR) + (set-field! FIELD O (append (get-field FIELD O) (list EXPR)))) -(define-macro (pop-field! FIELD O) - #'(let ([xs (get-field FIELD O)]) - (set-field! FIELD O (cdr xs)) - (car xs))) +(define-syntax-rule (pop-field! FIELD O) + (let ([xs (get-field FIELD O)]) + (set-field! FIELD O (cdr xs)) + (car xs))) -(define-macro-cases increment-field! - [(_ FIELD O) #'(increment-field! FIELD O 1)] - [(_ FIELD O EXPR) - #'(begin (set-field! FIELD O (+ (get-field FIELD O) EXPR)) (get-field FIELD O))]) +(define-syntax (increment-field! stx) + (syntax-case stx () + [(_ FIELD O) #'(increment-field! FIELD O 1)] + [(_ FIELD O EXPR) + #'(begin (set-field! FIELD O (+ (get-field FIELD O) EXPR)) (get-field FIELD O))])) -(define-macro (getter-field/override [ID . EXPRS]) - (syntax-property #'(getter-field [ID . EXPRS]) 'override #t)) +(define-syntax (getter-field/override stx) + (syntax-case stx () + [(_ [ID . EXPRS]) + (syntax-property #'(getter-field [ID . EXPRS]) 'override #t)])) -(define-macro (getter-field [ID . EXPRS]) - (with-pattern ([_ID (prefix-id "_" #'ID)]) - #`(begin - (field [(ID _ID) . EXPRS]) - (public (_ID ID)) - (#,(if (syntax-property caller-stx 'override) #'define/override #'define) (_ID) ID)))) \ No newline at end of file +(define-syntax (getter-field stx) + (syntax-case stx () + [(_ [ID . EXPRS]) + (with-syntax ([_ID (format-id #'ID "_~a" (syntax->datum #'ID))]) + #`(begin + (field [(ID _ID) . EXPRS]) + (public (_ID ID)) + (#,(if (syntax-property stx 'override) #'define/override #'define) (_ID) ID)))])) \ No newline at end of file diff --git a/sugar/unstable/js.rkt b/sugar/unstable/js.rkt index da388f9..8fc4406 100644 --- a/sugar/unstable/js.rkt +++ b/sugar/unstable/js.rkt @@ -1,27 +1,28 @@ #lang racket/base -(require racket/class (for-syntax racket/base racket/syntax br/syntax) br/define racket/dict) +(require racket/class (for-syntax racket/base racket/syntax) racket/dict) (provide (all-defined-out)) ;; js-style `push`, which appends to end of list -(define-macro (push-end! ID THING) - #'(set! ID (append ID (list THING)))) +(define-syntax-rule (push-end! ID THING) + (set! ID (append ID (list THING)))) -(define-macro-cases increment! - [(_ ID) #'(increment! ID 1)] - [(_ ID EXPR) - #'(begin (set! ID (+ ID EXPR)) ID)]) +(define-syntax (increment! stx) + (syntax-case stx () + [(_ ID) #'(increment! ID 1)] + [(_ ID EXPR) + #'(begin (set! ID (+ ID EXPR)) ID)])) (module+ test (define xs '(1 2 3)) (push-end! xs 4) (check-equal? xs '(1 2 3 4))) -(define-macro (+= ID THING) #'(begin (set! ID (+ ID THING)) ID)) -(define-macro (++ ID) #'(+= ID 1)) -(define-macro (-- ID) #'(+= ID -1)) -(define-macro (-= ID THING) #'(+= ID (- THING))) +(define-syntax-rule (+= ID THING) (begin (set! ID (+ ID THING)) ID)) +(define-syntax-rule (++ ID) (+= ID 1)) +(define-syntax-rule (-- ID) (+= ID -1)) +(define-syntax-rule (-= ID THING) (+= ID (- THING))) ;; fancy number->string. bounds are checked, inexact integers are coerced. @@ -57,7 +58,7 @@ [else #f])] [else (raise-argument-error '· "object or dict" x)]))) '·)) -(define-macro (· X REF ...) #'(·-helper X 'REF ...)) +(define-syntax-rule (· X REF ...) (·-helper X 'REF ...)) #;(module+ test (define c (class object% @@ -71,8 +72,8 @@ (check-equal? (· co a) 42) (check-equal? (· co b) 43)) -(define-macro (·map REF XS) - #'(for/list ([x (in-list XS)]) (· x REF))) +(define-syntax-rule (·map REF XS) + (for/list ([x (in-list XS)]) (· x REF))) (module+ test (require rackunit) diff --git a/sugar/unstable/stub.rkt b/sugar/unstable/stub.rkt index 521d2f0..0265841 100644 --- a/sugar/unstable/stub.rkt +++ b/sugar/unstable/stub.rkt @@ -1,5 +1,5 @@ #lang racket/base -(require (for-syntax racket/base br/syntax) br/define) +(require (for-syntax racket/base racket/syntax)) (provide (all-defined-out)) (begin-for-syntax @@ -7,25 +7,33 @@ (define (make-prefix caller-stx) (string-join (map ~a (list (syntax-source caller-stx) (syntax-line caller-stx))) ":" #:after-last ":"))) -(define-macro (define-stub-stop ID) - (with-pattern ([ERROR-ID (suffix-id (prefix-id (make-prefix caller-stx) #'ID) ":not-implemented")]) - #'(define (ID . args) - (error 'ERROR-ID)))) +(define-syntax (define-stub-stop stx) + (syntax-case stx () + [(_ ID) + (with-syntax ([ERROR-ID (format-id stx "~a~a:not-implemented" (make-prefix stx) (syntax->datum #'ID))]) + #'(define (ID . args) + (error 'ERROR-ID)))])) (provide (rename-out [define-stub-stop define-stub])) -(define-macro (define-stub-go ID) - (with-pattern ([ERROR-ID (suffix-id (prefix-id (make-prefix caller-stx) #'ID) ":not-implemented")]) - #'(define (ID . args) - (displayln 'ERROR-ID)))) +(define-syntax (define-stub-go stx) + (syntax-case stx () + [(_ ID) + (with-syntax ([ERROR-ID (format-id stx "~a~a:not-implemented" (make-prefix stx) (syntax->datum #'ID))]) + #'(define (ID . args) + (displayln 'ERROR-ID)))])) -(define-macro (define-unfinished (ID . ARGS) . BODY) - (with-pattern ([ID-UNFINISHED (suffix-id (prefix-id (make-prefix caller-stx) #'ID) ":unfinished")]) - #'(define (ID . ARGS) - (begin . BODY) - (error 'ID-UNFINISHED)))) +(define-syntax (define-unfinished stx) + (syntax-case stx () + [(_ (ID . ARGS) . BODY) + (with-syntax ([ID-UNFINISHED (format-id stx "~a~a:unfinished" (make-prefix stx) (syntax->datum #'ID))]) + #'(define (ID . ARGS) + (begin . BODY) + (error 'ID-UNFINISHED)))])) -(define-macro (unfinished) - (with-pattern ([ID-UNFINISHED (prefix-id (syntax-source caller-stx) ":" (syntax-line caller-stx) ":" #'unfinished)]) - #'(error 'ID-UNFINISHED))) \ No newline at end of file +(define-syntax (unfinished stx) + (syntax-case stx () + [(_) + (with-syntax ([ID-UNFINISHED (format-id stx "~a:~a:~a" (syntax-source stx) (syntax-line stx) (syntax->datum #'unfinished))]) + #'(error 'ID-UNFINISHED))])) \ No newline at end of file