Initial import

1 files changed, 635 insertions, 0 deletions

diff --git a/src/cepis_json.f90 b/src/cepis_json.f90
new file mode 100644
index 0000000..b7be02e
--- /dev/null
+++ b/src/cepis_json.f90
@@ -0,0 +1,635 @@
+!> 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