kekkonen/parse.scm

;;; Parser module building on comparse.

(module parse (lift followed-by-consuming is-not parse-whitespace skip-whitespace parse-symbol parse-number parse-string followed-by-consuming separated-by parse-symbol-or-number-or-string completely-parse parse-statement parse-line)
  (import scheme)
  (import chicken.base)
  (import srfi-13)
  (import srfi-14)
  (import util)
  (import comparse)

  (define +letter-char-set+
    (string->char-set "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVwXYZ"))

  (define +symbol-char-set+
    (char-set-union +letter-char-set+ (string->char-set "-0123456789")))

  (define (lift fn parser)
    (bind parser (compose result fn)))

  (define (is-not x)
    (satisfies (lambda (y)
		 (not (eqv? x y)))))

  (define parse-whitespace
    (one-or-more (is #\space)))

  (define skip-whitespace
    (skip (zero-or-more (is #\space))))

  (define parse-symbol
    (lift (compose string->symbol string-downcase list->string (applied append))
	  (sequence (lift list (in +letter-char-set+)) (zero-or-more (in +symbol-char-set+)))))

  (define parse-number
    (lift (compose string->number list->string) (one-or-more (in char-set:digit))))

  (define parse-string
    (lift list->string (enclosed-by (is #\") (one-or-more (is-not #\")) (is #\"))))

  (define (followed-by-consuming parser separator)
    (sequence* ((value parser) (_ separator))
	       (result value)))

  (define (separated-by separator parser)
    (one-or-more (any-of (followed-by-consuming parser separator) parser)))

  (define parse-symbol-or-number-or-string
    (any-of parse-number parse-symbol parse-string))

  (define (completely-parse parser)
    (followed-by parser end-of-input))

  (define parse-statement
    (all-of skip-whitespace (separated-by parse-whitespace parse-symbol-or-number-or-string)))

  (define (parse-line line)
    (parse (completely-parse parse-statement) line)))