;; -*- Mode: Irken -*-

;; parser combinators.
;; references:
;; https://www.youtube.com/watch?v=RDalzi7mhdY "Understanding Parser Combinators"
;; https://fsharpforfunandprofit.com/posts/understanding-parser-combinators/
;; https://github.com/inhabitedtype/angstrom/
;;
;; Note: monad/currying weirdness makes some of the 'pure' monadic stuff
;;   not work.  I cribbed `lift2` from angstrom for this reason.

(require "lib/basis.scm")

(typealias chars (list char))

(datatype result
  (:ok 'a 'b)  ;; result, rest-of-input
  (:no string) ;; error string
  )

(datatype parser
  (:t (chars -> (result 'a chars)))
  )

(define (pchar ch)
  (define inner
    ()
    -> (result:no (format "no more input"))
    (first . rest)
    -> (if (eq? first ch)
           (result:ok ch rest)
           ;; note: needless consing here when backtracking.
           (result:no (format "expecting " (char ch) " got " (char first) ".")))
    )
  (parser:t inner))

(define (run parser input)
  (match parser with
    (parser:t fun)
    -> (fun input)))

;; note - F# infix semantics:
;; x A y A z => (A x (A y z))

(define (andThen parser1 parser2)
  (parser:t
   (lambda (input)
     (match (run parser1 input) with
       (result:ok v1 rest)
       -> (match (run parser2 rest) with
            (result:ok v2 rest)
            -> (result:ok (:tuple v1 v2) rest)
            (result:no err)
            -> (result:no err)
            )
       (result:no err)
       -> (result:no err)
       ))))

(define (orElse parser1 parser2)
  (define (inner input)
    (match (run parser1 input) with
      (result:no _)
      -> (run parser2 input)
      success
      -> success
      ))
  (parser:t inner)
  )

(define choice
  (a b)     -> (orElse a b)
  (hd . tl) -> (orElse hd (choice tl))
  _         -> (raise (:BadChoice))
  )

(define (anyOf char-list)
  (choice (map pchar char-list)))

(define (mapP f parser)
  (parser:t
   (lambda (input)
     (match (run parser input) with
       (result:ok v rest)
       -> (result:ok (f v) rest)
       (result:no err)
       -> (result:no err)
       ))))

(define (lift2 f)
  (lambda (p1 p2)
    (parser:t
     (lambda (input)
       (match (run p1 input) with
         (result:ok v1 rest1)
         -> (match (run p2 rest1) with
              (result:ok v2 rest2)
              -> (result:ok (f v1 v2) rest2)
              (result:no err)
              -> (result:no err)
              )
         (result:no err)
         -> (result:no err)
         )))))

(define consP (lift2 list:cons))

(define (returnP x)
  (parser:t
   (lambda (input)
     (result:ok x input))))

(define (sequence parserList)
  (match parserList with
    ()        -> (returnP (list:nil))
    (hd . tl) -> (consP hd (sequence tl))
    ))

(define (zero-or-more parser input)
  (let loop ((acc (list:nil))
             (r (run parser input))
             (input input))
    (match r with
      (result:no _)
      -> (:tuple acc input)
      (result:ok val rest)
      -> (loop (list:cons val acc)
               (run parser rest)
               rest))))

(define (star parser)
  (define (inner input)
    ;; star always wins
    (match (zero-or-more parser input) with
      (:tuple v rest)
      -> (result:ok v rest)))
  (parser:t inner))

(define (plus parser)
  (define (inner input)
    (match (run parser input) with
      (result:no err)
      -> (result:no err)
      (result:ok v1 rest)
      -> (match (zero-or-more parser rest) with
           (:tuple others rest)
           -> (result:ok (list:cons v1 others) rest))))
  (parser:t inner))

(define (opt parser)
  (orElse
   (mapP maybe:yes parser)
   (returnP (maybe:no))))

(define (t0)

  (define parseDigit (anyOf (string->list "0123456789")))
  (define parseThreeDigits (andThen parseDigit (andThen parseDigit parseDigit)))

  (printn (run parseThreeDigits (string->list "123")))
  (printn (run (orElse (pchar #\A) (pchar #\B)) (string->list "Z")))
  (printn (run (andThen (pchar #\A) (pchar #\B)) (string->list "AB")))

  (define parseThreeDigitsAsStr
    (mapP
     (lambda (x)
       (match x with
         ;; note how andThen builds tuples upon tuples
         (:tuple a (:tuple b c))
         -> (list->string (list a b c))
         ))
     (andThen parseDigit (andThen parseDigit parseDigit))
     ))

  (printn (run parseThreeDigitsAsStr (string->list "123")))

  (define parseThreeDigitsAsInt
    (mapP string->int parseThreeDigitsAsStr)
    )

  (printn (run parseThreeDigitsAsInt (string->list "123")))

  )

(t0)

(define print-result
  (result:ok v rest)
  -> (begin
       (printf "ok: ")
       (printn v)
       (printf "    " (list->string rest) "\n"))
  (result:no err)
  -> (printf "no: " err "\n"))

(define (t1)

  (let ((parsers (map pchar (string->list "ABC")))
        (combined (sequence parsers)))
    (printn combined)
    (print-result (run combined (string->list "ABCD")))
    )
  )

(t1)

(define (t2)
  (let ((Astar (star (pchar #\A))))
    (print-result (run Astar (string->list "AAAABBB")))
    (print-result (run Astar (string->list "not")))
    ))

(t2)

(define (t3)
  (let ((Aplus (plus (pchar #\A))))
    (print-result (run Aplus (string->list "AAAABBB")))
    (print-result (run Aplus (string->list "not")))
    ))

(t3)

(define (t4)
  (let ((A? (opt (pchar #\A))))
    (print-result (run A? (string->list "A")))
    (print-result (run A? (string->list "B")))
    ))

(t4)

(define (t5)
  (list (:one 1) (:two 2 3) (:three 'a 'b 'c))
  )

(t5)