Welcome to the CHICKEN Scheme pasting service

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

(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-syntax parser
  (syntax-rules (<-)
    ((parser)
     (error "empty parser"))
    ((parser v <- p)
     (error "parser must end with non-binding form"))
    ((parser p)
     (error "parser without binding"))
    ((parser v <- p f)
     (lambda (s i)
       (let-values (((v i) (p s i)))
         (if i
             (f s i)
             (values #f #f)))))
    ((parser v <- p . ...)
     (lambda (s i)
       (let-values (((v i) (p s i)))
         (if i
             ((parser . ...) s i)
             (values #f #f)))))
    ((parser p f)
     (lambda (s i)
       (let-values (((v i) (p s i)))
         (if i
             (f s i)
             (values #f #f)))))
    ((parser p . ...)
     (lambda (s i)
       (let-values (((v i) (p s i)))
         (if i
             ((parser . ...) s i)
             (values #f #f)))))))

;;;;;;;;;;;;;
;; Parsers
;;;;;;;;;;;;;

(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 (any-char-but c)
  (lambda (s i)
    (if (and (< i (string-length s))
	     (not (char-set-contains? (string->char-set c)
				      (string-ref s i))))
        (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 (star p)
  (parser
   el <- p
   (let loop ((l (list el)))
     (choice
      (parser
       n <- p
       (loop (append l (list n))))
      (return l)))))

(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 (in? set)
  (lambda (c)
    (char-set-contains? set c)))

(define (anyof? string)
  (lambda (c)
    (char-set-contains? (string->char-set string) c)))

(define (nonof? string)
  (lambda (c)
    (not (char-set-contains? (string->char-set string) 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 (notspace? x)
  (not (space? x)))


(define tag
  (parser
   (matches "[")
   name <- (while-char (nonof? "]="))
   para <- (choice
	    (parser (matches "]")
		    (return #f))
	    (parser (matches "=")
		    p <- (while-char (nonof? " ]"))
		    (matches "]")
		    (return p)))
   cont <- text
   (matches "[/")
   (matches name)
   (matches "]")
   (return (list 'tag name para cont))))

(define words
  (parser
   c <- (any-char-but "[]")
   t <- (while-char (nonof? "[] "))
   (return (string-append  (make-string 1 c) t))
   ))

(define link
  (parser
   a <- (token (choice
                (matches "http://")
                (matches "https://")
                (matches "mailto:")
                ;; you may add others: ftp ssh gopher telnet &c.
                ))
   b <- (while-char (anyof? "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789@?./\\#=+-_"))
   (return (list 'link (string-append a b)))))

(define text
  (star
   (choice
    tag
    link
    words)))

(define (bbparse t)
  (text t 0))

)
; (print "Enter an expression:")
; (test-parser text)