add (picrin parser) library

contrib/60.peg/nitro.mk

@@ -0,0 +1,8 @@
+CONTRIB_LIBS += contrib/60.peg/picrin/parser.scm contrib/60.peg/picrin/parser/string.scm
+
+CONTRIB_TESTS += test-peg
+
+test-peg: bin/picrin
+	for test in `ls contrib/60.peg/t/*.scm`; do \
+	  $(TEST_RUNNER) "$$test"; \
+	done

contrib/60.peg/picrin/parser.scm

@@ -0,0 +1,100 @@
+(define-library (picrin parser)
+  (import (scheme base)
+          (picrin control)
+          (picrin procedure))
+  (export parse
+          ;; monadic
+          reify
+          reflect
+          bind
+          unit
+          zero
+          plus
+          fapply
+          ;; look ahead
+          with
+          without
+          ;; eta
+          lazy
+          ;; aux
+          choice
+          optional
+          many
+          between)
+
+  ;; type Parser i r = i -> Maybe (r, i)
+
+  (define (parse rule input)
+    (rule input))
+
+  ;; monadic operators
+
+  (define-syntax reify
+    (syntax-rules ()
+      ((_ expr)
+       (reset (unit expr)))))
+
+  (define (reflect x)
+    (shift k (bind x k)))
+
+  (define (bind m f)
+    (lambda (i)
+      (let ((x (m i)))
+        (and x ((f (car x)) (cdr x))))))
+
+  (define (unit x)
+    (lambda (i)
+      `(,x . ,i)))
+
+  (define zero
+    (lambda (i) #f))
+
+  (define (plus a b)
+    (lambda (i)
+      (or (a i) (b i))))
+
+  (define (fapply f . args)
+    (reify
+     (let loop ((args args) (ps '()))
+       (if (null? args)
+           (apply f (reverse ps))
+           (loop (cdr args) (cons (reflect (car args)) ps))))))
+
+  ;; look ahead
+
+  (define (with a)
+    (lambda (i)
+      (and (a i) `(#f . ,i))))
+
+  (define (without a)
+    (lambda (i)
+      (and (not (a i)) `(#f . ,i))))
+
+  ;; eta conversion
+
+  (define-syntax lazy
+    (syntax-rules ()
+      ((_ expr)
+       (lambda (i) (expr i)))))
+
+  ;; aux
+
+  (define (choice . xs)
+    (if (null? xs)
+        zero
+        (plus (car xs) (apply choice (cdr xs)))))
+
+  (define (optional a)
+    (choice a (unit #f)))
+
+  (define (many a)
+    (lazy
+     (choice
+      (reify
+       (let* ((a (reflect a))
+              (b (reflect (many a))))
+         (cons a b)))
+      null)))
+
+  (define (between l x r)
+    (fapply (>> list cadr) l x r)))

contrib/60.peg/picrin/parser/string.scm

@@ -0,0 +1,28 @@
+(define-library (picrin parser string)
+  (import (except (scheme base) string)
+          (picrin parser))
+  (export string
+          any-char
+          eof
+          parse-string)
+
+  ;; string stream parser
+
+  (define (string str)
+    (lambda (i)
+      (let ((i (car i)) (input (cdr i)))
+        (let ((j (min (+ i (string-length str)) (string-length input))))
+          (and (equal? str (string-copy input i j))
+               `(,str . ,(cons j input)))))))
+
+  (define any-char
+    (lambda (i)
+      (let ((i (car i)) (input (cdr i)))
+        (and (< i (string-length input))
+             `(,(string-ref input i) . ,(cons (+ i 1) input))))))
+
+  (define eof
+    (without any-char))
+
+  (define (parse-string rule input)
+    (parse rule (cons 0 input))))

contrib/60.peg/t/peg.scm

@@ -0,0 +1,45 @@
+;;; test case
+
+(import (scheme base)
+        (picrin test)
+        (picrin procedure)
+        (picrin parser)
+        (picrin parser string))
+
+(test-begin "(picrin parser) and (picrin parser string)")
+
+(define LPAREN (string "("))
+(define RPAREN (string ")"))
+
+(define PLUS (string "+"))
+(define MINUS (string "-"))
+
+(define ONE (fapply (constant 1) (string "1")))
+
+(define S (lazy
+           (fapply (>> list car) A eof)))
+
+(define A (lazy
+           (choice
+            (fapply (lambda (p _ a) (list '+ p a)) P PLUS A)
+            (fapply (lambda (p _ a) (list '- p a)) P MINUS A)
+            P)))
+
+(define P (lazy
+           (choice
+            (between LPAREN A RPAREN)
+            ONE)))
+
+(define-syntax test-success
+  (syntax-rules ()
+    ((_ expect str)
+     (test (cons expect (cons (string-length str) str))
+           (parse-string S str)))))
+
+(test-success 1 "(1)")
+(test-success '(- (+ 1 1) 1) "((1+1)-1)")
+(test-success '(- (+ 1 1) 1) "((1+(1))-1)")
+(test-success '(+ 1 (- 1 (+ 1 (- 1 (+ 1 1))))) "(1+(1-(1+(1-(1+1)))))")
+(test-success '(+ 1 (+ 1(- 1 (+ 1 (- 1 (+ 1 1)))))) "(1+1+(1-(1+(1-(1+1)))))")
+
+(test-end)