avoid dark patterns

main
Matthew Butterick 6 years ago
parent 8de6136536
commit d0647d4532

@ -1,6 +1,16 @@
#lang racket/base
(require "private/racket.rkt")
(require "number.rkt" "utils.rkt")
(require racket/class
racket/list
racket/function
sugar/unstable/class
sugar/unstable/dict
sugar/unstable/js
racket/dict
"struct.rkt"
"private/generic.rkt"
"private/helper.rkt"
"number.rkt"
"utils.rkt")
(provide (all-defined-out))
#|
@ -30,10 +40,10 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
[else +inf.0]))
(for/list ([i (in-naturals)]
#:break (or (eof-object? (peek-byte port)) (= (pos port) end-pos)))
(send type decode port ctx))]
(send type decode port ctx))]
;; we have decoded-len, which is treated as count of items
[else (for/list ([i (in-range decoded-len)])
(send type decode port ctx))]))
(send type decode port ctx))]))
(define/augride (size [val #f] [ctx #f])
@ -44,7 +54,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
(values (mhasheq 'parent ctx) (send len size))
(values ctx 0))])
(+ len-size (for/sum ([item (in-list (countable->list val))])
(send type size item ctx))))]
(send type size item ctx))))]
[else (let ([item-count (resolve-length len #f ctx)]
[item-size (send type size #f ctx)])
(* item-size item-count))]))
@ -59,7 +69,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
[item-count (length items)]
[max-items (if (number? len) len item-count)])
(for ([item (in-list items)])
(send type encode port item ctx))))
(send type encode port item ctx))))
(cond
[(NumberT? len) (define ctx (mhash 'pointers null
@ -69,9 +79,15 @@ https://github.com/mbutterick/restructure/blob/master/src/Array.coffee
(send len encode port (length array)) ; encode length at front
(encode-items ctx)
(for ([ptr (in-list (· ctx pointers))]) ; encode pointer data at end
(send (· ptr type) encode port (· ptr val)))]
(send (· ptr type) encode port (· ptr val)))]
[else (encode-items parent)])))
(define-syntax-rule (define-procedures (NEW ...) (OLD ...))
(define-values (NEW ...)
(values (if (procedure? OLD)
(procedure-rename OLD 'NEW)
OLD) ...)))
(define-procedures (Array Array? +Array) (ArrayT ArrayT? +ArrayT))
(define-procedures (array% array? array) (ArrayT ArrayT? +ArrayT))

@ -1,7 +1,13 @@
#lang racket/base
(require racket/class sugar/unstable/class racket/generic racket/private/generic-methods "private/generic.rkt" racket/port racket/dict racket/function)
(require sugar/debug)
(require racket/class
sugar/unstable/class
racket/generic
racket/private/generic-methods
"private/generic.rkt"
racket/port
racket/dict)
(provide (all-defined-out))
(define-generics posable
(pos posable [new-pos])
#:defaults

@ -1,5 +1,10 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/class
racket/list
sugar/unstable/class
sugar/unstable/dict
"private/generic.rkt"
"private/helper.rkt")
(provide (all-defined-out))
#|

@ -1,6 +1,10 @@
#lang racket/base
(require "private/racket.rkt")
(require "number.rkt" "utils.rkt")
(require racket/class
sugar/unstable/class
"private/generic.rkt"
"private/helper.rkt"
"number.rkt"
"utils.rkt")
(provide (all-defined-out))
#|

@ -1,5 +1,8 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/class
racket/list
sugar/unstable/class
"private/helper.rkt")
(provide (all-defined-out))
#|

@ -1,6 +1,12 @@
#lang racket/base
(require "private/racket.rkt")
(require "utils.rkt" "array.rkt" "number.rkt")
(require racket/class
sugar/unstable/class
sugar/unstable/dict
"private/generic.rkt"
"private/helper.rkt"
"utils.rkt"
"array.rkt"
"number.rkt")
(provide (all-defined-out))
#|

@ -1,5 +1,7 @@
#lang racket/base
(require "private/racket.rkt")
(define-syntax-rule (r+p ID ...)
(begin (require ID ...) (provide (all-from-out ID ...))))
(r+p "array.rkt"
"base.rkt"

@ -1,6 +1,14 @@
#lang racket/base
(require "private/racket.rkt")
(require "sizes.rkt" (for-syntax "sizes.rkt" racket/match))
(require (for-syntax racket/base
racket/syntax
"sizes.rkt"
racket/match)
racket/class
racket/list
racket/function
sugar/unstable/class
"private/helper.rkt"
"sizes.rkt")
(provide (all-defined-out))
#|
@ -48,7 +56,7 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(define bstr (read-bytes _size port))
(define bs ((if (eq? endian system-endian) identity reverse) (bytes->list bstr)))
(define unsigned-int (for/sum ([(b i) (in-indexed bs)])
(arithmetic-shift b (* 8 i))))
(arithmetic-shift b (* 8 i))))
unsigned-int)
(define/override (post-decode unsigned-val . _)
@ -155,20 +163,21 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
(check-equal? (send (+Number 'double) size) 8))
;; use keys of type-sizes hash to generate corresponding number definitions
(define-macro (make-int-types)
(with-pattern ([((ID BASE ENDIAN) ...) (for*/list ([k (in-hash-keys type-sizes)]
[kstr (in-value (format "~a" k))]
#:unless (regexp-match #rx"^(float|double)" kstr))
(match-define (list* prefix suffix _)
(regexp-split #rx"(?=[bl]e|$)" kstr))
(map string->symbol
(list (string-downcase kstr)
prefix
(if (positive? (string-length suffix))
suffix
(if (system-big-endian?) "be" "le")))))]
[(ID ...) (suffix-id #'(ID ...) #:context caller-stx)])
#'(begin (define-instance ID (make-object Integer 'BASE 'ENDIAN)) ...)))
(define-syntax (make-int-types stx)
(syntax-case stx ()
[(_) (with-syntax* ([((ID BASE ENDIAN) ...) (for*/list ([k (in-hash-keys type-sizes)]
[kstr (in-value (format "~a" k))]
#:unless (regexp-match #rx"^(float|double)" kstr))
(match-define (list* prefix suffix _)
(regexp-split #rx"(?=[bl]e|$)" kstr))
(map string->symbol
(list (string-downcase kstr)
prefix
(if (positive? (string-length suffix))
suffix
(if (system-big-endian?) "be" "le")))))]
[(ID ...) (map (λ (s) (datum->syntax stx (syntax->datum s))) (syntax->list #'(ID ...)))])
#'(begin (define-instance ID (make-object Integer 'BASE 'ENDIAN)) ...))]))
(make-int-types)

@ -1,5 +1,7 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/class
sugar/unstable/class
"private/helper.rkt")
(provide (all-defined-out))
#|

@ -1,6 +1,11 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/undefined)
(require racket/class
sugar/unstable/class
sugar/unstable/case
sugar/unstable/dict
sugar/unstable/js
"private/generic.rkt"
"private/helper.rkt")
(provide (all-defined-out))
#|

@ -1,33 +0,0 @@
#lang racket/base
(require (for-syntax racket/base br/syntax) br/define)
(provide (for-syntax (all-from-out racket/base br/syntax)))
(provide (all-from-out racket/base) r+p)
(define-macro (r+p ID ...)
#'(begin (require ID ...) (provide (all-from-out ID ...))))
(r+p "helper.rkt"
"generic.rkt"
sugar/debug
racket/class
racket/list
racket/string
racket/function
br/define
sugar/define
sugar/unstable/class
sugar/unstable/js
sugar/unstable/dict
sugar/unstable/stub
sugar/unstable/port
sugar/unstable/case)
(provide define-procedures)
(define-macro (define-procedures (NEW ...) (OLD ...))
#'(define-values (NEW ...)
(values (if (procedure? OLD)
(procedure-rename OLD 'NEW)
OLD) ...)))
(module reader syntax/module-reader
#:language 'xenomorph/private/racket)

@ -1,6 +1,8 @@
#lang racket/base
(require "private/racket.rkt")
(require "utils.rkt")
(require racket/class
sugar/unstable/class
"private/helper.rkt"
"utils.rkt")
(provide (all-defined-out))
#|

@ -1,5 +1,5 @@
#lang racket/base
(require "private/racket.rkt")
(require "private/helper.rkt")
(provide type-sizes get-type-size)
(define-values (int-keys byte-values) (for*/lists (int-keys byte-values)

@ -1,5 +1,11 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/class
racket/function
sugar/unstable/class
sugar/unstable/case
sugar/unstable/js
"private/generic.rkt"
"private/helper.rkt")
(require "number.rkt" "utils.rkt")
(provide (all-defined-out))

@ -1,6 +1,14 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/dict racket/private/generic-methods racket/struct)
(require racket/list
sugar/unstable/class
sugar/unstable/dict
sugar/unstable/js
racket/class
"private/helper.rkt"
"private/generic.rkt"
racket/dict
racket/private/generic-methods
racket/function)
(provide (all-defined-out) ref* ref*-set! (all-from-out racket/dict))
(require (prefix-in d: racket/dict))

@ -1,5 +1,7 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates

@ -1,6 +1,9 @@
#lang racket/base
(require "racket.rkt")
(require racket/match)
(require rackunit
xenomorph
sugar/unstable/dict
racket/list
racket/match)
#|
approximates
@ -20,7 +23,7 @@ https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee
(define bitfield (+Bitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack)))
(match-define (list JACK KACK LACK MACK NACK OACK PACK QUACK)
(map (curry arithmetic-shift 1) (range 8)))
(map (λ (x) (arithmetic-shift 1 x)) (range 8)))
; it 'should have the right size', ->
(check-equal? (size bitfield) 1)

@ -1,5 +1,7 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
sugar/unstable/dict)
#|

@ -1,5 +1,7 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates

@ -1,5 +1,8 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
sugar/unstable/dict
"../private/generic.rkt")
#|
approximates

@ -1,5 +1,4 @@
#lang racket/base
(require "racket.rkt")
(require "array-test.rkt"
"bitfield-test.rkt"

@ -1,5 +1,8 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
racket/class
sugar/unstable/dict)
#|

@ -1,5 +1,7 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates

@ -1,5 +1,10 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
sugar/unstable/js
sugar/unstable/dict
racket/class
"../private/helper.rkt")
#|
approximates

@ -1,6 +0,0 @@
#lang racket/base
(require rackunit xenomorph "../private/racket.rkt")
(provide (all-from-out rackunit xenomorph "../private/racket.rkt"))
(module reader syntax/module-reader
#:language 'xenomorph/test/racket)

@ -1,5 +1,7 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
sugar/unstable/dict)
#|
approximates

@ -1,5 +1,7 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
sugar/unstable/dict)
#|

@ -1,5 +1,10 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
racket/class
sugar/unstable/dict
sugar/unstable/js
"../private/generic.rkt")
#|
approximates

@ -1,5 +1,7 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
racket/class)
(define Person
(make-object Struct
@ -10,10 +12,10 @@
(define ip (open-input-bytes #"\4MikeA"))
(define x (send Person decode ip))
(test-module
(module+ test
(check-equal? (dict-ref x 'name) "Mike")
(check-equal? (dict-ref x 'age) 65))
;; encode a person from a hash
(test-module
(module+ test
(check-equal? (send Person encode #f (hasheq 'name "Mike" 'age 65)) #"\4MikeA"))

@ -1,5 +1,9 @@
#lang racket/base
(require "racket.rkt")
(require rackunit
xenomorph
racket/class
"../private/generic.rkt"
sugar/unstable/dict)
#|
approximates

@ -1,7 +1,9 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/class
"number.rkt"
"private/generic.rkt"
"private/helper.rkt")
(provide (all-defined-out))
(require "number.rkt")
(define (resolve-length len-arg [stream #f] [parent #f])
(cond

@ -1,6 +1,14 @@
#lang racket/base
(require "private/racket.rkt")
(require racket/dict "struct.rkt")
(require racket/class
racket/list
racket/function
sugar/unstable/class
sugar/unstable/dict
sugar/unstable/js
racket/dict
"struct.rkt"
"private/generic.rkt"
"private/helper.rkt")
(provide (all-defined-out))
#|

Loading…
Cancel
Save