refactored ebus code

5 files changed, 529 insertions, 0 deletions

diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/calc.ss b/ebus-racket/3rdparty/bzlib/parseq/example/calc.ss
new file mode 100644
index 0000000..35ada60
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/calc.ss
@@ -0,0 +1,51 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT 
+;; A Parser Combinator library.
+;; 
+;; Bonzai Lab, LLC.  All rights reserved.
+;; 
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; calc.ss - a simple arithmetic calculator  
+;; yc 12/31/2009 - first version 
+(require "../main.ss"
+         )
+
+;; determine the operator (currently there are no precedences)... 
+(define OP (tokens op <- (char-in '(#\+ #\- #\* #\/))
+                   (return (case op 
+                             ((#\+) +)
+                             ((#\-) -)
+                             ((#\*) *)
+                             ((#\/) /)))))
+
+(define NUMBER (token real-number)) 
+
+;; expr := term op term 
+(define expr (tokens lhs <- term 
+                     (let loop ((lhs lhs))
+                       (choice (tokens opr <- OP 
+                                       rhs <- term 
+                                       (loop (list opr lhs rhs)))
+                               (return lhs)))))
+;; term := factor op factor 
+(define term (tokens lhs <- factor 
+                     (let loop ((lhs lhs))
+                       (choice (tokens opr <- OP 
+                                       rhs <- factor 
+                                       (loop (list opr lhs rhs)))
+                               (return lhs)))))
+
+;; factor := number | ( exp ) 
+(define factor (choice NUMBER (bracket #\( expr #\))))
+
+(define (calc in) 
+  (define (helper exp)
+    (cond ((number? exp) exp)
+          ((pair? exp) 
+           (apply (car exp) 
+                  (map helper (cdr exp))))))
+  (helper ((make-reader expr) in))) 
+
+(provide calc) 
diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/csv.ss b/ebus-racket/3rdparty/bzlib/parseq/example/csv.ss
new file mode 100644
index 0000000..4fd1526
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/csv.ss
@@ -0,0 +1,42 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT 
+;; A Parser Combinator library.
+;; 
+;; Bonzai Lab, LLC.  All rights reserved.
+;; 
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; csv.ss - a customizable csv reader 
+;; yc 12/31/2009 - first version 
+(require "../main.ss"
+         )
+
+;; creating a delimiter-based string. 
+(define (delim-string delim)
+  (seq s <- (zero-many (choice (escaped-char #\\ delim) 
+                               (char-not-in (list delim #\return #\newline))))
+       (return (list->string s))))
+
+;; csv-string 
+;; combine between quoted string and delimited string 
+(define (csv-string delim)
+  (choice quoted-string (delim-string delim)))
+
+;; csv-record 
+;; reads a list of csv-strings by skipping over the delimiters
+(define (csv-record delim)
+  (delimited (csv-string delim) (char= delim)))
+
+;; csv-table
+;; reads over a csv-table 
+(define (csv-table delim) 
+  (delimited (csv-record delim) newline))
+
+;; make-csv-reader
+;; creates a csv-reader based on the delim... 
+(define (make-csv-reader delim)
+  (make-reader (csv-table delim))) 
+
+;; contract 
+(provide make-csv-reader) 
diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/json.ss b/ebus-racket/3rdparty/bzlib/parseq/example/json.ss
new file mode 100644
index 0000000..c8df746
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/json.ss
@@ -0,0 +1,135 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT 
+;; A Parser Combinator library.
+;; 
+;; Bonzai Lab, LLC.  All rights reserved.
+;; 
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; json.ss - a parser for the json format 
+;; yc 1/5/2010 - first version 
+;; yc 7/76/2010 - updated json-string to handle single quotes. 
+(require "../main.ss"
+         )
+
+(define hex-digit (seq d <- (choice digit #\a #\b #\c #\d #\e #\f
+                                    #\A #\B #\C #\D #\E #\F)
+                       (return (case d 
+                                 ((#\0) 0)
+                                 ((#\1) 1)
+                                 ((#\2) 2) 
+                                 ((#\3) 3)
+                                 ((#\4) 4)
+                                 ((#\5) 5)
+                                 ((#\6) 6) 
+                                 ((#\7) 7)
+                                 ((#\8) 8)
+                                 ((#\9) 9) 
+                                 ((#\a #\A) 10)
+                                 ((#\b #\B) 11)
+                                 ((#\c #\C) 12)
+                                 ((#\d #\D) 13)
+                                 ((#\e #\E) 14)
+                                 ((#\f #\F) 15)))))
+
+(define (hex->char h) 
+  (case h
+    ((0) #\0)
+    ((1) #\1)
+    ((2) #\2)
+    ((3) #\3) 
+    ((4) #\4) 
+    ((5) #\5) 
+    ((6) #\6)
+    ((7) #\7) 
+    ((8) #\8)
+    ((9) #\9) 
+    ((10) #\a)
+    ((11) #\b) 
+    ((12) #\c)
+    ((13) #\d) 
+    ((14) #\e) 
+    ((15) #\f)))
+
+
+(define (hexes->char hexes) 
+  (integer->char (hexes->integer hexes))) 
+
+(define (char->hexes c) 
+  (integer->hexes (char->integer c))) 
+
+(define (char->hex-chars c)
+  (map hex->char (char->hexes c))) 
+
+(define (hexes->integer hexes)
+  (define (helper rest acc) 
+    (cond ((null? rest) acc) 
+          (else
+           (helper (cdr rest) (+ (* acc 16) (car rest))))))
+  (helper hexes 0)) 
+
+(define (integer->hexes i) 
+  (define (helper q acc) 
+    (if (= q 0) 
+        acc 
+        (let-values (((q r) 
+                      (quotient/remainder q 16))) 
+          (helper q (cons r acc)))))
+  (helper i '()))
+
+(define unicode-char
+  (seq #\\ #\u 
+       code <- (repeat hex-digit 4 4) 
+       (return (hexes->char code)))) 
+
+(define (json-string/inner quote)
+  (zero-many (choice e-newline 
+                     e-return 
+                     e-tab 
+                     e-backslash 
+                     (escaped-char #\\ quote) 
+                     (escaped-char #\\ #\/) 
+                     (escaped-char #\\ #\\) 
+                     (escaped-char #\\ #\b #\backspace) 
+                     (escaped-char #\\ #\f #\page) 
+                     unicode-char
+                     (char-not-in  (list quote 
+                                         #\newline 
+                                         #\return 
+                                         #\tab 
+                                         #\\ 
+                                         #\backspace 
+                                         #\page))
+                     )))
+
+(define json-string
+  (choice (seq #\' atoms <- (json-string/inner #\') #\'
+               (return (list->string atoms)))
+          (seq #\" atoms <- (json-string/inner #\") #\" 
+               (return (list->string atoms)))))
+
+(define json-array (tokens v <- (bracket/delimited #\[ json-value #\, #\])
+                           (return (list->vector v))))
+
+(define json-object (tokens v <- (bracket/delimited #\{ json-pair #\, #\}) 
+                            (return (make-immutable-hash v))))
+
+(define json-pair (tokens key <- (choice json-string 
+                                         (seq c <- alpha 
+                                              lst <- (zero-many alphanumeric)
+                                              (return (list->string (cons c lst)))))
+                          #\: 
+                          value <- json-value 
+                          (return (cons key value)))) 
+
+(define json-literal (choice (tokens "true" (return #t)) 
+                             (tokens "false" (return #f))
+                             (tokens "null" (return '())) 
+                             ))
+
+(define json-value (choice json-literal json-array json-object real-number json-string)) 
+
+(define read-json (make-reader json-value)) 
+
+(provide read-json) 
diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/regex.ss b/ebus-racket/3rdparty/bzlib/parseq/example/regex.ss
new file mode 100644
index 0000000..299b999
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/regex.ss
@@ -0,0 +1,163 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT 
+;; A Parser Combinator library.
+;; 
+;; Bonzai Lab, LLC.  All rights reserved.
+;; 
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; regex.ss - a simple regular expression parser 
+;; yc 1/1/2009 - first version 
+(require "../main.ss"
+         mzlib/trace
+         )
+
+;; sof = start of file
+(define regex-sof (zero-one (char= #\^) #\$))
+
+;; eof = end of file 
+(define regex-eof (zero-one (char= #\$) #\^)) 
+
+;; meta-chars - a list of meta characters 
+(define regex-meta-chars '( #\. #\+ #\* #\? #\^ #\$ #\[ #\] #\( #\) #\{ #\} #\\))
+
+;; digit = \\d 
+(define regex-digit (seq "\\d" (return digit)))
+
+;; not-digit = \\D 
+(define regex-not-digit (seq "\\D" (return not-digit)))
+
+;; word = \\w 
+(define regex-word (seq "\\w" (return word)))
+
+;; not-word = \\W 
+(define regex-not-word (seq "\\W" (return not-word)))
+
+;; whitespace = \\s 
+(define regex-whitespace (seq "\\s" (return whitespace)))
+
+;; not-whitespace = \\S 
+(define regex-not-whitespace (seq "\\S" (return not-whitespace)))
+
+;; any-char = . 
+(define regex-any-char (seq #\. (return any-char))) 
+
+;; literal = \\d | \\D | \\w | \\W | \\s | \\S | . | \n | \r | \t | \\ | other chars
+(define regex-literal (choice regex-digit 
+                              regex-not-digit 
+                              regex-word 
+                              regex-not-word 
+                              regex-whitespace 
+                              regex-not-whitespace 
+                              regex-any-char 
+                              (seq v <- (choice e-newline
+                                                e-return
+                                                e-tab
+                                                (escaped-char #\\ any-char) 
+                                                (char-not-in regex-meta-chars))
+                                   (return (char= v))))) 
+
+;; atom = literal | group | choice 
+(define regex-atom (choice regex-literal
+                           regex-group
+                           regex-choice 
+                           )) 
+
+;; char-range = <lc>-<hc>, e.g., a-z 
+(define regex-char-range (seq lc <- (char-not-in (cons #\- regex-meta-chars))
+                              #\- 
+                              hc <- (char-not-in (cons #\- regex-meta-chars))
+                              (return `(,char-between ,lc ,hc))))
+
+;; choice = [<char-range | literal>+]
+(define regex-choice (seq #\[ 
+                          literals <- (one-many (choice regex-char-range 
+                                                     regex-literal))
+                          #\] 
+                          (return `(,one-of* ,@literals))))
+
+;; group = (<atom>+) 
+(define regex-group (seq #\( 
+                         chars <- (one-many regex-atom)
+                         #\) 
+                         (return `(,sequence* ,@chars))))
+
+;; regex combinators 
+;; zero-one = <atom>?
+(define regex-zero-one (seq v <- regex-atom 
+                            #\? 
+                            (return `(,zero-one ,v))))
+;; zero-many = <atom>* 
+(define regex-zero-many (seq v <- regex-atom 
+                             #\* 
+                             (return `(,zero-many ,v))))
+
+;; one-many = <atom>+ 
+(define regex-one-many (seq v <- regex-atom 
+                            #\+ 
+                            (return `(,one-many ,v))))
+
+;; range = <atom>{min,max} | <atom>{times} 
+(define regex-range (seq v <- regex-atom 
+                         #\{ 
+                         min <- (zero-one natural-number 0)
+                         max <- (zero-one (seq #\,
+                                               max <- (zero-one natural-number +inf.0)
+                                               (return max)) 
+                                          min)
+                         #\} 
+                         (return `(,repeat ,v ,min ,max))))
+
+;; exp = sof ? <zero-one | zero-many | one-many | range | atom>* eof ? 
+(define regex-exp (seq SOF 
+                       sof <- regex-sof 
+                       atoms <- (zero-many (choice regex-zero-one
+                                                   regex-zero-many
+                                                   regex-one-many
+                                                   regex-range 
+                                                   regex-atom
+                                                   ))
+                       eof <- regex-eof 
+                       EOF 
+                       (return `(,regex-parser* ,@(if (char=? sof #\^) 
+                                                      `(,SOF)
+                                                      '())
+                                                ,@atoms
+                                                ,@(if (char=? eof #\$)
+                                                      `(,EOF)
+                                                      '())))))
+
+;; regex-parser 
+;; convert the regexp into an useable parser, which including determining 
+;; whether to allow for 
+(define (regex-parser parsers) 
+  (let ((regexp (sequence parsers)))
+    (if (eq? (car parsers) SOF)
+        regexp 
+        (seq v <- (choice regexp 
+                          (seq any-char (regex-parser parsers)))
+             (return v)))))
+
+;; regex-parser* 
+;; the variable arg form of regex-parser
+(define (regex-parser* parser . parsers)
+  (regex-parser (cons parser parsers)))
+
+;; make-regex-exp 
+;; wrapper over regex... 
+(define (make-regex-exp in)
+  (define (helper exp)
+    (cond ((list? exp) (apply (car exp) (map helper (cdr exp))))
+          (else exp)))
+  ;; (trace helper)
+  (let-values (((exp in)
+                (regex-exp (make-input in))))
+    (if (failed? exp) 
+        (error 'make-regex-exp "the regular expression is invalid")
+        (lambda (in) 
+          ((helper exp) (make-input in))))))
+
+(provide regex-parser 
+         make-regex-exp
+         )
diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/sql.ss b/ebus-racket/3rdparty/bzlib/parseq/example/sql.ss
new file mode 100644
index 0000000..3863ab1
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/sql.ss
@@ -0,0 +1,138 @@
+#lang scheme
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT 
+;; A Parser Combinator library.
+;; 
+;; Bonzai Lab, LLC.  All rights reserved.
+;; 
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; sql.ss - parsing the create table statement  
+;; yc 1/5/2010 - first version 
+(require "../main.ss"
+         mzlib/defmacro
+         (for-syntax scheme/base
+                     scheme/match
+                     )
+         (planet bzlib/base) 
+         ) 
+
+(define sql-identifier 
+  (seq c <- alpha 
+       rest <- (zero-many word) 
+       (return (string->symbol 
+                (string-downcase (list->string (cons c rest)))))))
+
+(define create-table-def
+  (tokens-ci "create" "table"
+             name <- sql-identifier 
+             clauses <- (bracket #\( 
+                                 (delimited clause-def #\,)  
+                                 #\)) 
+             (return (cons name clauses))))
+
+(define clause-def 
+  (choice primary-key-def foreign-key-def column-def)) 
+
+;; making things without order would be quite a difficult combinator. 
+;; basically we need to try each of the combinator, and then as we have the binding
+;; make sure it is returned in a way that can easily be identified... 
+;; for example, the first 
+(define (self-and-value parser) 
+  (seq v <- parser 
+       (return (cons parser v)))) 
+
+(define (one-of-each parsers defaults) 
+  ;; we need to try each one, and then figure out the *rest* that weren't matched
+  ;; continue until we are either out of the stream or out of the combinator... 
+  ;; at any time there is anything that none of them matches then we will be in trouble... 
+  (define (each-helper parsers) 
+    (one-of (map self-and-value parsers))) 
+  (define (sort-helper acc parsers defaults) 
+    (map (lambda (v default) 
+           (if (pair? v) 
+               (cdr v) 
+               default)) 
+         (map (lambda (parser) 
+                (assf (lambda (p) 
+                        (eq? p parser)) 
+                      acc)) 
+              parsers)
+         defaults))
+  ;; if all of them failed @ the next position, then we need to offer 
+  ;; default values for the remainder of the parsers!!! 
+  ;; this is where it is *interesting!!!... 
+  ;; in such case we want to have a chance to work on the *fail* clause... 
+  ;; this is hmm.... 
+  (define (helper rest acc) 
+    (bind (each-helper rest) 
+          (lambda (v) 
+            (if (succeeded? v) 
+                (let ((rest (remove (car v) rest))) 
+                  (if (null? rest) 
+                      (return (sort-helper acc parsers defaults))
+                      (helper rest (cons v acc))))
+                (return (sort-helper acc parsers defaults))))))
+  (helper parsers '())) 
+
+(define-syntax one-of-each* 
+  (syntax-rules () 
+    ((~ (parser default) ...) 
+     (one-of-each (list parser ...) (list default ...)))))
+
+(define column-def 
+  (tokens name <- sql-identifier
+          attrs <- (one-of-each* (type-def 'text)
+                                 (nullability 'null) 
+                                 (inline-primary-key #f) 
+                                 (inline-foreign-key #f))
+          (return (cons name attrs))))
+
+(define nullability 
+  (choice (tokens-ci "null" (return 'null)) 
+          (tokens-ci "not" "null" (return 'not-null))))
+
+(define type-def 
+  (seq type <- (choice (string-ci= "int")
+                       (string-ci= "integer") 
+                       (string-ci= "float")
+                       (string-ci= "text"))
+       (return (string->symbol type))))
+
+(define inline-primary-key 
+  (tokens-ci "primary" "key" (return 'pkey)))
+;; (trace inline-primary-key) 
+
+(define sql-identifiers/paren 
+  (bracket #\( (delimited sql-identifier #\,) #\))) 
+
+(define inline-foreign-key 
+  (tokens-ci "foreign" "key"  
+             (zero-one (string-ci= "references") "references") 
+             table <- sql-identifier 
+             (zero-one (string-ci= "on") "on") 
+             columns <- sql-identifiers/paren 
+             (return `(foreign-key ,table ,columns))))
+
+(define primary-key-def 
+  (tokens-ci "primary" "key" 
+             name <- (zero-one sql-identifier #f) 
+             columns <- sql-identifiers/paren  
+             (return `(primary-key ,name ,columns))))
+
+(define foreign-key-def 
+  (tokens-ci "foreign" "key" 
+             name <- (zero-one sql-identifier #f) 
+             columns <- sql-identifiers/paren 
+             (string-ci= "references")
+             table <- sql-identifier 
+             (zero-one (string-ci= "on") "on") 
+             fk-columns <- sql-identifiers/paren 
+             (return `(foreign-key ,name ,columns ,table ,fk-columns))))
+
+;; (provide create-table-def) 
+(define sql-def (choice create-table-def))
+
+(define read-sql (make-reader sql-def)) 
+
+(provide read-sql)