Skip to content
Browse files

Make vectors and characters accepted as parsers.

Better test coverage would be useful, but seems to work.
  • Loading branch information...
1 parent 3afd3c3 commit a1c55d97e594cd41ec822f853dec5be11e3f56ca @Ramarren committed Sep 25, 2009
Showing with 413 additions and 364 deletions.
  1. +24 −23 combinators.lisp
  2. +55 −0 ensure-parser.lisp
  3. +126 −132 greedy.lisp
  4. +6 −5 parser-combinators.asd
  5. +196 −186 parsers.lisp
  6. +0 −18 primitives.lisp
  7. +6 −0 test-parsers.lisp
View
47 combinators.lisp
@@ -15,24 +15,25 @@
;;; (bind p f inp)=(concat list-comprehension)
(defun execute-bind (inp parser parser-generator) ;return continuation function
- (let ((p-parse-continuation (funcall parser inp))
- (q-parse-continuation nil))
- #'(lambda ()
- (let ((result nil))
- (iter (when q-parse-continuation (setf result (funcall q-parse-continuation)))
- (until (or result
- (and (null p-parse-continuation)
- (null q-parse-continuation))))
- (unless result
- (setf q-parse-continuation
- (let ((p-next-result
- (funcall p-parse-continuation)))
- (if p-next-result
- (let ((v (tree-of p-next-result))
- (inp-prime (suffix-of p-next-result)))
- (funcall (funcall parser-generator v) inp-prime))
- (setf p-parse-continuation nil))))))
- result))))
+ (with-parsers (parser)
+ (let ((p-parse-continuation (funcall parser inp))
+ (q-parse-continuation nil))
+ #'(lambda ()
+ (let ((result nil))
+ (iter (when q-parse-continuation (setf result (funcall q-parse-continuation)))
+ (until (or result
+ (and (null p-parse-continuation)
+ (null q-parse-continuation))))
+ (unless result
+ (setf q-parse-continuation
+ (let ((p-next-result
+ (funcall p-parse-continuation)))
+ (if p-next-result
+ (let ((v (tree-of p-next-result))
+ (inp-prime (suffix-of p-next-result)))
+ (funcall (ensure-parser (funcall parser-generator v)) inp-prime))
+ (setf p-parse-continuation nil))))))
+ result)))))
(defmacro bind (parser parser-generator) ; results in parser-promise
`(let ((parser ,parser)
@@ -62,15 +63,15 @@
(defmacro choice (parser1 parser2)
"Combinator: all alternatives from two parsers"
- `(let ((parser1 ,parser1)
- (parser2 ,parser2))
+ `(let ((parser1 (ensure-parser ,parser1))
+ (parser2 (ensure-parser ,parser2)))
#'(lambda (inp)
(execute-choice inp parser1 parser2))))
(defmacro choice1 (parser1 parser2)
"Combinator: one alternative from two parsers"
- `(let ((parser1 ,parser1)
- (parser2 ,parser2))
+ `(let ((parser1 (ensure-parser ,parser1))
+ (parser2 (ensure-parser ,parser2)))
(define-oneshot-result inp is-unread
(funcall (execute-choice inp
parser1
@@ -88,6 +89,6 @@
`(let ((parser-list (list ,@parser-list)))
(define-oneshot-result inp is-unread
(iter (for p in parser-list)
- (for result = (funcall (funcall p inp)))
+ (for result = (funcall (funcall (ensure-parser p) inp)))
(finding result)
(finally (setf parser-list nil))))))
View
55 ensure-parser.lisp
@@ -0,0 +1,55 @@
+(in-package :parser-combinators)
+
+(declaim (inline sat))
+(def-cached-arg-parser sat (predicate)
+ "Parser: return a token satisfying a predicate."
+ #'(lambda (inp)
+ (typecase inp
+ (end-context (constantly nil))
+ (context
+ (if (funcall predicate (context-peek inp))
+ (let ((closure-value
+ (make-instance 'parser-possibility
+ :tree (context-peek inp) :suffix (context-next inp))))
+ #'(lambda ()
+ (when closure-value
+ (prog1
+ closure-value
+ (setf closure-value nil)))))
+ (constantly nil))))))
+
+(def-cached-arg-parser char? (character)
+ "Parser: accept token eql to argument"
+ (sat (curry #'eql character)))
+
+(def-cached-arg-parser string? (sequence)
+ "Non-backtracking parser: accept a sequence of EQL elements."
+ (let ((vector (coerce sequence 'vector)))
+ (define-oneshot-result inp is-unread
+ (iter (for c in-vector vector)
+ (for inp-iter initially inp then (context-next inp-iter))
+ (when (end-context-p inp-iter)
+ (return nil))
+ (for inp-data = (context-peek inp-iter))
+ (unless (eql c inp-data)
+ (return nil))
+ (finally (return
+ (make-instance 'parser-possibility
+ :tree (copy-seq sequence)
+ :suffix inp-iter)))))))
+
+(defun ensure-parser (parser)
+ (typecase parser
+ (function parser)
+ (list (if (cdr parser)
+ (string? parser)
+ (char? (car parser))))
+ (vector (if (length= 1 parser)
+ (char? parser)
+ (string? parser)))
+ (t (char? parser))))
+
+(defmacro with-parsers ((&rest parsers) &body body)
+ `(let ,(iter (for p in parsers)
+ (collect `(,p (ensure-parser ,p))))
+ ,@body))
View
258 greedy.lisp
@@ -14,20 +14,21 @@
;; can't have 0-0 parser
(assert (or (null max)
(plusp max)))
- (define-oneshot-result inp is-unread
- (iter (for count from 0)
- (for result next (funcall (funcall parser inp-prime)))
- (while (and result
- (or (null max)
- (< count max))))
- (for inp-prime initially inp then (suffix-of result))
- (collect result into results)
- (finally (return
- (when (or (null min)
- (>= count min))
- (make-instance 'parser-possibility
- :tree (map result-type #'tree-of results)
- :suffix inp-prime)))))))
+ (with-parsers (parser)
+ (define-oneshot-result inp is-unread
+ (iter (for count from 0)
+ (for result next (funcall (funcall parser inp-prime)))
+ (while (and result
+ (or (null max)
+ (< count max))))
+ (for inp-prime initially inp then (suffix-of result))
+ (collect result into results)
+ (finally (return
+ (when (or (null min)
+ (>= count min))
+ (make-instance 'parser-possibility
+ :tree (map result-type #'tree-of results)
+ :suffix inp-prime))))))))
(defun many* (parser)
"Non-backtracking parser: collect as many of first result of parser as possible"
@@ -47,39 +48,42 @@
(defun sepby1* (parser-item parser-separator)
"Non-backtracking parser: accept as many as possible of parser-item separated by parser-separator, but at least one."
- (mdo (<- x parser-item)
- (<- xs (many* (mdo parser-separator
- (<- y parser-item)
- (result y))))
- (result (cons x xs))))
+ (with-parsers (parser-item parser-separator)
+ (mdo (<- x parser-item)
+ (<- xs (many* (mdo parser-separator
+ (<- y parser-item)
+ (result y))))
+ (result (cons x xs)))))
(defun sepby* (parser-item parser-separator)
"Non-backtracking parser: accept as many as possible of parser-item separated by parser-separator."
- (choice1 (sepby1* parser-item parser-separator)
- (result nil)))
+ (with-parsers (parser-item parser-separator)
+ (choice1 (sepby1* parser-item parser-separator)
+ (result nil))))
(defun chainl1* (p op)
"Non-backtracking parser: accept as many as possible, but at least one of p, reduced by result of op with left associativity"
- (labels ((rest-chain (init-x)
- (define-oneshot-result inp is-unread
- (let ((final-result (iter (for f-result next (funcall (funcall op p-inp)))
- (while f-result)
- (for f-inp next (suffix-of f-result))
- (for p-result next (funcall (funcall p f-inp)))
- (while p-result)
- (for p-inp initially inp then (suffix-of p-result))
- (for f = (tree-of f-result))
- (for x initially init-x then tree)
- (for y = (tree-of p-result))
- (for tree next (funcall f x y))
- (finally (return (list tree p-inp))))))
- (if (car final-result)
- (make-instance 'parser-possibility
- :tree (car final-result)
- :suffix (cadr final-result))
- (make-instance 'parser-possibility
- :tree init-x :suffix inp))))))
- (bind p #'rest-chain)))
+ (with-parsers (p op)
+ (labels ((rest-chain (init-x)
+ (define-oneshot-result inp is-unread
+ (let ((final-result (iter (for f-result next (funcall (funcall op p-inp)))
+ (while f-result)
+ (for f-inp next (suffix-of f-result))
+ (for p-result next (funcall (funcall p f-inp)))
+ (while p-result)
+ (for p-inp initially inp then (suffix-of p-result))
+ (for f = (tree-of f-result))
+ (for x initially init-x then tree)
+ (for y = (tree-of p-result))
+ (for tree next (funcall f x y))
+ (finally (return (list tree p-inp))))))
+ (if (car final-result)
+ (make-instance 'parser-possibility
+ :tree (car final-result)
+ :suffix (cadr final-result))
+ (make-instance 'parser-possibility
+ :tree init-x :suffix inp))))))
+ (bind p #'rest-chain))))
(defun nat* ()
"Non-backtracking parser: accept natural number, consuming as many digits as possible"
@@ -97,94 +101,83 @@
(defun chainr1* (p op)
"Non-backtracking parser: accept as many as possible, but at least one of p, reduced by result of op with right associativity"
- (bind p
- #'(lambda (init-x)
- (define-oneshot-result inp is-unread
- (let ((final-result
- (iter (for f-result next (funcall (funcall op p-inp)))
- (while f-result)
- (for f-inp next (suffix-of f-result))
- (for p-result next (funcall (funcall p f-inp)))
- (while p-result)
- (for p-inp initially inp then (suffix-of p-result))
- (for f = (tree-of f-result))
- (for y = (tree-of p-result))
- (collect f into function-list)
- (collect y into y-list)
- (finally (let ((rev-y-list (nreverse (cons init-x y-list))))
- (return (list (iter (for x in (cdr rev-y-list))
- (for f in function-list)
- (for tree next (if (first-iteration-p)
- (funcall f x (car rev-y-list))
- (funcall f x tree)))
- (finally (return tree)))
- p-inp)))))))
- (if (car final-result)
- (make-instance 'parser-possibility
- :tree (car final-result)
- :suffix (cadr final-result))
- (make-instance 'parser-possibility
- :tree init-x :suffix inp)))))))
+ (with-parsers (p op)
+ (bind p
+ #'(lambda (init-x)
+ (define-oneshot-result inp is-unread
+ (let ((final-result
+ (iter (for f-result next (funcall (funcall op p-inp)))
+ (while f-result)
+ (for f-inp next (suffix-of f-result))
+ (for p-result next (funcall (funcall p f-inp)))
+ (while p-result)
+ (for p-inp initially inp then (suffix-of p-result))
+ (for f = (tree-of f-result))
+ (for y = (tree-of p-result))
+ (collect f into function-list)
+ (collect y into y-list)
+ (finally (let ((rev-y-list (nreverse (cons init-x y-list))))
+ (return (list (iter (for x in (cdr rev-y-list))
+ (for f in function-list)
+ (for tree next (if (first-iteration-p)
+ (funcall f x (car rev-y-list))
+ (funcall f x tree)))
+ (finally (return tree)))
+ p-inp)))))))
+ (if (car final-result)
+ (make-instance 'parser-possibility
+ :tree (car final-result)
+ :suffix (cadr final-result))
+ (make-instance 'parser-possibility
+ :tree init-x :suffix inp))))))))
(defun chainl* (p op v)
"Non-backtracking parser: like chainl1*, but will return v if no p can be parsed"
- (choice1
- (chainl1* p op)
- (result v)))
+ (with-parsers (p op)
+ (choice1
+ (chainl1* p op)
+ (result v))))
(defun chainr* (p op v)
"Non-backtracking parser: like chainr1*, but will return v if no p can be parsed"
- (choice1
- (chainr1* p op)
- (result v)))
-
-(def-cached-arg-parser string? (sequence)
- "Non-backtracking parser: accept a sequence of EQL elements."
- (let ((vector (coerce sequence 'vector)))
- (define-oneshot-result inp is-unread
- (iter (for c in-vector vector)
- (for inp-iter initially inp then (context-next inp-iter))
- (when (typep inp-iter 'end-context)
- (return nil))
- (for inp-data = (context-peek inp-iter))
- (unless (eql c inp-data)
- (return nil))
- (finally (return
- (make-instance 'parser-possibility
- :tree (copy-seq sequence)
- :suffix inp-iter)))))))
+ (with-parsers (p op)
+ (choice1
+ (chainr1* p op)
+ (result v))))
(def-cached-arg-parser times* (parser count)
"Non-backtracking parser: accept exactly count expressions accepted by parser, without backtracking."
(between* parser count count))
(defun find-after* (p q)
"Non-backtracking parser: Find first q after some sequence of p."
- (define-oneshot-result inp is-unread
- (iter (for p-result next (funcall (funcall p inp-prime)))
- (for q-result next (funcall (funcall q inp-prime)))
- (while (and p-result (null q-result)))
- (for inp-prime initially inp then (suffix-of p-result))
- (finally (return
- (when q-result
- (make-instance 'parser-possibility
- :tree (tree-of q-result)
- :suffix (suffix-of q-result))))))))
+ (with-parsers (p q)
+ (define-oneshot-result inp is-unread
+ (iter (for p-result next (funcall (funcall p inp-prime)))
+ (for q-result next (funcall (funcall q inp-prime)))
+ (while (and p-result (null q-result)))
+ (for inp-prime initially inp then (suffix-of p-result))
+ (finally (return
+ (when q-result
+ (make-instance 'parser-possibility
+ :tree (tree-of q-result)
+ :suffix (suffix-of q-result)))))))))
(defun find-after-collect* (p q &optional (result-type 'list))
"Non-backtracking parser: Find first q after some sequence of p. Return cons of list of p-results and q"
- (define-oneshot-result inp is-unread
- (iter (for p-result next (funcall (funcall p inp-prime)))
- (for q-result next (funcall (funcall q inp-prime)))
- (while (and p-result (null q-result)))
- (collect p-result into p-results)
- (for inp-prime initially inp then (suffix-of p-result))
- (finally (return
- (when q-result
- (make-instance 'parser-possibility
- :tree (cons (map result-type #'tree-of p-results)
- (tree-of q-result))
- :suffix (suffix-of q-result))))))))
+ (with-parsers (p q)
+ (define-oneshot-result inp is-unread
+ (iter (for p-result next (funcall (funcall p inp-prime)))
+ (for q-result next (funcall (funcall q inp-prime)))
+ (while (and p-result (null q-result)))
+ (collect p-result into p-results)
+ (for inp-prime initially inp then (suffix-of p-result))
+ (finally (return
+ (when q-result
+ (make-instance 'parser-possibility
+ :tree (cons (map result-type #'tree-of p-results)
+ (tree-of q-result))
+ :suffix (suffix-of q-result)))))))))
(defun find* (q)
"Non-backtracking parser: Find first q"
@@ -194,22 +187,23 @@
"Non-backtracking parser: Reduce a sequence of terms with unary/binary operators with precedence.
OPERATORS is a list of (op-parser :left/:right/:unary), where OP-PARSER is a parser consuming
an operator and returning a reduction function. Highest precedence first."
- (let ((wrapped-term term))
- (labels ((term-wrapper (inp)
- (funcall wrapped-term inp)))
- (let ((expr-parser
- (iter (for (op assoc) in operators)
- (for base initially #'term-wrapper
- then (ecase assoc
- (:left (chainl1* base op))
- (:right (chainr1* base op))
- (:unary (choice1
- (mdo (<- op-fun op)
- (<- subexpr base)
- (result (funcall op-fun subexpr)))
- base))))
- (finally (return base)))))
- (when (and bracket-left bracket-right)
- (setf wrapped-term (choice1 (bracket? bracket-left expr-parser bracket-right)
- term)))
- expr-parser))))
+ (with-parsers (term bracket-left bracket-right)
+ (let ((wrapped-term term))
+ (labels ((term-wrapper (inp)
+ (funcall wrapped-term inp)))
+ (let ((expr-parser
+ (iter (for (op assoc) in operators)
+ (for base initially #'term-wrapper
+ then (ecase assoc
+ (:left (chainl1* base op))
+ (:right (chainr1* base op))
+ (:unary (choice1
+ (mdo (<- op-fun op)
+ (<- subexpr base)
+ (result (funcall op-fun subexpr)))
+ base))))
+ (finally (return base)))))
+ (when (and bracket-left bracket-right)
+ (setf wrapped-term (choice1 (bracket? bracket-left expr-parser bracket-right)
+ term)))
+ expr-parser)))))
View
11 parser-combinators.asd
@@ -10,9 +10,10 @@
(:file "contexts" :depends-on ("package"))
(:file "lazy" :depends-on ("package"))
(:file "basic" :depends-on ("package" "lazy"))
- (:file "combinators" :depends-on ("package" "basic" "lazy"))
+ (:file "ensure-parser" :depends-on ("package" "contexts" "basic"))
+ (:file "combinators" :depends-on ("package" "basic" "lazy" "ensure-parser"))
(:file "primitives" :depends-on ("package" "lazy" "basic" "combinators" "contexts"))
- (:file "parsers" :depends-on ("package" "basic" "primitives" "combinators"))
- (:file "memoize" :depends-on ("package" "basic"))
- (:file "recurse" :depends-on ("package" "basic"))
- (:file "greedy" :depends-on ("package" "basic" "primitives" "combinators"))))
+ (:file "parsers" :depends-on ("package" "basic" "primitives" "combinators" "ensure-parser"))
+ (:file "memoize" :depends-on ("package" "basic" "ensure-parser"))
+ (:file "recurse" :depends-on ("package" "basic" "ensure-parser"))
+ (:file "greedy" :depends-on ("package" "basic" "primitives" "combinators" "ensure-parser"))))
View
382 parsers.lisp
@@ -5,10 +5,6 @@
(define-oneshot-result inp is-unread
(make-instance 'parser-possibility :tree inp :suffix inp)))
-(def-cached-arg-parser char? (character)
- "Parser: accept token eql to argument"
- (sat (curry #'eql character)))
-
(def-cached-parser digit?
"Parser: accept digit character"
(sat #'digit-char-p))
@@ -44,64 +40,65 @@
(assert (or (null max)
(plusp max)))
;; gather results depth-first, longest first, ie. gather shorter on returning
- #'(lambda (inp)
- (let ((continuation-stack nil)
- (result-stack nil)
- (count 1)
- (zero-width (or (null min)
- (zerop min)))
- (state :next-result))
- (push (funcall parser inp) continuation-stack)
- #'(lambda ()
- (setf state :next-result)
- (iter
- ;; (print state)
- ;; (print result-stack)
- ;; (print zero-width)
- ;; (print count)
- (while (or continuation-stack
- zero-width))
- (ecase state
- (:next-result
- (let ((next-result (funcall (car continuation-stack))))
- (cond ((null next-result)
- (pop continuation-stack)
- (decf count)
- (setf state :check-count))
- ((and max (= count max))
- (push next-result result-stack)
+ (with-parsers (parser)
+ #'(lambda (inp)
+ (let ((continuation-stack nil)
+ (result-stack nil)
+ (count 1)
+ (zero-width (or (null min)
+ (zerop min)))
+ (state :next-result))
+ (push (funcall parser inp) continuation-stack)
+ #'(lambda ()
+ (setf state :next-result)
+ (iter
+ ;; (print state)
+ ;; (print result-stack)
+ ;; (print zero-width)
+ ;; (print count)
+ (while (or continuation-stack
+ zero-width))
+ (ecase state
+ (:next-result
+ (let ((next-result (funcall (car continuation-stack))))
+ (cond ((null next-result)
+ (pop continuation-stack)
+ (decf count)
+ (setf state :check-count))
+ ((and max (= count max))
+ (push next-result result-stack)
+ (setf state :return))
+ (t
+ (incf count)
+ (when (and result-stack
+ (eq (suffix-of (car result-stack))
+ (suffix-of next-result)))
+ (error "Subparser in repetition parser didn't advance the input."))
+ (push next-result result-stack)
+ (push (funcall parser (suffix-of next-result)) continuation-stack)))))
+ (:check-count
+ (cond ((or (null continuation-stack)
+ (and (or (null min)
+ (>= count min))
+ (or (null max)
+ (<= count max))))
(setf state :return))
- (t
- (incf count)
- (when (and result-stack
- (eq (suffix-of (car result-stack))
- (suffix-of next-result)))
- (error "Subparser in repetition parser didn't advance the input."))
- (push next-result result-stack)
- (push (funcall parser (suffix-of next-result)) continuation-stack)))))
- (:check-count
- (cond ((or (null continuation-stack)
- (and (or (null min)
- (>= count min))
- (or (null max)
- (<= count max))))
- (setf state :return))
- (t (pop result-stack)
- (setf state :next-result))))
- (:return
- (return
- (cond (result-stack
- (let ((result
- (make-instance 'parser-possibility
- :tree (map result-type #'tree-of (reverse result-stack))
- :suffix (suffix-of (car result-stack)))))
- (pop result-stack)
- result))
- (zero-width
- (setf zero-width nil)
- (make-instance 'parser-possibility
- :tree nil
- :suffix inp)))))))))))
+ (t (pop result-stack)
+ (setf state :next-result))))
+ (:return
+ (return
+ (cond (result-stack
+ (let ((result
+ (make-instance 'parser-possibility
+ :tree (map result-type #'tree-of (reverse result-stack))
+ :suffix (suffix-of (car result-stack)))))
+ (pop result-stack)
+ result))
+ (zero-width
+ (setf zero-width nil)
+ (make-instance 'parser-possibility
+ :tree nil
+ :suffix inp))))))))))))
(def-cached-parser word?
"Parser: accept a string of alphabetic characters"
@@ -135,73 +132,78 @@
(defun sepby1? (parser-item parser-separator)
"Parser: accept at least one of parser-item separated by parser-separator"
- (mdo (<- x parser-item)
- (<- xs (many? (mdo parser-separator (<- y parser-item) (result y))))
- (result (cons x xs))))
+ (with-parsers (parser-item parser-separator)
+ (mdo (<- x parser-item)
+ (<- xs (many? (mdo parser-separator (<- y parser-item) (result y))))
+ (result (cons x xs)))))
(defun bracket? (parser-open parser-center parser-close)
"Parser: accept parser-center bracketed by parser-open and parser-close"
- (mdo parser-open (<- xs parser-center) parser-close (result xs)))
+ (with-parsers (parser-open parser-center parser-close)
+ (mdo parser-open (<- xs parser-center) parser-close (result xs))))
(defun sepby? (parser-item parser-separator)
"Parser: accept zero or more of parser-item separated by parser-separator"
- (choice (sepby1? parser-item parser-separator) (result nil)))
+ (with-parsers (parser-item parser-separator)
+ (choice (sepby1? parser-item parser-separator) (result nil))))
;; since all intermediate results have to be kept anyway for backtracking, they might be just as
;; well be kept not on the stack, so chainl/r1? can be implemented in terms of between? as well
(defun sepby1-cons? (p op)
"Parser: as sepby1, but returns a list of a result of p and pairs (op p). Mainly a component parser for chains"
- (let ((between-parser (between? (mdo (<- op-result op)
- (<- p-result p)
- (result (cons op-result p-result)))
- 1 nil)))
- #'(lambda (inp)
- (let ((front-continuation (funcall p inp))
- (between-continuation nil)
- (front nil)
- (chain nil)
- (state :next-result))
- #'(lambda ()
- (setf state :next-result)
- (iter
- (ecase state
- (:next-result
- (cond (between-continuation
- (if-let (next-chain (funcall between-continuation))
- (setf chain next-chain
- state :return)
- (setf between-continuation nil
- chain nil
- state :return)))
- (front-continuation
- (if-let (next-front (funcall front-continuation))
- (setf front next-front
- between-continuation (funcall between-parser (suffix-of next-front)))
- (setf front-continuation nil)))
- (t (setf state :return))))
- (:return
- (return (cond
- (chain (make-instance 'parser-possibility
- :suffix (suffix-of chain)
- :tree (cons (tree-of front) (tree-of chain))))
- (front (prog1 (make-instance 'parser-possibility
- :tree (list (tree-of front))
- :suffix (suffix-of front))
- (setf front nil)))))))))))))
+ (with-parsers (p op)
+ (let ((between-parser (between? (mdo (<- op-result op)
+ (<- p-result p)
+ (result (cons op-result p-result)))
+ 1 nil)))
+ #'(lambda (inp)
+ (let ((front-continuation (funcall p inp))
+ (between-continuation nil)
+ (front nil)
+ (chain nil)
+ (state :next-result))
+ #'(lambda ()
+ (setf state :next-result)
+ (iter
+ (ecase state
+ (:next-result
+ (cond (between-continuation
+ (if-let (next-chain (funcall between-continuation))
+ (setf chain next-chain
+ state :return)
+ (setf between-continuation nil
+ chain nil
+ state :return)))
+ (front-continuation
+ (if-let (next-front (funcall front-continuation))
+ (setf front next-front
+ between-continuation (funcall between-parser (suffix-of next-front)))
+ (setf front-continuation nil)))
+ (t (setf state :return))))
+ (:return
+ (return (cond
+ (chain (make-instance 'parser-possibility
+ :suffix (suffix-of chain)
+ :tree (cons (tree-of front) (tree-of chain))))
+ (front (prog1 (make-instance 'parser-possibility
+ :tree (list (tree-of front))
+ :suffix (suffix-of front))
+ (setf front nil))))))))))))))
(defun chainl1? (p op)
"Parser: accept one or more p reduced by result of op with left associativity"
- (let ((subparser (sepby1-cons? p op)))
- (mdo (<- chain subparser)
- (result
- (destructuring-bind (front . chain) chain
- (iter (for left initially front
- then (funcall op
- left
- right))
- (for (op . right) in chain)
- (finally (return left))))))))
+ (with-parsers (p op)
+ (let ((subparser (sepby1-cons? p op)))
+ (mdo (<- chain subparser)
+ (result
+ (destructuring-bind (front . chain) chain
+ (iter (for left initially front
+ then (funcall op
+ left
+ right))
+ (for (op . right) in chain)
+ (finally (return left)))))))))
(defun nat? ()
"Parser: accept natural numbers"
@@ -213,29 +215,32 @@
(defun chainr1? (p op)
"Parser: accept one or more p reduced by result of op with right associativity"
- (let ((subparser (sepby1-cons? p op)))
- (mdo (<- chain subparser)
- (result
- (destructuring-bind (front . chain) chain
- (iter (with chain = (reverse chain))
- (with current-op = (car (car chain)))
- (with current-right = (cdr (car chain)))
- (for (op . right) in (cdr chain))
- (setf current-right (funcall current-op right current-right)
- current-op op)
- (finally (return (funcall op front current-right)))))))))
+ (with-parsers (p op)
+ (let ((subparser (sepby1-cons? p op)))
+ (mdo (<- chain subparser)
+ (result
+ (destructuring-bind (front . chain) chain
+ (iter (with chain = (reverse chain))
+ (with current-op = (car (car chain)))
+ (with current-right = (cdr (car chain)))
+ (for (op . right) in (cdr chain))
+ (setf current-right (funcall current-op right current-right)
+ current-op op)
+ (finally (return (funcall op front current-right))))))))))
(defun chainl? (p op v)
"Parser: like chainl1?, but will return v if no p can be parsed"
- (choice
- (chainl1? p op)
- (result v)))
+ (with-parsers (p op)
+ (choice
+ (chainl1? p op)
+ (result v))))
(defun chainr? (p op v)
"Parser: like chainr1?, but will return v if no p can be parsed"
- (choice
- (chainr1? p op)
- (result v)))
+ (with-parsers (p op)
+ (choice
+ (chainr1? p op)
+ (result v))))
(defclass result-node (parser-possibility)
((emit :initarg :emit :initform t :accessor emit-of)
@@ -253,73 +258,78 @@
(defun breadth? (parser min max &optional (result-type 'list))
"Parser: like between? but breadth first (shortest matches first)"
- #'(lambda (inp)
- (let ((queue (make-queue (list
- (make-instance 'result-node
- :suffix inp
- :suffix-continuation (funcall parser inp)
- :tree nil
- :emit nil
- :up nil))))
- (node nil))
- #'(lambda ()
- (iter
- (until (empty-p queue))
- (setf node (pop-front queue))
- (for count = (count-of node))
- (iter (for result next (funcall (suffix-continuation-of node)))
- (while result)
- (for suffix = (suffix-of result))
- (unless (and max
- (= count max))
- (push-back queue (make-instance 'result-node
- :suffix suffix
- :suffix-continuation (funcall parser suffix)
- :up node
- :count (1+ count)
- :tree (tree-of result)))))
- (when (and (emit-of node)
- (or (null min)
- (>= count min)))
- (return (make-instance 'parser-possibility
- :tree (map result-type #'tree-of (gather-nodes node))
- :suffix (suffix-of node)))))))))
+ (with-parsers (parser)
+ #'(lambda (inp)
+ (let ((queue (make-queue (list
+ (make-instance 'result-node
+ :suffix inp
+ :suffix-continuation (funcall parser inp)
+ :tree nil
+ :emit nil
+ :up nil))))
+ (node nil))
+ #'(lambda ()
+ (iter
+ (until (empty-p queue))
+ (setf node (pop-front queue))
+ (for count = (count-of node))
+ (iter (for result next (funcall (suffix-continuation-of node)))
+ (while result)
+ (for suffix = (suffix-of result))
+ (unless (and max
+ (= count max))
+ (push-back queue (make-instance 'result-node
+ :suffix suffix
+ :suffix-continuation (funcall parser suffix)
+ :up node
+ :count (1+ count)
+ :tree (tree-of result)))))
+ (when (and (emit-of node)
+ (or (null min)
+ (>= count min)))
+ (return (make-instance 'parser-possibility
+ :tree (map result-type #'tree-of (gather-nodes node))
+ :suffix (suffix-of node))))))))))
(defun find-after? (p q)
"Parser: Find first q after some sequence of p."
- (mdo (breadth? p nil nil nil)
- q))
+ (with-parsers (p q)
+ (mdo (breadth? p nil nil nil)
+ q)))
(defun find-after-collect? (p q &optional (result-type 'list))
"Parser: Find first q after some sequence of p. Return cons of list of p-results and q"
- (mdo (<- prefix (breadth? p nil nil result-type))
- (<- q-result q)
- (result (cons prefix q-result))))
+ (with-parsers (p q)
+ (mdo (<- prefix (breadth? p nil nil result-type))
+ (<- q-result q)
+ (result (cons prefix q-result)))))
(defun find? (q)
"Parser: Find first q"
- (find-after? (item) q))
+ (with-parsers (q)
+ (find-after? (item) q)))
(defun expression? (term operators &optional (bracket-left nil) (bracket-right nil))
"Parser: Reduce a sequence of terms with unary/binary operators with precedence.
OPERATORS is a list of (op-parser :left/:right/:unary), where OP-PARSER is a parser consuming
an operator and returning a reduction function. Highest precedence first."
- (let ((wrapped-term term))
- (labels ((term-wrapper (inp)
- (funcall wrapped-term inp)))
- (let ((expr-parser
- (iter (for (op assoc) in operators)
- (for base initially #'term-wrapper
- then (ecase assoc
- (:left (chainl1? base op))
- (:right (chainr1? base op))
- (:unary (choice
- (mdo (<- op-fun op)
- (<- subexpr base)
- (result (funcall op-fun subexpr)))
- base))))
- (finally (return base)))))
- (when (and bracket-left bracket-right)
- (setf wrapped-term (choice (bracket? bracket-left expr-parser bracket-right)
- term)))
- expr-parser))))
+ (with-parsers (term bracket-left bracket-right)
+ (let ((wrapped-term term))
+ (labels ((term-wrapper (inp)
+ (funcall wrapped-term inp)))
+ (let ((expr-parser
+ (iter (for (op assoc) in operators)
+ (for base initially #'term-wrapper
+ then (ecase assoc
+ (:left (chainl1? base op))
+ (:right (chainr1? base op))
+ (:unary (choice
+ (mdo (<- op-fun op)
+ (<- subexpr base)
+ (result (funcall op-fun subexpr)))
+ base))))
+ (finally (return base)))))
+ (when (and bracket-left bracket-right)
+ (setf wrapped-term (choice (bracket? bracket-left expr-parser bracket-right)
+ term)))
+ expr-parser)))))
View
18 primitives.lisp
@@ -71,24 +71,6 @@
closure-value
(setf closure-value nil)))))))))
-(declaim (inline sat))
-(def-cached-arg-parser sat (predicate)
- "Parser: return a token satisfying a predicate."
- #'(lambda (inp)
- (typecase inp
- (end-context (constantly nil))
- (context
- (if (funcall predicate (context-peek inp))
- (let ((closure-value
- (make-instance 'parser-possibility
- :tree (context-peek inp) :suffix (context-next inp))))
- #'(lambda ()
- (when closure-value
- (prog1
- closure-value
- (setf closure-value nil)))))
- (constantly nil))))))
-
(defun force? (parser)
"Parser modifier: fully realize result from parser"
#'(lambda (inp)
View
6 test-parsers.lisp
@@ -163,3 +163,9 @@
(<- c2 (context?))
(result (context-interval c1 c2)))
"1234"))))))
+
+(defparsertest test-mdo-constants (mdo (times? "ab" 2)
+ #\c
+ "defg")
+ ("ababcdefg" "defg")
+ ("ababccdefg"))

0 comments on commit a1c55d9

Please sign in to comment.
Something went wrong with that request. Please try again.