Mercurial > gui
diff datebox.ur @ 14:0827320b0f04
Write calendarCtl in terms of a source with a listener.
| author | Karn Kallio <kkallio@eka> |
|---|---|
| date | Fri, 05 Aug 2011 18:55:24 -0430 |
| parents | c016beb0ebac |
| children | 8300d5f0dc19 |
line wrap: on
line diff
--- a/datebox.ur Thu Jul 28 11:51:10 2011 -0430 +++ b/datebox.ur Fri Aug 05 18:55:24 2011 -0430 @@ -1,245 +1,35 @@ -style calendar -style prev -style this -style next -style weekday -style curday -style otherday -style selday +type t = {Cal : Calendar.t, + Panel : TogglePanel.togglePanel Calendar.t} -datatype month = Prev | This | Next +type date = Calendar.date +val date_eq = Calendar.date_eq +val date_ord = Calendar.date_ord +val time = Calendar.time +val date = Calendar.date -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) +val format = TogglePanel.defaultFormat + --#OpenCtl -- #CloseCtl + ++ {OpenCtl = fn behaviour => <xml><button value="Choose" onclick={behaviour}/></xml>, + CloseCtl = fn behaviour => <xml><button value="Hide" onclick={behaviour}/></xml>} 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} + cal <- Calendar.create tm; + panel <- TogglePanel.create format cal False; -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}><< {[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 + return {Cal = cal, + Panel = panel} -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> +fun addListener f db = + Calendar.addListener f db.Cal -type calendarCtl = $cal +fun set db day = + Calendar.set db.Cal day -fun givesDates_calendarCtl x = x.Day +fun value db = Calendar.value db.Cal -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 = +fun render db = <xml> - <dyn signal={render' action ctl}/> + <dyn signal={date <- Calendar.value db.Cal; + return <xml>{[date.Year]}-{[date.Month]}-{[date.Day]}</xml>}/> + {Gui.toXml db.Panel} </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)