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

add syntax/stx lenses (#273)

Browse Source
This commit is contained in:
Alex Knauth 2016-07-20 14:11:27 -04:00 committed by GitHub
parent a1f1907606
commit 2d5c736df4
5 changed files with 398 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

307
lens/private/syntax/stx.rkt Normal file
View File

@ -0,0 +1,307 @@
#lang racket/base
(provide stx->list-lens
stx-map-lens
stx-car-lens
stx-cdr-lens
stx-caar-lens
stx-cdar-lens
stx-cadr-lens
stx-cddr-lens
stx-caaar-lens
stx-cdaar-lens
stx-cadar-lens
stx-cddar-lens
stx-caadr-lens
stx-cdadr-lens
stx-caddr-lens
stx-cdddr-lens
stx-append*-lens
stx-append*n-lens
)
(require fancy-app lens racket/list racket/match syntax/stx)
(module+ test
(require rackunit syntax/parse lens/private/test-util/test-lens))
;; stx-e : Any -> Any
(define (stx-e stx)
(if (syntax? stx)
(syntax-e stx)
stx))
;; restore-stx : (case-> [Stx Any -> Stx]
;; [Any Any -> Any])
(define (restore-stx stx dat)
(if (syntax? stx)
(datum->syntax stx dat stx stx)
dat))
(define stx-e-lens
(make-lens
stx-e
restore-stx)) ; the target will be used as the context
;; stx->list* : (Stx-Listof Any) -> (Listof Any)
(define (stx->list* stx)
(define lst (stx->list stx))
;; lst : (U (Listof Any) False)
(unless lst (error 'stx->list* "expected a stx-list, given ~v" stx))
;; lst : (Listof Any)
lst)
(define stx->list-lens
(make-lens
stx->list*
restore-stx))
(define (stx-map-lens elt-lens)
(make-lens
(lens-view/stx-map elt-lens _)
(lens-set/stx-map elt-lens _ _)))
(define (lens-view/stx-map lens tgts)
(stx-map (lens-view lens _) tgts))
(define (lens-set/stx-map lens tgts new-views)
(restore-stx tgts
(stx-map (lens-set lens _ _) tgts new-views)))
(define stx-car-lens (lens-thrush stx-e-lens car-lens))
(define stx-cdr-lens (lens-thrush stx-e-lens cdr-lens))
(define stx-caar-lens (lens-thrush stx-car-lens stx-car-lens))
(define stx-cdar-lens (lens-thrush stx-car-lens stx-cdr-lens))
(define stx-cadr-lens (lens-thrush stx-cdr-lens stx-car-lens))
(define stx-cddr-lens (lens-thrush stx-cdr-lens stx-cdr-lens))
(define stx-caaar-lens (lens-thrush stx-caar-lens stx-car-lens))
(define stx-cdaar-lens (lens-thrush stx-caar-lens stx-cdr-lens))
(define stx-cadar-lens (lens-thrush stx-cdar-lens stx-car-lens))
(define stx-cddar-lens (lens-thrush stx-cdar-lens stx-cdr-lens))
(define stx-caadr-lens (lens-thrush stx-cadr-lens stx-car-lens))
(define stx-cdadr-lens (lens-thrush stx-cadr-lens stx-cdr-lens))
(define stx-caddr-lens (lens-thrush stx-cddr-lens stx-car-lens))
(define stx-cdddr-lens (lens-thrush stx-cddr-lens stx-cdr-lens))
;; stx-append* : (Stx-Listof (Stx-Listof A)) -> (Stx-Listof A)
(define (stx-append* lol)
(append* (stx-map stx->list* lol)))
;; restore-structure : (Stx-Listof (Stx-Listof A)) (Stx-Listof B) -> (Stx-Listof (Stx-Listof B))
;; Takes a list of lists and a list and un-flattens the flattened
;; argument according to the structure of the structure arguement.
;; The length of the flattened list must be the same as the length
;; of (stx-append* structure).
(define (restore-structure structure flattened)
(match (stx-e structure)
[(list)
(unless (stx-null? flattened)
(error 'stx-append*-lens "flattened list is too long to match the structure"))
structure]
[(cons s-lst s-rst)
(define-values [f-lst f-rst]
(stx-split-at flattened (stx-length s-lst)))
(restore-stx structure
(cons (restore-stx s-lst f-lst)
(restore-structure s-rst f-rst)))]))
;; stx-append*-lens : (Lens (Stx-Listof (Stx-Listof Any)) (Stx-Listof Any))
;; where the only valid views are stx-lists with the same length as
;; the result of applying stx-append* to the target.
(define stx-append*-lens
(make-lens
stx-append*
restore-structure))
(define (stx-append*n-lens n)
(apply lens-thrush (make-list n stx-append*-lens)))
;; stx-length : (Stx-Listof A) -> Natural
(define (stx-length lst)
(length (stx->list* lst)))
;; stx-split-at : (Stx-Listof A) Natural -> (values (Listof A) (Stx-Listof A))
(define (stx-split-at lst* pos*)
(let loop ([acc (list)] [pos pos*] [lst lst*])
(cond [(zero? pos)
(values (reverse acc) lst)]
[(stx-null? lst)
(error 'stx-split-at "index is too large for stx-list\n index: ~v\n stx-list: ~v"
pos* lst*)]
[else
(loop (cons (stx-car lst) acc)
(sub1 pos)
(stx-cdr lst))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(define a* #'a)
(define b* #'b)
(define c* #'c)
(define 1* #'1)
(define 2* #'2)
(define 3* #'3)
(test-case "syntax-e-lens and stx-e-lens"
(check-equal? (lens-view stx-e-lens a*) 'a)
(check-equal? (syntax-e (lens-set stx-e-lens a* 1)) 1)
(check-equal? (lens-view stx-e-lens 'a) 'a)
(check-equal? (lens-set stx-e-lens 'a 1) 1)
(check-equal? (lens-view stx-e-lens #`(#,a* #,b* #,c*)) (list a* b* c*))
(check-equal? (syntax-e (lens-set stx-e-lens #`(#,a* #,b* #,c*) (list 1* 2* 3*)))
(list 1* 2* 3*))
(check-equal? (lens-view stx-e-lens (list a* b* c*)) (list a* b* c*))
(check-equal? (lens-set stx-e-lens (list a* b* c*) (list 1* 2* 3*)) (list 1* 2* 3*))
)
(test-case "stx->list-lens"
(check-equal? (lens-view stx->list-lens #`(#,a* #,b* #,c*))
(list a* b* c*))
(check-equal? (syntax->list (lens-set stx->list-lens #`(#,a* #,b* #,c*) (list 1* 2* 3*)))
(list 1* 2* 3*))
(check-exn #rx"expected a stx-list, given #<syntax.* 5>"
(λ () (lens-view stx->list-lens #'5)))
)
(test-case "(stx-map-lens stx->list-lens)"
(check-equal? (lens-view (stx-map-lens stx->list-lens) #`((#,a*) (#,b* #,c*) ()))
(list (list a*) (list b* c*) (list)))
(check-equal? (stx-map syntax->list
(lens-set (stx-map-lens stx->list-lens)
#`((#,a*) (#,b* #,c*) ())
(list (list 1*) (list 2* 3*) (list))))
(list (list 1*) (list 2* 3*) (list)))
)
(test-case "stx-car-lens, stx-cdr-lens, etc."
(check-equal? (lens-view stx-car-lens #`(#,a* . #,b*)) a*)
(check-equal? (lens-view stx-cdr-lens #`(#,a* . #,b*)) b*)
(check-equal? (lens-view stx-car-lens (cons a* b*)) a*)
(check-equal? (lens-view stx-cdr-lens (cons a* b*)) b*)
(check-equal? (syntax-e (lens-set stx-car-lens #`(#,a* . #,b*) 1*)) (cons 1* b*))
(check-equal? (syntax-e (lens-set stx-cdr-lens #`(#,a* . #,b*) 1*)) (cons a* 1*))
(check-equal? (lens-set stx-car-lens (cons a* b*) 1*) (cons 1* b*))
(check-equal? (lens-set stx-cdr-lens (cons a* b*) 1*) (cons a* 1*))
(check-equal? (lens-view stx-car-lens #`(#,a* #,b* #,c*)) a*)
(check-equal? (lens-view stx-cadr-lens #`(#,a* #,b* #,c*)) b*)
(check-equal? (lens-view stx-caddr-lens #`(#,a* #,b* #,c*)) c*)
(check-equal? (lens-view stx-car-lens (list a* b* c*)) a*)
(check-equal? (lens-view stx-cadr-lens (list a* b* c*)) b*)
(check-equal? (lens-view stx-caddr-lens (list a* b* c*)) c*)
(check-equal? (syntax-e (lens-set stx-car-lens #`(#,a* #,b* #,c*) 1*)) (list 1* b* c*))
(check-equal? (syntax-e (lens-set stx-cadr-lens #`(#,a* #,b* #,c*) 1*)) (list a* 1* c*))
(check-equal? (syntax-e (lens-set stx-caddr-lens #`(#,a* #,b* #,c*) 1*)) (list a* b* 1*))
(check-equal? (lens-set stx-car-lens (list a* b* c*) 1*) (list 1* b* c*))
(check-equal? (lens-set stx-cadr-lens (list a* b* c*) 1*) (list a* 1* c*))
(check-equal? (lens-set stx-caddr-lens (list a* b* c*) 1*) (list a* b* 1*))
)
(test-case "stx-append*-lens"
(check-equal? (lens-view stx-append*-lens (list (list 1*) (list 2* 3*) (list)))
(list 1* 2* 3*))
(check-equal? (lens-view stx-append*-lens #`((#,1*) (#,2* #,3*) ()))
(list 1* 2* 3*))
(check-equal? (lens-set stx-append*-lens
(list (list 1) (list 2 3) (list))
(list 'a 'b 'c))
(list (list 'a) (list 'b 'c) (list)))
(check-equal? (map syntax->list
(lens-set stx-append*-lens
(list #`(#,1*) #`(#,2* #,3*) #`())
(list a* b* c*)))
(list (list a*) (list b* c*) (list)))
(check-equal? (map syntax->list
(syntax-e
(lens-set stx-append*-lens
#`((#,1*) (#,2* #,3*) ())
(list a* b* c*))))
(list (list a*) (list b* c*) (list)))
(check-equal? (lens-transform stx-append*-lens
(list (list 1) (list 2 3) (list))
(lambda (lst)
;; a length-preserving computation
(let loop ([acc (list)] [sum 0] [lst lst])
(match lst
[(list) (reverse acc)]
[(cons fst rst)
(loop (cons (+ sum fst) acc)
(+ sum fst)
rst)]))))
(list (list 1) (list 3 6) (list)))
(check-equal? (map syntax->datum
(syntax-e
(lens-transform
stx-append*-lens
#'(((+ a)) ((- a b) (* c d)) ())
(lambda (lst)
;; a length-preserving computation
(syntax-parse
(expand #`(#%expression (λ (a b c d) (#%app list #,@lst))))
#:literals (#%plain-lambda #%plain-app list)
[(#%expression (#%plain-lambda (x ...) (#%plain-app list e ...)))
#'[e ...]])))))
(list (list '(#%app + a))
(list '(#%app - a b) '(#%app * c d))
(list)))
(test-lens-laws stx-append*-lens
(list (list 1) (list 2 3) (list))
(list 'a 'b 'c)
(list "a" "b" "c"))
(test-lens-laws stx-append*-lens
(list (list 1*) (list 2* 3*) (list))
(list a* b* c*)
(list "a" "b" "c"))
)
(test-case "stx-append*n-lens"
(define append**-lens (stx-append*n-lens 2))
(define append***-lens (stx-append*n-lens 3))
(check-equal? (lens-view append**-lens
(list (list (list) (list 1))
(list (list 2 3))
(list)
(list (list 4) (list) (list 5 6))))
(list 1 2 3 4 5 6))
(check-equal? (lens-set append**-lens
(list (list (list) (list 1))
(list (list 2 3))
(list)
(list (list 4) (list) (list 5 6)))
(list 'a 'b 'c 'd 'e 'f))
(list (list (list) (list 'a))
(list (list 'b 'c))
(list)
(list (list 'd) (list) (list 'e 'f))))
(test-lens-laws append**-lens
(list (list (list) (list 1))
(list (list 2 3))
(list)
(list (list 4) (list) (list 5 6)))
(list 'a 'b 'c 'd 'e 'f)
(list "a" "b" "c" "d" "e" "f"))
(check-equal? (lens-view append***-lens
(list (list (list) (list (list 1)))
(list (list (list) (list 2 3)))
(list)
(list (list (list 4) (list)) (list) (list (list 5 6)))))
(list 1 2 3 4 5 6))
(check-equal? (lens-set append***-lens
(list (list (list) (list (list 1)))
(list (list (list) (list 2 3)))
(list)
(list (list (list 4) (list)) (list) (list (list 5 6))))
(list 'a 'b 'c 'd 'e 'f))
(list (list (list) (list (list 'a)))
(list (list (list) (list 'b 'c)))
(list)
(list (list (list 'd) (list)) (list) (list (list 'e 'f)))))
(test-lens-laws append***-lens
(list (list (list) (list (list 1)))
(list (list (list) (list 2 3)))
(list)
(list (list (list 4) (list)) (list) (list (list 5 6))))
(list 'a 'b 'c 'd 'e 'f)
(list "a" "b" "c" "d" "e" "f"))
))

87
lens/private/syntax/stx.scrbl Normal file
View File

@ -0,0 +1,87 @@
#lang scribble/manual
@(require "../doc-util/main.rkt" (for-label syntax/stx))
@title{Syntax object lenses based on @racketmodname[syntax/stx]}
@defthing[stx->list-lens lens?]{
A lens that views a stx-list as a list. Viewing with this lens is
equivalent to using @racket[stx->list], and if the target is a syntax
object, setting it with this lens preserves the lexical context,
source location, and syntax properties of the outer syntax object.
@lens-unstable-examples[
(lens-view stx->list-lens #'(a b c))
(lens-set stx->list-lens #'(a b c) '(1 2 3))
]}
@defproc[(stx-map-lens [lens lens?]) lens?]{
Creates a lens that maps @racket[lens] over a target stx-list. Like
@racket[stx->list-lens], setting with a syntax object target preserves
lexical context, location, and properties.
This is the syntax version of @racket[map-lens].
@lens-unstable-examples[
(lens-view (stx-map-lens stx-car-lens) #'((a b) (c d) (e f)))
(lens-set (stx-map-lens stx-car-lens) #'((a b) (c d) (e f)) #'(1 2 3))
]}
@deftogether[[
@defthing[stx-car-lens lens?]
@defthing[stx-cdr-lens lens?]
]]{
Lenses for looking at the car and cdr of syntax-pairs.
These are the syntax versions of @racket[car-lens] and @racket[cdr-lens].
@lens-unstable-examples[
(lens-view stx-car-lens #'(a . b))
(lens-view stx-cdr-lens #'(a . b))
(lens-set stx-car-lens #'(a . b) #'1)
(lens-set stx-cdr-lens #'(a . b) #'1)
]}
@deftogether[[
@defthing[stx-caar-lens lens?]
@defthing[stx-cdar-lens lens?]
@defthing[stx-cadr-lens lens?]
@defthing[stx-cddr-lens lens?]
@defthing[stx-caaar-lens lens?]
@defthing[stx-cdaar-lens lens?]
@defthing[stx-cadar-lens lens?]
@defthing[stx-cddar-lens lens?]
@defthing[stx-caadr-lens lens?]
@defthing[stx-cdadr-lens lens?]
@defthing[stx-caddr-lens lens?]
@defthing[stx-cdddr-lens lens?]
]]{
Lenses for accessing nested syntax-pairs.
@lens-unstable-examples[
(lens-view stx-caddr-lens #'(a b c d))
(lens-set stx-caddr-lens #'(a b c d) #'1)
]}
@defthing[stx-append*-lens lens?]{
A lens like that flattens a stx-list one-level down when viewing, and
restores the original structure when setting.
This is the syntax version of @racket[append*-lens].
@lens-unstable-examples[
(lens-view stx-append*-lens #'((a) (b c) () (d e f)))
(lens-set stx-append*-lens #'((a) (b c) () (d e f)) #'(1 2 3 4 5 6))
]}
@defproc[(stx-append*n-lens [n exact-nonnegative-integer?]) lens?]{
Creates a lens that flattens a list @racket[n] levels down when
viewing, and restores the original structure when setting.
This is the syntax version of @racket[append*n-lens].
@lens-unstable-examples[
(lens-view (stx-append*n-lens 2) #'(((a) ()) (() (b) (c)) () ((d e) () (f))))
(lens-set (stx-append*n-lens 2) #'(((a) ()) (() (b) (c)) () ((d e) () (f))) #'(1 2 3 4 5 6))
]}

1
unstable/lens/main.rkt
View File

@ -20,5 +20,6 @@
"sublist.rkt"
"substring.rkt"
"syntax.rkt"
"syntax/stx.rkt"
"set-all.rkt"
"zoom.rkt"

1
unstable/lens/main.scrbl
View File

@ -33,6 +33,7 @@ this library being backwards-compatible.
"sublist.scrbl"
"substring.scrbl"
"syntax.scrbl"
(lib "lens/private/syntax/stx.scrbl")
"set-all.scrbl"
"zoom.scrbl"
)

2
unstable/lens/syntax/stx.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang reprovide
lens/private/syntax/stx