--- a/.hgignore Tue Jul 24 00:37:36 2018 +0000
+++ b/.hgignore Tue Jul 24 00:43:57 2018 +0000
@@ -38,12 +38,9 @@
ipython/profile_default/history.sqlite
weechat/certs/ca-bundle.crt
-roswell/clhs
-roswell/clhs-old
-roswell/lispindent
-roswell/compile-parenscript
weechat/slack.cache
vim/bundle/_wat
vim/bundle/simple-scala
vim/bundle/LanguageClient-neovim
weechat/sec.conf
+lisp/binaries
--- a/fish/config.fish Tue Jul 24 00:37:36 2018 +0000
+++ b/fish/config.fish Tue Jul 24 00:43:57 2018 +0000
@@ -73,7 +73,7 @@
prepend_to_path "/usr/bin"
prepend_to_path "/usr/local/bin"
prepend_to_path "/usr/local/sbin"
-prepend_to_path "$HOME/src/dotfiles/roswell"
+prepend_to_path "$HOME/src/dotfiles/lisp/binaries"
prepend_to_path "$HOME/src/dotfiles/bin"
prepend_to_path "$HOME/src/hg"
prepend_to_path "$HOME/bin"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/Makefile Tue Jul 24 00:43:57 2018 +0000
@@ -0,0 +1,11 @@
+.PHONY: all
+
+all: binaries/clhs binaries/lispindent
+
+binaries/clhs: clhs.lisp
+ sbcl --eval '(load "clhs.lisp")' --eval "(build)" --eval "(exit)"
+ mv clhs binaries/clhs
+
+binaries/lispindent: lispindent.lisp
+ sbcl --no-userinit --eval '(load "lispindent.lisp")' --eval "(build)" --eval "(exit)"
+ mv lispindent binaries/lispindent
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/clhs.lisp Tue Jul 24 00:43:57 2018 +0000
@@ -0,0 +1,148 @@
+#|
+
+A Roswell script to open the HyperSpec page of a specified symbol in the default browser.
+
+Usage
+-----
+
+ $ clhs [SYMBOL]
+
+
+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
+
+
+Environment variables
+---------------------
+
+ CLHS_BASE_URL:
+ The base URL of HyperSpec. The default is LispWorks'.
+
+ 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
+
+
+LICENSE
+-------
+
+This script is licensed under the MIT License.
+
+|#
+
+(unless (find-package :uiop)
+ (ql:quickload '(:uiop) :silent t))
+
+
+(defun clhs-base-url ()
+ "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 terminate (code &optional message &rest args)
+ (when message
+ (format *error-output* "~&~A~%"
+ (apply #'format nil (princ-to-string message) args)))
+ (uiop:quit code))
+
+
+(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 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 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)))))))
+
+(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 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))))
+
+(defun build ()
+ (sb-ext:save-lisp-and-die "clhs" :executable t :toplevel 'main :save-runtime-options t))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/compile-parenscript.ros Tue Jul 24 00:43:57 2018 +0000
@@ -0,0 +1,50 @@
+#!/bin/sh
+#|-*- mode:lisp -*-|#
+#|
+exec ros -Q -- $0 "$@"
+|#
+
+#|
+
+A Roswell script to compile Parenscript files.
+
+Usage
+-----
+
+ $ compile-parenscript filename...
+
+LICENSE
+-------
+
+MIT/X11.
+
+|#
+
+(unless (find-package :uiop)
+ (ql:quickload '(:uiop) :silent t))
+
+(unless (find-package :parenscript)
+ (ql:quickload '(:parenscript) :silent t))
+
+
+(defun terminate (code &optional message &rest args)
+ (when message
+ (format *error-output* "~&~A~%"
+ (apply #'format nil (princ-to-string message) args)))
+ (uiop:quit code))
+
+
+(defun compile-parenscript-file (source)
+ (let* ((source-path (pathname source))
+ (target-path (make-pathname :type "js"
+ :defaults source-path)))
+ (with-open-file (output target-path
+ :direction :output
+ :if-exists :supersede)
+ (write-string (parenscript::ps-compile-file source-path) output)))
+ (values))
+
+(defun main (&rest filenames)
+ (unless filenames
+ (terminate -1 "Usage: compile-parenscript filename..."))
+ (mapc #'compile-parenscript-file filenames))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/lispindent.lisp Tue Jul 24 00:43:57 2018 +0000
@@ -0,0 +1,264 @@
+;; Fork of lispindent https://github.com/ds26gte/scmindent
+;; Some day I need to rewrite this with smug or something, jesus.
+
+
+;Dorai Sitaram
+;Oct 8, 1999
+;last change 2014-09-16
+
+;this script takes lines of Lisp or Scheme code from its
+;stdin and produces an indented version thereof on its
+;stdout
+
+(defun safe-read (stream)
+ (let ((*read-eval* nil))
+ (read stream nil)))
+
+(defun safe-read-from-string (string)
+ (let ((*read-eval* nil))
+ (read-from-string string)))
+
+
+(defvar *lisp-keywords* '())
+(defvar *labels-keywords* '(labels flet macrolet labels* flet* labels-memoized))
+(defvar *labels2-keywords* '(state-machine))
+(defvar *lambda-list-keywords* '(defun defmethod defmacro define-compiler-macro defun* defmacro-clause defmacro-driver))
+(defvar *case-keywords* '(cond case))
+
+
+(defun define-with-lisp-indent-number (n syms)
+ (dolist (sym syms)
+ (let* ((x (symbol-name sym))
+ (c (assoc x *lisp-keywords* :test #'string-equal)))
+ (unless c
+ (push (setq c (cons x nil)) *lisp-keywords*))
+ (setf (cdr c) n))))
+
+(define-with-lisp-indent-number 0
+ '(block
+ handler-bind
+ loop))
+
+(define-with-lisp-indent-number 1
+ '(case
+ defpackage do-all-symbols do-external-symbols dolist do-symbols dotimes
+ ecase etypecase eval-when
+ flet
+ handler-case
+ labels lambda let let* let-values
+ macrolet
+ prog1
+ typecase
+ unless unwind-protect
+ when with-input-from-string with-open-file with-open-socket
+ with-open-stream with-output-to-string))
+
+(define-with-lisp-indent-number 2
+ '(assert
+ defun destructuring-bind do do*
+ if
+ multiple-value-bind
+ with-slots))
+
+
+(defparameter *config-files*
+ (list (merge-pathnames ".lispwords" (user-homedir-pathname))
+ ".lispwords"
+ ".notmylispwords"))
+
+
+(defun source-config-files ()
+ (dolist (path *config-files*)
+ (with-open-file (i path :if-does-not-exist nil)
+ (when i
+ (loop
+ (let ((w (or (safe-read i) (return))))
+ (define-with-lisp-indent-number (car w) (cdr w))))))))
+
+
+(defstruct lparen
+ word
+ spaces-before
+ num-aligned-subforms
+ (num-finished-subforms 0)
+ (num-processed-subforms 0))
+
+
+(defun past-next-token (s i n)
+ (let ((escapep nil))
+ (loop
+ (when (>= i n) (return i))
+ (let ((c (char s i)))
+ (cond (escapep (setq escapep nil))
+ ((char= c #\\) (setq escapep t))
+ ((char= c #\#)
+ (let ((j (+ i 1)))
+ (if (>= j n) (return i)
+ (let ((c (char s j)))
+ (cond ((char= c #\\) (setq escapep t i j))
+ (t (return i)))))))
+ ((member c '(#\space #\tab #\( #\) #\[ #\] #\" #\' #\` #\, #\;))
+ (return i))))
+ (incf i))))
+
+(defun lisp-indent-number (s &optional (possible-keyword-p t))
+ (or (cdr (assoc s *lisp-keywords* :test #'string-equal))
+ (if (zerop (or (search "def" s :test #'char-equal)
+ (search "with-" s :test #'char-equal)
+ -1))
+ 0
+ (if possible-keyword-p
+ (let ((p (position #\: s :from-end t)))
+ (if p
+ (lisp-indent-number (subseq s (1+ p)) nil)
+ -1))
+ -1))))
+
+(defun literal-token-p (s)
+ (let ((colon-pos (position #\: s)))
+ (if colon-pos
+ (if (= colon-pos 0) t nil)
+ (let ((s (safe-read-from-string s)))
+ (or (eql t s) (characterp s) (numberp s) (stringp s))))))
+
+;(trace lisp-indent-number literal-token-p read-from-string past-next-token)
+
+(defun current-word (s i n)
+ (let ((j (past-next-token s i n)))
+ (when (not (= i j))
+ (subseq s i j))))
+
+
+(defun in-labels-p (stack)
+ (let ((target (cadr stack)))
+ (or (and target
+ (member (lparen-word target) *labels-keywords*
+ :key #'symbol-name :test #'string-equal)
+ (= (lparen-num-processed-subforms target) 0))
+ (and target
+ (member (lparen-word target) *labels2-keywords*
+ :key #'symbol-name :test #'string-equal)
+ (= (lparen-num-processed-subforms target) 1)))))
+
+(defun in-lambda-list-p (stack)
+ (let ((target (car stack)))
+ (and target
+ (member (lparen-word target) *lambda-list-keywords*
+ :key #'symbol-name :test #'string-equal)
+ (= (lparen-num-processed-subforms target) 0))))
+
+(defun in-case-p (stack)
+ (let ((target (car stack)))
+ (and target
+ (member (lparen-word target) *case-keywords*
+ :key #'symbol-name :test #'string-equal))))
+
+
+
+(defun calc-subindent (stack s i n)
+ (let* ((j (past-next-token s i n))
+ (num-aligned-subforms 0)
+ (left-indent
+ (if (= j i) 1
+ (let ((w (subseq s i j)))
+ (if (and (>= i 2) (member (char s (- i 2)) '(#\' #\`))) 2
+ (let ((nas (if (in-labels-p stack)
+ 1
+ (lisp-indent-number w))))
+ (cond ((or (in-lambda-list-p stack)
+ (in-case-p stack)) 1)
+ ((>= nas 0) (setq num-aligned-subforms nas)
+ 2)
+ ((literal-token-p w) 1)
+ ((= j n) 2)
+ (t (+ (- j i) 2)))))))))
+ (values left-indent num-aligned-subforms (1- j))))
+
+(defun num-leading-spaces (s)
+ (let ((n (length s))
+ (i 0) (j 0))
+ (loop
+ (when (>= i n) (return 0))
+ (case (char s i)
+ (#\space (incf i) (incf j))
+ (#\tab (incf i) (incf j 8))
+ (t (return j))))))
+
+
+(defun string-trim-blanks (s)
+ (string-trim '(#\space #\tab #\newline #\return) s))
+
+
+(defun indent-lines ()
+ (let ((left-i 0)
+ (paren-stack '())
+ (stringp nil))
+ (loop
+ (let* ((curr-line (or (read-line nil nil) (return)))
+ (leading-spaces (num-leading-spaces curr-line))
+ (curr-left-i
+ (cond (stringp leading-spaces)
+ ((null paren-stack)
+ (when (= left-i 0) (setq left-i leading-spaces))
+ left-i)
+ (t (let* ((lp (car paren-stack))
+ (nas (lparen-num-aligned-subforms lp))
+ (nfs (lparen-num-finished-subforms lp))
+ (extra-w 0))
+ (when (< nfs nas) ;(and (>= nas 0) (< nfs nas))
+ (incf (lparen-num-finished-subforms lp))
+ (setq extra-w 2))
+ (+ (lparen-spaces-before lp)
+ extra-w))))))
+ (setq curr-line (string-trim-blanks curr-line))
+ (when (not (string= curr-line "")) ; don't add "trailing" whitespace
+ (dotimes (k curr-left-i) (write-char #\space)))
+ (princ curr-line)
+ (terpri)
+ ;
+ (let ((i 0) (n (length curr-line)) (escapep nil)
+ (inter-word-space-p nil))
+ (loop
+ (when (>= i n) (return))
+ (let ((c (char curr-line i)))
+ (cond (escapep (setq escapep nil))
+ ((char= c #\\) (setq escapep t))
+ (stringp (when (char= c #\") (setq stringp nil)))
+ ((char= c #\;) (return))
+ ((char= c #\") (setq stringp t))
+ ((member c '(#\space #\tab) :test #'char=)
+ (unless inter-word-space-p
+ (setq inter-word-space-p t)
+ (let ((lp (car paren-stack)))
+ (when lp
+ (incf (lparen-num-finished-subforms lp))))))
+ ((member c '(#\( #\[) :test #'char=)
+ (setq inter-word-space-p nil)
+ (multiple-value-bind (left-indent num-aligned-subforms j)
+ (calc-subindent paren-stack curr-line (1+ i) n)
+ (push
+ (make-lparen :word (current-word curr-line (1+ i) n)
+ :spaces-before (+ i curr-left-i left-indent)
+ :num-aligned-subforms num-aligned-subforms)
+ paren-stack)
+ (setq i j)))
+ ((member c '(#\) #\]) :test #'char=)
+ (setq inter-word-space-p nil)
+ (cond (paren-stack (pop paren-stack))
+ (t (setq left-i 0)))
+ (let ((lp (car paren-stack)))
+ (when lp
+ (incf (lparen-num-processed-subforms lp)))))
+ (t (setq inter-word-space-p nil)))
+ (incf i))))))))
+
+
+(defun main ()
+ (source-config-files)
+ (indent-lines)
+ t)
+
+(defun build ()
+ (sb-ext:save-lisp-and-die "lispindent"
+ :toplevel 'main
+ :executable t))
--- a/roswell/clhs.lisp Tue Jul 24 00:37:36 2018 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,148 +0,0 @@
-#|
-
-A Roswell script to open the HyperSpec page of a specified symbol in the default browser.
-
-Usage
------
-
- $ clhs [SYMBOL]
-
-
-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
-
-
-Environment variables
----------------------
-
- CLHS_BASE_URL:
- The base URL of HyperSpec. The default is LispWorks'.
-
- 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
-
-
-LICENSE
--------
-
-This script is licensed under the MIT License.
-
-|#
-
-(unless (find-package :uiop)
- (ql:quickload '(:uiop) :silent t))
-
-
-(defun clhs-base-url ()
- "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 terminate (code &optional message &rest args)
- (when message
- (format *error-output* "~&~A~%"
- (apply #'format nil (princ-to-string message) args)))
- (uiop:quit code))
-
-
-(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 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 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)))))))
-
-(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 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))))
-
-(defun build ()
- (sb-ext:save-lisp-and-die "clhs" :executable t :toplevel 'main :save-runtime-options t))
--- a/roswell/compile-parenscript.ros Tue Jul 24 00:37:36 2018 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,50 +0,0 @@
-#!/bin/sh
-#|-*- mode:lisp -*-|#
-#|
-exec ros -Q -- $0 "$@"
-|#
-
-#|
-
-A Roswell script to compile Parenscript files.
-
-Usage
------
-
- $ compile-parenscript filename...
-
-LICENSE
--------
-
-MIT/X11.
-
-|#
-
-(unless (find-package :uiop)
- (ql:quickload '(:uiop) :silent t))
-
-(unless (find-package :parenscript)
- (ql:quickload '(:parenscript) :silent t))
-
-
-(defun terminate (code &optional message &rest args)
- (when message
- (format *error-output* "~&~A~%"
- (apply #'format nil (princ-to-string message) args)))
- (uiop:quit code))
-
-
-(defun compile-parenscript-file (source)
- (let* ((source-path (pathname source))
- (target-path (make-pathname :type "js"
- :defaults source-path)))
- (with-open-file (output target-path
- :direction :output
- :if-exists :supersede)
- (write-string (parenscript::ps-compile-file source-path) output)))
- (values))
-
-(defun main (&rest filenames)
- (unless filenames
- (terminate -1 "Usage: compile-parenscript filename..."))
- (mapc #'compile-parenscript-file filenames))
--- a/roswell/lispindent.lisp Tue Jul 24 00:37:36 2018 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,264 +0,0 @@
-;; Fork of lispindent https://github.com/ds26gte/scmindent
-;; Some day I need to rewrite this with smug or something, jesus.
-
-
-;Dorai Sitaram
-;Oct 8, 1999
-;last change 2014-09-16
-
-;this script takes lines of Lisp or Scheme code from its
-;stdin and produces an indented version thereof on its
-;stdout
-
-(defun safe-read (stream)
- (let ((*read-eval* nil))
- (read stream nil)))
-
-(defun safe-read-from-string (string)
- (let ((*read-eval* nil))
- (read-from-string string)))
-
-
-(defvar *lisp-keywords* '())
-(defvar *labels-keywords* '(labels flet macrolet labels* flet* labels-memoized))
-(defvar *labels2-keywords* '(state-machine))
-(defvar *lambda-list-keywords* '(defun defmethod defmacro define-compiler-macro defun* defmacro-clause defmacro-driver))
-(defvar *case-keywords* '(cond case))
-
-
-(defun define-with-lisp-indent-number (n syms)
- (dolist (sym syms)
- (let* ((x (symbol-name sym))
- (c (assoc x *lisp-keywords* :test #'string-equal)))
- (unless c
- (push (setq c (cons x nil)) *lisp-keywords*))
- (setf (cdr c) n))))
-
-(define-with-lisp-indent-number 0
- '(block
- handler-bind
- loop))
-
-(define-with-lisp-indent-number 1
- '(case
- defpackage do-all-symbols do-external-symbols dolist do-symbols dotimes
- ecase etypecase eval-when
- flet
- handler-case
- labels lambda let let* let-values
- macrolet
- prog1
- typecase
- unless unwind-protect
- when with-input-from-string with-open-file with-open-socket
- with-open-stream with-output-to-string))
-
-(define-with-lisp-indent-number 2
- '(assert
- defun destructuring-bind do do*
- if
- multiple-value-bind
- with-slots))
-
-
-(defparameter *config-files*
- (list (merge-pathnames ".lispwords" (user-homedir-pathname))
- ".lispwords"
- ".notmylispwords"))
-
-
-(defun source-config-files ()
- (dolist (path *config-files*)
- (with-open-file (i path :if-does-not-exist nil)
- (when i
- (loop
- (let ((w (or (safe-read i) (return))))
- (define-with-lisp-indent-number (car w) (cdr w))))))))
-
-
-(defstruct lparen
- word
- spaces-before
- num-aligned-subforms
- (num-finished-subforms 0)
- (num-processed-subforms 0))
-
-
-(defun past-next-token (s i n)
- (let ((escapep nil))
- (loop
- (when (>= i n) (return i))
- (let ((c (char s i)))
- (cond (escapep (setq escapep nil))
- ((char= c #\\) (setq escapep t))
- ((char= c #\#)
- (let ((j (+ i 1)))
- (if (>= j n) (return i)
- (let ((c (char s j)))
- (cond ((char= c #\\) (setq escapep t i j))
- (t (return i)))))))
- ((member c '(#\space #\tab #\( #\) #\[ #\] #\" #\' #\` #\, #\;))
- (return i))))
- (incf i))))
-
-(defun lisp-indent-number (s &optional (possible-keyword-p t))
- (or (cdr (assoc s *lisp-keywords* :test #'string-equal))
- (if (zerop (or (search "def" s :test #'char-equal)
- (search "with-" s :test #'char-equal)
- -1))
- 0
- (if possible-keyword-p
- (let ((p (position #\: s :from-end t)))
- (if p
- (lisp-indent-number (subseq s (1+ p)) nil)
- -1))
- -1))))
-
-(defun literal-token-p (s)
- (let ((colon-pos (position #\: s)))
- (if colon-pos
- (if (= colon-pos 0) t nil)
- (let ((s (safe-read-from-string s)))
- (or (eql t s) (characterp s) (numberp s) (stringp s))))))
-
-;(trace lisp-indent-number literal-token-p read-from-string past-next-token)
-
-(defun current-word (s i n)
- (let ((j (past-next-token s i n)))
- (when (not (= i j))
- (subseq s i j))))
-
-
-(defun in-labels-p (stack)
- (let ((target (cadr stack)))
- (or (and target
- (member (lparen-word target) *labels-keywords*
- :key #'symbol-name :test #'string-equal)
- (= (lparen-num-processed-subforms target) 0))
- (and target
- (member (lparen-word target) *labels2-keywords*
- :key #'symbol-name :test #'string-equal)
- (= (lparen-num-processed-subforms target) 1)))))
-
-(defun in-lambda-list-p (stack)
- (let ((target (car stack)))
- (and target
- (member (lparen-word target) *lambda-list-keywords*
- :key #'symbol-name :test #'string-equal)
- (= (lparen-num-processed-subforms target) 0))))
-
-(defun in-case-p (stack)
- (let ((target (car stack)))
- (and target
- (member (lparen-word target) *case-keywords*
- :key #'symbol-name :test #'string-equal))))
-
-
-
-(defun calc-subindent (stack s i n)
- (let* ((j (past-next-token s i n))
- (num-aligned-subforms 0)
- (left-indent
- (if (= j i) 1
- (let ((w (subseq s i j)))
- (if (and (>= i 2) (member (char s (- i 2)) '(#\' #\`))) 2
- (let ((nas (if (in-labels-p stack)
- 1
- (lisp-indent-number w))))
- (cond ((or (in-lambda-list-p stack)
- (in-case-p stack)) 1)
- ((>= nas 0) (setq num-aligned-subforms nas)
- 2)
- ((literal-token-p w) 1)
- ((= j n) 2)
- (t (+ (- j i) 2)))))))))
- (values left-indent num-aligned-subforms (1- j))))
-
-(defun num-leading-spaces (s)
- (let ((n (length s))
- (i 0) (j 0))
- (loop
- (when (>= i n) (return 0))
- (case (char s i)
- (#\space (incf i) (incf j))
- (#\tab (incf i) (incf j 8))
- (t (return j))))))
-
-
-(defun string-trim-blanks (s)
- (string-trim '(#\space #\tab #\newline #\return) s))
-
-
-(defun indent-lines ()
- (let ((left-i 0)
- (paren-stack '())
- (stringp nil))
- (loop
- (let* ((curr-line (or (read-line nil nil) (return)))
- (leading-spaces (num-leading-spaces curr-line))
- (curr-left-i
- (cond (stringp leading-spaces)
- ((null paren-stack)
- (when (= left-i 0) (setq left-i leading-spaces))
- left-i)
- (t (let* ((lp (car paren-stack))
- (nas (lparen-num-aligned-subforms lp))
- (nfs (lparen-num-finished-subforms lp))
- (extra-w 0))
- (when (< nfs nas) ;(and (>= nas 0) (< nfs nas))
- (incf (lparen-num-finished-subforms lp))
- (setq extra-w 2))
- (+ (lparen-spaces-before lp)
- extra-w))))))
- (setq curr-line (string-trim-blanks curr-line))
- (when (not (string= curr-line "")) ; don't add "trailing" whitespace
- (dotimes (k curr-left-i) (write-char #\space)))
- (princ curr-line)
- (terpri)
- ;
- (let ((i 0) (n (length curr-line)) (escapep nil)
- (inter-word-space-p nil))
- (loop
- (when (>= i n) (return))
- (let ((c (char curr-line i)))
- (cond (escapep (setq escapep nil))
- ((char= c #\\) (setq escapep t))
- (stringp (when (char= c #\") (setq stringp nil)))
- ((char= c #\;) (return))
- ((char= c #\") (setq stringp t))
- ((member c '(#\space #\tab) :test #'char=)
- (unless inter-word-space-p
- (setq inter-word-space-p t)
- (let ((lp (car paren-stack)))
- (when lp
- (incf (lparen-num-finished-subforms lp))))))
- ((member c '(#\( #\[) :test #'char=)
- (setq inter-word-space-p nil)
- (multiple-value-bind (left-indent num-aligned-subforms j)
- (calc-subindent paren-stack curr-line (1+ i) n)
- (push
- (make-lparen :word (current-word curr-line (1+ i) n)
- :spaces-before (+ i curr-left-i left-indent)
- :num-aligned-subforms num-aligned-subforms)
- paren-stack)
- (setq i j)))
- ((member c '(#\) #\]) :test #'char=)
- (setq inter-word-space-p nil)
- (cond (paren-stack (pop paren-stack))
- (t (setq left-i 0)))
- (let ((lp (car paren-stack)))
- (when lp
- (incf (lparen-num-processed-subforms lp)))))
- (t (setq inter-word-space-p nil)))
- (incf i))))))))
-
-
-(defun main ()
- (source-config-files)
- (indent-lines)
- t)
-
-(defun build ()
- (sb-ext:save-lisp-and-die "lispindent"
- :toplevel 'main
- :executable t))