(define-module (vcomponent recurrence parse)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-19)           ; Datetime
  #:use-module (srfi srfi-19 util)
  #:use-module (srfi srfi-26)
  #:use-module ((vcomponent datetime) #:select (parse-datetime))
  #:duplicates (last)                   ; Replace @var{count}
  #:use-module (vcomponent recurrence internal)
  #:use-module (util)
  #:use-module (exceptions)
  #:use-module (ice-9 curried-definitions)
  #:export (parse-recurrence-rule))


(define (printerr fmt . args)
  (apply format (current-error-port)
          fmt args))

(define (parse-recurrence-rule str)
  (catch-multiple
    (lambda () (%build-recur-rules str))

    [unfulfilled-constraint
     (cont obj key val . rest)
     (printerr "ERR ~a [~a] doesn't fulfill constraint of type [~a], ignoring~%"
               err val key)
     (cont #f)]

    [invalid-value
     (cont obj key val . rest)
     (printerr "ERR ~a [~a] for key [~a], ignoring.~%"
               err val key)
     (cont #f)]))

(eval-when (expand)
 (define ((handle-case stx obj) key val proc)
   (with-syntax ((skey (datum->syntax
                        stx (symbol-downcase (syntax->datum key)))))
     #`((#,key)
        (let ((v #,val))
          (cond ((not v) (throw-returnable 'invalid-value #,obj (quote #,key) v))
                ((#,proc #,val) (set! (skey #,obj) v))
                (else (set! (skey #,obj)
                            (throw-returnable 'unfulfilled-constraint
                                              #,obj (quote #,key) v)))))))))


;; A special form of case only useful in parse-recurrence-rules above.
;; Each case is on the form (KEY val check-proc) where:
;; `key` is what should be matched against, and what is used for the setter
;; `val` is the value to bind to the loop object and
;; `check` is something the object must conform to
(define-syntax quick-case
  (lambda (stx)
   (syntax-case stx ()
     ((_ var-key obj (key val proc) ...)
      #`(case var-key
          #,@(map (handle-case stx #'obj)
                  #'(key ...)
                  #'(val ...)
                  #'(proc ...))
        (else obj))))))

(define-syntax all-in
  (syntax-rules ()
    ((_ var rules ...)
     (cut every (lambda (var) (and rules ...)) <>))))

(define (string->number-list val delim)
  (map string->number (string-split val delim)))

(define (string->symbols val delim)
  (map string->symbol (string-split val delim)))

;; @example
;; <weekday> ∈ weekdays
;; <weekdaynum> ::= [[±] <num>] <weekday> ;; +3MO
;; (<weekadynum>, ...)
;; @end example

;; Returns a pair, where the @code{car} is the offset
;; and @code{cdr} is the day symbol.
;; The @code{car} may be @code{#f}.
(define (parse-day-spec str)
  (let* ((numchars (append '(#\+ #\-) (map integer->char (iota 10 #x30))))
         (num symb (span (cut memv <> numchars)
                         (string->list str))))
    (cons (string->number (list->string num))
          (apply symbol symb))))

(define (%build-recur-rules str)
  (fold
   (lambda (kv obj)
     (let* (((key val) kv))
       (let-lazy
        ((symb (string->symbol val))
         (date (date->time-utc (parse-datetime val)))
         (days (map parse-day-spec (string-split val #\,)))
         (num  (string->number val))
         (nums (string->number-list val #\,)))

        (quick-case (string->symbol key) obj
                    (FREQ     symb (cut memv <> intervals)) ; Required
                    (UNTIL    date identity)
                    (COUNT    num  (cut <= 0 <>))
                    (INTERVAL num  (cut <= 0 <>))
                    (BYSECOND nums (all-in n (<= 0 n 60)))
                    (BYMINUTE nums (all-in n (<= 0 n 59)))
                    (BYHOUR   nums (all-in n (<= 0 n 23)))

                    (BYDAY days
                           (lambda (p*)
                             (map (lambda (p)
                                    (let* (((n . s) p))
                                      (memv s weekdays)))
                                  p*)))

                    (BYMONTHDAY nums (all-in n (<=  -31 n  31) (!= n 0)))
                    (BYYEARDAY  nums (all-in n (<= -366 n 366) (!= n 0)))
                    (BYWEEKNO   nums (all-in n (<=  -53 n  53) (!= n 0)))
                    (BYMONTH    nums (all-in n (<=    1 n  12)))
                    (BYSETPOS   nums (all-in n (<= -366 n 366) (!= n 0)))

                    (WKST symb (cut memv <> weekdays))))))
   ;; obj
   (make-recur-rule 1 'MO)

   ;; ((key val) ...)
   (map (cut string-split <> #\=)
        (string-split str #\;))))