#lang scheme #| This is the code, directly as typed in class. Do consider cleaning it up, eg moving the test cases to a separate file (See 'provide' in the manual. (Hit F1 to bring up the docs.)) |# (define-syntax (test-parse stx) (syntax-case stx () [(_ p input expected) #`(test-parse/proc p input expected #,(syntax-line stx))])) (define (test-parse/proc p str expected line) (let ([got (send p parse str 0)]) (unless (equal? got expected) (error 'test-parse "line ~a failed\n expected ~v\n got ~v" line expected got)))) (define-struct succ (pos v) #:transparent) (define parser<%> (interface () parse)) (define atom% (class* object% (parser<%>) (init-field char) (define/public (parse str pos) (cond [(and (< pos (string-length str)) (equal? char (string-ref str pos))) (make-succ (+ pos 1) char)] [else #f])) (super-new))) (define (p-atom char) (new atom% [char char])) (test-parse (p-atom #\a) "a" (make-succ 1 #\a)) (test-parse (p-atom #\a) "" #f) (test-parse (p-atom #\a) "b" #f) (define or% (class* object% (parser<%>) (init-field p1 p2) (define/public (parse str pos) (or (send p1 parse str pos) (send p2 parse str pos))) (super-new))) (define (p-or p1 . ps) (cond [(null? ps) p1] [else (new or% [p1 p1] [p2 (apply p-or ps)])])) (test-parse (p-or (p-atom #\a) (p-atom #\b)) "a" (make-succ 1 #\a)) (test-parse (p-or (p-atom #\a) (p-atom #\b)) "b" (make-succ 1 #\b)) (test-parse (p-or (p-atom #\a) (p-atom #\b)) "c" #f) (define seq% (class* object% (parser<%>) (init-field p1 p2) (define/public (parse str pos) (let ([p1-ans (send p1 parse str pos)]) (and p1-ans (let ([p2-ans (send p2 parse str (succ-pos p1-ans))]) (and p2-ans (make-succ (succ-pos p2-ans) (list (succ-v p1-ans) (succ-v p2-ans)))))))) (super-new))) (define (p-seq p1 p2) (new seq% [p1 p1] [p2 p2])) (test-parse (p-seq (p-atom #\a) (p-atom #\b)) "ab" (make-succ 2 (list #\a #\b))) (test-parse (p-seq (p-atom #\a) (p-atom #\b)) "aa" #f) (test-parse (p-seq (p-atom #\a) (p-atom #\b)) "ba" #f) (define knot% (class* object% (parser<%>) (define p #f) (define ht (make-hash)) (define/public (parse str pos) (cond [(not p) (error 'knot% "untied")] [else (hash-ref ht (cons str pos) (λ () (let ([res (send p parse str pos)]) (hash-set! ht (cons str pos) res) res)))])) (define/public (tie _p) (set! p _p)) (super-new))) (define D (p-or (p-atom #\0) (p-atom #\1) (p-atom #\2) (p-atom #\3) (p-atom #\4) (p-atom #\5) (p-atom #\6) (p-atom #\7) (p-atom #\8) (p-atom #\9))) (define N/raw (new knot%)) (send N/raw tie (p-or (p-seq D N/raw) D)) (test-parse N/raw "0" (make-succ 1 #\0)) (test-parse N/raw "012" (make-succ 3 (list #\0 (list #\1 #\2)))) (define trans% (class* object% (parser<%>) (init-field p f) (define/public (parse str pos) (let ([res (send p parse str pos)]) (and res (make-succ (succ-pos res) (f (succ-v res)))))) (super-new))) (define (p-trans p f) (new trans% [p p] [f f])) (test-parse (p-trans (p-atom #\0) (λ (x) 123)) "0" (make-succ 1 123)) (test-parse (p-trans (p-atom #\0) (λ (x) 123)) "x" #f) (define N (p-trans N/raw (λ (l) (let loop ([l l] [acc '()]) (cond [(char? l) (string->number (apply string (reverse (cons l acc))))] [else (loop (cadr l) (cons (car l) acc))]))))) (test-parse N "0123" (make-succ 4 123)) (define E (new knot%)) ;; aproc : char -> parser (define (aproc c) (p-seq E (p-seq (p-atom c) E))) (send E tie (p-or (aproc #\-) (aproc #\+) N)) ;(test-parse E "12+12" (make-succ 2 12)) ;(test-parse E "(12+12)" (make-succ 7 (list #\( (list 12 (list #\+ (list 12 #\))))))) (define X (new knot%)) (send X tie (p-or (p-seq (p-atom #\a) X) (p-seq (p-atom #\a) X))) ; ;(time (send X parse "aaaaaaaaaaaaaab" 0)) ;(time (send X parse "aaaaaaaaaaaaaaab" 0)) ;(time (send X parse "aaaaaaaaaaaaaaaab" 0)) ;(time (send X parse "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaab" 0)) (define (p-keyword str) (p-trans (p-seq (p-seq-list (map p-atom (string->list str))) (new not% [p (p-or (p-atom #\a) (p-atom #\b) (p-atom #\c) (p-atom #\d) (p-atom #\e) (p-atom #\f))])) (λ (x) str))) ;; p-seq-list : list-of-parser -> parser ;; buidls a sequence parser from ps (define (p-seq-list ps) (cond [(empty? (rest ps)) (car ps)] [else (p-seq (car ps) (p-seq-list (cdr ps)))])) (define not% (class* object% (parser<%>) (init-field p) (define/public (parse str pos) (let ([p-res (send p parse str pos)]) (cond [p-res #f] [else (make-succ pos (void))]))) (super-new))) (test-parse (new not% [p (p-atom #\a)]) "a" #f) (test-parse (new not% [p (p-atom #\a)]) "b" (make-succ 0 (void))) (test-parse (p-keyword "while") "while" (make-succ 5 "while")) (test-parse (p-keyword "for") "for" (make-succ 3 "for")) (test-parse (p-keyword "while") "for" #f) (test-parse (p-keyword "while") "whilefor" #f) (test-parse (p-seq (p-keyword "while") (p-keyword "for")) "whilefor" #f)