diff --git a/sugar/unstable/case.rkt b/sugar/unstable/case.rkt new file mode 100644 index 0000000..69c8d02 --- /dev/null +++ b/sugar/unstable/case.rkt @@ -0,0 +1,24 @@ +#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)])]) \ No newline at end of file diff --git a/sugar/unstable/class.rkt b/sugar/unstable/class.rkt new file mode 100644 index 0000000..2ae7195 --- /dev/null +++ b/sugar/unstable/class.rkt @@ -0,0 +1,85 @@ +#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)))) \ No newline at end of file diff --git a/sugar/unstable/contract.rkt b/sugar/unstable/contract.rkt new file mode 100644 index 0000000..6d4fbbc --- /dev/null +++ b/sugar/unstable/contract.rkt @@ -0,0 +1,25 @@ +#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)) \ No newline at end of file diff --git a/sugar/unstable/dict.rkt b/sugar/unstable/dict.rkt new file mode 100644 index 0000000..c447bad --- /dev/null +++ b/sugar/unstable/dict.rkt @@ -0,0 +1,22 @@ +#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)) \ No newline at end of file diff --git a/sugar/unstable/js.rkt b/sugar/unstable/js.rkt new file mode 100644 index 0000000..da388f9 --- /dev/null +++ b/sugar/unstable/js.rkt @@ -0,0 +1,94 @@ +#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))) + diff --git a/sugar/unstable/port.rkt b/sugar/unstable/port.rkt new file mode 100644 index 0000000..d90b6b3 --- /dev/null +++ b/sugar/unstable/port.rkt @@ -0,0 +1,27 @@ +#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)) \ No newline at end of file diff --git a/sugar/unstable/stub.rkt b/sugar/unstable/stub.rkt new file mode 100644 index 0000000..521d2f0 --- /dev/null +++ b/sugar/unstable/stub.rkt @@ -0,0 +1,31 @@ +#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))) \ No newline at end of file