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