├── .github └── workflows │ └── main.yml ├── .gitignore ├── LICENSE ├── README.md ├── base.scrbl ├── base ├── comparator.rkt ├── comparator.scrbl ├── converter.rkt ├── converter.scrbl ├── equivalence-relation.rkt ├── equivalence-relation.scrbl ├── generative-token.rkt ├── generative-token.scrbl ├── immutable-string.rkt ├── immutable-string.scrbl ├── impossible-function.rkt ├── impossible-function.scrbl ├── option.rkt ├── option.scrbl ├── option │ └── private │ │ └── guard.rkt ├── pair.rkt ├── pair.scrbl ├── range.rkt ├── range.scrbl ├── result.rkt ├── result.scrbl ├── symbol.rkt ├── symbol.scrbl ├── variant.rkt └── variant.scrbl ├── binary.scrbl ├── binary ├── bit.rkt ├── bit.scrbl ├── bitstring.rkt ├── bitstring.scrbl ├── byte.rkt ├── byte.scrbl ├── immutable-bytes.rkt └── immutable-bytes.scrbl ├── collection.rkt ├── collection.scrbl ├── collection ├── association-list.rkt ├── association-list.scrbl ├── choosing-collections.scrbl ├── entry.rkt ├── entry.scrbl ├── hash.rkt ├── hash.scrbl ├── immutable-vector.rkt ├── immutable-vector.scrbl ├── keyset.rkt ├── keyset.scrbl ├── keyset │ ├── low-dependency.rkt │ └── private │ │ └── reducer.rkt ├── list.rkt ├── list.scrbl ├── multidict.rkt ├── multidict.scrbl ├── multiset.rkt ├── multiset.scrbl ├── private │ ├── endpoint-map-complement.rkt │ ├── endpoint-map-range-set.rkt │ ├── mutable-red-black-tree-base.rkt │ ├── mutable-red-black-tree-batch-deletion.rkt │ ├── mutable-red-black-tree-batch-insertion.rkt │ ├── mutable-red-black-tree-clear-test.rkt │ ├── mutable-red-black-tree-deletion.rkt │ ├── mutable-red-black-tree-insertion.rkt │ ├── mutable-red-black-tree-iteration.rkt │ ├── mutable-red-black-tree-permutation-test.rkt │ ├── mutable-red-black-tree-regression-test.rkt │ ├── mutable-red-black-tree-search.rkt │ ├── mutable-red-black-tree.rkt │ ├── mutable-sorted-map.rkt │ ├── mutable-sorted-set.rkt │ ├── persistent-red-black-tree.rkt │ ├── persistent-sorted-map.rkt │ ├── persistent-sorted-set.rkt │ ├── range-set-interface.rkt │ ├── regular-immutable-sorted-map.rkt │ ├── regular-immutable-sorted-set.rkt │ ├── reversed-sorted-map.rkt │ ├── reversed-sorted-set.rkt │ ├── sorted-map-builder.rkt │ ├── sorted-map-entry-set.rkt │ ├── sorted-map-interface.rkt │ ├── sorted-map-key-set.rkt │ ├── sorted-set-builder.rkt │ ├── sorted-set-interface.rkt │ ├── sorted-submap.rkt │ ├── sorted-subset.rkt │ ├── synchronized-sorted-set.rkt │ ├── testing │ │ ├── literal-mutable-red-black-tree.rkt │ │ └── mutable-red-black-tree-invariants.rkt │ ├── unmodifiable-sorted-set.rkt │ └── vector-binary-search.rkt ├── range-set.rkt ├── range-set.scrbl ├── record.rkt ├── record.scrbl ├── set.rkt ├── set.scrbl ├── sorted-map-test.rkt ├── sorted-map.rkt ├── sorted-map.scrbl ├── sorted-set-test.rkt ├── sorted-set.rkt ├── sorted-set.scrbl ├── table.rkt ├── table.scrbl ├── vector.rkt ├── vector.scrbl └── vector │ ├── builder.rkt │ └── builder.scrbl ├── concurrency.scrbl ├── concurrency ├── atomic │ ├── boolean.rkt │ ├── boolean.scrbl │ ├── fixnum.rkt │ └── fixnum.scrbl ├── lock.rkt └── lock.scrbl ├── custom-write.rkt ├── custom-write.scrbl ├── equal+hash.rkt ├── equal+hash.scrbl ├── equal+hash └── struct.rkt ├── info.rkt ├── main.rkt ├── main.scrbl ├── media.rkt ├── media.scrbl ├── media ├── application │ ├── octet-stream.rkt │ └── octet-stream.scrbl └── text │ ├── plain.rkt │ └── plain.scrbl ├── module.scrbl ├── module ├── binding.rkt ├── binding.scrbl ├── phase.rkt └── phase.scrbl ├── other.scrbl ├── permutation.rkt ├── permutation.scrbl ├── point.rkt ├── point.scrbl ├── private ├── contract-projection.rkt ├── cut.rkt ├── for-body.rkt ├── impersonation.rkt ├── precondition.rkt ├── printer-markup.rkt ├── scribble-cross-document-tech.rkt ├── scribble-evaluator-factory.rkt ├── scribble-index-attribute.rkt ├── sequence-empty.rkt ├── static-name.rkt ├── strict-cond.rkt ├── subsequence.rkt ├── todo.rkt └── vector-merge-adjacent.rkt ├── setup ├── streaming.scrbl ├── streaming ├── reducer.rkt ├── reducer.scrbl ├── reducer │ └── private │ │ ├── base-test.rkt │ │ ├── base.rkt │ │ ├── zip-test.rkt │ │ └── zip.rkt ├── transducer.rkt ├── transducer.scrbl └── transducer │ ├── base.rkt │ ├── composition-test.rkt │ ├── composition.rkt │ ├── private.rkt │ ├── private │ ├── adding-between-test.rkt │ ├── adding-between.rkt │ ├── batching-test.rkt │ ├── batching.rkt │ ├── contract-test.rkt │ ├── contract.rkt │ ├── deduplicating-test.rkt │ ├── deduplicating.rkt │ ├── enumerating-test.rkt │ ├── enumerating.rkt │ ├── impersonation-test.rkt │ ├── reducer-test.rkt │ ├── reducer.rkt │ ├── shuffling-test.rkt │ ├── shuffling.rkt │ ├── sorting-test.rkt │ ├── sorting.rkt │ ├── splicing-between-test.rkt │ ├── splicing-between.rkt │ ├── taking-duplicates-test.rkt │ ├── taking-duplicates.rkt │ ├── taking-local-maxima-test.rkt │ ├── taking-local-maxima.rkt │ ├── taking-maxima-test.rkt │ ├── taking-maxima.rkt │ ├── transposing-test.rkt │ ├── transposing.rkt │ ├── windowing-test.rkt │ └── windowing.rkt │ └── testing.rkt ├── type.scrbl ├── type ├── enum.rkt ├── enum.scrbl ├── enum │ ├── base.rkt │ ├── binding-test.rkt │ ├── binding.rkt │ ├── descriptor.rkt │ └── private │ │ └── definition-macro.rkt ├── object.rkt ├── object.scrbl ├── object │ ├── base.rkt │ ├── binding-test.rkt │ ├── binding.rkt │ ├── descriptor.rkt │ └── private │ │ └── definition-macro.rkt ├── private │ └── naming.rkt ├── record.rkt ├── record.scrbl ├── record │ ├── base.rkt │ ├── binding-test.rkt │ ├── binding.rkt │ ├── descriptor.rkt │ └── private │ │ ├── definition-macro.rkt │ │ └── provide-transformer.rkt ├── singleton.rkt ├── singleton.scrbl ├── singleton │ ├── base.rkt │ ├── binding-test.rkt │ ├── binding.rkt │ ├── descriptor.rkt │ └── private │ │ └── definition-macro.rkt ├── struct.rkt ├── struct.scrbl ├── tuple.rkt ├── tuple.scrbl ├── tuple │ ├── base.rkt │ ├── binding-test.rkt │ ├── binding.rkt │ ├── descriptor.rkt │ └── private │ │ └── definition-macro.rkt ├── type-descriptor-printing-test.rkt ├── wrapper.rkt ├── wrapper.scrbl └── wrapper │ ├── base.rkt │ ├── binding-test.rkt │ ├── binding.rkt │ ├── descriptor.rkt │ └── private │ └── definition-macro.rkt ├── web-graph.rkt ├── web-graph.scrbl ├── web-link.rkt └── web-link.scrbl /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | racket-package-ci: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v1 10 | - uses: jackfirth/racket-package-ci-action@v0.1.4 11 | with: 12 | name: rebellion 13 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | compiled/ 2 | doc/ 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # rebellion [![CI Status][ci-status-badge]][ci-status] [![Documentation][docs-badge]][docs] 2 | 3 | Rebellion is a set of infrastructure libraries for Racketeers to build new languages, new frameworks, and new tools with. It is installable as a single package with `raco pkg install --auto rebellion` and provides dozens of modules to aid general-purpose programming. Most of these modules are grouped into the following collections: 4 | 5 | - [`rebellion/base`][rebellion-base] - Relatively simple utility modules used in the APIs of other Rebellion modules. 6 | - [`rebellion/collection`][rebellion-collection] - Collection types including records, tables, multidicts, and association lists. 7 | - [`rebellion/streaming`][rebellion-streaming] - Libraries for processing streams of data, including [reducers][rebellion-reducers] for aggregating streams into a single value and [transducers][rebellion-transducers] for transforming streams into other streams. 8 | - [`rebellion/type`][rebellion-type] - Libraries for dynamically creating new data types using structs. 9 | - [`rebellion/binary`][rebellion-binary] - Libraries for working with bits, bytes, and binary data, including the encoding and decoding of binary data into other forms. 10 | 11 | [ci-status]: https://github.com/jackfirth/rebellion/actions 12 | [ci-status-badge]: https://github.com/jackfirth/rebellion/workflows/CI/badge.svg 13 | [docs]: http://docs.racket-lang.org/rebellion/index.html 14 | [docs-badge]: https://img.shields.io/badge/docs-published-blue.svg 15 | [rebellion-base]: https://docs.racket-lang.org/rebellion/Base_Libraries.html 16 | [rebellion-binary]: https://docs.racket-lang.org/rebellion/Binary_Data.html 17 | [rebellion-collection]: https://docs.racket-lang.org/rebellion/Collections.html 18 | [rebellion-reducers]: https://docs.racket-lang.org/rebellion/Reducers.html 19 | [rebellion-streaming]: https://docs.racket-lang.org/rebellion/Streaming_Computations.html 20 | [rebellion-transducers]: https://docs.racket-lang.org/rebellion/Transducers.html 21 | [rebellion-type]: https://docs.racket-lang.org/rebellion/Data_Types.html 22 | -------------------------------------------------------------------------------- /base.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title[#:style (list 'toc)]{Base Libraries} 4 | 5 | @local-table-of-contents[] 6 | 7 | @include-section[(lib "rebellion/base/generative-token.scrbl")] 8 | @include-section[(lib "rebellion/base/immutable-string.scrbl")] 9 | @include-section[(lib "rebellion/base/impossible-function.scrbl")] 10 | @include-section[(lib "rebellion/base/option.scrbl")] 11 | @include-section[(lib "rebellion/base/pair.scrbl")] 12 | @include-section[(lib "rebellion/base/result.scrbl")] 13 | @include-section[(lib "rebellion/base/symbol.scrbl")] 14 | @include-section[(lib "rebellion/base/variant.scrbl")] 15 | @include-section[(lib "rebellion/base/converter.scrbl")] 16 | @include-section[(lib "rebellion/base/comparator.scrbl")] 17 | @include-section[(lib "rebellion/base/equivalence-relation.scrbl")] 18 | @include-section[(lib "rebellion/base/range.scrbl")] 19 | -------------------------------------------------------------------------------- /base/equivalence-relation.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [equivalence-relation? (-> any/c boolean?)] 8 | [make-equivalence-relation 9 | (->* ((-> any/c any/c boolean?)) 10 | (#:name (or/c interned-symbol? #f)) 11 | equivalence-relation?)] 12 | [equivalence-relation-holds? (-> equivalence-relation? any/c any/c boolean?)] 13 | [equivalence-relation-function 14 | (-> equivalence-relation? (-> any/c any/c boolean?))] 15 | [natural-equality equivalence-relation?] 16 | [object-identity-equality equivalence-relation?] 17 | [numeric-equality equivalence-relation?] 18 | [equivalence-relation-map 19 | (-> equivalence-relation? (-> any/c any/c) equivalence-relation?)])) 20 | 21 | (require rebellion/base/symbol 22 | rebellion/private/static-name 23 | rebellion/type/object) 24 | 25 | (module+ test 26 | (require (submod "..") 27 | rackunit)) 28 | 29 | ;@------------------------------------------------------------------------------ 30 | 31 | (define-object-type equivalence-relation (function) 32 | #:constructor-name constructor:equivalence-relation) 33 | 34 | (define (make-equivalence-relation function #:name [name #f]) 35 | (constructor:equivalence-relation #:function function #:name name)) 36 | 37 | (define (equivalence-relation-holds? relation x y) 38 | ((equivalence-relation-function relation) x y)) 39 | 40 | (define/name natural-equality 41 | (make-equivalence-relation equal? #:name enclosing-variable-name)) 42 | 43 | (define/name object-identity-equality 44 | (make-equivalence-relation eq? #:name enclosing-variable-name)) 45 | 46 | (define/name numeric-equality 47 | (make-equivalence-relation = #:name enclosing-variable-name)) 48 | 49 | (module+ test 50 | (struct foo (value) #:transparent) 51 | (define x (foo 1)) 52 | (define y (foo 1)) 53 | (define z (foo 2)) 54 | (test-case (name-string natural-equality) 55 | (check-true (equivalence-relation-holds? natural-equality x y)) 56 | (check-false (equivalence-relation-holds? natural-equality x z)) 57 | (check-false (equivalence-relation-holds? natural-equality 1 1.0)) 58 | (check-true (equivalence-relation-holds? natural-equality +nan.0 +nan.0))) 59 | (test-case (name-string object-identity-equality) 60 | (check-true (equivalence-relation-holds? object-identity-equality x x)) 61 | (check-false (equivalence-relation-holds? object-identity-equality x y))) 62 | (test-case (name-string numeric-equality) 63 | (check-true (equivalence-relation-holds? numeric-equality 1 1.0)) 64 | (check-true (equivalence-relation-holds? numeric-equality 0.0 -0.0)) 65 | (check-false (equivalence-relation-holds? numeric-equality 1 2)) 66 | (check-false (equivalence-relation-holds? numeric-equality +nan.0 +nan.0)))) 67 | 68 | (define (equivalence-relation-map relation f) 69 | (define original (equivalence-relation-function relation)) 70 | (make-equivalence-relation (λ (x y) (original (f x) (f y))))) 71 | 72 | (module+ test 73 | (test-case (name-string equivalence-relation-map) 74 | (define rel 75 | (equivalence-relation-map natural-equality string-length)) 76 | (check-true (equivalence-relation-holds? rel "foo" "bar")) 77 | (check-false (equivalence-relation-holds? rel "foo" "barrr")))) 78 | -------------------------------------------------------------------------------- /base/generative-token.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [generative-token? (-> any/c boolean?)] 8 | [make-generative-token (-> generative-token?)])) 9 | 10 | ;@------------------------------------------------------------------------------ 11 | 12 | (struct generative-token () #:constructor-name make-generative-token) 13 | -------------------------------------------------------------------------------- /base/generative-token.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | rebellion/base/generative-token) 6 | (submod rebellion/private/scribble-evaluator-factory doc) 7 | scribble/example) 8 | 9 | @(define make-evaluator 10 | (make-module-sharing-evaluator-factory 11 | #:public (list 'rebellion/base/generative-token) 12 | #:private (list 'racket/base))) 13 | 14 | @title{Generative Tokens} 15 | @defmodule[rebellion/base/generative-token] 16 | 17 | A @deftech{generative token} is a primitive data type for unique objects. Two 18 | generative tokens are only @racket[equal?] if they are @racket[eq?], and the 19 | constructor @racket[make-generative-token] always creates a new token that is 20 | not @racket[eq?] to any other token. Tokens contain no other data --- their only 21 | use is as a building block for creating other, more complex generative data 22 | types. 23 | 24 | @defproc[(generative-token? [v any/c]) boolean?]{ 25 | A predicate for @tech{generative tokens}.} 26 | 27 | @defproc[(make-generative-token) generative-token?]{ 28 | Constructs a new @tech{generative token} that is distinct from all other 29 | tokens. Multiple calls to @racket[make-generative-token] always yield multiple 30 | distinct tokens. 31 | 32 | @(examples 33 | #:eval (make-evaluator) #:once 34 | (define tok (make-generative-token)) 35 | tok 36 | (equal? tok tok) 37 | (equal? tok (make-generative-token)))} 38 | -------------------------------------------------------------------------------- /base/impossible-function.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [impossible (-> none/c any/c)])) 8 | 9 | ;@------------------------------------------------------------------------------ 10 | 11 | (struct exn:fail:impossible exn:fail () #:transparent) 12 | 13 | (define (impossible _) 14 | (raise (exn:fail:impossible "This should be impossible" 15 | (current-continuation-marks)))) 16 | -------------------------------------------------------------------------------- /base/impossible-function.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | rebellion/base/impossible-function 6 | rebellion/collection/list) 7 | (submod rebellion/private/scribble-cross-document-tech doc) 8 | (submod rebellion/private/scribble-evaluator-factory doc) 9 | scribble/example) 10 | 11 | @(define make-evaluator 12 | (make-module-sharing-evaluator-factory 13 | #:public (list 'rebellion/base/impossible-function 14 | 'rebellion/collection/list) 15 | #:private (list 'racket/base))) 16 | 17 | @title{Uncallable Functions} 18 | @defmodule[rebellion/base/impossible-function] 19 | 20 | @defproc[(impossible [v none/c]) any/c]{ 21 | The impossible function. Calling @racket[impossible] with any input always 22 | raises an error, because it is impossible for @racket[v] to satisfy the 23 | @racket[none/c] @tech/reference{contract}. 24 | 25 | @(examples 26 | #:eval (make-evaluator) 27 | (eval:error (impossible 42))) 28 | 29 | This function is useful as an argument to higher-order functions where you know 30 | the function will not be called. For example, mapping the impossible function 31 | over an empty list will succeed without error: 32 | 33 | @(examples 34 | #:eval (make-evaluator) 35 | (map impossible empty-list))} 36 | -------------------------------------------------------------------------------- /base/option/private/guard.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide guard-present) 4 | 5 | (require (for-syntax racket/base 6 | racket/syntax) 7 | guard 8 | racket/block 9 | rebellion/base/option 10 | syntax/parse/define) 11 | 12 | (module+ test 13 | (require (submod "..") 14 | rackunit)) 15 | 16 | ;@---------------------------------------------------------------------------------------------------- 17 | 18 | (begin-for-syntax 19 | ;; This is used to give the generated identifiers readable names, and to make it clear which 20 | ;; option identifiers are associated with which present value identifiers. We could just use an 21 | ;; identifier like "tmp" for all of them (because macro hygiene will ensure the right one gets used) 22 | ;; but deriving the option name from the identifier given to guard-present makes it easier for users 23 | ;; to understand the generated code in the macro stepper. 24 | (define (make-option-id present-id) 25 | (format-id #'here "~a-option" present-id))) 26 | 27 | (define-syntax-parser guard-present 28 | #:track-literals 29 | 30 | [(_ id:id expr #:else ~! body:expr ...+) 31 | #:declare expr (expr/c #'option?) 32 | #:with id-option (make-option-id #'id) 33 | #'(begin 34 | (define id-option expr.c) 35 | (guard (present? id-option) #:else body ...) 36 | (define id (present-value id-option)))] 37 | 38 | [(_ id:id expr) 39 | #:declare expr (expr/c #'option?) 40 | #:with id-option (make-option-id #'id) 41 | #'(begin 42 | (define id-option expr.c) 43 | (guard (present? id-option) #:else 44 | (raise-arguments-error 'guard-present "expected a present option")) 45 | (define id (present-value id-option)))]) 46 | 47 | (module+ test 48 | (test-case "guard-present" 49 | 50 | (test-case "else case" 51 | (define/guard (run opt) 52 | (guard-present v opt #:else #false) 53 | v) 54 | (check-equal? (run (present 4)) 4) 55 | (check-false (run absent))) 56 | 57 | (test-case "else raise case" 58 | (define/guard (run opt) 59 | (guard-present v opt) 60 | v) 61 | (check-equal? (run (present 4)) 4) 62 | (check-exn exn:fail:contract? (λ () (run absent))) 63 | (check-exn #rx"guard-present:" (λ () (run absent))) 64 | (check-exn #rx"expected a present option" (λ () (run absent)))) 65 | 66 | (test-case "hygiene" 67 | (define foo-option "other binding") 68 | (check-equal? 69 | (guarded-block 70 | (guard-present foo (present 4)) 71 | foo-option) 72 | "other binding") 73 | (check-equal? 74 | (guarded-block 75 | (guard-present foo absent #:else foo-option) 76 | foo) 77 | "other binding")))) 78 | -------------------------------------------------------------------------------- /base/pair.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [pair (-> any/c any/c any/c)] 8 | [pair? (-> any/c boolean?)] 9 | [pair-first (-> pair? any/c)] 10 | [pair-second (-> pair? any/c)])) 11 | 12 | (require rebellion/type/tuple) 13 | 14 | ;@------------------------------------------------------------------------------ 15 | 16 | (define-tuple-type pair (first second)) 17 | -------------------------------------------------------------------------------- /base/pair.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label (except-in racket/base pair?) 4 | racket/contract/base 5 | rebellion/base/pair) 6 | (submod rebellion/private/scribble-evaluator-factory doc) 7 | scribble/example) 8 | 9 | @(define make-evaluator 10 | (make-module-sharing-evaluator-factory 11 | #:public (list 'rebellion/base/pair) 12 | #:private (list 'racket/base))) 13 | 14 | @title{Pairs} 15 | @defmodule[rebellion/base/pair] 16 | 17 | A @deftech{pair} is a container of two values. Pairs as defined by 18 | @racketmodname[rebellion/base/pair] are distinct from the pair datatype defined by 19 | @racketmodname[racket/base], and are meant to be a drop-in replacement for them. 20 | Changes include: 21 | 22 | @itemlist[ 23 | @item{@racket[cons] is spelled @racket[pair]} 24 | @item{@racket[car] is spelled @racket[pair-first]} 25 | @item{@racket[cdr] is spelled @racket[pair-second]} 26 | @item{@racket[list?] does not imply @racket[pair?]} 27 | @item{@racket[(pair 1 2)] writes as @literal{(pair 1 2)} instead of 28 | @literal{(1 . 2)}}] 29 | 30 | Note that @racketmodname[rebellion/base/pair] provides a @racket[pair?] predicate 31 | that conflicts with the one provided by @racketmodname[racket/base]. 32 | 33 | @defproc[(pair? [v any/c]) boolean?]{ 34 | A predicate for @tech{pairs}, as defined by @racketmodname[rebellion/base/pair]. 35 | Mututally exclusive with @racket[list?]. 36 | 37 | @(examples 38 | #:eval (make-evaluator) #:once 39 | (pair? (pair 1 2)) 40 | (list? (pair 1 2)) 41 | (require (only-in racket/base cons)) 42 | (pair? (cons 1 2)))} 43 | 44 | @defproc[(pair [first any/c] [second any/c]) pair?]{ 45 | Constructs a @tech{pair}.} 46 | 47 | @defproc[(pair-first [p pair?]) any/c]{ 48 | Returns the first value of @racket[p].} 49 | 50 | @defproc[(pair-second [p pair?]) any/c]{ 51 | Returns the second value of @racket[p].} 52 | -------------------------------------------------------------------------------- /base/symbol.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [interned-symbol? (-> any/c boolean?)] 8 | [uninterned-symbol? (-> any/c boolean?)] 9 | [unreadable-symbol? (-> any/c boolean?)])) 10 | 11 | (module+ test 12 | (require (submod "..") 13 | rackunit)) 14 | 15 | ;@------------------------------------------------------------------------------ 16 | 17 | (define (interned-symbol? v) (and (symbol? v) (symbol-interned? v))) 18 | (define (unreadable-symbol? v) (and (symbol? v) (symbol-unreadable? v))) 19 | 20 | (define (uninterned-symbol? v) 21 | (and (symbol? v) 22 | (not (symbol-interned? v)) 23 | (not (symbol-unreadable? v)))) 24 | 25 | (module+ test 26 | (test-case "symbol-predicates" 27 | (define x 'interned) 28 | (define y (string->unreadable-symbol "unreadable")) 29 | (define z (string->uninterned-symbol "uninterned")) 30 | (test-case "interned-symbol?" 31 | (check-true (interned-symbol? x)) 32 | (check-false (interned-symbol? y)) 33 | (check-false (interned-symbol? z)) 34 | (check-false (interned-symbol? 42))) 35 | (test-case "unreadable-symbol?" 36 | (check-false (unreadable-symbol? x)) 37 | (check-true (unreadable-symbol? y)) 38 | (check-false (unreadable-symbol? z)) 39 | (check-false (unreadable-symbol? 42))) 40 | (test-case "uninterned-symbol?" 41 | (check-false (uninterned-symbol? x)) 42 | (check-false (uninterned-symbol? y)) 43 | (check-true (uninterned-symbol? z)) 44 | (check-false (uninterned-symbol? 42))))) 45 | -------------------------------------------------------------------------------- /base/symbol.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | rebellion/base/symbol)) 6 | 7 | @title{Symbols} 8 | @defmodule[rebellion/base/symbol] 9 | 10 | @defproc[(interned-symbol? [v any/c]) boolean?] 11 | 12 | @defproc[(unreadable-symbol? [v any/c]) boolean?] 13 | 14 | @defproc[(unininterned-symbol? [v any/c]) boolean?] 15 | -------------------------------------------------------------------------------- /base/variant.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | racket/contract/region 6 | racket/match 7 | rebellion/base/variant) 8 | (submod rebellion/private/scribble-cross-document-tech doc) 9 | (submod rebellion/private/scribble-evaluator-factory doc) 10 | scribble/example) 11 | 12 | @(define make-evaluator 13 | (make-module-sharing-evaluator-factory 14 | #:public (list 'racket/match 15 | 'racket/contract/base 16 | 'racket/contract/region 17 | 'rebellion/base/variant) 18 | #:private (list 'racket/base))) 19 | 20 | @title{Variants} 21 | @defmodule[rebellion/base/variant] 22 | 23 | A @deftech{variant} is a value tagged with a keyword. Variants are used to 24 | distinguish different kinds of values by name, without knowing anything about 25 | the types of those values. 26 | 27 | @defproc[(variant? [v any/c]) variant?]{ 28 | A predicate for @tech{variants}.} 29 | 30 | @defproc[(variant [#: v any/c]) variant?]{ 31 | Constructs a @tech{variant} containing @racket[v] tagged with the given 32 | keyword, where @racket[#:] stands for any keyword. 33 | 34 | @(examples 35 | #:eval (make-evaluator) #:once 36 | (variant #:success 42) 37 | (variant #:failure "oops")) 38 | 39 | Additionally, the @racket[variant] constructor may be used as a 40 | @tech/reference{match expander}. 41 | 42 | @(examples 43 | #:eval (make-evaluator) #:once 44 | (eval:no-prompt 45 | (define (try-add1 v) 46 | (match v 47 | [(variant #:success x) (add1 x)] 48 | [(variant #:failure msg) (error msg)]))) 49 | 50 | (try-add1 (variant #:success 42)) 51 | (eval:error (try-add1 (variant #:failure "oops"))))} 52 | 53 | @defproc[(variant-value [var variant?]) any/c]{ 54 | Returns the value contained in @racket[var]. 55 | 56 | @(examples 57 | #:eval (make-evaluator) #:once 58 | (variant-value (variant #:success 42)) 59 | (variant-value (variant #:failure "oops")))} 60 | 61 | @defproc[(variant-tag [var variant?]) keyword?]{ 62 | Returns the tag keyword of @racket[var]. 63 | 64 | @(examples 65 | #:eval (make-evaluator) #:once 66 | (variant-tag (variant #:success 42)) 67 | (variant-tag (variant #:failure "oops")))} 68 | 69 | @defproc[(variant-tagged-as? [var variant?] [tag-keyword keyword?]) boolean?]{ 70 | Returns @racket[#t] if @racket[var] is tagged with @racket[tag-keyword], 71 | returns @racket[#f] otherwise. 72 | 73 | @(examples 74 | #:eval (make-evaluator) #:once 75 | (variant-tagged-as? (variant #:success 42) '#:success) 76 | (variant-tagged-as? (variant #:success 42) '#:failure))} 77 | 78 | @defproc[(variant/c [#: case-contract contract?] ...) contract?]{ 79 | A @tech/reference{contract combinator} for @tech{variants}. Returns a contract 80 | that enforces that the contracted value is a variant tagged with one of the 81 | given @racket[#:]s. If it is, then the corresponding @racket[case-contract] 82 | is used to check the variant's value. If every @racket[case-contract] is a 83 | @tech/reference{flat contract} then the returned contract is as well, and 84 | likewise for @tech/reference{chaperone contracts}. 85 | 86 | @(examples 87 | #:eval (make-evaluator) #:once 88 | (eval:no-prompt 89 | (define/contract (get-success-or-zero var) 90 | (-> (variant/c #:success number? #:failure string?) number?) 91 | (match var 92 | [(variant #:success x) x] 93 | [(variant #:failure _) 0]))) 94 | 95 | (get-success-or-zero (variant #:success 42)) 96 | (eval:error (get-success-or-zero (variant #:success "not a number"))) 97 | (eval:error (get-success-or-zero (variant #:other "whoops"))))} 98 | -------------------------------------------------------------------------------- /binary.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title[#:style (list 'toc)]{Binary Data} 4 | 5 | @local-table-of-contents[] 6 | 7 | @include-section[(lib "rebellion/binary/bit.scrbl")] 8 | @include-section[(lib "rebellion/binary/bitstring.scrbl")] 9 | @include-section[(lib "rebellion/binary/byte.scrbl")] 10 | @include-section[(lib "rebellion/binary/immutable-bytes.scrbl")] 11 | -------------------------------------------------------------------------------- /binary/bit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [bit? (-> any/c boolean?)] 8 | [bit->boolean (-> bit? boolean?)] 9 | [boolean->bit (-> boolean? bit?)])) 10 | 11 | (module+ test 12 | (require (submod "..") 13 | rackunit 14 | rebellion/private/static-name)) 15 | 16 | ;@------------------------------------------------------------------------------ 17 | 18 | (define (bit? v) (or (zero? v) (equal? v 1))) 19 | 20 | (define (bit->boolean b) (equal? b 1)) 21 | (define (boolean->bit b) (if b 1 0)) 22 | 23 | (module+ test 24 | (test-case (name-string bit->boolean) 25 | (check-false (bit->boolean 0)) 26 | (check-true (bit->boolean 1))) 27 | (test-case (name-string boolean->bit) 28 | (check-equal? (boolean->bit #false) 0) 29 | (check-equal? (boolean->bit #true) 1))) 30 | -------------------------------------------------------------------------------- /binary/bit.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | rebellion/binary/bit) 6 | (submod rebellion/private/scribble-evaluator-factory doc) 7 | scribble/example) 8 | 9 | @(define make-evaluator 10 | (make-module-sharing-evaluator-factory 11 | #:public (list 'rebellion/binary/bit) 12 | #:private (list 'racket/base))) 13 | 14 | @title{Bits} 15 | @defmodule[rebellion/binary/bit] 16 | 17 | A @deftech{bit} is either zero or one. Eight bits form a @tech{byte}, and a 18 | @tech{bitstring} is an arbitrary-length sequence of bits. 19 | 20 | @defproc[(bit? [v any/c]) boolean?]{ 21 | A predicate for @tech{bits}.} 22 | 23 | @defproc[(bit->boolean [b bit?]) boolean?]{ 24 | Converts zero to false and one to true. 25 | 26 | @(examples 27 | #:eval (make-evaluator) #:once 28 | (bit->boolean 0) 29 | (bit->boolean 1))} 30 | 31 | @defproc[(boolean->bit [bool boolean?]) bit?]{ 32 | Converts true to one and false to zero. 33 | 34 | @(examples 35 | #:eval (make-evaluator) #:once 36 | (boolean->bit #true) 37 | (boolean->bit #false))} 38 | -------------------------------------------------------------------------------- /collection.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | -------------------------------------------------------------------------------- /collection/choosing-collections.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label rebellion/collection) 4 | (submod rebellion/private/scribble-cross-document-tech doc)) 5 | 6 | @title[#:tag "choosing-collections"]{Choosing Collections} 7 | 8 | The modules in @racketmodname[rebellion/collection] provide a wide selection of 9 | different collections. Choosing the right one can be tricky, so this document 10 | aims to make that decision easier. Treat this as @emph{guidance} rather than 11 | @emph{rules} --- the lines between collection types are blurry and can shift 12 | with circumstance. 13 | 14 | @section{To Key or Not to Key} 15 | 16 | The first question you should ask yourself is, do the items of this collection 17 | have keys? Can items be looked up by key? If so, you have a @deftech{ 18 | dictionary-like collection}, also called a @deftech{bicollection}. There are 19 | many different kinds of bicollections that vary in whether or not keys are 20 | unique, whether entries are unordered, ordered, or sorted, and whether any type 21 | of value can serve as a key or only certain types of values. Bicollections can 22 | usually be viewed as a collection of key-value @tech{entries}. 23 | 24 | @tabular[ 25 | #:style 'boxed 26 | #:column-properties 27 | (list (list 'center 'left-border 'right-border) (list 'center 'right-border)) 28 | #:row-properties (list 'bottom-border '() '() '() '() 'bottom-border) 29 | #:cell-properties (list (list 'vcenter)) 30 | (list (list @bold{Bicollections} @bold{Not bicollections}) 31 | (list @tech/reference{Hash tables} @tech/reference{Lists}) 32 | (list @tech/reference{Dictionaries} @tech/reference{Sets}) 33 | (list @tech{Multidicts} @tech{Multisets}) 34 | (list @tech{Association lists} @tech{Keysets}) 35 | (list @tech{Records} @tech{Tables}))] 36 | 37 | @section{Collection Cheat Sheet} 38 | 39 | @tabular[ 40 | #:style 'boxed 41 | (list 42 | (list @italic{Instead of using...} @italic{Consider using...}) 43 | (list 44 | @elem{An unordered @tech/reference{list} with no duplicates} 45 | @elem{A @tech/reference{set}}) 46 | 47 | (list 48 | @elem{An unordered @tech/reference{list}} 49 | @elem{A @tech{multiset}}) 50 | 51 | (list 52 | @elem{A @tech/reference{hash} whose values are always @racket[#true]} 53 | @elem{A @tech/reference{set}}) 54 | 55 | (list 56 | @elem{A @tech/reference{hash} whose values are nonempty @tech/reference{ 57 | sets}} 58 | @elem{A @tech{multidict}}) 59 | 60 | (list 61 | @elem{A @tech/reference{hash} whose values are nonempty @tech/reference{ 62 | lists}} 63 | @elem{An @tech{association list}}) 64 | 65 | (list 66 | @elem{A @tech/reference{hash} whose values are positive integers representing 67 | frequencies} 68 | @elem{A @tech{multiset}}) 69 | 70 | (list 71 | @elem{An unordered @tech/reference{list} of key-value pairs with no duplicate 72 | keys} 73 | @elem{A @tech/reference{hash}}) 74 | 75 | (list 76 | @elem{An unordered @tech/reference{list} of key-value pairs} 77 | @elem{A @tech{multidict}}) 78 | 79 | (list 80 | @elem{A @tech/reference{list} of key-value pairs where order is significant} 81 | @elem{An @tech{association list}}) 82 | 83 | (list 84 | @elem{A @tech/reference{list} or @tech/reference{set} of keywords or symbols} 85 | @elem{A @tech{keyset}}) 86 | 87 | (list 88 | @elem{A @tech/reference{hash} whose keys are symbols or strings} 89 | @elem{A @tech{record}}) 90 | 91 | (list 92 | @elem{A @tech/reference{list} of symbol-keyed @tech/reference{hash}es} 93 | @elem{A @tech{table}}))] 94 | -------------------------------------------------------------------------------- /collection/keyset.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rebellion/collection/keyset/low-dependency 4 | rebellion/collection/keyset/private/reducer) 5 | 6 | (provide (all-from-out rebellion/collection/keyset/low-dependency 7 | rebellion/collection/keyset/private/reducer)) 8 | -------------------------------------------------------------------------------- /collection/keyset/private/reducer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | for/keyset 7 | for*/keyset 8 | (contract-out 9 | [into-keyset (reducer/c keyword? keyset?)])) 10 | 11 | (require (for-syntax racket/base) 12 | rebellion/collection/keyset/low-dependency 13 | rebellion/collection/list 14 | rebellion/streaming/reducer) 15 | 16 | (module+ test 17 | (require (submod "..") 18 | rackunit)) 19 | 20 | ;@------------------------------------------------------------------------------ 21 | 22 | (define into-keyset 23 | (reducer-map into-reversed-list #:range list->keyset)) 24 | 25 | (define-syntaxes (for/keyset for*/keyset) 26 | (make-reducer-based-for-comprehensions #'into-keyset)) 27 | 28 | (module+ test 29 | (test-case "into-keyset" 30 | (define strings (list "banana" "grape" "apple" "orange")) 31 | (check-equal? (for/keyset ([str (in-list strings)]) (string->keyword str)) 32 | (keyset #:apple #:banana #:grape #:orange)))) 33 | -------------------------------------------------------------------------------- /collection/list.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [empty-list empty-list?] 8 | [empty-list? (-> any/c boolean?)] 9 | [nonempty-list? (-> any/c boolean?)] 10 | [list-insert (-> list? any/c nonempty-list?)] 11 | [list-first (-> nonempty-list? any/c)] 12 | [list-rest (-> nonempty-list? list?)] 13 | [list-append (-> list? ... list?)] 14 | [list-size (-> list? natural?)] 15 | [list-ref-safe (-> list? natural? option?)] 16 | [list-contains? (-> list? any/c boolean?)] 17 | [list-reverse (-> list? list?)] 18 | [into-list (reducer/c any/c list?)] 19 | [into-reversed-list (reducer/c any/c list?)] 20 | [append-into-list (reducer/c list? list?)])) 21 | 22 | (require guard 23 | racket/math 24 | rebellion/base/option 25 | rebellion/streaming/reducer) 26 | 27 | (module+ test 28 | (require (submod "..") 29 | rackunit)) 30 | 31 | ;@------------------------------------------------------------------------------ 32 | 33 | (define empty-list (list)) 34 | (define (empty-list? v) (and (list? v) (equal? v empty-list))) 35 | (define (nonempty-list? v) (and (list? v) (not (equal? v empty-list)))) 36 | 37 | (define (list-size lst) (length lst)) 38 | (define (list-insert lst v) (cons v lst)) 39 | (define (list-first lst) (car lst)) 40 | (define (list-rest lst) (cdr lst)) 41 | (define (list-append . lsts) (apply append lsts)) 42 | (define (list-reverse lst) (reverse lst)) 43 | (define (list-contains? lst v) (not (not (member v lst)))) 44 | 45 | (define (list-ref-safe lst pos) 46 | (define/guard (loop lst pos) 47 | (guard (nonempty-list? lst) #:else 48 | absent) 49 | (guard (zero? pos) #:else 50 | (loop (list-rest lst) (sub1 pos))) 51 | (present (list-first lst))) 52 | (loop lst pos)) 53 | 54 | (define into-list 55 | (make-effectful-fold-reducer list-insert 56 | (λ () empty-list) 57 | list-reverse 58 | #:name 'into-list)) 59 | 60 | (define into-reversed-list 61 | (make-fold-reducer list-insert empty-list #:name 'into-reversed-list)) 62 | 63 | (define append-into-list 64 | (reducer-map into-list #:range (λ (lst) (apply list-append lst)))) 65 | 66 | (module+ test 67 | (test-case "list-ref-safe" 68 | (define lst (list 'a 'b 'c)) 69 | (check-equal? (list-ref-safe lst 0) (present 'a)) 70 | (check-equal? (list-ref-safe lst 2) (present 'c)) 71 | (check-equal? (list-ref-safe lst 3) absent)) 72 | (test-case "list-contains?" 73 | (check-true (list-contains? (list 1 2 3) 1)) 74 | (check-true (list-contains? (list 1 2 3) 2)) 75 | (check-true (list-contains? (list 1 2 3) 3)) 76 | (check-false (list-contains? (list 1 2 3) 4))) 77 | (test-case "empty-lists" 78 | (check-pred empty-list? empty-list) 79 | (check-pred empty-list? (list)) 80 | (check-pred nonempty-list? (list 1 2 3)) 81 | (check-false (empty-list? (list 1 2 3))) 82 | (check-false (nonempty-list? empty-list)) 83 | (check-false (nonempty-list? (list)))) 84 | (test-case "into-list" 85 | (check-equal? (reduce into-list 1 2 3 4 5) (list 1 2 3 4 5)) 86 | (check-equal? (reduce into-list) empty-list)) 87 | (test-case "into-reversed-list" 88 | (check-equal? (reduce into-reversed-list 1 2 3 4 5) (list 5 4 3 2 1)) 89 | (check-equal? (reduce into-reversed-list) empty-list)) 90 | (test-case "append-into-list" 91 | (check-equal? (reduce append-into-list 92 | (list 1 2 3) 93 | (list 'a 'b) 94 | empty-list 95 | (list 'foo) 96 | (list 4 5 6 7 8)) 97 | (list 1 2 3 'a 'b 'foo 4 5 6 7 8)))) 98 | -------------------------------------------------------------------------------- /collection/private/mutable-red-black-tree-batch-deletion.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [mutable-rb-subtree-clear! (-> mutable-rb-tree? range? void?)])) 10 | 11 | 12 | (require racket/sequence 13 | rebellion/base/range 14 | rebellion/collection/private/mutable-red-black-tree-base 15 | rebellion/collection/private/mutable-red-black-tree-deletion 16 | rebellion/collection/private/mutable-red-black-tree-iteration) 17 | 18 | 19 | ;@---------------------------------------------------------------------------------------------------- 20 | 21 | 22 | (define (mutable-rb-subtree-clear! tree key-range) 23 | ;; There's definitely a faster algorithm for this than just collecting all the elements into a list 24 | ;; and removing them one at a time. But this works fine for now, and it has the advantages of being 25 | ;; simple, easy to implement, and obviously correct. 26 | (define keys (sequence->list (in-mutable-rb-subtree-keys tree key-range))) 27 | ;; It's important that we don't remove keys and iterate over the tree at the same time, as tree 28 | ;; rotations could invalidate assumptions the tree iteration code is making. By collecting the keys 29 | ;; into a list and then iterating over the list, we ensure everything is in a consistent state. 30 | (for ([key (in-list keys)]) 31 | (mutable-rb-tree-remove! tree key))) 32 | -------------------------------------------------------------------------------- /collection/private/mutable-red-black-tree-batch-insertion.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [mutable-rb-tree-put-all! (-> mutable-rb-tree? (sequence/c entry?) #:who interned-symbol? void?)])) 10 | 11 | 12 | (require racket/match 13 | racket/sequence 14 | rebellion/base/option 15 | rebellion/base/symbol 16 | rebellion/collection/entry 17 | rebellion/collection/private/mutable-red-black-tree-base 18 | rebellion/collection/private/mutable-red-black-tree-insertion 19 | rebellion/collection/private/mutable-red-black-tree-iteration 20 | rebellion/collection/private/mutable-red-black-tree-search) 21 | 22 | 23 | ;@---------------------------------------------------------------------------------------------------- 24 | 25 | 26 | (define (mutable-rb-tree-put-all! tree entries #:who who) 27 | (define unique-entries (make-mutable-rb-tree (mutable-rb-tree-key-comparator tree))) 28 | (for ([e entries]) 29 | (match-define (entry key value) e) 30 | (match (mutable-rb-tree-get-option unique-entries key) 31 | [(present first-value) 32 | (raise-arguments-error 33 | who 34 | "cannot batch insert entries, entry batch contain duplicate keys" 35 | "key" key 36 | "first value" first-value 37 | "duplicate value" value)] 38 | [(== absent) 39 | (mutable-rb-tree-put! unique-entries key value)])) 40 | ;; This could be much faster since we're combining two red-black trees and there exist efficient 41 | ;; algorithms for that. But that's complicated and the naive approach is obviously correct. Future 42 | ;; work may optimize this but the simple and correct approach is fine for now. 43 | (for ([e (in-mutable-rb-tree unique-entries)]) 44 | (mutable-rb-tree-put! tree (entry-key e) (entry-value e)))) 45 | -------------------------------------------------------------------------------- /collection/private/mutable-red-black-tree-clear-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (module+ test 5 | (require racket/sequence 6 | rackunit 7 | rebellion/base/comparator 8 | rebellion/collection/private/mutable-red-black-tree-base 9 | rebellion/collection/private/mutable-red-black-tree-insertion 10 | rebellion/collection/private/mutable-red-black-tree-iteration 11 | (submod rebellion/collection/private/testing/mutable-red-black-tree-invariants test) 12 | rebellion/private/static-name)) 13 | 14 | 15 | (module+ test 16 | (test-case (name-string mutable-rb-tree-clear!) 17 | 18 | (test-case "clear should do nothing to an empty tree" 19 | (define tree (make-mutable-rb-tree natural<=>)) 20 | (mutable-rb-tree-clear! tree) 21 | (define entries (sequence->list (in-mutable-rb-tree tree))) 22 | (check-equal? entries '())) 23 | 24 | (test-case "clear should remove all elements from a tree" 25 | (define tree (make-mutable-rb-tree natural<=>)) 26 | (mutable-rb-tree-put! tree 1 'a) 27 | (mutable-rb-tree-put! tree 2 'b) 28 | (mutable-rb-tree-put! tree 3 'c) 29 | (mutable-rb-tree-clear! tree) 30 | (check-mutable-rb-tree-invariants tree) 31 | (define entries (sequence->list (in-mutable-rb-tree tree))) 32 | (check-equal? entries '())) 33 | 34 | (test-case "clear should set size to zero" 35 | (define tree (make-mutable-rb-tree natural<=>)) 36 | (mutable-rb-tree-put! tree 1 'a) 37 | (mutable-rb-tree-put! tree 2 'b) 38 | (mutable-rb-tree-put! tree 3 'c) 39 | (mutable-rb-tree-clear! tree) 40 | (check-mutable-rb-tree-invariants tree) 41 | (check-equal? (mutable-rb-tree-size tree) 0)))) 42 | -------------------------------------------------------------------------------- /collection/private/mutable-red-black-tree-permutation-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (module+ test 5 | (require racket/list 6 | racket/sequence 7 | rackunit 8 | rebellion/base/comparator 9 | rebellion/collection/private/mutable-red-black-tree-base 10 | rebellion/collection/private/mutable-red-black-tree-deletion 11 | rebellion/collection/private/mutable-red-black-tree-insertion 12 | rebellion/collection/private/mutable-red-black-tree-iteration 13 | (submod rebellion/collection/private/testing/mutable-red-black-tree-invariants test))) 14 | 15 | 16 | ;@---------------------------------------------------------------------------------------------------- 17 | 18 | 19 | (module+ test 20 | 21 | (test-case "permutation test" 22 | (for* ([max-size (in-range 1 6)] 23 | [keys (in-value (range 1 (add1 max-size)))] 24 | [insertion-order (in-permutations keys)] 25 | [deletion-order (in-permutations keys)]) 26 | (define tree (make-mutable-rb-tree natural<=>)) 27 | (with-check-info (['tree tree]) 28 | 29 | (for/fold ([inserted-keys '()] 30 | #:result (void)) 31 | ([key (in-list insertion-order)] 32 | [inserted-key-count (in-naturals 1)]) 33 | (mutable-rb-tree-put! tree key #false) 34 | (let ([inserted-keys (append inserted-keys (list key))]) 35 | (with-check-info (['inserted-keys inserted-keys]) 36 | 37 | (check-mutable-rb-tree-invariants tree) 38 | 39 | (check-equal? 40 | (sequence->list (in-mutable-rb-tree-keys tree)) 41 | (sort inserted-keys <) 42 | "inserted keys should appear in sorted order when the tree is iterated") 43 | 44 | (check-equal? (mutable-rb-tree-size tree) inserted-key-count 45 | "inserting a key should increase the tree's size") 46 | 47 | inserted-keys))) 48 | 49 | (with-check-info (['inserted-keys insertion-order]) 50 | (for/fold ([remaining-keys keys] 51 | [deleted-keys '()] 52 | #:result (void)) 53 | ([key (in-list deletion-order)] 54 | [deleted-key-count (in-naturals 1)]) 55 | (with-check-info (['deleted-keys deleted-keys] 56 | ['next-deleted-key key]) 57 | (mutable-rb-tree-remove! tree key)) 58 | (let ([remaining-keys (remove key remaining-keys)] 59 | [deleted-keys (append deleted-keys (list key))]) 60 | (with-check-info (['deleted-keys deleted-keys]) 61 | 62 | (check-mutable-rb-tree-invariants tree) 63 | 64 | (check-equal? (sequence->list (in-mutable-rb-tree-keys tree)) remaining-keys 65 | "removed keys should no longer appear when the tree is iterated") 66 | 67 | (check-equal? (mutable-rb-tree-size tree) (- max-size deleted-key-count) 68 | "removing a key should decrease the tree's size") 69 | 70 | (values remaining-keys deleted-keys))))))))) 71 | -------------------------------------------------------------------------------- /collection/private/mutable-red-black-tree-regression-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (module+ test 5 | (require racket/sequence 6 | rackunit 7 | rebellion/base/comparator 8 | rebellion/collection/private/mutable-red-black-tree-base 9 | rebellion/collection/private/mutable-red-black-tree-insertion 10 | rebellion/collection/private/mutable-red-black-tree-iteration 11 | rebellion/collection/private/mutable-red-black-tree-deletion 12 | (submod rebellion/collection/private/testing/mutable-red-black-tree-invariants test))) 13 | 14 | 15 | ;@---------------------------------------------------------------------------------------------------- 16 | 17 | 18 | (module+ test 19 | (test-case "regression test #509" 20 | ;; See https://github.com/jackfirth/rebellion/issues/509 21 | (define tree (make-mutable-rb-tree real<=>)) 22 | (mutable-rb-tree-put! tree 4 #false) 23 | (mutable-rb-tree-put! tree 6 #false) 24 | (mutable-rb-tree-put! tree 7 #false) 25 | (mutable-rb-tree-put! tree 5 #false) 26 | (mutable-rb-tree-put! tree 1 #false) 27 | (mutable-rb-tree-put! tree 2 #false) 28 | (mutable-rb-tree-put! tree 3 #false) 29 | (mutable-rb-tree-remove! tree 6) 30 | (mutable-rb-tree-remove! tree 7) 31 | (check-mutable-rb-tree-invariants tree) 32 | (check-equal? (sequence->list (in-mutable-rb-tree-keys tree)) (list 1 2 3 4 5)))) 33 | -------------------------------------------------------------------------------- /collection/private/mutable-red-black-tree.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base 5 | rebellion/collection/private/mutable-red-black-tree-base 6 | rebellion/collection/private/mutable-red-black-tree-batch-deletion 7 | rebellion/collection/private/mutable-red-black-tree-batch-insertion 8 | rebellion/collection/private/mutable-red-black-tree-deletion 9 | rebellion/collection/private/mutable-red-black-tree-insertion 10 | rebellion/collection/private/mutable-red-black-tree-iteration 11 | rebellion/collection/private/mutable-red-black-tree-search) 12 | 13 | 14 | (provide 15 | (recontract-out 16 | mutable-rb-tree? 17 | make-mutable-rb-tree 18 | mutable-rb-tree-size 19 | mutable-rb-tree-key-comparator 20 | mutable-rb-tree-contains-key? 21 | mutable-rb-tree-contains-value? 22 | mutable-rb-tree-contains-entry? 23 | mutable-rb-tree-least-key 24 | mutable-rb-tree-greatest-key 25 | mutable-rb-tree-key-less-than 26 | mutable-rb-tree-key-greater-than 27 | mutable-rb-tree-key-at-most 28 | mutable-rb-tree-key-at-least 29 | mutable-rb-tree-least-entry 30 | mutable-rb-tree-greatest-entry 31 | mutable-rb-tree-entry-less-than 32 | mutable-rb-tree-entry-greater-than 33 | mutable-rb-tree-entry-at-most 34 | mutable-rb-tree-entry-at-least 35 | mutable-rb-tree-get 36 | mutable-rb-tree-get-option 37 | mutable-rb-tree-get-entry 38 | mutable-rb-tree-get! 39 | mutable-rb-tree-get-entry! 40 | mutable-rb-tree-put! 41 | mutable-rb-tree-put-if-absent! 42 | mutable-rb-tree-put-all! 43 | mutable-rb-tree-update! 44 | mutable-rb-tree-remove! 45 | mutable-rb-tree-clear! 46 | mutable-rb-subtree-size 47 | mutable-rb-subtree-clear! 48 | in-mutable-rb-tree 49 | in-mutable-rb-tree-keys 50 | in-mutable-rb-tree-values 51 | in-mutable-rb-subtree 52 | in-mutable-rb-subtree-keys 53 | in-mutable-rb-subtree-values)) 54 | -------------------------------------------------------------------------------- /collection/private/sorted-map-builder.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [sorted-map-builder? (-> any/c boolean?)] 10 | [sorted-map-builder-put (-> sorted-map-builder? any/c any/c sorted-map-builder?)] 11 | [sorted-map-builder-put-all (-> sorted-map-builder? (sequence/c entry?) sorted-map-builder?)] 12 | [make-sorted-map-builder (-> comparator? sorted-map-builder?)] 13 | [build-sorted-map (-> sorted-map-builder? immutable-sorted-map?)])) 14 | 15 | 16 | (require racket/match 17 | racket/sequence 18 | racket/unsafe/ops 19 | racket/vector 20 | rebellion/base/comparator 21 | rebellion/collection/entry 22 | rebellion/collection/vector 23 | rebellion/collection/vector/builder 24 | (submod rebellion/collection/private/persistent-sorted-map private-for-rebellion-only) 25 | (submod rebellion/collection/private/regular-immutable-sorted-map private-for-rebellion-only) 26 | rebellion/collection/private/sorted-map-interface 27 | rebellion/streaming/transducer 28 | guard 29 | rebellion/private/static-name) 30 | 31 | 32 | ;@---------------------------------------------------------------------------------------------------- 33 | 34 | 35 | (struct sorted-map-builder 36 | (key-comparator entry-vector-builder) 37 | #:omit-define-syntaxes 38 | #:constructor-name constructor:sorted-map-builder) 39 | 40 | 41 | (define (make-sorted-map-builder key-comparator) 42 | (constructor:sorted-map-builder key-comparator (make-vector-builder))) 43 | 44 | 45 | (define (sorted-map-builder-put builder key value) 46 | (vector-builder-add (sorted-map-builder-entry-vector-builder builder) (entry key value)) 47 | builder) 48 | 49 | 50 | (define (sorted-map-builder-put-all builder entries) 51 | (vector-builder-add-all (sorted-map-builder-entry-vector-builder builder) entries) 52 | builder) 53 | 54 | 55 | (define/guard (build-sorted-map builder) 56 | (define key<=> (sorted-map-builder-key-comparator builder)) 57 | (define mutable-entries (build-mutable-vector (sorted-map-builder-entry-vector-builder builder))) 58 | 59 | (guard (not (vector-empty? mutable-entries)) #:else 60 | (empty-sorted-map key<=>)) 61 | 62 | (define (entry< e1 e2) 63 | (compare-infix key<=> (entry-key e1) < (entry-key e2))) 64 | 65 | (vector-sort! mutable-entries entry<) 66 | 67 | (define value-vector (make-vector (vector-length mutable-entries))) 68 | 69 | (for/fold ([previous #false] #:result (void)) 70 | ([i (in-range (vector-length mutable-entries))]) 71 | (define e (vector-ref mutable-entries i)) 72 | (match-define (entry key value) e) 73 | (when (and previous (compare-infix key<=> (entry-key previous) == key)) 74 | (raise-arguments-error 75 | (name build-sorted-map) 76 | "multiple values for the same key are not allowed" 77 | "key" key 78 | "value1" (entry-value previous) 79 | "value2" value)) 80 | (vector-set! mutable-entries i key) 81 | (vector-set! value-vector i value) 82 | e) 83 | 84 | (constructor:regular-immutable-sorted-map 85 | (unsafe-vector*->immutable-vector! mutable-entries) 86 | (unsafe-vector*->immutable-vector! value-vector) 87 | key<=>)) 88 | -------------------------------------------------------------------------------- /collection/private/sorted-set-builder.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [sorted-set-builder? (-> any/c boolean?)] 10 | [sorted-set-builder-add (-> sorted-set-builder? any/c any/c ... sorted-set-builder?)] 11 | [sorted-set-builder-add-all (-> sorted-set-builder? (sequence/c any/c) sorted-set-builder?)] 12 | [make-sorted-set-builder (-> comparator? sorted-set-builder?)] 13 | [build-sorted-set (-> sorted-set-builder? immutable-sorted-set?)])) 14 | 15 | 16 | (require racket/sequence 17 | racket/vector 18 | rebellion/base/comparator 19 | rebellion/collection/vector 20 | rebellion/collection/vector/builder 21 | (submod rebellion/collection/private/persistent-sorted-set private-for-rebellion-only) 22 | (submod rebellion/collection/private/regular-immutable-sorted-set private-for-rebellion-only) 23 | rebellion/collection/private/sorted-set-interface 24 | rebellion/streaming/transducer 25 | guard) 26 | 27 | 28 | ;@---------------------------------------------------------------------------------------------------- 29 | 30 | 31 | (struct sorted-set-builder 32 | (comparator vector-builder) 33 | #:guard (struct-guard/c comparator? vector-builder?) 34 | #:omit-define-syntaxes 35 | #:constructor-name constructor:sorted-set-builder) 36 | 37 | 38 | (define (make-sorted-set-builder comparator) 39 | (constructor:sorted-set-builder comparator (make-vector-builder))) 40 | 41 | 42 | (define (sorted-set-builder-add builder . elements) 43 | (sorted-set-builder-add-all builder elements)) 44 | 45 | 46 | (define (sorted-set-builder-add-all builder elements) 47 | (define modified (vector-builder-add-all (sorted-set-builder-vector-builder builder) elements)) 48 | (constructor:sorted-set-builder (sorted-set-builder-comparator builder) modified)) 49 | 50 | 51 | (define/guard (build-sorted-set builder) 52 | (define element<=> (sorted-set-builder-comparator builder)) 53 | (define mutable-elements (build-mutable-vector (sorted-set-builder-vector-builder builder))) 54 | (guard (positive? (vector-length mutable-elements)) #:else 55 | (empty-sorted-set element<=>)) 56 | 57 | (define (< x y) 58 | (equal? (compare element<=> x y) lesser)) 59 | 60 | (vector-sort! mutable-elements <) 61 | (define deduplicated 62 | (transduce mutable-elements 63 | (deduplicating-consecutive) 64 | #:into (into-vector #:size (vector-length mutable-elements)))) 65 | (make-regular-immutable-sorted-set deduplicated element<=>)) 66 | -------------------------------------------------------------------------------- /collection/private/testing/literal-mutable-red-black-tree.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide mutable-rbtree!) 5 | 6 | 7 | (require (for-syntax racket/base) 8 | rebellion/collection/private/mutable-red-black-tree-base 9 | syntax/parse/define) 10 | 11 | 12 | (begin-for-syntax 13 | 14 | (define-syntax-class literal-mutable-rb-node 15 | #:datum-literals (NIL) 16 | #:attributes (initialization-expr) 17 | 18 | (pattern (color key:expr (~optional value:expr)) 19 | #:declare color (expr/c #'color?) 20 | #:with initialization-expr 21 | #'(make-rb-node color key (~? value #false))) 22 | 23 | (pattern 24 | (color key:expr (~optional value:expr) 25 | (~or NIL left-child:literal-mutable-rb-node) 26 | (~or NIL right-child:literal-mutable-rb-node)) 27 | #:declare color (expr/c #'color?) 28 | #:with initialization-expr 29 | #'(let ([node (make-rb-node color key (~? value #false))]) 30 | (~? (mutable-rb-node-add-child! node left left-child.initialization-expr)) 31 | (~? (mutable-rb-node-add-child! node right right-child.initialization-expr)) 32 | node)))) 33 | 34 | 35 | (define-syntax-parse-rule (mutable-rbtree! #:key-comparator key-comparator:expr 36 | root-node:literal-mutable-rb-node) 37 | (let ([tree (make-mutable-rb-tree key-comparator)] 38 | [root root-node.initialization-expr]) 39 | (mutable-rb-tree-add-root-child! tree root) 40 | tree)) 41 | -------------------------------------------------------------------------------- /collection/set.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [empty-set empty-set?] 8 | [empty-set? (-> any/c boolean?)] 9 | [nonempty-set? (-> any/c boolean?)] 10 | [mutable-set? (-> any/c boolean?)] 11 | [into-set (reducer/c any/c set?)] 12 | [into-mutable-set (reducer/c any/c mutable-set?)])) 13 | 14 | (require racket/set 15 | rebellion/streaming/reducer) 16 | 17 | (module+ test 18 | (require (submod "..") 19 | rackunit)) 20 | 21 | ;@------------------------------------------------------------------------------ 22 | 23 | (define empty-set (set)) 24 | 25 | (define (empty-set? v) (and (set? v) (set-empty? v))) 26 | (define (nonempty-set? v) (and (set? v) (not (set-empty? v)))) 27 | 28 | (define (mutable-set? v) (set-mutable? v)) 29 | 30 | (define into-set (make-fold-reducer set-add empty-set #:name 'into-set)) 31 | 32 | (define into-mutable-set 33 | (make-effectful-fold-reducer (λ (st element) (set-add! st element) st) 34 | mutable-set 35 | values 36 | #:name 'into-mutable-set)) 37 | 38 | (module+ test 39 | (test-case "into-set" 40 | (check-equal? (reduce into-set 1 4 2 3 4 2) (set 1 2 3 4)) 41 | (check-equal? (reduce into-set) empty-set) 42 | (check-equal? (reduce into-set 1 1 1 1 1 1) (set 1))) 43 | (test-case "into-mutable-set" 44 | (define st (reduce into-mutable-set 1 2 3)) 45 | (check-pred mutable-set? st))) 46 | -------------------------------------------------------------------------------- /collection/set.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | racket/set 6 | rebellion/base/immutable-string 7 | rebellion/collection/set 8 | rebellion/streaming/reducer 9 | rebellion/streaming/transducer) 10 | (submod rebellion/private/scribble-cross-document-tech doc) 11 | (submod rebellion/private/scribble-evaluator-factory doc) 12 | scribble/example) 13 | 14 | @(define make-evaluator 15 | (make-module-sharing-evaluator-factory 16 | #:public (list 'rebellion/base/immutable-string 17 | 'rebellion/collection/set 18 | 'rebellion/streaming/reducer 19 | 'rebellion/streaming/transducer) 20 | #:private (list 'racket/base))) 21 | 22 | @title{Sets} 23 | @defmodule[rebellion/collection/set] 24 | 25 | @defthing[empty-set empty-set?]{ 26 | The empty immutable @tech/reference{set}.} 27 | 28 | @defproc[(empty-set? [v any/c]) boolean?]{ 29 | A predicate for empty immutable sets. Implies @racket[set?].} 30 | 31 | @defproc[(nonempty-set? [v any/c]) boolean?]{ 32 | A predicate for nonempty immutable sets. Implies @racket[set?].} 33 | 34 | @defproc[(mutable-set? [v any/c]) boolean?]{ 35 | A predicate for mutable sets. Equivalent to @racket[set-mutable?].} 36 | 37 | @deftogether[[ 38 | @defthing[into-set (reducer/c any/c set?)] 39 | @defthing[into-mutable-set (reducer/c any/c set-mutable?)]]]{ 40 | @tech{Reducers} that collect elements of the reduced sequence into either an 41 | immutable @tech/reference{set} or a mutable set, respectively. 42 | 43 | @(examples 44 | #:eval (make-evaluator) #:once 45 | (transduce (list "the" "quick" "brown" "fox") 46 | (mapping immutable-string-length) 47 | #:into into-set))} 48 | -------------------------------------------------------------------------------- /collection/sorted-set.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (all-from-out rebellion/collection/private/mutable-sorted-set) 9 | (all-from-out rebellion/collection/private/regular-immutable-sorted-set) 10 | (all-from-out rebellion/collection/private/sorted-set-builder) 11 | (all-from-out rebellion/collection/private/sorted-set-interface) 12 | (all-from-out rebellion/collection/private/synchronized-sorted-set) 13 | (all-from-out rebellion/collection/private/unmodifiable-sorted-set) 14 | (contract-out 15 | [sorted-set (-> #:comparator comparator? any/c ... immutable-sorted-set?)] 16 | [sequence->sorted-set (-> (sequence/c any/c) #:comparator comparator? immutable-sorted-set?)] 17 | [into-sorted-set (-> comparator? (reducer/c any/c immutable-sorted-set?))])) 18 | 19 | 20 | (require racket/sequence 21 | rebellion/base/comparator 22 | rebellion/collection/private/mutable-sorted-set 23 | rebellion/collection/private/regular-immutable-sorted-set 24 | (submod rebellion/collection/private/regular-immutable-sorted-set private-for-rebellion-only) 25 | rebellion/collection/private/sorted-set-interface 26 | rebellion/collection/private/sorted-set-builder 27 | rebellion/collection/private/synchronized-sorted-set 28 | rebellion/collection/private/unmodifiable-sorted-set 29 | guard 30 | rebellion/private/static-name 31 | rebellion/streaming/reducer 32 | rebellion/streaming/transducer) 33 | 34 | 35 | ;@---------------------------------------------------------------------------------------------------- 36 | 37 | 38 | (define (sorted-set #:comparator comparator . elements) 39 | (sequence->sorted-set elements #:comparator comparator)) 40 | 41 | 42 | (define/guard (sequence->sorted-set elements #:comparator comparator) 43 | ;; We only avoid copying if the input is a regular-immutable-sorted-set? instead of any 44 | ;; immutable-sorted-set? because the latter includes subset views. A subset view could be a tiny 45 | ;; portion of a much larger backing set, and there's a soft expectation that copying a sequence into 46 | ;; an immutable collection retains space linear in the size of the returned collection. 47 | (guard (not (and (regular-immutable-sorted-set? elements) 48 | (equal? (sorted-set-comparator elements) comparator))) #:else 49 | elements) 50 | (transduce elements #:into (into-sorted-set comparator))) 51 | 52 | 53 | (define (into-sorted-set comparator) 54 | (make-effectful-fold-reducer 55 | sorted-set-builder-add 56 | (λ () (make-sorted-set-builder comparator)) 57 | build-sorted-set 58 | #:name (name into-sorted-set))) 59 | -------------------------------------------------------------------------------- /collection/vector.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | racket/math 6 | racket/sequence 7 | rebellion/collection/immutable-vector 8 | rebellion/collection/vector 9 | rebellion/streaming/reducer 10 | rebellion/streaming/transducer) 11 | (submod rebellion/private/scribble-cross-document-tech doc) 12 | (submod rebellion/private/scribble-evaluator-factory doc) 13 | scribble/example) 14 | 15 | @(define make-evaluator 16 | (make-module-sharing-evaluator-factory 17 | #:public (list 'rebellion/collection/vector 18 | 'rebellion/streaming/transducer) 19 | #:private (list 'racket/base))) 20 | 21 | @title{Vectors} 22 | @defmodule[rebellion/collection/vector] 23 | 24 | @defproc[(mutable-vector? [v any/c]) boolean?]{ 25 | A predicate for mutable vectors. Implies @racket[vector?].} 26 | 27 | @defproc[(into-vector [#:size size (or/c natural? +inf.0) +inf.0]) 28 | (reducer/c any/c immutable-vector?)]{ 29 | Constructs a @tech{reducer} that collects at most @racket[size] elements of a 30 | sequence into an immutable vector. 31 | 32 | @(examples 33 | #:eval (make-evaluator) #:once 34 | (transduce (in-naturals) 35 | (filtering odd?) 36 | #:into (into-vector #:size 5)))} 37 | 38 | @defproc[(into-mutable-vector [#:size size (or/c natural? +inf.0) +inf.0]) 39 | (reducer/c any/c mutable-vector?)]{ 40 | Constructs a @tech{reducer} that collects at most @racket[size] elements of a 41 | sequence into a mutable vector. 42 | 43 | @(examples 44 | #:eval (make-evaluator) #:once 45 | (transduce (in-naturals) 46 | (filtering even?) 47 | #:into (into-mutable-vector #:size 5)))} 48 | 49 | @defproc[(sequence->vector [seq (sequence/c any/c)]) immutable-vector?]{ 50 | Copies @racket[seq] into an immutable vector. If @racket[seq] is already an 51 | immutable vector, it is returned directly. 52 | 53 | @(examples 54 | #:eval (make-evaluator) #:once 55 | (sequence->vector (list 1 2 3)) 56 | (sequence->vector (in-range 0 10)))} 57 | -------------------------------------------------------------------------------- /concurrency.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title[#:style (list 'toc)]{Concurrency} 4 | 5 | @local-table-of-contents[] 6 | 7 | @include-section[(lib "rebellion/concurrency/atomic/boolean.scrbl")] 8 | @include-section[(lib "rebellion/concurrency/atomic/fixnum.scrbl")] 9 | @include-section[(lib "rebellion/concurrency/lock.scrbl")] 10 | -------------------------------------------------------------------------------- /concurrency/atomic/boolean.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [atomic-boolean? (-> any/c boolean?)] 8 | [make-atomic-boolean (-> boolean? atomic-boolean?)] 9 | [atomic-boolean-get (-> atomic-boolean? boolean?)] 10 | [rename set-atomic-boolean-get! atomic-boolean-set! 11 | (-> atomic-boolean? boolean? void?)] 12 | [atomic-boolean-compare-and-set! 13 | (-> atomic-boolean? boolean? boolean? boolean?)] 14 | [atomic-boolean-compare-and-exchange! 15 | (-> atomic-boolean? boolean? boolean? boolean?)] 16 | [atomic-boolean-get-then-set! (-> atomic-boolean? boolean? boolean?)])) 17 | 18 | (require rebellion/base/symbol 19 | (only-in racket/unsafe/ops unsafe-struct*-cas!)) 20 | 21 | (module+ test 22 | (require (submod "..") 23 | rackunit 24 | rebellion/private/static-name)) 25 | 26 | ;@------------------------------------------------------------------------------ 27 | 28 | (struct atomic-boolean ([get #:mutable]) 29 | #:constructor-name make-atomic-boolean 30 | #:authentic) 31 | 32 | (define (atomic-boolean-compare-and-set! bool expected replacement) 33 | (unsafe-struct*-cas! bool 0 expected replacement)) 34 | 35 | (define (atomic-boolean-compare-and-exchange! bool expected replacement) 36 | (if (atomic-boolean-compare-and-set! bool expected replacement) 37 | expected 38 | (not expected))) 39 | 40 | (define (atomic-boolean-get-then-set! bool replacement) 41 | (atomic-boolean-compare-and-exchange! bool (not replacement) replacement)) 42 | 43 | (module+ test 44 | (test-case (name-string atomic-boolean-compare-and-exchange!) 45 | 46 | (test-case "stay false" 47 | (define bool (make-atomic-boolean #false)) 48 | (check-false (atomic-boolean-compare-and-exchange! bool #true #false)) 49 | (check-false (atomic-boolean-get bool)) 50 | (check-false (atomic-boolean-compare-and-exchange! bool #false #false)) 51 | (check-false (atomic-boolean-get bool))) 52 | 53 | (test-case "stay true" 54 | (define bool (make-atomic-boolean #true)) 55 | (check-true (atomic-boolean-compare-and-exchange! bool #false #true)) 56 | (check-true (atomic-boolean-get bool)) 57 | (check-true (atomic-boolean-compare-and-exchange! bool #true #true)) 58 | (check-true (atomic-boolean-get bool))) 59 | 60 | (test-case "set false to true" 61 | (define bool (make-atomic-boolean #false)) 62 | (check-false (atomic-boolean-compare-and-exchange! bool #true #true)) 63 | (check-false (atomic-boolean-get bool)) 64 | (check-false (atomic-boolean-compare-and-exchange! bool #false #true)) 65 | (check-true (atomic-boolean-get bool))) 66 | 67 | (test-case "set true to false" 68 | (define bool (make-atomic-boolean #true)) 69 | (check-true (atomic-boolean-compare-and-exchange! bool #false #false)) 70 | (check-true (atomic-boolean-get bool)) 71 | (check-true (atomic-boolean-compare-and-exchange! bool #true #false)) 72 | (check-false (atomic-boolean-get bool)))) 73 | 74 | (test-case (name-string atomic-boolean-get-then-set!) 75 | 76 | (test-case "stay false" 77 | (define bool (make-atomic-boolean #false)) 78 | (check-false (atomic-boolean-get-then-set! bool #false)) 79 | (check-false (atomic-boolean-get bool))) 80 | 81 | (test-case "stay true" 82 | (define bool (make-atomic-boolean #true)) 83 | (check-true (atomic-boolean-get-then-set! bool #true)) 84 | (check-true (atomic-boolean-get bool))) 85 | 86 | (test-case "set false to true" 87 | (define bool (make-atomic-boolean #false)) 88 | (check-false (atomic-boolean-get-then-set! bool #true)) 89 | (check-true (atomic-boolean-get bool))) 90 | 91 | (test-case "set true to false" 92 | (define bool (make-atomic-boolean #true)) 93 | (check-true (atomic-boolean-get-then-set! bool #false)) 94 | (check-false (atomic-boolean-get bool))))) 95 | -------------------------------------------------------------------------------- /concurrency/atomic/boolean.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | rebellion/concurrency/atomic/boolean) 6 | (submod rebellion/private/scribble-cross-document-tech doc) 7 | (submod rebellion/private/scribble-evaluator-factory doc) 8 | scribble/example) 9 | 10 | @(define make-evaluator 11 | (make-module-sharing-evaluator-factory 12 | #:public (list 'rebellion/concurrency/atomic/boolean) 13 | #:private (list 'racket/base))) 14 | 15 | @title{Atomic Booleans} 16 | @defmodule[rebellion/concurrency/atomic/boolean] 17 | 18 | An @deftech{atomic boolean} is a thread-safe, future-safe, kill-safe, 19 | break-safe, and wait-free mutable object containing a single @tech/reference{ 20 | boolean}. 21 | 22 | @defproc[(atomic-boolean? [v any/c]) boolean?]{ 23 | A predicate for @tech{atomic booleans}.} 24 | 25 | @defproc[(make-atomic-boolean [initial-value boolean?]) atomic-boolean?]{ 26 | Constructs a new @tech{atomic boolean} and sets it to @racket[initial-value].} 27 | 28 | @defproc[(atomic-boolean-get [bool atomic-boolean?]) boolean?]{ 29 | Returns the current value of @racket[bool]. 30 | 31 | @(examples 32 | #:eval (make-evaluator) #:once 33 | (define bool (make-atomic-boolean #false)) 34 | (atomic-boolean-get bool))} 35 | 36 | @defproc[(atomic-boolean-set! [bool atomic-boolean?] [replacement boolean?]) 37 | void?]{ 38 | Sets the current value of @racket[bool] to @racket[replacement]. 39 | 40 | @(examples 41 | #:eval (make-evaluator) #:once 42 | (define bool (make-atomic-boolean #false)) 43 | (atomic-boolean-set! bool #true) 44 | (atomic-boolean-get bool))} 45 | 46 | @defproc[(atomic-boolean-compare-and-set! [bool atomic-boolean?] 47 | [expected boolean?] 48 | [replacement boolean?]) 49 | boolean?]{ 50 | Attempts to set @racket[bool] to @racket[replacement], succeeding if and only 51 | if its current value is @racket[expected]. Returns a boolean indicating whether 52 | or not the operation succeeded. 53 | 54 | @(examples 55 | #:eval (make-evaluator) #:once 56 | (define bool (make-atomic-boolean #true)) 57 | (atomic-boolean-compare-and-set! bool #false #true) 58 | (atomic-boolean-get bool) 59 | (atomic-boolean-compare-and-set! bool #true #false) 60 | (atomic-boolean-get bool))} 61 | 62 | @defproc[(atomic-boolean-compare-and-exchange! [bool atomic-boolean?] 63 | [expected boolean?] 64 | [replacement boolean?]) 65 | boolean?]{ 66 | Attempts to set @racket[bool] to @racket[replacement], succeeding if and only 67 | if its current value is @racket[expected]. Returns the value of @racket[bool] 68 | before the exchange. If the returned value is equal to @racket[expected], that 69 | indicates the exchange succeeded. 70 | 71 | @(examples 72 | #:eval (make-evaluator) #:once 73 | (define bool (make-atomic-boolean #false)) 74 | (atomic-boolean-compare-and-exchange! bool #true #false) 75 | (atomic-boolean-get bool) 76 | (atomic-boolean-compare-and-exchange! bool #false #true) 77 | (atomic-boolean-get bool))} 78 | 79 | @defproc[(atomic-boolean-get-then-set! [bool atomic-boolean?] 80 | [replacement boolean?]) 81 | boolean?]{ 82 | Sets @racket[bool] to @racket[replacement] and returns its previous value. 83 | 84 | @(examples 85 | #:eval (make-evaluator) #:once 86 | (define bool (make-atomic-boolean #false)) 87 | (atomic-boolean-get-then-set! bool #true) 88 | (atomic-boolean-get bool))} 89 | -------------------------------------------------------------------------------- /custom-write.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [custom-write-mode/c flat-contract?] 8 | [custom-write-function/c chaperone-contract?] 9 | [make-named-object-custom-write 10 | (->* (symbol?) (#:name-getter (-> any/c (or/c symbol? #false))) 11 | custom-write-function/c)])) 12 | 13 | ;@------------------------------------------------------------------------------ 14 | 15 | (define custom-write-mode/c (or/c boolean? 0 1)) 16 | 17 | (define custom-write-function/c 18 | (-> any/c output-port? custom-write-mode/c void?)) 19 | 20 | (define (make-named-object-custom-write type-name 21 | #:name-getter [get-name object-name]) 22 | (define type-part (string-append "#<" (symbol->string type-name))) 23 | (λ (this out mode) 24 | (parameterize ([current-output-port out]) 25 | (write-string type-part) 26 | (define name (get-name this)) 27 | (when name 28 | (write-string ":") 29 | (write-string (symbol->string name))) 30 | (write-string ">")) 31 | (void))) 32 | -------------------------------------------------------------------------------- /custom-write.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | racket/math 6 | racket/pretty 7 | racket/struct 8 | rebellion/custom-write 9 | rebellion/type/struct 10 | rebellion/type/tuple) 11 | (submod rebellion/private/scribble-evaluator-factory doc) 12 | (submod rebellion/private/scribble-cross-document-tech doc) 13 | scribble/example) 14 | 15 | @(define make-evaluator 16 | (make-module-sharing-evaluator-factory 17 | #:public (list 'racket/pretty 18 | 'rebellion/custom-write 19 | 'rebellion/type/struct 20 | 'rebellion/type/tuple) 21 | #:private (list 'racket/base))) 22 | 23 | @title{Custom Write Implementations} 24 | @defmodule[rebellion/custom-write] 25 | 26 | A @deftech{custom write implementation} is a function that prints values and is 27 | suitable for use with @racket[prop:custom-write]. Custom write implementations 28 | must satisfy the @racket[custom-write-function/c] contract. 29 | 30 | @defthing[custom-write-function/c chaperone-contract? 31 | #:value (-> any/c output-port? custom-write-mode/c void?)]{ 32 | A @tech/reference{contract} describing functions suitable for use with @racket[ 33 | prop:custom-write].} 34 | 35 | @defthing[custom-write-mode/c flat-contract? 36 | #:value (or/c boolean? 0 1)]{ 37 | A @tech/reference{contract} describing the @racket[_mode] argument to functions 38 | matching @racket[custom-write-function/c]. See @racket[gen:custom-write] for 39 | details.} 40 | 41 | @defproc[(make-named-object-custom-write 42 | [type-name symbol?] 43 | [#:name-getter get-name (-> any/c (or/c symbol? #false)) object-name]) 44 | custom-write-function/c]{ 45 | Constructs a @tech{custom write implementation} that prints values as opaque, 46 | unreadable, named objects, similar to the way functions are printed. 47 | 48 | @(examples 49 | #:eval (make-evaluator) #:once 50 | (struct person (name) 51 | #:property prop:object-name (struct-field-index name) 52 | #:property prop:custom-write (make-named-object-custom-write 'person)) 53 | 54 | (person 'alyssa) 55 | (person 'jared) 56 | (person #false))} 57 | -------------------------------------------------------------------------------- /equal+hash.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [make-accessor-based-equal+hash 8 | (-> (-> any/c natural? any/c) natural? equal+hash/c)] 9 | [make-singleton-equal+hash (-> equal+hash/c)] 10 | [equal+hash/c contract?])) 11 | 12 | (require racket/math 13 | rebellion/base/generative-token) 14 | 15 | ;@------------------------------------------------------------------------------ 16 | 17 | (define equal+hash/c (list/c procedure? procedure? procedure?)) 18 | 19 | (define (make-accessor-based-equal+hash accessor size) 20 | (define token (make-generative-token)) 21 | (define (equal-proc this other recur) 22 | (for/and ([pos (in-range size)]) 23 | (recur (accessor this pos) (accessor other pos)))) 24 | (define (hash-proc this recur) 25 | (recur (cons token (build-list size (λ (pos) (accessor this pos)))))) 26 | (define hash2-proc hash-proc) 27 | (list equal-proc hash-proc hash2-proc)) 28 | 29 | (define (make-singleton-equal+hash) 30 | (define token (make-generative-token)) 31 | (define (equal-proc this other recur) #t) 32 | (define (hash-proc _ recur) (recur token)) 33 | (define hash2-proc hash-proc) 34 | (list equal-proc hash-proc hash2-proc)) 35 | -------------------------------------------------------------------------------- /equal+hash.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | racket/math 6 | rebellion/type/struct 7 | rebellion/type/tuple 8 | rebellion/equal+hash 9 | rebellion/equal+hash/struct) 10 | (submod rebellion/private/scribble-evaluator-factory doc) 11 | scribble/example) 12 | 13 | @(define make-evaluator 14 | (make-module-sharing-evaluator-factory 15 | #:public (list 'rebellion/type/struct 16 | 'rebellion/type/tuple 17 | 'rebellion/equal+hash 18 | 'rebellion/equal+hash/struct) 19 | #:private (list 'racket/base))) 20 | 21 | @title{Equality and Hashing Implementations} 22 | @defmodule[rebellion/equal+hash] 23 | 24 | @defproc[(make-accessor-based-equal+hash [accessor (-> any/c natural? any/c)] 25 | [size natural?]) 26 | equal+hash/c]{ 27 | Builds an equality-checking function, a hashing function, and a secondary 28 | hashing function suitable for use with @racket[prop:equal+hash]. These 29 | functions extract @racket[size] fields from values using @racket[accessor] and 30 | recursively compare and hash them. This function is typically not used 31 | directly; instead clients are expected to use one of @racket[ 32 | make-struct-equal+hash] or @racket[default-tuple-equal+hash].} 33 | 34 | @defthing[equal+hash/c contract? 35 | #:value (list/c procedure? procedure? procedure?)] 36 | 37 | @section{Struct Equality and Hashing} 38 | @defmodule[rebellion/equal+hash/struct] 39 | 40 | @defproc[(make-struct-equal+hash [descriptor struct-descriptor?]) 41 | equal+hash/c]{ 42 | Builds an equality-checking function, a hashing function, and a secondary 43 | hashing function suitable for use with @racket[prop:equal+hash], each of which 44 | operate on instances of @racket[descriptor]. All fields in @racket[descriptor] 45 | are compared and hashed by the returned procedures. This causes @racket[equal?] 46 | to behave roughly the same as it does on transparent structure types. 47 | 48 | @(examples 49 | #:eval (make-evaluator) #:once 50 | (struct opaque-point (x y)) 51 | (equal? (opaque-point 1 2) (opaque-point 1 2)) 52 | 53 | (define point-descriptor 54 | (make-struct-implementation 55 | #:name 'point 56 | #:immutable-fields 2 57 | #:property-maker 58 | (λ (descriptor) 59 | (define equal+hash (make-struct-equal+hash descriptor)) 60 | (list (cons prop:equal+hash equal+hash))))) 61 | 62 | (define point (struct-descriptor-constructor point-descriptor)) 63 | (equal? (point 1 2) (point 1 2)))} 64 | -------------------------------------------------------------------------------- /equal+hash/struct.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [make-struct-equal+hash 8 | (-> struct-descriptor? 9 | (list/c procedure? procedure? procedure?))])) 10 | 11 | (require rebellion/equal+hash 12 | rebellion/type/struct) 13 | 14 | ;@------------------------------------------------------------------------------ 15 | 16 | (define (make-struct-equal+hash descriptor) 17 | (define accessor (struct-descriptor-accessor descriptor)) 18 | (define size 19 | (+ (struct-descriptor-mutable-fields descriptor) 20 | (struct-descriptor-immutable-fields descriptor) 21 | (struct-descriptor-auto-fields descriptor))) 22 | (make-accessor-based-equal+hash accessor size)) 23 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | 3 | (define collection "rebellion") 4 | 5 | (define scribblings 6 | (list (list "main.scrbl" 7 | (list 'multi-page) 8 | (list "Data Structures") 9 | "rebellion"))) 10 | 11 | (define deps 12 | (list "base" 13 | "guard")) 14 | 15 | (define build-deps 16 | (list "net-doc" 17 | "racket-doc" 18 | "rackunit-lib" 19 | "scribble-lib")) 20 | 21 | (define test-omit-paths 22 | (list #rx"\\.scrbl$")) 23 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | -------------------------------------------------------------------------------- /main.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label rebellion)) 4 | 5 | @title{Rebellion} 6 | @defmodule[rebellion] 7 | 8 | Rebellion is a collection of core Racket libraries that includes a stream 9 | processing system built on @tech{transducers} and @tech{reducers}, new kinds of 10 | collections such as @tech{multisets} and @tech{multidicts}, a suite of libraries 11 | for defining new @racket[struct]-based types including @tech{record types} and 12 | @tech{enum types}, and much more. The goal of Rebellion is to make high quality 13 | standard libraries accessible to all Racketeers regardless of what @hash-lang[] 14 | they're using. 15 | 16 | @table-of-contents[] 17 | 18 | @include-section[(lib "rebellion/base.scrbl")] 19 | @include-section[(lib "rebellion/type.scrbl")] 20 | @include-section[(lib "rebellion/streaming.scrbl")] 21 | @include-section[(lib "rebellion/collection.scrbl")] 22 | @include-section[(lib "rebellion/concurrency.scrbl")] 23 | @include-section[(lib "rebellion/binary.scrbl")] 24 | @include-section[(lib "rebellion/module.scrbl")] 25 | @include-section[(lib "rebellion/other.scrbl")] 26 | -------------------------------------------------------------------------------- /media/application/octet-stream.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract) 4 | 5 | (provide 6 | (contract-out 7 | [application/octet-stream (->* () (#:padding (integer-in 0 7)) media-type?)] 8 | [media->octet-stream (-> media? octet-stream?)] 9 | [octet-stream 10 | (->* (immutable-bytes?) (#:padding (integer-in 0 7)) octet-stream?)] 11 | [octet-stream? (-> any/c boolean?)] 12 | [octet-stream-bytes (-> octet-stream? immutable-bytes?)] 13 | [octet-stream-padding (-> octet-stream? (integer-in 0 7))] 14 | [octet-stream->bitstring (-> octet-stream? bitstring?)] 15 | [octet-stream->media (-> octet-stream? media?)])) 16 | 17 | (require guard 18 | rebellion/base/immutable-string 19 | rebellion/binary/bitstring 20 | rebellion/binary/immutable-bytes 21 | rebellion/collection/record 22 | rebellion/media 23 | rebellion/type/tuple) 24 | 25 | (module+ test 26 | (require (submod "..") 27 | rackunit 28 | rebellion/binary/byte)) 29 | 30 | ;@------------------------------------------------------------------------------ 31 | 32 | ;; TODO: handle the "type" parameter 33 | (define-tuple-type octet-stream (bytes padding) #:omit-root-binding) 34 | 35 | (define (octet-stream bytes #:padding [padding 0]) 36 | (constructor:octet-stream bytes padding)) 37 | 38 | (define (octet-stream->bitstring octets) 39 | (bytes->bitstring (octet-stream-bytes octets) 40 | #:padding (octet-stream-padding octets))) 41 | 42 | (define (application/octet-stream #:padding [padding 0]) 43 | (if (zero? padding) 44 | (media-type 'application 'octet-stream) 45 | (media-type 'application 'octet-stream 46 | #:parameters 47 | (record #:padding (number->immutable-string padding))))) 48 | 49 | (define (application/octet-stream? type) 50 | (and (equal? (media-type-top-level type) 'application) 51 | (equal? (media-type-subtype type) 'octet-stream) 52 | (not (media-type-tree type)) 53 | (not (media-type-suffix type)))) 54 | 55 | (define (media->octet-stream m) 56 | (define bstr (media-bytes m)) 57 | (define type (media-get-type m)) 58 | (define padding 59 | (guarded-block 60 | (guard (application/octet-stream? type) #:else 61 | 0) 62 | (define params (media-type-parameters type)) 63 | (if (record-contains-key? params '#:padding) 64 | (string->number (record-ref params '#:padding)) 65 | 0))) 66 | (octet-stream bstr #:padding padding)) 67 | 68 | (define (octet-stream->media octets) 69 | (media (application/octet-stream #:padding (octet-stream-padding octets)) 70 | (octet-stream-bytes octets))) 71 | 72 | (module+ test 73 | (test-case "octet-stream->bitstring" 74 | (define bstr 75 | (bytes (byte 1 1 0 0 0 1 1 1) 76 | (byte 0 0 1 0 0 0 1 1) 77 | (byte 1 1 0 0 0 0 0 0))) 78 | (define octets (octet-stream (bytes->immutable-bytes bstr) #:padding 3)) 79 | (check-equal? (octet-stream->bitstring octets) 80 | (bitstring 1 1 0 0 0 1 1 1 81 | 0 0 1 0 0 0 1 1 82 | 1 1 0 0 0)))) 83 | -------------------------------------------------------------------------------- /media/application/octet-stream.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | rebellion/media 6 | rebellion/media/application/octet-stream) 7 | (submod rebellion/private/scribble-evaluator-factory doc) 8 | scribble/example) 9 | 10 | @(define make-evaluator 11 | (make-module-sharing-evaluator-factory 12 | #:public (list 'rebellion/media/application/octet-stream) 13 | #:private (list 'racket/base))) 14 | 15 | @title{Octet Streams} 16 | @defmodule[rebellion/media/application/octet-stream] 17 | 18 | An @deftech{octet stream} is an immutable byte string whose last byte may 19 | include extra bits of padding, making octet streams semantically similar to 20 | @tech{bitstrings}. Octet streams are @tech{media}, and their @tech{media type} 21 | is @racket[application/octet-stream]. 22 | 23 | @defproc[(octet-stream? [v any/c]) boolean?]{ 24 | A predicate for @tech{octet streams}.} 25 | 26 | @defproc[(application/octet-stream [#:padding padding (integer-in 0 7) 0]) 27 | media-type?]{ 28 | Constructs the @tech{media type} of @tech{octet streams} padded with @racket[ 29 | padding] bits. 30 | 31 | @(examples 32 | #:eval (make-evaluator) #:once 33 | (application/octet-stream) 34 | (application/octet-stream #:padding 6))} 35 | 36 | @defproc[(octet-stream [bstr immutable-bytes?] 37 | [#:padding padding (integer-in 0 7) 0]) 38 | octet-stream?]{ 39 | Constructs an @tech{octet stream} from @racket[bstr]. If @racket[padding] is 40 | nonzero, that many bits are ignored from the last byte of @racket[bstr] when 41 | the octet stream is converted to a @tech{bitstring} with @racket[ 42 | octet-stream->bitstring]. 43 | 44 | @(examples 45 | #:eval (make-evaluator) #:once 46 | (octet-stream #"Apple") 47 | (octet-stream #"Apple" #:padding 3))} 48 | 49 | @defproc[(octet-stream->bitstring [octets octet-stream?]) bitstring?]{ 50 | Converts @racket[octets] into a @tech{bitstring}. 51 | 52 | @(examples 53 | #:eval (make-evaluator) #:once 54 | (octet-stream->bitstring (octet-stream #"Apple")) 55 | (octet-stream->bitstring (octet-stream #"Apple" #:padding 3)))} 56 | 57 | @defproc[(octet-stream-bytes [octets octet-stream?]) immutable-bytes?]{ 58 | Returns the bytes contained in @racket[octets].} 59 | 60 | @defproc[(octet-stream-padding [octets octet-stream?]) (integer-in 0 7)]{ 61 | Returns the number of padding bits in @racket[octets].} 62 | 63 | @defproc[(media->octet-stream [m media?]) octet-stream?]{ 64 | Constructs an @tech{octet stream} containing the bytes of @racket[m]. Octet 65 | streams are the most general @tech{media type}, so all media can be converted 66 | to an octet stream regardless of type. However, the returned octet stream will 67 | only have nonzero padding if @racket[m] has type @racket[ 68 | application/octet-stream] with the @racket[#:padding] parameter set.} 69 | 70 | @defproc[(octet-stream->media [octets octet-stream?]) media?]{ 71 | Converts @racket[octets] into @tech{media} of type @racket[ 72 | application/octet-stream] with the padding parameter set if @racket[octets] has 73 | nonzero padding. 74 | 75 | @(examples 76 | #:eval (make-evaluator) #:once 77 | (octet-stream->media (octet-stream #"Apple")) 78 | (octet-stream->media (octet-stream #"Apple" #:padding 3)))} 79 | -------------------------------------------------------------------------------- /media/text/plain.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [charset? (-> any/c boolean?)] 8 | [us-ascii charset?] 9 | [utf-8 charset?] 10 | [text? (-> any/c boolean?)] 11 | [text (-> (or/c charset? #f) immutable-bytes? text?)] 12 | [text-charset (-> text? (or/c charset? #f))] 13 | [text-bytes (-> text? immutable-bytes?)] 14 | [text-media? (-> any/c boolean?)] 15 | [text->media (-> text? text-media?)] 16 | [media->text (-> text-media? text?)] 17 | [text/plain (-> #:charset (or/c charset? #f) media-type?)] 18 | [text/plain? (-> media-type? boolean?)])) 19 | 20 | (require racket/bool 21 | rebellion/binary/immutable-bytes 22 | rebellion/collection/record 23 | rebellion/media 24 | rebellion/type/tuple) 25 | 26 | (module+ test 27 | (require (submod "..") 28 | rackunit)) 29 | 30 | ;@------------------------------------------------------------------------------ 31 | 32 | (define-tuple-type charset (name)) 33 | 34 | (define us-ascii (charset "us-ascii")) 35 | (define utf-8 (charset "utf-8")) 36 | 37 | (define-tuple-type text (charset bytes)) 38 | 39 | (define (text-media? m) 40 | (define type (media-get-type m)) 41 | (equal? (media-type-top-level type) 'text)) 42 | 43 | (define (text->media txt) 44 | (media (text/plain #:charset (text-charset txt)) (text-bytes txt))) 45 | 46 | (define (media->text m) 47 | (error 'media->text "not yet implemented")) 48 | 49 | (define (text/plain? type) 50 | (and (equal? (media-type-top-level type) 'text) 51 | (equal? (media-type-subtype type) 'plain) 52 | (false? (media-type-tree type)) 53 | (false? (media-type-suffix type)))) 54 | 55 | (define (text/plain #:charset chset) 56 | (define params 57 | (if chset (record #:charset (charset-name chset)) empty-record)) 58 | (media-type 'text 'plain #:parameters params)) 59 | -------------------------------------------------------------------------------- /media/text/plain.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | rebellion/binary/immutable-bytes 6 | rebellion/media/text/plain) 7 | (submod rebellion/private/scribble-evaluator-factory doc) 8 | (submod rebellion/private/scribble-cross-document-tech doc) 9 | scribble/example) 10 | 11 | @(define make-evaluator 12 | (make-module-sharing-evaluator-factory 13 | #:public (list 'rebellion/media/text/plain) 14 | #:private (list 'racket/base))) 15 | 16 | @title{Text Media} 17 | @defmodule[rebellion/media/text/plain] 18 | 19 | @(define charset-registry-url 20 | "https://www.iana.org/assignments/character-sets/character-sets.xhtml") 21 | 22 | @deftech{Text} is a type of @tech{media} that represents a sequence of 23 | @tech/guide{characters} encoded in a bytestring according to a standardized set of 24 | rules called a @deftech{character set}, or @deftech{charset} for short. Charsets 25 | must be registered with the IANA and their names are assigned in the @hyperlink[ 26 | charset-registry-url]{IANA Character Set Registry}. 27 | 28 | Text values are very similar to @tech/guide{strings}. The primary difference between 29 | the two is in how character encoding and decoding are handled: 30 | 31 | @itemlist[ 32 | @item{Strings are all encoded with the same charset, which is a Unicode 33 | encoding internal to Racket. Conversion between strings and bytes requires 34 | explicitly reencoding the string.} 35 | 36 | @item{Text values specify their charset directly, and different text values can 37 | have different charsets. Constructing a text value from bytes doesn't require 38 | performing any decoding --- that's only needed when changing the text's 39 | charset or when converting the text into a string.}] 40 | 41 | This difference is important when a program produces and consumes textual data 42 | without examining it, such as one that copies files from one computer to 43 | another. In such cases, the text can be handled without @emph{ever} changing its 44 | encoding, completely avoiding the cost of converting its bytes back and forth 45 | between string representations. 46 | 47 | @defproc[(text? [v any/c]) boolean?]{ 48 | A predicate for @tech{text}.} 49 | 50 | @defproc[(text [charset charset?] [bytes immutable-bytes?]) text?]{ 51 | Constructs @tech{text} from the given @racket[bytes] and @racket[charset]. This 52 | function performs no validation whatsoever that @racket[bytes] conforms to the 53 | rules of @racket[charset]; a noncomforming @racket[bytes] instead results in an 54 | error when the constructed text is converted to a string or reencoded with a 55 | different charset. This function runs in constant time and constant space.} 56 | 57 | @defproc[(text-charset [txt text?]) charset?]{ 58 | Returns the @tech{charset} of @racket[txt].} 59 | 60 | @defproc[(text-bytes [txt text?]) charset?]{ 61 | Returns the bytes of @racket[txt].} 62 | 63 | @defproc[(charset? [v any/c]) boolean?]{ 64 | A predicate for @tech{charsets}.} 65 | 66 | @defthing[utf-8 charset?]{ 67 | The Unicode UTF-8 @tech{character set}.} 68 | 69 | @defthing[us-ascii]{ 70 | The ASCII @tech{character set}.} 71 | 72 | @defproc[(text-media? [m media?]) boolean?]{ 73 | A predicate for @tech{media} whose top level type is @litchar{text}, such as 74 | @racket[text/plain] and @racket[text/csv].} 75 | 76 | @defproc[(text/plain [#:charset charset charset?]) media-type?]{ 77 | Constructs the @tech{media type} for @tech{text} encoded according to @racket[ 78 | charset].} 79 | 80 | @defproc[(text->media [txt text?]) text-media?]{ 81 | Converts @racket[txt] into @tech{media} of type @racket[text/plain].} 82 | 83 | @defproc[(media->text [m text-media?]) text?]{ 84 | Converts @racket[m] into @tech{text}.} 85 | -------------------------------------------------------------------------------- /module.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title[#:style (list 'toc)]{Module Utilities} 4 | 5 | @local-table-of-contents[] 6 | 7 | @include-section[(lib "rebellion/module/binding.scrbl")] 8 | @include-section[(lib "rebellion/module/phase.scrbl")] 9 | -------------------------------------------------------------------------------- /module/binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [module-binding (-> module-path? phase? symbol? module-binding?)] 8 | [module-binding? (-> any/c boolean?)] 9 | [module-binding-source (-> module-binding? module-path?)] 10 | [module-binding-name (-> module-binding? symbol?)] 11 | [module-binding-phase (-> module-binding? phase?)] 12 | [module-bindings 13 | (->* (module-path?) (#:namespace namespace?) (set/c module-binding?))] 14 | [module-provided-bindings 15 | (->* (module-path?) (#:namespace namespace?) (set/c module-binding?))] 16 | [module-internal-bindings 17 | (->* (module-path?) (#:namespace namespace?) (set/c module-binding?))])) 18 | 19 | (require racket/list 20 | racket/set 21 | rebellion/module/phase 22 | rebellion/type/tuple) 23 | 24 | (module+ test 25 | (require (submod "..") 26 | rackunit)) 27 | 28 | ;@------------------------------------------------------------------------------ 29 | 30 | (define (dynamic-declare mod #:namespace [ns (current-namespace)]) 31 | (parameterize ([current-namespace ns]) 32 | (dynamic-require mod (void)))) 33 | 34 | (define-tuple-type module-binding (source phase name)) 35 | 36 | (define (module-provided-bindings mod #:namespace [ns (make-base-namespace)]) 37 | (parameterize ([current-namespace ns]) 38 | (dynamic-declare mod) 39 | (define-values (exported-variables exported-syntax) (module->exports mod)) 40 | (for*/set ([export-list (in-list (list exported-variables exported-syntax))] 41 | [phase-export-list (in-list export-list)] 42 | [ph (in-value (phase (first phase-export-list)))] 43 | [export (in-list (rest phase-export-list))]) 44 | (define name (first export)) 45 | (module-binding mod ph name)))) 46 | 47 | (define (module-internal-bindings mod #:namespace [ns (make-base-namespace)]) 48 | (parameterize ([current-namespace ns]) 49 | (dynamic-declare mod) 50 | (for*/set ([phase-name-list (in-list (module->indirect-exports mod))] 51 | [ph (in-value (phase (first phase-name-list)))] 52 | [name (in-list (rest phase-name-list))]) 53 | (module-binding mod ph name)))) 54 | 55 | (define (module-bindings mod #:namespace [ns (make-base-namespace)]) 56 | (set-union (module-provided-bindings mod #:namespace ns) 57 | (module-internal-bindings mod #:namespace ns))) 58 | 59 | (module+ test 60 | (test-case "module-provided-bindings" 61 | (define m 'rebellion/module/binding) 62 | (check-equal? (module-provided-bindings m) 63 | (set 64 | (module-binding m runtime-phase 'module-binding) 65 | (module-binding m runtime-phase 'module-binding?) 66 | (module-binding m runtime-phase 'module-binding-source) 67 | (module-binding m runtime-phase 'module-binding-phase) 68 | (module-binding m runtime-phase 'module-binding-name) 69 | (module-binding m runtime-phase 'module-provided-bindings) 70 | (module-binding m runtime-phase 'module-internal-bindings) 71 | (module-binding m runtime-phase 'module-bindings))))) 72 | -------------------------------------------------------------------------------- /module/binding.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | racket/set 6 | rebellion/module/binding 7 | rebellion/module/phase) 8 | (submod rebellion/private/scribble-evaluator-factory doc) 9 | scribble/example) 10 | 11 | @(define make-evaluator 12 | (make-module-sharing-evaluator-factory 13 | #:public (list 'rebellion/module/binding) 14 | #:private (list 'racket/base))) 15 | 16 | @title{Module Bindings} 17 | @defmodule[rebellion/module/binding] 18 | 19 | @defproc[(module-binding? [v any/c]) boolean?] 20 | 21 | @defproc[(module-binding [source module-path?] 22 | [phase execution-phase?] 23 | [name symbol?]) 24 | module-binding?] 25 | 26 | @defproc[(module-binding-source [binding module-binding?]) module-path?] 27 | @defproc[(module-binding-phase [binding module-binding?]) phase?] 28 | @defproc[(module-binding-name [binding module-binding?]) symbol?] 29 | 30 | @defproc[(module-bindings [mod module-path?]) (set/c module-binding?)]{ 31 | Returns the set of bindings currently defined by @racket[mod], including both 32 | provided bindings and internal bindings. 33 | 34 | @(examples 35 | #:eval (make-evaluator) #:once 36 | (module-bindings 'racket/vector))} 37 | 38 | @defproc[(module-provided-bindings [mod module-path?]) 39 | (set/c module-binding?)]{ 40 | Returns the set of bindings currently defined and exported by @racket[mod] with 41 | @racket[provide]. 42 | 43 | @(examples 44 | #:eval (make-evaluator) #:once 45 | (module-provided-bindings 'racket/vector))} 46 | 47 | @defproc[(module-internal-bindings [mod module-path?]) 48 | (set/c module-binding?)]{ 49 | Returns the set of bindings currently defined by @racket[mod] but @emph{not} 50 | provided. 51 | 52 | @(examples 53 | #:eval (make-evaluator) #:once 54 | (module-internal-bindings 'racket/vector))} 55 | -------------------------------------------------------------------------------- /module/phase.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [phase (-> (or/c exact-integer? #f) phase?)] 8 | [phase? (-> any/c boolean?)] 9 | [phase-level (-> phase? (or/c exact-integer? #f))] 10 | [phase-shift (-> phase? exact-integer? phase?)] 11 | [label-phase label-phase?] 12 | [label-phase? (-> any/c boolean?)] 13 | [execution-phase (-> exact-integer? execution-phase?)] 14 | [execution-phase? (-> any/c boolean?)] 15 | [execution-phase-level (-> execution-phase? exact-integer?)] 16 | [execution-phase-shift (-> execution-phase? exact-integer? execution-phase?)] 17 | [runtime-phase execution-phase?] 18 | [compile-phase execution-phase?] 19 | [compile-phase-for (-> execution-phase? execution-phase?)] 20 | [template-phase execution-phase?] 21 | [template-phase-for (-> execution-phase? execution-phase?)] 22 | [meta-compile-phase execution-phase?])) 23 | 24 | (require rebellion/type/singleton 25 | rebellion/type/tuple) 26 | 27 | (module+ test 28 | (require (submod "..") 29 | rackunit)) 30 | 31 | ;@------------------------------------------------------------------------------ 32 | 33 | (define-tuple-type execution-phase (level)) 34 | (define-singleton-type label-phase) 35 | 36 | (define (phase? v) (or (execution-phase? v) (label-phase? v))) 37 | (define (phase level) (if level (execution-phase level) label-phase)) 38 | 39 | (define (phase-level ph) 40 | (and (not (label-phase? ph)) (execution-phase-level ph))) 41 | 42 | (define runtime-phase (phase 0)) 43 | (define compile-phase (phase 1)) 44 | (define template-phase (phase -1)) 45 | (define meta-compile-phase (phase 2)) 46 | 47 | (module+ test 48 | (test-case "phase-smart-constructor" 49 | (check-pred execution-phase? runtime-phase) 50 | (check-pred execution-phase? compile-phase) 51 | (check-pred execution-phase? template-phase) 52 | (check-pred execution-phase? meta-compile-phase) 53 | (check-pred label-phase? (phase #f)))) 54 | 55 | (define (phase-shift ph relative-level) 56 | (if (label-phase? ph) 57 | label-phase 58 | (execution-phase-shift ph relative-level))) 59 | 60 | (define (execution-phase-shift ph relative-level) 61 | (execution-phase (+ (execution-phase-level ph) relative-level))) 62 | 63 | (define (compile-phase-for ph) (execution-phase-shift ph 1)) 64 | (define (template-phase-for ph) (execution-phase-shift ph -1)) 65 | -------------------------------------------------------------------------------- /other.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title[#:style (list 'toc)]{Other Libraries} 4 | 5 | @local-table-of-contents[] 6 | 7 | @include-section[(lib "rebellion/custom-write.scrbl")] 8 | @include-section[(lib "rebellion/equal+hash.scrbl")] 9 | @include-section[(lib "rebellion/media.scrbl")] 10 | @include-section[(lib "rebellion/media/application/octet-stream.scrbl")] 11 | @include-section[(lib "rebellion/permutation.scrbl")] 12 | @include-section[(lib "rebellion/point.scrbl")] 13 | @include-section[(lib "rebellion/media/text/plain.scrbl")] 14 | @include-section[(lib "rebellion/web-graph.scrbl")] 15 | @include-section[(lib "rebellion/web-link.scrbl")] 16 | -------------------------------------------------------------------------------- /point.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [point (-> real? real? point?)] 8 | [point? (-> real? boolean?)] 9 | [point-x (-> point? real?)] 10 | [point-y (-> point? real?)])) 11 | 12 | (require rebellion/type/tuple) 13 | 14 | ;@------------------------------------------------------------------------------ 15 | 16 | (define-tuple-type point (x y)) 17 | -------------------------------------------------------------------------------- /point.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket/base 4 | racket/contract/base 5 | rebellion/point) 6 | (submod rebellion/private/scribble-evaluator-factory doc) 7 | scribble/example) 8 | 9 | @(define make-evaluator 10 | (make-module-sharing-evaluator-factory 11 | #:public (list 'rebellion/point) 12 | #:private (list 'racket/base))) 13 | 14 | @title{Points} 15 | @defmodule[rebellion/point] 16 | 17 | A @deftech{point} is a location in two-dimensional Euclidean geometry, 18 | represented by a pair of numbers. 19 | 20 | @defproc[(point? [v any/c]) boolean?]{ 21 | A predicate for @tech{points}.} 22 | 23 | @defproc[(point [x real?] [y real?]) point?]{ 24 | Constructs a @tech{point}.} 25 | 26 | @deftogether[[ 27 | @defproc[(point-x [pt point?]) real?] 28 | @defproc[(point-y [pt point?]) real?]]]{ 29 | Accessors for the X and Y components of a @tech{point}.} 30 | -------------------------------------------------------------------------------- /private/contract-projection.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [projection/c contract?] 8 | [contract-get-projection (-> (-> any/c boolean?) blame? projection/c)] 9 | [projection-and (-> projection/c ... projection/c)] 10 | [projection-convert 11 | (-> projection/c (-> any/c any/c) (-> any/c any/c) projection/c)] 12 | [projection-filter (-> projection/c (-> any/c boolean?) projection/c)] 13 | [assert-satisfies (-> any/c (-> any/c boolean?) blame? #:missing-party any/c void?)])) 14 | 15 | (require racket/contract/combinator) 16 | 17 | ;@------------------------------------------------------------------------------ 18 | 19 | (define projection/c (-> any/c any/c any/c)) 20 | 21 | (define (contract-get-projection predicate blame) 22 | ((contract-late-neg-projection predicate) blame)) 23 | 24 | (define ((projection-and . projections) v missing-party) 25 | (for/fold ([v v]) ([p (in-list projections)]) 26 | (p v missing-party))) 27 | 28 | (define ((projection-convert projection forwards backwards) v missing-party) 29 | (backwards (projection (forwards v) missing-party))) 30 | 31 | (define ((projection-filter projection pred) v missing-party) 32 | (if (pred v) (projection v missing-party) v)) 33 | 34 | (define (assert-satisfies v predicate blame #:missing-party missing-party) 35 | (unless (predicate v) 36 | (raise-blame-error blame #:missing-party missing-party v 37 | '(expected: "~a" given: "~e") 38 | (object-name predicate) 39 | v))) 40 | -------------------------------------------------------------------------------- /private/cut.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (struct-out upper-cut) 9 | (struct-out middle-cut) 10 | (struct-out lower-cut) 11 | (contract-out 12 | [cut? (-> any/c boolean?)] 13 | [top-cut cut?] 14 | [bottom-cut cut?] 15 | [intermediate-cut? (-> any/c boolean?)] 16 | [intermediate-cut-value (-> intermediate-cut? any/c)] 17 | [cut<=> (-> comparator? (comparator/c cut?))] 18 | [cut-flip-side (-> cut? cut?)])) 19 | 20 | 21 | (require guard 22 | racket/match 23 | rebellion/base/comparator 24 | rebellion/private/static-name) 25 | 26 | 27 | ;@---------------------------------------------------------------------------------------------------- 28 | 29 | 30 | (struct cut () #:transparent) 31 | (struct intermediate-cut cut () #:transparent) 32 | (struct upper-cut intermediate-cut (value) #:transparent) 33 | (struct middle-cut intermediate-cut (value) #:transparent) 34 | (struct lower-cut intermediate-cut (value) #:transparent) 35 | 36 | 37 | (struct top-cut cut () 38 | #:transparent 39 | #:omit-define-syntaxes 40 | #:constructor-name constructor:top-cut) 41 | 42 | 43 | (struct bottom-cut cut () 44 | #:transparent 45 | #:omit-define-syntaxes 46 | #:constructor-name constructor:bottom-cut) 47 | 48 | 49 | (define top-cut (constructor:top-cut)) 50 | (define bottom-cut (constructor:bottom-cut)) 51 | 52 | 53 | (define (intermediate-cut-value cut) 54 | (match cut 55 | [(upper-cut value) value] 56 | [(middle-cut value) value] 57 | [(lower-cut value) value])) 58 | 59 | 60 | (define (cut<=> base-comparator) 61 | ;; Using a cache ensures that a == b implies (cut<=> a) == (cut<=> b) 62 | (hash-ref! 63 | cut-comparator-cache 64 | base-comparator 65 | (λ () (make-comparator (cut-compare base-comparator) #:name (name cut<=>))))) 66 | 67 | 68 | (define cut-comparator-cache (make-ephemeron-hash)) 69 | 70 | 71 | (define/guard ((cut-compare base-comparator) left right) 72 | (cond 73 | [(and (equal? left bottom-cut) (equal? right bottom-cut)) equivalent] 74 | [(equal? left bottom-cut) lesser] 75 | [(equal? right bottom-cut) greater] 76 | [(and (equal? left top-cut) (equal? right top-cut)) equivalent] 77 | [(equal? left top-cut) greater] 78 | [(equal? right top-cut) lesser] 79 | [else 80 | (define result 81 | (compare 82 | base-comparator 83 | (intermediate-cut-value left) 84 | (intermediate-cut-value right))) 85 | (cond 86 | [(or (equal? result lesser) (equal? result greater)) result] 87 | [(and (lower-cut? left) (lower-cut? right)) equivalent] 88 | [(lower-cut? left) lesser] 89 | [(lower-cut? right) greater] 90 | [(and (middle-cut? left) (middle-cut? right)) equivalent] 91 | [(middle-cut? left) lesser] 92 | [(middle-cut? right) greater] 93 | [else equivalent])])) 94 | 95 | 96 | (define (cut-flip-side cut) 97 | (match cut 98 | [(upper-cut value) (lower-cut value)] 99 | [(lower-cut value) (upper-cut value)] 100 | [_ cut])) 101 | -------------------------------------------------------------------------------- /private/for-body.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide for-body) 5 | 6 | 7 | (require syntax/for-body 8 | syntax/parse) 9 | 10 | 11 | ;@---------------------------------------------------------------------------------------------------- 12 | 13 | 14 | (define-splicing-syntax-class (for-body context) 15 | #:attributes ([pre-body 1] [post-body 1]) 16 | (pattern (~seq body ... tail-expr:expr) 17 | #:with ((pre-body ...) (post-body ...)) (split-for-body context #'(body ... tail-expr)))) 18 | -------------------------------------------------------------------------------- /private/precondition.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [check-precondition (unconstrained-domain-> void?)])) 10 | 11 | 12 | ;@---------------------------------------------------------------------------------------------------- 13 | 14 | 15 | (define (check-precondition precondition source-name error-message-template . template-args) 16 | (unless precondition 17 | (apply raise-arguments-error source-name error-message-template template-args))) 18 | -------------------------------------------------------------------------------- /private/scribble-cross-document-tech.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module doc racket/base 4 | 5 | (require racket/contract/base) 6 | 7 | (provide 8 | (contract-out 9 | ;; Similar to @tech{....}, but creates a link to a `deftech` in The Racket 10 | ;; Guide. 11 | [tech/guide cross-document-tech-function/c] 12 | ;; Links to a `deftech` in The Racket Reference. 13 | [tech/reference cross-document-tech-function/c] 14 | ;; Links to a `deftech` in the `syntax/` libraries. 15 | [syntax-tech cross-document-tech-function/c])) 16 | 17 | (require rebellion/base/immutable-string 18 | scribble/base 19 | scribble/core 20 | scribble/decode 21 | scribble/manual) 22 | 23 | ;@---------------------------------------------------------------------------- 24 | 25 | (define cross-document-tech-function/c 26 | (->* () 27 | (#:key (or/c string? #f) #:normalize? boolean?) 28 | #:rest (listof pre-content?) 29 | element?)) 30 | 31 | (define (tech/guide #:key [key #f] #:normalize? [normalize? #t] . text) 32 | (apply tech 33 | #:doc '(lib "scribblings/guide/guide.scrbl") 34 | #:key key 35 | #:normalize? normalize? 36 | text)) 37 | 38 | (define (tech/reference #:key [key #f] #:normalize? [normalize? #t] . text) 39 | (apply tech 40 | #:doc '(lib "scribblings/reference/reference.scrbl") 41 | #:key key 42 | #:normalize? normalize? 43 | text)) 44 | 45 | (define (syntax-tech #:key [key #f] #:normalize? [normalize? #t] . text) 46 | (apply tech 47 | #:doc '(lib "syntax/scribblings/syntax.scrbl") 48 | #:key key 49 | #:normalize? normalize? 50 | text))) 51 | -------------------------------------------------------------------------------- /private/scribble-evaluator-factory.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module doc racket/base 4 | 5 | (require racket/contract/base) 6 | 7 | (provide 8 | (contract-out 9 | [evaluator/c contract?] 10 | [evaluator-factory? (-> any/c boolean?)] 11 | [evaluator-factory-create (-> evaluator-factory? evaluator/c)] 12 | [make-module-sharing-evaluator-factory 13 | (->* () 14 | (#:private (listof module-path?) 15 | #:public (listof module-path?)) 16 | evaluator-factory?)])) 17 | 18 | (require racket/list 19 | scribble/example) 20 | 21 | ;@---------------------------------------------------------------------------- 22 | 23 | (define evaluator/c (-> any/c any/c)) 24 | 25 | (struct evaluator-factory (thunk) 26 | #:constructor-name make-evaluator-factory 27 | #:property prop:procedure 0) 28 | 29 | (define (evaluator-factory-create factory) 30 | ((evaluator-factory-thunk factory))) 31 | 32 | (define (make-module-sharing-evaluator-factory 33 | #:public [public-modules empty] 34 | #:private [private-modules empty]) 35 | (define base-factory 36 | (make-base-eval-factory (append private-modules public-modules))) 37 | (define (factory) 38 | (define evaluator (base-factory)) 39 | (evaluator `(require ,@public-modules)) 40 | evaluator) 41 | (make-evaluator-factory factory))) 42 | -------------------------------------------------------------------------------- /private/scribble-index-attribute.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module doc racket/base 4 | 5 | (provide index-attribute) 6 | 7 | (require (for-syntax racket/base 8 | racket/symbol) 9 | scribble/manual 10 | syntax/parse/define) 11 | 12 | ;@---------------------------------------------------------------------------- 13 | 14 | ;; This is used to document the attributes of syntax classes. It indexes them 15 | ;; in Scribble as class.attribute, so they can be searched. 16 | (define-syntax-parse-rule (index-attribute class-id:id 17 | attribute-id:id 18 | (~and ellipsis (~literal ...)) ...) 19 | #:with attribute-string (symbol->immutable-string (syntax-e #'attribute-id)) 20 | #:with (ellipses-string ...) (for/list ([_ (in-range (length (syntax->list #'(ellipsis ...))))]) 21 | #`'" ...") 22 | #:with indexed-word (format "~a.~a" (syntax-e #'class-id) (syntax-e #'attribute-id)) 23 | (index* (list 'indexed-word) 24 | (list (racketidfont 'indexed-word)) 25 | (racketidfont 'attribute-string ellipses-string ...)))) 26 | -------------------------------------------------------------------------------- /private/sequence-empty.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [sequence-empty? (-> sequence? boolean?)])) 10 | 11 | 12 | (module+ test 13 | (require (submod "..") 14 | rackunit 15 | rebellion/private/static-name)) 16 | 17 | 18 | ;@---------------------------------------------------------------------------------------------------- 19 | 20 | 21 | (define (sequence-empty? sequence) 22 | (define-values (has-next? get-next!) (sequence-generate sequence)) 23 | (not (has-next?))) 24 | 25 | 26 | (module+ test 27 | (test-case (name-string sequence-empty?) 28 | (check-true (sequence-empty? '())) 29 | (check-false (sequence-empty? (list 1))) 30 | (check-true (sequence-empty? (vector))) 31 | (check-false (sequence-empty? (vector 1))) 32 | (check-true (sequence-empty? (in-range 0 0))) 33 | (check-false (sequence-empty? (in-range 0 1))))) 34 | -------------------------------------------------------------------------------- /private/strict-cond.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide strict-cond) 4 | 5 | (require (for-syntax racket/base) 6 | syntax/parse/define) 7 | 8 | (module+ test 9 | (require (submod "..") 10 | rackunit 11 | rebellion/private/static-name)) 12 | 13 | ;@------------------------------------------------------------------------------ 14 | 15 | (define-syntax-parser strict-cond 16 | #:literals (else) 17 | #:track-literals 18 | [(_ [condition:expr body ...+] ... [else ~! else-body ...+]) 19 | #'(cond [condition body ...] ... [else else-body ...])] 20 | [(_ [condition:expr body ...+] ...) 21 | #:with raise-error 22 | (syntax/loc this-syntax 23 | (raise-arguments-error 'strict-cond "none of the conditions were true")) 24 | #'(cond [condition body ...] ... [else raise-error])]) 25 | 26 | (module+ test 27 | (test-case (name-string strict-cond) 28 | (check-equal? (strict-cond [else 42]) 42) 29 | (check-equal? (strict-cond [#t 1] [else 2]) 1) 30 | (check-equal? (strict-cond [#f 1] [else 2]) 2) 31 | (check-equal? (strict-cond [#t 1]) 1) 32 | (check-exn exn:fail:contract? (λ () (strict-cond [#f 1]))) 33 | (check-exn exn:fail:contract? (λ () (strict-cond))))) 34 | -------------------------------------------------------------------------------- /private/subsequence.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [subsequence 8 | (->i ([sequence sequence?] 9 | [start natural?]) 10 | ([end (start) (or/c (integer-in start #f) #f)]) 11 | [_ sequence?])])) 12 | 13 | (require guard 14 | racket/math 15 | racket/sequence) 16 | 17 | (module+ test 18 | (require (submod "..") 19 | rackunit)) 20 | 21 | ;@------------------------------------------------------------------------------ 22 | 23 | (define/guard (subsequence sequence start [end #false]) 24 | (guard end #:else 25 | (sequence-tail sequence start)) 26 | (define limit (- end start)) 27 | (define indexed-tail 28 | (sequence-map cons (in-indexed (sequence-tail sequence start)))) 29 | (define indexed-subsequence 30 | (stop-before indexed-tail (λ (pair) (>= (cdr pair) limit)))) 31 | (sequence-map car indexed-subsequence)) 32 | 33 | (module+ test 34 | (test-case "subsequence" 35 | (test-case "no end" 36 | (define seq (subsequence "hello world" 3)) 37 | (check-equal? (list->string (sequence->list seq)) "lo world")) 38 | 39 | (test-case "end" 40 | (define seq (subsequence "hello world" 3 8)) 41 | (check-equal? (list->string (sequence->list seq)) "lo wo")))) 42 | -------------------------------------------------------------------------------- /private/todo.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (provide TODO) 5 | 6 | 7 | (require (for-syntax racket/base 8 | syntax/parse)) 9 | 10 | 11 | ;@---------------------------------------------------------------------------------------------------- 12 | 13 | 14 | (define-syntax (TODO stx) 15 | (syntax-parse stx 16 | #:track-literals 17 | #:literals (TODO) 18 | [TODO 19 | #:with original stx 20 | #'(raise-syntax-error #false "not yet implemented" #'original)])) 21 | -------------------------------------------------------------------------------- /private/vector-merge-adjacent.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [vector-merge-adjacent 10 | (-> vector? (-> any/c any/c boolean?) (-> any/c any/c any/c) (and/c vector? immutable?))])) 11 | 12 | 13 | (require guard 14 | rebellion/collection/vector/builder) 15 | 16 | 17 | (module+ test 18 | (require (submod "..") 19 | rackunit 20 | rebellion/private/static-name)) 21 | 22 | 23 | ;@---------------------------------------------------------------------------------------------------- 24 | 25 | 26 | ;; Returns a new (immutable) vector that is like vec, except adjacent elements are merged with 27 | ;; merge-function when should-merge? returns true. 28 | ;; 29 | ;; Examples: 30 | ;; 31 | ;; > (vector-merge-adjacent (vector 1 2 3 "hello" 4 5 "world" 6) both-numbers? +) 32 | ;; (vector 6 "hello" 9 "world" 6) 33 | ;; 34 | (define/guard (vector-merge-adjacent vec should-merge? merge-function) 35 | (define count (vector-length vec)) 36 | (guard (>= count 2) #:else 37 | (vector->immutable-vector vec)) 38 | (for/fold ([builder (make-vector-builder #:expected-size count)] 39 | [element (vector-ref vec 0)] 40 | #:result (build-vector (vector-builder-add builder element))) 41 | ([next-element (in-vector vec 1)]) 42 | (if (should-merge? element next-element) 43 | (values builder (merge-function element next-element)) 44 | (values (vector-builder-add builder element) next-element)))) 45 | 46 | 47 | (module+ test 48 | (test-case (name-string vector-merge-adjacent) 49 | 50 | (define (both-numbers? left right) 51 | (and (number? left) (number? right))) 52 | 53 | (define (fail-immediately left right) 54 | (raise 'should-not-be-called)) 55 | 56 | (test-case "empty vectors are returned uninspected" 57 | (define actual (vector-merge-adjacent (vector-immutable) fail-immediately fail-immediately)) 58 | (check-equal? actual (vector-immutable))) 59 | 60 | (test-case "single-element vectors are returned uninspected" 61 | (define actual (vector-merge-adjacent (vector-immutable 1) fail-immediately fail-immediately)) 62 | (check-equal? actual (vector-immutable 1))) 63 | 64 | (test-case "can merge all elements" 65 | (define actual (vector-merge-adjacent (vector-immutable 1 2 3 4 5) (λ (a b) #true) +)) 66 | (check-equal? actual (vector-immutable 15))) 67 | 68 | (test-case "can merge no elements" 69 | (define actual 70 | (vector-merge-adjacent (vector-immutable 1 2 3 4 5) (λ (a b) #false) fail-immediately)) 71 | (check-equal? actual (vector-immutable 1 2 3 4 5))) 72 | 73 | (test-case "can merge elements at start" 74 | (define actual (vector-merge-adjacent (vector-immutable 1 2 3 'a 'b 'c) both-numbers? +)) 75 | (check-equal? actual (vector-immutable 6 'a 'b 'c))) 76 | 77 | (test-case "can merge elements at end" 78 | (define actual (vector-merge-adjacent (vector-immutable 'a 'b 'c 4 5 6) both-numbers? +)) 79 | (check-equal? actual (vector-immutable 'a 'b 'c 15))) 80 | 81 | (test-case "can merge elements in middle" 82 | (define actual 83 | (vector-merge-adjacent (vector-immutable 'a 'b 'c 4 5 6 'd 'e 'f) both-numbers? +)) 84 | (check-equal? actual (vector-immutable 'a 'b 'c 15 'd 'e 'f))) 85 | 86 | (test-case "can merge elements in middle multiple times" 87 | (define actual 88 | (vector-merge-adjacent (vector-immutable 1 2 3 "hello" 4 5 "world" 6) both-numbers? +)) 89 | (check-equal? actual (vector-immutable 6 "hello" 9 "world" 6))))) -------------------------------------------------------------------------------- /setup: -------------------------------------------------------------------------------- 1 | raco setup --doc-index --check-pkg-deps --tidy --unused-pkg-deps --pkgs rebellion 2 | -------------------------------------------------------------------------------- /streaming.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title[#:style (list 'toc)]{Streaming Computations} 4 | 5 | @local-table-of-contents[] 6 | 7 | @include-section[(lib "rebellion/streaming/reducer.scrbl")] 8 | @include-section[(lib "rebellion/streaming/transducer.scrbl")] 9 | -------------------------------------------------------------------------------- /streaming/reducer/private/base-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (module+ test 5 | (require racket/contract/base 6 | racket/contract/combinator 7 | racket/contract/region 8 | rackunit 9 | rebellion/collection/list 10 | rebellion/private/static-name 11 | rebellion/streaming/reducer)) 12 | 13 | 14 | ;@---------------------------------------------------------------------------------------------------- 15 | 16 | 17 | (module+ test 18 | (test-case (name-string reducer-impersonate) 19 | (test-case "properties only" 20 | (define reducer (into-all-match? even?)) 21 | (define properties (hash impersonator-prop:contracted 'foo)) 22 | (define impersonated 23 | (reducer-impersonate reducer #:properties properties)) 24 | (check-equal? (value-contract impersonated) 'foo) 25 | (check-equal? impersonated reducer) 26 | (check impersonator-of? impersonated reducer) 27 | (check impersonator-of? reducer impersonated) 28 | (check chaperone-of? impersonated reducer) 29 | (check chaperone-of? reducer impersonated)) 30 | 31 | (test-case "domain guard" 32 | (define counter (box 0)) 33 | (define (guard v) 34 | (set-box! counter (add1 (unbox counter))) 35 | v) 36 | (define impersonated 37 | (reducer-impersonate into-list #:domain-guard guard #:chaperone? #true)) 38 | (check-equal? (reduce impersonated 'a 'b 'c) (list 'a 'b 'c)) 39 | (check-equal? (unbox counter) 3) 40 | (check-equal? impersonated into-list) 41 | (check impersonator-of? impersonated into-list) 42 | (check-false (impersonator-of? into-list impersonated)) 43 | (check chaperone-of? impersonated into-list) 44 | (check-false (chaperone-of? into-list impersonated))) 45 | 46 | (test-case "range guard" 47 | (define result (box #false)) 48 | (define (guard v) 49 | (set-box! result v) 50 | v) 51 | (define impersonated 52 | (reducer-impersonate into-list #:range-guard guard #:chaperone? #true)) 53 | (check-equal? (reduce impersonated 1 2 3) (list 1 2 3)) 54 | (check-equal? (unbox result) (list 1 2 3)) 55 | (check-equal? impersonated into-list) 56 | (check impersonator-of? impersonated into-list) 57 | (check-false (impersonator-of? into-list impersonated)) 58 | (check chaperone-of? impersonated into-list) 59 | (check-false (chaperone-of? into-list impersonated)))) 60 | 61 | (test-case (name-string reducer/c) 62 | (test-case "should enforce the domain contract on sequence elements" 63 | (define/contract reducer (reducer/c number? any/c) into-list) 64 | (check-not-exn (λ () (reduce reducer 1 2 3))) 65 | (define (bad) (reduce reducer 1 2 'foo 3)) 66 | (check-exn exn:fail:contract:blame? bad) 67 | (check-exn #rx"expected: number\\?" bad) 68 | (check-exn #rx"given: 'foo" bad) 69 | (check-exn #rx"an element reduced by" bad)) 70 | 71 | (test-case "should enforce the range contract on reduction results" 72 | (define/contract reducer (reducer/c any/c integer?) into-sum) 73 | (check-not-exn (λ () (reduce reducer 1 2 3))) 74 | (define (bad) (reduce reducer 1 2 3.5)) 75 | (check-exn exn:fail:contract:blame? bad) 76 | (check-exn #rx"promised: integer\\?" bad) 77 | (check-exn #rx"produced: 6\\.5" bad) 78 | (check-exn #rx"the reduction result of" bad)))) -------------------------------------------------------------------------------- /streaming/reducer/private/zip-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (module+ test 5 | (require rackunit 6 | rebellion/base/option 7 | rebellion/private/static-name 8 | rebellion/streaming/reducer 9 | rebellion/streaming/transducer 10 | rebellion/type/tuple)) 11 | 12 | 13 | ;@---------------------------------------------------------------------------------------------------- 14 | 15 | 16 | (module+ test 17 | (test-case (name-string reducer-zip) 18 | 19 | (test-case "no early finishing" 20 | (define into-average (reducer-zip / into-sum into-count)) 21 | (check-equal? (transduce (list 1 2 3 4 5) #:into into-average) 3) 22 | (check-equal? (transduce (list 2) #:into into-average) 2)) 23 | 24 | (test-case "one reducer finishes early" 25 | (define-tuple-type endpoints (first last)) 26 | (define into-endpoints (reducer-zip endpoints nonempty-into-first nonempty-into-last)) 27 | (check-equal? (transduce (list 1 2 3 4 5) #:into into-endpoints) (endpoints 1 5))) 28 | 29 | (test-case "all reducers finish early" 30 | (define-tuple-type first-two-elements (first second)) 31 | (define into-first-two-elements (reducer-zip first-two-elements into-first (into-nth 1))) 32 | (define actual (transduce (in-naturals) #:into into-first-two-elements)) 33 | (check-equal? actual (first-two-elements (present 0) (present 1)))))) -------------------------------------------------------------------------------- /streaming/reducer/private/zip.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [reducer-zip 10 | (->i 11 | #:chaperone 12 | ([zip-function procedure?]) 13 | #:rest [reducers (listof reducer?)] 14 | #:pre/name (zip-function reducers) 15 | "zip function arity must match up with the number of reducers given" 16 | (procedure-arity-includes? zip-function (length reducers)) 17 | [_ reducer?])])) 18 | 19 | 20 | (require rebellion/base/variant 21 | rebellion/private/static-name 22 | rebellion/streaming/reducer/private/base 23 | rebellion/type/record) 24 | 25 | 26 | ;@---------------------------------------------------------------------------------------------------- 27 | 28 | 29 | (define-record-type zip-state (substate-values finished-reducers)) 30 | 31 | 32 | (define/name (reducer-zip zip-function . reducers) 33 | (define reducer-count (length reducers)) 34 | (define starters 35 | (vector->immutable-vector 36 | (for/vector #:length reducer-count ([reducer (in-list reducers)]) (reducer-starter reducer)))) 37 | (define consumers 38 | (vector->immutable-vector 39 | (for/vector #:length reducer-count ([reducer (in-list reducers)]) (reducer-consumer reducer)))) 40 | (define finishers 41 | (vector->immutable-vector 42 | (for/vector #:length reducer-count ([reducer (in-list reducers)]) (reducer-finisher reducer)))) 43 | (define early-finishers 44 | (vector->immutable-vector 45 | (for/vector #:length reducer-count 46 | ([reducer (in-list reducers)]) 47 | (reducer-early-finisher reducer)))) 48 | 49 | (define (tag-state state) 50 | (if (for/and ([finished-early? (in-vector (zip-state-finished-reducers state))]) finished-early?) 51 | (variant #:early-finish state) 52 | (variant #:consume state))) 53 | 54 | (define (start) 55 | (define substates (for/vector ([starter (in-vector starters)]) (starter))) 56 | (define substate-values (for/vector ([substate (in-vector substates)]) (variant-value substate))) 57 | (define finished-reducers 58 | (for/vector ([substate (in-vector substates)]) (variant-tagged-as? substate '#:early-finish))) 59 | (tag-state (zip-state #:substate-values substate-values #:finished-reducers finished-reducers))) 60 | 61 | (define (consume state element) 62 | (define substates (zip-state-substate-values state)) 63 | (define finished (zip-state-finished-reducers state)) 64 | (for ([i (in-range 0 reducer-count)] 65 | #:unless (vector-ref finished i)) 66 | (define substate (vector-ref substates i)) 67 | (define next-substate ((vector-ref consumers i) substate element)) 68 | (vector-set! substates i (variant-value next-substate)) 69 | (vector-set! finished i (variant-tagged-as? next-substate '#:early-finish))) 70 | (tag-state state)) 71 | 72 | (define (finish state) 73 | (define substates (zip-state-substate-values state)) 74 | (define finished (zip-state-finished-reducers state)) 75 | (define results 76 | (for/list ([i (in-range 0 reducer-count)]) 77 | (define substate (vector-ref substates i)) 78 | (define finish-function (vector-ref (if (vector-ref finished i) early-finishers finishers) i)) 79 | (finish-function substate))) 80 | (apply zip-function results)) 81 | 82 | (define (finish-early state) 83 | (define substates (zip-state-substate-values state)) 84 | (define results 85 | (for/list ([i (in-range 0 reducer-count)]) 86 | (define substate (vector-ref substates i)) 87 | (define finish-function (vector-ref early-finishers i)) 88 | (finish-function substate))) 89 | (apply zip-function results)) 90 | 91 | (make-reducer 92 | #:starter start 93 | #:consumer consume 94 | #:finisher finish 95 | #:early-finisher finish-early 96 | #:name 'zipped)) 97 | -------------------------------------------------------------------------------- /streaming/transducer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rebellion/streaming/transducer/base 4 | rebellion/streaming/transducer/composition 5 | rebellion/streaming/transducer/private 6 | rebellion/streaming/transducer/private/adding-between 7 | rebellion/streaming/transducer/private/batching 8 | rebellion/streaming/transducer/private/contract 9 | rebellion/streaming/transducer/private/deduplicating 10 | rebellion/streaming/transducer/private/enumerating 11 | rebellion/streaming/transducer/private/reducer 12 | rebellion/streaming/transducer/private/shuffling 13 | rebellion/streaming/transducer/private/sorting 14 | rebellion/streaming/transducer/private/splicing-between 15 | rebellion/streaming/transducer/private/taking-duplicates 16 | rebellion/streaming/transducer/private/taking-local-maxima 17 | rebellion/streaming/transducer/private/taking-maxima 18 | rebellion/streaming/transducer/private/transposing 19 | rebellion/streaming/transducer/private/windowing) 20 | 21 | (provide (all-from-out rebellion/streaming/transducer/base 22 | rebellion/streaming/transducer/composition 23 | rebellion/streaming/transducer/private 24 | rebellion/streaming/transducer/private/adding-between 25 | rebellion/streaming/transducer/private/batching 26 | rebellion/streaming/transducer/private/contract 27 | rebellion/streaming/transducer/private/deduplicating 28 | rebellion/streaming/transducer/private/enumerating 29 | rebellion/streaming/transducer/private/reducer 30 | rebellion/streaming/transducer/private/shuffling 31 | rebellion/streaming/transducer/private/sorting 32 | rebellion/streaming/transducer/private/splicing-between 33 | rebellion/streaming/transducer/private/taking-duplicates 34 | rebellion/streaming/transducer/private/taking-local-maxima 35 | rebellion/streaming/transducer/private/taking-maxima 36 | rebellion/streaming/transducer/private/transposing 37 | rebellion/streaming/transducer/private/windowing)) 38 | -------------------------------------------------------------------------------- /streaming/transducer/private/adding-between-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (module+ test 5 | (require rackunit 6 | rebellion/base/immutable-string 7 | rebellion/collection/list 8 | rebellion/private/static-name 9 | rebellion/streaming/reducer 10 | rebellion/streaming/transducer 11 | rebellion/streaming/transducer/testing)) 12 | 13 | 14 | ;@---------------------------------------------------------------------------------------------------- 15 | 16 | 17 | (module+ test 18 | (test-case (name-string adding-between) 19 | 20 | (test-case "should do nothing for empty sequences" 21 | (define actual-events 22 | (transduce '() (observing-transduction-events (adding-between 42)) #:into into-list)) 23 | 24 | (define expected-events 25 | (list start-event 26 | half-close-event 27 | finish-event)) 28 | (check-equal? actual-events expected-events)) 29 | 30 | (test-case "should leave singleton sequences unchanged" 31 | (define actual-events 32 | (transduce (list 'foo) (observing-transduction-events (adding-between 42)) #:into into-list)) 33 | 34 | (define expected-events 35 | (list start-event 36 | (consume-event 'foo) 37 | half-close-event 38 | (half-closed-emit-event 'foo) 39 | finish-event)) 40 | (check-equal? actual-events expected-events)) 41 | 42 | (test-case "should add an element in the middle of two-element sequences" 43 | (define actual-events 44 | (transduce (list 'foo 'bar) 45 | (observing-transduction-events (adding-between 42)) 46 | #:into into-list)) 47 | 48 | (define expected-events 49 | (list start-event 50 | (consume-event 'foo) 51 | (consume-event 'bar) 52 | (emit-event 'foo) 53 | (emit-event 42) 54 | half-close-event 55 | (half-closed-emit-event 'bar) 56 | finish-event)) 57 | (check-equal? actual-events expected-events)) 58 | 59 | (test-case "should add an element between each element of a many-element sequence" 60 | (define actual-events 61 | (transduce (list 'a 'b 'c 'd 'e) 62 | (observing-transduction-events (adding-between 42)) 63 | #:into into-list)) 64 | 65 | (define expected-events 66 | (list start-event 67 | (consume-event 'a) 68 | (consume-event 'b) 69 | (emit-event 'a) 70 | (emit-event 42) 71 | (consume-event 'c) 72 | (emit-event 'b) 73 | (emit-event 42) 74 | (consume-event 'd) 75 | (emit-event 'c) 76 | (emit-event 42) 77 | (consume-event 'e) 78 | (emit-event 'd) 79 | (emit-event 42) 80 | half-close-event 81 | (half-closed-emit-event 'e) 82 | finish-event)) 83 | (check-equal? actual-events expected-events)))) 84 | -------------------------------------------------------------------------------- /streaming/transducer/private/adding-between.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [adding-between (-> any/c transducer?)])) 10 | 11 | 12 | (require racket/match 13 | rebellion/base/option 14 | rebellion/base/variant 15 | rebellion/private/static-name 16 | rebellion/streaming/transducer/base) 17 | 18 | 19 | ;@---------------------------------------------------------------------------------------------------- 20 | 21 | 22 | (define (adding-between v) 23 | (make-transducer 24 | 25 | #:starter (λ () (variant #:consume absent)) 26 | 27 | #:consumer 28 | (λ (previous-element-opt next) 29 | (if (present? previous-element-opt) 30 | (variant #:emit (list previous-element-opt next)) 31 | (variant #:consume (present next)))) 32 | 33 | #:emitter 34 | (λ (state) 35 | (match-define (list previous-element-opt next) state) 36 | (match previous-element-opt 37 | [(present e) (emission (variant #:emit (list absent next)) e)] 38 | [(== absent) (emission (variant #:consume (present next)) v)])) 39 | 40 | #:half-closer 41 | (λ (previous-element-opt) 42 | (match previous-element-opt 43 | [(present e) (variant #:half-closed-emit e)] 44 | [(== absent) (variant #:finish #false)])) 45 | 46 | #:half-closed-emitter 47 | (λ (last-element) 48 | (half-closed-emission (variant #:finish #false) last-element)) 49 | 50 | #:finisher void 51 | #:name (name adding-between))) 52 | -------------------------------------------------------------------------------- /streaming/transducer/private/batching.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [batching (-> reducer? transducer?)])) 8 | 9 | (require guard 10 | rebellion/base/variant 11 | rebellion/private/static-name 12 | rebellion/streaming/reducer 13 | rebellion/streaming/transducer/base 14 | rebellion/type/singleton 15 | rebellion/type/tuple) 16 | 17 | ;@------------------------------------------------------------------------------ 18 | 19 | (define-singleton-type unstarted-batch-placeholder) 20 | (define-tuple-type batch (state)) 21 | 22 | (define/name (batching batch-reducer) 23 | (define batch-starter (reducer-starter batch-reducer)) 24 | (define batch-consumer (reducer-consumer batch-reducer)) 25 | (define batch-finisher (reducer-finisher batch-reducer)) 26 | (define batch-early-finisher (reducer-early-finisher batch-reducer)) 27 | (define (start-new-batch) 28 | (define init-state (batch-starter)) 29 | (unless (variant-tagged-as? init-state '#:consume) 30 | (raise-arguments-error enclosing-function-name 31 | "batch reducer must consume at least one value" 32 | "batch reducer" batch-reducer 33 | "batch start state" init-state)) 34 | (batch (variant-value init-state))) 35 | (define (start) (variant #:consume unstarted-batch-placeholder)) 36 | (define (consume current-batch v) 37 | (define state 38 | (batch-state 39 | (if (unstarted-batch-placeholder? current-batch) 40 | (start-new-batch) 41 | current-batch))) 42 | (define next-state (batch-consumer state v)) 43 | (if (variant-tagged-as? next-state '#:consume) 44 | (variant #:consume (batch (variant-value next-state))) 45 | (variant #:emit (batch-early-finisher (variant-value next-state))))) 46 | (define (emit batch-result) 47 | (emission (start) batch-result)) 48 | (define/guard (half-close last-batch) 49 | (guard (not (unstarted-batch-placeholder? last-batch)) #:else 50 | (variant #:finish #f)) 51 | (define last-batch-result (batch-finisher (batch-state last-batch))) 52 | (variant #:half-closed-emit last-batch-result)) 53 | (define (half-closed-emit last-batch-result) 54 | (half-closed-emission (variant #:finish #f) last-batch-result)) 55 | (make-transducer 56 | #:starter start 57 | #:consumer consume 58 | #:emitter emit 59 | #:half-closer half-close 60 | #:half-closed-emitter half-closed-emit 61 | #:finisher void 62 | #:name enclosing-function-name)) 63 | -------------------------------------------------------------------------------- /streaming/transducer/private/contract-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require (submod "..") 5 | racket/contract/base 6 | racket/contract/combinator 7 | racket/contract/region 8 | rackunit 9 | rebellion/collection/list 10 | rebellion/private/static-name 11 | rebellion/streaming/transducer)) 12 | 13 | ;@------------------------------------------------------------------------------ 14 | 15 | (module+ test 16 | (test-case (name-string transducer/c) 17 | (test-case "should enforce the domain contract on consumed elements" 18 | (define/contract transducer (transducer/c number? any/c) (mapping add1)) 19 | (check-not-exn 20 | (λ () (transduce (list 1 2 3) transducer #:into into-list))) 21 | (define (bad) (transduce (list 1 2 'foo 3) transducer #:into into-list)) 22 | (check-exn exn:fail:contract:blame? bad) 23 | (check-exn #rx"expected: number\\?" bad) 24 | (check-exn #rx"given: 'foo" bad) 25 | (check-exn #rx"an element consumed by" bad)) 26 | 27 | (test-case "should enforce the range contract on emitted elements" 28 | (define/contract transducer (transducer/c any/c integer?) (mapping add1)) 29 | (check-not-exn 30 | (λ () (transduce (list 1 2 3) transducer #:into into-list))) 31 | (define (bad) (transduce (list 1 2 3.5) transducer #:into into-list)) 32 | (check-exn exn:fail:contract:blame? bad) 33 | (check-exn #rx"promised: integer\\?" bad) 34 | (check-exn #rx"produced: 4\\.5" bad) 35 | (check-exn #rx"an element emitted by" bad)))) 36 | -------------------------------------------------------------------------------- /streaming/transducer/private/contract.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [transducer/c (-> contract? contract? contract?)])) 8 | 9 | (require racket/contract/combinator 10 | rebellion/private/contract-projection 11 | rebellion/private/static-name 12 | rebellion/streaming/transducer/base) 13 | 14 | ;@------------------------------------------------------------------------------ 15 | 16 | (define/name (transducer/c domain-contract* range-contract*) 17 | (define domain-contract 18 | (coerce-contract enclosing-function-name domain-contract*)) 19 | (define range-contract 20 | (coerce-contract enclosing-function-name range-contract*)) 21 | (define contract-name 22 | (build-compound-type-name enclosing-function-name 23 | domain-contract 24 | range-contract)) 25 | (define domain-projection (contract-late-neg-projection domain-contract)) 26 | (define range-projection (contract-late-neg-projection range-contract)) 27 | (define chaperone? 28 | (and (chaperone-contract? domain-contract) 29 | (chaperone-contract? range-contract))) 30 | (define (projection blame) 31 | (define domain-blame 32 | (blame-add-context blame "an element consumed by" #:swap? #t)) 33 | (define range-blame (blame-add-context blame "an element emitted by")) 34 | (define late-neg-domain-guard (domain-projection domain-blame)) 35 | (define late-neg-range-guard (range-projection range-blame)) 36 | (λ (v missing-party) 37 | (assert-satisfies v transducer? blame #:missing-party missing-party) 38 | (define props 39 | (hash impersonator-prop:contracted the-contract 40 | impersonator-prop:blame (cons blame missing-party))) 41 | (define (domain-guard v) (late-neg-domain-guard v missing-party)) 42 | (define (range-guard v) (late-neg-range-guard v missing-party)) 43 | (transducer-impersonate v 44 | #:domain-guard domain-guard 45 | #:range-guard range-guard 46 | #:chaperone? chaperone? 47 | #:properties props))) 48 | (define the-contract 49 | ((if chaperone? make-chaperone-contract make-contract) 50 | #:name contract-name 51 | #:first-order transducer? 52 | #:late-neg-projection projection)) 53 | the-contract) 54 | -------------------------------------------------------------------------------- /streaming/transducer/private/deduplicating.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [deduplicating (->* () (#:key (-> any/c any/c)) transducer?)] 8 | [deduplicating-consecutive (->* () (#:key (-> any/c any/c)) transducer?)])) 9 | 10 | (require guard 11 | racket/set 12 | rebellion/base/impossible-function 13 | rebellion/base/option 14 | rebellion/base/variant 15 | rebellion/streaming/transducer/base 16 | rebellion/type/record) 17 | 18 | ;@------------------------------------------------------------------------------ 19 | 20 | (define-record-type emit-state (previously-encountered novel-element)) 21 | 22 | (define (deduplicating #:key [key-function values]) 23 | (make-transducer 24 | #:starter (λ () (variant #:consume (set))) 25 | #:consumer 26 | (λ (encountered v) 27 | (guarded-block 28 | (define k (key-function v)) 29 | (guard (not (set-member? encountered k)) #:else 30 | (variant #:consume encountered)) 31 | (define state 32 | (emit-state #:previously-encountered (set-add encountered k) 33 | #:novel-element v)) 34 | (variant #:emit state))) 35 | #:emitter 36 | (λ (state) 37 | (define encountered (emit-state-previously-encountered state)) 38 | (define novel (emit-state-novel-element state)) 39 | (emission (variant #:consume encountered) novel)) 40 | #:half-closer (λ (_) (variant #:finish #f)) 41 | #:half-closed-emitter impossible 42 | #:finisher void 43 | #:name 'deduplicating)) 44 | 45 | (define-record-type consecutive-emit-state (previous-key novel-element)) 46 | 47 | (define (deduplicating-consecutive #:key [key-function values]) 48 | (make-transducer 49 | #:starter (λ () (variant #:consume absent)) 50 | #:consumer 51 | (λ (previous v) 52 | (guarded-block 53 | (define k (key-function v)) 54 | (guard (present? previous) #:else 55 | (variant #:emit 56 | (consecutive-emit-state #:previous-key (present k) 57 | #:novel-element v))) 58 | (guard (not (equal? (present-value previous) k)) #:else 59 | (variant #:consume previous)) 60 | (variant #:emit 61 | (consecutive-emit-state #:previous-key (present k) 62 | #:novel-element v)))) 63 | #:emitter 64 | (λ (state) 65 | (define previous (consecutive-emit-state-previous-key state)) 66 | (define novel (consecutive-emit-state-novel-element state)) 67 | (emission (variant #:consume previous) novel)) 68 | #:half-closer (λ (_) (variant #:finish #f)) 69 | #:half-closed-emitter impossible 70 | #:finisher void 71 | #:name 'deduplicating-consecutive)) 72 | -------------------------------------------------------------------------------- /streaming/transducer/private/enumerating-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require rackunit 5 | rebellion/collection/list 6 | rebellion/private/static-name 7 | rebellion/streaming/transducer 8 | rebellion/streaming/transducer/testing)) 9 | 10 | ;@------------------------------------------------------------------------------ 11 | 12 | (module+ test 13 | (test-case (name-string enumerating) 14 | (define inputs "cat") 15 | (define expected 16 | (list (enumerated #:element #\c #:position 0) 17 | (enumerated #:element #\a #:position 1) 18 | (enumerated #:element #\t #:position 2))) 19 | (define expected-events 20 | (list start-event 21 | (consume-event #\c) 22 | (emit-event (enumerated #:element #\c #:position 0)) 23 | (consume-event #\a) 24 | (emit-event (enumerated #:element #\a #:position 1)) 25 | (consume-event #\t) 26 | (emit-event (enumerated #:element #\t #:position 2)) 27 | half-close-event 28 | finish-event)) 29 | (check-equal? (transduce inputs enumerating #:into into-list) expected) 30 | (define actual-events 31 | (transduce inputs 32 | (observing-transduction-events enumerating) 33 | #:into into-list)) 34 | (check-equal? actual-events expected-events))) 35 | -------------------------------------------------------------------------------- /streaming/transducer/private/enumerating.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [enumerated? (-> any/c boolean?)] 8 | [enumerated (-> #:element any/c #:position natural? enumerated?)] 9 | [enumerated-element (-> enumerated? any/c)] 10 | [enumerated-position (-> enumerated? natural?)] 11 | [enumerating (transducer/c any/c enumerated?)])) 12 | 13 | (require racket/math 14 | rebellion/base/impossible-function 15 | rebellion/base/variant 16 | rebellion/private/static-name 17 | rebellion/streaming/transducer/base 18 | rebellion/streaming/transducer/private/contract 19 | rebellion/type/record) 20 | 21 | ;@------------------------------------------------------------------------------ 22 | 23 | (define-record-type enumerated (element position)) 24 | 25 | (define/name enumerating 26 | (make-transducer 27 | #:starter (λ () (variant #:consume 0)) 28 | #:consumer 29 | (λ (position element) 30 | (variant #:emit (enumerated #:element element #:position position))) 31 | #:emitter 32 | (λ (enum) 33 | (emission (variant #:consume (add1 (enumerated-position enum))) enum)) 34 | #:half-closer (λ (_) (variant #:finish #f)) 35 | #:half-closed-emitter impossible 36 | #:finisher void 37 | #:name enclosing-variable-name)) 38 | -------------------------------------------------------------------------------- /streaming/transducer/private/impersonation-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require rackunit 5 | rebellion/collection/list 6 | rebellion/private/static-name 7 | rebellion/streaming/transducer)) 8 | 9 | ;@------------------------------------------------------------------------------ 10 | 11 | (module+ test 12 | (test-case (name-string transducer-impersonate) 13 | 14 | (define-values (impersonator-prop:secret-of-life 15 | knows-secret-of-life? 16 | secret-of-life) 17 | (make-impersonator-property 'secret-of-life)) 18 | 19 | (define adding1 (mapping add1)) 20 | 21 | (test-case "impersonator properties only" 22 | 23 | (define props (hash impersonator-prop:secret-of-life 42)) 24 | (define impersonated (transducer-impersonate adding1 #:properties props)) 25 | (check-equal? impersonated adding1) 26 | (check impersonator-of? impersonated adding1) 27 | (check impersonator-of? adding1 impersonated) 28 | (check chaperone-of? impersonated adding1) 29 | (check chaperone-of? adding1 impersonated) 30 | (check-pred knows-secret-of-life? impersonated) 31 | (check-equal? (secret-of-life impersonated) 42)) 32 | 33 | (test-case "should enforce domain guard on input elements" 34 | (define seen (box empty-list)) 35 | (define (guard v) 36 | (set-box! seen (list-append (unbox seen) (list v))) 37 | v) 38 | (define impersonated 39 | (transducer-impersonate adding1 #:domain-guard guard #:chaperone? #t)) 40 | (define results (transduce (in-range 5) impersonated #:into into-list)) 41 | (check-equal? results (list 1 2 3 4 5)) 42 | (check-equal? (unbox seen) (list 0 1 2 3 4)) 43 | (check-equal? impersonated adding1) 44 | (check impersonator-of? impersonated adding1) 45 | (check-false (impersonator-of? adding1 impersonated)) 46 | (check chaperone-of? impersonated adding1) 47 | (check-false (chaperone-of? adding1 impersonated))) 48 | 49 | (test-case "should enforce range guard on output elements" 50 | (define seen (box empty-list)) 51 | (define (guard v) 52 | (set-box! seen (list-append (unbox seen) (list v))) 53 | v) 54 | (define impersonated 55 | (transducer-impersonate adding1 #:range-guard guard #:chaperone? #t)) 56 | (define results (transduce (in-range 5) impersonated #:into into-list)) 57 | (check-equal? results (list 1 2 3 4 5)) 58 | (check-equal? (unbox seen) (list 1 2 3 4 5)) 59 | (check-equal? impersonated adding1) 60 | (check impersonator-of? impersonated adding1) 61 | (check-false (impersonator-of? adding1 impersonated)) 62 | (check chaperone-of? impersonated adding1) 63 | (check-false (chaperone-of? adding1 impersonated))))) 64 | -------------------------------------------------------------------------------- /streaming/transducer/private/reducer-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require rackunit 5 | rebellion/base/option 6 | rebellion/collection/list 7 | rebellion/private/static-name 8 | rebellion/streaming/reducer 9 | rebellion/streaming/transducer)) 10 | 11 | ;@------------------------------------------------------------------------------ 12 | 13 | (module+ test 14 | (test-case (name-string into-transduced) 15 | 16 | (test-case "should finish early when reducer finishes early" 17 | (define red (into-transduced (mapping -) #:into into-first)) 18 | (check-equal? (reduce red 1 2 3) (present -1)) 19 | (check-equal? (reduce red) absent)) 20 | 21 | (test-case "should finish early when transducer finishes" 22 | (define red (into-transduced (taking 3) #:into into-list)) 23 | (check-equal? (reduce-all red (in-range 1 10)) (list 1 2 3)) 24 | (check-equal? (reduce red 1 2) (list 1 2))) 25 | 26 | (test-case "should finish normally when neither finishes early" 27 | (define red (into-transduced (mapping -) #:into into-list)) 28 | (check-equal? (reduce red 1 2 3) (list -1 -2 -3))))) 29 | -------------------------------------------------------------------------------- /streaming/transducer/private/shuffling-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (module+ test 5 | (require racket/list 6 | racket/set 7 | rackunit 8 | rebellion/collection/list 9 | rebellion/collection/set 10 | rebellion/private/static-name 11 | rebellion/streaming/reducer 12 | rebellion/streaming/transducer 13 | rebellion/streaming/transducer/testing)) 14 | 15 | 16 | ;@---------------------------------------------------------------------------------------------------- 17 | 18 | 19 | (module+ test 20 | (test-case (name-string shuffling) 21 | 22 | (test-case "should reuse single instance for default behavior" 23 | (check-eq? (shuffling) (shuffling))) 24 | 25 | (test-case "should do nothing on empty input" 26 | (check-equal? (transduce "" (shuffling) #:into into-string) "") 27 | (define actual-events 28 | (transduce "" 29 | (observing-transduction-events (shuffling)) 30 | #:into into-list)) 31 | (define expected-events (list start-event half-close-event finish-event)) 32 | (check-equal? actual-events expected-events)) 33 | 34 | (define input (list 'my 'quick 'brown 'fox 'jumped 'over 'the 'lazy 'dog)) 35 | 36 | (test-case "should reorder elements" 37 | ;; Technically the shuffle has a miniscule chance of returning the elements in the same order 38 | ;; but we'll ignore that because it's almost impossible. 39 | (check-not-equal? (transduce input (shuffling) #:into into-list) input)) 40 | 41 | (test-case "should not remove or add elements" 42 | (check-equal? (transduce input (shuffling) #:into into-set) (list->set input))) 43 | 44 | (test-case "should be nondeterministic" 45 | ;; This is also technically a flaky test, but only with astronomical odds. 46 | (check-not-equal? (transduce input (shuffling) #:into into-list) 47 | (transduce input (shuffling) #:into into-list))) 48 | 49 | (test-case "should be deterministic with respect to the current RNG state" 50 | (define rng-state (pseudo-random-generator->vector (current-pseudo-random-generator))) 51 | (define first-shuffle (transduce input (shuffling) #:into into-list)) 52 | (define second-shuffle 53 | (parameterize ([current-pseudo-random-generator (vector->pseudo-random-generator rng-state)]) 54 | (transduce input (shuffling) #:into into-list))) 55 | (check-equal? first-shuffle second-shuffle)))) 56 | -------------------------------------------------------------------------------- /streaming/transducer/private/shuffling.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [shuffling (-> transducer?)])) 10 | 11 | 12 | (require racket/list 13 | racket/match 14 | rebellion/base/impossible-function 15 | rebellion/base/variant 16 | rebellion/private/static-name 17 | rebellion/streaming/transducer/base) 18 | 19 | 20 | ;@---------------------------------------------------------------------------------------------------- 21 | 22 | 23 | (define (shuffling) 24 | standard-shuffling-transducer) 25 | 26 | 27 | (define standard-shuffling-transducer 28 | (make-transducer 29 | #:starter (λ () (variant #:consume '())) 30 | #:consumer (λ (previous v) (variant #:consume (cons v previous))) 31 | #:emitter impossible 32 | #:half-closer 33 | (λ (seen) 34 | (if (empty? seen) (variant #:finish #false) (variant #:half-closed-emit (shuffle seen)))) 35 | #:half-closed-emitter 36 | (λ (remaining) 37 | (match remaining 38 | [(cons v '()) (half-closed-emission (variant #:finish #false) v)] 39 | [(cons v tail) (half-closed-emission (variant #:half-closed-emit tail) v)])) 40 | #:finisher void 41 | #:name (name shuffling))) 42 | -------------------------------------------------------------------------------- /streaming/transducer/private/splicing-between.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [splicing-between (-> (sequence/c any/c) transducer?)])) 10 | 11 | 12 | (require racket/match 13 | racket/sequence 14 | rebellion/base/option 15 | rebellion/base/variant 16 | rebellion/private/static-name 17 | rebellion/streaming/transducer/base 18 | rebellion/type/record) 19 | 20 | 21 | ;@---------------------------------------------------------------------------------------------------- 22 | 23 | 24 | (define-record-type element-emit-state (previous-element buffered-element)) 25 | (define-record-type in-between-emit-state (splice-element splice-iterator buffered-element)) 26 | 27 | 28 | (define (splicing-between seq) 29 | (make-transducer 30 | 31 | #:starter (λ () (variant #:consume absent)) 32 | 33 | #:consumer 34 | (λ (previous-element-opt next) 35 | (match previous-element-opt 36 | [(present e) 37 | (variant #:emit (element-emit-state #:previous-element e #:buffered-element next))] 38 | [(== absent) (variant #:consume (present next))])) 39 | 40 | #:emitter 41 | (λ (state) 42 | (match state 43 | [(element-emit-state #:previous-element prev #:buffered-element buffered) 44 | (define-values (head iterator) (sequence-generate* seq)) 45 | (define next-state 46 | (match head 47 | [(list e) 48 | (define s 49 | (in-between-emit-state 50 | #:splice-element e #:splice-iterator iterator #:buffered-element buffered)) 51 | (variant #:emit s)] 52 | [#false (variant #:consume (present buffered))])) 53 | (emission next-state prev)] 54 | [(in-between-emit-state 55 | #:splice-element head #:splice-iterator iterator #:buffered-element buffered) 56 | (define-values (next-head next-iterator) (iterator)) 57 | (define next-state 58 | (match next-head 59 | [(list e) 60 | (define s 61 | (in-between-emit-state 62 | #:splice-element e #:splice-iterator next-iterator #:buffered-element buffered)) 63 | (variant #:emit s)] 64 | [#false (variant #:consume (present buffered))])) 65 | (emission next-state head)])) 66 | 67 | #:half-closer 68 | (λ (previous-element-opt) 69 | (match previous-element-opt 70 | [(present e) (variant #:half-closed-emit e)] 71 | [(== absent) (variant #:finish #false)])) 72 | 73 | #:half-closed-emitter 74 | (λ (last-element) 75 | (half-closed-emission (variant #:finish #false) last-element)) 76 | 77 | #:finisher void 78 | 79 | #:name (name splicing-between))) 80 | -------------------------------------------------------------------------------- /streaming/transducer/private/taking-duplicates-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require rackunit 5 | rebellion/base/immutable-string 6 | rebellion/collection/list 7 | rebellion/private/static-name 8 | rebellion/streaming/reducer 9 | rebellion/streaming/transducer 10 | rebellion/streaming/transducer/testing)) 11 | 12 | ;@------------------------------------------------------------------------------ 13 | 14 | (module+ test 15 | (test-case (name-string taking-duplicates) 16 | (test-case "should compare entire values by default" 17 | (define trans (taking-duplicates)) 18 | (define inputs "hello world") 19 | (define expected "lol") 20 | (check-equal? (transduce inputs trans #:into into-string) expected) 21 | (define actual-events (transduce inputs (observing-transduction-events trans) #:into into-list)) 22 | (define expected-events 23 | (list start-event 24 | (consume-event #\h) 25 | (consume-event #\e) 26 | (consume-event #\l) 27 | (consume-event #\l) 28 | (emit-event #\l) 29 | (consume-event #\o) 30 | (consume-event #\space) 31 | (consume-event #\w) 32 | (consume-event #\o) 33 | (emit-event #\o) 34 | (consume-event #\r) 35 | (consume-event #\l) 36 | (emit-event #\l) 37 | (consume-event #\d) 38 | half-close-event 39 | finish-event)) 40 | (check-equal? actual-events expected-events)) 41 | 42 | (test-case "should compare elements using given key function" 43 | (define trans (taking-duplicates #:key immutable-string-foldcase)) 44 | (define inputs (list "foo" "FOO" "Bar" "bar" "Foo")) 45 | (define expected (list "FOO" "bar" "Foo")) 46 | (check-equal? (transduce inputs trans #:into into-list) expected) 47 | (define actual-events (transduce inputs (observing-transduction-events trans) #:into into-list)) 48 | (define expected-events 49 | (list start-event 50 | (consume-event "foo") 51 | (consume-event "FOO") 52 | (emit-event "FOO") 53 | (consume-event "Bar") 54 | (consume-event "bar") 55 | (emit-event "bar") 56 | (consume-event "Foo") 57 | (emit-event "Foo") 58 | half-close-event 59 | finish-event)) 60 | (check-equal? actual-events expected-events)) 61 | 62 | (test-case "should emit nothing when upstream sequence empty" 63 | (define trans (taking-duplicates)) 64 | (check-equal? (transduce empty-list trans #:into into-list) empty-list) 65 | (define actual-events 66 | (transduce empty-list (observing-transduction-events trans) #:into into-list)) 67 | (define expected-events (list start-event half-close-event finish-event)) 68 | (check-equal? actual-events expected-events)))) 69 | -------------------------------------------------------------------------------- /streaming/transducer/private/taking-duplicates.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [taking-duplicates (->* () (#:key (-> any/c any/c)) transducer?)])) 8 | 9 | (require racket/set 10 | rebellion/base/impossible-function 11 | rebellion/base/variant 12 | rebellion/private/static-name 13 | rebellion/streaming/transducer/base) 14 | 15 | ;@---------------------------------------------------------------------------------------------------- 16 | 17 | (define/name (taking-duplicates #:key [key-function values]) 18 | 19 | (define (start) (variant #:consume (set))) 20 | 21 | (define (consume state element) 22 | (define key (key-function element)) 23 | (if (set-member? state key) 24 | (variant #:emit (emission (variant #:consume state) element)) 25 | (variant #:consume (set-add state key)))) 26 | 27 | (define (emit state) state) 28 | 29 | (define (half-close state) (variant #:finish #false)) 30 | 31 | (make-transducer 32 | #:starter start 33 | #:consumer consume 34 | #:emitter emit 35 | #:half-closer half-close 36 | #:half-closed-emitter impossible 37 | #:finisher void 38 | #:name enclosing-function-name)) 39 | -------------------------------------------------------------------------------- /streaming/transducer/private/taking-local-maxima.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | 4 | (require racket/contract/base) 5 | 6 | 7 | (provide 8 | (contract-out 9 | [taking-local-maxima (->* () (comparator? #:key (-> any/c any/c)) transducer?)] 10 | [taking-local-minima (->* () (comparator? #:key (-> any/c any/c)) transducer?)])) 11 | 12 | 13 | (require racket/match 14 | rebellion/base/comparator 15 | rebellion/base/option 16 | rebellion/base/variant 17 | rebellion/streaming/transducer/base) 18 | 19 | 20 | ;@---------------------------------------------------------------------------------------------------- 21 | 22 | 23 | (struct local-maxima-consumption-state (previous-element previous-key ascending?) #:transparent) 24 | (struct local-maxima-emission-state (emission-element previous-element previous-key) #:transparent) 25 | 26 | 27 | (define (taking-local-maxima [comparator real<=>] 28 | #:key [key-function values] 29 | #:name [name 'taking-local-maxima]) 30 | 31 | (define (start) 32 | (variant #:consume absent)) 33 | 34 | (define (consume state element) 35 | (match state 36 | 37 | [(== absent) 38 | (variant 39 | #:consume (present (local-maxima-consumption-state element (key-function element) #true)))] 40 | 41 | [(present (local-maxima-consumption-state previous-element previous-key #true)) 42 | (define key (key-function element)) 43 | (match (compare comparator key previous-key) 44 | [(== lesser) (variant #:emit (local-maxima-emission-state previous-element element key))] 45 | [_ (variant #:consume (present (local-maxima-consumption-state element key #true)))])] 46 | 47 | [(present (local-maxima-consumption-state previous-element previous-key #false)) 48 | (define key (key-function element)) 49 | (define ascending? 50 | (match (compare comparator key previous-key) 51 | [(== greater) #true] 52 | [_ #false])) 53 | (variant #:consume (present (local-maxima-consumption-state element key ascending?)))])) 54 | 55 | (define (emit state) 56 | (match-define (local-maxima-emission-state emission-element previous-element key) state) 57 | (define next-state 58 | (variant #:consume (present (local-maxima-consumption-state previous-element key #false)))) 59 | (emission next-state emission-element)) 60 | 61 | (define (half-close state) 62 | (match state 63 | [(== absent) (variant #:finish #false)] 64 | [(present (local-maxima-consumption-state previous-element previous-key #true)) 65 | (variant #:half-closed-emit previous-element)] 66 | [(present (local-maxima-consumption-state previous-element previous-key #false)) 67 | (variant #:finish #false)])) 68 | 69 | (define (half-closed-emit element) 70 | (half-closed-emission (variant #:finish #false) element)) 71 | 72 | (make-transducer 73 | #:starter start 74 | #:consumer consume 75 | #:emitter emit 76 | #:half-closer half-close 77 | #:half-closed-emitter half-closed-emit 78 | #:finisher void 79 | #:name name)) 80 | 81 | 82 | (define (taking-local-minima [comparator real<=>] #:key [key-function values]) 83 | (taking-local-maxima 84 | (comparator-reverse comparator) #:key key-function #:name 'taking-local-minima)) 85 | -------------------------------------------------------------------------------- /streaming/transducer/private/taking-maxima.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [taking-maxima (->* () (comparator? #:key (-> any/c any/c)) transducer?)] 8 | [taking-minima (->* () (comparator? #:key (-> any/c any/c)) transducer?)])) 9 | 10 | (require racket/match 11 | rebellion/base/comparator 12 | rebellion/base/impossible-function 13 | rebellion/base/option 14 | rebellion/base/variant 15 | rebellion/collection/immutable-vector 16 | rebellion/collection/vector/builder 17 | rebellion/streaming/transducer/base 18 | rebellion/type/tuple) 19 | 20 | ;@------------------------------------------------------------------------------ 21 | 22 | (define-tuple-type maxima-consumption-state (builder representative)) 23 | (define-tuple-type maxima-emission-state (elements index)) 24 | 25 | (define (taking-maxima [comparator real<=>] #:key [key-function values]) 26 | 27 | (define (start) 28 | (define state (maxima-consumption-state (make-vector-builder) absent)) 29 | (variant #:consume state)) 30 | 31 | (define (consume state element) 32 | (match-define (maxima-consumption-state builder representative) state) 33 | (match representative 34 | [(== absent) 35 | (define next-builder (vector-builder-add builder element)) 36 | (define new-representative (present (key-function element))) 37 | (define next-state 38 | (maxima-consumption-state next-builder new-representative)) 39 | (variant #:consume next-state)] 40 | [(present max-key) 41 | (define element-key (key-function element)) 42 | (match (compare comparator element-key max-key) 43 | [(== lesser) (variant #:consume state)] 44 | [(== greater) 45 | (define new-builder 46 | (vector-builder-add (make-vector-builder) element)) 47 | (define next-state 48 | (maxima-consumption-state new-builder (present element-key))) 49 | (variant #:consume next-state)] 50 | [(== equivalent) 51 | (define next-builder (vector-builder-add builder element)) 52 | (define next-state 53 | (maxima-consumption-state next-builder representative)) 54 | (variant #:consume next-state)])])) 55 | 56 | (define (half-close state) 57 | (define elements (build-vector (maxima-consumption-state-builder state))) 58 | (if (empty-immutable-vector? elements) 59 | (variant #:finish #false) 60 | (variant #:half-closed-emit (maxima-emission-state elements 0)))) 61 | 62 | (define (half-closed-emitter state) 63 | (match-define (maxima-emission-state elements index) state) 64 | (define emitted (vector-ref elements index)) 65 | (define next-index (add1 index)) 66 | (define next-state 67 | (if (equal? next-index (vector-length elements)) 68 | (variant #:finish #false) 69 | (variant 70 | #:half-closed-emit (maxima-emission-state elements next-index)))) 71 | (half-closed-emission next-state emitted)) 72 | 73 | (make-transducer 74 | #:starter start 75 | #:consumer consume 76 | #:emitter impossible 77 | #:half-closer half-close 78 | #:half-closed-emitter half-closed-emitter 79 | #:finisher void)) 80 | 81 | (define (taking-minima [comparator real<=>] #:key [key-function values]) 82 | (taking-maxima (comparator-reverse comparator) #:key key-function)) 83 | -------------------------------------------------------------------------------- /streaming/transducer/private/windowing.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [windowing (->* (exact-positive-integer?) (#:into reducer?) transducer?)])) 8 | 9 | (require racket/match 10 | rebellion/base/impossible-function 11 | rebellion/base/variant 12 | rebellion/collection/list 13 | rebellion/private/static-name 14 | rebellion/streaming/reducer 15 | rebellion/streaming/transducer/base 16 | rebellion/type/record) 17 | 18 | ;@------------------------------------------------------------------------------ 19 | 20 | (define-record-type window-state 21 | (substates next-finished-substate partial-windows-remaining)) 22 | 23 | (define (initial-window-state size) 24 | (window-state 25 | #:substates (make-vector size #false) 26 | #:next-finished-substate 0 27 | #:partial-windows-remaining size)) 28 | 29 | (define/name (windowing window-size #:into [window-reducer into-list]) 30 | (define window-starter (reducer-starter window-reducer)) 31 | (define window-consumer (reducer-consumer window-reducer)) 32 | (define window-finisher (reducer-finisher window-reducer)) 33 | (define window-early-finisher (reducer-early-finisher window-reducer)) 34 | (define (start) (variant #:consume (initial-window-state window-size))) 35 | (define (consume state element) 36 | (match state 37 | [(window-state 38 | #:substates substates 39 | #:next-finished-substate next-finished 40 | #:partial-windows-remaining (? zero?)) 41 | (for ([i (in-naturals)] 42 | [substate (in-vector substates)] 43 | #:when (variant-tagged-as? substate '#:consume)) 44 | (define next-consumer-substate 45 | (window-consumer (variant-value substate) element)) 46 | (vector-set! substates i next-consumer-substate)) 47 | (variant #:emit state)] 48 | [(window-state 49 | #:substates substates 50 | #:partial-windows-remaining (? positive? remaining)) 51 | (define next-substate-index (- window-size remaining)) 52 | (define num-substates (add1 next-substate-index)) 53 | (vector-set! substates next-substate-index (window-starter)) 54 | (for ([i (in-range 0 num-substates)] 55 | [substate (in-vector substates)] 56 | #:when (variant-tagged-as? substate '#:consume)) 57 | (define next-consumer-substate 58 | (window-consumer (variant-value substate) element)) 59 | (vector-set! substates i next-consumer-substate)) 60 | (define next-state 61 | (window-state 62 | #:substates substates 63 | #:next-finished-substate 0 64 | #:partial-windows-remaining (sub1 remaining))) 65 | (if (equal? remaining 1) 66 | (variant #:emit next-state) 67 | (variant #:consume next-state))])) 68 | (define (emit state) 69 | (define substates (window-state-substates state)) 70 | (define finished (window-state-next-finished-substate state)) 71 | (define emitted-value 72 | (match (vector-ref substates finished) 73 | [(variant #:early-finish early-finish-state) 74 | (window-early-finisher early-finish-state)] 75 | [(variant #:consume consume-state) 76 | (window-finisher consume-state)])) 77 | (vector-set! substates finished (window-starter)) 78 | (define next-state 79 | (window-state 80 | #:substates substates 81 | #:next-finished-substate (modulo (add1 finished) window-size) 82 | #:partial-windows-remaining 0)) 83 | (emission (variant #:consume next-state) emitted-value)) 84 | (make-transducer 85 | #:starter start 86 | #:consumer consume 87 | #:emitter emit 88 | #:half-closer (λ (state) (variant #:finish #false)) 89 | #:half-closed-emitter impossible 90 | #:finisher void 91 | #:name enclosing-function-name)) 92 | -------------------------------------------------------------------------------- /type/enum.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rebellion/type/enum/base 4 | rebellion/type/enum/descriptor 5 | rebellion/type/enum/private/definition-macro) 6 | 7 | (provide (all-from-out rebellion/type/enum/base 8 | rebellion/type/enum/descriptor 9 | rebellion/type/enum/private/definition-macro)) 10 | -------------------------------------------------------------------------------- /type/enum/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [enum-type 8 | (->* (interned-symbol? keyset?) 9 | (#:predicate-name (or/c interned-symbol? #f) 10 | #:discriminator-name (or/c interned-symbol? #f) 11 | #:selector-name (or/c interned-symbol? #f)) 12 | enum-type?)] 13 | [enum-type? (-> any/c boolean?)] 14 | [enum-type-name (-> enum-type? interned-symbol?)] 15 | [enum-type-constants (-> enum-type? keyset?)] 16 | [enum-type-predicate-name (-> enum-type? interned-symbol?)] 17 | [enum-type-discriminator-name (-> enum-type? interned-symbol?)] 18 | [enum-type-selector-name (-> enum-type? interned-symbol?)] 19 | [enum-type-size (-> enum-type? natural?)])) 20 | 21 | (require racket/math 22 | rebellion/base/symbol 23 | rebellion/collection/keyset/low-dependency 24 | rebellion/type/private/naming 25 | rebellion/type/tuple) 26 | 27 | ;@------------------------------------------------------------------------------ 28 | 29 | (define-tuple-type enum-type 30 | (name constants predicate-name discriminator-name selector-name) 31 | #:omit-root-binding) 32 | 33 | (define (enum-type name constants 34 | #:predicate-name [predicate-name* #f] 35 | #:discriminator-name [discriminator-name* #f] 36 | #:selector-name [selector-name* #f]) 37 | (define predicate-name (or predicate-name* (default-predicate-name name))) 38 | (define discriminator-name 39 | (or discriminator-name* (default-discriminator-name name))) 40 | (define selector-name (or selector-name* (default-selector-name name))) 41 | (constructor:enum-type name 42 | constants 43 | predicate-name 44 | discriminator-name 45 | selector-name)) 46 | 47 | (define (enum-type-size type) (keyset-size (enum-type-constants type))) 48 | -------------------------------------------------------------------------------- /type/enum/binding-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require (for-syntax rebellion/type/enum/binding) 5 | rackunit 6 | rebellion/type/enum 7 | syntax/parse/define)) 8 | 9 | ;@------------------------------------------------------------------------------ 10 | 11 | (module+ test 12 | (define-enum-type direction (up down left right)) 13 | 14 | (test-case "basic enum-id parsing" 15 | (define-syntax-parse-rule (tester :enum-id) 'success!) 16 | (check-equal? (tester direction) 'success!)) 17 | 18 | (test-case "enum-id.name" 19 | (define-syntax-parse-rule (tester enum:enum-id) enum.name) 20 | (check-equal? (tester direction) 'direction)) 21 | 22 | (test-case "enum-id.constant" 23 | (define-syntax-parse-rule (tester enum:enum-id) (list enum.constant ...)) 24 | (check-equal? (tester direction) (list down left right up))) 25 | 26 | (test-case "enum-id.constant-name" 27 | (define-syntax-parse-rule (tester enum:enum-id) (list enum.constant-name ...)) 28 | (check-equal? (tester direction) (list 'down 'left 'right 'up))) 29 | 30 | (test-case "enum-id.predicate" 31 | (define-syntax-parse-rule (tester enum:enum-id) enum.predicate) 32 | (check-equal? (tester direction) direction?)) 33 | 34 | (test-case "enum-id.discriminator" 35 | (define-syntax-parse-rule (tester enum:enum-id) enum.discriminator) 36 | (check-equal? (tester direction) discriminator:direction)) 37 | 38 | (test-case "enum-id.selector" 39 | (define-syntax-parse-rule (tester enum:enum-id) enum.selector) 40 | (check-equal? (tester direction) selector:direction)) 41 | 42 | (test-case "enum-id.descriptor" 43 | (define-syntax-parse-rule (tester enum:enum-id) enum.descriptor) 44 | (check-equal? (tester direction) descriptor:direction))) 45 | -------------------------------------------------------------------------------- /type/enum/binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | enum-id 7 | (contract-out 8 | [enum-binding? (-> any/c boolean?)] 9 | [enum-binding-type (-> enum-binding? enum-type?)] 10 | [enum-binding-constants 11 | (-> enum-binding? (vectorof identifier? #:immutable #t))] 12 | [enum-binding-descriptor (-> enum-binding? identifier?)] 13 | [enum-binding-predicate (-> enum-binding? identifier?)] 14 | [enum-binding-selector (-> enum-binding? identifier?)] 15 | [enum-binding-discriminator (-> enum-binding? identifier?)])) 16 | 17 | (module+ private-constructor 18 | (provide 19 | (contract-out 20 | [enum-binding 21 | (-> #:type enum-type? 22 | #:constants (sequence/c identifier?) 23 | #:descriptor identifier? 24 | #:predicate identifier? 25 | #:discriminator identifier? 26 | #:selector identifier? 27 | enum-binding?)]))) 28 | 29 | (require (for-template racket/base) 30 | racket/sequence 31 | racket/set 32 | rebellion/collection/keyset 33 | rebellion/type/enum/base 34 | syntax/parse) 35 | 36 | ;@------------------------------------------------------------------------------ 37 | 38 | (struct enum-binding 39 | (type constants descriptor predicate discriminator selector) 40 | #:omit-define-syntaxes 41 | #:constructor-name constructor:enum-binding) 42 | 43 | (define (enum-binding #:type type 44 | #:constants constants 45 | #:descriptor descriptor 46 | #:predicate predicate 47 | #:discriminator discriminator 48 | #:selector selector) 49 | (define constant-vector 50 | (vector->immutable-vector (for/vector ([c constants]) c))) 51 | (constructor:enum-binding 52 | type constant-vector descriptor predicate discriminator selector)) 53 | 54 | (define-syntax-class enum-id 55 | #:attributes 56 | (type 57 | binding 58 | name 59 | [constant 1] 60 | [constant-name 1] 61 | predicate 62 | selector 63 | discriminator 64 | descriptor) 65 | 66 | (pattern binding-id 67 | #:declare binding-id (static enum-binding? "a static enum binding") 68 | #:attr binding (attribute binding-id.value) 69 | #:attr type (enum-binding-type (attribute binding)) 70 | #:with name #`'#,(enum-type-name (attribute type)) 71 | #:with descriptor (enum-binding-descriptor (attribute binding)) 72 | #:with predicate (enum-binding-predicate (attribute binding)) 73 | #:with selector (enum-binding-selector (attribute binding)) 74 | #:with discriminator (enum-binding-discriminator (attribute binding)) 75 | 76 | #:with (constant ...) 77 | (sequence->list (enum-binding-constants (attribute binding))) 78 | 79 | #:with (constant-name ...) 80 | (for/list ([name (in-keyset (enum-type-constants (attribute type)))]) 81 | #`'#,(string->symbol (keyword->string name))))) 82 | -------------------------------------------------------------------------------- /type/object.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rebellion/type/object/base 4 | rebellion/type/object/descriptor 5 | rebellion/type/object/private/definition-macro) 6 | 7 | (provide (all-from-out rebellion/type/object/base 8 | rebellion/type/object/descriptor 9 | rebellion/type/object/private/definition-macro)) 10 | -------------------------------------------------------------------------------- /type/object/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [object-type 8 | (->* (interned-symbol? keyset?) 9 | (#:name-field keyword? 10 | #:constructor-name (or/c interned-symbol? #f) 11 | #:accessor-name (or/c interned-symbol? #f) 12 | #:predicate-name (or/c interned-symbol? #f)) 13 | object-type?)] 14 | [object-type? (-> any/c boolean?)] 15 | [object-type-name (-> object-type? interned-symbol?)] 16 | [object-type-fields (-> object-type? keyset?)] 17 | [object-type-private-fields (-> object-type? keyset?)] 18 | [object-type-name-field (-> object-type? keyword?)] 19 | [object-type-name-field-position (-> object-type? natural?)] 20 | [object-type-constructor-name (-> object-type? interned-symbol?)] 21 | [object-type-predicate-name (-> object-type? interned-symbol?)] 22 | [object-type-accessor-name (-> object-type? interned-symbol?)] 23 | [object-type-size (-> object-type? natural?)])) 24 | 25 | (require racket/math 26 | rebellion/base/symbol 27 | rebellion/collection/keyset/low-dependency 28 | rebellion/type/private/naming 29 | rebellion/type/record) 30 | 31 | ;@------------------------------------------------------------------------------ 32 | 33 | (define-record-type object-type 34 | (name 35 | fields 36 | name-field-position 37 | constructor-name 38 | predicate-name 39 | accessor-name) 40 | #:omit-root-binding) 41 | 42 | (define (object-type name fields 43 | #:name-field [name-field '#:name] 44 | #:constructor-name [constructor-name #f] 45 | #:accessor-name [accessor-name #f] 46 | #:predicate-name [predicate-name #f]) 47 | (define all-fields (keyset-add fields name-field)) 48 | (constructor:object-type 49 | #:name name 50 | #:fields all-fields 51 | #:name-field-position (keyset-index-of all-fields name-field) 52 | #:constructor-name 53 | (or constructor-name (default-opaque-constructor-name name)) 54 | #:accessor-name (or accessor-name (default-accessor-name name)) 55 | #:predicate-name (or predicate-name (default-predicate-name name)))) 56 | 57 | (define (object-type-name-field type) 58 | (keyset-ref (object-type-fields type) (object-type-name-field-position type))) 59 | 60 | (define (object-type-size type) (keyset-size (object-type-fields type))) 61 | 62 | (define (object-type-private-fields type) 63 | (define fields (object-type-fields type)) 64 | (keyset-remove fields (object-type-name-field type))) 65 | -------------------------------------------------------------------------------- /type/private/naming.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [default-descriptor-identifier (-> identifier? identifier?)] 8 | [default-predicate-name (-> interned-symbol? interned-symbol?)] 9 | [default-predicate-identifier (-> identifier? identifier?)] 10 | [default-constructor-name (-> interned-symbol? interned-symbol?)] 11 | [default-constructor-identifier (-> identifier? identifier?)] 12 | [default-accessor-name (-> interned-symbol? interned-symbol?)] 13 | [default-accessor-identifier (-> identifier? identifier?)] 14 | [default-discriminator-name (-> interned-symbol? interned-symbol?)] 15 | [default-discriminator-identifier (-> identifier? identifier?)] 16 | [default-selector-name (-> interned-symbol? interned-symbol?)] 17 | [default-selector-identifier (-> identifier? identifier?)] 18 | [default-opaque-constructor-name (-> interned-symbol? interned-symbol?)] 19 | [default-opaque-constructor-identifier (-> identifier? identifier?)] 20 | [default-pattern-identifier (-> identifier? identifier?)] 21 | [default-setter-identifier (-> identifier? identifier?)] 22 | [default-field-accessor-identifier (-> identifier? identifier? identifier?)] 23 | [default-unwrapping-accessor-name (-> interned-symbol? interned-symbol?)] 24 | [default-unwrapping-accessor-identifier (-> identifier? identifier?)] 25 | [default-instance-identifier (-> identifier? identifier?)])) 26 | 27 | (require racket/syntax 28 | rebellion/base/symbol) 29 | 30 | ;@------------------------------------------------------------------------------ 31 | 32 | (define (format-one-id template id) (format-id id template id #:subs? #true)) 33 | 34 | (define (default-descriptor-identifier id) (format-one-id "descriptor:~a" id)) 35 | (define (default-predicate-name name) (format-symbol "~a?" name)) 36 | (define (default-predicate-identifier id) (format-one-id "~a?" id)) 37 | (define (default-constructor-name name) (format-symbol "constructor:~a" name)) 38 | (define (default-constructor-identifier id) (format-one-id "constructor:~a" id)) 39 | (define (default-accessor-name name) (format-symbol "accessor:~a" name)) 40 | (define (default-accessor-identifier id) (format-one-id "accessor:~a" id)) 41 | 42 | (define (default-discriminator-name name) 43 | (format-symbol "discriminator:~a" name)) 44 | 45 | (define (default-discriminator-identifier id) 46 | (format-one-id "discriminator:~a" id)) 47 | 48 | (define (default-selector-name name) (format-symbol "selector:~a" name)) 49 | (define (default-selector-identifier id) (format-one-id "selector:~a" id)) 50 | (define (default-opaque-constructor-name name) (format-symbol "make-~a" name)) 51 | (define (default-opaque-constructor-identifier id) (format-one-id "make-~a" id)) 52 | (define (default-pattern-identifier id) (format-one-id "pattern:~a" id)) 53 | (define (default-setter-identifier id) (format-one-id "~a-set" id)) 54 | 55 | (define (default-field-accessor-identifier type-id field-id) 56 | (format-id field-id "~a-~a" type-id field-id #:subs? #true)) 57 | 58 | (define (default-unwrapping-accessor-name name) (format-symbol "~a-value" name)) 59 | 60 | (define (default-unwrapping-accessor-identifier id) 61 | (format-one-id "~a-value" id)) 62 | 63 | (define (default-instance-identifier id) (format-one-id "instance:~a" id)) 64 | -------------------------------------------------------------------------------- /type/record.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rebellion/type/record/base 4 | rebellion/type/record/descriptor 5 | rebellion/type/record/private/definition-macro 6 | rebellion/type/record/private/provide-transformer) 7 | 8 | (provide (all-from-out rebellion/type/record/base 9 | rebellion/type/record/descriptor 10 | rebellion/type/record/private/definition-macro 11 | rebellion/type/record/private/provide-transformer)) 12 | -------------------------------------------------------------------------------- /type/record/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [record-type 8 | (->* (interned-symbol? keyset?) 9 | (#:predicate-name (or/c interned-symbol? #f) 10 | #:constructor-name (or/c interned-symbol? #f) 11 | #:accessor-name (or/c interned-symbol? #f)) 12 | record-type?)] 13 | [record-type? (-> any/c boolean?)] 14 | [record-type-name (-> record-type? interned-symbol?)] 15 | [record-type-fields (-> record-type? keyset?)] 16 | [record-type-predicate-name (-> record-type? interned-symbol?)] 17 | [record-type-constructor-name (-> record-type? interned-symbol?)] 18 | [record-type-accessor-name (-> record-type? interned-symbol?)])) 19 | 20 | (require rebellion/base/symbol 21 | rebellion/collection/keyset/low-dependency 22 | rebellion/type/private/naming 23 | rebellion/type/tuple) 24 | 25 | ;@------------------------------------------------------------------------------ 26 | 27 | (define-tuple-type record-type 28 | (name fields predicate-name constructor-name accessor-name) 29 | #:omit-root-binding) 30 | 31 | (define (record-type name fields 32 | #:predicate-name [predicate-name* #f] 33 | #:constructor-name [constructor-name* #f] 34 | #:accessor-name [accessor-name* #f]) 35 | (define predicate-name (or predicate-name* (default-predicate-name name))) 36 | (define constructor-name 37 | (or constructor-name* (default-constructor-name name))) 38 | (define accessor-name (or accessor-name* (default-accessor-name name))) 39 | (constructor:record-type name 40 | fields 41 | predicate-name 42 | constructor-name 43 | accessor-name)) 44 | -------------------------------------------------------------------------------- /type/record/binding-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require (for-syntax rebellion/type/record/binding) 5 | rackunit 6 | rebellion/type/record 7 | syntax/parse/define)) 8 | 9 | ;@------------------------------------------------------------------------------ 10 | 11 | (module+ test 12 | (define-record-type widget (price weight description)) 13 | 14 | (test-case "basic record-id parsing" 15 | (define-syntax-parse-rule (tester :record-id) 'success!) 16 | (check-equal? (tester widget) 'success!)) 17 | 18 | (test-case "record-id.name" 19 | (define-syntax-parse-rule (tester record:record-id) record.name) 20 | (check-equal? (tester widget) 'widget)) 21 | 22 | (test-case "record-id.descriptor" 23 | (define-syntax-parse-rule (tester record:record-id) record.descriptor) 24 | (check-equal? (tester widget) descriptor:widget)) 25 | 26 | (test-case "record-id.predicate" 27 | (define-syntax-parse-rule (tester record:record-id) record.predicate) 28 | (check-equal? (tester widget) widget?)) 29 | 30 | (test-case "record-id.constructor" 31 | (define-syntax-parse-rule (tester record:record-id) record.constructor) 32 | (check-equal? (tester widget) widget)) 33 | 34 | (test-case "record-id.accessor" 35 | (define-syntax-parse-rule (tester record:record-id) record.accessor) 36 | (check-equal? (tester widget) accessor:widget)) 37 | 38 | (test-case "record-id.field" 39 | (define-syntax-parse-rule (tester record:record-id) (list 'record.field ...)) 40 | (check-equal? (tester widget) (list 'description 'price 'weight))) 41 | 42 | (test-case "record-id.field-name" 43 | (define-syntax-parse-rule (tester record:record-id) (list record.field-name ...)) 44 | (check-equal? (tester widget) (list 'description 'price 'weight))) 45 | 46 | (test-case "record-id.field-keyword" 47 | (define-syntax-parse-rule (tester record:record-id) 48 | (list 'record.field-keyword ...)) 49 | (check-equal? (tester widget) (list '#:description '#:price '#:weight))) 50 | 51 | (test-case "record-id.field-accessor" 52 | (define-syntax-parse-rule (tester record:record-id) 53 | (list record.field-accessor ...)) 54 | (check-equal? 55 | (tester widget) (list widget-description widget-price widget-weight)))) 56 | -------------------------------------------------------------------------------- /type/record/private/provide-transformer.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base 4 | racket/provide-transform 5 | rebellion/type/record/binding 6 | syntax/parse)) 7 | 8 | (module+ test 9 | (require rackunit 10 | syntax/location 11 | rebellion/private/static-name 12 | (submod ".."))) 13 | 14 | (provide record-out) 15 | 16 | (define-syntax record-out 17 | (make-provide-transformer 18 | (λ (provide-spec modes) 19 | (syntax-parse provide-spec 20 | [(_ record:record-id) 21 | (expand-export 22 | #'(combine-out 23 | record 24 | record.descriptor 25 | record.predicate 26 | record.field-accessor ...) 27 | modes)])))) 28 | 29 | (module+ test 30 | (module chair-module racket/base 31 | (require rebellion/type/record/private/definition-macro 32 | (submod ".." "..")) 33 | (provide (record-out chair)) 34 | (define-record-type chair (legs seat screws))) 35 | (test-case (name-string record-out) 36 | (define mod (quote-module-path chair-module)) 37 | (check-not-exn 38 | (λ () 39 | (for ([sym '(#f chair chair? chair-legs chair-seat chair-screws)]) 40 | (dynamic-require mod sym)))))) 41 | -------------------------------------------------------------------------------- /type/singleton.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rebellion/type/singleton/base 4 | rebellion/type/singleton/descriptor 5 | rebellion/type/singleton/private/definition-macro) 6 | 7 | (provide (all-from-out rebellion/type/singleton/base 8 | rebellion/type/singleton/descriptor 9 | rebellion/type/singleton/private/definition-macro)) 10 | -------------------------------------------------------------------------------- /type/singleton/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [singleton-type 8 | (->* (interned-symbol?) (#:predicate-name (or/c interned-symbol? #f)) 9 | singleton-type?)] 10 | [singleton-type? (-> any/c boolean?)] 11 | [singleton-type-name (-> singleton-type? interned-symbol?)] 12 | [singleton-type-predicate-name (-> singleton-type? interned-symbol?)])) 13 | 14 | (require rebellion/base/symbol 15 | rebellion/type/private/naming 16 | rebellion/type/tuple) 17 | 18 | ;@------------------------------------------------------------------------------ 19 | 20 | (define-tuple-type singleton-type (name predicate-name) #:omit-root-binding) 21 | 22 | (define (singleton-type name #:predicate-name [predicate-name* #f]) 23 | (define predicate-name (or predicate-name* (default-predicate-name name))) 24 | (constructor:singleton-type name predicate-name)) 25 | -------------------------------------------------------------------------------- /type/singleton/binding-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require (for-syntax rebellion/type/singleton/binding) 5 | rackunit 6 | rebellion/type/singleton 7 | syntax/parse/define)) 8 | 9 | ;@------------------------------------------------------------------------------ 10 | 11 | (module+ test 12 | (define-singleton-type infinity) 13 | 14 | (test-case "basic singleton-id parsing" 15 | (define-syntax-parse-rule (tester :singleton-id) 'success!) 16 | (check-equal? (tester infinity) 'success!)) 17 | 18 | (test-case "singleton-id.name" 19 | (define-syntax-parse-rule (tester singleton:singleton-id) singleton.name) 20 | (check-equal? (tester infinity) 'infinity)) 21 | 22 | (test-case "singleton-id.descriptor" 23 | (define-syntax-parse-rule (tester singleton:singleton-id) singleton.descriptor) 24 | (check-equal? (tester infinity) descriptor:infinity)) 25 | 26 | (test-case "singleton-id.predicate" 27 | (define-syntax-parse-rule (tester singleton:singleton-id) singleton.predicate) 28 | (check-equal? (tester infinity) infinity?)) 29 | 30 | (test-case "singleton-id.instance" 31 | (define-syntax-parse-rule (tester singleton:singleton-id) singleton.instance) 32 | (check-equal? (tester infinity) infinity))) 33 | -------------------------------------------------------------------------------- /type/singleton/binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | singleton-id 7 | (contract-out 8 | [singleton-binding? (-> any/c boolean?)] 9 | [singleton-binding-type (-> singleton-binding? singleton-type?)] 10 | [singleton-binding-descriptor (-> singleton-binding? identifier?)] 11 | [singleton-binding-predicate (-> singleton-binding? identifier?)] 12 | [singleton-binding-instance (-> singleton-binding? identifier?)])) 13 | 14 | (module+ private-constructor 15 | (provide 16 | (contract-out 17 | [singleton-binding 18 | (-> #:type singleton-type? 19 | #:descriptor identifier? 20 | #:predicate identifier? 21 | #:instance identifier? 22 | #:macro (-> syntax? syntax?) 23 | singleton-binding?)]))) 24 | 25 | (require (for-template racket/base) 26 | racket/sequence 27 | racket/syntax 28 | rebellion/type/singleton/base 29 | syntax/parse) 30 | 31 | ;@------------------------------------------------------------------------------ 32 | 33 | (struct singleton-binding 34 | (type descriptor predicate instance macro) 35 | #:omit-define-syntaxes 36 | #:constructor-name constructor:singleton-binding 37 | #:property prop:procedure (λ (this stx) ((singleton-binding-macro this) stx))) 38 | 39 | (define (singleton-binding 40 | #:type type 41 | #:descriptor descriptor 42 | #:predicate predicate 43 | #:instance instance 44 | #:macro macro) 45 | (constructor:singleton-binding type descriptor predicate instance macro)) 46 | 47 | (define-syntax-class singleton-id 48 | #:attributes (type binding name descriptor predicate instance) 49 | 50 | (pattern binding-id 51 | #:declare binding-id 52 | (static singleton-binding? "a static singleton-binding? value") 53 | 54 | #:attr binding (attribute binding-id.value) 55 | #:attr type (singleton-binding-type (attribute binding)) 56 | #:with name #`'#,(singleton-type-name (attribute type)) 57 | #:with descriptor (singleton-binding-descriptor (attribute binding)) 58 | #:with predicate (singleton-binding-predicate (attribute binding)) 59 | #:with instance (singleton-binding-instance (attribute binding)))) 60 | -------------------------------------------------------------------------------- /type/tuple.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rebellion/type/tuple/base 4 | rebellion/type/tuple/descriptor 5 | rebellion/type/tuple/private/definition-macro) 6 | 7 | (provide (all-from-out rebellion/type/tuple/base 8 | rebellion/type/tuple/descriptor 9 | rebellion/type/tuple/private/definition-macro)) 10 | -------------------------------------------------------------------------------- /type/tuple/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [tuple-type 8 | (->* (interned-symbol? (sequence/c interned-symbol?)) 9 | (#:predicate-name (or/c interned-symbol? #f) 10 | #:constructor-name (or/c interned-symbol? #f) 11 | #:accessor-name (or/c interned-symbol? #f)) 12 | tuple-type?)] 13 | [tuple-type? (-> any/c boolean?)] 14 | [tuple-type-name (-> tuple-type? interned-symbol?)] 15 | [tuple-type-fields 16 | (-> tuple-type? (vectorof interned-symbol? #:immutable #t))] 17 | [tuple-type-accessor-name (-> tuple-type? interned-symbol?)] 18 | [tuple-type-constructor-name (-> tuple-type? interned-symbol?)] 19 | [tuple-type-predicate-name (-> tuple-type? interned-symbol?)] 20 | [tuple-type-size (-> tuple-type? natural?)])) 21 | 22 | (require racket/list 23 | racket/math 24 | racket/sequence 25 | rebellion/base/symbol 26 | rebellion/type/private/naming) 27 | 28 | ;@------------------------------------------------------------------------------ 29 | 30 | (struct tuple-type (name fields predicate-name constructor-name accessor-name) 31 | #:transparent 32 | #:omit-define-syntaxes 33 | #:constructor-name constructor:tuple-type) 34 | 35 | (define (tuple-type 36 | name 37 | fields 38 | #:predicate-name [predicate-name* #f] 39 | #:constructor-name [constructor-name* #f] 40 | #:accessor-name [accessor-name* #f]) 41 | (define field-vector 42 | (vector->immutable-vector (for/vector ([field fields]) field))) 43 | (check-field-names-unique field-vector name) 44 | (define predicate-name (or predicate-name* (default-predicate-name name))) 45 | (define constructor-name 46 | (or constructor-name* (default-constructor-name name))) 47 | (define accessor-name (or accessor-name* (default-accessor-name name))) 48 | (constructor:tuple-type 49 | name field-vector predicate-name constructor-name accessor-name)) 50 | 51 | (define (tuple-type-size type) 52 | (vector-length (tuple-type-fields type))) 53 | 54 | (define (check-field-names-unique names type-name) 55 | (define duplicate (check-duplicates (vector->list names))) 56 | (when duplicate 57 | (raise-arguments-error 58 | 'tuple-type 59 | "duplicate field names are not allowed in tuple types" 60 | "duplicate name" duplicate 61 | "tuple type" type-name))) 62 | -------------------------------------------------------------------------------- /type/tuple/binding-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require (for-syntax rebellion/type/tuple/binding) 5 | rackunit 6 | rebellion/type/tuple 7 | syntax/parse/define)) 8 | 9 | ;@------------------------------------------------------------------------------ 10 | 11 | (module+ test 12 | (define-tuple-type widget (price weight description)) 13 | 14 | (test-case "basic tuple-id parsing" 15 | (define-syntax-parse-rule (tester :tuple-id) 'success!) 16 | (check-equal? (tester widget) 'success!)) 17 | 18 | (test-case "tuple-id.name" 19 | (define-syntax-parse-rule (tester tuple:tuple-id) tuple.name) 20 | (check-equal? (tester widget) 'widget)) 21 | 22 | (test-case "tuple-id.descriptor" 23 | (define-syntax-parse-rule (tester tuple:tuple-id) tuple.descriptor) 24 | (check-equal? (tester widget) descriptor:widget)) 25 | 26 | (test-case "tuple-id.predicate" 27 | (define-syntax-parse-rule (tester tuple:tuple-id) tuple.predicate) 28 | (check-equal? (tester widget) widget?)) 29 | 30 | (test-case "tuple-id.constructor" 31 | (define-syntax-parse-rule (tester tuple:tuple-id) tuple.constructor) 32 | (check-equal? (tester widget) widget)) 33 | 34 | (test-case "tuple-id.accessor" 35 | (define-syntax-parse-rule (tester tuple:tuple-id) tuple.accessor) 36 | (check-equal? (tester widget) accessor:widget)) 37 | 38 | (test-case "tuple-id.field" 39 | (define-syntax-parse-rule (tester tuple:tuple-id) (list 'tuple.field ...)) 40 | (check-equal? (tester widget) (list 'price 'weight 'description))) 41 | 42 | (test-case "tuple-id.field-name" 43 | (define-syntax-parse-rule (tester tuple:tuple-id) (list tuple.field-name ...)) 44 | (check-equal? (tester widget) (list 'price 'weight 'description))) 45 | 46 | (test-case "tuple-id.field-accessor" 47 | (define-syntax-parse-rule (tester tuple:tuple-id) 48 | (list tuple.field-accessor ...)) 49 | (check-equal? 50 | (tester widget) (list widget-price widget-weight widget-description)))) 51 | -------------------------------------------------------------------------------- /type/type-descriptor-printing-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (module+ test 4 | (require racket/format 5 | rackunit 6 | rebellion/type/enum 7 | rebellion/type/object 8 | rebellion/type/record 9 | rebellion/type/singleton 10 | rebellion/type/tuple 11 | rebellion/type/wrapper)) 12 | 13 | (module+ test 14 | (test-case "tuple descriptor printing" 15 | (define-tuple-type foo (a b)) 16 | (check-equal? (object-name descriptor:foo) 'foo) 17 | (check-equal? (~a descriptor:foo) "#") 18 | (check-equal? (~v descriptor:foo) "#") 19 | (check-equal? (~s descriptor:foo) "#") 20 | (check-equal? (~v (list descriptor:foo)) "(list #)")) 21 | 22 | (test-case "record descriptor printing" 23 | (define-record-type foo (a b)) 24 | (check-equal? (object-name descriptor:foo) 'foo) 25 | (check-equal? (~a descriptor:foo) "#") 26 | (check-equal? (~v descriptor:foo) "#") 27 | (check-equal? (~s descriptor:foo) "#") 28 | (check-equal? (~v (list descriptor:foo)) "(list #)")) 29 | 30 | (test-case "wrapper descriptor printing" 31 | (define-wrapper-type foo) 32 | (check-equal? (object-name descriptor:foo) 'foo) 33 | (check-equal? (~a descriptor:foo) "#") 34 | (check-equal? (~v descriptor:foo) "#") 35 | (check-equal? (~s descriptor:foo) "#") 36 | (check-equal? 37 | (~v (list descriptor:foo)) "(list #)")) 38 | 39 | (test-case "singleton descriptor printing" 40 | (define-singleton-type foo) 41 | (check-equal? (object-name descriptor:foo) 'foo) 42 | (check-equal? (~a descriptor:foo) "#") 43 | (check-equal? (~v descriptor:foo) "#") 44 | (check-equal? (~s descriptor:foo) "#") 45 | (check-equal? 46 | (~v (list descriptor:foo)) "(list #)")) 47 | 48 | (test-case "enum descriptor printing" 49 | (define-enum-type foo (a b)) 50 | (check-equal? (object-name descriptor:foo) 'foo) 51 | (check-equal? (~a descriptor:foo) "#") 52 | (check-equal? (~v descriptor:foo) "#") 53 | (check-equal? (~s descriptor:foo) "#") 54 | (check-equal? (~v (list descriptor:foo)) "(list #)")) 55 | 56 | (test-case "object descriptor printing" 57 | (define-object-type foo (a b)) 58 | (check-equal? (object-name descriptor:foo) 'foo) 59 | (check-equal? (~a descriptor:foo) "#") 60 | (check-equal? (~v descriptor:foo) "#") 61 | (check-equal? (~s descriptor:foo) "#") 62 | (check-equal? 63 | (~v (list descriptor:foo)) "(list #)"))) 64 | -------------------------------------------------------------------------------- /type/wrapper.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require rebellion/type/wrapper/base 4 | rebellion/type/wrapper/descriptor 5 | rebellion/type/wrapper/private/definition-macro) 6 | 7 | (provide (all-from-out rebellion/type/wrapper/base 8 | rebellion/type/wrapper/descriptor 9 | rebellion/type/wrapper/private/definition-macro)) 10 | -------------------------------------------------------------------------------- /type/wrapper/base.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [wrapper-type 8 | (->* (interned-symbol?) 9 | (#:predicate-name (or/c interned-symbol? #f) 10 | #:constructor-name (or/c interned-symbol? #f) 11 | #:accessor-name (or/c interned-symbol? #f)) 12 | wrapper-type?)] 13 | [wrapper-type? (-> any/c boolean?)] 14 | [wrapper-type-name (-> wrapper-type? interned-symbol?)] 15 | [wrapper-type-constructor-name (-> wrapper-type? interned-symbol?)] 16 | [wrapper-type-predicate-name (-> wrapper-type? interned-symbol?)] 17 | [wrapper-type-accessor-name (-> wrapper-type? interned-symbol?)])) 18 | 19 | (require rebellion/base/symbol 20 | rebellion/type/private/naming 21 | rebellion/type/record) 22 | 23 | ;@------------------------------------------------------------------------------ 24 | 25 | (define-record-type wrapper-type 26 | (name predicate-name constructor-name accessor-name) 27 | #:omit-root-binding) 28 | 29 | (define (wrapper-type 30 | name 31 | #:predicate-name [predicate-name #f] 32 | #:constructor-name [constructor-name #f] 33 | #:accessor-name [accessor-name #f]) 34 | (constructor:wrapper-type 35 | #:name name 36 | #:predicate-name (or predicate-name (default-predicate-name name)) 37 | #:constructor-name (or constructor-name (default-constructor-name name)) 38 | #:accessor-name (or accessor-name (default-unwrapping-accessor-name name)))) 39 | -------------------------------------------------------------------------------- /type/wrapper/binding-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (module+ test 4 | (require (for-syntax rebellion/type/wrapper/binding) 5 | rackunit 6 | rebellion/type/wrapper 7 | syntax/parse/define)) 8 | 9 | ;@------------------------------------------------------------------------------ 10 | 11 | (module+ test 12 | (define-wrapper-type radians) 13 | 14 | (test-case "basic wrapper-id parsing" 15 | (define-syntax-parse-rule (tester :wrapper-id) 'success!) 16 | (check-equal? (tester radians) 'success!)) 17 | 18 | (test-case "wrapper-id.name" 19 | (define-syntax-parse-rule (tester wrapper:wrapper-id) wrapper.name) 20 | (check-equal? (tester radians) 'radians)) 21 | 22 | (test-case "wrapper-id.descriptor" 23 | (define-syntax-parse-rule (tester wrapper:wrapper-id) wrapper.descriptor) 24 | (check-equal? (tester radians) descriptor:radians)) 25 | 26 | (test-case "wrapper-id.predicate" 27 | (define-syntax-parse-rule (tester wrapper:wrapper-id) wrapper.predicate) 28 | (check-equal? (tester radians) radians?)) 29 | 30 | (test-case "wrapper-id.constructor" 31 | (define-syntax-parse-rule (tester wrapper:wrapper-id) wrapper.constructor) 32 | (check-equal? (tester radians) radians)) 33 | 34 | (test-case "wrapper-id.accessor" 35 | (define-syntax-parse-rule (tester wrapper:wrapper-id) wrapper.accessor) 36 | (check-equal? (tester radians) radians-value))) 37 | -------------------------------------------------------------------------------- /type/wrapper/binding.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | wrapper-id 7 | (contract-out 8 | [wrapper-binding? (-> any/c boolean?)] 9 | [wrapper-binding-type (-> wrapper-binding? wrapper-type?)] 10 | [wrapper-binding-descriptor (-> wrapper-binding? identifier?)] 11 | [wrapper-binding-predicate (-> wrapper-binding? identifier?)] 12 | [wrapper-binding-constructor (-> wrapper-binding? identifier?)] 13 | [wrapper-binding-accessor (-> wrapper-binding? identifier?)])) 14 | 15 | (module+ private-constructor 16 | (provide 17 | (contract-out 18 | [wrapper-binding 19 | (-> #:type wrapper-type? 20 | #:descriptor identifier? 21 | #:predicate identifier? 22 | #:constructor identifier? 23 | #:accessor identifier? 24 | #:pattern identifier? 25 | #:macro (-> syntax? syntax?) 26 | wrapper-binding?)]))) 27 | 28 | (require (for-template racket/base 29 | racket/match) 30 | racket/sequence 31 | racket/syntax 32 | rebellion/type/wrapper/base 33 | syntax/parse) 34 | 35 | ;@------------------------------------------------------------------------------ 36 | 37 | (struct wrapper-binding 38 | (type descriptor predicate constructor accessor pattern macro) 39 | #:omit-define-syntaxes 40 | #:constructor-name constructor:wrapper-binding 41 | 42 | #:property prop:match-expander 43 | (λ (this stx) 44 | (define/with-syntax pattern (wrapper-binding-pattern this)) 45 | (syntax-parse stx #:track-literals 46 | [(_ . body) (quasisyntax/loc stx (pattern . body))])) 47 | 48 | #:property prop:procedure (λ (this stx) ((wrapper-binding-macro this) stx))) 49 | 50 | (define (wrapper-binding 51 | #:type type 52 | #:descriptor descriptor 53 | #:predicate predicate 54 | #:constructor constructor 55 | #:accessor accessor 56 | #:pattern pattern 57 | #:macro macro) 58 | (constructor:wrapper-binding 59 | type descriptor predicate constructor accessor pattern macro)) 60 | 61 | (define-syntax-class wrapper-id 62 | #:attributes (type binding name descriptor predicate constructor accessor) 63 | 64 | (pattern binding-id 65 | #:declare binding-id 66 | (static wrapper-binding? "a static wrapper-binding? value") 67 | 68 | #:attr binding (attribute binding-id.value) 69 | #:attr type (wrapper-binding-type (attribute binding)) 70 | #:with name #`'#,(wrapper-type-name (attribute type)) 71 | #:with descriptor (wrapper-binding-descriptor (attribute binding)) 72 | #:with predicate (wrapper-binding-predicate (attribute binding)) 73 | #:with constructor (wrapper-binding-constructor (attribute binding)) 74 | #:with accessor (wrapper-binding-accessor (attribute binding)))) 75 | -------------------------------------------------------------------------------- /web-graph.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract/base) 4 | 5 | (provide 6 | (contract-out 7 | [empty-web-graph web-graph?] 8 | [web-graph (-> web-link? ... web-graph?)] 9 | [web-graph? (-> any/c boolean?)])) 10 | 11 | (require racket/struct 12 | rebellion/type/tuple 13 | rebellion/web-link) 14 | 15 | (module+ test 16 | (require (submod "..") 17 | racket/format 18 | racket/port 19 | racket/pretty 20 | rackunit)) 21 | 22 | ;@------------------------------------------------------------------------------ 23 | 24 | (define (property-maker descriptor) 25 | (define name (tuple-type-name (tuple-descriptor-type descriptor))) 26 | (define accessor (tuple-descriptor-accessor descriptor)) 27 | (define equal+hash (default-tuple-equal+hash descriptor)) 28 | (define custom-write 29 | (make-constructor-style-printer 30 | (λ (_) name) 31 | (λ (this) (accessor this 0)))) 32 | (list (cons prop:equal+hash equal+hash) 33 | (cons prop:custom-write custom-write))) 34 | 35 | (define-tuple-type web-graph (links) 36 | #:property-maker property-maker 37 | #:omit-root-binding) 38 | 39 | (define (web-graph . links) 40 | (constructor:web-graph links)) 41 | 42 | (define empty-web-graph (web-graph)) 43 | 44 | (module+ test 45 | (test-case "custom-write" 46 | (define graph 47 | (web-graph 48 | (web-link "http://example.org" 'stylesheet "/styles.css") 49 | (web-link "http://example.org" 'stylesheet "/fonts.css") 50 | (web-link "http://example.org" 'search "/opensearch.xml") 51 | (web-link "http://example.org" 'privacy-policy "/privacy-policy"))) 52 | (define (~pretty v #:columns columns) 53 | (parameterize ([pretty-print-columns columns]) 54 | (with-output-to-string 55 | (λ () (pretty-print v))))) 56 | (check-equal? (~pretty graph #:columns 80) 57 | #< url-coercible? link-relation-coercible? url-coercible? web-link?)] 9 | [web-link? (-> any/c boolean?)] 10 | [web-link-source (-> web-link? url?)] 11 | [web-link-relation (-> web-link? (or/c url? symbol?))] 12 | [web-link-target (-> web-link? url?)])) 13 | 14 | (require net/url 15 | racket/struct 16 | rebellion/type/tuple) 17 | 18 | (module+ test 19 | (require (submod "..") 20 | racket/format 21 | rackunit)) 22 | 23 | ;@------------------------------------------------------------------------------ 24 | 25 | (define url-coercible? (or/c url? string?)) 26 | 27 | (define (url-coerce url-ish) 28 | (if (string? url-ish) (string->url url-ish) url-ish)) 29 | 30 | (define link-relation-coercible? (or/c url? string? symbol?)) 31 | 32 | (define (link-relation-coerce relation-ish) 33 | (if (string? relation-ish) (string->url relation-ish) relation-ish)) 34 | 35 | (define (link-relation->writable-value relation) 36 | (if (symbol? relation) relation (url->string relation))) 37 | 38 | (define (property-maker descriptor) 39 | (define name (tuple-type-name (tuple-descriptor-type descriptor))) 40 | (define accessor (tuple-descriptor-accessor descriptor)) 41 | (define equal+hash (default-tuple-equal+hash descriptor)) 42 | (define custom-write 43 | (make-constructor-style-printer 44 | (λ (_) name) 45 | (λ (this) (list (url->string (accessor this 0)) 46 | (link-relation->writable-value (accessor this 1)) 47 | (url->string (accessor this 2)))))) 48 | (list (cons prop:equal+hash equal+hash) 49 | (cons prop:custom-write custom-write))) 50 | 51 | (define-tuple-type web-link (source relation target) 52 | #:property-maker property-maker 53 | #:omit-root-binding) 54 | 55 | (define (web-link source relation target) 56 | (constructor:web-link (url-coerce source) 57 | (link-relation-coerce relation) 58 | (url-coerce target))) 59 | 60 | (module+ test 61 | (test-case "prop:custom-write" 62 | (define link (web-link "http://example.org" 'stylesheet "/styles.css")) 63 | (check-equal? (~v link) 64 | #< 71 | END 72 | ) 73 | (check-equal? (~a link) 74 | #< 76 | END 77 | ))) 78 | -------------------------------------------------------------------------------- /web-link.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label net/url 4 | racket/base 5 | racket/contract/base 6 | rebellion/web-link) 7 | (submod rebellion/private/scribble-evaluator-factory doc) 8 | scribble/example) 9 | 10 | @(define make-evaluator 11 | (make-module-sharing-evaluator-factory 12 | #:public (list 'rebellion/web-link 'net/url) 13 | #:private (list 'racket/base))) 14 | 15 | @title{Web Links} 16 | @defmodule[rebellion/web-link] 17 | 18 | @(define rfc8288 "https://tools.ietf.org/html/rfc8288") 19 | 20 | A @deftech{web link} is a relationship between two resources, represented as a 21 | source-relationship-target triple. See @hyperlink[rfc8288]{RFC 8288 - Web 22 | Linking} for more information on the purpose and uses of links. 23 | 24 | @defproc[(web-link? [v any/c]) boolean?]{ 25 | A predicate for @tech{web links}.} 26 | 27 | @defproc[(web-link [source (or/c url? string?)] 28 | [relation (or/c symbol? url? string?)] 29 | [target (or/c url? string?)]) 30 | web-link?]{ 31 | Constructs a @tech{web link} from @racket[source] to @racket[target] with type 32 | @racket[relation]. 33 | 34 | @(examples 35 | #:eval (make-evaluator) #:once 36 | (web-link "http://example.org" 'stylesheet "/styles.css"))} 37 | 38 | @deftogether[[ 39 | @defproc[(web-link-source [link web-link?]) url?] 40 | @defproc[(web-link-relation [link web-link?]) (or/c symbol? url?)] 41 | @defproc[(web-link-target [link web-link?]) url?]]]{ 42 | Accessors for the various components of a @tech{web link}.} 43 | --------------------------------------------------------------------------------