1 files changed, 83 insertions, 0 deletions
diff --git a/core.lisp b/core.lisp
new file mode 100644
index 0000000..d0955fe
--- /dev/null
+++ b/core.lisp
@@ -0,0 +1,83 @@
+(in-package #:monparser)
+
+(defun fail (message)
+  (lambda (input &key limit lazy)
+    (make-failure :place input :message message)))
+
+(defmacro unit (&optional predicate)
+  (cond ((null predicate)
+         (setf predicate '(characterp it)))
+        ((symbolp predicate)
+         (setf predicate `(,predicate it)))
+        ((characterp predicate)
+         (setf predicate `(char-equal ,predicate it)))
+        (t (setf predicate
+                 (nsubst-if 'it
+                            (lambda (x)
+                              (and (symbolp x)
+                                   (string-equal (symbol-name x) "IT"))) predicate))))
+  `(lambda (input &key limit lazy)
+     (declare (ignore lazy))
+     (if (and limit (<= limit 0))
+       (make-failure :place input :message "Reached established limit.")
+       (if (has-data? input)
+         (let ((it (peek input)))
+           (if ,predicate
+             (make-parsing :tree it :left (advance input) :limit (if limit (1- limit)))
+             (make-failure :place input
+                           :message (format nil "Expected: ~a, Got: ~a" ',predicate it))))
+         (make-failure :place input :message "Reached end of input.")))))
+
+(defun one-of (first-parser second-parser &rest other-parsers)
+  (lambda (input &key limit lazy)
+    (declare (ignore lazy))
+    (labels ((one-of-rec (parsers)
+                         (let ((intermediate-parsers '())
+                               (result nil))
+                           (dolist (p parsers)
+                             (let ((r (funcall p
+                                               input
+                                               :lazy (> (length parsers) 1)
+                                               :limit limit)))
+                               (cond ((functionp r)
+                                      (push r intermediate-parsers))
+                                     ((parsing-p r)
+                                      (when (or (not (parsing-p result))
+                                                (> (cursor (parsing-left r))
+                                                   (cursor (parsing-left result))))
+                                        (setf result r)))
+                                     ((failure-p r)
+                                      (when (or (failure-p result)
+                                                 (= (length parsers) 1))
+                                        (setf result r))))))
+                           (if intermediate-parsers
+                             (one-of-rec intermediate-parsers)
+                             result))))
+      (one-of-rec (cons first-parser (cons second-parser other-parsers))))))
+
+(defmacro comp (bindings &body body)
+  (if (null bindings)
+    `(new (progn ,@body))
+    (let ((var (first (car bindings)))
+          (parser (second (car bindings)))
+          (lazy (third (car bindings)))
+          (unused (gensym)))
+      (if (symbolp var)
+        (if (string= (symbol-name var) "_")
+          `(bind ,parser
+                 (lambda (&rest ,unused)
+                   (declare (ignore ,unused))
+                   (comp ,(cdr bindings) ,@body))
+                 :greedy ,(not lazy))
+          `(bind ,parser
+                 (lambda (,var &rest ,unused)
+                   (declare (ignore ,unused))
+                   (comp ,(cdr bindings) ,@body))
+                 :greedy ,(not lazy)))
+        (if (and (consp var) (symbolp (car var)) (symbolp (cdr var)))
+          `(bind ,parser
+                 (lambda (,(car var) ,(cdr var) &rest ,unused)
+                   (declare (ignore ,unused))
+                   (comp ,(cdr bindings) ,@body))
+                 :greedy ,(not lazy))
+          (error "Binding must be either a symbol or a cons of symbols."))))))