;;;; srfi-19-date.adjust.scm -*- Scheme -*- ;;;; Kon Lovett, Jan '20 (foreign-declare "#define C_rnd_fix() (C_fix(rand()))") (module (srfi-19-date adjust support) (;export date-adjust-key? date-adjust-key-rank date-adjuster-ref date-adjuster-set!) (import scheme) (import (chicken base)) (import (chicken type)) (define-syntax boolean (syntax-rules () ((boolean ?x) (and ?x #t)))) (: date-adjust-key? (* -> boolean)) (: date-adjust-key-rank (keyword -> (or false keyword) (or false keyword))) (: date-adjuster-ref ((or false symbol) keyword -> keyword procedure)) (: date-adjuster-set! (keyword (list-of keyword) procedure -> void)) ;; Date Adjust Support (define-syntax alist-update/set! (syntax-rules () ; ((alist-update/set! ?key ?val ?var) (alist-update/set! ?key ?val ?var eq?) ) ; ((alist-update/set! ?key ?val ?var ?tst) (set! ?var (alist-update! ?key ?val ?var ?tst)) ) ) ) ;empty alists (define +date-adjust-synonym-map+ '()) (define +date-adjuster-map+ '()) (define +date-key-lexical-order+ '()) ;; (define (date-adjust-key? obj) (boolean (memq obj +date-adjust-synonym-map+))) ;=> below above (define (date-adjust-key-rank key) ;`+date-key-lexical-order+' in "reverse" order (let seek ((ls +date-key-lexical-order+) (above #f)) (cond ((null? ls) ;error - key not found (values #f #f) ) ((eq? key (car ls)) (values (and (not (null? (cdr ls))) (cadr ls)) above) ) (else (seek (cdr ls) (car ls)) ) ) ) ) (define (date-adjuster-ref loc key) (let* ((real-key (alist-ref key +date-adjust-synonym-map+ eq? 'UNKNOWN)) (val (or (alist-ref real-key +date-adjuster-map+ eq?) (error loc "unknown date-adjust key" key))) ) (values real-key val) ) ) (define (date-adjuster-set! key syns hdlr) ;-set! in ascending order (set! +date-key-lexical-order+ (cons key +date-key-lexical-order+)) ;all are key (syntax, not procedure) (alist-update/set! key key +date-adjust-synonym-map+ eq?) (for-each (lambda (syn) (alist-update/set! syn key +date-adjust-synonym-map+ eq?)) syns) ;adjuster for key (alist-update/set! key hdlr +date-adjuster-map+ eq?) ) ) ;module (srfi-19-date adjust support) (module (srfi-19-date adjust) (;export date-adjust date-adjust*) (import scheme (chicken base) (chicken type) (chicken keyword) (chicken fixnum) (only (check-errors sys) check-real) (only srfi-19-support make-time* check-time-type check-date checked-tm:time->date checked-tm:date->time) srfi-19-tm (srfi-19-date adjust support) (only srfi-19-date default-date-clock-type)) (include-relative "srfi-19-common.types") (: date-adjust (date real (or keyword symbol) #!optional clock-type -> date)) (: date-adjust* (date keyword real #!rest -> date)) ;; (define (symbol->keyword sym) (string->keyword (symbol->string sym))) (define (keyword->symbol kwd) (string->symbol (keyword->string kwd))) (include-relative "srfi-19-common") ;;; ;FIXME not part of adjuster definition (define (below-conversion-factor key) (case key ((#:weeks #:week #:wks #:wk) 7 ) ((#:days #:day #:dys #:dy) 24 ) ((#:hours #:hour #:hrs #:hr) 60 ) ((#:minutes #:minute #:mins #:min) 60 ) ((#:seconds #:second #:secs #:sec) 1000 ) ((#:milliseconds #:millisecond #:millis #:milli #:ms) 1000 ) ((#:microseconds #:microsecond #:micros #:micro #:us) 1000 ) (else #f) ) ) (define (get-adjuster-key loc key) (cond ((keyword? key) key) ((symbol? key) (symbol->keyword key)) (else (error loc "invalid key form" key))) ) ;@tt used for duration conversion (define (*date-adjust loc dat key amt tt) (receive (real-key adjuster) (date-adjuster-ref loc key) (adjuster dat real-key amt tt) ) ) ;FIXME depreciate argument order (define (date-adjust dat amt key . args) (let-optionals args ((tt (default-date-clock-type))) (*date-adjust 'date-adjust (check-date 'date-adjust dat) (get-adjuster-key 'date-adjust key) (check-real 'date-adjust amt) (check-time-type 'date-adjust tt)) ) ) ;FIXME cannot thread "built" result date/time thru adjusters ;date-adjust* date key # ... [tt] ;key = #:year ... #:nanosecond (define (date-adjust* dat . adjs) (if (null? adjs) dat (let* ((tt (if (even? (length adjs)) (default-date-clock-type) (car (list-tail adjs (- (length adjs) 1))))) (tt (check-time-type 'date-adjust* tt)) ) (let adjust ((ls adjs) (dat (check-date 'date-adjust* dat))) (if (or (null? ls) (null? (cdr ls))) dat (adjust (cddr ls) (*date-adjust 'date-adjust* dat (car ls) (check-real 'date-adjust* (cadr ls)) tt)) ) ) ) ) ) (define (date-adjuster-years dat key amt tt) ;(assert (eq? #:years key)) (cond ((zero? amt) dat ) ((integer? amt) (let ((yr (+ (tm:date-year dat) (inexact->exact amt))) (ndat (tm:copy-date dat)) ) (tm:date-year-set! ndat yr) ;FIXME leap-year -> non-leap-year handling (when (and (not (tm:leap-year? yr)) (tm:leap-day? (tm:date-day dat) (tm:date-month dat))) (tm:date-day-set! ndat (tm:days-in-month (tm:date-month dat) yr)) ) ndat ) ) (else (let ((iamt (inexact->exact (floor amt)))) (*date-adjust 'date-adjust (date-adjuster-years dat #:years iamt tt) #:months ;(receive (b a) (date-adjust-key-rank key) b) (* (- amt iamt) 12) tt) ) ) ) ) (define (date-adjuster-months dat key amt tt) ;(assert (eq? #:months key)) (cond ((zero? amt) dat ) ((integer? amt) (let-values (((ndat) (tm:copy-date dat)) ((yrs mns) (quotient&remainder (inexact->exact amt) 12)) ) (cond ((positive? mns) (when (< 12 (+ (tm:date-month dat) mns)) (tm:date-month-set! ndat 1) (set! mns (- mns (- 12 (tm:date-month dat)))) (set! yrs (+ 1 yrs)) ) ) (else ;(negative? amt) (when (> 1 (+ (tm:date-month dat) mns)) (tm:date-month-set! ndat 12) (set! mns (+ mns (tm:date-month dat))) (set! yrs (- yrs 1)) ) ) ) (tm:date-month-set! ndat (+ mns (tm:date-month ndat))) (tm:date-year-set! ndat (+ yrs (tm:date-year ndat))) (let ((mndys (tm:days-in-month (tm:date-month ndat) (tm:date-year ndat)))) (when (< mndys (tm:date-day ndat)) (tm:date-day-set! ndat mndys) ) ) ndat ) ) (else (let ((iamt (inexact->exact (floor amt)))) (*date-adjust 'date-adjust (date-adjuster-months dat #:months iamt tt) #:days ;(receive (b a) (date-adjust-key-rank key) b) (* (- amt iamt) 365/12) tt) ) ) ) ) (define (date-adjuster-quarters dat key amt tt) (date-adjuster-months dat #:months (* 3 amt) tt) ) (define (date-adjuster-duration dat key amt tt) ;(assert (eq? XXXX key)) (cond ((zero? amt) dat ) ((integer? amt) (let* ((tim (checked-tm:date->time 'date-adjust-duration dat tt)) (dur (make-time* key (inexact->exact amt))) ) (checked-tm:time->date 'date-adjust (tm:add-duration tim dur (tm:as-some-time tim)) (tm:date-timezone-info dat)) ) ) (else (receive (below above) (date-adjust-key-rank key) ;at the units bottom? (if (not below) ;then bump by nearest integer (date-adjuster-duration dat key (inexact->exact (round amt)) tt) ;else (let ((iamt (inexact->exact (floor amt)))) (*date-adjust 'date-adjust (date-adjuster-duration dat key iamt tt) below (* (- amt iamt) (below-conversion-factor key)) tt) ) ) ) ) ) ) (define-syntax date-adjuster-create (er-macro-transformer (lambda (frm r cmp) (let ((_date-adjuster-set! (r 'date-adjuster-set!)) (_begin (r 'begin)) ) `(,_begin ,@(let loop ((args (cdr frm)) (ls '())) ;order is unimportant (if (null? args) ls (let ((?key (car args)) (?syns (cadr args)) (?hdlr (caddr args)) (?rest (cdddr args)) ) (loop ?rest (cons `(,_date-adjuster-set! ',?key ',?syns ,?hdlr) ls) ) ) ) ) ) ) ) ) ) (define (date-adjuster-initialize) (date-adjuster-create #:years (#:year #:yrs #:yr) date-adjuster-years #:quarters (#:quarter #:qtrs #:qtr) date-adjuster-quarters #:months (#:month #:mons #:mon) date-adjuster-months #:weeks (#:week #:wks #:wk) date-adjuster-duration #:days (#:day #:dys #:dy) date-adjuster-duration #:hours (#:hour #:hrs #:hr) date-adjuster-duration #:minutes (#:minute #:mins #:min) date-adjuster-duration #:seconds (#:second #:secs #:sec) date-adjuster-duration #:milliseconds (#:millisecond #:millis #:milli #:ms) date-adjuster-duration #:microseconds (#:microsecond #:micros #:micro #:us) date-adjuster-duration #:nanoseconds (#:nanosecond #:nanos #:nano #:ns) date-adjuster-duration) ) ;;; Module Begin (date-adjuster-initialize) ) ;module srfi-19-date