(define phosphate-dto (make-parameter eqv-alist-dto))
(define phosphate-empty-dict (make-parameter '()))

;;; ;;;;;;;;;;;;;;;;;;;;;
;;; Fundamental parsers
;;; ;;;;;;;;;;;;;;;;;;;;;

(define (dict-invoke dto dict key . arguments)
  (apply (dict-ref dto dict key) dto dict arguments))

(define (return/p . %values)
  (lambda (dto dict dyn)
    (apply values dict %values)))

(define-syntax delay/p
  (syntax-rules ()
    ((_ expr ...)
     (lambda (dto dict dyn)
       (values dict expr ...)))))

(define (ref/p key)
  (lambda (dto dict dyn)
    (values dict (dict-ref dto dict key))))

(define expose/p
  (lambda (dto dict dyn)
    (values dict dto dict dyn)))

(define (test/p conditional)
  (if conditional (return/p) fail/p))

;;; ;;;;;;;;;;;;;
;;; Fundamental parsers: current input
;;; ;;;;;;;;;;;;;

(define eof/p
  (lambda (dto dict dyn)
    (if (dict-ref dto dict 'eof?)
        ((return/p) dto dict dyn)
        (fail/p dto dict dyn))))

(define (satisfy/p predicate?)
  (lambda (dto dict dyn)
    (if (dict-ref dto dict 'eof?)
        (fail/p dto dict dyn)
        (let ((obj (dict-ref dto dict 'here)))
          (if (predicate? obj)
              (values (dict-invoke dto dict 'next)
                      obj)
              (fail/p dto dict dyn))))))

;;; ;;;;;;;;;;;;;;;;;;
;;; Fundamental parsers: sequencing
;;; ;;;;;;;;;;;;;;;;;;

(define-syntax lv/p
  (syntax-rules ()
    ((_ ((formal parser) ...) parser2)
     (lambda (dto dict dyn)
       (let*-values (((dict . formal) (parser dto dict dyn)) ...)
         (parser2 dto dict dyn))))))

(define (parameterize/p parser . associations)
  (lambda (dto dict dyn)
    (parser dto dict
            (apply dict-set! dto dyn associations))))

(define (parameterize-update/p key updater parser)
  (lambda (dto dict dyn)
    (parser dto dict
            (dict-update! dto dyn key updater))))

(define (ref-parameter/p key)
  (lambda (dto dict dyn)
    (values dict (dict-ref dto dyn key))))

;;; ;;;;;;;;;;;;;;;;;;;;;;;
;;; Fundamental parsers: backtracking
;;; ;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax parse
  (syntax-rules ()
    ((_ dto dict dyn parser %handlers ...)
     ((handle-errors/p parser %handlers ...) dto dict dyn))))

(define-syntax handle-errors/p
  (syntax-rules ()
    ((_ parser (name handler) ...)
     (lambda (dto dict dyn)
       ((call/cc (lambda (return)
                   (let-values ((returned
                                 (parser dto
                                         dict
                                         (apply dict-set!
                                                dto
                                                dyn
                                                (append
                                                 (list name
                                                       (lambda formals
                                                         (return
                                                          (lambda ()
                                                            (apply handler
                                                                   formals)))))
                                                 ...)))))
                     (lambda () (apply values returned))))))))))

(define unique-mark (vector #f))

(define-syntax if/p
  (syntax-rules ()
    ((_ conditional/p subsequent/p alternative/p)
     (lv/p (((dto dict dyn) expose/p)
            (returned (handle-errors/p conditional/p
                        (#f (lambda unused
                              (values dict unique-mark))))))
       (if (and (pair? returned)
                (eq? (car returned) unique-mark))
           alternative/p
           (apply subsequent/p returned))))))

(define-syntax cond/p
  (syntax-rules (else =>)
    ((_) fail/p)
    ((_ (else parser)) parser)
    ((_ (p1) rest ...)
     (if/p p1 return/p (cond/p rest ...)))
    ((_ (p1 => formals p2) rest ...)
     (if/p p1
           (lambda formals p2)
           (cond/p rest ...)))
    ((_ (p1 p2) rest ...)
     (if/p p1
           (lambda ignored p2)
           (cond/p rest ...)))))

(define (as-error/p mark parser . irritants)
  (lv/p (((dto dict dyn) expose/p))
    (handle-errors/p parser
      (#f (lambda (k dto dict ignored-dyn ignored-mark . rest)
            ((apply error/p mark (append rest irritants)) dto dict dyn))))))

(define (invoke-handler return dto dict dyn mark irritants)
  (let ((when-true (lambda (handler)
                     (apply handler return dto dict dyn mark irritants))))
    (dict-ref dto dyn mark
              (lambda ()
                (dict-ref dto dyn #t
                          (lambda ()
                            (error 'invoke-handler "no handler" mark))
                          when-true))
              when-true)))

(define (error/p mark . irritants)
  (lambda (dto dict dyn)
    ((call/cc (lambda (return)
                (invoke-handler return dto dict dyn mark irritants))))))

(define fail/p
  (lv/p (((dto dict dyn) expose/p))
    (error/p #f)))

(define (or/p . parsers)
  (let loop ((parsers parsers))
    (cond
      ((null? parsers) fail/p)
      ((null? (cdr parsers)) (car parsers))
      (else (if/p (car parsers)
                  return/p
                  (loop (cdr parsers)))))))

(define (lookahead/p parser)
  (lv/p (((dto dict dyn) expose/p))
    (handle-errors/p (lv/p ((ignored parser))
                       (lambda ignored dict))
      (#f (lambda (k dto dict ignored-dyn . rest)
           (invoke-handler k dto dict dyn #f rest))))))

(define (not/p parser)
  (lv/p (((dto dict dyn) expose/p))
    (handle-errors/p (lv/p ((ignored parser))
                       (error/p 'not/p))
      (#f (lambda (k . rest)
           ((return/p) dto dict dyn)))
      ('not/p (lambda (k ignored-dto ignored-dict ignored-dyn . rest)
               (fail/p dto dict dyn))))))

;;; ;;;;;;;;;;;;;;;;;
;;; Derived parsers: predicates
;;; ;;;;;;;;;;;;;;;;;

(define advance/p
  (satisfy/p (lambda (x) #t)))

(define ==/p
  (case-lambda
    ((obj) (==/p obj equal?))
    ((obj equal?) (satisfy/p (lambda (obj2) (equal? obj obj2))))))

(define !==/p
  (case-lambda
    ((obj) (!==/p obj equal?))
    ((obj equal?) (satisfy/p (lambda (obj2) (not (equal? obj obj2)))))))

(define ==seq/p
  (case-lambda
    ((sequence) (==seq/p sequence equal?))
    ((sequence equal?)
     (letrec ((loop
               (lambda (sequence)
                 (if (null? sequence)
                     (return/p)
                     (lv/p (((unused) (==/p (car sequence) equal?)))
                       (loop (cdr sequence)))))))
       (loop (cond
               ((pair? sequence) sequence)
               ((vector? sequence) (vector->list sequence))
               ((string? sequence) (string->list sequence))
               (else (error '==seq/p "not a sequence" sequence))))))))

(define one-of/p
  (case-lambda
    ((sequence) (one-of/p sequence equal?))
    ((sequence equal?)
     (satisfy/p (lambda (obj) (member obj sequence equal?))))))

;;; ;;;;;;;;;;;;;;;;;;
;;; Derived parsers: sequencing
;;; ;;;;;;;;;;;;;;;;;;

(define (values/p . parsers)
  (let loop ((parsers parsers)
             (acc '()))
    (if (null? parsers)
        (apply return/p (reverse acc))
        (lv/p ((returned (car parsers)))
          (loop (cdr parsers) (append-reverse returned acc))))))

(define (and/p . parsers)
  (let loop ((parsers parsers))
    (cond
      ((null? parsers) (return/p))
      ((null? (cdr parsers)) (car parsers))
      (else (lv/p ((ignored (car parsers)))
              (loop (cdr parsers)))))))

;;; ;;;;;;;;;;;;;;
;;; Dervied parsers: Repetition
;;; ;;;;;;;;;;;;;;

(define-syntax let-keywords
  (syntax-rules ()
    ((_ %kw ((key default) ...) body ...)
     (let ((kw %kw))
       (let ((key (cond
                    ((assv (quote key) kw) => cdr)
                    (else default)))
             ...)
         body ...)))))

(define many/p
  (case-lambda
    ((parser) (many/p parser '()))
    ((parser kws)
     (let-keywords kws ((min 0)
                        (max #f)
                        (too-little-error #f)
                        (expected-after-sep-error #f)
                        (sep/p #f))
       (unless (number? min)
         (error 'many/p "min must be a number" min))
       (unless (or (not max) (number? max))
         (error 'many/p "max must be a number or #f" max))
       (let loop ((acc '()) (i 0))
         (cond/p
          ((test/p (and max (<= max i)))
           (return/p (reverse acc)))
          ((and/p (test/p (or (zero? i) (not sep/p)))
                  parser)
           => values
           (loop (append-reverse values acc) (+ i 1)))
          ((and/p (test/p sep/p) sep/p)
           => values
           (if/p parser
                 (lambda rest
                   (loop (append-reverse rest
                                         (append-reverse values acc))
                         (+ i 1)))
                 (error/p expected-after-sep-error
                          i min max acc loop values)))
          ((test/p (< i min))
           (error/p too-little-error i min max acc loop))
          (else (return/p (reverse acc)))))))))

(define (skip/p parser)
  (letrec ((loop
            (cond/p (parser loop)
                    (else (return/p)))))
    loop))

;;; TODO: skip/p eqv to (many/p (discard/p blah/p))

(define many-until/p
  (case-lambda
    ((parser end/p) (many-until/p parser end/p '()))
    ((parser end/p kws)
     (let-keywords kws ((min 0)
                        (max #f)
                        (too-little-error #f)
                        (expected-sep-or-end-error #f)
                        (expected-end-error #f)
                        (expected-after-sep-error #f)
                        (sep/p #f))
       (unless (number? min)
         (error 'many-until/p "min must be a number" min))
       (unless (or (not max) (number? max))
         (error 'many-until/p "max must be a number or #f" max))
       (let loop ((acc '()) (i 0))
         (cond/p
          ((test/p (and max (<= max i)))
           (lv/p (((acc) (return/p (reverse acc))))
             (as-error/p expected-end-error
                         (and/p end/p (return/p acc))
                         i min max acc)))
          (end/p
           (if (< i min)
               (error/p too-little-error i min max acc loop)
               (return/p (reverse acc))))
          ((and/p (test/p (or (zero? i) (not sep/p)))
                  parser)
           => values (loop (append-reverse values acc)
                           (+ i 1)))
          ((and/p (test/p sep/p) sep/p)
           => values
           (if/p parser
                 (lambda rest
                   (loop (append-reverse rest
                                         (append-reverse values
                                                         acc))
                         (+ i 1)))
                 (error/p expected-after-sep-error
                          i min max acc loop values)))
          (else (error/p expected-sep-or-end-error
                         i
                         min
                         max
                         acc
                         loop))))))))

;;; ;;;;;;;;;;;;;;;
;;; Derived parsers: misc.
;;; ;;;;;;;;;;;;;;;

(define (discard/p parser)
  (lv/p ((unused parser))
    (return/p)))

;;; ;;;;;;;;;;;;;;;;;;;;;
;;; Setup dictionary for reading
;;; ;;;;;;;;;;;;;;;;;;;;;

(define (parser-init dto dict)
  (if (not (dict-contains? dto dict 'here))
      (dict-invoke dto dict 'next)
      dict))

(define (char-sequence->dict filename input)
  (let* ((dict (cond
                 ((string? input)
                  (string->dict (phosphate-dto)
                                (phosphate-empty-dict)
                                input))
                 ((pair? input)
                  (list->dict (phosphate-dto)
                              (phosphate-empty-dict)
                              input))
                 ((vector? input)
                  (list->dict! (phosphate-dto)
                               (phosphate-empty-dict)
                               (vector->list input)))
                 ((textual-port? input)
                  (char-port->dict (phosphate-dto)
                                   (phosphate-empty-dict)
                                   input))
                 (else (error 'char-sequence->dict
                              "invalid input"
                              input))))
         (dict (char-position-wrapper (phosphate-dto) dict filename)))
    (parser-init (phosphate-dto) dict)))

(define (char-position-wrapper dto dict filename)
  (let ((dict (dict-set! dto dict 'filename filename))
        (real-next (dict-ref dto dict 'next)))
    (dict-set! dto dict 'next
               (lambda (dto dict)
                 (let* ((dict (real-next dto dict)))
                   (if (dict-ref dto dict 'eof?)
                       dict
                       (let* ((here (dict-ref dto dict 'here))
                              (dict (if (char=? here #\newline)
                                        (dict-update/default! dto
                                                              dict
                                                              'line-number
                                                              (lambda (x)
                                                                (+ x 1))
                                                              1)
                                        (dict-update/default! dto
                                                              dict
                                                              'line-number
                                                              values
                                                              1)))
                              (dict (if (char=? here #\newline)
                                        (dict-set! dto dict 'offset 0)
                                        (dict-update/default! dto
                                                              dict
                                                              'offset
                                                              (lambda (x)
                                                                (+ x 1))
                                                              0))))
                         (char-position-wrapper dto dict filename))))))))

(define (inject/p el)
  (lambda (dto dict dyn)
    (dict-set! dto dict
               'eof? #f
               'here el
               'next (lambda ignored dict))))

(define (port-like->dict dto dict accessor port)
  (let* ((next-dict #f)
         (generate
          (lambda (dto dict object)
            (if (eof-object? object)
                (dict-set! dto dict 'eof? #t)
                (let* ((dict (dict-set! dto dict
                                        'eof? #f
                                        'here object)))
                  (port-like->dict dto dict accessor port)))))
         (dict
          (dict-set! dto dict
                     'next
                     (lambda (dto dict)
                       (when (not next-dict)
                         (set! next-dict (generate dto dict (accessor port))))
                       next-dict))))
    dict))

(define (char-port->dict dto dict port)
  (port-like->dict dto dict read-char port))

(define (u8-port->dict dto dict port)
  (port-like->dict dto dict read-u8 port))

(define (generator->dict dto dict generator)
  (port-like->dict dto dict (lambda (x) (generator)) #f))

(define (list->dict! dto dict list)
  (let ((generator
         (lambda ()
           (if (null? list)
               (eof-object)
               (let ((x (car list)))
                 (set! list (cdr list))
                 x)))))
    (generator->dict dto dict generator)))

(define (list->dict dto dict list)
  (list->dict! dto dict (list-copy list)))

(define (string->dict dto dict string)
  (list->dict! dto dict (string->list string)))