parse.knl

;;
;; parse.knl (based on PEG3.hum)
;;
($define! match-empty
	($lambda (in)
		(list #t () in)))
($define! match-fail
	($lambda (in)
		(list #f in)))
($define! match-any
	($lambda (in)
		($if (null? in)
			(list #f in)
			($let (((token . rest) in))
				(list #t token rest)))))
($define! match-eq
	($lambda (value)
		($lambda (in)
			($if (null? in)
				(list #f in)
				($let (((token . rest) in))
					($if (equal? token value)
						(list #t token rest)
						(list #f in)))))))
($define! match-if
	($lambda (test?)
		($lambda (in)
			($if (null? in)
				(list #f in)
				($let (((token . rest) in))
					($if (test? token)
						(list #t token rest)
						(list #f in)))))))
($define! match-or
	($lambda (left right)
		($lambda (in)
			($let (((ok . state) (left in)))
				($if ok
					(cons #t state)
					(right in))))))
($define! match-and
	($lambda (left right)
		($lambda (in)
			($let (((ok . state) (left in)))
				($if ok
					($let (((lval rest) state))
						($let (((ok . state) (right rest)))
							($if ok
								($let (((rval rest) state))
									(list #t (cons lval rval) rest))
								(list #f in))))
					(list #f in))))))
($define! match-alt
	($lambda (matches)
		($if (null? matches)
			match-fail
			(match-or (car matches) (match-alt (cdr matches))))))
($define! match-seq
	($lambda (matches)
		($if (null? matches)
			match-empty
			(match-and (car matches) (match-seq (cdr matches))))))
($define! match-opt
	($lambda (match)
		(match-or match match-empty)))
($define! match-star
	($lambda (match)
		($lambda (in)
			((match-opt (match-and match (match-star match))) in)
($define! match-plus
	($lambda (match)
		(match-and match (match-star match))))
($define! match-not
	($lambda (match)
		($lambda (in)
			($let (((ok . state) (match in)))
				($if ok
					(list #f in)
					(list #t () in))))))
($define! match-peek
	($lambda (match)
		(match-not (match-not match))))

;
; test fixture
;
; expr   = term ([-+] term)*
; term   = factor ([*/] factor)*
; factor = '(' expr ')' | number
; number = [0-9]+ $#
($define match-expr
	($lambda (in)
		((match-seq
			match-term
			(match-star (match-seq
				(match-or (match-eq '-') (match-eq '+'))
				match-term)))
		in)))
($define match-term
	($lambda (in)
		((match-seq
			match-factor
			(match-star (match-seq
				(match-or (match-eq '*') (match-eq '/'))
				match-factor)))
		in)))
($define match-factor
	($lambda (in)
		((match-alt
			(match-seq
				(match-eq '(')
				match-expr
				(match-eq ')'))
			match-number)
		in)))
($define match-number
	($lambda (in)
		((match-plus match-digit)
		in)))
($define match-digit
	($lambda (in)
		((match-alt
			(match-eq '0')
			(match-eq '1')
			(match-eq '2')
			(match-eq '3')
			(match-eq '4')
			(match-eq '5')
			(match-eq '6')
			(match-eq '7')
			(match-eq '8')
			(match-eq '9'))
		in)))

(match-expr '1' '+' '2' '*' '3' '-' '4')