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: kkallio@14: 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 Datebox: Bad weekday name 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: kkallio@14: else kkallio@14: kkallio@14: 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: {[day]} kkallio@14: else case month of kkallio@14: This => {[day]} kkallio@14: | _ => {[day]}) 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: kkallio@14: in kkallio@14: case month of kkallio@14: Next => kkallio@14: | _ => kkallio@14: kkallio@14: {row year month day 0} 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 => kkallio@14: | Some (year, month, day) => rows year month day kkallio@14: end} kkallio@14: kkallio@14: end kkallio@14: in kkallio@14: return kkallio@14: kkallio@14: kkallio@14: kkallio@14: kkallio@14: kkallio@14: kkallio@14: 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:
<< {[minf.PrevMonthName]}{[minf.ThisMonthName]} {[minf.Year]}{[minf.NextMonthName]} >>
M Tu W Th F Sa Su
kkallio@14:
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: kkallio@14: kkallio@14: ) 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