--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/bin/clhs Wed Dec 19 10:18:23 2018 -0500
@@ -0,0 +1,5 @@
+#!/usr/bin/env bash
+
+set -euo pipefail
+
+~/src/dotfiles/lisp/binaries/clhs --url "file:///home/sjl/Dropbox/HyperSpec/HyperSpec/" --open "w3m" "$@"
--- a/lisp/clhs.lisp Wed Dec 19 10:17:27 2018 -0500
+++ b/lisp/clhs.lisp Wed Dec 19 10:18:23 2018 -0500
@@ -1,150 +1,146 @@
-#|
-
-A Roswell script to open the HyperSpec page of a specified symbol in the default browser.
+;; Based on https://gist.github.com/fukamachi/3510ea1609c1b52830c2
-Usage
------
-
- $ clhs [SYMBOL]
-
+(ql:quickload '(:adopt :drakma :plump :clss :alexandria))
-Installation
-------------
-
-Just download this script, give execute permission, and move to somewhere your shell can find it (assuming `~/.roswell/bin/` is in $PATH in the following example).
-
- $ wget https://gist.githubusercontent.com/fukamachi/3510ea1609c1b52830c2/raw/clhs.ros -O clhs
- $ chmod u+x clhs
- $ mv clhs ~/.roswell/bin
-
-You may want to `ros build` for creating an executable file for fast execution.
-
- $ ros build clhs.ros
- $ mv clhs ~/.roswell/bin
+;;;; Config -------------------------------------------------------------------
+(defparameter *default-hyperspec-url* "http://www.lispworks.com/documentation/HyperSpec/")
+;; (defparameter *default-hyperspec-url* "file:///home/sjl/Dropbox/HyperSpec/HyperSpec/")
+(defparameter *default-open-command* "open")
+(defparameter *open* *default-open-command*)
+(defparameter *url* *default-hyperspec-url*)
-Environment variables
----------------------
-
- CLHS_BASE_URL:
- The base URL of HyperSpec. The default is LispWorks'.
+;;;; Curl ---------------------------------------------------------------------
+(defun retrieve-url (url)
+ (tagbody
+ retry
+ (multiple-value-bind (body status) (drakma:http-request url)
+ (unless (= status 200)
+ (restart-case
+ (error "Failed to retrieve ~S (Code=~A)" url status)
+ (retry-request ()
+ :report "Retry the request to URL."
+ (go retry))))
+ (return-from retrieve-url body))))
- CLHS_OPEN_COMMAND:
- Command name to open an URL with the default browser.
- The default value is 'open' for Mac and 'xdg-open' for Linux.
-
-
-Copyright
----------
-
-Copyright (c) 2015 Eitaro Fukamachi, Masatoshi Sano
+(defun retrieve-file (path)
+ (alexandria:read-file-into-string path))
-LICENSE
--------
-
-This script is licensed under the MIT License.
-
-|#
-
-(unless (find-package :uiop)
- (ql:quickload '(:uiop) :silent t))
-
+(defun url (target)
+ (format nil "~A~A" *url* target))
-(defun clhs-base-url ()
- ;; "http://www.lispworks.com/documentation/HyperSpec/"
- "file:///home/sjl/Dropbox/HyperSpec/HyperSpec/"
- )
-
-(defun clhs-cache-directory ()
- (let ((cache-dir
- (uiop:ensure-directory-pathname (uiop:getenv "XDG_CACHE_HOME")
- (merge-pathnames ".cache/" (user-homedir-pathname)))))
- (merge-pathnames #P"clhs/" cache-dir)))
-
-(defun clhs-cache-file ()
- (merge-pathnames #P"symbols-map.sexp" (clhs-cache-directory)))
-
-(defun open-command () "w3m")
+(defun retrieve (target)
+ (let ((path-or-url (url target)))
+ (if (string= "file://" path-or-url :end2 7)
+ (retrieve-file (subseq path-or-url 7))
+ (retrieve-url path-or-url))))
-(defun terminate (code &optional message &rest args)
- (when message
- (format *error-output* "~&~A~%"
- (apply #'format nil (princ-to-string message) args)))
- (uiop:quit code))
+;;;; Cache --------------------------------------------------------------------
+(defun cache-directory ()
+ (let ((cache-dir
+ (uiop:ensure-directory-pathname
+ (uiop:getenv "XDG_CACHE_HOME")
+ (merge-pathnames ".cache/" (user-homedir-pathname)))))
+ (merge-pathnames #P"clhs/" cache-dir)))
+(defun cache-file ()
+ (merge-pathnames #P"symbols-map.sexp" (cache-directory)))
+
+(defun retrieve-symbol-map ()
+ (let ((body (retrieve "Front/X_AllSym.htm")))
+ (map 'list
+ (lambda (a)
+ (cons (plump:text a)
+ (let ((path (plump:attribute a "href")))
+ ;; Omit "../" and URL fragment
+ (subseq path 3 (position #\# path)))))
+ (clss:select "a[rel=definition]" (plump:parse body)))))
-(defmacro with-package-functions (package-designator functions &body body)
- (let ((args (gensym "ARGS")))
- `(flet (,@(loop for fn in functions
- collect `(,fn (&rest ,args)
- (apply
- ,(if (and (listp fn) (eq (car fn) 'setf))
- `(eval `(function (setf ,(intern ,(string (cadr fn)) ,package-designator))))
- `(symbol-function (intern ,(string fn) ,package-designator)))
- ,args))))
- ,@body)))
+(defun rebuild-cache ()
+ (let ((cache (cache-file)))
+ (format t "Rebuilding cache at ~A~%" cache)
+ (let ((symbols (retrieve-symbol-map)))
+ (ensure-directories-exist cache)
+ (with-open-file (out cache
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (prin1 symbols out))
+ symbols)))
-(defun retrieve-url (url)
- (with-package-functions :drakma (http-request)
- (tagbody retry
- (multiple-value-bind (body status)
- (http-request url)
- (unless (= status 200)
- (restart-case
- (error "Failed to retrieve ~S (Code=~A)" url status)
- (retry-request ()
- :report "Retry the request to URL."
- (go retry))))
- (return-from retrieve-url body)))))
+(defun symbol-map ()
+ (let ((cache (cache-file)))
+ (if (probe-file cache)
+ (uiop:read-file-form cache)
+ (rebuild-cache))))
+
+(defun find-symbol-path (target-symbol)
+ (cdr (assoc target-symbol (symbol-map) :test #'string-equal)))
+
+(defun run (target-symbol)
+ (let ((path (find-symbol-path target-symbol)))
+ (if path
+ (let ((url (url path)))
+ (format t "Opening ~A~%" url)
+ (uiop:run-program `(,*open* ,url)
+ :ignore-error-status t
+ :input :interactive
+ :output :interactive)
+ t)
+ nil)))
-(defun clhs-url (path)
- (format nil "~A~A" (clhs-base-url) path))
-
-(defun retrieve-clhs-symbols-map ()
- (ql:quickload '(:drakma :plump :clss) :silent t)
- (with-package-functions :plump (parse text attribute)
- (with-package-functions :clss (select)
- (let ((body (retrieve-url (clhs-url "Front/X_AllSym.htm"))))
- (map 'list
- (lambda (a)
- (cons (text a)
- (let ((path (attribute a "href")))
- ;; Omit "../" and URL fragment
- (subseq path 3 (position #\# path)))))
- (select "a[rel=definition]" (parse body)))))))
+;;;; User Interface -----------------------------------------------------------
+(adopt:define-interface *ui* "SYMBOL"
+ "Look up SYMBOL in the hyperspec and open it in a web browser."
+ ((help) "display help and exit"
+ :long "help"
+ :short #\h
+ :reduce (constantly t))
+ ((rebuild-cache) "rebuild the symbol cache, even if it already exists"
+ :long "rebuild-cache"
+ :reduce (constantly t))
+ ((open) (format nil "program to use to open hyperspec URLs (default ~A)"
+ *default-open-command*)
+ :long "open"
+ :short #\o
+ :parameter "COMMAND"
+ :initial-value *default-open-command*
+ :reduce #'adopt:newest)
+ ((url) (format nil "base Hyperspec URL (default ~A)" *default-hyperspec-url*)
+ :long "url"
+ :short #\u
+ :parameter "URL"
+ :initial-value *default-hyperspec-url*
+ :reduce #'adopt:newest))
-(defun clhs-symbols-map ()
- (let ((cache (clhs-cache-file)))
- (if (probe-file cache)
- (uiop:read-file-form cache)
- (let ((symbols (retrieve-clhs-symbols-map)))
- (ensure-directories-exist cache)
- (with-open-file (out cache
- :direction :output
- :if-does-not-exist :create)
- (prin1 symbols out))
- symbols))))
+(defun toplevel ()
+ (multiple-value-bind (arguments options) (adopt:parse-options *ui*)
+ (when (gethash 'help options)
+ (adopt:print-usage *ui*)
+ (adopt:exit 0))
+ (let ((*open* (gethash 'open options))
+ (*url* (gethash 'url options))
+ (target (first arguments)))
+ (if (gethash 'rebuild-cache options)
+ (rebuild-cache)
+ (progn
+ (when (/= (length arguments) 1)
+ (cerror "Type a symbol"
+ "Exactly one symbol to look up must be provided (got ~D: ~S)"
+ (length arguments)
+ arguments)
+ (setf arguments (list (read-line))))
+ (unless (run target)
+ (format *error-output* "Symbol not found: ~A~%" target)
+ (adopt:exit 1)))))))
-(defun find-symbol-path (target-symbol)
- (cdr (assoc target-symbol (clhs-symbols-map)
- :test #'string-equal)))
-
-(defun main (&aux (target-symbol (second sb-ext:*posix-argv*)))
- (unless target-symbol
- (terminate -1 "Usage: clhs [SYMBOL]"))
- (let ((path (find-symbol-path target-symbol)))
- (if path
- (let ((url (clhs-url path)))
- (format t "~&Opening ~S~%" url)
- (uiop:run-program `(,(open-command) ,url)
- :ignore-error-status t
- :input :interactive
- :output :interactive))
- (terminate -1 "Symbol not found: ~A" target-symbol))))
-
+;;;; Build --------------------------------------------------------------------
(defun build ()
- (sb-ext:save-lisp-and-die "clhs" :executable t :toplevel 'main :save-runtime-options t))
+ (sb-ext:save-lisp-and-die "clhs"
+ :executable t
+ :toplevel 'toplevel
+ :save-runtime-options t))
--- a/lispwords Wed Dec 19 10:17:27 2018 -0500
+++ b/lispwords Wed Dec 19 10:18:23 2018 -0500
@@ -15,6 +15,7 @@
(2 defmacro)
(1 multiple-value-call) ; maybe not...
(1 restart-case)
+(1 handler-bind)
; my own weird things
(1 make-array)