Mercurial > gui
changeset 12:bbdedfde154e
Add a calendar control.
| author | Karn Kallio <kkallio@eka> |
|---|---|
| date | Thu, 28 Jul 2011 10:24:34 -0430 |
| parents | ccd0a169e827 |
| children | c016beb0ebac |
| files | datebox.ur datebox.urs examples/datebox.ur examples/datebox.urp examples/datebox.urs |
| diffstat | 5 files changed, 78 insertions(+), 11 deletions(-) [+] |
line wrap: on
line diff
--- a/datebox.ur Sun Jul 24 14:51:16 2011 -0400 +++ b/datebox.ur Thu Jul 28 10:24:34 2011 -0430 @@ -15,12 +15,17 @@ 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 : source date, - Hide : source bool} +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 @@ -36,6 +41,14 @@ 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 @@ -103,7 +116,7 @@ hide <- source True; return {Month = minf, Day = day, Hide = hide} -fun render' t = +fun render' action t = minf <- signal t.Month; let fun rows year month day = @@ -126,7 +139,7 @@ <xml><td class={selday}>{[day]}</td></xml> else case month of This => <xml><td class={curday} - onclick={set t.Day thisDate}>{[day]}</td></xml> + onclick={action thisDate; set t.Day thisDate}>{[day]}</td></xml> | _ => <xml><td class={otherday}>{[day]}</td></xml>) end}/> {let @@ -202,8 +215,29 @@ if hd then return <xml><button value="Choose" onclick={set t.Hide False}/></xml> else - main <- render' t; + main <- render' (fn _ => return ()) (t -- #Hide); return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/> </xml> -fun value t = signal t.Day +type calendarCtl = $cal + +fun givesDates_calendarCtl x = x.Day + +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 = + <xml> + <dyn signal={render' action ctl}/> + </xml> + +fun setCalendarCtl action ctl day = + action day; + set ctl.Day day + +fun value [t ::: Type] (gd : givesDates t) t = signal (gd t)
--- a/datebox.urs Sun Jul 24 14:51:16 2011 -0400 +++ b/datebox.urs Thu Jul 28 10:24:34 2011 -0430 @@ -1,12 +1,24 @@ +class givesDates + type t +type calendarCtl + +val givesDates_t : givesDates t +val givesDates_calendarCtl : givesDates calendarCtl type date = {Year : int, Month : int, Day : int} val date_ord : ord date val time : date -> time +val date : time -> date val create : time -> transaction t val render : t -> xbody -val value : t -> signal date + +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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/examples/datebox.ur Thu Jul 28 10:24:34 2011 -0430 @@ -0,0 +1,13 @@ +fun main () = + +tm <- now; + +dayCtl <- Datebox.createCalendarCtl tm; + +return + <xml> + <head><title>Datebox Example</title></head> + <body> + {Datebox.renderCalendarCtl (fn (d : Datebox.date) => alert (show d.Year)) dayCtl} + </body> + </xml>