uahgi2/parser.rkt

#lang racket
(require megaparsack megaparsack/text)
(require uahgi2/lexer)
(require megaparsack/parser-tools/lex)
(require data/monad)
(require data/applicative)

(define newline/p  (token/p 'NEWLINE))
(define num/p (do
      [num <- (token/p 'NUM)]
      (pure (number->string num))))
(define char/p  (token/p 'CHAR))
(define id/p  (token/p 'ID))
(define num-converter/p  (token/p 'NUM_CONVERTER))

(define string/p
     (do 
         [chars <- (many+/p char/p)]
         (pure (foldr string-append "" chars))))

(define atom/p (or/p
                num/p
                string/p
                id/p))

(define converting-num/p
  (do
      (token/p 'NUM_CONVERTER)
      [num <- num/p]
      (pure (string->number num))))


(define sexp-elem/p
  (delay/p (or/p (try/p series/p)
        expr/p)))


(define sexp/p
     (do
         (token/p 'L_PAREN)
         [args <- (many/p sexp-elem/p #:sep (token/p 'SEPERATOR))]
         (token/p 'R_PAREN)
         (pure (list* args))))

(define expr/p
  (or/p atom/p
        converting-num/p
        sexp/p))

(define series-elem/p
  (or/p newline/p
        num/p
        string/p
        id/p
        sexp/p))

(define series/p
  (do [args <- (many/p series-elem/p #:min 2)]
    (pure (list 'text-series args))))

(define prog/p
  (syntax/p
     (do
         (many/p (token/p 'NEWLINE))
         [lines <- (many/p expr/p #:sep (many/p(token/p 'NEWLINE)))]
         (many/p (token/p 'NEWLINE))
         (pure `(begin ,@lines)))))

(define (parse-tkns tokens)
  (parse-result! (parse-tokens prog/p tokens)))

(define (parse-string str)
  (parse-tkns (looping-lex str)))

(provide parse-tkns parse-string)