path: root/stdlib/source/lux/time/instant.lux

(.module:
  [lux #*
   [io (#+ IO io)]
   [control
    [equivalence (#+ Equivalence)]
    [order (#+ Order)]
    [enum (#+ Enum)]
    codec
    [monad (#+ do Monad)]
    ["p" parser]]
   [data
    ["." error (#+ Error)]
    ["." maybe]
    [number
     ["." int ("#;." decimal)]]
    ["." text ("#;." monoid)
     ["l" lexer]]
    [collection
     ["." list ("#;." fold)]
     ["." row (#+ Row row) ("#;." functor fold)]]]
   [type
    abstract]]
  [//
   ["." duration ("#;." order)]
   ["." date (#+ Date)]
   ["." month (#+ Month)]
   ["." day (#+ Day)]])

(abstract: #export Instant
  {#.doc "Instant is defined as milliseconds since the epoch."}
  Int

  (def: #export from-millis
    (-> Int Instant)
    (|>> :abstraction))

  (def: #export to-millis
    (-> Instant Int)
    (|>> :representation))

  (def: #export (span from to)
    (-> Instant Instant duration.Duration)
    (duration.from-millis (i/- (:representation from) (:representation to))))

  (def: #export (shift duration instant)
    (-> duration.Duration Instant Instant)
    (:abstraction (i/+ (duration.to-millis duration) (:representation instant))))

  (def: #export (relative instant)
    (-> Instant duration.Duration)
    (|> instant :representation duration.from-millis))

  (def: #export (absolute offset)
    (-> duration.Duration Instant)
    (|> offset duration.to-millis :abstraction))

  (structure: #export equivalence (Equivalence Instant)
    (def: (= param subject)
      (:: int.equivalence = (:representation param) (:representation subject))))

  (`` (structure: #export order (Order Instant)
        (def: &equivalence ..equivalence)
        (~~ (do-template [<name>]
              [(def: (<name> param subject)
                 (:: int.order <name> (:representation param) (:representation subject)))]

              [<] [<=] [>] [>=]
              ))))

  (`` (structure: #export enum (Enum Instant)
        (def: &order ..order)
        (~~ (do-template [<name>]
              [(def: <name>
                 (|>> :representation (:: int.enum <name>) :abstraction))]

              [succ] [pred]
              ))))
  )

(def: #export epoch
  {#.doc "The instant corresponding to 1970-01-01T00:00:00Z"}
  Instant
  (from-millis +0))

## Codec::encode
(def: (divisible? factor input)
  (-> Int Int Bit)
  (|> input (i/% factor) (i/= +0)))

(def: (leap-year? year)
  (-> Int Bit)
  (and (divisible? +4 year)
       (or (not (divisible? +100 year))
           (divisible? +400 year))))

(def: epoch-year Int +1970)

(def: (find-year now)
  (-> Instant [Int duration.Duration])
  (loop [reference epoch-year
         time-left (relative now)]
    (let [year (if (leap-year? reference)
                 duration.leap-year
                 duration.normal-year)]
      (if (i/= +0 (duration.query year time-left))
        [reference time-left]
        (if (duration;>= duration.empty time-left)
          (recur (inc reference) (duration.merge (duration.inverse year) time-left))
          (recur (dec reference) (duration.merge year time-left)))
        ))))

(def: normal-months
  (Row Nat)
  (row 31 28 31
       30 31 30
       31 31 30
       31 30 31))

(def: leap-year-months
  (Row Nat)
  (row.update [1] inc normal-months))

(def: (find-month months time)
  (-> (Row Nat) duration.Duration [Nat duration.Duration])
  (if (duration;>= duration.empty time)
    (row;fold (function (_ month-days [current-month time-left])
                (let [month-duration (duration.scale-up month-days duration.day)]
                  (if (i/= +0 (duration.query month-duration time-left))
                    [current-month         time-left]
                    [(inc current-month) (duration.merge (duration.inverse month-duration) time-left)])))
              [0 time]
              months)
    (row;fold (function (_ month-days [current-month time-left])
                (let [month-duration (duration.scale-up month-days duration.day)]
                  (if (i/= +0 (duration.query month-duration time-left))
                    [current-month         time-left]
                    [(dec current-month) (duration.merge month-duration time-left)])))
              [11 time]
              (row.reverse months))))

(def: (pad value)
  (-> Int Text)
  (if (i/< +10 value)
    (text;compose "0" (int;encode value))
    (int;encode value)))

(def: (adjust-negative space duration)
  (-> duration.Duration duration.Duration duration.Duration)
  (if (duration.negative? duration)
    (duration.merge space duration)
    duration))

(def: (encode-millis millis)
  (-> Int Text)
  (cond (i/= +0 millis)   ""
        (i/< +10 millis)  ($_ text;compose ".00" (int;encode millis))
        (i/< +100 millis) ($_ text;compose ".0" (int;encode millis))
        ## (i/< +1,000 millis)
        ($_ text;compose "." (int;encode millis))))

(def: seconds-per-day Int (duration.query duration.second duration.day))
(def: days-up-to-epoch Int +719468)

(def: (extract-date instant)
  (-> Instant [[Int Int Int] duration.Duration])
  (let [offset (relative instant)
        seconds (duration.query duration.second offset)
        z (|> seconds (i// seconds-per-day) (i/+ days-up-to-epoch))
        era (i// +146097
                 (if (i/>= +0 z)
                   z
                   (i/- +146096 z)))
        days-of-era (|> z (i/- (i/* +146097 era)))
        years-of-era (|> days-of-era
                         (i/- (i// +1460 days-of-era))
                         (i/+ (i// +36524 days-of-era))
                         (i/- (i// +146096 days-of-era))
                         (i// +365))
        year (|> years-of-era (i/+ (i/* +400 era)))
        days-of-year (|> days-of-era
                         (i/- (|> (i/* +365 years-of-era)
                                  (i/+ (i// +4 years-of-era))
                                  (i/- (i// +100 years-of-era)))))
        day-time (duration.frame duration.day offset)
        days-of-year (if (duration;>= duration.empty day-time)
                       days-of-year
                       (dec days-of-year))
        mp (|> days-of-year (i/* +5) (i/+ +2) (i// +153))
        day (|> days-of-year
                (i/- (|> mp (i/* +153) (i/+ +2) (i// +5)))
                (i/+ +1))
        month (|> mp
                  (i/+ (if (i/< +10 mp)
                         +3
                         -9)))
        year (if (i/<= +2 month)
               (inc year)
               year)]
    [[year month day]
     day-time]))

## Based on this: https://stackoverflow.com/a/42936293/6823464
(def: #export (to-text instant)
  (-> Instant Text)
  (let [[[year month day] day-time] (extract-date instant)
        day-time (if (duration;>= duration.empty day-time)
                   day-time
                   (duration.merge duration.day day-time))
        [hours day-time] [(duration.query duration.hour day-time) (duration.frame duration.hour day-time)]
        [minutes day-time] [(duration.query duration.minute day-time) (duration.frame duration.minute day-time)]
        [seconds millis] [(duration.query duration.second day-time) (duration.frame duration.second day-time)]]
    ($_ text;compose (int;encode year) "-" (pad month) "-" (pad day) "T"
        (pad hours) ":" (pad minutes) ":" (pad seconds)
        (|> millis
            (adjust-negative duration.second)
            duration.to-millis
            encode-millis)
        "Z")))

## Codec::decode
(def: lex-year
  (l.Lexer Int)
  (do p.monad
    [sign (p.or (l.this "-") (l.this "+"))
     raw-year (p.codec int.decimal (l.many l.decimal))
     #let [signum (case sign
                    (#.Left _)  -1
                    (#.Right _) +1)]]
    (wrap (i/* signum raw-year))))

(def: lex-section
  (l.Lexer Int)
  (p.codec int.decimal (l.exactly 2 l.decimal)))

(def: lex-millis
  (l.Lexer Int)
  (p.either (|> (l.at-most 3 l.decimal)
                (p.codec int.decimal)
                (p.after (l.this ".")))
            (:: p.monad wrap +0)))

(def: (leap-years year)
  (-> Int Int)
  (|> (i// +4 year)
      (i/- (i// +100 year))
      (i/+ (i// +400 year))))

## Based on: https://stackoverflow.com/a/3309340/6823464
## (def: lex-instant
##   (l.Lexer Instant)
##   (do p.monad
##     [utc-year lex-year
##      _ (l.this "-")
##      utc-month lex-section
##      _ (p.assert "Invalid month."
##                  (and (i/>= +1 utc-month)
##                       (i/<= +12 utc-month)))
##      #let [months (if (leap-year? utc-year)
##                     leap-year-months
##                     normal-months)
##            month-days (|> months
##                           (row.nth (.nat (dec utc-month)))
##                           maybe.assume)]
##      _ (l.this "-")
##      utc-day lex-section
##      _ (p.assert "Invalid day."
##                  (and (i/>= +1 utc-day)
##                       (i/<= (.int month-days) utc-day)))
##      _ (l.this "T")
##      utc-hour lex-section
##      _ (p.assert "Invalid hour."
##                  (and (i/>= +0 utc-hour)
##                       (i/<= +23 utc-hour)))
##      _ (l.this ":")
##      utc-minute lex-section
##      _ (p.assert "Invalid minute."
##                  (and (i/>= +0 utc-minute)
##                       (i/<= +59 utc-minute)))
##      _ (l.this ":")
##      utc-second lex-section
##      _ (p.assert "Invalid second."
##                  (and (i/>= +0 utc-second)
##                       (i/<= +59 utc-second)))
##      utc-millis lex-millis
##      _ (l.this "Z")
##      #let [years-since-epoch (i/- epoch-year utc-year)
##            previous-leap-days (i/- (leap-years epoch-year)
##                                    (leap-years (dec utc-year)))
##            year-days-so-far (|> (i/* +365 years-since-epoch)
##                                 (i/+ previous-leap-days))
##            month-days-so-far (|> months
##                                  row.to-list
##                                  (list.take (.nat (dec utc-month)))
##                                  (list;fold n/+ 0))
##            total-days (|> year-days-so-far
##                           (i/+ (.int month-days-so-far))
##                           (i/+ (dec utc-day)))]]
##     (wrap (|> epoch
##               (shift (duration.scale-up total-days duration.day))
##               (shift (duration.scale-up utc-hour duration.hour))
##               (shift (duration.scale-up utc-minute duration.minute))
##               (shift (duration.scale-up utc-second duration.second))
##               (shift (duration.scale-up utc-millis duration.milli))))))

## (def: (decode input)
##   (-> Text (Error Instant))
##   (l.run input lex-instant))

## (structure: #export _
##   {#.doc (doc "Based on ISO 8601."
##               "For example: 2017-01-15T21:14:51.827Z")}
##   (Codec Text Instant)
##   (def: encode encode)
##   (def: decode decode))

(def: #export now
  (IO Instant)
  (io (from-millis ("lux io current-time"))))

(def: #export (date instant)
  (-> Instant Date)
  (let [[[year month day] _] (extract-date instant)]
    {#date.year year
     #date.month (case (dec month)
                   +0 #month.January
                   +1 #month.February
                   +2 #month.March
                   +3 #month.April
                   +4 #month.May
                   +5 #month.June
                   +6 #month.July
                   +7 #month.August
                   +8 #month.September
                   +9 #month.October
                   +10 #month.November
                   +11 #month.December
                   _ (undefined))
     #date.day (.nat day)}))

(def: #export (month instant)
  (-> Instant Month)
  (let [[year month day] (date instant)]
    month))

(def: #export (day instant)
  (-> Instant Day)
  (let [offset (relative instant)
        days (duration.query duration.day offset)
        day-time (duration.frame duration.day offset)
        days (if (and (duration.negative? offset)
                      (not (duration.neutral? day-time)))
               (dec days)
               days)
        ## 1970/01/01 was a Thursday
        y1970m0d0 +4]
    (case (|> y1970m0d0
              (i/+ days) (i/% +7)
              ## This is done to turn negative days into positive days.
              (i/+ +7) (i/% +7))
      +0 #day.Sunday
      +1 #day.Monday
      +2 #day.Tuesday
      +3 #day.Wednesday
      +4 #day.Thursday
      +5 #day.Friday
      +6 #day.Saturday
      _ (undefined))))