blob: 7fcf3e9c60424a64c15d6596b4d3f84281eb5307 (
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
|
(.module:
[lux #*
[abstract
[equivalence (#+ Equivalence)]
[order (#+ Order)]
[enum (#+ Enum)]
codec
[monad (#+ do)]]
[control
["." try]
["p" parser ("#@." functor)
["l" text (#+ Parser)]]]
[data
[number
["n" nat ("#@." decimal)]
["i" int ("#@." decimal)]]
["." text ("#@." monoid)]
[collection
["." row (#+ Row row)]]]]
["." // #_
["#." month (#+ Month)]])
(type: #export Year Int)
(type: #export Date
{#year Year
#month Month
#day Nat})
(structure: #export equivalence (Equivalence Date)
(def: (= reference sample)
(and (i.= (get@ #year reference)
(get@ #year sample))
(:: //month.equivalence =
(get@ #month reference)
(get@ #month sample))
(n.= (get@ #day reference)
(get@ #day sample)))))
(structure: #export order (Order Date)
(def: &equivalence ..equivalence)
(def: (< reference sample)
(or (i.< (get@ #year reference)
(get@ #year sample))
(and (i.= (get@ #year reference)
(get@ #year sample))
(or (:: //month.order <
(get@ #month reference)
(get@ #month sample))
(and (:: //month.order =
(get@ #month reference)
(get@ #month sample))
(n.< (get@ #day reference)
(get@ #day sample))))))))
## Based on this: https://stackoverflow.com/a/42936293/6823464
(def: (pad value)
(-> Int Text)
(let [digits (n@encode (.nat value))]
(if (i.< +10 value)
(text@compose "0" digits)
digits)))
(def: (encode [year month day])
(-> Date Text)
($_ text@compose
(if (i.< +0 year)
(i@encode year)
(n@encode (.nat year)))
"-"
(pad (|> month //month.number inc .int)) "-"
(pad (|> day .inc .int))))
(def: lex-year
(Parser Int)
(do p.monad
[sign (p.maybe (l.this "-"))
raw-year (p.codec n.decimal (l.many l.decimal))
#let [signum (case sign
(#.Some _)
-1
#.None
+1)]]
(wrap (i.* signum (.int raw-year)))))
(def: lex-section
(Parser Int)
(p@map .int (p.codec n.decimal (l.exactly 2 l.decimal))))
(def: (leap-years year)
(-> Int Int)
(|> (i./ +4 year)
(i.- (i./ +100 year))
(i.+ (i./ +400 year))))
(def: #export common-months
(Row Nat)
(row 31 28 31
30 31 30
31 31 30
31 30 31))
(def: #export leap-year-months
(Row Nat)
(|> common-months
(row.update 1 inc)
try.assume))
(def: (divisible? factor input)
(-> Int Int Bit)
(|> input (i.% factor) (i.= +0)))
## https://en.wikipedia.org/wiki/Leap_year#Algorithm
(def: (leap-year? year)
(-> Int Bit)
(and (divisible? +4 year)
(or (not (divisible? +100 year))
(divisible? +400 year))))
## Based on: https://stackoverflow.com/a/3309340/6823464
(def: lex-date
(Parser Date)
(do p.monad
[utc-year lex-year
_ (l.this "-")
utc-month lex-section
month (case utc-month
+01 (wrap #//month.January)
+02 (wrap #//month.February)
+03 (wrap #//month.March)
+04 (wrap #//month.April)
+05 (wrap #//month.May)
+06 (wrap #//month.June)
+07 (wrap #//month.July)
+08 (wrap #//month.August)
+09 (wrap #//month.September)
+10 (wrap #//month.October)
+11 (wrap #//month.November)
+12 (wrap #//month.December)
_ (p.fail "Invalid month."))
#let [months (if (leap-year? utc-year)
leap-year-months
common-months)
month-days (|> months
(row.nth (.nat (dec utc-month)))
try.assume)]
_ (l.this "-")
utc-day lex-section
_ (p.assert "Invalid day."
(and (i.>= +1 utc-day)
(i.<= (.int month-days) utc-day)))]
(wrap {#year utc-year
#month month
#day (.nat (.dec utc-day))})))
(structure: #export codec
{#.doc (doc "Based on ISO 8601."
"For example: 2017-01-15")}
(Codec Text Date)
(def: encode ..encode)
(def: decode (l.run ..lex-date)))
|
