faith.fnl
1 ;;; faith.fnl --- The Fennel Advanced Interactive Test Helper 2 3 ;; https://git.sr.ht/~technomancy/faith 4 5 ;; SPDX-License-Identifier: MIT 6 ;; SPDX-FileCopyrightText: Scott Vokes, Phil Hagelberg, and contributors 7 8 ;; To use Faith, create a test runner file which calls the `run` function with 9 ;; a list of module names. The modules should export functions whose 10 ;; names start with `test-` and which call the assertion functions in the 11 ;; `faith` module. 12 13 ;; Copyright © 2009-2013 Scott Vokes and contributors 14 ;; Copyright © 2023 Phil Hagelberg and contributors 15 16 ;; Permission is hereby granted, free of charge, to any person obtaining a copy 17 ;; of this software and associated documentation files (the "Software"), to deal 18 ;; in the Software without restriction, including without limitation the rights 19 ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 20 ;; copies of the Software, and to permit persons to whom the Software is 21 ;; furnished to do so, subject to the following conditions: 22 23 ;; The above copyright notice and this permission notice shall be included in 24 ;; all copies or substantial portions of the Software. 25 26 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 27 ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 28 ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 29 ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 30 ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 31 ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 32 ;; SOFTWARE. 33 34 (local fennel (require :fennel)) 35 36 ;;; helper functions 37 38 (local unpack (or table.unpack _G.unpack)) 39 40 (fn now [] 41 {:real (or (and (pcall require :socket) 42 (package.loaded.socket.gettime)) 43 (and (pcall require :posix) 44 (package.loaded.posix.gettimeofday) 45 (let [t (package.loaded.posix.gettimeofday)] 46 (+ t.sec (/ t.usec 1000000)))) 47 nil) 48 :approx (os.time) 49 :cpu (os.clock)}) 50 51 (fn result-table [name] 52 {:started-at (now) :err [] :fail [] : name :pass [] :skip [] :ran 0 :tests []}) 53 54 (fn combine-results [to from] 55 (each [_ s (ipairs [:pass :fail :skip :err])] 56 (each [name val (pairs (. from s))] 57 (tset (. to s) name val)))) 58 59 (fn fn? [v] (= (type v) :function)) 60 61 (fn count [t] (accumulate [c 0 _ (pairs t)] (+ c 1))) 62 63 (fn fail->string [{: where : reason : msg} name] 64 (string.format "FAIL: %s: %s\n %s%s\n" 65 where name (or reason "") 66 (or (and msg (.. " - " (tostring msg))) ""))) 67 68 (fn err->string [{: msg} name] 69 (or msg (string.format "ERROR (in %s, couldn't get traceback)" 70 (or name "(unknown)")))) 71 72 (fn get-where [start] 73 (let [traceback (fennel.traceback nil start) 74 (_ _ where) (traceback:find "\n *([^:]+:[0-9]+):")] 75 (or where "?"))) 76 77 ;;; assertions 78 79 ;; while I'd prefer to remove all top-level state, this one is difficult 80 ;; because it has to be set by every assertion, and the assertion functions 81 ;; themselves do not have access to any stateful arguments given that they 82 ;; are called directly from user code. 83 (var checked 0) 84 85 (macro wrap [flag msg ...] 86 `(do (set ,(sym :checked) (+ ,(sym :checked) 1)) 87 (when (not ,flag) 88 (error {:char "F" :type :fail :tostring fail->string 89 :reason (string.format ,...) :msg ,msg :where (get-where 4)})))) 90 91 (fn pass [] {:char "." :type :pass}) 92 93 (fn error-result [msg] {:char "E" :type :err :tostring err->string :msg msg}) 94 95 (fn skip [] 96 (error {:char :s :type :skip})) 97 98 (fn is [got ?msg] 99 (wrap got ?msg "Expected truthy value")) 100 101 (fn error-match [pat f ?msg] 102 (case (pcall f) 103 (true ?val) (wrap false ?msg "Expected an error, got %s" (fennel.view ?val)) 104 (_ err) (let [err-string (if (= (type err) :string) err (fennel.view err))] 105 (wrap (: err-string :match pat) ?msg 106 "Expected error to match pattern %s, was %s" 107 pat err-string)))) 108 109 (fn extra-fields? [t keys] 110 (or (accumulate [extra? false k (pairs t) &until extra?] 111 (if (= nil (. keys k)) 112 true 113 (tset keys k nil))) 114 (next keys))) 115 116 (fn table= [x y equal?] 117 (let [keys {}] 118 (and (accumulate [same? true k v (pairs x) &until (not same?)] 119 (do (tset keys k true) 120 (equal? v (. y k)))) 121 (not (extra-fields? y keys))))) 122 123 (fn equal? [x y] 124 (or (= x y) 125 (and (= (type x) :table (type y)) (table= x y equal?)))) 126 127 (fn =* [exp got ?msg] 128 (wrap (equal? exp got) ?msg "Expected %s, got %s" 129 (fennel.view exp) (fennel.view got))) 130 131 (fn not=* [exp got ?msg] 132 (wrap (not (equal? exp got)) ?msg "Expected something other than %s" 133 (fennel.view exp))) 134 135 (fn <* [...] 136 (let [args [...] 137 msg (if (= :string (type (. args (length args)))) (table.remove args)) 138 correct? (faccumulate [ok? true i 2 (length args) &until (not ok?)] 139 (< (. args (- i 1)) (. args i)))] 140 (wrap correct? msg 141 "Expected arguments in strictly increasing order, got %s" 142 (fennel.view args)))) 143 144 (fn <=* [...] 145 (let [args [...] 146 msg (if (= :string (type (. args (length args)))) (table.remove args)) 147 correct? (faccumulate [ok? true i 2 (length args) &until (not ok?)] 148 (<= (. args (- i 1)) (. args i)))] 149 (wrap correct? msg 150 "Expected arguments in increasing/equal order, got %s" 151 (fennel.view args)))) 152 153 (fn almost= [exp got tolerance ?msg] 154 (wrap (<= (math.abs (- exp got)) tolerance) ?msg 155 "Expected %s +/- %s, got %s" exp tolerance got)) 156 157 (fn identical [exp got ?msg] 158 (wrap (= exp got) ?msg 159 "Expected %s, got %s" (fennel.view exp) (fennel.view got))) 160 161 (fn match* [pat s ?msg] 162 (wrap (: (tostring s) :match pat) ?msg 163 "Expected string to match pattern %s, was\n%s" pat s)) 164 165 (fn not-match [pat s ?msg] 166 (wrap (or (not= (type s) :string) (not (s:match pat))) ?msg 167 "Expected string not to match pattern %s, was\n %s" pat s)) 168 169 ;;; running 170 171 (fn dot [c ran] 172 (io.write c) 173 (when (= 0 (math.fmod ran 76)) 174 (io.write "\n")) 175 (io.stdout:flush)) 176 177 (fn print-totals [{: pass : fail : skip : err : started-at : ended-at}] 178 (let [duration (fn [start end] 179 (let [decimal-places 2] 180 (: (.. "%." (tonumber decimal-places) "f") 181 :format 182 (math.max (- end start) 183 (^ 10 (- decimal-places))))))] 184 (print (: (.. "Testing finished %s with %d assertion(s)\n" 185 "%d passed, %d failed, %d error(s), %d skipped\n" 186 "%.2f second(s) of CPU time used") 187 :format 188 (if started-at.real 189 (: "in %s second(s)" :format 190 (duration started-at.real ended-at.real)) 191 (: "in approximately %s second(s)" :format 192 (- ended-at.approx started-at.approx))) 193 checked 194 (count pass) (count fail) (count err) (count skip) 195 (duration started-at.cpu ended-at.cpu))))) 196 197 (fn begin-module [s-env tests] 198 (print (string.format "\nStarting module %s with %d test(s)" 199 s-env.name (count tests)))) 200 (fn done [results] 201 (print "\n") 202 (each [_ ts (ipairs [results.fail results.err results.skip])] 203 (each [name result (pairs ts)] 204 (when result.tostring (print (result:tostring name))))) 205 (print-totals results)) 206 207 (local default-hooks {:begin false 208 : done 209 : begin-module 210 :end-module false 211 :begin-test false 212 :end-test (fn [_name result ran] (dot result.char ran))}) 213 214 (fn test-key? [k] 215 (and (= (type k) :string) (k:match :^test.*))) 216 217 (local ok-types {:fail true :pass true :skip true}) 218 219 (fn err-handler [name] 220 (fn [e] 221 (if (and (= (type e) :table) (. ok-types e.type)) 222 e 223 (error-result (-> (string.format "\nERROR: %s:\n%s\n" name e) 224 (fennel.traceback 4)))))) 225 226 (fn run-test [name ?setup test ?teardown module-result hooks context] 227 (when (fn? hooks.begin-test) (hooks.begin-test name)) 228 (let [started-at (now) 229 result (case-try (if ?setup (xpcall ?setup (err-handler name)) true) 230 true (xpcall #(test (unpack context)) (err-handler name)) 231 true (pass) 232 (catch (_ err) err))] 233 (when ?teardown (pcall ?teardown (unpack context))) 234 (tset module-result result.type name result) 235 (set module-result.ran (+ module-result.ran 1)) 236 (when (fn? hooks.end-test) (hooks.end-test name result module-result.ran)))) 237 238 (fn run-setup-all [setup-all results module-name] 239 (if (fn? setup-all) 240 (case [(pcall setup-all)] 241 [true & context] context 242 [false err] (let [msg (: "ERROR in test module %s setup-all: %s" 243 :format module-name err)] 244 (tset results.err module-name (error-result msg)) 245 (values nil err))) 246 [])) 247 248 (fn run-module [hooks results module-name test-module] 249 (assert (= :table (type test-module)) (.. "test module must be table: " 250 module-name)) 251 (let [result (result-table module-name)] 252 (case (run-setup-all test-module.setup-all results module-name) 253 context (do 254 (when hooks.begin-module (hooks.begin-module result test-module)) 255 (each [name test (pairs test-module)] 256 (when (test-key? name) 257 (table.insert result.tests test) 258 (run-test name 259 test-module.setup 260 test 261 test-module.teardown 262 result 263 hooks 264 context))) 265 (case test-module.teardown-all 266 teardown (pcall teardown (unpack context))) 267 (when hooks.end-module (hooks.end-module result)) 268 (combine-results results result))))) 269 270 (fn exit [hooks] 271 (if hooks.exit (hooks.exit 1) 272 _G.___replLocals___ :failed 273 (and os os.exit) (os.exit 1))) 274 275 (fn run [module-names ?hooks] 276 (set checked 0) 277 (io.stdout:setvbuf :line) 278 ;; don't count load time against the test runtime 279 (each [_ m (ipairs module-names)] 280 (when (not (pcall require m)) 281 (tset package.loaded m nil))) 282 (let [hooks (setmetatable (or ?hooks {}) {:__index default-hooks}) 283 results (result-table :main)] 284 (when hooks.begin 285 (hooks.begin results module-names)) 286 (each [_ module-name (ipairs module-names)] 287 (case (pcall require module-name) 288 (true test-mod) (run-module hooks results module-name test-mod) 289 (false err) (tset results.err module-name 290 (error-result (: "ERROR: Cannot load %q:\n%s" 291 :format module-name err))))) 292 (set results.ended-at (now)) 293 (when hooks.done (hooks.done results)) 294 (when (or (next results.err) (next results.fail)) 295 (exit hooks)))) 296 297 (if (= ... "--tests") 298 (run (doto [...] (table.remove 1))) 299 {: run : skip :version "0.1.3-dev" 300 : is : error-match := =* :not= not=* :< <* :<= <=* : almost= 301 : identical :match match* : not-match})