Set up hall

11 files changed, 560 insertions, 0 deletions

diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..f658e91
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,3 @@
+This project's license is GPL 3+.
+
+You can read the full license at https://www.gnu.org/licenses/gpl.html.
diff --git a/HACKING b/HACKING
new file mode 100644
index 0000000..a24d6fb
--- /dev/null
+++ b/HACKING
@@ -0,0 +1,47 @@
+-*- mode: org; coding: utf-8; -*-
+
+#+TITLE: Hacking disfluid
+
+* Contributing
+
+By far the easiest way to hack on disfluid is to develop using Guix:
+
+#+BEGIN_SRC bash
+  # Obtain the source code
+  cd /path/to/source-code
+  guix environment -l guix.scm
+  # In the new shell, run:
+  hall dist --execute && autoreconf -vif && ./configure && make check
+#+END_SRC
+
+You can now hack this project's files to your heart's content, whilst
+testing them from your `guix environment' shell.
+
+To try out any scripts in the project you can now use
+
+#+BEGIN_SRC bash
+  ./pre-inst-env scripts/${script-name}
+#+END_SRC
+
+If you'd like to tidy the project again, but retain the ability to test the
+project from the commandline, simply run:
+
+#+BEGIN_SRC bash
+  ./hall clean --skip "scripts/${script-name},pre-inst-env" --execute
+#+END_SRC
+
+** Manual Installation
+
+If you do not yet use  Guix, you will have to install this project's
+dependencies manually:
+  - autoconf
+  - automake
+  - pkg-config
+  - texinfo
+  - guile-hall
+
+Once those dependencies are installed you can run:
+
+#+BEGIN_SRC bash
+  hall dist -x && autoreconf -vif && ./configure && make check
+#+END_SRC
diff --git a/README b/README
new file mode 120000
index 0000000..314e17d
--- /dev/null
+++ b/README
@@ -0,0 +1 @@
+README.org
\ No newline at end of file
diff --git a/README.org b/README.org
new file mode 100644
index 0000000..9129e04
--- /dev/null
+++ b/README.org
@@ -0,0 +1,4 @@
+-*- mode: org; coding: utf-8; -*-
+
+#+TITLE: README for Disfluid
+
diff --git a/bootstrap b/bootstrap
new file mode 100644
index 0000000..2aaba09
--- /dev/null
+++ b/bootstrap
@@ -0,0 +1,8 @@
+#!/usr/local/bin/guile -s
+!#
+
+(add-to-load-path (dirname (current-filename)))
+
+(use-modules (disfluid build bootstrap))
+
+(main)
diff --git a/channels.scm b/channels.scm
new file mode 100644
index 0000000..682e85b
--- /dev/null
+++ b/channels.scm
@@ -0,0 +1,6 @@
+(cons
+ (channel
+  (name 'disfluid)
+  (url (dirname (current-filename)))
+  (branch "guix"))
+ %default-channels)
diff --git a/disfluid.scm b/disfluid.scm
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/disfluid.scm
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))))
diff --git a/doc/disfluid.texi b/doc/disfluid.texi
new file mode 100644
index 0000000..9c152f6
--- /dev/null
+++ b/doc/disfluid.texi
@@ -0,0 +1,60 @@
+\input texinfo
+@c -*-texinfo-*-
+
+@c %**start of header
+@setfilename disfluid.info
+@documentencoding UTF-8
+@settitle Disfluid Reference Manual
+@c %**end of header
+
+@include version.texi
+
+@copying
+Copyright @copyright{} 2022 Vivien Kraus
+
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.  A
+copy of the license is included in the section entitled ``GNU Free
+Documentation License''.
+@end copying
+
+@dircategory The Algorithmic Language Scheme
+@direntry
+* Disfluid: (disfluid).   
+@end direntry
+
+@titlepage
+@title The Disfluid Manual
+@author Vivien Kraus
+
+@page
+@vskip 0pt plus 1filll
+Edition @value{EDITION} @*
+@value{UPDATED} @*
+
+@insertcopying
+@end titlepage
+
+@contents
+
+@c *********************************************************************
+@node Top
+@top Disfluid
+
+This document describes Disfluid version @value{VERSION}.
+
+@menu
+* Introduction::                Why Disfluid?
+@end menu
+
+@c *********************************************************************
+@node Introduction
+@chapter Introduction
+
+INTRODUCTION HERE
+
+This documentation is a stub.
+
+@bye