Permalink
Browse files

Move some parsers to a new file, add a new parser inspired by recent …

…Lispforum thread.
  • Loading branch information...
1 parent d01cbee commit 9bf93325f053f3660af44d14cbe3b2da338bf947 @Ramarren committed Sep 3, 2010
Showing with 92 additions and 39 deletions.
  1. +2 −1 parser-combinators.asd
  2. +0 −38 parsers.lisp
  3. +90 −0 token-parsers.lisp
View
@@ -17,4 +17,5 @@
(:file "parsers" :depends-on ("package" "basic" "primitives" "combinators" "ensure-parser" "cache"))
(: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" "cache"))))
+ (:file "greedy" :depends-on ("package" "basic" "primitives" "combinators" "ensure-parser" "cache"))
+ (:file "token-parsers" :depends-on ("package" "basic" "primitives" "combinators" "parsers" "greedy"))))
View
@@ -53,26 +53,6 @@ parsers."
(make-instance 'parser-possibility :tree t :suffix inp)))
"end of input"))
-(def-cached-parser digit?
- "Parser: accept digit character"
- (sat #'digit-char-p))
-
-(def-cached-parser lower?
- "Parser: accept lowercase character"
- (sat #'lower-case-p))
-
-(def-cached-parser upper?
- "Parser: accept uppercase character"
- (sat #'upper-case-p))
-
-(def-cached-parser letter?
- "Parser: accept alphabetic character"
- (sat #'alpha-char-p))
-
-(def-cached-parser alphanum?
- "Parser: accept alphanumeric character"
- (sat #'alphanumericp))
-
;;; implement repetition parsers in terms of (between? ...)
(defun between? (parser min max &optional (result-type 'list))
@@ -148,10 +128,6 @@ parsers."
:tree (coerce nil result-type)
:suffix inp))))))))))))
-(def-cached-parser word?
- "Parser: accept a string of alphabetic characters"
- (between? (letter?) 1 nil 'string))
-
(defun many? (parser)
"Parser: accept zero or more repetitions of expression accepted by parser"
(between? parser nil nil))
@@ -172,12 +148,6 @@ parsers."
"Parser: accept at most count expressions accepted by parser"
(between? parser nil count))
-(defun int? ()
- "Parser: accept an integer"
- (mdo (<- f (choice (mdo (char? #\-) (result #'-)) (result #'identity)))
- (<- n (nat?))
- (result (funcall f n))))
-
(defun sepby1? (parser-item parser-separator)
"Parser: accept at least one of parser-item separated by parser-separator"
(with-parsers (parser-item parser-separator)
@@ -253,14 +223,6 @@ parsers."
(for (op . right) in chain)
(finally (return left)))))))))
-(defun nat? ()
- "Parser: accept natural numbers"
- (chainl1? (mdo (<- x (digit?))
- (result (digit-char-p x)))
- (result
- #'(lambda (x y)
- (+ (* 10 x) y)))))
-
(defun chainr1? (p op)
"Parser: accept one or more p reduced by result of op with right associativity"
(with-parsers (p op)
View
@@ -0,0 +1,90 @@
+(in-package :parser-combinators)
+
+;; single character parsers
+
+(def-cached-parser digit?
+ "Parser: accept digit character"
+ (sat #'digit-char-p))
+
+(def-cached-parser lower?
+ "Parser: accept lowercase character"
+ (sat #'lower-case-p))
+
+(def-cached-parser upper?
+ "Parser: accept uppercase character"
+ (sat #'upper-case-p))
+
+(def-cached-parser letter?
+ "Parser: accept alphabetic character"
+ (sat #'alpha-char-p))
+
+(def-cached-parser alphanum?
+ "Parser: accept alphanumeric character"
+ (sat #'alphanumericp))
+
+;; some usual lexical tokens
+
+(def-cached-arg-parser whitespace? (&key (result-type nil) (accept-empty nil))
+ "Parser: accept a sequence of whitespace characters."
+ (gather-if* (rcurry #'member '(#\Space #\Newline #\ ))
+ :result-type result-type
+ :accept-empty accept-empty))
+
+(def-cached-parser word?
+ "Parser: accept a string of alphabetic characters"
+ (gather-if* #'alpha-char-p :result-type 'string))
+
+;; naive implementation using monadic combinators, unfortunately rather slow
+;; (defun int? ()
+;; "Parser: accept an integer"
+;; (mdo (<- f (choice (mdo (char? #\-) (result #'-)) (result #'identity)))
+;; (<- n (nat?))
+;; (result (funcall f n))))
+
+(def-cached-arg-parser nat? (&optional (radix 10))
+ "Parser: accept natural numbers"
+ (named-seq* (<- number (gather-if* #'digit-char-p :result-type 'string))
+ (parse-integer number)))
+
+(def-cached-arg-parser int? (&optional (radix 10))
+ "Parser: accept an integer, return as integer."
+ (named-seq*
+ (<- sign (choice (between* #\- 0 1)
+ (between* #\+ 0 1)))
+ (<- number (nat?))
+ (let ((sign (if (or (null sign) (eql (car sign) #\+))
+ 1
+ -1)))
+ (* sign number))))
+
+(def-cached-arg-parser quoted? (&key (quote-char #\")
+ (left-quote-char nil)
+ (right-quote-char nil)
+ (escape-char #\\)
+ (include-quotes t))
+ "Parser: accept a string delimited with quote-char, possibly escaped by escape-char, possibly including quotation chars."
+ (let* ((left-quote-char (or left-quote-char quote-char))
+ (right-quote-char (or right-quote-char quote-char))
+ (gather-end-condition (if escape-char
+ (rcurry #'member (list right-quote-char escape-char))
+ (rcurry #'eql right-quote-char)))
+ (quoted-quote (when escape-char
+ (format nil "~a~a" escape-char right-quote-char)))
+ (internal-parser (if escape-char
+ (many* (choice1 (gather-if-not* gather-end-condition
+ :result-type 'string)
+ (named-seq* quoted-quote 'quote)))
+ (gather-if-not* gather-end-condition :result-type nil :accept-empty t))))
+ (named-seq*
+ (<- c1 (context?))
+ left-quote-char
+ (<- data internal-parser)
+ right-quote-char
+ (<- c4 (context?))
+ (if include-quotes
+ (context-interval c1 c4)
+ (with-output-to-string (str)
+ (iter (for datum in data)
+ (if (eql datum 'quote)
+ (princ right-quote-char str)
+ (princ datum str))))))))

0 comments on commit 9bf9332

Please sign in to comment.