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                (cond
  26                  ((not non-ws-position)
  27                   (unless (zerop (length line))
  28                     (setq change-p t))
  29                   "")
  30                  ((< non-ws-position (1- (length line)))
  31                   (setq change-p t)
  32                   (subseq line 0 (1+ non-ws-position)))
  33                  (t
  34                   line))))
  35            (remove-tabs (line)
  36              (unless (find #\Tab line :test #'char=)
  37                (return-from remove-tabs line))
  38              (setq change-p t)
  39              (with-output-to-string (stream)
  40                (loop :for char :across line :do
  41                   (if (char= char #\Tab)
  42                       (write-string "        " stream)
  43                       (write-char char stream))))))
  44       (loop :for line = (read-line input nil :eof)
  45          :until (eq line :eof)
  46          :do (let ((clean (remove-tabs (remove-trailing-whitespace line))))
  47                (write-line clean output))))
  48     change-p))
  49
  50 (defun canonicalize-whitespace/file (file)
  51   (macrolet ((with-open-source-file ((stream pathname direction) &body body)
  52                `(with-open-file (,stream ,pathname
  53                                          :direction ,direction
  54                                          :external-format #-clisp :utf-8 #+clisp charset:utf-8)
  55                   ,@body)))
  56     (let* ((temporary (make-pathname :type "temp" :defaults file))
  57            (change-p
  58             (handler-case
  59                 (with-open-source-file (input file :input)
  60                   (with-open-source-file (output temporary :output)
  61                     (canonicalize-whitespace input output)))
  62               (#+sbcl sb-int:stream-decoding-error #-sbcl error ()
  63                 (format t "// Ignoring non-UTF-8 source file ~S~%" file)
  64                 nil))))
  65       (cond
  66         (change-p
  67          (delete-file file)
  68          (rename-file temporary file))
  69         ((probe-file temporary)
  70          (delete-file temporary))))))
  71
  72 ;;; Timestamp functions
  73
  74 (defvar *stamp-file* "whitespace-stamp")
  75
  76 (defun read-stamp-file ()
  77   (if (probe-file *stamp-file*)
  78       (file-write-date *stamp-file*)
  79       0))
  80
  81 (defun write-stamp-file ()
  82   (with-open-file (stream *stamp-file*
  83                           :direction :output
  84                           :if-exists :supersede)
  85     #-sbcl (declare (ignore stream))))
  86
  87 ;;; Repository-level functions
  88
  89 (defvar *source-types* '("lisp" "lisp-expr" "c" "h" "asd" "texinfo"))
  90
  91 (defvar *exceptions* '("compile-file-pos-utf16be"))
  92
  93 (defun canonicalize-whitespace/directory
  94     (&optional (directory *default-pathname-defaults*))
  95   (let ((stamp-date (read-stamp-file)))
  96     (labels ((older-than-stamp (file)
  97                (< (file-write-date file) stamp-date))
  98              (exception-p (file)
  99                (member (pathname-name file) *exceptions*
 100                        :test #'string=))
 101              (skip-p (file)
 102                (or (older-than-stamp file) (exception-p file))))
 103       (dolist (type *source-types*)
 104         (let* ((pattern (merge-pathnames
 105                          (make-pathname :type type
 106                                         :name :wild
 107                                         :directory '(:relative :wild-inferiors))
 108                          directory))
 109                (files (remove-if #'skip-p (directory pattern))))
 110           (mapc #'canonicalize-whitespace/file files))))
 111     (write-stamp-file)))
 112
 113 ;;; Entry point
 114
 115 (canonicalize-whitespace/directory)