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

Refactor struct/lens definition

Browse Source
This commit is contained in:
Jack Firth 2015-07-12 20:59:55 -07:00
parent a8a5836dbb
commit d063f7b8f5
1 changed files with 34 additions and 18 deletions

52
unstable/lens/struct.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(provide define-struct-lenses struct/lens) (provide define-struct-lenses
struct/lens)
(require syntax/parse/define (require syntax/parse/define
lens/base/main lens/base/main
@ -12,35 +13,50 @@
racket/struct-info racket/struct-info
)) ))
(module+ test (module+ test
(require rackunit fancy-app)) (require rackunit
fancy-app
lens/test-util/test-lens))
(define-for-syntax (get-struct-field-ids struct-info failure-context)
(define-values (_ field-ids)
(get-struct-accessors struct-info failure-context))
field-ids)
(define-for-syntax (get-struct-id-field-ids struct-id-stx)
(define info (extract-struct-info (syntax-local-value struct-id-stx)))
(get-struct-field-ids info struct-id-stx))
(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 field-ids (get-struct-id-field-ids struct-id-stx))
(define set-ids (map-format-id struct-id-stx "~a-set" field-ids))
(define lens-ids (map-format-id struct-id-stx "~a-lens" field-ids))
(list field-ids set-ids lens-ids))
(define-syntax define-struct-lenses (define-syntax define-struct-lenses
(syntax-parser (syntax-parser
[(define-struct-lenses s:id) [(define-struct-lenses s:id)
#:do [(define-values (ids1 ids2) #:with [(s-fld ...)
(get-struct-accessors (extract-struct-info (syntax-local-value #'s)) #'s))] (s-fld-set ...)
#:with [s-fld:id ...] ids2 (s-fld-lens ...)] (struct-get-set-lens-ids #'s)
#:with [[s-fld-set s-fld-lens] ...]
(for/list ([s-fld (in-list ids2)])
(list (format-id #'s "~a-set" s-fld #:source s-fld)
(format-id #'s "~a-lens" s-fld #:source s-fld)))
#'(begin #'(begin
(define-struct-updaters s) (define-struct-updaters s)
(define s-fld-lens (make-lens s-fld s-fld-set)) (define s-fld-lens (make-lens s-fld s-fld-set))
...)])) ...)]))
(define-simple-macro (struct/lens s:id (field-spec ...) option ...) (define-simple-macro (struct/lens s:id (field-spec ...) option ...)
(begin (begin
(struct s (field-spec ...) option ...) (struct s (field-spec ...) option ...)
(define-struct-lenses s))) (define-struct-lenses s)))
(module+ test (module+ test
(require rackunit) (struct/lens foo (a b c d) #:transparent)
(struct/lens foo (a b c) #:transparent) (check-view foo-b-lens (foo 1 2 3 4) 2)
(check-equal? (lens-transform foo-a-lens (foo 1 2 3) (* 100 _)) (check-set foo-c-lens (foo 1 2 3 4) 'a (foo 1 2 'a 4))
(foo 100 2 3)) (test-lens-laws foo-a-lens (foo 1 2 3 4) 'a 'b))
(struct bar foo (d e f) #:transparent)
(define-struct-lenses bar)
(check-equal? (lens-transform bar-d-lens (bar 1 2 3 4 5 6) (* 100 _))
(bar 1 2 3 400 5 6))
)