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

(.module:
  [lux #*
   [abstract
    [equivalence (#+ Equivalence)]
    [order (#+ Order)]
    [enum (#+ Enum)]
    [codec (#+ Codec)]
    [monad (#+ do)]]
   [control
    ["." try (#+ Try)]
    ["." exception (#+ exception:)]
    ["<>" parser
     ["<t>" text (#+ Parser)]]]
   [data
    ["." maybe]
    ["." text ("#\." monoid)]
    [number
     ["n" nat ("#\." decimal)]
     ["i" int]]
    [collection
     ["." list ("#\." fold)]
     ["." dictionary (#+ Dictionary)]]]
   [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))

(exception: #export there_is_no_year_0)

(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])))

  (template [<name> <type> <field>]
    [(def: #export <name>
       (-> Date <type>)
       (|>> :representation (get@ <field>)))]

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

  (structure: #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))))))

  (structure: #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 (<t>.exactly 2 <t>.decimal)))

(def: parse_millis
  (Parser Nat)
  (<>.either (|> (<t>.at_most 3 <t>.decimal)
                 (<>.codec n.decimal)
                 (<>.after (<t>.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
     _ (<t>.this ..separator)
     utc_month ..parse_month
     _ (<t>.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))))

(structure: #export codec
  {#.doc (doc "Based on ISO 8601."
              "For example: 2017-01-15")}
  (Codec Text Date)
  
  (def: encode ..encode)
  (def: decode (<t>.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 (:coerce 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 (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 (:coerce Year year)
                        (maybe.assume (dictionary.get month ..month_by_number))
                        day))))

(structure: #export enum
  (Enum Date)

  (def: &order ..order)

  (def: succ
    (|>> ..days inc ..from_days))

  (def: pred
    (|>> ..days dec ..from_days)))