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

(;module:
  lux
  (lux [io #- run]
       (control eq
                order
                codec
                [monad #+ do Monad]
                ["p" parser])
       (data [text "text/" Monoid<Text>]
             (text ["l" lexer]
                   format)
             [number]
             ["R" result]
             (coll [list "L/" Fold<List> Functor<List>]
                   ["v" vector "v/" Functor<Vector> Fold<Vector>]))
       (type model))
  (.. ["../d" duration "../d/" ;Order<Duration>]))

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

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

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

  (def: #export (span param subject)
    (-> Instant Instant ../d;Duration)
    (../d;from-millis (i.- (@repr param) (@repr subject))))

  (struct: #export _ (Eq Instant)
    (def: (= param subject)
      (i.= (@repr param) (@repr subject))))

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

      [<  i.<]
      [<= i.<=]
      [>  i.>]
      [>= i.>=]
      ))

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

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

  (def: #export (absolute offset)
    (-> ../d;Duration Instant)
    (|> offset ../d;to-millis @model))
  )

(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 ../d;Duration])
  (loop [reference epoch-year
         time-left (relative now)]
    (let [year (if (leap-year? reference)
                 ../d;leap-year
                 ../d;normal-year)]
      (if (i.= 0 (../d;query year time-left))
        [reference time-left]
        (if (../d/>= ../d;empty time-left)
          (recur (i.inc reference) (../d;merge (../d;scale -1 year) time-left))
          (recur (i.dec reference) (../d;merge year time-left)))
        ))))

(def: normal-months
  (v;Vector Nat)
  (v;vector +31 +28 +31
            +30 +31 +30
            +31 +31 +30
            +31 +30 +31))

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

(def: (find-month months time)
  (-> (v;Vector Nat) ../d;Duration [Nat ../d;Duration])
  (if (../d/>= ../d;empty time)
    (v/fold (function [month-days [current-month time-left]]
              (let [month-duration (../d;scale (nat-to-int month-days) ../d;day)]
                (if (i.= 0 (../d;query month-duration time-left))
                  [current-month         time-left]
                  [(n.inc current-month) (../d;merge (../d;scale -1 month-duration) time-left)])))
            [+0 time]
            months)
    (v/fold (function [month-days [current-month time-left]]
              (let [month-duration (../d;scale (nat-to-int month-days) ../d;day)]
                (if (i.= 0 (../d;query month-duration time-left))
                  [current-month         time-left]
                  [(n.dec current-month) (../d;merge month-duration time-left)])))
            [+11 time]
            (v;reverse months))))

(def: (pad value)
  (-> Int Text)
  (if (i.< 10 value)
    (text/append "0" (%i value))
    (%i value)))

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

(def: (encode-millis millis)
  (-> Int Text)
  (cond (i.= 0 millis)   ""
        (i.< 10 millis)  (format ".00" (%i millis))
        (i.< 100 millis) (format ".0" (%i millis))
        ## (i.< 1_000 millis)
        (format "." (%i millis))))

(def: seconds-per-day Int (../d;query ../d;second ../d;day))
(def: days-up-to-epoch Int 719468)

(def: (extract-date instant)
  (-> Instant [[Int Int Int] ../d;Duration])
  (let [offset (relative instant)
        seconds (../d;query ../d;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 (../d;frame ../d;day offset)
        days-of-year (if (../d/>= ../d;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 (../d/>= ../d;empty day-time)
                   day-time
                   (../d;merge ../d;day day-time))
        [hours day-time] [(../d;query ../d;hour day-time) (../d;frame ../d;hour day-time)]
        [minutes day-time] [(../d;query ../d;minute day-time) (../d;frame ../d;minute day-time)]
        [seconds millis] [(../d;query ../d;second day-time) (../d;frame ../d;second day-time)]
        ]
    (format (%i year) "-" (pad month) "-" (pad day) "T"
            (pad hours) ":" (pad minutes) ":" (pad seconds)
            (|> millis
                (adjust-negative ../d;second)
                ../d;to-millis
                encode-millis)
            "Z")))

## Codec::decode
(def: lex-year
  (l;Lexer Int)
  (do p;Monad<Parser>
    [sign? (p;opt (l;this "-"))
     raw-year (l;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)
  (l;codec number;Codec<Text,Int> (l;exactly +2 l;decimal)))

(def: lex-millis
  (l;Lexer Int)
  (p;either (|> (l;at-most +3 l;decimal)
                (l;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
                          (v;nth (int-to-nat (i.dec utc-month)))
                          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
                                 v;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 (../d;scale total-days ../d;day))
              (shift (../d;scale utc-hour ../d;hour))
              (shift (../d;scale utc-minute ../d;minute))
              (shift (../d;scale utc-second ../d;second))
              (shift (../d;scale utc-millis ../d;milli))))))

(def: (decode input)
  (-> Text (R;Result 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"] []))))