4 files changed, 135 insertions, 0 deletions
diff --git a/input.lisp b/input.lisp
new file mode 100644
index 0000000..d6dd4b3
--- /dev/null
+++ b/input.lisp
@@ -0,0 +1,40 @@
+(in-package #:input)
+
+(defstruct input
+  (cursor 0)
+  (file nil :read-only t)
+  (data nil :read-only t))
+
+(defun has-data? (input)
+  (< (input-cursor input)
+     (length (input-data input))))
+
+(defun element (input)
+  (char (input-data input)
+        (input-cursor input)))
+
+(defun advance (input)
+  (let ((new-input (copy-structure input)))
+    (incf (input-cursor new-input))
+    new-input))
+
+(declaim (ftype (function (simple-string) (values input &optional)) from-string))
+(defun from-string (str)
+  (make-input :data str))
+
+(declaim (ftype (function (simple-string) (values input &optional)) from-file))
+(defun from-file (filename)
+  (make-input :file filename :data (str:read-file filename)))
+
+(defun generate-report (input message)
+  (let ((line 0) (column 0))
+    (dotimes (i (input-cursor input))
+      (let ((c (char (input-data input) i)))
+        (case c
+          (#\Newline
+           (incf line)
+           (setf column 1))
+          (t (incf column)))))
+    (if (input-file input)
+      (format nil "~a:~a:~a: ~a" (input-file input) line column message)
+      (format nil "~a:~a: ~a" line column message))))
diff --git a/monparser.asd b/monparser.asd
new file mode 100644
index 0000000..6374e8e
--- /dev/null
+++ b/monparser.asd
@@ -0,0 +1,7 @@
+(asdf:defsystem #:monparser
+  :serial t
+  :depends-on (#:utils)
+  :components
+  ((:file "package")
+   (:file "input")
+   (:file "parser")))
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..fdb1ab6
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,17 @@
+(defpackage #:input
+  (:use #:cl)
+  (:export #:from-string
+           #:from-file))
+
+(defpackage #:parser
+  (:use #:cl)
+  (:export #:run
+           #:new
+           #:bind
+           #:fail
+           #:any
+           #:unit
+           #:comp
+           #:zero-or-one
+           #:zero-or-more
+           #:one-or-more))
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)))