reorg

pitfall/pitfall/color.rkt

@@ -38,21 +38,21 @@
       [(and (string? color) (regexp-match #px"^#(?i:[0-9A-F]){3}$" color))
        (loop (list->string (cdr (apply append
                                        (for/list ([c (in-string color)])
-                                         (list c c))))))] ; change #abc to ##aabbcc then drop the first char
+                                                 (list c c))))))] ; change #abc to ##aabbcc then drop the first char
       ;; 6-digit hexish string becomes list of hex numbers and maybe #f vals
       [(and (string? color) (= 7 (string-length color)) (string-prefix? color "#"))
        (loop (for/list ([str (in-list (regexp-match* #rx".." (string-trim color "#")))])
-               (string->number str 16)))] ; match two at a time and convert to hex
+                       (string->number str 16)))] ; match two at a time and convert to hex
       ;; named color
       [(and (string? color) (hash-ref namedColors color #f)) => loop]
       ;; array of numbers
       [(and (list? color) (andmap number? color))
        (for/list ([i (in-list color)])
-         (define x (/ i (case (length color)
-                          [(3) 255.0] ; RGB
-                          [(4) 100.0] ; CMYK
-                          [else 1.0])))
-         (if (integer? x) (inexact->exact x) x))]
+                 (define x (/ i (case (length color)
+                                  [(3) 255.0] ; RGB
+                                  [(4) 100.0] ; CMYK
+                                  [else 1.0])))
+                 (if (integer? x) (inexact->exact x) x))]
       [else #f])))
 
 
@@ -113,6 +113,22 @@
   (_doOpacity this #f opacity)
   this)
 
+(define (bounded low x high)
+  (if (high . < . low)
+      (bounded high x low)
+      (max low (min high x))))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (bounded 0 2 1) 1)
+  (check-equal? (bounded 1 2 0) 1)
+  (check-equal? (bounded 0 -2 1) 0)
+  (check-equal? (bounded 1 -2 0) 0)
+  (check-equal? (bounded 0 .5 1) 0.5)
+  (check-equal? (bounded 0 0 1) 0)
+  (check-equal? (bounded 0 1 1) 1))
+
+
 
 (define/contract (_doOpacity this [fill-arg #f] [stroke-arg #f])
   (() ((or/c number? #f) (or/c number? #f)) . ->*m . object?)

pitfall/pitfall/directory.rkt

@@ -14,7 +14,6 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js
                               'length uint32be)))
 
 (define-subclass RStruct (RDirectory)
-  (super-new)
   (define/public (process)
     'boom))
 
@@ -26,12 +25,15 @@ https://github.com/mbutterick/fontkit/blob/master/src/tables/directory.js
                              'rangeShift uint16be
                              'tables (make-object RArray TableEntry 'numTables))))
 
+(define (directory-decode ip [options (mhash)])
+  (define is (make-object RDecodeStream ip))
+  (send Directory decode is))
+
 (module+ test
   (require rackunit)
   (define ip (open-input-file "test/assets/Charter.ttf"))
-  (define is (make-object RDecodeStream ip))
   (check-equal?
-   (send Directory decode is)
+   (directory-decode ip)
    (make-hasheq
     (list (cons 'tables
                 (list (make-hasheq '((length . 96) (checkSum . 2351070438) (offset . 360) (tag . "OS/2")))

pitfall/pitfall/document.rkt

@@ -6,8 +6,6 @@
 (define mixed% (annotation-mixin (image-mixin (text-mixin (fonts-mixin (color-mixin (vector-mixin object%)))))))
 
 (define-subclass mixed% (PDFDocument [options (mhash)])
-  (super-new)
-
   (compress-streams? (hash-ref options 'compress #t))
   
   (field [byte-strings empty]

pitfall/pitfall/glyph-position.rkt

@@ -13,7 +13,6 @@
                           ;; The offset from the pen position in the Y direction at which to render this glyph.
                           [yOffset 0]
                           [advanceWidth 0])
-  (super-new)
 
   (as-methods
    scale)

pitfall/pitfall/helper.rkt

@@ -2,136 +2,10 @@
 (require (for-syntax racket/base racket/syntax br/syntax) br/define racket/class sugar/list racket/list (only-in br/list push! pop!) racket/string racket/format racket/contract)
 (provide (all-defined-out) push! pop!)
 
-(define-syntax (· stx)
-  (syntax-case stx ()
-    [(_ x ref)
-     #'(cond
-         [(object? x) (with-handlers ([exn:fail:object? (λ (exn) (send x ref))])
-                        (get-field ref x))]
-         [(hash? x) (hash-ref x 'ref #f)]
-         [else (raise-argument-error '· (format "~a must be object or hash" 'x) x)])]
-    [(_ x ref0 . refs) #'(· (· x ref0) . refs)]))
-
-(define-syntax (·map stx)
-  (syntax-case stx ()
-    [(_ ref xs) #'(for/list ([x (in-list xs)]) (· x ref))]))
-
-(define-syntax-rule (+= id thing) (begin (set! id (+ id thing)) id)) 
-(define-syntax-rule (++ id) (+= id 1))
-(define-syntax-rule (-- id) (+= id -1))
-(define-syntax-rule (-= id thing) (+= id (- thing)))
-
-(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)))
-
-
-(define (listify kvs)
-  (for/list ([slice (in-list (slice-at kvs 2))])
-            (cons (first slice) (second slice))))
-(define-syntax-rule (define-hashifier id hasher) (define (id . kvs) (hasher (listify kvs))))
-(define-hashifier mhash make-hash)
-(define-hashifier mhasheq make-hasheq)
-(define-hashifier mhasheqv make-hasheqv)
-(define (dictify . xs) (listify xs))
-
-(module+ test
-  (check-equal? (mhash 'k "v") (make-hash (list (cons 'k "v"))))) 
-
-
 (define isBuffer? bytes?)
 (define (newBuffer x) (string->bytes/latin-1 (format "~a" x)))
 (define buffer-length bytes-length)
 
-
-;; js-style `push`, which appends to end of list
-(define-syntax-rule (push-end! id thing) (set! id (append id (list thing))))
-
-(define-syntax-rule (push-field! field o expr) (set-field! field o (cons expr (get-field field o))))
-
-(define-syntax-rule (push-end-field! field o expr)
-  (set-field! field o (append (get-field field o) (list expr))))
-
-(define-syntax-rule (pop-field! field o) (let ([xs (get-field field o)])
-                                           (set-field! field o (cdr xs))
-                                           (car xs)))
-(define-syntax (increment-field! stx)
-  (syntax-case stx ()
-    [(_ 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-syntax (increment! stx)
-  (syntax-case stx ()
-    [(_ 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)))
-
-;; 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-syntax (send*/fold stx)
-  (syntax-case stx ()
-    [(_ o) #'o]
-    [(_ o [m0 . args0] [m . args] ...)
-     #'(send*/fold (send o m0 . args0) [m . args] ...)]))
-
-(module+ test
-  (define SFC (class object%
-                (super-new)
-                (field [sum 0])
-                (define/public (add x) (set! sum (+ sum x)) this)))
-  (define sfo (new SFC))
-  (check-equal? (get-field sum (send*/fold sfo [add 1] [add 2] [add 3])) 6))
-
-(define (bounded low x high)
-  (if (high . < . low)
-      (bounded high x low)
-      (max low (min high x))))
-
-(module+ test
-  (check-equal? (bounded 0 2 1) 1)
-  (check-equal? (bounded 1 2 0) 1)
-  (check-equal? (bounded 0 -2 1) 0)
-  (check-equal? (bounded 1 -2 0) 0)
-  (check-equal? (bounded 0 .5 1) 0.5)
-  (check-equal? (bounded 0 0 1) 0)
-  (check-equal? (bounded 0 1 1) 1))
-
-
 (struct exn:pitfall:test exn (data))
 
 (define (raise-test-exn val)
@@ -140,30 +14,6 @@
 (define-syntax-rule (test-when cond expr)
   (if cond (raise-test-exn expr) expr))
 
-(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-syntax (as-method stx)
-  (syntax-case stx ()
-    [(_ id) (with-syntax ([private-id (generate-temporary #'id)])
-              #'(begin
-                  (public [private-id id])
-                  (define (private-id . args) (apply id this args))))]))
-
-(define-syntax-rule (as-methods id ...)
-  (begin (as-method id) ...))
 
 (define (color-string? x)
   (and (string? x)
@@ -171,17 +21,6 @@
            (or (= (string-length x) 4) (= (string-length x) 7))
            #t)))
 
-(define-syntax-rule (define-subclass CLASS-ID (SUBCLASS-ID INIT-FIELD ...) . EXPRS)
-  (define SUBCLASS-ID
-    (class CLASS-ID
-      (init-field INIT-FIELD ...) . EXPRS)))
-
-(define (bytes->hex bstr)
-  (map (λ (b) (string->symbol (string-append (if (< b 16)
-                                                 "x0" "x") (~r b #:base 16)))) (bytes->list bstr)))
-
-(module+ test
-  (check-equal? (bytes->hex #"PNG") '(x50 x4e x47)))
 
 (define (layout? x)
   (and (hash? x) (hash-has-key? x 'glyphs) (hash-has-key? x 'positions)))
@@ -189,26 +28,4 @@
 (define index? (and/c (not/c negative?) integer?))
 
 
-(define-macro (define-stub-stop ID)
-  (with-pattern ([ERROR-ID (suffix-id (prefix-id (syntax-source #'this) ":" #'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 (syntax-source #'this) ":" #'ID) ":not-implemented")])
-                #'(define (ID . args)
-                    (displayln 'ERROR-ID))))
-
-(define-macro (define-unfinished (ID . ARGS) . BODY)
-  (with-pattern ([ID-UNFINISHED (suffix-id (prefix-id (syntax-source #'this) ":" #'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)))
   

pitfall/pitfall/jpeg.rkt

@@ -5,7 +5,6 @@
                          #xffc8 #xffc9 #xffca #xffcb #xffcc #xffcd #xffce #xffcf))
 
 (define-subclass object% (JPEG data [label #f])
-  (super-new)
   (define last-ip (current-input-port))
   (current-input-port (if (input-port? data)
                           data

pitfall/pitfall/page-test.rkt

@@ -1,5 +1,5 @@
 #lang racket/base
-(require racket/class rackunit "document.rkt" "page.rkt" "reference.rkt" "helper.rkt")
+(require racket/class rackunit "document.rkt" "page.rkt" "reference.rkt" "helper.rkt" sugar/js)
 (define p (make-object PDFPage (make-object PDFDocument)))
 (check-equal? (· p size) "letter")
 (check-equal? (· p layout) "portrait")

pitfall/pitfall/png.rkt

@@ -3,7 +3,6 @@
 (provide PNG)
 
 (define-subclass object% (PNG data [label #f])
-  (super-new)
   
   (field [image (read-png data)]
          [pixelBitlength (· image pixelBitlength)]

pitfall/pitfall/racket.rkt

@@ -18,7 +18,11 @@
      racket/list
      racket/port
      racket/function
-     br/define)
+     br/define
+     sugar/class
+     sugar/js
+     sugar/dict
+     sugar/stub)
 
 (module reader syntax/module-reader
   #:language 'pitfall/racket

pitfall/pitfall/reference.rkt

@@ -3,7 +3,6 @@
 (provide PDFReference)
 
 (define-subclass object% (PDFReference document id [payload (mhash)])
-  (super-new)
   (field [byte-strings empty]
          [offset #f])
 

pitfall/pitfall/standard-font.rkt

@@ -4,7 +4,6 @@
 (provide isStandardFont standard-fonts StandardFont)
 
 (define-subclass PDFFont (StandardFont document name id)
-  (super-new)
   (field [font (make-object AFMFont ((hash-ref standard-fonts name
                                                (λ () (raise-argument-error 'PDFFont "valid font name" name)))))]
          [ascender (· font ascender)]

pitfall/restructure/decodestream.rkt

@@ -3,6 +3,12 @@
 
 ;; approximates https://github.com/mbutterick/restructure/blob/master/src/DecodeStream.coffee
 
+(define (read-bytes-exact count p)
+  (define bs (read-bytes count p))
+  (unless (and (bytes? bs) (= (bytes-length bs) count))
+    (raise-argument-error 'read-bytes-exact (format "byte string length ~a" count) bs))
+  bs)
+
 (provide (rename-out [type-sizes TYPES]))
 
 (define type-sizes (let-values ([(intkeys intvalues)

pitfall/restructure/helper.rkt

@@ -2,12 +2,6 @@
 (require (for-syntax racket/base br/syntax) racket/class br/define)
 (provide (all-defined-out))
 
-(define (read-bytes-exact count p)
-  (define bs (read-bytes count p))
-  (unless (and (bytes? bs) (= (bytes-length bs) count))
-    (raise-argument-error 'read-bytes-exact (format "byte string length ~a" count) bs))
-  bs)
-
 (define RBase
   (class object%
     (super-new)    
@@ -16,89 +10,14 @@
     #;(abstract size)))
 
 
-(define-macro (define-subclass SUPERCLASS (ID . INIT-ARGS) . BODY)
-  #'(define ID (class SUPERCLASS (super-new) (init-field . INIT-ARGS) . BODY)))
-
-(require (for-syntax sugar/debug))
-(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))))
-
-(define-macro (getter-field/override [ID . EXPRS])
-  (syntax-property #'(getter-field [ID . EXPRS]) 'override #t))
-
 (define-macro (test-module . EXPRS)
   #`(module+ test
       (require #,(datum->syntax caller-stx 'rackunit))
       . EXPRS))
 
-(define-macro (define-stub-stop ID)
-  (with-pattern ([ERROR-ID (suffix-id (prefix-id (syntax-source #'this) ":" #'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 (syntax-source #'this) ":" #'ID) ":not-implemented")])
-    #'(define (ID . args)
-        (displayln 'ERROR-ID))))
-
-(define-macro (define-unfinished (ID . ARGS) . BODY)
-  (with-pattern ([ID-UNFINISHED (suffix-id (prefix-id (syntax-source #'this) ":" #'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)))
-
-(define-macro (define+provide ID . EXPRS)
-  #'(begin
-      (provide ID)
-      (define ID . EXPRS)))
-
-(require sugar/list)
-(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))))
-(define-hashifier mhash make-hash)
-(define-hashifier mhasheq make-hasheq)
-(define-hashifier mhasheqv make-hasheqv)
-
-(provide dictify)
-(define (dictify . xs) (listify xs))
 
 (define (port-position port)
   (define-values (l c p) (port-next-location port))
   p)
 
-(define-syntax (· stx)
-  (syntax-case stx ()
-    [(_ x ref)
-     #'(cond
-         [(object? x) (with-handlers ([exn:fail:object? (λ (exn) (send x ref))])
-                        (get-field ref x))]
-         [(hash? x) (hash-ref x 'ref #f)]
-         [else (raise-argument-error '· (format "~a must be object or hash" 'x) x)])]
-    [(_ x ref0 . refs) #'(· (· x ref0) . refs)]))
-
-(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)

pitfall/restructure/racket.rkt

@@ -9,7 +9,13 @@
      sugar/debug
      racket/class
      racket/string
-     br/define)
+     br/define
+     sugar/define
+     sugar/class
+     sugar/js
+     sugar/dict
+     sugar/stub
+     sugar/case)
 
 (module reader syntax/module-reader
   #:language 'restructure/racket

pitfall/sugar/case.rkt

@@ -0,0 +1,17 @@
+#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)

pitfall/sugar/class.rkt

@@ -0,0 +1,62 @@
+#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-subclass SUPERCLASS (ID . INIT-ARGS) . BODY)
+  #'(define ID (class SUPERCLASS (super-new) (init-field . INIT-ARGS) . 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))))

pitfall/sugar/dict.rkt

@@ -0,0 +1,20 @@
+#lang racket/base
+(require sugar/list)
+(provide (all-defined-out))
+
+
+(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))

pitfall/sugar/js.rkt

@@ -0,0 +1,73 @@
+#lang racket/base
+(require racket/class (for-syntax racket/base racket/syntax br/syntax) br/define)
+(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-macro-cases ·
+  [(_ X REF)
+   #'(cond
+       [(object? X) (with-handlers ([exn:fail:object? (λ (exn) (send X REF))])
+                      (get-field REF X))]
+       [(hash? X) (hash-ref X 'REF #f)]
+       [else (raise-argument-error '· (format "~a must be object or hash" 'X) X)])]
+  [(_ X REF0 . REFS) #'(· (· X REF0) . REFS)])
+
+
+(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)))
+

pitfall/sugar/stub.rkt

@@ -0,0 +1,26 @@
+#lang racket/base
+(require (for-syntax racket/base br/syntax) br/define)
+(provide (all-defined-out))
+
+(define-macro (define-stub-stop ID)
+  (with-pattern ([ERROR-ID (suffix-id (prefix-id (syntax-source #'this) ":" #'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 (syntax-source #'this) ":" #'ID) ":not-implemented")])
+                #'(define (ID . args)
+                    (displayln 'ERROR-ID))))
+
+(define-macro (define-unfinished (ID . ARGS) . BODY)
+  (with-pattern ([ID-UNFINISHED (suffix-id (prefix-id (syntax-source #'this) ":" #'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)))