From 1b2b7c3eb939724696894f31ff27db97b0cac84c Mon Sep 17 00:00:00 2001 From: Andreas Widen Date: Sat, 25 Nov 2023 17:21:37 +0100 Subject: Initial commit. Signed-off-by: Andreas Widen --- apps/base/utils.scm | 224 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 224 insertions(+) create mode 100644 apps/base/utils.scm (limited to 'apps/base/utils.scm') diff --git a/apps/base/utils.scm b/apps/base/utils.scm new file mode 100644 index 0000000..31e18ea --- /dev/null +++ b/apps/base/utils.scm @@ -0,0 +1,224 @@ +;;; Harmonic Flow web site + +(define-module (apps base utils) + #:use-module (apps aux lists) + #:use-module (apps aux system) + #:use-module (apps base types) + #:use-module (apps i18n) + #:use-module (haunt artifact) + #:use-module (ice-9 i18n) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (gnu-url + hfweb-url + locale-display-name + manual-url + manual-devel-url + manual-url-with-language + number* + paginate + packages-url)) + + +;;; +;;; Harmonic Flow variables. +;;; + +(define* (gnu-url #:optional (path "")) + "Append PATH to GNU.org URL. + + PATH (string) + An optional relative URL path to a resource. For example: + 'software/guile/'. + + RETURN VALUE (string) + A URL. For example: https://gnu.org/software/guile/." + (string-append "https://gnu.org/" path)) + +(define hfweb-root-url-path + ;; Path to hfge site: + (let ((path (match (getenv "HFGE_WEB_SITE_LOCAL") + ;; If we are trying out the website locally, use "/" as the root. + ("yes" "/") + (else (or (getenv "HFGE_WEB_SITE_ROOT_PATH") "/"))))) + (make-parameter + path + ;; When setting hfweb-root-url-path, make it end in a slash. + (lambda (path) + (if (string-suffix? "/" path) + path + (string-append path "/")))))) + +(define (locale-display-name) + "Return the display name of the current locale." + ;; TRANSLATORS: The locale’s display name; please include a country + ;; code like in English (US) *only* if there are multiple + ;; translations for the same language. + (let ((str '(G_ "English"))) + ;;; XXX: If we ever add a separate English (UK) translation, then + ;;; change the display name to English (US), but maybe do not + ;;; change str, because it would break translated PO files. + (gettext (cadr str)))) + + + +;;; +;;; URL linking. +;;; + + +(define* (hfweb-url #:optional (subpath "") #:key (localize #t)) + "Append SUBPATH to Harmonic Flow root URL path (see hfweb-root-url-path). + + SUBPATH (string) + An optional relative URL path to a resource in the Harmonic Flwo path. + For example: 'indeed/something-XYZ/'. + + LOCALIZE (boolean) + Whether to prepend the result of 'localized-root-path' to the URL path. + + RETURN VALUE (string) + A URL path. For example: /indeed/something/-XYZ/." + (string-append (hfweb-root-url-path) + (if localize (localized-root-path subpath) "") + subpath)) + + +(define* (manual-url #:optional (subpath "") + #:key (language "en")) + "Append SUBPATH to the Harmonic Flow manual URL path. + + SUBPATH (string) + An optional relative URL path to a section of the manual. + For example: 'SomeFile.html'. + + RETURN VALUE (string) + A URL path. For example: + /indeed/SomeFile.html." + (string-append + (hfweb-url (string-append (string-append "manual/" language + "/html_node/") + subpath) #:localize #f))) + +(define* (manual-devel-url #:optional (subpath "") + #:key (language "en")) + "Similar to 'manual-url', but link to the development manual." + (string-append + (hfweb-url (string-append (string-append "manual/devel/" language + "/html_node/") + subpath) #:localize #f))) + +(define* (manual-url-with-language _ language #:optional (subpath "")) + "Shorthand for manual-url without keywords for prettier output +PO files when marked for translation. It can be marked for translation +as: + + (G_ (manual-url-with-language (G_ \"en\") (G_ \"Some-section.html\"))) + + LANGUAGE (string) + Normalized language for the Guix manual as produced by +'doc/build.scm' in the Guix source tree, i.e. \"en\" for the English +manual. + + SUBPATH (string) + Like manual-url. + + RETURN VALUE (string) + A URL path. For example: + /software/guix/manual/en/html_node/System-installation.html." + ;; The _ argument is a placeholder for an arg added by G_, cf. i18n-howto.txt. + (manual-url subpath #:language language)) + + +;;; +;;; Helper procedures. +;;; + +(define (number* number) + "Return NUMBER correctly formatting according to English conventions." + (number->locale-string number 0 + (or (false-if-exception + (make-locale LC_ALL "en_US.utf8")) + (make-locale LC_ALL "en_US.UTF-8")))) + + +(define* (paginate #:key dataset (limit 30) base-path template (context '()) writer) + "Distribute the objects of the DATASET in pages. + + DATASET (list) + A list with any kind of object. + + LIMIT (integer) + The maximum number of objects that should appear in a page. + + The limit is optional. If not provided, it defaults to 30. + + BASE-PATH (string) + A system path relative to the website directory where all the + pages will be written to. For example: 'blog' or 'blog/tags'. + + In the latter example, pages would be written to files in a path + like 'blog/tags/page/PAGE_NUMBER/index.html'. + + TEMPLATE (procedure) + A procedure that accepts a context and returns an SXML tree. + + CONTEXT (context) + A context object as defined in (apps base types). The context + holds additional data to insert into the TEMPLATE. + + The context is optional, and will always be extended to include + the following data that can be used in the TEMPLATE: + + items (list) + The list of items to insert into the page. + + total-pages (integer) + The number of pages generated to distribute all items. + + page-number (integer) + The number of the page. + + WRITER + A procedure that writes the page into a given format. See Haunt's + 'sxml->html' writer in the (haunt html) module, for example. + + RETURN VALUE (list) + A list of objects as defined in (haunt page) module." + (let* ((grouped-data (list-group dataset limit)) + (total-pages (cons "total-pages" (length grouped-data)))) + ;; Read the following like (cons Page ListOfPages): + (cons + ;; Page + ;; This is the cover of the pages. For example, the resource + ;; located in a path such as /blog/, which is identical to the + ;; resource available in /blog/page/1/. + (let* ((page-number (cons "page-number" 1)) + (path (path-join base-path "index.html")) + (items + (match grouped-data + (() + (cons "items" '())) + ((head _ ...) + (cons "items" head)))) + (new-context + (append context + (list items page-number total-pages)))) + + (serialized-artifact path (template new-context) writer)) + ;; ListOfPages + ;; This is a list of pages that are the actual ordered pages + ;; located in paths such as /blog/page/NUMBER/. + (map + (lambda (index) + (let* ((page-number (cons "page-number" (+ index 1))) + (path (path-join base-path + "page" + (number->string (+ index 1)) + "index.html")) + (items (cons "items" (list-ref grouped-data index))) + (new-context + (append context (list items page-number total-pages)))) + (serialized-artifact path (template new-context) writer))) + + (iota (length grouped-data)))))) -- cgit v1.2.3-54-g00ecf