parse operators

collects/honu/core/private/honu2.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 
 (require "macro2.rkt"
+         "operator.rkt"
          (for-syntax syntax/parse
                      "literals.rkt"
                      "parse2.rkt"
@@ -20,3 +21,10 @@
                                       (parse #'(code ...)))])
                (do-parse)))
          #'rest)])))
+
+(provide honu-+)
+(define-honu-operator/syntax honu-+ 1
+                             (lambda (left right)
+                               (with-syntax ([left left]
+                                             [right right])
+                                 #'(+ left right))))

collects/honu/core/private/operator.rkt

@@ -0,0 +1,11 @@
+#lang racket/base
+
+(require (for-syntax racket/base
+                     "transformer.rkt"
+                     syntax/parse))
+
+(provide define-honu-operator/syntax)
+(define-syntax (define-honu-operator/syntax stx)
+  (syntax-parse stx
+    [(_ name precedence function)
+     #'(define-syntax name (make-honu-operator precedence function))]))

collects/honu/core/private/parse2.rkt

@@ -42,6 +42,11 @@
     (with-syntax ([check check])
       #'(syntax-local-value check #'check (lambda () #f))))) 
 
+(define (bound-to-operator? check)
+  (let ([value (get-value check)])
+    (debug "operator? ~a ~a\n" check value)
+    (transformer:honu-operator? value)))
+
 (define (bound-to-macro? check)
   (let ([value (get-value check)])
     (debug "macro? ~a ~a\n" check value)
@@ -54,6 +59,10 @@
   (and (identifier? something)
        (bound-to-macro? something)))
 
+(define (honu-operator? something)
+  (and (identifier? something)
+       (bound-to-operator? something)))
+
 (define (semicolon? what)
   (define-literal-set check (semicolon))
   (and (identifier? what)
@@ -81,16 +90,32 @@
                                                                   current))])
                                        parsed
                                        (more-parsing . rest)))))]
+         [(honu-operator? #'head)
+          (define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0))
+          (define operator-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 1))
+          (define association 'left)
+          (define check
+            (case association
+              [(left) >]
+              [(right) >=]))
+          (printf "new precedence ~a\n" new-precedence)
+          (if (check new-precedence precedence)
+            (do-parse #'(rest ...) new-precedence
+                      (lambda (stuff)
+                        (operator-transformer left stuff))
+                      current)
+            (left current))]
          [(semicolon? #'head)
           (with-syntax ([so-far left])
             #'(splicing-let-syntax ([more (lambda (stx)
                                             (parse #'(rest ...)))])
                 so-far (more)))]
-
          [(identifier? #'head)
           (do-parse #'(rest ...) precedence #'head current)]
          [else (syntax-parse #'head
                  #:literal-sets (cruft)
+                 [x:number (do-parse #'(rest ...)
+                                     precedence (left #'x) current)]
                  [(#%parens args ...)
                   (debug "function call ~a\n" left)
                   (with-syntax ([left left])
@@ -101,7 +126,7 @@
 
          )]))
 
-  (do-parse input 0 #'(void) #'(void)))
+  (do-parse input 0 (lambda (x) x) #'(void)))
 
 (define (parse2 forms)
   (debug "parse forms ~a\n" forms)

collects/honu/core/private/transformer.rkt

@@ -2,8 +2,11 @@
 
 (require (for-syntax racket/base))
 
+#;
 (provide (all-defined-out))
 
+(provide honu-transformer? make-honu-transformer)
+
 (define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
                (make-struct-type-property 'honu-transformer))
 
@@ -20,3 +23,26 @@
       "procedure (arity 2)"
       proc))
   (make-honu-trans proc))
+
+(provide (rename-out [prop:honu-operator? honu-operator?])
+         make-honu-operator
+         (rename-out [-honu-operator-ref honu-operator-ref]))
+(define-values (prop:honu-operator prop:honu-operator? prop:honu-operator-ref)
+               (make-struct-type-property 'honu-operator))
+
+#;
+(provide honu-operator?)
+(define-values (struct:honu-operator -make-honu-operator honu-operator? -honu-operator-ref honu-operator-set!)
+               (make-struct-type 'honu-operator #f 2 0 #f 
+                                 (list (list prop:honu-operator #t))
+                                 (current-inspector) 0))
+
+(define (make-honu-operator precedence proc)
+  (unless (and (procedure? proc)
+               (procedure-arity-includes? proc 2))
+    (raise-type-error
+      'define-honu-operator/syntax
+      "procedure (arity 2)"
+      proc))
+  (-make-honu-operator precedence proc))
+

collects/tests/honu/test.rkt

@@ -3,7 +3,8 @@
 (require 
   (prefix-in macro_ honu/core/private/macro2)
   (rename-in honu/core/private/honu2
-             [honu-function honu_function])
+             [honu-function honu_function]
+             [honu-+ honu_plus])
   (rename-in honu/core/private/literals
              [honu-= =]
              [semicolon |;|])
@@ -41,3 +42,7 @@
                                        print(x)
                                        }))
   (test 5))
+
+
+(let ()
+  (fake-module-begin #hx(1 honu_plus 1)))