suzanne.soy/lens
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #30 from jackfirth/non-applicable-#14

Browse Source 
Non applicable #14, closes #26
This commit is contained in:
Jack Firth 2015-07-05 18:35:14 -07:00
commit 01864e7b9c
14 changed files with 236 additions and 296 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
lenses/applicable.rkt
View File

@ -1,42 +1,15 @@
#lang racket/base
#lang racket
(provide (all-defined-out)
lens/c let-lens lens-view lens-set lens-transform lens-struct lens-proc)
(provide (all-from-out "main.rkt"))
(require (prefix-in - "main.rkt")
(only-in "main.rkt"
lens/c let-lens lens-view lens-set lens-transform lens-struct lens-proc))
(require "main.rkt"
(only-in "core/base.rkt" use-applicable-lenses!))
(define (make-lens getter setter)
(lens-struct (-make-lens getter setter)))
(module+ test
(require rackunit))
(define (lens-compose . args)
(lens-struct (apply -lens-compose args)))
(define identity-lens
(lens-struct -identity-lens))
(define (list-lens n)
(lens-struct (-list-lens n)))
(define first-lens (lens-struct -first-lens))
(define second-lens (lens-struct -second-lens))
(define third-lens (lens-struct -third-lens))
(define fourth-lens (lens-struct -fourth-lens))
(define fifth-lens (lens-struct -fifth-lens))
(define (assoc-lens key #:is-equal? [key-equal? equal?])
(lens-struct (-assoc-lens key #:is-equal? key-equal?)))
(define (assv-lens key)
(lens-struct (-assv-lens key)))
(define (assq-lens key)
(lens-struct (-assq-lens key)))
(define-syntax-rule (syntax-lens target-id pattern)
(lens-struct (-syntax-lens target-id pattern)))
(define-syntax-rule (syntax-keyword-seq-lens kw)
(lens-struct (-syntax-keyword-seq-lens kw)))
(use-applicable-lenses!)
(module+ test
(check-equal? (first-lens '(a b c)) 'a))

54
lenses/core/base.rkt
View File

@ -7,49 +7,45 @@
(provide let-lens
make-lens
lens-proc
(struct-out lens-struct))
apply-lens
use-applicable-lenses!
(rename-out [lens-struct? lens?]))
(define lens-2-val-context-key
(make-continuation-mark-key 'lens-2-val-context-key))
(define lens-app-context? (make-parameter #f))
(define-syntax-rule (let/immediate-mark [val-id key-expr] body-expr ...)
(call-with-immediate-continuation-mark key-expr (lambda (val-id) body-expr ...)))
(define (use-applicable-lenses!)
(lens-app-context? #t))
(define (first-value v _) v)
(struct lens-struct (proc)
(struct lens-struct (get set)
#:property prop:procedure
(lambda (this target)
(let/immediate-mark [lens-2-val-context? lens-2-val-context-key]
(if lens-2-val-context?
((lens-struct-proc this) target)
(call-with-values (thunk ((lens-struct-proc this) target))
first-value)))))
(if (lens-app-context?)
((lens-struct-get this) target)
(error "cannot apply a non-applicable lens as a function"))))
(define (lens-proc lns)
(match lns
[(lens-struct proc) proc]
[(? procedure? proc) proc]))
(define ((make-lens getter setter) v)
(values (getter v)
(setter v _))) ; fancy-app
(module+ test
(require rackunit)
(check-exn exn:fail? (thunk (first-lens '(a b c)))))
(define-syntax-rule (let-lens (view setter) lens-call-expr body ...)
(let-values ([(view setter) (with-continuation-mark lens-2-val-context-key #t
lens-call-expr)])
(define (make-lens getter setter)
(lens-struct getter setter))
(define (apply-lens lens target)
(match-define (lens-struct get set) lens)
(values (get target)
(set target _)))
(define-syntax-rule (let-lens (view setter) lens-expr target-expr body ...)
(let-values ([(view setter) (apply-lens lens-expr target-expr)])
body ...))
(module+ test
(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))
(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))))

19
lenses/core/compose.rkt
View File

@ -2,21 +2,24 @@
(require fancy-app
"base.rkt"
"view-set.rkt"
"identity.rkt")
(module+ test
(require rackunit
"view-set.rkt"))
(require rackunit))
(provide lens-compose
lens-thrush)
(define ((lens-compose2 sub-lens super-lens) v)
(let-lens (super-view super-setter) (super-lens v)
(let-lens (sub-view sub-setter) (sub-lens super-view)
(values sub-view
(compose super-setter sub-setter)))))
(define (lens-compose2 sub-lens super-lens)
(define (get target)
(lens-view sub-lens (lens-view super-lens target)))
(define (set target new-view)
(define sub-view (lens-view super-lens target))
(define new-sub-view (lens-set sub-lens sub-view new-view))
(lens-set super-lens target new-sub-view))
(make-lens get set))
(define lens-compose
@ -42,6 +45,6 @@
(module+ test
(define first-of-second-lens* (lens-thrush second-lens first-lens))
(let-lens [val ctxt] (first-of-second-lens* test-alist)
(let-lens [val ctxt] first-of-second-lens* test-alist
(check-equal? val 'b)
(check-equal? (ctxt 'B) '((a 1) (B 2) (c 3)))))

31
lenses/core/contract.rkt
View File

@ -1,31 +0,0 @@
#lang racket
(require unstable/contract
"base.rkt")
(module+ test
(require rackunit))
(provide lens/c
lens-proc/c)
(define (lens-proc/c input subcomponent)
(-> input
(values subcomponent
(-> subcomponent
input))))
(define (lens/c target/c view/c)
(define proc/c (lens-proc/c target/c view/c))
(if/c lens-struct?
(struct/c lens-struct proc/c)
proc/c))
(module+ test
(define list-lens/c (lens/c list? any/c))
(check-true (contract? list-lens/c))
(check-false (flat-contract? list-lens/c)))

6
lenses/core/identity.rkt
View File

@ -1,6 +1,6 @@
#lang racket
(require fancy-app)
(require "base.rkt")
(module+ test
(require rackunit
@ -9,8 +9,10 @@
(provide identity-lens)
(define (second-value _ v) v)
(define identity-lens
(values _ identity))
(make-lens identity second-value))
(module+ test

2
lenses/core/main.rkt
View File

@ -2,7 +2,6 @@
(require "base.rkt"
"view-set.rkt"
"contract.rkt"
"transform.rkt"
"identity.rkt"
"compose.rkt")
@ -11,7 +10,6 @@
(all-from-out
"base.rkt"
"view-set.rkt"
"contract.rkt"
"transform.rkt"
"identity.rkt"
"compose.rkt"))

2
lenses/core/transform.rkt
View File

@ -12,7 +12,7 @@
(define (lens-transform lens f v)
(let-lens (view setter) (lens v)
(let-lens (view setter) lens v
(setter (f view))))
(module+ test

4
lenses/core/view-set.rkt
View File

@ -11,11 +11,11 @@
(define (lens-view lens v)
(let-lens (view _) (lens v)
(let-lens (view _) lens v
view))
(define (lens-set lens v x)
(let-lens (_ setter) (lens v)
(let-lens (_ setter) lens v
(setter x)))
(define (lens-view* v . lenses)

19
lenses/hash.rkt
View File

@ -3,14 +3,15 @@
(provide hash-ref-lens)
(require fancy-app
"core/main.rkt"
)
"core/main.rkt")
(module+ test
(require rackunit))
(define ((hash-ref-lens1 key) hash)
(values (hash-ref hash key)
(hash-set hash key _))) ; fancy-app
(define (hash-ref-lens1 key)
(make-lens (hash-ref _ key)
(hash-set _ key _)))
(define (hash-ref-lens . keys)
(apply lens-thrush (map hash-ref-lens1 keys)))
@ -18,15 +19,13 @@
(module+ test
(define a (hash-ref-lens 'a))
(define a-x (hash-ref-lens 'a 'x))
(let-lens [val ctxt] (a (hash 'a 1 'b 2 'c 3))
(let-lens [val ctxt] a (hash 'a 1 'b 2 'c 3)
(check-equal? val 1)
(check-equal? (ctxt 100) (hash 'a 100 'b 2 'c 3)))
(check-equal? (lens-transform* (hash 'a 1 'b 2 'c 3) a (* 10 _))
(hash 'a 10 'b 2 'c 3))
(let-lens [val ctxt] (a-x (hash 'a (hash 'x 1 'y 2) 'b (hash 'z 3)))
(let-lens [val ctxt] a-x (hash 'a (hash 'x 1 'y 2) 'b (hash 'z 3))
(check-equal? val 1)
(check-equal? (ctxt 100) (hash 'a (hash 'x 100 'y 2) 'b (hash 'z 3))))
(check-equal? (lens-transform* (hash 'a (hash 'x 1 'y 2) 'b (hash 'z 3)) a-x (* 10 _))
(hash 'a (hash 'x 10 'y 2) 'b (hash 'z 3)))
)
(hash 'a (hash 'x 10 'y 2) 'b (hash 'z 3))))

171
lenses/lenses.scrbl
View File

@ -11,12 +11,18 @@
@(define-syntax-rule (lenses-examples datum ...)
(examples #:eval lenses-eval datum ...))
@(define lenses-applicable-eval (make-base-eval))
@(lenses-applicable-eval '(require "applicable.rkt"))
@(lenses-applicable-eval '(require racket/list))
@(define-syntax-rule (lenses-applicable-examples datum ...)
(examples #:eval lenses-applicable-eval datum ...))
@title{Lenses}
@defmodule[lenses]
This library includes functions and forms for working with @italic{lenses}.
A lens is a pure function that operates on some small piece of a larger
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.
@ -26,50 +32,18 @@ source code: @url["https://github.com/jackfirth/lenses"]
@section{Core Lens Forms}
@defproc[(lens/c [target/c contract?] [view/c contract?]) contract?]{
Contract constructor for lenses. A lens is either a function or
@racket[lens-struct] containing that function. The function takes one
value, its @italic{target}, and returns two values, a @italic{view}
and a @italic{context}. The context is a function that takes a new view
value and "replaces" the old view value with the new value, giving a
modified target. Less technically, a lens is a way to analyze some
specific piece of a @racket[target/c] that is a @racket[view/c],
along with a way to replace that piece with a new view value. Lenses
deconstruct and reconstruct data by examinimg small portions of their
structure. In terms of contracts, @racket[(lens/c target/c view/c)]
checks the function with following function contract:
@racketblock[
(-> target/c
(values view/c
(-> view/c target/c)))
]
An example is the @racket[first-lens], which is a lens for examiniming
specifically the first item in a list:
@lenses-examples[
(define first-lens-proc (lens-proc first-lens))
(first-lens-proc '(1 2 3))
(let-values ([(_ context) (first-lens-proc '(1 2 3))])
(context 'a))
(let-lens (_ context) (first-lens '(1 2 3))
(context 'a))
]
Lenses that are instances of the lens struct can also be used directly
as getter procedures:
@lenses-examples[
(define first-lens* (lens-struct first-lens))
(first-lens* '(1 2 3))
(let-lens (fst context) (first-lens* '(1 2 3))
(values fst (context 'a)))
]
@defproc[(lens? [v any/c]) boolean?]{
Predicate for lenses.
}
@defproc[(make-lens [getter (-> target/c view/c)]
[setter (-> target/c view/c target/c)])
(lens/c target/c view/c)]{
Given a getter and a setter, constructs a lens. The setter must take
the new value to use second.
lens?]{
Given a getter and a setter, constructs a lens defined on values
satisfying @racket[target/c] and viewing values satisfying
@racket[view/c]. The getter must accept a target and return the
lens's view. The setter must accept a target and a new view, and
return a new target with its view replaced with the new view.
@lenses-examples[
(define (set-first lst v)
(list* v (rest lst)))
@ -79,32 +53,35 @@ source code: @url["https://github.com/jackfirth/lenses"]
(lens-set first-lens '(1 2 3) 'a)
]}
@defform[(let-lens (view-id context-id) lens-call-expr body ...)]{
Gets the two return values of a lens function and binds them to the
given identifiers within the body expressions.
@defform[(let-lens (view-id context-id) lens-expr target-expr body ...)]{
Gets a lens and a target, constructs the @italic{view} and the
@italic{context} of the target through the lens and binds them
to @racket[view-id] and @racket[context-id] respectively. The
@italic{context} is a function that accepts a new view and sets
the target's view to the new view. The context is conceptually
a function representing the "hole" formed by abstracting the view
of the target.
@lenses-examples[
(let-lens (view context) (first-lens '(1 2 3))
(let-lens (view context) first-lens '(1 2 3)
(printf "View is ~a\n" view)
(context 'a))
]}
@defproc[(lens-view [lens (lens/c target/c view/c)] [target target/c]) view/c]{
Extracts only the view of @racket[target] with @racket[lens], disregarding
the context. Essentially a getter function.
@defproc[(lens-view [lens lens?] [target target/c]) view/c]{
Extracts the view of @racket[target] with @racket[lens].
Essentially a getter function.
@lenses-examples[
(lens-view first-lens '(1 2 3))
]}
@defproc[(lens-set [lens (lens/c target/c view/c)] [target target/c] [new-view view/c]) target/c]{
Sets the view of @racket[target] to @racket[new-view] using @racket[lens].
Shorthand for getting the context of @racket[target] with @racket[lens],
then calling that context function with @racket[new-view]. Essentially
a setter function.
@defproc[(lens-set [lens lens?] [target target/c] [new-view view/c]) target/c]{
Sets the view of @racket[target] to @racket[new-view] using
@racket[lens]. Essentially a setter function.
@lenses-examples[
(lens-set first-lens '(1 2 3) 'a)
]}
@defproc[(lens-transform [lens (lens/c target/c view/c)]
@defproc[(lens-transform [lens lens?]
[transformer (-> view/c view/c)]
[target target/c])
target/c]{
@ -118,7 +95,7 @@ source code: @url["https://github.com/jackfirth/lenses"]
(lens-transform first-lens number->string '(1 2 3))
]}
@defproc[(lens-compose [lens proc] ...) lens?]{
@defproc[(lens-compose [lens lens?] ...) lens?]{
Composes the given lenses together into one @italic{compound lens}.
The compound lens operates similarly to composed functions do in
that the last @racket[lens] is the first @racket[lens] the compound
@ -130,15 +107,22 @@ source code: @url["https://github.com/jackfirth/lenses"]
(lens-set first-of-second-lens '((1 a) (2 b) (3 c)) 200)
]}
@defthing[identity-lens (lens/c any/c any/c)]{
The identity lens.
}
@defthing[identity-lens lens?]{
The identity lens. Performs no destructuring at all - it's view is
the target itself. For all lenses, both
@racket[(lens-compose lens identity-lens)] and
@racket[(lens-compose identity-lens lens)] are equivalent to
@racket[lens].
@lenses-examples[
(lens-view identity-lens 4)
(lens-set identity-lens 4 'a)
]}
@section{List lenses}
@defproc[(list-lens [n exact-nonnegative-integer?])
(lens/c list? any?)]{
Returns a lens for examining the @racket[n]th item of a list,
lens?]{
Returns a lens for viewing the @racket[n]th item of a list,
with indexing starting from zero.
@lenses-examples[
(lens-view (list-lens 3) '(a b c d e f g h))
@ -146,11 +130,16 @@ The identity lens.
]}
@deftogether[(
@defthing[first-lens (lens/c list? any/c)]
@defthing[second-lens (lens/c list? any/c)]
@defthing[third-lens (lens/c list? any/c)]
@defthing[fourth-lens (lens/c list? any/c)]
@defthing[fifth-lens (lens/c list? any/c)])]{
@defthing[first-lens lens?]
@defthing[second-lens lens?]
@defthing[third-lens lens?]
@defthing[fourth-lens lens?]
@defthing[fifth-lens lens?]
@defthing[sixth-lens lens?]
@defthing[seventh-lens lens?]
@defthing[eighth-lens lens?]
@defthing[ninth-lens lens?]
@defthing[tenth-lens lens?])]{
Lenses for examiniming specific items of lists. Shorthands
for the common use cases of @racket[list-lens].
@lenses-examples[
@ -160,29 +149,18 @@ The identity lens.
]}
@defproc[(assoc-lens [key any/c] [#:is-equal? key-equal? (-> any/c any/c any/c) equal?])
(lens/c (listof pair?) any/c)]{
lens?]{
Constructs a lens for examiniming association lists.
Specifically, for a given association list the returned
lens examines the second value of the first pair that
has a key that is @racket[key-equal?] to @racket[key].
@lenses-examples[
(define assoc-a-lens (assoc-lens 'a))
(define some-assoc-list '((a 1) (b 2) (c 3)))
(define some-assoc-list '((a . 1) (b . 2) (c . 3)))
(lens-view assoc-a-lens some-assoc-list)
(lens-set assoc-a-lens some-assoc-list 100)
]
If no key in the association list exists that is
@racket[key-equal?] to @racket[key], then attempting
to view an association list with the lens returns
@racket[#f] and setting a view appends a new pair
to the end of the association list
@lenses-examples[
(define assoc-d-lens (assoc-lens 'd))
(lens-view assoc-d-lens some-assoc-list)
(lens-set assoc-d-lens some-assoc-list 100)
]
The @racket[key-equal?] procedure is useful for
datatypes that have their own definition of
equality, such as strings.
@ -191,11 +169,11 @@ The identity lens.
(lens-view assoc-foo-lens '(("bar" 1) ("foo" 2) ("baz" 3)))
]}
@defproc[(assv-lens [key any/c]) (lens/c (listof pair?) any/c)]{
@defproc[(assv-lens [key any/c]) lens?]{
Equivalent to @racket[(assoc-lens key #:is-equal? eqv?)].
}
@defproc[(assq-lens [key any/c]) (lens/c (listof pair?) any/c)]{
@defproc[(assq-lens [key any/c]) lens?]{
Equivalent to @racket[(assoc-lens key #:is-equal? eq?)].
}
@ -217,7 +195,7 @@ The identity lens.
]}
@defproc[(syntax-keyword-seq-lens [kw keyword?])
(lens/c syntax? syntax?)]{
lens?]{
Constructs a lens that examines a non-flat syntax object
and views a syntax object containing all the terms in the
target syntax that appear after @racket[kw] but before any
@ -240,23 +218,24 @@ The identity lens.
(lens-set foo-kw-seq-lens #'(a b f g) #'(these are ignored))
]}
@section{Lens Structs}
@defproc[(lens-struct [proc procedure?]) lens-struct?]{
Wraps a lens function in the lens struct. The result lens can also be
used directly as a getter procedure.
}
@defproc[(lens-proc [lens lens?]) procedure?]{
Gets a lens function. If @racket[lens] is a lens function but not a lens
struct, returns the @racket[lens].
}
@section{lenses/applicable}
@defmodule[lenses/applicable]
This module provides the same functions as @racketmodname[lenses], but lenses
are provided as applicable lens structs, and functions that return lenses return
lens structs.
This module provides the same functions as @racketmodname[lenses],
but enables the use of @italic{applicable lenses}. Applicable lenses
may be used directly as getter functions, removing the need to use
@racket[lens-view].
@lenses-applicable-examples[
(require lenses/applicable)
(first-lens '(a b c))
(map first-lens '((1 2 3) (a b c) (100 200 300)))
]
Attempting to use non-applicable lenses as functions is an error.
@lenses-examples[
(require lenses)
(first-lens '(a b c))
]

61
lenses/list/assoc.rkt
View File

@ -1,19 +1,25 @@
#lang racket/base
(provide assoc-lens assv-lens assq-lens)
(provide assoc-lens
assv-lens
assq-lens)
(require racket/list
"../core/main.rkt"
)
(module+ test
(require rackunit))
fancy-app
"../core/main.rkt")
(module+ test
(require rackunit)
(define assoc-list '((a . 1) (b . 2) (c . 3))))
(define (assoc-get assoc-list key #:is-equal? [equal? equal?])
(define assoc-pair (assoc key assoc-list equal?))
(and assoc-pair (cdr assoc-pair)))
(module+ test
(check-equal? (assoc-get assoc-list 'b) 2))
(define (assoc-swap assoc-list old-assoc-pair new-assoc-pair #:is-equal? [equal? equal?])
(define (swap-assoc-pair assoc-pair)
(if (equal? assoc-pair old-assoc-pair)
new-assoc-pair
assoc-pair))
(map swap-assoc-pair assoc-list))
(define (assoc-set assoc-list key value #:is-equal? [equal? equal?])
(define (set-assoc-pair assoc-pair)
@ -23,34 +29,19 @@
(map set-assoc-pair assoc-list))
(module+ test
(define assoc-list '((a . 1) (b . 2) (c . 3)))
(check-equal? (assoc-swap assoc-list '(b . 2) '(FOO . BAR))
'((a . 1) (FOO . BAR) (c . 3))))
(check-equal? (assoc-set assoc-list 'b 200) '((a . 1) (b . 200) (c . 3))))
(define ((assoc-lens key #:is-equal? [equal? equal?]) assoc-list)
(define assoc-pair (assoc key assoc-list equal?))
(define (assoc-lens-set v)
(if assoc-pair
(assoc-set assoc-list key v #:is-equal? equal?)
(append assoc-list (list (cons key v)))))
(values (and assoc-pair (cdr assoc-pair))
assoc-lens-set))
(define (assoc-lens key #:is-equal? [equal? equal?])
(define get (assoc-get _ key #:is-equal? equal?))
(define set (assoc-set _ key _ #:is-equal? equal?))
(make-lens get set))
(module+ test
(define assoc-a-lens (assoc-lens 'a))
(define assoc-d-lens (assoc-lens 'd))
(check-equal? (lens-view assoc-a-lens assoc-list) 1)
(check-equal? (lens-set assoc-a-lens assoc-list 100)
'((a . 100) (b . 2) (c . 3)))
(check-false (lens-view assoc-d-lens assoc-list))
(check-equal? (lens-set assoc-d-lens assoc-list 4)
'((a . 1) (b . 2) (c . 3) (d . 4)))
(define assoc-foo-lens (assoc-lens "foo"))
(define assoc-str '(("bar" . 1) ("foo" . 2) ("baz" . 3)))
(check-equal? (lens-view assoc-foo-lens assoc-str) 2)
(check-equal? (lens-set assoc-foo-lens assoc-str 100)
'(("bar" . 1) ("foo" . 100) ("baz" . 3))))
(define assoc-b-lens (assoc-lens 'b))
(check-equal? (lens-view assoc-b-lens assoc-list) 2)
(check-equal? (lens-set assoc-b-lens assoc-list 200)
'((a . 1) (b . 200) (c . 3))))
(define (assv-lens assv-key)

25
lenses/list/car-cdr.rkt
View File

@ -2,16 +2,21 @@
(provide car-lens cdr-lens)
(require racket/match
fancy-app
"../core/main.rkt"
)
(require "../core/main.rkt")
(define (car-lens v)
(match-define (cons car cdr) v)
(values car (cons _ cdr))) ; fancy-app
(module+ test
(require rackunit))
(define (cdr-lens v)
(match-define (cons car cdr) v)
(values cdr (cons car _)))
(define (set-car pair v)
(cons v (cdr pair)))
(define (set-cdr pair v)
(cons (car pair) v))
(define car-lens (make-lens car set-car))
(define cdr-lens (make-lens cdr set-cdr))
(module+ test
(check-equal? (lens-view car-lens '(1 . 2)) 1)
(check-equal? (lens-view cdr-lens '(1 . 2)) 2))

68
lenses/list/list-ref-take-drop.rkt
View File

@ -12,26 +12,49 @@
sixth-lens
seventh-lens
eighth-lens
nineth-lens
tenth-lens
)
ninth-lens
tenth-lens)
(require racket/list
(only-in srfi/1 append-reverse)
fancy-app
"../core/main.rkt"
"car-cdr.rkt"
)
"car-cdr.rkt")
(module+ test
(require rackunit))
(define ((take-lens n) lst)
(define-values [fst-lst rst-lst] (split-at lst n))
(values fst-lst (append _ rst-lst)))
(define ((drop-lens n) lst)
(define-values [fst-lst rst-lst] (split-at-reverse lst n))
(values rst-lst (append-reverse fst-lst _)))
(define (set-take n lst new-head)
(append new-head (drop lst n)))
(module+ test
(check-equal? (set-take 2 '(1 2 3 4 5) '(a b)) '(a b 3 4 5)))
(define (set-drop n lst new-tail)
(append (take lst n) new-tail))
(module+ test
(check-equal? (set-drop 2 '(1 2 3 4 5) '(a b c)) '(1 2 a b c)))
(define (take-lens n)
(make-lens (take _ n) (set-take n _ _)))
(module+ test
(define take2-lens (take-lens 2))
(check-equal? (lens-view take2-lens '(1 2 3 4 5)) '(1 2))
(check-equal? (lens-set take2-lens '(1 2 3 4 5) '(a b)) '(a b 3 4 5)))
(define (drop-lens n)
(make-lens (drop _ n) (set-drop n _ _)))
(module+ test
(define drop2-lens (drop-lens 2))
(check-equal? (lens-view drop2-lens '(1 2 3 4 5)) '(3 4 5))
(check-equal? (lens-set drop2-lens '(1 2 3 4 5) '(a b c)) '(1 2 a b c)))
(define (list-ref-lens i)
(lens-compose car-lens (drop-lens i)))
@ -47,9 +70,10 @@
(define sixth-lens (list-ref-lens 5))
(define seventh-lens (list-ref-lens 6))
(define eighth-lens (list-ref-lens 7))
(define nineth-lens (list-ref-lens 8))
(define ninth-lens (list-ref-lens 8))
(define tenth-lens (list-ref-lens 9))
(module+ test
(check-eqv? (lens-view first-lens '(1 2 3 4 5)) 1)
(check-eqv? (lens-view second-lens '(1 2 3 4 5)) 2)
@ -62,20 +86,4 @@
(check-equal? (lens-set fourth-lens '(1 2 3 4 5) 'a) '(1 2 3 a 5))
(check-equal? (lens-set fifth-lens '(1 2 3 4 5) 'a) '(1 2 3 4 a))
(check-equal? (lens-transform* '(a (b c) (d e f)) (list-ref-nested-lens 2 1) symbol->string)
'(a (b c) (d "e" f)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; modified from split-at in racket/list
(define (split-at-reverse list0 n0)
(let loop ([list list0] [n n0] [rev-pfx '()])
(cond [(zero? n) (values rev-pfx list)]
[(pair? list) (loop (cdr list) (sub1 n) (cons (car list) rev-pfx))]
[else (raise-arguments-error
'split-at-reverse
(if (list? list0) "index is too large for list" "index reaches a non-pair")
"index" n0
(if (list? list0) "list" "in")
list0)])))
'(a (b c) (d "e" f))))

25
lenses/syntax.rkt
View File

@ -10,15 +10,32 @@
(provide syntax-lens)
(define-syntax syntax-lens
(define-syntax syntax-lens-getter
(syntax-parser
[(_ target-name:id template)
(with-syntax* ([target ((target-stx #'target-name) #'template)]
[parse-pattern (template->pattern #'template)])
#'(syntax-parser
[parse-pattern
#'target]))]))
(define-syntax syntax-lens-setter
(syntax-parser
[(_ target-name:id template)
(with-syntax* ([target ((target-stx #'target-name) #'template)]
[parse-pattern (template->pattern #'template)]
[rebuilder ((template-rebuilder #'target-name) #'parse-pattern)])
#'(syntax-parser
[parse-pattern
(values #'target rebuilder)]))]))
#'(λ (stx new-view)
(syntax-parse stx
[parse-pattern
(rebuilder new-view)])))]))
(define-syntax syntax-lens
(syntax-parser
[(_ target-name:id template)
#'(make-lens (syntax-lens-getter target-name template)
(syntax-lens-setter target-name template))]))
(module+ test
(define stx-lens (syntax-lens A (_ _ (_ _ A _ _) _ ...)))