1 files changed, 71 insertions, 0 deletions
diff --git a/parser.lisp b/parser.lisp
new file mode 100644
index 0000000..16911ec
--- /dev/null
+++ b/parser.lisp
@@ -0,0 +1,71 @@
+(in-package #:parser)
+
+(defun run (p input)
+  (let ((r (funcall p input)))
+    (if (parsing-p r)
+      (parsing-tree r)
+      (input::generate-report (failure-place r) (failure-message r)))))
+
+(defstruct parsing
+  tree
+  left)
+
+(defstruct failure
+  place
+  message)
+
+(defun new (tree)
+  (lambda (input)
+    (make-parsing :tree tree :left input)))
+
+(defun bind (p f)
+  (lambda (input)
+    (let ((r (funcall p input)))
+      (if (parsing-p r)
+        (funcall (funcall f (parsing-tree r)) (parsing-left r))
+        r))))
+
+(defun fail (&optional (message "Unknown error."))
+  (lambda (input)
+    (make-failure :place input :message message)))
+
+(defun any (first-parser &rest other-parsers)
+  (lambda (input)
+    (labels ((any-rec (body)
+                      (if (cdr body)
+                        (let ((r (funcall (car body) input)))
+                          (if (parsing-p r)
+                            r
+                            (any-rec (cdr body))))
+                        (funcall (car body) input))))
+      (any-rec (cons first-parser other-parsers)))))
+
+(defun unit (&optional (predicate #'characterp))
+  (lambda (input)
+    (if (input::has-data? input)
+      (let ((c (input::element input)))
+        (if (funcall predicate c)
+          (make-parsing :tree c :left (input::advance input))
+          (make-failure :place input :message "Predicate not satisfied.")))
+      (make-failure :place input :message "Reached end of input."))))
+
+(defmacro comp (bindings &body body)
+  (if (null bindings)
+    `(new (progn ,@body))
+    (let ((v (first (car bindings)))
+          (p (second (car bindings))))
+      `(bind ,p (lambda (,v) (comp ,(cdr bindings) ,@body))))))
+
+(defun zero-or-one (p)
+  (any p (new nil)))
+
+(defun zero-or-more (p)
+  (any (comp ((x p)
+              (xs (zero-or-more p)))
+         (cons x xs))
+       (new nil)))
+
+(defun one-or-more (p)
+  (comp ((x p)
+         (xs (zero-or-more p)))
+    (cons x xs)))