(in-package #:tempores.parser)

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

(defun .first-hour-char ()
  (.is (lambda (x)
         (member x '(#\0 #\1 #\2)))))

(defun .first-minute-char ()
  (.is (lambda (x)
         (member x '(#\0 #\1 #\2 #\3 #\4 #\5)))))

(defun .time-separator ()
  (.char= #\:))

; TODO: consider adding one-digit hours
(defun .hour ()
  (.let* ((f (.first-hour-char))
          (s (.digit)))
    (if (or (char/= f #\2) (member s '(#\0 #\1 #\2 #\3))) ;; make sure we don't get 24
      (.identity (coerce (vector f s) 'string))
      (.fail))))

(defun .minute-or-second ()
  (.let* ((f (.first-minute-char))
          (s (.digit)))
    (.identity (coerce (vector f s) 'string))))

(defun .time-range-separator ()
  (.string= "--"))

(define-condition invalid-time (parsing-error) ()
  (:report (lambda (condition stream)
             (format stream "Not a valid time part ~s"
                     (failed-chunk condition)))))

(defun .valid-time ()
  (.let* ((hour (.hour))
          (_ (.time-separator))
          (minute (.minute-or-second))
          (second (.optional
                    (.progn (.time-separator)
                            (.minute-or-second)))))
    (.identity (list hour minute (if second second "0")))))

(defun .invalid-time ()
  (flet ((.non-time-character ()
           (.map 'string
                 (.and (.not (.or (.time-separator)
                                  (.char= #\newline)
                                  (.char= #\space)))
                       (.item)))))
    (.let* ((hour (.or (.hour)
                       (.non-time-character)))
            (_ (.time-separator))
            (minute (.or (.minute-or-second)
                         (.non-time-character)))
            (second (.optional
                      (.progn (.time-separator)
                              (.or (.minute-or-second)
                                   (.non-time-character))))))
      (error 'invalid-time
        :failed-chunk (concatenate 'string
                                   (string hour) ":"
                                   (string minute)
                                   (if second
                                     (concatenate 'string ":" (string second))
                                     ""))))))

(defun .time ()
  (.let* ((time (.or (.valid-time) (.invalid-time))))
    (.identity
      (apply #'make-time-obj
             (mapcar #'parse-integer
                     time)))))

(defun .time-unit ()
  (.or
    (.string= "mins")
    (.string= "hrs")
    (.string= "min")
    (.string= "hr")))

(defun .time-mod ()
  (.let* ((sign (.or (.char= #\+) (.char= #\-)))
          (num (.first (.map 'string (.digit))))
          (unit (.time-unit)))
    (.identity
      (make-time-mod
        (parse-integer
          (with-output-to-string (s)
            (princ sign s)
            (princ num s)))
        unit))))

(defun .peek (parser)
  (lambda (input)
    (if (run parser input)
      (list (cons t input))
      (run (.fail) input))))

(defun .time-range ()
  (.let* ((start (.time))
          (_ (.prog1
               (.time-range-separator)
               (.peek (.not (.char= #\,)))))
          (done (.optional (.time)))
          (mod (.optional (.time-mod))))
    (when (and mod (not done))
      (.fail))
    (if done
      (if mod
        (.identity
          (list start done mod))
        (.identity (list start done)))
      (.identity (list start)))))

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

(defun .range-list-separator ()
  (.char= #\,))

(defun .range-list ()
  (.let*
    ((ranges (.prog1
               (.map 'list
                     (.prog1 (.time-range)
                             (.optional (.progn (.range-list-separator)
                                                (.zero-or-more (.char= #\Space))))))
               (.char= #\Newline))))
    (let ((lengths (map 'vector #'length ranges)))
      (if (/= 0 (elt lengths (1- (length lengths))))
        (.identity ranges)
        (.fail)))))

(defun .whitespace-char ()
  (.or (.char= #\tab) (.char= #\space)))

(defun .whitespace ()
  (.map 'string (.whitespace-char)))

(defun .valid-initial-space ()
  (.or (.string= (string #\tab))
       (.string= "   ")))

(defun .extra-whitespace ()
  (.let* ((_ (.valid-initial-space))
          (extra-space (.optional (.whitespace))))
    (if extra-space
      (error 'invalid-whitespace :failed-chunk extra-space)
      (.fail))))

(defun .initial-space ()
  (.or (.extra-whitespace)
       (.valid-initial-space)))

(defun .time-line-start ()
  (.progn (.initial-space)
          (.string= "start@")))

(defun .time-line ()
  (.progn
    (.time-line-start)
    (.range-list)))

(defun .client-separator ()
  (.char= #\:))

(defun .client-name ()
  (.prog1
    (.map 'string (.and (.not (.client-separator)) (.item)) :at-least 0)
    (.client-separator)))

(defun .memo ()
  (.prog2
    (.map 'string (.char= #\Space))
    (.first
      (.map 'string
          (.and (.not (.char= #\Newline))
                (.item))))
    (.optional (.not (.item)))))

(defun .memo-line ()
  (.progn
    (.initial-space)
    (.let* ((client (.client-name))
            (memo (.memo)))
      (.identity (list client memo)))))

(defun .record ()
  (.let* ((time-line (.time-line))
          (memo-line (.memo-line)))
    (.identity (make-time-record time-line memo-line))))

(defun .records ()
  (.first
    (.map 'list (.prog1 (.record)
                        (.or (.map 'string (.char= #\Newline))
                             (.progn
                               (.char= #\Newline)
                               (.not (.item)))
                             (.not (.item)))))))

(defun .weekday ()
  (.or (.string-equal "Sunday")
       (.string-equal "Monday")
       (.string-equal "Tuesday")
       (.string-equal "Wednesday")
       (.string-equal "Thursday")
       (.string-equal "Friday")
       (.string-equal "Saturday")))

(defun .year ()
  (.let* ((fi (.digit))
          (se (.digit))
          (th (.digit))
          (fo (.digit)))
    (.identity (coerce (list fi se th fo) 'string))))

(defun .first-month-char ()
  (.or (.char= #\0) (.char= #\1) (.char= #\2) (.char= #\3)))

(defun .first-day-char ()
  (.or (.char= #\0) (.char= #\1) (.char= #\2) (.char= #\3)))

(defun .month ()
  (.let* ((fi (.first-month-char))
          (se (.digit)))
    (let ((res (when (char= fi #\3)
                 (unless (member se '(#\1 #\0))
                   (.fail)))))
      (if (not res)
        (.identity (coerce (list fi se) 'string))
        res))))

(defun .day ()
  (.let* ((fi (.first-month-char))
          (se (.digit)))
    (when (and (char= fi #\3) (not (member se '(#\0 #\1))))
      (.fail))
    (.identity (coerce (list fi se) 'string))) )

(defun .date-separator ()
  (.or (.char= #\-)
       (.char= #\/)))

(defun .date ()
  (.let* ((dow (.weekday))
          (_ (.optional (.char= #\,)))
          (_ (.char= #\Space))
          (year (.year))
          (sep1 (.date-separator))
          (month (.month))
          (sep2 (.date-separator))
          (day (.day)))
    (let ((year (parse-integer year))
          (month (parse-integer month))
          (day (parse-integer day)))
      (.identity (make-date-obj dow year month day)))))

(defun .date-start ()
  (.string= "-- "))

(defun .date-line ()
  (.prog2 (.date-start)
          (.date)
          (.char= #\Newline)))

(defun .date-record ()
  (.let* ((date (.date-line))
          (records (.records)))
         (.identity (make-day-entry date records))))

(defun .date-records ()
  (.first (.map 'list (.date-record))))

(defun .parse-all-records ()
  (.prog1 (.date-records) (.not (.item))))

;; This will help make sure everything is consumed when
;; we don't care about the parser's output.
(defun cdar-equal (a b) (== (cdar a) (cdar b)))