! This file is part of jonquil. ! 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. !> JSON parser implementation. !> !> This module provides procedures for parsing JSON documents into TOML Fortran !> data structures. It reuses the TOML Fortran parser infrastructure with a !> custom JSON lexer. !> !> ## Main Interfaces !> !> - [[json_load]] - Load JSON from a file or unit !> - [[json_loads]] - Load JSON from a string !> !> ## Example !> !> ```fortran !> use jonquil, only : json_loads, json_value, json_object, json_error, & !> & cast_to_object, get_value !> class(json_value), allocatable :: val !> type(json_object), pointer :: obj !> type(json_error), allocatable :: error !> integer :: num !> !> call json_loads(val, '{"count": 42}', error=error) !> obj => cast_to_object(val) !> call get_value(obj, "count", num) !> print '(a,i0)', "count = ", num !> ``` module jonquil_parser use tomlf_constants, only : tfc, tfi, tfr, toml_type use tomlf_datetime, only : toml_datetime use tomlf_de_context, only : toml_context use jonquil_lexer, only : json_lexer, new_lexer_from_string, new_lexer_from_unit, & & new_lexer_from_file use tomlf_de_parser, only : parse, toml_parser_config use tomlf_diagnostic, only : toml_level use tomlf_build, only : get_value use tomlf_error, only : toml_error use tomlf_type, only : toml_table, toml_value, cast_to_table, & & toml_visitor, toml_array, toml_keyval, toml_key, len implicit none private public :: json_load, json_loads !> Load a TOML data structure from the provided source interface json_load module procedure :: json_load_file module procedure :: json_load_unit end interface json_load !> Load a TOML data structure from a string interface json_loads module procedure :: json_load_string end interface json_loads !> Implement pruning of annotated values as visitor type, extends(toml_visitor) :: json_prune contains !> Traverse the AST and prune all annotated values procedure :: visit end type json_prune contains !> Load TOML data structure from file subroutine json_load_file(object, filename, config, context, error) !> Instance of the TOML data structure, not allocated in case of error class(toml_value), allocatable, intent(out) :: object !> Name of the file to load character(*, tfc), intent(in) :: filename !> Configuration for the parser type(toml_parser_config), intent(in), optional :: config !> Context tracking the origin of the data structure to allow rich reports type(toml_context), intent(out), optional :: context !> Error handling, provides detailed diagnostic in case of error type(toml_error), allocatable, intent(out), optional :: error type(json_lexer) :: lexer type(toml_error), allocatable :: error_ type(toml_table), allocatable :: table call new_lexer_from_file(lexer, filename, error_) if (.not.allocated(error_)) then call parse(lexer, table, config, context, error) if (allocated(table)) call prune(object, table) else if (present(error)) call move_alloc(error_, error) end if end subroutine json_load_file !> Load TOML data structure from unit subroutine json_load_unit(object, io, config, context, error) !> Instance of the TOML data structure, not allocated in case of error class(toml_value), allocatable, intent(out) :: object !> Unit to read from integer, intent(in) :: io !> Configuration for the parser type(toml_parser_config), intent(in), optional :: config !> Context tracking the origin of the data structure to allow rich reports type(toml_context), intent(out), optional :: context !> Error handling, provides detailed diagnostic in case of error type(toml_error), allocatable, intent(out), optional :: error type(json_lexer) :: lexer type(toml_error), allocatable :: error_ type(toml_table), allocatable :: table call new_lexer_from_unit(lexer, io, error_) if (.not.allocated(error_)) then call parse(lexer, table, config, context, error) if (allocated(table)) call prune(object, table) else if (present(error)) call move_alloc(error_, error) end if end subroutine json_load_unit !> Load TOML data structure from string subroutine json_load_string(object, string, config, context, error) !> Instance of the TOML data structure, not allocated in case of error class(toml_value), allocatable, intent(out) :: object !> String containing TOML document character(*, tfc), intent(in) :: string !> Configuration for the parser type(toml_parser_config), intent(in), optional :: config !> Context tracking the origin of the data structure to allow rich reports type(toml_context), intent(out), optional :: context !> Error handling, provides detailed diagnostic in case of error type(toml_error), allocatable, intent(out), optional :: error type(json_lexer) :: lexer type(toml_table), allocatable :: table call new_lexer_from_string(lexer, string) call parse(lexer, table, config, context, error) if (allocated(table)) call prune(object, table) end subroutine json_load_string !> Prune the artificial root table inserted by the lexer subroutine prune(object, table) !> Instance of the TOML data structure, not allocated in case of error class(toml_value), allocatable, intent(inout) :: object !> Instance of the TOML data structure, not allocated in case of error type(toml_table), allocatable, intent(inout) :: table type(json_prune) :: pruner call table%pop("_", object) if (allocated(object)) call object%accept(pruner) end subroutine prune !> Visit a TOML value subroutine visit(self, val) !> Instance of the JSON pruner class(json_prune), intent(inout) :: self !> TOML value to visit class(toml_value), intent(inout) :: val select type(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 array subroutine visit_array(visitor, array) !> Instance of the JSON pruner class(json_prune), intent(inout) :: visitor !> TOML value to visit type(toml_array), intent(inout) :: array class(toml_value), allocatable :: val, tmp character(kind=tfc, len=:), allocatable :: str type(toml_key), allocatable :: vt(:) integer :: i, n, stat n = len(array) do i = 1, n call array%shift(val) select type(val) class default call val%accept(visitor) class is(toml_table) call val%get_keys(vt) if (val%has_key("type") .and. val%has_key("value") .and. size(vt)==2) then call get_value(val, "type", str) call prune_value(tmp, val, str) call val%destroy call tmp%accept(visitor) call array%push_back(tmp, stat) cycle else call val%accept(visitor) end if end select call array%push_back(val, stat) end do end subroutine visit_array !> Visit a TOML table subroutine visit_table(visitor, table) !> Instance of the JSON pruner class(json_prune), intent(inout) :: visitor !> TOML table to visit type(toml_table), intent(inout) :: table class(toml_value), pointer :: ptr class(toml_value), allocatable :: val character(kind=tfc, len=:), allocatable :: str type(toml_key), allocatable :: list(:), vt(:) integer :: i, n, stat call table%get_keys(list) n = size(list, 1) do i = 1, n call table%get(list(i)%key, ptr) select type(ptr) class default call ptr%accept(visitor) class is(toml_table) call ptr%get_keys(vt) if (ptr%has_key("type") .and. ptr%has_key("value") .and. size(vt)==2) then call get_value(ptr, "type", str) call prune_value(val, ptr, str) call val%accept(visitor) call table%delete(list(i)%key) call table%push_back(val, stat) else call ptr%accept(visitor) end if end select end do end subroutine visit_table subroutine prune_value(val, table, str) !> Actual TOML value class(toml_value), allocatable, intent(out) :: val !> TOML table to prune type(toml_table), intent(inout) :: table !> Value kind character(kind=tfc, len=*), intent(in) :: str class(toml_value), pointer :: ptr character(:, tfc), pointer :: sval character(kind=tfc, len=:), allocatable :: tmp integer :: stat type(toml_datetime) :: dval integer(tfi) :: ival real(tfr) :: fval call table%get("value", ptr) allocate(val, source=ptr) if (allocated(table%key)) then val%key = table%key else deallocate(val%key) end if select type(val) class is(toml_keyval) call val%get(sval) select case(str) case("date", "time", "datetime", "date-local", "time-local", "datetime-local") dval = toml_datetime(sval) call val%set(dval) case("bool") call val%set(sval == "true") case("integer") read(sval, *, iostat=stat) ival if (stat == 0) then call val%set(ival) end if case("float") read(sval, *, iostat=stat) fval if (stat == 0) then call val%set(fval) end if end select end select end subroutine prune_value end module jonquil_parser