From 68dbd5c9de78ad803cc33973db40d22e29c532ec Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 30 Jan 2020 01:17:54 +0100
Subject: gexp: Move 'file-mapping->tree' to (guix store).

* guix/gexp.scm (%not-slash): Remove.
(file-mapping->tree): Move to...
* guix/store.scm (file-mapping->tree): ... here.
---
 guix/store.scm | 40 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 40 insertions(+)

(limited to 'guix/store.scm')

diff --git a/guix/store.scm b/guix/store.scm
index f99fa581a8..77ee23fdd8 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
             build-things
             build
@@ -1220,6 +1221,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 build-things
   (let ((build (operation (build-things (string-list things)
                                         (integer mode))
-- 
cgit v1.2.3