From 4b3df0665edc6cab1ec41222d9a623360eae5b62 Mon Sep 17 00:00:00 2001 From: Hajime Mizuno Date: Sun, 17 Jan 2016 11:32:56 +0000 Subject: Import s-el_1.11.0.orig.tar.gz [dgit import orig s-el_1.11.0.orig.tar.gz] --- .travis.yml | 15 + Cask | 8 + README.md | 973 ++++++++++++++++++ create-docs.sh | 7 + dev/.nosearch | 0 dev/ert.el | 2544 ++++++++++++++++++++++++++++++++++++++++++++++ dev/examples-to-docs.el | 128 +++ dev/examples-to-tests.el | 22 + dev/examples.el | 432 ++++++++ dev/undercover-init.el | 2 + pre-commit.sh | 9 + readme-template.md | 161 +++ run-tests.sh | 7 + run-travis-ci.sh | 28 + s.el | 617 +++++++++++ watch-tests.watchr | 38 + 16 files changed, 4991 insertions(+) create mode 100644 .travis.yml create mode 100644 Cask create mode 100644 README.md create mode 100755 create-docs.sh create mode 100644 dev/.nosearch create mode 100644 dev/ert.el create mode 100644 dev/examples-to-docs.el create mode 100644 dev/examples-to-tests.el create mode 100644 dev/examples.el create mode 100644 dev/undercover-init.el create mode 100755 pre-commit.sh create mode 100644 readme-template.md create mode 100755 run-tests.sh create mode 100755 run-travis-ci.sh create mode 100644 s.el create mode 100644 watch-tests.watchr diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..828b89b --- /dev/null +++ b/.travis.yml @@ -0,0 +1,15 @@ +language: emacs-lisp +before_install: + # PPA for stable Emacs packages + - sudo add-apt-repository -y ppa:cassou/emacs + # PPA for Emacs nightlies + - sudo add-apt-repository -y ppa:ubuntu-elisp/ppa + # Update and install the Emacs for our environment + - sudo apt-get update -qq + - sudo apt-get install -qq -yy ${EMACS}-nox ${EMACS}-el +env: + - EMACS=emacs23 + - EMACS=emacs24 + - EMACS=emacs-snapshot +script: + ./run-travis-ci.sh diff --git a/Cask b/Cask new file mode 100644 index 0000000..52ffdee --- /dev/null +++ b/Cask @@ -0,0 +1,8 @@ +(source gnu) +(source melpa) + +(package-file "s.el") + +(development + (depends-on "undercover")) + diff --git a/README.md b/README.md new file mode 100644 index 0000000..8899279 --- /dev/null +++ b/README.md @@ -0,0 +1,973 @@ +# s.el [![Build Status](https://secure.travis-ci.org/magnars/s.el.png)](http://travis-ci.org/magnars/s.el) [![Coverage Status](https://coveralls.io/repos/magnars/s.el/badge.svg?branch=master)](https://coveralls.io/r/magnars/s.el?branch=master) + +The long lost Emacs string manipulation library. + +## Installation + +It's available on [marmalade](http://marmalade-repo.org/) and [Melpa](https://melpa.org/): + + M-x package-install s + +Or you can just dump `s.el` in your load path somewhere. + +## Functions + + +### Tweak whitespace + +* [s-trim](#s-trim-s) `(s)` +* [s-trim-left](#s-trim-left-s) `(s)` +* [s-trim-right](#s-trim-right-s) `(s)` +* [s-chomp](#s-chomp-s) `(s)` +* [s-collapse-whitespace](#s-collapse-whitespace-s) `(s)` +* [s-word-wrap](#s-word-wrap-len-s) `(len s)` +* [s-center](#s-center-len-s) `(len s)` +* [s-pad-left](#s-pad-left-len-padding-s) `(len padding s)` +* [s-pad-right](#s-pad-right-len-padding-s) `(len padding s)` + +### To shorter string + +* [s-truncate](#s-truncate-len-s) `(len s)` +* [s-left](#s-left-len-s) `(len s)` +* [s-right](#s-right-len-s) `(len s)` +* [s-chop-suffix](#s-chop-suffix-suffix-s) `(suffix s)` +* [s-chop-suffixes](#s-chop-suffixes-suffixes-s) `(suffixes s)` +* [s-chop-prefix](#s-chop-prefix-prefix-s) `(prefix s)` +* [s-chop-prefixes](#s-chop-prefixes-prefixes-s) `(prefixes s)` +* [s-shared-start](#s-shared-start-s1-s2) `(s1 s2)` +* [s-shared-end](#s-shared-end-s1-s2) `(s1 s2)` + +### To longer string + +* [s-repeat](#s-repeat-num-s) `(num s)` +* [s-concat](#s-concat-rest-strings) `(&rest strings)` +* [s-prepend](#s-prepend-prefix-s) `(prefix s)` +* [s-append](#s-append-suffix-s) `(suffix s)` +* [s-wrap](#s-wrap-s-prefix-optional-suffix) `(s prefix &optional suffix)` + +### To and from lists + +* [s-lines](#s-lines-s) `(s)` +* [s-match](#s-match-regexp-s-optional-start) `(regexp s &optional start)` +* [s-match-strings-all](#s-match-strings-all-regex-string) `(regex string)` +* [s-matched-positions-all](#s-matched-positions-all-regexp-string-optional-subexp-depth) `(regexp string &optional subexp-depth)` +* [s-slice-at](#s-slice-at-regexp-s) `(regexp s)` +* [s-split](#s-split-separator-s-optional-omit-nulls) `(separator s &optional omit-nulls)` +* [s-split-up-to](#s-split-up-to-separator-s-n-optional-omit-nulls) `(separator s n &optional omit-nulls)` +* [s-join](#s-join-separator-strings) `(separator strings)` + +### Predicates + +* [s-equals?](#s-equals-s1-s2) `(s1 s2)` +* [s-less?](#s-less-s1-s2) `(s1 s2)` +* [s-matches?](#s-matches-regexp-s-optional-start) `(regexp s &optional start)` +* [s-blank?](#s-blank-s) `(s)` +* [s-present?](#s-present-s) `(s)` +* [s-ends-with?](#s-ends-with-suffix-s-optional-ignore-case) `(suffix s &optional ignore-case)` +* [s-starts-with?](#s-starts-with-prefix-s-optional-ignore-case) `(prefix s &optional ignore-case)` +* [s-contains?](#s-contains-needle-s-optional-ignore-case) `(needle s &optional ignore-case)` +* [s-lowercase?](#s-lowercase-s) `(s)` +* [s-uppercase?](#s-uppercase-s) `(s)` +* [s-mixedcase?](#s-mixedcase-s) `(s)` +* [s-capitalized?](#s-capitalized-s) `(s)` +* [s-numeric?](#s-numeric-s) `(s)` + +### The misc bucket + +* [s-replace](#s-replace-old-new-s) `(old new s)` +* [s-replace-all](#s-replace-all-replacements-s) `(replacements s)` +* [s-downcase](#s-downcase-s) `(s)` +* [s-upcase](#s-upcase-s) `(s)` +* [s-capitalize](#s-capitalize-s) `(s)` +* [s-titleize](#s-titleize-s) `(s)` +* [s-with](#s-with-s-form-rest-more) `(s form &rest more)` +* [s-index-of](#s-index-of-needle-s-optional-ignore-case) `(needle s &optional ignore-case)` +* [s-reverse](#s-reverse-s) `(s)` +* [s-presence](#s-presence-s) `(s)` +* [s-format](#s-format-template-replacer-optional-extra) `(template replacer &optional extra)` +* [s-lex-format](#s-lex-format-format-str) `(format-str)` +* [s-count-matches](#s-count-matches-regexp-s-optional-start-end) `(regexp s &optional start end)` +* [s-wrap](#s-wrap-s-prefix-optional-suffix) `(s prefix &optional suffix)` + +### Pertaining to words + +* [s-split-words](#s-split-words-s) `(s)` +* [s-lower-camel-case](#s-lower-camel-case-s) `(s)` +* [s-upper-camel-case](#s-upper-camel-case-s) `(s)` +* [s-snake-case](#s-snake-case-s) `(s)` +* [s-dashed-words](#s-dashed-words-s) `(s)` +* [s-capitalized-words](#s-capitalized-words-s) `(s)` +* [s-titleized-words](#s-titleized-words-s) `(s)` +* [s-word-initials](#s-word-initials-s) `(s)` + +## Documentation and examples + + +### s-trim `(s)` + +Remove whitespace at the beginning and end of `s`. + +```cl +(s-trim "trim ") ;; => "trim" +(s-trim " this") ;; => "this" +(s-trim " only trims beg and end ") ;; => "only trims beg and end" +``` + +### s-trim-left `(s)` + +Remove whitespace at the beginning of `s`. + +```cl +(s-trim-left "trim ") ;; => "trim " +(s-trim-left " this") ;; => "this" +``` + +### s-trim-right `(s)` + +Remove whitespace at the end of `s`. + +```cl +(s-trim-right "trim ") ;; => "trim" +(s-trim-right " this") ;; => " this" +``` + +### s-chomp `(s)` + +Remove one trailing `\n`, `\r` or `\r\n` from `s`. + +```cl +(s-chomp "no newlines\n") ;; => "no newlines" +(s-chomp "no newlines\r\n") ;; => "no newlines" +(s-chomp "some newlines\n\n") ;; => "some newlines\n" +``` + +### s-collapse-whitespace `(s)` + +Convert all adjacent whitespace characters to a single space. + +```cl +(s-collapse-whitespace "only one space please") ;; => "only one space please" +(s-collapse-whitespace "collapse \n all \t sorts of \r whitespace") ;; => "collapse all sorts of whitespace" +``` + +### s-word-wrap `(len s)` + +If `s` is longer than `len`, wrap the words with newlines. + +```cl +(s-word-wrap 10 "This is too long") ;; => "This is\ntoo long" +(s-word-wrap 10 "This is way way too long") ;; => "This is\nway way\ntoo long" +(s-word-wrap 10 "It-wraps-words-but-does-not-break-them") ;; => "It-wraps-words-but-does-not-break-them" +``` + +### s-center `(len s)` + +If `s` is shorter than `len`, pad it with spaces so it is centered. + +```cl +(s-center 5 "a") ;; => " a " +(s-center 5 "ab") ;; => " ab " +(s-center 1 "abc") ;; => "abc" +``` + +### s-pad-left `(len padding s)` + +If `s` is shorter than `len`, pad it with `padding` on the left. + +```cl +(s-pad-left 3 "0" "3") ;; => "003" +(s-pad-left 3 "0" "23") ;; => "023" +(s-pad-left 3 "0" "1234") ;; => "1234" +``` + +### s-pad-right `(len padding s)` + +If `s` is shorter than `len`, pad it with `padding` on the right. + +```cl +(s-pad-right 3 "." "3") ;; => "3.." +(s-pad-right 3 "." "23") ;; => "23." +(s-pad-right 3 "." "1234") ;; => "1234" +``` + + +### s-truncate `(len s)` + +If `s` is longer than `len`, cut it down to `len` - 3 and add ... at the end. + +```cl +(s-truncate 6 "This is too long") ;; => "Thi..." +(s-truncate 16 "This is also too long") ;; => "This is also ..." +(s-truncate 16 "But this is not!") ;; => "But this is not!" +``` + +### s-left `(len s)` + +Returns up to the `len` first chars of `s`. + +```cl +(s-left 3 "lib/file.js") ;; => "lib" +(s-left 3 "li") ;; => "li" +``` + +### s-right `(len s)` + +Returns up to the `len` last chars of `s`. + +```cl +(s-right 3 "lib/file.js") ;; => ".js" +(s-right 3 "li") ;; => "li" +``` + +### s-chop-suffix `(suffix s)` + +Remove `suffix` if it is at end of `s`. + +```cl +(s-chop-suffix "-test.js" "penguin-test.js") ;; => "penguin" +(s-chop-suffix "\n" "no newlines\n") ;; => "no newlines" +(s-chop-suffix "\n" "some newlines\n\n") ;; => "some newlines\n" +``` + +### s-chop-suffixes `(suffixes s)` + +Remove `suffixes` one by one in order, if they are at the end of `s`. + +```cl +(s-chop-suffixes '("_test.js" "-test.js" "Test.js") "penguin-test.js") ;; => "penguin" +(s-chop-suffixes '("\r" "\n") "penguin\r\n") ;; => "penguin\r" +(s-chop-suffixes '("\n" "\r") "penguin\r\n") ;; => "penguin" +``` + +### s-chop-prefix `(prefix s)` + +Remove `prefix` if it is at the start of `s`. + +```cl +(s-chop-prefix "/tmp" "/tmp/file.js") ;; => "/file.js" +(s-chop-prefix "/tmp" "/tmp/tmp/file.js") ;; => "/tmp/file.js" +``` + +### s-chop-prefixes `(prefixes s)` + +Remove `prefixes` one by one in order, if they are at the start of `s`. + +```cl +(s-chop-prefixes '("/tmp" "/my") "/tmp/my/file.js") ;; => "/file.js" +(s-chop-prefixes '("/my" "/tmp") "/tmp/my/file.js") ;; => "/my/file.js" +``` + +### s-shared-start `(s1 s2)` + +Returns the longest prefix `s1` and `s2` have in common. + +```cl +(s-shared-start "bar" "baz") ;; => "ba" +(s-shared-start "foobar" "foo") ;; => "foo" +(s-shared-start "bar" "foo") ;; => "" +``` + +### s-shared-end `(s1 s2)` + +Returns the longest suffix `s1` and `s2` have in common. + +```cl +(s-shared-end "bar" "var") ;; => "ar" +(s-shared-end "foo" "foo") ;; => "foo" +(s-shared-end "bar" "foo") ;; => "" +``` + + +### s-repeat `(num s)` + +Make a string of `s` repeated `num` times. + +```cl +(s-repeat 10 " ") ;; => " " +(s-concat (s-repeat 8 "Na") " Batman!") ;; => "NaNaNaNaNaNaNaNa Batman!" +``` + +### s-concat `(&rest strings)` + +Join all the string arguments into one string. + +```cl +(s-concat "abc" "def" "ghi") ;; => "abcdefghi" +``` + +### s-prepend `(prefix s)` + +Concatenate `prefix` and `s`. + +```cl +(s-prepend "abc" "def") ;; => "abcdef" +``` + +### s-append `(suffix s)` + +Concatenate `s` and `suffix`. + +```cl +(s-append "abc" "def") ;; => "defabc" +``` + +### s-wrap `(s prefix &optional suffix)` + +Wrap string `s` with `prefix` and optionally `suffix`. + +Return string `s` with `prefix` prepended. If `suffix` is present, it +is appended, otherwise `prefix` is used as both prefix and +suffix. + +```cl +(s-wrap "[" "]" "foobar") ;; => "[foobar]" +(s-wrap "(" "" "foobar") ;; => "(foobar" +(s-wrap "" ")" "foobar") ;; => "foobar)" +``` + + +### s-lines `(s)` + +Splits `s` into a list of strings on newline characters. + +```cl +(s-lines "abc\ndef\nghi") ;; => '("abc" "def" "ghi") +(s-lines "abc\rdef\rghi") ;; => '("abc" "def" "ghi") +(s-lines "abc\r\ndef\r\nghi") ;; => '("abc" "def" "ghi") +``` + +### s-match `(regexp s &optional start)` + +When the given expression matches the string, this function returns a list +of the whole matching string and a string for each matched subexpressions. +If it did not match the returned value is an empty list (nil). + +When `start` is non-nil the search will start at that index. + +```cl +(s-match "^def" "abcdefg") ;; => nil +(s-match "^abc" "abcdefg") ;; => '("abc") +(s-match "^/.*/\\([a-z]+\\)\\.\\([a-z]+\\)" "/some/weird/file.html") ;; => '("/some/weird/file.html" "file" "html") +``` + +### s-match-strings-all `(regex string)` + +Return a list of matches for `regex` in `string`. + +Each element itself is a list of matches, as per +`match-string`. Multiple matches at the same position will be +ignored after the first. + +```cl +(s-match-strings-all "{\\([^}]+\\)}" "x is {x} and y is {y}") ;; => '(("{x}" "x") ("{y}" "y")) +(s-match-strings-all "ab." "abXabY") ;; => '(("abX") ("abY")) +(s-match-strings-all "\\<" "foo bar baz") ;; => '(("") ("") ("")) +``` + +### s-matched-positions-all `(regexp string &optional subexp-depth)` + +Return a list of matched positions for `regexp` in `string`. +`subexp-depth` is 0 by default. + +```cl +(s-matched-positions-all "l+" "{{Hello}} World, {{Emacs}}!" 0) ;; => '((4 . 6) (13 . 14)) +(s-matched-positions-all "{{\\(.+?\\)}}" "{{Hello}} World, {{Emacs}}!" 0) ;; => '((0 . 9) (17 . 26)) +(s-matched-positions-all "{{\\(.+?\\)}}" "{{Hello}} World, {{Emacs}}!" 1) ;; => '((2 . 7) (19 . 24)) +``` + +### s-slice-at `(regexp s)` + +Slices `s` up at every index matching `regexp`. + +```cl +(s-slice-at "-" "abc") ;; => '("abc") +(s-slice-at "-" "abc-def") ;; => '("abc" "-def") +(s-slice-at "[.#]" "abc.def.ghi#id") ;; => '("abc" ".def" ".ghi" "#id") +``` + +### s-split `(separator s &optional omit-nulls)` + +Split `s` into substrings bounded by matches for regexp `separator`. +If `omit-nulls` is non-nil, zero-length substrings are omitted. + +This is a simple wrapper around the built-in `split-string`. + +```cl +(s-split "|" "a|bc|12|3") ;; => '("a" "bc" "12" "3") +(s-split ":" "a,c,d") ;; => '("a,c,d") +(s-split "\n" "z\nefg\n") ;; => '("z" "efg" "") +``` + +### s-split-up-to `(separator s n &optional omit-nulls)` + +Split `s` up to `n` times into substrings bounded by matches for regexp `separator`. + +If `omit-nulls` is non-nil, zero-length substrings are omitted. + +See also `s-split`. + +```cl +(s-split-up-to "\\s-*-\\s-*" "Author - Track-number-one" 1) ;; => '("Author" "Track-number-one") +(s-split-up-to "\\s-*-\\s-*" "Author - Track-number-one" 2) ;; => '("Author" "Track" "number-one") +(s-split-up-to "|" "foo||bar|baz|qux" 3 t) ;; => '("foo" "bar" "baz|qux") +``` + +### s-join `(separator strings)` + +Join all the strings in `strings` with `separator` in between. + +```cl +(s-join "+" '("abc" "def" "ghi")) ;; => "abc+def+ghi" +(s-join "\n" '("abc" "def" "ghi")) ;; => "abc\ndef\nghi" +``` + + +### s-equals? `(s1 s2)` + +Is `s1` equal to `s2`? + +This is a simple wrapper around the built-in `string-equal`. + +```cl +(s-equals? "abc" "ABC") ;; => nil +(s-equals? "abc" "abc") ;; => t +``` + +### s-less? `(s1 s2)` + +Is `s1` less than `s2`? + +This is a simple wrapper around the built-in `string-lessp`. + +```cl +(s-less? "abc" "abd") ;; => t +(s-less? "abd" "abc") ;; => nil +(s-less? "abc" "abc") ;; => nil +``` + +### s-matches? `(regexp s &optional start)` + +Does `regexp` match `s`? +If `start` is non-nil the search starts at that index. + +This is a simple wrapper around the built-in `string-match-p`. + +```cl +(s-matches? "^[0-9]+$" "123") ;; => t +(s-matches? "^[0-9]+$" "a123") ;; => nil +(s-matches? "1" "1a" 1) ;; => nil +``` + +### s-blank? `(s)` + +Is `s` nil or the empty string? + +```cl +(s-blank? "") ;; => t +(s-blank? nil) ;; => t +(s-blank? " ") ;; => nil +``` + +### s-present? `(s)` + +Is `s` anything but nil or the empty string? + +```cl +(s-present? "") ;; => nil +(s-present? nil) ;; => nil +(s-present? " ") ;; => t +``` + +### s-ends-with? `(suffix s &optional ignore-case)` + +Does `s` end with `suffix`? + +If `ignore-case` is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-suffix?` + +```cl +(s-ends-with? ".md" "readme.md") ;; => t +(s-ends-with? ".MD" "readme.md") ;; => nil +(s-ends-with? ".MD" "readme.md" t) ;; => t +``` + +### s-starts-with? `(prefix s &optional ignore-case)` + +Does `s` start with `prefix`? + +If `ignore-case` is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-prefix?`. This is a simple wrapper around the built-in +`string-prefix-p`. + +```cl +(s-starts-with? "lib/" "lib/file.js") ;; => t +(s-starts-with? "LIB/" "lib/file.js") ;; => nil +(s-starts-with? "LIB/" "lib/file.js" t) ;; => t +``` + +### s-contains? `(needle s &optional ignore-case)` + +Does `s` contain `needle`? + +If `ignore-case` is non-nil, the comparison is done without paying +attention to case differences. + +```cl +(s-contains? "file" "lib/file.js") ;; => t +(s-contains? "nope" "lib/file.js") ;; => nil +(s-contains? "^a" "it's not ^a regexp") ;; => t +``` + +### s-lowercase? `(s)` + +Are all the letters in `s` in lower case? + +```cl +(s-lowercase? "file") ;; => t +(s-lowercase? "File") ;; => nil +(s-lowercase? "filä") ;; => t +``` + +### s-uppercase? `(s)` + +Are all the letters in `s` in upper case? + +```cl +(s-uppercase? "HULK SMASH") ;; => t +(s-uppercase? "Bruce no smash") ;; => nil +(s-uppercase? "FöB") ;; => nil +``` + +### s-mixedcase? `(s)` + +Are there both lower case and upper case letters in `s`? + +```cl +(s-mixedcase? "HULK SMASH") ;; => nil +(s-mixedcase? "Bruce no smash") ;; => t +(s-mixedcase? "BRÜCE") ;; => nil +``` + +### s-capitalized? `(s)` + +In `s`, is the first letter upper case, and all other letters lower case? + +```cl +(s-capitalized? "Capitalized") ;; => t +(s-capitalized? "I am capitalized") ;; => t +(s-capitalized? "I Am Titleized") ;; => nil +``` + +### s-numeric? `(s)` + +Is `s` a number? + +```cl +(s-numeric? "123") ;; => t +(s-numeric? "onetwothree") ;; => nil +(s-numeric? "7a") ;; => nil +``` + + +### s-replace `(old new s)` + +Replaces `old` with `new` in `s`. + +```cl +(s-replace "file" "nope" "lib/file.js") ;; => "lib/nope.js" +(s-replace "^a" "\\1" "it's not ^a regexp") ;; => "it's not \\1 regexp" +``` + +### s-replace-all `(replacements s)` + +`replacements` is a list of cons-cells. Each `car` is replaced with `cdr` in `s`. + +```cl +(s-replace-all '(("lib" . "test") ("file" . "file_test")) "lib/file.js") ;; => "test/file_test.js" +(s-replace-all '(("lib" . "test") ("test" . "lib")) "lib/test.js") ;; => "test/lib.js" +``` + +### s-downcase `(s)` + +Convert `s` to lower case. + +This is a simple wrapper around the built-in `downcase`. + +```cl +(s-downcase "ABC") ;; => "abc" +``` + +### s-upcase `(s)` + +Convert `s` to upper case. + +This is a simple wrapper around the built-in `upcase`. + +```cl +(s-upcase "abc") ;; => "ABC" +``` + +### s-capitalize `(s)` + +Convert the first word's first character to upper case and the rest to lower case in `s`. + +```cl +(s-capitalize "abc DEF") ;; => "Abc def" +(s-capitalize "abc.DEF") ;; => "Abc.def" +``` + +### s-titleize `(s)` + +Convert each word's first character to upper case and the rest to lower case in `s`. + +This is a simple wrapper around the built-in `capitalize`. + +```cl +(s-titleize "abc DEF") ;; => "Abc Def" +(s-titleize "abc.DEF") ;; => "Abc.Def" +``` + +### s-with `(s form &rest more)` + +Threads `s` through the forms. Inserts `s` as the last item +in the first form, making a list of it if it is not a list +already. If there are more forms, inserts the first form as the +last item in second form, etc. + +```cl +(s-with " hulk smash " s-trim s-upcase) ;; => "HULK SMASH" +(s-with "My car is a Toyota" (s-replace "car" "name") (s-replace "a Toyota" "Bond") (s-append ", James Bond")) ;; => "My name is Bond, James Bond" +(s-with "abc \ndef \nghi" s-lines (mapcar 's-trim) (s-join "-") s-reverse) ;; => "ihg-fed-cba" +``` + +### s-index-of `(needle s &optional ignore-case)` + +Returns first index of `needle` in `s`, or nil. + +If `ignore-case` is non-nil, the comparison is done without paying +attention to case differences. + +```cl +(s-index-of "abc" "abcdef") ;; => 0 +(s-index-of "CDE" "abcdef" t) ;; => 2 +(s-index-of "n.t" "not a regexp") ;; => nil +``` + +### s-reverse `(s)` + +Return the reverse of `s`. + +```cl +(s-reverse "abc") ;; => "cba" +(s-reverse "ab xyz") ;; => "zyx ba" +(s-reverse "") ;; => "" +``` + +### s-presence `(s)` + +Return `s` if it's `s-present?`, otherwise return nil. + +```cl +(s-presence nil) ;; => nil +(s-presence "") ;; => nil +(s-presence "foo") ;; => "foo" +``` + +### s-format `(template replacer &optional extra)` + +Format `template` with the function `replacer`. + +`replacer` takes an argument of the format variable and optionally +an extra argument which is the `extra` value from the call to +`s-format`. + +Several standard `s-format` helper functions are recognized and +adapted for this: + + (s-format "${name}" 'gethash hash-table) + (s-format "${name}" 'aget alist) + (s-format "$0" 'elt sequence) + +The `replacer` function may be used to do any other kind of +transformation. + +```cl +(s-format "help ${name}! I'm ${malady}" 'aget '(("name" . "nic") ("malady" . "on fire"))) ;; => "help nic! I'm on fire" +(s-format "hello ${name}, nice day" (lambda (var-name) "nic")) ;; => "hello nic, nice day" +(s-format "hello $0, nice $1" 'elt '("nic" "day")) ;; => "hello nic, nice day" +``` + +### s-lex-format `(format-str)` + +`s-format` with the current environment. + +`format-str` may use the `s-format` variable reference to refer to +any variable: + + (let ((x 1)) + (s-lex-format "x is: ${x}")) + +The values of the variables are interpolated with "%s" unless +the variable `s-lex-value-as-lisp` is `t` and then they are +interpolated with "%S". + +```cl +(let ((x 1)) (s-lex-format "x is ${x}")) ;; => "x is 1" +(let ((str1 "this") (str2 "that")) (s-lex-format "${str1} and ${str2}")) ;; => "this and that" +(let ((foo "Hello\\nWorld")) (s-lex-format "${foo}")) ;; => "Hello\\nWorld" +``` + +### s-count-matches `(regexp s &optional start end)` + +Count occurrences of `regexp` in `s'. + +`start`, inclusive, and `end`, exclusive, delimit the part of `s` +to match. + +```cl +(s-count-matches "a" "aba") ;; => 2 +(s-count-matches "a" "aba" 0 2) ;; => 1 +(s-count-matches "\\w\\{2\\}[0-9]+" "ab1bab2frobinator") ;; => 2 +``` + +### s-wrap `(s prefix &optional suffix)` + +Wrap string `s` with `prefix` and optionally `suffix`. + +Return string `s` with `prefix` prepended. If `suffix` is present, it +is appended, otherwise `prefix` is used as both prefix and +suffix. + +```cl +(s-wrap "foo" "\"") ;; => "\"foo\"" +(s-wrap "foo" "(" ")") ;; => "(foo)" +(s-wrap "foo" "bar") ;; => "barfoobar" +``` + + +### s-split-words `(s)` + +Split `s` into list of words. + +```cl +(s-split-words "under_score") ;; => '("under" "score") +(s-split-words "some-dashed-words") ;; => '("some" "dashed" "words") +(s-split-words "evenCamelCase") ;; => '("even" "Camel" "Case") +``` + +### s-lower-camel-case `(s)` + +Convert `s` to lowerCamelCase. + +```cl +(s-lower-camel-case "some words") ;; => "someWords" +(s-lower-camel-case "dashed-words") ;; => "dashedWords" +(s-lower-camel-case "under_scored_words") ;; => "underScoredWords" +``` + +### s-upper-camel-case `(s)` + +Convert `s` to UpperCamelCase. + +```cl +(s-upper-camel-case "some words") ;; => "SomeWords" +(s-upper-camel-case "dashed-words") ;; => "DashedWords" +(s-upper-camel-case "under_scored_words") ;; => "UnderScoredWords" +``` + +### s-snake-case `(s)` + +Convert `s` to snake_case. + +```cl +(s-snake-case "some words") ;; => "some_words" +(s-snake-case "dashed-words") ;; => "dashed_words" +(s-snake-case "camelCasedWords") ;; => "camel_cased_words" +``` + +### s-dashed-words `(s)` + +Convert `s` to dashed-words. + +```cl +(s-dashed-words "some words") ;; => "some-words" +(s-dashed-words "under_scored_words") ;; => "under-scored-words" +(s-dashed-words "camelCasedWords") ;; => "camel-cased-words" +``` + +### s-capitalized-words `(s)` + +Convert `s` to Capitalized words. + +```cl +(s-capitalized-words "some words") ;; => "Some words" +(s-capitalized-words "under_scored_words") ;; => "Under scored words" +(s-capitalized-words "camelCasedWords") ;; => "Camel cased words" +``` + +### s-titleized-words `(s)` + +Convert `s` to Titleized Words. + +```cl +(s-titleized-words "some words") ;; => "Some Words" +(s-titleized-words "under_scored_words") ;; => "Under Scored Words" +(s-titleized-words "camelCasedWords") ;; => "Camel Cased Words" +``` + +### s-word-initials `(s)` + +Convert `s` to its initials. + +```cl +(s-word-initials "some words") ;; => "sw" +(s-word-initials "under_scored_words") ;; => "usw" +(s-word-initials "camelCasedWords") ;; => "cCW" +``` + + +## What's with the built-in wrappers? + +Imagine looking through the function list and seeing `s-ends-with?`, but +`s-starts-with?` is nowhere to be found. Why? Well, because Emacs already has +`string-prefix-p`. Now you're starting out slightly confused, then have to go +somewhere else to dig for the command you were looking for. + +The wrapping functions serve as both documentation for existing functions and +makes for a consistent API. + +## Other string related libraries + +* [inflections](https://github.com/eschulte/jump.el/blob/master/inflections.el) package +provides functions for strings pluralization and singularization. + +* [levenshtein](http://emacswiki.org/emacs/levenshtein.el) package provides a function to +calculate the Levenshtein distance between two strings. + +* [string-utils](https://github.com/rolandwalker/string-utils) is another general string manipulation library. + +## Changelist + +### From 1.10.0 to 1.11.0 + +- Add `s-matched-positions-all` (ono hiroko) + +### From 1.9.0 to 1.10.0 + +- Add `s-wrap` (Johan Andersson) +- Add `s-split-up-to` (Matus Goljer) +- Fix `s-reverse` for Unicode combining characters. (Christopher Wellons) + +### From 1.8.0 to 1.9.0 + +- Add `s-count-matches` (Lars Andersen) + +### From 1.7.0 to 1.8.0 + +- Add `s-present?` and `s-present?` (Johan Andersson) +- Better handling of international characters + +### From 1.6.0 to 1.7.0 + +- Add `s-word-initials` (Sylvain Rousseau) +- Better handling of camel cased strings (@Bruce-Connor) + +### From 1.5.0 to 1.6.0 + +- Add `s-pad-left` and `s-pad-right` +- Bugfixes for `s-format` (Nic Ferrier) + +### From 1.4.0 to 1.5.0 + +- Add `s-all-match-strings` (Geoff Gole) +- Add `s-lex-format` (Nic Ferrier) + +### From 1.3.1 to 1.4.0 + +- Add `s-capitalized?` +- Add `s-replace-all` +- Add `s-slice-at` +- Add `s-split` alias for `split-string` (Rüdiger Sonderfeld) +- Add `s-less?` predicate (Rüdiger Sonderfeld) +- Add START parameter to `s-matches?` (Rüdiger Sonderfeld) +- Bugfixes + +### From 1.3.0 to 1.3.1 + +- Add `s-numeric?` +- Add `s-match` (Arthur Andersen) +- Add `s-format` (Nic Ferrier) +- Move .el files out of root to avoid problems with require. + +### From 1.2.1 to 1.3.0 + +- **Breaking change:** `s-capitalize` now converts the first word's first + character to upper case and the rest to lower case. `s-titleize` + works like the old `s-capitalize` and capitalizes each word. + (Johan Andersson) + +- `s-capitalized-words` and `s-titleized-words` mirror this change. + +## Contributors + +* [Arthur Andersen](https://github.com/leoc) contributed `s-match` +* [Rolando](https://github.com/rolando2424) contributed `s-shared-start` and `s-shared-end` +* [Johan Andersson](https://github.com/rejeep) contributed `s-presence`, `s-present?` and fixed `s-titleize` vs `s-capitalize` +* [Nic Ferrier](https://github.com/nicferrier) added `s-format` and `s-lex-format` +* [Rüdiger Sonderfeld](https://github.com/ruediger) contributed `s-less?`, `s-split` and several bugfixes. +* [Geoff Gole](https://github.com/gsg) contributed `s-all-match-strings` +* [Sylvain Rousseau](https://github.com/thisirs) contributed `s-word-initials` +* [Lars Andersen](https://github.com/expez) contributed `s-count-matches` +* [ono hiroko](https://github.com/kuanyui) contributed `s-matched-positions-all` + +Thanks! + +## Contribute + +Yes, please do. Pure functions in the string manipulation realm only, +please. There's a suite of tests in `dev/examples.el`, so remember to add +tests for your function, or I might break it later. + +You'll find the repo at: + + https://github.com/magnars/s.el + +Run the tests with + + ./run-tests.sh + +Create the docs with + + ./create-docs.sh + +I highly recommend that you install these as a pre-commit hook, so that +the tests are always running and the docs are always in sync: + + cp pre-commit.sh .git/hooks/pre-commit + +Oh, and don't edit `README.md` directly, it is auto-generated. +Change `readme-template.md` or `examples-to-docs.el` instead. + +## License + +Copyright (C) 2012-2015 Magnar Sveen + +Authors: Magnar Sveen +Keywords: strings + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . diff --git a/create-docs.sh b/create-docs.sh new file mode 100755 index 0000000..3ac32e0 --- /dev/null +++ b/create-docs.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env bash + +if [ -z "$EMACS" ] ; then + EMACS="emacs" +fi + +$EMACS -batch -l s.el -l dev/examples-to-docs.el -l dev/examples.el -f create-docs-file diff --git a/dev/.nosearch b/dev/.nosearch new file mode 100644 index 0000000..e69de29 diff --git a/dev/ert.el b/dev/ert.el new file mode 100644 index 0000000..cd2d354 --- /dev/null +++ b/dev/ert.el @@ -0,0 +1,2544 @@ +;;; ert.el --- Emacs Lisp Regression Testing + +;; Copyright (C) 2007, 2008, 2010 Free Software Foundation, Inc. + +;; Author: Christian M. Ohler +;; Keywords: lisp, tools + +;; This file is NOT part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation, either version 3 of the +;; License, or (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see `http://www.gnu.org/licenses/'. + +;;; Commentary: + +;; ERT is a tool for automated testing in Emacs Lisp. Its main +;; features are facilities for defining and running test cases and +;; reporting the results as well as for debugging test failures +;; interactively. +;; +;; The main entry points are `ert-deftest', which is similar to +;; `defun' but defines a test, and `ert-run-tests-interactively', +;; which runs tests and offers an interactive interface for inspecting +;; results and debugging. There is also +;; `ert-run-tests-batch-and-exit' for non-interactive use. +;; +;; The body of `ert-deftest' forms resembles a function body, but the +;; additional operators `should', `should-not' and `should-error' are +;; available. `should' is similar to cl's `assert', but signals a +;; different error when its condition is violated that is caught and +;; processed by ERT. In addition, it analyzes its argument form and +;; records information that helps debugging (`assert' tries to do +;; something similar when its second argument SHOW-ARGS is true, but +;; `should' is more sophisticated). For information on `should-not' +;; and `should-error', see their docstrings. +;; +;; See ERT's info manual as well as the docstrings for more details. +;; To compile the manual, run `makeinfo ert.texinfo' in the ERT +;; directory, then C-u M-x info ert.info in Emacs to view it. +;; +;; To see some examples of tests written in ERT, see its self-tests in +;; ert-tests.el. Some of these are tricky due to the bootstrapping +;; problem of writing tests for a testing tool, others test simple +;; functions and are straightforward. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'button) +(require 'debug) +(require 'easymenu) +(require 'ewoc) +(require 'find-func) +(require 'help) + + +;;; UI customization options. + +(defgroup ert () + "ERT, the Emacs Lisp regression testing tool." + :prefix "ert-" + :group 'lisp) + +(defface ert-test-result-expected '((((class color) (background light)) + :background "green1") + (((class color) (background dark)) + :background "green3")) + "Face used for expected results in the ERT results buffer." + :group 'ert) + +(defface ert-test-result-unexpected '((((class color) (background light)) + :background "red1") + (((class color) (background dark)) + :background "red3")) + "Face used for unexpected results in the ERT results buffer." + :group 'ert) + + +;;; Copies/reimplementations of cl functions. + +(defun ert--cl-do-remf (plist tag) + "Copy of `cl-do-remf'. Modify PLIST by removing TAG." + (let ((p (cdr plist))) + (while (and (cdr p) (not (eq (car (cdr p)) tag))) (setq p (cdr (cdr p)))) + (and (cdr p) (progn (setcdr p (cdr (cdr (cdr p)))) t)))) + +(defun ert--remprop (sym tag) + "Copy of `cl-remprop'. Modify SYM's plist by removing TAG." + (let ((plist (symbol-plist sym))) + (if (and plist (eq tag (car plist))) + (progn (setplist sym (cdr (cdr plist))) t) + (ert--cl-do-remf plist tag)))) + +(defun ert--remove-if-not (ert-pred ert-list) + "A reimplementation of `remove-if-not'. + +ERT-PRED is a predicate, ERT-LIST is the input list." + (loop for ert-x in ert-list + if (funcall ert-pred ert-x) + collect ert-x)) + +(defun ert--intersection (a b) + "A reimplementation of `intersection'. Intersect the sets A and B. + +Elements are compared using `eql'." + (loop for x in a + if (memql x b) + collect x)) + +(defun ert--set-difference (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eql'." + (loop for x in a + unless (memql x b) + collect x)) + +(defun ert--set-difference-eq (a b) + "A reimplementation of `set-difference'. Subtract the set B from the set A. + +Elements are compared using `eq'." + (loop for x in a + unless (memq x b) + collect x)) + +(defun ert--union (a b) + "A reimplementation of `union'. Compute the union of the sets A and B. + +Elements are compared using `eql'." + (append a (ert--set-difference b a))) + +(eval-and-compile + (defvar ert--gensym-counter 0)) + +(eval-and-compile + (defun ert--gensym (&optional prefix) + "Only allows string PREFIX, not compatible with CL." + (unless prefix (setq prefix "G")) + (make-symbol (format "%s%s" + prefix + (prog1 ert--gensym-counter + (incf ert--gensym-counter)))))) + +(defun ert--coerce-to-vector (x) + "Coerce X to a vector." + (when (char-table-p x) (error "Not supported")) + (if (vectorp x) + x + (vconcat x))) + +(defun* ert--remove* (x list &key key test) + "Does not support all the keywords of remove*." + (unless key (setq key #'identity)) + (unless test (setq test #'eql)) + (loop for y in list + unless (funcall test x (funcall key y)) + collect y)) + +(defun ert--string-position (c s) + "Return the position of the first occurrence of C in S, or nil if none." + (loop for i from 0 + for x across s + when (eql x c) return i)) + +(defun ert--mismatch (a b) + "Return index of first element that differs between A and B. + +Like `mismatch'. Uses `equal' for comparison." + (cond ((or (listp a) (listp b)) + (ert--mismatch (ert--coerce-to-vector a) + (ert--coerce-to-vector b))) + ((> (length a) (length b)) + (ert--mismatch b a)) + (t + (let ((la (length a)) + (lb (length b))) + (assert (arrayp a) t) + (assert (arrayp b) t) + (assert (<= la lb) t) + (loop for i below la + when (not (equal (aref a i) (aref b i))) return i + finally (return (if (/= la lb) + la + (assert (equal a b) t) + nil))))))) + +(defun ert--subseq (seq start &optional end) + "Return a subsequence of SEQ from START to END." + (when (char-table-p seq) (error "Not supported")) + (let ((vector (substring (ert--coerce-to-vector seq) start end))) + (etypecase seq + (vector vector) + (string (concat vector)) + (list (append vector nil)) + (bool-vector (loop with result = (make-bool-vector (length vector) nil) + for i below (length vector) do + (setf (aref result i) (aref vector i)) + finally (return result))) + (char-table (assert nil))))) + +(defun ert-equal-including-properties (a b) + "Return t if A and B have similar structure and contents. + +This is like `equal-including-properties' except that it compares +the property values of text properties structurally (by +recursing) rather than with `eq'. Perhaps this is what +`equal-including-properties' should do in the first place; see +Emacs bug 6581 at URL `http://debbugs.gnu.org/cgi/bugreport.cgi?bug=6581'." + ;; This implementation is inefficient. Rather than making it + ;; efficient, let's hope bug 6581 gets fixed so that we can delete + ;; it altogether. + (not (ert--explain-not-equal-including-properties a b))) + + +;;; Defining and locating tests. + +;; The data structure that represents a test case. +(defstruct ert-test + (name nil) + (documentation nil) + (body (assert nil)) + (most-recent-result nil) + (expected-result-type ':passed) + (tags '())) + +(defun ert-test-boundp (symbol) + "Return non-nil if SYMBOL names a test." + (and (get symbol 'ert--test) t)) + +(defun ert-get-test (symbol) + "If SYMBOL names a test, return that. Signal an error otherwise." + (unless (ert-test-boundp symbol) (error "No test named `%S'" symbol)) + (get symbol 'ert--test)) + +(defun ert-set-test (symbol definition) + "Make SYMBOL name the test DEFINITION, and return DEFINITION." + (when (eq symbol 'nil) + ;; We disallow nil since `ert-test-at-point' and related functions + ;; want to return a test name, but also need an out-of-band value + ;; on failure. Nil is the most natural out-of-band value; using 0 + ;; or "" or signalling an error would be too awkward. + ;; + ;; Note that nil is still a valid value for the `name' slot in + ;; ert-test objects. It designates an anonymous test. + (error "Attempt to define a test named nil")) + (put symbol 'ert--test definition) + definition) + +(defun ert-make-test-unbound (symbol) + "Make SYMBOL name no test. Return SYMBOL." + (ert--remprop symbol 'ert--test) + symbol) + +(defun ert--parse-keys-and-body (keys-and-body) + "Split KEYS-AND-BODY into keyword-and-value pairs and the remaining body. + +KEYS-AND-BODY should have the form of a property list, with the +exception that only keywords are permitted as keys and that the +tail -- the body -- is a list of forms that does not start with a +keyword. + +Returns a two-element list containing the keys-and-values plist +and the body." + (let ((extracted-key-accu '()) + (remaining keys-and-body)) + (while (and (consp remaining) (keywordp (first remaining))) + (let ((keyword (pop remaining))) + (unless (consp remaining) + (error "Value expected after keyword %S in %S" + keyword keys-and-body)) + (when (assoc keyword extracted-key-accu) + (warn "Keyword %S appears more than once in %S" keyword + keys-and-body)) + (push (cons keyword (pop remaining)) extracted-key-accu))) + (setq extracted-key-accu (nreverse extracted-key-accu)) + (list (loop for (key . value) in extracted-key-accu + collect key + collect value) + remaining))) + +;;;###autoload +(defmacro* ert-deftest (name () &body docstring-keys-and-body) + "Define NAME (a symbol) as a test. + +BODY is evaluated as a `progn' when the test is run. It should +signal a condition on failure or just return if the test passes. + +`should', `should-not' and `should-error' are useful for +assertions in BODY. + +Use `ert' to run tests interactively. + +Tests that are expected to fail can be marked as such +using :expected-result. See `ert-test-result-type-p' for a +description of valid values for RESULT-TYPE. + +\(fn NAME () [DOCSTRING] [:expected-result RESULT-TYPE] \ +\[:tags '(TAG...)] BODY...)" + (declare (debug (&define :name test + name sexp [&optional stringp] + [&rest keywordp sexp] def-body)) + (doc-string 3) + (indent 2)) + (let ((documentation nil) + (documentation-supplied-p nil)) + (when (stringp (first docstring-keys-and-body)) + (setq documentation (pop docstring-keys-and-body) + documentation-supplied-p t)) + (destructuring-bind ((&key (expected-result nil expected-result-supplied-p) + (tags nil tags-supplied-p)) + body) + (ert--parse-keys-and-body docstring-keys-and-body) + `(progn + (ert-set-test ',name + (make-ert-test + :name ',name + ,@(when documentation-supplied-p + `(:documentation ,documentation)) + ,@(when expected-result-supplied-p + `(:expected-result-type ,expected-result)) + ,@(when tags-supplied-p + `(:tags ,tags)) + :body (lambda () ,@body))) + ;; This hack allows `symbol-file' to associate `ert-deftest' + ;; forms with files, and therefore enables `find-function' to + ;; work with tests. However, it leads to warnings in + ;; `unload-feature', which doesn't know how to undefine tests + ;; and has no mechanism for extension. + (push '(ert-deftest . ,name) current-load-list) + ',name)))) + +;; We use these `put' forms in addition to the (declare (indent)) in +;; the defmacro form since the `declare' alone does not lead to +;; correct indentation before the .el/.elc file is loaded. +;; Autoloading these `put' forms solves this. +;;;###autoload +(progn + ;; TODO(ohler): Figure out what these mean and make sure they are correct. + (put 'ert-deftest 'lisp-indent-function 2) + (put 'ert-info 'lisp-indent-function 1)) + +(defvar ert--find-test-regexp + (concat "^\\s-*(ert-deftest" + find-function-space-re + "%s\\(\\s-\\|$\\)") + "The regexp the `find-function' mechanisms use for finding test definitions.") + + +(put 'ert-test-failed 'error-conditions '(error ert-test-failed)) +(put 'ert-test-failed 'error-message "Test failed") + +(defun ert-pass () + "Terminate the current test and mark it passed. Does not return." + (throw 'ert--pass nil)) + +(defun ert-fail (data) + "Terminate the current test and mark it failed. Does not return. +DATA is displayed to the user and should state the reason of the failure." + (signal 'ert-test-failed (list data))) + + +;;; The `should' macros. + +(defvar ert--should-execution-observer nil) + +(defun ert--signal-should-execution (form-description) + "Tell the current `should' form observer (if any) about FORM-DESCRIPTION." + (when ert--should-execution-observer + (funcall ert--should-execution-observer form-description))) + +(defun ert--special-operator-p (thing) + "Return non-nil if THING is a symbol naming a special operator." + (and (symbolp thing) + (let ((definition (indirect-function thing t))) + (and (subrp definition) + (eql (cdr (subr-arity definition)) 'unevalled))))) + +(defun ert--expand-should-1 (whole form inner-expander) + "Helper function for the `should' macro and its variants." + (let ((form + ;; If `cl-macroexpand' isn't bound, the code that we're + ;; compiling doesn't depend on cl and thus doesn't need an + ;; environment arg for `macroexpand'. + (if (fboundp 'cl-macroexpand) + ;; Suppress warning about run-time call to cl funtion: we + ;; only call it if it's fboundp. + (with-no-warnings + (cl-macroexpand form (and (boundp 'cl-macro-environment) + cl-macro-environment))) + (macroexpand form)))) + (cond + ((or (atom form) (ert--special-operator-p (car form))) + (let ((value (ert--gensym "value-"))) + `(let ((,value (ert--gensym "ert-form-evaluation-aborted-"))) + ,(funcall inner-expander + `(setq ,value ,form) + `(list ',whole :form ',form :value ,value) + value) + ,value))) + (t + (let ((fn-name (car form)) + (arg-forms (cdr form))) + (assert (or (symbolp fn-name) + (and (consp fn-name) + (eql (car fn-name) 'lambda) + (listp (cdr fn-name))))) + (let ((fn (ert--gensym "fn-")) + (args (ert--gensym "args-")) + (value (ert--gensym "value-")) + (default-value (ert--gensym "ert-form-evaluation-aborted-"))) + `(let ((,fn (function ,fn-name)) + (,args (list ,@arg-forms))) + (let ((,value ',default-value)) + ,(funcall inner-expander + `(setq ,value (apply ,fn ,args)) + `(nconc (list ',whole) + (list :form `(,,fn ,@,args)) + (unless (eql ,value ',default-value) + (list :value ,value)) + (let ((-explainer- + (and (symbolp ',fn-name) + (get ',fn-name 'ert-explainer)))) + (when -explainer- + (list :explanation + (apply -explainer- ,args))))) + value) + ,value)))))))) + +(defun ert--expand-should (whole form inner-expander) + "Helper function for the `should' macro and its variants. + +Analyzes FORM and returns an expression that has the same +semantics under evaluation but records additional debugging +information. + +INNER-EXPANDER should be a function and is called with two +arguments: INNER-FORM and FORM-DESCRIPTION-FORM, where INNER-FORM +is an expression equivalent to FORM, and FORM-DESCRIPTION-FORM is +an expression that returns a description of FORM. INNER-EXPANDER +should return code that calls INNER-FORM and performs the checks +and error signalling specific to the particular variant of +`should'. The code that INNER-EXPANDER returns must not call +FORM-DESCRIPTION-FORM before it has called INNER-FORM." + (lexical-let ((inner-expander inner-expander)) + (ert--expand-should-1 + whole form + (lambda (inner-form form-description-form value-var) + (let ((form-description (ert--gensym "form-description-"))) + `(let (,form-description) + ,(funcall inner-expander + `(unwind-protect + ,inner-form + (setq ,form-description ,form-description-form) + (ert--signal-should-execution ,form-description)) + `,form-description + value-var))))))) + +(defmacro* should (form) + "Evaluate FORM. If it returns nil, abort the current test as failed. + +Returns the value of FORM." + (ert--expand-should `(should ,form) form + (lambda (inner-form form-description-form value-var) + `(unless ,inner-form + (ert-fail ,form-description-form))))) + +(defmacro* should-not (form) + "Evaluate FORM. If it returns non-nil, abort the current test as failed. + +Returns nil." + (ert--expand-should `(should-not ,form) form + (lambda (inner-form form-description-form value-var) + `(unless (not ,inner-form) + (ert-fail ,form-description-form))))) + +(defun ert--should-error-handle-error (form-description-fn + condition type exclude-subtypes) + "Helper function for `should-error'. + +Determines whether CONDITION matches TYPE and EXCLUDE-SUBTYPES, +and aborts the current test as failed if it doesn't." + (let ((signalled-conditions (get (car condition) 'error-conditions)) + (handled-conditions (etypecase type + (list type) + (symbol (list type))))) + (assert signalled-conditions) + (unless (ert--intersection signalled-conditions handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled did not" + " have the expected type"))))) + (when exclude-subtypes + (unless (member (car condition) handled-conditions) + (ert-fail (append + (funcall form-description-fn) + (list + :condition condition + :fail-reason (concat "the error signalled was a subtype" + " of the expected type")))))))) + +;; FIXME: The expansion will evaluate the keyword args (if any) in +;; nonstandard order. +(defmacro* should-error (form &rest keys &key type exclude-subtypes) + "Evaluate FORM and check that it signals an error. + +The error signalled needs to match TYPE. TYPE should be a list +of condition names. (It can also be a non-nil symbol, which is +equivalent to a singleton list containing that symbol.) If +EXCLUDE-SUBTYPES is nil, the error matches TYPE if one of its +condition names is an element of TYPE. If EXCLUDE-SUBTYPES is +non-nil, the error matches TYPE if it is an element of TYPE. + +If the error matches, returns (ERROR-SYMBOL . DATA) from the +error. If not, or if no error was signalled, abort the test as +failed." + (unless type (setq type ''error)) + (ert--expand-should + `(should-error ,form ,@keys) + form + (lambda (inner-form form-description-form value-var) + (let ((errorp (ert--gensym "errorp")) + (form-description-fn (ert--gensym "form-description-fn-"))) + `(let ((,errorp nil) + (,form-description-fn (lambda () ,form-description-form))) + (condition-case -condition- + ,inner-form + ;; We can't use ,type here because we want to evaluate it. + (error + (setq ,errorp t) + (ert--should-error-handle-error ,form-description-fn + -condition- + ,type ,exclude-subtypes) + (setq ,value-var -condition-))) + (unless ,errorp + (ert-fail (append + (funcall ,form-description-fn) + (list + :fail-reason "did not signal an error"))))))))) + + +;;; Explanation of `should' failures. + +;; TODO(ohler): Rework explanations so that they are displayed in a +;; similar way to `ert-info' messages; in particular, allow text +;; buttons in explanations that give more detail or open an ediff +;; buffer. Perhaps explanations should be reported through `ert-info' +;; rather than as part of the condition. + +(defun ert--proper-list-p (x) + "Return non-nil if X is a proper list, nil otherwise." + (loop + for firstp = t then nil + for fast = x then (cddr fast) + for slow = x then (cdr slow) do + (when (null fast) (return t)) + (when (not (consp fast)) (return nil)) + (when (null (cdr fast)) (return t)) + (when (not (consp (cdr fast))) (return nil)) + (when (and (not firstp) (eq fast slow)) (return nil)))) + +(defun ert--explain-format-atom (x) + "Format the atom X for `ert--explain-not-equal'." + (typecase x + (fixnum (list x (format "#x%x" x) (format "?%c" x))) + (t x))) + +(defun ert--explain-not-equal (a b) + "Explainer function for `equal'. + +Returns a programmer-readable explanation of why A and B are not +`equal', or nil if they are." + (if (not (equal (type-of a) (type-of b))) + `(different-types ,a ,b) + (etypecase a + (cons + (let ((a-proper-p (ert--proper-list-p a)) + (b-proper-p (ert--proper-list-p b))) + (if (not (eql (not a-proper-p) (not b-proper-p))) + `(one-list-proper-one-improper ,a ,b) + (if a-proper-p + (if (not (equal (length a) (length b))) + `(proper-lists-of-different-length ,(length a) ,(length b) + ,a ,b + first-mismatch-at + ,(ert--mismatch a b)) + (loop for i from 0 + for ai in a + for bi in b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(list-elt ,i ,xi))) + finally (assert (equal a b) t))) + (let ((car-x (ert--explain-not-equal (car a) (car b)))) + (if car-x + `(car ,car-x) + (let ((cdr-x (ert--explain-not-equal (cdr a) (cdr b)))) + (if cdr-x + `(cdr ,cdr-x) + (assert (equal a b) t) + nil)))))))) + (array (if (not (equal (length a) (length b))) + `(arrays-of-different-length ,(length a) ,(length b) + ,a ,b + ,@(unless (char-table-p a) + `(first-mismatch-at + ,(ert--mismatch a b)))) + (loop for i from 0 + for ai across a + for bi across b + for xi = (ert--explain-not-equal ai bi) + do (when xi (return `(array-elt ,i ,xi))) + finally (assert (equal a b) t)))) + (atom (if (not (equal a b)) + (if (and (symbolp a) (symbolp b) (string= a b)) + `(different-symbols-with-the-same-name ,a ,b) + `(different-atoms ,(ert--explain-format-atom a) + ,(ert--explain-format-atom b))) + nil))))) +(put 'equal 'ert-explainer 'ert--explain-not-equal) + +(defun ert--significant-plist-keys (plist) + "Return the keys of PLIST that have non-null values, in order." + (assert (zerop (mod (length plist) 2)) t) + (loop for (key value . rest) on plist by #'cddr + unless (or (null value) (memq key accu)) collect key into accu + finally (return accu))) + +(defun ert--plist-difference-explanation (a b) + "Return a programmer-readable explanation of why A and B are different plists. + +Returns nil if they are equivalent, i.e., have the same value for +each key, where absent values are treated as nil. The order of +key/value pairs in each list does not matter." + (assert (zerop (mod (length a) 2)) t) + (assert (zerop (mod (length b) 2)) t) + ;; Normalizing the plists would be another way to do this but it + ;; requires a total ordering on all lisp objects (since any object + ;; is valid as a text property key). Perhaps defining such an + ;; ordering is useful in other contexts, too, but it's a lot of + ;; work, so let's punt on it for now. + (let* ((keys-a (ert--significant-plist-keys a)) + (keys-b (ert--significant-plist-keys b)) + (keys-in-a-not-in-b (ert--set-difference-eq keys-a keys-b)) + (keys-in-b-not-in-a (ert--set-difference-eq keys-b keys-a))) + (flet ((explain-with-key (key) + (let ((value-a (plist-get a key)) + (value-b (plist-get b key))) + (assert (not (equal value-a value-b)) t) + `(different-properties-for-key + ,key ,(ert--explain-not-equal-including-properties value-a + value-b))))) + (cond (keys-in-a-not-in-b + (explain-with-key (first keys-in-a-not-in-b))) + (keys-in-b-not-in-a + (explain-with-key (first keys-in-b-not-in-a))) + (t + (loop for key in keys-a + when (not (equal (plist-get a key) (plist-get b key))) + return (explain-with-key key))))))) + +(defun ert--abbreviate-string (s len suffixp) + "Shorten string S to at most LEN chars. + +If SUFFIXP is non-nil, returns a suffix of S, otherwise a prefix." + (let ((n (length s))) + (cond ((< n len) + s) + (suffixp + (substring s (- n len))) + (t + (substring s 0 len))))) + +(defun ert--explain-not-equal-including-properties (a b) + "Explainer function for `ert-equal-including-properties'. + +Returns a programmer-readable explanation of why A and B are not +`ert-equal-including-properties', or nil if they are." + (if (not (equal a b)) + (ert--explain-not-equal a b) + (assert (stringp a) t) + (assert (stringp b) t) + (assert (eql (length a) (length b)) t) + (loop for i from 0 to (length a) + for props-a = (text-properties-at i a) + for props-b = (text-properties-at i b) + for difference = (ert--plist-difference-explanation props-a props-b) + do (when difference + (return `(char ,i ,(substring-no-properties a i (1+ i)) + ,difference + context-before + ,(ert--abbreviate-string + (substring-no-properties a 0 i) + 10 t) + context-after + ,(ert--abbreviate-string + (substring-no-properties a (1+ i)) + 10 nil)))) + ;; TODO(ohler): Get `equal-including-properties' fixed in + ;; Emacs, delete `ert-equal-including-properties', and + ;; re-enable this assertion. + ;;finally (assert (equal-including-properties a b) t) + ))) +(put 'ert-equal-including-properties + 'ert-explainer + 'ert--explain-not-equal-including-properties) + + +;;; Implementation of `ert-info'. + +;; TODO(ohler): The name `info' clashes with +;; `ert--test-execution-info'. One or both should be renamed. +(defvar ert--infos '() + "The stack of `ert-info' infos that currently apply. + +Bound dynamically. This is a list of (PREFIX . MESSAGE) pairs.") + +(defmacro* ert-info ((message-form &key ((:prefix prefix-form) "Info: ")) + &body body) + "Evaluate MESSAGE-FORM and BODY, and report the message if BODY fails. + +To be used within ERT tests. MESSAGE-FORM should evaluate to a +string that will be displayed together with the test result if +the test fails. PREFIX-FORM should evaluate to a string as well +and is displayed in front of the value of MESSAGE-FORM." + (declare (debug ((form &rest [sexp form]) body)) + (indent 1)) + `(let ((ert--infos (cons (cons ,prefix-form ,message-form) ert--infos))) + ,@body)) + + + +;;; Facilities for running a single test. + +(defvar ert-debug-on-error nil + "Non-nil means enter debugger when a test fails or terminates with an error.") + +;; The data structures that represent the result of running a test. +(defstruct ert-test-result + (messages nil) + (should-forms nil) + ) +(defstruct (ert-test-passed (:include ert-test-result))) +(defstruct (ert-test-result-with-condition (:include ert-test-result)) + (condition (assert nil)) + (backtrace (assert nil)) + (infos (assert nil))) +(defstruct (ert-test-quit (:include ert-test-result-with-condition))) +(defstruct (ert-test-failed (:include ert-test-result-with-condition))) +(defstruct (ert-test-aborted-with-non-local-exit (:include ert-test-result))) + + +(defun ert--record-backtrace () + "Record the current backtrace (as a list) and return it." + ;; Since the backtrace is stored in the result object, result + ;; objects must only be printed with appropriate limits + ;; (`print-level' and `print-length') in place. For interactive + ;; use, the cost of ensuring this possibly outweighs the advantage + ;; of storing the backtrace for + ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we + ;; already have `ert-results-rerun-test-debugging-errors-at-point'. + ;; For batch use, however, printing the backtrace may be useful. + (loop + ;; 6 is the number of frames our own debugger adds (when + ;; compiled; more when interpreted). FIXME: Need to describe a + ;; procedure for determining this constant. + for i from 6 + for frame = (backtrace-frame i) + while frame + collect frame)) + +(defun ert--print-backtrace (backtrace) + "Format the backtrace BACKTRACE to the current buffer." + ;; This is essentially a reimplementation of Fbacktrace + ;; (src/eval.c), but for a saved backtrace, not the current one. + (let ((print-escape-newlines t) + (print-level 8) + (print-length 50)) + (dolist (frame backtrace) + (ecase (first frame) + ((nil) + ;; Special operator. + (destructuring-bind (special-operator &rest arg-forms) + (cdr frame) + (insert + (format " %S\n" (list* special-operator arg-forms))))) + ((t) + ;; Function call. + (destructuring-bind (fn &rest args) (cdr frame) + (insert (format " %S(" fn)) + (loop for firstp = t then nil + for arg in args do + (unless firstp + (insert " ")) + (insert (format "%S" arg))) + (insert ")\n"))))))) + +;; A container for the state of the execution of a single test and +;; environment data needed during its execution. +(defstruct ert--test-execution-info + (test (assert nil)) + (result (assert nil)) + ;; A thunk that may be called when RESULT has been set to its final + ;; value and test execution should be terminated. Should not + ;; return. + (exit-continuation (assert nil)) + ;; The binding of `debugger' outside of the execution of the test. + next-debugger + ;; The binding of `ert-debug-on-error' that is in effect for the + ;; execution of the current test. We store it to avoid being + ;; affected by any new bindings the test itself may establish. (I + ;; don't remember whether this feature is important.) + ert-debug-on-error) + +(defun ert--run-test-debugger (info debugger-args) + "During a test run, `debugger' is bound to a closure that calls this function. + +This function records failures and errors and either terminates +the test silently or calls the interactive debugger, as +appropriate. + +INFO is the ert--test-execution-info corresponding to this test +run. DEBUGGER-ARGS are the arguments to `debugger'." + (destructuring-bind (first-debugger-arg &rest more-debugger-args) + debugger-args + (ecase first-debugger-arg + ((lambda debug t exit nil) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (error + (let* ((condition (first more-debugger-args)) + (type (case (car condition) + ((quit) 'quit) + (otherwise 'failed))) + (backtrace (ert--record-backtrace)) + (infos (reverse ert--infos))) + (setf (ert--test-execution-info-result info) + (ecase type + (quit + (make-ert-test-quit :condition condition + :backtrace backtrace + :infos infos)) + (failed + (make-ert-test-failed :condition condition + :backtrace backtrace + :infos infos)))) + ;; Work around Emacs' heuristic (in eval.c) for detecting + ;; errors in the debugger. + (incf num-nonmacro-input-events) + ;; FIXME: We should probably implement more fine-grained + ;; control a la non-t `debug-on-error' here. + (cond + ((ert--test-execution-info-ert-debug-on-error info) + (apply (ert--test-execution-info-next-debugger info) debugger-args)) + (t)) + (funcall (ert--test-execution-info-exit-continuation info))))))) + +(defun ert--run-test-internal (ert-test-execution-info) + "Low-level function to run a test according to ERT-TEST-EXECUTION-INFO. + +This mainly sets up debugger-related bindings." + (lexical-let ((info ert-test-execution-info)) + (setf (ert--test-execution-info-next-debugger info) debugger + (ert--test-execution-info-ert-debug-on-error info) ert-debug-on-error) + (catch 'ert--pass + ;; For now, each test gets its own temp buffer and its own + ;; window excursion, just to be safe. If this turns out to be + ;; too expensive, we can remove it. + (with-temp-buffer + (save-window-excursion + (let ((debugger (lambda (&rest debugger-args) + (ert--run-test-debugger info debugger-args))) + (debug-on-error t) + (debug-on-quit t) + ;; FIXME: Do we need to store the old binding of this + ;; and consider it in `ert--run-test-debugger'? + (debug-ignored-errors nil) + (ert--infos '())) + (funcall (ert-test-body (ert--test-execution-info-test info)))))) + (ert-pass)) + (setf (ert--test-execution-info-result info) (make-ert-test-passed))) + nil) + +(defun ert--force-message-log-buffer-truncation () + "Immediately truncate *Messages* buffer according to `message-log-max'. + +This can be useful after reducing the value of `message-log-max'." + (with-current-buffer (get-buffer-create "*Messages*") + ;; This is a reimplementation of this part of message_dolog() in xdisp.c: + ;; if (NATNUMP (Vmessage_log_max)) + ;; { + ;; scan_newline (Z, Z_BYTE, BEG, BEG_BYTE, + ;; -XFASTINT (Vmessage_log_max) - 1, 0); + ;; del_range_both (BEG, BEG_BYTE, PT, PT_BYTE, 0); + ;; } + (when (and (integerp message-log-max) (>= message-log-max 0)) + (let ((begin (point-min)) + (end (save-excursion + (goto-char (point-max)) + (forward-line (- message-log-max)) + (point)))) + (delete-region begin end))))) + +(defvar ert--running-tests nil + "List of tests that are currently in execution. + +This list is empty while no test is running, has one element +while a test is running, two elements while a test run from +inside a test is running, etc. The list is in order of nesting, +innermost test first. + +The elements are of type `ert-test'.") + +(defun ert-run-test (ert-test) + "Run ERT-TEST. + +Returns the result and stores it in ERT-TEST's `most-recent-result' slot." + (setf (ert-test-most-recent-result ert-test) nil) + (block error + (lexical-let ((begin-marker + (with-current-buffer (get-buffer-create "*Messages*") + (set-marker (make-marker) (point-max))))) + (unwind-protect + (lexical-let ((info (make-ert--test-execution-info + :test ert-test + :result + (make-ert-test-aborted-with-non-local-exit) + :exit-continuation (lambda () + (return-from error nil)))) + (should-form-accu (list))) + (unwind-protect + (let ((ert--should-execution-observer + (lambda (form-description) + (push form-description should-form-accu))) + (message-log-max t) + (ert--running-tests (cons ert-test ert--running-tests))) + (ert--run-test-internal info)) + (let ((result (ert--test-execution-info-result info))) + (setf (ert-test-result-messages result) + (with-current-buffer (get-buffer-create "*Messages*") + (buffer-substring begin-marker (point-max)))) + (ert--force-message-log-buffer-truncation) + (setq should-form-accu (nreverse should-form-accu)) + (setf (ert-test-result-should-forms result) + should-form-accu) + (setf (ert-test-most-recent-result ert-test) result)))) + (set-marker begin-marker nil)))) + (ert-test-most-recent-result ert-test)) + +(defun ert-running-test () + "Return the top-level test currently executing." + (car (last ert--running-tests))) + + +;;; Test selectors. + +(defun ert-test-result-type-p (result result-type) + "Return non-nil if RESULT matches type RESULT-TYPE. + +Valid result types: + +nil -- Never matches. +t -- Always matches. +:failed, :passed -- Matches corresponding results. +\(and TYPES...\) -- Matches if all TYPES match. +\(or TYPES...\) -- Matches if some TYPES match. +\(not TYPE\) -- Matches if TYPE does not match. +\(satisfies PREDICATE\) -- Matches if PREDICATE returns true when called with + RESULT." + ;; It would be easy to add `member' and `eql' types etc., but I + ;; haven't bothered yet. + (etypecase result-type + ((member nil) nil) + ((member t) t) + ((member :failed) (ert-test-failed-p result)) + ((member :passed) (ert-test-passed-p result)) + (cons + (destructuring-bind (operator &rest operands) result-type + (ecase operator + (and + (case (length operands) + (0 t) + (t + (and (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(and ,@(rest operands))))))) + (or + (case (length operands) + (0 nil) + (t + (or (ert-test-result-type-p result (first operands)) + (ert-test-result-type-p result `(or ,@(rest operands))))))) + (not + (assert (eql (length operands) 1)) + (not (ert-test-result-type-p result (first operands)))) + (satisfies + (assert (eql (length operands) 1)) + (funcall (first operands) result))))))) + +(defun ert-test-result-expected-p (test result) + "Return non-nil if TEST's expected result type matches RESULT." + (ert-test-result-type-p result (ert-test-expected-result-type test))) + +(defun ert-select-tests (selector universe) + "Return the tests that match SELECTOR. + +UNIVERSE specifies the set of tests to select from; it should be +a list of tests, or t, which refers to all tests named by symbols +in `obarray'. + +Returns the set of tests as a list. + +Valid selectors: + +nil -- Selects the empty set. +t -- Selects UNIVERSE. +:new -- Selects all tests that have not been run yet. +:failed, :passed -- Select tests according to their most recent result. +:expected, :unexpected -- Select tests according to their most recent result. +a string -- Selects all tests that have a name that matches the string, + a regexp. +a test -- Selects that test. +a symbol -- Selects the test that the symbol names, errors if none. +\(member TESTS...\) -- Selects TESTS, a list of tests or symbols naming tests. +\(eql TEST\) -- Selects TEST, a test or a symbol naming a test. +\(and SELECTORS...\) -- Selects the tests that match all SELECTORS. +\(or SELECTORS...\) -- Selects the tests that match any SELECTOR. +\(not SELECTOR\) -- Selects all tests that do not match SELECTOR. +\(tag TAG) -- Selects all tests that have TAG on their tags list. +\(satisfies PREDICATE\) -- Selects all tests that satisfy PREDICATE. + +Only selectors that require a superset of tests, such +as (satisfies ...), strings, :new, etc. make use of UNIVERSE. +Selectors that do not, such as \(member ...\), just return the +set implied by them without checking whether it is really +contained in UNIVERSE." + ;; This code needs to match the etypecase in + ;; `ert-insert-human-readable-selector'. + (etypecase selector + ((member nil) nil) + ((member t) (etypecase universe + (list universe) + ((member t) (ert-select-tests "" universe)))) + ((member :new) (ert-select-tests + `(satisfies ,(lambda (test) + (null (ert-test-most-recent-result test)))) + universe)) + ((member :failed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':failed))) + universe)) + ((member :passed) (ert-select-tests + `(satisfies ,(lambda (test) + (ert-test-result-type-p + (ert-test-most-recent-result test) + ':passed))) + universe)) + ((member :expected) (ert-select-tests + `(satisfies + ,(lambda (test) + (ert-test-result-expected-p + test + (ert-test-most-recent-result test)))) + universe)) + ((member :unexpected) (ert-select-tests `(not :expected) universe)) + (string + (etypecase universe + ((member t) (mapcar #'ert-get-test + (apropos-internal selector #'ert-test-boundp))) + (list (ert--remove-if-not (lambda (test) + (and (ert-test-name test) + (string-match selector + (ert-test-name test)))) + universe)))) + (ert-test (list selector)) + (symbol + (assert (ert-test-boundp selector)) + (list (ert-get-test selector))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + (member + (mapcar (lambda (purported-test) + (etypecase purported-test + (symbol (assert (ert-test-boundp purported-test)) + (ert-get-test purported-test)) + (ert-test purported-test))) + operands)) + (eql + (assert (eql (length operands) 1)) + (ert-select-tests `(member ,@operands) universe)) + (and + ;; Do these definitions of AND, NOT and OR satisfy de + ;; Morgan's laws? Should they? + (case (length operands) + (0 (ert-select-tests 't universe)) + (t (ert-select-tests `(and ,@(rest operands)) + (ert-select-tests (first operands) + universe))))) + (not + (assert (eql (length operands) 1)) + (let ((all-tests (ert-select-tests 't universe))) + (ert--set-difference all-tests + (ert-select-tests (first operands) + all-tests)))) + (or + (case (length operands) + (0 (ert-select-tests 'nil universe)) + (t (ert--union (ert-select-tests (first operands) universe) + (ert-select-tests `(or ,@(rest operands)) + universe))))) + (tag + (assert (eql (length operands) 1)) + (let ((tag (first operands))) + (ert-select-tests `(satisfies + ,(lambda (test) + (member tag (ert-test-tags test)))) + universe))) + (satisfies + (assert (eql (length operands) 1)) + (ert--remove-if-not (first operands) + (ert-select-tests 't universe)))))))) + +(defun ert--insert-human-readable-selector (selector) + "Insert a human-readable presentation of SELECTOR into the current buffer." + ;; This is needed to avoid printing the (huge) contents of the + ;; `backtrace' slot of the result objects in the + ;; `most-recent-result' slots of test case objects in (eql ...) or + ;; (member ...) selectors. + (labels ((rec (selector) + ;; This code needs to match the etypecase in `ert-select-tests'. + (etypecase selector + ((or (member nil t + :new :failed :passed + :expected :unexpected) + string + symbol) + selector) + (ert-test + (if (ert-test-name selector) + (make-symbol (format "<%S>" (ert-test-name selector))) + (make-symbol ""))) + (cons + (destructuring-bind (operator &rest operands) selector + (ecase operator + ((member eql and not or) + `(,operator ,@(mapcar #'rec operands))) + ((member tag satisfies) + selector))))))) + (insert (format "%S" (rec selector))))) + + +;;; Facilities for running a whole set of tests. + +;; The data structure that contains the set of tests being executed +;; during one particular test run, their results, the state of the +;; execution, and some statistics. +;; +;; The data about results and expected results of tests may seem +;; redundant here, since the test objects also carry such information. +;; However, the information in the test objects may be more recent, it +;; may correspond to a different test run. We need the information +;; that corresponds to this run in order to be able to update the +;; statistics correctly when a test is re-run interactively and has a +;; different result than before. +(defstruct ert--stats + (selector (assert nil)) + ;; The tests, in order. + (tests (assert nil) :type vector) + ;; A map of test names (or the test objects themselves for unnamed + ;; tests) to indices into the `tests' vector. + (test-map (assert nil) :type hash-table) + ;; The results of the tests during this run, in order. + (test-results (assert nil) :type vector) + ;; The start times of the tests, in order, as reported by + ;; `current-time'. + (test-start-times (assert nil) :type vector) + ;; The end times of the tests, in order, as reported by + ;; `current-time'. + (test-end-times (assert nil) :type vector) + (passed-expected 0) + (passed-unexpected 0) + (failed-expected 0) + (failed-unexpected 0) + (start-time nil) + (end-time nil) + (aborted-p nil) + (current-test nil) + ;; The time at or after which the next redisplay should occur, as a + ;; float. + (next-redisplay 0.0)) + +(defun ert-stats-completed-expected (stats) + "Return the number of tests in STATS that had expected results." + (+ (ert--stats-passed-expected stats) + (ert--stats-failed-expected stats))) + +(defun ert-stats-completed-unexpected (stats) + "Return the number of tests in STATS that had unexpected results." + (+ (ert--stats-passed-unexpected stats) + (ert--stats-failed-unexpected stats))) + +(defun ert-stats-completed (stats) + "Number of tests in STATS that have run so far." + (+ (ert-stats-completed-expected stats) + (ert-stats-completed-unexpected stats))) + +(defun ert-stats-total (stats) + "Number of tests in STATS, regardless of whether they have run yet." + (length (ert--stats-tests stats))) + +;; The stats object of the current run, dynamically bound. This is +;; used for the mode line progress indicator. +(defvar ert--current-run-stats nil) + +(defun ert--stats-test-key (test) + "Return the key used for TEST in the test map of ert--stats objects. + +Returns the name of TEST if it has one, or TEST itself otherwise." + (or (ert-test-name test) test)) + +(defun ert--stats-set-test-and-result (stats pos test result) + "Change STATS by replacing the test at position POS with TEST and RESULT. + +Also changes the counters in STATS to match." + (let* ((tests (ert--stats-tests stats)) + (results (ert--stats-test-results stats)) + (old-test (aref tests pos)) + (map (ert--stats-test-map stats))) + (flet ((update (d) + (if (ert-test-result-expected-p (aref tests pos) + (aref results pos)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-expected stats) d)) + (ert-test-failed (incf (ert--stats-failed-expected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit)) + (etypecase (aref results pos) + (ert-test-passed (incf (ert--stats-passed-unexpected stats) d)) + (ert-test-failed (incf (ert--stats-failed-unexpected stats) d)) + (null) + (ert-test-aborted-with-non-local-exit))))) + ;; Adjust counters to remove the result that is currently in stats. + (update -1) + ;; Put new test and result into stats. + (setf (aref tests pos) test + (aref results pos) result) + (remhash (ert--stats-test-key old-test) map) + (setf (gethash (ert--stats-test-key test) map) pos) + ;; Adjust counters to match new result. + (update +1) + nil))) + +(defun ert--make-stats (tests selector) + "Create a new `ert--stats' object for running TESTS. + +SELECTOR is the selector that was used to select TESTS." + (setq tests (ert--coerce-to-vector tests)) + (let ((map (make-hash-table :size (length tests)))) + (loop for i from 0 + for test across tests + for key = (ert--stats-test-key test) do + (assert (not (gethash key map))) + (setf (gethash key map) i)) + (make-ert--stats :selector selector + :tests tests + :test-map map + :test-results (make-vector (length tests) nil) + :test-start-times (make-vector (length tests) nil) + :test-end-times (make-vector (length tests) nil)))) + +(defun ert-run-or-rerun-test (stats test listener) + ;; checkdoc-order: nil + "Run the single test TEST and record the result using STATS and LISTENER." + (let ((ert--current-run-stats stats) + (pos (ert--stats-test-pos stats test))) + (ert--stats-set-test-and-result stats pos test nil) + ;; Call listener after setting/before resetting + ;; (ert--stats-current-test stats); the listener might refresh the + ;; mode line display, and if the value is not set yet/any more + ;; during this refresh, the mode line will flicker unnecessarily. + (setf (ert--stats-current-test stats) test) + (funcall listener 'test-started stats test) + (setf (ert-test-most-recent-result test) nil) + (setf (aref (ert--stats-test-start-times stats) pos) (current-time)) + (unwind-protect + (ert-run-test test) + (setf (aref (ert--stats-test-end-times stats) pos) (current-time)) + (let ((result (ert-test-most-recent-result test))) + (ert--stats-set-test-and-result stats pos test result) + (funcall listener 'test-ended stats test result)) + (setf (ert--stats-current-test stats) nil)))) + +(defun ert-run-tests (selector listener) + "Run the tests specified by SELECTOR, sending progress updates to LISTENER." + (let* ((tests (ert-select-tests selector t)) + (stats (ert--make-stats tests selector))) + (setf (ert--stats-start-time stats) (current-time)) + (funcall listener 'run-started stats) + (let ((abortedp t)) + (unwind-protect + (let ((ert--current-run-stats stats)) + (force-mode-line-update) + (unwind-protect + (progn + (loop for test in tests do + (ert-run-or-rerun-test stats test listener)) + (setq abortedp nil)) + (setf (ert--stats-aborted-p stats) abortedp) + (setf (ert--stats-end-time stats) (current-time)) + (funcall listener 'run-ended stats abortedp))) + (force-mode-line-update)) + stats))) + +(defun ert--stats-test-pos (stats test) + ;; checkdoc-order: nil + "Return the position (index) of TEST in the run represented by STATS." + (gethash (ert--stats-test-key test) (ert--stats-test-map stats))) + + +;;; Formatting functions shared across UIs. + +(defun ert--format-time-iso8601 (time) + "Format TIME in the variant of ISO 8601 used for timestamps in ERT." + (format-time-string "%Y-%m-%d %T%z" time)) + +(defun ert-char-for-test-result (result expectedp) + "Return a character that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed ".P") + (ert-test-failed "fF") + (null "--") + (ert-test-aborted-with-non-local-exit "aA")))) + (elt s (if expectedp 0 1)))) + +(defun ert-string-for-test-result (result expectedp) + "Return a string that represents the test result RESULT. + +EXPECTEDP specifies whether the result was expected." + (let ((s (etypecase result + (ert-test-passed '("passed" "PASSED")) + (ert-test-failed '("failed" "FAILED")) + (null '("unknown" "UNKNOWN")) + (ert-test-aborted-with-non-local-exit '("aborted" "ABORTED"))))) + (elt s (if expectedp 0 1)))) + +(defun ert--pp-with-indentation-and-newline (object) + "Pretty-print OBJECT, indenting it to the current column of point. +Ensures a final newline is inserted." + (let ((begin (point))) + (pp object (current-buffer)) + (unless (bolp) (insert "\n")) + (save-excursion + (goto-char begin) + (indent-sexp)))) + +(defun ert--insert-infos (result) + "Insert `ert-info' infos from RESULT into current buffer. + +RESULT must be an `ert-test-result-with-condition'." + (check-type result ert-test-result-with-condition) + (dolist (info (ert-test-result-with-condition-infos result)) + (destructuring-bind (prefix . message) info + (let ((begin (point)) + (indentation (make-string (+ (length prefix) 4) ?\s)) + (end nil)) + (unwind-protect + (progn + (insert message "\n") + (setq end (copy-marker (point))) + (goto-char begin) + (insert " " prefix) + (forward-line 1) + (while (< (point) end) + (insert indentation) + (forward-line 1))) + (when end (set-marker end nil))))))) + + +;;; Running tests in batch mode. + +(defvar ert-batch-backtrace-right-margin 70 + "*The maximum line length for printing backtraces in `ert-run-tests-batch'.") + +;;;###autoload +(defun ert-run-tests-batch (&optional selector) + "Run the tests specified by SELECTOR, printing results to the terminal. + +SELECTOR works as described in `ert-select-tests', except if +SELECTOR is nil, in which case all tests rather than none will be +run; this makes the command line \"emacs -batch -l my-tests.el -f +ert-run-tests-batch-and-exit\" useful. + +Returns the stats object." + (unless selector (setq selector 't)) + (ert-run-tests + selector + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (message "Running %s tests (%s)" + (length (ert--stats-tests stats)) + (ert--format-time-iso8601 (ert--stats-start-time stats))))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (let ((unexpected (ert-stats-completed-unexpected stats)) + (expected-failures (ert--stats-failed-expected stats))) + (message "\n%sRan %s tests, %s results as expected%s (%s)%s\n" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)) + (ert--format-time-iso8601 (ert--stats-end-time stats)) + (if (zerop expected-failures) + "" + (format "\n%s expected failures" expected-failures))) + (unless (zerop unexpected) + (message "%s unexpected results:" unexpected) + (loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (when (not (ert-test-result-expected-p test result)) + (message "%9s %S" + (ert-string-for-test-result result nil) + (ert-test-name test)))) + (message "%s" ""))))) + (test-started + ) + (test-ended + (destructuring-bind (stats test result) event-args + (unless (ert-test-result-expected-p test result) + (etypecase result + (ert-test-passed + (message "Test %S passed unexpectedly" (ert-test-name test))) + (ert-test-result-with-condition + (message "Test %S backtrace:" (ert-test-name test)) + (with-temp-buffer + (ert--print-backtrace (ert-test-result-with-condition-backtrace + result)) + (goto-char (point-min)) + (while (not (eobp)) + (let ((start (point)) + (end (progn (end-of-line) (point)))) + (setq end (min end + (+ start ert-batch-backtrace-right-margin))) + (message "%s" (buffer-substring-no-properties + start end))) + (forward-line 1))) + (with-temp-buffer + (ert--insert-infos result) + (insert " ") + (let ((print-escape-newlines t) + (print-level 5) + (print-length 10)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)))) + (goto-char (1- (point-max))) + (assert (looking-at "\n")) + (delete-char 1) + (message "Test %S condition:" (ert-test-name test)) + (message "%s" (buffer-string)))) + (ert-test-aborted-with-non-local-exit + (message "Test %S aborted with non-local exit" + (ert-test-name test))))) + (let* ((max (prin1-to-string (length (ert--stats-tests stats)))) + (format-string (concat "%9s %" + (prin1-to-string (length max)) + "s/" max " %S"))) + (message format-string + (ert-string-for-test-result result + (ert-test-result-expected-p + test result)) + (1+ (ert--stats-test-pos stats test)) + (ert-test-name test))))))))) + +;;;###autoload +(defun ert-run-tests-batch-and-exit (&optional selector) + "Like `ert-run-tests-batch', but exits Emacs when done. + +The exit status will be 0 if all test results were as expected, 1 +on unexpected results, or 2 if the framework detected an error +outside of the tests (e.g. invalid SELECTOR or bug in the code +that runs the tests)." + (unwind-protect + (let ((stats (ert-run-tests-batch selector))) + (kill-emacs (if (zerop (ert-stats-completed-unexpected stats)) 0 1))) + (unwind-protect + (progn + (message "Error running tests") + (backtrace)) + (kill-emacs 2)))) + + +;;; Utility functions for load/unload actions. + +(defun ert--activate-font-lock-keywords () + "Activate font-lock keywords for some of ERT's symbols." + (font-lock-add-keywords + nil + '(("(\\(\\\\s *\\(\\sw+\\)?" + (1 font-lock-keyword-face nil t) + (2 font-lock-function-name-face nil t))))) + +(defun* ert--remove-from-list (list-var element &key key test) + "Remove ELEMENT from the value of LIST-VAR if present. + +This can be used as an inverse of `add-to-list'." + (unless key (setq key #'identity)) + (unless test (setq test #'equal)) + (setf (symbol-value list-var) + (ert--remove* element + (symbol-value list-var) + :key key + :test test))) + + +;;; Some basic interactive functions. + +(defun ert-read-test-name (prompt &optional default history + add-default-to-prompt) + "Read the name of a test and return it as a symbol. + +Prompt with PROMPT. If DEFAULT is a valid test name, use it as a +default. HISTORY is the history to use; see `completing-read'. +If ADD-DEFAULT-TO-PROMPT is non-nil, PROMPT will be modified to +include the default, if any. + +Signals an error if no test name was read." + (etypecase default + (string (let ((symbol (intern-soft default))) + (unless (and symbol (ert-test-boundp symbol)) + (setq default nil)))) + (symbol (setq default + (if (ert-test-boundp default) + (symbol-name default) + nil))) + (ert-test (setq default (ert-test-name default)))) + (when add-default-to-prompt + (setq prompt (if (null default) + (format "%s: " prompt) + (format "%s (default %s): " prompt default)))) + (let ((input (completing-read prompt obarray #'ert-test-boundp + t nil history default nil))) + ;; completing-read returns an empty string if default was nil and + ;; the user just hit enter. + (let ((sym (intern-soft input))) + (if (ert-test-boundp sym) + sym + (error "Input does not name a test"))))) + +(defun ert-read-test-name-at-point (prompt) + "Read the name of a test and return it as a symbol. +As a default, use the symbol at point, or the test at point if in +the ERT results buffer. Prompt with PROMPT, augmented with the +default (if any)." + (ert-read-test-name prompt (ert-test-at-point) nil t)) + +(defun ert-find-test-other-window (test-name) + "Find, in another window, the definition of TEST-NAME." + (interactive (list (ert-read-test-name-at-point "Find test definition: "))) + (find-function-do-it test-name 'ert-deftest 'switch-to-buffer-other-window)) + +(defun ert-delete-test (test-name) + "Make the test TEST-NAME unbound. + +Nothing more than an interactive interface to `ert-make-test-unbound'." + (interactive (list (ert-read-test-name-at-point "Delete test"))) + (ert-make-test-unbound test-name)) + +(defun ert-delete-all-tests () + "Make all symbols in `obarray' name no test." + (interactive) + (when (interactive-p) + (unless (y-or-n-p "Delete all tests? ") + (error "Aborted"))) + ;; We can't use `ert-select-tests' here since that gives us only + ;; test objects, and going from them back to the test name symbols + ;; can fail if the `ert-test' defstruct has been redefined. + (mapc #'ert-make-test-unbound (apropos-internal "" #'ert-test-boundp)) + t) + + +;;; Display of test progress and results. + +;; An entry in the results buffer ewoc. There is one entry per test. +(defstruct ert--ewoc-entry + (test (assert nil)) + ;; If the result of this test was expected, its ewoc entry is hidden + ;; initially. + (hidden-p (assert nil)) + ;; An ewoc entry may be collapsed to hide details such as the error + ;; condition. + ;; + ;; I'm not sure the ability to expand and collapse entries is still + ;; a useful feature. + (expanded-p t) + ;; By default, the ewoc entry presents the error condition with + ;; certain limits on how much to print (`print-level', + ;; `print-length'). The user can interactively switch to a set of + ;; higher limits. + (extended-printer-limits-p nil)) + +;; Variables local to the results buffer. + +;; The ewoc. +(defvar ert--results-ewoc) +;; The stats object. +(defvar ert--results-stats) +;; A string with one character per test. Each character represents +;; the result of the corresponding test. The string is displayed near +;; the top of the buffer and serves as a progress bar. +(defvar ert--results-progress-bar-string) +;; The position where the progress bar button begins. +(defvar ert--results-progress-bar-button-begin) +;; The test result listener that updates the buffer when tests are run. +(defvar ert--results-listener) + +(defun ert-insert-test-name-button (test-name) + "Insert a button that links to TEST-NAME." + (insert-text-button (format "%S" test-name) + :type 'ert--test-name-button + 'ert-test-name test-name)) + +(defun ert--results-format-expected-unexpected (expected unexpected) + "Return a string indicating EXPECTED expected results, UNEXPECTED unexpected." + (if (zerop unexpected) + (format "%s" expected) + (format "%s (%s unexpected)" (+ expected unexpected) unexpected))) + +(defun ert--results-update-ewoc-hf (ewoc stats) + "Update the header and footer of EWOC to show certain information from STATS. + +Also sets `ert--results-progress-bar-button-begin'." + (let ((run-count (ert-stats-completed stats)) + (results-buffer (current-buffer)) + ;; Need to save buffer-local value. + (font-lock font-lock-mode)) + (ewoc-set-hf + ewoc + ;; header + (with-temp-buffer + (insert "Selector: ") + (ert--insert-human-readable-selector (ert--stats-selector stats)) + (insert "\n") + (insert + (format (concat "Passed: %s\n" + "Failed: %s\n" + "Total: %s/%s\n\n") + (ert--results-format-expected-unexpected + (ert--stats-passed-expected stats) + (ert--stats-passed-unexpected stats)) + (ert--results-format-expected-unexpected + (ert--stats-failed-expected stats) + (ert--stats-failed-unexpected stats)) + run-count + (ert-stats-total stats))) + (insert + (format "Started at: %s\n" + (ert--format-time-iso8601 (ert--stats-start-time stats)))) + ;; FIXME: This is ugly. Need to properly define invariants of + ;; the `stats' data structure. + (let ((state (cond ((ert--stats-aborted-p stats) 'aborted) + ((ert--stats-current-test stats) 'running) + ((ert--stats-end-time stats) 'finished) + (t 'preparing)))) + (ecase state + (preparing + (insert "")) + (aborted + (cond ((ert--stats-current-test stats) + (insert "Aborted during test: ") + (ert-insert-test-name-button + (ert-test-name (ert--stats-current-test stats)))) + (t + (insert "Aborted.")))) + (running + (assert (ert--stats-current-test stats)) + (insert "Running test: ") + (ert-insert-test-name-button (ert-test-name + (ert--stats-current-test stats)))) + (finished + (assert (not (ert--stats-current-test stats))) + (insert "Finished."))) + (insert "\n") + (if (ert--stats-end-time stats) + (insert + (format "%s%s\n" + (if (ert--stats-aborted-p stats) + "Aborted at: " + "Finished at: ") + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert "\n")) + (insert "\n")) + (let ((progress-bar-string (with-current-buffer results-buffer + ert--results-progress-bar-string))) + (let ((progress-bar-button-begin + (insert-text-button progress-bar-string + :type 'ert--results-progress-bar-button + 'face (or (and font-lock + (ert-face-for-stats stats)) + 'button)))) + ;; The header gets copied verbatim to the results buffer, + ;; and all positions remain the same, so + ;; `progress-bar-button-begin' will be the right position + ;; even in the results buffer. + (with-current-buffer results-buffer + (set (make-local-variable 'ert--results-progress-bar-button-begin) + progress-bar-button-begin)))) + (insert "\n\n") + (buffer-string)) + ;; footer + ;; + ;; We actually want an empty footer, but that would trigger a bug + ;; in ewoc, sometimes clearing the entire buffer. (It's possible + ;; that this bug has been fixed since this has been tested; we + ;; should test it again.) + "\n"))) + + +(defvar ert-test-run-redisplay-interval-secs .1 + "How many seconds ERT should wait between redisplays while running tests. + +While running tests, ERT shows the current progress, and this variable +determines how frequently the progress display is updated.") + +(defun ert--results-update-stats-display (ewoc stats) + "Update EWOC and the mode line to show data from STATS." + ;; TODO(ohler): investigate using `make-progress-reporter'. + (ert--results-update-ewoc-hf ewoc stats) + (force-mode-line-update) + (redisplay t) + (setf (ert--stats-next-redisplay stats) + (+ (float-time) ert-test-run-redisplay-interval-secs))) + +(defun ert--results-update-stats-display-maybe (ewoc stats) + "Call `ert--results-update-stats-display' if not called recently. + +EWOC and STATS are arguments for `ert--results-update-stats-display'." + (when (>= (float-time) (ert--stats-next-redisplay stats)) + (ert--results-update-stats-display ewoc stats))) + +(defun ert--tests-running-mode-line-indicator () + "Return a string for the mode line that shows the test run progress." + (let* ((stats ert--current-run-stats) + (tests-total (ert-stats-total stats)) + (tests-completed (ert-stats-completed stats))) + (if (>= tests-completed tests-total) + (format " ERT(%s/%s,finished)" tests-completed tests-total) + (format " ERT(%s/%s):%s" + (1+ tests-completed) + tests-total + (if (null (ert--stats-current-test stats)) + "?" + (format "%S" + (ert-test-name (ert--stats-current-test stats)))))))) + +(defun ert--make-xrefs-region (begin end) + "Attach cross-references to function names between BEGIN and END. + +BEGIN and END specify a region in the current buffer." + (save-excursion + (save-restriction + (narrow-to-region begin (point)) + ;; Inhibit optimization in `debugger-make-xrefs' that would + ;; sometimes insert unrelated backtrace info into our buffer. + (let ((debugger-previous-backtrace nil)) + (debugger-make-xrefs))))) + +(defun ert--string-first-line (s) + "Return the first line of S, or S if it contains no newlines. + +The return value does not include the line terminator." + (substring s 0 (ert--string-position ?\n s))) + +(defun ert-face-for-test-result (expectedp) + "Return a face that shows whether a test result was expected or unexpected. + +If EXPECTEDP is nil, returns the face for unexpected results; if +non-nil, returns the face for expected results.." + (if expectedp 'ert-test-result-expected 'ert-test-result-unexpected)) + +(defun ert-face-for-stats (stats) + "Return a face that represents STATS." + (cond ((ert--stats-aborted-p stats) 'nil) + ((plusp (ert-stats-completed-unexpected stats)) + (ert-face-for-test-result nil)) + ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) + (ert-face-for-test-result t)) + (t 'nil))) + +(defun ert--print-test-for-ewoc (entry) + "The ewoc print function for ewoc test entries. ENTRY is the entry to print." + (let* ((test (ert--ewoc-entry-test entry)) + (stats ert--results-stats) + (result (let ((pos (ert--stats-test-pos stats test))) + (assert pos) + (aref (ert--stats-test-results stats) pos))) + (hiddenp (ert--ewoc-entry-hidden-p entry)) + (expandedp (ert--ewoc-entry-expanded-p entry)) + (extended-printer-limits-p (ert--ewoc-entry-extended-printer-limits-p + entry))) + (cond (hiddenp) + (t + (let ((expectedp (ert-test-result-expected-p test result))) + (insert-text-button (format "%c" (ert-char-for-test-result + result expectedp)) + :type 'ert--results-expand-collapse-button + 'face (or (and font-lock-mode + (ert-face-for-test-result + expectedp)) + 'button))) + (insert " ") + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n") + (when (and expandedp (not (eql result 'nil))) + (when (ert-test-documentation test) + (insert " " + (propertize + (ert--string-first-line (ert-test-documentation test)) + 'font-lock-face 'font-lock-doc-face) + "\n")) + (etypecase result + (ert-test-passed + (if (ert-test-result-expected-p test result) + (insert " passed\n") + (insert " passed unexpectedly\n")) + (insert "")) + (ert-test-result-with-condition + (ert--insert-infos result) + (let ((print-escape-newlines t) + (print-level (if extended-printer-limits-p 12 6)) + (print-length (if extended-printer-limits-p 100 10))) + (insert " ") + (let ((begin (point))) + (ert--pp-with-indentation-and-newline + (ert-test-result-with-condition-condition result)) + (ert--make-xrefs-region begin (point))))) + (ert-test-aborted-with-non-local-exit + (insert " aborted\n"))) + (insert "\n"))))) + nil) + +(defun ert--results-font-lock-function (enabledp) + "Redraw the ERT results buffer after font-lock-mode was switched on or off. + +ENABLEDP is true if font-lock-mode is switched on, false +otherwise." + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (ewoc-refresh ert--results-ewoc) + (font-lock-default-function enabledp)) + +(defun ert--setup-results-buffer (stats listener buffer-name) + "Set up a test results buffer. + +STATS is the stats object; LISTENER is the results listener; +BUFFER-NAME, if non-nil, is the buffer name to use." + (unless buffer-name (setq buffer-name "*ert*")) + (let ((buffer (get-buffer-create buffer-name))) + (with-current-buffer buffer + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-results-mode) + ;; Erase buffer again in case switching out of the previous + ;; mode inserted anything. (This happens e.g. when switching + ;; from ert-results-mode to ert-results-mode when + ;; font-lock-mode turns itself off in change-major-mode-hook.) + (erase-buffer) + (set (make-local-variable 'font-lock-function) + 'ert--results-font-lock-function) + (let ((ewoc (ewoc-create 'ert--print-test-for-ewoc nil nil t))) + (set (make-local-variable 'ert--results-ewoc) ewoc) + (set (make-local-variable 'ert--results-stats) stats) + (set (make-local-variable 'ert--results-progress-bar-string) + (make-string (ert-stats-total stats) + (ert-char-for-test-result nil t))) + (set (make-local-variable 'ert--results-listener) listener) + (loop for test across (ert--stats-tests stats) do + (ewoc-enter-last ewoc + (make-ert--ewoc-entry :test test :hidden-p t))) + (ert--results-update-ewoc-hf ert--results-ewoc ert--results-stats) + (goto-char (1- (point-max))) + buffer))))) + + +(defvar ert--selector-history nil + "List of recent test selectors read from terminal.") + +;; Should OUTPUT-BUFFER-NAME and MESSAGE-FN really be arguments here? +;; They are needed only for our automated self-tests at the moment. +;; Or should there be some other mechanism? +;;;###autoload +(defun ert-run-tests-interactively (selector + &optional output-buffer-name message-fn) + "Run the tests specified by SELECTOR and display the results in a buffer. + +SELECTOR works as described in `ert-select-tests'. +OUTPUT-BUFFER-NAME and MESSAGE-FN should normally be nil; they +are used for automated self-tests and specify which buffer to use +and how to display message." + (interactive + (list (let ((default (if ert--selector-history + ;; Can't use `first' here as this form is + ;; not compiled, and `first' is not + ;; defined without cl. + (car ert--selector-history) + "t"))) + (read-from-minibuffer (if (null default) + "Run tests: " + (format "Run tests (default %s): " default)) + nil nil t 'ert--selector-history + default nil)) + nil)) + (unless message-fn (setq message-fn 'message)) + (lexical-let ((output-buffer-name output-buffer-name) + buffer + listener + (message-fn message-fn)) + (setq listener + (lambda (event-type &rest event-args) + (ecase event-type + (run-started + (destructuring-bind (stats) event-args + (setq buffer (ert--setup-results-buffer stats + listener + output-buffer-name)) + (pop-to-buffer buffer))) + (run-ended + (destructuring-bind (stats abortedp) event-args + (funcall message-fn + "%sRan %s tests, %s results were as expected%s" + (if (not abortedp) + "" + "Aborted: ") + (ert-stats-total stats) + (ert-stats-completed-expected stats) + (let ((unexpected + (ert-stats-completed-unexpected stats))) + (if (zerop unexpected) + "" + (format ", %s unexpected" unexpected)))) + (ert--results-update-stats-display (with-current-buffer buffer + ert--results-ewoc) + stats))) + (test-started + (destructuring-bind (stats test) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (assert node) + (setf (ert--ewoc-entry-test (ewoc-data node)) test) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result nil t)) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node))))) + (test-ended + (destructuring-bind (stats test result) event-args + (with-current-buffer buffer + (let* ((ewoc ert--results-ewoc) + (pos (ert--stats-test-pos stats test)) + (node (ewoc-nth ewoc pos))) + (when (ert--ewoc-entry-hidden-p (ewoc-data node)) + (setf (ert--ewoc-entry-hidden-p (ewoc-data node)) + (ert-test-result-expected-p test result))) + (aset ert--results-progress-bar-string pos + (ert-char-for-test-result result + (ert-test-result-expected-p + test result))) + (ert--results-update-stats-display-maybe ewoc stats) + (ewoc-invalidate ewoc node)))))))) + (ert-run-tests + selector + listener))) +;;;###autoload +(defalias 'ert 'ert-run-tests-interactively) + + +;;; Simple view mode for auxiliary information like stack traces or +;;; messages. Mainly binds "q" for quit. + +(define-derived-mode ert-simple-view-mode fundamental-mode "ERT-View" + "Major mode for viewing auxiliary information in ERT.") + +(loop for (key binding) in + '(("q" quit-window) + ) + do + (define-key ert-simple-view-mode-map key binding)) + + +;;; Commands and button actions for the results buffer. + +(define-derived-mode ert-results-mode fundamental-mode "ERT-Results" + "Major mode for viewing results of ERT test runs.") + +(loop for (key binding) in + '(;; Stuff that's not in the menu. + ("\t" forward-button) + ([backtab] backward-button) + ("j" ert-results-jump-between-summary-and-result) + ("q" quit-window) + ("L" ert-results-toggle-printer-limits-for-test-at-point) + ("n" ert-results-next-test) + ("p" ert-results-previous-test) + ;; Stuff that is in the menu. + ("R" ert-results-rerun-all-tests) + ("r" ert-results-rerun-test-at-point) + ("d" ert-results-rerun-test-at-point-debugging-errors) + ("." ert-results-find-test-at-point-other-window) + ("b" ert-results-pop-to-backtrace-for-test-at-point) + ("m" ert-results-pop-to-messages-for-test-at-point) + ("l" ert-results-pop-to-should-forms-for-test-at-point) + ("h" ert-results-describe-test-at-point) + ("D" ert-delete-test) + ("T" ert-results-pop-to-timings) + ) + do + (define-key ert-results-mode-map key binding)) + +(easy-menu-define ert-results-mode-menu ert-results-mode-map + "Menu for `ert-results-mode'." + '("ERT Results" + ["Re-run all tests" ert-results-rerun-all-tests] + "--" + ["Re-run test" ert-results-rerun-test-at-point] + ["Debug test" ert-results-rerun-test-at-point-debugging-errors] + ["Show test definition" ert-results-find-test-at-point-other-window] + "--" + ["Show backtrace" ert-results-pop-to-backtrace-for-test-at-point] + ["Show messages" ert-results-pop-to-messages-for-test-at-point] + ["Show `should' forms" ert-results-pop-to-should-forms-for-test-at-point] + ["Describe test" ert-results-describe-test-at-point] + "--" + ["Delete test" ert-delete-test] + "--" + ["Show execution time of each test" ert-results-pop-to-timings] + )) + +(define-button-type 'ert--results-progress-bar-button + 'action #'ert--results-progress-bar-button-action + 'help-echo "mouse-2, RET: Reveal test result") + +(define-button-type 'ert--test-name-button + 'action #'ert--test-name-button-action + 'help-echo "mouse-2, RET: Find test definition") + +(define-button-type 'ert--results-expand-collapse-button + 'action #'ert--results-expand-collapse-button-action + 'help-echo "mouse-2, RET: Expand/collapse test result") + +(defun ert--results-test-node-or-null-at-point () + "If point is on a valid ewoc node, return it; return nil otherwise. + +To be used in the ERT results buffer." + (let* ((ewoc ert--results-ewoc) + (node (ewoc-locate ewoc))) + ;; `ewoc-locate' will return an arbitrary node when point is on + ;; header or footer, or when all nodes are invisible. So we need + ;; to validate its return value here. + ;; + ;; Update: I'm seeing nil being returned in some cases now, + ;; perhaps this has been changed? + (if (and node + (>= (point) (ewoc-location node)) + (not (ert--ewoc-entry-hidden-p (ewoc-data node)))) + node + nil))) + +(defun ert--results-test-node-at-point () + "If point is on a valid ewoc node, return it; signal an error otherwise. + +To be used in the ERT results buffer." + (or (ert--results-test-node-or-null-at-point) + (error "No test at point"))) + +(defun ert-results-next-test () + "Move point to the next test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-next + "No tests below")) + +(defun ert-results-previous-test () + "Move point to the previous test. + +To be used in the ERT results buffer." + (interactive) + (ert--results-move (ewoc-locate ert--results-ewoc) 'ewoc-prev + "No tests above")) + +(defun ert--results-move (node ewoc-fn error-message) + "Move point from NODE to the previous or next node. + +EWOC-FN specifies the direction and should be either `ewoc-prev' +or `ewoc-next'. If there are no more nodes in that direction, an +error is signalled with the message ERROR-MESSAGE." + (loop + (setq node (funcall ewoc-fn ert--results-ewoc node)) + (when (null node) + (error "%s" error-message)) + (unless (ert--ewoc-entry-hidden-p (ewoc-data node)) + (goto-char (ewoc-location node)) + (return)))) + +(defun ert--results-expand-collapse-button-action (button) + "Expand or collapse the test node BUTTON belongs to." + (let* ((ewoc ert--results-ewoc) + (node (save-excursion + (goto-char (ert--button-action-position)) + (ert--results-test-node-at-point))) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-expanded-p entry) + (not (ert--ewoc-entry-expanded-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-find-test-at-point-other-window () + "Find the definition of the test at point in another window. + +To be used in the ERT results buffer." + (interactive) + (let ((name (ert-test-at-point))) + (unless name + (error "No test at point")) + (ert-find-test-other-window name))) + +(defun ert--test-name-button-action (button) + "Find the definition of the test BUTTON belongs to, in another window." + (let ((name (button-get button 'ert-test-name))) + (ert-find-test-other-window name))) + +(defun ert--ewoc-position (ewoc node) + ;; checkdoc-order: nil + "Return the position of NODE in EWOC, or nil if NODE is not in EWOC." + (loop for i from 0 + for node-here = (ewoc-nth ewoc 0) then (ewoc-next ewoc node-here) + do (when (eql node node-here) + (return i)) + finally (return nil))) + +(defun ert-results-jump-between-summary-and-result () + "Jump back and forth between the test run summary and individual test results. + +From an ewoc node, jumps to the character that represents the +same test in the progress bar, and vice versa. + +To be used in the ERT results buffer." + ;; Maybe this command isn't actually needed much, but if it is, it + ;; seems like an indication that the UI design is not optimal. If + ;; jumping back and forth between a summary at the top of the buffer + ;; and the error log in the remainder of the buffer is useful, then + ;; the summary apparently needs to be easily accessible from the + ;; error log, and perhaps it would be better to have it in a + ;; separate buffer to keep it visible. + (interactive) + (let ((ewoc ert--results-ewoc) + (progress-bar-begin ert--results-progress-bar-button-begin)) + (cond ((ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (pos (ert--ewoc-position ewoc node))) + (goto-char (+ progress-bar-begin pos)))) + ((and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((node (ewoc-nth ewoc (- (point) progress-bar-begin))) + (entry (ewoc-data node))) + (when (ert--ewoc-entry-hidden-p entry) + (setf (ert--ewoc-entry-hidden-p entry) nil) + (ewoc-invalidate ewoc node)) + (ewoc-goto-node ewoc node))) + (t + (goto-char progress-bar-begin))))) + +(defun ert-test-at-point () + "Return the name of the test at point as a symbol, or nil if none." + (or (and (eql major-mode 'ert-results-mode) + (let ((test (ert--results-test-at-point-no-redefinition))) + (and test (ert-test-name test)))) + (let* ((thing (thing-at-point 'symbol)) + (sym (intern-soft thing))) + (and (ert-test-boundp sym) + sym)))) + +(defun ert--results-test-at-point-no-redefinition () + "Return the test at point, or nil. + +To be used in the ERT results buffer." + (assert (eql major-mode 'ert-results-mode)) + (if (ert--results-test-node-or-null-at-point) + (let* ((node (ert--results-test-node-at-point)) + (test (ert--ewoc-entry-test (ewoc-data node)))) + test) + (let ((progress-bar-begin ert--results-progress-bar-button-begin)) + (when (and (<= progress-bar-begin (point)) + (< (point) (button-end (button-at progress-bar-begin)))) + (let* ((test-index (- (point) progress-bar-begin)) + (test (aref (ert--stats-tests ert--results-stats) + test-index))) + test))))) + +(defun ert--results-test-at-point-allow-redefinition () + "Look up the test at point, and check whether it has been redefined. + +To be used in the ERT results buffer. + +Returns a list of two elements: the test (or nil) and a symbol +specifying whether the test has been redefined. + +If a new test has been defined with the same name as the test at +point, replaces the test at point with the new test, and returns +the new test and the symbol `redefined'. + +If the test has been deleted, returns the old test and the symbol +`deleted'. + +If the test is still current, returns the test and the symbol nil. + +If there is no test at point, returns a list with two nils." + (let ((test (ert--results-test-at-point-no-redefinition))) + (cond ((null test) + `(nil nil)) + ((null (ert-test-name test)) + `(,test nil)) + (t + (let* ((name (ert-test-name test)) + (new-test (and (ert-test-boundp name) + (ert-get-test name)))) + (cond ((eql test new-test) + `(,test nil)) + ((null new-test) + `(,test deleted)) + (t + (ert--results-update-after-test-redefinition + (ert--stats-test-pos ert--results-stats test) + new-test) + `(,new-test redefined)))))))) + +(defun ert--results-update-after-test-redefinition (pos new-test) + "Update results buffer after the test at pos POS has been redefined. + +Also updates the stats object. NEW-TEST is the new test +definition." + (let* ((stats ert--results-stats) + (ewoc ert--results-ewoc) + (node (ewoc-nth ewoc pos)) + (entry (ewoc-data node))) + (ert--stats-set-test-and-result stats pos new-test nil) + (setf (ert--ewoc-entry-test entry) new-test + (aref ert--results-progress-bar-string pos) (ert-char-for-test-result + nil t)) + (ewoc-invalidate ewoc node)) + nil) + +(defun ert--button-action-position () + "The buffer position where the last button action was triggered." + (cond ((integerp last-command-event) + (point)) + ((eventp last-command-event) + (posn-point (event-start last-command-event))) + (t (assert nil)))) + +(defun ert--results-progress-bar-button-action (button) + "Jump to details for the test represented by the character clicked in BUTTON." + (goto-char (ert--button-action-position)) + (ert-results-jump-between-summary-and-result)) + +(defun ert-results-rerun-all-tests () + "Re-run all tests, using the same selector. + +To be used in the ERT results buffer." + (interactive) + (assert (eql major-mode 'ert-results-mode)) + (let ((selector (ert--stats-selector ert--results-stats))) + (ert-run-tests-interactively selector (buffer-name)))) + +(defun ert-results-rerun-test-at-point () + "Re-run the test at point. + +To be used in the ERT results buffer." + (interactive) + (destructuring-bind (test redefinition-state) + (ert--results-test-at-point-allow-redefinition) + (when (null test) + (error "No test at point")) + (let* ((stats ert--results-stats) + (progress-message (format "Running %stest %S" + (ecase redefinition-state + ((nil) "") + (redefined "new definition of ") + (deleted "deleted ")) + (ert-test-name test)))) + ;; Need to save and restore point manually here: When point is on + ;; the first visible ewoc entry while the header is updated, point + ;; moves to the top of the buffer. This is undesirable, and a + ;; simple `save-excursion' doesn't prevent it. + (let ((point (point))) + (unwind-protect + (unwind-protect + (progn + (message "%s..." progress-message) + (ert-run-or-rerun-test stats test + ert--results-listener)) + (ert--results-update-stats-display ert--results-ewoc stats) + (message "%s...%s" + progress-message + (let ((result (ert-test-most-recent-result test))) + (ert-string-for-test-result + result (ert-test-result-expected-p test result))))) + (goto-char point)))))) + +(defun ert-results-rerun-test-at-point-debugging-errors () + "Re-run the test at point with `ert-debug-on-error' bound to t. + +To be used in the ERT results buffer." + (interactive) + (let ((ert-debug-on-error t)) + (ert-results-rerun-test-at-point))) + +(defun ert-results-pop-to-backtrace-for-test-at-point () + "Display the backtrace for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (etypecase result + (ert-test-passed (error "Test passed, no backtrace available")) + (ert-test-result-with-condition + (let ((backtrace (ert-test-result-with-condition-backtrace result)) + (buffer (get-buffer-create "*ERT Backtrace*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + ;; Use unibyte because `debugger-setup-buffer' also does so. + (set-buffer-multibyte nil) + (setq truncate-lines t) + (ert--print-backtrace backtrace) + (debugger-make-xrefs) + (goto-char (point-min)) + (insert "Backtrace for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))))) + +(defun ert-results-pop-to-messages-for-test-at-point () + "Display the part of the *Messages* buffer generated during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT Messages*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (insert (ert-test-result-messages result)) + (goto-char (point-min)) + (insert "Messages for test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n"))))) + +(defun ert-results-pop-to-should-forms-for-test-at-point () + "Display the list of `should' forms executed during the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((test (ert--results-test-at-point-no-redefinition)) + (stats ert--results-stats) + (pos (ert--stats-test-pos stats test)) + (result (aref (ert--stats-test-results stats) pos))) + (let ((buffer (get-buffer-create "*ERT list of should forms*"))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null (ert-test-result-should-forms result)) + (insert "\n(No should forms during this test.)\n") + (loop for form-description in (ert-test-result-should-forms result) + for i from 1 do + (insert "\n") + (insert (format "%s: " i)) + (let ((begin (point))) + (ert--pp-with-indentation-and-newline form-description) + (ert--make-xrefs-region begin (point))))) + (goto-char (point-min)) + (insert "`should' forms executed during test `") + (ert-insert-test-name-button (ert-test-name test)) + (insert "':\n") + (insert "\n") + (insert (concat "(Values are shallow copies and may have " + "looked different during the test if they\n" + "have been modified destructively.)\n")) + (forward-line 1))))) + +(defun ert-results-toggle-printer-limits-for-test-at-point () + "Toggle how much of the condition to print for the test at point. + +To be used in the ERT results buffer." + (interactive) + (let* ((ewoc ert--results-ewoc) + (node (ert--results-test-node-at-point)) + (entry (ewoc-data node))) + (setf (ert--ewoc-entry-extended-printer-limits-p entry) + (not (ert--ewoc-entry-extended-printer-limits-p entry))) + (ewoc-invalidate ewoc node))) + +(defun ert-results-pop-to-timings () + "Display test timings for the last run. + +To be used in the ERT results buffer." + (interactive) + (let* ((stats ert--results-stats) + (start-times (ert--stats-test-start-times stats)) + (end-times (ert--stats-test-end-times stats)) + (buffer (get-buffer-create "*ERT timings*")) + (data (loop for test across (ert--stats-tests stats) + for start-time across (ert--stats-test-start-times stats) + for end-time across (ert--stats-test-end-times stats) + collect (list test + (float-time (subtract-time end-time + start-time)))))) + (setq data (sort data (lambda (a b) + (> (second a) (second b))))) + (pop-to-buffer buffer) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (buffer-disable-undo) + (erase-buffer) + (ert-simple-view-mode) + (if (null data) + (insert "(No data)\n") + (insert (format "%-3s %8s %8s\n" "" "time" "cumul")) + (loop for (test time) in data + for cumul-time = time then (+ cumul-time time) + for i from 1 do + (let ((begin (point))) + (insert (format "%3s: %8.3f %8.3f " i time cumul-time)) + (ert-insert-test-name-button (ert-test-name test)) + (insert "\n")))) + (goto-char (point-min)) + (insert "Tests by run time (seconds):\n\n") + (forward-line 1)))) + +;;;###autoload +(defun ert-describe-test (test-or-test-name) + "Display the documentation for TEST-OR-TEST-NAME (a symbol or ert-test)." + (interactive (list (ert-read-test-name-at-point "Describe test"))) + (when (< emacs-major-version 24) + (error "Requires Emacs 24")) + (let (test-name + test-definition) + (etypecase test-or-test-name + (symbol (setq test-name test-or-test-name + test-definition (ert-get-test test-or-test-name))) + (ert-test (setq test-name (ert-test-name test-or-test-name) + test-definition test-or-test-name))) + (help-setup-xref (list #'ert-describe-test test-or-test-name) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer (help-buffer) + (insert (if test-name (format "%S" test-name) "")) + (insert " is a test") + (let ((file-name (and test-name + (symbol-file test-name 'ert-deftest)))) + (when file-name + (insert " defined in `" (file-name-nondirectory file-name) "'") + (save-excursion + (re-search-backward "`\\([^`']+\\)'" nil t) + (help-xref-button 1 'help-function-def test-name file-name))) + (insert ".") + (fill-region-as-paragraph (point-min) (point)) + (insert "\n\n") + (unless (and (ert-test-boundp test-name) + (eql (ert-get-test test-name) test-definition)) + (let ((begin (point))) + (insert "Note: This test has been redefined or deleted, " + "this documentation refers to an old definition.") + (fill-region-as-paragraph begin (point))) + (insert "\n\n")) + (insert (or (ert-test-documentation test-definition) + "It is not documented.") + "\n"))))))) + +(defun ert-results-describe-test-at-point () + "Display the documentation of the test at point. + +To be used in the ERT results buffer." + (interactive) + (ert-describe-test (ert--results-test-at-point-no-redefinition))) + + +;;; Actions on load/unload. + +(add-to-list 'find-function-regexp-alist '(ert-deftest . ert--find-test-regexp)) +(add-to-list 'minor-mode-alist '(ert--current-run-stats + (:eval + (ert--tests-running-mode-line-indicator)))) +(add-to-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) + +(defun ert--unload-function () + "Unload function to undo the side-effects of loading ert.el." + (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) + (ert--remove-from-list 'emacs-lisp-mode-hook + 'ert--activate-font-lock-keywords) + nil) + +(defvar ert-unload-hook '()) +(add-hook 'ert-unload-hook 'ert--unload-function) + + +(provide 'ert) + +;;; ert.el ends here diff --git a/dev/examples-to-docs.el b/dev/examples-to-docs.el new file mode 100644 index 0000000..999e3c1 --- /dev/null +++ b/dev/examples-to-docs.el @@ -0,0 +1,128 @@ +(defvar functions '()) + +(defun example-to-string (example) + (let ((actual (car example)) + (expected (cadr (cdr example)))) + (replace-regexp-in-string + "\r" "\\r" + (replace-regexp-in-string + "\t" "\\t" + (replace-regexp-in-string + "\n" "\\n" + (replace-regexp-in-string + "\\\\\\?" "?" + (format "%S ;; => %S" actual expected)) t t) t t) t t))) + +(defun examples-to-strings (examples) + (let (result) + (while examples + (setq result (cons (example-to-string examples) result)) + (setq examples (cddr (cdr examples)))) + (nreverse result))) + +(defun docs--signature (cmd) + (if (eq 'macro (car cmd)) + (car (cddr cmd)) + (cadr cmd))) + +(defun docs--docstring (cmd) + (if (eq 'macro (car cmd)) + (cadr (cddr cmd)) + (car (cddr cmd)))) + +(defmacro defexamples (cmd &rest examples) + (declare (indent 1)) + `(add-to-list 'functions (list + ',cmd + (docs--signature (symbol-function ',cmd)) + (docs--docstring (symbol-function ',cmd)) + (examples-to-strings ',examples)))) + +(defmacro def-example-group (group &rest examples) + `(progn + (add-to-list 'functions ,group) + ,@examples)) + +(defun quote-and-downcase (string) + (format "`%s`" (downcase string))) + +(defun quote-docstring (docstring) + (let (case-fold-search) + (setq docstring (replace-regexp-in-string "\\b\\([A-Z][A-Z-]*[0-9]*\\)\\b" 'quote-and-downcase docstring t)) + (setq docstring (replace-regexp-in-string "`\\([^ ]+\\)'" "`\\1`" docstring t))) + docstring) + +(defun function-to-md (function) + (if (stringp function) + "" + (let ((command-name (car function)) + (signature (cadr function)) + (docstring (quote-docstring (cadr (cdr function)))) + (examples (cadr (cddr function)))) + (format "### %s `%s`\n\n%s\n\n```cl\n%s\n```\n" + command-name + signature + docstring + (mapconcat 'identity (three-first examples) "\n"))))) + +(defun docs--chop-suffix (suffix s) + "Remove SUFFIX if it is at end of S." + (let ((pos (- (length suffix)))) + (if (and (>= (length s) (length suffix)) + (string= suffix (substring s pos))) + (substring s 0 pos) + s))) + +(defun github-id (command-name signature) + (docs--chop-suffix + "-" + (replace-regexp-in-string "[^a-zA-Z0-9-]+" "-" (format "%S %S" command-name signature)))) + +(defun function-summary (function) + (if (stringp function) + (concat "\n### " function "\n") + (let ((command-name (car function)) + (signature (cadr function))) + (format "* [%s](#%s) `%s`" command-name (github-id command-name signature) signature)))) + +(defun simplify-quotes () + (goto-char (point-min)) + (while (search-forward "(quote nil)" nil t) + (replace-match "'()")) + (goto-char (point-min)) + (while (search-forward "(quote " nil t) + (forward-char -7) + (let ((p (point))) + (forward-sexp 1) + (delete-char -1) + (goto-char p) + (delete-char 7) + (insert "'")))) + +(defun goto-and-remove (s) + (goto-char (point-min)) + (search-forward s) + (delete-char (- (length s)))) + +(defun create-docs-file () + (let ((functions (nreverse functions))) + (with-temp-file "./README.md" + (insert-file-contents-literally "./readme-template.md") + + (goto-and-remove "[[ function-list ]]") + (insert (mapconcat 'function-summary functions "\n")) + + (goto-and-remove "[[ function-docs ]]") + (insert (mapconcat 'function-to-md functions "\n")) + + (simplify-quotes)))) + +(defun three-first (list) + (let (first) + (when (car list) + (setq first (cons (car list) first)) + (when (cadr list) + (setq first (cons (cadr list) first)) + (when (car (cddr list)) + (setq first (cons (car (cddr list)) first))))) + (nreverse first))) diff --git a/dev/examples-to-tests.el b/dev/examples-to-tests.el new file mode 100644 index 0000000..bbed66b --- /dev/null +++ b/dev/examples-to-tests.el @@ -0,0 +1,22 @@ +(require 'ert) + +(defun examples-to-should-1 (examples) + (let ((actual (car examples)) + (expected (cadr (cdr examples)))) + `(should (equal ,actual ,expected)))) + +(defun examples-to-should (examples) + (let (result) + (while examples + (setq result (cons (examples-to-should-1 examples) result)) + (setq examples (cddr (cdr examples)))) + (nreverse result))) + +(defmacro defexamples (cmd &rest examples) + (declare (indent 1)) + `(ert-deftest ,cmd () + ,@(examples-to-should examples))) + +(defun def-example-group (&rest _)) ; ignore + +(provide 'examples-to-tests) diff --git a/dev/examples.el b/dev/examples.el new file mode 100644 index 0000000..66d4dcb --- /dev/null +++ b/dev/examples.el @@ -0,0 +1,432 @@ +;; -*- lexical-binding: t; eval: (font-lock-add-keywords nil '(("defexamples\\|def-example-group\\| => " (0 'font-lock-keyword-face)))); -*- + +;; Only the first three examples per function are shown in the docs, +;; so make those good. + +(require 's) +(require 'assoc) + +(def-example-group "Tweak whitespace" + (defexamples s-trim + (s-trim "trim ") => "trim" + (s-trim " this") => "this" + (s-trim " only trims beg and end ") => "only trims beg and end") + + (defexamples s-trim-left + (s-trim-left "trim ") => "trim " + (s-trim-left " this") => "this") + + (defexamples s-trim-right + (s-trim-right "trim ") => "trim" + (s-trim-right " this") => " this") + + (defexamples s-chomp + (s-chomp "no newlines\n") => "no newlines" + (s-chomp "no newlines\r\n") => "no newlines" + (s-chomp "some newlines\n\n") => "some newlines\n") + + (defexamples s-collapse-whitespace + (s-collapse-whitespace "only one space please") => "only one space please" + (s-collapse-whitespace "collapse \n all \t sorts of \r whitespace") => "collapse all sorts of whitespace") + + (defexamples s-word-wrap + (s-word-wrap 10 "This is too long") => "This is\ntoo long" + (s-word-wrap 10 "This is way way too long") => "This is\nway way\ntoo long" + (s-word-wrap 10 "It-wraps-words-but-does-not-break-them") => "It-wraps-words-but-does-not-break-them") + + (defexamples s-center + (s-center 5 "a") => " a " + (s-center 5 "ab") => " ab " + (s-center 1 "abc") => "abc" + (s-center 6 "ab") => " ab ") + + (defexamples s-pad-left + (s-pad-left 3 "0" "3") => "003" + (s-pad-left 3 "0" "23") => "023" + (s-pad-left 3 "0" "1234") => "1234") + + (defexamples s-pad-right + (s-pad-right 3 "." "3") => "3.." + (s-pad-right 3 "." "23") => "23." + (s-pad-right 3 "." "1234") => "1234")) + +(def-example-group "To shorter string" + (defexamples s-truncate + (s-truncate 6 "This is too long") => "Thi..." + (s-truncate 16 "This is also too long") => "This is also ..." + (s-truncate 16 "But this is not!") => "But this is not!") + + (defexamples s-left + (s-left 3 "lib/file.js") => "lib" + (s-left 3 "li") => "li") + + (defexamples s-right + (s-right 3 "lib/file.js") => ".js" + (s-right 3 "li") => "li") + + (defexamples s-chop-suffix + (s-chop-suffix "-test.js" "penguin-test.js") => "penguin" + (s-chop-suffix "\n" "no newlines\n") => "no newlines" + (s-chop-suffix "\n" "some newlines\n\n") => "some newlines\n") + + (defexamples s-chop-suffixes + (s-chop-suffixes '("_test.js" "-test.js" "Test.js") "penguin-test.js") => "penguin" + (s-chop-suffixes '("\r" "\n") "penguin\r\n") => "penguin\r" + (s-chop-suffixes '("\n" "\r") "penguin\r\n") => "penguin") + + (defexamples s-chop-prefix + (s-chop-prefix "/tmp" "/tmp/file.js") => "/file.js" + (s-chop-prefix "/tmp" "/tmp/tmp/file.js") => "/tmp/file.js") + + (defexamples s-chop-prefixes + (s-chop-prefixes '("/tmp" "/my") "/tmp/my/file.js") => "/file.js" + (s-chop-prefixes '("/my" "/tmp") "/tmp/my/file.js") => "/my/file.js") + + (defexamples s-shared-start + (s-shared-start "bar" "baz") => "ba" + (s-shared-start "foobar" "foo") => "foo" + (s-shared-start "bar" "foo") => "" + (s-shared-start "" "foo") => "" + (s-shared-start "foo" "foo") => "foo" + (s-shared-start "" "") => "") + + (defexamples s-shared-end + (s-shared-end "bar" "var") => "ar" + (s-shared-end "foo" "foo") => "foo" + (s-shared-end "bar" "foo") => "" + (s-shared-end "" "foo") => "" + (s-shared-end "" "") => "")) + +(def-example-group "To longer string" + (defexamples s-repeat + (s-repeat 10 " ") => " " + (s-concat (s-repeat 8 "Na") " Batman!") => "NaNaNaNaNaNaNaNa Batman!") + + (defexamples s-concat + (s-concat "abc" "def" "ghi") => "abcdefghi") + + (defexamples s-prepend + (s-prepend "abc" "def") => "abcdef") + + (defexamples s-append + (s-append "abc" "def") => "defabc") + + (defexamples s-wrap + (s-wrap "[" "]" "foobar") => "[foobar]" + (s-wrap "(" "" "foobar") => "(foobar" + (s-wrap "" ")" "foobar") => "foobar)")) + +(def-example-group "To and from lists" + (defexamples s-lines + (s-lines "abc\ndef\nghi") => '("abc" "def" "ghi") + (s-lines "abc\rdef\rghi") => '("abc" "def" "ghi") + (s-lines "abc\r\ndef\r\nghi") => '("abc" "def" "ghi")) + + (defexamples s-match + (s-match "^def" "abcdefg") => nil + (s-match "^abc" "abcdefg") => '("abc") + (s-match "^/.*/\\([a-z]+\\)\\.\\([a-z]+\\)" "/some/weird/file.html") => '("/some/weird/file.html" "file" "html") + (s-match "^/.*/\\([a-z]+\\)\\.\\([a-z]+\\)" "/some/weird/file.org") => '("/some/weird/file.org" "file" "org") + (s-match "^\\(abc\\)\\(def\\)?" "abcdef") => '("abcdef" "abc" "def") + (s-match "^\\(abc\\)\\(def\\)?" "abc") => '("abc" "abc") + (s-match "^\\(abc\\)\\(def\\)?\\(ghi\\)" "abcghi") => '("abcghi" "abc" nil "ghi") + (s-match "abc" "abcdef" 1) => nil + (s-match "abc" "abcdefabc" 2) => '("abc")) + + (defexamples s-match-strings-all + (s-match-strings-all + "{\\([^}]+\\)}" "x is {x} and y is {y}") => '(("{x}" "x") ("{y}" "y")) + (s-match-strings-all "ab." "abXabY") => '(("abX") ("abY")) + (s-match-strings-all "\\<" "foo bar baz") => '(("") ("") (""))) + + (defexamples s-matched-positions-all + (s-matched-positions-all "l+" "{{Hello}} World, {{Emacs}}!" 0) => '((4 . 6) (13 . 14)) + (s-matched-positions-all "{{\\(.+?\\)}}" "{{Hello}} World, {{Emacs}}!" 0) => '((0 . 9) (17 . 26)) + (s-matched-positions-all "{{\\(.+?\\)}}" "{{Hello}} World, {{Emacs}}!" 1) => '((2 . 7) (19 . 24)) + (s-matched-positions-all "l" "{{Hello}} World, {{Emacs}}!" 0) => '((4 . 5) (5 . 6) (13 . 14)) + (s-matched-positions-all "abc" "{{Hello}} World, {{Emacs}}!") => nil) + + (defexamples s-slice-at + (s-slice-at "-" "abc") => '("abc") + (s-slice-at "-" "abc-def") => '("abc" "-def") + (s-slice-at "[\.#]" "abc.def.ghi#id") => '("abc" ".def" ".ghi" "#id") + (s-slice-at "-" "abc-def-") => '("abc" "-def" "-")) + + (defexamples s-split + (s-split "|" "a|bc|12|3") => '("a" "bc" "12" "3") + (s-split ":" "a,c,d") => '("a,c,d") + (s-split "\n" "z\nefg\n") => '("z" "efg" "") + (s-split "\n" "z\nefg\n" t) => '("z" "efg") + (s-split "ö" "xyöözeföklmö") => '("xy" "" "zef" "klm" "") + (s-split "ö" "xyöözeföklmö" t) => '("xy" "zef" "klm")) + + (defexamples s-split-up-to + (s-split-up-to "\\s-*-\\s-*" "Author - Track-number-one" 1) => '("Author" "Track-number-one") + (s-split-up-to "\\s-*-\\s-*" "Author - Track-number-one" 2) => '("Author" "Track" "number-one") + (s-split-up-to "|" "foo||bar|baz|qux" 3 t) => '("foo" "bar" "baz|qux") + (s-split-up-to "|" "foo||bar|baz|qux" 3) => '("foo" "" "bar" "baz|qux") + (s-split-up-to ":" "a,b,c" 1) => '("a,b,c") + (s-split-up-to ":" "a,b,c" 10) => '("a,b,c") + (s-split-up-to "\n" "z\nefg\n" 5) => '("z" "efg" "") + (s-split-up-to "\n" "z\nefg\n" 5 t) => '("z" "efg") + (s-split-up-to "|" "foo||bar|baz|qux" 10) => '("foo" "" "bar" "baz" "qux") + (s-split-up-to "|" "foo||bar|baz|qux" 10 t) => '("foo" "bar" "baz" "qux") + (s-split-up-to "|" "foo|bar|baz|" 2) => '("foo" "bar" "baz|") + (s-split-up-to "|" "foo|bar|baz|" 2 t) => '("foo" "bar" "baz|") + (s-split-up-to "|" "foo|bar|baz|qux|" 2) => '("foo" "bar" "baz|qux|")) + + (defexamples s-join + (s-join "+" '("abc" "def" "ghi")) => "abc+def+ghi" + (s-join "\n" '("abc" "def" "ghi")) => "abc\ndef\nghi")) + +(def-example-group "Predicates" + (defexamples s-equals? + (s-equals? "abc" "ABC") => nil + (s-equals? "abc" "abc") => t) + + (defexamples s-less? + (s-less? "abc" "abd") => t + (s-less? "abd" "abc") => nil + (s-less? "abc" "abc") => nil) + + (defexamples s-matches? + (s-matches? "^[0-9]+$" "123") => t + (s-matches? "^[0-9]+$" "a123") => nil + (s-matches? "1" "1a" 1) => nil + (s-matches? "1" "1a1" 1) => t) + + (defexamples s-blank? + (s-blank? "") => t + (s-blank? nil) => t + (s-blank? " ") => nil) + + (defexamples s-present? + (s-present? "") => nil + (s-present? nil) => nil + (s-present? " ") => t) + + (defexamples s-ends-with? + (s-ends-with? ".md" "readme.md") => t + (s-ends-with? ".MD" "readme.md") => nil + (s-ends-with? ".MD" "readme.md" t) => t + (s-ends-with? ".md" "md") => nil + (s-suffix? ".md" "readme.md") => t) + + (defexamples s-starts-with? + (s-starts-with? "lib/" "lib/file.js") => t + (s-starts-with? "LIB/" "lib/file.js") => nil + (s-starts-with? "LIB/" "lib/file.js" t) => t + (s-starts-with? "lib/" "lib") => nil + (s-prefix? "lib/" "lib/file.js") => t) + + (defexamples s-contains? + (s-contains? "file" "lib/file.js") => t + (s-contains? "nope" "lib/file.js") => nil + (s-contains? "^a" "it's not ^a regexp") => t + (s-contains? "FILE" "lib/file.js") => nil + (s-contains? "FILE" "lib/file.js" t) => t) + + (defexamples s-lowercase? + (s-lowercase? "file") => t + (s-lowercase? "File") => nil + (s-lowercase? "filä") => t + (s-lowercase? "filÄ") => nil + (s-lowercase? "123?") => t) + + (defexamples s-uppercase? + (s-uppercase? "HULK SMASH") => t + (s-uppercase? "Bruce no smash") => nil + (s-uppercase? "FöB") => nil + (s-uppercase? "FÖB") => t + (s-uppercase? "123?") => t) + + (defexamples s-mixedcase? + (s-mixedcase? "HULK SMASH") => nil + (s-mixedcase? "Bruce no smash") => t + (s-mixedcase? "BRÜCE") => nil + (s-mixedcase? "BRüCE") => t + (s-mixedcase? "123?") => nil) + + (defexamples s-capitalized? + (s-capitalized? "Capitalized") => t + (s-capitalized? "I am capitalized") => t + (s-capitalized? "I Am Titleized") => nil + (s-capitalized? "lower") => nil + (s-capitalized? "UPPER") => nil + (s-capitalized? "Привет") => t) + + (defexamples s-numeric? + (s-numeric? "123") => t + (s-numeric? "onetwothree") => nil + (s-numeric? "7a") => nil + (s-numeric? "a89") => nil)) + +(def-example-group "The misc bucket" + (defexamples s-replace + (s-replace "file" "nope" "lib/file.js") => "lib/nope.js" + (s-replace "^a" "\\1" "it's not ^a regexp") => "it's not \\1 regexp") + + (defexamples s-replace-all + (s-replace-all '(("lib" . "test") ("file" . "file_test")) "lib/file.js") => "test/file_test.js" + (s-replace-all '(("lib" . "test") ("test" . "lib")) "lib/test.js") => "test/lib.js") + + (defexamples s-downcase + (s-downcase "ABC") => "abc") + + (defexamples s-upcase + (s-upcase "abc") => "ABC") + + (defexamples s-capitalize + (s-capitalize "abc DEF") => "Abc def" + (s-capitalize "abc.DEF") => "Abc.def") + + (defexamples s-titleize + (s-titleize "abc DEF") => "Abc Def" + (s-titleize "abc.DEF") => "Abc.Def") + + (defexamples s-with + (s-with " hulk smash " s-trim s-upcase) => "HULK SMASH" + (s-with "My car is a Toyota" (s-replace "car" "name") (s-replace "a Toyota" "Bond") (s-append ", James Bond")) => "My name is Bond, James Bond" + (s-with "abc \ndef \nghi" s-lines (mapcar 's-trim) (s-join "-") s-reverse) => "ihg-fed-cba") + + (defexamples s-index-of + (s-index-of "abc" "abcdef") => 0 + (s-index-of "CDE" "abcdef" t) => 2 + (s-index-of "n.t" "not a regexp") => nil) + + (defexamples s-reverse + (s-reverse "abc") => "cba" + (s-reverse "ab xyz") => "zyx ba" + (s-reverse "") => "" + (s-reverse "résumé") => "émusér" + ;; Two combining marks on a single character + (s-reverse "Ęyǫgwędę́hte⁷") => "⁷ethę́dęwgǫyĘ") + + (defexamples s-presence + (s-presence nil) => nil + (s-presence "") => nil + (s-presence "foo") => "foo") + + (defexamples s-format + ;; One with an alist works + (s-format + "help ${name}! I'm ${malady}" + 'aget + '(("name" . "nic") ("malady" . "on fire"))) + => "help nic! I'm on fire" + + ;; One with a function works + (s-format "hello ${name}, nice day" (lambda (var-name) "nic")) + => "hello nic, nice day" + + ;; One with a list works + (s-format "hello $0, nice $1" 'elt '("nic" "day")) + => "hello nic, nice day" + + ;; Two with a hash-table works + (s-format + "help ${name}! I'm ${malady}" + 'gethash + #s(hash-table test equal data ("name" "nic" "malady" "on fire"))) + => "help nic! I'm on fire" + + ;; Replacing case has no effect on s-format + (let ((case-replace t)) + (s-format "help ${NAME}!" 'aget '(("NAME" . "Nick")))) + => "help Nick!" + + (let ((case-replace nil)) + (s-format "help ${NAME}!" 'aget '(("NAME" . "Nick")))) + => "help Nick!" + + (let ((case-replace nil)) + (s-format "help ${name}!" 'aget '(("name" . "Nick")))) + => "help Nick!" + + ;; What happens when we have literal slashes? + (s-format "$0" 'elt '("Hello\\nWorld")) + => "Hello\\nWorld" + + ;; What happens when we don't have the elements? with hash... + (condition-case err + (s-format + "help ${name}! I'm ${malady}" + 'gethash + #s(hash-table test equal data ("name" "nic" ))) + (s-format-resolve (car err))) + => 's-format-resolve) + + (defexamples s-lex-format + ;; lexical stuff + (let ((x 1)) + (s-lex-format "x is ${x}")) + => "x is 1" + + (let ((str1 "this") + (str2 "that")) + (s-lex-format "${str1} and ${str2}")) + => "this and that" + + ;; Have a litteral \ in the replacement + (let ((foo "Hello\\nWorld")) + (s-lex-format "${foo}")) + => "Hello\\nWorld" + ) + + (defexamples s-count-matches + (s-count-matches "a" "aba") => 2 + (s-count-matches "a" "aba" 0 2) => 1 + (s-count-matches "\\w\\{2\\}[0-9]+" "ab1bab2frobinator") => 2) + + (defexamples s-wrap + (s-wrap "foo" "\"") => "\"foo\"" + (s-wrap "foo" "(" ")") => "(foo)" + (s-wrap "foo" "bar") => "barfoobar")) + +(def-example-group "Pertaining to words" + (defexamples s-split-words + (s-split-words "under_score") => '("under" "score") + (s-split-words "some-dashed-words") => '("some" "dashed" "words") + (s-split-words "evenCamelCase") => '("even" "Camel" "Case") + (s-split-words "!map (fn list)") => '("map" "fn" "list") + (s-split-words "Привет, мир") => '("Привет" "мир") + (s-split-words "e é è e") => '("e" "é" "è" "e") + (s-split-words "MANYUpperCases") => '("MANY" "Upper" "Cases") + (s-split-words "Приве́т") => '("Приве́т") + (s-split-words "漢語") => '("漢語")) + + (defexamples s-lower-camel-case + (s-lower-camel-case "some words") => "someWords" + (s-lower-camel-case "dashed-words") => "dashedWords" + (s-lower-camel-case "under_scored_words") => "underScoredWords") + + (defexamples s-upper-camel-case + (s-upper-camel-case "some words") => "SomeWords" + (s-upper-camel-case "dashed-words") => "DashedWords" + (s-upper-camel-case "under_scored_words") => "UnderScoredWords") + + (defexamples s-snake-case + (s-snake-case "some words") => "some_words" + (s-snake-case "dashed-words") => "dashed_words" + (s-snake-case "camelCasedWords") => "camel_cased_words") + + (defexamples s-dashed-words + (s-dashed-words "some words") => "some-words" + (s-dashed-words "under_scored_words") => "under-scored-words" + (s-dashed-words "camelCasedWords") => "camel-cased-words") + + (defexamples s-capitalized-words + (s-capitalized-words "some words") => "Some words" + (s-capitalized-words "under_scored_words") => "Under scored words" + (s-capitalized-words "camelCasedWords") => "Camel cased words") + + (defexamples s-titleized-words + (s-titleized-words "some words") => "Some Words" + (s-titleized-words "under_scored_words") => "Under Scored Words" + (s-titleized-words "camelCasedWords") => "Camel Cased Words") + + (defexamples s-word-initials + (s-word-initials "some words") => "sw" + (s-word-initials "under_scored_words") => "usw" + (s-word-initials "camelCasedWords") => "cCW" + (s-word-initials "dashed-words") => "dw")) diff --git a/dev/undercover-init.el b/dev/undercover-init.el new file mode 100644 index 0000000..52f90ee --- /dev/null +++ b/dev/undercover-init.el @@ -0,0 +1,2 @@ +(when (require 'undercover nil t) + (undercover "s.el")) diff --git a/pre-commit.sh b/pre-commit.sh new file mode 100755 index 0000000..97fbd45 --- /dev/null +++ b/pre-commit.sh @@ -0,0 +1,9 @@ +#!/bin/sh + +git stash -q --keep-index +./run-tests.sh +RESULT=$? +[ $RESULT == 0 ] && ./create-docs.sh && git add ./README.md +git stash pop -q +[ $RESULT -ne 0 ] && exit 1 +exit 0 diff --git a/readme-template.md b/readme-template.md new file mode 100644 index 0000000..c31512d --- /dev/null +++ b/readme-template.md @@ -0,0 +1,161 @@ +# s.el [![Build Status](https://secure.travis-ci.org/magnars/s.el.png)](http://travis-ci.org/magnars/s.el) [![Coverage Status](https://coveralls.io/repos/magnars/s.el/badge.svg?branch=master)](https://coveralls.io/r/magnars/s.el?branch=master) + +The long lost Emacs string manipulation library. + +## Installation + +It's available on [marmalade](http://marmalade-repo.org/) and [Melpa](https://melpa.org/): + + M-x package-install s + +Or you can just dump `s.el` in your load path somewhere. + +## Functions + +[[ function-list ]] + +## Documentation and examples + +[[ function-docs ]] + +## What's with the built-in wrappers? + +Imagine looking through the function list and seeing `s-ends-with?`, but +`s-starts-with?` is nowhere to be found. Why? Well, because Emacs already has +`string-prefix-p`. Now you're starting out slightly confused, then have to go +somewhere else to dig for the command you were looking for. + +The wrapping functions serve as both documentation for existing functions and +makes for a consistent API. + +## Other string related libraries + +* [inflections](https://github.com/eschulte/jump.el/blob/master/inflections.el) package +provides functions for strings pluralization and singularization. + +* [levenshtein](http://emacswiki.org/emacs/levenshtein.el) package provides a function to +calculate the Levenshtein distance between two strings. + +* [string-utils](https://github.com/rolandwalker/string-utils) is another general string manipulation library. + +## Changelist + +### From 1.10.0 to 1.11.0 + +- Add `s-matched-positions-all` (ono hiroko) + +### From 1.9.0 to 1.10.0 + +- Add `s-wrap` (Johan Andersson) +- Add `s-split-up-to` (Matus Goljer) +- Fix `s-reverse` for Unicode combining characters. (Christopher Wellons) + +### From 1.8.0 to 1.9.0 + +- Add `s-count-matches` (Lars Andersen) + +### From 1.7.0 to 1.8.0 + +- Add `s-present?` and `s-present?` (Johan Andersson) +- Better handling of international characters + +### From 1.6.0 to 1.7.0 + +- Add `s-word-initials` (Sylvain Rousseau) +- Better handling of camel cased strings (@Bruce-Connor) + +### From 1.5.0 to 1.6.0 + +- Add `s-pad-left` and `s-pad-right` +- Bugfixes for `s-format` (Nic Ferrier) + +### From 1.4.0 to 1.5.0 + +- Add `s-all-match-strings` (Geoff Gole) +- Add `s-lex-format` (Nic Ferrier) + +### From 1.3.1 to 1.4.0 + +- Add `s-capitalized?` +- Add `s-replace-all` +- Add `s-slice-at` +- Add `s-split` alias for `split-string` (Rüdiger Sonderfeld) +- Add `s-less?` predicate (Rüdiger Sonderfeld) +- Add START parameter to `s-matches?` (Rüdiger Sonderfeld) +- Bugfixes + +### From 1.3.0 to 1.3.1 + +- Add `s-numeric?` +- Add `s-match` (Arthur Andersen) +- Add `s-format` (Nic Ferrier) +- Move .el files out of root to avoid problems with require. + +### From 1.2.1 to 1.3.0 + +- **Breaking change:** `s-capitalize` now converts the first word's first + character to upper case and the rest to lower case. `s-titleize` + works like the old `s-capitalize` and capitalizes each word. + (Johan Andersson) + +- `s-capitalized-words` and `s-titleized-words` mirror this change. + +## Contributors + +* [Arthur Andersen](https://github.com/leoc) contributed `s-match` +* [Rolando](https://github.com/rolando2424) contributed `s-shared-start` and `s-shared-end` +* [Johan Andersson](https://github.com/rejeep) contributed `s-presence`, `s-present?` and fixed `s-titleize` vs `s-capitalize` +* [Nic Ferrier](https://github.com/nicferrier) added `s-format` and `s-lex-format` +* [Rüdiger Sonderfeld](https://github.com/ruediger) contributed `s-less?`, `s-split` and several bugfixes. +* [Geoff Gole](https://github.com/gsg) contributed `s-all-match-strings` +* [Sylvain Rousseau](https://github.com/thisirs) contributed `s-word-initials` +* [Lars Andersen](https://github.com/expez) contributed `s-count-matches` +* [ono hiroko](https://github.com/kuanyui) contributed `s-matched-positions-all` + +Thanks! + +## Contribute + +Yes, please do. Pure functions in the string manipulation realm only, +please. There's a suite of tests in `dev/examples.el`, so remember to add +tests for your function, or I might break it later. + +You'll find the repo at: + + https://github.com/magnars/s.el + +Run the tests with + + ./run-tests.sh + +Create the docs with + + ./create-docs.sh + +I highly recommend that you install these as a pre-commit hook, so that +the tests are always running and the docs are always in sync: + + cp pre-commit.sh .git/hooks/pre-commit + +Oh, and don't edit `README.md` directly, it is auto-generated. +Change `readme-template.md` or `examples-to-docs.el` instead. + +## License + +Copyright (C) 2012-2015 Magnar Sveen + +Authors: Magnar Sveen +Keywords: strings + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program. If not, see . diff --git a/run-tests.sh b/run-tests.sh new file mode 100755 index 0000000..bea81d4 --- /dev/null +++ b/run-tests.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env bash + +if [ -z "$EMACS" ] ; then + EMACS="emacs" +fi + +$EMACS -batch -l dev/ert.el -l dev/examples-to-tests.el -l s.el -l dev/examples.el -f ert-run-tests-batch-and-exit diff --git a/run-travis-ci.sh b/run-travis-ci.sh new file mode 100755 index 0000000..16a1717 --- /dev/null +++ b/run-travis-ci.sh @@ -0,0 +1,28 @@ +#!/bin/sh + +cd "$(dirname "$0")" + +set_default () { + eval " +if [ -z \$$1 ]; then + $1=$2 +fi +" +} + +set_default EMACS "$(which emacs)" + +echo "*** Emacs version ***" +echo "EMACS =" $(which $EMACS) +$EMACS --version +echo + +if [ "$EMACS" != "emacs23" ]; then + curl -fsSLo /tmp/cask-master.zip https://github.com/cask/cask/archive/master.zip + sudo unzip -qq -d /opt /tmp/cask-master.zip + sudo ln -sf /opt/cask-master/bin/cask /usr/local/bin/cask + cask + cask exec $EMACS -batch -l dev/ert.el -l dev/examples-to-tests.el -l dev/undercover-init.el -l s.el -l dev/examples.el -f ert-run-tests-batch-and-exit +else + exec ./run-tests.sh +fi diff --git a/s.el b/s.el new file mode 100644 index 0000000..4d85eb4 --- /dev/null +++ b/s.el @@ -0,0 +1,617 @@ +;;; s.el --- The long lost Emacs string manipulation library. + +;; Copyright (C) 2012-2015 Magnar Sveen + +;; Author: Magnar Sveen +;; Version: 1.10.0 +;; Keywords: strings + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; The long lost Emacs string manipulation library. +;; +;; See documentation on https://github.com/magnars/s.el#functions + +;;; Code: + +(require 'ucs-normalize) + +(defun s-trim-left (s) + "Remove whitespace at the beginning of S." + (if (string-match "\\`[ \t\n\r]+" s) + (replace-match "" t t s) + s)) + +(defun s-trim-right (s) + "Remove whitespace at the end of S." + (if (string-match "[ \t\n\r]+\\'" s) + (replace-match "" t t s) + s)) + +(defun s-trim (s) + "Remove whitespace at the beginning and end of S." + (s-trim-left (s-trim-right s))) + +(defun s-collapse-whitespace (s) + "Convert all adjacent whitespace characters to a single space." + (replace-regexp-in-string "[ \t\n\r]+" " " s)) + +(defun s-split (separator s &optional omit-nulls) + "Split S into substrings bounded by matches for regexp SEPARATOR. +If OMIT-NULLS is non-nil, zero-length substrings are omitted. + +This is a simple wrapper around the built-in `split-string'." + (split-string s separator omit-nulls)) + +(defun s-split-up-to (separator s n &optional omit-nulls) + "Split S up to N times into substrings bounded by matches for regexp SEPARATOR. + +If OMIT-NULLS is non-nil, zero-length substrings are omitted. + +See also `s-split'." + (save-match-data + (let ((op 0) + (r nil)) + (with-temp-buffer + (insert s) + (setq op (goto-char (point-min))) + (while (and (re-search-forward separator nil t) + (< 0 n)) + (let ((sub (buffer-substring-no-properties op (match-beginning 0)))) + (unless (and omit-nulls + (equal sub "")) + (push sub r))) + (setq op (goto-char (match-end 0))) + (setq n (1- n))) + (let ((sub (buffer-substring-no-properties op (point-max)))) + (unless (and omit-nulls + (equal sub "")) + (push sub r)))) + (nreverse r)))) + +(defun s-lines (s) + "Splits S into a list of strings on newline characters." + (s-split "\\(\r\n\\|[\n\r]\\)" s)) + +(defun s-join (separator strings) + "Join all the strings in STRINGS with SEPARATOR in between." + (mapconcat 'identity strings separator)) + +(defun s-concat (&rest strings) + "Join all the string arguments into one string." + (apply 'concat strings)) + +(defun s-prepend (prefix s) + "Concatenate PREFIX and S." + (concat prefix s)) + +(defun s-append (suffix s) + "Concatenate S and SUFFIX." + (concat s suffix)) + +(defun s-repeat (num s) + "Make a string of S repeated NUM times." + (let (ss) + (while (> num 0) + (setq ss (cons s ss)) + (setq num (1- num))) + (apply 'concat ss))) + +(defun s-chop-suffix (suffix s) + "Remove SUFFIX if it is at end of S." + (let ((pos (- (length suffix)))) + (if (and (>= (length s) (length suffix)) + (string= suffix (substring s pos))) + (substring s 0 pos) + s))) + +(defun s-chop-suffixes (suffixes s) + "Remove SUFFIXES one by one in order, if they are at the end of S." + (while suffixes + (setq s (s-chop-suffix (car suffixes) s)) + (setq suffixes (cdr suffixes))) + s) + +(defun s-chop-prefix (prefix s) + "Remove PREFIX if it is at the start of S." + (let ((pos (length prefix))) + (if (and (>= (length s) (length prefix)) + (string= prefix (substring s 0 pos))) + (substring s pos) + s))) + +(defun s-chop-prefixes (prefixes s) + "Remove PREFIXES one by one in order, if they are at the start of S." + (while prefixes + (setq s (s-chop-prefix (car prefixes) s)) + (setq prefixes (cdr prefixes))) + s) + +(defun s-shared-start (s1 s2) + "Returns the longest prefix S1 and S2 have in common." + (let ((search-length (min (length s1) (length s2))) + (i 0)) + (while (and (< i search-length) + (= (aref s1 i) (aref s2 i))) + (setq i (1+ i))) + (substring s1 0 i))) + +(defun s-shared-end (s1 s2) + "Returns the longest suffix S1 and S2 have in common." + (let* ((l1 (length s1)) + (l2 (length s2)) + (search-length (min l1 l2)) + (i 0)) + (while (and (< i search-length) + (= (aref s1 (- l1 i 1)) (aref s2 (- l2 i 1)))) + (setq i (1+ i))) + ;; If I is 0, then it means that there's no common suffix between + ;; S1 and S2. + ;; + ;; However, since (substring s (- 0)) will return the whole + ;; string, `s-shared-end' should simply return the empty string + ;; when I is 0. + (if (zerop i) + "" + (substring s1 (- i))))) + +(defun s-chomp (s) + "Remove one trailing `\\n`, `\\r` or `\\r\\n` from S." + (s-chop-suffixes '("\n" "\r") s)) + +(defun s-truncate (len s) + "If S is longer than LEN, cut it down to LEN - 3 and add ... at the end." + (if (> (length s) len) + (format "%s..." (substring s 0 (- len 3))) + s)) + +(defun s-word-wrap (len s) + "If S is longer than LEN, wrap the words with newlines." + (with-temp-buffer + (insert s) + (let ((fill-column len)) + (fill-region (point-min) (point-max))) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun s-center (len s) + "If S is shorter than LEN, pad it with spaces so it is centered." + (let ((extra (max 0 (- len (length s))))) + (concat + (make-string (ceiling extra 2) ? ) + s + (make-string (floor extra 2) ? )))) + +(defun s-pad-left (len padding s) + "If S is shorter than LEN, pad it with PADDING on the left." + (let ((extra (max 0 (- len (length s))))) + (concat (make-string extra (string-to-char padding)) + s))) + +(defun s-pad-right (len padding s) + "If S is shorter than LEN, pad it with PADDING on the right." + (let ((extra (max 0 (- len (length s))))) + (concat s + (make-string extra (string-to-char padding))))) + +(defun s-left (len s) + "Returns up to the LEN first chars of S." + (if (> (length s) len) + (substring s 0 len) + s)) + +(defun s-right (len s) + "Returns up to the LEN last chars of S." + (let ((l (length s))) + (if (> l len) + (substring s (- l len) l) + s))) + +(defun s-ends-with? (suffix s &optional ignore-case) + "Does S end with SUFFIX? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-suffix?'" + (let ((start-pos (- (length s) (length suffix)))) + (and (>= start-pos 0) + (eq t (compare-strings suffix nil nil + s start-pos nil ignore-case))))) + +(defalias 's-ends-with-p 's-ends-with?) + +(defun s-starts-with? (prefix s &optional ignore-case) + "Does S start with PREFIX? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-prefix?'. This is a simple wrapper around the built-in +`string-prefix-p'." + (string-prefix-p prefix s ignore-case)) + +(defalias 's-starts-with-p 's-starts-with?) + +(defalias 's-suffix? 's-ends-with?) +(defalias 's-prefix? 's-starts-with?) +(defalias 's-suffix-p 's-ends-with?) +(defalias 's-prefix-p 's-starts-with?) + +(defun s--truthy? (val) + (not (null val))) + +(defun s-contains? (needle s &optional ignore-case) + "Does S contain NEEDLE? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences." + (let ((case-fold-search ignore-case)) + (s--truthy? (string-match-p (regexp-quote needle) s)))) + +(defalias 's-contains-p 's-contains?) + +(defun s-equals? (s1 s2) + "Is S1 equal to S2? + +This is a simple wrapper around the built-in `string-equal'." + (string-equal s1 s2)) + +(defalias 's-equals-p 's-equals?) + +(defun s-less? (s1 s2) + "Is S1 less than S2? + +This is a simple wrapper around the built-in `string-lessp'." + (string-lessp s1 s2)) + +(defalias 's-less-p 's-less?) + +(defun s-matches? (regexp s &optional start) + "Does REGEXP match S? +If START is non-nil the search starts at that index. + +This is a simple wrapper around the built-in `string-match-p'." + (s--truthy? (string-match-p regexp s start))) + +(defalias 's-matches-p 's-matches?) + +(defun s-blank? (s) + "Is S nil or the empty string?" + (or (null s) (string= "" s))) + +(defun s-present? (s) + "Is S anything but nil or the empty string?" + (not (s-blank? s))) + +(defun s-presence (s) + "Return S if it's `s-present?', otherwise return nil." + (and (s-present? s) s)) + +(defun s-lowercase? (s) + "Are all the letters in S in lower case?" + (let ((case-fold-search nil)) + (not (string-match-p "[[:upper:]]" s)))) + +(defun s-uppercase? (s) + "Are all the letters in S in upper case?" + (let ((case-fold-search nil)) + (not (string-match-p "[[:lower:]]" s)))) + +(defun s-mixedcase? (s) + "Are there both lower case and upper case letters in S?" + (let ((case-fold-search nil)) + (s--truthy? + (and (string-match-p "[[:lower:]]" s) + (string-match-p "[[:upper:]]" s))))) + +(defun s-capitalized? (s) + "In S, is the first letter upper case, and all other letters lower case?" + (let ((case-fold-search nil)) + (s--truthy? + (string-match-p "^[[:upper:]][^[:upper:]]*$" s)))) + +(defun s-numeric? (s) + "Is S a number?" + (s--truthy? + (string-match-p "^[0-9]+$" s))) + +(defun s-replace (old new s) + "Replaces OLD with NEW in S." + (replace-regexp-in-string (regexp-quote old) new s t t)) + +(defun s--aget (alist key) + (cdr (assoc key alist))) + +(defun s-replace-all (replacements s) + "REPLACEMENTS is a list of cons-cells. Each `car` is replaced with `cdr` in S." + (replace-regexp-in-string (regexp-opt (mapcar 'car replacements)) + (lambda (it) (s--aget replacements it)) + s)) + +(defun s-downcase (s) + "Convert S to lower case. + +This is a simple wrapper around the built-in `downcase'." + (downcase s)) + +(defun s-upcase (s) + "Convert S to upper case. + +This is a simple wrapper around the built-in `upcase'." + (upcase s)) + +(defun s-capitalize (s) + "Convert the first word's first character to upper case and the rest to lower case in S." + (concat (upcase (substring s 0 1)) (downcase (substring s 1)))) + +(defun s-titleize (s) + "Convert each word's first character to upper case and the rest to lower case in S. + +This is a simple wrapper around the built-in `capitalize'." + (capitalize s)) + +(defmacro s-with (s form &rest more) + "Threads S through the forms. Inserts S as the last item +in the first form, making a list of it if it is not a list +already. If there are more forms, inserts the first form as the +last item in second form, etc." + (declare (debug (form &rest [&or (function &rest form) fboundp]))) + (if (null more) + (if (listp form) + `(,(car form) ,@(cdr form) ,s) + (list form s)) + `(s-with (s-with ,s ,form) ,@more))) + +(put 's-with 'lisp-indent-function 1) + +(defun s-index-of (needle s &optional ignore-case) + "Returns first index of NEEDLE in S, or nil. + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences." + (let ((case-fold-search ignore-case)) + (string-match-p (regexp-quote needle) s))) + +(defun s-reverse (s) + "Return the reverse of S." + (if (multibyte-string-p s) + (let ((input (string-to-list s)) + (output ())) + (while input + ;; Handle entire grapheme cluster as a single unit + (let ((grapheme (list (pop input)))) + (while (memql (car input) ucs-normalize-combining-chars) + (push (pop input) grapheme)) + (setq output (nconc (nreverse grapheme) output)))) + (concat output)) + (concat (nreverse (string-to-list s))))) + +(defun s-match-strings-all (regex string) + "Return a list of matches for REGEX in STRING. + +Each element itself is a list of matches, as per +`match-string'. Multiple matches at the same position will be +ignored after the first." + (let ((all-strings ()) + (i 0)) + (while (and (< i (length string)) + (string-match regex string i)) + (setq i (1+ (match-beginning 0))) + (let (strings + (num-matches (/ (length (match-data)) 2)) + (match 0)) + (while (/= match num-matches) + (push (match-string match string) strings) + (setq match (1+ match))) + (push (nreverse strings) all-strings))) + (nreverse all-strings))) + +(defun s-matched-positions-all (regexp string &optional subexp-depth) + "Return a list of matched positions for REGEXP in STRING. +SUBEXP-DEPTH is 0 by default." + (if (null subexp-depth) + (setq subexp-depth 0)) + (let ((pos 0) result) + (while (and (string-match regexp string pos) + (< pos (length string))) + (let ((m (match-end subexp-depth))) + (push (cons (match-beginning subexp-depth) (match-end subexp-depth)) result) + (setq pos m))) + (nreverse result))) + +(defun s-match (regexp s &optional start) + "When the given expression matches the string, this function returns a list +of the whole matching string and a string for each matched subexpressions. +If it did not match the returned value is an empty list (nil). + +When START is non-nil the search will start at that index." + (save-match-data + (if (string-match regexp s start) + (let ((match-data-list (match-data)) + result) + (while match-data-list + (let* ((beg (car match-data-list)) + (end (cadr match-data-list)) + (subs (if (and beg end) (substring s beg end) nil))) + (setq result (cons subs result)) + (setq match-data-list + (cddr match-data-list)))) + (nreverse result))))) + +(defun s-slice-at (regexp s) + "Slices S up at every index matching REGEXP." + (save-match-data + (let (i) + (setq i (string-match regexp s 1)) + (if i + (cons (substring s 0 i) + (s-slice-at regexp (substring s i))) + (list s))))) + +(defun s-split-words (s) + "Split S into list of words." + (s-split + "[^[:word:]0-9]+" + (let ((case-fold-search nil)) + (replace-regexp-in-string + "\\([[:lower:]]\\)\\([[:upper:]]\\)" "\\1 \\2" + (replace-regexp-in-string "\\([[:upper:]]\\)\\([[:upper:]][0-9[:lower:]]\\)" "\\1 \\2" s))) + t)) + +(defun s--mapcar-head (fn-head fn-rest list) + "Like MAPCAR, but applies a different function to the first element." + (if list + (cons (funcall fn-head (car list)) (mapcar fn-rest (cdr list))))) + +(defun s-lower-camel-case (s) + "Convert S to lowerCamelCase." + (s-join "" (s--mapcar-head 'downcase 'capitalize (s-split-words s)))) + +(defun s-upper-camel-case (s) + "Convert S to UpperCamelCase." + (s-join "" (mapcar 'capitalize (s-split-words s)))) + +(defun s-snake-case (s) + "Convert S to snake_case." + (s-join "_" (mapcar 'downcase (s-split-words s)))) + +(defun s-dashed-words (s) + "Convert S to dashed-words." + (s-join "-" (mapcar 'downcase (s-split-words s)))) + +(defun s-capitalized-words (s) + "Convert S to Capitalized words." + (let ((words (s-split-words s))) + (s-join " " (cons (capitalize (car words)) (mapcar 'downcase (cdr words)))))) + +(defun s-titleized-words (s) + "Convert S to Titleized Words." + (s-join " " (mapcar 's-titleize (s-split-words s)))) + +(defun s-word-initials (s) + "Convert S to its initials." + (s-join "" (mapcar (lambda (ss) (substring ss 0 1)) + (s-split-words s)))) + +;; Errors for s-format +(progn + (put 's-format-resolve + 'error-conditions + '(error s-format s-format-resolve)) + (put 's-format-resolve + 'error-message + "Cannot resolve a template to values")) + +(defun s-format (template replacer &optional extra) + "Format TEMPLATE with the function REPLACER. + +REPLACER takes an argument of the format variable and optionally +an extra argument which is the EXTRA value from the call to +`s-format'. + +Several standard `s-format' helper functions are recognized and +adapted for this: + + (s-format \"${name}\" 'gethash hash-table) + (s-format \"${name}\" 'aget alist) + (s-format \"$0\" 'elt sequence) + +The REPLACER function may be used to do any other kind of +transformation." + (let ((saved-match-data (match-data))) + (unwind-protect + (replace-regexp-in-string + "\\$\\({\\([^}]+\\)}\\|[0-9]+\\)" + (lambda (md) + (let ((var + (let ((m (match-string 2 md))) + (if m m + (string-to-number (match-string 1 md))))) + (replacer-match-data (match-data))) + (unwind-protect + (let ((v + (cond + ((eq replacer 'gethash) + (funcall replacer var extra)) + ((eq replacer 'aget) + (funcall 's--aget extra var)) + ((eq replacer 'elt) + (funcall replacer extra var)) + (t + (set-match-data saved-match-data) + (if extra + (funcall replacer var extra) + (funcall replacer var)))))) + (if v v (signal 's-format-resolve md))) + (set-match-data replacer-match-data)))) template + ;; Need literal to make sure it works + t t) + (set-match-data saved-match-data)))) + +(defvar s-lex-value-as-lisp nil + "If `t' interpolate lisp values as lisp. + +`s-lex-format' inserts values with (format \"%S\").") + +(defun s-lex-fmt|expand (fmt) + "Expand FMT into lisp." + (list 's-format fmt (quote 'aget) + (append '(list) + (mapcar + (lambda (matches) + (list + 'cons + (cadr matches) + `(format + (if s-lex-value-as-lisp "%S" "%s") + ,(intern (cadr matches))))) + (s-match-strings-all "${\\([^}]+\\)}" fmt))))) + +(defmacro s-lex-format (format-str) + "`s-format` with the current environment. + +FORMAT-STR may use the `s-format' variable reference to refer to +any variable: + + (let ((x 1)) + (s-lex-format \"x is: ${x}\")) + +The values of the variables are interpolated with \"%s\" unless +the variable `s-lex-value-as-lisp' is `t' and then they are +interpolated with \"%S\"." + (declare (debug (form))) + (s-lex-fmt|expand format-str)) + +(defun s-count-matches (regexp s &optional start end) + "Count occurrences of `regexp' in `s'. + +`start', inclusive, and `end', exclusive, delimit the part of `s' +to match. " + (with-temp-buffer + (insert s) + (goto-char (point-min)) + (count-matches regexp (or start 1) (or end (point-max))))) + +(defun s-wrap (s prefix &optional suffix) + "Wrap string S with PREFIX and optionally SUFFIX. + +Return string S with PREFIX prepended. If SUFFIX is present, it +is appended, otherwise PREFIX is used as both prefix and +suffix." + (concat prefix s (or suffix prefix))) + +(provide 's) +;;; s.el ends here diff --git a/watch-tests.watchr b/watch-tests.watchr new file mode 100644 index 0000000..8146789 --- /dev/null +++ b/watch-tests.watchr @@ -0,0 +1,38 @@ +ENV["WATCHR"] = "1" +system 'clear' + +def run(cmd) + `#{cmd}` +end + +def run_all_tests + system('clear') + result = run "./run-tests.sh" + puts result +end + +run_all_tests +watch('.*.el') { run_all_tests } + +# Ctrl-\ +Signal.trap 'QUIT' do + puts " --- Running all tests ---\n\n" + run_all_tests +end + +@interrupted = false + +# Ctrl-C +Signal.trap 'INT' do + if @interrupted then + @wants_to_quit = true + abort("\n") + else + puts "Interrupt a second time to quit" + @interrupted = true + Kernel.sleep 1.5 + # raise Interrupt, nil # let the run loop catch it + run_all_tests + @interrupted = false + end +end -- cgit v1.2.3