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

datatype month = Prev | This | Next

type t = {Month : source {ThisMonth : int, Year : int,
                          ThisMonthLength : int, PrevMonthLength : int,
                          MondayMonth : month, MondayDay : int,
                          PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
          Day : source int}

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

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

fun render (t : t) = <xml>
  <dyn signal={minf <- signal t.Month;
               let
                   fun rows month day =
                       let
                           fun row month day weekday =
                               if weekday >= 7 then
                                   <xml/>
                               else
                                   <xml>
                                     <td class={case month of
                                                    This => curday
                                                  | _ => otherday}>{[day]}</td>
                                     {let
                                          val (month, day) =
                                              case month of
                                                  Prev => if day = minf.PrevMonthLength then
                                                              (This, 1)
                                                          else
                                                              (Prev, day+1)
                                                | This => if day = minf.ThisMonthLength then
                                                              (Next, 1)
                                                          else
                                                              (This, day+1)
                                                | Next => (Next, day+1)
                                      in
                                          row month day (weekday+1)
                                      end}
                                   </xml>
                       in
                           case month of
                               Next => <xml/>
                             | _ =>
                               <xml>
                                 <tr>{row month day 0}</tr>
                                 {let
                                      val next =
                                          case month of
                                              Prev => Some (This, day + 7 - minf.PrevMonthLength)
                                            | This =>
                                              Some (if day + 7 > minf.ThisMonthLength then
                                                        (Next, day + 7 - minf.ThisMonthLength)
                                                    else
                                                        (This, day + 7))
                                            | Next => None
                                  in
                                      case next of
                                          None => <xml/>
                                        | Some (month, day) => rows 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.Day 1;
                                      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.Day 1;
                                      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 minf.MondayMonth minf.MondayDay}
                     </table>
                   </xml>
               end}/>
  </xml>

fun value t =
    month <- signal t.Month;
    day <- signal t.Day;
    return {Year = month.Year, Month = month.ThisMonth, Day = day}