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