Mercurial > gui
changeset 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 |
| files | calendar.ur calendar.urs changePoller.ur changePoller.urs datebox.ur datebox.urs examples/datebox.ur lib.urp |
| diffstat | 8 files changed, 353 insertions(+), 259 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/calendar.ur Fri Aug 05 18:55:24 2011 -0430 @@ -0,0 +1,220 @@ +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_eq = mkEq (fn {Year = y, Month = m, Day = d} {Year = y', Month = m', Day = d'} => + y = y' && m = m' && d = d') +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)} + +type t = {Month : source {ThisMonth : int, Year : int, + ThisMonthLength : int, PrevMonthLength : int, + MondayMonth : month, MondayDay : int, + PrevMonthName : string, ThisMonthName : string, NextMonthName : string}, + Day : ChangePoller.changePoller date} + +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 <- ChangePoller.create {Year = year, Month = month, Day = day}; + return {Month = minf, Day = day} + +fun render' 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 <- ChangePoller.value 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={set (ChangePoller.ctl 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 + +fun addListener f ctl = + ChangePoller.addChangeListener f 100 ctl.Day + +val gui_t = Gui.mkGui + (fn ctl => + <xml> + <dyn signal={render' ctl}/> + </xml>) + +fun set ctl day = + minf <- rpc (monthInfo (day -- #Day)); + Basis.set ctl.Month minf; + Basis.set (ChangePoller.ctl ctl.Day) day + +fun value ctl = ChangePoller.value ctl.Day
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/calendar.urs Fri Aug 05 18:55:24 2011 -0430 @@ -0,0 +1,37 @@ +type date = {Year : int, Month : int, Day : int} +val date_eq : eq date +val date_ord : ord date +val time : date -> time +val date : time -> date +(* A type to represent calendar dates and some operations on them. *) + +type t +(* Interactive calendar control widgets. The date can be set and read. + * They support adding a change listener which will be called on + * the new date. They are displayed as pictures of calendars which + * have clickable dates. *) + +val addListener : (date -> transaction unit) -> t -> transaction unit +(* Add a change listener to a calendar control. *) + +val set : t -> date -> transaction unit +(* Set the date of the calendar. *) + +val value : t -> signal date +(* Read the date of the calendar. *) + +val gui_t : Gui.gui t +(* Witness that this is a gui widget. *) + +val create : time -> transaction t +(* Get a basic interactive calendar control widget. *) + +style calendar +style prev +style this +style next +style weekday +style curday +style otherday +style selday +(* Styles for the calendar panel. *)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/changePoller.ur Fri Aug 05 18:55:24 2011 -0430 @@ -0,0 +1,30 @@ +con changePoller t = {Val : source t, + Last : source t} + +fun create [t ::: Type] (_ : eq t) (i : t) = + v <- source i; + l <- source i; + + return {Val = v, + Last = l} + +fun addChangeListener [t ::: Type] (_ : eq t) f pollInterval cp = + let + fun go () = + sleep pollInterval; + sample <- get cp.Val; + lst <- get cp.Last; + if sample = lst then + go () + else + f sample; + set cp.Last sample; + go () + in + go () + end + +fun ctl [t ::: Type] cp = cp.Val + +fun value [t ::: Type] cp = signal (cp.Val) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/changePoller.urs Fri Aug 05 18:55:24 2011 -0430 @@ -0,0 +1,17 @@ +(* A source which can poll for changes and call an action on the new value + * when one is found. *) + +con changePoller :: Type -> Type +(* The type of pollers over the given type. *) + +val create : t ::: Type -> eq t -> t -> transaction (changePoller t) +(* From an initial value get a poller. *) + +val addChangeListener : t ::: Type -> eq t -> (t -> transaction unit) -> int -> changePoller t -> transaction unit +(* Add an action to run on changed values with a polling period given by the int. *) + +val ctl : t ::: Type -> changePoller t -> source t +(* Get a source to control or set the current value. *) + +val value : t ::: Type -> changePoller t -> signal t +(* A signal holding the current value. *)
--- 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)
--- a/datebox.urs Thu Jul 28 11:51:10 2011 -0430 +++ b/datebox.urs Fri Aug 05 18:55:24 2011 -0430 @@ -1,30 +1,26 @@ -class givesDates - type t -type calendarCtl - -val givesDates_t : givesDates t -val givesDates_calendarCtl : givesDates calendarCtl +(* The type of dateboxes, which are input elements + * allowing the user to select a date from a popup + * calendar. *) type date = {Year : int, Month : int, Day : int} +val date_eq : eq date val date_ord : ord date val time : date -> time val date : time -> date +(* Type of dates and some useful utility functions. *) val create : time -> transaction t +(* Get a datebox initially set to the given time. *) + +val addListener : (date -> transaction unit) -> t -> transaction unit +(* Add an action to be run when the date changes. *) + +val set : t -> date -> transaction unit +(* Call this to change the selected date. *) + +val value : t -> signal date +(* Extract the current date value. *) + val render : t -> xbody - -val createCalendarCtl : time -> transaction calendarCtl -val renderCalendarCtl : (date -> transaction unit) -> calendarCtl -> xbody -val setCalendarCtl : (date -> transaction unit) -> calendarCtl -> date -> transaction unit - -val value : t ::: Type -> givesDates t -> t -> signal date - -style calendar -style prev -style this -style next -style weekday -style curday -style otherday -style selday +(* Draws the datebox as a piece of xml. *)
--- a/examples/datebox.ur Thu Jul 28 11:51:10 2011 -0430 +++ b/examples/datebox.ur Fri Aug 05 18:55:24 2011 -0430 @@ -2,12 +2,14 @@ tm <- now; -dayCtl <- Datebox.createCalendarCtl tm; +dayCtl <- Datebox.create tm; + +load <- return (Datebox.addListener (fn d => alert (show d.Day)) dayCtl); return <xml> <head><title>Datebox Example</title></head> - <body> - {Datebox.renderCalendarCtl (fn (d : Datebox.date) => alert (show d.Year)) dayCtl} + <body onload={load}> + {Datebox.render dayCtl} </body> </xml>