Allow user supplied description filters.

3 files changed, 35 insertions, 14 deletions

diff --git a/config.scm b/config.scm
index f30263fd..4efdccb6 100644
--- a/config.scm
+++ b/config.scm
@@ -2,10 +2,13 @@
 ;;; Currently loaded by main, and requires that `calendar-files`
 ;;; is set to a list of files (or directories).
 
+(use-modules (vcomponent))
+
 (use-modules (srfi srfi-26)
              (srfi srfi-88)
              (ice-9 regex)
              (ice-9 rdelim)
+             (sxml simple)
              (glob))
 
 (calendar-files (glob "~/.local/var/cal/*"))
@@ -28,3 +31,30 @@
     #f "T[A-Z]{3}[0-9]{2}" str
     'pre (lambda (m) (aref my-courses (string->symbol (match:substring m))))
     'post)))
+
+(define (a link) `(a (@ (href ,link)) ,link))
+
+(define (parse-html str)
+  (xml->sxml (string-append "<div>" str "</div>")
+             default-entity-handler:
+             (lambda (port name)
+               (case name
+                 [(nbsp) " "]
+                 [else (symbol->string name)]))) )
+
+(define (parse-links str)
+  (define regexp (make-regexp "https?://\\S+"))
+  (let recur ((str str))
+    (let ((m (regexp-exec regexp str)))
+      (if (not m)
+          '()
+          (cons* (match:prefix m)
+                 (a (match:substring m))
+                 (recur (match:suffix m)))))))
+
+(description-filter
+ (lambda (ev str)
+   (cond [(member (attr (parent ev) 'NAME) '("d_sektionen" #; "lithekod"
+                                             ))
+          (parse-html str)]
+         [else (parse-links str)])))
diff --git a/module/output/html.scm b/module/output/html.scm
index 394bb476..16520f0b 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -12,7 +12,6 @@
   #:use-module (srfi srfi-19 util)
   #:use-module (output general)
 
-  #:use-module (ice-9 regex)
 
   #:use-module (git)
   #:use-module (parameters)
@@ -24,8 +23,6 @@
                                (cdr p)))
                        param)) ,d)))
 
-(define (a link) `(a (@ (href ,link)) ,link))
-
 (define (date-link date)
   (date->string date "~Y-~m-~d"))
 
@@ -164,16 +161,6 @@
          (end (time->string (attr ev 'DTEND) fmt)))
     (values start end)))
 
-(define (description-preprocess text)
-  (define regexp (make-regexp "https?://\\S+"))
-
-  (let recur ((str text))
-    (let ((m (regexp-exec  regexp str)))
-      (if (not m)
-          '()
-          (cons* (match:prefix m)
-                 (a (match:substring m))
-                 (recur (match:suffix m)))))))
 
 ;; For sidebar, just text
 (define (fmt-single-event ev)
@@ -188,7 +175,7 @@
                 `(div ,start " — " ,end))
              ,(when (and=> (attr ev 'LOCATION) (negate string-null?))
                 `(div (b "Plats: ") ,(attr ev 'LOCATION)))
-             ,(and=> (attr ev 'DESCRIPTION) description-preprocess))))
+             ,(and=> (attr ev 'DESCRIPTION) (lambda (str) ((description-filter) ev str))))))
 
 ;; Single event in side bar (text objects)
 (define (fmt-day day)
diff --git a/module/parameters.scm b/module/parameters.scm
index cc91c18b..8438040d 100644
--- a/module/parameters.scm
+++ b/module/parameters.scm
@@ -22,3 +22,7 @@
 
 (define-public summary-filter
   (make-parameter (lambda (_ a) a) (ensure procedure?)))
+
+;; ev x str -> sxml
+(define-public description-filter
+  (make-parameter (lambda (_ a) a) (ensure procedure?)))