aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/time/instant.lux
blob: a574ef20877ddb9f1862182d3d32f73749e27bc5 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
(.module:
  [lux #*
   [io (#+ IO io)]
   [control
    equivalence
    order
    enum
    codec
    [monad (#+ do Monad)]
    ["p" parser]]
   [data
    ["e" error]
    ["." maybe]
    ["." number ("int/" Codec<Text,Int>)]
    [text ("text/" Monoid<Text>)
     ["l" lexer]]
    [collection
     ["." list ("list/" Fold<List>)]
     ["." row (#+ Row row) ("row/" Functor<Row> Fold<Row>)]]]
   [type
    abstract]]
  [//
   ["." duration ("duration/" Order<Duration>)]
   ["." date]])

(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 Instant)
    (def: (= param subject)
      (:: number.Equivalence<Int> = (:representation param) (:representation subject))))

  (structure: #export _ (Order Instant)
    (def: eq Equivalence<Instant>)
    (do-template [<name>]
      [(def: (<name> param subject)
         (:: number.Order<Int> <name> (:representation param) (:representation subject)))]

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

  (structure: #export _ (Enum Instant)
    (def: order Order<Instant>)
    (do-template [<name>]
      [(def: <name>
         (|>> :representation (:: number.Enum<Int> <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.scale -1 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 (.int month-days) duration.day)]
                  (if (i/= 0 (duration.query month-duration time-left))
                    [current-month         time-left]
                    [(inc current-month) (duration.merge (duration.scale -1 month-duration) time-left)])))
              [+0 time]
              months)
    (row/fold (function (_ month-days [current-month time-left])
                (let [month-duration (duration.scale (.int 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<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
                          (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 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))

## (structure: #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 io current-time"))))

(def: #export (date instant)
  (-> Instant date.Date)
  (let [[[year month day] _] (extract-date instant)]
    {#date.year year
     #date.month (case (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 (.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)))
               (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))))