move sugars to sugar/unstable
parent
562c99e757
commit
3f0a33c61b
@ -1,24 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax br/syntax) br/define)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-macro (define-case-macro ID PRED)
|
||||
#'(define-macro-cases ID
|
||||
[(_ TEST-VAL [(MATCH0 . MATCH-VALS) . RESULT] (... ...) [else . ELSE-RESULT])
|
||||
#'(cond
|
||||
[(PRED TEST-VAL '(MATCH0 . MATCH-VALS)) . RESULT] (... ...)
|
||||
[else . ELSE-RESULT])]
|
||||
[(_ TEST-VAL MATCH-CLAUSE (... ...))
|
||||
#'(ID TEST-VAL
|
||||
MATCH-CLAUSE (... ...)
|
||||
[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)
|
||||
(define-case-macro casev memv)
|
||||
|
||||
|
||||
(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)])])
|
||||
@ -1,85 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax br/syntax) br/define racket/class)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define string%
|
||||
(class* object% (writable<%>)
|
||||
(super-new)
|
||||
(init-field [data #f])
|
||||
(define (get-string)
|
||||
(with-handlers ([exn:fail:object? (λ (exn) data)])
|
||||
(send this toString)))
|
||||
(define/public (custom-write port) (write (get-string) port))
|
||||
(define/public (custom-display port) (display (get-string) port))))
|
||||
|
||||
(define mixin-tester%
|
||||
(class object%
|
||||
(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-macro (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-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-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-macro (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-macro (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-macro (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-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-macro (getter-field/override [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))))
|
||||
@ -1,25 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/contract racket/class)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (option/c x) (or/c #f x))
|
||||
|
||||
(module+ main
|
||||
|
||||
(define-syntax-rule (define/public/contract (ID . ARGS) CONTRACT . BODY)
|
||||
(define/public (ID . ARGS)
|
||||
(define/contract (ID . ARGS)
|
||||
CONTRACT . BODY)
|
||||
(ID . ARGS)))
|
||||
|
||||
(define c% (class object%
|
||||
(super-new)
|
||||
|
||||
(define/public/contract (add x y)
|
||||
(integer? integer? . -> . integer?)
|
||||
(+ x y))))
|
||||
|
||||
|
||||
(define c (make-object c%))
|
||||
|
||||
(send c add 12 21))
|
||||
@ -1,22 +0,0 @@
|
||||
#lang racket/base
|
||||
(require sugar/list)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (assoc? x) (and (pair? x) (not (list? x))))
|
||||
(define (assocs? xs) (and (list? xs) (andmap assoc? xs)))
|
||||
|
||||
(define (listify kvs)
|
||||
(for/list ([slice (in-list (slice-at kvs 2))])
|
||||
(cons (car slice) (cadr slice))))
|
||||
(define-syntax-rule (define-hashifier id hasher) (define (id . kvs) (hasher (listify kvs))))
|
||||
|
||||
;; like indefinite-arity `hash` but mutable
|
||||
(define-hashifier mhash make-hash)
|
||||
(define-hashifier mhasheq make-hasheq)
|
||||
(define-hashifier mhasheqv make-hasheqv)
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (mhash 'k "v") (make-hash (list (cons 'k "v")))))
|
||||
|
||||
(define (dictify . xs) (listify xs))
|
||||
@ -1,94 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/class (for-syntax racket/base racket/syntax br/syntax) br/define 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-macro-cases increment!
|
||||
[(_ 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)))
|
||||
|
||||
|
||||
;; fancy number->string. bounds are checked, inexact integers are coerced.
|
||||
(define (number x)
|
||||
(unless (and (number? x) (< -1e21 x 1e21))
|
||||
(raise-argument-error 'number "valid number" x))
|
||||
(let ([x (/ (round (* x 1e6)) 1e6)])
|
||||
(number->string (if (integer? x)
|
||||
(inexact->exact x)
|
||||
x))))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (number 4.5) "4.5")
|
||||
(check-equal? (number 4.0) "4")
|
||||
(check-equal? (number 4) "4")
|
||||
(check-equal? (number -4) "-4"))
|
||||
|
||||
|
||||
(define ·-helper
|
||||
(procedure-rename
|
||||
(λ (x . refs)
|
||||
(for/fold ([x x])
|
||||
([ref (in-list refs)]
|
||||
#:break (not x))
|
||||
(cond
|
||||
;; give `send` precedence (presence of method => wants runtime resolution of value)
|
||||
[(and (object? x)
|
||||
(memq ref (interface->method-names (object-interface x)))) (dynamic-send x ref)]
|
||||
;; dict first, to catch objects that implement gen:dict
|
||||
[(dict? x) (dict-ref x ref #f)]
|
||||
[(object? x) (cond
|
||||
[(memq ref (field-names x)) (dynamic-get-field ref x)]
|
||||
[else #f])]
|
||||
[else (raise-argument-error '· "object or dict" x)]))) '·))
|
||||
|
||||
(define-macro (· X REF ...) #'(·-helper X 'REF ...))
|
||||
|
||||
#;(module+ test
|
||||
(define c (class object%
|
||||
(super-new)
|
||||
(field [a 42])
|
||||
(define/public (res) (hash 'res (hash 'b 43)))))
|
||||
(define co (make-object c))
|
||||
(define h2 (hash 'a 42 'res co))
|
||||
(check-equal? (· h2 a) 42)
|
||||
(check-equal? (· h2 b) 43)
|
||||
(check-equal? (· co a) 42)
|
||||
(check-equal? (· co b) 43))
|
||||
|
||||
(define-macro (·map REF XS)
|
||||
#'(for/list ([x (in-list XS)]) (· x REF)))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define C
|
||||
(class object%
|
||||
(super-new)
|
||||
(field [foo 'field])
|
||||
(define/public (bar) 'method)
|
||||
(define/public (zam) (hasheq 'zoom 'hash))))
|
||||
(define h (hasheq 'bam (new C) 'foo 'hashlet))
|
||||
(define o (new C))
|
||||
(check-equal? (· o foo) 'field)
|
||||
(check-equal? (· o bar) 'method)
|
||||
(check-equal? (· o zam zoom) 'hash)
|
||||
(check-equal? (· h bam foo) 'field)
|
||||
(check-equal? (· h bam bar) 'method)
|
||||
(check-equal? (· h bam zam zoom) 'hash)
|
||||
(check-equal? (·map foo (list o h)) '(field hashlet)))
|
||||
|
||||
@ -1,27 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/port)
|
||||
(provide (all-defined-out) (all-from-out racket/port))
|
||||
|
||||
(define (port-position ip [where #f])
|
||||
(cond
|
||||
[where (file-position ip where)
|
||||
ip]
|
||||
[else (file-position ip)]))
|
||||
|
||||
(define (set-port-position! ip where)
|
||||
(file-position ip where))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define ip (open-input-bytes (bytes 1 2 3 4)))
|
||||
(port-count-lines! ip)
|
||||
(check-equal? (port-position ip) 0)
|
||||
(check-equal? (read-byte ip) 1)
|
||||
(check-equal? (port-position ip) 1)
|
||||
(check-equal? (read-byte ip) 2)
|
||||
(set-port-position! ip 4)
|
||||
(check-equal? (port-position ip) 4)
|
||||
(check-equal? (read-byte ip) eof)
|
||||
(set-port-position! ip 0)
|
||||
(check-equal? (port-position ip) 0)
|
||||
(check-equal? (read-byte ip) 1))
|
||||
@ -1,31 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base br/syntax) br/define)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(begin-for-syntax
|
||||
(require racket/string racket/format)
|
||||
(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))))
|
||||
|
||||
(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-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-macro (unfinished)
|
||||
(with-pattern ([ID-UNFINISHED (prefix-id (syntax-source caller-stx) ":" (syntax-line caller-stx) ":" #'unfinished)])
|
||||
#'(error 'ID-UNFINISHED)))
|
||||
Loading…
Reference in New Issue