(require-extension typeclass input-classes lexgen srfi-1 srfi-14 test)
(define char-list-
(make- null? car cdr))
(define char-list-
(Input->Token char-list-))
(define char-list-
(Token->CharLex char-list-))
(import-instance ( char-list- char-list/)
( char-list- char-list/))
(define a-pat (char-list/tok #\a (try char=?)))
(define b-pat (char-list/tok #\b (try char=?)))
(define a-then-b-pat (seq a-pat b-pat))
(define a-or-b-pat (bar a-pat b-pat))
(define a-star-pat (star a-pat))
(define a-star-or-b-pat (bar (star a-pat) b-pat))
(define a-or-b-star-pat (star a-or-b-pat))
(define a-b-opt-pat (seq a-pat (opt b-pat)))
(define b-opt-a-pat (seq (opt b-pat) a-pat))
(define a-b-opt-a-pat (seq a-pat (seq (opt b-pat) a-pat)))
(define a-star-b-opt-pat (seq (star a-pat) (opt b-pat)))
(define aabac-pat (char-list/lit "aabac"))
(define aa-pat (char-list/lit "aa"))
(define n4-pat (lst (list-tabulate 4 (lambda (i) (char-list/range #\0 #\9)))))
(define abc-stream `(() ,(string->list "abc")))
(define bac-stream `(() ,(string->list "bac")))
(define aabac-stream `(() ,(string->list "aabac")))
(define aaaabac-stream `(() ,(string->list "aaaabac")))
(define num-stream `(() ,(string->list "1234")))
(define (err s)
(print "lexical error on stream: " s)
`(error))
(test-group "lexgen test"
(test (sprintf "match [a] on ~S" "abc")
`((#\a) (#\b #\c)) (a-pat identity err abc-stream))
(test (sprintf "match [b] on ~S" "abc")
`(error) (b-pat identity err abc-stream))
(test (sprintf "match ab on ~S" "abc")
`((#\b #\a ) ( #\c))
(a-then-b-pat identity err abc-stream))
(test (sprintf "match a|b on ~S" "abc")
`((#\a) (#\b #\c))
(a-or-b-pat identity err abc-stream))
(test (sprintf "match a|b on ~S" "bac")
`((#\b) (#\a #\c))
(a-or-b-pat identity err bac-stream))
(test (sprintf "match a* on ~S" "abc")
`((#\a) (#\b #\c))
(a-star-pat identity err abc-stream))
(test (sprintf "match a* on ~S" "aabac")
`((#\a #\a) (#\b #\a #\c))
(a-star-pat identity err aabac-stream))
(test (sprintf "match (a*|b) on ~S" "aabac")
`((#\a #\a) (#\b #\a #\c))
(a-star-or-b-pat identity err aabac-stream))
(test (sprintf "match (a|b)* on ~S" "abc")
`((#\b #\a) (#\c))
(a-or-b-star-pat identity err abc-stream))
(test (sprintf "match (a|b)* on ~S" "aabac")
`((#\a #\b #\a #\a) (#\c))
(a-or-b-star-pat identity err aabac-stream))
(test (sprintf "match ab? on ~S" "abc")
`((#\b #\a) (#\c))
(a-b-opt-pat identity err abc-stream))
(test (sprintf "match ab? on ~S" "aabac")
`((#\a) (#\a #\b #\a #\c))
(a-b-opt-pat identity err aabac-stream))
(test (sprintf "match b?a on ~S" "abc")
`((#\a) (#\b #\c))
(b-opt-a-pat identity err abc-stream))
(test (sprintf "match ab?a on ~S" "aabac")
`((#\a #\a) (#\b #\a #\c))
(a-b-opt-a-pat identity err aabac-stream))
(test (sprintf "match a*b? on ~S" "aabac")
`((#\b #\a #\a) (#\a #\c))
(a-star-b-opt-pat identity err aabac-stream))
(test (sprintf "match literal string ~S" "aabac")
`((#\c #\a #\b #\a #\a) ())
(aabac-pat identity err aabac-stream))
(test (sprintf "match n4 on ~S" "1234")
`((#\4 #\3 #\2 #\1) ())
(n4-pat identity err num-stream))
)
;; A pattern to match floating point numbers.
;; "-"?(([0-9]+(\\.[0-9]+)?)|(\\.[0-9]+))([eE][+-]?[0-9]+)?
(define numpat
(let* ((digit (char-list/range #\0 #\9))
(digits (pos digit))
(fraction (seq (char-list/char #\.) digits))
(significand (bar (seq digits (opt fraction)) fraction))
(exp (seq (char-list/set "eE") (seq (opt (char-list/set "+-")) digits)))
(sign (opt (char-list/char #\-))))
(seq sign (seq significand (opt exp)))))
(print (lex numpat err "-123.45e-6"))
(test-group "lexgen numpat test"
(test (sprintf "match numpat on ~S" "-123.45e-6")
`(#\- #\1 #\2 #\3 #\. #\4 #\5 #\e #\- #\6)
(car (lex numpat err "-123.45e-6")))
(test (sprintf "match numpat on ~S" "hi there")
`(error)
(lex numpat err "hi there")))
(define (->char-list s)
(if (string? s) (string->list s) s))
(define (collect cs)
(let loop ((cs cs) (ax (list)))
(cond ((null? cs) `(,(list->string ax)))
((atom? (car cs)) (loop (cdr cs) (cons (car cs) ax)))
(else (cons (list->string ax) cs)))))
(define (make-exp x)
(or (and (pair? x)
(let ((x1 (collect x)))
(list `(exp . ,x1)))) x))
(define (make-significand x)
(or (and (pair? x)
(let ((x1 (collect x)))
(cons `(significand ,(car x1)) (cdr x1)))) x))
(define (make-sign x)
(or (and (pair? x)
(let ((x1 (collect x)))
(cons `(sign ,(car x1)) (cdr x1)))) x))
(define (check s) (lambda (s1) (if (null? s1) (err s) s1)))
(define bnumpat
(let* ((digit (char-list/range #\0 #\9))
(digits (star digit))
(fraction (seq (char-list/char #\.) digits))
(significand (bar (seq digits (opt fraction)) fraction))
(exp (seq (char-list/set "eE") (seq (opt (char-list/set "+-")) digits)))
(sign (opt (char-list/char #\-)) )
(pat (seq (bind make-sign sign)
(seq (bind make-significand significand)
(bind make-exp (opt exp))))))
pat))
(define (num-parser s) (car (lex bnumpat err s)))
(test-group "lexgen num-parser test"
(test (sprintf "match num-parser on ~S" "-123.45e-6")
`((sign "-") (significand "123.45") (exp "e-6"))
(num-parser "-123.45e-6")) )
;; Tokens with position information
(define-record-type postok
(make-postok pos token)
postok?
(pos postok-pos )
(token postok-token )
)
(define pos? pair?)
(define pos-row car)
(define pos-col cdr)
(define make-pos cons)
(define-record-printer (postok x out)
(fprintf out "#"
(postok-pos x)
(postok-token x)))
(define (getpos p)
(let ((f (lambda (in) (and (pair? in) (postok-pos (car in)))))
(g (lambda (i s) (list (make-postok i (car s))))))
(rebind f g p)))
(define pos-
(let ((pos-tail
(lambda (strm)
(cond ((or (null? strm) (null? (cdr strm))) '())
(else
(let* ((curtok (car strm))
(pos0 (postok-pos curtok))
(pos1 (let ((row0 (pos-row pos0))
(col0 (pos-col pos0)))
(case (cadr strm)
((#\newline) (make-pos (+ 1 row0) 1))
((#\return) (make-pos row0 1))
(else (make-pos row0 (+ 1 col0))))))
(res (cons (make-postok pos1 (cadr strm)) (cddr strm))))
res)))))
(pos-null? null?)
(pos-head (compose postok-token car)))
(make- pos-null? pos-head pos-tail)))
(define pos-
(Input->Token pos-))
(define pos-
(Token->CharLex pos-))
(import-instance ( pos- pos/)
( pos- pos/))
(define (make-pos-stream strm)
(let ((begpos (make-pos 1 1)))
`(() ,(cons (make-postok begpos (car strm)) (cdr strm)))))
(define pos-numpat-stream
(make-pos-stream (string->list "-123.45e-6")))
(define pbnumpat
(let* ((digit (pos/range #\0 #\9))
(digits (star digit))
(fraction (seq (pos/char #\.) digits))
(significand (bar (seq digits (opt fraction)) fraction))
(exp (seq (pos/set "eE") (seq (opt (pos/set "+-")) digits)))
(sign (opt (pos/char #\-)) )
(pat (seq (getpos (bind make-sign sign))
(seq (getpos (bind make-significand significand))
(getpos (bind make-exp (opt exp)))))))
pat))
(define (pos-num-parser s) (car (lex pbnumpat err s)))
(test-group "lexgen pos-num-parser test"
(test (sprintf "match pos-num-parser on ~S" "-123.45e-6")
`(,(make-postok (make-pos 1 1) `(sign "-"))
,(make-postok (make-pos 1 2) `(significand "123.45"))
,(make-postok (make-pos 1 8) `(exp "e-6")))
(pos-num-parser pos-numpat-stream))
)
(test-exit)