diff options
author | Andreas Widen <andreas@harmonicflow.org> | 2023-11-25 17:21:37 +0100 |
---|---|---|
committer | Andreas Widen <andreas@harmonicflow.org> | 2023-11-25 17:21:37 +0100 |
commit | 1b2b7c3eb939724696894f31ff27db97b0cac84c (patch) | |
tree | efb7b7746a628efb7bb99b2e44c9c2fbfd75b656 /apps/blog/utils.scm | |
download | hf-web-1b2b7c3eb939724696894f31ff27db97b0cac84c.tar.xz hf-web-1b2b7c3eb939724696894f31ff27db97b0cac84c.zip |
Initial commit.
Signed-off-by: Andreas Widen <andreas@harmonicflow.org>
Diffstat (limited to 'apps/blog/utils.scm')
-rw-r--r-- | apps/blog/utils.scm | 143 |
1 files changed, 143 insertions, 0 deletions
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))) |