module cubedag_type
  use cubetools_parameters
  use cubedag_messaging
  use cubedag_types

  ! Describe support for one Fortran type
  type :: dag_type_t
    character(len=8)     :: key   ! Unique identifier
    character(len=12)    :: name  ! Human-friendly name
    integer(kind=code_k) :: code  ! Internal unique code set at run time
    procedure(alloc_interface), nopass, pointer :: alloc => null()
    procedure(alloc_interface), nopass, pointer :: dealloc => null()
  end type dag_type_t

  abstract interface
    subroutine alloc_interface(object,error)
      use cubedag_types
      class(cubedag_node_object_t), pointer       :: object
      logical,                      intent(inout) :: error
    end subroutine alloc_interface
  end interface

  ! Collection of Fortran types declared by the callers
  integer, parameter :: mtype=5
  integer :: ntype=0
  type(dag_type_t) :: types(mtype)

  public :: cubedag_type_register,cubedag_type_tostr,cubedag_type_tokey,  &
            cubedag_type_tocode,cubedag_type_allocate,cubedag_type_deallocate
  private

contains

  subroutine cubedag_type_register(key,name,alloc,dealloc,code,error)
    !-------------------------------------------------------------------
    ! For a new type identified by its universal and unique key,
    ! register the associated:
    !  - human-friendly name,
    !  - allocation subroutine (see expected interface below),
    !  - deallocation subroutine.
    ! In return, a unique code chosen by the DAG is return, to be used
    ! when registering new objects. This code is unique during the
    ! session, but might change from one session to another.
    !-------------------------------------------------------------------
    character(len=*),     intent(in)    :: key
    character(len=*),     intent(in)    :: name
    procedure(alloc_interface)          :: alloc
    procedure(alloc_interface)          :: dealloc
    integer(kind=code_k), intent(out)   :: code
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='TYPE>DECLARE'
    integer(kind=4) :: itype
    !
    ! Sanity
    do itype=1,ntype
      if (types(itype)%key.eq.key) then
        call cubedag_message(seve%e,rname,'Fortran type '//trim(key)//' already registered')
        error = .true.
        return
      endif
    enddo
    !
    ntype = ntype+1
    code = ntype
    types(ntype)%key     =  key
    types(ntype)%name    =  name
    types(ntype)%alloc   => alloc
    types(ntype)%dealloc => dealloc
    types(ntype)%code    =  code
  end subroutine cubedag_type_register

  subroutine cubedag_type_tocode(key,code,error)
    character(len=*),     intent(in)    :: key
    integer(kind=code_k), intent(out)   :: code
    logical,              intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='TYPE>TOCODE'
    do code=1,ntype
      if (types(code)%key.eq.key)  return
    enddo
    call cubedag_message(seve%e,rname,'Fortran type '//trim(key)//' not found')
    error = .true.
    return
  end subroutine cubedag_type_tocode

  function cubedag_type_tostr(code)
    character(len=12) :: cubedag_type_tostr
    integer(kind=code_k), intent(in) :: code
    if (code.ge.1 .and. code.le.ntype) then
      cubedag_type_tostr = types(code)%name
    else
      cubedag_type_tostr = '???'
    endif
  end function cubedag_type_tostr

  function cubedag_type_tokey(code)
    character(len=12) :: cubedag_type_tokey
    integer(kind=code_k), intent(in) :: code
    if (code.ge.1 .and. code.le.ntype) then
      cubedag_type_tokey = types(code)%key
    else
      cubedag_type_tokey = '???'
    endif
  end function cubedag_type_tokey

  subroutine cubedag_type_allocate(object,code,error)
    class(cubedag_node_object_t), pointer       :: object
    integer(kind=code_k),         intent(in)    :: code
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='TYPE>ALLOCATE'
    !
    if (code.lt.1 .or. code.gt.ntype) then
      call cubedag_message(seve%e,rname,'Support for this fortran type is not available')
      error = .true.
      return
    endif
    !
    call types(code)%alloc(object,error)
    if (error)  return
    object%node%type = code
  end subroutine cubedag_type_allocate

  subroutine cubedag_type_deallocate(object,error)
    class(cubedag_node_object_t), pointer       :: object
    logical,                      intent(inout) :: error
    ! Local
    character(len=*), parameter :: rname='TYPE>DEALLOCATE'
    integer(kind=code_k) :: code
    !
    code = object%node%type
    if (code.lt.1 .or. code.gt.ntype) then
      call cubedag_message(seve%e,rname,'Support for this fortran type is not available')
      error = .true.
      return
    endif
    !
    call types(code)%dealloc(object,error)
    if (error)  return
  end subroutine cubedag_type_deallocate

end module cubedag_type
