From 9a9b30c7511b0e22c4c1335e652755173eb31134 Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Fri, 11 Jan 2013 00:40:48 -0700
Subject: [PATCH] [honu] many small things: allow with syntax to bind arbitrary
 patterns. provide time and time-apply. make compress-dollars recurse on
 sub-expressions. add an implicit pattern variable that consists of the result
 with an ellipses depth of 1. fix the while form. allow require forms to
 contain mostly anything and be separated by commas.

---
 collects/honu/core/main.rkt             |  1 +
 collects/honu/core/private/extra.rkt    |  3 ++-
 collects/honu/core/private/honu2.rkt    | 31 ++++++++++++++-----------
 collects/honu/core/private/macro2.rkt   |  5 +++-
 collects/honu/core/private/parse2.rkt   |  8 ++++++-
 collects/honu/core/private/template.rkt |  5 ++--
 collects/honu/main.rkt                  |  2 ++
 collects/honu/private/common.rkt        |  9 +++++++
 collects/honu/private/with.honu         |  2 +-
 9 files changed, 46 insertions(+), 20 deletions(-)

diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt
index a64fdce75b..df2470816a 100644
--- a/collects/honu/core/main.rkt
+++ b/collects/honu/core/main.rkt
@@ -22,6 +22,7 @@
                                    [racket:else else]
                                    [racket:void void]
                                    [parse:honu-number number]
+                                   [parse:honu-string string]
                                    [honu-function function]
                                    [honu-function fun]
                                    [honu-var var]
diff --git a/collects/honu/core/private/extra.rkt b/collects/honu/core/private/extra.rkt
index 1dfe234e04..cd54bae06d 100644
--- a/collects/honu/core/private/extra.rkt
+++ b/collects/honu/core/private/extra.rkt
@@ -4,5 +4,6 @@
 (define (do-lookup data slice)
   (cond
     [(list? data) (list-ref data slice)]
+    [(string? data) (string-ref data slice)]
     [(vector? data) (vector-ref data slice)]
-    [else (error 'lookup "don't know how to lookup" data)]))
+    [else (error 'lookup "don't know how to lookup ~a" data)]))
diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt
index bb8ed7ec80..d755c437d7 100644
--- a/collects/honu/core/private/honu2.rkt
+++ b/collects/honu/core/private/honu2.rkt
@@ -276,6 +276,8 @@
                     [(string? path) path]
                     [else (error 'combine-paths "what is ~a" path)])))
     (format-id name (string-join all "/")))
+  (define-splicing-syntax-class not-comma
+    [pattern x #:when (not ((literal-set->predicate cruft) #'x))])
   (define-splicing-syntax-class require-form
                                 #:literals (honu-prefix honu-for-syntax)
                                 #:literal-sets (cruft)
@@ -284,20 +286,19 @@
     [pattern (~seq honu-for-syntax ~! (#%parens module:require-form))
              #:with result #'(for-syntax module.result)]
     [pattern x:str #:with result #'x]
-    [pattern (~seq (~seq base:id (~literal honu-/)) ... x:id)
-             #:with result (with-syntax ([name (combine-paths
-                                                 (syntax->list #'(base ...))
-                                                 (fix-module-name #'x))])
-                             (emit-remark "require-form" #'honu-for-syntax #'x)
-                             (debug "Plain path: ~a ~a\n" #'name (free-identifier=? #'honu-for-syntax #'x))
-                             #'name)
-             #:when (not ((literal-set->predicate cruft) #'x))]))
-
+    [pattern (~seq x:not-comma ...)
+             #:with result (with-syntax ([name
+                                           (string->symbol
+                                             (apply string-append
+                                                    (map (compose symbol->string syntax->datum)
+                                                         (syntax->list #'(x.x ...)))))])
+                             #'name)]))
+                                                                    
 (provide honu-require)
 (define-honu-syntax honu-require
   (lambda (code)
     (syntax-parse code
-      [(_ form1:require-form form:require-form ... . rest)
+      [(_ form1:require-form (~seq honu-comma form:require-form) ... . rest)
        (values
          (racket-syntax (require (filtered-in (lambda (name)
                                                 (regexp-replace* #rx"-"
@@ -338,8 +339,9 @@
       [(_ condition:honu-expression body:honu-body . rest)
        (values
          (racket-syntax (let loop ()
-                      body.result
-                      (when condition.result (loop))))
+                          (when condition.result
+                            body.result
+                            (loop))))
          #'rest
          #t)])))
 
@@ -457,7 +459,9 @@
       [pattern (~seq name:id honu-equal data:honu-expression)
                #:with out #'(name data.result)]
       [pattern (~seq (#%parens name:id ellipses) honu-equal data:honu-expression)
-               #:with out #'((name (... ...)) data.result)])
+               #:with out #'((name (... ...)) data.result)]
+      [pattern (~seq (#%parens (#%parens name:id ellipses) ellipses) honu-equal data:honu-expression)
+               #:with out #'(((name (... ...)) (... ...)) data.result)])
     (syntax-parse code #:literal-sets (cruft)
                        #:literals (honu-equal)
       [(_ (~seq all:clause (~optional honu-comma)) ...
@@ -516,4 +520,3 @@
          (racket-syntax (define-honu-syntax name transformer.result))
          #'rest
          #t)])))
-
diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt
index 03f193a573..f0b5a81133 100644
--- a/collects/honu/core/private/macro2.rkt
+++ b/collects/honu/core/private/macro2.rkt
@@ -399,12 +399,15 @@
                                                             [(#%braces what ...)
                                                              #'(what ...)])
                                                             ])
-                                             #'(#:with result (parse-stuff honu-syntax (#%parens out ...))))
+                                             ;; #'(#:with result (parse-stuff honu-syntax (#%parens out ...)))
+                                             #'(#:with result (parse-stuff out ...))
+                                             )
                                            #'(#:with result #'()))])
           (syntax/loc honu-pattern
                       [pattern (~seq new-pattern ...)
                                withs ... ...
                                result-with ...
+                               #:with (inner (... ...)) #'result
                                ])))
 
       (define pattern-stuff
diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt
index fc40ddc019..01d5ab4f6e 100644
--- a/collects/honu/core/private/parse2.rkt
+++ b/collects/honu/core/private/parse2.rkt
@@ -303,6 +303,7 @@
       (values (left current) stream)
       (begin
         (debug "Honu macro at phase ~a: ~a ~a\n" (syntax-local-phase-level) head (syntax-local-value head))
+        #;
         (emit-remark "Input to macro" 
                      (with-syntax ([head head]
                                      [(rest ...) rest])
@@ -316,6 +317,7 @@
                          (datum->syntax #'head
                                         (syntax->list #'(head rest ...))
                                         #'head #'head)))])
+          #;
           (emit-remark "Output from macro" parsed)
           #;
           (emit-local-step stream parsed #:id #'do-macro)
@@ -598,7 +600,7 @@
                      [else (if (not current)
                              (error 'what "don't know how to parse ~a" #'head)
                              (values (left current) stream))]
-                     [else (error 'what "don't know how to parse ~a" #'head)])])])])))
+                     [else (error 'parser "don't know how to parse ~a" #'head)])])])])))
 
   (emit-remark "Honu parse" input)
   (define-values (parsed unparsed)
@@ -750,6 +752,10 @@
                               #:literal-sets (cruft)
   [pattern x:number #:with result #'x])
 
+(provide honu-string)
+(define-splicing-syntax-class honu-string
+                              #:literal-sets (cruft)
+  [pattern x:str #:with result #'x])
 
 (provide identifier-comma-list)
 (define-splicing-syntax-class identifier-comma-list
diff --git a/collects/honu/core/private/template.rkt b/collects/honu/core/private/template.rkt
index b09f0515b1..c594bd830a 100644
--- a/collects/honu/core/private/template.rkt
+++ b/collects/honu/core/private/template.rkt
@@ -81,8 +81,9 @@
   (syntax-parse stx #:literal-sets (local-literals)
     [(honu-$ x:not-dollar ... honu-$ rest ...)
      (debug 2 "Compressing ~a\n" #'(x.out ...))
-     (with-syntax ([(rest* ...) (compress-dollars #'(rest ...))])
-       (datum->syntax stx (syntax->list #'((repeat$ x.out ...) rest* ...))
+     (with-syntax ([(rest* ...) (compress-dollars #'(rest ...))]
+                   [(x.out* ...) (compress-dollars #'(x.out ...))])
+       (datum->syntax stx (syntax->list #'((repeat$ x.out* ...) rest* ...))
                       stx stx))]
     [(honu-$ rest ...)
      (error 'compress-dollars "unmatched $ ~a" (syntax->datum stx))]
diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt
index f9f2d217f6..57fdd0be9c 100644
--- a/collects/honu/main.rkt
+++ b/collects/honu/main.rkt
@@ -35,6 +35,8 @@
          error
          (racket:rename-out
            [honu-cond cond]
+           [honu-time time]
+           [time-apply time_apply]
            [null empty]
            [make-hash mutable_hash]
            [hash-set! hash_update]
diff --git a/collects/honu/private/common.rkt b/collects/honu/private/common.rkt
index 47ac0d0223..789b352786 100644
--- a/collects/honu/private/common.rkt
+++ b/collects/honu/private/common.rkt
@@ -29,3 +29,12 @@
                           ...))
          #'rest
          #t)])))
+
+(provide honu-time)
+(define-honu-syntax honu-time
+  (lambda (code)
+    (syntax-parse code #:literal-sets (cruft)
+      [(_ e:honu-expression . rest)
+       (values (racket-syntax (time e.result))
+               #'rest
+               #'t)])))
diff --git a/collects/honu/private/with.honu b/collects/honu/private/with.honu
index 15c9ac9cc7..9a16643662 100644
--- a/collects/honu/private/with.honu
+++ b/collects/honu/private/with.honu
@@ -3,7 +3,7 @@
 provide withSyntax;
 
 macro withSyntax () {
- [variable:identifier expr:expression] { b ... /* body:statement */ }; } {
+ [variable expr:expression] { b ... /* body:statement */ }; } {
   primitiveWithSyntax [variable_result (datumToSyntax (syntax expr)
                                                       expr_result
                                                       (syntax expr)