Mutable Fortran string type

string.f90

module string_mod
    implicit none

    private
    public string_t

    type :: string_t
        private
        character(len=:), allocatable :: chars
        integer :: n = 0
    contains
        procedure :: ensure_capacity
        procedure :: length
        procedure :: capacity
        procedure :: clear
        generic :: push => push_chars, push_str
        procedure :: strip

        procedure :: to_chars
        procedure :: as_chars
        procedure :: move

        generic :: assignment(=) => assign_chars, assign_str
        generic :: operator(//) => append_chars, append_str

        procedure, private :: assign_chars
        procedure, private :: assign_str
        procedure, private :: append_chars
        procedure, private :: append_str
        procedure, private :: push_chars
        procedure, private :: push_str
    end type

    interface string_t
        module procedure init
    end interface

contains


    type(string_t) pure function init(chars) result(this)
        character(len=*), intent(in) :: chars

        this = chars
    end function


    pure subroutine assign_chars(this, rhs)
        class(string_t), intent(inout) :: this
        character(len=*), intent(in) :: rhs

        integer :: n

        n = len(rhs)
        call this%clear()
        call this%ensure_capacity(n)
        this%chars(:) = rhs
        this%n = n
    end subroutine


    pure subroutine assign_str(this, rhs)
        class(string_t), intent(inout) :: this
        type(string_t), intent(in) :: rhs

        integer :: n

        call this%clear()
        if (allocated(rhs%chars)) then
            n = rhs%length()
            call this%ensure_capacity(n)
            this%chars(:) = rhs%chars(1:n)
            this%n = n
        end if
    end subroutine


    type(string_t) pure function append_chars(this, rhs) result(str)
        class(string_t), intent(in) :: this
        character(len=*), intent(in) :: rhs

        str = this
        call str%push(rhs)
    end function


    type(string_t) pure function append_str(this, rhs) result(str)
        class(string_t), intent(in) :: this
        type(string_t), intent(in) :: rhs

        str = this
        call str%push(rhs)
    end function


    pure subroutine ensure_capacity(this, cap)
        class(string_t), intent(inout) :: this
        integer, intent(in) :: cap

        if (.not. allocated(this%chars)) then
            allocate(character(len=cap) :: this%chars)
        else if (this%capacity() < cap) then
            if (this%n == 0) then
                deallocate(this%chars)
                allocate(character(len=cap) :: this%chars)
            else
                block
                    character(len=this%n) :: tmp

                    tmp = this%chars(1:this%n)
                    deallocate(this%chars)
                    allocate(character(len=cap) :: this%chars)
                    this%chars(1:this%n) = tmp
                end block
            end if
        end if
    end subroutine


    pure subroutine push_chars(this, chars)
        class(string_t), intent(inout) :: this
        character(len=*), intent(in) :: chars

        integer :: n_new

        n_new = this%length() + len(chars)
        call this%ensure_capacity(n_new)
        this%chars(this%n + 1:) = chars
        this%n = n_new
    end subroutine


    pure subroutine push_str(this, str)
        class(string_t), intent(inout) :: this
        type(string_t), intent(in) :: str

        call this%ensure_capacity(0)
        if (allocated(str%chars)) then
            call this%push(str%chars(1:str%n))
        end if
    end subroutine


    integer pure function length(this)
        class(string_t), intent(in) :: this

        length = this%n
    end function


    integer pure function capacity(this)
        class(string_t), intent(in) :: this

        if (allocated(this%chars)) then
            capacity = len(this%chars)
        else
            capacity = 0
        end if
    end function


    pure subroutine clear(this)
        class(string_t), intent(inout) :: this

        call this%ensure_capacity(0)
        this%n = 0
    end subroutine


    pure subroutine strip(this)
        class(string_t), intent(inout) :: this

        integer :: start
        integer :: end

        call this%ensure_capacity(0)
        do start = 1, this%n
            if (.not. is_whitespace(this%chars(start:))) exit
        end do
        do end = this%n, start, -1
            if (.not. is_whitespace(this%chars(end:))) exit
        end do
        this%chars(:) = this%chars(start:end)
        this%n = end - start + 1
    end subroutine


    logical pure function is_whitespace(chars)
        character(len=*), intent(in) :: chars

        !TODO: Include other Unicode whitespace characters
        is_whitespace = chars(1:1) == ' '
    end function


    pure function to_chars(this) result(chars)
        class(string_t), intent(in) :: this
        character(len=:), allocatable :: chars

        if (this%n > 0) then
            chars = this%chars(1:this%n)
        else
            chars = ''
        end if
    end function


    function as_chars(this) result(chars)
        class(string_t), target, intent(in) :: this
        character(len=:), pointer :: chars

        if (allocated(this%chars)) then
            chars => this%chars(1:this%n)
        else
            nullify(chars)
        end if
    end function


    pure subroutine move(this, chars, n)
        class(string_t), target, intent(inout) :: this
        character(len=:), allocatable, intent(out) :: chars
        integer, intent(out) :: n

        call this%ensure_capacity(0)
        call move_alloc(this%chars, chars)
        n = this%n
        this%n = 0
    end subroutine
end module