Compare commits
No commits in common. "master" and "2.0" have entirely different histories.
2
.gitignore
vendored
2
.gitignore
vendored
|
|
@ -1,7 +1,7 @@
|
|||
**/compiled/*
|
||||
doc/
|
||||
**/*.bak
|
||||
**/*.html
|
||||
**/*.css
|
||||
**/*.js
|
||||
*~
|
||||
**.rktd
|
||||
|
|
|
|||
32
.travis.yml
32
.travis.yml
|
|
@ -1,36 +1,22 @@
|
|||
language: c
|
||||
langauge: c
|
||||
sudo: false
|
||||
env:
|
||||
global:
|
||||
- RACKET_DIR=~/racket
|
||||
- VERSION_TO_COVER="6.5"
|
||||
matrix:
|
||||
- RACKET_VERSION="6.0.1" CATALOG_VERSION="6.0.1"
|
||||
- RACKET_VERSION="6.1" CATALOG_VERSION="6.1"
|
||||
- RACKET_VERSION="6.1.1" CATALOG_VERSION="6.1.1"
|
||||
- RACKET_VERSION="6.2" CATALOG_VERSION="6.2"
|
||||
- RACKET_VERSION="6.2.1" CATALOG_VERSION="6.2.1"
|
||||
- RACKET_VERSION="6.3" CATALOG_VERSION="6.3"
|
||||
- RACKET_VERSION="6.4" CATALOG_VERSION="6.4"
|
||||
- RACKET_VERSION="6.5" CATALOG_VERSION="6.5"
|
||||
- RACKET_VERSION="6.6" CATALOG_VERSION="6.6"
|
||||
- RACKET_VERSION="HEAD" CATALOG_VERSION="6.6"
|
||||
matrix:
|
||||
allow_failures:
|
||||
- env: RACKET_VERSION="HEAD" CATALOG_VERSION="6.6"
|
||||
- RACKET_VERSION=6.1.1
|
||||
- RACKET_VERSION=6.2
|
||||
- RACKET_VERSION=HEAD
|
||||
|
||||
before_install:
|
||||
- git clone https://github.com/greghendershott/travis-racket.git ../travis-racket
|
||||
- cat ../travis-racket/install-racket.sh | bash
|
||||
- export PATH="${RACKET_DIR}/bin:${PATH}"
|
||||
- export VERSION_SPECIFIC_CATALOG="http://download.racket-lang.org/releases/${CATALOG_VERSION}/catalog/"
|
||||
- raco pkg config --set catalogs $VERSION_SPECIFIC_CATALOG http://pkgs.racket-lang.org http://planet-compats.racket-lang.org
|
||||
- if [ "${VERSION_TO_COVER}" == "${RACKET_VERSION}" ]; then raco pkg install --auto cover cover-coveralls; fi
|
||||
|
||||
install:
|
||||
- raco pkg install --auto lens-common/ lens-data/ lens-lib/ lens-unstable/ lens-doc/ lens/
|
||||
install: raco pkg install --deps search-auto $TRAVIS_BUILD_DIR # install dependencies
|
||||
|
||||
script:
|
||||
- raco test -p lens-common lens-data lens-lib lens-unstable lens-doc lens
|
||||
- if [ "${VERSION_TO_COVER}" == "${RACKET_VERSION}" ]; then raco cover -f coveralls -d $TRAVIS_BUILD_DIR/coverage -p lens-common lens-data lens-lib lens-unstable lens-doc lens; fi
|
||||
- raco setup
|
||||
- raco test $TRAVIS_BUILD_DIR # run tests. you wrote tests, right?
|
||||
|
||||
after_success:
|
||||
- raco cover -f coveralls -d $TRAVIS_BUILD_DIR/coverage . # generate coverage information for coveralls
|
||||
|
|
|
|||
23
LICENSE
23
LICENSE
|
|
@ -1,23 +0,0 @@
|
|||
The MIT License (MIT)
|
||||
|
||||
Copyright (c) 2015 Jack Firth
|
||||
Modified work Copyright 2015 Alex Knauth
|
||||
Modified work Copyright 2015 Google Inc.
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
of this software and associated documentation files (the "Software"), to deal
|
||||
in the Software without restriction, including without limitation the rights
|
||||
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
copies of the Software, and to permit persons to whom the Software is
|
||||
furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all
|
||||
copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
SOFTWARE.
|
||||
75
README.md
75
README.md
|
|
@ -1,78 +1,15 @@
|
|||
# lens  [](https://travis-ci.org/jackfirth/lens) [](https://coveralls.io/r/jackfirth/lens) [](https://waffle.io/jackfirth/lens) [](http://pkg-build.racket-lang.org/doc/lens/index.html) [](https://gitter.im/jackfirth/lens?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
|
||||
lens [](https://travis-ci.org/jackfirth/lens) [](https://coveralls.io/r/jackfirth/lens) [](https://waffle.io/jackfirth/lens)
|
||||
===================================
|
||||
Documentation: [`lens`](http://pkg-build.racket-lang.org/doc/lens/index.html) [`unstable/lens`](http://pkg-build.racket-lang.org/doc/unstable-lens/index.html)
|
||||
|
||||
Latest Version: `1.2`
|
||||
|
||||
A Racket package for creating and composing pure functional lenses.
|
||||
|
||||
`raco pkg install lens`
|
||||
`(require lens)`
|
||||
|
||||
### What on earth are lenses?
|
||||
|
||||
A lens is a value that can be used to focus on a small subpiece of some larger structure. A lens splits some data structure into two pieces - a *view*, which is some small isolated component of the data structure, and a *context*, which is everything else. The context can have a new view placed into it. This makes a lens act like a pure functional getter and setter:
|
||||
|
||||
```racket
|
||||
> (lens-view first-lens '(1 2 3))
|
||||
1
|
||||
> (lens-set first-lens '(1 2 3) 'a)
|
||||
'(a 2 3)
|
||||
```
|
||||
|
||||
Lenses are first class values and pure functional, so they can be abstracted over and functions that operate on lenses can be created. For instance, given a lens its view can be "updated":
|
||||
|
||||
```racket
|
||||
> (lens-transform first-lens '(1 2 3) number->string)
|
||||
'("1" 2 3)
|
||||
```
|
||||
|
||||
Additionaly, lenses are separate values from the objects they operate on, so they can be manipulated independently of any specific data. Functions can construct lenses, and operations can combine lenses. This allows for *lens composition*:
|
||||
|
||||
```racket
|
||||
> (define first-of-b-key-lens (lens-compose first-lens (hash-ref-lens 'b)))
|
||||
> (define a-hash (hash 'a '(1 2 3) 'b '(10 20 30) 'c '(100 200 300)))
|
||||
> (lens-view first-of-b-key-lens a-hash)
|
||||
10
|
||||
> (lens-set first-of-b-key-lens a-hash 'foo)
|
||||
#hash((a . (1 2 3)) (b . (foo 20 30)) (c . (100 200 300)))
|
||||
```
|
||||
|
||||
Lenses can also be joined together to form compound lenses that view many things:
|
||||
|
||||
```racket
|
||||
> (define first-third-fifth-lens (lens-join/list first-lens third-lens fifth-lens))
|
||||
> (lens-view first-third-fifth-lens '(1 2 3 4 5 6))
|
||||
'(1 3 5)
|
||||
> (lens-set first-third-fifth-lens '(1 2 3 4 5 6) '(a b c))
|
||||
'(a 2 b 4 c 6)
|
||||
```
|
||||
|
||||
Lenses can also be extended to operate on some new data structure:
|
||||
|
||||
```racket
|
||||
> (define first-of-each-lens (map-lens first-lens))
|
||||
> (lens-view first-of-each-lens '((1 2) (3 4) (5 6)))
|
||||
'(1 3 5)
|
||||
> (lens-set first-of-each-lens '((1 2) (3 4) (5 6)) '(a b c))
|
||||
'((a 2) (b 4) (c 6))
|
||||
```
|
||||
|
||||
See [the documentation](http://pkg-build.racket-lang.org/doc/lens/index.html) for a full API reference
|
||||
|
||||
#### So when would I want to use lenses?
|
||||
|
||||
Lenses are most effective when you're dealing with the "giant ball of state" problem. When you
|
||||
have a large amount of state you need to pass around between code written in a functional
|
||||
style, it's difficult to update and manage it due to the lack of mutation "magically" updating
|
||||
your entire object graph when a function changes a small part of it. Lenses allow code to
|
||||
break down and manipulate portions of this state, simplifying interactions and updates.
|
||||
|
||||
In particular, consider using lenses if you find yourself doing any of the following:
|
||||
|
||||
- Using a giant complex piece of state that most pieces of code only care about a small part of
|
||||
- Writing `struct-copy` a lot
|
||||
- Converting some hairy data structure into another one, manipulating it, then turning it back
|
||||
- Wishing you could treat data X as if it were a Y, i.e. "I wish this struct was a list so I could `map` over it easily"
|
||||
- Creating structs that have nested struct instances inside them.
|
||||
|
||||
For a more in depth introduction, see [The Lens Guide](http://pkg-build.racket-lang.org/doc/lens/lens-guide.html). For detailed API documentation, see [The Lens Reference](http://pkg-build.racket-lang.org/doc/lens/lens-reference.html).
|
||||
A lens is a value that can be used to focus on a small subpiece of some larger structure. Given a lens and a value of that larger structure, two values can be dervied: a *view* value, which is the subpiece, and a *context* function, which accepts a new view value and returns a new structure with the old view replaced by the new view. Think of them as composable, pure functional getters and setters. Examples can be found in the documentation.
|
||||
|
||||
#### Contributions
|
||||
|
||||
|
|
|
|||
68
info.rkt
Normal file
68
info.rkt
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
#lang info
|
||||
|
||||
(define collection 'multi)
|
||||
|
||||
|
||||
(define version "2.0")
|
||||
|
||||
|
||||
(define deps
|
||||
'("base"
|
||||
"rackunit-lib"
|
||||
"unstable-lib"
|
||||
"fancy-app"
|
||||
"alexis-util"
|
||||
"scribble-lib"))
|
||||
|
||||
|
||||
(define build-deps
|
||||
'("cover"
|
||||
"rackunit-lib"
|
||||
"racket-doc"
|
||||
"doc-coverage"))
|
||||
|
||||
|
||||
(define test-omit-paths
|
||||
'("info.rkt"
|
||||
"lens/base/base.scrbl"
|
||||
"lens/base/contract.scrbl"
|
||||
"lens/base/laws.scrbl"
|
||||
"lens/base/main.scrbl"
|
||||
"lens/base/transform.scrbl"
|
||||
"lens/base/view-set.scrbl"
|
||||
"lens/compound/compose.scrbl"
|
||||
"lens/compound/join-hash.scrbl"
|
||||
"lens/compound/join-list.scrbl"
|
||||
"lens/compound/join-string.scrbl"
|
||||
"lens/compound/join-vector.scrbl"
|
||||
"lens/compound/main.scrbl"
|
||||
"lens/compound/thrush.scrbl"
|
||||
"lens/doc-util"
|
||||
"lens/hash/main.scrbl"
|
||||
"lens/hash/nested.scrbl"
|
||||
"lens/hash/pick.scrbl"
|
||||
"lens/hash/ref.scrbl"
|
||||
"lens/list/assoc.scrbl"
|
||||
"lens/list/car-cdr.scrbl"
|
||||
"lens/list/list-ref-take-drop.scrbl"
|
||||
"lens/list/main.scrbl"
|
||||
"lens/list/multi.scrbl"
|
||||
"lens/struct/field.scrbl"
|
||||
"lens/struct/main.scrbl"
|
||||
"lens/struct/struct.scrbl"
|
||||
"lens/test-util"
|
||||
"lens/vector/main.scrbl"
|
||||
"lens/vector/nested.scrbl"
|
||||
"lens/vector/pick.scrbl"
|
||||
"lens/vector/ref.scrbl"
|
||||
"lens/applicable.scrbl"
|
||||
"lens/dict.scrbl"
|
||||
"lens/info.rkt"
|
||||
"lens/main.scrbl"
|
||||
"lens/stream.scrbl"
|
||||
"lens/string.scrbl"
|
||||
"unstable/lens/arrow.scrbl"
|
||||
"unstable/lens/main.scrbl"
|
||||
"unstable/lens/sublist.scrbl"
|
||||
"unstable/lens/syntax.scrbl"
|
||||
"unstable/lens/view-set.scrbl"))
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define collection 'multi)
|
||||
|
||||
(define deps
|
||||
'("base"
|
||||
"fancy-app"
|
||||
"rackunit-lib"
|
||||
"reprovide-lang"
|
||||
"unstable-contract-lib"
|
||||
"unstable-lib"
|
||||
))
|
||||
|
||||
(define build-deps
|
||||
'("lens-data"
|
||||
"sweet-exp-lib"
|
||||
))
|
||||
|
||||
(define cover-omit-paths
|
||||
'(#rx"info\\.rkt"
|
||||
#rx"main\\.rkt"
|
||||
"lens/common.rkt"
|
||||
"lens/private/test-util"
|
||||
"lens/private/util"
|
||||
))
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang sweet-exp reprovide
|
||||
except-in
|
||||
combine-in
|
||||
lens/private/base/main
|
||||
lens/private/compound/main
|
||||
gen:lens
|
||||
focus-lens
|
||||
use-applicable-lenses!
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
#lang racket/base
|
||||
(require reprovide/reprovide)
|
||||
(reprovide (except-in "gen-lens.rkt" gen-lens/c) "make-lens.rkt" "contract.rkt")
|
||||
(module+ test
|
||||
(require rackunit racket/list)
|
||||
(define (set-first l v)
|
||||
(list* v (rest l)))
|
||||
(define first-lens (make-lens first set-first))
|
||||
(let-lens (view-first setter-first) first-lens '(1 2 3 4 5)
|
||||
(check-eqv? view-first 1)
|
||||
(check-equal? (setter-first 'a) '(a 2 3 4 5))))
|
||||
|
|
@ -1,44 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide lens/c)
|
||||
|
||||
(require racket/contract/base
|
||||
unstable/contract
|
||||
"gen-lens.rkt"
|
||||
)
|
||||
(module+ test
|
||||
(require rackunit
|
||||
racket/contract/region
|
||||
fancy-app
|
||||
"make-lens.rkt"
|
||||
))
|
||||
|
||||
(define (lens/c target/c view/c)
|
||||
(rename-contract
|
||||
(gen-lens/c
|
||||
[lens-view (or/c #f [lens? target/c . -> . view/c])]
|
||||
[lens-set (or/c #f [lens? target/c view/c . -> . target/c])]
|
||||
[focus-lens (or/c #f [lens? target/c . -> . (values view/c [view/c . -> . target/c])])])
|
||||
`(lens/c ,(contract-name target/c) ,(contract-name view/c))))
|
||||
|
||||
(module+ test
|
||||
(check-exn exn:fail:contract?
|
||||
(λ ()
|
||||
(define/contract lns (lens/c any/c any/c) #f)
|
||||
(void)))
|
||||
(define/contract lns (lens/c hash? string?)
|
||||
(make-lens (hash-ref _ 'a) (hash-set _ 'a _)))
|
||||
(check-equal? (lens-view lns (hash 'a "alpha" 'b "bet"))
|
||||
"alpha")
|
||||
(check-equal? (lens-set lns (hash 'a "alpha" 'b "bet") "alfa")
|
||||
(hash 'a "alfa" 'b "bet"))
|
||||
(let-lens [tgt ctxt] lns (hash 'a "alpha" 'b "bet")
|
||||
(check-equal? tgt "alpha")
|
||||
(check-equal? (ctxt "alfa") (hash 'a "alfa" 'b "bet"))
|
||||
(check-exn exn:fail:contract?
|
||||
(λ () (ctxt 'alpha))))
|
||||
(check-exn exn:fail:contract?
|
||||
(λ () (lens-view lns (hash 'a 'alpha 'b 'bet))))
|
||||
(check-exn exn:fail:contract?
|
||||
(λ () (lens-set lns (hash 'a "alpha" 'b "bet") 'alpha)))
|
||||
)
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract/base)
|
||||
(provide gen:lens
|
||||
let-lens
|
||||
(rename-out [lens/c gen-lens/c])
|
||||
(contract-out
|
||||
[lens? predicate/c]
|
||||
[lens-view (-> lens? any/c any/c)]
|
||||
[lens-set (-> lens? any/c any/c any/c)]
|
||||
[focus-lens (-> lens? any/c
|
||||
(values any/c (-> any/c any/c)))]
|
||||
[use-applicable-lenses! (-> void?)]
|
||||
))
|
||||
|
||||
(require racket/generic fancy-app)
|
||||
|
||||
(define-generics lens
|
||||
(lens-view lens target)
|
||||
(lens-set lens target x)
|
||||
(focus-lens lens target)
|
||||
#:defined-predicate lens-implements?
|
||||
#:fallbacks
|
||||
[(define/generic gen-lens-view lens-view)
|
||||
(define/generic gen-lens-set lens-set)
|
||||
(define/generic gen-focus-lens focus-lens)
|
||||
(define (lens-view lens target)
|
||||
(unless (lens-implements? lens 'focus-lens)
|
||||
(error 'lens-view "not implemented for ~v" lens))
|
||||
(let-values ([(view _) (gen-focus-lens lens target)])
|
||||
view))
|
||||
(define (lens-set lens target x)
|
||||
(unless (lens-implements? lens 'focus-lens)
|
||||
(error 'lens-set "not implemented for ~v" lens))
|
||||
(let-values ([(_ setter) (gen-focus-lens lens target)])
|
||||
(setter x)))
|
||||
(define (focus-lens lens target)
|
||||
(unless (lens-implements? lens 'lens-view 'lens-set)
|
||||
(error 'focus-lens "not implemented for ~v" lens))
|
||||
(values (gen-lens-view lens target)
|
||||
(gen-lens-set lens target _)))]
|
||||
#:derive-property prop:procedure
|
||||
(lambda (this target)
|
||||
(if (lenses-applicable?)
|
||||
(lens-view this target)
|
||||
(error "cannot apply a non-applicable lens as a function"))))
|
||||
|
||||
(define lenses-applicable? (make-parameter #f))
|
||||
|
||||
(define (use-applicable-lenses!)
|
||||
(lenses-applicable? #t))
|
||||
|
||||
(define-syntax-rule (let-lens (view context) lens-expr target-expr body ...)
|
||||
(let-values ([(view context) (focus-lens lens-expr target-expr)])
|
||||
body ...))
|
||||
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang reprovide
|
||||
lens/private/base/base
|
||||
"view-set.rkt"
|
||||
"transform.rkt"
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract/base)
|
||||
(provide (contract-out [make-lens (-> (-> any/c any/c)
|
||||
(-> any/c any/c any/c)
|
||||
lens?)]))
|
||||
|
||||
(require "gen-lens.rkt")
|
||||
|
||||
(module+ test
|
||||
(require rackunit racket/list racket/function))
|
||||
|
||||
(struct lens-struct (get set)
|
||||
#:methods gen:lens
|
||||
[(define (lens-view this target)
|
||||
((lens-struct-get this) target))
|
||||
(define (lens-set this target x)
|
||||
((lens-struct-set this) target x))]
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc this out mode)
|
||||
(write-string "#<lens>" out))])
|
||||
|
||||
(define (make-lens getter setter)
|
||||
(lens-struct getter setter))
|
||||
|
||||
(module+ test
|
||||
(define (set-first l v)
|
||||
(list* v (rest l)))
|
||||
(define first-lens (make-lens first set-first))
|
||||
(check-exn exn:fail? (thunk (first-lens '(a b c))))
|
||||
(let-lens (view-first setter-first) first-lens '(1 2 3 4 5)
|
||||
(check-eqv? view-first 1)
|
||||
(check-equal? (setter-first 'a) '(a 2 3 4 5)))
|
||||
(check-equal? (format "~v" first-lens) "#<lens>"))
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require reprovide/reprovide)
|
||||
(reprovide lens/common)
|
||||
|
||||
(require (only-in lens/private/base/base use-applicable-lenses!))
|
||||
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
|
||||
(use-applicable-lenses!)
|
||||
|
||||
(module+ test
|
||||
(define (set-car p a)
|
||||
(cons a (cdr p)))
|
||||
(define car-lens (make-lens car set-car))
|
||||
(check-equal? (car-lens '(a b c)) 'a)
|
||||
(check-equal? (lens-view car-lens '(a b c)) 'a)
|
||||
(check-equal? (lens-set car-lens '(a b c) 97) '(97 b c)))
|
||||
|
|
@ -1,74 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide define-nested-lenses
|
||||
|
||||
require lens/private/compound/thrush
|
||||
for-syntax racket/base
|
||||
racket/syntax
|
||||
syntax/parse
|
||||
syntax/srcloc
|
||||
"../util/id-append.rkt"
|
||||
module+ test
|
||||
require lens/private/base/base
|
||||
lens/private/list/main
|
||||
rackunit
|
||||
|
||||
begin-for-syntax
|
||||
(define (with-sub-range-binders stx prop)
|
||||
(syntax-property stx 'sub-range-binders prop))
|
||||
(define -- (update-source-location (datum->syntax #f '-)
|
||||
#:span 1))
|
||||
(define -lens (update-source-location (datum->syntax #f '-lens)
|
||||
#:span 5))
|
||||
;; helper syntax-class for define-nested-lenses
|
||||
(define-syntax-class (clause base-id base-lens-tmp)
|
||||
#:attributes (def)
|
||||
[pattern [suffix-id:id suffix-lens-expr:expr
|
||||
unchecked-clause ...]
|
||||
#:with base-lens:id base-lens-tmp
|
||||
#:do [(define-values [base-suffix-id base-suffix-sub-range]
|
||||
(id-append #:context base-id
|
||||
base-id -- #'suffix-id))
|
||||
(define-values [base-suffix-lens-id base-suffix-lens-sub-range]
|
||||
(id-append #:context base-id
|
||||
base-suffix-id -lens))]
|
||||
#:with base-suffix
|
||||
base-suffix-id
|
||||
#:with base-suffix-lens
|
||||
base-suffix-lens-id
|
||||
#:with [(~var clause (clause #'base-suffix #'base-suffix-lens)) ...]
|
||||
#'[unchecked-clause ...]
|
||||
#:with def
|
||||
(with-sub-range-binders
|
||||
#'(begin
|
||||
(define base-suffix-lens
|
||||
(lens-thrush base-lens suffix-lens-expr))
|
||||
clause.def
|
||||
...)
|
||||
base-suffix-lens-sub-range)])
|
||||
|
||||
|
||||
(define-syntax define-nested-lenses
|
||||
(syntax-parser
|
||||
[(define-nested-lenses [base:id base-lens-expr:expr]
|
||||
(~parse base-lens:id (generate-temporary #'base))
|
||||
(~var clause (clause #'base #'base-lens))
|
||||
...)
|
||||
#'(begin
|
||||
(define base-lens base-lens-expr)
|
||||
clause.def
|
||||
...)]))
|
||||
|
||||
module+ test
|
||||
(define-nested-lenses [first first-lens]
|
||||
[first first-lens]
|
||||
[second second-lens]
|
||||
[third third-lens
|
||||
[first first-lens]
|
||||
[second second-lens]])
|
||||
(check-equal? (lens-view first-first-lens '((a b c d) e)) 'a)
|
||||
(check-equal? (lens-view first-second-lens '((a b c d) e)) 'b)
|
||||
(check-equal? (lens-view first-third-lens '((a b c d) e)) 'c)
|
||||
(check-equal? (lens-view first-third-first-lens '((a b (c d) e) f)) 'c)
|
||||
(check-equal? (lens-view first-third-second-lens '((a b (c d) e) f)) 'd)
|
||||
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/function
|
||||
racket/contract/base
|
||||
"../base/main.rkt"
|
||||
lens/private/isomorphism/base
|
||||
|
||||
module+ test
|
||||
require rackunit
|
||||
"../base/main.rkt"
|
||||
"../test-util/test-lens.rkt"
|
||||
|
||||
provide
|
||||
contract-out
|
||||
identity-lens lens?
|
||||
|
||||
|
||||
(define identity-lens
|
||||
(make-isomorphism-lens identity identity))
|
||||
|
||||
(module+ test
|
||||
(check-lens-view identity-lens 'foo 'foo)
|
||||
(check-lens-set identity-lens 'foo 'bar 'bar))
|
||||
|
|
@ -1,92 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide lens-if
|
||||
lens-cond
|
||||
lens-match
|
||||
)
|
||||
|
||||
(require lens/private/base/main
|
||||
racket/match
|
||||
(for-syntax racket/base
|
||||
syntax/parse
|
||||
))
|
||||
(module+ test
|
||||
(require rackunit lens/private/list/main lens/private/vector/main lens/private/string/main))
|
||||
|
||||
(define (lens-if pred lens1 lens2)
|
||||
(make-lens
|
||||
(λ (tgt)
|
||||
(if (pred tgt)
|
||||
(lens-view lens1 tgt)
|
||||
(lens-view lens2 tgt)))
|
||||
(λ (tgt nvw)
|
||||
(if (pred tgt)
|
||||
(lens-set lens1 tgt nvw)
|
||||
(lens-set lens2 tgt nvw)))))
|
||||
|
||||
(define (any? x) #t)
|
||||
|
||||
(define-syntax lens-cond
|
||||
(syntax-parser #:literals (else)
|
||||
[(lens-cond [pred-expr:expr lens-expr:expr] ... [else else-lens-expr:expr])
|
||||
#'(lens-cond [pred-expr lens-expr] ... [any? else-lens-expr])]
|
||||
[(lens-cond [pred-expr:expr lens-expr:expr] ...)
|
||||
#:with [pred ...] (generate-temporaries #'[pred-expr ...])
|
||||
#:with [lens ...] (generate-temporaries #'[lens-expr ...])
|
||||
#'(let ([pred pred-expr] ... [lens lens-expr] ...)
|
||||
(make-lens
|
||||
(λ (tgt)
|
||||
(cond [(pred tgt) (lens-view lens tgt)]
|
||||
...
|
||||
[else (raise-lens-cond-error tgt 'pred-expr ...)]))
|
||||
(λ (tgt nvw)
|
||||
(cond [(pred tgt) (lens-set lens tgt nvw)]
|
||||
...
|
||||
[else (raise-lens-cond-error tgt 'pred-expr ...)]))))]))
|
||||
|
||||
(define (raise-lens-cond-error tgt . pred-expr-syms)
|
||||
(raise-arguments-error 'lens-cond "no matching clause for target"
|
||||
"target" tgt
|
||||
"expected" `(or/c ,@pred-expr-syms)))
|
||||
|
||||
(define-syntax lens-match
|
||||
(syntax-parser
|
||||
[(lens-match [pat:expr lens-expr:expr] ...)
|
||||
#'(make-lens
|
||||
(λ (tgt)
|
||||
(match tgt
|
||||
[pat (lens-view lens-expr tgt)]
|
||||
...))
|
||||
(λ (tgt nvw)
|
||||
(match tgt
|
||||
[pat (lens-set lens-expr tgt nvw)]
|
||||
...)))]))
|
||||
|
||||
(module+ test
|
||||
(define if-lens (lens-if list? first-lens (vector-ref-lens 0)))
|
||||
(check-equal? (lens-view if-lens '(1 2 3)) 1)
|
||||
(check-equal? (lens-view if-lens '#(1 2 3)) 1)
|
||||
(check-equal? (lens-set if-lens '(1 2 3) 'a) '(a 2 3))
|
||||
(check-equal? (lens-set if-lens '#(1 2 3) 'a) '#(a 2 3))
|
||||
(define cond-lens (lens-cond [list? first-lens]
|
||||
[vector? (vector-ref-lens 0)]
|
||||
[string? (string-ref-lens 0)]))
|
||||
(check-equal? (lens-view cond-lens '(1 2 3)) 1)
|
||||
(check-equal? (lens-view cond-lens '#(1 2 3)) 1)
|
||||
(check-equal? (lens-view cond-lens "123") #\1)
|
||||
(check-equal? (lens-set cond-lens '(1 2 3) 'a) '(a 2 3))
|
||||
(check-equal? (lens-set cond-lens '#(1 2 3) 'a) '#(a 2 3))
|
||||
(check-equal? (lens-set cond-lens "123" #\a) "a23")
|
||||
(define match-lens (lens-match [(list a) first-lens]
|
||||
[(list a b) second-lens]
|
||||
[(list a b c) third-lens]
|
||||
[(list a ... b) (list-ref-lens (length a))]))
|
||||
(check-equal? (lens-view match-lens '(1)) 1)
|
||||
(check-equal? (lens-view match-lens '(1 2)) 2)
|
||||
(check-equal? (lens-view match-lens '(1 2 3)) 3)
|
||||
(check-equal? (lens-view match-lens '(1 2 3 4 5 6)) 6)
|
||||
(check-equal? (lens-set match-lens '(1) 'a) '(a))
|
||||
(check-equal? (lens-set match-lens '(1 2) 'a) '(1 a))
|
||||
(check-equal? (lens-set match-lens '(1 2 3) 'a) '(1 2 a))
|
||||
(check-equal? (lens-set match-lens '(1 2 3 4 5 6) 'a) '(1 2 3 4 5 a))
|
||||
)
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide lazy-lens
|
||||
rec-lens
|
||||
|
||||
require fancy-app lens/private/base/main racket/promise
|
||||
module+ test
|
||||
require rackunit
|
||||
lens/private/compound/if
|
||||
lens/private/isomorphism/data
|
||||
lens/private/list/map
|
||||
|
||||
(define-syntax-rule (lazy-lens expr)
|
||||
(let ([p (delay expr)])
|
||||
(make-lens (lens-view (force p) _) (lens-set (force p) _ _))))
|
||||
|
||||
(define-syntax-rule (rec-lens name expr)
|
||||
(letrec ([name (lazy-lens expr)])
|
||||
name))
|
||||
|
||||
module+ test
|
||||
(define (tree-map-lens item-lens)
|
||||
(rec-lens the-tree-lens
|
||||
(lens-cond [list? (map-lens the-tree-lens)]
|
||||
[else item-lens])))
|
||||
(check-equal? (lens-view (tree-map-lens symbol->string-lens) '(a (b (() c)) (d)))
|
||||
'("a" ("b" (() "c")) ("d")))
|
||||
(check-equal? (lens-set (tree-map-lens symbol->string-lens)
|
||||
'(a (b (() c)) (d))
|
||||
'("hay" ("bee" (() "sea")) ("deep")))
|
||||
'(hay (bee (() sea)) (deep)))
|
||||
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang reprovide
|
||||
"compose.rkt"
|
||||
"identity.rkt"
|
||||
"thrush.rkt"
|
||||
|
|
@ -1,104 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/contract/base
|
||||
provide
|
||||
contract-out
|
||||
lens-zoom (-> lens? lens? lens?)
|
||||
lens-zoom* (->* [] #:rest (listof2 lens? lens?) lens?)
|
||||
|
||||
require fancy-app
|
||||
lens/private/base/main
|
||||
lens/private/compound/thrush
|
||||
lens/private/util/list-pair-contract
|
||||
racket/match
|
||||
unstable/sequence
|
||||
lens/private/isomorphism/base
|
||||
module+ test
|
||||
require lens/private/list/main
|
||||
rackunit
|
||||
lens/private/isomorphism/data
|
||||
lens/private/list/map
|
||||
|
||||
;; lens-zoom : (Lens (Outer Inner) Inner) (Lens A B) -> (Lens (Outer A) (Outer B))
|
||||
(define (lens-zoom zoom-lens transformer-lens)
|
||||
(match transformer-lens
|
||||
[(make-isomorphism-lens transformer inverse)
|
||||
;; transformer : A -> B
|
||||
;; inverse : B -> A
|
||||
(make-isomorphism-lens
|
||||
(lens-transform zoom-lens _ transformer) ; (Outer A) -> (Outer B)
|
||||
(lens-transform zoom-lens _ inverse))] ; (Outer B) -> (Outer A)
|
||||
[transformer-lens
|
||||
;; get : (Outer A) -> (Outer B)
|
||||
(define (get tgt)
|
||||
;; transformer : A -> B
|
||||
(define (transformer a)
|
||||
(lens-view transformer-lens a))
|
||||
(lens-transform zoom-lens tgt transformer))
|
||||
;; set : (Outer A) (Outer B) -> (Outer A)
|
||||
(define (set tgt nvw)
|
||||
;; a : A
|
||||
(define a (lens-view zoom-lens tgt))
|
||||
;; transformer : B -> A
|
||||
(define (transformer b)
|
||||
(lens-set transformer-lens a b))
|
||||
(lens-transform zoom-lens nvw transformer))
|
||||
(make-lens get set)]))
|
||||
|
||||
(define (lens-zoom* . lenses/transformers)
|
||||
(apply lens-thrush
|
||||
(for/list ([args (in-slice 2 lenses/transformers)])
|
||||
(apply lens-zoom args))))
|
||||
|
||||
module+ test
|
||||
(define first-sym->str
|
||||
(lens-zoom first-lens symbol->string-lens))
|
||||
(check-equal? (lens-view first-sym->str '(a b c))
|
||||
'("a" b c))
|
||||
(check-equal? (lens-set first-sym->str '(a b c) '("a" b c))
|
||||
'(a b c))
|
||||
(check-equal? (lens-set first-sym->str '(a b c) '("z" b c))
|
||||
'(z b c))
|
||||
(check-equal? (lens-set first-sym->str '(a b c) '("z" bee sea))
|
||||
'(z bee sea))
|
||||
(check-equal? (lens-view first-sym->str (lens-set first-sym->str '(a b c) '("z" bee sea)))
|
||||
'("z" bee sea))
|
||||
(define trans-second-first/third-second
|
||||
(lens-zoom* second-lens first-lens third-lens second-lens))
|
||||
(check-equal? (lens-view trans-second-first/third-second '(1 (2 3) (4 5)))
|
||||
'(1 2 5))
|
||||
(check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 2 5))
|
||||
'(1 (2 3) (4 5)))
|
||||
(check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(1 b 5))
|
||||
'(1 (b 3) (4 5)))
|
||||
(check-equal? (lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c))
|
||||
'(a (b 3) (4 c)))
|
||||
(check-equal? (lens-view trans-second-first/third-second
|
||||
(lens-set trans-second-first/third-second '(1 (2 3) (4 5)) '(a b c)))
|
||||
'(a b c))
|
||||
(define (rekey-alist-lens key->new-key-lens)
|
||||
(map-lens (lens-zoom car-lens key->new-key-lens)))
|
||||
(check-equal? (lens-view (rekey-alist-lens symbol->string-lens) '((a . 1) (b . 2) (c . 3)))
|
||||
'(("a" . 1) ("b" . 2) ("c" . 3)))
|
||||
(check-equal? (lens-set (rekey-alist-lens symbol->string-lens)
|
||||
'((a . 1) (b . 2) (c . 3))
|
||||
'(("a" . 10) ("b" . 200) ("c" . 3000)))
|
||||
'((a . 10) (b . 200) (c . 3000)))
|
||||
(check-equal? (lens-set (rekey-alist-lens symbol->string-lens)
|
||||
'((a . 1) (b . 2) (c . 3))
|
||||
'(("one" . 10) ("two" . 200) ("three" . 3000)))
|
||||
'((one . 10) (two . 200) (three . 3000)))
|
||||
(define (rek+v-alist-lens key->new-key-lens value->new-value-lens)
|
||||
(map-lens (lens-zoom* car-lens key->new-key-lens cdr-lens value->new-value-lens)))
|
||||
(check-equal? (lens-view (rek+v-alist-lens symbol->string-lens number->string-lens)
|
||||
'((a . 1) (b . 2) (c . 3)))
|
||||
'(("a" . "1") ("b" . "2") ("c" . "3")))
|
||||
(check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens)
|
||||
'((a . 1) (b . 2) (c . 3))
|
||||
'(("a" . "10") ("b" . "200") ("c" . "3000")))
|
||||
'((a . 10) (b . 200) (c . 3000)))
|
||||
(check-equal? (lens-set (rek+v-alist-lens symbol->string-lens number->string-lens)
|
||||
'((a . 1) (b . 2) (c . 3))
|
||||
'(("one" . "10") ("two" . "200") ("three" . "3000")))
|
||||
'((one . 10) (two . 200) (three . 3000)))
|
||||
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide isomorphism-lens?
|
||||
isomorphism-lens-inverse
|
||||
rename-out [isomorphism-lens make-isomorphism-lens]
|
||||
[isomorphism-lenses make-isomorphism-lenses]
|
||||
|
||||
require racket/match
|
||||
lens/private/base/gen-lens
|
||||
|
||||
|
||||
(struct isomorphism-lens (f inv) #:transparent
|
||||
#:methods gen:lens
|
||||
[(define (lens-view lens tgt)
|
||||
((isomorphism-lens-f lens) tgt))
|
||||
(define (lens-set lens tgt v)
|
||||
((isomorphism-lens-inv lens) v))])
|
||||
|
||||
(define (isomorphism-lens-inverse lens)
|
||||
(match lens
|
||||
[(isomorphism-lens f inv)
|
||||
(isomorphism-lens inv f)]))
|
||||
|
||||
(define (isomorphism-lenses f inv)
|
||||
(values (isomorphism-lens f inv)
|
||||
(isomorphism-lens inv f)))
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/contract/base
|
||||
provide
|
||||
contract-out
|
||||
isomorphism-compose
|
||||
(rest-> isomorphism-lens? isomorphism-lens?)
|
||||
isomorphism-thrush
|
||||
(rest-> isomorphism-lens? isomorphism-lens?)
|
||||
|
||||
require racket/match
|
||||
lens/private/util/rest-contract
|
||||
"base.rkt"
|
||||
module+ test
|
||||
require lens/private/base/main
|
||||
lens/private/compound/identity
|
||||
lens/private/isomorphism/data
|
||||
rackunit
|
||||
|
||||
(define (isomorphism-compose . args)
|
||||
(match args
|
||||
[(list (make-isomorphism-lens fs invs) ...)
|
||||
(make-isomorphism-lens
|
||||
(apply compose1 fs)
|
||||
(apply compose1 (reverse invs)))]))
|
||||
|
||||
(define (isomorphism-thrush . args)
|
||||
(apply isomorphism-compose (reverse args)))
|
||||
|
||||
module+ test
|
||||
(define string->vector-lens (isomorphism-thrush string->list-lens list->vector-lens))
|
||||
(check-equal? (lens-view string->vector-lens "abc") #(#\a #\b #\c))
|
||||
(check-equal? (lens-set string->vector-lens "abc" #(#\1 #\2 #\3)) "123")
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract
|
||||
rackunit
|
||||
fancy-app
|
||||
lens/private/base/base
|
||||
"../base/view-set.rkt")
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[check-lens-view (-> lens? any/c any/c void?)]
|
||||
[check-lens-set (-> lens? any/c any/c any/c void?)]
|
||||
[check-lens-view-set (-> lens? any/c void?)]
|
||||
[check-lens-set-view (-> lens? any/c any/c void?)]
|
||||
[check-lens-set-set (-> lens? any/c any/c any/c void?)]
|
||||
[test-lens-laws (-> lens? any/c any/c any/c void?)]))
|
||||
|
||||
|
||||
(define-check (check-lens-view lens target expected-view)
|
||||
(check-equal? (lens-view lens target) expected-view))
|
||||
|
||||
(define-check (check-lens-set lens target new-view expected-new-target)
|
||||
(check-equal? (lens-set lens target new-view) expected-new-target))
|
||||
|
||||
|
||||
(define-check (check-lens-view-set lens target)
|
||||
(check-lens-set lens target (lens-view lens target)
|
||||
target
|
||||
"setting target's view to its own view not equal? to itself"))
|
||||
|
||||
(define-check (check-lens-set-view lens target new-view)
|
||||
(check-lens-view lens (lens-set lens target new-view)
|
||||
new-view
|
||||
"view of target after setting it's view not equal? to the set view"))
|
||||
|
||||
(define-check (check-lens-set-set lens target new-view1 new-view2)
|
||||
(let* ([target* (lens-set lens target new-view1)]
|
||||
[target** (lens-set lens target* new-view2)])
|
||||
(check-lens-view lens target**
|
||||
new-view2
|
||||
"view of target after setting its view twice not equal? to second view")))
|
||||
|
||||
(define (test-lens-laws lens test-target test-view1 test-view2)
|
||||
(check-lens-view-set lens test-target)
|
||||
(check-lens-set-view lens test-target test-view1)
|
||||
(check-lens-set-view lens test-target test-view2)
|
||||
(check-lens-set-set lens test-target test-view1 test-view2))
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide test-multi*
|
||||
|
||||
require racket/match
|
||||
racket/string
|
||||
racket/format
|
||||
syntax/parse/define
|
||||
rackunit
|
||||
for-syntax racket/base
|
||||
syntax/parse
|
||||
|
||||
(define-simple-macro
|
||||
(test-multi* ([test-id:id #:in [test-variant:expr ...]] ...)
|
||||
body ...)
|
||||
#:with [pair-id ...] (generate-temporaries #'[test-id ...])
|
||||
#:with [which-test ...] (generate-temporaries #'[test-id ...])
|
||||
(for* ([pair-id (in-list (list (cons 'test-variant test-variant) ...))] ...)
|
||||
(match-define (cons which-test test-id) pair-id) ...
|
||||
(test-case (string-join (list (format "~a = ~a" 'test-id which-test) ...) ", ")
|
||||
body ...)))
|
||||
|
|
@ -1,65 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide id-append)
|
||||
|
||||
(require racket/list
|
||||
racket/syntax
|
||||
syntax/srcloc)
|
||||
|
||||
;; orig : Syntax -> Syntax
|
||||
(define (orig stx)
|
||||
(syntax-property stx 'original-for-check-syntax #t))
|
||||
|
||||
;; Sub-Range-Binder-Prop = (Treeof (Vector Id Nat Nat Real Real Id Nat Nat Real Real))
|
||||
;; Binder-Proc = Id -> Sub-Range-Binder-Prop
|
||||
|
||||
;; make-binder-proc : Id Nat -> Binder-Proc
|
||||
(define ((make-binder-proc base n) id)
|
||||
(vector (syntax-local-introduce id)
|
||||
n (syntax-span base) 0.5 0.5
|
||||
(syntax-local-introduce base)
|
||||
0 (syntax-span base) 0.5 0.5))
|
||||
|
||||
;; get-sub-range-binders : Id (Listof Binder-Proc) -> Sub-Range-Binder-Prop
|
||||
(define (get-sub-range-binders id binder-procs)
|
||||
(for/list ([binder-proc (in-list binder-procs)])
|
||||
(binder-proc id)))
|
||||
|
||||
;; empty-id : Syntax -> Id
|
||||
(define (empty-id ctxt)
|
||||
(datum->syntax ctxt '||))
|
||||
|
||||
(define appended-id-prop (gensym 'appended-id))
|
||||
|
||||
;; id-append : #:context Syntax Identifier ... -> (values Identifier Sub-Range-Binder-Prop)
|
||||
;; a wrapper around id-append* that keeps track of identifiers that
|
||||
;; are themselves appended from other identifiers
|
||||
(define (id-append #:context ctxt . ids)
|
||||
(define ids*
|
||||
(append*
|
||||
(for/list ([id (in-list ids)])
|
||||
;; appended : (U #false (Listof Id))
|
||||
(define appended (syntax-property id appended-id-prop))
|
||||
(cond [appended appended]
|
||||
[else (list id)]))))
|
||||
(define-values [id sub-range-binders]
|
||||
(apply id-append* #:context ctxt ids*))
|
||||
(values (syntax-property id appended-id-prop ids*)
|
||||
sub-range-binders))
|
||||
|
||||
;; id-append* : #:context Syntax Identifier ... -> (values Identifier Sub-Range-Binder-Prop)
|
||||
(define (id-append* #:context ctxt . ids)
|
||||
;; binder-procs : (Listof Binder-Proc)
|
||||
(define-values [id n binder-procs]
|
||||
(for/fold ([id1 (empty-id ctxt)] [n 0] [binder-procs '()])
|
||||
([id2 (in-list ids)])
|
||||
(values (format-id ctxt "~a~a" id1 id2)
|
||||
(+ n (syntax-span id2))
|
||||
(cons (make-binder-proc id2 n) binder-procs))))
|
||||
(define id* (orig id))
|
||||
(values id*
|
||||
(get-sub-range-binders id* binder-procs)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -1,27 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define collection 'multi)
|
||||
|
||||
(define deps
|
||||
'("base"
|
||||
"lens-common"
|
||||
"rackunit-lib"
|
||||
"unstable-lib"
|
||||
"unstable-list-lib"
|
||||
"unstable-contract-lib"
|
||||
"fancy-app"
|
||||
"syntax-classes-lib"
|
||||
"struct-update-lib"
|
||||
"kw-make-struct"
|
||||
"reprovide-lang"
|
||||
))
|
||||
|
||||
(define build-deps
|
||||
'("sweet-exp-lib"
|
||||
))
|
||||
|
||||
(define cover-omit-paths
|
||||
'(#rx"info\\.rkt"
|
||||
#rx"main\\.rkt"
|
||||
))
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang sweet-exp reprovide
|
||||
"data/dict.rkt"
|
||||
"data/hash.rkt"
|
||||
"data/list.rkt"
|
||||
"data/stream.rkt"
|
||||
"data/string.rkt"
|
||||
"data/struct.rkt"
|
||||
"data/vector.rkt"
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang reprovide
|
||||
lens/private/dict/dict
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang reprovide
|
||||
lens/private/hash/main
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang reprovide
|
||||
lens/private/list/main
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang reprovide
|
||||
lens/private/stream/stream
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang reprovide
|
||||
lens/private/string/main
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang reprovide
|
||||
lens/private/struct/main
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
#lang reprovide
|
||||
lens/private/vector/main
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/contract/base
|
||||
provide
|
||||
contract-out
|
||||
dict-ref-nested-lens (->* [] #:rest (listof any/c) (lens/c functional-dict? any/c))
|
||||
|
||||
require lens/private/base/main
|
||||
lens/private/compound/thrush
|
||||
lens/private/dict/dict
|
||||
lens/private/util/functional-dict
|
||||
module+ test
|
||||
require rackunit fancy-app
|
||||
|
||||
(define (dict-ref-nested-lens . ks)
|
||||
(apply lens-thrush (map dict-ref-lens ks)))
|
||||
|
||||
module+ test
|
||||
(define a-x (dict-ref-nested-lens 'a 'x))
|
||||
(let-lens [val ctxt] a-x '([a . ([x . 1] [y . 2])] '[b . ([z . 3])])
|
||||
(check-equal? val 1)
|
||||
(check-equal? (ctxt 100) '([a . ([x . 100] [y . 2])] '[b . ([z . 3])])))
|
||||
(check-equal? (lens-transform/list '([a . ([x . 1] [y . 2])] '[b . ([z . 3])]) a-x (* 10 _))
|
||||
'([a . ([x . 10] [y . 2])] '[b . ([z . 3])]))
|
||||
|
|
@ -1,60 +0,0 @@
|
|||
#lang sweet-exp racket
|
||||
|
||||
;; inspired by https://github.com/jackfirth/racket-auto-fix-deps/blob/master/job/src/filter-hash.rkt
|
||||
|
||||
provide
|
||||
contract-out
|
||||
hash-filterer-lens (-> (-> any/c any/c boolean?) (lens/c immutable-hash? immutable-hash?))
|
||||
hash-filterer-lens/key (-> predicate/c (lens/c immutable-hash? immutable-hash?))
|
||||
hash-filterer-lens/value (-> predicate/c (lens/c immutable-hash? immutable-hash?))
|
||||
|
||||
require fancy-app
|
||||
lens/private/base/main
|
||||
lens/private/util/immutable
|
||||
unstable/hash
|
||||
module+ test
|
||||
require lens/private/test-util/test-lens
|
||||
rackunit
|
||||
|
||||
(define (hash-filter keep? hsh)
|
||||
(for/hash ([(k v) (in-hash hsh)] #:when (keep? k v))
|
||||
(values k v)))
|
||||
|
||||
(define (hash-filter-not drop? hsh)
|
||||
(hash-filter (λ (k v) (not (drop? k v))) hsh))
|
||||
|
||||
(define (hash-andmap f hsh)
|
||||
(for/and ([(k v) (in-hash hsh)])
|
||||
(f k v)))
|
||||
|
||||
(define (hash-filterer-lens keep?)
|
||||
(make-lens
|
||||
(hash-filter keep? _)
|
||||
(λ (tgt nvw)
|
||||
(unless (hash-andmap keep? nvw)
|
||||
(raise-argument-error 'hash-filterer-lens-setter
|
||||
(format "a hash where all key-value pairs pass ~v" keep?)
|
||||
nvw))
|
||||
(hash-union (hash-filter-not keep? tgt) nvw))))
|
||||
|
||||
(define (hash-filterer-lens/key keep?)
|
||||
(hash-filterer-lens (λ (k v) (keep? k))))
|
||||
|
||||
(define (hash-filterer-lens/value keep?)
|
||||
(hash-filterer-lens (λ (k v) (keep? v))))
|
||||
|
||||
module+ test
|
||||
(check-lens-view (hash-filterer-lens/key symbol?) (hash 'a 1 "b" 2 'c 3)
|
||||
(hash 'a 1 'c 3))
|
||||
(check-lens-set (hash-filterer-lens/key symbol?) (hash 'a 1 "b" 2 'c 3) (hash 'd 4 'e 5)
|
||||
(hash "b" 2 'd 4 'e 5))
|
||||
(check-lens-view (hash-filterer-lens/value number?) (hash 'a 1 'b "two" 'c 3)
|
||||
(hash 'a 1 'c 3))
|
||||
(check-lens-set (hash-filterer-lens/value number?) (hash 'a 1 'b "two" 'c 3) (hash 'd 4)
|
||||
(hash 'b "two" 'd 4))
|
||||
(check-lens-view (hash-filterer-lens =) (hash 1 1.0 2 45 3 3)
|
||||
(hash 1 1.0 3 3))
|
||||
(check-lens-set (hash-filterer-lens =) (hash 1 1.0 2 45 3 3) (hash 4 4.0 5.0 5)
|
||||
(hash 2 45 4 4.0 5.0 5))
|
||||
(check-exn exn:fail:contract?
|
||||
(thunk (lens-set (hash-filterer-lens/key symbol?) (hash 'a 1) (hash "d" 4))))
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract
|
||||
racket/match
|
||||
unstable/sequence
|
||||
fancy-app
|
||||
lens/private/base/main
|
||||
lens/private/util/alternating-list
|
||||
lens/private/util/list-pair-contract
|
||||
"../util/immutable.rkt"
|
||||
"../list/join-list.rkt")
|
||||
|
||||
(module+ test
|
||||
(require rackunit
|
||||
"../list/list-ref-take-drop.rkt"
|
||||
lens/private/test-util/test-lens))
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[lens-join/hash (->* () #:rest (listof2 any/c lens?) (lens/c any/c immutable-hash?))]))
|
||||
|
||||
|
||||
(define (keys+values->hash keys vs)
|
||||
(make-immutable-hash (keys+values->assoc-list keys vs)))
|
||||
|
||||
(define (lens-join/hash . keys/lenses)
|
||||
(define-values [keys lenses] (alternating-list->keys+values keys/lenses))
|
||||
(define list-lens (apply lens-join/list lenses))
|
||||
(define (get target)
|
||||
(keys+values->hash keys (lens-view list-lens target)))
|
||||
(define (set target new-view-hash)
|
||||
(lens-set list-lens target (map (hash-ref new-view-hash _) keys)))
|
||||
(make-lens get set))
|
||||
|
||||
(module+ test
|
||||
(define a-b-lens (lens-join/hash 'b third-lens
|
||||
'a first-lens))
|
||||
(check-lens-view a-b-lens '(1 2 3)
|
||||
(hash 'a 1 'b 3))
|
||||
(check-lens-set a-b-lens '(1 2 3) (hash 'a 100 'b 200)
|
||||
'(100 2 200)))
|
||||
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang reprovide
|
||||
"nested.rkt"
|
||||
"pick.rkt"
|
||||
"ref.rkt"
|
||||
"join-hash.rkt"
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide string->symbol-lens
|
||||
symbol->string-lens
|
||||
number->string-lens
|
||||
string->number-lens
|
||||
list->vector-lens
|
||||
vector->list-lens
|
||||
list->string-lens
|
||||
string->list-lens
|
||||
|
||||
require lens/private/base/main
|
||||
lens/private/util/alternating-list
|
||||
lens/private/isomorphism/base
|
||||
|
||||
module+ test
|
||||
require rackunit
|
||||
|
||||
|
||||
(define-values [string->symbol-lens symbol->string-lens]
|
||||
(make-isomorphism-lenses string->symbol symbol->string))
|
||||
(define-values [number->string-lens string->number-lens]
|
||||
(make-isomorphism-lenses number->string string->number))
|
||||
(define-values [list->vector-lens vector->list-lens]
|
||||
(make-isomorphism-lenses list->vector vector->list))
|
||||
(define-values [list->string-lens string->list-lens]
|
||||
(make-isomorphism-lenses list->string string->list))
|
||||
(define-values [alternating->assoc-list-lens assoc->alternating-list-lens]
|
||||
(make-isomorphism-lenses alternating->assoc-list assoc->alternating-list))
|
||||
|
||||
|
||||
(module+ test
|
||||
(test-case "string-symbol"
|
||||
(check-equal? (lens-view string->symbol-lens "a") 'a)
|
||||
(check-equal? (lens-set string->symbol-lens "a" 'b) "b")
|
||||
(check-equal? (lens-view symbol->string-lens 'a) "a")
|
||||
(check-equal? (lens-set symbol->string-lens 'a "b") 'b))
|
||||
(test-case "number-string"
|
||||
(check-equal? (lens-view number->string-lens 5) "5")
|
||||
(check-equal? (lens-set number->string-lens 5 "6") 6)
|
||||
(check-equal? (lens-view string->number-lens "5") 5)
|
||||
(check-equal? (lens-set string->number-lens "5" 6) "6"))
|
||||
(test-case "inverses"
|
||||
(check-equal? (isomorphism-lens-inverse string->symbol-lens) symbol->string-lens)
|
||||
(check-equal? (isomorphism-lens-inverse symbol->string-lens) string->symbol-lens)
|
||||
(check-equal? (isomorphism-lens-inverse number->string-lens) string->number-lens)
|
||||
(check-equal? (isomorphism-lens-inverse string->number-lens) number->string-lens)))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang reprovide
|
||||
lens/private/isomorphism/base
|
||||
lens/private/isomorphism/compound
|
||||
"data.rkt"
|
||||
|
|
@ -1,76 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide append*-lens append*n-lens)
|
||||
|
||||
(require "flatten.rkt")
|
||||
|
||||
(module+ test
|
||||
(require rackunit lens/common lens/private/test-util/test-lens))
|
||||
|
||||
(define (append*n-lens n)
|
||||
(flatten/depth-lens (add1 n)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(test-case "append*n-lens"
|
||||
(define append**-lens (append*n-lens 2))
|
||||
(define append***-lens (append*n-lens 3))
|
||||
|
||||
(check-equal? (lens-view append**-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6))))
|
||||
(list 1 2 3 4 5 6))
|
||||
(check-equal? (lens-set append**-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b 'c 'd 'e 'f))
|
||||
(list (list (list) (list 'a))
|
||||
(list (list 'b 'c))
|
||||
(list)
|
||||
(list (list 'd) (list) (list 'e 'f))))
|
||||
|
||||
(test-lens-laws append**-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b 'c 'd 'e 'f)
|
||||
(list "a" "b" "c" "d" "e" "f"))
|
||||
|
||||
(check-equal? (lens-view append***-lens
|
||||
(list (list (list) (list (list 1)))
|
||||
(list (list (list) (list 2 3)))
|
||||
(list)
|
||||
(list (list (list 4) (list)) (list) (list (list 5 6)))))
|
||||
(list 1 2 3 4 5 6))
|
||||
(check-equal? (lens-set append***-lens
|
||||
(list (list (list) (list (list 1)))
|
||||
(list (list (list) (list 2 3)))
|
||||
(list)
|
||||
(list (list (list 4) (list)) (list) (list (list 5 6))))
|
||||
(list 'a 'b 'c 'd 'e 'f))
|
||||
(list (list (list) (list (list 'a)))
|
||||
(list (list (list) (list 'b 'c)))
|
||||
(list)
|
||||
(list (list (list 'd) (list)) (list) (list (list 'e 'f)))))
|
||||
|
||||
(test-lens-laws append**-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b 'c 'd 'e 'f)
|
||||
(list "a" "b" "c" "d" "e" "f"))
|
||||
(test-lens-laws append***-lens
|
||||
(list (list (list) (list (list 1)))
|
||||
(list (list (list) (list 2 3)))
|
||||
(list)
|
||||
(list (list (list 4) (list)) (list) (list (list 5 6))))
|
||||
(list 'a 'b 'c 'd 'e 'f)
|
||||
(list "a" "b" "c" "d" "e" "f"))
|
||||
))
|
||||
|
|
@ -1,217 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide append*-lens flatten/depth-lens flatten/depth unflatten/depth)
|
||||
|
||||
(require fancy-app lens/common racket/list racket/match)
|
||||
|
||||
(module+ test
|
||||
(require rackunit syntax/parse lens/private/test-util/test-lens))
|
||||
|
||||
;; (define-type (Listof* A n)
|
||||
;; (cond [(zero? n) A]
|
||||
;; [else (Listof* (Listof A) (sub1 n))]))
|
||||
|
||||
;; flatten/depth-lens : (Lens (Listof* Any n) (Listof Any))
|
||||
;; where the only valid views are lists with the same length as the
|
||||
;; result of (flatten/depth n target)
|
||||
(define (flatten/depth-lens n)
|
||||
(make-lens
|
||||
(flatten/depth n _)
|
||||
(unflatten/depth n _ _)))
|
||||
|
||||
;; append*-lens : (Lens (Listof (Listof Any)) (Listof Any))
|
||||
;; where the only valid views are lists with the same length as the
|
||||
;; result of applying append* to the target.
|
||||
;; Viewing is equivalent to using append*
|
||||
;; Setting restores the structure of the original nested list
|
||||
(define append*-lens
|
||||
(flatten/depth-lens 2))
|
||||
|
||||
;; flatten/depth : n (Listof* A n) -> (Listof A)
|
||||
(define (flatten/depth n structure)
|
||||
(check-structure-depth! n structure)
|
||||
(cond [(zero? n) (list structure)]
|
||||
[else (append*n (sub1 n) structure)]))
|
||||
|
||||
;; unflatten/depth : n (Listof* A n) (Listof B) -> (Listof* B n)
|
||||
(define (unflatten/depth n structure flattened)
|
||||
(check-structure-depth! n structure)
|
||||
(check-flattened-length! n structure flattened)
|
||||
(cond [(zero? n) (first flattened)]
|
||||
[else (unappend*n (sub1 n) structure flattened)]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; restore-structure : (Listof (Listof A)) (Listof B) -> (Listof (Listof B))
|
||||
;; Takes a list of lists and a list and un-flattens the flattened
|
||||
;; argument according to the structure of the structure arguement.
|
||||
;; The length of the flattened list must be the same as the length
|
||||
;; of (append* structure).
|
||||
(define (restore-structure structure flattened)
|
||||
(restore-structure/acc structure flattened (list)))
|
||||
|
||||
;; restore-structure/acc : (Listof (Listof A)) (Listof B) (Listof (Listof B)) -> (Listof (Listof B))
|
||||
;; Accumulates a reversed version of the result of restore-structure,
|
||||
;; then returns an un-reversed version.
|
||||
(define (restore-structure/acc structure flattened acc)
|
||||
(match structure
|
||||
[(list)
|
||||
(reverse acc)]
|
||||
[(cons s-lst s-rst)
|
||||
(define-values [f-lst f-rst]
|
||||
(split-at flattened (length s-lst)))
|
||||
(restore-structure/acc s-rst f-rst (cons f-lst acc))]))
|
||||
|
||||
;; append*n : n (Listof (Listof* A n)) -> (Listof A)
|
||||
(define (append*n n structure)
|
||||
(cond [(zero? n) structure]
|
||||
[else (append*n (sub1 n) (append* structure))]))
|
||||
|
||||
;; unappend*n : n (Listof (Listof* A n)) (Listof B) -> (Listof (Listof* B n))
|
||||
(define (unappend*n n structure flattened)
|
||||
(cond [(zero? n) flattened]
|
||||
[else (restore-structure
|
||||
structure
|
||||
(unappend*n (sub1 n) (append* structure) flattened))]))
|
||||
|
||||
;; list/depth? : Natural Any -> Boolean
|
||||
(define (list/depth? n structure)
|
||||
(cond [(zero? n) #true]
|
||||
[else (and (list? structure)
|
||||
(andmap (list/depth? (sub1 n) _) structure))]))
|
||||
|
||||
;; check-structure-depth! : n (Listof* A n) -> Void
|
||||
(define (check-structure-depth! depth structure)
|
||||
(unless (list/depth? depth structure)
|
||||
(raise-argument-error 'flatten/depth-lens
|
||||
(format "a nested list of depth ~v" depth)
|
||||
structure)))
|
||||
|
||||
;; check-flattened-length! : n (Listof* A n) (Listof B) -> Void
|
||||
(define (check-flattened-length! depth structure flattened)
|
||||
(unless (= (length (flatten/depth depth structure)) (length flattened))
|
||||
(raise-argument-error 'flatten/depth-lens
|
||||
(format "a list of length ~v"
|
||||
(length (flatten/depth depth structure)))
|
||||
1
|
||||
structure
|
||||
flattened)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(test-case "append*-lens"
|
||||
(check-equal? (lens-view append*-lens (list (list 1) (list 2 3) (list)))
|
||||
(list 1 2 3))
|
||||
(check-equal? (lens-set append*-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
(list 'a 'b 'c))
|
||||
(list (list 'a) (list 'b 'c) (list)))
|
||||
|
||||
(check-equal? (lens-transform append*-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
reverse) ; any length-preserving computation
|
||||
(list (list 3) (list 2 1) (list)))
|
||||
|
||||
(check-exn #rx"expected: a nested list of depth 2\n given: '\\(5\\)"
|
||||
(λ () (lens-view append*-lens (list 5))))
|
||||
(check-exn #rx"expected: a nested list of depth 2\n given: '\\(5\\)"
|
||||
(λ () (lens-set append*-lens (list 5) (list 'a))))
|
||||
|
||||
(check-exn #rx"expected: a list of length 3\n given: '\\(a b\\)"
|
||||
(λ () (lens-set append*-lens (list (list 1) (list 2 3) (list)) (list 'a 'b))))
|
||||
|
||||
(test-lens-laws append*-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
(list 'a 'b 'c)
|
||||
(list "a" "b" "c"))
|
||||
)
|
||||
|
||||
(test-case "(flatten/depth-lens 0) adds a list layer"
|
||||
(define flat0-lens (flatten/depth-lens 0))
|
||||
(check-equal? (lens-view flat0-lens 42) (list 42))
|
||||
(check-equal? (lens-set flat0-lens 42 (list 'a)) 'a)
|
||||
(check-equal? (lens-transform flat0-lens 42 reverse) 42)
|
||||
(test-lens-laws flat0-lens
|
||||
42
|
||||
(list 'a)
|
||||
(list "a")))
|
||||
(test-case "(flatten/depth-lens 1) copies the list"
|
||||
(define flat1-lens (flatten/depth-lens 1))
|
||||
(check-equal? (lens-view flat1-lens (list 1 2 3)) (list 1 2 3))
|
||||
(check-equal? (lens-set flat1-lens (list 1 2 3) (list 'a 'b 'c)) (list 'a 'b 'c))
|
||||
(check-equal? (lens-transform flat1-lens (list 1 2 3) reverse) (list 3 2 1))
|
||||
(test-lens-laws flat1-lens
|
||||
(list 1 2 3)
|
||||
(list 'a 'b 'c)
|
||||
(list "a" "b" "c")))
|
||||
(test-case "(flatten/depth-lens 2) should be equivalent to append*-lens"
|
||||
(define flat2-lens (flatten/depth-lens 2))
|
||||
(check-equal? (lens-view flat2-lens
|
||||
(list (list 1) (list 2 3) (list)))
|
||||
(list 1 2 3))
|
||||
(check-equal? (lens-set flat2-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
(list 'a 'b 'c))
|
||||
(list (list 'a) (list 'b 'c) (list)))
|
||||
|
||||
(check-equal? (lens-transform flat2-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
reverse)
|
||||
(list (list 3) (list 2 1) (list)))
|
||||
|
||||
(test-lens-laws flat2-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
(list 'a 'b 'c)
|
||||
(list "a" "b" "c")))
|
||||
(test-case "(flatten/depth-lens 3) deals with lists of depth 3"
|
||||
(define flat3-lens (flatten/depth-lens 3))
|
||||
(check-equal? (lens-view flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6))))
|
||||
(list 1 2 3 4 5 6))
|
||||
(check-equal? (lens-set flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b 'c 'd 'e 'f))
|
||||
(list (list (list) (list 'a))
|
||||
(list (list 'b 'c))
|
||||
(list)
|
||||
(list (list 'd) (list) (list 'e 'f))))
|
||||
|
||||
(check-equal? (lens-transform flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
reverse)
|
||||
(list (list (list) (list 6))
|
||||
(list (list 5 4))
|
||||
(list)
|
||||
(list (list 3) (list) (list 2 1))))
|
||||
|
||||
(check-exn #rx"expected: a nested list of depth 3\n *given: '\\(5\\)"
|
||||
(λ () (lens-view flat3-lens (list 5))))
|
||||
(check-exn #rx"expected: a nested list of depth 3\n given: '\\(5\\)"
|
||||
(λ () (lens-set flat3-lens (list 5) (list 'a))))
|
||||
|
||||
(check-exn #rx"expected: a list of length 6\n given: '\\(a b\\)"
|
||||
(λ () (lens-set flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b))))
|
||||
|
||||
(test-lens-laws flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b 'c 'd 'e 'f)
|
||||
(list "a" "b" "c" "d" "e" "f")))
|
||||
)
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/contract/base
|
||||
provide
|
||||
contract-out
|
||||
lens-join/assoc (->* [] #:rest (listof2 any/c lens?) (lens/c any/c (listof pair?)))
|
||||
|
||||
require lens/private/base/main
|
||||
lens/private/list/join-list
|
||||
lens/private/list/assoc
|
||||
lens/private/util/alternating-list
|
||||
lens/private/util/list-pair-contract
|
||||
racket/match
|
||||
unstable/sequence
|
||||
module+ test
|
||||
require rackunit lens/private/list/list-ref-take-drop
|
||||
|
||||
(define (lens-join/assoc . ks/lenses)
|
||||
(define-values [keys lenses]
|
||||
(alternating-list->keys+values ks/lenses))
|
||||
(define key-lenses (map assoc-lens keys))
|
||||
(define list-lens (apply lens-join/list lenses))
|
||||
(make-lens
|
||||
(λ (tgt)
|
||||
(keys+values->assoc-list keys (lens-view list-lens tgt)))
|
||||
(λ (tgt nvw)
|
||||
(lens-set list-lens tgt (apply lens-view/list nvw key-lenses)))))
|
||||
|
||||
module+ test
|
||||
(define a-b-lens (lens-join/assoc 'a first-lens
|
||||
'b third-lens))
|
||||
(check-equal? (lens-view a-b-lens '(1 2 3))
|
||||
'((a . 1) (b . 3)))
|
||||
(check-equal? (lens-set a-b-lens '(1 2 3) '((a . 100) (b . 200)))
|
||||
'(100 2 200))
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/list
|
||||
racket/contract
|
||||
lens/private/base/main
|
||||
lens/private/util/alternating-list
|
||||
lens/private/util/rest-contract
|
||||
|
||||
module+ test
|
||||
require rackunit
|
||||
"../list/list-ref-take-drop.rkt"
|
||||
lens/private/test-util/test-lens
|
||||
|
||||
provide
|
||||
contract-out
|
||||
lens-join/list (rest-> lens? (lens/c any/c list?))
|
||||
|
||||
|
||||
(define (lens-join/list . lenses)
|
||||
(define (get target)
|
||||
(apply lens-view/list target lenses))
|
||||
(define (set target new-views)
|
||||
(apply lens-set/list target (keys+values->alternating-list lenses new-views)))
|
||||
(make-lens get set))
|
||||
|
||||
|
||||
(module+ test
|
||||
(define first-third-fifth-lens
|
||||
(lens-join/list first-lens
|
||||
third-lens
|
||||
fifth-lens))
|
||||
(check-lens-view first-third-fifth-lens '(a b c d e f)
|
||||
'(a c e))
|
||||
(check-lens-set first-third-fifth-lens '(a b c d e f) '(1 2 3)
|
||||
'(1 b 2 d 3 f)))
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
#lang reprovide
|
||||
"car-cdr.rkt"
|
||||
(except-in "list-ref-take-drop.rkt" drop-lens take-lens)
|
||||
"cadr-etc.rkt"
|
||||
"multi.rkt"
|
||||
"join-list.rkt"
|
||||
"assoc.rkt"
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract/base)
|
||||
(provide (contract-out
|
||||
[map-lens
|
||||
(-> lens? (lens/c list? list?))]
|
||||
[vector-map-lens
|
||||
(-> lens? (lens/c immutable-vector? immutable-vector?))]
|
||||
))
|
||||
|
||||
(require lens/private/base/main
|
||||
lens/private/util/immutable
|
||||
racket/vector
|
||||
fancy-app
|
||||
)
|
||||
(module+ test
|
||||
(require rackunit lens/private/list/main))
|
||||
|
||||
(define (map-lens lens)
|
||||
(make-lens
|
||||
(lens-view/map lens _)
|
||||
(lens-set/map lens _ _)))
|
||||
|
||||
(define (lens-view/map lens tgts)
|
||||
(map (lens-view lens _) tgts))
|
||||
|
||||
(define (lens-set/map lens tgts new-views)
|
||||
(map (lens-set lens _ _) tgts new-views))
|
||||
|
||||
(define (vector-map-lens lens)
|
||||
(make-lens
|
||||
(lens-view/vector-map lens _)
|
||||
(lens-set/vector-map lens _ _)))
|
||||
|
||||
(define (lens-view/vector-map lens tgt)
|
||||
(vector->immutable-vector (vector-map (lens-view lens _) tgt)))
|
||||
|
||||
(define (lens-set/vector-map lens tgt new-view)
|
||||
(vector->immutable-vector (vector-map (lens-set lens _ _) tgt new-view)))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (lens-view (map-lens first-lens) '((a b) (c d) (e f)))
|
||||
'(a c e))
|
||||
(check-equal? (lens-set (map-lens first-lens) '((a b) (c d) (e f)) '(1 2 3))
|
||||
'((1 b) (2 d) (3 f)))
|
||||
(check-equal? (lens-transform (map-lens first-lens) '((a b) (c d) (e f)) (map symbol->string _))
|
||||
'(("a" b) ("c" d) ("e" f)))
|
||||
(check-equal? (lens-view (vector-map-lens first-lens) '#((a b) (c d) (e f)))
|
||||
'#(a c e))
|
||||
(check-equal? (lens-set (vector-map-lens first-lens) '#((a b) (c d) (e f)) '#(1 2 3))
|
||||
'#((1 b) (2 d) (3 f)))
|
||||
(check-equal? (lens-transform (vector-map-lens first-lens) '#((a b) (c d) (e f))
|
||||
(immutable-vector-map symbol->string _))
|
||||
'#(("a" b) ("c" d) ("e" f)))
|
||||
)
|
||||
|
|
@ -1,32 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/contract/base
|
||||
|
||||
provide
|
||||
contract-out
|
||||
reverse-lens (lens/c list? list?)
|
||||
last-lens (lens/c list? any/c)
|
||||
|
||||
require lens/private/base/main
|
||||
lens/private/list/main
|
||||
lens/private/compound/main
|
||||
lens/private/isomorphism/base
|
||||
|
||||
module+ test
|
||||
require rackunit fancy-app
|
||||
|
||||
|
||||
(define reverse-lens
|
||||
(make-isomorphism-lens reverse reverse))
|
||||
|
||||
module+ test
|
||||
(check-equal? (lens-view reverse-lens '(1 2 3)) '(3 2 1))
|
||||
(check-equal? (lens-transform reverse-lens '(1 2 3) (cons 4 _)) '(1 2 3 4))
|
||||
|
||||
|
||||
(define last-lens
|
||||
(lens-thrush reverse-lens first-lens))
|
||||
|
||||
module+ test
|
||||
(check-equal? (lens-view last-lens '(1 2 3)) 3)
|
||||
(check-equal? (lens-set last-lens '(1 2 3) 'a) '(1 2 a))
|
||||
|
|
@ -1,34 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide match-lens)
|
||||
|
||||
(require racket/match
|
||||
racket/local
|
||||
syntax/parse/define
|
||||
lens/private/base/main
|
||||
)
|
||||
(module+ test
|
||||
(require rackunit lens/private/test-util/test-lens))
|
||||
|
||||
(define-simple-macro (match-lens a:id pat:expr replacement:expr)
|
||||
(local [(define (get target)
|
||||
(match target
|
||||
[pat
|
||||
a]))
|
||||
(define (set target new-view)
|
||||
(match target
|
||||
[pat
|
||||
(let ([a new-view])
|
||||
replacement)]))]
|
||||
(make-lens get set)))
|
||||
|
||||
(module+ test
|
||||
(define car-lens (match-lens a (cons a b) (cons a b)))
|
||||
(define cdr-lens (match-lens b (cons a b) (cons a b)))
|
||||
(check-lens-view car-lens (cons 1 2) 1)
|
||||
(check-lens-view cdr-lens (cons 1 2) 2)
|
||||
(check-lens-set car-lens (cons 1 2) 'a (cons 'a 2))
|
||||
(check-lens-set cdr-lens (cons 1 2) 'a (cons 1 'a))
|
||||
(test-lens-laws car-lens (cons 1 2) 'a 'b)
|
||||
(test-lens-laws cdr-lens (cons 1 2) 'a 'b)
|
||||
)
|
||||
|
|
@ -1,54 +0,0 @@
|
|||
#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))))
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#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))
|
||||
|
|
@ -1,77 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/contract/base
|
||||
|
||||
provide
|
||||
contract-out
|
||||
stream-first-lens (lens/c stream? any/c)
|
||||
stream-rest-lens (lens/c stream? stream?)
|
||||
stream-ref-lens (-> exact-nonnegative-integer? (lens/c stream? any/c))
|
||||
|
||||
require racket/stream
|
||||
fancy-app
|
||||
lens/private/base/main
|
||||
lens/private/compound/main
|
||||
|
||||
module+ test
|
||||
require rackunit
|
||||
lens/private/test-util/test-lens
|
||||
|
||||
|
||||
module+ test
|
||||
(define-check (check-stream-equal? stream1 stream2)
|
||||
(let ([list1 (stream->list stream1)] [list2 (stream->list stream2)])
|
||||
(with-check-info
|
||||
(['actual-list list1] ['expected-list list2])
|
||||
(check-equal? list1 list2))))
|
||||
|
||||
|
||||
(define (stream-ref-lens i)
|
||||
(lens-compose stream-first-lens (stream-tail-lens i)))
|
||||
|
||||
(define (stream-set-first s v)
|
||||
(stream-cons v (stream-rest s)))
|
||||
|
||||
(define (stream-set-rest s rst)
|
||||
(stream-cons (stream-first s) rst))
|
||||
|
||||
(define stream-first-lens
|
||||
(make-lens
|
||||
stream-first
|
||||
stream-set-first))
|
||||
|
||||
(define stream-rest-lens
|
||||
(make-lens
|
||||
stream-rest
|
||||
stream-set-rest))
|
||||
|
||||
(define (stream-tail-lens i)
|
||||
(make-lens
|
||||
(stream-tail _ i)
|
||||
(stream-set-tail _ i _)))
|
||||
|
||||
(define (stream-set-tail s i rst)
|
||||
(define rev-fst
|
||||
(for/fold ([rev-fst '()]) ([v (in-stream s)] [_ (in-range i)])
|
||||
(cons v rev-fst)))
|
||||
(for/fold ([rst rst]) ([v (in-list rev-fst)])
|
||||
(stream-cons v rst)))
|
||||
|
||||
module+ test
|
||||
(check-lens-view stream-first-lens (stream 'a 'b 'c) 'a)
|
||||
(check-lens-view (stream-ref-lens 2) (stream 'a 'b 'c) 'c)
|
||||
(check-stream-equal? (lens-set stream-first-lens (stream 'a 'b 'c) 1)
|
||||
(stream 1 'b 'c))
|
||||
(check-stream-equal? (lens-set (stream-ref-lens 2) (stream 'a 'b 'c) 1)
|
||||
(stream 'a 'b 1))
|
||||
|
||||
(define (stream-ref-nested-lens . is)
|
||||
(apply lens-thrush (map stream-ref-lens is)))
|
||||
|
||||
module+ test
|
||||
(check-lens-view (stream-ref-nested-lens 1 2 0)
|
||||
(stream 'a (stream 1 2 (stream 'foo 'bar 'baz) 3 4) 'b 'c 'd)
|
||||
'foo)
|
||||
(check-lens-set-view (stream-ref-nested-lens 1 2 0)
|
||||
(stream 'a (stream 1 2 (stream 'foo 'bar 'baz) 3 4) 'b 'c 'd)
|
||||
'FOO)
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/contract
|
||||
lens/private/base/main
|
||||
lens/private/isomorphism/base
|
||||
lens/private/compound/compose
|
||||
lens/private/util/rest-contract
|
||||
"../util/immutable.rkt"
|
||||
"../list/join-list.rkt"
|
||||
|
||||
module+ test
|
||||
require rackunit
|
||||
lens/private/test-util/test-lens
|
||||
"../list/list-ref-take-drop.rkt"
|
||||
|
||||
provide
|
||||
contract-out
|
||||
lens-join/string (rest-> (lens/c any/c char?) (lens/c any/c immutable-string?))
|
||||
|
||||
|
||||
(define (lens-join/string . lenses)
|
||||
(lens-compose list->string-lens (apply lens-join/list lenses)))
|
||||
|
||||
(define list->string-lens
|
||||
(make-isomorphism-lens list->immutable-string string->list))
|
||||
|
||||
(module+ test
|
||||
(define string-first-third-fifth-lens
|
||||
(lens-join/string first-lens
|
||||
third-lens
|
||||
fifth-lens))
|
||||
(check-lens-view string-first-third-fifth-lens '(#\a #\b #\c #\d #\e #\f)
|
||||
"ace")
|
||||
(check-pred immutable? (lens-view string-first-third-fifth-lens '(#\a #\b #\c #\d #\e #\f)))
|
||||
(check-lens-set string-first-third-fifth-lens '(#\a #\b #\c #\d #\e #\f) "ACE"
|
||||
'(#\A #\b #\C #\d #\E #\f)))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang reprovide
|
||||
"string.rkt"
|
||||
"join-string.rkt"
|
||||
|
|
@ -1,72 +0,0 @@
|
|||
#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 'string-split-lens "expected a string, char, or regexp, given: ~v" sep)]))
|
||||
(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 "a b c") '("a" "b" "c"))
|
||||
(check-equal? (lens-set ws-lens "a b c" '("d" "e" "f")) "d e f")
|
||||
(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")
|
||||
;; this input would violate the lens laws
|
||||
(check-exn (regexp (regexp-quote "expected a string not matching #px\"\\\\s+\", given: \"e f\""))
|
||||
(λ ()
|
||||
(lens-set ws-lens "a b c" '("d" "e f" "g"))))
|
||||
|
||||
(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")
|
||||
;; this input would violate the lens laws
|
||||
(check-exn (regexp (regexp-quote "expected a string not matching \"\\n\", given: \"2\\n2.5\""))
|
||||
(λ ()
|
||||
(lens-set newline-lens "a,b\nc,d\ne,f,g" '("1" "2\n2.5" "3"))))
|
||||
|
||||
(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")
|
||||
;; this input would violate the lens laws
|
||||
(check-exn (regexp (regexp-quote "expected a string not matching #\\,, given: \"2,2.5\""))
|
||||
(λ ()
|
||||
(lens-set comma-lens "a,b,c" '("1" "2,2.5" "3"))))
|
||||
)
|
||||
|
|
@ -1,65 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/function racket/contract/base unstable/contract)
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[substring-lens (->i ([start exact-nonnegative-integer?]
|
||||
[end (start) (and/c exact-nonnegative-integer?
|
||||
(>=/c start))])
|
||||
[result (start end)
|
||||
(lens/c (string-length->=/c end)
|
||||
(string-length-=/c (- end start)))])]))
|
||||
|
||||
(define (string-length->=/c min)
|
||||
(define (length>=? str)
|
||||
(>= (string-length str) min))
|
||||
(and/c string?
|
||||
(rename-contract length>=?
|
||||
`(string-length->=/c ,min))))
|
||||
|
||||
(define (string-length-=/c n)
|
||||
(define (length=? str)
|
||||
(= (string-length str) n))
|
||||
(and/c string?
|
||||
(rename-contract length=?
|
||||
`(string-length-=/c ,n))))
|
||||
|
||||
(require lens/common)
|
||||
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
|
||||
(define (set-substring str start end replacement-str)
|
||||
(string-append (substring str 0 start)
|
||||
replacement-str
|
||||
(substring str end)))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (set-substring "mitten" 0 4 "MITT") "MITTen")
|
||||
(check-equal? (set-substring "mitten" 2 4 "ZZ") "miZZen")
|
||||
(check-equal? (set-substring "mitten" 2 6 "LLER") "miLLER"))
|
||||
|
||||
(define (substring-lens start end)
|
||||
(define (substring-lens-getter str)
|
||||
(substring str start end))
|
||||
(define (substring-lens-setter str replacement-str)
|
||||
(set-substring str start end replacement-str))
|
||||
(make-lens substring-lens-getter substring-lens-setter))
|
||||
|
||||
(module+ test
|
||||
(check-pred lens? (substring-lens 2 4))
|
||||
(check-equal? (lens-view (substring-lens 2 4) "mitten") "tt")
|
||||
(check-equal? (lens-set (substring-lens 2 4) "mitten" "TT") "miTTen"))
|
||||
|
||||
(module+ test
|
||||
(require (submod ".."))
|
||||
(check-exn exn:fail:contract?
|
||||
(thunk (substring-lens -1 5))) ; Improper substring boundaries
|
||||
(check-exn exn:fail:contract?
|
||||
(thunk (lens-set (substring-lens 2 4) "kitten" "c"))) ; Replacement string is too short
|
||||
(check-exn exn:fail:contract?
|
||||
(thunk (lens-set (substring-lens 2 4) "kitten" "cat"))) ; Replacement string is too long
|
||||
(check-not-exn
|
||||
(thunk (lens-set (substring-lens 2 4) "kitten" "ca"))) ; Replacement string is just right!
|
||||
)
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang sweet-exp reprovide
|
||||
"field.rkt"
|
||||
except-in "struct.rkt"
|
||||
struct-lenses-out
|
||||
struct+lenses-out
|
||||
|
|
@ -1,81 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide lens-join/struct
|
||||
|
||||
require racket/local
|
||||
racket/match
|
||||
lens/private/base/main
|
||||
kw-make-struct
|
||||
for-syntax racket/base
|
||||
syntax/parse
|
||||
module+ test
|
||||
require rackunit lens/private/hash/main lens/private/test-util/test-multi
|
||||
|
||||
(begin-for-syntax
|
||||
(define-splicing-syntax-class field-lenses
|
||||
#:attributes ([lens-expr 1] [lens-id 1] [vw-id 1] [norm 1])
|
||||
[pattern (~seq lens-expr:expr ...)
|
||||
#:with [lens-id ...] (generate-temporaries #'[lens-expr ...])
|
||||
#:with [vw-id ...] (generate-temporaries #'[lens-expr ...])
|
||||
#:with [norm ...] #'[vw-id ...]]
|
||||
[pattern (~seq fst-lens:expr ...+ rst:field-lenses)
|
||||
#:with [fst-lens-id ...] (generate-temporaries #'[fst-lens ...])
|
||||
#:with [fst-vw-id ...] (generate-temporaries #'[fst-lens ...])
|
||||
#:with [lens-expr ...] #'[fst-lens ... rst.lens-expr ...]
|
||||
#:with [lens-id ...] #'[fst-lens-id ... rst.lens-id ...]
|
||||
#:with [vw-id ...] #'[fst-vw-id ... rst.vw-id ...]
|
||||
#:with [norm ...] #'[fst-vw-id ... rst.norm ...]]
|
||||
[pattern (~seq (~seq kw:keyword fst-lens:expr) ...+ rst:field-lenses)
|
||||
#:with [fst-lens-id ...] (generate-temporaries #'[fst-lens ...])
|
||||
#:with [fst-vw-id ...] (generate-temporaries #'[fst-lens ...])
|
||||
#:with [lens-expr ...] #'[fst-lens ... rst.lens-expr ...]
|
||||
#:with [lens-id ...] #'[fst-lens-id ... rst.lens-id ...]
|
||||
#:with [vw-id ...] #'[fst-vw-id ... rst.vw-id ...]
|
||||
#:with [[fst-kw/vw-id ...] ...] #'[[kw fst-vw-id] ...]
|
||||
#:with [norm ...] #'[fst-kw/vw-id ... ... rst.norm ...]]
|
||||
))
|
||||
|
||||
(define-syntax lens-join/struct
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(lens-join/struct s:id flds:field-lenses)
|
||||
#:with make/kw-form #`(make/kw/derived #,stx s flds.norm ...)
|
||||
#:with [[lens-id/vw-id ...] ...] #'[[flds.lens-id flds.vw-id] ...]
|
||||
#`(local [(define flds.lens-id flds.lens-expr) ...]
|
||||
(make-lens
|
||||
(λ (tgt)
|
||||
(define flds.vw-id (lens-view flds.lens-id tgt))
|
||||
...
|
||||
make/kw-form)
|
||||
(λ (tgt nvw)
|
||||
(match-define make/kw-form nvw)
|
||||
(lens-set/list tgt lens-id/vw-id ... ...))))])))
|
||||
|
||||
(module+ test
|
||||
(struct foo (a b c) #:transparent)
|
||||
(define foo-hash-lens1
|
||||
(lens-join/struct foo
|
||||
(hash-ref-lens 'a)
|
||||
(hash-ref-lens 'b)
|
||||
(hash-ref-lens 'c)))
|
||||
(define foo-hash-lens2
|
||||
(lens-join/struct foo
|
||||
#:a (hash-ref-lens 'a)
|
||||
#:b (hash-ref-lens 'b)
|
||||
#:c (hash-ref-lens 'c)))
|
||||
(define foo-hash-lens3
|
||||
(lens-join/struct foo
|
||||
#:c (hash-ref-lens 'c)
|
||||
#:a (hash-ref-lens 'a)
|
||||
#:b (hash-ref-lens 'b)))
|
||||
(define foo-hash-lens4
|
||||
(lens-join/struct foo
|
||||
(hash-ref-lens 'a)
|
||||
#:c (hash-ref-lens 'c)
|
||||
#:b (hash-ref-lens 'b)))
|
||||
(test-multi* ([foo-hash-lens #:in [foo-hash-lens1 foo-hash-lens2 foo-hash-lens3 foo-hash-lens4]])
|
||||
(check-equal? (lens-view foo-hash-lens (hash 'a 1 'b 2 'c 3))
|
||||
(foo 1 2 3))
|
||||
(check-equal? (lens-set foo-hash-lens (hash 'a 1 'b 2 'c 3) (foo 10 20 30))
|
||||
(hash 'a 10 'b 20 'c 30))
|
||||
))
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide struct->list-lens list->struct-lens
|
||||
|
||||
require racket/local
|
||||
lens/private/isomorphism/base
|
||||
for-syntax racket/base
|
||||
racket/list
|
||||
racket/struct-info
|
||||
syntax/parse
|
||||
module+ test
|
||||
require lens/private/base/base
|
||||
lens/private/test-util/test-lens
|
||||
rackunit
|
||||
|
||||
begin-for-syntax
|
||||
(define-syntax-class struct-id
|
||||
#:attributes (info constructor-id [accessor-id 1])
|
||||
[pattern struct-id:id
|
||||
#:attr v (syntax-local-value #'struct-id (λ () #f))
|
||||
#:when (struct-info? (attribute v))
|
||||
#:attr info (extract-struct-info (attribute v))
|
||||
#:with descriptor-id:id (first (attribute info))
|
||||
#:with constructor-id:id (syntax-property (second (attribute info))
|
||||
'disappeared-use
|
||||
(list (syntax-local-introduce #'struct-id)))
|
||||
#:with predicate-id:id (third (attribute info))
|
||||
#:with [accessor-id:id ...] (reverse (fourth (attribute info)))])
|
||||
|
||||
(define-syntax struct->list-lens
|
||||
(syntax-parser
|
||||
[(struct->list-lens s:struct-id)
|
||||
#'(local [(define (struct->list struct)
|
||||
(list (s.accessor-id struct) ...))
|
||||
(define (list->struct list)
|
||||
(apply s.constructor-id list))]
|
||||
(make-isomorphism-lens struct->list list->struct))]))
|
||||
|
||||
(define-syntax list->struct-lens
|
||||
(syntax-parser
|
||||
[(list->struct-lens s:struct-id)
|
||||
#'(isomorphism-lens-inverse (struct->list-lens s))]))
|
||||
|
||||
module+ test
|
||||
(struct foo (a b c))
|
||||
;; foo is opaque, so struct->vector doesn't work
|
||||
(check-equal? (struct->vector (foo 1 2 3)) '#(struct:foo ...))
|
||||
(test-case "without inheritance"
|
||||
(check-equal? (lens-view (struct->list-lens foo) (foo 1 2 3)) '(1 2 3))
|
||||
(check-match (lens-set (struct->list-lens foo) (foo 1 2 3) '(4 5 6)) (foo 4 5 6))
|
||||
(check-match (lens-view (list->struct-lens foo) '(1 2 3)) (foo 1 2 3))
|
||||
(check-equal? (lens-set (list->struct-lens foo) '(1 2 3) (foo 4 5 6)) '(4 5 6)))
|
||||
(struct bar foo (d e))
|
||||
(test-case "inheriting from foo"
|
||||
(check-equal? (lens-view (struct->list-lens bar) (bar 1 2 3 4 5)) '(1 2 3 4 5))
|
||||
(check-match (lens-set (struct->list-lens bar) (bar 1 2 3 4 5) '(6 7 8 9 10)) (bar 6 7 8 9 10))
|
||||
(check-match (lens-view (list->struct-lens bar) '(1 2 3 4 5)) (bar 1 2 3 4 5))
|
||||
(check-equal? (lens-set (list->struct-lens bar) '(1 2 3 4 4) (bar 6 7 8 9 10)) '(6 7 8 9 10)))
|
||||
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require fancy-app
|
||||
lens/common
|
||||
lens/private/struct/main
|
||||
(for-syntax racket/base
|
||||
syntax/parse))
|
||||
|
||||
(module+ test
|
||||
(require rackunit))
|
||||
|
||||
(provide struct-nested-lens
|
||||
struct-nested-lens*)
|
||||
|
||||
|
||||
(define-syntax struct-nested-lens
|
||||
(syntax-parser
|
||||
[(_ [struct-id:id field-id:id] ...)
|
||||
#'(lens-thrush (struct-lens struct-id field-id) ...)]))
|
||||
|
||||
(define-syntax struct-nested-lens*
|
||||
(syntax-parser
|
||||
[(_ struct-id:id field-id:id)
|
||||
#'(struct-lens struct-id field-id)]
|
||||
[(_ struct-id:id both0:id both:id ... field-id:id)
|
||||
#'(lens-thrush (struct-lens struct-id both0)
|
||||
(struct-nested-lens* both0 both ... field-id))]))
|
||||
|
||||
(module+ test
|
||||
(struct game (player level) #:transparent)
|
||||
(struct player (posn stats) #:transparent)
|
||||
(struct posn (x y) #:transparent)
|
||||
(struct combat-stats (health attack) #:transparent)
|
||||
(define the-game (game (player (posn 0 0) (combat-stats 10 1)) 'foo-level))
|
||||
|
||||
(define game-player-health-lens
|
||||
(struct-nested-lens [game player]
|
||||
[player stats]
|
||||
[combat-stats health]))
|
||||
(check-equal? (lens-view game-player-health-lens the-game) 10)
|
||||
(check-equal? (lens-set game-player-health-lens the-game 20)
|
||||
(game (player (posn 0 0) (combat-stats 20 1)) 'foo-level))
|
||||
|
||||
(define game-player-posn-x-lens
|
||||
(struct-nested-lens* game player posn x))
|
||||
(check-equal? (lens-view game-player-posn-x-lens the-game) 0)
|
||||
(check-equal? (lens-set game-player-posn-x-lens the-game 3)
|
||||
(game (player (posn 3 0) (combat-stats 10 1)) 'foo-level)))
|
||||
|
||||
|
||||
|
|
@ -1,73 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require syntax/parse/define
|
||||
struct-update
|
||||
racket/provide-syntax
|
||||
lens/private/base/main
|
||||
(for-syntax racket/base
|
||||
syntax/parse
|
||||
syntax/parse/class/struct-id
|
||||
racket/syntax
|
||||
racket/struct-info))
|
||||
|
||||
(module+ test
|
||||
(require rackunit
|
||||
fancy-app
|
||||
lens/private/test-util/test-lens))
|
||||
|
||||
(provide define-struct-lenses
|
||||
struct/lens
|
||||
struct-lenses-out
|
||||
struct+lenses-out)
|
||||
|
||||
|
||||
(define-for-syntax (get-struct-own-accessor-ids struct-id-stx)
|
||||
(syntax-parse struct-id-stx
|
||||
[s:struct-id
|
||||
(attribute s.own-accessor-id)]))
|
||||
|
||||
(define-for-syntax (map-format-id lex-context format-str ids)
|
||||
(define (format-one-id id)
|
||||
(format-id lex-context format-str id #:source id))
|
||||
(map format-one-id ids))
|
||||
|
||||
(define-for-syntax (struct-get-set-lens-ids struct-id-stx)
|
||||
(define accessor-ids (get-struct-own-accessor-ids struct-id-stx))
|
||||
(define set-ids (map-format-id struct-id-stx "~a-set" accessor-ids))
|
||||
(define lens-ids (map-format-id struct-id-stx "~a-lens" accessor-ids))
|
||||
(list accessor-ids set-ids lens-ids))
|
||||
|
||||
(define-syntax define-struct-lenses
|
||||
(syntax-parser
|
||||
[(define-struct-lenses s:id)
|
||||
#:with [(s-fld ...)
|
||||
(s-fld-set ...)
|
||||
(s-fld-lens ...)] (struct-get-set-lens-ids #'s)
|
||||
#'(begin
|
||||
(define-struct-updaters s)
|
||||
(define s-fld-lens (make-lens s-fld s-fld-set))
|
||||
...)]))
|
||||
|
||||
|
||||
(define-simple-macro (struct/lens s:id (field-spec ...) option ...)
|
||||
(begin
|
||||
(struct s (field-spec ...) option ...)
|
||||
(define-struct-lenses s)))
|
||||
|
||||
(define-provide-syntax struct-lenses-out
|
||||
(syntax-parser
|
||||
[(struct-lenses-out struct-type:id)
|
||||
#:do [(define accessor-ids (get-struct-own-accessor-ids #'struct-type))]
|
||||
#:with [lens-id ...] (map-format-id #'struct-type "~a-lens" accessor-ids)
|
||||
#'(combine-out lens-id ...)]))
|
||||
|
||||
(define-provide-syntax struct+lenses-out
|
||||
(syntax-parser
|
||||
[(struct+lenses-out struct-type:id)
|
||||
#'(combine-out (struct-out struct-type) (struct-lenses-out struct-type))]))
|
||||
|
||||
(module+ test
|
||||
(struct/lens foo (a b c d) #:transparent)
|
||||
(check-lens-view foo-b-lens (foo 1 2 3 4) 2)
|
||||
(check-lens-set foo-c-lens (foo 1 2 3 4) 'a (foo 1 2 'a 4))
|
||||
(test-lens-laws foo-a-lens (foo 1 2 3 4) 'a 'b))
|
||||
|
|
@ -1,3 +0,0 @@
|
|||
#lang reprovide
|
||||
"syntax.rkt"
|
||||
"syntax-keyword.rkt"
|
||||
|
|
@ -1,269 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide syntax-srcloc-lens
|
||||
syntax-source-lens
|
||||
syntax-line-lens
|
||||
syntax-position-lens
|
||||
syntax-column-lens
|
||||
syntax-span-lens
|
||||
source-location->srcloc-lens
|
||||
source-location->list-lens
|
||||
source-location->vector-lens
|
||||
source-location-source-lens
|
||||
source-location-line-lens
|
||||
source-location-column-lens
|
||||
source-location-position-lens
|
||||
source-location-span-lens
|
||||
|
||||
require fancy-app
|
||||
lens/common
|
||||
syntax/parse/define
|
||||
syntax/srcloc
|
||||
module+ test
|
||||
require rackunit
|
||||
|
||||
(define-simple-macro
|
||||
(define-source-location-lenses [lens-id:id getter:expr update-kw:keyword] ...)
|
||||
(begin
|
||||
(define lens-id
|
||||
(make-lens getter (update-source-location _ update-kw _)))
|
||||
...))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Syntax
|
||||
|
||||
;; syntax-srcloc : Syntax -> Srcloc
|
||||
(define (syntax-srcloc stx)
|
||||
(source-location->srcloc stx))
|
||||
|
||||
;; syntax-set-source-location : Syntax Source-Location -> Syntax
|
||||
(define (syntax-set-source-location stx src)
|
||||
(define stx* (syntax-disarm stx #f))
|
||||
(syntax-rearm
|
||||
(datum->syntax stx*
|
||||
(syntax-e stx*)
|
||||
(source-location->list src)
|
||||
stx*)
|
||||
stx))
|
||||
|
||||
(define syntax-srcloc-lens
|
||||
(make-lens
|
||||
syntax-srcloc
|
||||
syntax-set-source-location))
|
||||
|
||||
(define-source-location-lenses
|
||||
[syntax-source-lens syntax-source #:source]
|
||||
[syntax-line-lens syntax-line #:line]
|
||||
[syntax-column-lens syntax-column #:column]
|
||||
[syntax-position-lens syntax-position #:position]
|
||||
[syntax-span-lens syntax-span #:span])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Source Locations
|
||||
|
||||
;; source-location->srcloc : Source-Location -> Srcloc
|
||||
(define (source-location->srcloc src)
|
||||
(build-source-location src))
|
||||
|
||||
;; source-location->list : Source-Location -> Source-Location-List
|
||||
(define (source-location->list src)
|
||||
(build-source-location-list src))
|
||||
|
||||
;; source-location->vector : Source-Location -> Source-Location-Vector
|
||||
(define (source-location->vector src)
|
||||
(build-source-location-vector src))
|
||||
|
||||
;; replace-source-location : Syntax Source-Location -> Syntax
|
||||
;; Srcloc Source-Location -> Srcloc
|
||||
;; Source-Location-List Source-Location -> Source-Location-List
|
||||
;; Source-Location-Vector Source-Location -> Source-Location-Vector
|
||||
;; Source-Location Source-Location -> Source-Location
|
||||
(define (replace-source-location old new)
|
||||
(update-source-location old
|
||||
#:source (source-location-source new)
|
||||
#:line (source-location-line new)
|
||||
#:column (source-location-column new)
|
||||
#:position (source-location-position new)
|
||||
#:span (source-location-span new)))
|
||||
|
||||
(define source-location->srcloc-lens
|
||||
(make-lens
|
||||
source-location->srcloc
|
||||
replace-source-location))
|
||||
|
||||
(define source-location->list-lens
|
||||
(make-lens
|
||||
source-location->list
|
||||
replace-source-location))
|
||||
|
||||
(define source-location->vector-lens
|
||||
(make-lens
|
||||
source-location->vector
|
||||
replace-source-location))
|
||||
|
||||
(define-source-location-lenses
|
||||
[source-location-source-lens source-location-source #:source]
|
||||
[source-location-line-lens source-location-line #:line]
|
||||
[source-location-column-lens source-location-column #:column]
|
||||
[source-location-position-lens source-location-position #:position]
|
||||
[source-location-span-lens source-location-span #:span])
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Tests
|
||||
|
||||
(module+ test
|
||||
(define-check (check-syntax actual-stx expected-datum expected-srcloc)
|
||||
(check-pred syntax? actual-stx)
|
||||
(check-equal? (syntax->datum actual-stx) expected-datum)
|
||||
(check-equal? (syntax-srcloc actual-stx) expected-srcloc))
|
||||
|
||||
(define a-src (srcloc 'a 12 5 144 9))
|
||||
(define b-src (srcloc 'b 49 7 343 14))
|
||||
(define a-lst (list 'a 12 5 144 9))
|
||||
(define b-lst (list 'b 49 7 343 14))
|
||||
(define a-vec (vector-immutable 'a 12 5 144 9))
|
||||
(define b-vec (vector-immutable 'b 49 7 343 14))
|
||||
(define a (datum->syntax #f (list '+ 1 2 3) a-lst))
|
||||
(define b (datum->syntax #f (list 'define 'x 987) b-lst))
|
||||
|
||||
(test-case "syntax-srcloc-lens"
|
||||
(check-equal? (lens-view syntax-srcloc-lens a) a-src)
|
||||
(check-equal? (lens-view syntax-srcloc-lens b) b-src)
|
||||
(check-syntax (lens-set syntax-srcloc-lens a a-src) (list '+ 1 2 3) a-src)
|
||||
(check-syntax (lens-set syntax-srcloc-lens b b-src) (list 'define 'x 987) b-src)
|
||||
(check-syntax (lens-set syntax-srcloc-lens a b-src) (list '+ 1 2 3) b-src)
|
||||
(check-syntax (lens-set syntax-srcloc-lens b a-src) (list 'define 'x 987) a-src)
|
||||
;; same thing, but with source-location->srcloc-lens instead of syntax-srcloc-lens
|
||||
(check-equal? (lens-view source-location->srcloc-lens a) a-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens b) b-src)
|
||||
(check-syntax (lens-set source-location->srcloc-lens a a-src) (list '+ 1 2 3) a-src)
|
||||
(check-syntax (lens-set source-location->srcloc-lens b b-src) (list 'define 'x 987) b-src)
|
||||
(check-syntax (lens-set source-location->srcloc-lens a b-src) (list '+ 1 2 3) b-src)
|
||||
(check-syntax (lens-set source-location->srcloc-lens b a-src) (list 'define 'x 987) a-src)
|
||||
;; same thing, but with source-location->list-lens
|
||||
(check-equal? (lens-view source-location->list-lens a) a-lst)
|
||||
(check-equal? (lens-view source-location->list-lens b) b-lst)
|
||||
(check-syntax (lens-set source-location->list-lens a a-lst) (list '+ 1 2 3) a-src)
|
||||
(check-syntax (lens-set source-location->list-lens b b-lst) (list 'define 'x 987) b-src)
|
||||
(check-syntax (lens-set source-location->list-lens a b-lst) (list '+ 1 2 3) b-src)
|
||||
(check-syntax (lens-set source-location->list-lens b a-lst) (list 'define 'x 987) a-src)
|
||||
;; same thing, but with source-location->vector-lens
|
||||
(check-equal? (lens-view source-location->vector-lens a) a-vec)
|
||||
(check-equal? (lens-view source-location->vector-lens b) b-vec)
|
||||
(check-syntax (lens-set source-location->vector-lens a a-vec) (list '+ 1 2 3) a-src)
|
||||
(check-syntax (lens-set source-location->vector-lens b b-vec) (list 'define 'x 987) b-src)
|
||||
(check-syntax (lens-set source-location->vector-lens a b-vec) (list '+ 1 2 3) b-src)
|
||||
(check-syntax (lens-set source-location->vector-lens b a-vec) (list 'define 'x 987) a-src)
|
||||
;; source-location->srcloc-lens also works with other types of source-locations
|
||||
(check-equal? (lens-view source-location->srcloc-lens a-src) a-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens b-src) b-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens a-lst) a-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens b-lst) b-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens a-vec) a-src)
|
||||
(check-equal? (lens-view source-location->srcloc-lens b-vec) b-src)
|
||||
(check-equal? (lens-set source-location->srcloc-lens a-src b-src) b-src)
|
||||
(check-equal? (lens-set source-location->srcloc-lens a-lst b-src) b-lst)
|
||||
(check-equal? (lens-set source-location->srcloc-lens a-vec b-src) b-vec)
|
||||
(check-equal? (lens-set source-location->srcloc-lens b-src a-src) a-src)
|
||||
(check-equal? (lens-set source-location->srcloc-lens b-lst a-src) a-lst)
|
||||
(check-equal? (lens-set source-location->srcloc-lens b-vec a-src) a-vec)
|
||||
)
|
||||
(test-case "syntax-source-lens"
|
||||
(check-equal? (lens-view syntax-source-lens a) 'a)
|
||||
(check-equal? (lens-view syntax-source-lens b) 'b)
|
||||
(check-syntax (lens-set syntax-source-lens a "bye.rkt")
|
||||
(list '+ 1 2 3)
|
||||
(srcloc "bye.rkt" 12 5 144 9))
|
||||
(check-syntax (lens-set syntax-source-lens b "hellooo.rkt")
|
||||
(list 'define 'x 987)
|
||||
(srcloc "hellooo.rkt" 49 7 343 14))
|
||||
;; same thing, but with source-location-source-lens instead of syntax-source-lens
|
||||
(check-equal? (lens-view source-location-source-lens a) 'a)
|
||||
(check-equal? (lens-view source-location-source-lens b) 'b)
|
||||
(check-syntax (lens-set source-location-source-lens a "bye.rkt")
|
||||
(list '+ 1 2 3)
|
||||
(srcloc "bye.rkt" 12 5 144 9))
|
||||
(check-syntax (lens-set source-location-source-lens b "hellooo.rkt")
|
||||
(list 'define 'x 987)
|
||||
(srcloc "hellooo.rkt" 49 7 343 14))
|
||||
)
|
||||
(test-case "syntax-line-lens"
|
||||
(check-equal? (lens-view syntax-line-lens a) 12)
|
||||
(check-equal? (lens-view syntax-line-lens b) 49)
|
||||
(check-syntax (lens-set syntax-line-lens a 8)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 8 5 144 9))
|
||||
(check-syntax (lens-set syntax-line-lens b 11)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 11 7 343 14))
|
||||
;; same thing, but with source-location-line-lens instead of syntax-line-lens
|
||||
(check-equal? (lens-view source-location-line-lens a) 12)
|
||||
(check-equal? (lens-view source-location-line-lens b) 49)
|
||||
(check-syntax (lens-set source-location-line-lens a 8)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 8 5 144 9))
|
||||
(check-syntax (lens-set source-location-line-lens b 11)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 11 7 343 14))
|
||||
)
|
||||
(test-case "syntax-column-lens"
|
||||
(check-equal? (lens-view syntax-column-lens a) 5)
|
||||
(check-equal? (lens-view syntax-column-lens b) 7)
|
||||
(check-syntax (lens-set syntax-column-lens a 8)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 12 8 144 9))
|
||||
(check-syntax (lens-set syntax-column-lens b 11)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 11 343 14))
|
||||
;; same thing, but with source-location-column-lens instead of syntax-column-lens
|
||||
(check-equal? (lens-view source-location-column-lens a) 5)
|
||||
(check-equal? (lens-view source-location-column-lens b) 7)
|
||||
(check-syntax (lens-set source-location-column-lens a 8)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 12 8 144 9))
|
||||
(check-syntax (lens-set source-location-column-lens b 11)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 11 343 14))
|
||||
)
|
||||
(test-case "syntax-position-lens"
|
||||
(check-equal? (lens-view syntax-position-lens a) 144)
|
||||
(check-equal? (lens-view syntax-position-lens b) 343)
|
||||
(check-syntax (lens-set syntax-position-lens a 233)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 12 5 233 9))
|
||||
(check-syntax (lens-set syntax-position-lens b 610)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 7 610 14))
|
||||
;; same thing, but with source-location-position-lens instead of syntax-position-lens
|
||||
(check-equal? (lens-view source-location-position-lens a) 144)
|
||||
(check-equal? (lens-view source-location-position-lens b) 343)
|
||||
(check-syntax (lens-set source-location-position-lens a 233)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 12 5 233 9))
|
||||
(check-syntax (lens-set source-location-position-lens b 610)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 7 610 14))
|
||||
)
|
||||
(test-case "syntax-span-lens"
|
||||
(check-equal? (lens-view syntax-span-lens a) 9)
|
||||
(check-equal? (lens-view syntax-span-lens b) 14)
|
||||
(check-syntax (lens-set syntax-span-lens a 10)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 12 5 144 10))
|
||||
(check-syntax (lens-set syntax-span-lens b 15)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 7 343 15))
|
||||
;; same thing, but with source-location-span-lens instead of syntax-span-lens
|
||||
(check-equal? (lens-view source-location-span-lens a) 9)
|
||||
(check-equal? (lens-view source-location-span-lens b) 14)
|
||||
(check-syntax (lens-set source-location-span-lens a 10)
|
||||
(list '+ 1 2 3)
|
||||
(srcloc 'a 12 5 144 10))
|
||||
(check-syntax (lens-set source-location-span-lens b 15)
|
||||
(list 'define 'x 987)
|
||||
(srcloc 'b 49 7 343 15))
|
||||
)
|
||||
)
|
||||
|
|
@ -1,419 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide stx->list-lens
|
||||
stx-map-lens
|
||||
stx-car-lens
|
||||
stx-cdr-lens
|
||||
stx-caar-lens
|
||||
stx-cdar-lens
|
||||
stx-cadr-lens
|
||||
stx-cddr-lens
|
||||
stx-caaar-lens
|
||||
stx-cdaar-lens
|
||||
stx-cadar-lens
|
||||
stx-cddar-lens
|
||||
stx-caadr-lens
|
||||
stx-cdadr-lens
|
||||
stx-caddr-lens
|
||||
stx-cdddr-lens
|
||||
stx-append*-lens
|
||||
stx-flatten/depth-lens
|
||||
stx-append*n-lens
|
||||
)
|
||||
|
||||
(require fancy-app lens/common lens/private/list/main racket/list racket/match syntax/stx)
|
||||
|
||||
(module+ test
|
||||
(require rackunit syntax/parse lens/private/test-util/test-lens))
|
||||
|
||||
;; stx-e : Any -> Any
|
||||
(define (stx-e stx)
|
||||
(if (syntax? stx)
|
||||
(syntax-e stx)
|
||||
stx))
|
||||
|
||||
;; restore-stx : (case-> [Stx Any -> Stx]
|
||||
;; [Any Any -> Any])
|
||||
(define (restore-stx stx dat)
|
||||
(if (syntax? stx)
|
||||
(datum->syntax stx dat stx stx)
|
||||
dat))
|
||||
|
||||
(define stx-e-lens
|
||||
(make-lens
|
||||
stx-e
|
||||
restore-stx)) ; the target will be used as the context
|
||||
|
||||
;; stx->list* : (Stx-Listof Any) -> (Listof Any)
|
||||
(define (stx->list* stx)
|
||||
(define lst (stx->list stx))
|
||||
;; lst : (U (Listof Any) False)
|
||||
(unless lst (error 'stx->list* "expected a stx-list, given ~v" stx))
|
||||
;; lst : (Listof Any)
|
||||
lst)
|
||||
|
||||
(define stx->list-lens
|
||||
(make-lens
|
||||
stx->list*
|
||||
restore-stx))
|
||||
|
||||
(define (stx-map-lens elt-lens)
|
||||
(make-lens
|
||||
(lens-view/stx-map elt-lens _)
|
||||
(lens-set/stx-map elt-lens _ _)))
|
||||
|
||||
(define (lens-view/stx-map lens tgts)
|
||||
(stx-map (lens-view lens _) tgts))
|
||||
|
||||
(define (lens-set/stx-map lens tgts new-views)
|
||||
(restore-stx tgts
|
||||
(stx-map (lens-set lens _ _) tgts new-views)))
|
||||
|
||||
(define stx-car-lens (lens-thrush stx-e-lens car-lens))
|
||||
(define stx-cdr-lens (lens-thrush stx-e-lens cdr-lens))
|
||||
(define stx-caar-lens (lens-thrush stx-car-lens stx-car-lens))
|
||||
(define stx-cdar-lens (lens-thrush stx-car-lens stx-cdr-lens))
|
||||
(define stx-cadr-lens (lens-thrush stx-cdr-lens stx-car-lens))
|
||||
(define stx-cddr-lens (lens-thrush stx-cdr-lens stx-cdr-lens))
|
||||
(define stx-caaar-lens (lens-thrush stx-caar-lens stx-car-lens))
|
||||
(define stx-cdaar-lens (lens-thrush stx-caar-lens stx-cdr-lens))
|
||||
(define stx-cadar-lens (lens-thrush stx-cdar-lens stx-car-lens))
|
||||
(define stx-cddar-lens (lens-thrush stx-cdar-lens stx-cdr-lens))
|
||||
(define stx-caadr-lens (lens-thrush stx-cadr-lens stx-car-lens))
|
||||
(define stx-cdadr-lens (lens-thrush stx-cadr-lens stx-cdr-lens))
|
||||
(define stx-caddr-lens (lens-thrush stx-cddr-lens stx-car-lens))
|
||||
(define stx-cdddr-lens (lens-thrush stx-cddr-lens stx-cdr-lens))
|
||||
|
||||
;; stx-append* : (Stx-Listof (Stx-Listof A)) -> (Stx-Listof A)
|
||||
(define (stx-append* lol)
|
||||
(append* (stx-map stx->list* lol)))
|
||||
|
||||
;; restore-structure : (Stx-Listof (Stx-Listof A)) (Stx-Listof B) -> (Stx-Listof (Stx-Listof B))
|
||||
;; Takes a list of lists and a list and un-flattens the flattened
|
||||
;; argument according to the structure of the structure arguement.
|
||||
;; The length of the flattened list must be the same as the length
|
||||
;; of (stx-append* structure).
|
||||
(define (restore-structure structure flattened)
|
||||
(match (stx-e structure)
|
||||
[(list)
|
||||
(unless (stx-null? flattened)
|
||||
(error 'stx-append*-lens "flattened list is too long to match the structure"))
|
||||
structure]
|
||||
[(cons s-lst s-rst)
|
||||
(define-values [f-lst f-rst]
|
||||
(stx-split-at flattened (stx-length s-lst)))
|
||||
(restore-stx structure
|
||||
(cons (restore-stx s-lst f-lst)
|
||||
(restore-structure s-rst f-rst)))]))
|
||||
|
||||
|
||||
;; stx-flatten/depth-lens : (Lens (Stx-Listof* Any n) (Stx-Listof Any))
|
||||
;; where the only valid views are stx-lists with the same length as
|
||||
;; the result of (stx-flatten/depth n target)
|
||||
(define (stx-flatten/depth-lens n)
|
||||
(make-lens
|
||||
(stx-flatten/depth n _)
|
||||
(stx-unflatten/depth n _ _)))
|
||||
|
||||
;; stx-append*-lens : (Lens (Stx-Listof (Stx-Listof Any)) (Stx-Listof Any))
|
||||
;; where the only valid views are stx-lists with the same length as
|
||||
;; the result of applying stx-append* to the target.
|
||||
;; Viewing is equivalent to using stx-append*
|
||||
;; Setting restores the structure of the original nested stx-list
|
||||
(define stx-append*-lens
|
||||
(stx-flatten/depth-lens 2))
|
||||
|
||||
;; stx-flatten/depth : n (Stx-Listof* A n) -> (Stx-Listof A)
|
||||
(define (stx-flatten/depth n lst*)
|
||||
(check-structure-depth! n lst*)
|
||||
(cond [(zero? n) (list lst*)]
|
||||
[else (stx-append*n (sub1 n) lst*)]))
|
||||
|
||||
;; stx-unflatten/depth : n (Stx-Listof* A n) (Stx-Listof B) -> (Stx-Listof* B n)
|
||||
(define (stx-unflatten/depth n lst* lst)
|
||||
(check-structure-depth! n lst*)
|
||||
(check-flattened-length! n lst* lst)
|
||||
(cond [(zero? n)
|
||||
(match-define (list v) (stx->list* lst))
|
||||
v]
|
||||
[else
|
||||
(stx-unappend*n (sub1 n) lst* lst)]))
|
||||
|
||||
;; stx-append*n : n (Stx-Listof (Stx-Listof* A n)) -> (Stx-Listof A)
|
||||
(define (stx-append*n n lst*)
|
||||
(cond [(zero? n) lst*]
|
||||
[else (stx-append*n (sub1 n) (stx-append* lst*))]))
|
||||
|
||||
;; stx-unappend*n : n (Stx-Listof (Stx-Listof* A n)) (Stx-Listof B) -> (Stx-Listof (Stx-Listof* B n))
|
||||
(define (stx-unappend*n n lst* lst)
|
||||
(cond [(zero? n) lst]
|
||||
[else (restore-structure
|
||||
lst*
|
||||
(stx-unappend*n (sub1 n) (stx-append* lst*) lst))]))
|
||||
|
||||
(define (stx-append*n-lens n)
|
||||
(stx-flatten/depth-lens (add1 n)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; stx-list/depth? : Natural Any -> Boolean
|
||||
(define (stx-list/depth? n structure)
|
||||
(cond [(zero? n) #true]
|
||||
[else (and (stx-list? structure)
|
||||
(stx-andmap (stx-list/depth? (sub1 n) _) structure))]))
|
||||
|
||||
;; check-structure-depth! : n (Stx-Listof* A n) -> Void
|
||||
(define (check-structure-depth! depth structure)
|
||||
(unless (stx-list/depth? depth structure)
|
||||
(raise-argument-error 'stx-flatten/depth-lens
|
||||
(format "a nested stx-list of depth ~v" depth)
|
||||
structure)))
|
||||
|
||||
;; check-flattened-length! : n (Stx-Listof* A n) (Stx-Listof B) -> Void
|
||||
(define (check-flattened-length! depth structure flattened)
|
||||
(unless (= (stx-length (stx-flatten/depth depth structure)) (stx-length flattened))
|
||||
(raise-argument-error 'stx-flatten/depth-lens
|
||||
(format "a stx-list of length ~v"
|
||||
(stx-length (stx-flatten/depth depth structure)))
|
||||
1
|
||||
structure
|
||||
flattened)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; stx-length : (Stx-Listof A) -> Natural
|
||||
(define (stx-length lst)
|
||||
(length (stx->list* lst)))
|
||||
|
||||
;; stx-andmap : [A -> Boolean] (Stx-Listof A) -> Boolean
|
||||
(define (stx-andmap f lst)
|
||||
(andmap f (stx->list* lst)))
|
||||
|
||||
;; stx-split-at : (Stx-Listof A) Natural -> (values (Listof A) (Stx-Listof A))
|
||||
(define (stx-split-at lst* pos*)
|
||||
(let loop ([acc (list)] [pos pos*] [lst lst*])
|
||||
(cond [(zero? pos)
|
||||
(values (reverse acc) lst)]
|
||||
[(stx-null? lst)
|
||||
(error 'stx-split-at "index is too large for stx-list\n index: ~v\n stx-list: ~v"
|
||||
pos* lst*)]
|
||||
[else
|
||||
(loop (cons (stx-car lst) acc)
|
||||
(sub1 pos)
|
||||
(stx-cdr lst))])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(define a* #'a)
|
||||
(define b* #'b)
|
||||
(define c* #'c)
|
||||
(define 1* #'1)
|
||||
(define 2* #'2)
|
||||
(define 3* #'3)
|
||||
(test-case "syntax-e-lens and stx-e-lens"
|
||||
(check-equal? (lens-view stx-e-lens a*) 'a)
|
||||
(check-equal? (syntax-e (lens-set stx-e-lens a* 1)) 1)
|
||||
(check-equal? (lens-view stx-e-lens 'a) 'a)
|
||||
(check-equal? (lens-set stx-e-lens 'a 1) 1)
|
||||
(check-equal? (lens-view stx-e-lens #`(#,a* #,b* #,c*)) (list a* b* c*))
|
||||
(check-equal? (syntax-e (lens-set stx-e-lens #`(#,a* #,b* #,c*) (list 1* 2* 3*)))
|
||||
(list 1* 2* 3*))
|
||||
(check-equal? (lens-view stx-e-lens (list a* b* c*)) (list a* b* c*))
|
||||
(check-equal? (lens-set stx-e-lens (list a* b* c*) (list 1* 2* 3*)) (list 1* 2* 3*))
|
||||
)
|
||||
(test-case "stx->list-lens"
|
||||
(check-equal? (lens-view stx->list-lens #`(#,a* #,b* #,c*))
|
||||
(list a* b* c*))
|
||||
(check-equal? (syntax->list (lens-set stx->list-lens #`(#,a* #,b* #,c*) (list 1* 2* 3*)))
|
||||
(list 1* 2* 3*))
|
||||
(check-exn #rx"expected a stx-list, given #<syntax.* 5>"
|
||||
(λ () (lens-view stx->list-lens #'5)))
|
||||
)
|
||||
(test-case "(stx-map-lens stx->list-lens)"
|
||||
(check-equal? (lens-view (stx-map-lens stx->list-lens) #`((#,a*) (#,b* #,c*) ()))
|
||||
(list (list a*) (list b* c*) (list)))
|
||||
(check-equal? (stx-map syntax->list
|
||||
(lens-set (stx-map-lens stx->list-lens)
|
||||
#`((#,a*) (#,b* #,c*) ())
|
||||
(list (list 1*) (list 2* 3*) (list))))
|
||||
(list (list 1*) (list 2* 3*) (list)))
|
||||
)
|
||||
(test-case "stx-car-lens, stx-cdr-lens, etc."
|
||||
(check-equal? (lens-view stx-car-lens #`(#,a* . #,b*)) a*)
|
||||
(check-equal? (lens-view stx-cdr-lens #`(#,a* . #,b*)) b*)
|
||||
(check-equal? (lens-view stx-car-lens (cons a* b*)) a*)
|
||||
(check-equal? (lens-view stx-cdr-lens (cons a* b*)) b*)
|
||||
(check-equal? (syntax-e (lens-set stx-car-lens #`(#,a* . #,b*) 1*)) (cons 1* b*))
|
||||
(check-equal? (syntax-e (lens-set stx-cdr-lens #`(#,a* . #,b*) 1*)) (cons a* 1*))
|
||||
(check-equal? (lens-set stx-car-lens (cons a* b*) 1*) (cons 1* b*))
|
||||
(check-equal? (lens-set stx-cdr-lens (cons a* b*) 1*) (cons a* 1*))
|
||||
(check-equal? (lens-view stx-car-lens #`(#,a* #,b* #,c*)) a*)
|
||||
(check-equal? (lens-view stx-cadr-lens #`(#,a* #,b* #,c*)) b*)
|
||||
(check-equal? (lens-view stx-caddr-lens #`(#,a* #,b* #,c*)) c*)
|
||||
(check-equal? (lens-view stx-car-lens (list a* b* c*)) a*)
|
||||
(check-equal? (lens-view stx-cadr-lens (list a* b* c*)) b*)
|
||||
(check-equal? (lens-view stx-caddr-lens (list a* b* c*)) c*)
|
||||
(check-equal? (syntax-e (lens-set stx-car-lens #`(#,a* #,b* #,c*) 1*)) (list 1* b* c*))
|
||||
(check-equal? (syntax-e (lens-set stx-cadr-lens #`(#,a* #,b* #,c*) 1*)) (list a* 1* c*))
|
||||
(check-equal? (syntax-e (lens-set stx-caddr-lens #`(#,a* #,b* #,c*) 1*)) (list a* b* 1*))
|
||||
(check-equal? (lens-set stx-car-lens (list a* b* c*) 1*) (list 1* b* c*))
|
||||
(check-equal? (lens-set stx-cadr-lens (list a* b* c*) 1*) (list a* 1* c*))
|
||||
(check-equal? (lens-set stx-caddr-lens (list a* b* c*) 1*) (list a* b* 1*))
|
||||
)
|
||||
(test-case "stx-append*-lens"
|
||||
(check-equal? (lens-view stx-append*-lens (list (list 1*) (list 2* 3*) (list)))
|
||||
(list 1* 2* 3*))
|
||||
(check-equal? (lens-view stx-append*-lens #`((#,1*) (#,2* #,3*) ()))
|
||||
(list 1* 2* 3*))
|
||||
(check-equal? (lens-set stx-append*-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
(list 'a 'b 'c))
|
||||
(list (list 'a) (list 'b 'c) (list)))
|
||||
(check-equal? (map syntax->list
|
||||
(lens-set stx-append*-lens
|
||||
(list #`(#,1*) #`(#,2* #,3*) #`())
|
||||
(list a* b* c*)))
|
||||
(list (list a*) (list b* c*) (list)))
|
||||
(check-equal? (map syntax->list
|
||||
(syntax-e
|
||||
(lens-set stx-append*-lens
|
||||
#`((#,1*) (#,2* #,3*) ())
|
||||
(list a* b* c*))))
|
||||
(list (list a*) (list b* c*) (list)))
|
||||
|
||||
(check-equal? (lens-transform stx-append*-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
(lambda (lst)
|
||||
;; a length-preserving computation
|
||||
(let loop ([acc (list)] [sum 0] [lst lst])
|
||||
(match lst
|
||||
[(list) (reverse acc)]
|
||||
[(cons fst rst)
|
||||
(loop (cons (+ sum fst) acc)
|
||||
(+ sum fst)
|
||||
rst)]))))
|
||||
(list (list 1) (list 3 6) (list)))
|
||||
|
||||
(check-equal? (map syntax->datum
|
||||
(syntax-e
|
||||
(lens-transform
|
||||
stx-append*-lens
|
||||
#'(((+ a)) ((- a b) (* c d)) ())
|
||||
(lambda (lst)
|
||||
;; a length-preserving computation
|
||||
(syntax-parse
|
||||
(expand #`(#%expression (λ (a b c d) (#%app list #,@lst))))
|
||||
#:literals (#%plain-lambda #%plain-app list)
|
||||
[(#%expression (#%plain-lambda (x ...) (#%plain-app list e ...)))
|
||||
#'[e ...]])))))
|
||||
(list (list '(#%app + a))
|
||||
(list '(#%app - a b) '(#%app * c d))
|
||||
(list)))
|
||||
|
||||
(check-exn #rx"expected: a nested stx-list of depth 2\n given: '\\(5\\)"
|
||||
(λ () (lens-view stx-append*-lens (list 5))))
|
||||
(check-exn #rx"expected: a nested stx-list of depth 2\n given: '\\(5\\)"
|
||||
(λ () (lens-set stx-append*-lens (list 5) (list 'a))))
|
||||
|
||||
(check-exn #rx"expected: a stx-list of length 3\n given: '\\(a b\\)"
|
||||
(λ () (lens-set stx-append*-lens (list (list 1) (list 2 3) (list)) (list 'a 'b))))
|
||||
|
||||
(test-lens-laws stx-append*-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
(list 'a 'b 'c)
|
||||
(list "a" "b" "c"))
|
||||
(test-lens-laws stx-append*-lens
|
||||
(list (list 1*) (list 2* 3*) (list))
|
||||
(list a* b* c*)
|
||||
(list "a" "b" "c"))
|
||||
)
|
||||
(test-case "stx-flatten/depth-lens"
|
||||
(define flat0-lens (stx-flatten/depth-lens 0))
|
||||
(define flat1-lens (stx-flatten/depth-lens 1))
|
||||
(define flat2-lens (stx-flatten/depth-lens 2))
|
||||
(define flat3-lens (stx-flatten/depth-lens 3))
|
||||
(define flat4-lens (stx-flatten/depth-lens 4))
|
||||
|
||||
(check-equal? (lens-view flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6))))
|
||||
(list 1 2 3 4 5 6))
|
||||
(check-equal? (lens-set flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b 'c 'd 'e 'f))
|
||||
(list (list (list) (list 'a))
|
||||
(list (list 'b 'c))
|
||||
(list)
|
||||
(list (list 'd) (list) (list 'e 'f))))
|
||||
|
||||
(test-lens-laws flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b 'c 'd 'e 'f)
|
||||
(list "a" "b" "c" "d" "e" "f"))
|
||||
|
||||
(check-equal? (lens-view flat4-lens
|
||||
(list (list (list) (list (list 1)))
|
||||
(list (list (list) (list 2 3)))
|
||||
(list)
|
||||
(list (list (list 4) (list)) (list) (list (list 5 6)))))
|
||||
(list 1 2 3 4 5 6))
|
||||
(check-equal? (lens-set flat4-lens
|
||||
(list (list (list) (list (list 1)))
|
||||
(list (list (list) (list 2 3)))
|
||||
(list)
|
||||
(list (list (list 4) (list)) (list) (list (list 5 6))))
|
||||
(list 'a 'b 'c 'd 'e 'f))
|
||||
(list (list (list) (list (list 'a)))
|
||||
(list (list (list) (list 'b 'c)))
|
||||
(list)
|
||||
(list (list (list 'd) (list)) (list) (list (list 'e 'f)))))
|
||||
|
||||
(check-exn #rx"expected: a nested stx-list of depth 3\n *given: '\\(5\\)"
|
||||
(λ () (lens-view flat3-lens (list 5))))
|
||||
(check-exn #rx"expected: a nested stx-list of depth 3\n given: '\\(5\\)"
|
||||
(λ () (lens-set flat3-lens (list 5) (list 'a))))
|
||||
|
||||
(check-exn #rx"expected: a stx-list of length 6\n given: '\\(a b\\)"
|
||||
(λ () (lens-set flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b))))
|
||||
|
||||
(test-lens-laws flat0-lens
|
||||
42
|
||||
(list 'a)
|
||||
(list "a"))
|
||||
(test-lens-laws flat1-lens
|
||||
(list 1 2 3)
|
||||
(list 'a 'b 'c)
|
||||
(list "a" "b" "c"))
|
||||
(test-lens-laws flat2-lens
|
||||
(list (list 1) (list 2 3) (list))
|
||||
(list 'a 'b 'c)
|
||||
(list "a" "b" "c"))
|
||||
(test-lens-laws flat3-lens
|
||||
(list (list (list) (list 1))
|
||||
(list (list 2 3))
|
||||
(list)
|
||||
(list (list 4) (list) (list 5 6)))
|
||||
(list 'a 'b 'c 'd 'e 'f)
|
||||
(list "a" "b" "c" "d" "e" "f"))
|
||||
(test-lens-laws flat4-lens
|
||||
(list (list (list) (list (list 1)))
|
||||
(list (list (list) (list 2 3)))
|
||||
(list)
|
||||
(list (list (list 4) (list)) (list) (list (list 5 6))))
|
||||
(list 'a 'b 'c 'd 'e 'f)
|
||||
(list "a" "b" "c" "d" "e" "f"))
|
||||
))
|
||||
|
|
@ -1,31 +0,0 @@
|
|||
#lang racket/base
|
||||
(require lens/private/base/gen-lens
|
||||
rackunit
|
||||
racket/function)
|
||||
|
||||
(struct bad1 ()
|
||||
#:methods gen:lens [])
|
||||
(check-exn #rx"lens-view: not implemented"
|
||||
(thunk (lens-view (bad1) 1)))
|
||||
(check-exn #rx"lens-set: not implemented"
|
||||
(thunk (lens-set (bad1) 1 1)))
|
||||
(check-exn #rx"focus-lens: not implemented"
|
||||
(thunk (focus-lens (bad1) 1)))
|
||||
|
||||
(struct bad2 ()
|
||||
#:methods gen:lens
|
||||
[(define (lens-view this tgt) "something")])
|
||||
(check-equal? (lens-view (bad2) 1) "something")
|
||||
(check-exn #rx"lens-set: not implemented"
|
||||
(thunk (lens-set (bad2) 1 1)))
|
||||
(check-exn #rx"focus-lens: not implemented"
|
||||
(thunk (focus-lens (bad2) 1)))
|
||||
|
||||
(struct bad3 ()
|
||||
#:methods gen:lens
|
||||
[(define (lens-set this tgt nvw) tgt)])
|
||||
(check-equal? (lens-set (bad3) 1 2) 1)
|
||||
(check-exn #rx"lens-view: not implemented"
|
||||
(thunk (lens-view (bad3) 1)))
|
||||
(check-exn #rx"focus-lens: not implemented"
|
||||
(thunk (focus-lens (bad3) 1)))
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide alternating->assoc-list
|
||||
assoc->alternating-list
|
||||
keys+values->assoc-list
|
||||
assoc-list->keys+values
|
||||
keys+values->alternating-list
|
||||
alternating-list->keys+values
|
||||
|
||||
require racket/list
|
||||
racket/match
|
||||
unstable/sequence
|
||||
module+ test
|
||||
require rackunit
|
||||
|
||||
(define (alternating->assoc-list alternating-list)
|
||||
(for/list ([lst (in-slice 2 alternating-list)])
|
||||
(match-define (list a b) lst)
|
||||
(cons a b)))
|
||||
|
||||
(define (assoc->alternating-list alist)
|
||||
(append*
|
||||
(for/list ([(k v) (in-pairs alist)])
|
||||
(list k v))))
|
||||
|
||||
(define (keys+values->assoc-list keys values)
|
||||
(map cons keys values))
|
||||
|
||||
(define (assoc-list->keys+values alist)
|
||||
(values (map car alist)
|
||||
(map cdr alist)))
|
||||
|
||||
(define (keys+values->alternating-list keys values)
|
||||
(append-map list keys values))
|
||||
|
||||
(define (alternating-list->keys+values alternating-list)
|
||||
(for/lists (ks vv) ([lst (in-slice 2 alternating-list)])
|
||||
(match-define (list k v) lst)
|
||||
(values k v)))
|
||||
|
||||
module+ test
|
||||
(check-equal? (alternating->assoc-list '(a 1 b 2)) '((a . 1) (b . 2)))
|
||||
(check-equal? (alternating->assoc-list '(b 2 a 1)) '((b . 2) (a . 1)))
|
||||
(check-equal? (assoc->alternating-list '((a . 1) (b . 2))) '(a 1 b 2))
|
||||
(check-equal? (assoc->alternating-list '((b . 2) (a . 1))) '(b 2 a 1))
|
||||
(check-equal? (keys+values->assoc-list '(a b) '(1 2)) '((a . 1) (b . 2)))
|
||||
(check-equal? (keys+values->assoc-list '(b a) '(2 1)) '((b . 2) (a . 1)))
|
||||
(check-equal? (keys+values->alternating-list '(a b) '(1 2)) '(a 1 b 2))
|
||||
(check-equal? (keys+values->alternating-list '(b a) '(2 1)) '(b 2 a 1))
|
||||
(let-values ([(ks vs) (assoc-list->keys+values '((a . 1) (b . 2)))])
|
||||
(check-equal? ks '(a b))
|
||||
(check-equal? vs '(1 2)))
|
||||
(let-values ([(ks vs) (assoc-list->keys+values '((b . 2) (a . 1)))])
|
||||
(check-equal? ks '(b a))
|
||||
(check-equal? vs '(2 1)))
|
||||
(let-values ([(ks vs) (alternating-list->keys+values '(a 1 b 2))])
|
||||
(check-equal? ks '(a b))
|
||||
(check-equal? vs '(1 2)))
|
||||
(let-values ([(ks vs) (alternating-list->keys+values '(b 2 a 1))])
|
||||
(check-equal? ks '(b a))
|
||||
(check-equal? vs '(2 1)))
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide functional-dict?
|
||||
|
||||
require racket/dict
|
||||
module+ test
|
||||
require rackunit
|
||||
|
||||
(define (functional-dict? v)
|
||||
(and (dict? v) (dict-can-functional-set? v)))
|
||||
|
||||
module+ test
|
||||
(check-true (functional-dict? (hash 'a 1 'b 2)))
|
||||
(check-true (functional-dict? '((a . 1) (b . 2))))
|
||||
(check-false (functional-dict? (make-hash '((a . 1) (b . 2)))))
|
||||
|
|
@ -1,17 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide functional-set?
|
||||
|
||||
require racket/set
|
||||
module+ test
|
||||
require rackunit
|
||||
|
||||
(define (functional-set? st)
|
||||
(and (generic-set? st)
|
||||
(set-implements? st 'set-add 'set-remove)
|
||||
(not (set-mutable? st))))
|
||||
|
||||
module+ test
|
||||
(check-true (functional-set? (set 1 2 3)))
|
||||
(check-true (functional-set? '(1 2 3)))
|
||||
(check-false (functional-set? (mutable-set 1 2 3)))
|
||||
|
|
@ -1,37 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
require racket/contract
|
||||
lens/private/base/main
|
||||
lens/private/isomorphism/base
|
||||
lens/private/compound/compose
|
||||
lens/private/util/rest-contract
|
||||
"../util/immutable.rkt"
|
||||
"../list/join-list.rkt"
|
||||
|
||||
module+ test
|
||||
require rackunit
|
||||
lens/private/test-util/test-lens
|
||||
"../list/list-ref-take-drop.rkt"
|
||||
|
||||
provide
|
||||
contract-out
|
||||
lens-join/vector (rest-> lens? (lens/c any/c immutable-vector?))
|
||||
|
||||
|
||||
(define (lens-join/vector . lenses)
|
||||
(lens-compose list->vector-lens (apply lens-join/list lenses)))
|
||||
|
||||
(define list->vector-lens
|
||||
(make-isomorphism-lens list->immutable-vector vector->list))
|
||||
|
||||
(module+ test
|
||||
(define vector-first-third-fifth-lens
|
||||
(lens-join/vector first-lens
|
||||
third-lens
|
||||
fifth-lens))
|
||||
(check-lens-view vector-first-third-fifth-lens '(a b c d e f)
|
||||
#(a c e))
|
||||
(check-pred immutable? (lens-view vector-first-third-fifth-lens '(a b c d e f)))
|
||||
(check-lens-set vector-first-third-fifth-lens '(a b c d e f) #(1 2 3)
|
||||
'(1 b 2 d 3 f)))
|
||||
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
#lang reprovide
|
||||
"nested.rkt"
|
||||
"pick.rkt"
|
||||
"ref.rkt"
|
||||
"join-vector.rkt"
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define collection 'multi)
|
||||
|
||||
(define deps
|
||||
'("base"
|
||||
"lens-lib"
|
||||
"lens-unstable"
|
||||
"scribble-lib"
|
||||
"reprovide-lang"
|
||||
"jack-scribble-example"
|
||||
))
|
||||
|
||||
(define build-deps
|
||||
'("at-exp-lib"
|
||||
"doc-coverage"
|
||||
"racket-doc"
|
||||
"sweet-exp-lib"
|
||||
))
|
||||
|
||||
(define cover-omit-paths
|
||||
'(#rx".*\\.scrbl"
|
||||
#rx"info\\.rkt"
|
||||
"lens/private/doc-util"
|
||||
))
|
||||
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang info
|
||||
|
||||
(define scribblings '(["main.scrbl" (multi-page) (library) "lens"]))
|
||||
|
||||
|
|
@ -1,25 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main)
|
||||
|
||||
@title[#:style '(toc)]{Lenses}
|
||||
|
||||
@defmodule[lens]
|
||||
|
||||
This library includes functions and forms for working with
|
||||
@lens-tech{lenses}. A lens is a value that operates on some small piece
|
||||
of a larger structure. Think of them as a more general representation
|
||||
of getters and setters in object-oriented languages.
|
||||
|
||||
@author[@author+email["Jack Firth" "jackhfirth@gmail.com"]
|
||||
@author+email["Alex Knauth" "alexander@knauth.org"]]
|
||||
|
||||
source code: @url["https://github.com/jackfirth/lens"]
|
||||
|
||||
@stability-notice[unstable/lens]
|
||||
|
||||
@local-table-of-contents[]
|
||||
|
||||
@include-section["private/scribblings/guide.scrbl"]
|
||||
@include-section["private/scribblings/reference.scrbl"]
|
||||
@include-section[(lib "unstable/lens/main.scrbl")]
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main)
|
||||
|
||||
@title{Lens Contracts}
|
||||
|
||||
@defproc[(lens/c [target/c contract?] [view/c contract?]) contract?]{
|
||||
A contract constructor for lenses. The @racket[target/c] contract is used for
|
||||
any target given to or returned by the lens, while the @racket[view/c] contract
|
||||
is used for any view given to or returned by the lens. For example, the
|
||||
@racket[view/c] contract is used for the return value of
|
||||
@racket[(lens-view lens target)] and the third argument of
|
||||
@racket[(lens-set lens target view)], as well as other places where targets or
|
||||
views of the lens are used as inputs or outputs.
|
||||
@lens-examples[
|
||||
(define contracted-car-lens
|
||||
(invariant-assertion (lens/c pair? number?) car-lens))
|
||||
(lens-view contracted-car-lens (cons 1 2))
|
||||
(lens-view contracted-car-lens 'not-a-pair)
|
||||
(lens-view contracted-car-lens (cons 'not-a-number 2))
|
||||
(lens-set contracted-car-lens (cons 1 2) 'not-a-number)
|
||||
]}
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/scribble-include-no-subsection)
|
||||
|
||||
@title[#:tag "composing-lenses"]{Joining and Composing Lenses}
|
||||
|
||||
@scribble-include/no-subsection["compose.scrbl"]
|
||||
@scribble-include/no-subsection["thrush.scrbl"]
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide include-sections)
|
||||
|
||||
(require (only-in scribble/base include-section))
|
||||
|
||||
(define-syntax-rule (include-sections mod-path ...)
|
||||
(begin (include-section mod-path) ...))
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require scribble/manual)
|
||||
|
||||
(provide lens-tech)
|
||||
|
||||
(define (lens-tech . pre-content)
|
||||
(apply tech #:key "lens" #:normalize? #f pre-content))
|
||||
|
|
@ -1,21 +0,0 @@
|
|||
#lang sweet-exp racket
|
||||
|
||||
provide lens-examples
|
||||
lens-applicable-examples
|
||||
lens-unstable-examples
|
||||
persistent-lens-unstable-examples
|
||||
|
||||
require scribble-example
|
||||
|
||||
|
||||
(define-examples-form lens-examples
|
||||
lens racket/list racket/vector racket/stream racket/set racket/contract)
|
||||
|
||||
(define-examples-form lens-applicable-examples
|
||||
lens/applicable racket/list racket/vector racket/stream racket/set racket/contract)
|
||||
|
||||
(define-examples-form lens-unstable-examples
|
||||
lens unstable/lens racket/list racket/vector racket/stream racket/set racket/contract)
|
||||
|
||||
(define-persistent-examples-form persistent-lens-unstable-examples
|
||||
lens unstable/lens racket/list racket/vector racket/stream racket/set racket/contract)
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
#lang sweet-exp reprovide
|
||||
syntax/parse/define
|
||||
lens/private/doc-util/deflenses
|
||||
lens/private/doc-util/include-sections
|
||||
lens/private/doc-util/lens-tech
|
||||
lens/private/doc-util/lenses-examples
|
||||
lens/private/doc-util/other-reference
|
||||
lens/private/doc-util/stability-notice
|
||||
for-label
|
||||
lens
|
||||
unstable/lens
|
||||
racket/base
|
||||
racket/match
|
||||
racket/list
|
||||
racket/vector
|
||||
racket/stream
|
||||
racket/set
|
||||
racket/contract
|
||||
racket/function
|
||||
for-syntax
|
||||
racket/base
|
||||
syntax/parse
|
||||
racket/syntax
|
||||
|
|
@ -1,19 +0,0 @@
|
|||
.flexible-container {
|
||||
display: -webkit-flex;
|
||||
display: flex;
|
||||
}
|
||||
|
||||
.flexible-element {
|
||||
-webkit-flex: 1;
|
||||
flex: 1;
|
||||
}
|
||||
|
||||
.margin-note__image-left {
|
||||
float: left;
|
||||
font-size: 1.25em;
|
||||
margin-right: 0.4em;
|
||||
}
|
||||
|
||||
.margin-note__image-left--finger::before {
|
||||
content: '☞';
|
||||
}
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
#lang at-exp racket/base
|
||||
|
||||
(require racket/require
|
||||
(multi-in scribble (base html-properties struct))
|
||||
(only-in scribble/core style)
|
||||
setup/collects)
|
||||
|
||||
(provide other-reference-note see-guide-note see-reference-note)
|
||||
|
||||
(define css-resource
|
||||
(make-css-addition
|
||||
(path->collects-relative
|
||||
(collection-file-path "other-reference.css" "lens" "private" "doc-util"))))
|
||||
|
||||
(define finger (element (style "margin-note__image-left margin-note__image-left--finger"
|
||||
(list css-resource))
|
||||
'()))
|
||||
|
||||
(define (flexible-container . content)
|
||||
(element (style "flexible-container" (list css-resource (alt-tag "div"))) content))
|
||||
(define (flexible-element . content)
|
||||
(element (style "flexible-element" (list css-resource (alt-tag "div"))) content))
|
||||
|
||||
(define (other-reference-note . pre-content)
|
||||
(margin-note (flexible-container finger (apply flexible-element pre-content))))
|
||||
|
||||
(define (see-guide-note tag . pre-content)
|
||||
@other-reference-note{
|
||||
@seclink[tag]{The Lens Guide} has additional examples of @|pre-content|.})
|
||||
|
||||
(define (see-reference-note tag . pre-content)
|
||||
@other-reference-note{
|
||||
@seclink[tag]{The Lens Reference} has additional information on @|pre-content|.})
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide scribble-include/no-subsection
|
||||
|
||||
require syntax/parse/define
|
||||
racket/match
|
||||
scribble/core
|
||||
for-syntax racket/base
|
||||
syntax/parse
|
||||
|
||||
|
||||
;; scribble-include/no-subsection requires that the module to be included:
|
||||
;; - has no title
|
||||
;; - has no tag-prefix
|
||||
;; - has exactly one (list 'part (generated-tag)) tag
|
||||
;; - has no subsections
|
||||
;; - has no `to-collect` content
|
||||
(define-syntax scribble-include/no-subsection
|
||||
(syntax-parser
|
||||
[(~and stx (scribble-include/no-subsection mod))
|
||||
#:with doc-from-mod (datum->syntax #'mod 'doc)
|
||||
(unless (module-path? (syntax->datum #'mod))
|
||||
(raise-syntax-error #f
|
||||
"not a module path"
|
||||
#'stx
|
||||
#'mod))
|
||||
#'(begin
|
||||
(require (only-in mod [doc-from-mod doc]))
|
||||
(match-define (part #f (list (list 'part (generated-tag))) #f style '() blocks '()) doc)
|
||||
(nested-flow style blocks))]))
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide stability-notice
|
||||
|
||||
require scribble/manual
|
||||
|
||||
|
||||
(define-syntax-rule (stability-notice id)
|
||||
(list "This library is stable, backwards compatibility will be maintained. For experimental features see "
|
||||
(racketmodname id) "."))
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main
|
||||
lens/private/doc-util/scribble-include-no-subsection)
|
||||
|
||||
@title[#:tag "hash-reference"]{Hash Lenses}
|
||||
|
||||
@defmodule[lens/data/hash]
|
||||
|
||||
@see-guide-note["hash-guide"]{hash lenses}
|
||||
|
||||
@scribble-include/no-subsection["ref.scrbl"]
|
||||
@scribble-include/no-subsection["nested.scrbl"]
|
||||
@scribble-include/no-subsection["pick.scrbl"]
|
||||
@scribble-include/no-subsection["join-hash.scrbl"]
|
||||
|
|
@ -1,88 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main)
|
||||
|
||||
@title{Flattening and unflattening lists}
|
||||
|
||||
@defthing[append*-lens lens?]{
|
||||
A lens that flattens a list one-level down when viewing, and restores
|
||||
the original structure when setting. The target list must be a nested
|
||||
list at least 2 levels deep, or a list of lists. Viewing with this
|
||||
lens is equivalent to using @racket[append*], and setting with this
|
||||
lens restores the structure of the original nested list.
|
||||
|
||||
When setting, the new view must have the same length as the old view,
|
||||
so it must have the same length as @racket[(append* target)].
|
||||
|
||||
This is equivalent to @racket[(flatten/depth-lens 2)], since it
|
||||
flattens lists of depth 2.
|
||||
@lens-unstable-examples[
|
||||
(lens-view append*-lens '((a b c) (1 2 3)))
|
||||
(lens-set append*-lens '((a b c) (1 2 3)) '("do" "re" "mi" "re" "mi" "do"))
|
||||
(lens-view append*-lens '((a) (b c) () (d e f)))
|
||||
(lens-set append*-lens '((a) (b c) () (d e f)) '(1 2 3 4 5 6))
|
||||
]
|
||||
The further nested elements don't have to be atomic, they could be
|
||||
other lists. @racket[append*-lens] doesn't recur into those.
|
||||
@lens-unstable-examples[
|
||||
(lens-view append*-lens '(((a) (b) (c)) ((1) (2) (3))))
|
||||
(lens-set append*-lens '(((a) (b) (c)) ((1) (2) (3))) '("mi" "re" "do" "re" "re" "mi"))
|
||||
]}
|
||||
|
||||
@defproc[(flatten/depth-lens [n exact-nonnegative-integer?]) lens?]{
|
||||
Creates a lens that flattens a list of depth @racket[n] when
|
||||
viewing, and restores the original structure when setting.
|
||||
|
||||
A list of depth @racket[0] is a single element, a list of depth
|
||||
@racket[1] is a list, a list of depth @racket[2] is a list of lists,
|
||||
and so on.
|
||||
|
||||
This is a generalization of @racket[append*-lens], with that being
|
||||
equivalent to @racket[(flatten/depth-lens 2)]. It uses
|
||||
@racket[flatten/depth] to view, and @racket[unflatten/depth] to set.
|
||||
|
||||
When setting, the new view must have the same length as the old view,
|
||||
so it must have the same length as @racket[(flatten/depth n target)].
|
||||
@lens-unstable-examples[
|
||||
(lens-view (flatten/depth-lens 0) 'a)
|
||||
(lens-set (flatten/depth-lens 0) 'a '(1))
|
||||
(lens-view (flatten/depth-lens 1) '(a b c))
|
||||
(lens-set (flatten/depth-lens 1) '(a b c) '(1 2 3))
|
||||
(lens-view (flatten/depth-lens 2) '((a) (b c) () (d e f)))
|
||||
(lens-set (flatten/depth-lens 2) '((a) (b c) () (d e f)) '(1 2 3 4 5 6))
|
||||
(lens-view (flatten/depth-lens 3) '(((a) ()) (() (b) (c)) () ((d e) () (f))))
|
||||
(lens-set (flatten/depth-lens 3) '(((a) ()) (() (b) (c)) () ((d e) () (f))) '(1 2 3 4 5 6))
|
||||
]}
|
||||
|
||||
@defproc[(flatten/depth [n exact-nonnegative-integer?] [structure any/c]) list?]{
|
||||
Flattens a list of depth @racket[n]. For depth @racket[n] = @racket[0],
|
||||
it returns @racket[(list structure)]. For a depth of @racket[1], it
|
||||
returns @racket[structure]. For a depth of @racket[2], it returns
|
||||
@racket[(append* structure)]. For a depth of @racket[3], it returns
|
||||
@racket[(append* (append* structure))], and so on for higher depths.
|
||||
|
||||
This is what @racket[flatten/depth-lens] uses for viewing.
|
||||
@lens-unstable-examples[
|
||||
(flatten/depth 0 'a)
|
||||
(flatten/depth 1 '(a b c))
|
||||
(flatten/depth 2 '((a) (b c) () (d e f)))
|
||||
(flatten/depth 3 '(((a) ()) (() (b) (c)) () ((d e) () (f))))
|
||||
]}
|
||||
|
||||
@defproc[(unflatten/depth [n exact-nonnegative-integer?] [structure any/c] [flattened list?]) any/c]{
|
||||
Un-does the work done by @racket[flatten/depth], to return an
|
||||
un-flattened version of @racket[flattened], with the structure restored based
|
||||
on @racket[structure].
|
||||
|
||||
This is what @racket[flatten/depth-lens] uses for setting.
|
||||
@lens-unstable-examples[
|
||||
(unflatten/depth 0 'a '(1))
|
||||
(unflatten/depth 1 '(a b c) '(1 2 3))
|
||||
(unflatten/depth 2 '((a) (b c) () (d e f)) '(1 2 3 4 5 6))
|
||||
(unflatten/depth 3 '(((a) ()) (() (b) (c)) () ((d e) () (f))) '(1 2 3 4 5 6))
|
||||
]}
|
||||
|
||||
@defproc[(append*n-lens [n exact-nonnegative-integer?]) lens?]{
|
||||
This is deprecated. Use @racket[(flatten/depth-lens (add1 n))] instead.
|
||||
}
|
||||
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main)
|
||||
|
||||
@title[#:tag "pair-list-reference"]{Pair and List Lenses}
|
||||
|
||||
@defmodule[lens/data/list]
|
||||
|
||||
@see-guide-note["pair-list-guide"]{pair and list lenses}
|
||||
|
||||
@include-section["car-cdr.scrbl"]
|
||||
@include-section["list-ref-take-drop.scrbl"]
|
||||
@include-section["join-list.scrbl"]
|
||||
@include-section["assoc.scrbl"]
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@title[#:tag "lens-guide" #:style 'toc]{The Lens Guide}
|
||||
|
||||
This guide is intended for programmers who are familiar with Racket but new to working with lenses or
|
||||
a certain part of this lens library. It contains a non-authorative introduction to lenses, including
|
||||
examples of usage and recipes for solving certain kinds of problems. It does not describe all features
|
||||
this library provides; for a complete API reference, see @secref{lens-reference}.
|
||||
|
||||
@local-table-of-contents[]
|
||||
|
||||
@include-section["guide/introduction.scrbl"]
|
||||
@include-section["guide/built-in.scrbl"]
|
||||
@include-section["guide/user-defined.scrbl"]
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main)
|
||||
|
||||
@title[#:tag "built-in-lenses" #:style 'toc]{Lenses on Built-In Datatypes}
|
||||
|
||||
This library provides @lens-tech{lenses} for most built-in Racket datatypes. In general, the name of
|
||||
each lens corresponds to the name of its accessor function with @racket[-lens] appended to the end.
|
||||
For example, the lens for accessing the first element of a pair is @racket[car-lens], and the lens for
|
||||
accessing an element of a hash is called @racket[hash-ref-lens].
|
||||
|
||||
@local-table-of-contents[]
|
||||
|
||||
@include-section["built-in/ordered.scrbl"]
|
||||
@include-section["built-in/key-value.scrbl"]
|
||||
|
|
@ -1,90 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require scribble/eval
|
||||
lens/private/doc-util/main)
|
||||
|
||||
@(define make-lens-eval
|
||||
(make-eval-factory '(racket/base lens)))
|
||||
|
||||
@(define-syntax-rule (lens-interaction expr ...)
|
||||
(interaction #:eval (make-lens-eval) expr ...))
|
||||
|
||||
@title[#:tag "key-value-lenses"]{Lenses on Key-Value Data}
|
||||
|
||||
Many Racket data structures hold values that correspond to a given key. Lenses for accessing elements
|
||||
of these structures by their keys are provided.
|
||||
|
||||
@section[#:tag "hash-guide"]{Hash Tables}
|
||||
|
||||
@see-reference-note["hash-reference"]{hash lenses}
|
||||
|
||||
Racket hash tables are simple key-value associations, and as a result, they only have one primitive
|
||||
lens constructor, @racket[hash-ref-lens]. Given a key, it produces a lens which views the value
|
||||
associated with the key:
|
||||
|
||||
@(lens-interaction
|
||||
(lens-transform (hash-ref-lens 'a) (hash 'a "Hello")
|
||||
(λ (s) (string-append s ", world!"))))
|
||||
|
||||
Note that @racket[hash-ref-lens]'s signature differs from that of @racket[hash-ref] in an important
|
||||
way: it does not accept a “failure result” if the key is missing from the hash. Instead, the lens
|
||||
always throws an error:
|
||||
|
||||
@(lens-interaction
|
||||
(lens-view (hash-ref-lens 'not-a-key) (hash)))
|
||||
|
||||
This may seem inconvenient, but this limitation is by design---supporting a failure result would
|
||||
violate one of the @seclink["laws"]{lens laws}. Specifically, “get-set consistency” would no longer
|
||||
hold. Consider this example:
|
||||
|
||||
@(racketblock
|
||||
(let ([l (hash-ref-lens 'not-a-key "default")]
|
||||
[h (hash)])
|
||||
(lens-set l h (lens-view l h))))
|
||||
|
||||
If @racket[hash-ref-lens] accepted a default value, then the above expression would produce a new hash
|
||||
that was not @racket[equal?] to the original target. Enforcing this property makes lenses easier to
|
||||
reason about, just as ensuring purity makes functions easier to reason about.
|
||||
|
||||
Of course, sometimes breaking purity is the easiest way to solve a problem, and similarly, sometimes
|
||||
breaking the lens laws is okay (though it should be avoided if possible). We could, if we wished,
|
||||
define our own hash lens that accepts a default value:
|
||||
|
||||
@(define ref-default-eval (make-lens-eval))
|
||||
@(interaction #:eval ref-default-eval
|
||||
(define (hash-ref-lens/default key failure-result)
|
||||
(make-lens (λ (h) (hash-ref h key failure-result))
|
||||
(λ (h v) (hash-set h key v)))))
|
||||
|
||||
With this custom, “naughty” lens, we can actually perform the example from above:
|
||||
|
||||
@(interaction #:eval ref-default-eval
|
||||
(let ([l (hash-ref-lens/default 'not-a-key "default")]
|
||||
[h (hash)])
|
||||
(lens-set l h (lens-view l h))))
|
||||
|
||||
In addition to @racket[hash-ref-lens], @racket[hash-ref-nested-lens] is provided, which assists in
|
||||
fetching values from nested hashes. It is defined in terms of @racket[hash-ref-lens] and
|
||||
@racket[lens-compose], so it is just a shorter way of expressing the same concept:
|
||||
|
||||
@(lens-interaction
|
||||
(lens-set (hash-ref-nested-lens 'a 'b 'c)
|
||||
(hash 'a (hash 'b (hash 'c "foo")))
|
||||
"bar"))
|
||||
|
||||
@section[#:tag "dict-guide"]{Dictionaries}
|
||||
|
||||
@see-reference-note["dict-reference"]{dictionary lenses}
|
||||
|
||||
Racket @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{dictionaries} provide a generic
|
||||
interface for many kinds of key-value data-structures. They encompass hash tables, association lists,
|
||||
user-defined dictionaries, and even integer-keyed structures like vectors.
|
||||
|
||||
In practice, dictionary lenses work identically to lenses on hashes. The @racket[dict-ref-lens]
|
||||
lens constructor creates a lens with a view that is the value associated with the lens's key.
|
||||
|
||||
@(lens-interaction
|
||||
(lens-transform (dict-ref-lens 'b)
|
||||
'((a . 1)
|
||||
(b . 2))
|
||||
(λ (x) (* x 2))))
|
||||
|
|
@ -1,108 +0,0 @@
|
|||
|
||||
#lang scribble/manual
|
||||
|
||||
@(require scribble/eval
|
||||
lens/private/doc-util/main)
|
||||
|
||||
@(define make-lens-eval
|
||||
(make-eval-factory '(racket/base racket/function racket/list racket/stream lens)))
|
||||
|
||||
@(define-syntax-rule (lens-interaction expr ...)
|
||||
(interaction #:eval (make-lens-eval) expr ...))
|
||||
|
||||
@title[#:tag "ordered-data-lenses"]{Lenses on Ordered Data}
|
||||
|
||||
Many Racket data structures hold @emph{ordered} or @emph{sequential} values. Lenses for accessing
|
||||
elements of these structures by index are provided.
|
||||
|
||||
@section[#:tag "pair-list-guide" #:style 'quiet]{Pairs and Lists}
|
||||
|
||||
@see-reference-note["pair-list-reference"]{pair and list lenses}
|
||||
|
||||
The two primitive pair lenses are @racket[car-lens] and @racket[cdr-lens]:
|
||||
|
||||
@(lens-interaction
|
||||
(lens-transform car-lens '(1 . 2) (curry * 2))
|
||||
(lens-transform cdr-lens '(1 . 2) (curry * 2)))
|
||||
|
||||
Obviously, these also work with lists, but most of the time, it's easier to use list-specific lenses.
|
||||
For arbitrary access to elements within a list, use the @racket[list-ref-lens] lens constructor, which
|
||||
produces a new lens given an index to look up. Abbreviation lenses such as @racket[first-lens] and
|
||||
@racket[second-lens] are provided for common use-cases:
|
||||
|
||||
@(lens-interaction
|
||||
(lens-transform (list-ref-lens 3) (range 10) sub1)
|
||||
(lens-transform third-lens (range 10) sub1))
|
||||
|
||||
This is useful, but it only works for flat lists. However, using lens composition, it is possible to
|
||||
create a lens that performs indexed lookups for nested lists using only @racket[list-ref-lens]:
|
||||
|
||||
@(lens-interaction
|
||||
(define (2d-list-ref-lens x y)
|
||||
(lens-compose (list-ref-lens x)
|
||||
(list-ref-lens y)))
|
||||
(lens-set (2d-list-ref-lens 1 2)
|
||||
'((1 2 3)
|
||||
(4 5 6)
|
||||
(7 8 9))
|
||||
0))
|
||||
|
||||
This can also be generalized to @emph{n}-dimensional lists:
|
||||
|
||||
@(lens-interaction
|
||||
(define (list-ref-lens* . indices)
|
||||
(apply lens-compose (map list-ref-lens indices)))
|
||||
(lens-set (list-ref-lens* 0 1 0)
|
||||
'(((a b) (c d))
|
||||
((e f) (g h)))
|
||||
'z))
|
||||
|
||||
This function is actually provided by @racketmodname[lens] under the name
|
||||
@racket[list-ref-nested-lens], but the above example demonstrates that it's really a derived concept.
|
||||
|
||||
@subsection{Fetching multiple list values at once}
|
||||
|
||||
Sometimes it can be useful to fetch multiple values from a list with a single lens. This can be done
|
||||
with @racket[lens-join/list], which combines multiple lenses whose target is a single value and
|
||||
produces a new lens whose view is all of those values.
|
||||
|
||||
@(lens-interaction
|
||||
(define first-two-lens (lens-join/list first-lens second-lens))
|
||||
(lens-view first-two-lens '(1 2 3 4))
|
||||
(lens-set first-two-lens '(1 2 3 4) '(a b))
|
||||
(lens-transform first-two-lens '(1 2 3 4) (curry map sub1)))
|
||||
|
||||
This can be useful to implement a form of information hiding, in which only a portion of a list is
|
||||
provided to client code, but the result can still be used to update the original list.
|
||||
|
||||
@section[#:tag "vectors-strings-guide"]{Vectors and Strings}
|
||||
|
||||
@other-reference-note{
|
||||
The @secref["vectors-reference"] and @secref["strings-reference"] sections in The Lens Reference
|
||||
have additional information on vector and string lenses, respectively.}
|
||||
|
||||
Lenses for random-access retrieval and functional update on vectors and strings are similar to the
|
||||
lenses provided for lists, but unlike lists, they are truly random-access. The
|
||||
@racket[vector-ref-lens] and @racket[string-ref-lens] lens constructors produce random-access lenses,
|
||||
and @racket[lens-join/vector] and @racket[lens-join/string] combine multiple lenses with vector or
|
||||
string targets.
|
||||
|
||||
@(lens-interaction
|
||||
(lens-transform (vector-ref-lens 1) #("a" "b" "c") string->symbol)
|
||||
(lens-transform (string-ref-lens 3) "Hello!" char-upcase))
|
||||
|
||||
@section[#:tag "streams-guide"]{Streams}
|
||||
|
||||
@see-reference-note["streams-reference"]{stream lenses}
|
||||
|
||||
Racket's @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{streams} contain ordered data,
|
||||
much like lists, but unlike lists, they are @emph{lazy}. Lenses on streams are similarly lazy, only
|
||||
forcing the stream up to what is necessary. This allows stream lenses to successfully operate on
|
||||
infinite streams.
|
||||
|
||||
@(lens-interaction
|
||||
(lens-view (stream-ref-lens 10)
|
||||
(stream-map (curry expt 2) (in-naturals))))
|
||||
|
||||
Keep in mind that since @racket[lens-transform] is strict, using it to update a value within a stream
|
||||
will force the stream up to the position of the element being modified.
|
||||
|
|
@ -1,135 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require scribble/eval
|
||||
lens/private/doc-util/main)
|
||||
|
||||
@(define introduction-eval ((make-eval-factory '(racket/base lens))))
|
||||
|
||||
@title[#:tag "lens-intro"]{Introduction to Lenses}
|
||||
|
||||
The @racketmodname[lens] library defines @lens-tech{lenses}, tools for extracting values from
|
||||
potentially-nested data structures. Lenses are most useful when writing in a functional style, such as
|
||||
the style employed by @italic{How to Design Programs}, in which data structures are immutable and
|
||||
side-effects are kept to a minimum.
|
||||
|
||||
@section{What are lenses?}
|
||||
|
||||
A @deftech[#:key "lens" #:normalize? #f]{lens} is a value that composes a getter and a setter function
|
||||
to produce a bidirectional view into a data structure. This definition is intentionally broad---lenses
|
||||
are a very general concept, and they can be applied to almost any kind of value that encapsulates
|
||||
data. To make the concept more concrete, consider one of Racket's most primitive datatypes, the
|
||||
@tech[#:doc '(lib "scribblings/guide/guide.scrbl")]{pair}. Pairs are constructed from two values using
|
||||
the @racket[cons] function; the first value can then be retrieved using @racket[car], and the second
|
||||
can be retrieved using @racket[cdr].
|
||||
|
||||
@(interaction
|
||||
(define p (cons 1 2))
|
||||
p
|
||||
(car p)
|
||||
(cdr p))
|
||||
|
||||
With these three primitives, it's very easy to create new pairs and subsequently extract values from
|
||||
them. However, it's a little bit harder to update a single field in an existing pair. In a traditional
|
||||
Scheme, this could be accomplished by using @racket[set-car!] or @racket[set-cdr!], but these
|
||||
@emph{mutate} the original pair. To remain functional, we want to produce an @emph{entirely new} pair
|
||||
with one of the fields updated.
|
||||
|
||||
Fortunately, this is quite easy to implement in Racket:
|
||||
|
||||
@(interaction #:eval introduction-eval
|
||||
(define (set-car p v)
|
||||
(cons v (cdr p)))
|
||||
(define (set-cdr p v)
|
||||
(cons (car p) v))
|
||||
(set-car (cons 1 2) 'x)
|
||||
(set-cdr (cons 1 2) 'y))
|
||||
|
||||
@other-reference-note{
|
||||
Both @racket[car-lens] and @racket[cdr-lens], are provided by @racketmodname[lens] out of the box,
|
||||
along with some other shorthand lenses. For the full list, see @secref{pair-lenses}.}
|
||||
|
||||
This means that each field now has a pair of getters and setters: @racket[car]/@racket[set-car] and
|
||||
@racket[cdr]/@racket[set-cdr]. A lens just wraps up each of these pairs of functions into a single
|
||||
value, so instead of having four functions, we would just have two lenses: @racket[car-lens] and
|
||||
@racket[cdr-lens]. In fact, using the functions we've just written, we can implement these lenses
|
||||
ourselves.
|
||||
|
||||
@(interaction #:eval introduction-eval
|
||||
(define car-lens (make-lens car set-car))
|
||||
(define cdr-lens (make-lens cdr set-cdr)))
|
||||
|
||||
To use a lens's getter function, use @racket[lens-view]. To use the setter function, use
|
||||
@racket[lens-set]:
|
||||
|
||||
@(interaction #:eval introduction-eval
|
||||
(lens-view car-lens (cons 1 2))
|
||||
(lens-set car-lens (cons 1 2) 'x))
|
||||
|
||||
This, of course, isn't very useful, since we could just use the functions on their own. One extra
|
||||
thing we @emph{do} get for free when using lenses is @racket[lens-transform]. This allows you to
|
||||
provide a procedure which will update the “view” based on its existing value. For example, we could
|
||||
increment one element in a pair:
|
||||
|
||||
@(interaction #:eval introduction-eval
|
||||
(lens-transform cdr-lens (cons 1 2) add1))
|
||||
|
||||
While that's kind of cool, it still probably isn't enough to justify using lenses instead of just
|
||||
using functions.
|
||||
|
||||
@section[#:style 'quiet]{Why use lenses?}
|
||||
|
||||
So far, lenses just seem like a way to group getters and setters, and as we've seen, that's really all
|
||||
they are. However, on their own, this wouldn't be very useful. Using @racket[(car _p)] is a lot easier
|
||||
than using @racket[(lens-view car-lens _p)].
|
||||
|
||||
Using plain functions starts to get a lot harder, though, once you start nesting data structures. For
|
||||
example, consider a tree constructed by nesting pairs inside of pairs:
|
||||
|
||||
@(interaction #:eval introduction-eval
|
||||
(define tree (cons (cons 'a 'b)
|
||||
(cons 'c 'd))))
|
||||
|
||||
Now, getting at a nested value gets much harder. It's necessary to nest calls to get at the right
|
||||
value:
|
||||
|
||||
@(interaction #:eval introduction-eval
|
||||
(cdr (car tree)))
|
||||
|
||||
Still, this isn't too bad. However, what if we want to @emph{set} a value? We could use our
|
||||
@racket[set-car] and @racket[set-cdr] functions from earlier, but if we try, we'll find they don't
|
||||
work quite right:
|
||||
|
||||
@(interaction #:eval introduction-eval
|
||||
(set-cdr (car tree) 'x))
|
||||
|
||||
Oops. We wanted to get back the whole tree, but we just got back one of the internal nodes because
|
||||
we used @racket[set-cdr] on that node. In order to actually do what we want, we'd need to add a lot
|
||||
more complexity:
|
||||
|
||||
@(interaction #:eval introduction-eval
|
||||
(set-car tree (set-cdr (car tree) 'x)))
|
||||
|
||||
That's what we need to do just for @emph{one} level of nesting---it would be much worse for any more
|
||||
than that. How can we solve it?
|
||||
|
||||
@subsection{Lens composition}
|
||||
|
||||
@other-reference-note{For more ways to construct compound lenses, see @secref{composing-lenses}.}
|
||||
|
||||
In order to solve this problem, we can use @emph{lens composition}, which is similar to function
|
||||
composition but extended to lenses. Just as we can create a compound getter function with the
|
||||
expression @racket[(compose cdr car)], we can create a compound lens with the expression
|
||||
@racket[(lens-compose cdr-lens car-lens)]. With this, we produce an entirely new lens that can be used
|
||||
with @racket[lens-view], @racket[lens-set], and @racket[lens-transform], all of which do what you
|
||||
would expect:
|
||||
|
||||
@(interaction #:eval introduction-eval
|
||||
(define cdar-lens (lens-compose cdr-lens car-lens))
|
||||
(lens-view cdar-lens tree)
|
||||
(lens-set cdar-lens tree 'x)
|
||||
(lens-transform cdar-lens tree symbol->string))
|
||||
|
||||
Now the reason lenses are useful may begin to crystallize: they make it possible to not just get at
|
||||
but to actually functionally update and transform values within deeply-nested data structures. Since
|
||||
they are composable, it is easy to create lenses that can traverse any set of structures with nothing
|
||||
but a small set of primitives. This library provides those primitives.
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@title[#:tag "user-defined-lenses" #:style 'toc]{Lenses on User-Defined Datatypes}
|
||||
|
||||
In addition to the built-in lenses, @racketmodname[lens] provides utilities for construcing new lenses
|
||||
for user-defined datatypes. This section covers the utilities for creating lenses for Racket structs,
|
||||
as well as the general lens constructors for making arbitrary lenses.
|
||||
|
||||
@local-table-of-contents[]
|
||||
|
||||
@include-section["user-defined/struct.scrbl"]
|
||||
@include-section["user-defined/custom.scrbl"]
|
||||
|
|
@ -1,49 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require scribble/eval
|
||||
lens/private/doc-util/main)
|
||||
|
||||
@(define make-lens-eval
|
||||
(make-eval-factory '(racket/base lens)))
|
||||
@(define-syntax-rule (lens-interaction expr ...)
|
||||
(interaction #:eval (make-lens-eval) expr ...))
|
||||
|
||||
@(define construct-eval (make-lens-eval))
|
||||
@(define-syntax-rule (construct-interaction expr ...)
|
||||
(interaction #:eval construct-eval expr ...))
|
||||
|
||||
@title[#:tag "construction-guide"]{Constructing Entirely New Lenses}
|
||||
|
||||
Sometimes the existing set of lenses isn't enough. Perhaps you have a particularly unique data
|
||||
structure, and you want to create a lens for it. Perhaps you just want to provide lenses for your
|
||||
custom data structures, and struct lenses are insufficient. In that case, it's always possible to
|
||||
fall back on the primitive lens constructor, @racket[make-lens].
|
||||
|
||||
The @racket[make-lens] constructor is simple---it creates a new lens from a getter function and a
|
||||
(functional) setter function. That's it. A lens is nothing more than that.
|
||||
|
||||
As an example, it would actually be possible to implement lenses for complex numbers: one lens for the
|
||||
real part and a second lens for the imaginary part. Implementing these lenses is fairly simple---we
|
||||
just need to write getters and setters for each portion of the number:
|
||||
|
||||
@(construct-interaction
|
||||
(define real-lens
|
||||
(make-lens real-part
|
||||
(λ (n r) (make-rectangular (real-part r) (imag-part n)))))
|
||||
(define imag-lens
|
||||
(make-lens imag-part
|
||||
(λ (n i) (make-rectangular (real-part n) (real-part i))))))
|
||||
|
||||
In this case, Racket already provides the getters for us: @racket[real-part] and @racket[imag-part].
|
||||
We need to implement the setters ourselves, which we can do using @racket[make-rectangular]. Now we
|
||||
can actually do math on separate components of numbers using @racket[lens-transform]:
|
||||
|
||||
@(construct-interaction
|
||||
(lens-transform real-lens 2+3i (λ (x) (* x 2)))
|
||||
(lens-transform imag-lens 2+3i (λ (x) (* x 2))))
|
||||
|
||||
When creating a lens with @racket[make-lens], it's important to make sure it also follows the
|
||||
@seclink["laws"]{lens laws}. These are simple requirements to ensure that your custom lens behaves
|
||||
intuitively. Lenses that do @emph{not} adhere to these laws will most likely cause unexpected
|
||||
behavior. However, as long as your lens plays by the rules, it will automatically work with all the
|
||||
other lens functions, including lens combinators like @racket[lens-compose].
|
||||
|
|
@ -1,75 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require scribble/eval
|
||||
lens/private/doc-util/main)
|
||||
|
||||
@(define make-lens-eval
|
||||
(make-eval-factory '(racket/base lens)))
|
||||
@(define-syntax-rule (lens-interaction expr ...)
|
||||
(interaction #:eval (make-lens-eval) expr ...))
|
||||
|
||||
@(define struct-eval (make-lens-eval))
|
||||
@(define-syntax-rule (struct-interaction expr ...)
|
||||
(interaction #:eval struct-eval expr ...))
|
||||
|
||||
@title[#:tag "struct-guide"]{Structures}
|
||||
|
||||
@see-reference-note["struct-reference"]{struct lenses}
|
||||
|
||||
Racket's structure system is an extremely useful tool to help model your problem domain, but using
|
||||
them in a functional style can be laborious. To make this easier, @racketmodname[lens] provides helper
|
||||
macros to automatically generate lenses for structure fields, which can be composed just like any
|
||||
other lenses to allow easy functional programming with nested structs.
|
||||
|
||||
To start using lenses with structs, use the @racket[struct/lens] form when defining a structure
|
||||
instead of @racket[struct]:
|
||||
|
||||
@(struct-interaction
|
||||
(struct/lens point (x y) #:transparent))
|
||||
|
||||
This will define a struct called @racket[point], and it will also produce two lenses,
|
||||
@racket[point-x-lens] and @racket[point-y-lens]. It's also possible to define lenses for an
|
||||
@emph{existing} structure type using @racket[define-struct-lenses].
|
||||
|
||||
@(lens-interaction
|
||||
(struct point (x y) #:transparent)
|
||||
(define-struct-lenses point))
|
||||
|
||||
If you don't want to use the auto-definition behavior of @racket[struct/lens] or
|
||||
@racket[define-struct-lenses], you can also use @racket[struct-lens] to create one-off lenses for
|
||||
particular fields.
|
||||
|
||||
@(lens-interaction
|
||||
(struct point (x y) #:transparent)
|
||||
(struct-lens point x))
|
||||
|
||||
One created, structure lenses work just like any other lenses: they can be used with functions like
|
||||
@racket[lens-view], @racket[lens-set], and @racket[lens-transform], and they can be composed with
|
||||
other lenses to produce new ones.
|
||||
|
||||
@(struct-interaction
|
||||
(lens-view point-x-lens (point 4 10))
|
||||
(lens-set point-y-lens (point 4 10) 15)
|
||||
(lens-transform point-x-lens (point 4 10)
|
||||
(λ (x) (* x 3))))
|
||||
|
||||
Composition of struct lenses can make it much easier to write purely functional state transformations,
|
||||
such as the “world programs” of @italic{How to Design Programs}. For example, given some state:
|
||||
|
||||
@(struct-interaction
|
||||
(struct/lens world (play-time player-stats) #:transparent)
|
||||
(struct/lens player-stats (health attack) #:transparent)
|
||||
(struct/lens monster (attack) #:transparent))
|
||||
|
||||
It's possible to write updater functions that manipulate nested state without completely destructuring
|
||||
and rebuilding the structure each time:
|
||||
|
||||
@(struct-interaction
|
||||
(define (perform-monster-attack world monster)
|
||||
(lens-transform (lens-compose player-stats-health-lens
|
||||
world-player-stats-lens)
|
||||
world
|
||||
(λ (hp) (- hp (monster-attack monster)))))
|
||||
(let ([w (world 0 (player-stats 15 6))]
|
||||
[m (monster 2)])
|
||||
(perform-monster-attack w m)))
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@title[#:tag "lens-reference"]{The Lens Reference}
|
||||
|
||||
@local-table-of-contents[]
|
||||
|
||||
@include-section["reference/common.scrbl"]
|
||||
@include-section["reference/data.scrbl"]
|
||||
@include-section["../../applicable.scrbl"]
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@title[#:tag "lens-common-reference"]{Lens Operations}
|
||||
|
||||
@defmodule[lens/common]{
|
||||
Provides core lens functions and other non-data-specific lens
|
||||
operations.
|
||||
}
|
||||
|
||||
@include-section[(lib "lens/private/base/main.scrbl")]
|
||||
@include-section[(lib "lens/private/compound/main.scrbl")]
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@title[#:tag "lens-data-reference"]{Lenses for different types of data}
|
||||
|
||||
@defmodule[lens/data]{
|
||||
Provides lenses and lens operations for different types of data, such
|
||||
as lists and structs.
|
||||
}
|
||||
|
||||
@include-section["../../list/main.scrbl"]
|
||||
@include-section["../../hash/main.scrbl"]
|
||||
@include-section["../../struct/main.scrbl"]
|
||||
@include-section["../../vector/main.scrbl"]
|
||||
@include-section["../../string/main.scrbl"]
|
||||
@include-section["../../stream/stream.scrbl"]
|
||||
@include-section["../../dict/dict.scrbl"]
|
||||
|
|
@ -1,10 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require "../doc-util/scribble-include-no-subsection.rkt")
|
||||
|
||||
@title[#:tag "strings-reference"]{String Lenses}
|
||||
|
||||
@defmodule[lens/data/string]
|
||||
|
||||
@scribble-include/no-subsection["string.scrbl"]
|
||||
@scribble-include/no-subsection["join-string.scrbl"]
|
||||
|
|
@ -1,13 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main
|
||||
lens/private/doc-util/scribble-include-no-subsection)
|
||||
|
||||
@title[#:tag "struct-reference"]{Struct Lenses}
|
||||
|
||||
@defmodule[lens/data/struct]
|
||||
|
||||
@see-guide-note["struct-guide"]{struct lenses}
|
||||
|
||||
@scribble-include/no-subsection["field.scrbl"]
|
||||
@scribble-include/no-subsection["struct.scrbl"]
|
||||
|
|
@ -1,82 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main (for-label syntax/srcloc))
|
||||
|
||||
@title{Syntax object source locations}
|
||||
|
||||
@defthing[syntax-srcloc-lens (lens/c syntax? srcloc?)]{
|
||||
A lens that views the source location of a syntax object as a
|
||||
@racket[srcloc] structure.
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view syntax-srcloc-lens #'here)
|
||||
(lens-set syntax-srcloc-lens #'here (srcloc "a.rkt" 5 8 55 13))
|
||||
(syntax-source (lens-set syntax-srcloc-lens #'here (srcloc "a.rkt" 5 8 55 13)))
|
||||
(syntax-position (lens-set syntax-srcloc-lens #'here (srcloc "a.rkt" 5 8 55 13)))
|
||||
]}
|
||||
|
||||
@defthing[syntax-source-lens (lens/c syntax? any/c)]{
|
||||
A lens that views the source field of a syntax object.
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view syntax-source-lens #'here)
|
||||
(lens-set syntax-source-lens #'here "a.rkt")
|
||||
(syntax-source (lens-set syntax-source-lens #'here "a.rkt"))
|
||||
]}
|
||||
|
||||
@defthing[syntax-line-lens (lens/c syntax? (or/c exact-positive-integer? #f))]{
|
||||
A lens that views the line number of a syntax object.
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view syntax-line-lens #'here)
|
||||
(lens-set syntax-line-lens #'here 8)
|
||||
(syntax-line (lens-set syntax-line-lens #'here 8))
|
||||
]}
|
||||
|
||||
@defthing[syntax-column-lens (lens/c syntax? (or/c exact-nonnegative-integer? #f))]{
|
||||
A lens that views the column number of a syntax object within its line.
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view syntax-column-lens #'here)
|
||||
(lens-set syntax-column-lens #'here 13)
|
||||
(syntax-column (lens-set syntax-column-lens #'here 13))
|
||||
]}
|
||||
|
||||
@defthing[syntax-position-lens (lens/c syntax? (or/c exact-positive-integer? #f))]{
|
||||
A lens that views the source position a syntax object.
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view syntax-position-lens #'here)
|
||||
(lens-set syntax-position-lens #'here 21)
|
||||
(syntax-position (lens-set syntax-position-lens #'here 21))
|
||||
]}
|
||||
|
||||
@defthing[syntax-span-lens (lens/c syntax? (or/c exact-nonnegative-integer? #f))]{
|
||||
A lens that views the source span a syntax object.
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view syntax-span-lens #'here)
|
||||
(lens-set syntax-span-lens #'here 34)
|
||||
(syntax-span (lens-set syntax-span-lens #'here 34))
|
||||
]}
|
||||
|
||||
@deftogether[[
|
||||
@defthing[source-location->srcloc-lens (lens/c source-location? srcloc?)]
|
||||
@defthing[source-location->list-lens (lens/c source-location? source-location-list?)]
|
||||
@defthing[source-location->vector-lens (lens/c source-location? source-location-vector?)]
|
||||
]]{
|
||||
Lenses for converting from all the common types of source locations
|
||||
into @racket[srcloc] structures, lists, and vectors.
|
||||
}
|
||||
|
||||
@deftogether[[
|
||||
@defthing[source-location-source-lens (lens/c source-location? any/c)]
|
||||
@defthing[source-location-line-lens (lens/c source-location? (or/c exact-positive-integer? #f))]
|
||||
@defthing[source-location-column-lens (lens/c source-location? (or/c exact-nonnegative-integer? #f))]
|
||||
@defthing[source-location-position-lens (lens/c source-location? (or/c exact-positive-integer? #f))]
|
||||
@defthing[source-location-span-lens (lens/c source-location? (or/c exact-nonnegative-integer? #f))]
|
||||
]]{
|
||||
Like @racket[syntax-source-lens], @racket[syntax-line-lens], etc, but for all
|
||||
the common types of source locations.
|
||||
}
|
||||
|
||||
|
|
@ -1,97 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/main (for-label syntax/stx))
|
||||
|
||||
@title{Syntax object lenses based on @racketmodname[syntax/stx]}
|
||||
|
||||
@defthing[stx->list-lens lens?]{
|
||||
A lens that views a stx-list as a list. Viewing with this lens is
|
||||
equivalent to using @racket[stx->list], and if the target is a syntax
|
||||
object, setting it with this lens preserves the lexical context,
|
||||
source location, and syntax properties of the outer syntax object.
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view stx->list-lens #'(a b c))
|
||||
(lens-set stx->list-lens #'(a b c) '(1 2 3))
|
||||
]}
|
||||
|
||||
@defproc[(stx-map-lens [lens lens?]) lens?]{
|
||||
Creates a lens that maps @racket[lens] over a target stx-list. Like
|
||||
@racket[stx->list-lens], setting with a syntax object target preserves
|
||||
lexical context, location, and properties.
|
||||
|
||||
This is the syntax version of @racket[map-lens].
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view (stx-map-lens stx-car-lens) #'((a b) (c d) (e f)))
|
||||
(lens-set (stx-map-lens stx-car-lens) #'((a b) (c d) (e f)) #'(1 2 3))
|
||||
]}
|
||||
|
||||
@deftogether[[
|
||||
@defthing[stx-car-lens lens?]
|
||||
@defthing[stx-cdr-lens lens?]
|
||||
]]{
|
||||
Lenses for looking at the car and cdr of syntax-pairs.
|
||||
|
||||
These are the syntax versions of @racket[car-lens] and @racket[cdr-lens].
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view stx-car-lens #'(a . b))
|
||||
(lens-view stx-cdr-lens #'(a . b))
|
||||
(lens-set stx-car-lens #'(a . b) #'1)
|
||||
(lens-set stx-cdr-lens #'(a . b) #'1)
|
||||
]}
|
||||
|
||||
@deftogether[[
|
||||
@defthing[stx-caar-lens lens?]
|
||||
@defthing[stx-cdar-lens lens?]
|
||||
@defthing[stx-cadr-lens lens?]
|
||||
@defthing[stx-cddr-lens lens?]
|
||||
@defthing[stx-caaar-lens lens?]
|
||||
@defthing[stx-cdaar-lens lens?]
|
||||
@defthing[stx-cadar-lens lens?]
|
||||
@defthing[stx-cddar-lens lens?]
|
||||
@defthing[stx-caadr-lens lens?]
|
||||
@defthing[stx-cdadr-lens lens?]
|
||||
@defthing[stx-caddr-lens lens?]
|
||||
@defthing[stx-cdddr-lens lens?]
|
||||
]]{
|
||||
Lenses for accessing nested syntax-pairs.
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view stx-caddr-lens #'(a b c d))
|
||||
(lens-set stx-caddr-lens #'(a b c d) #'1)
|
||||
]}
|
||||
|
||||
@defthing[stx-append*-lens lens?]{
|
||||
A lens like that flattens a stx-list one-level down when viewing, and
|
||||
restores the original structure when setting.
|
||||
|
||||
This is the syntax version of @racket[append*-lens].
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view stx-append*-lens #'((a) (b c) () (d e f)))
|
||||
(lens-set stx-append*-lens #'((a) (b c) () (d e f)) #'(1 2 3 4 5 6))
|
||||
]}
|
||||
|
||||
@defproc[(stx-flatten/depth-lens [n exact-nonnegative-integer?]) lens?]{
|
||||
Creates a lens that flattens a stx-list of depth @racket[n] when
|
||||
viewing, and restores the original structure when setting.
|
||||
|
||||
This is the syntax version of @racket[flatten/depth-lens].
|
||||
|
||||
@lens-unstable-examples[
|
||||
(lens-view (stx-flatten/depth-lens 0) #'42)
|
||||
(lens-set (stx-flatten/depth-lens 0) #'42 #'(43))
|
||||
(lens-view (stx-flatten/depth-lens 1) #'(a b c))
|
||||
(lens-set (stx-flatten/depth-lens 1) #'(a b c) #'(1 2 3))
|
||||
(lens-view (stx-flatten/depth-lens 2) #'((a) (b c) () (d e f)))
|
||||
(lens-set (stx-flatten/depth-lens 2) #'((a) (b c) () (d e f)) #'(1 2 3 4 5 6))
|
||||
(lens-view (stx-flatten/depth-lens 3) #'(((a) ()) (() (b) (c)) () ((d e) () (f))))
|
||||
(lens-set (stx-flatten/depth-lens 3) #'(((a) ()) (() (b) (c)) () ((d e) () (f))) #'(1 2 3 4 5 6))
|
||||
]}
|
||||
|
||||
@defproc[(stx-append*n-lens [n exact-nonnegative-integer?]) lens?]{
|
||||
This is deprecated. Use @racket[(stx-flatten/depth-lens (add1 n))] instead.
|
||||
}
|
||||
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang scribble/manual
|
||||
|
||||
@(require lens/private/doc-util/scribble-include-no-subsection)
|
||||
|
||||
@title[#:tag "vectors-reference"]{Vector lenses}
|
||||
|
||||
@defmodule[lens/data/vector]
|
||||
|
||||
@scribble-include/no-subsection["ref.scrbl"]
|
||||
@scribble-include/no-subsection["nested.scrbl"]
|
||||
@scribble-include/no-subsection["pick.scrbl"]
|
||||
@scribble-include/no-subsection["join-vector.scrbl"]
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user