diff --git a/pitfall/pitfall/color.rkt b/pitfall/pitfall/color.rkt index bd9c22fa..0b90911b 100644 --- a/pitfall/pitfall/color.rkt +++ b/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?) diff --git a/pitfall/pitfall/directory.rkt b/pitfall/pitfall/directory.rkt index 9750170c..339f1f5f 100644 --- a/pitfall/pitfall/directory.rkt +++ b/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"))) diff --git a/pitfall/pitfall/document.rkt b/pitfall/pitfall/document.rkt index a51253f9..080ac0b8 100644 --- a/pitfall/pitfall/document.rkt +++ b/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] diff --git a/pitfall/pitfall/glyph-position.rkt b/pitfall/pitfall/glyph-position.rkt index 12d0d32c..2d40fe57 100644 --- a/pitfall/pitfall/glyph-position.rkt +++ b/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) diff --git a/pitfall/pitfall/helper.rkt b/pitfall/pitfall/helper.rkt index 7d6ab462..b5866f30 100644 --- a/pitfall/pitfall/helper.rkt +++ b/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))) \ No newline at end of file diff --git a/pitfall/pitfall/jpeg.rkt b/pitfall/pitfall/jpeg.rkt index cd2d196d..c02fbb2a 100644 --- a/pitfall/pitfall/jpeg.rkt +++ b/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 diff --git a/pitfall/pitfall/page-test.rkt b/pitfall/pitfall/page-test.rkt index 2b00a6b2..c4667995 100644 --- a/pitfall/pitfall/page-test.rkt +++ b/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") diff --git a/pitfall/pitfall/png.rkt b/pitfall/pitfall/png.rkt index 73f7ac70..0659a410 100644 --- a/pitfall/pitfall/png.rkt +++ b/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)] diff --git a/pitfall/pitfall/racket.rkt b/pitfall/pitfall/racket.rkt index 9155f462..ad960192 100644 --- a/pitfall/pitfall/racket.rkt +++ b/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 diff --git a/pitfall/pitfall/reference.rkt b/pitfall/pitfall/reference.rkt index d2dd6a6f..568d45dc 100644 --- a/pitfall/pitfall/reference.rkt +++ b/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]) diff --git a/pitfall/pitfall/standard-font.rkt b/pitfall/pitfall/standard-font.rkt index f4cd9ade..f164b557 100644 --- a/pitfall/pitfall/standard-font.rkt +++ b/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)] diff --git a/pitfall/restructure/decodestream.rkt b/pitfall/restructure/decodestream.rkt index d8189104..da307dc4 100644 --- a/pitfall/restructure/decodestream.rkt +++ b/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) diff --git a/pitfall/restructure/helper.rkt b/pitfall/restructure/helper.rkt index a25dcf49..dfab4357 100644 --- a/pitfall/restructure/helper.rkt +++ b/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) \ No newline at end of file diff --git a/pitfall/restructure/racket.rkt b/pitfall/restructure/racket.rkt index c11ec2c7..e7f99526 100644 --- a/pitfall/restructure/racket.rkt +++ b/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 diff --git a/pitfall/sugar/case.rkt b/pitfall/sugar/case.rkt new file mode 100644 index 00000000..752f0a92 --- /dev/null +++ b/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) \ No newline at end of file diff --git a/pitfall/sugar/class.rkt b/pitfall/sugar/class.rkt new file mode 100644 index 00000000..24a12dd6 --- /dev/null +++ b/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)))) \ No newline at end of file diff --git a/pitfall/sugar/dict.rkt b/pitfall/sugar/dict.rkt new file mode 100644 index 00000000..c95bbd18 --- /dev/null +++ b/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)) \ No newline at end of file diff --git a/pitfall/sugar/js.rkt b/pitfall/sugar/js.rkt new file mode 100644 index 00000000..3573ca13 --- /dev/null +++ b/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))) + diff --git a/pitfall/sugar/stub.rkt b/pitfall/sugar/stub.rkt new file mode 100644 index 00000000..d3a2e66c --- /dev/null +++ b/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))) \ No newline at end of file