! This file is part of toml-f.
! SPDX-Identifier: Apache-2.0 OR MIT
!
! Licensed under either of Apache License, Version 2.0 or MIT license
! at your option; you may not use this file except in compliance with
! the License.
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

!> TOML serializer implementation
module tomlf_ser
   use tomlf_constants, only : tfc, tfi, tfr, tfout, toml_type
   use tomlf_datetime, only : toml_datetime, to_string
   use tomlf_error, only : toml_error, toml_stat, make_error
   use tomlf_type, only : toml_value, toml_visitor, toml_key, toml_table, &
      & toml_array, toml_keyval, is_array_of_tables, len
   use tomlf_utils, only : to_string, toml_escape_string
   implicit none
   private

   public :: toml_serializer, new_serializer, new
   public :: toml_dump, toml_dumps, toml_serialize


   interface toml_dumps
      module procedure :: toml_dump_to_string
   end interface toml_dumps

   interface toml_dump
      module procedure :: toml_dump_to_file
      module procedure :: toml_dump_to_unit
   end interface toml_dump


   !> Configuration for JSON serializer
   type :: toml_ser_config

      !> Indentation
      character(len=:), allocatable :: indent

   end type toml_ser_config


   !> TOML serializer to produduce a TOML document from a datastructure
   type, extends(toml_visitor) :: toml_serializer
      private

      !> Output string
      character(:), allocatable :: output

      !> Configuration for serializer
      type(toml_ser_config) :: config = toml_ser_config()

      !> Special mode for printing array of tables
      logical, private :: array_of_tables = .false.

      !> Special mode for printing inline arrays
      logical, private :: inline_array = .false.

      !> Top of the key stack
      integer, private :: top = 0

      !> Key stack to create table headers
      type(toml_key), allocatable, private :: stack(:)

   contains

      !> Visit a TOML value
      procedure :: visit

   end type toml_serializer


   !> Create standard constructor
   interface toml_serializer
      module procedure :: new_serializer_func
   end interface toml_serializer


   !> Overloaded constructor for TOML serializers
   interface new
      module procedure :: new_serializer
   end interface


   !> Initial size of the key path stack
   integer, parameter :: initial_size = 8


contains


!> Serialize a JSON value to a string and return it.
!>
!> In case of an error this function will invoke an error stop.
function toml_serialize(val, config) result(string)
   !> TOML value to visit
   class(toml_value), intent(inout) :: val

   !> Configuration for serializer
   type(toml_ser_config), intent(in), optional :: config

   !> Serialized JSON value
   character(len=:), allocatable :: string

   type(toml_error), allocatable :: error

   call toml_dumps(val, string, error, config=config)
   if (allocated(error)) then
      print '(a)', "Error: " // error%message
      error stop 1
   end if
end function toml_serialize


!> Create a string representing the JSON value
subroutine toml_dump_to_string(val, string, error, config)

   !> TOML value to visit
   class(toml_value), intent(inout) :: val

   !> Formatted unit to write to
   character(:), allocatable, intent(out) :: string

   !> Error handling
   type(toml_error), allocatable, intent(out) :: error

   !> Configuration for serializer
   type(toml_ser_config), intent(in), optional :: config

   type(toml_serializer) :: ser

   ser = toml_serializer(config=config)
   call val%accept(ser)
   string = ser%output
end subroutine toml_dump_to_string


!> Write string representation of JSON value to a connected formatted unit
subroutine toml_dump_to_unit(val, io, error, config)

   !> TOML value to visit
   class(toml_value), intent(inout) :: val

   !> Formatted unit to write to
   integer, intent(in) :: io

   !> Error handling
   type(toml_error), allocatable, intent(out) :: error

   !> Configuration for serializer
   type(toml_ser_config), intent(in), optional :: config

   character(len=:), allocatable :: string
   character(512) :: msg
   integer :: stat

   call toml_dumps(val, string, error, config=config)
   if (allocated(error)) return
   write(io, '(a)', iostat=stat, iomsg=msg) string
   if (stat /= 0) then
      call make_error(error, trim(msg))
      return
   end if
end subroutine toml_dump_to_unit


!> Write string representation of JSON value to a file
subroutine toml_dump_to_file(val, filename, error, config)

   !> TOML value to visit
   class(toml_value), intent(inout) :: val

   !> File name to write to
   character(*), intent(in) :: filename

   !> Error handling
   type(toml_error), allocatable, intent(out) :: error

   !> Configuration for serializer
   type(toml_ser_config), intent(in), optional :: config

   integer :: io
   integer :: stat
   character(512) :: msg

   open(file=filename, newunit=io, iostat=stat, iomsg=msg)
   if (stat /= 0) then
      call make_error(error, trim(msg))
      return
   end if
   call toml_dump(val, io, error, config=config)
   close(unit=io, iostat=stat, iomsg=msg)
   if (.not.allocated(error) .and. stat /= 0) then
      call make_error(error, trim(msg))
   end if
end subroutine toml_dump_to_file


!> Constructor to create new serializer instance
subroutine new_serializer(self, config)

   !> Instance of the TOML serializer
   type(toml_serializer), intent(out) :: self

   !> Configuration for serializer
   type(toml_ser_config), intent(in), optional :: config

   self%output = ""
   if (present(config)) self%config = config
end subroutine new_serializer


!> Default constructor for TOML serializer
function new_serializer_func(config) result(self)

   !> Configuration for serializer
   type(toml_ser_config), intent(in), optional :: config

   !> Instance of the TOML serializer
   type(toml_serializer) :: self

   call new_serializer(self, config)
end function new_serializer_func


!> Visit a TOML value
recursive subroutine visit(self, val)

   !> Instance of the TOML serializer
   class(toml_serializer), intent(inout) :: self

   !> TOML value to visit
   class(toml_value), intent(inout) :: val

   select type(val)
   class is(toml_keyval)
      call visit_keyval(self, val)
   class is(toml_array)
      call visit_array(self, val)
   class is(toml_table)
      call visit_table(self, val)
   end select

end subroutine visit


!> Visit a TOML key-value pair
subroutine visit_keyval(visitor, keyval)

   !> Instance of the TOML serializer
   class(toml_serializer), intent(inout) :: visitor

   !> TOML value to visit
   type(toml_keyval), intent(inout) :: keyval

   character(kind=tfc, len=:), allocatable :: key, str
   type(toml_datetime), pointer :: dval
   character(:, tfc), pointer :: sval
   integer(tfi), pointer :: ival
   real(tfr), pointer :: rval
   logical, pointer :: lval

   call keyval%get_key(key)

   select case(keyval%get_type())
   case(toml_type%string)
      call keyval%get(sval)
      call toml_escape_string(sval, str)
   case(toml_type%int)
      call keyval%get(ival)
      str = to_string(ival)
   case(toml_type%float)
      call keyval%get(rval)
      str = to_string(rval)
   case(toml_type%boolean)
      call keyval%get(lval)
      if (lval) then
         str = "true"
      else
         str = "false"
      end if
   case(toml_type%datetime)
      call keyval%get(dval)
      str = to_string(dval)
   end select

   if (visitor%inline_array) then
      visitor%output = visitor%output // " "
   end if
   visitor%output = visitor%output // key // " = " // str
   if (.not.visitor%inline_array) then
      visitor%output = visitor%output // new_line('a')
   end if

end subroutine visit_keyval


!> Visit a TOML array
recursive subroutine visit_array(visitor, array)

   !> Instance of the TOML serializer
   class(toml_serializer), intent(inout) :: visitor

   !> TOML value to visit
   type(toml_array), intent(inout) :: array

   class(toml_value), pointer :: ptr
   character(kind=tfc, len=:), allocatable :: key, str
   type(toml_datetime), pointer :: dval
   character(:, tfc), pointer :: sval
   integer(tfi), pointer :: ival
   real(tfr), pointer :: rval
   logical, pointer :: lval
   integer :: i, n

   if (visitor%inline_array) visitor%output = visitor%output // " ["
   n = len(array)
   do i = 1, n
      call array%get(i, ptr)
      select type(ptr)
      class is(toml_keyval)

         select case(ptr%get_type())
         case(toml_type%string)
            call ptr%get(sval)
            call toml_escape_string(sval, str)
         case(toml_type%int)
            call ptr%get(ival)
            str = to_string(ival)
         case(toml_type%float)
            call ptr%get(rval)
            str = to_string(rval)
         case(toml_type%boolean)
            call ptr%get(lval)
            if (lval) then
               str = "true"
            else
               str = "false"
            end if
         case(toml_type%datetime)
            call ptr%get(dval)
            str = to_string(dval)
         end select

         visitor%output = visitor%output // " " // str
         if (i /= n) visitor%output = visitor%output // ","
      class is(toml_array)
         call ptr%accept(visitor)
         if (i /= n) visitor%output = visitor%output // ","
      class is(toml_table)
         if (visitor%inline_array) then
            visitor%output = visitor%output // " {"
            call ptr%accept(visitor)
            visitor%output = visitor%output // " }"
            if (i /= n) visitor%output = visitor%output // ","
         else
            visitor%array_of_tables = .true.
            if (size(visitor%stack, 1) <= visitor%top) call resize(visitor%stack)
            visitor%top = visitor%top + 1
            call array%get_key(key)
            visitor%stack(visitor%top)%key = key
            call ptr%accept(visitor)
            deallocate(visitor%stack(visitor%top)%key)
            visitor%top = visitor%top - 1
         end if
      end select
   end do
   if (visitor%inline_array) visitor%output = visitor%output // " ]"

end subroutine visit_array


!> Visit a TOML table
recursive subroutine visit_table(visitor, table)

   !> Instance of the TOML serializer
   class(toml_serializer), intent(inout) :: visitor

   !> TOML table to visit
   type(toml_table), intent(inout) :: table

   class(toml_value), pointer :: ptr
   type(toml_key), allocatable :: list(:)
   logical, allocatable :: defer(:)
   character(kind=tfc, len=:), allocatable :: key
   integer :: i, n

   call table%get_keys(list)

   n = size(list, 1)
   allocate(defer(n))

   if (.not.allocated(visitor%stack)) then
      call resize(visitor%stack)
   else
      if (.not.(visitor%inline_array .or. table%implicit)) then
         visitor%output = visitor%output // "["
         if (visitor%array_of_tables) visitor%output = visitor%output // "["
         do i = 1, visitor%top-1
            visitor%output = visitor%output // visitor%stack(i)%key // "."
         end do
         visitor%output = visitor%output // visitor%stack(visitor%top)%key
         visitor%output = visitor%output // "]"
         if (visitor%array_of_tables) visitor%output = visitor%output // "]"
         visitor%output = visitor%output // new_line('a')
         visitor%array_of_tables = .false.
      end if
   end if

   do i = 1, n
      defer(i) = .false.
      call table%get(list(i)%key, ptr)
      select type(ptr)
      class is(toml_keyval)
         call ptr%accept(visitor)
         if (visitor%inline_array) then
            if (i /= n) visitor%output = visitor%output // ","
         end if
      class is(toml_array)
         if (visitor%inline_array) then
            call ptr%get_key(key)
            visitor%output = visitor%output // " " // key // " ="
            call ptr%accept(visitor)
            if (i /= n) visitor%output = visitor%output // ","
         else
            if (is_array_of_tables(ptr)) then
               ! Array of tables open a new section
               ! -> cannot serialize them before all key-value pairs are done
               defer(i) = .true.
            else
               visitor%inline_array = .true.
               call ptr%get_key(key)
               visitor%output = visitor%output // key // " ="
               call ptr%accept(visitor)
               visitor%inline_array = .false.
               visitor%output = visitor%output // new_line('a')
            end if
         end if
      class is(toml_table)
         ! Subtables open a new section
         ! -> cannot serialize them before all key-value pairs are done
         defer(i) = .true.
      end select
   end do

   do i = 1, n
      if (defer(i)) then
         call table%get(list(i)%key, ptr)
         select type(ptr)
         class is(toml_keyval)
            call ptr%accept(visitor)
            if (visitor%inline_array) then
               if (i /= n) visitor%output = visitor%output // ","
            end if
         class is(toml_array)
            if (visitor%inline_array) then
               call ptr%get_key(key)
               visitor%output = visitor%output // " " // key // " ="
               call ptr%accept(visitor)
               if (i /= n) visitor%output = visitor%output // ","
            else
               if (is_array_of_tables(ptr)) then
                  call ptr%accept(visitor)
               else
                  visitor%inline_array = .true.
                  call ptr%get_key(key)
                  visitor%output = visitor%output // key // " ="
                  call ptr%accept(visitor)
                  visitor%inline_array = .false.
                  visitor%output = visitor%output // new_line('a')
               end if
            end if
         class is(toml_table)
            if (size(visitor%stack, 1) <= visitor%top) call resize(visitor%stack)
            visitor%top = visitor%top + 1
            call ptr%get_key(key)
            visitor%stack(visitor%top)%key = key
            call ptr%accept(visitor)
            deallocate(visitor%stack(visitor%top)%key)
            visitor%top = visitor%top - 1
         end select
      end if
   end do

   if (.not.visitor%inline_array .and. visitor%top == 0) then
      deallocate(visitor%stack)
   end if

end subroutine visit_table


!> Change size of the stack
subroutine resize(stack, n)

   !> Stack of keys to be resized
   type(toml_key), allocatable, intent(inout) :: stack(:)

   !> New size of the stack
   integer, intent(in), optional :: n

   type(toml_key), allocatable :: tmp(:)
   integer :: m

   if (present(n)) then
      m = n
   else
      if (allocated(stack)) then
         m = size(stack)
         m = m + m/2 + 1
      else
         m = initial_size
      end if
   end if

   if (allocated(stack)) then
      call move_alloc(stack, tmp)
      allocate(stack(m))

      m = min(size(tmp), m)
      stack(:m) = tmp(:m)

      deallocate(tmp)
   else
      allocate(stack(m))
   end if

end subroutine resize


end module tomlf_ser
