#lang scheme/base
(require (prefix-in s: srfi/19)
"base.ss"
scheme/contract
(for-syntax scheme/base)
)
(define (date/plt->srfi/19 d)
(s:make-date 0
(date-second d) (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 (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*)