Line data Source code
1 : !> YAML serializer: dump an hsd_table tree to YAML.
2 : !>
3 : !> Mapping (per SPECIFICATION.md):
4 : !> hsd_table → YAML mapping
5 : !> hsd_value (str) → scalar (plain or quoted)
6 : !> hsd_value (int) → plain number
7 : !> hsd_value (real) → plain number
8 : !> hsd_value (bool) → true / false
9 : !> hsd_value (complex) → {re: r, im: i}
10 : !> hsd_value (array) → flow sequence [a, b, c]
11 : !> node%attrib → sibling key "name__attrib": "value"
12 : !> anonymous value → "_value": ...
13 : !> same-named children → YAML sequence of mappings
14 : module hsd_data_yaml_writer
15 : use hsd, only: hsd_table, hsd_value, hsd_node, hsd_node_ptr, &
16 : & VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER, &
17 : & VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY, &
18 : & VALUE_TYPE_COMPLEX, hsd_error_t, dp, HSD_STAT_IO_ERROR
19 : implicit none(type, external)
20 : private
21 :
22 : public :: yaml_dump_to_string, yaml_dump_file
23 :
24 : !> Suffix for attribute sibling keys
25 : character(len=*), parameter :: ATTRIB_SUFFIX = "__attrib"
26 :
27 : !> Key for anonymous values
28 : character(len=*), parameter :: ANON_VALUE_KEY = "_value"
29 :
30 : !> Default indentation width
31 : integer, parameter :: INDENT_WIDTH = 2
32 :
33 : contains
34 :
35 : !> Dump an hsd_table tree to a YAML string.
36 17 : subroutine yaml_dump_to_string(root, output, pretty)
37 : type(hsd_table), intent(in) :: root
38 : character(len=:), allocatable, intent(out) :: output
39 : logical, intent(in), optional :: pretty
40 :
41 17 : logical :: do_pretty
42 17 : character(len=:), allocatable :: buf
43 17 : integer :: buf_len, buf_cap
44 :
45 17 : do_pretty = .true.
46 6 : if (present(pretty)) do_pretty = pretty
47 :
48 17 : buf_cap = 4096
49 17 : allocate(character(len=buf_cap) :: buf)
50 17 : buf_len = 0
51 :
52 17 : if (do_pretty) then
53 15 : call write_block_table(root, buf, buf_len, buf_cap, 0, .true.)
54 : else
55 : ! Compact mode: flow style
56 2 : call write_flow_table(root, buf, buf_len, buf_cap)
57 : end if
58 :
59 : ! Ensure trailing newline
60 17 : if (buf_len > 0) then
61 17 : if (buf(buf_len:buf_len) /= new_line("a")) then
62 2 : call append_str(buf, buf_len, buf_cap, new_line("a"))
63 : end if
64 : end if
65 :
66 17 : output = buf(1:buf_len)
67 :
68 17 : end subroutine yaml_dump_to_string
69 :
70 : !> Dump an hsd_table tree to a YAML file.
71 6 : subroutine yaml_dump_file(root, filename, error, pretty)
72 : type(hsd_table), intent(in) :: root
73 : character(len=*), intent(in) :: filename
74 : type(hsd_error_t), allocatable, intent(out), optional :: error
75 : logical, intent(in), optional :: pretty
76 :
77 6 : character(len=:), allocatable :: output
78 6 : integer :: unit_num, ios
79 :
80 6 : call yaml_dump_to_string(root, output, pretty)
81 :
82 : open(newunit=unit_num, file=filename, status="replace", action="write", &
83 6 : & iostat=ios)
84 6 : if (ios /= 0) then
85 0 : if (present(error)) then
86 0 : allocate(error)
87 0 : error%code = HSD_STAT_IO_ERROR
88 0 : error%message = "Failed to open file for writing: " // trim(filename)
89 : end if
90 0 : return
91 : end if
92 6 : write(unit_num, "(a)", iostat=ios) output
93 6 : close(unit_num)
94 :
95 6 : if (ios /= 0 .and. present(error)) then
96 0 : allocate(error)
97 0 : error%code = HSD_STAT_IO_ERROR
98 0 : error%message = "Failed to write to file: " // trim(filename)
99 : end if
100 :
101 23 : end subroutine yaml_dump_file
102 :
103 : !> Write a table as block-style YAML mapping.
104 : !> Same-named children are grouped into YAML sequences.
105 81 : recursive subroutine write_block_table(table, buf, buf_len, buf_cap, &
106 : & depth, is_root)
107 : type(hsd_table), intent(in) :: table
108 : character(len=:), allocatable, intent(inout) :: buf
109 : integer, intent(inout) :: buf_len, buf_cap
110 : integer, intent(in) :: depth
111 : logical, intent(in) :: is_root
112 :
113 81 : integer :: ii, jj, name_count
114 81 : character(len=:), allocatable :: child_name
115 81 : logical, allocatable :: emitted(:)
116 :
117 81 : if (table%num_children == 0) then
118 0 : if (.not. is_root) then
119 0 : call append_str(buf, buf_len, buf_cap, "{}")
120 0 : call append_str(buf, buf_len, buf_cap, new_line("a"))
121 : end if
122 0 : return
123 : end if
124 :
125 81 : allocate(emitted(table%num_children))
126 219 : emitted = .false.
127 :
128 219 : do ii = 1, table%num_children
129 138 : if (.not. associated(table%children(ii)%node)) cycle
130 138 : if (emitted(ii)) cycle
131 :
132 138 : child_name = get_child_name(table%children(ii)%node)
133 :
134 : ! Count how many children share this name
135 138 : name_count = 0
136 366 : do jj = ii, table%num_children
137 228 : if (.not. associated(table%children(jj)%node)) cycle
138 594 : if (get_child_name(table%children(jj)%node) == child_name) then
139 366 : name_count = name_count + 1
140 : end if
141 : end do
142 :
143 219 : if (name_count > 1) then
144 : ! Multiple same-named children → sequence of mappings
145 0 : call write_sequence_group(table, child_name, ii, emitted, &
146 : & buf, buf_len, buf_cap, depth)
147 : else
148 138 : emitted(ii) = .true.
149 0 : select type (child => table%children(ii)%node)
150 : type is (hsd_table)
151 0 : call write_block_table_member(child, buf, buf_len, buf_cap, depth)
152 : ! Emit attrib sibling
153 132 : if (allocated(child%attrib)) then
154 7 : if (len_trim(child%attrib) > 0) then
155 0 : call write_attrib_member(child%name, child%attrib, &
156 7 : & buf, buf_len, buf_cap, depth)
157 : end if
158 : end if
159 :
160 : type is (hsd_value)
161 0 : call write_block_value_member(child, buf, buf_len, buf_cap, depth)
162 : ! Emit attrib sibling
163 144 : if (allocated(child%attrib)) then
164 11 : if (len_trim(child%attrib) > 0) then
165 0 : call write_attrib_member(child%name, child%attrib, &
166 11 : & buf, buf_len, buf_cap, depth)
167 : end if
168 : end if
169 : end select
170 : end if
171 : end do
172 :
173 87 : end subroutine write_block_table
174 :
175 : !> Get the effective name of a child node.
176 404 : function get_child_name(node) result(name)
177 : class(hsd_node), intent(in) :: node
178 : character(len=:), allocatable :: name
179 :
180 : select type (node)
181 : type is (hsd_table)
182 222 : if (allocated(node%name)) then
183 222 : if (len_trim(node%name) > 0) then
184 222 : name = node%name
185 : else
186 0 : name = ANON_VALUE_KEY
187 : end if
188 : else
189 0 : name = ANON_VALUE_KEY
190 : end if
191 : type is (hsd_value)
192 182 : if (allocated(node%name)) then
193 182 : if (len_trim(node%name) > 0) then
194 182 : name = node%name
195 : else
196 0 : name = ANON_VALUE_KEY
197 : end if
198 : else
199 0 : name = ANON_VALUE_KEY
200 : end if
201 : class default
202 0 : name = ANON_VALUE_KEY
203 : end select
204 :
205 404 : end function get_child_name
206 :
207 : !> Write a sequence group for same-named children.
208 0 : recursive subroutine write_sequence_group(table, name, start_idx, emitted, &
209 : & buf, buf_len, buf_cap, depth)
210 : type(hsd_table), intent(in) :: table
211 : character(len=*), intent(in) :: name
212 : integer, intent(in) :: start_idx
213 : logical, intent(inout) :: emitted(:)
214 : character(len=:), allocatable, intent(inout) :: buf
215 : integer, intent(inout) :: buf_len, buf_cap
216 : integer, intent(in) :: depth
217 :
218 0 : integer :: jj
219 :
220 : ! Write key
221 0 : call write_indent(buf, buf_len, buf_cap, depth)
222 0 : call append_str(buf, buf_len, buf_cap, yaml_key_str(name) // ":")
223 0 : call append_str(buf, buf_len, buf_cap, new_line("a"))
224 :
225 0 : do jj = start_idx, table%num_children
226 0 : if (.not. associated(table%children(jj)%node)) cycle
227 0 : if (get_child_name(table%children(jj)%node) /= name) cycle
228 0 : emitted(jj) = .true.
229 :
230 0 : select type (child => table%children(jj)%node)
231 : type is (hsd_table)
232 0 : call write_indent(buf, buf_len, buf_cap, depth)
233 0 : call append_str(buf, buf_len, buf_cap, "- ")
234 : ! Write table contents inline at increased indent
235 0 : if (child%num_children == 0) then
236 0 : call append_str(buf, buf_len, buf_cap, "{}")
237 0 : call append_str(buf, buf_len, buf_cap, new_line("a"))
238 : else
239 : ! Write first child on same line as -, rest indented
240 0 : call write_block_table(child, buf, buf_len, buf_cap, depth + 1, .false.)
241 : end if
242 : type is (hsd_value)
243 0 : call write_indent(buf, buf_len, buf_cap, depth)
244 0 : call append_str(buf, buf_len, buf_cap, "- ")
245 0 : call write_value_content(child, buf, buf_len, buf_cap)
246 0 : call append_str(buf, buf_len, buf_cap, new_line("a"))
247 : end select
248 : end do
249 :
250 0 : end subroutine write_sequence_group
251 :
252 : !> Write a table child as "key:\n ..."
253 66 : recursive subroutine write_block_table_member(table, buf, buf_len, buf_cap, &
254 : & depth)
255 : type(hsd_table), intent(in) :: table
256 : character(len=:), allocatable, intent(inout) :: buf
257 : integer, intent(inout) :: buf_len, buf_cap
258 : integer, intent(in) :: depth
259 :
260 66 : character(len=:), allocatable :: key
261 :
262 66 : if (allocated(table%name)) then
263 66 : if (len_trim(table%name) > 0) then
264 66 : key = table%name
265 : else
266 0 : key = ANON_VALUE_KEY
267 : end if
268 : else
269 0 : key = ANON_VALUE_KEY
270 : end if
271 :
272 66 : call write_indent(buf, buf_len, buf_cap, depth)
273 66 : call append_str(buf, buf_len, buf_cap, yaml_key_str(key) // ":")
274 :
275 66 : if (table%num_children == 0) then
276 0 : call append_str(buf, buf_len, buf_cap, " {}")
277 0 : call append_str(buf, buf_len, buf_cap, new_line("a"))
278 : else
279 66 : call append_str(buf, buf_len, buf_cap, new_line("a"))
280 66 : call write_block_table(table, buf, buf_len, buf_cap, depth + 1, .false.)
281 : end if
282 :
283 66 : end subroutine write_block_table_member
284 :
285 : !> Write a value child as "key: value"
286 72 : subroutine write_block_value_member(val, buf, buf_len, buf_cap, depth)
287 : type(hsd_value), intent(in) :: val
288 : character(len=:), allocatable, intent(inout) :: buf
289 : integer, intent(inout) :: buf_len, buf_cap
290 : integer, intent(in) :: depth
291 :
292 72 : character(len=:), allocatable :: key
293 :
294 72 : if (allocated(val%name)) then
295 72 : if (len_trim(val%name) > 0) then
296 72 : key = val%name
297 : else
298 0 : key = ANON_VALUE_KEY
299 : end if
300 : else
301 0 : key = ANON_VALUE_KEY
302 : end if
303 :
304 72 : call write_indent(buf, buf_len, buf_cap, depth)
305 72 : call append_str(buf, buf_len, buf_cap, yaml_key_str(key) // ": ")
306 72 : call write_value_content(val, buf, buf_len, buf_cap)
307 72 : call append_str(buf, buf_len, buf_cap, new_line("a"))
308 :
309 72 : end subroutine write_block_value_member
310 :
311 : !> Write an attribute as a sibling member "name__attrib: value"
312 18 : subroutine write_attrib_member(name, attrib, buf, buf_len, buf_cap, depth)
313 : character(len=*), intent(in) :: name
314 : character(len=*), intent(in) :: attrib
315 : character(len=:), allocatable, intent(inout) :: buf
316 : integer, intent(inout) :: buf_len, buf_cap
317 : integer, intent(in) :: depth
318 :
319 18 : character(len=:), allocatable :: key
320 :
321 18 : if (len_trim(name) > 0) then
322 18 : key = name // ATTRIB_SUFFIX
323 : else
324 0 : key = ANON_VALUE_KEY // ATTRIB_SUFFIX
325 : end if
326 :
327 18 : call write_indent(buf, buf_len, buf_cap, depth)
328 18 : call append_str(buf, buf_len, buf_cap, yaml_key_str(key) // ": ")
329 18 : call append_str(buf, buf_len, buf_cap, yaml_quote_string(attrib))
330 18 : call append_str(buf, buf_len, buf_cap, new_line("a"))
331 :
332 90 : end subroutine write_attrib_member
333 :
334 : !> Write a value's content.
335 80 : subroutine write_value_content(val, buf, buf_len, buf_cap)
336 : type(hsd_value), intent(in) :: val
337 : character(len=:), allocatable, intent(inout) :: buf
338 : integer, intent(inout) :: buf_len, buf_cap
339 :
340 : character(len=64) :: num_buf
341 :
342 80 : select case (val%value_type)
343 : case (VALUE_TYPE_INTEGER)
344 0 : write(num_buf, "(i0)") val%int_value
345 0 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
346 :
347 : case (VALUE_TYPE_REAL)
348 0 : call format_real(val%real_value, num_buf)
349 0 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
350 :
351 : case (VALUE_TYPE_LOGICAL)
352 0 : if (val%logical_value) then
353 0 : call append_str(buf, buf_len, buf_cap, "true")
354 : else
355 0 : call append_str(buf, buf_len, buf_cap, "false")
356 : end if
357 :
358 : case (VALUE_TYPE_COMPLEX)
359 0 : call append_str(buf, buf_len, buf_cap, "{re: ")
360 0 : call format_real(real(val%complex_value, dp), num_buf)
361 0 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
362 0 : call append_str(buf, buf_len, buf_cap, ", im: ")
363 0 : call format_real(aimag(val%complex_value), num_buf)
364 0 : call append_str(buf, buf_len, buf_cap, trim(adjustl(num_buf)))
365 0 : call append_str(buf, buf_len, buf_cap, "}")
366 :
367 : case (VALUE_TYPE_ARRAY)
368 17 : call write_array_value(val, buf, buf_len, buf_cap)
369 :
370 : case (VALUE_TYPE_STRING)
371 126 : if (allocated(val%string_value)) then
372 92 : if (looks_like_number(val%string_value)) then
373 29 : call append_str(buf, buf_len, buf_cap, val%string_value)
374 34 : else if (is_hsd_boolean(val%string_value)) then
375 : call append_str(buf, buf_len, buf_cap, &
376 21 : & hsd_bool_to_yaml(val%string_value))
377 : else
378 : call append_str(buf, buf_len, buf_cap, &
379 13 : & yaml_quote_string(val%string_value))
380 : end if
381 : else
382 0 : call append_str(buf, buf_len, buf_cap, '""')
383 : end if
384 :
385 : case (VALUE_TYPE_NONE)
386 0 : if (allocated(val%string_value)) then
387 0 : if (len(val%string_value) > 0) then
388 : call append_str(buf, buf_len, buf_cap, &
389 0 : & yaml_quote_string(val%string_value))
390 : else
391 0 : call append_str(buf, buf_len, buf_cap, "null")
392 : end if
393 : else
394 0 : call append_str(buf, buf_len, buf_cap, "null")
395 : end if
396 :
397 : case default
398 0 : if (allocated(val%string_value)) then
399 : call append_str(buf, buf_len, buf_cap, &
400 0 : & yaml_quote_string(val%string_value))
401 : else
402 0 : call append_str(buf, buf_len, buf_cap, "null")
403 : end if
404 : end select
405 :
406 18 : end subroutine write_value_content
407 :
408 : !> Write an array value as YAML flow sequences.
409 17 : subroutine write_array_value(val, buf, buf_len, buf_cap)
410 : type(hsd_value), intent(in) :: val
411 : character(len=:), allocatable, intent(inout) :: buf
412 : integer, intent(inout) :: buf_len, buf_cap
413 :
414 17 : character(len=:), allocatable :: text
415 17 : integer :: ii, nlines, line_start, line_end
416 17 : logical :: has_newlines, is_nl
417 :
418 17 : if (allocated(val%string_value)) then
419 17 : text = val%string_value
420 0 : else if (allocated(val%raw_text)) then
421 0 : text = val%raw_text
422 : else
423 0 : call append_str(buf, buf_len, buf_cap, "[]")
424 0 : return
425 : end if
426 :
427 17 : if (len_trim(text) == 0) then
428 0 : call append_str(buf, buf_len, buf_cap, "[]")
429 0 : return
430 : end if
431 :
432 : ! Check for newlines (matrix data)
433 17 : has_newlines = .false.
434 234 : do ii = 1, len(text)
435 234 : if (text(ii:ii) == new_line("a")) then
436 8 : has_newlines = .true.
437 8 : exit
438 : end if
439 : end do
440 :
441 26 : if (has_newlines) then
442 : ! Matrix: nested sequences [[...], [...]]
443 8 : call append_str(buf, buf_len, buf_cap, "[")
444 8 : line_start = 1
445 8 : nlines = 0
446 364 : do ii = 1, len(text) + 1
447 356 : if (ii > len(text)) then
448 8 : is_nl = .true.
449 : else
450 348 : is_nl = (text(ii:ii) == new_line("a"))
451 : end if
452 364 : if (is_nl) then
453 16 : line_end = ii - 1
454 16 : if (line_start <= line_end .and. len_trim(text(line_start:line_end)) > 0) then
455 16 : if (nlines > 0) call append_str(buf, buf_len, buf_cap, ", ")
456 16 : call write_tokens_as_flow_seq(text(line_start:line_end), &
457 32 : & buf, buf_len, buf_cap)
458 16 : nlines = nlines + 1
459 : end if
460 16 : line_start = ii + 1
461 : end if
462 : end do
463 8 : call append_str(buf, buf_len, buf_cap, "]")
464 : else
465 : ! Flat array
466 9 : call write_tokens_as_flow_seq(text, buf, buf_len, buf_cap)
467 : end if
468 :
469 97 : end subroutine write_array_value
470 :
471 : !> Write space-separated tokens as a YAML flow sequence: [t1, t2, ...]
472 25 : subroutine write_tokens_as_flow_seq(line, buf, buf_len, buf_cap)
473 : character(len=*), intent(in) :: line
474 : character(len=:), allocatable, intent(inout) :: buf
475 : integer, intent(inout) :: buf_len, buf_cap
476 :
477 25 : integer :: ii, tok_start, tok_count
478 25 : logical :: in_token, is_sep
479 25 : character(len=:), allocatable :: token
480 :
481 25 : call append_str(buf, buf_len, buf_cap, "[")
482 25 : tok_count = 0
483 25 : in_token = .false.
484 25 : tok_start = 1
485 :
486 437 : do ii = 1, len(line) + 1
487 412 : if (ii > len(line)) then
488 25 : is_sep = .true.
489 : else
490 774 : is_sep = (line(ii:ii) == " " .or. line(ii:ii) == achar(9) &
491 1161 : & .or. line(ii:ii) == ",")
492 : end if
493 :
494 437 : if (is_sep) then
495 120 : if (in_token) then
496 84 : token = line(tok_start:ii - 1)
497 84 : if (tok_count > 0) call append_str(buf, buf_len, buf_cap, ", ")
498 152 : if (looks_like_number(token)) then
499 68 : call append_str(buf, buf_len, buf_cap, token)
500 16 : else if (is_hsd_boolean(token)) then
501 0 : call append_str(buf, buf_len, buf_cap, hsd_bool_to_yaml(token))
502 : else
503 16 : call append_str(buf, buf_len, buf_cap, yaml_quote_string(token))
504 : end if
505 84 : tok_count = tok_count + 1
506 84 : in_token = .false.
507 : end if
508 : else
509 292 : if (.not. in_token) then
510 84 : tok_start = ii
511 84 : in_token = .true.
512 : end if
513 : end if
514 : end do
515 25 : call append_str(buf, buf_len, buf_cap, "]")
516 :
517 42 : end subroutine write_tokens_as_flow_seq
518 :
519 : !> Write a table in flow style (compact mode): {key: value, ...}
520 9 : recursive subroutine write_flow_table(table, buf, buf_len, buf_cap)
521 : type(hsd_table), intent(in) :: table
522 : character(len=:), allocatable, intent(inout) :: buf
523 : integer, intent(inout) :: buf_len, buf_cap
524 :
525 9 : integer :: ii, jj, member_count, name_count
526 9 : character(len=:), allocatable :: child_name, key
527 9 : logical, allocatable :: emitted(:)
528 :
529 9 : call append_str(buf, buf_len, buf_cap, "{")
530 :
531 9 : member_count = 0
532 9 : allocate(emitted(table%num_children))
533 24 : emitted = .false.
534 :
535 24 : do ii = 1, table%num_children
536 15 : if (.not. associated(table%children(ii)%node)) cycle
537 15 : if (emitted(ii)) cycle
538 :
539 15 : child_name = get_child_name(table%children(ii)%node)
540 :
541 : ! Count same-named children
542 15 : name_count = 0
543 38 : do jj = ii, table%num_children
544 23 : if (.not. associated(table%children(jj)%node)) cycle
545 61 : if (get_child_name(table%children(jj)%node) == child_name) then
546 38 : name_count = name_count + 1
547 : end if
548 : end do
549 :
550 15 : if (member_count > 0) then
551 6 : call append_str(buf, buf_len, buf_cap, ", ")
552 : end if
553 :
554 24 : if (name_count > 1) then
555 : ! Flow sequence of values
556 0 : call append_str(buf, buf_len, buf_cap, yaml_key_str(child_name) // ": [")
557 : block
558 0 : integer :: arr_count
559 0 : arr_count = 0
560 0 : do jj = ii, table%num_children
561 0 : if (.not. associated(table%children(jj)%node)) cycle
562 0 : if (get_child_name(table%children(jj)%node) /= child_name) cycle
563 0 : emitted(jj) = .true.
564 0 : if (arr_count > 0) call append_str(buf, buf_len, buf_cap, ", ")
565 0 : select type (child => table%children(jj)%node)
566 : type is (hsd_table)
567 0 : call write_flow_table(child, buf, buf_len, buf_cap)
568 : type is (hsd_value)
569 0 : call write_value_content(child, buf, buf_len, buf_cap)
570 : end select
571 0 : arr_count = arr_count + 1
572 : end do
573 : end block
574 0 : call append_str(buf, buf_len, buf_cap, "]")
575 0 : member_count = member_count + 1
576 : else
577 15 : emitted(ii) = .true.
578 0 : select type (child => table%children(ii)%node)
579 : type is (hsd_table)
580 7 : if (allocated(child%name)) then
581 7 : if (len_trim(child%name) > 0) then
582 7 : key = child%name
583 : else
584 0 : key = ANON_VALUE_KEY
585 : end if
586 : else
587 0 : key = ANON_VALUE_KEY
588 : end if
589 7 : call append_str(buf, buf_len, buf_cap, yaml_key_str(key) // ": ")
590 7 : call write_flow_table(child, buf, buf_len, buf_cap)
591 7 : member_count = member_count + 1
592 :
593 : ! Attrib
594 14 : if (allocated(child%attrib)) then
595 1 : if (len_trim(child%attrib) > 0) then
596 1 : call append_str(buf, buf_len, buf_cap, ", ")
597 : call append_str(buf, buf_len, buf_cap, &
598 1 : & yaml_key_str(key // ATTRIB_SUFFIX) // ": ")
599 : call append_str(buf, buf_len, buf_cap, &
600 1 : & yaml_quote_string(child%attrib))
601 1 : member_count = member_count + 1
602 : end if
603 : end if
604 :
605 : type is (hsd_value)
606 8 : if (allocated(child%name)) then
607 8 : if (len_trim(child%name) > 0) then
608 8 : key = child%name
609 : else
610 0 : key = ANON_VALUE_KEY
611 : end if
612 : else
613 0 : key = ANON_VALUE_KEY
614 : end if
615 8 : call append_str(buf, buf_len, buf_cap, yaml_key_str(key) // ": ")
616 8 : call write_value_content(child, buf, buf_len, buf_cap)
617 8 : member_count = member_count + 1
618 :
619 : ! Attrib
620 16 : if (allocated(child%attrib)) then
621 1 : if (len_trim(child%attrib) > 0) then
622 1 : call append_str(buf, buf_len, buf_cap, ", ")
623 : call append_str(buf, buf_len, buf_cap, &
624 1 : & yaml_key_str(key // ATTRIB_SUFFIX) // ": ")
625 : call append_str(buf, buf_len, buf_cap, &
626 1 : & yaml_quote_string(child%attrib))
627 1 : member_count = member_count + 1
628 : end if
629 : end if
630 : end select
631 : end if
632 : end do
633 :
634 9 : call append_str(buf, buf_len, buf_cap, "}")
635 :
636 34 : end subroutine write_flow_table
637 :
638 :
639 : !> Format a YAML key. Quote if it contains special characters.
640 173 : pure function yaml_key_str(key) result(out)
641 : character(len=*), intent(in) :: key
642 : character(len=:), allocatable :: out
643 :
644 173 : if (needs_quoting_key(key)) then
645 17 : out = '"' // yaml_escape(key) // '"'
646 : else
647 156 : out = key
648 : end if
649 :
650 346 : end function yaml_key_str
651 :
652 :
653 : !> Check if a key needs quoting.
654 173 : pure function needs_quoting_key(str) result(needs)
655 : character(len=*), intent(in) :: str
656 : logical :: needs
657 :
658 173 : integer :: ii
659 :
660 173 : needs = .false.
661 173 : if (len(str) == 0) then
662 0 : needs = .true.
663 0 : return
664 : end if
665 :
666 : ! Check for special starting characters
667 : if (str(1:1) == '"' .or. str(1:1) == "'" .or. str(1:1) == "[" &
668 : & .or. str(1:1) == "]" .or. str(1:1) == "{" .or. str(1:1) == "}" &
669 : & .or. str(1:1) == "@" .or. str(1:1) == "`" .or. str(1:1) == "&" &
670 : & .or. str(1:1) == "*" .or. str(1:1) == "!" .or. str(1:1) == "|" &
671 : & .or. str(1:1) == ">" .or. str(1:1) == "%" .or. str(1:1) == "#" &
672 173 : & .or. str(1:1) == "~" .or. str(1:1) == "-" .or. str(1:1) == "?") then
673 17 : needs = .true.
674 17 : return
675 : end if
676 :
677 : ! Check for colon-space, hash-space, or special chars
678 1912 : do ii = 1, len(str)
679 1756 : if (str(ii:ii) == ":" .or. str(ii:ii) == "#") then
680 0 : needs = .true.
681 0 : return
682 : end if
683 : ! Non-printable or non-ASCII
684 1912 : if (iachar(str(ii:ii)) < 32) then
685 0 : needs = .true.
686 0 : return
687 : end if
688 : end do
689 :
690 : ! Check if it looks like a YAML boolean or null
691 156 : if (is_yaml_reserved(str)) then
692 0 : needs = .true.
693 0 : return
694 : end if
695 :
696 346 : end function needs_quoting_key
697 :
698 :
699 : !> Quote a string value for YAML output. Uses double quotes.
700 49 : pure function yaml_quote_string(str) result(quoted)
701 : character(len=*), intent(in) :: str
702 : character(len=:), allocatable :: quoted
703 :
704 49 : if (needs_quoting_value(str)) then
705 3 : quoted = '"' // yaml_escape(str) // '"'
706 : else
707 46 : quoted = str
708 : end if
709 :
710 173 : end function yaml_quote_string
711 :
712 :
713 : !> Check if a string value needs quoting.
714 49 : pure function needs_quoting_value(str) result(needs)
715 : character(len=*), intent(in) :: str
716 : logical :: needs
717 :
718 49 : integer :: ii
719 :
720 49 : needs = .false.
721 49 : if (len(str) == 0) then
722 0 : needs = .true.
723 0 : return
724 : end if
725 :
726 : ! Always quote if it might be confused with YAML types
727 49 : if (is_yaml_reserved(str)) then
728 0 : needs = .true.
729 0 : return
730 : end if
731 :
732 : ! Check for characters that require quoting
733 278 : do ii = 1, len(str)
734 232 : select case (str(ii:ii))
735 : case (":", "#", "[", "]", "{", "}", ",", "&", "*", "!", "|", ">", "'", '"', &
736 : & "%", "@", "`", "~", "?")
737 1 : needs = .true.
738 232 : return
739 : case default
740 232 : continue
741 : end select
742 : ! Control characters and newlines
743 231 : if (iachar(str(ii:ii)) < 32) then
744 2 : needs = .true.
745 2 : return
746 : end if
747 : ! Backslash
748 275 : if (str(ii:ii) == "\") then
749 0 : needs = .true.
750 0 : return
751 : end if
752 : end do
753 :
754 : ! Check if starts/ends with space
755 46 : if (str(1:1) == " " .or. str(len(str):len(str)) == " ") then
756 0 : needs = .true.
757 0 : return
758 : end if
759 :
760 98 : end function needs_quoting_value
761 :
762 :
763 : !> Check if a string is a YAML reserved word.
764 205 : pure function is_yaml_reserved(str) result(reserved)
765 : character(len=*), intent(in) :: str
766 : logical :: reserved
767 :
768 205 : character(len=:), allocatable :: lower
769 :
770 205 : reserved = .false.
771 205 : lower = to_lower(str)
772 :
773 : if (lower == "true" .or. lower == "false" .or. lower == "yes" &
774 : & .or. lower == "no" .or. lower == "null" .or. lower == "~" &
775 205 : & .or. lower == "on" .or. lower == "off") then
776 0 : reserved = .true.
777 : end if
778 :
779 254 : end function is_yaml_reserved
780 :
781 :
782 : !> Escape special characters for YAML double-quoted strings.
783 20 : pure function yaml_escape(str) result(escaped)
784 : character(len=*), intent(in) :: str
785 : character(len=:), allocatable :: escaped
786 :
787 20 : integer :: ii
788 :
789 20 : escaped = ""
790 199 : do ii = 1, len(str)
791 199 : select case (str(ii:ii))
792 : case ('"')
793 0 : escaped = escaped // '\"'
794 : case ("\")
795 0 : escaped = escaped // "\\"
796 : case default
797 179 : if (iachar(str(ii:ii)) == 10) then ! newline
798 4 : escaped = escaped // "\n"
799 175 : else if (iachar(str(ii:ii)) == 13) then ! CR
800 0 : escaped = escaped // "\r"
801 175 : else if (iachar(str(ii:ii)) == 9) then ! tab
802 0 : escaped = escaped // "\t"
803 175 : else if (iachar(str(ii:ii)) < 32) then ! other control chars
804 0 : escaped = escaped // "?"
805 : else
806 175 : escaped = escaped // str(ii:ii)
807 : end if
808 : end select
809 : end do
810 :
811 205 : end function yaml_escape
812 :
813 :
814 : !> Format a real number for YAML.
815 0 : subroutine format_real(rval, buf)
816 : real(dp), intent(in) :: rval
817 : character(len=64), intent(out) :: buf
818 :
819 0 : integer :: dot_pos, last_nonzero
820 :
821 0 : write(buf, "(g0)") rval
822 0 : buf = adjustl(buf)
823 :
824 : ! Ensure decimal point
825 0 : dot_pos = index(buf, ".")
826 0 : if (dot_pos == 0 .and. scan(buf, "eEdD") == 0) then
827 0 : buf = trim(buf) // ".0"
828 0 : return
829 : end if
830 :
831 0 : if (dot_pos == 0) return
832 :
833 : ! Strip trailing zeros
834 0 : last_nonzero = scan(buf, "eE") - 1
835 0 : if (last_nonzero < dot_pos) last_nonzero = len_trim(buf)
836 :
837 0 : do while (last_nonzero > dot_pos + 1 .and. buf(last_nonzero:last_nonzero) == "0")
838 0 : last_nonzero = last_nonzero - 1
839 : end do
840 :
841 0 : if (scan(buf, "eE") > 0) then
842 0 : buf = buf(1:last_nonzero) // buf(scan(buf, "eE"):len_trim(buf))
843 : else
844 0 : buf = buf(1:last_nonzero)
845 : end if
846 :
847 20 : end subroutine format_real
848 :
849 :
850 : ! ─── String sniffing helpers ───
851 :
852 : !> Check if a string looks like a number.
853 147 : pure function looks_like_number(str) result(is_num)
854 : character(len=*), intent(in) :: str
855 : logical :: is_num
856 :
857 147 : integer :: ii, slen
858 :
859 147 : is_num = .false.
860 147 : slen = len_trim(str)
861 0 : if (slen == 0) return
862 :
863 147 : ii = 1
864 147 : if (str(ii:ii) == "-" .or. str(ii:ii) == "+") then
865 0 : ii = ii + 1
866 0 : if (ii > slen) return
867 : end if
868 :
869 147 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") return
870 :
871 243 : do while (ii <= slen)
872 211 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
873 142 : ii = ii + 1
874 : end do
875 :
876 101 : if (ii <= slen) then
877 69 : if (str(ii:ii) == ".") then
878 65 : ii = ii + 1
879 65 : if (ii > slen) then
880 0 : is_num = .true.
881 0 : return
882 : end if
883 227 : do while (ii <= slen)
884 162 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
885 162 : ii = ii + 1
886 : end do
887 : end if
888 : end if
889 :
890 101 : if (ii <= slen) then
891 4 : if (str(ii:ii) == "e" .or. str(ii:ii) == "E") then
892 0 : ii = ii + 1
893 0 : if (ii <= slen .and. (str(ii:ii) == "+" .or. str(ii:ii) == "-")) &
894 0 : & ii = ii + 1
895 0 : if (ii > slen .or. str(ii:ii) < "0" .or. str(ii:ii) > "9") return
896 0 : do while (ii <= slen)
897 0 : if (str(ii:ii) < "0" .or. str(ii:ii) > "9") exit
898 0 : ii = ii + 1
899 : end do
900 : end if
901 : end if
902 :
903 101 : is_num = (ii > slen)
904 :
905 147 : end function looks_like_number
906 :
907 : !> Check if a string is an HSD boolean.
908 50 : pure function is_hsd_boolean(str) result(is_bool)
909 : character(len=*), intent(in) :: str
910 : logical :: is_bool
911 :
912 50 : character(len=:), allocatable :: lower
913 :
914 50 : is_bool = .false.
915 50 : lower = to_lower(str)
916 : is_bool = (lower == "yes" .or. lower == "no" .or. lower == "true" &
917 50 : & .or. lower == "false" .or. lower == ".true." .or. lower == ".false.")
918 :
919 197 : end function is_hsd_boolean
920 :
921 : !> Convert an HSD boolean string to YAML true/false.
922 21 : pure function hsd_bool_to_yaml(str) result(yaml)
923 : character(len=*), intent(in) :: str
924 : character(len=:), allocatable :: yaml
925 :
926 21 : character(len=:), allocatable :: lower
927 :
928 21 : lower = to_lower(str)
929 21 : if (lower == "yes" .or. lower == "true" .or. lower == ".true.") then
930 20 : yaml = "true"
931 : else
932 1 : yaml = "false"
933 : end if
934 :
935 71 : end function hsd_bool_to_yaml
936 :
937 : !> Convert string to lowercase.
938 276 : pure function to_lower(str) result(lower)
939 : character(len=*), intent(in) :: str
940 : character(len=:), allocatable :: lower
941 :
942 276 : integer :: ii, ic
943 :
944 276 : allocate(character(len=len_trim(str)) :: lower)
945 2612 : do ii = 1, len_trim(str)
946 2336 : ic = iachar(str(ii:ii))
947 2612 : if (ic >= iachar("A") .and. ic <= iachar("Z")) then
948 134 : lower(ii:ii) = achar(ic + 32)
949 : else
950 2202 : lower(ii:ii) = str(ii:ii)
951 : end if
952 : end do
953 :
954 21 : end function to_lower
955 :
956 :
957 : ! ─── Buffer utilities ───
958 :
959 657 : subroutine append_str(buf, buf_len, buf_cap, str)
960 : character(len=:), allocatable, intent(inout) :: buf
961 : integer, intent(inout) :: buf_len, buf_cap
962 : character(len=*), intent(in) :: str
963 :
964 657 : integer :: slen
965 :
966 657 : slen = len(str)
967 657 : call ensure_capacity(buf, buf_len, buf_cap, slen)
968 657 : buf(buf_len + 1:buf_len + slen) = str
969 657 : buf_len = buf_len + slen
970 :
971 276 : end subroutine append_str
972 :
973 156 : subroutine write_indent(buf, buf_len, buf_cap, depth)
974 : character(len=:), allocatable, intent(inout) :: buf
975 : integer, intent(inout) :: buf_len, buf_cap
976 : integer, intent(in) :: depth
977 :
978 156 : integer :: spaces
979 :
980 156 : spaces = depth * INDENT_WIDTH
981 156 : if (spaces > 0) then
982 119 : call ensure_capacity(buf, buf_len, buf_cap, spaces)
983 527 : buf(buf_len + 1:buf_len + spaces) = repeat(" ", spaces)
984 119 : buf_len = buf_len + spaces
985 : end if
986 :
987 657 : end subroutine write_indent
988 :
989 776 : subroutine ensure_capacity(buf, buf_len, buf_cap, needed)
990 : character(len=:), allocatable, intent(inout) :: buf
991 : integer, intent(in) :: buf_len, needed
992 : integer, intent(inout) :: buf_cap
993 :
994 776 : character(len=:), allocatable :: tmp
995 776 : integer :: new_cap
996 :
997 776 : if (buf_len + needed <= buf_cap) return
998 :
999 0 : new_cap = buf_cap * 2
1000 0 : do while (buf_len + needed > new_cap)
1001 0 : new_cap = new_cap * 2
1002 : end do
1003 :
1004 0 : allocate(character(len=new_cap) :: tmp)
1005 0 : tmp(1:buf_len) = buf(1:buf_len)
1006 0 : call move_alloc(tmp, buf)
1007 0 : buf_cap = new_cap
1008 :
1009 932 : end subroutine ensure_capacity
1010 :
1011 889 : end module hsd_data_yaml_writer
|
