gnu: Add scmutils.

* gnu/packages/scheme.scm (scmutils): New variable.

1 files changed, 177 insertions, 0 deletions

diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 803b8d5a20..7465b1b58c 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -486,3 +487,179 @@ addition to support for lightweight VM-based threads, each VM itself runs in
 an isolated heap allowing multiple VMs to run simultaneously in different OS
 threads.")
     (license bsd-3)))
+
+;; FIXME: This function is temporarily in the engineering module and not
+;; exported.  It will be moved to an utility module for general use.  Once
+;; this is done, we should remove this definition.
+(define broken-tarball-fetch
+  (@@ (gnu packages engineering) broken-tarball-fetch))
+
+(define-public scmutils
+  (let ()
+    (define (system-suffix)
+      (cond
+       ((string-prefix? "x86_64" (or (%current-target-system)
+                                     (%current-system)))
+        "x86-64")
+       (else "i386")))
+
+    (package
+      (name "scmutils")
+      (version "20140302")
+      (source
+       (origin
+         (method broken-tarball-fetch)
+         (modules '((guix build utils)))
+         (snippet
+          ;; Remove binary code
+          '(delete-file-recursively "scmutils/mit-scheme"))
+         (file-name (string-append name "-" version ".tar.gz"))
+         (uri (string-append "http://groups.csail.mit.edu/mac/users/gjs/6946"
+                             "/scmutils-tarballs/" name "-" version
+                             "-x86-64-gnu-linux.tar.gz"))
+         (sha256
+          (base32 "10cnbm7nh78m5mrl1di85s29gny81jb1am9zd9f9yx725xb6dnfg"))))
+      (build-system gnu-build-system)
+      (inputs
+       `(("mit-scheme" ,mit-scheme)
+         ("emacs" ,emacs-no-x)))
+      (arguments
+       `(#:tests? #f ;; no tests-suite
+         #:modules ((guix build gnu-build-system)
+                    (guix build utils)
+                    (guix build emacs-utils))
+         #:imported-modules (,@%gnu-build-system-modules
+                             (guix build emacs-utils))
+         #:phases
+         (modify-phases %standard-phases
+           (replace 'configure
+                    ;; No standard build procedure is used. We set the correct
+                    ;; runtime path in the custom build system.
+                    (lambda* (#:key outputs #:allow-other-keys)
+                      (let ((out (assoc-ref outputs "out")))
+                        ;; Required to find .bci files at runtime.
+                        (with-directory-excursion "scmutils"
+                          (rename-file "src" "scmutils"))
+                        (substitute* "scmutils/scmutils/load.scm"
+                          (("/usr/local/scmutils/")
+                           (string-append out "/lib/mit-scheme-"
+                                          ,(system-suffix) "/")))
+                        #t)))
+           (replace 'build
+                    ;; Compile the code and build a band.
+                    (lambda* (#:key outputs #:allow-other-keys)
+                      (let* ((out (assoc-ref outputs "out"))
+                             (make-img (string-append
+                                        "echo '(load \"load\") "
+                                        "(disk-save \"edwin-mechanics.com\")'"
+                                        "| mit-scheme")))
+                        (with-directory-excursion "scmutils/scmutils"
+                          (and (zero? (system "mit-scheme < compile.scm"))
+                               (zero? (system make-img)))))))
+           (add-before 'install 'fix-directory-names
+                       ;; Correct directory names in the startup script.
+                       (lambda* (#:key inputs outputs #:allow-other-keys)
+                         (let* ((out (assoc-ref outputs "out"))
+                                (scm-root (assoc-ref inputs "mit-scheme")))
+                           (substitute* "bin/mechanics"
+                             (("ROOT=\"\\$\\{SCMUTILS_ROOT:-/.*\\}\"")
+                              (string-append
+                               "ROOT=\"${SCMUTILS_ROOT:-" scm-root "}\"\n"
+                               "LIB=\"${ROOT}/lib/mit-scheme-"
+                               ,(system-suffix) ":"
+                               out "/lib/mit-scheme-" ,(system-suffix) "\""))
+                             (("EDWIN_INFO_DIRECTORY=.*\n") "")
+                             (("SCHEME=.*\n")
+                              (string-append "SCHEME=\"${ROOT}/bin/scheme "
+                                             "--library ${LIB}\"\n"))
+                             (("export EDWIN_INFO_DIRECTORY") ""))
+                           #t)))
+           (add-before 'install 'emacs-tags
+                       ;; Generate Emacs's tags for easy reference to source
+                       ;; code.
+                       (lambda* (#:key inputs outputs #:allow-other-keys)
+                         (with-directory-excursion "scmutils/scmutils"
+                           (zero? (apply system* "etags"
+                                         (find-files "." "\\.scm"))))))
+           (replace 'install
+                    ;; Copy files to the store.
+                    (lambda* (#:key outputs #:allow-other-keys)
+                      (define* (copy-files-to-directory files dir
+                                                        #:optional (delete? #f))
+                        (for-each (lambda (f)
+                                    (copy-file f (string-append dir "/" f))
+                                    (when delete? (delete-file f)))
+                                  files))
+
+                      (let* ((out (assoc-ref outputs "out"))
+                             (bin (string-append out "/bin"))
+                             (doc (string-append out "/share/doc/"
+                                                 ,name "-" ,version))
+                             (lib (string-append out "/lib/mit-scheme-"
+                                                 ,(system-suffix)
+                                                 "/scmutils")))
+                        (for-each mkdir-p (list lib doc bin))
+                        (with-directory-excursion "scmutils/scmutils"
+                          (copy-files-to-directory '("COPYING" "LICENSE")
+                                                   doc #t)
+                          (for-each delete-file (find-files "." "\\.bin"))
+                          (copy-files-to-directory '("edwin-mechanics.com")
+                                                   (string-append lib "/..") #t)
+                          (copy-recursively "." lib))
+                        (with-directory-excursion "bin"
+                          (copy-files-to-directory (find-files ".") bin))
+                        (with-directory-excursion "scmutils/manual"
+                          (copy-files-to-directory (find-files ".") doc))
+                        #t)))
+           (add-after 'install 'emacs-helpers
+                      ;; Add convenience Emacs commands to easily load the
+                      ;; Scmutils band in an MIT-Scheme buffer inside of Emacs
+                      ;; and to easily load code tags.
+                      (lambda* (#:key inputs outputs #:allow-other-keys)
+                        (let* ((out (assoc-ref outputs "out"))
+                               (mit-root (assoc-ref inputs "mit-scheme"))
+                               (emacs-lisp-dir
+                                (string-append out "/share/emacs/site-lisp"
+                                               "/guix.d/" ,name "-" ,version))
+                               (el-file (string-append emacs-lisp-dir
+                                                       "/scmutils.el"))
+                               (lib-relative-path
+                                (string-append "/lib/mit-scheme-"
+                                               ,(system-suffix))))
+                          (mkdir-p emacs-lisp-dir)
+                          (call-with-output-file el-file
+                            (lambda (p)
+                              (format p
+                                      ";;;###autoload
+(defun scmutils-load ()
+  (interactive)
+  (require 'xscheme)
+  (let ((mit-root \"~a\")
+    (scmutils \"~a\"))
+    (run-scheme
+     (concat mit-root \"/bin/scheme --library \"
+          mit-root \"~a:\" scmutils \"~a\"
+          \" --band edwin-mechanics.com\"
+          \" --emacs\"))))
+
+;;;###autoload
+(defun scmutils-load-tags ()
+  (interactive)
+  (let ((scmutils \"~a\"))
+    (visit-tags-table (concat scmutils \"/TAGS\"))))
+"
+                                      mit-root out
+                                      lib-relative-path
+                                      lib-relative-path
+                                      (string-append out lib-relative-path
+                                                     "/scmutils"))))
+                          (emacs-byte-compile-directory (dirname el-file))
+                          #t))))))
+      (home-page
+       "http://groups.csail.mit.edu/mac/users/gjs/6946/linux-install.htm")
+      (synopsis "Scmutils library for MIT Scheme")
+      (description "The Scmutils system is an integrated library of
+procedures, embedded in the programming language Scheme, and intended to
+support teaching and research in mathematical physics and electrical
+engineering.")
+      (license gpl2+))))