From bfa9c9cfcbe1fc9e37ca8b077104c337365e52a6 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Wed, 21 May 2014 21:02:38 -0400
Subject: [PATCH] projection->pattern

---
 minimart/core.rkt  |  1 +
 minimart/route.rkt | 23 +++++++++++++++++++++++
 2 files changed, 24 insertions(+)

diff --git a/minimart/core.rkt b/minimart/core.rkt
index a0643ca..739829a 100644
--- a/minimart/core.rkt
+++ b/minimart/core.rkt
@@ -21,6 +21,7 @@
 	 (struct-out capture)
 	 pretty-print-matcher
 	 matcher-key-set
+	 projection->pattern
 
 	 sub
 	 pub
diff --git a/minimart/route.rkt b/minimart/route.rkt
index 98a8210..fb9f930 100644
--- a/minimart/route.rkt
+++ b/minimart/route.rkt
@@ -22,6 +22,7 @@
 	 matcher-match-matcher
 	 matcher-relabel
 	 compile-projection
+	 projection->pattern
 	 matcher-project
 	 matcher-key-set
 	 pretty-print-matcher)
@@ -429,6 +430,21 @@
       [(? hash?) (error 'compile-projection "Cannot match on hash tables at present")]
       [other (cons other acc)])))
 
+(define (projection->pattern p)
+  (let walk ((p p))
+    (match p
+      [(capture sub) (walk sub)] ;; TODO: maybe enforce non-nesting here too?
+      [(cons p1 p2) (cons (walk p1) (walk p2))]
+      [(? vector? v) (for/vector [(e (in-vector v))] (walk e))]
+      [(? non-object-struct?)
+       (define-values (t skipped?) (struct-info p))
+       (when skipped? (error 'projection->pattern "Cannot reflect on struct instance ~v" p))
+       (define fs (cdr (vector->list (struct->vector p))))
+       (apply (struct-type-make-constructor t) (map walk fs))]
+      ;; TODO: consider options for treating hash tables as compounds rather than (useless) atoms
+      [(? hash?) (error 'projection->pattern "Cannot match on hash tables at present")]
+      [other other])))
+
 ;; Matcher × CompiledProjection [× (Value -> (Option Value))] → Matcher
 ;; The result matches a vector of length equal to the number of captures.
 ;; The project-success function should return #f to signal "no success values".
@@ -1092,4 +1108,11 @@
 				  (compile-projection (cons (?!) (?!)))
 				  #:project-success (lambda (v) #t)))
 		(set '#(1 2) '#(3 4)))
+
+  (check-equal? (projection->pattern (list 'a 'b)) (list 'a 'b))
+  (check-equal? (projection->pattern (list 'a ?)) (list 'a ?))
+  (check-equal? (projection->pattern (list 'a (?!))) (list 'a ?))
+  (check-equal? (projection->pattern (list 'a (?! 'b))) (list 'a 'b))
+  (check-equal? (projection->pattern (list 'a (?! (vector 'b)))) (list 'a (vector 'b)))
+  (check-equal? (projection->pattern (list 'a (?! (vector ? ?)))) (list 'a (vector ? ?)))
   )
\ No newline at end of file