From 380986f85d1d57b7a2d231aad29c876b9835ee78 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sun, 24 Oct 2021 11:50:57 -0400
Subject: cli: bundle: Allow excluding asset files via regexp match.

---
 chickadee/cli/bundle.scm | 38 ++++++++++++++++++++++----------------
 1 file changed, 22 insertions(+), 16 deletions(-)

diff --git a/chickadee/cli/bundle.scm b/chickadee/cli/bundle.scm
index 9d66286..35ffd53 100644
--- a/chickadee/cli/bundle.scm
+++ b/chickadee/cli/bundle.scm
@@ -23,6 +23,7 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-37)
   #:use-module (system base compile)
@@ -158,7 +159,7 @@
       (() #t))))
 
 ;; Also snarfed from Guix, with some simplifications.
-(define* (copy-recursively source destination)
+(define* (copy-recursively source destination ignore-regexps)
   (define strip-source
     (let ((len (string-length source)))
       (lambda (file)
@@ -166,15 +167,18 @@
 
   (file-system-fold (const #t)                    ; enter?
                     (lambda (file stat result)    ; leaf
-                      (let ((dest (string-append destination
-                                                 (strip-source file))))
-                        (format #t "copy ~a → ~a~%" file dest)
-                        (case (stat:type stat)
-                          ((symlink)
-                           (let ((target (readlink file)))
-                             (symlink target dest)))
-                          (else
-                           (copy-file file dest)))))
+                      (unless (any (lambda (regexp)
+                                     (regexp-exec regexp file))
+                                   ignore-regexps)
+                        (let ((dest (string-append destination
+                                                   (strip-source file))))
+                          (format #t "copy ~a → ~a~%" file dest)
+                          (case (stat:type stat)
+                            ((symlink)
+                             (let ((target (readlink file)))
+                               (symlink target dest)))
+                            (else
+                             (copy-file file dest))))))
                     (lambda (dir stat result)     ; down
                       (let ((target (string-append destination
                                                    (strip-source dir))))
@@ -252,16 +256,16 @@
     (format #t "copy ~a → ~a~%" src dest)
     (copy-file src dest)))
 
-(define (install-assets dirs destdir)
+(define (install-assets dirs destdir ignore-regexps)
   (for-each (lambda (dir)
               (let ((target (string-append destdir "/" dir)))
-                (copy-recursively dir target)))
+                (copy-recursively dir target ignore-regexps)))
             dirs))
 
 (define (install-chickadee-data destdir)
   (let ((sharedir (string-append destdir "/share/chickadee")))
     (mkdir sharedir)
-    (copy-recursively %datadir sharedir)))
+    (copy-recursively %datadir sharedir '())))
 
 (define (install-init.scm code method destdir)
   (let ((init (string-append destdir "/init.scm")))
@@ -347,7 +351,8 @@ exec bin/guile ~a
                             "/usr/lib"
                             "/usr/lib/x86_64-linux-gnu"))
     (method . play)
-    (play-args . ())))
+    (play-args . ())
+    (ignore-files . ())))
 
 (define %tmpdir (or (getenv "TMPDIR") "/tmp"))
 
@@ -364,14 +369,15 @@ exec bin/guile ~a
          (launcher (assq-ref config 'launcher-name))
          (libraries (assq-ref config 'libraries))
          (libdirs (assq-ref config 'library-directories))
-         (method (assq-ref config 'method)))
+         (method (assq-ref config 'method))
+         (ignore-regexps (map make-regexp (assq-ref config 'ignore-files))))
     (mkdir destdir)
     (mkdir (string-append destdir "/bin"))
     (mkdir (string-append destdir "/lib"))
     (mkdir (string-append destdir "/share"))
     (install-init.scm code method destdir)
     (install-launcher launcher method args destdir)
-    (install-assets assets destdir)
+    (install-assets assets destdir ignore-regexps)
     (install-guile destdir bindirs)
     (install-chickadee-data destdir)
     (install-libraries destdir libraries (scan-for-libraries libdirs))
-- 
cgit v1.2.3