test/src/casefiddle-tests.el

   1 ;;; casefiddle-tests.el --- tests for casefiddle.c functions -*- lexical-binding: t -*-
   2
   3 ;; Copyright (C) 2015-2016 Free Software Foundation, Inc.
   4
   5 ;; This file is part of GNU Emacs.
   6
   7 ;; GNU Emacs is free software: you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Emacs is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Code:
  21
  22 (require 'case-table)
  23 (require 'ert)
  24
  25 (ert-deftest casefiddle-tests-char-properties ()
  26   "Sanity check of character Unicode properties."
  27   (should-not
  28    (let (errors)
  29      ;;            character  uppercase  lowercase  titlecase
  30      (dolist (test '((?A nil ?a nil)
  31                      (?a ?A nil ?A)
  32                      (?Ł nil ?ł nil)
  33                      (?ł ?Ł nil ?Ł)
  34
  35                      (?Ǆ nil ?ǆ ?ǅ)
  36                      (?ǅ ?Ǆ ?ǆ ?ǅ)
  37                      (?ǆ ?Ǆ nil ?ǅ)
  38
  39                      (?Σ nil ?σ nil)
  40                      (?σ ?Σ nil ?Σ)
  41                      (?ς ?Σ nil ?Σ)
  42
  43                      (?ⅷ ?Ⅷ nil ?Ⅷ)
  44                      (?Ⅷ nil ?ⅷ nil)))
  45        (let ((ch (car test))
  46              (expected (cdr test))
  47              (props '(uppercase lowercase titlecase)))
  48          (while props
  49            (let ((got (get-char-code-property ch (car props))))
  50              (unless (equal (car expected) got)
  51                (push (format "\n%c %s; expected: %s but got: %s"
  52                              ch (car props) (car expected) got)
  53                      errors)))
  54            (setq props (cdr props) expected (cdr expected)))))
  55      (when errors
  56        (mapconcat (lambda (line) line) (nreverse errors) "")))))
  57
  58
  59 (defconst casefiddle-tests--characters
  60   ;; character  uppercase  lowercase  titlecase
  61   '((?A ?A ?a ?A)
  62     (?a ?A ?a ?A)
  63     (?Ł ?Ł ?ł ?Ł)
  64     (?ł ?Ł ?ł ?Ł)
  65
  66     ;; FIXME(bug#24603): Commented ones are what we want.
  67     ;;(?Ǆ ?Ǆ ?ǆ ?ǅ)
  68     (?Ǆ ?Ǆ ?ǆ ?Ǆ)
  69     ;;(?ǅ ?Ǆ ?ǆ ?ǅ)
  70     (?ǅ ?Ǆ ?ǆ ?Ǆ)
  71     ;;(?ǆ ?Ǆ ?ǆ ?ǅ)
  72     (?ǆ ?Ǆ ?ǆ ?Ǆ)
  73
  74     (?Σ ?Σ ?σ ?Σ)
  75     (?σ ?Σ ?σ ?Σ)
  76     (?ς ?Σ ?ς ?Σ)
  77
  78     (?Ⅷ ?Ⅷ ?ⅷ ?Ⅷ)
  79     (?ⅷ ?Ⅷ ?ⅷ ?Ⅷ)))
  80
  81
  82 (ert-deftest casefiddle-tests-case-table ()
  83   "Sanity check of down and up case tables."
  84   (should-not
  85    (let (errors
  86          (up (case-table-get-table (current-case-table) 'up))
  87          (down (case-table-get-table (current-case-table) 'down)))
  88      (dolist (test casefiddle-tests--characters)
  89        (let ((ch (car test))
  90              (expected (cdr test))
  91              (props '(uppercase lowercase))
  92              (tabs (list up down)))
  93          (while props
  94            (let ((got (aref (car tabs) ch)))
  95              (unless (equal (car expected) got)
  96                (push (format "\n%c %s; expected: %s but got: %s"
  97                              ch (car props) (car expected) got)
  98                      errors)))
  99            (setq props (cdr props) tabs (cdr tabs) expected (cdr expected)))))
 100      (when errors
 101        (mapconcat (lambda (line) line) (nreverse errors) "")))))
 102
 103
 104 (ert-deftest casefiddle-tests-casing-character ()
 105   (should-not
 106    (let (errors)
 107      (dolist (test casefiddle-tests--characters)
 108        (let ((ch (car test))
 109              (expected (cdr test))
 110              (funcs '(upcase downcase capitalize)))
 111          (while funcs
 112            (let ((got (funcall (car funcs) ch)))
 113              (unless (equal (car expected) got)
 114                (push (format "\n%c %s; expected: %s but got: %s"
 115                              ch (car funcs) (car expected) got)
 116                      errors)))
 117            (setq funcs (cdr funcs) expected (cdr expected)))))
 118      (when errors
 119        (mapconcat (lambda (line) line) (nreverse errors) "")))))
 120
 121
 122 (ert-deftest casefiddle-tests-casing-word ()
 123   (with-temp-buffer
 124     (dolist (test '((upcase-word     . "FOO Bar")
 125                     (downcase-word   . "foo Bar")
 126                     (capitalize-word . "Foo Bar")))
 127       (dolist (back '(nil t))
 128         (delete-region (point-min) (point-max))
 129         (insert "foO Bar")
 130         (goto-char (+ (if back 4 0) (point-min)))
 131         (funcall (car test) (if back -1 1))
 132         (should (string-equal (cdr test) (buffer-string)))
 133         (should (equal (+ (if back 4 3) (point-min)) (point)))))))
 134
 135
 136 (defun casefiddle-tests--test-casing (tests)
 137   (nreverse
 138    (cl-reduce
 139     (lambda (errors test)
 140       (let* ((input (car test))
 141              (expected (cdr test))
 142              (func-pairs '((upcase upcase-region)
 143                            (downcase downcase-region)
 144                            (capitalize capitalize-region)
 145                            (upcase-initials upcase-initials-region)))
 146              (get-string (lambda (func) (funcall func input)))
 147              (get-region (lambda (func)
 148                            (delete-region (point-min) (point-max))
 149                            (unwind-protect
 150                                (progn
 151                                  (unless (multibyte-string-p input)
 152                                    (toggle-enable-multibyte-characters))
 153                                  (insert input)
 154                                  (funcall func (point-min) (point-max))
 155                                  (buffer-string))
 156                              (unless (multibyte-string-p input)
 157                                (toggle-enable-multibyte-characters)))))
 158              (fmt-str (lambda (str)
 159                         (format "%s  (%sbyte; %d chars; %d bytes)"
 160                                 str
 161                                 (if (multibyte-string-p str) "multi" "uni")
 162                                 (length str) (string-bytes str))))
 163              funcs getters)
 164         (while (and func-pairs expected)
 165           (setq funcs (car func-pairs)
 166                 getters (list get-string get-region))
 167           (while (and funcs getters)
 168             (let ((got (funcall (car getters) (car funcs))))
 169               (unless (string-equal got (car expected))
 170                 (let ((fmt (length (symbol-name (car funcs)))))
 171                   (setq fmt (format "\n%%%ds: %%s" (max fmt 8)))
 172                   (push (format (concat fmt fmt fmt)
 173                                 (car funcs) (funcall fmt-str input)
 174                                 "expected" (funcall fmt-str (car expected))
 175                                 "but got" (funcall fmt-str got))
 176                         errors))))
 177             (setq funcs (cdr funcs) getters (cdr getters)))
 178           (setq func-pairs (cdr func-pairs) expected (cdr expected))))
 179       errors)
 180     (cons () tests))))
 181
 182 (ert-deftest casefiddle-tests-casing ()
 183   (should-not
 184    (with-temp-buffer
 185      (casefiddle-tests--test-casing
 186       ;; input     upper     lower    capitalize up-initials
 187       '(("Foo baR" "FOO BAR" "foo bar" "Foo Bar" "Foo BaR")
 188         ("Ⅷ ⅷ" "Ⅷ Ⅷ" "ⅷ ⅷ" "Ⅷ Ⅷ" "Ⅷ Ⅷ")
 189         ;; FIXME(bug#24603): Everything below is broken at the moment.
 190         ;; Here’s what should happen:
 191         ;;("ǄUNGLA" "ǄUNGLA" "ǆungla" "ǅungla" "ǅUNGLA")
 192         ;;("ǅungla" "ǄUNGLA" "ǆungla" "ǅungla" "ǅungla")
 193         ;;("ǆungla" "ǄUNGLA" "ǆungla" "ǅungla" "ǅungla")
 194         ;;("deﬁne" "DEFINE" "deﬁne" "Deﬁne" "Deﬁne")
 195         ;;("ﬁsh" "FIsh" "ﬁsh" "Fish" "Fish")
 196         ;;("Straße" "STRASSE" "straße" "Straße" "Straße")
 197         ;;("ΌΣΟΣ" "ΌΣΟΣ" "όσος" "Όσος" "Όσος")
 198         ;; And here’s what is actually happening:
 199         ("ǄUNGLA" "ǄUNGLA" "ǆungla" "Ǆungla" "ǄUNGLA")
 200         ("ǅungla" "ǄUNGLA" "ǆungla" "Ǆungla" "Ǆungla")
 201         ("ǆungla" "ǄUNGLA" "ǆungla" "Ǆungla" "Ǆungla")
 202         ("deﬁne" "DEﬁNE" "deﬁne" "Deﬁne" "Deﬁne")
 203         ("ﬁsh" "ﬁSH" "ﬁsh" "ﬁsh" "ﬁsh")
 204         ("Straße" "STRAßE" "straße" "Straße" "Straße")
 205         ("ΌΣΟΣ" "ΌΣΟΣ" "όσοσ" "Όσοσ" "ΌΣΟΣ")
 206
 207         ("όσος" "ΌΣΟΣ" "όσος" "Όσος" "Όσος"))))))
 208
 209 (ert-deftest casefiddle-tests-casing-byte8 ()
 210   (should-not
 211    (with-temp-buffer
 212      (casefiddle-tests--test-casing
 213       '(("\xff Foo baR \xff"
 214          "\xff FOO BAR \xff"
 215          "\xff foo bar \xff"
 216          "\xff Foo Bar \xff"
 217          "\xff Foo BaR \xff")
 218         ("\xff Zażółć gĘŚlą \xff"
 219          "\xff ZAŻÓŁĆ GĘŚLĄ \xff"
 220          "\xff zażółć gęślą \xff"
 221          "\xff Zażółć Gęślą \xff"
 222          "\xff Zażółć GĘŚlą \xff"))))))
 223
 224 (ert-deftest casefiddle-tests-casing-byte8-with-changes ()
 225   (let ((tab (copy-case-table (standard-case-table)))
 226         (test '("\xff\xff\xef Foo baR \xcf\xcf"
 227                 "\xef\xef\xef FOO BAR \xcf\xcf"
 228                 "\xff\xff\xff foo bar \xcf\xcf"
 229                 "\xef\xff\xff Foo Bar \xcf\xcf"
 230                 "\xef\xff\xef Foo BaR \xcf\xcf"))
 231         (byte8 #x3FFF00))
 232     (should-not
 233      (with-temp-buffer
 234        (set-case-table tab)
 235        (set-case-syntax-pair (+ byte8 #xef) (+ byte8 #xff) tab)
 236        (casefiddle-tests--test-casing
 237         (list test
 238               (mapcar (lambda (str) (decode-coding-string str 'binary)) test)
 239               '("\xff\xff\xef Zażółć gĘŚlą \xcf\xcf"
 240                 "\xef\xef\xef ZAŻÓŁĆ GĘŚLĄ \xcf\xcf"
 241                 "\xff\xff\xff zażółć gęślą \xcf\xcf"
 242                 "\xef\xff\xff Zażółć Gęślą \xcf\xcf"
 243                 "\xef\xff\xef Zażółć GĘŚlą \xcf\xcf")))))))
 244
 245
 246 ;;; casefiddle-tests.el ends here