From 6987dc991886aee198579b7062500b3c07f38c8e Mon Sep 17 00:00:00 2001 From: AlexKnauth Date: Sun, 13 Dec 2015 22:45:20 -0500 Subject: [PATCH] move more unstable code to lens/private --- lens/private/set/set-filterer.rkt | 54 ++++++++++++++++++++++++++ lens/private/set/set-member.rkt | 30 ++++++++++++++ lens/private/string/string-split.rkt | 56 +++++++++++++++++++++++++++ unstable/lens/set-filterer.rkt | 56 +-------------------------- unstable/lens/set-member.rkt | 32 +-------------- unstable/lens/string-split.rkt | 58 +--------------------------- 6 files changed, 146 insertions(+), 140 deletions(-) create mode 100644 lens/private/set/set-filterer.rkt create mode 100644 lens/private/set/set-member.rkt create mode 100644 lens/private/string/string-split.rkt diff --git a/lens/private/set/set-filterer.rkt b/lens/private/set/set-filterer.rkt new file mode 100644 index 0000000..76940ae --- /dev/null +++ b/lens/private/set/set-filterer.rkt @@ -0,0 +1,54 @@ +#lang sweet-exp racket/base + +require racket/contract/base + +provide + contract-out + set-filterer-lens (-> predicate/c (lens/c functional-set? functional-set?)) + +require lens/private/base/main + lens/private/util/functional-set + racket/set + racket/function + fancy-app + +module+ test + require rackunit + + +(define (set-filter pred set) + (for/fold ([set set]) ([elem (in-set set)] #:unless (pred elem)) + (set-remove set elem))) + +(define (set-filter-not pred set) + (for/fold ([set set]) ([elem (in-set set)] #:when (pred elem)) + (set-remove set elem))) + +(define (andmap-set pred set) + (andmap pred (set->list set))) + + +(define (check-set-filterer-lens-view pred new-view-to-check) + (unless (andmap-set pred new-view-to-check) + (raise-argument-error 'set-filterer-lens + (format "(set/c ~a)" (contract-name pred)) + new-view-to-check))) + +(define (set-filterer-lens pred) + (define (insert-filtered-items target new-view) + (check-set-filterer-lens-view pred new-view) + (set-union (set-filter-not pred target) new-view)) + (make-lens (set-filter pred _) + insert-filtered-items)) + +module+ test + (check-equal? (lens-view (set-filterer-lens number?) '(1 a 2 b c 3 d e)) + '(1 2 3)) + (check-equal? (lens-set (set-filterer-lens number?) '(1 a 2 b c 3 d e) '(4 5 6 7)) + '(7 6 5 4 a b c d e)) + (check-equal? (lens-view (set-filterer-lens number?) (set 1 'a 2 'b 'c 3 'd 'e)) + (set 1 2 3)) + (check-equal? (lens-set (set-filterer-lens number?) (set 1 'a 2 'b 'c 3 'd 'e) (set 4 5 6 7)) + (set 4 5 6 7 'a 'b 'c 'd 'e)) + (check-exn exn:fail:contract? + (thunk (lens-set (set-filterer-lens number?) (set 1) (set 'a)))) diff --git a/lens/private/set/set-member.rkt b/lens/private/set/set-member.rkt new file mode 100644 index 0000000..845c323 --- /dev/null +++ b/lens/private/set/set-member.rkt @@ -0,0 +1,30 @@ +#lang sweet-exp racket/base + +require racket/contract/base +provide + contract-out + set-member-lens (-> any/c (lens/c functional-set? boolean?)) + +require fancy-app + lens/private/base/main + lens/private/util/functional-set + racket/set +module+ test + require rackunit + +(define (set-member-lens v) + (make-lens + (set-member? _ v) + (λ (tgt nvw) + (if nvw + (set-add tgt v) + (set-remove tgt v))))) + +module+ test + (define 2-lens (set-member-lens 2)) + (check-equal? (lens-view 2-lens (set 1 2 3)) #t) + (check-equal? (lens-view 2-lens (set 1 3)) #f) + (check-equal? (lens-set 2-lens (set 1 2 3) #t) (set 1 2 3)) + (check-equal? (lens-set 2-lens (set 1 2 3) #f) (set 1 3)) + (check-equal? (lens-set 2-lens (set 1 3) #t) (set 1 2 3)) + (check-equal? (lens-set 2-lens (set 1 3) #f) (set 1 3)) diff --git a/lens/private/string/string-split.rkt b/lens/private/string/string-split.rkt new file mode 100644 index 0000000..70779d6 --- /dev/null +++ b/lens/private/string/string-split.rkt @@ -0,0 +1,56 @@ +#lang racket/base + +(require racket/contract/base) +(provide (contract-out + [string-split-lens + (-> (or/c immutable-string? char? regexp?) + (lens/c immutable-string? (listof immutable-string?)))] + )) + +(require racket/match + racket/string + lens/private/base/main + lens/private/util/immutable + ) +(module+ test + (require rackunit)) + +(define (string-split-lens sep) + (define sep-rx + (cond + [(string? sep) (regexp (regexp-quote sep))] + [(char? sep) (regexp (regexp-quote (string sep)))] + [(regexp? sep) sep] + [else (error 'bad)])) + (define (get str) + (map string->immutable-string (regexp-split sep-rx str))) + (define (set str lst) + (for ([s (in-list lst)]) + (when (regexp-match? sep-rx s) ; this would violate the lens laws + (error 'string-split-lens "expected a string not matching ~v, given: ~v" sep s))) + (define seps (regexp-match* sep-rx str)) + (match-define (cons fst rst) lst) + (string->immutable-string (string-append* fst (map string-append seps rst)))) + (make-lens get set)) + +(module+ test + (define ws-lens (string-split-lens #px"\\s+")) + (check-equal? (lens-view ws-lens " foo bar baz \r\n\t") + '("" "foo" "bar" "baz" "")) + (check-equal? (lens-set ws-lens " foo bar baz \r\n\t" '("a" "b" "c" "d" "e")) + "a b c d \r\n\te") + (check-equal? (lens-view ws-lens "a b c d \r\n\te") + '("a" "b" "c" "d" "e")) + (check-equal? (lens-set ws-lens "a b c d \r\n\te" '("" "foo" "bar" "baz" "")) + " foo bar baz \r\n\t") + (define newline-lens (string-split-lens "\n")) + (check-equal? (lens-view newline-lens "a,b\nc,d\ne,f,g") + '("a,b" "c,d" "e,f,g")) + (check-equal? (lens-set newline-lens "a,b\nc,d\ne,f,g" '("1" "2" "3")) + "1\n2\n3") + (define comma-lens (string-split-lens #\,)) + (check-equal? (lens-view comma-lens "a,b,c") + '("a" "b" "c")) + (check-equal? (lens-set comma-lens "a,b,c" '("1" "2" "3")) + "1,2,3") + ) diff --git a/unstable/lens/set-filterer.rkt b/unstable/lens/set-filterer.rkt index 76940ae..f919f42 100644 --- a/unstable/lens/set-filterer.rkt +++ b/unstable/lens/set-filterer.rkt @@ -1,54 +1,2 @@ -#lang sweet-exp racket/base - -require racket/contract/base - -provide - contract-out - set-filterer-lens (-> predicate/c (lens/c functional-set? functional-set?)) - -require lens/private/base/main - lens/private/util/functional-set - racket/set - racket/function - fancy-app - -module+ test - require rackunit - - -(define (set-filter pred set) - (for/fold ([set set]) ([elem (in-set set)] #:unless (pred elem)) - (set-remove set elem))) - -(define (set-filter-not pred set) - (for/fold ([set set]) ([elem (in-set set)] #:when (pred elem)) - (set-remove set elem))) - -(define (andmap-set pred set) - (andmap pred (set->list set))) - - -(define (check-set-filterer-lens-view pred new-view-to-check) - (unless (andmap-set pred new-view-to-check) - (raise-argument-error 'set-filterer-lens - (format "(set/c ~a)" (contract-name pred)) - new-view-to-check))) - -(define (set-filterer-lens pred) - (define (insert-filtered-items target new-view) - (check-set-filterer-lens-view pred new-view) - (set-union (set-filter-not pred target) new-view)) - (make-lens (set-filter pred _) - insert-filtered-items)) - -module+ test - (check-equal? (lens-view (set-filterer-lens number?) '(1 a 2 b c 3 d e)) - '(1 2 3)) - (check-equal? (lens-set (set-filterer-lens number?) '(1 a 2 b c 3 d e) '(4 5 6 7)) - '(7 6 5 4 a b c d e)) - (check-equal? (lens-view (set-filterer-lens number?) (set 1 'a 2 'b 'c 3 'd 'e)) - (set 1 2 3)) - (check-equal? (lens-set (set-filterer-lens number?) (set 1 'a 2 'b 'c 3 'd 'e) (set 4 5 6 7)) - (set 4 5 6 7 'a 'b 'c 'd 'e)) - (check-exn exn:fail:contract? - (thunk (lens-set (set-filterer-lens number?) (set 1) (set 'a)))) +#lang reprovide +lens/private/set/set-filterer diff --git a/unstable/lens/set-member.rkt b/unstable/lens/set-member.rkt index 845c323..9f54abc 100644 --- a/unstable/lens/set-member.rkt +++ b/unstable/lens/set-member.rkt @@ -1,30 +1,2 @@ -#lang sweet-exp racket/base - -require racket/contract/base -provide - contract-out - set-member-lens (-> any/c (lens/c functional-set? boolean?)) - -require fancy-app - lens/private/base/main - lens/private/util/functional-set - racket/set -module+ test - require rackunit - -(define (set-member-lens v) - (make-lens - (set-member? _ v) - (λ (tgt nvw) - (if nvw - (set-add tgt v) - (set-remove tgt v))))) - -module+ test - (define 2-lens (set-member-lens 2)) - (check-equal? (lens-view 2-lens (set 1 2 3)) #t) - (check-equal? (lens-view 2-lens (set 1 3)) #f) - (check-equal? (lens-set 2-lens (set 1 2 3) #t) (set 1 2 3)) - (check-equal? (lens-set 2-lens (set 1 2 3) #f) (set 1 3)) - (check-equal? (lens-set 2-lens (set 1 3) #t) (set 1 2 3)) - (check-equal? (lens-set 2-lens (set 1 3) #f) (set 1 3)) +#lang reprovide +lens/private/set/set-member diff --git a/unstable/lens/string-split.rkt b/unstable/lens/string-split.rkt index 70779d6..ca63522 100644 --- a/unstable/lens/string-split.rkt +++ b/unstable/lens/string-split.rkt @@ -1,56 +1,2 @@ -#lang racket/base - -(require racket/contract/base) -(provide (contract-out - [string-split-lens - (-> (or/c immutable-string? char? regexp?) - (lens/c immutable-string? (listof immutable-string?)))] - )) - -(require racket/match - racket/string - lens/private/base/main - lens/private/util/immutable - ) -(module+ test - (require rackunit)) - -(define (string-split-lens sep) - (define sep-rx - (cond - [(string? sep) (regexp (regexp-quote sep))] - [(char? sep) (regexp (regexp-quote (string sep)))] - [(regexp? sep) sep] - [else (error 'bad)])) - (define (get str) - (map string->immutable-string (regexp-split sep-rx str))) - (define (set str lst) - (for ([s (in-list lst)]) - (when (regexp-match? sep-rx s) ; this would violate the lens laws - (error 'string-split-lens "expected a string not matching ~v, given: ~v" sep s))) - (define seps (regexp-match* sep-rx str)) - (match-define (cons fst rst) lst) - (string->immutable-string (string-append* fst (map string-append seps rst)))) - (make-lens get set)) - -(module+ test - (define ws-lens (string-split-lens #px"\\s+")) - (check-equal? (lens-view ws-lens " foo bar baz \r\n\t") - '("" "foo" "bar" "baz" "")) - (check-equal? (lens-set ws-lens " foo bar baz \r\n\t" '("a" "b" "c" "d" "e")) - "a b c d \r\n\te") - (check-equal? (lens-view ws-lens "a b c d \r\n\te") - '("a" "b" "c" "d" "e")) - (check-equal? (lens-set ws-lens "a b c d \r\n\te" '("" "foo" "bar" "baz" "")) - " foo bar baz \r\n\t") - (define newline-lens (string-split-lens "\n")) - (check-equal? (lens-view newline-lens "a,b\nc,d\ne,f,g") - '("a,b" "c,d" "e,f,g")) - (check-equal? (lens-set newline-lens "a,b\nc,d\ne,f,g" '("1" "2" "3")) - "1\n2\n3") - (define comma-lens (string-split-lens #\,)) - (check-equal? (lens-view comma-lens "a,b,c") - '("a" "b" "c")) - (check-equal? (lens-set comma-lens "a,b,c" '("1" "2" "3")) - "1,2,3") - ) +#lang reprovide +lens/private/string/string-split