;;;; locale-components.scm
;;;; Kon Lovett, May '06

;; ISSUES
;;
;; - Components predicates are not fool-proof.
;;
;; - Used selectors for *-components since it is assumed extra elements
;; will be needed by platform specific code. May switch to records later &
;; deprecate the existing interface.

(module locale-components

(;export
  ;
  make-locale-components
  locale-components?
  check-locale-components error-locale-components
  locale-components=?
  locale-component-ref
  locale-component-exists?
  set-locale-component!
  update-locale-components!
  ;
  make-timezone-components
  timezone-components?
  check-timezone-components error-timezone-components
  set-timezone-component!
  timezone-component-ref
  update-timezone-components!
  ;
  timezone-offset?
  check-timezone-offset error-timezone-offset
  ;
  make-timezone-dst-rule-julian-leap
  timezone-dst-rule-julian-leap?
  check-timezone-dst-rule-julian-leap-day error-timezone-dst-rule-julian-leap-day
  ;
  make-timezone-dst-rule-julian-noleap
  timezone-dst-rule-julian-noleap?
  check-timezone-dst-rule-julian-noleap-day error-timezone-dst-rule-julian-noleap-day
  ;
  timezone-dst-rule-julian?
  timezone-dst-rule-julian
  ;
  make-timezone-dst-rule-mwd
  timezone-dst-rule-mwd?
  check-timezone-dst-rule-mwd error-timezone-dst-rule-mwd
  check-timezone-dst-rule-mwd-day error-timezone-dst-rule-mwd-day
  check-timezone-dst-rule-mwd-week error-timezone-dst-rule-mwd-week
  check-timezone-dst-rule-mwd-month error-timezone-dst-rule-mwd-month
  timezone-components=?
  timezone-dst-rule-day
  timezone-dst-rule-month
  timezone-dst-rule-week
  ;
  timezone-dst-rule-offset)

(import scheme chicken)
(use
  (only srfi-1 last-pair every alist-cons)
  type-checks type-errors)

;;;

;;fx-utils

(: fxnegative? (fixnum --> boolean))
;
(define (fxnegative? n)
  (fx> 0 n) )

(: fxabs (fixnum --> fixnum))
;
(define (fxabs n)
  (if (fxnegative? n) (fxneg n) n) )

;;

(define-inline (->boolean obj)
  (and obj #t))

;;

(define (*check-component loc pred what value)
  (unless (pred value)
    (error loc (make-error-type-message what) value)) )


;;; Locale Components Operations

(define-inline (*locale-component-exists? loc lc what)
  (->boolean (assq what lc)) )

(define-inline (*locale-component-ref loc lc what def)
  (let (
    (cell (assq what lc)) )
    (if cell
      (cdr cell)
      def ) ) )

; Components argument cannot be null to effect in-place modification.

(define (*set-locale-component! loc lc what value checker)
  (checker loc what value)
  (if (null? lc)
    (alist-cons what value lc)
    (let (
      (cell (assq what lc)) )
      (cond
        (cell
          (set-cdr! cell value))
        (else
          (set-cdr! (last-pair lc) (list (cons what value)))) )
      lc ) ) )

#;
(define (*delete-locale-component! loc lc what)
  (check-symbol loc what 'key)
  (if (null? lc)
    lc
    () ) )

(define (*update-locale-components! loc lc kvs checker)
  (let loop ((kvs kvs))
    (cond
      ((null? kvs)
        lc )
      (else
        (set! lc (*set-locale-component! loc lc (car kvs) (cadr kvs) checker))
        (loop (cddr kvs)) ) ) ) )

(define (*locale-components=? a b)
  (or
    (eq? a b)
    (and
      (fx= (length a) (length b))
      (foldl
        (lambda (flg elma)
          (and
            flg
            (and-let* (
              (elmb (assq (car elma) b)) )
              (equal? (cdr elma) (cdr elmb)) ) ) )
        #t
        a) ) ) )

;;; Locale Components

(define (check-locale-component loc what value)
  (case (check-symbol loc what 'key)
    ((tag)
      (*check-component loc symbol? what value) )
    ((name)
      ;Because anything can be a "name" need to protect against "unspecified"
      (*check-component loc (lambda (x) (not (eq? (void) x))) what value) )
    ((source)
      (*check-component loc
        (lambda (x) (or (string? x) (and (pair? x) (string? (car x)))))
        what value) )
    ((locales)
      (*check-component loc
        (lambda (x) (and (list? x) (every locale-components? x)))
        what value) )
    ((language)
      (*check-component loc string? what value) )
    ((script)
      (*check-component loc string? what value) )
    ((region)
      (*check-component loc string? what value) )
    ((country)
      (*check-component loc string? what value) )
    ((subdivision)
      (*check-component loc string? what value) )
    ((codeset)
      (*check-component loc string? what value) )
    ((modifier)
      (*check-component loc string? what value) )
    ; accept everything else
    (else ) ) )

(define (make-empty-locale-components loc tag)
  (*set-locale-component! loc '() 'tag tag check-locale-component))

(define (*make-locale-components loc nam src tag)
  (let ((lc (make-empty-locale-components loc tag)))
    (*set-locale-component! loc lc 'name nam check-locale-component)
    (*set-locale-component! loc lc 'source src check-locale-component)
    lc ) )

(define (make-locale-components nam . args)
  (let-optionals args (
    (src #f)
    (tag 'locale))
    (*make-locale-components 'make-locale-components nam src tag) ) )

(define (locale-components? obj)
  (and
    (pair? obj)
    (*locale-component-exists? 'locale-components? obj 'tag)
    (*locale-component-exists? 'locale-components? obj 'name)
    (*locale-component-exists? 'locale-components? obj 'source)) )

(define-check+error-type locale-components)

(define (locale-components=? a b)
  (*locale-components=?
    (check-locale-components 'locale-components=? a)
    (check-locale-components 'locale-components=? b)) )

(define (locale-component-exists? lc what)
  (*locale-component-exists? 'locale-component-exists?
    (check-locale-components 'locale-component-exists? lc)
    what) )

(define (locale-component-ref lc what . def)
  (*locale-component-ref 'locale-component-ref
    (check-locale-components 'locale-component-ref lc)
    what (optional def #f)) )

(define (set-locale-component! lc what value)
  (*set-locale-component! 'set-locale-component!
    (check-locale-components 'set-locale-component! lc)
    what value check-locale-component) )

#;
(define (delete-locale-component! lc what)
  (*delete-locale-component! 'delete-locale-component!
    (check-locale-components 'delete-locale-component! lc)
    what check-locale-component) )

(define (update-locale-components! lc . args)
  (*update-locale-components! 'update-locale-components!
    (check-locale-components 'update-locale-components! lc)
    args check-locale-component) )

;;; Timezone Daylight Saving Time Rule

;; Offset

(define-constant SEC/DY 86400)
(define (timezone-offset? obj)
  (and
    (fixnum? obj)
    (let (
      (atzo (fxabs obj)) )
      (and (fx<= 0 atzo) (fx< atzo SEC/DY)))) )

(define-check+error-type timezone-offset)

;;

;The Julian day n (1 <= n <= 365).  Leap days are not counted; that is, in all
;years -- including leap years -- February 28 is day 59 and March 1 is day 60.
;It is impossible to explicitly refer to the occasional February 29.

(define-record-type timezone-dst-rule-julian-noleap
  (%make-timezone-dst-rule-julian-noleap j o)
  timezone-dst-rule-julian-noleap?
  (j timezone-dst-rule-julian-noleap-day)
  (o timezone-dst-rule-julian-noleap-offset) )

(define (timezone-dst-rule-julian-noleap-day? obj)
  (and (fixnum? obj) (<= 1 obj 365)) )

(define-check+error-type timezone-dst-rule-julian-noleap-day)

(define (make-timezone-dst-rule-julian-noleap j o)
  (%make-timezone-dst-rule-julian-noleap
    (check-timezone-dst-rule-julian-noleap-day 'make-timezone-dst-rule-julian-noleap j)
    (check-timezone-offset 'make-timezone-dst-rule-julian-noleap o)) )

;;

;The zero-based Julian day (0 <= n <= 365 ). Leap days are counted, and it is
;possible to refer to February 29.

(define-record-type timezone-dst-rule-julian-leap
  (%make-timezone-dst-rule-julian-leap j o)
  timezone-dst-rule-julian-leap?
  (j timezone-dst-rule-julian-leap-day)
  (o timezone-dst-rule-julian-leap-offset) )

(define (timezone-dst-rule-julian-leap-day? obj)
  (and (fixnum? obj) (<= 0 obj 365)) )

(define-check+error-type timezone-dst-rule-julian-leap-day)

(define (make-timezone-dst-rule-julian-leap j o)
  (%make-timezone-dst-rule-julian-leap
    (check-timezone-dst-rule-julian-leap-day 'make-timezone-dst-rule-julian-leap j)
    (check-timezone-offset 'make-timezone-dst-rule-julian-leap o)) )

;;

(define (timezone-dst-rule-julian? r)
  (or (timezone-dst-rule-julian-noleap? r) (timezone-dst-rule-julian-leap? r)) )

(define-error-type timezone-dst-rule-julian)

(define (timezone-dst-rule-julian r)
  (cond
    ((timezone-dst-rule-julian-noleap? r)
      (timezone-dst-rule-julian-noleap-day r))
    ((timezone-dst-rule-julian-leap? r)
      (timezone-dst-rule-julian-leap-day r))
    (else
      (error-timezone-dst-rule-julian 'timezone-dst-rule-julian r) ) ) )

;;

;The d'th day (0 <= d <= 6) of week n of month m of the year (1 <= n <= 5), (1
;<= m <= 12), where week 5 means ``the last d day in month m'' which may occur
;in either the fourth or the fifth week).  Week 1 is the first week in which the
;d'th day occurs.  Day zero is Sunday.

(define-record-type timezone-dst-rule-mwd
  (%make-timezone-dst-rule-mwd m w d o)
  timezone-dst-rule-mwd?
  (m timezone-dst-rule-mwd-month)
  (w timezone-dst-rule-mwd-week)
  (d timezone-dst-rule-mwd-day)
  (o timezone-dst-rule-mwd-offset) )

(define (timezone-dst-rule-mwd-day? obj)
  (and (fixnum? obj) (<= 0 obj 6)) )

(define (timezone-dst-rule-mwd-week? obj)
  (and (fixnum? obj) (<= 1 obj 5)) )

(define (timezone-dst-rule-mwd-month? obj)
  (and (fixnum? obj) (<= 1 obj 12)) )

(define-check+error-type timezone-dst-rule-mwd-day)
(define-check+error-type timezone-dst-rule-mwd-week)
(define-check+error-type timezone-dst-rule-mwd-month)

(define-check+error-type timezone-dst-rule-mwd)

(define (make-timezone-dst-rule-mwd m w d o)
  (%make-timezone-dst-rule-mwd
    (check-timezone-dst-rule-mwd-month 'make-timezone-dst-rule-mwd m)
    (check-timezone-dst-rule-mwd-week 'make-timezone-dst-rule-mwd w)
    (check-timezone-dst-rule-mwd-day 'make-timezone-dst-rule-mwd d)
    (check-timezone-offset 'make-timezone-dst-rule-mwd o)) )

(define (timezone-dst-rule-month r)
  (timezone-dst-rule-mwd-month
    (check-timezone-dst-rule-mwd 'timezone-dst-rule-month r)) )

(define (timezone-dst-rule-week r)
  (timezone-dst-rule-mwd-week
    (check-timezone-dst-rule-mwd 'timezone-dst-rule-week r)) )

(define (timezone-dst-rule-day r)
  (timezone-dst-rule-mwd-day
    (check-timezone-dst-rule-mwd 'timezone-dst-rule-day r)) )

;;

(define (timezone-dst-rule? obj)
  (or
    (timezone-dst-rule-julian-noleap? obj)
    (timezone-dst-rule-julian-leap? obj)
    (timezone-dst-rule-mwd? obj) ) )

(define-error-type timezone-dst-rule)

(define (timezone-dst-rule-offset r)
  (cond
    ((timezone-dst-rule-julian-noleap? r)
      (timezone-dst-rule-julian-noleap-offset r))
    ((timezone-dst-rule-julian-leap? r)
      (timezone-dst-rule-julian-leap-offset r))
    ((timezone-dst-rule-mwd? r)
      (timezone-dst-rule-mwd-offset r))
    (else
      (error-timezone-dst-rule 'timezone-dst-rule-offset r) ) ) )

;;; Timezone Components

(define (check-timezone-component loc what value)
  (case (check-symbol loc what 'key)
    ((std-name)
      (*check-component loc string? what value) )
    ((std-offset)
      (*check-component loc timezone-offset? what value) )
    ((dst-name)
      (*check-component loc string? what value) )
    ((dst-offset)
      (*check-component loc timezone-offset? what value) )
    ((dst-start)
      (*check-component loc timezone-dst-rule? what value) )
    ((dst-end)
      (*check-component loc timezone-dst-rule? what value) )
    ; accept everything else
    (else ) ) )

(define (make-timezone-components nam . src)
  (*make-locale-components 'make-timezone-components nam (optional src #f) 'timezone) )

(define (timezone-components? obj)
  (and
    (locale-components? obj)
    (eq? 'timezone (*locale-component-ref 'timezone-components? obj 'tag #f))) )

(define-check+error-type timezone-components)

(define (timezone-components=? a b)
  (*locale-components=?
    (check-timezone-components 'timezone-components=? a)
    (check-timezone-components 'timezone-components=? b)) )

(define (timezone-component-ref tz what . def)
  (*locale-component-ref 'timezone-component-ref
    (check-timezone-components 'timezone-component-ref tz)
    what (optional def #f)) )

(define (set-timezone-component! tz what value)
  (*set-locale-component! 'set-timezone-component!
    (check-timezone-components 'set-timezone-component! tz)
    what value check-timezone-component) )

(define (update-timezone-components! tz . args)
  (*update-locale-components! 'update-timezone-components!
    (check-timezone-components 'update-timezone-components! tz)
    args check-timezone-component) )

) ;module locale-components