! This file is part of tblite.
! SPDX-Identifier: LGPL-3.0-or-later
!
! tblite 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.
!
! tblite 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 tblite.  If not, see <https://www.gnu.org/licenses/>.

!> Implementation of the argument list processor.
module tblite_argument
   implicit none
   private

   public :: argument_list, len
   public :: argument_count_interface, get_argument_interface


   !> Internal representation of the command line arguments
   type :: argument
      private
      !> Actual payload of the argument
      character(len=:), allocatable :: raw
   end type argument

   !> Constructor for the argument representation
   interface argument
      module procedure :: new_argument
   end interface argument


   !> Argument list class
   type :: argument_list
      !> Name of the invoked executable, if available
      character(len=:), allocatable :: prog
      !> Number of arguments
      integer :: nargs = 0
      !> Array of arguments in this list
      type(argument), allocatable :: argv(:)
   contains
      !> Append a command line argument
      procedure :: push_back
      !> Display debug information on this instance
      procedure :: info
      !> Get command line argument
      procedure :: get
   end type argument_list

   !> Constructor for the argument list
   interface argument_list
      module procedure :: new_argument_list
   end interface argument_list

   interface len
      module procedure :: get_length
   end interface len


   abstract interface
      !> Interface of the argument counter
      function argument_count_interface() result(argument_count)
         !> Number of available arguments
         integer :: argument_count
      end function argument_count_interface

      !> Interface of the argument getter
      subroutine get_argument_interface(idx, arg)
         !> Index of the argument to retrieve, range 0 to argument_counter()
         integer, intent(in) :: idx
         !> Returned argument payload, allocation status is used to signal errors
         character(len=:), allocatable, intent(out) :: arg
      end subroutine get_argument_interface
   end interface

   !> Token identifyin response files
   character(len=*), parameter :: response_token = "@"

   !> Initial size for the resizer of the argument list
   integer, parameter :: initial_size = 20


contains


!> Create a new argument from a raw payload
pure function new_argument(raw) result(new)
   !> Raw argument value
   character(len=*), intent(in) :: raw
   !> Representation of the argument
   type(argument) :: new

   new%raw = raw
end function new_argument

!> Constructor of the argument list
function new_argument_list(argument_counter, argument_getter) result(new)
   !> Argument counter interface
   procedure(argument_count_interface), optional :: argument_counter
   !> Argument getter interface
   procedure(get_argument_interface), optional :: argument_getter
   !> Newly created argument list
   type(argument_list) :: new

   intrinsic :: present

   if (present(argument_getter) .and. present(argument_counter)) then
      call make_argument_list(new, argument_counter, argument_getter)
   else
      call make_argument_list(new, default_argument_count, get_default_argument)
   end if
end function new_argument_list

!> Internal constructor of the argument list
subroutine make_argument_list(self, argument_counter, argument_getter)
   !> Instance of the argument list to be created
   type(argument_list), intent(out) :: self
   !> Argument counter interface
   procedure(argument_count_interface) :: argument_counter
   !> Argument getter interface
   procedure(get_argument_interface) :: argument_getter

   integer :: iarg, narg, info
   character(len=:), allocatable :: arg
   intrinsic :: allocated

   info = 0
   narg = argument_counter()
   self%nargs = 0
   call resize(self%argv, narg)
   call argument_getter(0, self%prog)
   do iarg = 1, narg
      call argument_getter(iarg, arg)
      if (.not.allocated(arg)) return
      if (is_response_file(arg)) then
         call get_response_file(self, arg(2:), info)
         if (info == 0) cycle
      end if
      call push_back(self, arg)
   end do

end subroutine make_argument_list


!> Check if an argument represents a response file
pure function is_response_file(arg) result(is_resp)
   !> Argument of interest
   character(len=*), intent(in) :: arg
   !> Whether the argument could be a response file or not
   logical :: is_resp
   intrinsic :: len

   if (len(arg) > 1) then
      is_resp = arg(1:1) == response_token
   else
      is_resp = .false.
   end if
end function is_response_file

!> Recursively consume a response file and append it to the argument list
recursive subroutine get_response_file(self, resp, stat)
   !> Instance of the argument list
   class(argument_list), intent(inout) :: self
   !> Name of the response file to be appended
   character(len=*), intent(in) :: resp
   !> Status of reading the reponse file
   integer, intent(out) :: stat

   integer :: unit, info, istat
   logical :: opened
   character(len=:), allocatable :: arg

   inquire(file=resp, opened=opened)
   if (opened) then
      stat = 1
      return
   end if

   open(file=resp, unit=unit, iostat=info, status='old', action='read')
   do while(info == 0)
      call getline(unit, arg, info)
      if (info /= 0) exit
      if (is_response_file(arg)) then
         call get_response_file(self, arg(2:), istat)
         if (istat == 0) cycle
      end if
      call push_back(self, arg)
   end do
   close(unit, iostat=stat)
   if (info /= 0) then
      stat = merge(0, info, is_iostat_end(info))
   end if
end subroutine get_response_file

!> Consume a whole line from a formatted unit
subroutine getline(unit, line, iostat, iomsg)
   !> Formatted IO unit
   integer, intent(in) :: unit
   !> Line to read
   character(len=:), allocatable, intent(out) :: line
   !> Status of operation
   integer, intent(out) :: iostat
   !> Error message
   character(len=:), allocatable, optional :: iomsg

   integer, parameter :: bufsize = 512
   character(len=bufsize) :: buffer, msg
   integer :: size, stat
   intrinsic :: is_iostat_eor, present, trim

   allocate(character(len=0) :: line)
   do
      read(unit, '(a)', advance='no', iostat=stat, iomsg=msg, size=size) &
         & buffer
      if (stat > 0) exit
      line = line // buffer(:size)
      if (stat < 0) exit
   end do

   if (is_iostat_eor(stat)) stat = 0

   if (stat /= 0) then
      if (present(iomsg)) iomsg = trim(msg)
   end if
   iostat = stat

end subroutine getline


!> Append a string to the argument list
subroutine push_back(self, string)
   !> Instance of the argument list
   class(argument_list), intent(inout) :: self
   !> String representing the argument
   character(len=*), intent(in) :: string
   intrinsic :: size

   self%nargs = self%nargs + 1
   if (self%nargs > size(self%argv)) call resize(self%argv)
   self%argv(self%nargs) = argument(string)

end subroutine push_back

!> Reallocate list of arguments
pure subroutine resize(list, n)
   !> Instance of the array to be resized
   type(argument), allocatable, intent(inout) :: list(:)
   !> Dimension of the final array size
   integer, intent(in), optional :: n

   type(argument), allocatable :: tmp(:)
   integer :: this_size, new_size, iv
   intrinsic :: allocated, size, move_alloc, present, min

   if (allocated(list)) then
      this_size = size(list, 1)
      call move_alloc(list, tmp)
   else
      this_size = initial_size
   end if

   if (present(n)) then
      new_size = n
   else
      new_size = this_size + this_size/2 + 1
   end if

   allocate(list(new_size))

   if (allocated(tmp)) then
      this_size = min(size(tmp, 1), size(list, 1))
      do iv = 1, this_size
         call move_alloc(tmp(iv)%raw, list(iv)%raw)
      end do
      deallocate(tmp)
   end if
end subroutine resize


!> Display debug information on an argument list instance
subroutine info(self, unit)
   !> Instance of the argument list
   class(argument_list), intent(in) :: self
   !> Formatted unit for output
   integer, intent(in) :: unit

   character(len=*), parameter :: fmt = '("#", *(1x, g0))'
   integer :: iarg
   intrinsic :: allocated

   if (allocated(self%prog)) then
      write(unit, fmt) self%prog
   end if

   if (allocated(self%argv)) then
      write(unit, fmt) self%nargs, "arguments provided"
      do iarg = 1, self%nargs
         write(unit, fmt) iarg, "/", self%nargs, "->", self%argv(iarg)%raw
      end do
   end if
end subroutine info


!> Default argument counter using the intrinsic command_argument_count procedure
function default_argument_count() result(argument_count)
   !> Number of available arguments
   integer :: argument_count

   intrinsic :: command_argument_count

   argument_count = command_argument_count()
end function default_argument_count

!> Default argument getter using the intrinsic get_command_argument procedure
subroutine get_default_argument(idx, arg)
   !> Index of the argument to retrieve, range 0 to argument_counter()
   integer, intent(in) :: idx
   !> Returned argument payload, allocation status is used to signal errors
   character(len=:), allocatable, intent(out) :: arg

   integer :: length, stat
   intrinsic :: get_command_argument

   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_default_argument


pure subroutine get(self, idx, arg)
   class(argument_list), intent(in) :: self
   character(len=:), allocatable, intent(out) :: arg
   integer, intent(in) :: idx

   if (idx > 0 .and. idx <= self%nargs) arg = self%argv(idx)%raw
end subroutine get

pure function get_length(self) result(length)
   class(argument_list), intent(in) :: self
   integer :: length
   length = self%nargs
end function get_length

end module tblite_argument
