path: root/stdlib/source/library/lux/time/date.lux

(.using
 [library
  [lux "*"
   [abstract
    [equivalence {"+" Equivalence}]
    [order {"+" Order}]
    [enum {"+" Enum}]
    [codec {"+" Codec}]
    [monad {"+" do}]]
   [control
    ["[0]" maybe]
    ["[0]" try {"+" Try}]
    ["[0]" exception {"+" exception:}]
    ["<>" parser
     ["<[0]>" text {"+" Parser}]]]
   [data
    ["[0]" text ("[1]#[0]" monoid)]
    [collection
     ["[0]" list ("[1]#[0]" mix)]
     ["[0]" dictionary {"+" Dictionary}]]]
   [math
    [number
     ["n" nat ("[1]#[0]" decimal)]
     ["i" int]]]
   [type
    [abstract {"-" pattern}]]]]
 ["[0]" // "_"
  ["[1][0]" year {"+" Year}]
  ["[1][0]" month {"+" Month}]])

(def: month_by_number
  (Dictionary Nat Month)
  (list#mix (function (_ month mapping)
              (dictionary.has (//month.number month) month mapping))
            (dictionary.empty 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: (invalid_day? year month day)
  (-> Year Month Nat Bit)
  (or (n.< ..minimum_day day)
      (n.> (..month_days year month) day)))

(exception: .public (invalid_day [year Year
                                  month Month
                                  day Nat])
  (exception.report
   "Value" (n#encoded day)
   "Minimum" (n#encoded ..minimum_day)
   "Maximum" (n#encoded (..month_days year month))
   "Year" (# //year.codec encoded year)
   "Month" (n#encoded (//month.number month))))

(def: (padded value)
  (-> Nat Text)
  (let [digits (n#encoded value)]
    (if (n.< 10 value)
      (text#composite "0" digits)
      digits)))

(def: separator
  "-")

(abstract: .public Date
  (Record
   [#year Year
    #month Month
    #day Nat])

  (def: .public (date year month day_of_month)
    (-> Year Month Nat (Try Date))
    (if (..invalid_day? year month day_of_month)
      (exception.except ..invalid_day [year month day_of_month])
      {try.#Success
       (abstraction
        [#year year
         #month month
         #day day_of_month])}))

  (def: .public epoch
    Date
    (try.trusted
     (..date //year.epoch
             {//month.#January}
             ..minimum_day)))

  (template [<name> <type> <field>]
    [(def: .public <name>
       (-> Date <type>)
       (|>> representation (the <field>)))]

    [year Year #year]
    [month Month #month]
    [day_of_month Nat #day]
    )

  (implementation: .public equivalence
    (Equivalence Date)
    
    (def: (= reference sample)
      (let [reference (representation reference)
            sample (representation sample)]
        (and (# //year.equivalence =
                (the #year reference)
                (the #year sample))
             (# //month.equivalence =
                (the #month reference)
                (the #month sample))
             (n.= (the #day reference)
                  (the #day sample))))))

  (implementation: .public order
    (Order Date)
    
    (def: equivalence ..equivalence)
    
    (def: (< reference sample)
      (let [reference (representation reference)
            sample (representation sample)]
        (or (# //year.order <
               (the #year reference)
               (the #year sample))
            (and (# //year.equivalence =
                    (the #year reference)
                    (the #year sample))
                 (or (# //month.order <
                        (the #month reference)
                        (the #month sample))
                     (and (# //month.order =
                             (the #month reference)
                             (the #month sample))
                          (n.< (the #day reference)
                               (the #day sample)))))))))
  )

(def: section_parser
  (Parser Nat)
  (<>.codec n.decimal (<text>.exactly 2 <text>.decimal)))

(def: millis_parser
  (Parser Nat)
  (<>.either (|> (<text>.at_most 3 <text>.decimal)
                 (<>.codec n.decimal)
                 (<>.after (<text>.this ".")))
             (# <>.monad in 0)))

(template [<minimum> <maximum> <parser> <exception>]
  [(exception: .public (<exception> [value Nat])
     (exception.report
      "Value" (n#encoded value)
      "Minimum" (n#encoded <minimum>)
      "Maximum" (n#encoded <maximum>)))

   (def: <parser>
     (Parser Nat)
     (do <>.monad
       [value ..section_parser]
       (if (or (n.< <minimum> value)
               (n.> <maximum> value))
         (<>.lifted (exception.except <exception> [value]))
         (in value))))]

  [1 12 month_parser invalid_month]
  )

(def: .public parser
  (Parser Date)
  (do <>.monad
    [utc_year //year.parser
     _ (<text>.this ..separator)
     utc_month ..month_parser
     _ (<text>.this ..separator)
     .let [month (maybe.trusted (dictionary.value utc_month ..month_by_number))]
     utc_day ..section_parser]
    (<>.lifted (..date utc_year month utc_day))))

(def: (format value)
  (-> Date Text)
  (all text#composite
       (# //year.codec encoded (..year value))
       ..separator (..padded (|> value ..month //month.number))
       ..separator (..padded (..day_of_month value))))

(implementation: .public codec
  (Codec Text Date)
  
  (def: encoded ..format)
  (def: decoded (<text>.result ..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 (-- ..days_per_leap)))

(def: last_era_day
  (.int (-- ..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)
      (-- utc_year)
      utc_year)))

... http://howardhinnant.github.io/date_algorithms.html
(def: .public (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 (-- //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 (-- (..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: .public (of_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)
               (++ year)
               year)]
    ... Coercing, because the year is already in internal form.
    (try.trusted
     (..date (as Year year)
             (maybe.trusted (dictionary.value month ..month_by_number))
             day))))

(implementation: .public enum
  (Enum Date)

  (def: order ..order)

  (def: succ
    (|>> ..days ++ ..of_days))

  (def: pred
    (|>> ..days -- ..of_days)))