# HG changeset patch # User Steve Losh # Date 1545176258 18000 # Node ID 76c25760f62fc890284a12225b4581615c3840fe # Parent 2f3f2eb8cfdf66a4a5b85437f6d43464fa24d5fa Rewrite the fucking clhs thing with adopt diff -r 2f3f2eb8cfdf -r 76c25760f62f bin/clhs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/bin/clhs Tue Dec 18 18:37:38 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" "$@" diff -r 2f3f2eb8cfdf -r 76c25760f62f fish/config.fish --- a/fish/config.fish Sun Dec 16 17:59:46 2018 -0500 +++ b/fish/config.fish Tue Dec 18 18:37:38 2018 -0500 @@ -4,6 +4,7 @@ function ed; nvim ~/.vim/custom-dictionary.utf-8.add; end function ef; nvim ~/.config/fish/config.fish; end function ew; nvim (which $argv[1]); end +function cw; cat (which $argv[1]); end function eff; nvim ~/.config/fish/functions; end function eg; nvim ~/.gitconfig; end function eh; nvim ~/.hgrc; end diff -r 2f3f2eb8cfdf -r 76c25760f62f lisp/clhs.lisp --- a/lisp/clhs.lisp Sun Dec 16 17:59:46 2018 -0500 +++ b/lisp/clhs.lisp Tue Dec 18 18:37:38 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)) diff -r 2f3f2eb8cfdf -r 76c25760f62f lispwords --- a/lispwords Sun Dec 16 17:59:46 2018 -0500 +++ b/lispwords Tue Dec 18 18:37:38 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)