RailsOnLisp/rol-uri

diff --git a/expand.lisp b/expand.lisp
deleted file mode 100644
index 7fdc91c..0000000
--- a/expand.lisp
+++ /dev/null
@@ -1,89 +0,0 @@
-;;
-;;  Triangle
-;;
-;;  Copyright 2012,2013 Thomas de Grivel <thomas@lowh.net>
-;;
-;;  Permission to use, copy, modify, and distribute this software for any
-;;  purpose with or without fee is hereby granted, provided that the above
-;;  copyright notice and this permission notice appear in all copies.
-;;
-;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-;;
-
-(defvar *op*)
-(defvar *uri-env*)
-(defvar *separator*)
-
-(defgeneric expand-value (x))
-
-
-(defun expand-uri-template (template &optional env)
-  (macrolet ((op (op &body body) `(let ((*op* ,op)) ,@body))
-	     (var (sym) `(expand-value (getf *uri-env* ,sym)))
-	     (explode (var) `(let ((*separator* (op-explode-separator *op*)))
-			       ,var)))
-    (flet ((prefix (n s) (if (<= (length s) n) s (subseq s 0 n))))
-      (let ((*op* nil)
-	    (*separator* #\,)
-	    (*uri-env* env))
-	(uri-template-parts template)))))
-
-(defgeneric expand-value (x)
-  (:documentation "Returns the expansion of X as a string"))
-
-(defmethod expand-value ((x string))
-  x)
-
-(defun join-alist (alist joiner)
-  (with-output-to-string (out)
-    (format out "~A=~A" (caar alist) (cdar alist))
-    (dolist (i (cdr alist))
-      (format out "~A~A=~A" joiner (car i) (cdr i)))))
-
-(defun join-list (list joiner)
-  (with-output-to-string (out)
-    (format out "~A" (first list))
-    (dolist (i (cdr list))
-      (format out "~A~A" joiner i))))
-
-(defmethod expand-value ((x cons) (joiner character))
-  (if (consp (car x))
-      (join-alist x joiner)
-      (join-list x joiner)))
-
-(defun var (name &key prefix explode)
-  (declare (type symbol name))
-  (cond (prefix (prefix (var name :explode explode) prefix))
-	(explode (explode (var name :prefix prefix)))
-	(t (getf *env* name))))
-
-(defun op (*op* &rest vars)
-  (declare (type character *op*))
-  (when *op* (write-char *op*))
-  (dolist (v vars)
-    (destructuring-bind (f &rest args) v
-      (declare (type (member var) f))
-      (apply (symbol-function f) args))))
-
-(defun uri-template-expand (template &optional stream)
-  (if (null stream)
-      (with-output-to-string (s) (uri-template-expand template s))
-      (dolist (part (uri-template-parts template))
-	(typecase part
-	  (string (write-string part stream))
-	  (cons (destructuring-bind (f &rest args) part
-		  (declare (type (member op) f))
-		  (apply (symbol-function f) args)))))))
-
-(defmacro uri-template-bind ((template target) &body body)
-  (multiple-value-bind (regex vars) (uri-template-regex template)
-    `(cl-ppcre:register-groups-bind
-	 ,vars
-	 (',regex ,target)
-       ,@body)))
diff --git a/package.lisp b/package.lisp
index 610426a..94af684 100644
--- a/package.lisp
+++ b/package.lisp
@@ -38,4 +38,11 @@
    #:%-encode-char
    ;;  URI Template
    #:uri-template
-   #:uri-template-expand))
+   #:uri-template-p
+   #:uri-template-string
+   #:expand-uri
+   ;;  URI Template vars
+   #:uri-var
+   #:uri-var-p
+   #:uri-let
+   #:compile-uri-template-matcher))
diff --git a/uri-template.lisp b/uri-template.lisp
index d72d3e2..4c230f7 100644
--- a/uri-template.lisp
+++ b/uri-template.lisp
@@ -20,7 +20,7 @@
 
 ;;  RFC 6570 - URI Template
 
-(defvar *separator* #\,)
+(defvar *op*)
 
 (define-constant +op-level2+ "+#"
   :test 'string=)
@@ -39,6 +39,8 @@
   (case-char op
     ("#./;?&" op)))
 
+(defvar *separator* #\,)
+
 (defun op-separator (op)
   (case-char op
     ("?&" #\&)
@@ -57,51 +59,112 @@
    (expand-function :type function
 		    :reader uri-template-expand-function)))
 
+(defun uri-template-p (thing)
+  "
+URI-TEMPLATE-P returns T if THING is a URI Template or a string with
+at least one URI Template operator. Otherwise NIL is returned.
+"
+  (typecase thing
+    (string (find #\{ thing))
+    (uri-template t)))
+
+;;  URI vars
+
+(defparameter *uri-vars-package*
+  (let ((pkg (find-package :L>uri.vars)))
+    (when pkg
+      (do-symbols (sym pkg)
+	(unexport sym pkg)
+	(unintern sym pkg)))
+    (defpackage lowh.triangle.uri.vars
+      (:nicknames :L>uri.vars)))
+  "All uri variable names are interned in this package.")
+
+(defun uri-var (name)
+  "URI-VAR interns NAME in the current *URI-VARS-PACKAGE*."
+  (let ((sym (intern (string name) *uri-vars-package*)))
+    (export sym *uri-vars-package*)
+    sym))
+
+(defun uri-var-p (thing)
+  (and (symbolp thing)
+       (eq *uri-vars-package* (symbol-package thing))))
+
+(deftype uri-var ()
+  "The type of all uri variables."
+  `(and symbol
+	(satisfies uri-var-p)))
+
+(defmacro uri-let (bindings &body body)
+  "Create dynamic bindings for URI variables and lexical bindings to
+access them in BODY."
+  (let ((bindings (mapcar (lambda (b) (if (consp b) b (list b nil)))
+			  bindings)))
+    `(let ,(mapcar (lambda (b) `(,(uri-var (car b)) ,(cadr b)))
+		   bindings)
+       (declare (special ,@(mapcar (lambda (b) (uri-var (car b)))
+				   bindings)))
+       (symbol-macrolet ,(mapcar (lambda (b)
+				   `(,(car b) ,(uri-var (car b))))
+				 bindings)
+	 ,@body))))
+
+;;  Read
+
+(defun read-uri-template-from-string (string)
+  "Read a URI Template string as per RFC 6570 and return an instance of
+URI-TEMPLATE."
+  (labels ((read/var (s)
+	     (cl-ppcre:register-groups-bind (name prefix explode)
+		 (#.(str "(" #1="(?:[0-9A-Za-z_]|%[0-9][0-9])"
+			 "(?:[.]?" #1# ")*)(?::(.*)|([*]))?$")
+		    s)
+	       (let ((sym (uri-var (string-upcase name))))
+		 (cond (prefix  `(prefix ,(parse-integer prefix) ,sym))
+		       (explode `(explode ,sym))
+		       (t       sym)))))
+	   (read/part (s)
+	     (cond ((char= #\{ (char s 0))
+		    (let ((start 1)
+			  (end (1- (length s))))
+		      (assert (char= #\} (char s end)))
+		      (let ((op (find (char s 1) +operator+)))
+			(when op (incf start))
+			(let ((vars (mapcar #'read/var
+					    (cl-ppcre:split "," s
+							    :start start
+							    :end end))))
+			  `(,op ,@vars)))))
+		   (t s))))
+    (let (parts chars)
+      (flet ((push-part ()
+	       (when chars
+		 (push (read/part (coerce (nreverse chars) 'string))
+		       parts)
+		 (setf chars nil))))
+	(dotimes (i (length string))
+	  (let ((c (char string i)))
+	    (cond
+	      ((char= #\{ c) (push-part) (push c chars))
+	      ((char= #\} c) (push c chars) (push-part))
+	      (t (push c chars)))))
+	(push-part))
+      (make-instance 'uri-template :parts (nreverse parts)))))
+
 ;;  Cache
 
 (defvar *uri-templates* (make-hash-table :test 'equal :weakness :value))
 
-;;  Reader
-
-(defun uri-template (string)
-  (or (gethash string *uri-templates*)
-      (setf (gethash string *uri-templates*)
-	    (labels ((parse/var (s)
-		       (cl-ppcre:register-groups-bind (name prefix explode)
-			   (#.(str "(" #1="(?:[0-9A-Za-z_]|%[0-9][0-9])"
-				   "(?:[.]?" #1# ")*)(?::(.*)|([*]))?$")
-			      s)
-			 (let ((sym (intern (string-upcase name))))
-			   (cond (prefix  `(prefix ,(parse-integer prefix) ,sym))
-				 (explode `(explode ,sym))
-				 (t       sym)))))
-		     (parse/part (s)
-		       (cond ((char= #\{ (char s 0))
-			      (let ((start 1)
-				    (end (1- (length s))))
-				(assert (char= #\} (char s end)))
-				(let ((op (find (char s 1) +operator+)))
-				  (when op (incf start))
-				  (let ((vars (mapcar #'parse/var
-						      (cl-ppcre:split "," s
-								      :start start
-								      :end end))))
-				    `(,op ,@vars)))))
-			     (t s))))
-	      (let (parts chars)
-		(flet ((push-part ()
-			 (when chars
-			   (push (parse/part (coerce (nreverse chars) 'string))
-				 parts)
-			   (setf chars nil))))
-		  (dotimes (i (length string))
-		    (let ((c (char string i)))
-		      (cond
-			((char= #\{ c) (push-part) (push c chars))
-			((char= #\} c) (push c chars) (push-part))
-			(t (push c chars)))))
-		  (push-part))
-		(make-instance 'uri-template :parts (nreverse parts)))))))
+(defun uri-template (thing)
+  (typecase thing
+    (string (or (gethash thing *uri-templates*)
+		(setf (gethash thing *uri-templates*)
+		      (read-uri-template-from-string thing))))
+    (uri-template thing)))
+
+(defmethod make-load-form ((uri-template uri-template) &optional env)
+  (declare (ignore env))
+  `(uri-template ,(uri-template-string uri-template)))
 
 #+nil
 (define-compiler-macro uri-template (&whole whole string)
@@ -112,20 +175,12 @@
 #+test
 (uri-template-parts (uri-template "/assets/{+path:4}"))
 
-;;  Printer
-
-(defvar *op*)
-
-(defmacro ignore-unbound (&body body)
-  `(handler-case (locally (declare (sb-ext:muffle-conditions warning))
-		   ,@body)
-     (unbound-variable () nil)
-     (warning (w) (format t "~&~S~%" w))))
+;;  Eval
 
-(defun uri-template-parse (template &key (parts #'list) (string #'identity)
+(defun do-uri-template (template &key (parts #'list) (string #'identity)
 				      (op #'list) explode prefix
 				      (var #'identity))
-  (labels ((parse-var (x)
+  (labels ((do-var (x)
 	     (if (symbolp x)
 		 (funcall var x)
 		 (destructuring-bind (a b &optional c) x
@@ -133,7 +188,7 @@
 		     ((explode) (let ((*separator* (explode-separator *op*)))
 				  (funcall explode (funcall var b))))
 		     ((prefix) (funcall prefix b (funcall var c)))))))
-	   (parse-part (part)
+	   (do-part (part)
 	     (typecase part
 	       (string (funcall string part))
 	       (cons (destructuring-bind (op-char &rest vars) part
@@ -141,19 +196,20 @@
 			     (*separator* (op-separator op-char)))
 			 (apply op op-char (remove-if
 					    #'null
-					    (mapcar #'parse-var vars)))))))))
+					    (mapcar #'do-var vars)))))))))
     (when (stringp template)
       (setq template (uri-template template)))
-    (apply parts (mapcar #'parse-part (uri-template-parts template)))))
+    (apply parts (mapcar #'do-part (uri-template-parts template)))))
+
+;;  Print
 
 (defun uri-template-string (template)
-  (uri-template-parse
-   template
-   :parts #'str
-   :op (lambda (op &rest vars) (format nil "{~@[~C~]~{~A~^,~}}" op vars))
-   :explode (lambda (var) (format nil "~A*" var))
-   :prefix (lambda (n var) (format nil "~A:~D" var n))
-   :var #'string-downcase))
+  (do-uri-template template
+    :parts #'str
+    :op (lambda (op &rest vars) (format nil "{~@[~C~]~{~A~^,~}}" op vars))
+    :explode (lambda (var) (format nil "~A*" var))
+    :prefix (lambda (n var) (format nil "~A:~D" var n))
+    :var #'string-downcase))
 
 #+test
 (uri-template-string (uri-template "/assets/{+path*,dir*}"))
@@ -161,10 +217,19 @@
 (defmethod print-object ((o uri-template) stream)
   (prin1 `(uri-template ,(uri-template-string o)) stream))
 
-;;  Expansion
+;;  Expand
 
-(defvar *op*)
-(defvar *separator*)
+(defmacro with-uri-vars (vars &body body)
+  (let ((unbound-vars (gensym "UNBOUND-VARS-"))
+	(nils (gensym "NILS")))
+    `(locally (declare (special ,@vars)) ;; (sb-ext:muffle-conditions warning)
+       (let (,unbound-vars ,nils)
+	 (dolist (v ',vars)
+	   (when (not (boundp v))
+	     (push v ,unbound-vars)
+	     (push nil ,nils)))
+	 (progv unbound-vars nils
+	   ,@body)))))
 
 (defun prefix (n s)
   (when s
@@ -175,14 +240,16 @@
 (defgeneric expand-value (x)
   (:documentation "Prints the expansion of X to *STANDARD-OUTPUT*"))
 
-(defmethod expand-value ((x null)))
+(defmethod expand-value ((x t))
+  (with-output-to-string (out)
+    (princ x out)))
+
+(defmethod expand-value ((x null))
+  "")
 
 (defmethod expand-value ((x string))
   x)
 
-(defmethod expand-value ((x number))
-  (format nil "~D" x))
-
 (defun expand-alist (alist separator assoc stream)
   (unless (endp alist)
     (princ (caar alist) stream)
@@ -207,47 +274,67 @@
 	(expand-alist x *separator* #\= o)
 	(expand-list x *separator* o))))
 
-(defun uri-template-expander (template)
-  (let ((vars))
+(defun uri-template-expand-code (template &optional (stream-var 'stream))
+  (declare (type symbol stream-var))
+  (let (vars)
     (values
-     (uri-template-parse
-      template
-      :parts (lambda (&rest p) `(with-output-to-string (o) ,@p))
-      :string (lambda (s) `(princ ,s o))
-      :op (lambda (op &rest v) `(let ((*separator* ,*separator*))
-				  ,@(when-let ((pre (op-prefix op)))
-					      `((write-char ,pre o)))
-				  (expand-list (remove-if #'null (list ,@v))
-					       ,*separator* o)))
-      :explode (lambda (v) `(let ((*separator* ,*separator*)) ,v))
-      :prefix (lambda (n v) `(prefix ,n ,v))
-      :var (lambda (v) (pushnew v vars) `(expand-value (ignore-unbound ,v))))
+     (do-uri-template template
+       :string (lambda (x) `(write-string ,x ,stream-var))
+       :op (lambda (op &rest v) `(let ((*separator* ,*separator*))
+				   ,@(when-let ((pre (op-prefix op)))
+					       `((write-char ,pre ,stream-var)))
+				   (expand-list (remove-if #'null (list ,@v))
+						,*separator* stream)))
+       :explode (lambda (v) `(let ((*separator* ,*separator*)) ,v))
+       :prefix (lambda (n v) `(prefix ,n ,v))
+       :var (lambda (v) (pushnew v vars) `(expand-value ,v)))
      vars)))
 
+#+nil
+(uri-template-expander-code "/assets{/plop*}")
+
+(defun compile-uri-template-expand-function (template)
+  (format *debug-io* "~&; compiling ~S~%" template)
+  (multiple-value-bind (code vars)
+      (uri-template-expand-code template 'stream)
+    (compile nil `(lambda (stream &key ,@vars)
+		    (declare (type stream stream)
+			     (special ,@vars))
+		    ,@code))))
+
 (defmethod slot-unbound (class
 			 (template uri-template)
 			 (slot (eql 'expand-function)))
-  (setf (slot-value template 'expand-function)
-	(let ((code (multiple-value-bind (proc vars)
-			(uri-template-expander template)
-		      `(lambda (&key ,@vars) ,proc))))
-	  (compile nil code))))
-
-(defun uri-template-expand (template &rest env &key &allow-other-keys)
-  (when (stringp template)
-    (setf template (uri-template template)))
-  (apply (uri-template-expand-function template) env))
-
-#+test nil
+    (setf (slot-value template 'expand-function)
+	  (compile-uri-template-expand-function template)))
+
+(defgeneric expand-uri (output uri &rest vars &key &allow-other-keys))
+
+(defmethod expand-uri ((output null) uri &rest vars &key &allow-other-keys)
+  (with-output-to-string (stream)
+    (apply #'expand-uri stream uri vars)))
+
+(defmethod expand-uri (output (uri string) &rest vars)
+  (if (uri-template-p uri)
+      (apply #'expand-uri output (uri-template uri) vars)
+      uri))
+
+(defmethod expand-uri ((output stream) (uri uri-template) &rest vars)
+  (apply (uri-template-expand-function uri) output vars))
+
+#+test
 (time
- (let ((template (uri-template "/assets/{+path}")))
-   (uri-template-expand template :path "plop")))
+ (let ((template (uri-template "/assets/{+path,pat,path}")))
+   (dotimes (i 100000)
+     (expand-uri nil template :path i))))
 
+#+test
 (time
  (let ((template (uri-template "/assets/{+path}")))
    (dotimes (i 8)
      (uri-template-expand template :path i))))
 
+#+test
 (time
  (dotimes (i 1000)
    (let ((template (uri-template (format nil "/assets/{+path}/~D" (mod i 10)))))
@@ -255,20 +342,67 @@
 
 ;;  Destructuring regex
 
+(defun var-regex (op var)
+  (declare (ignore var))
+  (let ((char-regex
+	 (case-char op
+	   (nil '(:property char-unreserved-p))
+	   ("+#./;?&" `(:alternation
+			(:property char-unreserved-p)
+			(:char-class ,@(coerce +reserved+ 'list))
+			(:sequence #\% :digit-class :digit-class))))))
+    `(:sequence
+      #1=(:greedy-repetition 1 nil ,char-regex)
+      (:non-greedy-repetition 0 nil (:sequence ,(op-separator op) #1#)))))
+
 (defun uri-template-regex (template)
-  (let ((template (etypecase template
-		    (string (uri-template template))
-		    (cons template)))
-	(registers nil))
+  (let ((vars))
     (values
-     `(:sequence
-       ,@(mapcar (lambda (token)
-		   (etypecase token
-		     (string token)
-		     (symbol (push token registers)
-			     '(:register (:greedy-repetition
-					  1 nil (:inverted-char-class #\/))))))
-		 template)
-       (:greedy-repetition 0 1 "/")
-       :end-anchor)
-     (nreverse registers))))
+     (do-uri-template template
+       :parts (lambda (&rest parts)
+		`(:sequence :start-anchor ,@parts :end-anchor))
+       :op (lambda (op &rest vars)
+	     `(:sequence
+	       ,@(when (op-prefix op) `(,(op-prefix op)))
+	       ,@(reduce (lambda (exp var)
+			   `((:named-register ,(string var)
+					      ,(var-regex op var))
+			     ,@(when exp `((:greedy-repetition
+					    0 1 (:sequence ,(op-separator op)
+							   ,@exp))))))
+			 (reverse vars) :initial-value nil)))
+       :explode (lambda (var) `(explode ,var))
+       :prefix (lambda (n var) `(prefix ,var ,n))
+       :var (lambda (var)
+	      (let ((sym (uri-var var)))
+		(push sym vars)
+		sym)))
+     (nreverse vars))))
+
+(defun uri-template-matcher (template body)
+  (let ((string (gensym "STRING-")))
+    (multiple-value-bind (regex vars) (uri-template-regex template)
+      `(lambda (,string)
+	 (cl-ppcre:register-groups-bind ,vars
+	     (,(cl-ppcre:create-scanner regex) ,string)
+	   ,@body)))))
+
+(defun compile-uri-template-matcher (template body)
+  (compile nil (uri-template-matcher template body)))
+
+(defun uri-template-call (template function string)
+  (multiple-value-bind (match registers)
+      (cl-ppcre:scan-to-strings (uri-template-regex template) string)
+    (when match
+      (apply function (coerce registers 'list)))))
+
+(defmacro uri-template-bind (vars (template string) &body body)
+  `(cl-ppcre:register-groups-bind ,vars ((uri-template-regex ,template)
+					 ,string)
+     ,@body))
+
+(defmacro uri-template-match ((template string) &body body)
+  (multiple-value-bind (regex vars) (uri-template-regex template)
+    `(cl-ppcre:register-groups-bind ,vars (,(cl-ppcre:create-scanner regex)
+					    ,string)
+       ,@body)))
diff --git a/uri.lisp b/uri.lisp
index 0504a01..30cc4a2 100644
--- a/uri.lisp
+++ b/uri.lisp
@@ -31,7 +31,7 @@
 
 (define-constant +gen-delims+ ":/?#[]@" :test 'string=)
 (define-constant +sub-delims+ "!$&'()*+,;=" :test 'string=)
-(define-constant +reserved+ (concatenate 'string +gen-delims+ +sub-delims+)
+(define-constant +reserved+ (str +gen-delims+ +sub-delims+)
   :test 'string=)
 
 (defun char-unreserved-p (c)