diff options
author | Vivien Kraus <vivien@planete-kraus.eu> | 2022-01-15 10:54:33 +0100 |
---|---|---|
committer | Vivien Kraus <vivien@planete-kraus.eu> | 2022-01-28 22:49:21 +0100 |
commit | 473095cfebc86ca09ccaedee142877bdfb9fd0d6 (patch) | |
tree | 2c76458651771469341836212b579e8fd1be362e /disfluid |
Set up hall
Diffstat (limited to 'disfluid')
-rw-r--r-- | disfluid/build/bootstrap.scm | 239 | ||||
-rw-r--r-- | disfluid/build/post-commit-hook.scm | 113 | ||||
-rw-r--r-- | disfluid/i18n.scm | 79 |
3 files changed, 431 insertions, 0 deletions
diff --git a/disfluid/build/bootstrap.scm b/disfluid/build/bootstrap.scm new file mode 100644 index 0000000..158c1b9 --- /dev/null +++ b/disfluid/build/bootstrap.scm @@ -0,0 +1,239 @@ +(define-module (disfluid build bootstrap) + #:use-module (disfluid i18n) + #:use-module (ice-9 popen) + #:use-module (ice-9 receive) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (ice-9 optargs) + #:declarative? #t + #:export (main)) + +(define* (main #:key + (emacs "emacs") + (hall "hall") + (git "git") + (mkdir "mkdir") + (which "which") + (autoreconf "autoreconf")) + (let ((config (false-if-exception + (resolve-interface '(disfluid config))))) + ;; The build system is internationalized, but a prior version of it + ;; is necessary to get the localedir. Otherwise, gettext cannot be + ;; set up. + (when config + (bindtextdomain "disfluid" (module-ref config 'localedir)) + (textdomain "disfluid"))) + (let ((disfluid-version + (with-exception-handler + (lambda (exn) + ;; .tarball-version is not present, use git + (receive (from to pids) + (pipeline + `((,git "describe" "--tags" "--dirty" "--broken"))) + (match (read-line from) + ((? eof-object? _) + "SNAPSHOT") + (version version)))) + (lambda () + ;; Try to read from .tarball-version + (call-with-input-file ".tarball-version" + read-line)) + #:unwind? #t))) + (call-with-output-file "hall.scm" + (lambda (port) + (write + `(hall-description + (name "disfluid") + (prefix "") + (version ,disfluid-version) + (author "Vivien Kraus") + (copyright (2022)) + (synopsis "Solid stack implementation") + (description "This package provides a Solid implementation, client and server.") + (home-page "https://disfluid.planete-kraus.eu") + (license gpl3+) + (dependencies `()) + (files (libraries + ((scheme-file "disfluid") + (directory "disfluid" ()))) + (tests ((directory "tests" ()))) + (programs ((directory "scripts" ()))) + (documentation + ((org-file "README") + (symlink "README" "README.org") + (text-file "HACKING") + (text-file "COPYING") + (directory "doc" ((texi-file "disfluid"))))) + (infrastructure + ((scheme-file "hall"))))) + port))) + ;; Before the scan, add a dummy disfluid/config.scm so that it is + ;; seen by the scan + (begin + (call-with-output-file "disfluid/config.scm" + (lambda (port) + (write + `(define-module (disfluid config)) port))) + (system* hall "scan" "-x") + (delete-file "disfluid/config.scm")) + (system* hall "distribute" "-x") + ;; Add (disfluid config) + (system* emacs "--batch" + "--file" "configure.ac" + "--eval" + (format #f "~s" + `(progn + (search-forward "AC_OUTPUT") + (beginning-of-line) + (insert "AX_RECURSIVE_EVAL([$localedir], EXPANDED_LOCALEDIR)") + (newline) + (insert "AC_SUBST([EXPANDED_LOCALEDIR])") + (newline) + (insert "AC_CONFIG_FILES([disfluid/config.scm])") + (newline) + (save-buffer))) + "--file" "Makefile.am" + "--eval" + (format #f "~s" + `(progn + (end-of-buffer) + (insert "dist-hook:") + (newline) + (insert-tab) + (insert "rm -f $(distdir)/disfluid/config.scm") + (newline) + (save-buffer)))) + (call-with-output-file "disfluid/config.scm.in" + (lambda (port) + (write + `(define-module (disfluid config) + #:export (localedir)) + port) + (newline port) + (write + `(define localedir "@EXPANDED_LOCALEDIR@") + port))) + ;; Use gettext + (system* emacs "--batch" + "--file" "configure.ac" + "--eval" + (format #f "~s" + `(progn + (beginning-of-buffer) + (search-forward "AC_OUTPUT") + (beginning-of-line) + (insert "AM_GNU_GETTEXT([external])") + (newline) + (insert "AM_GNU_GETTEXT_VERSION([0.21])") + (newline) + (beginning-of-buffer) + (search-forward "AC_CONFIG_FILES([Makefile") + (insert " po/Makefile.in") + (save-buffer)))) + (system* emacs "--batch" + "--file" "Makefile.am" + "--eval" + (format #f "~s" + `(progn + (beginning-of-buffer) + (insert "SUBDIRS = po") + (newline) + (save-buffer)))) + (system* mkdir "-p" "po") + (call-with-output-file "po/Makevars" + (lambda (port) + (format port "\ +DOMAIN = $(PACKAGE) +subdir = po +top_builddir = .. +XGETTEXT_OPTIONS = --keyword=_ --keyword=N_ --keyword=G_ +COPYRIGHT_HOLDER = Viven Kraus +PACKAGE_GNU = +MSGID_BUGS_ADDRESS = vivien@planete-kraus.eu +EXTRA_LOCALE_CATEGORIES = +USE_MSGCTXT = no +MSGMERGE_OPTIONS = +MSGINIT_OPTIONS = +PO_DEPENDS_ON_POT = yes +DIST_DEPENDS_ON_UPDATE_PO = yes +"))) + (call-with-output-file "po/POTFILES.in" + (lambda (port) + (define (enter? name stat result) + (not (member (basename name) '(".git" ".svn" "CVS" ".last-commit")))) + (define (leaf name stat result) + (if (or (string-suffix? ".scm" name) + (string-suffix? ".scm.in" name)) + (match result + ((directory . files) + `(,directory . (,name . ,files)))) + result)) + (define (down name stat result) + (match result + ((() . files) + `((,name) . ,files)) + ((directory . files) + `((,name + ,@directory) + . ,files)))) + (define (up name stat result) + (match result + (((_ . directory) . files) + `(,directory . ,files)))) + (define (skip name stat result) + result) + (define (error name stat errno result) + (format (current-error-port) (G_ "Warning: ~a: ~a~%") + name (strerror errno)) + result) + (match + (file-system-fold enter? leaf down up skip error + '(() . ()) + ".") + ((() . files) + (for-each + (lambda (file) + (display file port) + (newline port)) + (sort files string<?)))))) + ;; Install the post-commit hook + (system* mkdir "-p" ".git/hooks") + (call-with-output-file ".git/hooks/post-commit-" + (lambda (port) + (format port + "#!~a -s +!# + +(add-to-load-path ~s) + +(use-modules (disfluid build post-commit-hook)) + +(main) +" + (receive (from to pids) + (pipeline + `((,which "guile"))) + (match `(,pids ,(read-line from)) + ((((= waitpid + (_ . (= status:exit-val 0)))) + (? string? guile)) + guile) + (else + (format (current-error-port) + (G_ "Cannot find guile, using /usr/local/bin/guile.")) + "/usr/local/bin/guile"))) + (dirname (dirname (dirname (current-filename))))))) + (chmod ".git/hooks/post-commit-" #o755) + (rename-file ".git/hooks/post-commit-" ".git/hooks/post-commit") + ;; Also distribute the channels.scm file, so that it can be + ;; internationalized + (system* emacs "--batch" + "--file" "Makefile.am" + "--eval" + (format #f "~s" + `(progn + (search-forward "EXTRA_DIST =") + (insert "channels.scm ") + (save-buffer)))) + (system* autoreconf "-vif"))) diff --git a/disfluid/build/post-commit-hook.scm b/disfluid/build/post-commit-hook.scm new file mode 100644 index 0000000..4766b9a --- /dev/null +++ b/disfluid/build/post-commit-hook.scm @@ -0,0 +1,113 @@ +(define-module (disfluid build post-commit-hook) + #:use-module (disfluid i18n) + #:use-module (ice-9 popen) + #:use-module (ice-9 receive) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (ice-9 optargs) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:declarative? #t + #:export (main)) + +(define-syntax system** + (syntax-rules () + ((system** msg args ...) + (unless (zero? (status:exit-val (system* args ...))) + (raise + (condition + (&error) + (&message (message msg)))))))) + +(define source + (dirname + (dirname (dirname (current-filename))))) + +(define* (main #:key + (rm "rm") + (guix "guix") + (git "git")) + (guard (exn + ((and (error? exn) + (message-condition? exn)) + (format (current-error-port) + (G_ "Cannot update the package: ~a\n") + (condition-message exn)) + (exit 1))) + (system** (G_ "cannot cleanup .last-commit/") + rm "-rf" ".last-commit") + (system** (G_ "cannot clone the repository to .last-commit/") + git "clone" source ".last-commit") + (chdir ".last-commit") + (system** (G_ "cannot checkout main in .last-commit/") + git "checkout" "main") + (chdir "..") + (let* ((commit-id + (receive (from to pids) + (pipeline + `((,git "rev-parse" "HEAD"))) + (match `(,pids ,(read-line from)) + ((((= waitpid + (_ . (= status:exit-val 0)))) + (? string? commit-id)) + commit-id) + (else + (raise (condition (&error) + (&message + (message (G_ "git rev-parse failed"))))))))) + (hash + (receive (from to pids) + (pipeline + `((,guix "hash" "-x" "-S" "nar" ".last-commit"))) + (match `(,pids ,(read-line from)) + ((((= waitpid + (_ . (= status:exit-val 0)))) + (? string? hash)) + hash) + (else + (raise (condition (&error) + (&message + (message (G_ "guix hash failed"))))))))) + (version + (begin + (chdir ".last-commit") + (receive (from to pids) + (pipeline + `((,git "describe" "--tags" "--dirty" "--broken"))) + (match `(,pids ,(read-line from)) + ((((= waitpid + (_ . (= status:exit-val 0)))) + (? string? version)) + version) + (else + "UNKNOWN")))))) + (system** (G_ "cannot checkout the guix branch") + git "checkout" "guix") + (guard (exn + (#t + (raise + (condition (&error) + (&message + (message (G_ "cannot create a new release"))))))) + (call-with-output-file "vkraus/packages/disfluid/release.scm-" + (lambda (port) + (write `(define-module (vkraus packages disfluid release) + #:declarative? #t + #:export (version commit hash)) + port) + (newline port) + (write `(define version ,version) port) + (newline port) + (write `(define commit ,commit-id) port) + (newline port) + (write `(define hash ,hash) port))) + (rename-file "vkraus/packages/disfluid/release.scm-" + "vkraus/packages/disfluid/release.scm")) + (system** (G_ "cannot commit the new release") + git "commit" "-a" "-m" (format #f (G_ "Update disfluid to ~a.") version)) + (system** (G_ "cannot push the new release") + git "push") + (chdir "..") + (system** (G_ "cannot clean up the last commit files") + rm "-rf" ".last-commit")))) diff --git a/disfluid/i18n.scm b/disfluid/i18n.scm new file mode 100644 index 0000000..ea16f58 --- /dev/null +++ b/disfluid/i18n.scm @@ -0,0 +1,79 @@ +(define-module (disfluid i18n) + #:use-module (ice-9 i18n) + #:use-module (ice-9 threads) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:use-module (web request) + #:declarative? #t + #:export ((MY_LC_ALL . LC_ALL) domain G_ (my-ngettext . ngettext)) + #:re-export (bindtextdomain textdomain)) + +(define switching-locale-mutex + (make-mutex)) + +(define sort-qlist + (cute stable-sort <> + (match-lambda* + (((px . _) (py . _)) + (> px py))))) + +(define get-preferred-language + (match-lambda + ((? request? + (= request-accept-language + (= sort-qlist + ((_ . language) _ ...)))) + (get-preferred-language language)) + ((? string? + (= (cute string-split <> #\-) + ((? string? lang) + (? string? (= string-upcase region))))) + (format #f "~a_~a.UTF-8" lang region)) + (else ""))) + +(define MY_LC_ALL + (make-parameter "" get-preferred-language)) + +(define domain + (make-parameter "disfluid")) + +(define (disambiguate str out) + (if (string=? out str) + ;; No translation, disambiguate + (match (string-index str #\|) + (#f str) + (start (substring str (+ start 1)))) + ;; Translation performed + out)) + +(define (set-lc-all locale) + (catch #t + (lambda () + (setlocale LC_ALL locale)) + (lambda error + (setlocale LC_ALL "")))) + +(define (with-locale-lock thunk) + (with-mutex switching-locale-mutex + (let ((previous-locale (setlocale LC_ALL))) + (dynamic-wind + (lambda () + (set-lc-all (MY_LC_ALL))) + thunk + (lambda () + (set-lc-all previous-locale)))))) + +(define (G_ str) + (disambiguate + str + (with-locale-lock + (lambda () + (gettext str (domain)))))) + +(define (my-ngettext msg msgplural n) + (let ((out (with-locale-lock + (lambda () + (ngettext msg msgplural n (domain)))))) + (disambiguate + msg + (disambiguate msgplural out)))) |