! This file is part of xtb.
! SPDX-Identifier: LGPL-3.0-or-later
!
! xtb is free software: you can redistribute it and/or modify it under
! the terms of the GNU Lesser General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! xtb is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public License
! along with xtb.  If not, see <https://www.gnu.org/licenses/>.

!> Driver for unit testing
program tester
   use, intrinsic :: iso_fortran_env, only : error_unit
   use testdrive, only : new_testsuite, testsuite_type, select_suite, run_selected, &
      & get_argument, unittest_type, collect_interface, error_type
   use test_atomlist, only : collect_atomlist
   use test_coordinationnumber, only : collect_coordinationnumber
   use test_coulomb, only : collect_coulomb
   use test_dftd3, only : collect_dftd3
   use test_dftd4, only : collect_dftd4
   use test_docking, only : collect_docking
   use test_eeq, only : collect_eeq
   use test_gfn0, only : collect_gfn0
   use test_gfn1, only : collect_gfn1
   use test_gfn2, only : collect_gfn2
   use test_gfnff, only : collect_gfnff
   use test_hessian, only : collect_hessian
   use test_iff, only : collect_iff
   use test_latticepoint, only : collect_latticepoint
   use test_molecule, only : collect_molecule
   use test_oniom, only : collect_oniom
   use test_dipro, only : collect_dipro
   use test_pbc_tools, only : collect_pbc_tools
   use test_peeq, only : collect_peeq
   use test_ptb, only: collect_ptb
   use test_repulsion, only : collect_repulsion
   use test_symmetry, only : collect_symmetry
   use test_tblite, only : collect_tblite
   use test_thermo, only : collect_thermo
   use test_vertical, only : collect_fukui
   use test_wsc, only : collect_wsc
   use test_cpx, only : collect_cpx
   implicit none
   integer :: stat, is
   character(len=:), allocatable :: suite_name, test_name
   type(testsuite_type), allocatable :: testsuites(:)
   character(len=*), parameter :: fmt = '("#", *(1x, a))'

   call mctc_init('test',10,.true.)

   stat = 0

   testsuites = [ &
      new_testsuite("atomlist", collect_atomlist), &
      new_testsuite("coordinationnumber", collect_coordinationnumber), &
      new_testsuite("coulomb", collect_coulomb), &
      new_testsuite("dftd3", collect_dftd3), &
      new_testsuite("dftd4", collect_dftd4), &
      new_testsuite("docking", collect_docking), &
      new_testsuite("eeq", collect_eeq), &
      new_testsuite("gfn0", collect_gfn0), &
      new_testsuite("gfn1", collect_gfn1), &
      new_testsuite("gfn2", collect_gfn2), &
      new_testsuite("gfnff", collect_gfnff), &
      new_testsuite("hessian", collect_hessian), &
      new_testsuite("iff", collect_iff), &
      new_testsuite("latticepoint", collect_latticepoint), &
      new_testsuite("molecule", collect_molecule), &
      new_testsuite("oniom", collect_oniom), &
      new_testsuite("dipro", collect_dipro), &
      new_testsuite("pbc-tools", collect_pbc_tools), &
      new_testsuite("peeq", collect_peeq), &
      new_testsuite("ptb", collect_ptb), &
      new_testsuite("repulsion", collect_repulsion), &
      new_testsuite("symmetry", collect_symmetry), &
      new_testsuite("tblite", collect_tblite), &
      new_testsuite("thermo", collect_thermo), &
      new_testsuite("vertical", collect_fukui), &
      new_testsuite("wsc", collect_wsc), &
      new_testsuite("cpx", collect_cpx) &
      ]

   call get_argument(1, suite_name)
   call get_argument(2, test_name)

   if (allocated(suite_name)) then
      is = select_suite(testsuites, suite_name)
      if (is > 0 .and. is <= size(testsuites)) then
         if (allocated(test_name)) then
            write(error_unit, fmt) "Suite:", testsuites(is)%name
            call run_selected(testsuites(is)%collect, test_name, error_unit, stat)
            if (stat < 0) then
               error stop 1
            end if
         else
            write(error_unit, fmt) "Testing:", testsuites(is)%name
            call run_testsuite(testsuites(is)%collect, error_unit, stat)
         end if
      else
         write(error_unit, fmt) "Available testsuites"
         do is = 1, size(testsuites)
            write(error_unit, fmt) "-", testsuites(is)%name
         end do
         error stop 1
      end if
   else
      do is = 1, size(testsuites)
         write(error_unit, fmt) "Testing:", testsuites(is)%name
         call run_testsuite(testsuites(is)%collect, error_unit, stat)
      end do
   end if

   if (stat > 0) then
      write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
      error stop 1
   end if


contains

!> Driver for testsuite
subroutine run_testsuite(collect, unit, stat)

   !> Collect tests
   procedure(collect_interface) :: collect

   !> Unit for IO
   integer, intent(in) :: unit

   !> Number of failed tests
   integer, intent(inout) :: stat

   type(unittest_type), allocatable :: testsuite(:)
   integer :: it

   call collect(testsuite)

   do it = 1, size(testsuite)
      !$omp critical(testdrive_testsuite)
      write(unit, '(1x, 3(1x, a), 1x, "(", i0, "/", i0, ")")') &
         & "Starting", testsuite(it)%name, "...", it, size(testsuite)
      !$omp end critical(testdrive_testsuite)
      call run_unittest(testsuite(it), unit, stat)
   end do

end subroutine run_testsuite

!> Run a selected unit test
subroutine run_unittest(test, unit, stat)

   !> Unit test
   type(unittest_type), intent(in) :: test

   !> Unit for IO
   integer, intent(in) :: unit

   !> Number of failed tests
   integer, intent(inout) :: stat

   type(error_type), allocatable :: error
   character(len=:), allocatable :: message

   call test%test(error)
   if (.not.test_skipped(error) .and. allocated(error) .neqv. test%should_fail) then
      stat = stat + 1
   end if
   call make_output(message, test, error)
   !$omp critical(testdrive_testsuite)
   write(unit, '(a)') message
   !$omp end critical(testdrive_testsuite)
   if (allocated(error)) then
      call clear_error(error)
   end if

end subroutine run_unittest

!> Create output message for test (this procedure is pure and therefore cannot launch tests)
pure subroutine make_output(output, test, error)

   !> Output message for display
   character(len=:), allocatable, intent(out) :: output

   !> Unit test
   type(unittest_type), intent(in) :: test

   !> Error handling
   type(error_type), intent(in), optional :: error

   character(len=:), allocatable :: label
   character(len=*), parameter :: indent = repeat(" ", 7) // repeat(".", 3) // " "

   if (test_skipped(error)) then
      output = indent // test%name // " [SKIPPED]" &
         & // new_line("a") // "  Message: " // error%message
      return
   end if

   if (present(error) .neqv. test%should_fail) then
      if (test%should_fail) then
         label = " [UNEXPECTED PASS]"
      else
         label = " [FAILED]"
      end if
   else
      if (test%should_fail) then
         label = " [EXPECTED FAIL]"
      else
         label = " [PASSED]"
      end if
   end if
   output = indent // test%name // label
   if (present(error)) then
      output = output // new_line("a") // "  Message: " // error%message
   end if
end subroutine make_output

pure function test_skipped(error) result(is_skipped)

   !> Error handling
   type(error_type), intent(in), optional :: error

   !> Test was skipped
   logical :: is_skipped

   is_skipped = .false.
   if (present(error)) then
      is_skipped = error%stat == 77
   end if

end function test_skipped

!> Clear error type after it has been handled.
subroutine clear_error(error)

   !> Error handling
   type(error_type), intent(inout) :: error

   if (error%stat /= 0) then
      error%stat = 0
   end if

   if (allocated(error%message)) then
      deallocate(error%message)
   end if

end subroutine clear_error

end program tester

