#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DATE.plt
;;
;; date-specific routines.  Reexports srfi/19
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; convert.ss - convert between plt & srfi/19 dates
;; yc 8/31/2009 - first version
;; yc 10/7/2009 - adding define-date-plt* as a macro to creating the conversion binding (and provide at the same time)
;; yc 10/19/2009 - added #:rest clause for define-plt-date
;; yc 1/19/2010 - provide define-plt-date
(require (prefix-in s: srfi/19)
         "base.ss" 
         scheme/contract
         (for-syntax scheme/base)
         )

;; convert from plt date to srfi date
(define (date/plt->srfi/19 d)
  (s:make-date 0
               (date-second d) ;; why does this *expect*
               (date-minute d)
               (date-hour d)
               (date-day d)
               (date-month d)
               (date-year d)
               (date-time-zone-offset d)))

(define (date/srfi/19->plt s)
  (make-date (s:date-second s)
             (s:date-minute s)
             (s:date-hour s)
             (s:date-day s)
             (s:date-month s)
             (s:date-year s)
             (week-day s)
             (year-day s)
             #f ;; this eventually needs to have a way to determine whether this is true or false.
             (s:date-zone-offset s)))
(provide/contract 
 (date/srfi/19->plt (-> s:date? date?))
 (date/plt->srfi/19 (-> date? s:date?))
 )

(begin-for-syntax 
  
  (define (date-args->ids stx)
    (syntax-case stx (:date) 
      (()
       #'())
      (((id :date val) . rest)
       #`((id val) . #,(date-args->ids #'rest)))
      (((id :date) . rest)
       #`(id . #,(date-args->ids #'rest)))
      (((id val) . rest)
       #`((id val) . #,(date-args->ids #'rest)))
      ((id  . rest)
       #`(id . #,(date-args->ids #'rest)))))
  (define (date-args->srfi-args stx)
    (syntax-case stx (:date) 
      (()
       #'())
      (((id :date val) . rest)
       #`((date/plt->srfi/19 id) . #,(date-args->srfi-args #'rest)))
      (((id :date) . rest)
       #`((date/plt->srfi/19 id) . #,(date-args->srfi-args #'rest)))
      (((id val) . rest)
       #`(id . #,(date-args->srfi-args #'rest)))
      ((id  . rest)
       #`(id . #,(date-args->srfi-args #'rest)))))
  (define (date-rest-arg->id stx)
    (syntax-case stx (:date)
      ((id :date) 
       #'id)
      (id
       #'id)))
  (define (date-rest-arg->srfi-arg stx)
    (syntax-case stx (:date)
      ((id :date)
       #'(map date/plt->srfi/19 id))
      (id #'id)))
  )

(define-syntax (define-plt-date stx)
  (syntax-case stx () 
    ((~ proc #:any! arg ... #:rest rest)
     (with-syntax ((s:proc (datum->syntax #'proc 
                                          (string->symbol
                                           (string-append "s:" 
                                                          (symbol->string 
                                                           (syntax->datum #'proc))))))
                   ((id ...) 
                    (date-args->ids #'(arg ...)))
                   ((arg ...)
                    (date-args->srfi-args #'(arg ...)))
                   (rest-id (date-rest-arg->id #'rest)) 
                   (rest-arg (date-rest-arg->srfi-arg #'rest))
                   )
       #'(define (proc id ... . rest-id)
             (apply s:proc arg ... rest-arg))))
    ((~ proc #:any! arg ...)
     (with-syntax ((s:proc (datum->syntax #'proc 
                                          (string->symbol
                                           (string-append "s:" 
                                                          (symbol->string 
                                                           (syntax->datum #'proc))))))
                   ((id ...) 
                    (date-args->ids #'(arg ...)))
                   ((arg ...)
                    (date-args->srfi-args #'(arg ...))))
       #'(define (proc id ...)
           (s:proc arg ...))))
    ((~ proc arg ... #:rest rest) 
     (with-syntax ((s:proc (datum->syntax #'proc 
                                          (string->symbol
                                           (string-append "s:" 
                                                          (symbol->string 
                                                           (syntax->datum #'proc))))))
                   ((id ...) 
                    (date-args->ids #'(arg ...)))
                   ((arg ...)
                    (date-args->srfi-args #'(arg ...)))
                   (rest-id (date-rest-arg->id #'rest)) 
                   (rest-arg (date-rest-arg->srfi-arg #'rest))
                   )
       #'(define (proc id ... . rest-id)
           (date/srfi/19->plt (apply s:proc arg ... rest-arg)))))
    ((~ proc arg ...) 
     (with-syntax ((s:proc (datum->syntax #'proc 
                                          (string->symbol
                                           (string-append "s:" 
                                                          (symbol->string 
                                                           (syntax->datum #'proc))))))
                   ((id ...) 
                    (date-args->ids #'(arg ...)))
                   ((arg ...)
                    (date-args->srfi-args #'(arg ...))))
       #'(define (proc id ...)
           (date/srfi/19->plt (s:proc arg ...)))))
    ))

(define-syntax define-plt-date*
  (syntax-rules () 
    ((~)
     (void))
    ((~ (proc arg ...) rest ...) 
     (begin
       (define-plt-date proc arg ...)
       (provide proc)
       (define-plt-date* rest ...)))))
(provide define-plt-date* define-plt-date)