ltest

(defmodule ltest
  (export all))

(include-lib "include/ltest-macros.lfe")
(include-lib "include/ltest-records.lfe")

(defun skip-test-patt () ".*_skip")
(defun skip-test-group-patt () "(.*)(_skip)")

;; XXX this code actually assumes two possible layouts for different versions of
;;     rebar; those paths don't belong in a general purpose library, but rather
;;     in a rebar3 plugin.
;;
;;     instead, there should be two path functions:
;;     - one that takes two arguments, a prefix and a regex, where the two are
;;       filename:joined and then pumped into filelib:wildcard, and
;;     - one that takes one argument, a regex, and then calls the two-arg
;;       function with a default (e.g., ".")
;;
;;     come to think of it, though, that also feels like a bad approach. it
;;     should just recurse through a given directory, and look for beam files.
;;     in a rebar3 plugin, the appropriate path can be computed.
;;
;;     so, some examination should be done of the latest rebar3 code, to see
;;     what public utility functions there are for locating beam files for a
;;     given app (or, in the case of releases, set of apps). That would mean
;;     we wouldn't need to do any wild-carding whatsoever ...
;;
;;     see XXX comment on `get-possible-test-beams` for more thoughts ...
;;
;;     related ticket: https://github.com/lfex/ltest/issues/61
;;
(defun get-subdir-beam-files (path)
  (ltest-util:rebar-debug "Getting subdir beams ..." '())
  (lists:append
    (list
      (filelib:wildcard (filename:join
        (list path ".eunit/*.beam")))
      (filelib:wildcard (filename:join
        (list path "_build/*/lib/*/ebin/*.beam"))))))

;; XXX do we need this? after examining the current rebar3 utils, we might not.
;;
;;     this library baiscally uses behaviours as "marker interfaces" and that's
;;     why we're jumping through all these hoops. so we should ask some basic
;;     questions:
;;
;;     - is there a better way to do this in Erlang/LFE? for example, eunit
;;       expects functions to have a particular suffix; we could do the same
;;       to distinguish unit, system, and integration tests
;;     - is there a more elegant way to check for a behaviour in a beam file?
;;     - does rebar3 offer some utility functions that do this better, that we
;;       can use?
;;
;;     related ticket: https://github.com/lfex/ltest/issues/61
;;
(defun get-possible-test-beams (path)
  "Get the compiled .beam files, but without the .beam extension. The list of
  files generated by this function are meant to be consumed by (code:load_abs)."
  (ltest-util:rebar-debug "Getting possible test beams ..." '())
  (lists:map
    #'filename:rootname/1
    (get-subdir-beam-files path)))

(defun get-integration-beams ()
  (get-integration-beams "."))

(defun get-integration-beams (path)
  (lists:filter
    #'integration?/1
    (get-possible-test-beams path)))

(defun get-system-beams ()
  (get-system-beams "."))

(defun get-system-beams (path)
  (ltest-util:rebar-debug "Getting system beams from ~p ..." `(,path))
  (lists:filter
    #'system?/1
    (get-possible-test-beams path)))

(defun get-unit-beams ()
  (get-unit-beams "."))

(defun get-unit-beams (path)
  (lists:filter
    #'unit?/1
    (get-possible-test-beams path)))

(defun has-behaviour? (beam type)
  (ltest-util:rebar-debug "Checking if ~p has behaviour ~p ..." `(,beam ,type))
  (lists:member
    type
    (ltest-util:get-beam-behaviours beam)))

(defun integration? (beam)
  (has-behaviour? beam 'ltest-integration))

(defun system? (beam)
  (has-behaviour? beam 'ltest-system))

(defun unit? (beam)
  (has-behaviour? beam 'ltest-unit))

(defun check-skip-funcs (funcs)
  (lists:map
    (match-lambda
      (((tuple func arity))
        (case (re:run (atom_to_list func) (skip-test-patt))
          ((tuple 'match _) `#(,func ,arity))
          (_ 'false))))
    funcs))

(defun check-skipped-tests (funcs)
  (lists:map
    (match-lambda
      (((tuple func arity))
        (case (re:split (atom_to_list func)
                        (++ (skip-test-group-patt))
                        '(#(return list)))
          ((list '() test-name _ '()) test-name)
          (_ 'false))))
    funcs))

(defun get-skip-funcs (module)
  (lists:filter
    #'check-skip-funcs/1
    (ltest-util:get-module-exports module)))

(defun get-skipped-tests (module)
  (lists:filter
    #'check-skipped-tests/1
    (ltest-util:get-module-exports module)))

(defun check-failed-assert (data expected)
  "This function
    1) unwraps the data held in the error result returned by a failed
       assertion, and
    2) checks the buried failure type against an expected value, asserting
       that they are the same."
  (let ((`#(,failure-type ,_) data))
    (is-equal failure-type expected)))

(defun check-wrong-assert-exception (data expected)
  "This function
    1) unwraps the data held in the error result returned by
       assert-exception when an unexpected error occurs, and
    2) checks the buried failure type against an expected value, asserting
       that they are the same."
  (let* ((reason (assert-exception-failed))
         (`#(,reason (,_ ,_ ,_ ,_ #(,fail-type ,_))) data))
    (is-equal fail-type expected)))

;;; New API for running tests
;;;
;;; Each of the following functions takes an options data structure as its single
;;; argument. The options are of this form:
;;;
;;; #m(color         boolean
;;;    suite-headers boolean
;;;    test-listener atom    ; one of ltest-listener, eunit_surefire
;;;    test-type     atom    ; one of all, unit, system, integration
;;;    verbose       boolean ; only applicable to eunit_surefire
;;;
(defun run ()
  (run (default-opts)))

(defun run
  (((= `#m(test-type all) opts))
   (all opts))
  (((= `#m(test-type unit) opts))
   (unit opts))
  (((= `#m(test-type system) opts))
   (system opts))
  (((= `#m(test-type integration) opts))
   (integration opts))
  ((`#m(test-type ,test-type))
   `#(error ,(io_lib:format "Unknown test type: ~p" `(,test-type)))))

(defun all ()
  (all (default-opts)))

(defun all (opts)
  (let* ((merged-opts (maps:merge (default-opts) opts))
         (test-opts (maps:merge merged-opts #m(suite-headers false)))
         (state (make-state color? (mref opts 'color))))
    (maybe-suite-header opts state)
    (unit (maps:merge test-opts #m(test-type unit)))
    (system (maps:merge test-opts #m(test-type system)))
    (integration (maps:merge test-opts #m(test-type integration)))
    (maybe-suite-footer opts state)))

(defun unit ()
  (unit (default-opts)))

(defun unit (opts)
  (ltest-util:rebar-debug "Running unit tests ..." '())
  (ltest-util:rebar-debug "Got opts: ~p~n" `(,opts))
  (let ((state (make-state color? (mref opts 'color)
                           test-type 'unit)))
    (ltest-util:rebar-debug "Got state: ~p~n" `(,state))
    (maybe-suite-header opts state)
    (ltest-formatter:test-type-header "Unit Tests" state)
    (ltest-util:rebar-debug "Running beams ...~n" '())
    (run-beams 'unit #'get-unit-beams/1 opts)
    (maybe-suite-footer opts state)))

(defun system ()
  (system (default-opts)))

(defun system (opts)
  (ltest-util:rebar-debug "Running system tests ..." '())
  (let ((state (make-state color? (mref opts 'color)
                           test-type 'system)))
    (maybe-suite-header opts state)
    (ltest-formatter:test-type-header "System Tests" state)
    (run-beams 'unit #'get-system-beams/1 opts)
    (maybe-suite-footer opts state)))

(defun integration ()
  (integration (default-opts)))

(defun integration (opts)
  (ltest-util:rebar-debug "Running integration tests ..." '())
  (let ((state (make-state color? (mref opts 'color)
                           test-type 'integration)))
    (maybe-suite-header opts state)
    (ltest-formatter:test-type-header "Integration Tests" state)
    (run-beams 'unit #'get-integration-beams/1 opts)
    (maybe-suite-footer opts state)))

;;; New API support functions

(defun default-opts ()
  #m(color true
     suite-headers true
     test-listener ltest-listener
     test-type unit
     verbose true))

(defun maybe-suite-header (opts state)
  (if (mref opts 'suite-headers)
    (ltest-formatter:test-suite-header state)))

(defun maybe-suite-footer (opts state)
  (if (mref opts 'suite-headers)
    (ltest-formatter:test-suite-footer state)))

(defun eunit-opts (opts)
  (let* ((listener (mref opts 'test-listener))
         (tty (case listener
                ('eunit_surefire '())
                (_ '(no_tty))))
         (verbose (if (and (== listener 'eunit_surefire)
                           (mref opts 'verbose))
                    '(verbose)
                    '()))
         (report `(#(report #(,listener ,(ltest-opts opts))))))
    (lists:append `(,tty ,verbose ,report))))

(defun ltest-opts (opts)
  `(#(color ,(mref opts 'color))
    #(test-type ,(mref opts 'test-type))))

(defun run-beams (test-type test-fn opts)
  (let* ((`#(ok ,cwd) (file:get_cwd))
         (beams (funcall test-fn cwd))
         (beam-files (ltest-util:beams->files beams)))
    (eunit:test beam-files (eunit-opts opts))))