From 1ec18563fd0ece9aadcb96acc80ab953aa772e33 Mon Sep 17 00:00:00 2001
From: AlexKnauth <alexander@knauth.org>
Date: Wed, 29 Jul 2015 01:59:47 -0400
Subject: [PATCH] add match-lens

---
 unstable/lens/match.rkt | 34 ++++++++++++++++++++++++++++++++++
 1 file changed, 34 insertions(+)
 create mode 100644 unstable/lens/match.rkt

diff --git a/unstable/lens/match.rkt b/unstable/lens/match.rkt
new file mode 100644
index 0000000..ba2cc30
--- /dev/null
+++ b/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)
+  )