adam@2: style calendar
adam@2: style prev
adam@2: style this
adam@2: style next
adam@2: style weekday
adam@2: style curday
adam@2: style otherday
adam@2: 
adam@2: datatype month = Prev | This | Next
adam@2: 
adam@2: type t = {Month : source {ThisMonth : int, Year : int,
adam@2:                           ThisMonthLength : int, PrevMonthLength : int,
adam@2:                           MondayMonth : month, MondayDay : int,
adam@2:                           PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
adam@2:           Day : source int}
adam@2: 
adam@2: fun pad len n =
adam@2:     let
adam@2:         val s = show n
adam@2: 
adam@2:         fun pad' len s =
adam@2:             if len <= 0 then
adam@2:                 s
adam@2:             else
adam@2:                 pad' (len-1) ("0" ^ s)
adam@2:     in
adam@2:         pad' (len - String.length s) s
adam@2:     end
adam@2: 
adam@2: fun monthLen m =
adam@2:     let
adam@2:         fun f n tm =
adam@2:             let
adam@2:                 val next = addSeconds tm (60 * 60 * 24)
adam@2:                 val nextMon = readError (timef "%m" next)
adam@2:             in
adam@2:                 if nextMon = m.Month then
adam@2:                     f (n+1) next
adam@2:                 else
adam@2:                     n
adam@2:             end
adam@2:     in
adam@2:         f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00"))
adam@2:     end
adam@2: 
adam@2: fun weekdayToNum s =
adam@2:     case s of
adam@2:         "Mon" => 0
adam@2:       | "Tue" => 1
adam@2:       | "Wed" => 2
adam@2:       | "Thu" => 3
adam@2:       | "Fri" => 4
adam@2:       | "Sat" => 5
adam@2:       | "Sun" => 6
adam@2:       | _ => error <xml>Datebox: Bad weekday name</xml>
adam@2: 
adam@2: fun timeOfMonth my =
adam@2:     readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00")
adam@2: 
adam@3: fun monthInfo' this =
adam@2:     let
adam@2:         val prev = if this.Month = 1 then
adam@2:                        {Month = 12, Year = this.Year - 1}
adam@2:                    else
adam@2:                        {Month = this.Month-1, Year = this.Year}
adam@2:         val prevLen = monthLen prev
adam@2: 
adam@2:         val next = if this.Month = 12 then
adam@2:                        {Month = 1, Year = this.Year + 1}
adam@2:                    else
adam@2:                        {Month = this.Month + 1, Year = this.Year}
adam@2: 
adam@2:         val firstDow = weekdayToNum (timef "%a" (timeOfMonth this))
adam@2:     in
adam@2:         {ThisMonth = this.Month, Year = this.Year,
adam@2:          ThisMonthLength = monthLen this,
adam@2:          PrevMonthLength = prevLen,
adam@2:          MondayMonth = if firstDow = 0 then This else Prev,
adam@2:          MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1),
adam@2:          PrevMonthName = timef "%b" (timeOfMonth prev),
adam@2:          ThisMonthName = timef "%b" (timeOfMonth this),
adam@2:          NextMonthName = timef "%b" (timeOfMonth next)}
adam@2:     end
adam@2: 
adam@3: fun monthInfo this = return (monthInfo' this)
adam@3: 
adam@2: val create =
adam@2:     tm <- now;
adam@2:     year <- return (readError (timef "%Y" tm));
adam@2:     month <- return (readError (timef "%m" tm));
adam@3:     month <- source (monthInfo' {Month = month, Year = year});
adam@2:     day <- return (readError (timef "%d" tm));
adam@2:     day <- source day;
adam@2:     return {Month = month, Day = day}
adam@2: 
adam@2: fun render (t : t) = <xml>
adam@2:   <dyn signal={minf <- signal t.Month;
adam@2:                let
adam@2:                    fun rows month day =
adam@2:                        let
adam@2:                            fun row month day weekday =
adam@2:                                if weekday >= 7 then
adam@2:                                    <xml/>
adam@2:                                else
adam@2:                                    <xml>
adam@2:                                      <td class={case month of
adam@2:                                                     This => curday
adam@2:                                                   | _ => otherday}>{[day]}</td>
adam@2:                                      {let
adam@2:                                           val (month, day) =
adam@2:                                               case month of
adam@2:                                                   Prev => if day = minf.PrevMonthLength then
adam@2:                                                               (This, 1)
adam@2:                                                           else
adam@2:                                                               (Prev, day+1)
adam@2:                                                 | This => if day = minf.ThisMonthLength then
adam@2:                                                               (Next, 1)
adam@2:                                                           else
adam@2:                                                               (This, day+1)
adam@2:                                                 | Next => (Next, day+1)
adam@2:                                       in
adam@2:                                           row month day (weekday+1)
adam@2:                                       end}
adam@2:                                    </xml>
adam@2:                        in
adam@2:                            case month of
adam@2:                                Next => <xml/>
adam@2:                              | _ =>
adam@2:                                <xml>
adam@2:                                  <tr>{row month day 0}</tr>
adam@2:                                  {let
adam@2:                                       val next =
adam@2:                                           case month of
adam@2:                                               Prev => Some (This, day + 7 - minf.PrevMonthLength)
adam@2:                                             | This =>
adam@2:                                               Some (if day + 7 > minf.ThisMonthLength then
adam@2:                                                         (Next, day + 7 - minf.ThisMonthLength)
adam@2:                                                     else
adam@2:                                                         (This, day + 7))
adam@2:                                             | Next => None
adam@2:                                   in
adam@2:                                       case next of
adam@2:                                           None => <xml/>
adam@2:                                         | Some (month, day) => rows month day
adam@2:                                   end}
adam@2:                                </xml>
adam@2:                        end
adam@2:                in
adam@2:                    return <xml>
adam@2:                      <table class={calendar}>
adam@2:                        <tr>
adam@3:                          <th class={prev} colspan={2}
adam@3:                              onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
adam@3:                                                                   {Month = 12, Year = minf.Year - 1}
adam@3:                                                               else
adam@3:                                                                   {Month = minf.ThisMonth - 1, Year = minf.Year}));
adam@3:                                       set t.Day 1;
adam@3:                                       set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
adam@3:                          <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
adam@3:                          <th class={next} colspan={2}
adam@3:                              onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
adam@3:                                                                   {Month = 1, Year = minf.Year + 1}
adam@3:                                                               else
adam@3:                                                                   {Month = minf.ThisMonth + 1, Year = minf.Year}));
adam@3:                                       set t.Day 1;
adam@3:                                       set t.Month minf}>{[minf.NextMonthName]} >></th>
adam@2:                        </tr>
adam@2:                        <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>
adam@2:                        {rows minf.MondayMonth minf.MondayDay}
adam@2:                      </table>
adam@2:                    </xml>
adam@2:                end}/>
adam@2:   </xml>
adam@2: 
adam@2: fun value t =
adam@2:     month <- signal t.Month;
adam@2:     day <- signal t.Day;
adam@3:     return {Year = month.Year, Month = month.ThisMonth, Day = day}