gistfile1.txt

(defvar *masamune-pathnames*
  '("~/.conkerorrc"
    "~/.emacs"
    "~/.masamune/emacs-desktop-state/"
    "~/.mozrepl-conkeror.js"
    "~/.sbclrc"
    "~/.swank.lisp"
    "~/Pictures/screenshots/"
    "~/algol/"
    "~/lisp/"
    "~/quicklisp/local-projects/")) ;; required for cloning into

(in-package #:stumpwm)

(defvar y-or-n-p-map (make-sparse-keymap))
(defvar y-or-n-p-yes-callback nil)
(defvar y-or-n-p-no-callback nil)
(defvar y-or-n-p-prompt nil)

(defcommand (y-or-n-p-no tile-group) () ()
"Run y-or-n-p no callback"
(pop-top-map)
(let ((f y-or-n-p-no-callback))
(setf y-or-n-p-yes-callback nil
y-or-n-p-no-callback nil
y-or-n-p-prompt nil)
(funcall f)))

(defcommand (y-or-n-p-yes tile-group) () ()
"Run y-or-n-p yes callback"
(pop-top-map)
(let ((f y-or-n-p-yes-callback))
(setf y-or-n-p-yes-callback nil
y-or-n-p-no-callback nil
y-or-n-p-prompt nil)
(funcall f)))

(defun y-or-n-p (prompt yes-callback no-callback)
"Start y-or-n-p mode. A new keymap specific to this is loaded. C-g or ESC to exit"
(let* ((input-window-gravity :center)
(message-window-gravity :center))
(setf y-or-n-p-yes-callback yes-callback)
(setf y-or-n-p-no-callback no-callback)
(setf y-or-n-p-prompt prompt)
(push-top-map y-or-n-p-map)
(sb-thread:make-thread (lambda ()
(loop while (and y-or-n-p-yes-callback y-or-n-p-no-callback y-or-n-p-prompt)
do (progn (sleep .2) (message y-or-n-p-prompt)))))))

(define-key y-or-n-p-map (kbd "y") "y-or-n-p-yes")
(define-key y-or-n-p-map (kbd "n") "y-or-n-p-no")
(define-key y-or-n-p-map (kbd "C-g") "y-or-n-p-no")
(define-key y-or-n-p-map (kbd "ESC") "y-or-n-p-no")

(in-package #:cl)

;; get the highest level of debugging information available
(sb-ext:restrict-compiler-policy 'debug 3)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Build log

(defvar build-start (get-universal-time))
(defvar build-log-pathname (format nil "/tmp/masamune-build-log-~d" build-start))

(defun init-logging ()
(let* ((command-string (format nil "exec xterm -e tail -f ~a" build-log-pathname)))
(rp (format nil "touch ~a" build-log-pathname))
(stumpwm::run-commands command-string)))

(defun log-fmt (format-string &rest args)
(with-open-file (stream build-log-pathname
:direction :output
:if-exists :append)
(write (list :message (apply #'format (cons nil (cons format-string args)))
:time (get-universal-time))
:stream stream)
(terpri stream)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Clean Masamune pathnames

(defvar masamune-pathnames
'("/.conkerorrc"
"/.emacs"
"/.masamune/emacs-desktop-state/"
"/.mozrepl-conkeror.js"
"/.swank.lisp"
"/Pictures/screenshots/"
"/algol/"
"/lisp/"
"~/quicklisp/local-projects/")) ;; required for cloning into

(defun directory-pathname-p (pathname)
(string= "/" (subseq pathname (- (length pathname) 1) (length pathname))))

(defun delete-masamune-pathnames ()
(dolist (pathname masamune-pathnames)
(when (probe-file pathname)
(if (directory-pathname-p pathname)
(sb-ext:delete-directory pathname :recursive t)
(delete-file pathname)))))

(defun create-masamune-pathnames ()
"XXX must be called after 'delete-masamune-pathnames'"
(dolist (pathname masamune-pathnames)
(when (directory-pathname-p pathname)
(uiop:run-program (format nil "mkdir -p ~a" pathname) :output :string))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utility functions

(defun rp (shell-string)
(uiop:run-program shell-string :output :string))

(defun shell-commands-in-dir (commands dir)
(dolist (shell-command commands)
(rp (format nil "cd ~A && ~A" dir shell-command))))

(defun write-swank-dotfile ()
(with-open-file (stream "~/.swank.lisp" :direction :output)
(format stream "(setf swank::globally-redirect-io t)")))

(defun write-emacs-dotfile ()
(with-open-file (stream "/.emacs" :direction :output
:if-exists :append
:if-does-not-exist :create)
(let ((print-case :downcase))
(format stream "%s" '(load "/quicklisp/local-projects/masamune-os/init.el")))))

(defun download-hyperspec (hyperspec-pathname)
(shell-commands-in-dir
'("curl ftp://ftp.lispworks.com/pub/software_tools/reference/HyperSpec-7-0.tar.gz > /tmp/HyperSpec-7-0.tar.gz"
"tar xzf /tmp/HyperSpec-7-0.tar.gz")
"/tmp/")
(rename-file "/tmp/HyperSpec" hyperspec-pathname))

(defun latest-swank-asd-pathname ()
(let* ((slime-version-string (uiop:run-program "ls ~/quicklisp/dists/quicklisp/software/ | grep slime" :output :string))
(slime-version-string (subseq slime-version-string 0 (- (length slime-version-string) 1))))
(format nil "~~/quicklisp/dists/quicklisp/software/~a/swank.asd" slime-version-string)))

(defun libssl-location ()
(let* ((nix-output (uiop:run-program "ls /nix/store/openssl/lib/libssl.so" :output :string))
(libssl-location (subseq nix-output 0 (+ (length "libssl.so") (search "libssl" nix-output)))))
libssl-location))

(defparameter libssl-hack-sexp
(list 'handler-bind (list (list 'error (list 'lambda (list 'c) (list 'invoke-restart (quote 'use-value) (libssl-location)))))
'(eval (read-from-string "(ql:quickload 'cl+ssl)"))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; meat of the build process

(defun quicklisp-init ()
(rp (format nil "sbcl --load /tmp/quicklisp.lisp --eval s" "(quicklisp-quickstart:install)"))
(load "/quicklisp/setup.lisp"))

(defun quickload-in-other-proc (system-name)
"faux single-threaded quickload, used to generate ~/quicklisp/dists/quicklisp/software/"
(let* ((eval-string (format nil "(progn (ql:quickload '~a) (loop while (not (find-package '~a)) do (sleep 1)))"
system-name system-name)))
(rp (format nil "sbcl --noinform --non-interactive --disable-debugger --load ~~/quicklisp/setup.lisp --eval ~s"
eval-string))))

(defun install-cl+ssl ()
(let* ((program-string (format nil "sbcl --noinform --disable-debugger --non-interactive --load ~~/quicklisp/setup.lisp --eval ~s"
(format nil "~s" libssl-hack-sexp))))
(rp program-string))
(eval libssl-hack-sexp))

(defun build-masamune ()
(log-fmt "build started")
(delete-masamune-pathnames)
(create-masamune-pathnames)
(log-fmt "replaced old Masamune direcotries with clean ones")
(write-swank-dotfile)
(write-emacs-dotfile)
(download-hyperspec "/lisp/HyperSpec")
(log-fmt "write dotfiles and downloaded hyperspec")
(rp "curl http://beta.quicklisp.org/quicklisp.lisp > /tmp/quicklisp.lisp")
(shell-commands-in-dir '("git clone https://github.com/edicl/cl-ppcre.git"
"git clone https://github.com/sharplispers/clx.git"
"git clone git://common-lisp.net/projects/alexandria/alexandria.git"
"git clone https://github.com/gabriel-laddel/masamune-os.git")
"/quicklisp/local-projects/")
(log-fmt "curl'd quicklisp, cloned cl-ppcre, clx, alexandria and Masamune")
(quicklisp-init)
(log-fmt "quicklisp loaded")
(install-cl+ssl)
(log-fmt "cl+ssl installed - TODO remove from dependencies.")
(quickload-in-other-proc 'swank)
(log-fmt "swank quickloaded in another process")
(load (latest-swank-asd-pathname))
(load "/quicklisp/local-projects/cl-ppcre/cl-ppcre.asd")
(load "/quicklisp/local-projects/cl-ppcre/cl-ppcre-unicode.asd")
(load "~/quicklisp/local-projects/clx/clx.asd")
(log-fmt "loaded .asd files for swank, cl-ppcre and clx")
(eval (read-from-string "(ql:quickload '(cl-ppcre alexandria clx swank))"))
(log-fmt "cl-ppcre, alexandira, clx and swank quickloaded")
;; TODO 2014-11-09T00:34:53-08:00 Gabriel Laddel
;; (kill-log-xterm-window)
(eval (read-from-string "(swank:create-server :port 4005 :style swank:communication-style :dont-close t)"))
(log-fmt "swank server started, launching Emacs")
(stumpwm::emacs))

(defun required-load-hack ()
(load "/quicklisp/setup.lisp")
(load "/quicklisp/local-projects/cl-ppcre/cl-ppcre.asd")
(load "/quicklisp/local-projects/cl-ppcre/cl-ppcre-unicode.asd")
(load "/quicklisp/local-projects/clx/clx.asd")
(eval libssl-hack-sexp)
(eval (read-from-string "(ql:quickload '(cl-ppcre alexandria clx swank))"))
(eval (read-from-string "(swank:create-server :port 4005 :style swank:communication-style :dont-close t)")))

(in-package #:stumpwm)

(setf input-window-gravity :center
message-window-gravity :center
top-level-error-action :break)

(cl::init-logging)
(cl::log-fmt "compiled ~/.stumpwmrc")

(if (every #'cl:probe-file cl::masamune-pathnames)
(progn (cl::required-load-hack) (emacs))
(y-or-n-p "Build Masamune?(y/n - MUST PRESS ONE OF y or n - no other keys are currently accepted!): "
(lambda ()
(message-no-timeout "Building Masamune, hold tight and don't press any keys!")
(cl::build-masamune))
(lambda () (message-no-timeout "exited build process"))))