implement honu-syntax

collects/honu/main.rkt

@@ -6,6 +6,7 @@
          ;; "private/honu.ss"
          "private/parse.ss"
          "private/literals.ss"
+         "private/syntax.ss"
          "private/macro.ss")
 
 (define test-x-class
@@ -30,6 +31,7 @@
                      )
          #%datum
          #%braces
+         #%parens
          x
          true
          false
@@ -37,11 +39,13 @@
          display2
          newline
          else
+         foobar2000
          (rename-out
            (honu-if if)
            (honu-provide provide)
            (honu-macro-item macroItem)
            (honu-macro macro)
+           (honu-syntax syntax)
            ))
 
 #;

collects/honu/private/honu-typed-scheme.rkt

@@ -269,8 +269,9 @@
      (lambda (transformer)
        (let-values ([(code rest) (transformer body context)])
          (combine-k code rest)))]
-    [else (call-values parse-one (extract-until body (list #'\;
+    [else (call-values (extract-until body (list #'\;
-                                                           )))]))
+                                                 ))
+                       parse-one )]))
 
 #|
 (define-honu-macro (e ... * e ... \;))
@@ -295,13 +296,6 @@ x(2)
 
 )
 
-(define-syntax (define-honu-syntax stx)
-  (let-values ([(id rhs) (normalize-definition stx #'lambda #f)])
-    (with-syntax ([id id]
-                  [rhs rhs])
-                 #'(define-syntax id (make-honu-transformer rhs)))))
-
-
 #|
 
 Yes, check out head patterns and splicing syntax classes.
@@ -320,6 +314,14 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
 
 |#
 
+(define-syntax (define-honu-syntax stx)
+  (let-values ([(id rhs) (normalize-definition stx #'lambda #f)])
+    (with-syntax ([id id]
+                  [rhs rhs])
+      (syntax/loc stx
+                 (define-syntax id (make-honu-transformer rhs))))))
+
+
 (define-honu-syntax honu-provide
   (lambda (stx ctx)
     (syntax-parse stx
@@ -328,6 +330,8 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
        (values #'(provide something)
                #'rest)])))
 
+;; (honu-syntax ...)
+
 (define-honu-syntax honu-macro-item
   (lambda (stx ctx)
     (syntax-parse stx
@@ -465,11 +469,18 @@ if (foo){
 (define-syntax (honu-top stx)
   (raise-syntax-error #f "interactive use is not yet supported"))
 
+(define-syntax (foobar2000 stx)
+  (printf "Called foobar2000 on ~a\n" (syntax->datum stx))
+  (syntax-case stx ()
+    [(_ x y ...) #'(printf "foobar2000 ~a\n" x)]))
+
 (define (display2 x y)
   (printf "~a ~a" x y))
 
+
+
 (define-syntax (honu-unparsed-begin stx)
-  ;; (printf "honu unparsed begin: ~a\n" (syntax->datum stx))
+  (printf "honu unparsed begin: ~a\n" (syntax->datum stx))
   (syntax-case stx ()
     [(_) #'(begin (void))]
     [(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body
@@ -479,7 +490,8 @@ if (foo){
                   ;; (printf "Rest is ~a\n" (syntax->datum rest))
                   (with-syntax ([code code]
                                 [(rest ...) rest])
-                    #'(begin code (honu-unparsed-begin rest ...))))]
+                    (syntax/loc stx
+                                (begin code (honu-unparsed-begin rest ...)))))]
     #;
     [(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context
                                                            #'body 
@@ -490,9 +502,17 @@ if (foo){
                                 [(rest ...) rest])
                     #'(begin code (honu-unparsed-begin rest ...))))]))
 
+#;
 (define-syntax-rule (#%dynamic-honu-module-begin forms ...)
                     #;
                     (#%module-begin-typed-scheme
                      ;; (require honu/private/typed-utils)
                      (honu-unparsed-begin forms ...))
                     (#%plain-module-begin (honu-unparsed-begin forms ...)))
+
+(define-syntax (#%dynamic-honu-module-begin stx)
+  (syntax-case stx ()
+    [(_ forms ...)
+     (begin
+       (printf "Module begin ~a\n" (syntax->datum #'(forms ...)))
+       #'(#%plain-module-begin (honu-unparsed-begin forms ...)))]))

collects/honu/private/literals.rkt

@@ -16,4 +16,4 @@
                 honu-= honu-+= honu--= honu-*= honu-/= honu-%=
                 honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
                 honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
-                honu-? honu-: honu-comma honu-. #%braces)
+                honu-? honu-: honu-comma honu-. #%braces #%parens)

collects/honu/private/macro.rkt

@@ -1,6 +1,9 @@
 #lang scheme/base
 
 (require "honu-typed-scheme.ss"
+         "literals.ss"
+         "parse.ss"
+         "syntax.ss"
          (for-syntax "debug.ss"
                      "contexts.ss"
                      scheme/base
@@ -11,6 +14,17 @@
 
 (provide honu-macro)
 
+(define-syntax (ensure-defined stx)
+  (syntax-case stx ()
+    [(_ id ...)
+     (begin
+       (for-each (lambda (id)
+                   (syntax-local-value id (lambda () (raise-syntax-error 'syntax-id "not defined" id))))
+                 (syntax->list #'(id ...)))
+       #'(void))]))
+
+(ensure-defined #%parens #%braces)
+
 (define-for-syntax (extract-conventions pattern)
   (let loop ([out '()]
              [in pattern])
@@ -26,9 +40,6 @@
        (loop out #'(rest1 rest ...))]
       [(foo) out])))
 
-(define-syntax (semicolon stx)
-  stx)
-
 (define-for-syntax (extract-patterns pattern)
   (let loop ([out '()]
              [in pattern])
@@ -311,7 +322,8 @@
   (syntax-case stx ()
     [(_ x ...) (do-it #'(x ...))]))
 
-;; (provide unpull)
+(provide (for-syntax unpull))
+
 #;
 (define-honu-syntax unpull
   (lambda (stx ctx)
@@ -355,6 +367,23 @@
                                                      'pattern))]
              )))]))
 
+#;
+(define-syntax (honu-unparsed-expr stx)
+  (define (fix stx)
+    (printf "Fix ~a\n" (syntax->datum stx))
+    (syntax-parse stx #:literals (honu-syntax #%parens)
+      [(honu-syntax (#%parens x ...) y ...)
+       (with-syntax ([(y* ...) (fix #'(y ...))])
+         #'(x ... y* ...))]
+      [(z x ...)
+       (with-syntax ([z* (fix #'z)]
+                     [(x* ...) (fix #'(x ...))])
+         #'(z* x* ...))]
+      [else stx]
+      ))
+  (printf "unparsed expr ~a\n" stx)
+  (fix (stx-cdr stx)))
+
 (define-syntax (test2 stx)
   (syntax-case stx ()
     [(_ x ...)
@@ -383,7 +412,8 @@
                                           (syntax->list #'(pattern ...)))]
                      )
          (values
-          #'(define-honu-syntax name
+           (syntax/loc stx
+          (define-honu-syntax name
               (lambda (stx ctx)
                 ;; (define-literal-set literals (honu-literal ...))
                 (syntax-parse stx
@@ -397,16 +427,18 @@
                       (cond
                         [(type-context? ctx) (X)]
                         [(type-or-expression-context? ctx) (X)]
-                        [(expression-context? ctx) #'(honu-unparsed-expr out (... ...))]
+                        [(expression-context? ctx) (syntax/loc stx (honu-unparsed-expr (out (... ...))))]
                         [(expression-block-context? ctx)
-                         #'(honu-unparsed-begin out (... ...))]
+                         (syntax/loc stx 
+                         (honu-unparsed-begin out (... ...)))]
                         [(block-context? ctx)
-                         #'(honu-unparsed-begin out (... ...))]
+                         (syntax/loc stx
+                         (honu-unparsed-begin out (... ...)))]
                         [(variable-definition-context? ctx) (X)]
                         [(constant-definition-context? ctx) (X)]
                         [(function-definition-context? ctx) (X)]
                         [(prototype-context? ctx) (X)]
-                        [else #'(honu-unparsed-expr out (... ...))])
+                        [else (syntax/loc stx (out (... ...)))])
                       #;
                       #'(honu-unparsed-begin out (... ...))
                       #'rrest)
@@ -422,9 +454,22 @@
                          #f obj 'obj #f ctx
                          out (... ...) rrest)
                       #;
-                      #'rrest))])))
+                      #'rrest))]))))
           #'rest))]
-      [else (raise-syntax-error 'honu-macro "fail!")]
+      [(_ (m x ...)
+          (z y ...)
+          #;
+          (#%braces (#%braces name pattern ...))
+          . rest)
+       (begin
+         (printf "Got literals ~a\n" #'(x ...))
+         (printf "M is ~a, = to #%parens is ~a\n" #'m (free-identifier=? #'#%parens #'m))
+         (printf "Z is ~a, = to #%braces is ~a\n" #'z (free-identifier=? #'#%braces #'z))
+         (printf "Rest is ~a\n" (syntax->datum #'rest))
+         #;
+         (printf "Got name ~a pattern ~a\n" #'name #'(pattern ...))
+         (raise-syntax-error 'honu-macro "f1" stx))]
+      [else (raise-syntax-error 'honu-macro "fail" stx)]
       )))
 
 ;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...))

collects/honu/private/parse.rkt

@@ -3,11 +3,14 @@
 (require "contexts.ss"
          "util.ss"
          (for-template "literals.ss"
-                       "language.ss")
+                       "language.ss"
+                       "syntax.ss")
          syntax/parse
          syntax/parse/experimental/splicing
          (for-syntax syntax/parse)
          scheme/splicing
+         (for-syntax syntax/define)
+         syntax/name
          syntax/stx
          (for-syntax "util.ss")
          (for-template scheme/base))
@@ -40,8 +43,14 @@
   #:attrs (result)
   #:description "honu-expr"
   (lambda (stx fail)
+    (printf "Honu expr ~a\n" stx)
     (cond
      [(stx-null? stx) (fail)]
+     [(syntax-parse stx #:literals (honu-syntax)
+        [(honu-syntax expr ...) #'(expr ...)]
+        [else #f]) => (lambda (exprs)
+                               (printf "Ignoring honu-syntax 1!\n")
+                               (list exprs 0 #''()))]
      [(get-transformer stx) => (lambda (transformer)
                                  (printf "Transforming honu macro ~a\n" (car stx))
                                  (let-values ([(used rest)
@@ -55,8 +64,14 @@
   #:attributes (result)
   #:description "honu-expr"
   (lambda (stx fail)
+    (printf "Honu expr ~a\n" stx)
     (cond
      [(stx-null? stx) (fail)]
+     [(syntax-parse stx #:literals (honu-syntax)
+        [(honu-syntax expr ...) #'(expr ...)]
+        [else #f]) => (lambda (exprs)
+                               (printf "Ignoring honu-syntax 2!\n")
+                               (list '() 0 exprs))]
      [(get-transformer stx) => (lambda (transformer)
                                  (printf "Transforming honu macro ~a\n" (car stx))
                                  (let-values ([(used rest)
@@ -96,6 +111,7 @@
    (define-splicing-syntax-class (do-rest context left)
      (pattern (~seq (~var op operator-class)
                     (~var right (next context))
+
                     (~var new-right (do-rest context ((attribute op.func) left #'right.result))))
               #:with result (attribute new-right.result))
      (pattern (~seq) #:with result left))
@@ -203,6 +219,26 @@
                #:with result #'e.result])
 
 
+(define (fix-output stx)
+  #|
+  (printf "Fix output ~a\n" stx)
+  (when (and (stx-pair? stx) (equal? 'syntax (syntax->datum (stx-car stx))))
+    (printf "syntax == honu-syntax? ~a\n" (free-identifier=? (stx-car stx) #'honu-syntax)))
+  |#
+  (syntax-parse stx #:literals (honu-syntax #%parens syntax)
+    [((honu-syntax (#%parens x ...) y ...) rest ...)
+     (with-syntax ([(y* ...) (fix-output #'(y ... rest ...))])
+       (syntax/loc stx 
+       (x ... y* ...)))]
+    ;; dont touch real syntax
+    [(syntax stuff ...) stx]
+    [(z x ...)
+     (with-syntax ([z* (fix-output #'z)]
+                   [(x* ...) (fix-output #'(x ...))])
+       (syntax/loc stx
+                   (z* x* ...)))]
+    [else stx]))
+
 (define (parse-block-one/2 stx context)
   (define (parse-one stx context)
     
@@ -213,10 +249,30 @@
       #;
       [(x:number . rest) (values #'x #'rest)]
       ))
+  (printf "Parsing ~a\n" stx)
   (cond
     [(stx-null? stx) (values stx '())]
     [(get-transformer stx) => (lambda (transformer)
-                                (transformer stx context))]
+                                (printf "Parse one: execute transformer ~a\n" transformer)
+                                #;
+                                (printf "output of transformer is ~a\n" (let-values ([(a b) (transformer stx context)]) (list a b)))
+                                (call-values (transformer stx context)
+                                             (lambda (reparse rest)
+                                               (printf "Transformer gave us ~a\n" reparse)
+                                               #;
+                                               (values reparse rest)
+                                               #;
+                                               (values (fix-output reparse) rest)
+                                               #;
+                                               (printf "Macroized ~a and ~a\n" reparse rest)
+                                               (syntax-parse (fix-output reparse) #:literals (honu-unparsed-expr)
+                                                 [(honu-unparsed-expr stuff ...)
+                                                  (let-values ([(out rest2)
+                                                                (with-syntax ([(more ...) rest])
+                                                                  (parse-block-one/2 #'(stuff ... more ...) context))])
+                                                    (values out rest2))]
+                                                 [else (values reparse rest)]))
+                                             ))]
     [else (parse-one stx context)]))
 
 (define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
@@ -230,7 +286,6 @@
              (and (positive? (string-length str))
                   (memq (string-ref str 0) sym-chars)))))))
 
-
 (define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!)
   (make-struct-type 'honu-trans #f 1 0 #f
                     (list (list prop:honu-transformer #t))
@@ -246,6 +301,8 @@
   (make-honu-trans proc))
 
 
+
+
 ;; returns a transformer or #f
 (define (get-transformer stx)
   ;; if its an identifier and bound to a transformer return it
@@ -283,3 +340,14 @@
   ;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
   (or (bound-transformer stx)
       (special-transformer stx)))
+
+#;
+(define-honu-syntax honu-syntax
+  (lambda (stx ctx)
+  (syntax-case stx ()
+    [(_ expr ...)
+     (begin
+       (printf "Honu syntax on ~a\n" #'(expr ...))
+       (raise-syntax-error 'honu-syntax "should have been handled already")
+       #;
+       (parse-block-one/2 #'(expr ...) the-expression-context))])))

collects/honu/private/util.rkt

@@ -33,7 +33,7 @@
            (loop (stx-cdr r) (cons (stx-car r) val-stxs))]))]
     [(r ids) (extract-until r ids #f)]))
 
-(define-syntax-rule (call-values function values-producing)
+(define-syntax-rule (call-values values-producing function)
   (call-with-values (lambda () values-producing) function))
 
 ;; shortcut for treating arguments as syntax objects