style calendar
style prev
style this
style next
style weekday
style curday
style otherday
style selday

datatype month = Prev | This | Next

type date = {Year : int, Month : int, Day : int}
val date_eq = mkEq (fn {Year = y, Month = m, Day = d} {Year = y', Month = m', Day = d'} =>
                       y = y' && m = m' && d = d')
val date_ord = mkOrd {Lt = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
                              y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 < d2),
                      Le = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
                              y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 <= d2)}

type t = {Month : source {ThisMonth : int, Year : int,
                          ThisMonthLength : int, PrevMonthLength : int,
                          MondayMonth : month, MondayDay : int,
                          PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
          Day : ChangePoller.changePoller date}
         
fun pad len n =
    let
        val s = show n

        fun pad' len s =
            if len <= 0 then
                s
            else
                pad' (len-1) ("0" ^ s)
    in
        pad' (len - String.length s) s
    end

fun time {Year = y, Month = m, Day = d} = readError (show y ^ "-" ^ pad 2 m ^ "-" ^ pad 2 d ^ " 00:00:00")
fun date tm =
    let
        val y = readError (timef "%Y" tm)
        val m = readError (timef "%m" tm)
        val d = readError (timef "%d" tm)
    in
        {Year = y, Month = m, Day = d}
    end

fun monthLen m =
    let
        fun f n tm =
            let
                val next = addSeconds tm (60 * 60 * 24)
                val nextMon = readError (timef "%m" next)
            in
                if nextMon = m.Month then
                    f (n+1) next
                else
                    n
            end
    in
        f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00"))
    end

fun weekdayToNum s =
    case s of
        "Mon" => 0
      | "Tue" => 1
      | "Wed" => 2
      | "Thu" => 3
      | "Fri" => 4
      | "Sat" => 5
      | "Sun" => 6
      | _ => error <xml>Datebox: Bad weekday name</xml>

fun timeOfMonth my =
    readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00")

fun monthInfo' this =
    let
        val prev = if this.Month = 1 then
                       {Month = 12, Year = this.Year - 1}
                   else
                       {Month = this.Month-1, Year = this.Year}
        val prevLen = monthLen prev

        val next = if this.Month = 12 then
                       {Month = 1, Year = this.Year + 1}
                   else
                       {Month = this.Month + 1, Year = this.Year}

        val firstDow = weekdayToNum (timef "%a" (timeOfMonth this))
    in
        {ThisMonth = this.Month, Year = this.Year,
         ThisMonthLength = monthLen this,
         PrevMonthLength = prevLen,
         MondayMonth = if firstDow = 0 then This else Prev,
         MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1),
         PrevMonthName = timef "%b" (timeOfMonth prev),
         ThisMonthName = timef "%b" (timeOfMonth this),
         NextMonthName = timef "%b" (timeOfMonth next)}
    end

fun monthInfo this = return (monthInfo' this)

fun create tm =
    year <- return (readError (timef "%Y" tm));
    month <- return (readError (timef "%m" tm));
    minf <- source (monthInfo' {Month = month, Year = year});
    day <- return (readError (timef "%d" tm));
    day <- ChangePoller.create {Year = year, Month = month, Day = day};
    return {Month = minf, Day = day}

fun render' t =
    minf <- signal t.Month;
    let
        fun rows year month day =
            let
                fun row year month day weekday =
                    if weekday >= 7 then
                        <xml/>
                    else
                        <xml>
                          <dyn signal={let
                                           val thisDate = {Year = year,
                                                           Month = case month of
                                                                       Prev => if minf.ThisMonth = 1 then 12 else minf.ThisMonth - 1
                                                                     | This => minf.ThisMonth
                                                                     | Next => if minf.ThisMonth = 12 then 1 else minf.ThisMonth + 1,
                                                           Day = day}
                                       in
                                           cday <- ChangePoller.value t.Day;
                                           return (if Record.equal thisDate cday then
                                                       <xml><td class={selday}>{[day]}</td></xml>
                                                   else case month of
                                                            This => <xml><td class={curday}
                                                                             onclick={set (ChangePoller.ctl t.Day) thisDate}>{[day]}</td></xml>
                                                          | _ => <xml><td class={otherday}>{[day]}</td></xml>)
                                       end}/>
                            {let
                                 val (year, month, day) =
                                     case month of
                                         Prev => if day = minf.PrevMonthLength then
                                                     (if minf.ThisMonth = 1 then year + 1 else year, This, 1)
                                                 else
                                                     (year, Prev, day+1)
                                       | This => if day = minf.ThisMonthLength then
                                                     (if minf.ThisMonth = 12 then year + 1 else year, Next, 1)
                                                 else
                                                     (year, This, day+1)
                                       | Next => (year, Next, day+1)
                             in
                                 row year month day (weekday+1)
                             end}
                          </xml>
            in
                case month of
                    Next => <xml/>
                  | _ =>
                    <xml>
                      <tr>{row year month day 0}</tr>
                      {let
                           val next =
                               case month of
                                   Prev => Some (if minf.ThisMonth = 1 then year + 1 else year, This, day + 7 - minf.PrevMonthLength)
                                 | This =>
                                   Some (if day + 7 > minf.ThisMonthLength then
                                             (if minf.ThisMonth = 12 then year + 1 else year, Next, day + 7 - minf.ThisMonthLength)
                                         else
                                             (year, This, day + 7))
                                 | Next => None
                       in
                           case next of
                               None => <xml/>
                             | Some (year, month, day) => rows year month day
                       end}
                    </xml>
            end
    in
        return <xml>
          <table class={calendar}>
            <tr>
              <th class={prev} colspan={2}
                  onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
                                                       {Month = 12, Year = minf.Year - 1}
                                                   else
                                                       {Month = minf.ThisMonth - 1, Year = minf.Year}));
                           set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
                  <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
                  <th class={next} colspan={2}
                      onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
                                                           {Month = 1, Year = minf.Year + 1}
                                                       else
                                                           {Month = minf.ThisMonth + 1, Year = minf.Year}));
                               set t.Month minf}>{[minf.NextMonthName]} >></th>
            </tr>
            <tr class={weekday}> <th>M</th> <th>Tu</th> <th>W</th> <th>Th</th> <th>F</th> <th>Sa</th> <th>Su</th> </tr>
            {rows (if minf.ThisMonth = 1 && (case minf.MondayMonth of This => False | _ => True) then
                       minf.Year - 1
                   else
                       minf.Year) minf.MondayMonth minf.MondayDay}
          </table>
        </xml>
    end

fun addListener f ctl =
    ChangePoller.addChangeListener f 100 ctl.Day

val gui_t = Gui.mkGui 
                (fn ctl =>
                    <xml>
                      <dyn signal={render' ctl}/>
                    </xml>)

fun set ctl day =
    minf <- rpc (monthInfo (day -- #Day));
    Basis.set ctl.Month minf;
    Basis.set (ChangePoller.ctl ctl.Day) day

fun value ctl = ChangePoller.value ctl.Day