Unit tests

README.md

@@ -49,23 +49,23 @@ function, if called with no statements.
 
 (add 1 2) ; returns 3
 
-(local iseven (def [uint32 : bool]))
-(local isodd (def [n uint32 : bool]
-    (if (= n 0) 
-        (return true)
-        (return (iseven (- n 1))))))
-(iseven:adddefinition (def [n uint32 : bool]
+(local even? (def [uint32 : bool]))
+(local odd? (def [n uint32 : bool]
     (if (= n 0) 
         (return false)
-        (return (isodd (- n 1))))))
+        (return (even? (- n 1))))))
+(even?:adddefinition (def [n uint32 : bool]
+    (if (= n 0)
+        (return true)
+        (return (odd? (- n 1))))))
 
 ; compiles to: 
-; local terra iseven :: { uint32 } -> { bool }
-; local isodd = terra(n : uint32) : { bool }
-;   if n == 0 then return true else return iseven(n - 1) end
+; local terra even_3f :: { uint32 } -> { bool }
+; local odd_3f = terra(n : uint32) : { bool }
+;   if n == 0 then return true else return even_3f(n - 1) end
 ; end
-; iseven:adddefinition(terra(n : uint32) : { bool }
-;   if n == 0 then return false else return isodd(n - 1) end
+; even_3f:adddefinition(terra(n : uint32) : { bool }
+;   if n == 0 then return false else return odd_3f(n - 1) end
 ; end)
 ```
 

boot.t

@@ -4,8 +4,14 @@ _G.___repl___ = nil
 _G.___replLocals___ = nil
 _G._ = nil
 _G.__ = nil
+_G._1 = nil
+_G._2 = nil
+_G._3 = nil
 
 debug.traceback = fennel.traceback
 table.insert(package.loaders, fennel.searcher)
 
-fennel.repl()
+if arg[0] == "boot.t" then
+    fennel.repl()
+end
+

faith.fnl

@@ -0,0 +1,302 @@
+;;; faith.fnl --- The Fennel Advanced Interactive Test Helper
+
+;; https://git.sr.ht/~technomancy/faith
+
+;; SPDX-License-Identifier: MIT
+;; SPDX-FileCopyrightText: Scott Vokes, Phil Hagelberg, and contributors
+
+;; To use Faith, create a test runner file which calls the `run` function with
+;; a list of module names. The modules should export functions whose
+;; names start with `test-` and which call the assertion functions in the
+;; `faith` module.
+
+;; Copyright © 2009-2013 Scott Vokes and contributors
+;; Copyright © 2023 Phil Hagelberg and contributors
+
+;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;; of this software and associated documentation files (the "Software"), to deal
+;; in the Software without restriction, including without limitation the rights
+;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;; copies of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be included in
+;; all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(local fennel (require :fennel))
+
+;;; helper functions
+
+(local unpack (or table.unpack _G.unpack))
+
+(fn now []
+  {:real (or (and (pcall require :socket)
+                  (package.loaded.socket.gettime))
+             (and (pcall require :posix)
+                  (package.loaded.posix.gettimeofday)
+                  (let [t (package.loaded.posix.gettimeofday)]
+                    (+ t.sec (/ t.usec 1000000))))
+             nil)
+   :approx (os.time)
+   :cpu (os.clock)})
+
+(fn result-table [name]
+  {:started-at (now) :err [] :fail [] : name :pass [] :skip [] :ran 0 :tests []})
+
+(fn combine-results [to from]
+  (each [_ s (ipairs [:pass :fail :skip :err])]
+    (each [name val (pairs (. from s))]
+      (tset (. to s) name val))))
+
+(fn fn? [v] (= (type v) :function))
+
+(fn count [t] (accumulate [c 0 _ (pairs t)] (+ c 1)))
+
+(fn fail->string [{: where : reason : msg} name]
+  (string.format "FAIL: %s: %s\n  %s%s\n"
+                 where name (or reason "")
+                 (or (and msg (.. " - " (tostring msg))) "")))
+
+(fn err->string [{: msg} name]
+  (or msg (string.format "ERROR (in %s, couldn't get traceback)"
+                         (or name "(unknown)"))))
+
+(fn get-where [start]
+  (let [traceback (fennel.traceback nil start)
+        (_ _ where) (traceback:find "\n *([^:]+:[0-9]+):")]
+    (or where "?")))
+
+;;; assertions
+
+;; while I'd prefer to remove all top-level state, this one is difficult
+;; because it has to be set by every assertion, and the assertion functions
+;; themselves do not have access to any stateful arguments given that they
+;; are called directly from user code.
+(var checked 0)
+
+(macro wrap [flag msg ...]
+  `(do (set ,(sym :checked) (+ ,(sym :checked) 1))
+       (when (not ,flag)
+         (error {:char "F" :type :fail :tostring fail->string
+                 :reason (string.format ,...) :msg ,msg :where (get-where 4)}))))
+
+(fn pass [] {:char "." :type :pass})
+
+(fn error-result [msg] {:char "E" :type :err :tostring err->string :msg msg})
+
+(fn skip []
+  (error {:char :s :type :skip}))
+
+(fn is [got ?msg]
+  (wrap got ?msg "Expected truthy value"))
+
+(fn error* [pat f ?msg]
+  (case (pcall f)
+    (true ?val) (wrap false ?msg "Expected an error, got %s" (fennel.view ?val))
+    (_ err) (let [err-string (if (= (type err) :string) err (fennel.view err))]
+              (wrap (err-string:match pat) ?msg
+                    "Expected error to match pattern %s, was %s"
+                    pat err-string))))
+
+(fn extra-fields? [t keys]
+  (or (accumulate [extra? false k (pairs t) &until extra?]
+        (if (= nil (. keys k))
+            true
+            (tset keys k nil)))
+      (next keys)))
+
+(fn table= [x y equal?]
+  (let [keys {}]
+    (and (accumulate [same? true k v (pairs x) &until (not same?)]
+           (do (tset keys k true)
+               (equal? v (. y k))))
+         (not (extra-fields? y keys)))))
+
+(fn equal? [x y]
+  (or (= x y)
+      (and (= (type x) :table (type y)) (table= x y equal?))))
+
+(fn =* [exp got ?msg]
+  (wrap (equal? exp got) ?msg "Expected %s, got %s"
+        (fennel.view exp) (fennel.view got)))
+
+(fn not=* [exp got ?msg]
+  (wrap (not (equal? exp got)) ?msg "Expected something other than %s"
+        (fennel.view exp)))
+
+(fn <* [...]
+  (let [args [...]
+        msg (if (= :string (type (. args (length args)))) (table.remove args))
+        correct? (faccumulate [ok? true i 2 (length args) &until (not ok?)]
+                   (< (. args (- i 1)) (. args i)))]
+    (wrap correct? msg
+          "Expected arguments in strictly increasing order, got %s"
+          (fennel.view args))))
+
+(fn <=* [...]
+  (let [args [...]
+        msg (if (= :string (type (. args (length args)))) (table.remove args))
+        correct? (faccumulate [ok? true i 2 (length args) &until (not ok?)]
+                   (<= (. args (- i 1)) (. args i)))]
+    (wrap correct? msg
+          "Expected arguments in increasing/equal order, got %s"
+          (fennel.view args))))
+
+(fn almost= [exp got tolerance ?msg]
+  (wrap (<= (math.abs (- exp got)) tolerance) ?msg
+        "Expected %s +/- %s, got %s" exp tolerance got))
+
+(fn identical [exp got ?msg]
+  (wrap (= exp got) ?msg
+        "Expected %s, got %s" (fennel.view exp) (fennel.view got)))
+
+(fn match* [pat s ?msg]
+  (wrap (: (tostring s) :match pat) ?msg
+        "Expected string to match pattern %s, was\n%s" pat s))
+
+(fn not-match [pat s ?msg]
+  (wrap (or (not= (type s) :string) (not (s:match pat))) ?msg
+        "Expected string not to match pattern %s, was\n %s" pat s))
+
+;;; running
+
+(fn dot [c ran]
+  (io.write c)
+  (when (= 0 (math.fmod ran 76))
+    (io.write "\n"))
+  (io.stdout:flush))
+
+(fn print-totals [{: pass : fail : skip : err : started-at : ended-at}]
+  (let [duration (fn [start end]
+                   (let [decimal-places 2]
+                     (: (.. "%." (tonumber decimal-places) "f")
+                        :format
+                        (math.max (- end start)
+                                  (^ 10 (- decimal-places))))))]
+    (print (: (.. "Testing finished %s with %d assertion(s)\n"
+                  "%d passed, %d failed, %d error(s), %d skipped\n"
+                  "%.2f second(s) of CPU time used")
+              :format
+              (if started-at.real
+                  (: "in %s second(s)" :format
+                     (duration started-at.real ended-at.real))
+                  (: "in approximately %s second(s)" :format
+                     (- ended-at.approx started-at.approx)))
+              checked
+              (count pass) (count fail) (count err) (count skip)
+              (duration started-at.cpu ended-at.cpu)))))
+
+(fn begin-module [s-env tests]
+  (print (string.format "\nStarting module %s with %d test(s)"
+                        s-env.name (count tests))))
+(fn done [results]
+  (print "\n")
+  (each [_ ts (ipairs [results.fail results.err results.skip])]
+    (each [name result (pairs ts)]
+      (when result.tostring (print (result:tostring name)))))
+  (print-totals results))
+
+(local default-hooks {:begin false
+                      : done
+                      : begin-module
+                      :end-module false
+                      :begin-test false
+                      :end-test (fn [_name result ran] (dot result.char ran))})
+
+(fn test-key? [k]
+  (and (= (type k) :string) (k:match :^test.*)))
+
+(local ok-types {:fail true :pass true :skip true})
+
+(fn err-handler [name]
+  (fn [e]
+    (if (and (= (type e) :table) (. ok-types e.type))
+        e
+        (error-result (-> (string.format "\nERROR: %s:\n%s\n" name e)
+                          (fennel.traceback 4))))))
+
+(fn run-test [name ?setup test ?teardown module-result hooks context]
+  (when (fn? hooks.begin-test) (hooks.begin-test name))
+  (let [result (case-try (if ?setup (xpcall ?setup (err-handler name)) true)
+                 true (xpcall #(test (unpack context)) (err-handler name))
+                 true (pass)
+                 (catch (_ err) err))]
+    (when ?teardown (pcall ?teardown (unpack context)))
+    (tset module-result result.type name result)
+    (set module-result.ran (+ module-result.ran 1))
+    (when (fn? hooks.end-test) (hooks.end-test name result module-result.ran))))
+
+(fn run-setup-all [setup-all results module-name]
+  (if (fn? setup-all)
+      (case [(pcall setup-all)]
+        [true & context] context
+        [false err] (let [msg (: "ERROR in test module %s setup-all: %s"
+                                 :format module-name err)]
+                      (tset results.err module-name (error-result msg))
+                      (values nil err)))
+      []))
+
+(fn run-module [hooks results module-name test-module]
+  (assert (= :table (type test-module)) (.. "test module must be table: "
+                                            module-name))
+  (let [result (result-table module-name)]
+    (case (run-setup-all test-module.setup-all results module-name)
+      context (do
+                (when hooks.begin-module (hooks.begin-module result test-module))
+                (each [name test (pairs test-module)]
+                  (when (test-key? name)
+                    (table.insert result.tests test)
+                    (run-test name
+                              test-module.setup
+                              test
+                              test-module.teardown
+                              result
+                              hooks
+                              context)))
+                (case test-module.teardown-all
+                  teardown (pcall teardown (unpack context)))
+                (when hooks.end-module (hooks.end-module result))
+                (combine-results results result)))))
+
+(fn exit [hooks]
+  (if hooks.exit (hooks.exit 1)
+      _G.___replLocals___ :failed
+      (and os os.exit) (os.exit 1)))
+
+(fn run [module-names ?hooks]
+  (set checked 0)
+  (io.stdout:setvbuf :line)
+  ;; don't count load time against the test runtime
+  (each [_ m (ipairs module-names)]
+    (when (not (pcall require m))
+      (tset package.loaded m nil)))
+  (let [hooks (setmetatable (or ?hooks {}) {:__index default-hooks})
+        results (result-table :main)]
+    (when hooks.begin
+      (hooks.begin results module-names))
+    (each [_ module-name (ipairs module-names)]
+      (case (pcall require module-name)
+        (true test-mod) (run-module hooks results module-name test-mod)
+        (false err) (tset results.err module-name
+                          (error-result (: "ERROR: Cannot load %q:\n%s"
+                                           :format module-name err)))))
+    (set results.ended-at (now))
+    (when hooks.done (hooks.done results))
+    (when (or (next results.err) (next results.fail))
+      (exit hooks))))
+
+(when (= ... "--tests")
+  (run (doto [...] (table.remove 1)))
+  (os.exit 0))
+
+{: run : skip :version "0.1.3-dev"
+ : is :error error* := =* :not= not=* :< <* :<= <=* : almost=
+ : identical :match match* : not-match}

terra.fnl

@@ -195,7 +195,7 @@
 (fn forms.do [stmts scope]
     (scope:with #(block :do stmts :end scope #(comp.expr $1 scope))))
 
-(fn forms.def [[arglist & stmts] scope]
+(fn comp.def [[arglist & stmts] scope]
     (if (> (length stmts) 0)
         (scope:with #(let [(in out) (split-arglist arglist)
                         argpairs (fcollect [i 1 (length in) 2] {:name (. in i) :type (. in (+ i 1))})
@@ -270,13 +270,15 @@
         (icollect [_ {: expr} (ipairs scope.input) &into call] expr)
         call))
 
-(fn terra [expr] (build expr comp.expr))
 (fn ttype [expr] (build expr comp.type))
-
-(fn def [...] (terra `(,(sym :def) ,...)))
-(fn q [...] (build [...] comp.quote))
+(fn tquote [...] (build [...] comp.quote))
+(fn def [...] (build [...] comp.def))
 (fn static [typ initial-value] (build [typ initial-value] comp.global))
 
-(fn printform [form] `(do (print ,(view (macroexpand form))) ,form))
+(fn compile [compiler-name expr] (build expr (. comp (tostring compiler-name))))
+(fn uncompile [compiler-name expr]
+    (let [scope (new-scope)
+          compiler (. comp (tostring compiler-name))]
+        (compiler expr scope)))
 
-{: terra : ttype : def : q : static : printform}
+{: ttype :q tquote : def : static : compile : uncompile}

test.t

@@ -0,0 +1,29 @@
+require "boot"
+
+local fennel = require "fennel"
+local t = require "faith"
+local ffi = require "ffi"
+
+local C = terralib.includecstring([[
+   #include <sys/types.h>
+   #include <dirent.h> 
+]])
+
+local testmodules = {}
+if #arg == 0 then
+    local testdir = C.opendir("test")
+    local dirent = C.readdir(testdir)
+
+    while dirent ~= nil do
+        local name = ffi.string(dirent.d_name)
+        local match = name:match("^(.+)%.fnl$")
+        if match then
+            table.insert(testmodules, "test." .. match)
+        end
+        dirent = C.readdir(testdir)
+    end
+    C.closedir(testdir)
+else
+    testmodules = arg
+end
+t.run(testmodules)

test/def.fnl

@@ -0,0 +1,27 @@
+(import-macros {: def : q : ttype : static} :terra)
+(local t (require :faith))
+
+(local tests {})
+
+(fn tests.test-primitive-ops []
+    (local add (def [x int y int : int]
+                    (return (+ x y))))
+    (t.= (add 1 2) 3))
+
+(fn tests.test-even-odd []
+    (local even? (def [uint32 : bool]))
+    (local odd? (def [n uint32 : bool]
+        (if (= n 0) 
+            (return false)
+            (return (even? (- n 1))))))
+    (even?:adddefinition (def [n uint32 : bool]
+        (if (= n 0)
+            (return true)
+            (return (odd? (- n 1))))))
+
+    (t.= (even? 4) true)
+    (t.= (even? 5) false)
+    (t.= (odd? 4) false)
+    (t.= (odd? 5) true))
+
+tests

test/types.fnl

@@ -0,0 +1,20 @@
+(import-macros {: def : q : ttype : static : compile : uncompile} :terra)
+(local t (require :faith))
+
+(local tests {})
+
+(fn tests.test-pointer []
+    (t.= :&int8  (tostring (ttype [int8])))
+    (t.= :&int8  (tostring (ttype (& int8))))
+    (t.= :&&int8 (tostring (ttype [[int8]])))
+    (t.= :&&int8 (tostring (ttype (& [int8]))))
+    (t.= :&&int8 (tostring (ttype (& (& int8))))))
+
+(fn tests.test-array []
+    (t.= "int32[16]" (tostring (ttype [int32 16]))))
+
+(fn tests.test-fnptr []
+    (t.= "&{&int8,int8} -> int8"
+         (tostring (ttype (-> [int8] int8 : int8)))))
+
+tests