parsing Herbert programs

herbert-parser.scm

;;; herbert-parser.scm - parsing Herbert programs
;;;
;;; Usage (the result is indented manually):
;;;
;;;   % cat test.hervert
;;;   a(X,Y,Z):b(X-12+13-Y+Z,X)ccsslr
;;;   b(X):cccc
;;;   c:s
;;;   ss
;;;   % gosh herbert-parser.scm < test.hervert
;;;   (herbert
;;;    (definitions
;;;     (a (X Y Z) (b (+ (- (+ (- X 12) 13) Y) Z) X) (c) (c) (s) (s) (l) (r))
;;;     (b (X) (c) (c) (c) (c))
;;;     (c () (s)))
;;;    (execution-line (s) (s)))

(use parser.peg)

(define (parse-herbert source)
  (define (convert-precedence expr)
    (let l ((expr expr) (cont identity))
      (if (list? expr)
        (l (caddr expr) (^t `(,(car expr) ,(cont (cadr expr)) ,t)))
        (cont expr))))
  (define procname ($do (p ($one-of #[a-km-qt-z]))
                     ((.$ $return string->symbol string) p)))
  (define parameter upper)
  (define parameters ($sep-by parameter ($char #\,)))
  (define prototype
    ($do (name procname)
         (params ($optional
                  ($do (($char #\())
                       (ps parameters)
                       (($char #\)))
                    ($return ps))))
      ($return `(,name ,(or params ())))))
  (define definition
    ($do (proto prototype)
         (($char #\:))
         (content body)
         newline
      ($return `(,@proto ,@content))))
  (define sign ($do (s ($one-of #[-+])) ($return (if (eq? s #\-) '- '+))))
  (define number ($do (n ($many1 digit))
                   ((.$ $return string->number list->string) n)))
  (define numeric ($or number parameter))
  (define expression
    ($do (lhs numeric)
         (rhs ($optional
               ($do (s sign)
                    (r expression)
                 ($return (cons s r)))))
      ($return (if rhs
                 `(,(car rhs) ,lhs ,(cdr rhs))
                 lhs))))
  (define signed-expression
    ($do (s ($optional sign))
         (expr expression)
      ($return (let1 expr (convert-precedence expr)
                 (if (and s (eq? s '-)) `(- ,expr) expr)))))
  (define argument ($or signed-expression ($many1 statement)))
  (define arguments ($sep-by argument ($char #\,)))
  (define call
    ($do (name procname)
         (args ($optional
                ($do (($char #\()) (as arguments) (($char #\)))
                  ($return as))))
      ($return `(,name ,@(or args ())))))
  (define primitive ($do (p ($one-of #[srl]))
                      ((.$ $return list string->symbol string) p)))
  (define statement ($or primitive call parameter))
  (define body ($many statement))
  (define main ($do (r ($many1 statement)) eof ($return r)))
  (define program
    ($do (defs ($many definition))
           (prog main)
        ($return `(herbert (definitions . ,defs)
                           (execution-line . ,prog)))))
  (peg-parse-string program
   (regexp-replace-all* source  #/ +/ "" #/\n\n*/ "\n" #/\n$/ "")))

(define (main args)
  ((.$ print parse-herbert port->string current-input-port))
  0)