regex.rkt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (assert pred)
  (or pred (amb)))

(define amb-queue (make-parameter #f))
(define amb-escape (make-parameter #f))

(define-syntax-rule (begin-amb fail body ...)
  (let/cc k
    (parameterize ([amb-queue '()]
                   [amb-escape (λ () (k fail))])
      body ...)))

(define-syntax-rule (amb alt ...)
  (let/cc k
    (amb-queue (append (amb-queue)
                       (list (λ () (k alt)) ...)))
    (if (empty? (amb-queue))
        ((amb-escape))
        (let ([top (car (amb-queue))])
          (amb-queue (cdr (amb-queue)))
          (top)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ε k) k)

(define (((char c) k) u)
  (assert (and (cons? u) (eq? (car u) c)))
  (k (cdr u)))

(define ((alt p q) k)
  ((amb p q) k))

(define ((seq p q) k)
  (p (q k)))

(define (((rep r) k) u)
  ((amb k (r ((rep r) k))) u))

(define (accept? r u)
  (begin-amb #f ((r (λ (u) (assert (empty? u)))) u)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (str s)
  (for/fold ([f ε])
            ([c (string->list s)])
    (seq f (char c))))

(accept? (alt (str "hi") (str "there"))
         (string->list "hi"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;