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

(abstract: #export Duration
  {#.doc "Durations have a resolution of milliseconds."}
  Int

  (def: #export from-millis
    (-> Int Duration)
    (|>> :abstraction))

  (def: #export to-millis
    (-> Duration Int)
    (|>> :representation))

  (do-template [<name> <op>]
    [(def: #export (<name> param subject)
       (-> Duration Duration Duration)
       (:abstraction (<op> (:representation param) (:representation subject))))]

    [merge i/+]
    [frame i/%]
    )

  (def: #export (scale scalar duration)
    (-> Int Duration Duration)
    (:abstraction (i/* scalar (:representation duration))))

  (def: #export (query param subject)
    (-> Duration Duration Int)
    (i// (:representation param) (:representation subject)))

  (structure: #export _ (Equivalence Duration)
    (def: (= param subject)
      (i/= (:representation param) (:representation subject))))

  (structure: #export _ (Order Duration)
    (def: eq Equivalence<Duration>)
    (do-template [<name> <op>]
      [(def: (<name> param subject)
         (<op> (:representation param) (:representation subject)))]

      [<  i/<]
      [<= i/<=]
      [>  i/>]
      [>= i/>=]
      ))

  (do-template [<name> <op>]
    [(def: #export (<name> duration)
       (-> Duration Bit)
       (<op> 0 (:representation duration)))]

    [positive? i/>]
    [negative? i/<]
    [neutral?  i/=])
  )

(def: #export empty Duration (from-millis 0))
(def: #export milli Duration (from-millis 1))
(def: #export second Duration (scale 1_000 milli))
(def: #export minute Duration (scale 60 second))
(def: #export hour Duration (scale 60 minute))
(def: #export day Duration (scale 24 hour))
(def: #export week Duration (scale 7 day))
(def: #export normal-year Duration (scale 365 day))
(def: #export leap-year Duration (merge day normal-year))

(structure: #export _ (Monoid Duration)
  (def: identity empty)
  (def: compose merge))

(def: (encode duration)
  (-> Duration Text)
  (if (:: Equivalence<Duration> = empty duration)
    "0ms"
    (let [signed? (negative? duration)
          [days time-left] [(query day duration) (frame day duration)]
          days (if signed?
                 (int/abs days)
                 days)
          time-left (if signed?
                      (scale -1 time-left)
                      time-left)
          [hours time-left] [(query hour time-left) (frame hour time-left)]
          [minutes time-left] [(query minute time-left) (frame minute time-left)]
          [seconds time-left] [(query second time-left) (frame second time-left)]
          millis (to-millis time-left)]
      ($_ text/compose
          (if signed? "-" "")
          (if (i/= 0 days) "" (text/compose (int/encode days) "D"))
          (if (i/= 0 hours) "" (text/compose (int/encode hours) "h"))
          (if (i/= 0 minutes) "" (text/compose (int/encode minutes) "m"))
          (if (i/= 0 seconds) "" (text/compose (int/encode seconds) "s"))
          (if (i/= 0 millis) "" (text/compose (int/encode millis) "ms"))
          ))))

(def: (lex-section suffix)
  (-> Text (l.Lexer Int))
  (|> (p.codec number.Codec<Text,Int> (l.many l.decimal))
      (p.before (p.seq (l.this suffix) (p.not l.alpha)))
      (p.default 0)))

(def: lex-duration
  (l.Lexer Duration)
  (do p.Monad<Parser>
    [signed? (l.this? "-")
     #let [sign (function (_ raw) (if signed? (i/* -1 raw) raw))]
     utc-day (lex-section "D")
     utc-hour (lex-section "h")
     utc-minute (lex-section "m")
     _ (p.assert "Invalid minute."
                 (and (i/>= 0 utc-minute)
                      (i/<= 59 utc-minute)))
     utc-second (lex-section "s")
     _ (p.assert "Invalid second."
                 (and (i/>= 0 utc-second)
                      (i/<= 59 utc-second)))
     utc-millis (lex-section "ms")
     _ (p.assert "Invalid milli-seconds."
                 (and (i/>= 0 utc-millis)
                      (i/<= 999 utc-millis)))]
    (wrap (|> empty
              (merge (scale (sign utc-day) day))
              (merge (scale (sign utc-hour) hour))
              (merge (scale (sign utc-minute) minute))
              (merge (scale (sign utc-second) second))
              (merge (scale (sign utc-millis) milli))))))

(def: (decode input)
  (-> Text (e.Error Duration))
  (l.run input lex-duration))

(structure: #export _
  {#.doc "For example: 15D21h14m51s827ms"}
  (Codec Text Duration)
  (def: encode encode)
  (def: decode decode))