Merge pull request #142 from AlexKnauth/match

add match-lens

unstable/lens/main.rkt

@@ -7,6 +7,7 @@
          "isomorphism.rkt"
          "mapper.rkt"
          "string-split.rkt"
+         "match.rkt"
          )
 
 (provide (all-from-out "syntax.rkt"
@@ -16,4 +17,5 @@
                        "isomorphism.rkt"
                        "mapper.rkt"
                        "string-split.rkt"
+                       "match.rkt"
                        ))

unstable/lens/main.scrbl

@@ -16,3 +16,4 @@ this library being backwards-compatible.
 @include-section["isomorphism.scrbl"]
 @include-section["mapper.scrbl"]
 @include-section["string-split.scrbl"]
+@include-section["match.scrbl"]

unstable/lens/match.rkt

@@ -0,0 +1,34 @@
+#lang racket/base
+
+(provide match-lens)
+
+(require racket/match
+         racket/local
+         syntax/parse/define
+         lens/base/main
+         )
+(module+ test
+  (require rackunit lens/test-util/test-lens))
+
+(define-simple-macro (match-lens a:id pat:expr replacement:expr)
+  (local [(define (get target)
+            (match target
+              [pat
+               a]))
+          (define (set target new-view)
+            (match target
+              [pat
+               (let ([a new-view])
+                 replacement)]))]
+    (make-lens get set)))
+
+(module+ test
+  (define car-lens (match-lens a (cons a b) (cons a b)))
+  (define cdr-lens (match-lens b (cons a b) (cons a b)))
+  (check-view car-lens (cons 1 2) 1)
+  (check-view cdr-lens (cons 1 2) 2)
+  (check-set car-lens (cons 1 2) 'a (cons 'a 2))
+  (check-set cdr-lens (cons 1 2) 'a (cons 1 'a))
+  (test-lens-laws car-lens (cons 1 2) 'a 'b)
+  (test-lens-laws cdr-lens (cons 1 2) 'a 'b)
+  )

unstable/lens/match.scrbl

@@ -0,0 +1,21 @@
+#lang scribble/manual
+
+@(require lens/doc-util/main)
+
+@title{Lenses based on match patterns}
+
+@defform[(match-lens id pattern replacement)]{
+Creates a lens for viewing the @racket[id] within the @racket[pattern].
+
+The @racket[replacement] expression should be an expression such that
+@racket[(match target [pattern replacement])] produces a value equivalent to
+@racket[target], and should use @racket[id] as the view.
+@lenses-unstable-examples[
+  (define car-lens (match-lens a (cons a b) (cons a b)))
+  (define cdr-lens (match-lens b (cons a b) (cons a b)))
+  (define third-lens (match-lens c (list a b c d ...) (list* a b c d)))
+  (define vector-second-lens (match-lens b (vector a b c ...) (apply vector a b c)))
+  (define v2-of-l3-lens (match-lens d
+                          (list a b (vector c d e ...) f ...)
+                          (list* a b (apply vector c d e) f)))
+]}