#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PARSEQ.PLT
;; A Parser Combinator library.
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; combinator.ss - higher level combinator for parsers...
;; yc 12/31/2009 - first version
;; yc 1/5/2010 - moved delimited, bracket, and alternate to token.ss
(require "depend.ss"
         mzlib/defmacro
         (for-syntax scheme/base
                     "depend.ss"
                     scheme/match
                     )
         "primitive.ss" 
         "input.ss" 
         ) 

;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parser COMBINATORS

;; bind
;; Parser a -> (a -> Parser b) -> Parser b
;; this is the function version of the monad - use this when you want to
;; create higher combinators dynamically...
(define (bind parser v->parser) 
  (lambda (in)
    (let-values (((v in)
                  (parser in)))
      ((v->parser v) in))))

;; result
;; allows the transformation of the result of the parser...
(define (result parser transform)
  (bind parser 
        (lambda (v) 
          (if (succeeded? v) 
              (return (transform v))  
              fail))))

(define (result* parser transform)
  (bind parser 
        (lambda (v) 
          (if (and (succeeded? v) (list? v))
              (return (apply transform v))
              fail))))

;; seq
;; the macro-based monad for stringing multiple parsers together...
;; (seq parser) => parser
;; (seq v <- parser exp ...) => (bind paser (lambda (v) (if v (seq exp ...) fail))
(define-macro (seq . exps) 
  (define *in (gensym 'in)) ;; represents the input
  (define *v (gensym 'v)) ;; represents the value
  (define literal 'literal) 
  ;; sequence body for creating a sequence combinator...
  (define (body exps) 
    (match exps 
      ((list exp) 
       `((,literal ,exp) ,*in))
      ((list-rest var '<- exp rest)
        `(let-values (((,var ,*in)
                       ((,literal ,exp) ,*in)))
           (if (succeeded? ,var) 
               ,(body rest)
               (fail in))))
      ((list-rest exp rest) 
       (body `(,*v <- ,exp . ,rest)))
      ))
  `(lambda (in) 
     (let ((,*in in))
       ,(body exps))))

;; sequence
;; a functional version of seq
(define (sequence parsers) 
  (lambda (IN) 
    (define (helper parsers in acc) 
      (if (null? parsers) 
          ((return (reverse acc)) in)
          (let-values (((v in) 
                        ((car parsers) in))) 
            (if (succeeded? v) 
                (helper (cdr parsers) in (cons v acc))
                (fail IN)))))
    (helper (map literal parsers) IN '()))) 

;; sequence*
(define (sequence* . parsers)
  (sequence parsers))

;; #|
;; choice
;; (choice parser) => (bind parser (lambda (v) (if v (return v) fail))
;; (choice parser rest ...) => (bind parser (lambda (v) (if v (choice rest ...) fail)))
(define-macro (choice . exps) 
  (define *in (gensym 'in)) ;; represents the input
  (define *v (gensym 'v)) ;; represents the value
  (define (body exps) 
    (match exps 
      ((list) 
       `(fail ,*in))
      ((list-rest exp rest) 
       `(let-values (((,*v ,*in)
                      ((literal ,exp) ,*in)))
          (if (succeeded? ,*v)
               ((return ,*v) ,*in)
               ,(body rest))))
      ))
  `(lambda (,*in)
     ,(body exps)))
;;|#

;; one-of
;; a function version of choice
(define (one-of parsers)
  (lambda (in) 
    (define (helper parsers) 
      (if (null? parsers)
          (fail in) 
          (let-values (((v in) 
                        ((car parsers) in))) 
            (if (succeeded? v) 
                ((return v) in)
                (helper (cdr parsers))))))
    (helper (map literal parsers))))

;; one-of*
(define (one-of* . parsers)
  (one-of parsers)) 

;; all-of
(define (all-of parsers) 
  (lambda (in) 
    (define (helper parsers v)
      (if (null? parsers)
          ((return v) in) 
          (let-values (((v IN) 
                        ((car parsers) in)))
            (if (succeeded? v) 
                (helper (cdr parsers) v)
                (fail in)))))
    (helper (map literal parsers) (make-failed 0))))

;; all-of*
(define (all-of* . parsers) 
  (all-of parsers)) 

;; repeat
;; returns when # of occurence falls within the min and max range
;; default to [1,+inf]
(define (repeat parser (min 1) (max +inf.0)) 
  (define (make parser) 
    (lambda (IN) 
      (define (helper prev-in acc count)
        (let-values (((v in)
                      (parser prev-in)))
          (if (succeeded? v) 
              (if (< count max) 
                  (helper in (cons v acc) (add1 count))
                  ((return (reverse acc)) prev-in))
              (if (< count min) 
                  (fail IN)
                  ((return (reverse acc)) in)))))
      (helper IN '() 0)))
  (make (literal parser))) 

;; zero-many
;; returns the matched values if zero or more matches
;; (this means that this parser will always match)
(define (zero-many parser) 
  (repeat parser 0)) 

;; one-many
;; matches if parser parses one or more times
(define (one-many parser)
  (repeat parser)) 

;; zero-one
;; returns if the parser matches zero or one times
;; when the parser does not match, it defaults to fail, but you can pass in a
;; default value so it does not fail.
(define (zero-one parser default) 
  (lambda (in) 
    (let-values (((v in)
                  ((literal parser) in))) 
      ((return (if (succeeded? v) v default)) in))))

(provide bind
         result 
         result* 
         seq
         sequence
         sequence*
         choice
         one-of
         one-of* 
         all-of
         all-of* 
         repeat 
         zero-many
         one-many
         zero-one
         )