tools-for-build/canonicalize-whitespace.lisp

   1 ;;;; Convert tabs to spaces and delete trailing whitespace in files.
   2 ;;;;
   3 ;;;; To be run in the root directory of the distribution as part of
   4 ;;;; make.sh.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 ;;; Stream and single-file functions
  16
  17 (defun whitespace-p (character)
  18   (member character '(#\Space #\Tab) :test #'char=))
  19
  20 (defun canonicalize-whitespace (input output)
  21   (let (change-p)
  22     (flet ((remove-trailing-whitespace (line)
  23              (let ((non-ws-position (position-if-not #'whitespace-p line
  24                                                      :from-end t)))
  25                (unless (and non-ws-position
  26                             (< non-ws-position (1- (length line))))
  27                  (return-from remove-trailing-whitespace line))
  28                (setq change-p t)
  29                (subseq line 0 (1+ non-ws-position))))
  30            (remove-tabs (line)
  31              (unless (find #\Tab line :test #'char=)
  32                (return-from remove-tabs line))
  33              (setq change-p t)
  34              (with-output-to-string (stream)
  35                (loop :for char :across line :do
  36                   (if (char= char #\Tab)
  37                       (write-string "        " stream)
  38                       (write-char char stream))))))
  39       (loop :for line = (read-line input nil :eof)
  40          :until (eq line :eof)
  41          :do (let ((clean (remove-tabs (remove-trailing-whitespace line))))
  42                (write-line clean output))))
  43     change-p))
  44
  45 (defun canonicalize-whitespace/file (file)
  46   (macrolet ((with-open-source-file ((stream pathname direction) &body body)
  47                `(with-open-file (,stream ,pathname
  48                                          :direction ,direction
  49                                          :external-format #-clisp :utf-8 #+clisp charset:utf-8)
  50                   ,@body)))
  51     (let* ((temporary (make-pathname :type "temp" :defaults file))
  52            (change-p
  53             (handler-case
  54                 (with-open-source-file (input file :input)
  55                   (with-open-source-file (output temporary :output)
  56                     (canonicalize-whitespace input output)))
  57               (#+sbcl sb-int:stream-decoding-error #-sbcl error ()
  58                 (format t "// Ignoring non-UTF-8 source file ~S~%" file)
  59                 nil))))
  60       (cond
  61         (change-p
  62          (delete-file file)
  63          (rename-file temporary file))
  64         ((probe-file temporary)
  65          (delete-file temporary))))))
  66
  67 ;;; Timestamp functions
  68
  69 (defvar *stamp-file* "whitespace-stamp")
  70
  71 (defun read-stamp-file ()
  72   (if (probe-file *stamp-file*)
  73       (file-write-date *stamp-file*)
  74       0))
  75
  76 (defun write-stamp-file ()
  77   (with-open-file (stream *stamp-file*
  78                           :direction :output
  79                           :if-exists :supersede)
  80     #-sbcl (declare (ignore stream))))
  81
  82 ;;; Repository-level functions
  83
  84 (defvar *source-types* '("lisp" "lisp-expr" "c" "h" "asd" "texinfo"))
  85
  86 (defvar *exceptions* '("compile-file-pos-utf16be"))
  87
  88 (defun canonicalize-whitespace/directory
  89     (&optional (directory *default-pathname-defaults*))
  90   (let ((stamp-date (read-stamp-file)))
  91     (labels ((older-than-stamp (file)
  92                (< (file-write-date file) stamp-date))
  93              (exception-p (file)
  94                (member (pathname-name file) *exceptions*
  95                        :test #'string=))
  96              (skip-p (file)
  97                (or (older-than-stamp file) (exception-p file))))
  98       (dolist (type *source-types*)
  99         (let* ((pattern (merge-pathnames
 100                          (make-pathname :type type
 101                                         :name :wild
 102                                         :directory '(:relative :wild-inferiors))
 103                          directory))
 104                (files (remove-if #'skip-p (directory pattern))))
 105           (mapc #'canonicalize-whitespace/file files))))
 106     (write-stamp-file)))
 107
 108 ;;; Entry point
 109
 110 (canonicalize-whitespace/directory)