#lang scheme/base
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DATE-TZ.plt - provides time-zone-based date calculations
;;
;; Bonzai Lab, LLC.  All rights reserved.
;;
;; released under LGPL.
;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; util.ss - basic functions that are shared by other modules, inclding
;; zone-path, spec->date, zone-exists..
;; yc 10/2/2009 - first version
;; yc 10/6/2009 - added tz-names to retrieve all of the zones in the system.
;;              - added zone to abbr mapping, abbr to zone mapping
;; yc 10/19/2009 - use depend.ss for centralized dependency

(require "base.ss"
         "depend.ss"
         scheme/match
         )

(define (spec->date std-offset offset year month day 
                    (hour 0) (minute 0) (second 0) (type 'w))
  (let ((tz (case type 
              ((u g z) 0)
              ((s) std-offset)
              (else 
               (+ offset std-offset)))))
    (match day 
      ((? integer? date)
       (build-date year month date hour minute second #:tz tz))
      ((list 'last (? number? wday))
       (nth-week-day year month wday 'last hour minute second #:tz tz)) 
      ('- 
       (build-date year month 1 hour minute second #:tz tz))
      ((list 'match (? number? wday) (? symbol? test) (? number? day))
       ((case test 
          ((>=) week-day>=mday)
          ((>) week-day>mday)
          ((<=) week-day<=mday)
          ((<) week-day<mday)) year month wday day hour minute second #:tz tz)))))

(define (zone-path tz)
  (build-path* (this-expression-source-directory) "zoneinfo" tz)) 

(define (abbr-path)
  (zone-path "tz.abbr"))

(define (olson-path (file "."))
  (build-path* (this-expression-source-directory) "olson" file))

(define (olson2-path (file "."))
  (build-path* (this-expression-source-directory) "olson2" file))

(define all-zones
  (make-immutable-hash
   (let ((base (zone-path ".")))
     (fold-files (lambda (path type acc)
                   (let ((path (path->string (find-relative-path base path))))
                     (case type
                       ((file) 
                       (if (not (regexp-match #px"\\." path))
                           (cons (cons (string-downcase path) path) acc)
                           acc))
                       (else acc))))
                 '()
                 base
                 #f))))

(define (normalize-zone/abbrs z/abbrs)
  ;; first map each
  (define (z/abbr->abbr/z z/abbr)
    (map (lambda (abbr)
           (cons abbr (car z/abbr)))
         (cdr z/abbr)))
  (define (z/abbrs->abbr/zs)
    (make-immutable-hash (group (apply append (map z/abbr->abbr/z z/abbrs)))))
  (values (make-immutable-hash z/abbrs) (z/abbrs->abbr/zs)))

(define-values (zone->abbrs abbrs->zones)
  (normalize-zone/abbrs (call-with-input-file (abbr-path) 
                          (lambda (in)
                            (let loop ((term (read in))
                                       (acc '()))
                              (if (eof-object? term)
                                  (reverse acc)
                                  (loop (read in) (cons term acc))))))))

(define (zone-exists? tz)
  (hash-ref all-zones (string-downcase tz) #f))

(define (tz-names)
  (sort (hash-map all-zones (lambda (k v) v)) string<?))

(define (zone-abbrs tz)
  (hash-ref zone->abbrs tz '())) 

(define (abbr-zones abbr)
  (hash-ref abbrs->zones abbr '()))

(provide/contract
 (spec->date (->* (number? number? number? number? (or/c number?
                                                         list?))
                  (number? number? number? (or/c 'w 'u 'g 'z 's #f))
                  date?))
 (zone-path (-> path-string? path-string?)) 
 (abbr-path (-> path-string?))
 (olson-path (->* ()
                  (path-string?) 
                  path-string?))
 (olson2-path (->* ()
                   (path-string?)
                   path-string?))
 (zone-exists? (-> path-string? any))
 (tz-names (-> any))
 (zone-abbrs (-> string? list?))
 (abbr-zones (-> string? list?))
 )