coleslaw/src/util.lisp - Recently Written

src/util.lisp (5255 bytes)
1 (in-package :coleslaw)
2 
3 
4 (define-condition coleslaw-condition ()
5   ())
6 
7 (define-condition field-missing (error coleslaw-condition)
8   ((field-name :initarg :field-name :reader missing-field-field-name)
9    (file :initarg :file :reader missing-field-file
10          :documentation "The path of the file where the field is missing."))
11   (:report
12    (lambda (c s)
13      (format s "~A: The required field ~A is missing."
14              (missing-field-file c)
15              (missing-field-field-name c)))))
16 
17 (defmacro assert-field (field-name content)
18   `(when (not (slot-boundp ,content ,field-name))
19      (error 'field-missing
20             :field-name ,field-name
21             :file (content-file ,content))))
22 
23 (defun construct (class-name args)
24   "Create an instance of CLASS-NAME with the given ARGS."
25   (apply 'make-instance class-name args))
26 
27 ;; Thanks to bknr-web for this bit of code.
28 (defun all-subclasses (class)
29   "Return a list of all the subclasses of CLASS."
30   (let ((subclasses (closer-mop:class-direct-subclasses class)))
31     (append subclasses (loop for subclass in subclasses
32                           nconc (all-subclasses subclass)))))
33 
34 (defmacro do-subclasses ((var class) &body body)
35   "Iterate over the subclasses of CLASS performing BODY with VAR
36 lexically bound to the current subclass."
37   (alexandria:with-gensyms (klasses)
38     `(let ((,klasses (all-subclasses (find-class ',class))))
39        (loop for ,var in ,klasses do ,@body))))
40 
41 (defmacro do-files ((var path &optional extension) &body body)
42   "For each file under PATH, run BODY. If EXTENSION is provided, only run
43 BODY on files that match the given extension."
44   (alexandria:with-gensyms (extension-p)
45     `(flet ((,extension-p (file)
46               (string= (pathname-type file) ,extension)))
47        (cl-fad:walk-directory ,path (lambda (,var) ,@body)
48                               :follow-symlinks nil
49                               :test (if ,extension
50                                         #',extension-p
51                                         (constantly t))))))
52 
53 (define-condition directory-does-not-exist (error)
54   ((directory :initarg :dir :reader dir))
55   (:report (lambda (c stream)
56              (format stream "The directory '~A' does not exist" (dir c)))))
57 
58 (defun (setf getcwd) (path)
59   "Change the operating system's current directory to PATH."
60   (setf path (ensure-directory-pathname path))
61   (unless (and (uiop:directory-exists-p path)
62                (uiop:chdir path))
63     (error 'directory-does-not-exist :dir path))
64   path)
65 
66 (defmacro with-current-directory (path &body body)
67   "Change the current directory to PATH and execute BODY in
68 an UNWIND-PROTECT, then change back to the current directory."
69   (alexandria:with-gensyms (old)
70     `(let ((,old (getcwd)))
71        (unwind-protect (progn
72                          (setf (getcwd) ,path)
73                          ,@body)
74          (setf (getcwd) ,old)))))
75 
76 (defun exit ()
77   ;; KLUDGE: Just call UIOP for now. Don't want users updating scripts.
78   "Exit the lisp system returning a 0 status code."
79   (uiop:quit))
80 
81 (defun fmt (fmt-str args)
82   "A convenient FORMAT interface for string building."
83   (apply 'format nil fmt-str args))
84 
85 (defun rel-path (base path &rest args)
86   "Take a relative PATH and return the corresponding pathname beneath BASE.
87 If ARGS is provided, use (fmt path args) as the value of PATH."
88   (merge-pathnames (fmt path args) base))
89 
90 (defun app-path (path &rest args)
91   "Return a relative path beneath coleslaw."
92   (apply 'rel-path coleslaw-conf:*basedir* path args))
93 
94 (defun repo-path (path &rest args)
95   "Return a relative path beneath the repo being processed."
96   (apply 'rel-path (repo-dir *config*) path args))
97 
98 (defun run-program (program &rest args)
99   "Take a PROGRAM and execute the corresponding shell command. If ARGS is provided,
100 use (fmt program args) as the value of PROGRAM."
101   (inferior-shell:run (fmt program args) :show t))
102 
103 (defun run-lines (dir &rest programs)
104   "Runs some programs, in a directory."
105   (mapc (lambda (line)
106           (run-program "cd ~A && ~A" dir line))
107         programs))
108 
109 (defun take-up-to (n seq)
110   "Take elements from SEQ until all elements or N have been taken."
111   (subseq seq 0 (min (length seq) n)))
112 
113 (defun write-file (path text)
114   "Write the given TEXT to PATH. PATH is overwritten if it exists and created
115 along with any missing parent directories otherwise."
116   (ensure-directories-exist path)
117   (with-open-file (out path
118                    :direction :output
119                    :if-exists :supersede
120                    :if-does-not-exist :create
121                    :external-format :utf-8)
122     (write text :stream out :escape nil)))
123 
124 (defun get-updated-files (&optional (revision *last-revision*))
125   "Return a plist of (file-status file-name) for files that were changed
126 in the git repo since REVISION."
127   (flet ((split-on-whitespace (str)
128            (cl-ppcre:split "\\s+" str)))
129     (let ((cmd (format nil "git diff --name-status ~A HEAD" revision)))
130       (mapcar #'split-on-whitespace (inferior-shell:run/lines cmd)))))
131 
132 (defun class-name-p (name class)
133   "True if the specified string is the name of the class provided"
134   ;; This feels way too clever. I wish I could think of a better option.
135   (string-equal name (symbol-name (class-name class))))