#lang scheme
(provide (all-defined-out))

; Contains "translations" of the basic and some combinator parsers from Hutton & Meijer, Monadic Parser Combinators (http://www.cs.nott.ac.uk/~gmh/monparsing.pdf),
; as well as some own combinators used from the dta-parser module.

; the parser's return type is:
; parse-result = empty | listof parse-result-item
(define make-parse-result
  (lambda items
    items))

; parse-result-item is a tuple of 2 strings: value and remaining
(define-struct parse-result-item (value remaining))

; Helper functions for getting, comparing, and printing parse results ------------------------------------------------------------------------
(define get-parse-result
  (lambda (pr)
    (if (null? pr) '() (first pr))))

(define parse-result-item=?
  (lambda (pri1 pri2)
    (and (equal? (parse-result-item-value pri1) (parse-result-item-value pri2))
         (string=? (parse-result-item-remaining pri1) (parse-result-item-remaining pri2)))))

(define parse-result=?
  (lambda (pr1 pr2)
    (andmap parse-result-item=? pr1 pr2)))

(define print-parse-result
  (lambda (pr)
    (if (null? pr)
        (format "Empty parse result")
        (map (lambda (item) (printf "< PRI value: ~s remaining: ~s >" (parse-result-item-value item) (parse-result-item-remaining item))) pr))))

(define ppr print-parse-result)

; Parsers "translated" from the Hutton & Meijer article ----------------------------------------------------------------------------------------
; return: a -> Parser a
(define return
  (lambda (value)
    (lambda (input)
      (list (make-parse-result-item value input)))))

; zero: Parser a
(define zero
  (lambda (input) empty))

; item: Parser Char
(define item
  (lambda (input)
    (match (string->list input)
      ('() empty)
      ((cons x xs) (list (make-parse-result-item (list->string (list x)) (list->string xs)))))))

; bind: Parser a -> (a -> Parser b) -> Parser b
(define bind
  (lambda (p1 build-p2)
    (lambda (input)
      (let ((p1-result (p1 input)))
        (flatten (map
                  (lambda (ri)
                    (let ((p1-value (parse-result-item-value ri))
                          (p1-remaining (parse-result-item-remaining ri)))
                      (let ((p2 (build-p2 p1-value)))
                        (p2 p1-remaining)))) p1-result))))))

; sat: (Char -> Bool) -> Parser Char
(define sat
  (lambda (pred)
    (bind item
          (lambda (x) (if (pred x) (return x) zero)))))

; char -> Parser  Char
(define char
  (lambda (c)
    (sat (lambda (x) (char=? c (first (string->list x)))))))

; Parser Char
(define digit
  (sat (lambda (x) (char<=? #\0 (first (string->list x)) #\9))))

; Parser x -> Parser y -> Parser z
(define seq
  (lambda (p1 p2)
    (bind p1
          (lambda (x)
            (bind p2
                  (lambda (y)
                    (return (string-append x y))))))))

; Parser Char
(define upper
  (sat (lambda (x) (char<=? #\A (first (string->list x)) #\Z))))

; Parser Char
(define lower
  (sat (lambda (x) (char<=? #\a (first (string->list x)) #\z))))

; Parser a -> Parser a -> Parser a
(define plus
  (lambda (p1 p2)
    (lambda (input)
      (append (p1 input) (p2 input)))))

; Parser a -> Parser a -> Parser a
(define plus1
  (lambda (p1 p2)
    (lambda (input)
      (let ((res ((plus p1 p2) input)))
        (if (null? res) res (list (first res)))))))
  
; Parser Char
(define letter
  (lambda (input)
    ((plus lower upper) input)))

; Parser Char
(define alphanum
  (plus letter digit))

; Parser String
(define word
  (let ((non-empty-word (bind letter
                              (lambda (x) (bind word
                                                (lambda (xs) (return (string-append x xs))))))))
    (plus non-empty-word (return ""))))

; string -> Parser String
(define string
  (lambda (s)
    (match (string->list s)
      ('() (return ""))
      ((cons x xs)
       (let ((x-as-str (list->string (list x)))
             (xs-as-str (list->string xs)))
         (bind (char x)
               (lambda (y) (bind (string xs-as-str)
                                 (lambda (z) (return (string-append x-as-str xs-as-str)))))))))))

; Parser a -> Parser (listof a)               
(define many
  (lambda (p)
    (plus1 (many1 p) (return ""))))

; Parser a -> Parser (listof a)               
(define many1
  (lambda (p)
    (bind p
          (lambda (x) (bind (many p)
                            (lambda (y) (return (string-append x y))))))))                       

; Parser a...
(define oneof
  (lambda p
    (foldl plus1 (first p) (rest p))))

; Parser a -> Parser b -> Parser (listof a)
(define sepby
  (lambda (p sep)
    (plus1 (sepby1 p sep) zero)))

; Parser a -> Parser b -> Parser (listof a)
(define sepby1
  (lambda (p sep)
    (let ((parse-sep&char (bind sep (lambda (dummy) p))))
      (bind p (lambda (x) (bind (many parse-sep&char)
                                (lambda (xs) (return (string-append x xs)))))))))


; Additional parsers required for dta-parser.ss --------------------------------------------------------------------------
; Parser a -> number -> Parser (listof a)
(define repeat
  (lambda (p times)
    (if (= times 0)
        zero
        (let loop ((count 1))
          (cond ((= count times) p)
                (else (seq p (loop (+ count 1)))))))))

; Combines the results of the list of parsers given into a list, neglecting empty string parse result values
(define combine-list
  (lambda (ps)
    (cond ((null? ps) (return '()))
          (else (bind (first ps)
                      (lambda (x) (bind (combine-list (rest ps))
                                        (lambda (y) (return (if (and (string? x) (= (string-length x) 0))
                                                                y
                                                               (cons x y)))))))))))

; Combines the results of 1-n applications of the parser into a list 
(define combine-list-many1
  (lambda (p)
    (bind p
          (lambda (x) (bind (combine-list-many p)
                            (lambda (y) (return (cons x y))))))))

; Combines the results of 0-n applications of the parser into a list
(define combine-list-many
  (lambda (p)
    (plus1 (combine-list-many1 p) (return '()))))
              
; Parser a -> Parser b
(define skip1
  (lambda (p)
    (bind p
          (lambda (ignore) (return "")))))

; Parser a -> Number -> Parser b
(define skip
  (lambda (p n)
    (repeat (skip1 p) n)))

; Parser space 
(define space
  (sat (lambda (x) (char=? #\space (first (string->list x))))))

; Parser newline 
(define newln
  (sat (lambda (x) (char=? #\newline (first (string->list x))))))

; Parser of scheme char
(define character
  (sat (lambda (x) (char? (first (string->list x))))))

; Parser blank
(define blank
  (lambda (n)
    (skip space n)))