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

(;module:
  lux
  (lux [io #- run]
       (control eq
                order
                enum
                codec
                [monad #+ do Monad]
                ["p" parser])
       (data [text "text/" Monoid<Text>]
             (text ["l" lexer])
             [number "int/" Codec<Text,Int>]
             ["E" error]
             [maybe]
             (coll [list "L/" Fold<List> Functor<List>]
                   [sequence #+ Sequence sequence "sequence/" Functor<Sequence> Fold<Sequence>]))
       (meta (type opaque)))
  (.. [duration "duration/" Order<Duration>]
      [date]))

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

  (def: #export from-millis
    (-> Int Instant)
    (|>. @opaque))

  (def: #export to-millis
    (-> Instant Int)
    (|>. @repr))

  (def: #export (span from to)
    (-> Instant Instant duration;Duration)
    (duration;from-millis (i.- (@repr from) (@repr to))))

  (def: #export (shift duration instant)
    (-> duration;Duration Instant Instant)
    (@opaque (i.+ (duration;to-millis duration) (@repr instant))))

  (def: #export (relative instant)
    (-> Instant duration;Duration)
    (|> instant @repr duration;from-millis))

  (def: #export (absolute offset)
    (-> duration;Duration Instant)
    (|> offset duration;to-millis @opaque))

  (struct: #export _ (Eq Instant)
    (def: (= param subject)
      (:: number;Eq<Int> = (@repr param) (@repr subject))))

  (struct: #export _ (Order Instant)
    (def: eq Eq<Instant>)
    (do-template [<name>]
      [(def: (<name> param subject)
         (:: number;Order<Int> <name> (@repr param) (@repr subject)))]

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

  (struct: #export _ (Enum Instant)
    (def: order Order<Instant>)
    (do-template [<name>]
      [(def: <name>
         (|>. @repr (:: number;Enum<Int> <name>) @opaque))]

      [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 Bool)
  (|> input (i.% factor) (i.= 0)))

(def: (leap-year? year)
  (-> Int Bool)
  (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 (i.inc reference) (duration;merge (duration;scale -1 year) time-left))
          (recur (i.dec reference) (duration;merge year time-left)))
        ))))

(def: normal-months
  (Sequence Nat)
  (sequence +31 +28 +31
            +30 +31 +30
            +31 +31 +30
            +31 +30 +31))

(def: leap-year-months
  (Sequence Nat)
  (sequence;update [+1] n.inc normal-months))

(def: (find-month months time)
  (-> (Sequence Nat) duration;Duration [Nat duration;Duration])
  (if (duration/>= duration;empty time)
    (sequence/fold (function [month-days [current-month time-left]]
                     (let [month-duration (duration;scale (nat-to-int month-days) duration;day)]
                       (if (i.= 0 (duration;query month-duration time-left))
                         [current-month         time-left]
                         [(n.inc current-month) (duration;merge (duration;scale -1 month-duration) time-left)])))
                   [+0 time]
                   months)
    (sequence/fold (function [month-days [current-month time-left]]
                     (let [month-duration (duration;scale (nat-to-int month-days) duration;day)]
                       (if (i.= 0 (duration;query month-duration time-left))
                         [current-month         time-left]
                         [(n.dec current-month) (duration;merge month-duration time-left)])))
                   [+11 time]
                   (sequence;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
                       (i.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)
               (i.inc year)
               year)]
    [[year month day]
     day-time]))

## Based on this: https://stackoverflow.com/a/42936293/6823464
(def: (encode 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<Parser>
    [sign? (p;maybe (l;this "-"))
     raw-year (p;codec number;Codec<Text,Int> (l;many l;decimal))
     #let [signum (case sign?
                    #;None      1
                    (#;Some _) -1)]]
    (wrap (i.* signum raw-year))))

(def: lex-section
  (l;Lexer Int)
  (p;codec number;Codec<Text,Int> (l;exactly +2 l;decimal)))

(def: lex-millis
  (l;Lexer Int)
  (p;either (|> (l;at-most +3 l;decimal)
                (p;codec number;Codec<Text,Int>)
                (p;after (l;this ".")))
            (:: p;Monad<Parser> 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<Parser>
    [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
                          (sequence;nth (int-to-nat (i.dec utc-month)))
                          maybe;assume)]
     _ (l;this "-")
     utc-day lex-section
     _ (p;assert "Invalid day."
                 (and (i.>= 1 utc-day)
                      (i.<= (nat-to-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 (i.dec utc-year)))
           year-days-so-far (|> (i.* 365 years-since-epoch)
                                (i.+ previous-leap-days))
           month-days-so-far (|> months
                                 sequence;to-list
                                 (list;take (int-to-nat (i.dec utc-month)))
                                 (L/fold n.+ +0))
           total-days (|> year-days-so-far
                          (i.+ (nat-to-int month-days-so-far))
                          (i.+ (i.dec utc-day)))]]
    (wrap (|> epoch
              (shift (duration;scale total-days duration;day))
              (shift (duration;scale utc-hour duration;hour))
              (shift (duration;scale utc-minute duration;minute))
              (shift (duration;scale utc-second duration;second))
              (shift (duration;scale utc-millis duration;milli))))))

(def: (decode input)
  (-> Text (E;Error Instant))
  (l;run input lex-instant))

(struct: #export _
  {#;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_proc ["io" "current-time"] []))))

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

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

(def: #export (day instant)
  (-> Instant date;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)))
               (i.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 #date;Sunday
      1 #date;Monday
      2 #date;Tuesday
      3 #date;Wednesday
      4 #date;Thursday
      5 #date;Friday
      6 #date;Saturday
      _ (undefined))))