[honu] honu forms implemented in racket must call honu->racket on the parsed output. add an example to do ocaml style pattern matching

collects/honu/core/main.rkt

@@ -76,6 +76,7 @@
                                    [literal:semicolon %semicolon]
                                    [literal:honu-comma %comma]
                                    [literal:honu-comma %comma]
+                                   [literal:honu-$ $]
                                    [literal:honu-<- <-]
                                    [literal:honu-in-lines inLines]
                                    [literal:#%brackets #%brackets]

collects/honu/core/private/compile.rkt

@@ -1,14 +1,20 @@
 #lang racket/base
 
 (require syntax/parse
+         (for-syntax racket/base "debug.rkt" syntax/parse)
          "literals.rkt")
 
+;; to get syntax as a literal
+(require (for-template racket/base))
+
 (provide (all-defined-out))
 
 (define (honu->racket forms)
   (define-literal-set literals (%racket))
   (syntax-parse forms #:literal-sets (literals)
+    #:literals ([literal-syntax syntax])
     [(%racket x) (honu->racket #'x)]
+    [(literal-syntax form) #'#'form]
     [(form ...)
      (datum->syntax forms
                     (map honu->racket (syntax->list #'(form ...)))
@@ -26,3 +32,31 @@
   (syntax-parse code
     [(x:stopper rest ...) (strip-stops #'(rest ...))]
     [else code]))
+
+(define-syntax repeat$ (lambda (stx) (raise-syntax-error 'repeat$ "dont use this")))
+
+(define-syntax (unexpand-honu-syntax stx)
+  (define (remove-repeats input)
+    (debug "Remove repeats from ~a\n" (syntax->datum input))
+    (define-literal-set locals (repeat$))
+    (syntax-parse input #:literal-sets (locals)
+      [(out ... (repeat$ stuff ...) rest ...)
+       (debug " Found a repeat\n")
+       (with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))]
+                     [(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))])
+         (remove-repeats #'(out* ... stuff ... rest* ...)))]
+      [(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))])
+                      (datum->syntax input
+                                     #'(normal* ...)
+                                     input input))]
+      [x #'x]
+      [else (raise-syntax-error 'repeats "unhandled case" input)]))
+
+  (syntax-case stx ()
+    [(_ expr)
+     (begin
+       (debug "Expand honu syntax at phase ~a\n" (syntax-local-phase-level))
+       (debug " Is ~a expanded ~a\n" (syntax->datum #'expr) (syntax->datum #'#'expr))
+       (define removed (remove-repeats #'expr))
+       (debug "Cleansed ~a\n" (syntax->datum removed))
+       removed)]))

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

@@ -475,7 +475,10 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
      ;; if parsed is #f then we don't want to expand to anything that will print
      ;; so use an empty form, begin, `parsed' could be #f becuase there was no expression
      ;; in the input such as parsing just ";".
-     (with-syntax ([parsed (if (not parsed) #'(begin) (honu->racket parsed))]
+     (with-syntax ([parsed (if (not parsed) #'(begin)
+                             parsed
+                             #;
+                             (honu->racket parsed))]
                    [(unparsed ...) unparsed])
        (debug "Final parsed syntax\n~a\n" (pretty-format (syntax->datum #'parsed)))
        (if (null? (syntax->datum #'(unparsed ...)))

collects/honu/core/private/honu2.rkt

@@ -333,7 +333,9 @@
   (lambda (code context)
     (syntax-parse code #:literal-sets (cruft)
       [(var:honu-declaration . rest)
-       (define result #'(%racket (define-values (var.name ...) var.expression)))
+       (define result 
+         (with-syntax ([var.expression (honu->racket #'var.expression)])
+           #'(%racket (define-values (var.name ...) var.expression))))
        (values result #'rest #t)])))
 
 (provide (rename-out [honu-with-syntax withSyntax]))

collects/honu/core/private/literals.rkt

@@ -31,6 +31,7 @@
                 honu-for-syntax
                 honu-for-template
                 honu-prefix
+                honu-$
                 ;; FIXME: in-lines should probably not be here
                 honu-in-lines
                 %racket)

collects/honu/core/private/macro2.rkt

@@ -8,6 +8,7 @@
                      "literals.rkt"
                      "parse2.rkt"
                      "debug.rkt"
+                     "compile.rkt"
                      racket/base)
          (for-meta 2 syntax/parse
                      racket/base
@@ -15,6 +16,7 @@
                      "compile.rkt")
          "literals.rkt"
          "syntax.rkt"
+         (for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt")
          #;
          (for-syntax "honu-typed-scheme.rkt")
          syntax/parse)
@@ -155,14 +157,29 @@
 ;; Do any honu-specific expansion here
 (define-honu-syntax honu-syntax
   (lambda (code context)
+    (define (compress-dollars stx)
+      (define-literal-set local-literals (honu-$))
+      (syntax-parse stx #:literal-sets (local-literals)
+        [(honu-$ x ... honu-$ rest ...)
+         (with-syntax ([(rest* ...) (compress-dollars #'(rest ...))])
+           #'((repeat$ x ...) rest* ...))]
+        [(x rest ...)
+         (with-syntax ([x* (compress-dollars #'x)]
+                       [(rest* ...) (compress-dollars #'(rest ...))])
+           #'(x* rest* ...))]
+        [x #'x]))
     (syntax-parse code #:literal-sets (cruft)
       [(_ (#%parens stuff ...) . rest)
        (define context (stx-car #'(stuff ...)))
+       (define compressed (compress-dollars #'(stuff ...)))
        (values
          (with-syntax ([stuff* (datum->syntax context
-                                              (syntax->list #'(stuff ...))
+                                              (syntax->list compressed)
                                               context context)])
-           #'(%racket #'stuff*))
+           ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*))
+           ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*))
+           (with-syntax ([(out ...) #'stuff*])
+             #'(%racket #'(%racket (unexpand-honu-syntax (do-parse-rest-macro out ...))))))
          #; #'(%racket-expression (parse-stuff stuff ...))
          #'rest
          #f)])))
@@ -179,17 +196,7 @@
 (provide honu-pattern)
 (define-honu-syntax honu-pattern
   (lambda (code context)
-    (define (bind-to-results pattern)
+    (define (generate-pattern name literals original-pattern maybe-out)
-      (with-syntax ([((pattern-variable.name pattern-variable.result) ...)
-                    (find-pattern-variables pattern)])
-        (with-syntax ([(each ...)
-                       (for/list ([name (syntax->list #'(pattern-variable.name ...))]
-                                  [result (syntax->list #'(pattern-variable.result ...))])
-                         (with-syntax ([name name]
-                                       [result result])
-                           #'(#:with result result)))])
-          #'(each ...))))
-    (define (generate-pattern name literals original-pattern)
       (define variables (find-pattern-variables original-pattern))
       (define use (generate-temporaries variables))
       (define mapping (make-hash))
@@ -206,8 +213,10 @@
                     [(literal ...) literals]
                     [(new-pattern ...) (convert-pattern original-pattern mapping)]
                     [((withs ...) ...) withs]
-                    #;
+                    [(result-with ...) (if maybe-out
-                    [((bindings ...) ...) (bind-to-results original-pattern)])
+                                         (with-syntax ([(out ...) maybe-out])
+                                           #'(#:with result (syntax out ...)))
+                                         #'())])
         #'(%racket (begin-for-syntax
                      (define-literal-set local-literals (literal ...))
                      (define-splicing-syntax-class name
@@ -215,12 +224,15 @@
                                        [local-literals #:at name])
                        [pattern (~seq new-pattern ...)
                                 withs ... ...
-                                ; bindings ... ...
+                                result-with ...
                                 ])))))
     (syntax-parse code #:literal-sets (cruft)
       [(_ name (#%parens literal ...)
           (#%braces pattern ...)
+          (~optional (#%braces out ...))
           . rest)
-       (values (generate-pattern #'name #'(literal ...) #'(pattern ...))
+       (values (generate-pattern #'name #'(literal ...)
+                                 #'(pattern ...)
+                                 (attribute out))
                #'rest
                #f)])))

collects/honu/core/private/parse-helper.rkt

@@ -0,0 +1,11 @@
+#lang racket/base
+
+(require (for-syntax racket/base
+                     "parse2.rkt"))
+
+(provide (all-defined-out))
+
+(define-syntax (do-parse-rest-macro stx)
+  (syntax-case stx ()
+    [(_ stuff ...)
+     (do-parse-rest #'(stuff ...) #'do-parse-rest-macro)]))

collects/honu/core/private/parse2.rkt

@@ -154,13 +154,16 @@
   (debug 2 "Comma? ~a ~a\n" what is)
   is)
 
+(provide do-parse-rest)
 (define (do-parse-rest stx parse-more)
   (syntax-parse stx
-    [(_ stuff ...)
+    [(stuff ...)
      (define-values (parsed unparsed)
                     (parse (strip-stops #'(stuff ...))))
      (debug "Parse more: ~a unparsed ~a\n" parsed unparsed)
      (define output (if parsed
+                      parsed
+                      #;
                       (honu->racket parsed)
                       #'(void)))
      (debug "Output ~a\n" output)
@@ -169,20 +172,29 @@
                    [parse-more parse-more])
        (if (null? (syntax->datum #'(unparsed-out ...)))
          #'output
-         #'(begin output (parse-more unparsed-out ...))))]))
+         #'(begin output (parse-more unparsed-out ...))))]
+    [() #'(begin)]))
 
 (define (do-parse-rest/local stx)
   (define name (gensym 'local-parser))
   (define local-parser (with-syntax ([name name])
                          #'(define-syntax (name stx)
-                           (do-parse-rest stx #'name))))
+                             (syntax-case stx ()
+                               [(_ stuff (... ...))
+                                (do-parse-rest #'(stuff (... ...)) #'name)]))))
   (with-syntax ([local local-parser]
                 [parsed (do-parse-rest stx name)])
-    #'(begin local parsed)))
+    (with-syntax ([(stx ...) stx]
+                  [name name])
+      #'(begin local (name stx ...)))))
 
+#|
+(provide do-parse-rest-macro)
 (define-syntax (do-parse-rest-macro stx)
-  (with-syntax ([stx stx])
+  (syntax-case stx ()
-    #'(do-parse-rest stx #'do-parse-rest-macro)))
+    [(_ stuff ...)
+     (do-parse-rest #'(stuff ...) #'do-parse-rest-macro)]))
+|#
 
 (provide honu-body)
 (define-syntax-class honu-body
@@ -259,7 +271,7 @@
                       precedence left current)
             (define re-parse 
               (with-syntax ([(x ...) #'parsed])
-                (do-parse-rest/local #'(nothing x ...))))
+                (do-parse-rest/local #'(x ...))))
             (debug "Reparsed ~a\n" (pretty-format (syntax->datum re-parse)))
             #;
             (define re-parse (let-values ([(re-parse re-unparse)
@@ -287,7 +299,8 @@
       [pattern x:str]
       [pattern x:number])
 
-    (debug "parse ~a precedence ~a left ~a current ~a\n" (syntax->datum stream) precedence left current)
+    (debug "parse ~a precedence ~a left ~a current ~a\n"
+           (syntax->datum stream) precedence left current)
     (define final (if current current #f))
     (syntax-parse stream #:literal-sets (cruft)
       #;
@@ -299,7 +312,7 @@
        (debug "Native racket expression ~a\n" #'racket)
        (if current
          (values (left current) stream)
-         (values (left stream) #'()))
+         (values (left #'racket) #'()))
        #;
        (if current
          (values (left current) stream)
@@ -325,7 +338,6 @@
          [(honu-macro? #'head)
           (debug "Macro ~a\n" #'head)
           (do-macro #'head #'(rest ...) precedence left current stream)]
-         #;
          [(parsed-syntax? #'head)
           (debug "Parsed syntax ~a\n" #'head)
           (do-parse #'(rest ...) precedence left #'head)]

collects/honu/core/read.rkt

@@ -37,8 +37,8 @@
                                          (:~ #\")))
 (define-lex-abbrev string (:: #\" (:* string-character) #\"))
 (define-lex-abbrev operator (:or "+=" "-=" "*=" "/="
-                                 "+" "!=" "=" "==" "*" "/" "-" "^" "||" "|" "&&" "<="
+                                 "+" "!=" "=>" "=" "==" "*" "/" "-" "^" "||" "|" "&&" "<="
-                                 ">=" "<-" "<" ">" "!" "::" ":=" "%"))
+                                 ">=" "<-" "<" ">" "!" "::" ":=" "%" "$"))
 (define-lex-abbrev block-comment (:: "/*"
                                      (complement (:: any-string "*/" any-string))
                                      "*/"))

collects/honu/private/common.rkt

@@ -5,6 +5,7 @@
          (for-syntax syntax/parse
                      racket/base
                      honu/core/private/literals
+                     honu/core/private/compile
                      honu/core/private/parse2))
 
 (provide sqr)
@@ -22,8 +23,10 @@
       [(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ...
           . rest)
        (values
+         (with-syntax ([(clause.result ...) (map honu->racket (syntax->list #'(clause.result ...)))]
+                       [(body.result ...) (map honu->racket (syntax->list #'(body.result ...)))])
            #'(%racket (cond
                         [clause.result body.result]
-                      ...))
+                        ...)))
          #'rest
          #t)])))

collects/tests/honu/match.honu

@@ -0,0 +1,31 @@
+#lang honu
+
+var => = 0
+
+pattern match_pattern (){ [element:expression] } { [element] }
+
+pattern match_clause (| =>){ | pattern:match_pattern => out:expression , }
+
+macro mymatch(with){
+  thing:expression with
+  clause:match_clause ...
+} {
+  syntax(
+    cond
+     $ clause_pattern == thing: clause_out, $ ...
+     else: -2
+
+    /*
+    if (clause_pattern == thing){
+      clause_out
+    } else {
+      -2
+    }
+    */)
+}
+
+mymatch [1] with
+| [1] => 5,
+| [2] => 6,
+
+// mymatch [1] with | [2] => 5