Line data Source code
1 : !> HSD validation and verification
2 : !>
3 : !> This module provides utilities for validating HSD data, including
4 : !> required field checking, range validation, and unit conversion support.
5 : module hsd_validation
6 : use hsd_constants, only: dp
7 : use hsd_utils, only: to_lower
8 : use hsd_error, only: hsd_error_t, make_error, HSD_STAT_OK, HSD_STAT_NOT_FOUND, &
9 : HSD_STAT_TYPE_ERROR
10 : use hsd_types, only: hsd_node_t, NODE_TYPE_TABLE, NODE_TYPE_VALUE, &
11 : VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER, &
12 : VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY, VALUE_TYPE_COMPLEX
13 : use hsd_api, only: hsd_get_child
14 : implicit none (type, external)
15 : private
16 :
17 : ! Public procedures
18 : public :: hsd_require
19 : public :: hsd_validate_range
20 : public :: hsd_validate_one_of
21 : public :: hsd_get_with_unit
22 : public :: hsd_get_array_with_unit
23 : public :: hsd_get_matrix_with_unit
24 : public :: hsd_node_context
25 : public :: hsd_format_error
26 : public :: hsd_format_warning
27 : public :: hsd_warn_unprocessed
28 : public :: MAX_WARNING_LEN
29 :
30 : !> Maximum length for warning message strings
31 : integer, parameter :: MAX_WARNING_LEN = 256
32 :
33 : contains
34 :
35 : !> Require that a path exists and optionally check its type
36 : !>
37 : !> If the path doesn't exist or type doesn't match, creates a descriptive error.
38 : !>
39 : !> Both optional arguments should be passed as keyword arguments for clarity:
40 : !>
41 : !> call hsd_require(root, "Driver/MaxSteps", error, &
42 : !> expected_type=FIELD_TYPE_INTEGER, context="load_config")
43 18 : subroutine hsd_require(table, path, error, expected_type, context)
44 : type(hsd_node_t), intent(in), target :: table
45 : character(len=*), intent(in) :: path
46 : type(hsd_error_t), allocatable, intent(out) :: error
47 : integer, intent(in), optional :: expected_type
48 : character(len=*), intent(in), optional :: context
49 :
50 : type(hsd_node_t), pointer :: child
51 18 : integer :: local_stat, actual_type
52 18 : character(len=:), allocatable :: ctx_prefix
53 :
54 18 : call hsd_get_child(table, path, child, local_stat)
55 :
56 18 : if (present(context)) then
57 2 : ctx_prefix = context // ": "
58 : else
59 16 : ctx_prefix = ""
60 : end if
61 :
62 18 : if (local_stat /= 0 .or. .not. associated(child)) then
63 : call make_error(error, HSD_STAT_NOT_FOUND, &
64 5 : ctx_prefix // "Required field '" // path // "' not found")
65 5 : return
66 : end if
67 :
68 13 : if (present(expected_type)) then
69 10 : if (child%node_type == NODE_TYPE_VALUE) then
70 9 : actual_type = child%value_type
71 9 : if (expected_type /= actual_type) then
72 : call make_error(error, HSD_STAT_TYPE_ERROR, &
73 : ctx_prefix // "Field '" // path // &
74 : & "' has wrong type: expected " // &
75 : type_name(expected_type) // ", got " // &
76 8 : & type_name(actual_type))
77 : end if
78 1 : else if (child%node_type == NODE_TYPE_TABLE) then
79 1 : if (expected_type /= VALUE_TYPE_NONE) then
80 : call make_error(error, HSD_STAT_TYPE_ERROR, &
81 : ctx_prefix // "Field '" // path // &
82 : & "' is a table, expected value of type " // &
83 1 : type_name(expected_type))
84 : end if
85 : end if
86 : end if
87 :
88 18 : end subroutine hsd_require
89 :
90 : !> Get a human-readable name for a value type
91 17 : pure function type_name(val_type) result(name)
92 : integer, intent(in) :: val_type
93 : character(len=:), allocatable :: name
94 :
95 18 : select case (val_type)
96 : case (VALUE_TYPE_NONE)
97 1 : name = "none"
98 : case (VALUE_TYPE_STRING)
99 8 : name = "string"
100 : case (VALUE_TYPE_INTEGER)
101 3 : name = "integer"
102 : case (VALUE_TYPE_REAL)
103 1 : name = "real"
104 : case (VALUE_TYPE_LOGICAL)
105 1 : name = "logical"
106 : case (VALUE_TYPE_ARRAY)
107 1 : name = "array"
108 : case (VALUE_TYPE_COMPLEX)
109 1 : name = "complex"
110 : case default
111 1 : name = "unknown"
112 : end select
113 :
114 18 : end function type_name
115 :
116 : !> Validate that a real value is within a specified range
117 12 : subroutine hsd_validate_range(table, path, min_val, max_val, error, context)
118 : type(hsd_node_t), intent(in), target :: table
119 : character(len=*), intent(in) :: path
120 : real(dp), intent(in) :: min_val, max_val
121 : type(hsd_error_t), allocatable, intent(out) :: error
122 : character(len=*), intent(in), optional :: context
123 :
124 : type(hsd_node_t), pointer :: child
125 12 : real(dp) :: val
126 12 : integer :: local_stat
127 : character(len=32) :: min_str, max_str, val_str
128 12 : character(len=:), allocatable :: ctx_prefix
129 :
130 12 : call hsd_get_child(table, path, child, local_stat)
131 :
132 12 : if (present(context)) then
133 1 : ctx_prefix = context // ": "
134 : else
135 11 : ctx_prefix = ""
136 : end if
137 :
138 12 : if (local_stat /= HSD_STAT_OK .or. .not. associated(child)) then
139 : call make_error(error, local_stat, &
140 2 : ctx_prefix // "Field '" // path // "' not found or invalid type for range validation")
141 2 : return
142 : end if
143 :
144 10 : if (child%node_type == NODE_TYPE_VALUE) then
145 8 : call child%get_real(val, local_stat)
146 8 : if (local_stat /= HSD_STAT_OK) then
147 : call make_error(error, HSD_STAT_TYPE_ERROR, &
148 : ctx_prefix // "Field '" // path // &
149 1 : & "' is not a real number")
150 1 : return
151 : end if
152 :
153 7 : if (val < min_val .or. val > max_val) then
154 5 : write(min_str, '(G0)') min_val
155 5 : write(max_str, '(G0)') max_val
156 5 : write(val_str, '(G0)') val
157 : call make_error(error, HSD_STAT_TYPE_ERROR, &
158 : ctx_prefix // "Field '" // path // &
159 : & "' value " // trim(val_str) // &
160 : " is outside valid range [" // trim(min_str) // &
161 5 : & ", " // trim(max_str) // "]")
162 : end if
163 : else
164 : call make_error(error, HSD_STAT_TYPE_ERROR, &
165 : ctx_prefix // "Field '" // path // &
166 2 : & "' is not a value node")
167 : end if
168 :
169 29 : end subroutine hsd_validate_range
170 :
171 : !> Validate that a string value is one of the allowed choices
172 18 : subroutine hsd_validate_one_of(table, path, choices, error, context)
173 : type(hsd_node_t), intent(in), target :: table
174 : character(len=*), intent(in) :: path
175 : character(len=*), intent(in) :: choices(:)
176 : type(hsd_error_t), allocatable, intent(out) :: error
177 : character(len=*), intent(in), optional :: context
178 :
179 : type(hsd_node_t), pointer :: child
180 9 : character(len=:), allocatable :: val, choices_str, ctx_prefix
181 9 : integer :: i, local_stat
182 9 : logical :: found
183 :
184 9 : call hsd_get_child(table, path, child, local_stat)
185 :
186 9 : if (present(context)) then
187 1 : ctx_prefix = context // ": "
188 : else
189 8 : ctx_prefix = ""
190 : end if
191 :
192 9 : if (local_stat /= HSD_STAT_OK .or. .not. associated(child)) then
193 : call make_error(error, local_stat, &
194 1 : ctx_prefix // "Field '" // path // "' not found")
195 1 : return
196 : end if
197 :
198 8 : if (child%node_type == NODE_TYPE_VALUE) then
199 6 : call child%get_string(val, local_stat)
200 6 : if (local_stat /= HSD_STAT_OK) then
201 : call make_error(error, HSD_STAT_TYPE_ERROR, &
202 : ctx_prefix // "Field '" // path // &
203 0 : & "' is not a string")
204 0 : return
205 : end if
206 :
207 6 : found = .false.
208 16 : do i = 1, size(choices)
209 42 : if (to_lower(val) == to_lower(choices(i))) then
210 3 : found = .true.
211 26 : exit
212 : end if
213 : end do
214 :
215 6 : if (.not. found) then
216 3 : choices_str = ""
217 12 : do i = 1, size(choices)
218 15 : if (i > 1) choices_str = choices_str // ", "
219 : choices_str = choices_str // "'" // &
220 12 : & trim(choices(i)) // "'"
221 : end do
222 : call make_error(error, HSD_STAT_TYPE_ERROR, &
223 : ctx_prefix // "Field '" // path // &
224 : & "' value '" // val // &
225 3 : "' is not one of: " // choices_str)
226 : end if
227 : else
228 : call make_error(error, HSD_STAT_TYPE_ERROR, &
229 : ctx_prefix // "Field '" // path // &
230 2 : & "' is not a value node")
231 : end if
232 :
233 21 : end subroutine hsd_validate_one_of
234 :
235 : !> Get a real value with automatic unit conversion
236 : !>
237 : !> The unit is read from the node's attribute and converted to the target unit.
238 : !> The converter function takes (value, from_unit, to_unit) and returns the converted value.
239 : !>
240 : !> Example:
241 : !> For input `Temperature [Kelvin] = 300`, calling
242 : !> `hsd_get_with_unit(root, "Temperature", val, "Celsius", converter)`
243 : !> would call `converter(300.0, "Kelvin", "Celsius")` to get the result.
244 5 : subroutine hsd_get_with_unit(table, path, val, target_unit, converter, stat)
245 : type(hsd_node_t), intent(in), target :: table
246 : character(len=*), intent(in) :: path
247 : real(dp), intent(out) :: val
248 : character(len=*), intent(in) :: target_unit
249 : interface
250 : pure function converter(value, from_unit, to_unit) result(converted)
251 : import :: dp
252 : implicit none (type, external)
253 : real(dp), intent(in) :: value
254 : character(len=*), intent(in) :: from_unit, to_unit
255 : real(dp) :: converted
256 : end function converter
257 : end interface
258 : integer, intent(out), optional :: stat
259 :
260 : type(hsd_node_t), pointer :: child
261 5 : character(len=:), allocatable :: source_unit
262 5 : real(dp) :: raw_val
263 5 : integer :: local_stat
264 :
265 5 : val = 0.0_dp
266 :
267 5 : call hsd_get_child(table, path, child, local_stat)
268 5 : if (local_stat /= 0 .or. .not. associated(child)) then
269 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
270 1 : return
271 : end if
272 :
273 4 : if (child%node_type == NODE_TYPE_VALUE) then
274 3 : call child%get_real(raw_val, local_stat)
275 3 : if (local_stat /= HSD_STAT_OK) then
276 1 : if (present(stat)) stat = local_stat
277 1 : return
278 : end if
279 :
280 2 : if (allocated(child%attrib)) then
281 1 : source_unit = child%attrib
282 : else
283 1 : source_unit = target_unit ! No conversion needed
284 : end if
285 :
286 2 : val = converter(raw_val, source_unit, target_unit)
287 2 : if (present(stat)) stat = HSD_STAT_OK
288 :
289 : else
290 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
291 : end if
292 :
293 14 : end subroutine hsd_get_with_unit
294 :
295 : !> Get a real array with unit conversion
296 : !>
297 : !> Reads a real(:) array from the node at `path`, extracts the unit from
298 : !> the node's `attrib` field, and applies the `converter` function to each
299 : !> element. If no unit attribute is present, assumes `target_unit`.
300 4 : subroutine hsd_get_array_with_unit(table, path, val, target_unit, converter, stat)
301 : type(hsd_node_t), intent(in), target :: table
302 : character(len=*), intent(in) :: path
303 : real(dp), allocatable, intent(out) :: val(:)
304 : character(len=*), intent(in) :: target_unit
305 : interface
306 : pure function converter(value, from_unit, to_unit) result(converted)
307 : import :: dp
308 : implicit none (type, external)
309 : real(dp), intent(in) :: value
310 : character(len=*), intent(in) :: from_unit, to_unit
311 : real(dp) :: converted
312 : end function converter
313 : end interface
314 : integer, intent(out), optional :: stat
315 :
316 : type(hsd_node_t), pointer :: child
317 4 : character(len=:), allocatable :: source_unit
318 4 : integer :: local_stat, i
319 :
320 4 : call hsd_get_child(table, path, child, local_stat)
321 4 : if (local_stat /= 0 .or. .not. associated(child)) then
322 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
323 1 : allocate(val(0))
324 1 : return
325 : end if
326 :
327 3 : if (child%node_type == NODE_TYPE_VALUE) then
328 2 : call child%get_real_array(val, local_stat)
329 2 : if (local_stat /= HSD_STAT_OK) then
330 0 : if (present(stat)) stat = local_stat
331 0 : return
332 : end if
333 :
334 2 : if (allocated(child%attrib)) then
335 1 : source_unit = child%attrib
336 : else
337 1 : source_unit = target_unit
338 : end if
339 :
340 7 : do i = 1, size(val)
341 7 : val(i) = converter(val(i), source_unit, target_unit)
342 : end do
343 :
344 2 : if (present(stat)) stat = HSD_STAT_OK
345 :
346 : else
347 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
348 1 : allocate(val(0))
349 : end if
350 :
351 9 : end subroutine hsd_get_array_with_unit
352 :
353 : !> Get a real matrix with unit conversion
354 : !>
355 : !> Reads a real(:,:) matrix from the node at `path`, extracts the unit from
356 : !> the node's `attrib` field, and applies the `converter` function to each
357 : !> element. If no unit attribute is present, assumes `target_unit`.
358 3 : subroutine hsd_get_matrix_with_unit(table, path, val, nrows, ncols, &
359 : target_unit, converter, stat)
360 : type(hsd_node_t), intent(in), target :: table
361 : character(len=*), intent(in) :: path
362 : real(dp), allocatable, intent(out) :: val(:,:)
363 : integer, intent(out) :: nrows, ncols
364 : character(len=*), intent(in) :: target_unit
365 : interface
366 : pure function converter(value, from_unit, to_unit) result(converted)
367 : import :: dp
368 : implicit none (type, external)
369 : real(dp), intent(in) :: value
370 : character(len=*), intent(in) :: from_unit, to_unit
371 : real(dp) :: converted
372 : end function converter
373 : end interface
374 : integer, intent(out), optional :: stat
375 :
376 : type(hsd_node_t), pointer :: child
377 3 : character(len=:), allocatable :: source_unit
378 3 : integer :: local_stat, i, j
379 :
380 3 : nrows = 0
381 3 : ncols = 0
382 :
383 3 : call hsd_get_child(table, path, child, local_stat)
384 3 : if (local_stat /= 0 .or. .not. associated(child)) then
385 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
386 1 : allocate(val(0, 0))
387 1 : return
388 : end if
389 :
390 2 : if (child%node_type == NODE_TYPE_VALUE) then
391 1 : call child%get_real_matrix(val, nrows, ncols, local_stat)
392 1 : if (local_stat /= HSD_STAT_OK) then
393 0 : if (present(stat)) stat = local_stat
394 0 : return
395 : end if
396 :
397 1 : if (allocated(child%attrib)) then
398 1 : source_unit = child%attrib
399 : else
400 0 : source_unit = target_unit
401 : end if
402 :
403 4 : do j = 1, ncols
404 10 : do i = 1, nrows
405 6 : val(i, j) = converter(val(i, j), source_unit, &
406 15 : & target_unit)
407 : end do
408 : end do
409 :
410 1 : if (present(stat)) stat = HSD_STAT_OK
411 :
412 : else
413 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
414 1 : allocate(val(0, 0))
415 : end if
416 :
417 7 : end subroutine hsd_get_matrix_with_unit
418 :
419 :
420 : !> Get context string for an HSD node (for error messages)
421 : !>
422 : !> Returns "NodeName (line N)" if line info is available, or just "NodeName".
423 : !> Returns "" if the node has no name.
424 6 : function hsd_node_context(node) result(ctx)
425 : type(hsd_node_t), intent(in) :: node
426 : character(len=:), allocatable :: ctx
427 :
428 : character(len=20) :: linebuf
429 :
430 6 : if (allocated(node%name) .and. node%line > 0) then
431 3 : write(linebuf, '(i0)') node%line
432 3 : ctx = "'" // node%name // "' (line " // trim(linebuf) // ")"
433 3 : else if (allocated(node%name)) then
434 1 : ctx = "'" // node%name // "'"
435 : else
436 2 : ctx = ""
437 : end if
438 :
439 3 : end function hsd_node_context
440 :
441 :
442 : !> Format an error message with node context
443 : !>
444 : !> Returns "Error in 'NodeName' (line N): <msg>" or just <msg> if no context.
445 : !> This is a general-purpose utility for producing user-friendly error messages
446 : !> that include the location in the input file where the error occurred.
447 2 : subroutine hsd_format_error(node, msg, formatted)
448 : type(hsd_node_t), intent(in) :: node
449 : character(len=*), intent(in) :: msg
450 : character(len=:), allocatable, intent(out) :: formatted
451 :
452 2 : character(len=:), allocatable :: ctx
453 :
454 2 : ctx = hsd_node_context(node)
455 2 : if (len(ctx) > 0) then
456 1 : formatted = "Error in " // ctx // ": " // msg
457 : else
458 1 : formatted = msg
459 : end if
460 :
461 8 : end subroutine hsd_format_error
462 :
463 :
464 : !> Format a warning message with node context
465 : !>
466 : !> Returns "Warning in 'NodeName' (line N): <msg>" or just <msg> if no context.
467 2 : subroutine hsd_format_warning(node, msg, formatted)
468 : type(hsd_node_t), intent(in) :: node
469 : character(len=*), intent(in) :: msg
470 : character(len=:), allocatable, intent(out) :: formatted
471 :
472 2 : character(len=:), allocatable :: ctx
473 :
474 2 : ctx = hsd_node_context(node)
475 2 : if (len(ctx) > 0) then
476 1 : formatted = "Warning in " // ctx // ": " // msg
477 : else
478 1 : formatted = msg
479 : end if
480 :
481 4 : end subroutine hsd_format_warning
482 :
483 :
484 : !> Walk a table's children and collect warnings for unprocessed nodes.
485 : !>
486 : !> Any non-"#text" child that has `processed == .false.` and `line > 0`
487 : !> (i.e., it came from the parsed input, not programmatic defaults) is
488 : !> reported. Processed table children are recursed into so that deeply
489 : !> nested unprocessed nodes are also caught.
490 : !>
491 : !> Usage:
492 : !> ```fortran
493 : !> character(len=MAX_WARNING_LEN), allocatable :: warnings(:)
494 : !> call hsd_warn_unprocessed(root, warnings)
495 : !> do i = 1, size(warnings)
496 : !> write(*, '(A)') trim(warnings(i))
497 : !> end do
498 : !> ```
499 2 : subroutine hsd_warn_unprocessed(root, warnings)
500 : type(hsd_node_t), intent(in) :: root
501 : character(len=MAX_WARNING_LEN), allocatable, intent(out) :: warnings(:)
502 :
503 2 : character(len=MAX_WARNING_LEN), allocatable :: tmp(:)
504 2 : integer :: nwarn
505 :
506 2 : allocate(tmp(32))
507 2 : nwarn = 0
508 2 : call collect_unprocessed_(root, tmp, nwarn)
509 2 : allocate(warnings(nwarn))
510 43 : if (nwarn > 0) warnings(:) = tmp(1:nwarn)
511 :
512 4 : end subroutine hsd_warn_unprocessed
513 :
514 :
515 : !> Recursive helper: collect unprocessed node warnings into a growable array.
516 0 : recursive subroutine collect_unprocessed_(node, buf, nwarn)
517 : type(hsd_node_t), intent(in) :: node
518 : character(len=MAX_WARNING_LEN), allocatable, intent(inout) :: buf(:)
519 : integer, intent(inout) :: nwarn
520 :
521 2 : integer :: ii
522 : type(hsd_node_t), pointer :: child
523 2 : character(len=MAX_WARNING_LEN), allocatable :: tmp(:)
524 : character(len=20) :: linebuf
525 :
526 44 : do ii = 1, node%num_children
527 42 : call node%get_child(ii, child)
528 42 : if (.not. associated(child)) cycle
529 :
530 : ! Skip anonymous or #text value nodes
531 42 : if (.not. allocated(child%name)) cycle
532 42 : if (child%name == "#text") cycle
533 :
534 42 : if (.not. child%processed .and. child%line > 0) then
535 : ! Grow buffer if needed
536 41 : if (nwarn >= size(buf)) then
537 1 : allocate(tmp(size(buf) * 2))
538 33 : tmp(1:nwarn) = buf(1:nwarn)
539 1 : call move_alloc(tmp, buf)
540 : end if
541 41 : nwarn = nwarn + 1
542 41 : if (child%line > 0) then
543 41 : write(linebuf, '(i0)') child%line
544 0 : buf(nwarn) = "Unprocessed input: '" // trim(child%name) &
545 41 : & // "' (line " // trim(linebuf) // ")"
546 : else
547 0 : buf(nwarn) = "Unprocessed input: '" // trim(child%name) // "'"
548 : end if
549 : end if
550 :
551 : ! Recurse into processed table children
552 44 : if (child%node_type == NODE_TYPE_TABLE) then
553 0 : if (child%processed) &
554 0 : & call collect_unprocessed_(child, buf, nwarn)
555 : end if
556 : end do
557 :
558 4 : end subroutine collect_unprocessed_
559 :
560 15 : end module hsd_validation
|
