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@4: style selday adam@2: adam@2: datatype month = Prev | This | Next adam@2: adam@4: type date = {Year : int, Month : int, Day : int} adam@5: val date_ord = mkOrd {Lt = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} => adam@5: y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 < d2), adam@5: Le = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} => adam@5: y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 <= d2)} adam@4: 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@4: Day : source date, adam@4: Hide : source bool} 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@5: fun time {Year = y, Month = m, Day = d} = readError (show y ^ "-" ^ pad 2 m ^ "-" ^ pad 2 d ^ " 00:00:00") adam@5: 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@4: fun create tm = adam@2: year <- return (readError (timef "%Y" tm)); adam@2: month <- return (readError (timef "%m" tm)); adam@4: minf <- source (monthInfo' {Month = month, Year = year}); adam@2: day <- return (readError (timef "%d" tm)); adam@4: day <- source {Year = year, Month = month, Day = day}; adam@4: hide <- source True; adam@4: return {Month = minf, Day = day, Hide = hide} adam@2: adam@4: fun render' t = adam@4: minf <- signal t.Month; adam@4: let adam@4: fun rows year month day = adam@4: let adam@4: fun row year month day weekday = adam@4: if weekday >= 7 then adam@4: adam@4: else adam@4: adam@4: if minf.ThisMonth = 1 then 12 else minf.ThisMonth - 1 adam@4: | This => minf.ThisMonth adam@4: | Next => if minf.ThisMonth = 12 then 1 else minf.ThisMonth + 1, adam@4: Day = day} adam@4: in adam@4: cday <- signal t.Day; adam@4: return (if Record.equal thisDate cday then adam@4: {[day]} adam@4: else case month of adam@4: This => {[day]} adam@4: | _ => {[day]}) adam@4: end}/> adam@4: {let adam@4: val (year, month, day) = adam@4: case month of adam@4: Prev => if day = minf.PrevMonthLength then adam@4: (if minf.ThisMonth = 1 then year + 1 else year, This, 1) adam@4: else adam@4: (year, Prev, day+1) adam@4: | This => if day = minf.ThisMonthLength then adam@4: (if minf.ThisMonth = 12 then year + 1 else year, Next, 1) adam@4: else adam@4: (year, This, day+1) adam@4: | Next => (year, Next, day+1) adam@4: in adam@4: row year month day (weekday+1) adam@4: end} adam@4: adam@4: in adam@4: case month of adam@4: Next => adam@4: | _ => adam@4: adam@4: {row year month day 0} adam@4: {let adam@4: val next = adam@4: case month of adam@4: Prev => Some (if minf.ThisMonth = 1 then year + 1 else year, This, day + 7 - minf.PrevMonthLength) adam@4: | This => adam@4: Some (if day + 7 > minf.ThisMonthLength then adam@4: (if minf.ThisMonth = 12 then year + 1 else year, Next, day + 7 - minf.ThisMonthLength) adam@4: else adam@4: (year, This, day + 7)) adam@4: | Next => None adam@2: in adam@4: case next of adam@4: None => adam@4: | Some (year, month, day) => rows year month day adam@4: end} adam@4: adam@4: end adam@4: in adam@4: return adam@4: adam@4: adam@4: adam@4: adam@4: adam@4: adam@4: adam@4: {rows (if minf.ThisMonth = 1 && (case minf.MondayMonth of This => False | _ => True) then adam@4: minf.Year - 1 adam@4: else adam@4: minf.Year) minf.MondayMonth minf.MondayDay} adam@4:
<< {[minf.PrevMonthName]}{[minf.ThisMonthName]} {[minf.Year]}{[minf.NextMonthName]} >>
M Tu W Th F Sa Su
adam@4:
adam@4: end adam@2: adam@4: fun render t = adam@4: {[date.Year]}-{[date.Month]}-{[date.Day]}}/> adam@4: