diff --git a/unstable/lens/define-nested.rkt b/unstable/lens/define-nested.rkt new file mode 100644 index 0000000..47002e8 --- /dev/null +++ b/unstable/lens/define-nested.rkt @@ -0,0 +1,68 @@ +#lang sweet-exp racket/base + +provide define-nested-lenses + +require lens/private/compound/thrush + for-syntax racket/base + racket/syntax + syntax/parse + syntax/srcloc + "private/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) + [pattern [suffix-id:id suffix-lens-expr:expr] + #:do [(define-values [base-suffix-lens-id sub-range-binders] + (id-append #:context base-id + base-id -- #'suffix-id -lens))] + #:with [base-suffix-lens ...] + (list base-suffix-lens-id) + #:with [suffix-lens ...] + (list #'suffix-lens-expr) + #:attr sub-range-binders + sub-range-binders]) + + +(define-syntax define-nested-lenses + (syntax-parser + [(define-nested-lenses [base:id base-lens-expr:expr] + (~var clause (clause #'base)) + ...) + #:with base-lens:id (generate-temporary #'base) + #:with [def ...] + (for/list ([base-suffix-lens-ids (in-list (syntax->list #'[[clause.base-suffix-lens] ... ...]))] + [suffix-lens-exprs (in-list (syntax->list #'[[clause.suffix-lens ...] ...]))] + [sub-range-binders-prop (in-list (attribute clause.sub-range-binders))]) + (define/syntax-parse [base-suffix-lens ...] base-suffix-lens-ids) + (define/syntax-parse [suffix-lens ...] suffix-lens-exprs) + (with-sub-range-binders + #`(begin + (define base-suffix-lens + (lens-thrush base-lens suffix-lens)) + ...) + sub-range-binders-prop)) + #'(begin + (define base-lens base-lens-expr) + def + ...)])) + +module+ test + (define-nested-lenses [first first-lens] + [first first-lens] + [second second-lens] + [third third-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) + diff --git a/unstable/lens/define-nested.scrbl b/unstable/lens/define-nested.scrbl new file mode 100644 index 0000000..ebf75fc --- /dev/null +++ b/unstable/lens/define-nested.scrbl @@ -0,0 +1,36 @@ +#lang scribble/manual + +@(require lens/private/doc-util/main) + +@title{Lenses for nested data} + +@defmodule[unstable/lens/define-nested] + +@defform[(define-nested-lenses [base-id base-lens-expr] clause ...) + #:grammar ([clause [sub-id sub-lens-expr]])]{ +A shorthand for defining composed lenses for nested data structures. + +For example, if there is a @racket[top] struct containing a +@racket[middle] struct, which contains an @racket[x] field and a +@racket[y] field, a form like: +@(racketblock + (define-nested-lenses [top-middle top-middle-lens] + [x middle-x-lens] + [y middle-y-lens])) +Will define @racket[top-middle-x-lens] and @racket[top-middle-y-lens] +as @racket[(lens-thrush top-middle-lens middle-x-lens)] and +@racket[(lens-thrush top-middle-lens middle-y-lens)]. + +@lens-unstable-examples[ + (struct/lens ball (mass position velocity) #:transparent) + (struct/lens position (x y) #:transparent) + (struct/lens velocity (x y) #:transparent) + (define-nested-lenses [ball-pos ball-position-lens] + [x position-x-lens] + [y position-y-lens]) + (define-nested-lenses [ball-vel ball-velocity-lens] + [x velocity-x-lens] + [y velocity-y-lens]) + (lens-view ball-vel-x-lens (ball 1 (position 2 3) (velocity 4 5))) + (lens-set ball-vel-x-lens (ball 1 (position 2 3) (velocity 4 5)) 1004) +]} diff --git a/unstable/lens/main.rkt b/unstable/lens/main.rkt index 2ceccd9..9c8fa8e 100644 --- a/unstable/lens/main.rkt +++ b/unstable/lens/main.rkt @@ -1,5 +1,6 @@ #lang reprovide "arrow.rkt" +"define-nested.rkt" "dict-nested.rkt" "hash-filterer.rkt" "if.rkt" diff --git a/unstable/lens/main.scrbl b/unstable/lens/main.scrbl index a9445e7..0fa88ee 100644 --- a/unstable/lens/main.scrbl +++ b/unstable/lens/main.scrbl @@ -13,6 +13,7 @@ this library being backwards-compatible. @(include-sections "arrow.scrbl" + "define-nested.scrbl" "dict-nested.scrbl" "hash-filterer.scrbl" "if.scrbl" diff --git a/unstable/lens/private/id-append.rkt b/unstable/lens/private/id-append.rkt new file mode 100644 index 0000000..7601a3c --- /dev/null +++ b/unstable/lens/private/id-append.rkt @@ -0,0 +1,44 @@ +#lang racket/base + +(provide id-append) + +(require 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 '||)) + +;; 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))) + +