Line data Source code
1 : !> hsd-data — Multi-format structured data IO library for Fortran.
2 : !>
3 : !> This is the main public API module. It re-exports everything from
4 : !> hsd-fortran and adds unified multi-format IO via data_load/data_dump.
5 : !>
6 : !> ## Example usage
7 : !>
8 : !> ```fortran
9 : !> use hsd_data
10 : !> type(hsd_table) :: root
11 : !> type(hsd_error_t), allocatable :: error
12 : !>
13 : !> call data_load("input.hsd", root, error)
14 : !> call data_dump(root, "output.json", error)
15 : !> ```
16 : module hsd_data
17 : ! Re-export the full hsd-fortran public API
18 : use hsd, only: dp, sp, &
19 : & hsd_error_t, &
20 : & HSD_STAT_OK, HSD_STAT_SYNTAX_ERROR, HSD_STAT_UNCLOSED_TAG, &
21 : & HSD_STAT_UNCLOSED_ATTRIB, HSD_STAT_UNCLOSED_QUOTE, HSD_STAT_ORPHAN_TEXT, &
22 : & HSD_STAT_INCLUDE_CYCLE, HSD_STAT_INCLUDE_DEPTH, HSD_STAT_FILE_NOT_FOUND, &
23 : & HSD_STAT_IO_ERROR, HSD_STAT_TYPE_ERROR, HSD_STAT_NOT_FOUND, &
24 : & HSD_STAT_SCHEMA_ERROR, &
25 : & hsd_node, hsd_table, hsd_value, hsd_node_ptr, hsd_iterator, &
26 : & new_table, new_value, &
27 : & VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER, &
28 : & VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY, VALUE_TYPE_COMPLEX, &
29 : & hsd_load, hsd_load_string, hsd_dump, hsd_dump_to_string, &
30 : & hsd_visitor_t, hsd_accept, &
31 : & hsd_get, hsd_get_or, hsd_get_or_set, hsd_get_matrix, &
32 : & hsd_set, &
33 : & hsd_get_child, hsd_get_table, hsd_has_child, hsd_remove_child, &
34 : & hsd_get_type, hsd_is_table, hsd_is_value, hsd_is_array, &
35 : & hsd_child_count, hsd_get_keys, hsd_get_attrib, hsd_has_attrib, &
36 : & hsd_set_attrib, hsd_rename_child, hsd_get_choice, &
37 : & hsd_merge, hsd_clone, hsd_table_equal, &
38 : & hsd_require, hsd_validate_range, hsd_validate_one_of, hsd_get_with_unit, &
39 : & hsd_schema_t, hsd_field_def_t, &
40 : & FIELD_REQUIRED, FIELD_OPTIONAL, &
41 : & FIELD_TYPE_ANY, FIELD_TYPE_STRING, FIELD_TYPE_INTEGER, &
42 : & FIELD_TYPE_REAL, FIELD_TYPE_LOGICAL, FIELD_TYPE_TABLE, &
43 : & FIELD_TYPE_ARRAY, FIELD_TYPE_COMPLEX, &
44 : & schema_init, schema_destroy, schema_add_field, schema_add_field_enum, &
45 : & schema_validate, schema_validate_strict
46 :
47 : ! hsd-data specific modules
48 : use hsd_data_common, only: &
49 : & DATA_FMT_AUTO, DATA_FMT_HSD, DATA_FMT_XML, DATA_FMT_JSON, &
50 : & DATA_FMT_TOML, DATA_FMT_HDF5, DATA_FMT_YAML, &
51 : & data_detect_format, data_format_available
52 :
53 : ! Backends
54 : use hsd_data_hsd, only: &
55 : & hsd_backend_load, hsd_backend_load_string, &
56 : & hsd_backend_dump, hsd_backend_dump_to_string
57 : use hsd_data_xml_parser, only: xml_parse_file, xml_parse_string
58 : use hsd_data_xml_writer, only: xml_dump_file, xml_dump_to_string
59 : use hsd_data_json_parser, only: json_parse_file, json_parse_string
60 : use hsd_data_json_writer, only: json_dump_file, json_dump_to_string
61 : use hsd_data_yaml_parser, only: yaml_parse_file, yaml_parse_string
62 : use hsd_data_yaml_writer, only: yaml_dump_file, yaml_dump_to_string
63 : #ifdef WITH_TOML
64 : use hsd_data_toml, only: &
65 : & toml_backend_load, toml_backend_load_string, &
66 : & toml_backend_dump, toml_backend_dump_to_string
67 : #endif
68 : #ifdef WITH_HDF5
69 : use hsd_data_hdf5, only: hdf5_backend_load, hdf5_backend_dump
70 : #endif
71 :
72 : implicit none(type, external)
73 : private
74 :
75 : ! --- Re-export hsd-fortran public symbols ---
76 :
77 : ! Types
78 : public :: dp, sp
79 : public :: hsd_error_t
80 : public :: hsd_node, hsd_table, hsd_value, hsd_node_ptr, hsd_iterator
81 : public :: new_table, new_value
82 : public :: hsd_visitor_t, hsd_accept
83 :
84 : ! Status codes
85 : public :: HSD_STAT_OK, HSD_STAT_SYNTAX_ERROR, HSD_STAT_UNCLOSED_TAG
86 : public :: HSD_STAT_UNCLOSED_ATTRIB, HSD_STAT_UNCLOSED_QUOTE, HSD_STAT_ORPHAN_TEXT
87 : public :: HSD_STAT_INCLUDE_CYCLE, HSD_STAT_INCLUDE_DEPTH, HSD_STAT_FILE_NOT_FOUND
88 : public :: HSD_STAT_IO_ERROR, HSD_STAT_TYPE_ERROR, HSD_STAT_NOT_FOUND
89 : public :: HSD_STAT_SCHEMA_ERROR
90 :
91 : ! Value type constants
92 : public :: VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER
93 : public :: VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY
94 : public :: VALUE_TYPE_COMPLEX
95 :
96 : ! Accessors / mutators / query
97 : public :: hsd_get, hsd_get_or, hsd_get_or_set, hsd_get_matrix
98 : public :: hsd_set
99 : public :: hsd_get_child, hsd_get_table, hsd_has_child, hsd_remove_child
100 : public :: hsd_get_type, hsd_is_table, hsd_is_value, hsd_is_array
101 : public :: hsd_child_count, hsd_get_keys, hsd_get_attrib, hsd_has_attrib
102 : public :: hsd_set_attrib, hsd_rename_child, hsd_get_choice
103 : public :: hsd_merge, hsd_clone, hsd_table_equal
104 :
105 : ! Validation / schema
106 : public :: hsd_require, hsd_validate_range, hsd_validate_one_of, hsd_get_with_unit
107 : public :: hsd_schema_t, hsd_field_def_t
108 : public :: FIELD_REQUIRED, FIELD_OPTIONAL
109 : public :: FIELD_TYPE_ANY, FIELD_TYPE_STRING, FIELD_TYPE_INTEGER
110 : public :: FIELD_TYPE_REAL, FIELD_TYPE_LOGICAL, FIELD_TYPE_TABLE
111 : public :: FIELD_TYPE_ARRAY, FIELD_TYPE_COMPLEX
112 : public :: schema_init, schema_destroy, schema_add_field, schema_add_field_enum
113 : public :: schema_validate, schema_validate_strict
114 :
115 : ! --- hsd-data public symbols ---
116 :
117 : ! HSD format IO (from hsd-fortran)
118 : public :: hsd_load, hsd_load_string, hsd_dump, hsd_dump_to_string
119 :
120 : ! Format constants
121 : public :: DATA_FMT_AUTO, DATA_FMT_HSD, DATA_FMT_XML, DATA_FMT_JSON
122 : public :: DATA_FMT_TOML, DATA_FMT_HDF5, DATA_FMT_YAML
123 :
124 : ! Unified IO
125 : public :: data_load, data_load_string
126 : public :: data_dump, data_dump_to_string
127 : public :: data_detect_format, data_format_available
128 : public :: data_convert
129 :
130 : contains
131 :
132 : !> Load structured data from a file into an HSD tree.
133 : !>
134 : !> If fmt is DATA_FMT_AUTO (default), the format is detected from the file
135 : !> extension. Supported extensions: .hsd, .xml, .json, .toml, .h5/.hdf5
136 : !>
137 : !> When root_name is given the document element (XML) or first top-level
138 : !> child (HSD/JSON) must have that name, otherwise an error is returned.
139 : !>
140 : !> @param filename Path to the input file.
141 : !> @param root Output HSD tree (overwritten on success).
142 : !> @param error Optional error descriptor; allocated on failure.
143 : !> @param fmt Optional format constant (DATA_FMT_*). Default: auto-detect.
144 : !> @param root_name Optional expected root tag name.
145 : !> @param wrap_name Optional: wrap loaded content in a named root element.
146 : !> If present, the loaded content is placed as a child
147 : !> named wrap_name inside a new anonymous document table.
148 : !> If the loaded tree already has a single child whose
149 : !> name matches wrap_name, no additional wrapping is
150 : !> applied (idempotent).
151 432 : subroutine data_load(filename, root, error, fmt, root_name, wrap_name)
152 : character(len=*), intent(in) :: filename
153 : type(hsd_table), intent(out) :: root
154 : type(hsd_error_t), allocatable, intent(out), optional :: error
155 : integer, intent(in), optional :: fmt
156 : character(len=*), intent(in), optional :: root_name
157 : character(len=*), intent(in), optional :: wrap_name
158 :
159 162 : integer :: actual_fmt
160 :
161 162 : if (present(fmt)) then
162 141 : actual_fmt = fmt
163 : else
164 21 : actual_fmt = DATA_FMT_AUTO
165 : end if
166 :
167 162 : if (actual_fmt == DATA_FMT_AUTO) then
168 47 : actual_fmt = data_detect_format(filename)
169 47 : if (actual_fmt < 0) then
170 0 : if (present(error)) then
171 0 : allocate(error)
172 0 : error%code = HSD_STAT_IO_ERROR
173 0 : error%message = "Cannot detect format from extension: " // trim(filename)
174 : end if
175 0 : return
176 : end if
177 : end if
178 :
179 57 : select case (actual_fmt)
180 : case (DATA_FMT_HSD)
181 57 : call hsd_backend_load(filename, root, error)
182 : case (DATA_FMT_XML)
183 23 : call xml_parse_file(filename, root, error)
184 : case (DATA_FMT_JSON)
185 34 : call json_parse_file(filename, root, error)
186 : case (DATA_FMT_YAML)
187 19 : call yaml_parse_file(filename, root, error)
188 : #ifdef WITH_TOML
189 : case (DATA_FMT_TOML)
190 16 : call toml_backend_load(filename, root, error)
191 : #endif
192 : #ifdef WITH_HDF5
193 : case (DATA_FMT_HDF5)
194 13 : call hdf5_backend_load(filename, root, error)
195 : #endif
196 : case default
197 324 : if (present(error)) then
198 0 : allocate(error)
199 0 : error%code = HSD_STAT_IO_ERROR
200 0 : error%message = "Unsupported or unavailable format"
201 : end if
202 : end select
203 :
204 : ! Validate root_name if loading succeeded and root_name is provided
205 162 : if (present(root_name)) then
206 4 : if (present(error)) then
207 4 : if (allocated(error)) return
208 : end if
209 4 : call check_root_name_(root, root_name, error)
210 : end if
211 :
212 : ! Wrap in a named root element if requested
213 162 : if (present(wrap_name)) then
214 0 : if (present(error)) then
215 0 : if (allocated(error)) return
216 : end if
217 0 : call wrap_root_(root, wrap_name)
218 : end if
219 :
220 162 : end subroutine data_load
221 :
222 : !> Load structured data from a string.
223 : !>
224 : !> The format must be specified explicitly (no auto-detection from string
225 : !> content). HDF5 is not supported for string loading.
226 : !>
227 : !> @param source Character string containing the serialized data.
228 : !> @param root Output HSD tree (overwritten on success).
229 : !> @param fmt Format constant (DATA_FMT_HSD, DATA_FMT_XML, DATA_FMT_JSON).
230 : !> @param error Optional error descriptor; allocated on failure.
231 : !> @param filename Optional filename for error messages (informational only).
232 1990 : subroutine data_load_string(source, root, fmt, error, filename)
233 : character(len=*), intent(in) :: source
234 : type(hsd_table), intent(out) :: root
235 : integer, intent(in) :: fmt
236 : type(hsd_error_t), allocatable, intent(out), optional :: error
237 : character(len=*), intent(in), optional :: filename
238 :
239 176 : select case (fmt)
240 : case (DATA_FMT_HSD)
241 35 : call hsd_backend_load_string(source, root, error, filename)
242 : case (DATA_FMT_XML)
243 29 : call xml_parse_string(source, root, error, filename)
244 : case (DATA_FMT_JSON)
245 46 : call json_parse_string(source, root, error, filename)
246 : case (DATA_FMT_YAML)
247 3 : call yaml_parse_string(source, root, error, filename)
248 : #ifdef WITH_TOML
249 : case (DATA_FMT_TOML)
250 28 : call toml_backend_load_string(source, root, error, filename)
251 : #endif
252 : case default
253 141 : if (present(error)) then
254 0 : allocate(error)
255 0 : error%code = HSD_STAT_IO_ERROR
256 0 : error%message = "Unsupported or unavailable format"
257 : end if
258 : end select
259 :
260 162 : end subroutine data_load_string
261 :
262 : !> Dump an HSD tree to a file in the specified format.
263 : !>
264 : !> If fmt is DATA_FMT_AUTO (default), the format is detected from the file
265 : !> extension. The file is created or overwritten.
266 : !>
267 : !> @param root The HSD tree to serialize.
268 : !> @param filename Path to the output file.
269 : !> @param error Optional error descriptor; allocated on failure.
270 : !> @param fmt Optional format constant (DATA_FMT_*). Default: auto-detect.
271 : !> @param pretty Optional flag for pretty-printing (default: .true.).
272 50 : subroutine data_dump(root, filename, error, fmt, pretty)
273 : type(hsd_table), intent(in) :: root
274 : character(len=*), intent(in) :: filename
275 : type(hsd_error_t), allocatable, intent(out), optional :: error
276 : integer, intent(in), optional :: fmt
277 : logical, intent(in), optional :: pretty
278 :
279 50 : integer :: actual_fmt
280 :
281 50 : if (present(fmt)) then
282 49 : actual_fmt = fmt
283 : else
284 1 : actual_fmt = DATA_FMT_AUTO
285 : end if
286 :
287 50 : if (actual_fmt == DATA_FMT_AUTO) then
288 27 : actual_fmt = data_detect_format(filename)
289 27 : if (actual_fmt < 0) then
290 0 : if (present(error)) then
291 0 : allocate(error)
292 0 : error%code = HSD_STAT_IO_ERROR
293 0 : error%message = "Cannot detect format from extension: " // trim(filename)
294 : end if
295 0 : return
296 : end if
297 : end if
298 :
299 16 : select case (actual_fmt)
300 : case (DATA_FMT_HSD)
301 16 : call hsd_backend_dump(root, filename, error, pretty)
302 : case (DATA_FMT_XML)
303 7 : call xml_dump_file(root, filename, error, pretty)
304 : case (DATA_FMT_JSON)
305 7 : call json_dump_file(root, filename, error, pretty)
306 : case (DATA_FMT_YAML)
307 6 : call yaml_dump_file(root, filename, error, pretty)
308 : #ifdef WITH_TOML
309 : case (DATA_FMT_TOML)
310 1 : call toml_backend_dump(root, filename, error, pretty)
311 : #endif
312 : #ifdef WITH_HDF5
313 : case (DATA_FMT_HDF5)
314 13 : call hdf5_backend_dump(root, filename, error, pretty)
315 : #endif
316 : case default
317 100 : if (present(error)) then
318 0 : allocate(error)
319 0 : error%code = HSD_STAT_IO_ERROR
320 0 : error%message = "Unsupported or unavailable format"
321 : end if
322 : end select
323 :
324 191 : end subroutine data_dump
325 :
326 : !> Dump an HSD tree to a string in the specified format.
327 : !>
328 : !> HDF5 is not supported for string output.
329 : !>
330 : !> @param root The HSD tree to serialize.
331 : !> @param output Allocatable string receiving the serialized output.
332 : !> @param fmt Format constant (DATA_FMT_HSD, DATA_FMT_XML, DATA_FMT_JSON).
333 : !> @param pretty Optional flag for pretty-printing (default: .true.).
334 : !> @param error Optional error descriptor; allocated on failure.
335 222 : subroutine data_dump_to_string(root, output, fmt, pretty, error)
336 : type(hsd_table), intent(in) :: root
337 : character(len=:), allocatable, intent(out) :: output
338 : integer, intent(in) :: fmt
339 : logical, intent(in), optional :: pretty
340 : type(hsd_error_t), allocatable, intent(out), optional :: error
341 :
342 274 : select case (fmt)
343 : case (DATA_FMT_HSD)
344 52 : call hsd_backend_dump_to_string(root, output, pretty)
345 : case (DATA_FMT_XML)
346 44 : call xml_dump_to_string(root, output, pretty)
347 : case (DATA_FMT_JSON)
348 72 : call json_dump_to_string(root, output, pretty)
349 : case (DATA_FMT_YAML)
350 5 : call yaml_dump_to_string(root, output, pretty)
351 : #ifdef WITH_TOML
352 : case (DATA_FMT_TOML)
353 49 : call toml_backend_dump_to_string(root, output, pretty)
354 : #endif
355 : case default
356 0 : output = ""
357 222 : if (present(error)) then
358 0 : allocate(error)
359 0 : error%code = HSD_STAT_IO_ERROR
360 0 : error%message = "Unsupported format for dump_to_string"
361 : end if
362 : end select
363 :
364 50 : end subroutine data_dump_to_string
365 :
366 : !> Convert a file from one format to another.
367 : !>
368 : !> Convenience routine: loads the input file and dumps to the output file.
369 : !> Formats default to DATA_FMT_AUTO (detected from file extensions).
370 : !>
371 : !> @param input_file Path to the source file.
372 : !> @param output_file Path to the destination file.
373 : !> @param error Optional error descriptor; allocated on failure.
374 : !> @param input_fmt Optional input format (DATA_FMT_*). Default: auto-detect.
375 : !> @param output_fmt Optional output format (DATA_FMT_*). Default: auto-detect.
376 2 : subroutine data_convert(input_file, output_file, error, input_fmt, output_fmt)
377 : character(len=*), intent(in) :: input_file
378 : character(len=*), intent(in) :: output_file
379 : type(hsd_error_t), allocatable, intent(out), optional :: error
380 : integer, intent(in), optional :: input_fmt
381 : integer, intent(in), optional :: output_fmt
382 :
383 2 : type(hsd_table) :: root
384 :
385 2 : call data_load(input_file, root, error, input_fmt)
386 2 : if (present(error)) then
387 2 : if (allocated(error)) return
388 : end if
389 :
390 2 : call data_dump(root, output_file, error, output_fmt)
391 :
392 260 : end subroutine data_convert
393 :
394 :
395 : ! ---------------------------------------------------------------------------
396 : ! Private helpers
397 : ! ---------------------------------------------------------------------------
398 :
399 : !> Check that root contains a child matching expected_name.
400 : !>
401 : !> After loading, the root table is anonymous. In XML the document element
402 : !> is unwrapped so its children are direct children of root; in HSD/JSON
403 : !> the top-level keys become children. We check that at least one top-level
404 : !> child has the expected name.
405 4 : subroutine check_root_name_(root, expected_name, error)
406 : type(hsd_table), intent(in) :: root
407 : character(len=*), intent(in) :: expected_name
408 : type(hsd_error_t), allocatable, intent(inout), optional :: error
409 :
410 4 : if (hsd_has_child(root, expected_name, case_insensitive=.true.)) return
411 :
412 1 : if (present(error)) then
413 1 : allocate(error)
414 1 : error%code = HSD_STAT_IO_ERROR
415 : error%message = "Expected root element '" // expected_name &
416 1 : & // "' not found"
417 : end if
418 :
419 6 : end subroutine check_root_name_
420 :
421 :
422 : !> Wrap the loaded root table in a named element if not already present.
423 : !>
424 : !> If root already has a single child whose name matches wrap_name (case-
425 : !> insensitive), no wrapping is applied (idempotent). Otherwise, a new
426 : !> anonymous root table is created with the old content placed inside
427 : !> a child named wrap_name.
428 0 : subroutine wrap_root_(root, wrap_name)
429 : type(hsd_table), intent(inout) :: root
430 : character(len=*), intent(in) :: wrap_name
431 :
432 0 : type(hsd_table) :: new_root, wrapper
433 : class(hsd_node), pointer :: first_child
434 0 : integer :: ii
435 :
436 : ! Check idempotency: if root has exactly one child matching wrap_name, done
437 0 : if (root%num_children == 1) then
438 0 : call root%get_child(1, first_child)
439 0 : if (associated(first_child)) then
440 0 : if (allocated(first_child%name)) then
441 : block
442 0 : character(len=:), allocatable :: lower_child, lower_wrap
443 0 : lower_child = to_lower_(first_child%name)
444 0 : lower_wrap = to_lower_(wrap_name)
445 0 : if (lower_child == lower_wrap) return
446 : end block
447 : end if
448 : end if
449 : end if
450 :
451 : ! Build wrapper: anonymous root -> wrap_name table -> old children
452 0 : call new_table(wrapper, name=wrap_name)
453 0 : do ii = 1, root%num_children
454 0 : call root%get_child(ii, first_child)
455 0 : if (associated(first_child)) then
456 : select type (first_child)
457 : type is (hsd_table)
458 0 : call wrapper%add_child(first_child)
459 : type is (hsd_value)
460 0 : call wrapper%add_child(first_child)
461 : end select
462 : end if
463 : end do
464 :
465 : ! Replace root content
466 0 : call new_table(new_root)
467 0 : call new_root%add_child(wrapper)
468 0 : root = new_root
469 :
470 4 : end subroutine wrap_root_
471 :
472 :
473 : !> Simple case-insensitive lowering (ASCII only)
474 0 : pure function to_lower_(str) result(lower)
475 : character(len=*), intent(in) :: str
476 : character(len=:), allocatable :: lower
477 0 : integer :: ii, ic
478 0 : lower = str
479 0 : do ii = 1, len(lower)
480 0 : ic = iachar(lower(ii:ii))
481 0 : if (ic >= iachar('A') .and. ic <= iachar('Z')) then
482 0 : lower(ii:ii) = achar(ic + 32)
483 : end if
484 : end do
485 0 : end function to_lower_
486 :
487 0 : end module hsd_data
|
