unstablers

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)])]) 

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))))

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))

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))

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)))
+

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))

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)))