diff --git a/README.md b/README.md index 7d4c590..8861dce 100644 --- a/README.md +++ b/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] +(local even? (def [uint32 : bool])) +(local odd? (def [n uint32 : bool] (if (= n 0) - (return true) - (return (iseven (- n 1)))))) -(iseven:adddefinition (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) ``` @@ -141,14 +141,14 @@ auto-convert `-` to `_` at least. ; compiles to: ; local Variant = struct { ; tag : int, -; union { +; union { ; number : float, ; string : &int8, ; complex : struct { ; real : float, ; imag : float ; } -; } +; } ; } ``` diff --git a/boot.t b/boot.t index d56e7dc..f6801fc 100644 --- a/boot.t +++ b/boot.t @@ -11,4 +11,7 @@ _G._3 = nil debug.traceback = fennel.traceback table.insert(package.loaders, fennel.searcher) -fennel.repl() +if arg[0] == "boot.t" then + fennel.repl() +end + diff --git a/faith.fnl b/faith.fnl new file mode 100644 index 0000000..c120d2d --- /dev/null +++ b/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} diff --git a/terra.fnl b/terra.fnl index 5d614b0..fceba10 100644 --- a/terra.fnl +++ b/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} \ No newline at end of file +{: ttype :q tquote : def : static : compile : uncompile} diff --git a/test.t b/test.t new file mode 100644 index 0000000..2da2cdf --- /dev/null +++ b/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 + #include +]]) + +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) diff --git a/test/def.fnl b/test/def.fnl new file mode 100644 index 0000000..f28e983 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/test/types.fnl b/test/types.fnl new file mode 100644 index 0000000..e57d273 --- /dev/null +++ b/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 \ No newline at end of file