kkallio@14: style calendar
kkallio@14: style prev
kkallio@14: style this
kkallio@14: style next
kkallio@14: style weekday
kkallio@14: style curday
kkallio@14: style otherday
kkallio@14: style selday
kkallio@14: 
kkallio@14: datatype month = Prev | This | Next
kkallio@14: 
kkallio@14: type date = {Year : int, Month : int, Day : int}
kkallio@14: val date_eq = mkEq (fn {Year = y, Month = m, Day = d} {Year = y', Month = m', Day = d'} =>
kkallio@14:                        y = y' && m = m' && d = d')
kkallio@14: val date_ord = mkOrd {Lt = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
kkallio@14:                               y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 < d2),
kkallio@14:                       Le = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
kkallio@14:                               y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 <= d2)}
kkallio@14: 
kkallio@14: type t = {Month : source {ThisMonth : int, Year : int,
kkallio@14:                           ThisMonthLength : int, PrevMonthLength : int,
kkallio@14:                           MondayMonth : month, MondayDay : int,
kkallio@14:                           PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
adam@15:           Day : SourceL.t date}
kkallio@14:          
kkallio@14: fun pad len n =
kkallio@14:     let
kkallio@14:         val s = show n
kkallio@14: 
kkallio@14:         fun pad' len s =
kkallio@14:             if len <= 0 then
kkallio@14:                 s
kkallio@14:             else
kkallio@14:                 pad' (len-1) ("0" ^ s)
kkallio@14:     in
kkallio@14:         pad' (len - String.length s) s
kkallio@14:     end
kkallio@14: 
adam@25: fun time {Year = y, Month = m, Day = d} = readError (show y ^ "/" ^ pad 2 m ^ "/" ^ pad 2 d ^ " 00:00:00")
kkallio@14: fun date tm =
kkallio@14:     let
kkallio@14:         val y = readError (timef "%Y" tm)
kkallio@14:         val m = readError (timef "%m" tm)
kkallio@14:         val d = readError (timef "%d" tm)
kkallio@14:     in
kkallio@14:         {Year = y, Month = m, Day = d}
kkallio@14:     end
kkallio@14: 
kkallio@14: fun monthLen m =
kkallio@14:     let
kkallio@14:         fun f n tm =
kkallio@14:             let
kkallio@14:                 val next = addSeconds tm (60 * 60 * 24)
kkallio@14:                 val nextMon = readError (timef "%m" next)
kkallio@14:             in
kkallio@14:                 if nextMon = m.Month then
kkallio@14:                     f (n+1) next
kkallio@14:                 else
kkallio@14:                     n
kkallio@14:             end
kkallio@14:     in
kkallio@14:         f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00"))
kkallio@14:     end
kkallio@14: 
kkallio@14: fun weekdayToNum s =
kkallio@14:     case s of
kkallio@14:         "Mon" => 0
kkallio@14:       | "Tue" => 1
kkallio@14:       | "Wed" => 2
kkallio@14:       | "Thu" => 3
kkallio@14:       | "Fri" => 4
kkallio@14:       | "Sat" => 5
kkallio@14:       | "Sun" => 6
kkallio@14:       | _ => error <xml>Datebox: Bad weekday name</xml>
kkallio@14: 
kkallio@14: fun timeOfMonth my =
kkallio@14:     readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00")
kkallio@14: 
kkallio@14: fun monthInfo' this =
kkallio@14:     let
kkallio@14:         val prev = if this.Month = 1 then
kkallio@14:                        {Month = 12, Year = this.Year - 1}
kkallio@14:                    else
kkallio@14:                        {Month = this.Month-1, Year = this.Year}
kkallio@14:         val prevLen = monthLen prev
kkallio@14: 
kkallio@14:         val next = if this.Month = 12 then
kkallio@14:                        {Month = 1, Year = this.Year + 1}
kkallio@14:                    else
kkallio@14:                        {Month = this.Month + 1, Year = this.Year}
kkallio@14: 
kkallio@14:         val firstDow = weekdayToNum (timef "%a" (timeOfMonth this))
kkallio@14:     in
kkallio@14:         {ThisMonth = this.Month, Year = this.Year,
kkallio@14:          ThisMonthLength = monthLen this,
kkallio@14:          PrevMonthLength = prevLen,
kkallio@14:          MondayMonth = if firstDow = 0 then This else Prev,
kkallio@14:          MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1),
kkallio@14:          PrevMonthName = timef "%b" (timeOfMonth prev),
kkallio@14:          ThisMonthName = timef "%b" (timeOfMonth this),
kkallio@14:          NextMonthName = timef "%b" (timeOfMonth next)}
kkallio@14:     end
kkallio@14: 
kkallio@14: fun monthInfo this = return (monthInfo' this)
kkallio@14: 
kkallio@14: fun create tm =
kkallio@14:     year <- return (readError (timef "%Y" tm));
kkallio@14:     month <- return (readError (timef "%m" tm));
kkallio@14:     minf <- source (monthInfo' {Month = month, Year = year});
kkallio@14:     day <- return (readError (timef "%d" tm));
adam@15:     day <- SourceL.create {Year = year, Month = month, Day = day};
kkallio@14:     return {Month = minf, Day = day}
kkallio@14: 
kkallio@14: fun render' t =
kkallio@14:     minf <- signal t.Month;
kkallio@14:     let
kkallio@14:         fun rows year month day =
kkallio@14:             let
kkallio@14:                 fun row year month day weekday =
kkallio@14:                     if weekday >= 7 then
kkallio@14:                         <xml/>
kkallio@14:                     else
kkallio@14:                         <xml>
kkallio@14:                           <dyn signal={let
kkallio@14:                                            val thisDate = {Year = year,
kkallio@14:                                                            Month = case month of
kkallio@14:                                                                        Prev => if minf.ThisMonth = 1 then 12 else minf.ThisMonth - 1
kkallio@14:                                                                      | This => minf.ThisMonth
kkallio@14:                                                                      | Next => if minf.ThisMonth = 12 then 1 else minf.ThisMonth + 1,
kkallio@14:                                                            Day = day}
kkallio@14:                                        in
adam@15:                                            cday <- SourceL.value t.Day;
kkallio@14:                                            return (if Record.equal thisDate cday then
kkallio@14:                                                        <xml><td class={selday}>{[day]}</td></xml>
kkallio@14:                                                    else case month of
kkallio@14:                                                             This => <xml><td class={curday}
adam@15:                                                                              onclick={SourceL.set t.Day thisDate}>{[day]}</td></xml>
kkallio@14:                                                           | _ => <xml><td class={otherday}>{[day]}</td></xml>)
kkallio@14:                                        end}/>
kkallio@14:                             {let
kkallio@14:                                  val (year, month, day) =
kkallio@14:                                      case month of
kkallio@14:                                          Prev => if day = minf.PrevMonthLength then
kkallio@14:                                                      (if minf.ThisMonth = 1 then year + 1 else year, This, 1)
kkallio@14:                                                  else
kkallio@14:                                                      (year, Prev, day+1)
kkallio@14:                                        | This => if day = minf.ThisMonthLength then
kkallio@14:                                                      (if minf.ThisMonth = 12 then year + 1 else year, Next, 1)
kkallio@14:                                                  else
kkallio@14:                                                      (year, This, day+1)
kkallio@14:                                        | Next => (year, Next, day+1)
kkallio@14:                              in
kkallio@14:                                  row year month day (weekday+1)
kkallio@14:                              end}
kkallio@14:                           </xml>
kkallio@14:             in
kkallio@14:                 case month of
kkallio@14:                     Next => <xml/>
kkallio@14:                   | _ =>
kkallio@14:                     <xml>
kkallio@14:                       <tr>{row year month day 0}</tr>
kkallio@14:                       {let
kkallio@14:                            val next =
kkallio@14:                                case month of
kkallio@14:                                    Prev => Some (if minf.ThisMonth = 1 then year + 1 else year, This, day + 7 - minf.PrevMonthLength)
kkallio@14:                                  | This =>
kkallio@14:                                    Some (if day + 7 > minf.ThisMonthLength then
kkallio@14:                                              (if minf.ThisMonth = 12 then year + 1 else year, Next, day + 7 - minf.ThisMonthLength)
kkallio@14:                                          else
kkallio@14:                                              (year, This, day + 7))
kkallio@14:                                  | Next => None
kkallio@14:                        in
kkallio@14:                            case next of
kkallio@14:                                None => <xml/>
kkallio@14:                              | Some (year, month, day) => rows year month day
kkallio@14:                        end}
kkallio@14:                     </xml>
kkallio@14:             end
kkallio@14:     in
kkallio@14:         return <xml>
kkallio@14:           <table class={calendar}>
kkallio@14:             <tr>
kkallio@14:               <th class={prev} colspan={2}
kkallio@14:                   onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
kkallio@14:                                                        {Month = 12, Year = minf.Year - 1}
kkallio@14:                                                    else
kkallio@14:                                                        {Month = minf.ThisMonth - 1, Year = minf.Year}));
kkallio@14:                            set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
kkallio@14:                   <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
kkallio@14:                   <th class={next} colspan={2}
kkallio@14:                       onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
kkallio@14:                                                            {Month = 1, Year = minf.Year + 1}
kkallio@14:                                                        else
kkallio@14:                                                            {Month = minf.ThisMonth + 1, Year = minf.Year}));
kkallio@14:                                set t.Month minf}>{[minf.NextMonthName]} >></th>
kkallio@14:             </tr>
kkallio@14:             <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>
kkallio@14:             {rows (if minf.ThisMonth = 1 && (case minf.MondayMonth of This => False | _ => True) then
kkallio@14:                        minf.Year - 1
kkallio@14:                    else
kkallio@14:                        minf.Year) minf.MondayMonth minf.MondayDay}
kkallio@14:           </table>
kkallio@14:         </xml>
kkallio@14:     end
kkallio@14: 
adam@15: fun onChange ctl f =
adam@15:     SourceL.onChange ctl.Day f
kkallio@14: 
kkallio@14: val gui_t = Gui.mkGui 
adam@20:                 (fn [body ~ []] ctl =>
kkallio@14:                     <xml>
kkallio@14:                       <dyn signal={render' ctl}/>
kkallio@14:                     </xml>)
kkallio@14: 
kkallio@14: fun set ctl day =
kkallio@14:     minf <- rpc (monthInfo (day -- #Day));
kkallio@14:     Basis.set ctl.Month minf;
adam@15:     SourceL.set ctl.Day day
kkallio@14: 
adam@15: fun value ctl = SourceL.value ctl.Day