(in-package :edn)

(defun .0-or-more (parser)
  (lambda (input)
    (loop
       for remaining-input = input then (cdr result)
       for result = (first (funcall parser remaining-input))
       while (and (car result) (> (length remaining-input) 0))
       collect (car result) into matches
       finally (return (list (cons matches remaining-input))))))

(defun .satisfies (predicate &rest args)
  (.bind (.item)
         (lambda (x)
           (if (apply predicate x args)
               (.identity x)
               (.fail)))))

(defun .one-of (items &optional (test 'eql))
  (.satisfies
   (serapeum:op
     (member _ items :test test))))

(defun .zero-or-more (parser)
  (.plus (.let* ((x parser)
                 (xs (.zero-or-more parser)))
           (.identity (cons x xs)))
         (.identity ())))

(defun .elements ()
  (.0-or-more (.progn (.s)
                      (.element))))

(defun .s ()
  (.first
   (.0-or-more
    (.or (.whitespace)
         (.comment)
         (.discarded-element)))))

(defun .whitespace ()
  (.one-of '(#\space
             #\tab
             #\return
             #\newline
             #\,)))

(defmacro read-if (s test)
  `(when (funcall (lambda (_)
                    ,test)
                  (peek-char nil ,s))
     (read-char s)))

(defun parse-whitespace (s)
  (read-if s (member _ '(#\space #\, #\tab #\return #\newline))))

(defun .comment ()
  (.let* ((result (.prog2 (.char= #\;)
                          (.first
                           (.0-or-more
                            (.and (.not (.or (.char= #\newline)
                                             (.char= #\nul)))
                                  (.item))))
                          (.or (.char= #\newline)
                               (.not (.item))))))
    (.identity (list :comment (coerce result 'string)))))

(defun .discarded-element ()
  (.progn (.string= "#_")
          (.element)))

(defun .alt (&rest r)
  (reduce '.plus r))

(defun .map-element ()
  (.prog2 (.char= #\{)
          (.progn (.s)
                  (.first
                   (.0-or-more (.let* ((first (.prog1 (.element) (.s)))
                                          (second (.prog1 (.element) (.s))))
                                    (.identity (list :pair first second))))))
          (.char= #\})))

(defun .between (start-parser end-parser element-parser)
  (.prog2 start-parser
          (.first element-parser)
          (.s)
          end-parser))

(defun .tag (tag parser)
  (.let* ((item parser))
    (.identity (cons tag item))))

(defun .collection (tag start-parser end-parser)
  (.tag tag
        (.between start-parser end-parser
                  (.elements))))

(defun .primitive ()
  (.or (.nil)
       (.boolean)))

(defun .collections ()
  (.alt (.tag :map (.map-element))
        (.collection :set (.string= "#{") (.char= #\}))
        (.collection :vector (.char= #\[) (.char= #\]))
        (.collection :list (.char= #\() (.char= #\)))))

(defun .atoms ()
  (.alt (.number)
        (.symbol)
        (.keyword)
        (.character)
        (.string)))

(defun .element ()
  (.or (.primitive)
       (.alt (.atoms)
             (.collections)
             
             (.tag :tagged
                   (.let* ((tag (.progn (.char= #\#) (.tag-symbol)))
                           (element (.progn (.s) (.element))))
                     (.identity (list tag element)))))))

(defun .nil ()
  (.and (.string= "nil")
        (.identity edn-primitives:nil)))

(defun .boolean ()
  (.let* ((r (.or (.string= "true")
                  (.string= "false"))))
    (string-case:string-case (r)
      ("true" (.identity edn-primitives:true))
      ("false" (.identity edn-primitives:false)))))

(defun .symbol ()
  (.plus (.char= #\/)
         (.let* ((ns (.optional (.prog1 (.name) (.char= #\/))))
                 (name (.name)))
           (.identity (list :symbol ns name)))))

(defun .tag-symbol ()
  (.let* ((first (.satisfies #'alpha-char-p))
          (rest (.let* ((ns (.or (.char= #\/)
                                 (.optional (.prog1 (.name) (.char= #\/)))))
                        (name (.name)))
                  (.identity (list ns name)))))
    (destructuring-bind (ns name) rest
      (if ns
          (if (eql ns #\/)
              (.identity (list :symbol (format nil "~c" first) name))
              (.identity (list :symbol (format nil "~c~a" first ns) name)))
          (.identity (list :symbol nil (format nil "~c~a" first name)))))))

(defun .keyword ()
  (.progn (.char= #\:)
          (.let* ((ns (.optional (.prog1 (.name) (.char= #\/))))
                  (name (.name)))
            (.identity (list :keyword ns name)))))

(defun .juxt (a b)
  (.let* ((first a)
          (second b))
    (.identity (list first second))))

(defun .name ()
  (.let* ((prefix (.or (.let* ((first (.name-start-1)))
                         (.identity (string first)))
                       (.let* ((first (.juxt (.name-start-2)
                                             (.satisfies (complement #'digit-char-p)))))
                         (.identity (coerce first 'string)))))
          (suffix (.0-or-more (.name-constituent))))
    (.identity (concatenate 'string prefix suffix))))

(defun name-start-1-p (c)
  (member c
          '(#\! #\* #\? #\_
            #\$ #\% #\& #\=)))

(defun name-start-2-p (c)
  (member c '(#\. #\- #\+)))

(defun .name-start-1 ()
  (.or (.satisfies 'alpha-char-p)
       (.one-of '(#\! #\* #\? #\_ #\$ #\% #\& #\=))))

(defun .name-start-2 ()
  (.one-of '(#\. #\- #\+)))

(defun name-constituent-p (c)
  (or (alpha-char-p c)
      (digit-char-p c)
      (name-start-1-p c)
      (name-start-2-p c)
      (member c '(#\# #\:))))

(defun .name-constituent ()
  (.satisfies 'name-constituent-p))

(defun apply-sign (sign num)
  (if sign
      (ecase sign
        (#\+ num)
        (#\- (* -1 num)))
      num))

(defun .frac-exp ()
  (.alt (.let* ((frac (.frac))
                (exp (.optional (.exp)))
                (flag (.optional (.char= #\M))))
          flag
          (.identity (list frac exp)))
        (.let* ((exp (.exp))
                (flag (.optional (.char= #\M))))
          flag
          (.identity (list 0 exp)))
        (.let* ((flag (.optional (.char= #\M))))
          flag
          (.identity (list 0 0)))))

(defun .frac ()
  (.let* ((nums (.first
                 (.progn (.char= #\.)
                         (.0-or-more (.digit))))))
    (.identity
     (if nums
         (let ((num (parse-integer (coerce nums 'string))))
           (coerce (if (= num 0)
                       0
                       (/ num
                          (expt 10
                                (floor
                                 (1+ (log num
                                          10))))))
                   'double-float))
         0))))

(defun interpret-number (parts)
  (destructuring-bind (sign radix float-info flag) parts
    (let* ((base-value (if float-info
                           (destructuring-bind (mantissa exp) float-info
                             (coerce (* (+ radix
                                           (or mantissa 0))
                                        (if exp
                                            (expt 10 exp)
                                            1))
                                     'double-float))
                           radix))
           (signed (case sign
                     ((#\+ nil) base-value)
                     (#\- (- base-value)))))
      (typecase signed
        (integer (if (member flag '(nil #\N))
                     (.identity signed)
                     (.identity (coerce signed 'double-float))))
        (float (if (member flag '(nil #\M))
                   (.identity signed)
                   (.fail)))))))

(defun .number ()
  (flet ((.sign () (.one-of '(#\+ #\-))))
    (.let* ((sign (.optional (.sign)))
            (num (.cardinal))
            (frac (.optional (.frac)))
            (exp (.optional (.exp)))
            (flag (.optional (.one-of '(#\N #\M)))))
      (interpret-number
       (list sign
             num
             (when (or frac exp)
               (list frac exp))
             flag)))))

(defun .exp ()
  (.progn (.char-equal #\e)
          (.let* ((sign (.optional
                         (.or (.char= #\+)
                              (.char= #\-))))
                  (num (.cardinal)))
            (.identity (apply-sign sign num)))))

(defun .cardinal ()
  (.let* ((nums (.or (.first
                      (.let* ((first (.non-zero-digit))
                              (rest (.0-or-more
                                     (.digit))))
                        (.identity (list* first rest))))
                     (.let* ((c (.digit)))
                       (.identity (list c))))))
    (.identity (parse-integer (coerce nums 'string)))))

(defun .digit ()
  (.satisfies #'digit-char-p))

(defun .non-zero-digit ()
  (.satisfies (lambda (x)
                (and (digit-char-p x)
                     (not (eql #\0 x))))))

(defun .printable-character ()
  (.or (.satisfies (lambda (x) (char>= #\~ x #\!)))
       (.satisfies (lambda (x) (char<= #\space x)))))

(defun .character-name ()
  (.or (.string= "newline")
       (.string= "space")
       (.string= "tab")
       (.string= "return")
       (.string= "backspace")
       (.string= "formfeed")))

(defun .character ()
  (.let* ((char (.progn (.char= #\\)
                        (.or (.character-name)
                             (.printable-character)))))
    (.identity (list :character char))))

(defun .string-char ()
  (.and (.not (.char= #\nul))
        (.not (.char= #\"))
        (.not (.char= #\\))
        (.item)))

(defun translate-escape (c)
  (ecase c
    ((#\" #\\) c)
    (#\t #\tab)
    (#\n #\newline)
    (#\r #\return)
    (#\b #\backspace)
    (#\f #.(code-char 12))))

(defun parse-string-ending-old (s)
  (let ((pos 0)
        (done nil))
    (flet ((consume-char ()
             (prog1 (elt s pos)
               (setf done (= pos (length s)))
               (incf pos))))
      (let ((result (loop
                       for char = (serapeum:case-let (next (consume-char))
                                    (#\\ (translate-escape (consume-char)))
                                    (#\" nil)
                                    (t next))
                       while char 
                       when (= pos (length s)) do (return nil)
                       collect char)))
        (if result
            (values (coerce result 'string) pos)
            (values nil 0))))))

(defun translate-escapes (s)
  (let ((parts (coerce (fwoar.string-utils:split #\\ s) 'list)))
    (serapeum:string-join (list* (car parts)
                                 (mapcan (lambda (part)
                                           (list (translate-escape (elt part 0))
                                                 (subseq part 1)))
                                         (cdr parts))))))

(defun parse-string-ending (s)
  (declare (optimize (speed 3))
           (type simple-string s))
  (loop
     for possible-quote = (position #\" s) then (position #\" s
                                                          :start (1+ possible-quote))

     while possible-quote
     when (not (char= #\\ (aref s (1- possible-quote)))) do
       (return (values (translate-escapes (subseq s 0 possible-quote))
                       (1+ possible-quote)))))

(defun combine (list)
  (format nil "~{~a~}" list))

(define-condition invalid-string-ending (error)
  ())

(defun .string ()
  (.let* ((string (.prog2 (.char= #\")
                          (.first
                           (.0-or-more (.or (.string-char)
                                            (.let* ((escape-char (.progn (.char= #\\)
                                                                         (.string-escape))))
                                              (.identity (translate-escape escape-char))))))
                          (.char= #\"))))
    (.identity (list :string (combine string)))))

(defun .string-ending ()
  (lambda (input)
    (multiple-value-bind (ending count) (parse-string-ending input)
      (if (> count 0)
          (list (cons ending
                      (subseq input count)))
          nil))))

(defun .string.old ()
  (.let* ((string (.progn (.char= #\")
                          (.string-ending))))
    (.identity (list :string string))))

(defun read-edn (s)
  (car
   (smug:parse (.prog1 (.elements)
                       (.s)
                       (.not (.item)))
               s)))