scsh-install-lib/install.scm

#!/bin/sh
exec scsh -e main -o let-opt -o srfi-1 -o srfi-37 -s "$0" "$@"
!#

;; Install scsh's installation library as follows:
;;   - files install-lib.scm and install-lib-module.scm go to
;;     <prefix>/share/scsh-install-lib/scheme/
;;   - file proposal.pdf goes to
;;     <prefix>/share/doc/scsh-install-lib/
;;   - a new file called scsh-install-pkg, providing an entry point to
;;     the installation library, is installed in <prefix>/bin

;; TODO most of the following functions were lifted straight from
;; install-lib.scm, but should really be shared in some way.

;; 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 "cannot find key in alist" key alist))))

;; 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 #o777))
    (let ((parent (parent-directory fname)))
      (if (not (file-exists? parent))
          (apply create-directory&parents parent rest))
      (if (not (file-exists? fname))
          (create-directory fname perms)))))

;; 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 SOURCE to TARGET-DIR, with the same name.
(define (copy-file-to-dir source target-dir)
  (let ((target (absolute-file-name (file-name-nondirectory source)
                                    target-dir)))
    (run (cp ,source ,target))
    (set-file-mode target (file-mode source))))

(define usage #<<END
Usage: ~a [options]

options:
  -h, --help        display this help message, then exit
  --prefix <dir>    specify directory where files are installed
                    (default: /usr/local)
  --dest-dir <dir>  specify prefix to used during installation
                    (to be used only during staged installations)

END
)

;; Template for scsh-install-pkg script, must be plugged with the
;; directory containing the Scheme code.
(define scsh-install-pkg-template #<<END
#!/bin/sh
exec scsh -lm ~a/install-lib-module.scm -o pp -o configure -o install -e install-main -s "$0" "$@"
!#

END
)

(define (display-usage-and-exit prog . args)
  (format (current-error-port) usage prog)
  (if (not (null? args))
      (for-each (lambda (thing) (display thing (current-error-port)))
                (cons "Error: " args)))
  (exit 1))

(define (parse-options prog args)
  (args-fold
   args
   (let ((alist-arg-updater (lambda (key)
                              (lambda (opt name arg alist)
                                (alist-replace key arg alist)))))
     (list (option '(#\h "help") #f #f
                   (lambda ignored (display-usage-and-exit prog)))
           (option '("prefix") #t #f (alist-arg-updater 'prefix))
           (option '("dest-dir") #t #f (alist-arg-updater 'dest-dir))))
   (lambda (option name . rest)
     (display-usage-and-exit prog "Unknown option "name))
   (lambda (operand . rest)
     (display-usage-and-exit prog
                             "Don't know what to do with "
                             operand))
   '((prefix . "/usr/local")
     (dest-dir . "/"))))

(define (main cmd-line)
  (let* ((options (parse-options (car cmd-line) (cdr cmd-line)))
         (prefix (alist-get 'prefix options))
         (r-prefix (absolute-file-name prefix "/"))
         (i-prefix (re-root-file-name r-prefix (alist-get 'dest-dir options))))

    ;; Install documentation
    (let ((doc-dir (absolute-file-name "share/doc/scsh-install-lib"
                                       i-prefix)))
      (create-directory&parents doc-dir)
      (copy-file-to-dir "doc/proposal.pdf" doc-dir))

    ;; Install Scheme code
    (let ((scheme-dir (absolute-file-name "share/scsh-install-lib/scheme"
                                          i-prefix)))
      (create-directory&parents scheme-dir)
      (copy-file-to-dir "scheme/install-lib.scm" scheme-dir)
      (copy-file-to-dir "scheme/install-lib-module.scm" scheme-dir))

    ;; Install script
    (let ((bin-dir (absolute-file-name "bin" i-prefix))
          (r-scheme-dir (absolute-file-name "share/scsh-install-lib/scheme"
                                            r-prefix)))
      (create-directory&parents bin-dir)
      (call-with-output-file (absolute-file-name "scsh-install-pkg" bin-dir)
        (lambda (p)
          (format p scsh-install-pkg-template r-scheme-dir)
          (set-file-mode p #o755))))))