From 83b320a301aebe16bb91a5ae32e7196d781c0114 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Fri, 3 May 2013 00:12:44 +0900
Subject: [PATCH] Adding parse-binary-op utility to (chibi parse common).

---
 lib/chibi/parse/common.scm | 55 ++++++++++++++++++++++++++++++++++++++
 lib/chibi/parse/common.sld |  1 +
 tests/parse-tests.scm      | 21 ++++++++++++++-
 3 files changed, 76 insertions(+), 1 deletion(-)

diff --git a/lib/chibi/parse/common.scm b/lib/chibi/parse/common.scm
index 3620d113..e5a0307d 100644
--- a/lib/chibi/parse/common.scm
+++ b/lib/chibi/parse/common.scm
@@ -162,6 +162,61 @@
                  (apply parse-or parse-end (map parse-string terms)))
       car))))
 
+(define parse-space (parse-char char-whitespace?))
+
+(define (op-value op) (car op))
+(define (op-prec op) (cadr op))
+(define (op-assoc op)
+  (let ((tail (cddr op))) (if (pair? tail) (car tail) 'left)))
+(define (op<? op1 op2)
+  (or (< (op-prec op1) (op-prec op2))
+      (and (= (op-prec op1) (op-prec op2))
+           (eq? 'right (op-assoc op1)))))
+
+;; rules are of the form ((op precedence [assoc=left]) ...)
+;; ls is of the forms (expr [op expr] ...)
+;; returns an sexp representation of the operator chain
+(define (resolve-operator-precedence rules ls)
+  (define (lookup op rules)
+    (or (assoc op rules)
+        (list op 0)))
+  (define (join exprs ops)
+    `((,(op-value (car ops)) ,(cadr exprs) ,(car exprs))
+      ,@(cddr exprs)))
+  (if (null? ls) (error "empty operator chain"))
+  (let lp ((ls (cdr ls)) (exprs (list (car ls))) (ops '((#f -1))))
+    ;; ls: trailing operations ([op expr] ...)
+    ;; exprs: list of expressions (expr expr ...)
+    ;; ops: operator chain, same len as exprs ((op prec [assoc]) ...)
+    (cond
+     ((and (null? ls) (null? (cdr exprs)))
+      (car exprs))
+     ((null? ls)
+      (lp ls (join exprs ops) (cdr ops)))
+     ((null? (cdr ls))
+      (error "unbalanced expression" ls))
+     (else
+      (let ((op (lookup (car ls) rules))
+            (expr (cadr ls)))
+        (if (or (null? (cdr ops)) (op<? op (car ops)))
+            (lp (cddr ls) (cons expr exprs) (cons op ops))
+            (lp ls (join exprs ops) (cdr ops))))))))
+
+(define (parse-binary-op op rules expr . o)
+  (let* ((ws (if (pair? o) (car o) (parse-repeat parse-space)))
+         (ws-right (if (and (pair? o) (pair? (cdr o))) (cadr o) ws)))
+    (parse-map
+     (parse-seq ws expr (parse-repeat (parse-seq ws-right op ws expr)))
+     (lambda (x)
+       (resolve-operator-precedence
+        rules
+        (cons (cadr x)
+              (apply append
+                     (map (lambda (y) (list (cadr y) (cadr (cddr y))))
+                          (car (cddr x))))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (define parse-ipv4-digit (parse-integer 0 255))
 
 (define parse-ipv4-address
diff --git a/lib/chibi/parse/common.sld b/lib/chibi/parse/common.sld
index 5c3ecb5c..08a6ca4d 100644
--- a/lib/chibi/parse/common.sld
+++ b/lib/chibi/parse/common.sld
@@ -3,6 +3,7 @@
   (export parse-integer parse-unsigned-integer parse-c-integer
           parse-real parse-complex
           parse-identifier parse-delimited parse-separated parse-records
+          parse-space parse-binary-op
           parse-ipv4-address parse-ipv6-address parse-ip-address
           parse-domain parse-common-domain parse-email parse-uri
           char-hex-digit? char-octal-digit?)
diff --git a/tests/parse-tests.scm b/tests/parse-tests.scm
index 91e54958..245eac6e 100644
--- a/tests/parse-tests.scm
+++ b/tests/parse-tests.scm
@@ -1,7 +1,7 @@
 
 (import (chibi) (chibi test)
         (chibi char-set) (chibi char-set ascii)
-        (chibi parse))
+        (chibi parse) (chibi parse common))
 
 (test-begin "parse")
 
@@ -98,6 +98,25 @@
 (test 25 (parse calculator "2+2 * 10+1 * 3"))
 (test 41 (parse calculator "(2 + 2) * 10 + 1"))
 
+(define prec-calc
+  (grammar expr
+    (simple (,(parse-integer))
+            ((: "(" (=> e1 ,expr) ")") e1))
+    (op
+     ("+" '+) ("-" '-) ("*" '*) ("/" '/) ("^" '^))
+    (expr
+     (,(parse-binary-op op `((+ 5) (- 5) (* 3) (/ 3) (^ 1 right)) simple)))))
+
+(test 42 (parse prec-calc "42"))
+(test '(+ 2 2) (parse prec-calc "2 + 2"))
+(test '(+ (+ 2 2) 2) (parse prec-calc "2 + 2 + 2"))
+(test '(+ (+ 2 (* 2 10)) 1) (parse prec-calc "2 + 2*10 + 1"))
+(test '(+ (+ 2 (* 2 10)) (* 1 3)) (parse prec-calc "2+2 * 10+1 * 3"))
+(test '(+ (* (+ 2 2) 10) 1) (parse prec-calc "(2 + 2) * 10 + 1"))
+(test '(^ 2 (^ 2 2)) (parse prec-calc "2 ^ 2 ^ 2"))
+(test '(+ (+ (+ 1 (* (* 2 (^ 3 (^ 4 5))) 6)) (^ 7 8)) 9)
+    (parse prec-calc "1 + 2 * 3 ^ 4 ^ 5 * 6 + 7 ^ 8 + 9"))
+
 ;; this takes exponential time without memoization
 (define explode
   (grammar start