(zilch core vfs): add vfs-subset function

core/src/vfs.sld

@@ -5,12 +5,13 @@
     (scheme base) (scheme file)
     (chicken file)
     (zilch magic) (zilch file) (zilch zexpr)
-    (srfi 4) (srfi 113) (srfi 128) (srfi 146))
+    (srfi 4) (srfi 113) (srfi 128) (srfi 146) (srfi 152))
 
   (export
     <vfs> make-vfs vfs? vfs-contents
     vfs-dir-files vfs-file-ref
     vfs-dir-filter vfs-dir-filter-all
+    vfs-subdir
     vfs-from-directory vfs-from-store
     vfs-to-store)
 
@@ -91,6 +92,23 @@
         (zdir contents))
       (read-dir ""))
 
+    ;; Creates a new VFS that is a subdirectory of the existing
+    ;; VFS.
+    (define (vfs-subdir vfs subdir)
+      (define subdirprefix (string-append subdir "/"))
+      (define subdirprefixlength (string-length subdirprefix))
+      (if (string=? subdir "")
+       vfs
+       (make-vfs
+        (mapping-map
+         (lambda (key value)
+           (cond
+             ((string=? (car key) subdir) (values (cons "" (cdr key)) value))
+             ((string-prefix? subdirprefix (car key)) (values (cons (string-copy (car key) subdirprefixlength) (cdr key)) value))
+             (else (values))))
+         (make-default-comparator)
+         (vfs-contents vfs)))))
+
     ;; Generates a full VFS structure from an on-disk directory.
     (define (vfs-from-directory osdir)
       (define out (mapping (make-default-comparator)))
@@ -110,6 +128,8 @@
       (make-vfs out))
 
     (define (vfs-from-store store-path)
-      (define osdir (store-path-realised store-path))
-      ; TODO(puck): use builtin:fetchurl here instead of reimporting (requires divining a hash first)
-      (vfs-from-directory osdir))))
+      (if (vfs? store-path)
+        store-path
+        (let ((osdir (store-path-realised store-path)))
+         ; TODO(puck): use builtin:fetchurl here instead of reimporting (requires divining a hash first)
+         (vfs-from-directory osdir))))))