mbutterick
/
sugar
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

back out `br` libs

Browse Source
dev-refac-2020
Matthew Butterick 6 years ago
parent 53deef1871
commit 68947269ae
4 changed files with 106 additions and 85 deletions
Show Stats Download Patch File Download Diff File

14
sugar/unstable/case.rkt
Unescape Escape View File

@ -1,9 +1,10 @@
#lang racket/base #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)) (provide (all-defined-out))
(define-macro (define-case-macro ID PRED) (define-syntax-rule (define-case-macro ID PRED)
#'(define-macro-cases ID (define-syntax (ID stx)
(syntax-case stx ()
[(_ TEST-VAL [(MATCH0 . MATCH-VALS) . RESULT] (... ...) [else . ELSE-RESULT]) [(_ TEST-VAL [(MATCH0 . MATCH-VALS) . RESULT] (... ...) [else . ELSE-RESULT])
#'(cond #'(cond
[(PRED TEST-VAL '(MATCH0 . MATCH-VALS)) . RESULT] (... ...) [(PRED TEST-VAL '(MATCH0 . MATCH-VALS)) . RESULT] (... ...)
@ -11,7 +12,7 @@
[(_ TEST-VAL MATCH-CLAUSE (... ...)) [(_ TEST-VAL MATCH-CLAUSE (... ...))
#'(ID TEST-VAL #'(ID TEST-VAL
MATCH-CLAUSE (... ...) 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?`) ;; like case but strictly uses `eq?` comparison (as opposed to `equal?`)
(define-case-macro caseq memq) (define-case-macro caseq memq)
@ -19,6 +20,7 @@
(require sugar/debug) (require sugar/debug)
(define-macro-cases cond-report (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] ... [else . ELSE-BODY]) #'(cond [(report COND) (report (let () (void) . BODY))] ... [else . ELSE-BODY])]
[(_ [COND . BODY] ... ) #'(cond-report [COND . BODY] ... [else (void)])]) [(_ [COND . BODY] ... ) #'(cond-report [COND . BODY] ... [else (void)])]))

78
sugar/unstable/class.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base #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)) (provide (all-defined-out))
(define string% (define string%
@ -17,69 +17,79 @@
(super-new) (super-new)
(define/public (addContent val) (make-object string% val)))) (define/public (addContent val) (make-object string% val))))
(define-macro (as-method ID) (define-syntax (as-method stx)
(with-pattern ([PRIVATE-ID (generate-temporary #'ID)]) (syntax-case stx ()
[(_ ID) (with-syntax ([PRIVATE-ID (generate-temporary #'ID)])
#'(begin #'(begin
(public [PRIVATE-ID ID]) (public [PRIVATE-ID ID])
(define (PRIVATE-ID . args) (apply ID this args))))) (define (PRIVATE-ID . args) (apply ID this args))))]))
(define-macro (as-methods ID ...) (define-syntax-rule (as-methods ID ...)
#'(begin (as-method ID) ...)) (begin (as-method ID) ...))
(define-macro (define-instance ID (MAKER BASE-CLASS . ARGS)) (define-syntax (define-instance stx)
(with-pattern ([ID-CLASS (prefix-id #'BASE-CLASS ":" #'ID)]) (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))]) #'(define ID (let ([ID-CLASS (class BASE-CLASS (super-new))])
(MAKER ID-CLASS . ARGS))))) (MAKER ID-CLASS . ARGS))))]))
(define-macro (define-class-predicates ID) (define-syntax (define-class-predicates stx)
(with-pattern ([+ID (prefix-id "+" #'ID)] (syntax-case stx ()
[ID? (suffix-id #'ID "?")]) [(_ 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)) #'(begin (define (ID? x) (is-a? x ID))
(define (+ID . args) (apply make-object ID args))))) (define (+ID . args) (apply make-object ID args))))]))
(define-macro (define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY) (define-syntax-rule (define-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . BODY)
#'(begin (begin
(define ID (class* SUPERCLASS INTERFACES (init-field . INIT-ARGS) . BODY)) (define ID (class* SUPERCLASS INTERFACES (init-field . INIT-ARGS) . BODY))
(define-class-predicates ID))) (define-class-predicates ID)))
(define-macro (define-subclass/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) . 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-subclass*/interfaces SUPERCLASS INTERFACES (ID . INIT-ARGS) (super-new) . BODY))
(define-macro (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY) (define-syntax-rule (define-subclass* SUPERCLASS (ID . INIT-ARGS) . BODY)
#'(define-subclass*/interfaces SUPERCLASS () (ID . INIT-ARGS) . BODY)) (define-subclass*/interfaces SUPERCLASS () (ID . INIT-ARGS) . BODY))
(define-macro (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY) (define-syntax-rule (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY)
#'(define-subclass* SUPERCLASS (ID . INIT-ARGS) (super-new) . BODY)) (define-subclass* SUPERCLASS (ID . INIT-ARGS) (super-new) . BODY))
(define-macro (push-field! FIELD O EXPR) (define-syntax-rule (push-field! FIELD O EXPR)
#'(set-field! FIELD O (cons EXPR (get-field FIELD O)))) (set-field! FIELD O (cons EXPR (get-field FIELD O))))
(define-macro (push-end-field! FIELD O EXPR) (define-syntax-rule (push-end-field! FIELD O EXPR)
#'(set-field! FIELD O (append (get-field FIELD O) (list EXPR)))) (set-field! FIELD O (append (get-field FIELD O) (list EXPR))))
(define-macro (pop-field! FIELD O) (define-syntax-rule (pop-field! FIELD O)
#'(let ([xs (get-field FIELD O)]) (let ([xs (get-field FIELD O)])
(set-field! FIELD O (cdr xs)) (set-field! FIELD O (cdr xs))
(car xs))) (car xs)))
(define-macro-cases increment-field! (define-syntax (increment-field! stx)
(syntax-case stx ()
[(_ FIELD O) #'(increment-field! FIELD O 1)] [(_ FIELD O) #'(increment-field! FIELD O 1)]
[(_ FIELD O EXPR) [(_ FIELD O EXPR)
#'(begin (set-field! FIELD O (+ (get-field FIELD O) EXPR)) (get-field FIELD O))]) #'(begin (set-field! FIELD O (+ (get-field FIELD O) EXPR)) (get-field FIELD O))]))
(define-macro (getter-field/override [ID . EXPRS]) (define-syntax (getter-field/override stx)
(syntax-property #'(getter-field [ID . EXPRS]) 'override #t)) (syntax-case stx ()
[(_ [ID . EXPRS])
(syntax-property #'(getter-field [ID . EXPRS]) 'override #t)]))
(define-macro (getter-field [ID . EXPRS]) (define-syntax (getter-field stx)
(with-pattern ([_ID (prefix-id "_" #'ID)]) (syntax-case stx ()
[(_ [ID . EXPRS])
(with-syntax ([_ID (format-id #'ID "_~a" (syntax->datum #'ID))])
#`(begin #`(begin
(field [(ID _ID) . EXPRS]) (field [(ID _ID) . EXPRS])
(public (_ID ID)) (public (_ID ID))
(#,(if (syntax-property caller-stx 'override) #'define/override #'define) (_ID) ID)))) (#,(if (syntax-property stx 'override) #'define/override #'define) (_ID) ID)))]))

25
sugar/unstable/js.rkt
Unescape Escape View File

@ -1,27 +1,28 @@
#lang racket/base #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)) (provide (all-defined-out))
;; js-style `push`, which appends to end of list ;; js-style `push`, which appends to end of list
(define-macro (push-end! ID THING) (define-syntax-rule (push-end! ID THING)
#'(set! ID (append ID (list THING)))) (set! ID (append ID (list THING))))
(define-macro-cases increment! (define-syntax (increment! stx)
(syntax-case stx ()
[(_ ID) #'(increment! ID 1)] [(_ ID) #'(increment! ID 1)]
[(_ ID EXPR) [(_ ID EXPR)
#'(begin (set! ID (+ ID EXPR)) ID)]) #'(begin (set! ID (+ ID EXPR)) ID)]))
(module+ test (module+ test
(define xs '(1 2 3)) (define xs '(1 2 3))
(push-end! xs 4) (push-end! xs 4)
(check-equal? xs '(1 2 3 4))) (check-equal? xs '(1 2 3 4)))
(define-macro (+= ID THING) #'(begin (set! ID (+ ID THING)) ID)) (define-syntax-rule (+= ID THING) (begin (set! ID (+ ID THING)) ID))
(define-macro (++ ID) #'(+= ID 1)) (define-syntax-rule (++ ID) (+= ID 1))
(define-macro (-- ID) #'(+= ID -1)) (define-syntax-rule (-- ID) (+= ID -1))
(define-macro (-= ID THING) #'(+= ID (- THING))) (define-syntax-rule (-= ID THING) (+= ID (- THING)))
;; fancy number->string. bounds are checked, inexact integers are coerced. ;; fancy number->string. bounds are checked, inexact integers are coerced.
@ -57,7 +58,7 @@
[else #f])] [else #f])]
[else (raise-argument-error '· "object or dict" x)]))) '·)) [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 #;(module+ test
(define c (class object% (define c (class object%
@ -71,8 +72,8 @@
(check-equal? (· co a) 42) (check-equal? (· co a) 42)
(check-equal? (· co b) 43)) (check-equal? (· co b) 43))
(define-macro (·map REF XS) (define-syntax-rule (·map REF XS)
#'(for/list ([x (in-list XS)]) (· x REF))) (for/list ([x (in-list XS)]) (· x REF)))
(module+ test (module+ test
(require rackunit) (require rackunit)

34
sugar/unstable/stub.rkt
Unescape Escape View File

@ -1,5 +1,5 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base br/syntax) br/define) (require (for-syntax racket/base racket/syntax))
(provide (all-defined-out)) (provide (all-defined-out))
(begin-for-syntax (begin-for-syntax
@ -7,25 +7,33 @@
(define (make-prefix caller-stx) (define (make-prefix caller-stx)
(string-join (map ~a (list (syntax-source caller-stx) (syntax-line caller-stx))) ":" #:after-last ":"))) (string-join (map ~a (list (syntax-source caller-stx) (syntax-line caller-stx))) ":" #:after-last ":")))
(define-macro (define-stub-stop ID) (define-syntax (define-stub-stop stx)
(with-pattern ([ERROR-ID (suffix-id (prefix-id (make-prefix caller-stx) #'ID) ":not-implemented")]) (syntax-case stx ()
[(_ ID)
(with-syntax ([ERROR-ID (format-id stx "~a~a:not-implemented" (make-prefix stx) (syntax->datum #'ID))])
#'(define (ID . args) #'(define (ID . args)
(error 'ERROR-ID)))) (error 'ERROR-ID)))]))
(provide (rename-out [define-stub-stop define-stub])) (provide (rename-out [define-stub-stop define-stub]))
(define-macro (define-stub-go ID) (define-syntax (define-stub-go stx)
(with-pattern ([ERROR-ID (suffix-id (prefix-id (make-prefix caller-stx) #'ID) ":not-implemented")]) (syntax-case stx ()
[(_ ID)
(with-syntax ([ERROR-ID (format-id stx "~a~a:not-implemented" (make-prefix stx) (syntax->datum #'ID))])
#'(define (ID . args) #'(define (ID . args)
(displayln 'ERROR-ID)))) (displayln 'ERROR-ID)))]))
(define-macro (define-unfinished (ID . ARGS) . BODY) (define-syntax (define-unfinished stx)
(with-pattern ([ID-UNFINISHED (suffix-id (prefix-id (make-prefix caller-stx) #'ID) ":unfinished")]) (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) #'(define (ID . ARGS)
(begin . BODY) (begin . BODY)
(error 'ID-UNFINISHED)))) (error 'ID-UNFINISHED)))]))
(define-macro (unfinished) (define-syntax (unfinished stx)
(with-pattern ([ID-UNFINISHED (prefix-id (syntax-source caller-stx) ":" (syntax-line caller-stx) ":" #'unfinished)]) (syntax-case stx ()
#'(error 'ID-UNFINISHED))) [(_)
(with-syntax ([ID-UNFINISHED (format-id stx "~a:~a:~a" (syntax-source stx) (syntax-line stx) (syntax->datum #'unfinished))])
#'(error 'ID-UNFINISHED))]))
Write Preview
Loading…
Cancel
Save