lisp/clhs.lisp @ 76c25760f62f

;; Based on https://gist.github.com/fukamachi/3510ea1609c1b52830c2

(ql:quickload '(:adopt :drakma :plump :clss :alexandria))

;;;; 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*)


;;;; 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))))

(defun retrieve-file (path)
  (alexandria:read-file-into-string path))


(defun url (target)
  (format nil "~A~A" *url* target))

(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))))


;;;; 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)))))

(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 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)))


;;;; 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 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)))))))


;;;; Build --------------------------------------------------------------------
(defun build ()
  (sb-ext:save-lisp-and-die "clhs"
                            :executable t
                            :toplevel 'toplevel
                            :save-runtime-options t))