path: root/src/cepis_json.f90

!> A small, strict JSON reader.
!>
!> Fortran ships no JSON parser, so this is hand-written. It is a complete
!> RFC 8259 reader for the shapes the API produces: objects, arrays, strings
!> with `\u` escapes and surrogate pairs, numbers, `true`, `false` and `null`.
!>
!> Values live in one growable array inside a `json_document` and are referred
!> to by integer index. That keeps the type free of recursive allocatable
!> components, and it means no reference into the document can dangle when the
!> array grows during parsing.
module cepis_json
    use, intrinsic :: iso_fortran_env, only: real64, int64
    use cepis_strings, only: string_buffer, from_real, from_integer, parse_real, utf8_encode
    implicit none
    private

    character, parameter :: BACKSLASH = char(92)

    integer, parameter, public :: JSON_NULL = 0
    integer, parameter, public :: JSON_BOOL = 1
    integer, parameter, public :: JSON_NUMBER = 2
    integer, parameter, public :: JSON_STRING = 3
    integer, parameter, public :: JSON_ARRAY = 4
    integer, parameter, public :: JSON_OBJECT = 5

    !> One `"name": value` pair of an object.
    type, public :: json_member
        character(len=:), allocatable :: name
        integer :: node = 0
    end type json_member

    !> One JSON value.
    type, public :: json_node
        integer :: kind = JSON_NULL
        character(len=:), allocatable :: text
        real(real64) :: number = 0.0_real64
        logical :: truth = .false.
        type(json_member), allocatable :: members(:)
        integer, allocatable :: items(:)
    end type json_node

    !> A parsed document. `root` indexes the top-level value.
    type, public :: json_document
        type(json_node), allocatable :: nodes(:)
        integer :: used = 0
        integer :: root = 0
    contains
        !> The kind of a node; `JSON_NULL` for an index of zero.
        procedure :: kind_of
        !> Index of the value of `name` inside object `node`, or zero.
        procedure :: member
        !> `.true.` when object `node` carries `name`.
        procedure :: has
        !> A node as text. Numbers and booleans are rendered; other kinds and
        !> a zero index give the empty string, never a failure.
        procedure :: text_of
        !> A node as a floating-point value; zero when it is not a number.
        procedure :: number_of
        !> A node as an integer; zero when it is not a number.
        procedure :: integer_of
        !> `text_of` applied to a named member of an object.
        procedure :: field_text
        !> `number_of` applied to a named member of an object.
        procedure :: field_number
        !> `integer_of` applied to a named member of an object.
        procedure :: field_integer
    end type json_document

    public :: json_parse

contains

    !> Parse `text`. On failure `ok` is `.false.` and `message` says why.
    subroutine json_parse(text, doc, ok, message)
        character(len=*), intent(in) :: text
        type(json_document), intent(out) :: doc
        logical, intent(out) :: ok
        character(len=:), allocatable, intent(out) :: message
        integer :: pos

        message = ''
        pos = 1
        call skip_space(text, pos)
        call parse_value(doc, text, pos, doc%root, ok, message)
        if (.not. ok) return
        call skip_space(text, pos)
        if (pos <= len(text)) then
            ok = .false.
            message = 'trailing characters after the JSON value'
        end if
    end subroutine json_parse

    pure function kind_of(self, node) result(kind)
        class(json_document), intent(in) :: self
        integer, intent(in) :: node
        integer :: kind

        if (node <= 0 .or. node > self%used) then
            kind = JSON_NULL
        else
            kind = self%nodes(node)%kind
        end if
    end function kind_of

    pure function member(self, node, name) result(index)
        class(json_document), intent(in) :: self
        integer, intent(in) :: node
        character(len=*), intent(in) :: name
        integer :: index, i

        index = 0
        if (self%kind_of(node) /= JSON_OBJECT) return
        if (.not. allocated(self%nodes(node)%members)) return
        do i = 1, size(self%nodes(node)%members)
            if (self%nodes(node)%members(i)%name == name) then
                index = self%nodes(node)%members(i)%node
                return
            end if
        end do
    end function member

    pure function has(self, node, name) result(yes)
        class(json_document), intent(in) :: self
        integer, intent(in) :: node
        character(len=*), intent(in) :: name
        logical :: yes

        yes = self%member(node, name) /= 0
    end function has

    pure function text_of(self, node) result(text)
        class(json_document), intent(in) :: self
        integer, intent(in) :: node
        character(len=:), allocatable :: text

        text = ''
        select case (self%kind_of(node))
        case (JSON_STRING)
            if (allocated(self%nodes(node)%text)) text = self%nodes(node)%text
        case (JSON_NUMBER)
            if (abs(self%nodes(node)%number - aint(self%nodes(node)%number)) < &
                1.0e-9_real64 .and. abs(self%nodes(node)%number) < 1.0e15_real64) then
                text = from_integer(int(self%nodes(node)%number, int64))
            else
                text = from_real(self%nodes(node)%number)
            end if
        case (JSON_BOOL)
            if (self%nodes(node)%truth) then
                text = 'true'
            else
                text = 'false'
            end if
        end select
    end function text_of

    pure function number_of(self, node) result(value)
        class(json_document), intent(in) :: self
        integer, intent(in) :: node
        real(real64) :: value

        value = 0.0_real64
        if (self%kind_of(node) == JSON_NUMBER) value = self%nodes(node)%number
    end function number_of

    pure function integer_of(self, node) result(value)
        class(json_document), intent(in) :: self
        integer, intent(in) :: node
        integer(int64) :: value

        value = 0_int64
        if (self%kind_of(node) == JSON_NUMBER) then
            value = int(self%nodes(node)%number, int64)
        end if
    end function integer_of

    pure function field_text(self, node, name) result(text)
        class(json_document), intent(in) :: self
        integer, intent(in) :: node
        character(len=*), intent(in) :: name
        character(len=:), allocatable :: text

        text = self%text_of(self%member(node, name))
    end function field_text

    pure function field_number(self, node, name) result(value)
        class(json_document), intent(in) :: self
        integer, intent(in) :: node
        character(len=*), intent(in) :: name
        real(real64) :: value

        value = self%number_of(self%member(node, name))
    end function field_number

    pure function field_integer(self, node, name) result(value)
        class(json_document), intent(in) :: self
        integer, intent(in) :: node
        character(len=*), intent(in) :: name
        integer(int64) :: value

        value = self%integer_of(self%member(node, name))
    end function field_integer

    subroutine new_node(doc, index)
        type(json_document), intent(inout) :: doc
        integer, intent(out) :: index
        type(json_node), allocatable :: bigger(:)

        if (.not. allocated(doc%nodes)) allocate (doc%nodes(16))
        if (doc%used >= size(doc%nodes)) then
            allocate (bigger(2*size(doc%nodes)))
            bigger(1:doc%used) = doc%nodes(1:doc%used)
            call move_alloc(bigger, doc%nodes)
        end if
        doc%used = doc%used + 1
        index = doc%used
    end subroutine new_node

    pure subroutine skip_space(text, pos)
        character(len=*), intent(in) :: text
        integer, intent(inout) :: pos

        do while (pos <= len(text))
            select case (text(pos:pos))
            case (' ', char(9), char(10), char(13))
                pos = pos + 1
            case default
                return
            end select
        end do
    end subroutine skip_space

    recursive subroutine parse_value(doc, text, pos, node, ok, message)
        type(json_document), intent(inout) :: doc
        character(len=*), intent(in) :: text
        integer, intent(inout) :: pos
        integer, intent(out) :: node
        logical, intent(out) :: ok
        character(len=:), allocatable, intent(out) :: message

        node = 0
        ok = .false.
        message = ''

        call skip_space(text, pos)
        if (pos > len(text)) then
            message = 'unexpected end of input'
            return
        end if

        select case (text(pos:pos))
        case ('{')
            call parse_object(doc, text, pos, node, ok, message)
        case ('[')
            call parse_array(doc, text, pos, node, ok, message)
        case ('"')
            block
                character(len=:), allocatable :: value
                call parse_string(text, pos, value, ok, message)
                if (.not. ok) return
                call new_node(doc, node)
                doc%nodes(node)%kind = JSON_STRING
                doc%nodes(node)%text = value
            end block
        case ('t')
            call parse_literal(doc, text, pos, 'true', node, ok, message)
        case ('f')
            call parse_literal(doc, text, pos, 'false', node, ok, message)
        case ('n')
            call parse_literal(doc, text, pos, 'null', node, ok, message)
        case default
            call parse_number(doc, text, pos, node, ok, message)
        end select
    end subroutine parse_value

    subroutine parse_literal(doc, text, pos, word, node, ok, message)
        type(json_document), intent(inout) :: doc
        character(len=*), intent(in) :: text
        integer, intent(inout) :: pos
        character(len=*), intent(in) :: word
        integer, intent(out) :: node
        logical, intent(out) :: ok
        character(len=:), allocatable, intent(out) :: message

        node = 0
        ok = .false.
        message = ''
        if (pos + len(word) - 1 > len(text)) then
            message = 'truncated literal'
            return
        end if
        if (text(pos:pos + len(word) - 1) /= word) then
            message = 'unknown literal at position '//from_integer(int(pos, int64))
            return
        end if
        pos = pos + len(word)

        call new_node(doc, node)
        select case (word)
        case ('true')
            doc%nodes(node)%kind = JSON_BOOL
            doc%nodes(node)%truth = .true.
        case ('false')
            doc%nodes(node)%kind = JSON_BOOL
            doc%nodes(node)%truth = .false.
        case default
            doc%nodes(node)%kind = JSON_NULL
        end select
        ok = .true.
    end subroutine parse_literal

    subroutine parse_number(doc, text, pos, node, ok, message)
        type(json_document), intent(inout) :: doc
        character(len=*), intent(in) :: text
        integer, intent(inout) :: pos
        integer, intent(out) :: node
        logical, intent(out) :: ok
        character(len=:), allocatable, intent(out) :: message
        integer :: first
        real(real64) :: value

        node = 0
        ok = .false.
        message = ''
        first = pos

        if (text(pos:pos) == '-') pos = pos + 1
        do while (pos <= len(text))
            select case (text(pos:pos))
            case ('0':'9', '.', 'e', 'E', '+', '-')
                pos = pos + 1
            case default
                exit
            end select
        end do

        if (pos == first) then
            message = 'unexpected character '''//text(pos:pos)//''''
            return
        end if

        call parse_real(text(first:pos - 1), value, ok)
        if (.not. ok) then
            message = 'malformed number '''//text(first:pos - 1)//''''
            return
        end if

        call new_node(doc, node)
        doc%nodes(node)%kind = JSON_NUMBER
        doc%nodes(node)%number = value
    end subroutine parse_number

    subroutine parse_string(text, pos, value, ok, message)
        character(len=*), intent(in) :: text
        integer, intent(inout) :: pos
        character(len=:), allocatable, intent(out) :: value
        logical, intent(out) :: ok
        character(len=:), allocatable, intent(out) :: message
        type(string_buffer) :: out
        integer :: code, low
        logical :: got

        value = ''
        ok = .false.
        message = ''
        pos = pos + 1

        do
            if (pos > len(text)) then
                message = 'unterminated string'
                return
            end if

            if (text(pos:pos) == '"') then
                pos = pos + 1
                value = out%text()
                ok = .true.
                return
            else if (text(pos:pos) /= BACKSLASH) then
                call out%append(text(pos:pos))
                pos = pos + 1
                cycle
            end if

            pos = pos + 1
            if (pos > len(text)) then
                message = 'unterminated escape'
                return
            end if

            select case (text(pos:pos))
            case ('"')
                call out%append('"')
            case (BACKSLASH)
                call out%append(BACKSLASH)
            case ('/')
                call out%append('/')
            case ('b')
                call out%append(char(8))
            case ('f')
                call out%append(char(12))
            case ('n')
                call out%append(char(10))
            case ('r')
                call out%append(char(13))
            case ('t')
                call out%append(char(9))
            case ('u')
                call read_hex4(text, pos + 1, code, got)
                if (.not. got) then
                    message = 'malformed unicode escape'
                    return
                end if
                pos = pos + 4
                if (code >= 55296 .and. code <= 56319) then
                    if (pos + 6 <= len(text)) then
                        if (text(pos + 1:pos + 1) == BACKSLASH .and. &
                            text(pos + 2:pos + 2) == 'u') then
                            call read_hex4(text, pos + 3, low, got)
                            if (got .and. low >= 56320 .and. low <= 57343) then
                                code = 65536 + (code - 55296)*1024 + &
                                       (low - 56320)
                                pos = pos + 6
                            end if
                        end if
                    end if
                end if
                call out%append(utf8_encode(code))
            case default
                message = 'unknown escape sequence'
                return
            end select
            pos = pos + 1
        end do
    end subroutine parse_string

    pure subroutine read_hex4(text, at, code, ok)
        character(len=*), intent(in) :: text
        integer, intent(in) :: at
        integer, intent(out) :: code
        logical, intent(out) :: ok
        integer :: i, digit

        code = 0
        ok = .false.
        if (at + 3 > len(text)) return
        do i = at, at + 3
            select case (text(i:i))
            case ('0':'9')
                digit = iachar(text(i:i)) - 48
            case ('a':'f')
                digit = iachar(text(i:i)) - 87
            case ('A':'F')
                digit = iachar(text(i:i)) - 55
            case default
                return
            end select
            code = code*16 + digit
        end do
        ok = .true.
    end subroutine read_hex4

    recursive subroutine parse_array(doc, text, pos, node, ok, message)
        type(json_document), intent(inout) :: doc
        character(len=*), intent(in) :: text
        integer, intent(inout) :: pos
        integer, intent(out) :: node
        logical, intent(out) :: ok
        character(len=:), allocatable, intent(out) :: message
        integer, allocatable :: items(:), bigger(:)
        integer :: count, child

        node = 0
        ok = .false.
        message = ''
        allocate (items(8))
        count = 0
        pos = pos + 1

        call skip_space(text, pos)
        if (pos <= len(text)) then
            if (text(pos:pos) == ']') then
                pos = pos + 1
                call finish_array(doc, items, count, node)
                ok = .true.
                return
            end if
        end if

        do
            call parse_value(doc, text, pos, child, ok, message)
            if (.not. ok) return
            if (count >= size(items)) then
                allocate (bigger(2*size(items)))
                bigger(1:count) = items(1:count)
                call move_alloc(bigger, items)
            end if
            count = count + 1
            items(count) = child

            call skip_space(text, pos)
            if (pos > len(text)) then
                ok = .false.
                message = 'unterminated array'
                return
            end if
            if (text(pos:pos) == ',') then
                pos = pos + 1
                cycle
            else if (text(pos:pos) == ']') then
                pos = pos + 1
                call finish_array(doc, items, count, node)
                ok = .true.
                return
            else
                ok = .false.
                message = 'expected '','' or '']'' in array'
                return
            end if
        end do
    end subroutine parse_array

    subroutine finish_array(doc, items, count, node)
        type(json_document), intent(inout) :: doc
        integer, intent(in) :: items(:)
        integer, intent(in) :: count
        integer, intent(out) :: node

        call new_node(doc, node)
        doc%nodes(node)%kind = JSON_ARRAY
        allocate (doc%nodes(node)%items(count))
        if (count > 0) doc%nodes(node)%items = items(1:count)
    end subroutine finish_array

    recursive subroutine parse_object(doc, text, pos, node, ok, message)
        type(json_document), intent(inout) :: doc
        character(len=*), intent(in) :: text
        integer, intent(inout) :: pos
        integer, intent(out) :: node
        logical, intent(out) :: ok
        character(len=:), allocatable, intent(out) :: message
        type(json_member), allocatable :: members(:), bigger(:)
        character(len=:), allocatable :: name
        integer :: count, child

        node = 0
        ok = .false.
        message = ''
        allocate (members(8))
        count = 0
        pos = pos + 1

        call skip_space(text, pos)
        if (pos <= len(text)) then
            if (text(pos:pos) == '}') then
                pos = pos + 1
                call finish_object(doc, members, count, node)
                ok = .true.
                return
            end if
        end if

        do
            call skip_space(text, pos)
            if (pos > len(text)) then
                message = 'unterminated object'
                return
            end if
            if (text(pos:pos) /= '"') then
                message = 'expected a string key in object'
                return
            end if

            call parse_string(text, pos, name, ok, message)
            if (.not. ok) return

            call skip_space(text, pos)
            if (pos > len(text)) then
                ok = .false.
                message = 'unterminated object'
                return
            end if
            if (text(pos:pos) /= ':') then
                ok = .false.
                message = 'expected '':'' after key '''//name//''''
                return
            end if
            pos = pos + 1

            call parse_value(doc, text, pos, child, ok, message)
            if (.not. ok) return

            if (count >= size(members)) then
                allocate (bigger(2*size(members)))
                bigger(1:count) = members(1:count)
                call move_alloc(bigger, members)
            end if
            count = count + 1
            members(count)%name = name
            members(count)%node = child

            call skip_space(text, pos)
            if (pos > len(text)) then
                ok = .false.
                message = 'unterminated object'
                return
            end if
            if (text(pos:pos) == ',') then
                pos = pos + 1
                cycle
            else if (text(pos:pos) == '}') then
                pos = pos + 1
                call finish_object(doc, members, count, node)
                ok = .true.
                return
            else
                ok = .false.
                message = 'expected '','' or ''}'' in object'
                return
            end if
        end do
    end subroutine parse_object

    subroutine finish_object(doc, members, count, node)
        type(json_document), intent(inout) :: doc
        type(json_member), intent(in) :: members(:)
        integer, intent(in) :: count
        integer, intent(out) :: node

        call new_node(doc, node)
        doc%nodes(node)%kind = JSON_OBJECT
        allocate (doc%nodes(node)%members(count))
        if (count > 0) doc%nodes(node)%members = members(1:count)
    end subroutine finish_object

end module cepis_json