;; Copyright 2011 Ryan Culpepper
;; Released under the terms of the LGPL version 3 or later.
;; See the file COPYRIGHT for details.

#lang racket/base
(require racket/contract
         racket/match
         (prefix-in srfi: srfi/19))

;; SQL Data
;; Datatypes for things that have no appropriate corresponding Scheme datatype

(define sql-null
  (let ()
    (define-struct sql-null ())
    (make-sql-null)))

(define (sql-null? x)
  (eq? x sql-null))

(define (sql-null->false x)
  (if (eq? x sql-null)
      #f
      x))

(define (false->sql-null x)
  (if (eq? x #f)
      sql-null
      x))

;; ----

#|

** problems with Racket date:

 - fields in wrong order
 - too many fields (not checked for correctness?)
 - timezone, dst? field too limited (?)
 - no fractional seconds

** problems with SRFI date:

 - fields in wrong order
 - timezone offset too limited

|#

(define-struct sql-date (year month day) #:transparent)
(define-struct sql-time (hour minute second nanosecond tz) #:transparent)
(define-struct sql-timestamp
  (year month day hour minute second nanosecond tz) 
  #:transparent)

;; Intervals must be "pre-multiplied" rather than carry extra sign field.
;; Rationale: postgresql, at least, allows mixture of signs, eg "1 month - 30 days"
(define-struct sql-interval
  (years months days hours minutes seconds nanoseconds)
  #:transparent
  #:guard (lambda (years months days hours minutes seconds nanoseconds _name)
            ;; Normalize years/months, days/hours/minutes/seconds/nanoseconds
            ;; Recall: quotient, remainder results have sign of first arg
            ;;   (if second arg is positive)
            (let ([total-months (+ months (* years 12))]
                  ;; FIXME: avoid overflow to bignums
                  [total-nsecs (+ nanoseconds
                                  (* (+ seconds
                                        (* minutes 60)
                                        (* hours 60 60)
                                        (* days 60 60 24))
                                     #e1e9))])
              (let*-values ([(years months) (quotient/remainder total-months 12)]
                            [(left-secs nsecs) (quotient/remainder total-nsecs #e1e9)]
                            [(left-mins secs) (quotient/remainder left-secs 60)]
                            [(left-hours mins) (quotient/remainder left-mins 60)]
                            [(days hours) (quotient/remainder left-hours 24)])
                (values years months days hours mins secs nsecs)))))

;; ----

(define (sql-datetime->srfi-date datetime)
  (match datetime
    [(struct sql-date (year month day))
     (srfi:make-date 0 0 0 0 day month year 0)]
    [(struct sql-time (hour minute second nanosecond tz))
     (srfi:make-date nanosecond second minute hour 0 0 0 (or tz 0))]
    [(struct sql-timestamp (year month day hour minute second nanosecond tz))
     (srfi:make-date nanosecond second minute hour day month year (or tz 0))]
    [else
     (raise-type-error 'sql-datetime->srfi-date
                       "sql-date, sql-time, or sql-timestamp"
                       datetime)]))

(define (srfi-date->sql-date date)
  (make-sql-date (srfi:date-year date)
                 (srfi:date-month date)
                 (srfi:date-day date)))

(define (srfi-date->sql-time* date tz? ns)
  (make-sql-time (srfi:date-hour date)
                 (srfi:date-minute date)
                 (srfi:date-second date)
                 (or ns (srfi:date-nanosecond date))
                 (and tz? (srfi:date-zone-offset date))))

(define (srfi-date->sql-time date [ns #f])
  (srfi-date->sql-time* date #f ns))

(define (srfi-date->sql-time-tz date [ns #f])
  (srfi-date->sql-time* date #t ns))

(define (srfi-date->sql-timestamp* date tz? ns)
  (make-sql-timestamp (srfi:date-year date)
                      (srfi:date-month date)
                      (srfi:date-day date)
                      (srfi:date-hour date)
                      (srfi:date-minute date)
                      (srfi:date-second date)
                      (or ns (srfi:date-nanosecond date))
                      (and tz? (srfi:date-zone-offset date))))

(define (srfi-date->sql-timestamp date [ns #f])
  (srfi-date->sql-timestamp* date #f ns))

(define (srfi-date->sql-timestamp-tz date [ns #f])
  (srfi-date->sql-timestamp* date #t ns))

;; ----

(define (sql-day-time-interval? x)
  (and (sql-interval? x)
       (zero? (sql-interval-years x))
       (zero? (sql-interval-months x))))

(define (sql-year-month-interval? x)
  (and (sql-interval? x)
       (zero? (sql-interval-days x))
       (zero? (sql-interval-hours x))
       (zero? (sql-interval-minutes x))
       (zero? (sql-interval-seconds x))
       (zero? (sql-interval-nanoseconds x))))

(define (sql-day-time-interval->seconds x)
  (+ (* (sql-interval-hours x) 60 60)
     (* (sql-interval-minutes x) 60)
     (sql-interval-seconds x)
     (/ (sql-interval-nanoseconds x) #i1e9)))

(define (same-signs? w x y z)
  (define some-pos? (or (positive? w) (positive? x) (positive? y) (positive? z)))
  (define some-neg? (or (negative? w) (negative? x) (negative? y) (negative? z)))
  (not (and some-pos? some-neg?)))

(define no-arg (gensym))

(define (sql-interval->sql-time x [default no-arg])
  (let ([d (sql-interval-days x)]
        [h (sql-interval-hours x)]
        [m (sql-interval-minutes x)]
        [s (sql-interval-seconds x)]
        [ns (sql-interval-nanoseconds x)])
    (cond [(and (sql-day-time-interval? x)
                (zero? d)
                (<= 0 h 23)
                (<= 0 m 59)
                (<= 0 s 59)
                (<= 0 ns (sub1 #e1e9)))
           (sql-time h m s ns #f)]
          [else
           (cond [(eq? default no-arg)
                  (error 'sql-day-time-interval->sql-time
                         "cannot convert interval to time: ~e" x)]
                 [(procedure? default) (default)]
                 [else default])])))

(define (sql-time->sql-interval x)
  (sql-interval 0 0 0
                (sql-time-hour x)
                (sql-time-minute x)
                (sql-time-second x)
                (sql-time-nanosecond x)))

;; ----

;; Note: MySQL allows 0 month, 0 day, etc.

(provide sql-null
         sql-null?
         sql-null->false
         false->sql-null)
(provide/contract
 [struct sql-date ([year exact-integer?]
                   [month (integer-in 0 12)]
                   [day (integer-in 0 31)])]
 [struct sql-time ([hour (integer-in 0 23)]
                   [minute (integer-in 0 59)]
                   [second (integer-in 0 61)] ;; leap seconds
                   [nanosecond (integer-in 0 (sub1 #e1e9))]
                   [tz (or/c #f exact-integer?)])]
 [struct sql-timestamp ([year exact-integer?]
                        [month (integer-in 0 12)]
                        [day (integer-in 0 31)]
                        [hour (integer-in 0 23)]
                        [minute (integer-in 0 59)]
                        [second (integer-in 0 61)]
                        [nanosecond (integer-in 0 (sub1 #e1e9))]
                        [tz (or/c #f exact-integer?)])]
 [struct sql-interval ([years exact-integer?]
                       [months exact-integer?]
                       [days exact-integer?]
                       [hours exact-integer?]
                       [minutes exact-integer?]
                       [seconds exact-integer?]
                       [nanoseconds exact-integer?])]

 [sql-datetime->srfi-date
  (-> (or/c sql-date? sql-time? sql-timestamp?)
      srfi:date?)]
 [srfi-date->sql-date
  (-> srfi:date? sql-date?)]
 [srfi-date->sql-time
  (->* (srfi:date?) ((or/c exact-nonnegative-integer? #f))
       sql-time?)]
 [srfi-date->sql-time-tz
  (->* (srfi:date?) ((or/c exact-nonnegative-integer? #f))
       sql-time?)]
 [srfi-date->sql-timestamp
  (->* (srfi:date?) ((or/c exact-nonnegative-integer? #f))
       sql-timestamp?)]
 [srfi-date->sql-timestamp-tz
  (->* (srfi:date?) ((or/c exact-nonnegative-integer? #f))
       sql-timestamp?)]

 [sql-day-time-interval?
  (-> any/c boolean?)]
 [sql-year-month-interval?
  (-> any/c boolean?)]
 [sql-day-time-interval->seconds
  (-> sql-day-time-interval? rational?)]
 [sql-interval->sql-time
  (->* (sql-interval?) (any/c)
       any)]
 [sql-time->sql-interval
  (-> sql-time? sql-day-time-interval?)])

;; ----

#|
A sql-bits is (sql-bits len bv offset)
where len is the number of bits, and bv is a bytes, offset is nat.

Bit order is little-endian wrt bytes, but big-endian wrt bits within a
byte. (Because that's PostgreSQL's binary format.) For example:

  (bytes 128 3) represents 1000000 0000011
|#
(struct sql-bits (length bv offset))

(define (make-sql-bits len)
  (sql-bits len (make-bytes (/ceiling len 8) 0) 0))

(define (make-sql-bits/bytes len bv offset)
  (sql-bits len bv offset))

(define (check-index fsym b index)
  (let ([len (sql-bits-length b)])
    (unless (< index len)
      (if (zero? len)
          (error fsym "index ~e out of range for empty sql-bits" index)
          (error fsym "index ~e out of range: [0, ~a]" index (+ len -1))))))

(define (sql-bits-ref b i)
  (check-index 'sql-bits-ref b i)
  (bv-ref (sql-bits-bv b) (+ i (sql-bits-offset b))))
(define (bv-ref bv i)
  (let-values ([(bytei biti) (quotient/remainder i 8)])
    (bitwise-bit-set? (bytes-ref bv bytei) (- 7 biti))))

(define (sql-bits-set! b i v)
  (check-index 'sql-bits-set! b i)
  (bv-set! (sql-bits-bv b) (+ i (sql-bits-offset b)) v))
(define (bv-set! bv i v)
  (let-values ([(bytei biti) (quotient/remainder i 8)])
    (let* ([oldbyte (bytes-ref bv bytei)]
           [mask (arithmetic-shift 1 (- 7 biti))]
           [newbyte (bitwise-ior (bitwise-and oldbyte (bitwise-xor 255 mask)) (if v mask 0))])
      (unless (= oldbyte newbyte)
        (bytes-set! bv bytei newbyte)))))

(define (sql-bits->list b)
  (let ([l (sql-bits-length b)]
        [bv (sql-bits-bv b)]
        [offset (sql-bits-offset b)])
    (for/list ([i (in-range l)])
      (bv-ref bv (+ offset i)))))

(define (sql-bits->string b)
  (let* ([l (sql-bits-length b)]
         [bv (sql-bits-bv b)]
         [offset (sql-bits-offset b)]
         [s (make-string l)])
    (for ([i (in-range l)])
      (string-set! s i (if (bv-ref bv (+ offset i)) #\1 #\0)))
    s))

(define (list->sql-bits lst)
  (let* ([b (make-sql-bits (length lst))]
         [bv (sql-bits-bv b)])
    (for ([v (in-list lst)]
          [i (in-naturals)])
      (bv-set! bv i v))
    b))

(define (string->sql-bits s)
  (let* ([b (make-sql-bits (string-length s))]
         [bv (sql-bits-bv b)])
    (for ([i (in-range (string-length s))])
      (case (string-ref s i)
        ((#\0) (bv-set! bv i #f))
        ((#\1) (bv-set! bv i #t))
        (else (raise-type-error 'string->sql-bits "string over {0,1}" 0 s))))
    b))

(define (/ceiling x y)
  (let-values ([(q r) (quotient/remainder x y)])
    (+ q (if (zero? r) 0 1))))

(define (align-sql-bits b dir)
  (let* ([len (sql-bits-length b)]
         [bv (sql-bits-bv b)]
         [offset (sql-bits-offset b)]
         [offset* (case dir
                    ((left) 0)
                    ((right) (- 8 (remainder len 8))))])
    (cond [(= (remainder offset 8) offset*)
           (values len bv (quotient offset 8))]
          [else
           (let ([b* (copy-sql-bits b offset*)])
             (values len (sql-bits-bv b*) 0))])))

(define (copy-sql-bits b [offset* 0])
  (let* ([len (sql-bits-length b)]
         [bv0 (sql-bits-bv b)]
         [offset0 (sql-bits-offset b)]
         [bytelen* (/ceiling (+ len offset*) 8)]
         [bv* (make-bytes bytelen* 0)])
    (for ([i (in-range len)])
      (bv-set! bv* (+ i offset*) (bv-ref bv0 (+ offset0 i))))
    (sql-bits len bv* offset*)))

(provide make-sql-bits/bytes
         sql-bits-bv
         align-sql-bits)

(provide/contract
 [make-sql-bits
  (-> exact-nonnegative-integer? sql-bits?)]
 [sql-bits?
  (-> any/c boolean?)]
 [sql-bits-length
  (-> sql-bits? exact-nonnegative-integer?)]
 [sql-bits-ref
  (-> sql-bits? exact-nonnegative-integer? boolean?)]
 [sql-bits-set!
  (-> sql-bits? exact-nonnegative-integer? boolean? void?)]
 [sql-bits->list
  (-> sql-bits? (listof boolean?))]
 [list->sql-bits
  (-> (listof boolean?) sql-bits?)]
 [sql-bits->string
  (-> sql-bits? string?)]
 [string->sql-bits
  (-> string? sql-bits?)])

;; ----------------------------------------

;; Predicates

(define (mkintN? n)
  (let ([hi  (- (expt 2 (sub1 n)) 1)]
        [low (- (expt 2 (sub1 n)))])
    (lambda (x) (and (exact-integer? x) (<= low x hi)))))

(define (mkuintN? n)
  (let ([hi (- (expt 2 n) 1)])
    (lambda (x) (and (exact-integer? x) (<= 0 x hi)))))

(define int8?  (mkintN? 8))
(define int16? (mkintN? 16))
(define int24? (mkintN? 24))
(define int32? (mkintN? 32))
(define int64? (mkintN? 64))

(define uint8?  (mkuintN? 8))
(define uint16? (mkuintN? 16))
(define uint24? (mkuintN? 24))
(define uint32? (mkuintN? 32))
(define uint64? (mkuintN? 64))

(provide int8? int16? int24? int32? int64?
         uint8?)