time.carp

(relative-include "datetime.h")

(deftype Timezone [
  name String,
  delta Long,
  dst? Bool,
])
(derive Timezone =)
(derive Timezone zero)

(defmodule Timezone
  (def utc (init @"UTC" 0l false))
)

(deftype Datetime [
  year Int,
  month Int,
  day Int,
  hours (Maybe Int),
  minutes (Maybe Int),
  seconds (Maybe Int),
  nanoseconds (Maybe Int),
  tz (Maybe Timezone),
])

(register-type TM [
  tm_sec Int,
  tm_min Int,
  tm_hour Int,
  tm_mday Int,
  tm_mon Int,
  tm_year Int,
  tm_wday Int,
  tm_yday Int,
  tm_isdst Int,
  tm_zone String,
])

(defmodule TM
  (register tm_gmtoff (Fn [&TM] &Long))
)

(doc Datetime "This module is primarily concerned with date and time. The
`Datetime` type can be converted from and to various other types and formats,
and formatted using `strftime`, which mimics [the C formatting API](http://www.cplusplus.com/reference/ctime/strftime/).

Example:

```
(load \"git@github.com:carpentry-org/time.carp@0.1.0\")

(defn main []
  (println* &(Datetime.strftime &(Datetime.now) \"%Y-%m-%d %I:%M:%S.%n %p %z\")))
```")

(defmodule Datetime
  (doc copy "copies a `Datetime`. This will also copy the timezone contained in
it.")

  (private create-time)
  (hidden create-time)
  (register create-time (Fn [] (Ref TM)) "create_time")

  (private MONTH-STRINGS)
  (hidden MONTH-STRINGS)
  (def MONTH-STRINGS [
    @"",
    @"January",
    @"February",
    @"March",
    @"April",
    @"May",
    @"June",
    @"July",
    @"August",
    @"September",
    @"October",
    @"November",
    @"December"
  ])
  (private WEEKDAY-STRINGS)
  (hidden WEEKDAY-STRINGS)
  (def WEEKDAY-STRINGS [
    @"",
    @"Monday",
    @"Tuesday",
    @"Wednesday",
    @"Thursday",
    @"Friday",
    @"Saturday",
    @"Sunday"
  ])
  (private DAYS-IN-MONTH)
  (hidden DAYS-IN-MONTH)
  (def DAYS-IN-MONTH [0 31 28 31 30 31 30 31 31 30 31 30 31])
  (private DAYS-BEFORE-MONTH)
  (hidden DAYS-BEFORE-MONTH)
  (def DAYS-BEFORE-MONTH [0 0 31 59 90 120 151 181 212 243 273 304 334])
  (private SECOND)
  (hidden SECOND)
  (def SECOND 1)
  (private MINUTE)
  (hidden MINUTE)
  (def MINUTE (* 60 SECOND))
  (private HOUR)
  (hidden HOUR)
  (def HOUR (* 60 MINUTE))
  (private DAY)
  (hidden DAY)
  (def DAY (* 24 HOUR))
  (private YEAR)
  (hidden YEAR)
  (def YEAR (* 365 DAY))

  (private is-leap)
  (hidden is-leap)
  (defn is-leap [y] (and (= 0 (mod y 4)) (or (/= 0 (mod y 100)) (= 0 (mod y 400)))))
  (private days-before-year)
  (hidden days-before-year)
  (defn days-before-year [year]
    (let [y (Int.dec year)] (- (+ (* y 365) (+ (/ y 4) (/ y 400))) (/ y 100))))

  (private DI400Y)
  (hidden DI400Y)
  (def DI400Y (days-before-year 401))
  (private DI100Y)
  (hidden DI100Y)
  (def DI100Y (days-before-year 101))
  (private DI4Y)
  (hidden DI4Y)
  (def DI4Y (days-before-year 5))

  (private days-before-month)
  (hidden days-before-month)
  (defn days-before-month [year month]
    (if (and (> month 2) (is-leap year))
      (Int.inc @(Array.unsafe-nth &DAYS-BEFORE-MONTH month))
      @(Array.unsafe-nth &DAYS-BEFORE-MONTH month)))

  (private days-in-month)
  (hidden days-in-month)
  (defn days-in-month [year month]
    (if (and (= month 2) (is-leap year))
      29
      @(Array.unsafe-nth &DAYS-IN-MONTH month)))

  (private ymd2ord)
  (hidden ymd2ord)
  (defn ymd2ord [year month day]
    (+ (+ (days-before-year year) (days-before-month year month)) day))

  (doc date "create a `Datetime` from a year `y`, month `m`, and day `d`.")
  (defn date [y m d]
    (init y m d (Maybe.Nothing) (Maybe.Nothing) (Maybe.Nothing) (Maybe.Nothing)
          (Maybe.Nothing)))

  (doc to-ordinal "converts a `Datetime` struct `dt` to a Gregorian ordinal.")
  (defn to-ordinal [dt] (ymd2ord @(year dt) @(month dt) @(day dt)))

  (doc from-ordinal "converts a Gregorian ordinal `ord` to a `Datetime`.")
  (defn from-ordinal [ord]
    (let [ord (- ord 1)
          n400 (/ ord DI400Y)
          ord- (mod ord DI400Y)
          year- (+ (* n400 400) 1)
          n100 (/ ord- DI100Y)
          ord-- (mod ord- DI100Y)
          n4 (/ ord-- DI4Y)
          ord--- (mod ord-- DI4Y)
          n1 (/ ord--- 365)
          n (mod ord--- 365)
          year (+ year- (+ (* n100 100) (+ (* n4 4) n1)))]
        (if (or (= n1 4) (= n100 4))
          (date (- year 1) 12 31)
          (let [month (Int.bit-shift-right (+ n 50) 5)
                prec (days-before-month year month)]
            (if (> prec n)
              (let [month (- month 1)
                    prec (- prec (days-in-month year month))]
                (date year month (+ (- n prec) 1)))
              (date year month (+ (- n prec) 1)))))))

  (doc weekday "returns the weekday of the `Datetime` `dt` as a number in the range of `0` to `6`.")
  (defn weekday [dt] (mod (+ (to-ordinal dt) 6) 7))

  (doc isoweekday "returns the ISO representation of weekday of the `Datetime`
`dt` as a number in the range of `1` to `7`.")
  (defn isoweekday [dt] (+ (weekday dt) 1))

  (doc yearday "returns the day of the year of the `Datetime` `dt` as a number
in the range of `1` to `365` or `366`, depending on whether it’s a leap year.")
  (defn yearday [dt] (+ @(Array.unsafe-nth &DAYS-BEFORE-MONTH @(month dt)) @(day dt)))

  (doc weekday-string "returns the name of the weekday of the `Datetime` `dt`.")
  (defn weekday-string [dt]
    (let [modord (mod (to-ordinal dt) 7)]
      @(Array.unsafe-nth &WEEKDAY-STRINGS (if (= modord 0) 7 modord))))

  (doc weekday-short-string "returns the abbreviated name of the weekday of the
`Datetime` `dt`.")
  (defn weekday-short-string [dt]
    (let [modord (mod (to-ordinal dt) 7)]
      (String.prefix (Array.unsafe-nth &WEEKDAY-STRINGS (if (= modord 0) 7 modord)) 3)))

  (doc month-string "returns the name of the month of the `Datetime` `dt`.")
  (defn month-string [dt] @(Array.unsafe-nth &MONTH-STRINGS @(month dt)))

  (doc month-short-string "returns the abbreviated name of the month of the
`Datetime` `dt`.")
  (defn month-short-string [dt]
    (String.prefix (Array.unsafe-nth &MONTH-STRINGS @(month dt)) 3))

  (doc leap? "checks whether the `Datetime` `dt` is a leap year.")
  (defn leap? [dt] (is-leap @(year dt)))

  ; weird mod for our purposes (behaves more or less like in Python)
  (hidden mod-)
  (defn mod- [a n] (- a (* n (to-int (floor (/ (Double.from-int a) (Double.from-int n)))))))

  (doc add-seconds "adds a number of seconds `n` to a `Datetime`.

If `n` is negative, it will be subtracted instead.")
  (defn add-seconds [d n]
    (if (neg? n)
      (let-do [nd @d
               s (Maybe.from @(seconds d) 0)
               a (dec (+ s n))]
        (set-seconds! &nd (Maybe.Just (mod- a 60)))
        (if (>= a 0)
          nd
          (let-do [m (/ a 60)
                   dm (Maybe.from @(minutes d) 0)
                   ma (dec (+ m dm))]
            (set-minutes! &nd (Maybe.Just (mod- ma 60)))
            (if (>= ma 0)
              nd
              (let-do [h (/ ma 60)
                       dh (Maybe.from @(hours d) 0)
                       ha (dec (+ h dh))]
                (set-hours! &nd (Maybe.Just (mod- ha 24)))
                (if (>= ha 0)
                  nd
                  (let-do [ord (to-ordinal d)
                           nnd (from-ordinal (dec (+ ord (/ ha 24))))]
                    (set-day! &nd @(day &nnd))
                    (set-month! &nd @(month &nnd))
                    (set-year! &nd @(year &nnd))
                    nd)))))))
      (let-do [nd @d
               s (Maybe.from @(seconds d) 0)
               a (+ s n)]
        (set-seconds! &nd (Maybe.Just (Int.mod a 60)))
        (if (< a 60)
          nd
          (let-do [m (/ a 60)
                   dm (Maybe.from @(minutes d) 0)
                   ma (+ m dm)]
            (set-minutes! &nd (Maybe.Just (Int.mod ma 60)))
            (if (< ma 60)
              nd
              (let-do [h (/ ma 60)
                       dh (Maybe.from @(hours d) 0)
                       ha (+ h dh)]
                (set-hours! &nd (Maybe.Just (Int.mod ha 24)))
                (if (< ha 24)
                  nd
                  (let-do [ord (to-ordinal d)
                           nnd (from-ordinal (+ ord (/ ha 24)))]
                    (set-day! &nd @(day &nnd))
                    (set-month! &nd @(month &nnd))
                    (set-year! &nd @(year &nnd))
                    nd)))))))))

  (private for-year)
  (hidden for-year)
  (defn for-year [years a b]
    (Array.reduce &(fn [acc x] (if (is-leap @x) (+ a acc) (+ b acc)))
                  0
                  years))

  (private to-unix)
  (hidden to-unix)
  (defn to-unix [y m d hh mm ss delta]
    (let [yy (for-year &(Result.unsafe-from-success (Array.range 1970 y 1)) 366 365)]
      (+ (* yy DAY)
         (+ (* @(Array.unsafe-nth &DAYS-BEFORE-MONTH m) DAY)
            (+ (* (Int.dec d) DAY)
               (+ (* hh HOUR)
                  (+ (* mm MINUTE)
                     (+ (Long.to-int delta)
                        ss))))))))

  (doc to-unix-timestamp "returns the representation of the `Datetime` `dt` as
a UNIX timestamp, i.e. the number of seconds elapsed since the 1st of January,
1970.")
  (defn to-unix-timestamp [dt]
    (let [tz (Maybe.from @(tz dt) (Timezone.zero))]
      (to-unix @(year dt) @(month dt) @(day dt) (Maybe.from @(hours dt) 0)
               (Maybe.from @(minutes dt) 0) (Maybe.from @(seconds dt) 0)
               @(Timezone.delta &tz))))

  (doc from-unix-timestamp "returns the `Datetime` equivalent to the UNIX
timestamp `ts`, i.e. the number of seconds elapsed since the 1st of January,
1970.")
  (defn from-unix-timestamp [ts]
    (let [y (/ ts YEAR)
          ld (Int.dec (for-year &(Result.unsafe-from-success (Array.range 1970 (+ y 1971) 1)) 1 0))
          d (- (- (/ ts DAY) (* y 365)) ld)
          get-m-until (fn [n] (Array.reduce
                                &(fn [acc x] (if (< @x n) @x acc))
                                0
                                &DAYS-BEFORE-MONTH))
          mdays (get-m-until d)
          m (Maybe.unsafe-from (Array.index-of &DAYS-BEFORE-MONTH &mdays))
          nd (- d mdays)
          tmpy (* y (* 365 24))
          tmpd (* (+ nd (+ ld mdays)) 24)
          hh (- (- (/ ts HOUR) tmpd) tmpy)
          tmy (* tmpy 60)
          tmd (* tmpd 60)
          tmh (* hh 60)
          mm (- (- (- (/ ts 60) tmh) tmd) tmy)
          ss (- (- (- (- ts (* 60 mm)) (* tmh 60)) (* tmd 60)) (* tmy 60))]
      (init (+ y 1970) m (Int.inc nd) (Maybe.Just hh) (Maybe.Just mm) (Maybe.Just ss)
            (Maybe.Nothing) (Maybe.Nothing))))

  ; TODO should this be case-insensitive?
  (doc utc? "checks whether the timezone of the `Datetime` `dt` is UTC. It will
also return true if the timezone is not set.")
  (defn utc? [dt]
    (or (Maybe.nothing? (tz dt))
        (= &Timezone.utc &(Maybe.from @(tz dt) (Timezone.zero)))))

  (doc isoformat "returns the ISO format for the `Datetime` `dt`.

The ISO format is of the form `YYYY-MM-DD`. The time value is not represented.")
  (defn isoformat [dt]
    (fmt "%04d-%02d-%02d" @(year dt) @(month dt) @(day dt)))

  (doc isotime "returns the ISO time format for the `Datetime` `dt`.

The ISO format is of the form `HH:MM:SS`. The date value is not represented.")
  (defn isotime [dt]
    (fmt "%02d:%02d:%02d" (Maybe.from @(hours dt) 0)
                          (Maybe.from @(minutes dt) 0)
                          (Maybe.from @(seconds dt) 0)))

  (doc now "returns the `Datetime` representing the current time.

All of the time information is obtained from the operating system directly.")
  (defn now []
    (let [t (System.nanotime)
          ct (create-time)]
      (init (+ @(TM.tm_year ct) 1900) (Int.inc @(TM.tm_mon ct)) @(TM.tm_mday ct)
            (Maybe.Just @(TM.tm_hour ct))
            (Maybe.Just @(TM.tm_min ct))
            (Maybe.Just @(TM.tm_sec ct))
            (Maybe.Just (Long.to-int (mod t 1000000000l)))
            (Maybe.Just (Timezone.init @(TM.tm_zone ct)
                                       @(TM.tm_gmtoff ct)
                                       (/= 0 @(TM.tm_isdst ct)))))))

  (register format (Fn [(Ref String) (Ref Datetime)] String))
  (implements format Datetime.format)

  (doc strftime "formats the `Datetime` `dt` according to the string provided
in `s`. The formatting options mimic [the C interface](http://www.cplusplus.com/reference/ctime/strftime/).

You can alternatively use the `fmt` macro or `format` function, but you’ll only
be able to use one of the formatting properties there. Thus this function is
provided as a convenience for fine-grained string tweaking.

Example:

```
&(Datetime.strftime &(Datetime.now) \"%Y-%m-%d %I:%M:%S.%n %p %z\")
```")
  (defn strftime [dt s]
    (let [strings (String.split-by s &[\%])
          ln (Int.dec (Array.length &strings))
          rng (Result.unsafe-from-success (Array.range 0 ln 1))]
      (String.concat &(Array.zip &(fn [x i]
                                    (if (and (String.empty? x)
                                             (or (= i &0) (= i &ln)))
                                      @""
                                      (if (String.empty? x)
                                        @"%"
                                        (format &(String.concat &[@"%" @x])
                                                dt))))
                                 &strings
                                 &rng))))

  (private format-for)
  (hidden format-for)
  (defn format-for [c dt]
    (case c
      \a (weekday-short-string dt)
      \A (weekday-string dt)
      \w (str (weekday dt))
      \d (format "%02d" @(day dt))
      \b (month-short-string dt)
      \B (month-string dt)
      \m (format "%02d" @(month dt))
      \y (format "%02d" (mod @(year dt) 100))
      \Y (format "%04d" @(year dt))
      \H (format "%02d" (Maybe.from @(hours dt) 0))
      \I (format "%02d" (mod (Maybe.from @(hours dt) 0) 12))
      \p (if (> (Maybe.from @(hours dt) 0) 11) @"PM" @"AM")
      \M (format "%02d" (Maybe.from @(minutes dt) 0))
      \S (format "%02d" (Maybe.from @(seconds dt) 0))
      \n (format "%09d" (Maybe.from @(nanoseconds dt) 0))
      \z (match @(tz dt)
          (Maybe.Just t)
            (let [d @(Timezone.delta &t)
                  s (* 60l 60l)]
              (fmt "%s%02d%02d" (if (< d 0l) "-" "+") (Long.abs (/ d s))
                                (mod d s)))
          (Maybe.Nothing) @"")
      \Z @(Timezone.name &(Maybe.from @(tz dt) (Timezone.zero)))
      \j (format "%03d" (yearday dt))
      \U (format "%02d" (/ (+ (- (yearday dt) (isoweekday dt)) 7) 7))
      \W (format "%02d" (/ (+ (- (yearday dt) (mod (isoweekday dt) 7)) 7) 7))
      \c (strftime dt "%a %b %d %H:%M:%S %Y")
      \x (isoformat dt)
      \X (isotime dt)
      (str c)
    )
  )

  (doc format "The interface implementation of `format` for `Datetime` values.

It mimics [the C interface](http://www.cplusplus.com/reference/ctime/strftime/).")
  (defn format [s dt]
    (let [idx (String.index-of s \%)
          formatter (String.char-at s (Int.inc idx))]
      (String.concat &[
        (String.prefix s idx)
        (format-for formatter dt)
        (String.suffix s (+ idx 2))
      ])))

  (doc = "is defined as the equality of all members of `a` and `b`, even the
optional ones.")
  (defn = [a b]
    (and
      (= (year a) (year b))
      (= (day a) (day b))
      (= (hours a) (hours b))
      (= (minutes a) (minutes b))
      (= (seconds a) (seconds b))
      (= (nanoseconds a) (nanoseconds b))
      (= &(Maybe.from @(tz a) @&Timezone.utc) &(Maybe.from @(tz b) @&Timezone.utc))))
  (implements = Datetime.=)

  (doc > "is defined as the timezone-unaware comparison of `a` and `b`.")
  (defn > [a b]
    (or
      (> @(year a) @(year b))
      (> @(day a) @(day b))
      (> (Maybe.from @(hours a) 0) (Maybe.from @(hours b) 0))
      (> (Maybe.from @(minutes a) 0) (Maybe.from @(minutes b) 0))
      (> (Maybe.from @(seconds a) 0) (Maybe.from @(seconds b) 0))
      (> (Maybe.from @(nanoseconds a) 0) (Maybe.from @(nanoseconds b) 0))))
  (implements > Datetime.>)

  (doc < "is defined as the timezone-unaware comparison of `a` and `b`.")
  (defn < [a b]
    (or
      (< @(year a) @(year b))
      (< @(day a) @(day b))
      (< (Maybe.from @(hours a) 0) (Maybe.from @(hours b) 0))
      (< (Maybe.from @(minutes a) 0) (Maybe.from @(minutes b) 0))
      (< (Maybe.from @(seconds a) 0) (Maybe.from @(seconds b) 0))
      (< (Maybe.from @(nanoseconds a) 0) (Maybe.from @(nanoseconds b) 0))))
  (implements < Datetime.<)
)

(deftype Timedelta [
  seconds- Int
])

(doc Timedelta "this is a complementary module to be used with `Datetime` and
is concerned with adding and subtracting time values of the scale from seconds
to weeks from `Datetime` values.

Example:
```
(load \"git@github.com:carpentry-org/time.carp@0.1.0\")

(defn main []
  (println*
    &(Datetime.strftime
      &(Timedelta.sub &(Datetime.now) &(Timedelta.days 2))
      \"%Y-%m-%d %I:%M:%S.%n %p %z\")))
```
")
(defmodule Timedelta
  (hidden seconds-)
  (private seconds-)
  (hidden set-seconds-)
  (private set-seconds-)
  (hidden set-seconds-!)
  (private set-seconds-!)
  (hidden update-seconds-!)
  (private update-seconds-!)
  (hidden update-seconds-)
  (private update-seconds-)
  (hidden init)
  (private init)

  (doc seconds "creates a delta representing a number of seconds `n`.")
  (defn seconds [n] (init n))
  (doc minutes "creates a delta representing a number of minutes `n`.")
  (defn minutes [n] (seconds (* n 60)))
  (doc hours "creates a delta representing a number of hours `n`.")
  (defn hours [n]   (minutes (* n 60)))
  (doc days "creates a delta representing a number of days `n`.")
  (defn days [n]    (hours (* n 24)))
  (doc weeks "creates a delta representing a number of weeks `n`.")
  (defn weeks [n]   (days (* n 7)))

  (doc add "adds a `Timedelta` `delta` to a `Datetime` `dt`.")
  (defn add [dt delta]
    (Datetime.add-seconds dt @(seconds- delta)))

  (doc sub "subtracts a `Timedelta` `delta` from a `Datetime` `dt`.")
  (defn sub [dt delta]
    (Datetime.add-seconds dt (neg @(seconds- delta))))
)