From 1b2b7c3eb939724696894f31ff27db97b0cac84c Mon Sep 17 00:00:00 2001
From: Andreas Widen <andreas@harmonicflow.org>
Date: Sat, 25 Nov 2023 17:21:37 +0100
Subject: Initial commit.

Signed-off-by: Andreas Widen <andreas@harmonicflow.org>
---
 apps/blog/utils.scm | 143 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 143 insertions(+)
 create mode 100644 apps/blog/utils.scm

(limited to 'apps/blog/utils.scm')

diff --git a/apps/blog/utils.scm b/apps/blog/utils.scm
new file mode 100644
index 0000000..6a3c4b2
--- /dev/null
+++ b/apps/blog/utils.scm
@@ -0,0 +1,143 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog utils)
+  #:use-module (apps aux lists)
+  #:use-module (apps aux web)
+  #:use-module (apps i18n)
+  #:use-module (haunt post)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (syntax-highlight)
+  #:use-module (syntax-highlight scheme)
+  #:use-module (syntax-highlight lexers)
+  #:export (post-groups->tag-list
+	    post-url-path
+	    posts/latest
+	    syntax-highlight
+            change-image-to-video
+	    tag-first?
+	    tag-system-path
+	    tag-url-path))
+
+
+(define (post-groups->tag-list groups)
+  "Return a list of Haunt tags from the list of grouped posts.
+
+   GROUPS (association list)
+     An association list of tags mapped to posts, as returned by the
+     posts/group-by-tag procedure from (haunt post) module."
+  (cond ((null? groups) '())
+	(else
+	 (cons (car (first groups))
+	       (post-groups->tag-list (rest groups))))))
+
+
+(define (post-url-path post)
+  "Return a URL path for the POST in the form blog/YYYY/POST-SLUG.
+
+   POST (<post>)
+     A post object as defined in (haunt post) module."
+  ;; Note: End the path with a slash so 'localized-root-path' down the road
+  ;; prepends the language tag.
+  (url-path-join "blog"
+		 (date->string (post-date post) "~Y")
+                 (post-slug post)
+                 ""))
+
+
+(define (posts/latest posts n)
+  "Return the latest N posts from the given list of posts."
+  (let ((latest-posts (posts/reverse-chronological posts)))
+    (cond
+     ((null? posts) '())
+     ((<= (length posts) n) latest-posts)
+     (else (list-head latest-posts n)))))
+
+
+(define (tag-first? tag-a tag-b)
+  "Return true if TAG-A goes first than TAG-B alphabetically.
+
+   This predicate is used for sorting tags.
+
+   TAG-A, TAG-B (string)
+     A tag as used by Haunt posts. For example: 'User interface'."
+  (string<? (string-downcase tag-a) (string-downcase tag-b)))
+
+
+(define (tag-system-path tag)
+  "Return a system path for the TAG in the form blog/tags/TAG-SLUG.
+
+   The path is relative to the website directory.
+
+   TAG (string)
+     A tag as used by Haunt posts. For example: 'Scheme API'."
+  (string-append "blog/tags/" (slugify tag)))
+
+
+(define (tag-url-path tag)
+  "Return a URL path for the TAG in the form blog/tags/TAG-SLUG.
+
+   TAG (string)
+     A tag as used by Haunt posts. For example: 'Scheme API'."
+  ;; Note: End the path with a slash so 'localized-root-path' down the road
+  ;; prepends the language tag.
+  (url-path-join "blog" "tags" (slugify tag) ""))
+
+
+
+;;;
+;;; Syntax highlighting.
+;;;
+
+(define %default-special-prefixes
+  '("define" "syntax"))
+
+(define lex-scheme/guix
+  ;; Specialized lexer for the Scheme we use in Guix.
+  ;; TODO: Add #~, #$, etc.
+  (make-scheme-lexer (cons* "with-imported-modules"
+                            "gexp" "ungexp"
+                            "ungexp-native" "ungexp-splicing"
+                            "ungexp-native-splicing"
+                            "mlet" "mlet*"
+                            "match"
+                            %default-special-symbols)
+                     %default-special-prefixes))
+
+(define (syntax-highlight sxml)
+  "Recurse over SXML and syntax-highlight code snippets."
+  (match sxml
+    ;; sceheme:
+    ;;(('code ('@ ('class "language-scheme")) code-snippet)
+    ;; `(code ,(highlights->sxml
+    ;;          (highlight lex-scheme/guix code-snippet))))
+    ((tag ('@ attributes ...) body ...)
+     `(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
+    ((tag body ...)
+     `(,tag ,@(map syntax-highlight body)))
+    ((? string? str)
+     str)))
+
+(define (change-image-to-video sxml)
+  "Replace <img> tags in SXML that refer to WebM videos with proper <video>
+tags.  This hack allows one to refer to a video from a Markdown document."
+  (match sxml
+    (('img ('@ attributes ...) body ...)
+     (let ((src (match (assoc 'src attributes)
+                  ((_ url) url)))
+           (alt (match (assoc 'alt attributes)
+                  ((_ text) text))))
+       (if (string-suffix? ".webm" src)
+           `(video (@ (src ,src)
+                      (poster ,(string-append src ".poster.png"))
+                      (controls "controls"))
+                   (p ,(G_ `(a (@ (href ,src) (class "link-subtle"))
+                               "Download video."))))
+           sxml)))
+    ((tag ('@ attributes ...) body ...)
+     `(,tag (@ ,@attributes) ,@(map change-image-to-video body)))
+    ((tag body ...)
+     `(,tag ,@(map change-image-to-video body)))
+    ((? string? str)
+     str)))
-- 
cgit v1.2.3-54-g00ecf