adam@2: style calendar adam@2: style prev adam@2: style this adam@2: style next adam@2: style weekday adam@2: style curday adam@2: style otherday adam@2: adam@2: datatype month = Prev | This | Next adam@2: adam@2: type t = {Month : source {ThisMonth : int, Year : int, adam@2: ThisMonthLength : int, PrevMonthLength : int, adam@2: MondayMonth : month, MondayDay : int, adam@2: PrevMonthName : string, ThisMonthName : string, NextMonthName : string}, adam@2: Day : source int} adam@2: adam@2: fun pad len n = adam@2: let adam@2: val s = show n adam@2: adam@2: fun pad' len s = adam@2: if len <= 0 then adam@2: s adam@2: else adam@2: pad' (len-1) ("0" ^ s) adam@2: in adam@2: pad' (len - String.length s) s adam@2: end adam@2: adam@2: fun monthLen m = adam@2: let adam@2: fun f n tm = adam@2: let adam@2: val next = addSeconds tm (60 * 60 * 24) adam@2: val nextMon = readError (timef "%m" next) adam@2: in adam@2: if nextMon = m.Month then adam@2: f (n+1) next adam@2: else adam@2: n adam@2: end adam@2: in adam@2: f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00")) adam@2: end adam@2: adam@2: fun weekdayToNum s = adam@2: case s of adam@2: "Mon" => 0 adam@2: | "Tue" => 1 adam@2: | "Wed" => 2 adam@2: | "Thu" => 3 adam@2: | "Fri" => 4 adam@2: | "Sat" => 5 adam@2: | "Sun" => 6 adam@2: | _ => error Datebox: Bad weekday name adam@2: adam@2: fun timeOfMonth my = adam@2: readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00") adam@2: adam@3: fun monthInfo' this = adam@2: let adam@2: val prev = if this.Month = 1 then adam@2: {Month = 12, Year = this.Year - 1} adam@2: else adam@2: {Month = this.Month-1, Year = this.Year} adam@2: val prevLen = monthLen prev adam@2: adam@2: val next = if this.Month = 12 then adam@2: {Month = 1, Year = this.Year + 1} adam@2: else adam@2: {Month = this.Month + 1, Year = this.Year} adam@2: adam@2: val firstDow = weekdayToNum (timef "%a" (timeOfMonth this)) adam@2: in adam@2: {ThisMonth = this.Month, Year = this.Year, adam@2: ThisMonthLength = monthLen this, adam@2: PrevMonthLength = prevLen, adam@2: MondayMonth = if firstDow = 0 then This else Prev, adam@2: MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1), adam@2: PrevMonthName = timef "%b" (timeOfMonth prev), adam@2: ThisMonthName = timef "%b" (timeOfMonth this), adam@2: NextMonthName = timef "%b" (timeOfMonth next)} adam@2: end adam@2: adam@3: fun monthInfo this = return (monthInfo' this) adam@3: adam@2: val create = adam@2: tm <- now; adam@2: year <- return (readError (timef "%Y" tm)); adam@2: month <- return (readError (timef "%m" tm)); adam@3: month <- source (monthInfo' {Month = month, Year = year}); adam@2: day <- return (readError (timef "%d" tm)); adam@2: day <- source day; adam@2: return {Month = month, Day = day} adam@2: adam@2: fun render (t : t) = adam@2: = 7 then adam@2: adam@2: else adam@2: adam@2: curday adam@2: | _ => otherday}>{[day]} adam@2: {let adam@2: val (month, day) = adam@2: case month of adam@2: Prev => if day = minf.PrevMonthLength then adam@2: (This, 1) adam@2: else adam@2: (Prev, day+1) adam@2: | This => if day = minf.ThisMonthLength then adam@2: (Next, 1) adam@2: else adam@2: (This, day+1) adam@2: | Next => (Next, day+1) adam@2: in adam@2: row month day (weekday+1) adam@2: end} adam@2: adam@2: in adam@2: case month of adam@2: Next => adam@2: | _ => adam@2: adam@2: {row month day 0} adam@2: {let adam@2: val next = adam@2: case month of adam@2: Prev => Some (This, day + 7 - minf.PrevMonthLength) adam@2: | This => adam@2: Some (if day + 7 > minf.ThisMonthLength then adam@2: (Next, day + 7 - minf.ThisMonthLength) adam@2: else adam@2: (This, day + 7)) adam@2: | Next => None adam@2: in adam@2: case next of adam@2: None => adam@2: | Some (month, day) => rows month day adam@2: end} adam@2: adam@2: end adam@2: in adam@2: return adam@2: adam@2: adam@3: adam@3: adam@3: adam@2: adam@2: adam@2: {rows minf.MondayMonth minf.MondayDay} adam@2:
<< {[minf.PrevMonthName]}{[minf.ThisMonthName]} {[minf.Year]}{[minf.NextMonthName]} >>
M Tu W Th F Sa Su
adam@2:
adam@2: end}/> adam@2:
adam@2: adam@2: fun value t = adam@2: month <- signal t.Month; adam@2: day <- signal t.Day; adam@3: return {Year = month.Year, Month = month.ThisMonth, Day = day}