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@4: style selday
adam@2: 
adam@2: datatype month = Prev | This | Next
adam@2: 
adam@4: type date = {Year : int, Month : int, Day : int}
adam@5: val date_ord = mkOrd {Lt = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
adam@5:                               y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 < d2),
adam@5:                       Le = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
adam@5:                               y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 <= d2)}
adam@4: 
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@4:           Day : source date,
adam@4:           Hide : source bool}
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@5: fun time {Year = y, Month = m, Day = d} = readError (show y ^ "-" ^ pad 2 m ^ "-" ^ pad 2 d ^ " 00:00:00")
adam@5: 
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@4: fun create tm =
adam@2:     year <- return (readError (timef "%Y" tm));
adam@2:     month <- return (readError (timef "%m" tm));
adam@4:     minf <- source (monthInfo' {Month = month, Year = year});
adam@2:     day <- return (readError (timef "%d" tm));
adam@4:     day <- source {Year = year, Month = month, Day = day};
adam@4:     hide <- source True;
adam@4:     return {Month = minf, Day = day, Hide = hide}
adam@2: 
adam@4: fun render' t =
adam@4:     minf <- signal t.Month;
adam@4:     let
adam@4:         fun rows year month day =
adam@4:             let
adam@4:                 fun row year month day weekday =
adam@4:                     if weekday >= 7 then
adam@4:                         <xml/>
adam@4:                     else
adam@4:                         <xml>
adam@4:                           <dyn signal={let
adam@4:                                            val thisDate = {Year = year,
adam@4:                                                            Month = case month of
adam@4:                                                                        Prev => if minf.ThisMonth = 1 then 12 else minf.ThisMonth - 1
adam@4:                                                                      | This => minf.ThisMonth
adam@4:                                                                      | Next => if minf.ThisMonth = 12 then 1 else minf.ThisMonth + 1,
adam@4:                                                            Day = day}
adam@4:                                        in
adam@4:                                            cday <- signal t.Day;
adam@4:                                            return (if Record.equal thisDate cday then
adam@4:                                                        <xml><td class={selday}>{[day]}</td></xml>
adam@4:                                                    else case month of
adam@4:                                                             This => <xml><td class={curday}
adam@4:                                                                                        onclick={set t.Day thisDate}>{[day]}</td></xml>
adam@4:                                                           | _ => <xml><td class={otherday}>{[day]}</td></xml>)
adam@4:                                        end}/>
adam@4:                             {let
adam@4:                                  val (year, month, day) =
adam@4:                                      case month of
adam@4:                                          Prev => if day = minf.PrevMonthLength then
adam@4:                                                      (if minf.ThisMonth = 1 then year + 1 else year, This, 1)
adam@4:                                                  else
adam@4:                                                      (year, Prev, day+1)
adam@4:                                        | This => if day = minf.ThisMonthLength then
adam@4:                                                      (if minf.ThisMonth = 12 then year + 1 else year, Next, 1)
adam@4:                                                  else
adam@4:                                                      (year, This, day+1)
adam@4:                                        | Next => (year, Next, day+1)
adam@4:                              in
adam@4:                                  row year month day (weekday+1)
adam@4:                              end}
adam@4:                           </xml>
adam@4:             in
adam@4:                 case month of
adam@4:                     Next => <xml/>
adam@4:                   | _ =>
adam@4:                     <xml>
adam@4:                       <tr>{row year month day 0}</tr>
adam@4:                       {let
adam@4:                            val next =
adam@4:                                case month of
adam@4:                                    Prev => Some (if minf.ThisMonth = 1 then year + 1 else year, This, day + 7 - minf.PrevMonthLength)
adam@4:                                  | This =>
adam@4:                                    Some (if day + 7 > minf.ThisMonthLength then
adam@4:                                              (if minf.ThisMonth = 12 then year + 1 else year, Next, day + 7 - minf.ThisMonthLength)
adam@4:                                          else
adam@4:                                              (year, This, day + 7))
adam@4:                                  | Next => None
adam@2:                        in
adam@4:                            case next of
adam@4:                                None => <xml/>
adam@4:                              | Some (year, month, day) => rows year month day
adam@4:                        end}
adam@4:                     </xml>
adam@4:             end
adam@4:     in
adam@4:         return <xml>
adam@4:           <table class={calendar}>
adam@4:             <tr>
adam@4:               <th class={prev} colspan={2}
adam@4:                                            onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
adam@4:                                                                                 {Month = 12, Year = minf.Year - 1}
adam@4:                                                                             else
adam@4:                                                                                 {Month = minf.ThisMonth - 1, Year = minf.Year}));
adam@4:                                                     set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
adam@4:                                            <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
adam@4:                                            <th class={next} colspan={2}
adam@4:                                                                         onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
adam@4:                                                                                                              {Month = 1, Year = minf.Year + 1}
adam@4:                                                                                                          else
adam@4:                                                                                                              {Month = minf.ThisMonth + 1, Year = minf.Year}));
adam@4:                                                                                  set t.Month minf}>{[minf.NextMonthName]} >></th>
adam@4:             </tr>
adam@4:             <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@4:             {rows (if minf.ThisMonth = 1 && (case minf.MondayMonth of This => False | _ => True) then
adam@4:                        minf.Year - 1
adam@4:                    else
adam@4:                        minf.Year) minf.MondayMonth minf.MondayDay}
adam@4:           </table>
adam@4:         </xml>
adam@4:     end
adam@2: 
adam@4: fun render t = <xml>
adam@4:   <dyn signal={date <- signal t.Day;
adam@4:                return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/>
adam@4:   <dyn signal={hd <- signal t.Hide;
adam@4:                if hd then
adam@4:                    return <xml><button value="Choose" onclick={set t.Hide False}/></xml>
adam@4:                else
adam@4:                    main <- render' t;
adam@4:                    return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/>
adam@4: </xml>
adam@4: 
adam@4: fun value t = signal t.Day