forunittest.F90 – ForUnitTest

Files dependent on this one

Help
Source Code

module forunittest

   use, intrinsic :: iso_fortran_env, only: int32

   implicit none

   private

   public unit_tests, unit_test, rk, ik

#ifdef REAL32
   integer, parameter :: rk = selected_real_kind(6)
#elif REAL64
   integer, parameter :: rk = selected_real_kind(15)
#elif REALXDP
   integer, parameter :: rk = selected_real_kind(18)
#elif REAL128
   integer, parameter :: rk = selected_real_kind(33)
#else
   integer, parameter :: rk = selected_real_kind(15)
#endif

   integer, parameter :: ik = int32

   !===============================================================================
   !> author: Seyed Ali Ghasemi
   type unit_test
      character(len=64), private :: msg
      character(len=64), private :: name
      character(len=64), private :: group
      logical, private :: result = .false.
      logical, private :: silent = .false.
   contains
      procedure, private :: print_msg

      procedure, private :: unit_test_r0
      procedure, private :: unit_test_r1
      procedure, private :: unit_test_r2

      procedure, private :: unit_test_i0
      procedure, private :: unit_test_i1
      procedure, private :: unit_test_i2

      procedure, private :: unit_test_l0
      procedure, private :: unit_test_l1
      procedure, private :: unit_test_l2

      procedure, private :: unit_test_cx0
      procedure, private :: unit_test_cx1
      procedure, private :: unit_test_cx2

      generic :: check => unit_test_r0, unit_test_r1, unit_test_r2, &
         unit_test_i0, unit_test_i1, unit_test_i2, &
         unit_test_l0, unit_test_l1, unit_test_l2, &
         unit_test_cx0, unit_test_cx1, unit_test_cx2

      procedure, private :: set_silent
   end type unit_test
   !===============================================================================


   !===============================================================================
   type unit_tests
      type(unit_test), allocatable :: test(:)
      integer, private :: n = 0
   contains
      procedure :: initialize
      procedure :: summary
   end type unit_tests
   !===============================================================================

contains

   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine initialize(this, n)
      class(unit_tests), intent(inout) :: this
      integer, intent(in) :: n
      this%n = n
      allocate(this%test(this%n))
      call this%test(:)%set_silent()
   end subroutine initialize
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine summary(this, required_score, verbose, stop_fail)
      use face, only: colorize
      use, intrinsic :: iso_fortran_env, only: compiler_version, compiler_options

      class(unit_tests), intent(inout) :: this
      real,             intent(in)    :: required_score
      integer, optional, intent(in)   :: verbose
      logical, optional, intent(in)   :: stop_fail

      integer :: i, j
      integer :: n_passed, n_failed, n_groups, found_idx, bars
      integer :: name_w, group_w, msg_w, passed_w, total_w, bar_col, status_w, id_w
      logical :: do_test, do_group, do_stop
      real    :: score, rate
      character(len=64) :: test_name, test_msg
      character(len=:), allocatable :: comp_version, comp_options
      character(len=64), allocatable :: groups(:)
      character(len=64) :: grp
      character(len=8)  :: date_str
      character(len=10) :: time_str
      character(len=5)  :: zone_str
      character(len=6)  :: status_color
      character(len=100) :: fmt_string, hdr_line
      character(len=5)   :: success_label
      character(len=9)   :: bar_label
      integer, allocatable :: grp_total(:), grp_pass(:)
      character(len=*), parameter :: full_block = "█", light_block = "░"

      ! Determine verbosity
      do_test  = .false.
      do_group = .true.
      if (present(verbose)) then
         select case (verbose)
          case (0); do_test = .false.; do_group = .false.
          case (1); do_test = .false.; do_group = .true.
          case (2); do_test = .true.;  do_group = .false.
          case (3); do_test = .true.;  do_group = .true.
         case default; do_test = .false.; do_group = .true.
         end select
      end if

      do_stop = .false.; if (present(stop_fail)) do_stop = stop_fail

      n_passed = count(this%test(:)%result)
      n_failed = this%n - n_passed
      score = merge(100.0 * real(n_passed) / real(max(1, this%n)), 0.0, this%n > 0)

      call date_and_time(date=date_str, time=time_str, zone=zone_str)
      comp_version = compiler_version()
      comp_options = compiler_options()

      ! per-test summary
      if (do_test) then
         print "(A)", colorize("Per-test result summary:", color_fg="cyan")
         id_w    = 4
         name_w  = 4; group_w = 5; msg_w = 7; status_w = 6
         do i = 1, this%n
            name_w  = max(name_w,  len_trim(this%test(i)%name))
            group_w = max(group_w, len_trim(this%test(i)%group))
            msg_w   = max(msg_w,   len_trim(this%test(i)%msg))
         end do

         ! Print header
         print "(A)", "ID" // repeat(" ", id_w - 2 + 2) // &
            "NAME"  // repeat(" ", name_w - 4 + 2) // &
            "GROUP" // repeat(" ", group_w - 5 + 2) // &
            "MESSAGE" // repeat(" ", msg_w - 7 + 2) // "STATUS"

         ! Print separator line
         print "(A)", repeat("-", id_w + name_w + group_w + msg_w + status_w + 8)

         ! Print each test line
         do i = 1, this%n
            write(fmt_string, "(A,A,I0,A,I0,A,I0,A,I0,A,I0,A)") "(", "I", id_w, ",2X,A", name_w, ",2X,A", group_w, ",2X,A", msg_w, ",2X,A)"
            grp = trim(this%test(i)%group); if (grp == "") grp = "none"
            test_name = adjustl(this%test(i)%name)
            test_msg  = adjustl(this%test(i)%msg)
            status_color = merge("green", "red  ", this%test(i)%result)
            print fmt_string, i, test_name, adjustl(grp), test_msg, &
               colorize(merge("passed", "failed", this%test(i)%result), color_fg=status_color)
         end do
      end if

      ! per-group summary
      if (do_group) then
         print "(A)", ""
         print "(A)", colorize("Per-group test results:", color_fg="cyan")

         allocate(groups(this%n), grp_total(this%n), grp_pass(this%n))
         groups = ""; grp_total = 0; grp_pass = 0; n_groups = 0

         do i = 1, this%n
            grp = trim(this%test(i)%group); if (grp == "") grp = "none"
            found_idx = 0
            do j = 1, n_groups
               if (trim(grp) == trim(groups(j))) then
                  found_idx = j; exit
               end if
            end do
            if (found_idx == 0) then
               n_groups = n_groups + 1
               groups(n_groups) = grp
               grp_total(n_groups) = 1
               if (this%test(i)%result) grp_pass(n_groups) = 1
            else
               grp_total(found_idx) = grp_total(found_idx) + 1
               if (this%test(i)%result) grp_pass(found_idx) = grp_pass(found_idx) + 1
            end if
         end do

         group_w = 5; passed_w = 6; total_w = 5
         do i = 1, n_groups
            group_w  = max(group_w, len_trim(groups(i)))
            passed_w = max(passed_w, len_trim(adjustl(itoa(grp_pass(i)))))
            total_w  = max(total_w,  len_trim(adjustl(itoa(grp_total(i)))))
         end do

         write(fmt_string, "(A,I0,A,I0,A,I0,A)") &
            "(A", group_w, ",2X,I", passed_w, ",2X,I", total_w, ',2X,F6.1," %   ",A)'

         success_label = "SCORE"
         bar_label     = "SCORE BAR"

         hdr_line = "GROUP" // repeat(" ", group_w - 5 + 2) // &
            "PASSED" // repeat(" ", passed_w - 6 + 2) // &
            "TOTAL"  // repeat(" ", total_w - 5 + 3) // &
            success_label

         bar_col = group_w + 2 + passed_w + 2 + total_w + 2 + 11
         hdr_line = trim(hdr_line) // repeat(" ", max(1, bar_col - len_trim(hdr_line))) // bar_label

         print "(A)", hdr_line
         print "(A)", repeat("-", len_trim(hdr_line)+1)

         do i = 1, n_groups
            rate = merge(100.0 * real(grp_pass(i)) / grp_total(i), 0.0, grp_total(i) > 0)
            bars = min(10, int(rate / 10.0))
            print fmt_string, adjustl(groups(i)), grp_pass(i), grp_total(i), rate, &
               repeat(full_block, bars) // repeat(light_block, 10 - bars)
         end do

         deallocate(groups, grp_total, grp_pass)
      end if


      ! Final summary
      print "(A)", ""
      print "(A)", colorize("================== Tests Summary ==================", color_fg="cyan")
      print "(A,A)",      "Date:           ", date_str
      print "(A,A)",      "Time:           ", time_str(1:2)//":"//time_str(3:4)//":"//time_str(5:6)
      print "(A,A)",      "Compiler:       ", trim(comp_version)
      print "(A)", ""
      print "(A,I5)",     "Total tests:    ", this%n
      print "(A,I5)",     "Passed tests:   ", n_passed
      print "(A,I5)",     "Failed tests:   ", n_failed
      print "(A)", ""
      print "(A,F6.1,A)", "Score:          ", score, " %"
      print "(A,F6.1,A)", "Required score: ", required_score,  " %"

      bars = min(10, int(score / 10.0))
      print "(A,A)", "Score bar:      ", repeat(full_block, bars) // repeat(light_block, 10 - bars)

      if (score < required_score) then
         print "(A)", colorize("FAILED: Required score not met.", color_fg="red")
         print "(A)", ""
         print "(A)", colorize("ForUnitTest - https://github.com/gha3mi/forunittest", color_fg="cyan")
         print "(A)", colorize("===================================================", color_fg="cyan ")
         if (do_stop) stop 1
      else
         print "(A)", colorize("PASSED: Required score met.", color_fg="green")
         print "(A)", colorize("ForUnitTest - https://github.com/gha3mi/forunittest", color_fg="cyan")
         print "(A)", colorize("===================================================", color_fg="cyan ")
      end if

   contains
      pure function itoa(ii) result(str)
         integer, intent(in) :: ii
         character(len=32) :: str
         write(str, "(I0)") ii
         str = adjustl(str)
      end function itoa

   end subroutine summary
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine print_msg(this, result)
      use face, only: colorize
      class(unit_test), intent(inout) :: this
      logical, intent(in) :: result
      integer  :: lm
      character(len=20) :: fmt

      if (this%silent) return

      lm = 39-len_trim(this%msg)
      write(fmt,"(a,g0,a)") "(a,",lm,"x,a)"

      if (result) then
         print(fmt), trim(this%msg), colorize("passed.", color_fg="green")
      else
         print(fmt), trim(this%msg), colorize("failed.", color_fg="red")
      end if
   end subroutine print_msg
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   elemental subroutine set_silent(this)
      class(unit_test), intent(inout) :: this
      this%silent = .true.
   end subroutine set_silent
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_r0(this, res, expected, tol, msg, name, group)
      class(unit_test), intent(inout) :: this
      real(rk), intent(in) :: res, expected
      real(rk), intent(in), optional :: tol
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group
      real(rk) :: rel_err

      if (present(name)) then
         this%name = name
      else
         this%name = ""
      end if

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      if (abs(expected)<=tiny(0.0_rk)) then
         rel_err = abs(res-expected)
      else
         rel_err = abs(res-expected)/abs(expected)
      end if

      if (present(tol)) then
         this%result = rel_err <= tol
      else
         ! this%result = rel_err == 0.0_rk
         this%result = abs(rel_err) <= 2.0_rk*epsilon(0.0_rk)
      end if

      call this%print_msg(this%result)
   end subroutine unit_test_r0
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_r1(this, res, expected, tol, msg, name, group)
      class(unit_test), intent(inout) :: this
      real(rk), intent(in), dimension(:) :: res, expected
      real(rk), intent(in), optional :: tol
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group
      real(rk) :: rel_err

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      if (norm2(expected)<=tiny(0.0_rk)) then
         rel_err = norm2(res-expected)
      else
         rel_err = norm2(res-expected)/norm2(expected)
      end if

      if (present(tol)) then
         this%result = rel_err <= tol
      else
         ! this%result = rel_err == 0.0_rk
         this%result = abs(rel_err) <= 2.0_rk*epsilon(0.0_rk)
      end if

      call this%print_msg(this%result)
   end subroutine unit_test_r1
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_r2(this, res, expected, tol, msg, name, group)
      class(unit_test), intent(inout) :: this
      real(rk), intent(in), dimension(:,:) :: res, expected
      real(rk), intent(in), optional :: tol
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group
      real(rk) :: rel_err

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      if (norm2(expected)<=tiny(0.0_rk)) then
         rel_err = norm2(res-expected)
      else
         rel_err = norm2(res-expected)/norm2(expected)
      end if

      if (present(tol)) then
         this%result = rel_err <= tol
      else
         ! this%result = rel_err == 0.0_rk
         this%result = abs(rel_err) <= 2.0_rk*epsilon(0.0_rk)
      end if

      call this%print_msg(this%result)
   end subroutine unit_test_r2
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_i0(this, res, expected, msg, name, group)
      class(unit_test), intent(inout) :: this
      integer, intent(in) :: res, expected
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      this%result = res == expected

      call this%print_msg(this%result)
   end subroutine unit_test_i0
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_i1(this, res, expected, msg, name, group)
      class(unit_test), intent(inout) :: this
      integer, intent(in), dimension(:) :: res, expected
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      this%result = all(res == expected)

      call this%print_msg(this%result)
   end subroutine unit_test_i1
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_i2(this, res, expected, msg, name, group)
      class(unit_test), intent(inout) :: this
      integer, intent(in), dimension(:,:) :: res, expected
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      this%result = all(res == expected)

      call this%print_msg(this%result)
   end subroutine unit_test_i2
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_l0(this, res, expected, msg, name, group)
      class(unit_test), intent(inout) :: this
      logical, intent(in) :: res, expected
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      this%result = res .eqv. expected

      call this%print_msg(this%result)
   end subroutine unit_test_l0
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_l1(this, res, expected, msg, name, group)
      class(unit_test), intent(inout) :: this
      logical, intent(in), dimension(:) :: res, expected
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      this%result = all(res .eqv. expected)

      call this%print_msg(this%result)
   end subroutine unit_test_l1
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_l2(this, res, expected, msg, name, group)
      class(unit_test), intent(inout) :: this
      logical, intent(in), dimension(:,:) :: res, expected
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      this%result = all(res .eqv. expected)

      call this%print_msg(this%result)
   end subroutine unit_test_l2
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_cx0(this, res, expected, tol, msg, name, group)
      class(unit_test), intent(inout) :: this
      complex(rk), intent(in) :: res, expected
      real(rk), intent(in), optional :: tol
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group
      real(rk) :: rel_err

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      if (abs(expected)<=tiny(0.0_rk)) then
         rel_err = abs(res-expected)
      else
         rel_err = abs(res-expected)/abs(expected)
      end if

      if (present(tol)) then
         this%result = rel_err <= tol
      else
         ! this%result = rel_err == 0.0_rk
         this%result =abs(rel_err) <= 2.0_rk*epsilon(0.0_rk)
      end if

      call this%print_msg(this%result)
   end subroutine unit_test_cx0
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_cx1(this, res, expected, tol, msg, name, group)
      class(unit_test), intent(inout) :: this
      complex(rk), intent(in), dimension(:) :: res, expected
      real(rk), intent(in), optional :: tol
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group
      real(rk) :: rel_err_re, rel_err_im

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if

      if (norm2(real(expected,rk))<=tiny(0.0_rk)) then
         rel_err_re = norm2(real(res,rk)-real(expected,rk))
      else
         rel_err_re = norm2(real(res,rk)-real(expected,rk))/norm2(real(expected,rk))
      end if

      if (norm2(aimag(expected))<=tiny(0.0_rk)) then
         rel_err_im = norm2(aimag(res)-aimag(expected))
      else
         rel_err_im = norm2(aimag(res)-aimag(expected))/norm2(aimag(expected))
      end if

      if (present(tol)) then
         this%result = (rel_err_re <= tol) .and. (rel_err_im <= tol)
      else
         this%result = (rel_err_re <= tiny(0.0_rk)) .and. (rel_err_im <= tiny(0.0_rk))
      end if

      call this%print_msg(this%result)
   end subroutine unit_test_cx1
   !===============================================================================


   !===============================================================================
   !> author: Seyed Ali Ghasemi
   subroutine unit_test_cx2(this, res, expected, tol, msg, name, group)
      class(unit_test), intent(inout) :: this
      complex(rk), intent(in), dimension(:,:) :: res, expected
      real(rk), intent(in), optional :: tol
      character(*), intent(in), optional :: msg
      character(len=*), optional, intent(in) :: name
      character(len=*), optional, intent(in) :: group
      real(rk) :: rel_err_re, rel_err_im

      if (present(name)) then
         this%name = name
      else
         this%name = "none"
      end if

      if (present(msg)) then
         this%msg = msg
      else
         this%msg = "none"
      end if

      if (present(group)) then
         this%group = group
      else
         this%group = "none"
      end if
      if (norm2(real(expected,rk))<=tiny(0.0_rk)) then
         rel_err_re = norm2(real(res,rk)-real(expected,rk))
      else
         rel_err_re = norm2(real(res,rk)-real(expected,rk))/norm2(real(expected,rk))
      end if

      if (norm2(aimag(expected))<=tiny(0.0_rk)) then
         rel_err_im = norm2(aimag(res)-aimag(expected))
      else
         rel_err_im = norm2(aimag(res)-aimag(expected))/norm2(aimag(expected))
      end if

      if (present(tol)) then
         this%result = (rel_err_re <= tol) .and. (rel_err_im <= tol)
      else
         this%result = (rel_err_re <= tiny(0.0_rk)) .and. (rel_err_im <= tiny(0.0_rk))
      end if

      call this%print_msg(this%result)
   end subroutine unit_test_cx2
   !===============================================================================

end module forunittest
forunittest.F90 Source File

Contents

Modules

Source Code

Files dependent on this one

Source Code
