;;
;; 
;;  A parser for the grammar defined in RFC 3339, "Date and Time on
;;  the Internet: Timestamps".
;;
;;  Copyright 2009-2011 Ivan Raikov and the Okinawa Institute of
;;  Science and Technology.
;;
;;
;;  This program is free software: you can redistribute it and/or
;;  modify it under the terms of the GNU General Public License as
;;  published by the Free Software Foundation, either version 3 of the
;;  License, or (at your option) any later version.
;;
;;  This program is distributed in the hope that it will be useful,
;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;  General Public License for more details.
;;
;;  A full copy of the GPL license can be found at
;;  <http://www.gnu.org/licenses/>.

(module internet-timestamp

	(parser ts? ts-date ts-time ts-offset ts->list
	 CoreABNF->InetTimestamp <InetTimestamp> )

	(import scheme chicken data-structures extras srfi-1 )
	(import (only srfi-13 string-trim string-concatenate))

	(require-extension typeclass)

	(require-library abnf abnf-consumers)
	(import (prefix abnf abnf:) 
		(prefix abnf-consumers abnf:) 
		(only abnf <CoreABNF> <Input> <Token> <CharLex> )
		)

(define-class <InetTimestamp> (<CoreABNF> A)  
  date-time)

;; construct numbers from consumed chars
(define consumed-chars->number
  (abnf:consumed-chars->list 
   (compose string->number list->string)))

;; shortcut for (bind consumed-chars->number (longest ... ))
(define-syntax bind-consumed->number
  (syntax-rules () 
    ((_ p)    (abnf:bind consumed-chars->number p))
    ))

(define consumed-numbers 
  (abnf:consumed-objects number?))
(define consumed-numbers->list
  (abnf:consumed-objects-lift
   consumed-numbers))

(define consumed-objects-lift-any
  (abnf:consumed-objects-lift
   (abnf:consumed-objects identity)))


;; timestamp datatype 
(define-record-type ts (make-ts date time offset)
  ts?  (date ts-date )
  (time ts-time )
  (offset ts-offset )
  )

;; convert a number to a string with leading zeros
(define (number->lzstring n)
  (lambda (x)
    (or (and (number? x) 
	     (let loop ((d (string->list (number->string x))))
	       (if (>= (length d) n) (list->string d)
		   (loop (cons #\0 d)))))
	x)))
	   
	   

(define-record-printer (ts x out)
  (let ((number->lzstring2 (number->lzstring 2))
	(number->lzstring4 (number->lzstring 4)))
    (fprintf out "~AT~A~A"
	     (let ((date-list (vector->list (ts-date x))))
	       (apply sprintf (cons* "~A-~A-~A" 
				     (number->lzstring4 (car date-list))
				     (map number->lzstring2 (cdr date-list)))))
	     (string-concatenate
	      (cons
	       (apply sprintf
		      (cons "~A:~A:~A" 
			    (map number->lzstring2 (vector->list (ts-time x)))))
	       (cond ((vector-ref (ts-time x) 3) =>
		      (lambda (frac) 
			(list (string-trim (number->string frac) #\0))))
		     (else (list)))))
	     (case (vector-ref (ts-offset x) 0)
	       ((Z)  "Z")
	       (else (apply sprintf 
			    (cons "~A~A:~A" 
				  (map number->lzstring2 (vector->list (ts-offset x)))))))
	     )))
	       
(define (ts->list x)
  (and (ts? x)
       (let ((date (ts-date x))
	     (time (ts-time x))
	     (offset (ts-offset x)))
       `((date ,(vector->list date)) 
	 (time ,(filter identity (vector->list time)))
	 (offset ,(filter identity (vector->list offset)))))))
  

(define (make-date year month day)
  (make-ts (vector year month day) #f #f))

(define (make-partial-time hr min sec . rest)
  (let-optionals rest ((frac #f))
    (make-ts #f (vector hr min sec frac) 
	     #f)))

(define (make-offset sign . rest)
  (let-optionals rest ((hr #f) (min #f))
    (make-ts #f #f (vector sign hr min))))
  
(define (make-full-time time offset)
  (let ((time (ts-time time))
	(offset (ts-offset offset)))
    (make-ts #f time offset)))
  
(define (make-date-time date time )
  (let ((time (ts-time time))
	(offset (ts-offset time))
	(date  (ts-date date)))
    (make-ts date time offset)))

(define=> (number-n <CoreABNF>)
  (lambda (n)
    (bind-consumed->number
     (abnf:repetition-n n decimal))))

(define=> (time-secfrac <CoreABNF>)
  (bind-consumed->number
   (abnf:concatenation
    (char #\.)  
    (abnf:repetition1 decimal))))

(define=> (time-numoffset <CoreABNF>)
  (lambda (time-hour time-minute)
    (abnf:bind
     (consumed-objects-lift-any 
      (lambda (x) (make-offset (first x) (second x) (third x))))
     (abnf:concatenation
      (abnf:bind-consumed->symbol
       (set-from-string "+-"))
      time-hour (abnf:drop-consumed (char #\:))
      time-minute))))


(define=> (time-offset <CoreABNF>)
  (lambda (time-numoffset)
    (abnf:alternatives 
     (abnf:bind (lambda (x) (list (make-offset 'Z))) (char #\Z))
     time-numoffset)))


(define=> (partial-time <CoreABNF>)
  (lambda (time-hour time-minute time-second time-secfrac)
    (abnf:bind
     (consumed-numbers->list (lambda (x) (apply make-partial-time x)))
     (abnf:concatenation
      time-hour (abnf:drop-consumed (char #\:) )
      time-minute (abnf:drop-consumed (char #\:) )
      time-second
      (abnf:optional-sequence time-secfrac)))))

(define=> (full-time <CoreABNF>)
  (lambda (partial-time time-offset)
    (abnf:bind
     (consumed-objects-lift-any 
      (lambda (x) (make-full-time (first x) (second x))))
     (abnf:concatenation 
      partial-time
      time-offset))))

(define=> (full-date <CoreABNF>)
  (lambda (date-fullyear date-month date-mday)
    (abnf:bind
     (consumed-numbers->list (lambda (x) (apply make-date x)))
     (abnf:concatenation
      date-fullyear
      (abnf:drop-consumed (char #\-)) date-month 
      (abnf:drop-consumed (char #\-)) date-mday))))

(define=> (date-time <CoreABNF>)
  (lambda (full-date full-time)
    (abnf:bind
     (consumed-objects-lift-any 
      (lambda (x) (make-date-time (first x) (second x) )))
     (abnf:concatenation 
      full-date (abnf:drop-consumed (char #\T))
      full-time))))


(define (CoreABNF->InetTimestamp A)
  (let* ((number-n       (number-n A))
	 (date-fullyear  (number-n 4))
	 (date-month     (number-n 2))  ; 01-12
	 (date-mday      (number-n 2))  ; 01-28, 01-29, 01-30, 01-31 based on month/year
	 (time-hour      (number-n 2))  ; 00-23
	 (time-minute    (number-n 2))  ; 00-59
	 (time-second    (number-n 2))  ; 00-58, 00-59, 00-60 based on leap second
					; rules
	 (time-secfrac   (time-secfrac A))
	 (time-numoffset ((time-numoffset A) time-hour time-minute))
	 (time-offset    ((time-offset A) time-numoffset))
	 (partial-time   ((partial-time A) time-hour time-minute time-second time-secfrac))
	 (full-time      ((full-time A) partial-time time-offset))
	 (full-date      ((full-date A) date-fullyear date-month date-mday))
	 (date-time      ((date-time A) full-date full-time))
	 )
    (make-<InetTimestamp> A date-time)
    ))

(define (->char-list s)
  (if (string? s) (string->list s) s))

(define (err s)
  (print "time stamp parser error on stream: " s)
  (list))

(define=> (parser <InetTimestamp>)
  (let ((p date-time))
    (lambda (s)
      (date-time caar err `(() ,(->char-list s))))))

)