; Luke McCarthy March 2008
; Haskell-style Parser Combinators in Scheme
; http://shaurz.wordpress.com/2008/03/11/haskell-style-parser-combinators-in-scheme/

(use srfi-14)

(define (test-parser p)
  (printf ">> ")
  (let ([s (read-line)])
    (let-values ([(v i) (p s 0)])
      (if i
          (begin
            (printf "Parsed    : ~S (~A characters)~N" (substring s 0 i) i)
            (when (< i (string-length s))
              (printf "Remaining : ~S~N" (substring s i)))
            (printf "Returned  : ~S~N" v))
          (print "Failed")))))

(define-for-syntax *v-name* (gensym 'v))
(define-for-syntax *s-name* (gensym 's))
(define-for-syntax *i-name* (gensym 'i))

(define-for-syntax (expand-parser-body forms)
  (match forms
    [(_ '<- _)
       (error "parser must end with non-binding form")]
    [(p)
       `(,p ,*s-name* ,*i-name*)]
    [(v '<- p . xs)
       `(let-values ([(,v ,*i-name*) (,p ,*s-name* ,*i-name*)])
          (if ,*i-name*
              ,(expand-parser-body xs)
              (values #f #f)))]
    [(p . xs)
       `(let-values ([(,*v-name* ,*i-name*) (,p ,*s-name* ,*i-name*)])
          (if ,*i-name*
              ,(expand-parser-body xs)
              (values #f #f)))]))

(define-macro (parser . body)
  `(lambda (,*s-name* ,*i-name*)
     ,(expand-parser-body body)))

(define-inline fail (lambda (s i) (values #f #f)))
(define-inline (return v) (lambda (s i) (values v i)))

(define any-char
  (lambda (s i)
    (if (< i (string-length s))
        (values (string-ref s i) (+ i 1))
        (values #f #f))))

(define (matches m)
  (lambda (s i)
    (let ([n (string-length m)])
      (if (and (<= (+ i n) (string-length s))
               (string=? m (substring s i (+ i n))))
          (values (substring s i (+ i n)) (+ i n))
          (values #f #f)))))

(define (choice . ps)
  (lambda (s i)
    (let loop ([p ps])
      (if (pair? p)
          (let-values ([(v i) ((car p) s i)])
            (if i
                (values v i)
                (loop (cdr p))))
          (values #f #f)))))

(define (while-char pred)
  (lambda (s i)
    (let ([len (string-length s)])
      (let loop ([j i])
        (if (and (< j len) (pred (string-ref s j)))
            (loop (+ j 1))
            (values (substring s i j) j))))))

(define (while1-char pred)
  (parser
    s <- (while-char pred)
    (if (> (string-length s) 0) (return s) fail)))

(define (if-char pred)
  (parser
    c <- any-char
    (if (pred c) (return c) fail)))

(define (space? c)
  (char-set-contains? char-set:whitespace c))

(define (digit? c)
  (char-set-contains? char-set:digit c))

(define (digit->integer c)
  (- (char->integer c) (char->integer #\0)))

(define digit
  (parser
    c <- (if-char digit?)
    (return (digit->integer c))))

(define decimal
  (parser
    s <- (while1-char digit?)
    (return (string->number s))))

(define (token p)
  (parser
    (while-char space?)
    x <- p
    (return x)))

(define expr
  (parser
    lhs <- term
    (let loop ([lhs lhs])
      (choice
        (parser
          opr <- (token (choice (matches "+") (matches "-")))
          rhs <- term
          (loop (list (string->symbol opr) lhs rhs)))
        (return lhs)))))

(define term
  (parser
    lhs <- factor
    (let loop ([lhs lhs])
      (choice
        (parser
          opr <- (token (choice (matches "*") (matches "/")))
          rhs <- factor
          (loop (list (string->symbol opr) lhs rhs)))
        (return lhs)))))

(define factor
  (choice
    (token decimal)
    (parser
      (token (matches "("))
      e <- expr
      (token (matches ")"))
      (return e))
    (parser
      (token (matches "-"))
      e <- factor
      (return (list '- e)))))

(print "Enter an expression:")
(test-parser expr)