Allow selective testing of single suites and tests

2 files changed, 239 insertions, 40 deletions

diff --git a/fpm/test/main.f90 b/fpm/test/main.f90
index f9d0941..0e4f156 100644
--- a/fpm/test/main.f90
+++ b/fpm/test/main.f90
@@ -1,36 +1,97 @@
 !> Driver for unit testing
 program fpm_testing
     use, intrinsic :: iso_fortran_env, only : error_unit
-    use testsuite, only : run_testsuite
+    use testsuite, only : run_testsuite, new_testsuite, testsuite_t, &
+        & select_suite, run_selected
     use test_toml, only : collect_toml
     use test_manifest, only : collect_manifest
     use test_source_parsing, only : collect_source_parsing
     implicit none
-    integer :: stat
+    integer :: stat, is
+    character(len=:), allocatable :: suite_name, test_name
+    type(testsuite_t), allocatable :: testsuite(:)
     character(len=*), parameter :: fmt = '("#", *(1x, a))'
 
-    write(error_unit, fmt) "Testing:", "fpm_toml"
-    call run_testsuite(collect_toml, error_unit, stat)
+    testsuite = [ &
+        & new_testsuite("fpm_toml", collect_toml), &
+        & new_testsuite("fpm_manifest", collect_manifest), &
+        & new_testsuite("fpm_source_parsing", collect_source_parsing) &
+        & ]
 
-    if (stat > 0) then
-        write(error_unit, '(i0, 1x, a)') stat, "tests failed!"
-        error stop 1
-    end if
+    call get_argument(1, suite_name)
+    call get_argument(2, test_name)
+
+    if (allocated(suite_name)) then
+        is = select_suite(testsuite, suite_name)
+        if (is > 0 .and. is <= size(testsuite)) then
+            if (allocated(test_name)) then
+                write(error_unit, fmt) "Suite:", testsuite(is)%name
+                call run_selected(testsuite(is)%collect, test_name, error_unit, stat)
+                if (stat == -1) then
+                    error stop 1
+                end if
+            else
+                write(error_unit, fmt) "Testing:", testsuite(is)%name
+                call run_testsuite(testsuite(is)%collect, error_unit, stat)
+            end if
 
-    write(error_unit, fmt) "Testing:", "fpm_manifest"
-    call run_testsuite(collect_manifest, error_unit, stat)
+            if (stat > 0) then
+                write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
+                error stop 1
+            end if
+        else
+            write(error_unit, fmt) "Available testsuites"
+            do is = 1, size(testsuite)
+                write(error_unit, fmt) "-", testsuite(is)%name
+            end do
+            error stop 1
+        end if
+    else
+        do is = 1, size(testsuite)
+            write(error_unit, fmt) "Testing:", testsuite(is)%name
+            call run_testsuite(testsuite(is)%collect, error_unit, stat)
 
-    if (stat > 0) then
-        write(error_unit, '(i0, 1x, a)') stat, "tests failed!"
-        error stop 1
+            if (stat > 0) then
+                write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
+                error stop 1
+            end if
+        end do
     end if
 
-    write(error_unit, fmt) "Testing:", "fpm_sources (parsing)"
-    call run_testsuite(collect_source_parsing, error_unit, stat)
 
-    if (stat > 0) then
-        write(error_unit, '(i0, 1x, a)') stat, "tests failed!"
-        error stop 1
-    end if
+contains
+
+
+    !> Obtain the command line argument at a given index
+    subroutine get_argument(idx, arg)
+
+        !> Index of command line argument, range [0:command_argument_count()]
+        integer, intent(in) :: idx
+
+        !> Command line argument
+        character(len=:), allocatable, intent(out) :: arg
+
+        integer :: length, stat
+
+        call get_command_argument(idx, length=length, status=stat)
+        if (stat /= 0) then
+            return
+        endif
+
+        allocate(character(len=length) :: arg, stat=stat)
+        if (stat /= 0) then
+            return
+        endif
+
+        if (length > 0) then
+            call get_command_argument(idx, arg, status=stat)
+            if (stat /= 0) then
+                deallocate(arg)
+                return
+            end if
+        end if
+
+    end subroutine get_argument
+
 
 end program fpm_testing
diff --git a/fpm/test/testsuite.f90 b/fpm/test/testsuite.f90
index 9b69032..4e46217 100644
--- a/fpm/test/testsuite.f90
+++ b/fpm/test/testsuite.f90
@@ -4,9 +4,10 @@ module testsuite
     implicit none
     private
 
-    public :: run_testsuite, new_unittest, test_failed
+    public :: run_testsuite, run_selected, new_unittest, new_testsuite, test_failed
+    public :: select_test, select_suite
     public :: check_string
-    public :: unittest_t, error_t
+    public :: unittest_t, testsuite_t, error_t
 
 
     abstract interface
@@ -48,6 +49,22 @@ module testsuite
     end interface
 
 
+    !> Collection of unit tests
+    type :: testsuite_t
+
+        !> Name of the testsuite
+        character(len=:), allocatable :: name
+
+        !> Entry point of the test
+        procedure(collect_interface), pointer, nopass :: collect => null()
+
+    end type testsuite_t
+
+
+    character(len=*), parameter :: fmt = '("#", *(1x, a))'
+    character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3)
+
+
 contains
 
 
@@ -64,9 +81,6 @@ contains
         integer, intent(out) :: stat
 
         type(unittest_t), allocatable :: testsuite(:)
-        character(len=*), parameter :: fmt = '("#", *(1x, a))'
-        character(len=*), parameter :: indent = repeat(" ", 5) // repeat(".", 3)
-        type(error_t), allocatable :: error
         integer :: ii
 
         stat = 0
@@ -76,27 +90,133 @@ contains
         do ii = 1, size(testsuite)
             write(unit, '("#", 3(1x, a), 1x, "(", i0, "/", i0, ")")') &
                 & "Starting", testsuite(ii)%name, "...", ii, size(testsuite)
-            call testsuite(ii)%test(error)
-            if (allocated(error) .neqv. testsuite(ii)%should_fail) then
-                if (testsuite(ii)%should_fail) then
-                    write(unit, fmt) indent, testsuite(ii)%name, "[UNEXPECTED PASS]"
-                else
-                    write(unit, fmt) indent, testsuite(ii)%name, "[FAILED]"
-                end if
-                stat = stat + 1
+            call run_unittest(testsuite(ii), unit, stat)
+        end do
+
+    end subroutine run_testsuite
+
+
+    !> Driver for selective testing
+    subroutine run_selected(collect, name, unit, stat)
+
+        !> Collect tests
+        procedure(collect_interface) :: collect
+
+        !> Name of the selected test
+        character(len=*), intent(in) :: name
+
+        !> Unit for IO
+        integer, intent(in) :: unit
+
+        !> Number of failed tests
+        integer, intent(out) :: stat
+
+        type(unittest_t), allocatable :: testsuite(:)
+        integer :: ii
+
+        stat = 0
+
+        call collect(testsuite)
+
+        ii = select_test(testsuite, name)
+
+        if (ii > 0 .and. ii <= size(testsuite)) then
+            call run_unittest(testsuite(ii), unit, stat)
+        else
+            write(unit, fmt) "Available tests:"
+            do ii = 1, size(testsuite)
+                write(unit, fmt) "-", testsuite(ii)%name
+            end do
+            stat = -1
+        end if
+
+    end subroutine run_selected
+
+
+    !> Run a selected unit test
+    subroutine run_unittest(test, unit, stat)
+
+        !> Unit test
+        type(unittest_t), intent(in) :: test
+
+        !> Unit for IO
+        integer, intent(in) :: unit
+
+        !> Number of failed tests
+        integer, intent(inout) :: stat
+
+        type(error_t), allocatable :: error
+
+        call test%test(error)
+        if (allocated(error) .neqv. test%should_fail) then
+            if (test%should_fail) then
+                write(unit, fmt) indent, test%name, "[UNEXPECTED PASS]"
             else
-                if (testsuite(ii)%should_fail) then
-                    write(unit, fmt) indent, testsuite(ii)%name, "[EXPECTED FAIL]"
-                else
-                    write(unit, fmt) indent, testsuite(ii)%name, "[PASSED]"
-                end if
+                write(unit, fmt) indent, test%name, "[FAILED]"
             end if
-            if (allocated(error)) then
-                write(unit, fmt) "Message:", error%message
+            stat = stat + 1
+        else
+            if (test%should_fail) then
+                write(unit, fmt) indent, test%name, "[EXPECTED FAIL]"
+            else
+                write(unit, fmt) indent, test%name, "[PASSED]"
+            end if
+        end if
+        if (allocated(error)) then
+            write(unit, fmt) "Message:", error%message
+        end if
+
+    end subroutine run_unittest
+
+
+    !> Select a unit test from all available tests
+    function select_test(tests, name) result(pos)
+
+        !> Name identifying the test suite
+        character(len=*), intent(in) :: name
+
+        !> Available unit tests
+        type(unittest_t) :: tests(:)
+
+        !> Selected test suite
+        integer :: pos
+
+        integer :: it
+
+        pos = 0
+        do it = 1, size(tests)
+            if (name == tests(it)%name) then
+                pos = it
+                exit
             end if
         end do
 
-    end subroutine run_testsuite
+    end function select_test
+
+
+    !> Select a test suite from all available suites
+    function select_suite(suites, name) result(pos)
+
+        !> Name identifying the test suite
+        character(len=*), intent(in) :: name
+
+        !> Available test suites
+        type(testsuite_t) :: suites(:)
+
+        !> Selected test suite
+        integer :: pos
+
+        integer :: it
+
+        pos = 0
+        do it = 1, size(suites)
+            if (name == suites(it)%name) then
+                pos = it
+                exit
+            end if
+        end do
+
+    end function select_suite
 
 
     !> Register a new unit test
@@ -121,6 +241,24 @@ contains
     end function new_unittest
 
 
+    !> Register a new testsuite
+    function new_testsuite(name, collect) result(self)
+
+        !> Name of the testsuite
+        character(len=*), intent(in) :: name
+
+        !> Entry point to collect tests
+        procedure(collect_interface) :: collect
+
+        !> Newly registered testsuite
+        type(testsuite_t) :: self
+
+        self%name = name
+        self%collect => collect
+
+    end function new_testsuite
+
+
     !> Check a deferred length character variable against a reference value
     subroutine check_string(error, actual, expected, name)