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

con cal = [Month = source {ThisMonth : int, Year : int,
                           ThisMonthLength : int, PrevMonthLength : int,
                           MondayMonth : month, MondayDay : int,
                           PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
           Day = source date]

class givesDates t = t -> source date

type t = $(cal ++ [Hide = source bool])

fun givesDates_t x = x.Day

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 <- source {Year = year, Month = month, Day = day};
    hide <- source True;
    return {Month = minf, Day = day, Hide = hide}

fun render' action 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 <- signal 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={action thisDate; set 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 render t = <xml>
  <dyn signal={date <- signal t.Day;
               return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/>
  <dyn signal={hd <- signal t.Hide;
               if hd then
                   return <xml><button value="Choose" onclick={set t.Hide False}/></xml>
               else
                   main <- render' (fn _ => return ()) (t -- #Hide);
                   return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/>
</xml>

type calendarCtl = $cal

fun givesDates_calendarCtl x = x.Day

fun createCalendarCtl 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 <- source {Year = year, Month = month, Day = day};
    return {Month = minf, Day = day}

fun renderCalendarCtl action ctl =
    <xml>
      <dyn signal={render' action ctl}/>
    </xml>

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

fun value [t ::: Type] (gd : givesDates t) t = signal (gd t)