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

Merge pull request #37 from AlexKnauth/generic

Browse Source 
add gen:lens
This commit is contained in:
Jack Firth 2015-08-19 12:54:59 -07:00
commit f07ad9f5da
6 changed files with 126 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

57
lens/base/base.rkt
View File

@ -1,57 +1,8 @@
#lang racket
(require fancy-app)
(module+ test
(require rackunit))
(provide let-lens
(contract-out [make-lens (-> (-> any/c any/c)
(-> any/c any/c any/c)
lens?)]
[focus-lens (-> lens? any/c
(values any/c (-> any/c any/c)))]
[use-applicable-lenses! (-> void?)]
[lens? predicate/c]
[lens/c (contract? contract? . -> . contract?)]
))
(define lenses-applicable? (make-parameter #f))
(define (use-applicable-lenses!)
(lenses-applicable? #t))
(struct lens-struct (get set)
#:property prop:procedure
(lambda (this target)
(if (lenses-applicable?)
((lens-struct-get this) target)
(error "cannot apply a non-applicable lens as a function"))))
(define (lens/c target/c view/c)
(struct/c lens-struct (-> target/c view/c) (-> target/c view/c target/c)))
(module+ test
(require rackunit)
(check-exn exn:fail? (thunk (first-lens '(a b c)))))
(define lens? lens-struct?)
(define (make-lens getter setter)
(lens-struct getter setter))
(define (focus-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) (focus-lens lens-expr target-expr)])
body ...))
#lang racket/base
(require (except-in "gen-lens.rkt" gen-lens/c) "make-lens.rkt" "contract.rkt")
(provide (all-from-out "gen-lens.rkt" "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))

41
lens/base/contract.rkt Normal file
View File

@ -0,0 +1,41 @@
#lang racket/base
(provide lens/c)
(require racket/contract/base
"gen-lens.rkt"
)
(module+ test
(require rackunit
racket/contract/region
fancy-app
"make-lens.rkt"
))
(define (lens/c target/c view/c)
(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])])]))
(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)))
)

47
lens/base/gen-lens.rkt Normal file
View File

@ -0,0 +1,47 @@
#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)
#:fallbacks
[(define/generic gen-lens-view lens-view)
(define/generic gen-lens-set lens-set)
(define (lens-view lens target)
(let-lens (view _) lens target view))
(define (lens-set lens target x)
(let-lens (_ setter) lens target
(setter x)))
(define (focus-lens lens target)
(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 ...))

30
lens/base/make-lens.rkt Normal file
View File

@ -0,0 +1,30 @@
#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))])
(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))))

14
lens/base/view-set.rkt
View File

@ -9,20 +9,12 @@
(require rackunit))
(provide
(contract-out [lens-view (-> lens? any/c any/c)]
[lens-view/list (->* (any/c) #:rest (listof lens?) list?)]
[lens-set (-> lens? any/c any/c any/c)]
lens-view
lens-set
(contract-out [lens-view/list (->* (any/c) #:rest (listof lens?) list?)]
[lens-set/list (->* (any/c) #:rest (listof2 lens? any/c) any/c)]))
(define (lens-view lens target)
(let-lens (view _) lens target
view))
(define (lens-set lens target x)
(let-lens (_ setter) lens target
(setter x)))
(define (lens-view/list target . lenses)
(map (lens-view _ target) lenses))

1
lens/main.rkt
View File

@ -23,6 +23,7 @@
"string.rkt"
"struct/main.rkt"
"vector/main.rkt")
gen:lens
focus-lens
drop-lens
take-lens