upgraded to newest install-lib version

install-lib-module.scm

@@ -1,5 +1,5 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib-module.scm,v 1.2 2003/12/16 16:44:40 frese Exp $
+;;; $Id: install-lib-module.scm,v 1.3 2004/01/04 14:34:32 frese Exp $
 
 ;;; Interfaces
 
@@ -19,10 +19,12 @@
           install-directories
           install-directory-contents
 
-          get-directory
+          identity
+          parse-boolean
+          show-boolean
 
-          with-optional-part?
+          get-directory
-          is-running-dry?
+          get-option-value
 
           install-main))
 

install-lib.scm

@@ -1,14 +1,12 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib.scm,v 1.2 2003/12/16 16:44:40 frese Exp $
+;;; $Id: install-lib.scm,v 1.3 2004/01/04 14:34:32 frese Exp $
 
 ;; TODO
 ;; - add support for image creation,
 ;; - add support to maintain a documentation index,
-;; - add "--mode" option to specify permissions for files/directories.
 ;; - add "--verbose" to show whats being done.
 ;; - add "--log" option to specify a log file.
 ;; - decide what to do when target files already exist
-;; - allow installation of platform-specific files only
 
 ;;
 ;; Utilities
@@ -16,9 +14,11 @@
 
 (define default-perms #o755)
 
+;; Return the name of the parent directory of FNAME.
 (define (parent-directory fname)
   (file-name-directory (directory-as-file-name fname)))
 
+;; Create directory FNAME and all its parents, as needed.
 (define (create-directory&parents fname . rest)
   (let-optionals rest ((perms default-perms))
     (let ((parent (parent-directory fname)))
@@ -27,12 +27,16 @@
       (if (not (file-exists? fname))
             (-create-directory fname perms)))))
 
+;; Return the length of the longest prefix common to lists L1 and L2,
+;; by comparing elements using PRED (defaults to EQUAL?).
 (define (common-prefix-length l1 l2 . rest)
   (let-optionals rest ((pred equal?))
     (if (or (null? l1) (null? l2) (not (pred (first l1) (first l2))))
         0
         (+ 1 (apply common-prefix-length (cdr l1) (cdr l2) rest)))))
 
+;; Return the name of file NAME relative to DIR (defaults to current
+;; directory).
 (define (relative-file-name name . rest)
   (let-optionals rest ((dir (cwd)))
     (let* ((abs-pl (split-file-name (absolute-file-name name)))
@@ -41,6 +45,15 @@
       (path-list->file-name (append (make-list (- (length dir-pl) cp-len) "..")
                                     (drop abs-pl cp-len))))))
 
+;; Return the name of FNAME, which must be absolute, with NEW-ROOT as
+;; root.
+(define (re-root-file-name fname new-root)
+  (let ((fname-pl (split-file-name fname))
+        (new-root-pl (split-file-name new-root)))
+    (if (string=? (first fname-pl) "")
+        (path-list->file-name (append new-root-pl (cdr fname-pl)))
+        (error "no root to replace in relative file name" fname))))
+
 ;; Copy file/symlink SOURCE to TARGET and set the permisions of TARGET
 ;; to PERMS. TARGET must be the name of a non-existing file (i.e. it
 ;; cannot be the name of a directory).
@@ -67,15 +80,27 @@
                    (decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
                    (decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
 
+;; Replace all bindings of KEY in ALIST with one binding KEY to DATUM.
+(define (alist-replace key datum alist)
+  (alist-cons key datum (alist-delete key alist)))
+
+;; Return the value associated with KEY in ALIST. If none exists,
+;; return DEFAULT, or signal an error if no DEFAULT was given.
+(define (alist-get key alist . rest)
+  (cond ((assoc key alist) => cdr)
+        ((not (null? rest)) (first rest))
+        (else (error "internal error: cannot find key in alist" key alist))))
+
+;; Return a string of max(M,N) white spaces.
+(define (spaces m n) (make-string (max m n) #\space))
+
 ;;
 ;; Support for dry runs.
 ;;
 
-(define *dry-run* (make-fluid #f))
-
 (define (wrap-for-dry-run real-fn dry-fn)
   (lambda args
-    (apply (if (fluid *dry-run*) dry-fn real-fn) args)))
+    (apply (if (get-option-value 'dry-run) dry-fn real-fn) args)))
 
 (define (dry-run-print msg . args)
   (apply format #t msg args) (newline))
@@ -116,14 +141,20 @@
 ;; Versions are represented as lists of integers, the most significant
 ;; being at the head.
 
+;; Return the printed representation of VERSION.
 (define (version->string version)
   (string-join (map number->string version) "."))
 
+;; Convert the printed representation of a version found in
+;; VERSION-STRING to the version it represents.
 (define string->version
   (let ((split-version (infix-splitter ".")))
     (lambda (version-string)
       (map string->number (split-version version-string)))))
 
+;; Compare two versions lexicographically and return the symbol
+;; 'smaller if the first is strictly smaller than the second, 'equal
+;; if both are equal, and 'greater otherwise.
 (define (version-compare v1 v2)
   (cond ((and (null? v1) (null? v2)) 'equal)
         ((null? v1) 'smaller)
@@ -141,6 +172,28 @@
 ;; Layouts
 ;;
 
+;; Names of all shared locations (i.e. the ones which do not depend on
+;; the platform).
+(define shared-locations
+  '(active base misc-shared scheme doc))
+
+;; Names of all non-shared (i.e. platform-dependent) locations.
+(define non-shared-locations
+  '(lib))
+
+;; All locations defined for a layout.
+(define all-locations (append shared-locations non-shared-locations))
+
+;; Return true iff the given location is "active", that is if files
+;; should be installed in it.
+(define (active-location? location)
+  (member location (if (get-option-value 'non-shared-only)
+                       non-shared-locations
+                       all-locations)))
+
+;; Parse a layout given as a string of comma-separated bindings. A
+;; binding consists of the name of a location, followed by an equal
+;; sign and the name of the directory to associate to the location.
 (define parse-layout
   (let ((split-defs (infix-splitter ","))
         (split-sides (infix-splitter "=")))
@@ -165,9 +218,9 @@
          (cons (car key/value) (absolute-file-name (cdr key/value) prefix)))
        layout))
 
-(define (layout-dir layout dir)
+;; Return the directory associated with the LOCATION in LAYOUT.
-  (cond ((assoc dir layout) => cdr)
+(define (layout-dir layout location)
-        (else #f)))
+  (alist-get location layout #f))
 
 ;; Predefined layouts
 
@@ -175,9 +228,7 @@
   `((base        . ,base)
     (misc-shared . ,base)
     (scheme      . ,(absolute-file-name "scheme" base))
-    (lib         . ,(absolute-file-name
+    (lib         . ,(absolute-file-name "lib" base))
-                     (path-list->file-name (list "lib" platform))
-                     base))
     (doc         . ,(absolute-file-name "doc" base))))
 
 (define (scsh-layout-1 platform pkg)
@@ -221,14 +272,20 @@
   (extensions package-extensions)
   (install-thunk package-install-thunk))
 
+;; Return the full name of PKG.
 (define (package-full-name pkg)
   (string-append
    (package-name pkg) "-" (version->string (package-version pkg))))
 
+;; Return the value of extension called EXT for PKG. If such an
+;; extension doesn't exist, return #f.
+(define (package-extension pkg ext)
+  (alist-get ext (package-extensions pkg) #f))
+
 ;; List of all defined packages
 (define packages '())
 
-;; Add a package to the above list
+;; Add PKG to the above list of all defined packages.
 (define (add-package pkg)
   (set! packages (cons pkg packages)))
 
@@ -237,9 +294,80 @@
     ((define-package name version extensions body ...)
      (add-package (make-package name
                                 (quote version)
-				(quote extensions)
+				(quasiquote extensions)
                                 (lambda () body ...))))))
 
+;;
+;; Package options
+;;
+
+(define-record-type pkg-opt
+  (really-make-pkg-opt key
+                       help
+                       arg-help
+                       required-arg?
+                       optional-arg?
+                       default
+                       parse
+                       show
+                       transform)
+  pkg-opt?
+  (key pkg-opt-key)
+  (help pkg-opt-help)
+  (arg-help pkg-opt-arg-help)
+  (required-arg? pkg-opt-required-arg?)
+  (optional-arg? pkg-opt-optional-arg?)
+  (default pkg-opt-default)
+  (parse pkg-opt-parse)
+  (show pkg-opt-show)
+  (transform pkg-opt-transform))
+
+(define (make-pkg-opt key help arg-help req-arg? opt-arg? default . rest)
+  (let-optionals rest ((parse identity)
+                       (show identity)
+                       (transform (lambda (old new) new)))
+    (really-make-pkg-opt key
+                         help
+                         arg-help
+                         req-arg?
+                         opt-arg?
+                         default
+                         parse
+                         show
+                         transform)))
+
+;; Return the name of PKG-OPT
+(define (pkg-opt-name pkg-opt)
+  (symbol->string (pkg-opt-key pkg-opt)))
+
+;; Convert PKG-OPT into an SRFI-37 option.
+(define (pkg-opt->option pkg-opt)
+  (let ((key (pkg-opt-key pkg-opt))
+        (transform (pkg-opt-transform pkg-opt))
+        (parse (pkg-opt-parse pkg-opt)))
+    (option (list (pkg-opt-name pkg-opt))
+            (pkg-opt-required-arg? pkg-opt)
+            (pkg-opt-optional-arg? pkg-opt)
+            (lambda (opt name arg alist)
+              (alist-replace key
+                             (transform (alist-get key alist) (parse arg))
+                             alist)))))
+
+;; Return a pair (key, default) which associates the default value of
+;; PKG-OPT to its key.
+(define (pkg-opt-key&default pkg-opt)
+  (cons (pkg-opt-key pkg-opt) (pkg-opt-default pkg-opt)))
+
+;; Return the list of all package options of the PACKAGES.
+(define (all-package-options packages)
+  (append-map
+   (lambda (pkg)
+     (cond ((package-extension pkg 'options)
+            => (lambda (opts)
+                 (map (lambda (args) (apply make-pkg-opt args)) opts)))
+           (else '())))
+   packages))
+
 ;;
 ;; Actions
 ;;
@@ -267,7 +395,7 @@
     (cond ((or (file-regular? source) (file-symlink? source))
            (-copy-file source target perms))
           ((file-directory? source)
-           (create-directory target perms)
+           (-create-directory target perms)
            (install-directory-contents% layout
                                         source
                                         location
@@ -283,12 +411,13 @@
                  (directory-files name #t))))
 
 (define (install-thing name-or-pair location . rest)
-  (let-optionals rest ((target-rel-dir ".") (perms default-perms))
+  (if (active-location? location)
-    (install-thing% (fluid *install-layout*)
+      (let-optionals rest ((target-rel-dir ".") (perms default-perms))
-                    name-or-pair
+        (install-thing% (fluid *install-layout*)
-                    location
+                        name-or-pair
-                    target-rel-dir
+                        location
-                    perms)))
+                        target-rel-dir
+                        perms))))
 
 (define (install-things names-or-pairs . rest)
   (for-each (lambda (name-or-pair)
@@ -301,12 +430,13 @@
 (define install-directories install-things)
 
 (define (install-directory-contents name location . rest)
-  (let-optionals rest ((target-rel-dir ".") (perms default-perms))
+  (if (active-location? location)
-    (install-directory-contents% (fluid *install-layout*)
+      (let-optionals rest ((target-rel-dir ".") (perms default-perms))
-                                 name
+        (install-directory-contents% (fluid *install-layout*)
-                                 location
+                                     name
-                                 target-rel-dir
+                                     location
-                                 perms)))
+                                     target-rel-dir
+                                     perms))))
 
 (define (install-empty-directory% layout name location dir . rest)
   (let-optionals rest ((perms default-perms))
@@ -322,9 +452,17 @@
 (define *layout* (make-fluid #f))
 (define *install-layout* (make-fluid #f))
 
+;; Return the directory identified by LOCATION in the current layout.
+;; If INSTALL? is true, return the directory valid during the
+;; installation of the package, otherwise return the directory valid
+;; after installation (i.e. during package use).
 (define (get-directory location install?)
   (layout-dir (fluid (if install? *install-layout* *layout*)) location))
 
+;; Perform all actions to install PKG in INSTALL-LAYOUT. If LAYOUT is
+;; not the same as INSTALL-LAYOUT, assume that some external tool will
+;; move the installed files so that they are laid out according to
+;; LAYOUT.
 (define (install-package layout install-layout pkg)
   (let-fluids *layout* layout
               *install-layout* install-layout
@@ -334,6 +472,8 @@
 ;; Error handling
 ;;
 
+;; Display MSG (a format string with ARGS as arguments) on the error
+;; port, then exit with an error code of 1.
 (define (display-error-and-exit msg . args)
   (apply format (current-error-port) (string-append "Error: " msg) args)
   (newline)
@@ -349,6 +489,7 @@ options:
                        (predefined: ~a)
   --dry-run            don't do anything, print what would have been done
   --inactive           don't activate package after installing it
+  --non-shared-only    only install platform-dependent files, if any
 
 advanced options:
   --build <name>          name of platform for which to build
@@ -360,214 +501,150 @@ advanced options:
 END
 )
 
-(define usage-description-column 26)
+(define usage-descr-col 26)
 
-(define (complete-usage! optional-parts)
+;; Complete the above USAGE string to include information about the
+;; package options PKG-OPTS.
+(define (complete-usage! pkg-opts)
   (let ((usage-port (make-string-output-port)))
     (write-string usage usage-port)
-    (write-string "\noptional parts:\n" usage-port)
+    (write-string "\npackage-specific options:\n" usage-port)
     (for-each
-     (lambda (part)
+     (lambda (pkg-opt)
-       (let* ((sname (symbol->string (optional-part:name part)))
+       (let ((option/arg (format #f "--~a ~a"
-              (pf (string-append "  --with-" sname "=[yes|no]")))
+                                 (pkg-opt-name pkg-opt)
+                                 (pkg-opt-arg-help pkg-opt))))
          (format usage-port
-                 "~a~a~a [~a]\n"
+                 "  ~a~a~a [~a]\n"
-                 pf
+                 option/arg
-                 (spaces 2 (- usage-description-column
+                 (spaces 2 (- usage-descr-col (string-length option/arg)))
-                              (string-length pf)))
+                 (pkg-opt-help pkg-opt)
-                 (optional-part:description part)
+                 ((pkg-opt-show pkg-opt) (pkg-opt-default pkg-opt)))))
-                 (unbooleanize (optional-part:default part)))))
+     pkg-opts)
-     optional-parts)
     (set! usage (string-output-port-output usage-port))))
 
+;; Display the usage string, then MSG (a format string with ARGS as
+;; arguments) on the standard output port, then exit with an error
+;; code of 1.
 (define (display-usage-and-exit msg . args)
-  (if msg (begin (apply format #t msg args) (newline)))
   (format #t
           usage
           (car (command-line))
           (string-join (map car predefined-layouts) ", "))
+  (if msg (begin (apply format #t msg args) (newline)))
   (exit 1))
 
 ;;
 ;; Command line parsing
 ;;
 
-(define (booleanize s)
+;; Predefined parsers/unparsers
+(define (parse-boolean s)
   (cond ((string=? s "yes") #t)
         ((string=? s "no") #f)
         (else (display-error-and-exit
                "unknown boolean value '~a'. Use 'yes' or 'no'." s))))
 
-(define (unbooleanize b)
+(define (show-boolean b)
   (if b "yes" "no"))
 
-(define (spaces min n)
+;; The identity function, sometimes useful for parsers/unparsers.
-  (make-string (if (< n min) min n) #\space))
+(define (identity x) x)
 
-(define (get-all-optional-parts packages)
+;; Fluid containing the value of all options.
-  (if (null? packages)
+(define *options-values* (make-fluid #f))
-      '()
-      (let* ((p (car packages))
-             (ext (package-extensions p))
-             (op (assq 'optional-parts ext)))
-        (append (if op (cdr op) '())
-                (get-all-optional-parts (cdr packages))))))
-
-(define optional-part:name car)
-(define optional-part:description cadr)
-(define (optional-part:default part)
-  (if (null? (cddr part)) #f (caddr part)))
-
-(define (optional-parts->options parts)
-  (map (lambda (part)
-         (let ((part-name (optional-part:name part)))
-           (option (list (string-append "with-" (symbol->string part-name)))
-                   #t #f
-                   (optional-part-processor part-name))))
-       parts))
-
-(define (optional-parts-defaults parts)
-  (map (lambda (part)
-         (cons (optional-part:name part) (optional-part:default part)))
-       parts))
-
-(define *optional-parts-alist* (make-fluid '()))
-
-(define (with-optional-part? name)
-  (cdr (assq name (fluid *optional-parts-alist*))))
-
-(define (process-option opt
-                        name
-                        arg
-                        prefix
-                        i-prefix
-                        layout
-                        layout-file
-                        build
-                        activate?
-                        dry-run?
-                        opt-parts)
-  (case (cdr (assoc opt options/keys))
-    ((prefix)
-     (values arg i-prefix layout layout-file build activate? dry-run? opt-parts))
-    ((i-prefix)
-     (values prefix arg layout layout-file build activate? dry-run? opt-parts))
-    ((layout)
-     (values prefix
-             i-prefix
-             (cond ((assoc arg predefined-layouts) => cdr)
-                   (else (parse-layout arg)))
-             layout-file
-             build
-             activate?
-             dry-run?
-             opt-parts))
-    ((layout-from)
-     (values prefix
-             i-prefix
-             (let ((layout (call-with-input-file arg read)))
-               (lambda args layout))
-             layout-file
-             build
-             activate?
-             dry-run?
-             opt-parts))
-    ((layout-to)
-     (values prefix i-prefix layout arg build activate? dry-run? opt-parts))
-    ((build)
-     (values prefix i-prefix layout layout-file arg activate? dry-run? opt-parts))
-    ((inactive)
-     (values prefix i-prefix layout layout-file build #f dry-run? opt-parts))
-    ((dry-run)
-     (values prefix i-prefix layout layout-file build activate? #t opt-parts))
-    ((help)
-     (display-usage-and-exit #f))))
-
-(define (optional-part-processor part-name)
-  (lambda (opt
-           name
-           arg
-           prefix
-           i-prefix
-           layout
-           layout-file
-           build
-           activate?
-           dry-run?
-           opt-parts)
-    (values prefix
-            i-prefix
-            layout
-            layout-file
-            build
-            activate?
-            dry-run?
-            (alist-cons part-name (booleanize arg) opt-parts))))
-
-(define options/keys
-  (list
-   (cons (option '(#\h "help")       #f #f process-option) 'help)
-   (cons (option '("prefix")         #t #f process-option) 'prefix)
-   (cons (option '("install-prefix") #t #f process-option) 'i-prefix)
-   (cons (option '("layout")         #t #f process-option) 'layout)
-   (cons (option '("layout-from")    #t #f process-option) 'layout-from)
-   (cons (option '("layout-to")      #t #f process-option) 'layout-to)
-   (cons (option '("build")          #t #f process-option) 'build)
-   (cons (option '("inactive")       #f #f process-option) 'inactive)
-   (cons (option '("dry-run")        #f #f process-option) 'dry-run)))
 
 (define package-definition-file "pkg-def.scm")
 
-(define (is-running-dry?)
+(define (get-option-value key)
-  (fluid *dry-run*))
+  (alist-get key (fluid *options-values*)))
+
+(define options
+  (let ((alist-arg-updater (lambda (key)
+                             (lambda (opt name arg alist)
+                               (alist-replace key arg alist))))
+        (alist-boolean-updater (lambda (key)
+                                 (lambda (opt name arg alist)
+                                   (alist-replace key #t alist)))))
+    (list
+     (option '(#\h "help") #f #f
+             (lambda args (display-usage-and-exit #f)))
+     (option '("prefix") #t #f (alist-arg-updater 'prefix))
+     (option '("dest-dir") #t #f (alist-arg-updater 'dest-dir))
+     (option '("layout") #t #f
+             (lambda (opt name arg alist)
+               (alist-replace 'layout
+                              (cond ((assoc arg predefined-layouts) => cdr)
+                                    (else (parse-layout arg)))
+                              alist)))
+     (option '("layout-from") #t #f
+             (lambda (opt name arg alist)
+               (alist-replace 'layout
+                              (let ((layout (call-with-input-file arg read)))
+                                (lambda args layout))
+                              alist)))
+     (option '("layout-to") #t #f (alist-arg-updater 'layout-to))
+     (option '("build") #t #f (alist-arg-updater 'build))
+     (option '("non-shared-only") #f #f
+             (alist-boolean-updater 'non-shared-only))
+     (option '("inactive") #f #f (alist-boolean-updater 'inactive))
+     (option '("dry-run") #f #f (alist-boolean-updater 'dry-run)))))
+
+(define options-defaults
+  `((prefix          . #f)
+    (dest-dir        . "/")
+    (layout          . ,scsh-layout-1)
+    (layout-to       . #f)
+    (build           . ,(host))
+    (non-shared-only . #f)
+    (inactive        . #f)
+    (dry-run         . #f)))
+
+(define (parse-options args options defaults)
+  (args-fold args
+             options
+             (lambda (option name . rest)
+               (display-usage-and-exit "Unknown option ~a" name))
+             (lambda (operand . rest)
+               (display-usage-and-exit "Don't know what to do with ~a"
+                                       operand))
+             defaults))
 
 (define (install-main cmd-line)
   (if (not (file-exists? package-definition-file))
       (display-error-and-exit "cannot find package definition file (~a)"
                               package-definition-file))
   (load-quietly package-definition-file)
-  (let ((all-optional-parts (get-all-optional-parts packages)))
+  (let ((all-pkg-opts (all-package-options packages)))
-    (if (not (null? all-optional-parts))
+    (if (not (null? all-pkg-opts))
-        (complete-usage! all-optional-parts))
+        (complete-usage! all-pkg-opts))
-    (receive (prefix maybe-i-prefix layout-fn layout-to build activate? dry-run? opt-parts)
+    (let* ((all-opts (append options (map pkg-opt->option all-pkg-opts)))
-             (args-fold (cdr cmd-line)
+           (all-dfts (append options-defaults
-                        (append (map car options/keys)
+                             (map pkg-opt-key&default all-pkg-opts)))
-                                (optional-parts->options all-optional-parts))
+           (options-values (parse-options (cdr cmd-line) all-opts all-dfts))
-                        (lambda (option name . rest)
+           (prefix (alist-get 'prefix options-values))
-                          (display-usage-and-exit "Unknown option ~a" name))
+           (dest-dir (alist-get 'dest-dir options-values))
-                        (lambda (operand . rest)
+           (dest-prefix (and prefix (re-root-file-name prefix dest-dir)))
-                          (display-usage-and-exit
+           (layout-fn (alist-get 'layout options-values))
-                           "Don't know what to do with ~a"
+           (layout-to (alist-get 'layout-to options-values))
-                           operand))
+           (build (alist-get 'build options-values))
-                        #f                ; default prefix
+           (non-shared-only? (alist-get 'non-shared-only options-values))
-                        #f                ; default install-prefix
+           (activate? (not (alist-get 'inactive options-values))))
-                        scsh-layout-1     ; default layout-fn
-                        #f                ; default layout-to
-                        (host)            ; default build platform
-                        #t                ; default activation
-                        #f                ; default dry run
-                        (optional-parts-defaults all-optional-parts))
-
       (if (not prefix)
           (display-error-and-exit "no prefix specified (use --prefix option)"))
-      (let ((i-prefix (or maybe-i-prefix prefix)))
+      (let-fluids *options-values* options-values
-        (if (not (and (file-exists? i-prefix) (file-directory? i-prefix)))
+        (lambda ()
-            (display-error-and-exit "install prefix directory ~a doesn't exist"
+          (for-each
-                                    i-prefix))
+           (lambda (pkg)
-        (let-fluids *dry-run* dry-run?
+              (let* ((rel-layout (layout-fn build pkg))
-                    *optional-parts-alist* opt-parts
+                    (layout (absolute-layout rel-layout prefix))
-          (lambda ()
+                    (i-layout (absolute-layout rel-layout dest-prefix)))
-            (for-each
+               (if layout-to
-             (lambda (pkg)
+                   (call-with-output-file
-               (let* ((rel-layout (layout-fn build pkg))
+                       (string-append layout-to "_" (package-full-name pkg))
-                      (layout (absolute-layout rel-layout prefix))
+                     (lambda (port)
-                      (i-layout (absolute-layout rel-layout i-prefix)))
+                       (write rel-layout port) (newline port))))
-                 (if layout-to
+               (install-package layout i-layout pkg)
-                     (call-with-output-file
+               (if (and activate? (not non-shared-only?))
-                         (string-append layout-to "_"
+                   (activate-package i-layout pkg))))
-                                        (package-full-name pkg))
+           packages))))))
-                       (lambda (port)
-                         (write rel-layout port) (newline port))))
-                 (install-package layout i-layout pkg)
-                 (if activate? (activate-package i-layout pkg))))
-             packages)))))))