Add proper text calendar.

Previously the program `cal` was used, this was slow and unreliable.

4 files changed, 171 insertions, 19 deletions

diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm
index c4b30a54..395c85d6 100644
--- a/module/calp/terminal.scm
+++ b/module/calp/terminal.scm
@@ -10,7 +10,6 @@
   :use-module (vulgar)
   :use-module (vulgar info)
   :use-module (vulgar color)
-  :use-module (vulgar components)
 
   :use-module (vcomponent)
   :use-module (vcomponent datetime)
@@ -18,6 +17,7 @@
   :use-module (vcomponent util group)
 
   :use-module (text util)
+  :use-module ((text calendar) :select (cal-3))
   :use-module (text flow)
 
   :use-module (ice-9 format)
@@ -127,7 +127,7 @@
   (display (G_ "== Day View =="))
   (newline)
 
-  (display-calendar-header! (current-page this))
+  (cal-3 (current-page this))
 
   ;; display event list
   (display-event-table
diff --git a/module/text/calendar.scm b/module/text/calendar.scm
new file mode 100644
index 00000000..79341114
--- /dev/null
+++ b/module/text/calendar.scm
@@ -0,0 +1,86 @@
+(define-module (text calendar)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module ((hnh util) :select (when unless group ->))
+  :use-module ((hnh util lens) :select (modify))
+  :use-module ((hnh util io) :select (displayln))
+  :use-module (hnh util type)
+  :use-module (ice-9 format)
+  :use-module ((texinfo string-utils) :select (center-string))
+  :use-module (datetime)
+  :use-module ((text util) :select (unwords))
+  :export (graphical-calendar cal-3))
+
+;; Done manually rather than through vulgar, so the text
+;; utilities can become standalone.
+(define (ansi-invert str)
+  (format #f "\x1b[7m~a\x1b[m" str))
+
+(define line-length (+ 6 (* 7 2)))
+(define placeholder (gensym))
+
+;;; Always returns 8 lines
+;;; All lines are exactly 20 characters
+(define* (graphical-calendar target-date
+                             key:
+                             (wkst mon)
+                             (highlight-proc ansi-invert))
+  (typecheck target-date date?)
+  (typecheck target-date (or false? date?))
+
+  ;; Date which starts the target month
+  (define month-start (start-of-month target-date))
+
+  ;; Number of days in the current way which is part of the previous month.
+  (define to-skip (modulo (- (week-day (day target-date 1)) wkst) 7))
+
+  (define lines ; (list-of (list-of (or integer? (eq? placeholder))))
+    (let ((lines trail (floor/ (- (days-in-month target-date)
+                                  (- 7 to-skip))
+                               7)))
+      (append
+       (list (append (make-list to-skip placeholder) (iota (- 7 to-skip) 1)))
+       (group (iota (* 7 lines) (1+ (- 7 to-skip))) 7)
+       (list (append (iota trail (+ 1 (* 7 lines) (- 7 to-skip)) )
+                     (make-list (- 7 trail) placeholder)))
+       (when (= 3 lines)
+         (list (make-list 7 placeholder))))))
+
+  (append
+   ;; Month and year declaration
+   (list (center-string (date->string target-date "~B ~Y")
+                        line-length))
+   ;; Names of week days
+   (list (unwords
+          (map (lambda (d) (string-pad (week-day-name d 2) 2))
+               (weekday-list wkst))))
+
+   (map (lambda (group)
+          (unwords
+           (map (lambda (entry)
+                  (cond ((and (integer? entry)
+                              (= entry (day target-date)))
+                         (highlight-proc (format #f "~2d" entry)))
+                        ((integer? entry)
+                         (format #f "~2d" entry))
+                        (else "  ")))
+                group)))
+        lines)))
+
+
+(define* (cal-3 optional: (d (current-date)))
+  (typecheck d date?)
+  ;; Day is set to one for month arithmetic,
+  ;; and then to zero to not highlight any day
+  (for-each displayln
+            (map string-append
+                 (graphical-calendar (-> d (day 1)
+                                         (date- (date month: 1))
+                                         (day 0)))
+                 (make-list 8 "  ")
+                 (graphical-calendar d)
+                 (make-list 8 "  ")
+                 (graphical-calendar (-> d (day 1)
+                                         (date+ (date month: 1))
+                                         (day 0))))))
diff --git a/module/vulgar/components.scm b/module/vulgar/components.scm
deleted file mode 100644
index 74420f18..00000000
--- a/module/vulgar/components.scm
+++ /dev/null
@@ -1,17 +0,0 @@
-(define-module (vulgar components)
-  :use-module (datetime)
-  :use-module (hnh util)
-  :export (display-calendar-header!))
-
-(define (display-calendar-header! date)
-  (let ((day   (number->string (day   date)))
-        (month (number->string (month date)))
-        (year  (number->string (year  date))))
-    ;; BSD cal only supports setting highlighted day explicitly for
-    ;; testing the functionality. This seems to at least give me
-    ;; an (almost) working display, albeit ugly.
-    (if (file-exists? "/usr/bin/ncal")
-        (system* "ncal" "-3" "-H" (date->string date)
-                 month year)
-        (system* "cal" "-3" day month year))))
-
diff --git a/tests/unit/text/text-calendar.scm b/tests/unit/text/text-calendar.scm
new file mode 100644
index 00000000..43064ad1
--- /dev/null
+++ b/tests/unit/text/text-calendar.scm
@@ -0,0 +1,83 @@
+(define-module (test text-calendar)
+  :use-module (srfi srfi-64)
+  :use-module (srfi srfi-71)
+  :use-module (srfi srfi-88)
+  :use-module (datetime)
+  :use-module (text calendar))
+
+;;; TODO these tests are locale-dependant
+
+(test-equal "Start and end week are partial"
+  '("    oktober 2023    "
+    "må ti on to fr lö sö"
+    "                   1"
+    " 2  3  4  5  6  7  8"
+    " 9 10 11 12 13 14 15"
+    "16 17 18 19 20 21 22"
+    "23 24 25 26 27 28 29"
+    "30 31               ")
+  (graphical-calendar (date year: 2023 month: oct) wkst: mon))
+
+(test-equal "End week is full, start is partial"
+  '("     april 2023     "
+    "må ti on to fr lö sö"
+    "                1  2"
+    " 3  4  5  6  7  8  9"
+    "10 11 12 13 14 15 16"
+    "17 18 19 20 21 22 23"
+    "24 25 26 27 28 29 30"
+    "                    ")
+  (graphical-calendar (date year: 2023 month: apr) wkst: mon))
+
+(test-equal "Start week is full, end is partial"
+  '("    oktober 2023    "
+    "sö må ti on to fr lö"
+    " 1  2  3  4  5  6  7"
+    " 8  9 10 11 12 13 14"
+    "15 16 17 18 19 20 21"
+    "22 23 24 25 26 27 28"
+    "29 30 31            "
+    "                    ")
+  (graphical-calendar (date year: 2023 month: oct) wkst: sun))
+
+(test-equal "Exact lineup"
+  '("   februari 1800    "
+    "to fr lö sö må ti on"
+    " 1  2  3  4  5  6  7"
+    " 8  9 10 11 12 13 14"
+    "15 16 17 18 19 20 21"
+    "22 23 24 25 26 27 28"
+    "                    "
+    "                    ")
+  (graphical-calendar (date year: 1800 month: feb) wkst: thu))
+
+(test-equal "Exact lineup"
+  '("   februari 1800    "
+    "to fr lö sö må ti on"
+    " 1  2  3  4  5  6  7"
+    " 8  9 10 11 12 13 14"
+    "15 16 17 \x1b[7m18\x1b[m 19 20 21"
+    "22 23 24 25 26 27 28"
+    "                    "
+    "                    ")
+  (graphical-calendar (date year: 1800 month: feb day: 18) wkst: thu))
+
+
+
+;;; This also tests that month overflow into next year works
+(test-equal "Displayed calendar + overflowing into next year"
+ (string-append
+  "   november 2023         december 2023          januari 2024    \n"
+  "må ti on to fr lö sö  må ti on to fr lö sö  må ti on to fr lö sö\n"
+  "       1  2  3  4  5               1  2  3   1  2  3  4  5  6  7\n"
+  " 6  7  8  9 10 11 12   4  5  6  7  8  9 10   8  9 10 11 12 13 14\n"
+  "13 14 15 16 17 18 19  11 12 13 14 15 16 17  15 16 17 18 19 20 21\n"
+  "20 21 22 23 24 25 26  18 19 20 21 22 23 24  22 23 24 25 26 27 28\n"
+  "27 28 29 30           25 26 27 28 29 30 31  29 30 31            \n"
+  "                                                                \n")
+ (with-output-to-string
+   (lambda ()
+    (cal-3 (date year: 2023 month: dec)))))
+
+
+'((text calendar))