move sugars to sugar/unstable

main
Matthew Butterick 6 years ago
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…
Cancel
Save