(implicit parsepos*)
(implicit parsefail)

; failfn must be called *outside* the w/parsefail scope,
; thus the code to pass the normal/fail result of calling f
; out through the w/parsefail

(def fonparse (parser onsuccess onfail)
  (with (return-value nil failed nil)
    (catch
      (w/parsefail (fn ()
                     (set failed)
                     (throw nil))
        (= return-value (parser))))
    (if failed
        (onfail)
        (onsuccess return-value))))

(mac onparse (var parser onsuccess onfail)
  `(fonparse (fn () ,parser)
             (fn (,var) ,onsuccess)
             (fn () ,onfail)))

(mac on-parsefail (onfail . body)
  (w/uniq gv
    `(onparse ,gv (do ,@body)
       ,gv
       ,onfail)))

(def at-impl (parser)
  (let mark parsepos*
    (after (parser)
           (= parsepos* mark))))

(mac at body
  `(at-impl (fn () ,@body)))

(def ftry (parser onsuccess onfail)
  (let mark parsepos*
    (onparse r (parser)
      (onsuccess r)
      (do (= parsepos* mark)
          (onfail)))))

(mac try (v parser onsuccess onfail)
  `(ftry (fn () ,parser)
     (fn (,v) ,onsuccess)
     (fn () ,onfail)))

(def ascons (x)
  (if (or (no x) (acons x))
       x
      (isa x 'input)
       (drain (readc x))
      (isa x 'string)
       (coerce x 'cons)
       (err "don't know how to parse" x)))

(def fparse (seq body)
  (on-parsefail nil
    (w/parsepos* (ascons seq)
      (body))))

(mac parse (s . body)
  `(fparse ,s (fn () ,@body)))

(def rest ()
  parsepos*)

; TODO parsefail this?
(def at-end ()
  (no parsepos*))

; TODO rename to not-at-end?
(def fail-at-end ()
  (if (at-end) (parsefail)))

(def next ()
  (fail-at-end)
  (do1 car.parsepos*
       (= parsepos* cdr.parsepos*)))

(def match items
  (ret v (next)
    (unless (some [(testify _) v] items) (parsefail))))

(def falt2 (f1 f2)
  (let mark parsepos*
    (on-parsefail
     (do (= parsepos* mark)
         (f2))
     (f1))))

(mac alt2 (p1 p2)
  `(falt2 (fn () ,p1) (fn () ,p2)))

(mac alt ps
  (if (no ps)
       `(parsefail)
      (no (cdr ps))
       (car ps)
       `(alt2 ,(car ps) (alt ,@(cdr ps)))))

(mac optional body
  `(alt (do ,@body) nil))

(def mliteral1 (pat:ascons val)
  (if (begins parsepos* pat)
       (do (= parsepos* (nthcdr len.pat parsepos*))
           val)
       (parsefail)))

(def mliteral args
  (if (no args)
       (parsefail)
      (no (cdr args))
       (mliteral1 (car args) (car args))
       (alt (mliteral1 (car args) (cadr args))
            (apply mliteral (cddr args)))))

(mac mliteral-in pats
  `(alt ,@(map (fn (pat)
                 `(mliteral ,pat))
               pats)))

(def fmany (fp)
  (accum a
    (xloop ()
      (try v (fp)
        (do (a v)
            (next))
        nil))))

(mac many body
  `(fmany (fn () ,@body)))

(mac many1 parser
  `(cons (do ,@parser) (many (do ,@parser))))

(mac must (errmsg . body)
  `(on-parsefail (err ,errmsg)
     ,@body))

(def munch (f)
  (f (next)))

(mac parse-intersperse (separator parser must-message)
  `(optional
    (cons ,parser
          (many ,separator
                (must ,must-message ,parser)))))

(def skipwhite ()
  (many (match whitec)))

(mac comma-separated (parser (o must-message "a comma must be followed by a value"))
  `(parse-intersperse
    (do (skipwhite) (match #\,))
    ,parser
    ,must-message))

(mac entire body
  `(do1 (do ,@body)
        (unless (at-end) (parsefail))))

(def fmatched-input (parser)
  (let mark parsepos*
    (parser)
    (accum a
      (xloop (p mark)
        (when (and p (isnt p parsepos*))
          (a (car p))
          (next (cdr p)))))))

(mac matched-input body
  `(fmatched-input (fn () ,@body)))

(mac alt-extend (name arglist . body)
  (w/uniq (orig args)
    `(let ,orig ,name
       (= ,name
          (fn ,args
            (alt (let ,arglist ,args ,@body)
                 (apply ,orig ,args)))))))

(mac not body
  (w/uniq v
    `(try ,v (do ,@body)
       (parsefail)
       t)))

(def fupto (n parser)
  (if (< n 1)
       '()
      (try v (parser)
        (cons v (fupto (- n 1) parser))
        nil)))

(mac upto (n . body)
  `(fupto ,n (fn () ,@body)))

(def ffrom1upto (n parser)
  (or (upto n (parser))
      (parsefail)))

(mac from1upto (n . body)
  `(ffrom1upto ,n (fn () ,@body)))

; ideas
;  a "not" to invert the success/fail result of a parser