Permalink
Browse files

Simple parser combinators

Make the first version of the code consistent with the article's
sections "Simple parser combinators" and "Memoization".
  • Loading branch information...
1 parent c994a06 commit b3dd232080c0c5d38bf685e1b7982e634168b337 @epsil committed Nov 30, 2012
Showing with 75 additions and 77 deletions.
  1. +75 −77 1/parser.rkt
View
@@ -1,96 +1,94 @@
-#! /usr/bin/racket
#lang racket
-;; list version of set-union
-(define (union . sets)
- (reverse (set->list (apply set-union (map list->set sets)))))
+;;; Simple parser combinators
-;;; Memoization
+(require racket/mpair)
-(define (memo fn)
- (let ((alist '()))
- (lambda args
- (let ((entry (assoc args alist)))
- (if entry
- (cdr entry)
- (let ((result (apply fn args)))
- (set! alist (cons (cons args result) alist))
- result))))))
+(struct success (val rest) #:transparent)
+(struct failure (rest) #:transparent)
-;;; Parser combinators
+(define-syntax-rule (delay-parser parser)
+ (lambda args
+ (apply parser args)))
-(define-syntax-rule (define-parser parser body ...)
+(define-syntax-rule (define-parser parser body)
(define parser
- (memo
- (lambda (p)
- (map (lambda (r)
- (cons (cons 'parser (cdr (car r)))
- (cdr r)))
- ((begin body ...) p))))))
-
-(define-syntax-rule (term X ...)
+ (delay-parser body)))
+
+(define (memo fn)
+ (let ((alist (mlist)))
+ (lambda args
+ (match (massoc args alist)
+ [(mcons args result) result]
+ [_ (let* ((result (apply fn args))
+ (entry (mcons args result)))
+ (set! alist (mcons entry alist))
+ result)]))))
+
+(define succeed
(memo
- (lambda (p)
- (if (and (pair? p)
- (member (car p) '(X ...)))
- (list (cons (list 'term (car p)) (cdr p)))
- '()))))
+ (lambda (val)
+ (memo
+ (lambda (str)
+ (success val str))))))
-(define-syntax-rule (seq A ...)
+(define string
(memo
- (lambda (p)
- (foldl (lambda (fn v)
- (foldl union '()
- (map (lambda (prev)
- (map (lambda (next)
- (cons (append (car prev)
- (list (car next)))
- (cdr next)))
- (fn (cdr prev))))
- v)))
- (list (cons '(seq) p))
- (list A ...)))))
-
-(define-syntax-rule (alt A ...)
+ (lambda (match)
+ (memo
+ (lambda (str)
+ (let* ((len (min (string-length str) (string-length match)))
+ (head (substring str 0 len))
+ (tail (substring str len)))
+ (if (equal? head match)
+ (success head tail)
+ (failure str))))))))
+
+(define (bind p fn)
+ (lambda (str)
+ (match (p str)
+ [(success val rest)
+ ((fn val) rest)]
+ [failure failure])))
+
+(define seq
(memo
- (lambda (p)
- (foldl (lambda (fn v)
- (union v (fn p)))
- '()
- (list A ...)))))
+ (lambda (a b)
+ (memo
+ (bind a (lambda (x)
+ (bind b (lambda (y)
+ (succeed (list x y))))))))))
-(define-syntax-rule (opt A)
- (alt epsilon A))
-
-(define-syntax-rule (k* A)
- (alt epsilon
- (seq A (k* A))))
-
-;;; Parsers
-
-(define epsilon list)
-
-;; article
-(define-parser DET (term the a))
+(define alt
+ (memo
+ (lambda (a b)
+ (memo
+ (lambda (str)
+ (let ((result (a str)))
+ (match result
+ [(success val rest) result]
+ [failure (b str)])))))))
-;; noun
-(define-parser N (term student professor cat class))
+(define-parser article
+ (alt (string "the ")
+ (string "a ")))
-;; noun phrase
-(define-parser NP (seq DET N))
+(define-parser noun
+ (alt (string "student ")
+ (string "professor ")))
-;; verb
-(define-parser V (term studies lectures eats sleeps))
+(define-parser verb
+ (alt (string "studies ")
+ (string "lectures ")))
-;; sentence
-(define-parser S (seq NP VP))
+(define-parser noun-phrase
+ (seq article noun))
-;; verb phrase: VP -> V NP | V S
-(define-parser VP
- (alt (seq V NP)
- (seq V S)))
+(define-parser verb-phrase
+ (seq verb noun-phrase))
-;;; Test
+(define-parser sentence
+ (seq noun-phrase verb-phrase))
-(S '(the professor lectures the student))
-(S '(the student studies the cat intently))
+(sentence "the professor lectures the student ")
+(sentence "not a sentence ")

0 comments on commit b3dd232

Please sign in to comment.