aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/library/lux/time/date.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/library/lux/time/date.lux')
-rw-r--r--stdlib/source/library/lux/time/date.lux349
1 files changed, 349 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/time/date.lux b/stdlib/source/library/lux/time/date.lux
new file mode 100644
index 000000000..e8de6d99e
--- /dev/null
+++ b/stdlib/source/library/lux/time/date.lux
@@ -0,0 +1,349 @@
+(.module:
+ [library
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]
+ [order (#+ Order)]
+ [enum (#+ Enum)]
+ [codec (#+ Codec)]
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
+ ["<>" parser
+ ["<text>" text (#+ Parser)]]]
+ [data
+ ["." maybe]
+ ["." text ("#\." monoid)]
+ [collection
+ ["." list ("#\." fold)]
+ ["." dictionary (#+ Dictionary)]]]
+ [math
+ [number
+ ["n" nat ("#\." decimal)]
+ ["i" int]]]
+ [type
+ abstract]]]
+ ["." // #_
+ ["#." year (#+ Year)]
+ ["#." month (#+ Month)]])
+
+(def: month_by_number
+ (Dictionary Nat Month)
+ (list\fold (function (_ month mapping)
+ (dictionary.put (//month.number month) month mapping))
+ (dictionary.new n.hash)
+ //month.year))
+
+(def: minimum_day
+ 1)
+
+(def: (month_days year month)
+ (-> Year Month Nat)
+ (if (//year.leap? year)
+ (//month.leap_year_days month)
+ (//month.days month)))
+
+(def: (day_is_within_limits? year month day)
+ (-> Year Month Nat Bit)
+ (and (n.>= ..minimum_day day)
+ (n.<= (..month_days year month) day)))
+
+(exception: #export (invalid_day {year Year} {month Month} {day Nat})
+ (exception.report
+ ["Value" (n\encode day)]
+ ["Minimum" (n\encode ..minimum_day)]
+ ["Maximum" (n\encode (..month_days year month))]
+ ["Year" (\ //year.codec encode year)]
+ ["Month" (n\encode (//month.number month))]))
+
+(def: (pad value)
+ (-> Nat Text)
+ (let [digits (n\encode value)]
+ (if (n.< 10 value)
+ (text\compose "0" digits)
+ digits)))
+
+(def: separator
+ "-")
+
+(abstract: #export Date
+ {#year Year
+ #month Month
+ #day Nat}
+
+ (def: #export (date year month day)
+ (-> Year Month Nat (Try Date))
+ (if (..day_is_within_limits? year month day)
+ (#try.Success
+ (:abstraction
+ {#year year
+ #month month
+ #day day}))
+ (exception.throw ..invalid_day [year month day])))
+
+ (def: #export epoch
+ Date
+ (try.assume (..date //year.epoch
+ #//month.January
+ ..minimum_day)))
+
+ (template [<name> <type> <field>]
+ [(def: #export <name>
+ (-> Date <type>)
+ (|>> :representation (get@ <field>)))]
+
+ [year Year #year]
+ [month Month #month]
+ [day_of_month Nat #day]
+ )
+
+ (implementation: #export equivalence
+ (Equivalence Date)
+
+ (def: (= reference sample)
+ (let [reference (:representation reference)
+ sample (:representation sample)]
+ (and (\ //year.equivalence =
+ (get@ #year reference)
+ (get@ #year sample))
+ (\ //month.equivalence =
+ (get@ #month reference)
+ (get@ #month sample))
+ (n.= (get@ #day reference)
+ (get@ #day sample))))))
+
+ (implementation: #export order
+ (Order Date)
+
+ (def: &equivalence ..equivalence)
+
+ (def: (< reference sample)
+ (let [reference (:representation reference)
+ sample (:representation sample)]
+ (or (\ //year.order <
+ (get@ #year reference)
+ (get@ #year sample))
+ (and (\ //year.equivalence =
+ (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)))))))))
+ )
+
+(def: parse_section
+ (Parser Nat)
+ (<>.codec n.decimal (<text>.exactly 2 <text>.decimal)))
+
+(def: parse_millis
+ (Parser Nat)
+ (<>.either (|> (<text>.at_most 3 <text>.decimal)
+ (<>.codec n.decimal)
+ (<>.after (<text>.this ".")))
+ (\ <>.monad wrap 0)))
+
+(template [<minimum> <maximum> <parser> <exception>]
+ [(exception: #export (<exception> {value Nat})
+ (exception.report
+ ["Value" (n\encode value)]
+ ["Minimum" (n\encode <minimum>)]
+ ["Maximum" (n\encode <maximum>)]))
+
+ (def: <parser>
+ (Parser Nat)
+ (do <>.monad
+ [value ..parse_section]
+ (if (and (n.>= <minimum> value)
+ (n.<= <maximum> value))
+ (wrap value)
+ (<>.lift (exception.throw <exception> [value])))))]
+
+ [1 12 parse_month invalid_month]
+ )
+
+(def: #export parser
+ (Parser Date)
+ (do <>.monad
+ [utc_year //year.parser
+ _ (<text>.this ..separator)
+ utc_month ..parse_month
+ _ (<text>.this ..separator)
+ #let [month (maybe.assume (dictionary.get utc_month ..month_by_number))]
+ utc_day ..parse_section]
+ (<>.lift (..date utc_year month utc_day))))
+
+(def: (encode value)
+ (-> Date Text)
+ ($_ text\compose
+ (\ //year.codec encode (..year value))
+ ..separator (..pad (|> value ..month //month.number))
+ ..separator (..pad (..day_of_month value))))
+
+(implementation: #export codec
+ {#.doc (doc "Based on ISO 8601."
+ "For example: 2017-01-15")}
+ (Codec Text Date)
+
+ (def: encode ..encode)
+ (def: decode (<text>.run ..parser)))
+
+(def: days_per_leap
+ (|> //year.days
+ (n.* 4)
+ (n.+ 1)))
+
+(def: days_per_century
+ (let [leaps_per_century (n./ //year.leap
+ //year.century)]
+ (|> //year.century
+ (n.* //year.days)
+ (n.+ leaps_per_century)
+ (n.- 1))))
+
+(def: days_per_era
+ (let [centuries_per_era (n./ //year.century
+ //year.era)]
+ (|> centuries_per_era
+ (n.* ..days_per_century)
+ (n.+ 1))))
+
+(def: days_since_epoch
+ (let [years::70 70
+ leaps::70 (n./ //year.leap
+ years::70)
+ days::70 (|> years::70
+ (n.* //year.days)
+ (n.+ leaps::70))
+ ## The epoch is being calculated from March 1st, instead of January 1st.
+ january_&_february (n.+ (//month.days #//month.January)
+ (//month.days #//month.February))]
+ (|> 0
+ ## 1600/01/01
+ (n.+ (n.* 4 days_per_era))
+ ## 1900/01/01
+ (n.+ (n.* 3 days_per_century))
+ ## 1970/01/01
+ (n.+ days::70)
+ ## 1970/03/01
+ (n.- january_&_february))))
+
+(def: first_month_of_civil_year 3)
+
+(with_expansions [<pull> +3
+ <push> +9]
+ (def: (internal_month civil_month)
+ (-> Nat Int)
+ (if (n.< ..first_month_of_civil_year civil_month)
+ (i.+ <push> (.int civil_month))
+ (i.- <pull> (.int civil_month))))
+
+ (def: (civil_month internal_month)
+ (-> Int Nat)
+ (.nat (if (i.< +10 internal_month)
+ (i.+ <pull> internal_month)
+ (i.- <push> internal_month)))))
+
+(with_expansions [<up> +153
+ <translation> +2
+ <down> +5]
+ (def: day_of_year_from_month
+ (-> Nat Int)
+ (|>> ..internal_month
+ (i.* <up>)
+ (i.+ <translation>)
+ (i./ <down>)))
+
+ (def: month_from_day_of_year
+ (-> Int Nat)
+ (|>> (i.* <down>)
+ (i.+ <translation>)
+ (i./ <up>)
+ ..civil_month)))
+
+(def: last_era_leap_day
+ (.int (dec ..days_per_leap)))
+
+(def: last_era_day
+ (.int (dec ..days_per_era)))
+
+(def: (civil_year utc_month utc_year)
+ (-> Nat Year Int)
+ (let [## Coercing, because the year is already in external form.
+ utc_year (:as Int utc_year)]
+ (if (n.< ..first_month_of_civil_year utc_month)
+ (dec utc_year)
+ utc_year)))
+
+## http://howardhinnant.github.io/date_algorithms.html
+(def: #export (to_days date)
+ (-> Date Int)
+ (let [utc_month (|> date ..month //month.number)
+ civil_year (..civil_year utc_month (..year date))
+ era (|> (if (i.< +0 civil_year)
+ (i.- (.int (dec //year.era))
+ civil_year)
+ civil_year)
+ (i./ (.int //year.era)))
+ year_of_era (i.- (i.* (.int //year.era)
+ era)
+ civil_year)
+ day_of_year (|> utc_month
+ ..day_of_year_from_month
+ (i.+ (.int (dec (..day_of_month date)))))
+ day_of_era (|> day_of_year
+ (i.+ (i.* (.int //year.days) year_of_era))
+ (i.+ (i./ (.int //year.leap) year_of_era))
+ (i.- (i./ (.int //year.century) year_of_era)))]
+ (|> (i.* (.int ..days_per_era) era)
+ (i.+ day_of_era)
+ (i.- (.int ..days_since_epoch)))))
+
+## http://howardhinnant.github.io/date_algorithms.html
+(def: #export (from_days days)
+ (-> Int Date)
+ (let [days (i.+ (.int ..days_since_epoch) days)
+ era (|> (if (i.< +0 days)
+ (i.- ..last_era_day days)
+ days)
+ (i./ (.int ..days_per_era)))
+ day_of_era (i.- (i.* (.int ..days_per_era) era) days)
+ year_of_era (|> day_of_era
+ (i.- (i./ ..last_era_leap_day day_of_era))
+ (i.+ (i./ (.int ..days_per_century) day_of_era))
+ (i.- (i./ ..last_era_day day_of_era))
+ (i./ (.int //year.days)))
+ year (i.+ (i.* (.int //year.era) era)
+ year_of_era)
+ day_of_year (|> day_of_era
+ (i.- (i.* (.int //year.days) year_of_era))
+ (i.- (i./ (.int //year.leap) year_of_era))
+ (i.+ (i./ (.int //year.century) year_of_era)))
+ month (..month_from_day_of_year day_of_year)
+ day (|> day_of_year
+ (i.- (..day_of_year_from_month month))
+ (i.+ +1)
+ .nat)
+ year (if (n.< ..first_month_of_civil_year month)
+ (inc year)
+ year)]
+ ## Coercing, because the year is already in internal form.
+ (try.assume (..date (:as Year year)
+ (maybe.assume (dictionary.get month ..month_by_number))
+ day))))
+
+(implementation: #export enum
+ (Enum Date)
+
+ (def: &order ..order)
+
+ (def: succ
+ (|>> ..to_days inc ..from_days))
+
+ (def: pred
+ (|>> ..to_days dec ..from_days)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-24 11:35:40 +0000