move more unstable code to lens/private
This commit is contained in:
AlexKnauth
parent
6987dc9918
commit
3ebc839959
81
lens/private/struct/struct-join.rkt
Normal file
81
lens/private/struct/struct-join.rkt
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
#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))
|
||||
))
|
||||
59
lens/private/struct/struct-list.rkt
Normal file
59
lens/private/struct/struct-list.rkt
Normal file
|
|
@ -0,0 +1,59 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide struct->list-lens list->struct-lens
|
||||
|
||||
require racket/local
|
||||
unstable/lens/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)))
|
||||
|
||||
49
lens/private/struct/struct-nested.rkt
Normal file
49
lens/private/struct/struct-nested.rkt
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
#lang racket/base
|
||||
|
||||
(require fancy-app
|
||||
lens
|
||||
(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,81 +1,2 @@
|
|||
#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))
|
||||
))
|
||||
#lang reprovide
|
||||
lens/private/struct/struct-join
|
||||
|
|
|
|||
|
|
@ -1,59 +1,2 @@
|
|||
#lang sweet-exp racket/base
|
||||
|
||||
provide struct->list-lens list->struct-lens
|
||||
|
||||
require racket/local
|
||||
unstable/lens/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)))
|
||||
|
||||
#lang reprovide
|
||||
lens/private/struct/struct-list
|
||||
|
|
|
|||
|
|
@ -1,49 +1,2 @@
|
|||
#lang racket/base
|
||||
|
||||
(require fancy-app
|
||||
lens
|
||||
(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)))
|
||||
|
||||
|
||||
#lang reprovide
|
||||
lens/private/struct/struct-nested
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user