Merge branch 'core-updates'

1 files changed, 40 insertions, 0 deletions

diff --git a/guix/store.scm b/guix/store.scm
index fb4b92e0c4..6c7c07fd2d 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -103,6 +103,7 @@
             add-text-to-store
             add-to-store
             add-file-tree-to-store
+            file-mapping->tree
             binary-file
             with-build-handler
             map/accumulate-builds
@@ -1237,6 +1238,45 @@ an arbitrary directory layout in the store without creating a derivation."
             (hash-set! cache tree result)
             result)))))
 
+(define (file-mapping->tree mapping)
+  "Convert MAPPING, an alist like:
+
+  ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
+
+to a tree suitable for 'add-file-tree-to-store' and 'interned-file-tree'."
+  (let ((mapping (map (match-lambda
+                        ((destination . source)
+                         (cons (string-tokenize destination %not-slash)
+                               source)))
+                      mapping)))
+    (fold (lambda (pair result)
+            (match pair
+              ((destination . source)
+               (let loop ((destination destination)
+                          (result result))
+                 (match destination
+                   ((file)
+                    (let* ((mode (stat:mode (stat source)))
+                           (type (if (zero? (logand mode #o100))
+                                     'regular
+                                     'executable)))
+                      (alist-cons file
+                                  `(,type (file ,source))
+                                  result)))
+                   ((file rest ...)
+                    (let ((directory (assoc-ref result file)))
+                      (alist-cons file
+                                  `(directory
+                                    ,@(loop rest
+                                            (match directory
+                                              (('directory . entries) entries)
+                                              (#f '()))))
+                                  (if directory
+                                      (alist-delete file result)
+                                      result)))))))))
+          '()
+          mapping)))
+
 (define current-build-prompt
   ;; When true, this is the prompt to abort to when 'build-things' is called.
   (make-parameter #f))