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

add append*-lens (#272)

Browse Source
This commit is contained in:
Alex Knauth 2016-07-19 23:22:37 -04:00 committed by GitHub
parent b24d06d4e8
commit a1f1907606
5 changed files with 158 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
lens/private/list/append.rkt Normal file
View File

@ -0,0 +1,133 @@
#lang racket/base
(provide append*-lens append*n-lens)
(require lens racket/match racket/list)
(module+ test
(require rackunit syntax/parse lens/private/test-util/test-lens))
;; restore-structure : (Listof (Listof A)) (Listof B) -> (Listof (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 (append* structure).
(define (restore-structure structure flattened)
(match structure
[(list)
(unless (empty? flattened)
(error 'append*-lens "flattened list is too long to match the structure"))
structure]
[(cons s-lst s-rst)
(define-values [f-lst f-rst]
(split-at flattened (length s-lst)))
(cons f-lst (restore-structure s-rst f-rst))]))
;; append*-lens : (Lens (Listof (Listof Any)) (Listof Any))
;; where the only valid views are lists with the same length as the
;; result of applying append* to the target.
(define append*-lens
(make-lens
append*
restore-structure))
(define (append*n-lens n)
(apply lens-thrush (make-list n append*-lens)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(module+ test
(test-case "append*-lens"
(check-equal? (lens-view append*-lens (list (list 1) (list 2 3) (list)))
(list 1 2 3))
(check-equal? (lens-set append*-lens
(list (list 1) (list 2 3) (list))
(list 'a 'b 'c))
(list (list 'a) (list 'b 'c) (list)))
(check-equal? (lens-transform 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? (lens-transform append*-lens
(list (list #'(+ a)) (list #'(- a b) #'(* c d)) (list))
(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 ...)))
(syntax->datum #'[e ...])])))
(list (list '(#%app + a))
(list '(#%app - a b) '(#%app * c d))
(list)))
(test-lens-laws append*-lens
(list (list 1) (list 2 3) (list))
(list 'a 'b 'c)
(list "a" "b" "c"))
)
(test-case "append*n-lens"
(define append**-lens (append*n-lens 2))
(define append***-lens (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"))
))

21
lens/private/list/append.scrbl Normal file
View File

@ -0,0 +1,21 @@
#lang scribble/manual
@(require "../doc-util/main.rkt")
@title{Flattening and unflattening lists}
@defthing[append*-lens lens?]{
A lens that flattens a list one-level down when viewing, and restores
the original structure when setting.
@lens-unstable-examples[
(lens-view append*-lens '((a) (b c) () (d e f)))
(lens-set append*-lens '((a) (b c) () (d e f)) '(1 2 3 4 5 6))
]}
@defproc[(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.
@lens-unstable-examples[
(lens-view (append*n-lens 2) '(((a) ()) (() (b) (c)) () ((d e) () (f))))
(lens-set (append*n-lens 2) '(((a) ()) (() (b) (c)) () ((d e) () (f))) '(1 2 3 4 5 6))
]}

2
unstable/lens/append.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang reprovide
lens/private/list/append

1
unstable/lens/main.rkt
View File

@ -1,4 +1,5 @@
#lang reprovide
"append.rkt"
"arrow.rkt"
"define-nested.rkt"
"dict-nested.rkt"

1
unstable/lens/main.scrbl
View File

@ -12,6 +12,7 @@ may change in future releases. Do not depend on
this library being backwards-compatible.
@(include-sections
(lib "lens/private/list/append.scrbl")
"arrow.scrbl"
"define-nested.scrbl"
"dict-nested.scrbl"