(.module:
  [lux #*
   [control
    equivalence
    order
    enum
    codec
    ["p" parser]
    [monad (#+ do)]]
   [data
    ["e" error]
    ["." maybe]
    ["." number ("int/." Codec<Text,Int>)]
    [text ("text/." Monoid<Text>)
     ["l" lexer]]
    [collection
     ["." row (#+ Row row)]]]])

(type: #export Year Int)

(type: #export Month
  #January
  #February
  #March
  #April
  #May
  #June
  #July
  #August
  #September
  #October
  #November
  #December)

(structure: #export _ (Equivalence Month)
  (def: (= reference sample)
    (case [reference sample]
      (^template [<tag>]
        [<tag> <tag>]
        #1)
      ([#January]
       [#February]
       [#March]
       [#April]
       [#May]
       [#June]
       [#July]
       [#August]
       [#September]
       [#October]
       [#November]
       [#December])

      _
      #0)))

(def: (month-to-nat month)
  (-> Month Nat)
  (case month
    #January   +0
    #February  +1
    #March     +2
    #April     +3
    #May       +4
    #June      +5
    #July      +6
    #August    +7
    #September +8
    #October   +9
    #November +10
    #December +11))

(structure: #export _ (Order Month)
  (def: eq Equivalence<Month>)
  (do-template [<name> <comp>]
    [(def: (<name> reference sample)
       (<comp> (month-to-nat reference) (month-to-nat sample)))]

    [<  n/<]
    [<= n/<=]
    [>  n/>]
    [>= n/>=]
    ))

(structure: #export _ (Enum Month)
  (def: order Order<Month>)
  (def: (succ month)
    (case month
      #January   #February
      #February  #March
      #March     #April
      #April     #May
      #May       #June
      #June      #July
      #July      #August
      #August    #September
      #September #October
      #October   #November
      #November  #December
      #December  #January))
  (def: (pred month)
    (case month
      #February  #January
      #March     #February
      #April     #March
      #May       #April
      #June      #May
      #July      #June
      #August    #July
      #September #August
      #October   #September
      #November  #October
      #December  #November
      #January   #December)))

(type: #export Day
  #Sunday
  #Monday
  #Tuesday
  #Wednesday
  #Thursday
  #Friday
  #Saturday)

(structure: #export _ (Equivalence Day)
  (def: (= reference sample)
    (case [reference sample]
      (^template [<tag>]
        [<tag> <tag>]
        #1)
      ([#Sunday]
       [#Monday]
       [#Tuesday]
       [#Wednesday]
       [#Thursday]
       [#Friday]
       [#Saturday])

      _
      #0)))

(def: (day-to-nat day)
  (-> Day Nat)
  (case day
    #Sunday    +0
    #Monday    +1
    #Tuesday   +2
    #Wednesday +3
    #Thursday  +4
    #Friday    +5
    #Saturday  +6))

(structure: #export _ (Order Day)
  (def: eq Equivalence<Day>)
  (do-template [<name> <comp>]
    [(def: (<name> reference sample)
       (<comp> (day-to-nat reference) (day-to-nat sample)))]

    [<  n/<]
    [<= n/<=]
    [>  n/>]
    [>= n/>=]
    ))

(structure: #export _ (Enum Day)
  (def: order Order<Day>)
  (def: (succ day)
    (case day
      #Sunday    #Monday
      #Monday    #Tuesday
      #Tuesday   #Wednesday
      #Wednesday #Thursday
      #Thursday  #Friday
      #Friday    #Saturday
      #Saturday  #Sunday))
  (def: (pred day)
    (case day
      #Monday    #Sunday
      #Tuesday   #Monday
      #Wednesday #Tuesday
      #Thursday  #Wednesday
      #Friday    #Thursday
      #Saturday  #Friday
      #Sunday    #Saturday)))

(type: #export Date
  {#year Year
   #month Month
   #day Nat})

(structure: #export _ (Equivalence Date)
  (def: (= reference sample)
    (and (i/= (get@ #year reference)
              (get@ #year sample))
         (:: Equivalence<Month> =
             (get@ #month reference)
             (get@ #month sample))
         (n/= (get@ #day reference)
              (get@ #day sample)))))

(def: (date/< reference sample)
  (-> Date Date Bit)
  (or (i/< (get@ #year reference)
           (get@ #year sample))
      (:: Order<Month> <
          (get@ #month reference)
          (get@ #month sample))
      (n/< (get@ #day reference)
           (get@ #day sample))))

(structure: #export _ (Order Date)
  (def: eq Equivalence<Date>)
  (def: < date/<)
  (def: (> reference sample)
    (date/< sample reference))
  (def: (<= reference sample)
    (or (date/< reference sample)
        (:: Equivalence<Date> = reference sample)))
  (def: (>= reference sample)
    (or (date/< sample reference)
        (:: Equivalence<Date> = sample reference))))

## Based on this: https://stackoverflow.com/a/42936293/6823464
(def: (pad value)
  (-> Int Text)
  (if (i/< 10 value)
    (text/compose "0" (int/encode value))
    (int/encode value)))

(def: (encode [year month day])
  (-> Date Text)
  ($_ text/compose
      (int/encode year) "-"
      (pad (|> month month-to-nat inc .int)) "-"
      (pad (|> day .int))))

(def: lex-year
  (l.Lexer Int)
  (do p.Monad<Parser>
    [sign? (p.maybe (l.this "-"))
     raw-year (p.codec number.Codec<Text,Int> (l.many l.decimal))
     #let [signum (case sign?
                    #.None      1
                    (#.Some _) -1)]]
    (wrap (i/* signum raw-year))))

(def: lex-section
  (l.Lexer Int)
  (p.codec number.Codec<Text,Int> (l.exactly +2 l.decimal)))

(def: (leap-years year)
  (-> Int Int)
  (|> (i// 4 year)
      (i/- (i// 100 year))
      (i/+ (i// 400 year))))

(def: normal-months
  (Row Nat)
  (row +31 +28 +31
       +30 +31 +30
       +31 +31 +30
       +31 +30 +31))

(def: leap-year-months
  (Row Nat)
  (row.update [+1] inc normal-months))

(def: (divisible? factor input)
  (-> Int Int Bit)
  (|> input (i/% factor) (i/= 0)))

(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
  (l.Lexer Date)
  (do p.Monad<Parser>
    [utc-year lex-year
     _ (l.this "-")
     utc-month lex-section
     _ (p.assert "Invalid month."
                 (and (i/>= 1 utc-month)
                      (i/<= 12 utc-month)))
     #let [months (if (leap-year? utc-year)
                    leap-year-months
                    normal-months)
           month-days (|> months
                          (row.nth (.nat (dec utc-month)))
                          maybe.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 (case utc-month
                    1 #January
                    2 #February
                    3 #March
                    4 #April
                    5 #May
                    6 #June
                    7 #July
                    8 #August
                    9 #September
                    10 #October
                    11 #November
                    12 #December
                    _ (undefined))
           #day (.nat utc-day)})))

(def: (decode input)
  (-> Text (e.Error Date))
  (l.run input lex-date))

(structure: #export _
  {#.doc "Based on ISO 8601.

          For example: 2017-01-15"}
  (Codec Text Date)
  (def: encode encode)
  (def: decode decode))