Mercurial > gui
changeset 4:377c11586999
Fully-functional Datebox
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Tue, 08 Feb 2011 16:52:29 -0500 |
| parents | 8cab48efaff2 |
| children | 4385bc6a0d2d |
| files | datebox.ur datebox.urs lib.urp |
| diffstat | 3 files changed, 119 insertions(+), 89 deletions(-) [+] |
line wrap: on
line diff
--- a/datebox.ur Tue Feb 08 16:06:31 2011 -0500 +++ b/datebox.ur Tue Feb 08 16:52:29 2011 -0500 @@ -5,14 +5,18 @@ style weekday style curday style otherday +style selday datatype month = Prev | This | Next +type date = {Year : int, Month : int, Day : int} + type t = {Month : source {ThisMonth : int, Year : int, ThisMonthLength : int, PrevMonthLength : int, MondayMonth : month, MondayDay : int, PrevMonthName : string, ThisMonthName : string, NextMonthName : string}, - Day : source int} + Day : source date, + Hide : source bool} fun pad len n = let @@ -84,95 +88,116 @@ fun monthInfo this = return (monthInfo' this) -val create = - tm <- now; +fun create tm = year <- return (readError (timef "%Y" tm)); month <- return (readError (timef "%m" tm)); - month <- source (monthInfo' {Month = month, Year = year}); + minf <- source (monthInfo' {Month = month, Year = year}); day <- return (readError (timef "%d" tm)); - day <- source day; - return {Month = month, Day = day} + day <- source {Year = year, Month = month, Day = day}; + hide <- source True; + return {Month = minf, Day = day, Hide = hide} -fun render (t : t) = <xml> - <dyn signal={minf <- signal t.Month; - let - fun rows month day = - let - fun row month day weekday = - if weekday >= 7 then - <xml/> - else - <xml> - <td class={case month of - This => curday - | _ => otherday}>{[day]}</td> - {let - val (month, day) = - case month of - Prev => if day = minf.PrevMonthLength then - (This, 1) - else - (Prev, day+1) - | This => if day = minf.ThisMonthLength then - (Next, 1) - else - (This, day+1) - | Next => (Next, day+1) - in - row month day (weekday+1) - end} - </xml> +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 <- 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={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 month of - Next => <xml/> - | _ => - <xml> - <tr>{row month day 0}</tr> - {let - val next = - case month of - Prev => Some (This, day + 7 - minf.PrevMonthLength) - | This => - Some (if day + 7 > minf.ThisMonthLength then - (Next, day + 7 - minf.ThisMonthLength) - else - (This, day + 7)) - | Next => None - in - case next of - None => <xml/> - | Some (month, day) => rows 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.Day 1; - 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.Day 1; - 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 minf.MondayMonth minf.MondayDay} - </table> - </xml> - end}/> - </xml> + 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 value t = - month <- signal t.Month; - day <- signal t.Day; - return {Year = month.Year, Month = month.ThisMonth, Day = day} +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' t; + return <xml><button value="Hide" onclick={set t.Hide True}/><br/>{main}</xml>}/> +</xml> + +fun value t = signal t.Day
--- a/datebox.urs Tue Feb 08 16:06:31 2011 -0500 +++ b/datebox.urs Tue Feb 08 16:52:29 2011 -0500 @@ -1,8 +1,10 @@ type t -val create : transaction t +type date = {Year : int, Month : int, Day : int} + +val create : time -> transaction t val render : t -> xbody -val value : t -> signal {Year : int, Month : int, Day : int} +val value : t -> signal date style calendar style prev @@ -11,3 +13,4 @@ style weekday style curday style otherday +style selday