Commits

Anonymous committed 909adbd

Iniital commit

Comments (0)

Files changed (3)

+;; Based on http://common-lisp.net/~dcrampsie/smug.html
+;; Inspired by https://github.com/joshua-choi/fnparse/
+
+(module comparse
+
+(parse 
+ fail result item bind satisfies is char-seq maybe
+ sequence sequence* repeated  zero-or-more one-or-more
+ any-of none-of followed-by
+ as-string)
+
+(import chicken scheme)
+
+(use data-structures lazy-seq srfi-14 extras)
+
+(define ((result value) input)
+  (cons value input))
+
+(define fail
+  (constantly #f))
+
+(define (item input)
+  (and (not (lazy-null? input))
+       (cons (lazy-head input)
+             (lazy-tail input))))
+
+(define ((bind parser proc) input)
+  (and-let* ((value (parser input)))
+    ((proc (car value)) (cdr value))))
+
+(define (satisfies condition)
+  (if (char-set? condition)
+      (satisfies (lambda (c)
+                   (and (char? c)
+                        (char-set-contains? condition c))))
+      (bind item (lambda (x)
+                   (if (condition x)
+                       (result x)
+                       fail)))))
+
+(define (is x)
+  (satisfies (lambda (y) (eq? x y))))
+
+(define-syntax sequence*
+  (syntax-rules ()
+    ((_ () body ...)
+     (begin body ...))
+    ((_ ((binding parser) more-bindings ...) body ...)
+     (bind parser
+           (lambda (binding)
+             (sequence* (more-bindings ...) body ...))))))
+
+(define ((char-seq str) input)
+  (let ((len (string-length str)))
+    (let loop ((pos 0) (input input))
+      (if (= len pos)
+          (cons str input)
+          (and (< pos len)
+               (not (lazy-null? input))
+               (eq? (lazy-head input) (string-ref str pos))
+               (loop (+ pos 1) (lazy-tail input)))))))
+
+(define ((any-of parser . parsers) input)
+  (let loop ((parsers (cons parser parsers)))
+    (and (not (null? parsers))
+         (or ((car parsers) input)
+             (loop (cdr parsers))))))
+
+(define (sequence parser . parsers)
+  (let loop ((parsers (cons parser parsers)))
+    (bind (car parsers)
+          (lambda (value)
+            (if (null? (cdr parsers))
+                (result value)
+                (loop (cdr parsers)))))))
+
+(define ((none-of parser . parsers) input)
+  (let loop ((parsers (cons parser parsers)))
+    (if (null? parsers)
+        (cons #t input)
+        (and (not ((car parsers) input))
+             (loop (cdr parsers))))))
+
+(define ((followed-by parser following) input)
+  (let ((value (parser input)))
+    (and value (following (cdr value)) value)))
+
+(define (->parser object)
+  (cond ((procedure? object) object)
+        ((char-set? object) (satisfies object))
+        ((char? object) (is object))
+        ((string? object) (char-seq object))
+        (else (error "Don't know how to turn object into parser" object))))
+
+(define (zero-or-more parser)
+  (any-of (sequence* ((x parser)
+                      (xs (zero-or-more parser)))
+            (result (cons x xs)))
+          (result '())))
+
+(define (one-or-more parser)
+  (sequence* ((x parser)
+              (y (zero-or-more parser)))
+    (result (cons x y))))
+
+(define (repeated parser #!key (min 0) max)
+  (let loop ((min min) (max max))
+    (any-of (sequence* ((x parser)
+                        (y (loop (- min 1)
+                                 (and max (- max 1)))))
+              (result (cons x y)))
+            (if (and (<= min 0) (or (not max) (>= max 0)))
+                (result '())
+                fail))))
+
+(define (maybe parser)
+  (any-of parser (result #f)))
+
+(define (as-string parser)
+  (sequence* ((chars parser))
+    (result (list->string chars))))
+
+(define (->lazy-seq x)
+  (cond ((lazy-seq? x) x)
+        ((string? x) (list->lazy-seq (string->list x)))
+        ((input-port? x) (input-port->lazy-seq x read-char))
+        (else (error "Don't know how to turn object into lazy-seq" x))))
+
+(define (parse parser input)
+  (let* ((input (->lazy-seq input))
+         (result (parser (->lazy-seq input))))
+    (if result
+        (values (car result) (cdr result))
+        (values result input))))
+
+)
+(compile -d0 -O2 -J -s "comparse.scm")
+(compile -d0 -O2 -s "comparse.import.scm")
+
+(install-extension
+ 'comparse
+ '("comparse.so" "comparse.import.so")
+ '((version "0.0.1")))
+(load "comparse.scm")
+(import comparse)
+(use test lazy-seq)
+
+(define-syntax test-parse
+  (syntax-rules ()
+    ((_ expect parser input)
+     (test expect (parse parser input)))))
+
+(define-syntax test-parse*
+  (syntax-rules ()
+    ((_ expect parser input)
+     (test-parse expect (as-string parser) input))))
+
+(test-parse* "aaba" (repeated (satisfies (char-set #\a #\b))) "aabac")
+(test-parse* "   " (repeated (is #\space) max: 3) "      ")
+(test-parse* "" (repeated (is #\f)) "x")
+(test-parse* #f (repeated (is #\a) min: 1) "b")
+(test-parse #\a (sequence (none-of (is #\b) (is #\c)) item) "a")
+(test-parse* "b52" (zero-or-more (any-of (satisfies char-set:digit) (is #\b))) "b52s")
+
+(test-parse #f (none-of (is #\b) (is #\a)) "a")
+
+(test-parse* "ab"
+             (sequence* 
+                 ((a (is #\a)) (b (is #\b)))
+               (result (list a b)))
+             "abc")
+
+(test-group "tests one-or-more / zero-or-more"
+  (test-parse* "ooooo" (one-or-more (is #\o)) "ooooom")
+  (test-parse* #f (one-or-more (is #\o)) "m")
+  (test-parse* "oo" (zero-or-more (is #\o)) "oommm")
+  (test-parse* "" (zero-or-more (is #\o)) "m"))
+
+(test-group "char-seq"
+  (test-parse "" (char-seq "") "hey")
+  (test-parse "hey" (char-seq "hey") "heyyy")
+  (test-parse #f (char-seq "hey") "he"))
+
+
+(define (quoted-string #!key
+                       (delimiter (satisfies (char-set #\" #\')))
+                       (escape (is #\\)))
+  (let ((escaped-char (sequence escape item)))
+    (sequence* ((_ (zero-or-more (satisfies char-set:whitespace)))
+                (actual-delimiter delimiter)
+                (chars (zero-or-more
+                        (any-of escaped-char
+                                (sequence (none-of escape (is actual-delimiter))
+                                          item))))
+                (_ (is actual-delimiter)))
+      (result (list->string chars)))))
+
+(test-assert (not (parse (quoted-string) "this ain't a string")))
+(test "nice" (parse (quoted-string) "\"nice\""))
+
+(receive (result rest) (parse (quoted-string) "\"string 1\" 'string 2'  some trailing ")
+  (test "string 1" result)
+  (receive (result rest) (parse (quoted-string) rest)
+    (test "string 2" result)
+    (receive (result rest) (parse (quoted-string) rest)
+      (test-assert (not result))
+      (test "  some trailing " (list->string (lazy-seq->list rest))))))
+
+(let ((singly-quoted-bang-string (quoted-string delimiter: (is #\') escape: (is #\!))))
+  (test "this 'is' a string" (parse singly-quoted-bang-string "'this !'is!' a string'"))
+  (test "ok\\" (parse singly-quoted-bang-string "'ok\\'"))
+  (test-assert (not (parse singly-quoted-bang-string "\"check\""))))
+
+(let ((lol (sequence (followed-by item (char-seq "ol")) item)))
+  (test #\o (parse lol "lol"))
+  (test #f  (parse lol "lxl")))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.