Line data Source code
1 : !> HSD Schema Validation
2 : !>
3 : !> This module provides declarative schema validation for HSD data structures.
4 : !> Schemas define the expected structure of HSD documents including required
5 : !> fields, optional fields, type constraints, value ranges, and enumerations.
6 : !>
7 : !> ## Example Usage
8 : !>
9 : !> ```fortran
10 : !> use hsd
11 : !> use hsd_schema
12 : !>
13 : !> type(hsd_schema_t) :: schema
14 : !> type(hsd_table) :: root
15 : !> type(hsd_error_t), allocatable :: errors(:)
16 : !>
17 : !> ! Define schema
18 : !> call schema_init(schema)
19 : !> call schema_add_field(schema, "Geometry", FIELD_REQUIRED, FIELD_TYPE_TABLE)
20 : !> call schema_add_field(schema, "Geometry/Periodic", FIELD_OPTIONAL, FIELD_TYPE_LOGICAL)
21 : !> call schema_add_field(schema, "Hamiltonian", FIELD_REQUIRED, FIELD_TYPE_TABLE)
22 : !> call schema_add_field(schema, "Hamiltonian/MaxSCCIterations", FIELD_OPTIONAL, &
23 : !> FIELD_TYPE_INTEGER, min_int=1, max_int=1000)
24 : !> call schema_add_field(schema, "Hamiltonian/Mixer", FIELD_OPTIONAL, FIELD_TYPE_STRING, &
25 : !> allowed_values=["Broyden", "Anderson", "Simple"])
26 : !>
27 : !> ! Load and validate
28 : !> call hsd_load("input.hsd", root, error)
29 : !> call schema_validate(schema, root, errors)
30 : !>
31 : !> if (size(errors) > 0) then
32 : !> do i = 1, size(errors)
33 : !> call errors(i)%print()
34 : !> end do
35 : !> end if
36 : !>
37 : !> call schema_destroy(schema)
38 : !> ```
39 : !>
40 : !> ## Thread Safety
41 : !>
42 : !> Schema objects are NOT thread-safe. Do not share a schema object between
43 : !> threads without external synchronization. However, validation of different
44 : !> HSD trees with the same (immutable) schema is thread-safe.
45 : module hsd_schema
46 : use hsd_constants, only: dp
47 : use hsd_utils, only: to_lower
48 : use hsd_error, only: hsd_error_t, make_error, HSD_STAT_OK, HSD_STAT_NOT_FOUND, &
49 : HSD_STAT_TYPE_ERROR
50 : use hsd_types, only: hsd_node, hsd_table, hsd_value, &
51 : VALUE_TYPE_NONE, VALUE_TYPE_STRING, VALUE_TYPE_INTEGER, &
52 : VALUE_TYPE_REAL, VALUE_TYPE_LOGICAL, VALUE_TYPE_ARRAY, VALUE_TYPE_COMPLEX
53 : use hsd_query, only: hsd_get_child, hsd_has_child, hsd_child_count
54 : implicit none (type, external)
55 : private
56 :
57 : ! Public types
58 : public :: hsd_schema_t, hsd_field_def_t
59 :
60 : ! Public constants
61 : public :: FIELD_REQUIRED, FIELD_OPTIONAL
62 : public :: FIELD_TYPE_ANY, FIELD_TYPE_STRING, FIELD_TYPE_INTEGER
63 : public :: FIELD_TYPE_REAL, FIELD_TYPE_LOGICAL, FIELD_TYPE_TABLE
64 : public :: FIELD_TYPE_ARRAY, FIELD_TYPE_COMPLEX
65 :
66 : ! Public procedures
67 : public :: schema_init, schema_destroy
68 : public :: schema_add_field, schema_add_field_enum
69 : public :: schema_validate, schema_validate_strict
70 :
71 : !> Field requirement constants
72 : integer, parameter :: FIELD_REQUIRED = 1
73 : integer, parameter :: FIELD_OPTIONAL = 2
74 :
75 : !> Field type constants (map to VALUE_TYPE_* for values, plus TABLE)
76 : integer, parameter :: FIELD_TYPE_ANY = -1
77 : integer, parameter :: FIELD_TYPE_STRING = VALUE_TYPE_STRING
78 : integer, parameter :: FIELD_TYPE_INTEGER = VALUE_TYPE_INTEGER
79 : integer, parameter :: FIELD_TYPE_REAL = VALUE_TYPE_REAL
80 : integer, parameter :: FIELD_TYPE_LOGICAL = VALUE_TYPE_LOGICAL
81 : integer, parameter :: FIELD_TYPE_ARRAY = VALUE_TYPE_ARRAY
82 : integer, parameter :: FIELD_TYPE_COMPLEX = VALUE_TYPE_COMPLEX
83 : integer, parameter :: FIELD_TYPE_TABLE = 100 ! Special marker for table
84 :
85 : !> Maximum number of allowed values for enum validation
86 : integer, parameter :: MAX_ENUM_VALUES = 32
87 :
88 : !> Schema validation error code
89 : integer, parameter, public :: HSD_STAT_SCHEMA_ERROR = 20
90 :
91 : !> Field definition
92 : type :: hsd_field_def_t
93 : !> Path to the field (e.g., "Geometry/Periodic")
94 : character(len=:), allocatable :: path
95 : !> Whether field is required or optional
96 : integer :: requirement = FIELD_OPTIONAL
97 : !> Expected type (FIELD_TYPE_*)
98 : integer :: field_type = FIELD_TYPE_ANY
99 : !> Minimum integer value (if applicable)
100 : integer :: min_int = -huge(1)
101 : !> Maximum integer value (if applicable)
102 : integer :: max_int = huge(1)
103 : !> Minimum real value (if applicable)
104 : real(dp) :: min_real = -huge(1.0_dp)
105 : !> Maximum real value (if applicable)
106 : real(dp) :: max_real = huge(1.0_dp)
107 : !> Allowed string values (for enum validation)
108 : character(len=64) :: allowed_values(MAX_ENUM_VALUES) = ""
109 : !> Number of allowed values
110 : integer :: num_allowed = 0
111 : !> Whether range constraints are active
112 : logical :: has_int_range = .false.
113 : logical :: has_real_range = .false.
114 : !> Description for error messages
115 : character(len=:), allocatable :: description
116 : end type hsd_field_def_t
117 :
118 : !> Schema definition
119 : type :: hsd_schema_t
120 : !> Field definitions
121 : type(hsd_field_def_t), allocatable :: fields(:)
122 : !> Number of fields defined
123 : integer :: num_fields = 0
124 : !> Capacity of fields array
125 : integer :: capacity = 0
126 : !> Schema name/description
127 : character(len=:), allocatable :: name
128 : !> Whether to allow unknown fields (default: yes)
129 : logical :: allow_unknown = .true.
130 : contains
131 : procedure :: init => schema_init_method
132 : procedure :: destroy => schema_destroy_method
133 : procedure :: add_field => schema_add_field_method
134 : procedure :: validate => schema_validate_method
135 : end type hsd_schema_t
136 :
137 : contains
138 :
139 : !> Initialize a schema
140 68 : subroutine schema_init(schema, name, allow_unknown)
141 : type(hsd_schema_t), intent(out) :: schema
142 : character(len=*), intent(in), optional :: name
143 : logical, intent(in), optional :: allow_unknown
144 :
145 34 : call schema%init(name, allow_unknown)
146 :
147 68 : end subroutine schema_init
148 :
149 : !> Initialize a schema (method)
150 78 : subroutine schema_init_method(self, name, allow_unknown)
151 : class(hsd_schema_t), intent(out) :: self
152 : character(len=*), intent(in), optional :: name
153 : logical, intent(in), optional :: allow_unknown
154 :
155 39 : self%capacity = 16
156 1911 : allocate(self%fields(self%capacity))
157 39 : self%num_fields = 0
158 :
159 39 : if (present(name)) self%name = name
160 39 : if (present(allow_unknown)) self%allow_unknown = allow_unknown
161 :
162 34 : end subroutine schema_init_method
163 :
164 : !> Destroy a schema
165 34 : subroutine schema_destroy(schema)
166 : type(hsd_schema_t), intent(inout) :: schema
167 34 : call schema%destroy()
168 39 : end subroutine schema_destroy
169 :
170 : !> Destroy a schema (method)
171 39 : subroutine schema_destroy_method(self)
172 : class(hsd_schema_t), intent(inout) :: self
173 39 : integer :: i
174 :
175 39 : if (allocated(self%fields)) then
176 128 : do i = 1, self%num_fields
177 89 : if (allocated(self%fields(i)%path)) deallocate(self%fields(i)%path)
178 128 : if (allocated(self%fields(i)%description)) deallocate(self%fields(i)%description)
179 : end do
180 750 : deallocate(self%fields)
181 : end if
182 39 : if (allocated(self%name)) deallocate(self%name)
183 39 : self%num_fields = 0
184 39 : self%capacity = 0
185 :
186 34 : end subroutine schema_destroy_method
187 :
188 : !> Add a field definition to the schema
189 89 : subroutine schema_add_field(schema, path, requirement, field_type, &
190 : min_int, max_int, min_real, max_real, description)
191 : type(hsd_schema_t), intent(inout) :: schema
192 : character(len=*), intent(in) :: path
193 : integer, intent(in) :: requirement
194 : integer, intent(in), optional :: field_type
195 : integer, intent(in), optional :: min_int, max_int
196 : real(dp), intent(in), optional :: min_real, max_real
197 : character(len=*), intent(in), optional :: description
198 :
199 89 : type(hsd_field_def_t), allocatable :: tmp(:)
200 89 : integer :: new_capacity
201 :
202 : ! Initialize if needed
203 0 : if (schema%capacity == 0) call schema%init()
204 :
205 : ! Grow array if needed
206 89 : if (schema%num_fields >= schema%capacity) then
207 2 : new_capacity = schema%capacity * 2
208 162 : allocate(tmp(new_capacity))
209 50 : tmp(1:schema%num_fields) = schema%fields(1:schema%num_fields)
210 52 : call move_alloc(tmp, schema%fields)
211 2 : schema%capacity = new_capacity
212 : end if
213 :
214 : ! Add field definition
215 89 : schema%num_fields = schema%num_fields + 1
216 89 : schema%fields(schema%num_fields)%path = path
217 89 : schema%fields(schema%num_fields)%requirement = requirement
218 :
219 89 : if (present(field_type)) then
220 87 : schema%fields(schema%num_fields)%field_type = field_type
221 : end if
222 :
223 89 : if (present(min_int)) then
224 4 : schema%fields(schema%num_fields)%min_int = min_int
225 4 : schema%fields(schema%num_fields)%has_int_range = .true.
226 : end if
227 89 : if (present(max_int)) then
228 4 : schema%fields(schema%num_fields)%max_int = max_int
229 4 : schema%fields(schema%num_fields)%has_int_range = .true.
230 : end if
231 :
232 89 : if (present(min_real)) then
233 4 : schema%fields(schema%num_fields)%min_real = min_real
234 4 : schema%fields(schema%num_fields)%has_real_range = .true.
235 : end if
236 89 : if (present(max_real)) then
237 4 : schema%fields(schema%num_fields)%max_real = max_real
238 4 : schema%fields(schema%num_fields)%has_real_range = .true.
239 : end if
240 :
241 89 : if (present(description)) then
242 3 : schema%fields(schema%num_fields)%description = description
243 : end if
244 :
245 128 : end subroutine schema_add_field
246 :
247 : !> Add a field with enumerated allowed values
248 8 : subroutine schema_add_field_enum(schema, path, requirement, allowed_values, description)
249 : type(hsd_schema_t), intent(inout) :: schema
250 : character(len=*), intent(in) :: path
251 : integer, intent(in) :: requirement
252 : character(len=*), intent(in) :: allowed_values(:)
253 : character(len=*), intent(in), optional :: description
254 :
255 4 : integer :: i, n
256 :
257 : call schema_add_field(schema, path, requirement, FIELD_TYPE_STRING, &
258 4 : description=description)
259 :
260 4 : n = min(size(allowed_values), MAX_ENUM_VALUES)
261 16 : do i = 1, n
262 16 : schema%fields(schema%num_fields)%allowed_values(i) = trim(allowed_values(i))
263 : end do
264 4 : schema%fields(schema%num_fields)%num_allowed = n
265 :
266 89 : end subroutine schema_add_field_enum
267 :
268 : !> Add a field to schema (method wrapper)
269 1 : subroutine schema_add_field_method(self, path, requirement, field_type, &
270 : min_int, max_int, min_real, max_real, description)
271 : class(hsd_schema_t), intent(inout) :: self
272 : character(len=*), intent(in) :: path
273 : integer, intent(in) :: requirement
274 : integer, intent(in), optional :: field_type
275 : integer, intent(in), optional :: min_int, max_int
276 : real(dp), intent(in), optional :: min_real, max_real
277 : character(len=*), intent(in), optional :: description
278 :
279 : call schema_add_field(self, path, requirement, field_type, &
280 1 : min_int, max_int, min_real, max_real, description)
281 :
282 4 : end subroutine schema_add_field_method
283 :
284 : !> Validate an HSD tree against the schema
285 : !>
286 : !> Returns an array of all validation errors found.
287 55 : subroutine schema_validate(schema, root, errors)
288 : type(hsd_schema_t), intent(in) :: schema
289 : type(hsd_table), intent(in), target :: root
290 : type(hsd_error_t), allocatable, intent(out) :: errors(:)
291 :
292 55 : type(hsd_error_t), allocatable :: error_list(:)
293 55 : type(hsd_error_t), allocatable :: error
294 55 : integer :: i, num_errors
295 :
296 113 : allocate(error_list(schema%num_fields))
297 55 : num_errors = 0
298 :
299 113 : do i = 1, schema%num_fields
300 58 : call validate_field(root, schema%fields(i), error)
301 113 : if (allocated(error)) then
302 26 : num_errors = num_errors + 1
303 26 : error_list(num_errors) = error
304 26 : deallocate(error)
305 : end if
306 : end do
307 :
308 : ! Return only actual errors
309 55 : if (num_errors > 0) then
310 49 : allocate(errors(num_errors))
311 49 : errors = error_list(1:num_errors)
312 : else
313 32 : allocate(errors(0))
314 : end if
315 :
316 114 : end subroutine schema_validate
317 :
318 : !> Validate an HSD tree strictly (also checks for unknown fields)
319 2 : subroutine schema_validate_strict(schema, root, errors)
320 : type(hsd_schema_t), intent(in) :: schema
321 : type(hsd_table), intent(in), target :: root
322 : type(hsd_error_t), allocatable, intent(out) :: errors(:)
323 :
324 : ! For now, same as regular validation
325 : ! Full implementation would walk tree and check for unschema'd fields
326 2 : call schema_validate(schema, root, errors)
327 :
328 55 : end subroutine schema_validate_strict
329 :
330 : !> Validate method wrapper
331 1 : subroutine schema_validate_method(self, root, errors)
332 : class(hsd_schema_t), intent(in) :: self
333 : type(hsd_table), intent(in), target :: root
334 : type(hsd_error_t), allocatable, intent(out) :: errors(:)
335 :
336 1 : call schema_validate(self, root, errors)
337 :
338 2 : end subroutine schema_validate_method
339 :
340 : !> Validate a single field against its definition
341 58 : subroutine validate_field(root, field_def, error)
342 : type(hsd_table), intent(in), target :: root
343 : type(hsd_field_def_t), intent(in) :: field_def
344 : type(hsd_error_t), allocatable, intent(out) :: error
345 :
346 : class(hsd_node), pointer :: child
347 58 : integer :: stat, actual_type, int_val
348 58 : real(dp) :: real_val
349 58 : character(len=:), allocatable :: str_val
350 :
351 : ! Check if field exists
352 58 : call hsd_get_child(root, field_def%path, child, stat)
353 :
354 58 : if (stat /= HSD_STAT_OK .or. .not. associated(child)) then
355 5 : if (field_def%requirement == FIELD_REQUIRED) then
356 : call make_error(error, HSD_STAT_NOT_FOUND, &
357 4 : "Required field '" // field_def%path // "' not found")
358 : end if
359 5 : return
360 : end if
361 :
362 : ! Check type
363 53 : if (field_def%field_type /= FIELD_TYPE_ANY) then
364 : select type (child)
365 : type is (hsd_table)
366 4 : if (field_def%field_type /= FIELD_TYPE_TABLE) then
367 : call make_error(error, HSD_STAT_TYPE_ERROR, &
368 : "Field '" // field_def%path // "' is a table, expected " // &
369 2 : get_type_name(field_def%field_type))
370 22 : return
371 : end if
372 :
373 : type is (hsd_value)
374 47 : actual_type = child%value_type
375 :
376 47 : if (field_def%field_type == FIELD_TYPE_TABLE) then
377 : call make_error(error, HSD_STAT_TYPE_ERROR, &
378 3 : "Field '" // field_def%path // "' is a value, expected table")
379 3 : return
380 : end if
381 :
382 : ! For type checking, we verify that the value can be converted to the expected type.
383 : ! This matches HSD's behavior: values are strings, converted on access.
384 47 : select case (field_def%field_type)
385 : case (FIELD_TYPE_INTEGER)
386 18 : call child%get_integer(int_val, stat)
387 18 : if (stat /= HSD_STAT_OK) then
388 : call make_error(error, HSD_STAT_TYPE_ERROR, &
389 1 : "Field '" // field_def%path // "' cannot be converted to integer")
390 1 : return
391 : end if
392 : ! Validate integer range
393 23 : if (field_def%has_int_range) then
394 20 : if (int_val < field_def%min_int .or. int_val > field_def%max_int) then
395 0 : call make_range_error(error, field_def%path, int_val, &
396 7 : field_def%min_int, field_def%max_int)
397 7 : return
398 : end if
399 : end if
400 :
401 : case (FIELD_TYPE_REAL)
402 9 : call child%get_real(real_val, stat)
403 9 : if (stat /= HSD_STAT_OK) then
404 : call make_error(error, HSD_STAT_TYPE_ERROR, &
405 0 : "Field '" // field_def%path // "' cannot be converted to real")
406 0 : return
407 : end if
408 : ! Validate real range
409 13 : if (field_def%has_real_range) then
410 14 : if (real_val < field_def%min_real .or. real_val > field_def%max_real) then
411 0 : call make_range_error_real(error, field_def%path, real_val, &
412 5 : field_def%min_real, field_def%max_real)
413 5 : return
414 : end if
415 : end if
416 :
417 : case (FIELD_TYPE_LOGICAL)
418 2 : block
419 3 : logical :: log_val
420 3 : call child%get_logical(log_val, stat)
421 3 : if (stat /= HSD_STAT_OK) then
422 : call make_error(error, HSD_STAT_TYPE_ERROR, &
423 1 : "Field '" // field_def%path // "' cannot be converted to logical")
424 1 : return
425 : end if
426 : end block
427 :
428 : case (FIELD_TYPE_STRING)
429 12 : call child%get_string(str_val, stat)
430 12 : if (stat /= HSD_STAT_OK) then
431 : call make_error(error, HSD_STAT_TYPE_ERROR, &
432 0 : "Field '" // field_def%path // "' cannot be converted to string")
433 0 : return
434 : end if
435 : ! Validate enum values
436 18 : if (field_def%num_allowed > 0) then
437 8 : if (.not. is_allowed_value(str_val, field_def)) then
438 1 : call make_enum_error(error, field_def%path, str_val, field_def)
439 1 : return
440 : end if
441 : end if
442 :
443 : case (FIELD_TYPE_ARRAY)
444 : if (actual_type /= VALUE_TYPE_ARRAY .and. &
445 : .not. allocated(child%int_array) .and. &
446 1 : .not. allocated(child%real_array) .and. &
447 0 : .not. allocated(child%raw_text)) then
448 : call make_error(error, HSD_STAT_TYPE_ERROR, &
449 1 : "Field '" // field_def%path // "' is not an array")
450 1 : return
451 : end if
452 :
453 : case (FIELD_TYPE_COMPLEX)
454 1 : if (actual_type /= VALUE_TYPE_COMPLEX) then
455 : call make_error(error, HSD_STAT_TYPE_ERROR, &
456 1 : "Field '" // field_def%path // "' is not a complex value")
457 1 : return
458 : end if
459 :
460 : case default
461 : ! Unknown field type - no validation needed
462 44 : continue
463 :
464 : end select
465 : end select
466 : end if
467 :
468 59 : end subroutine validate_field
469 :
470 : !> Check if a value is in the allowed list
471 7 : pure function is_allowed_value(val, field_def) result(allowed)
472 : character(len=*), intent(in) :: val
473 : type(hsd_field_def_t), intent(in) :: field_def
474 : logical :: allowed
475 :
476 7 : integer :: i
477 7 : character(len=:), allocatable :: val_lower
478 :
479 7 : allowed = .false.
480 7 : val_lower = to_lower(trim(val))
481 :
482 16 : do i = 1, field_def%num_allowed
483 31 : if (to_lower(trim(field_def%allowed_values(i))) == val_lower) then
484 6 : allowed = .true.
485 21 : return
486 : end if
487 : end do
488 :
489 65 : end function is_allowed_value
490 :
491 : !> Get human-readable type name
492 2 : pure function get_type_name(type_id) result(name)
493 : integer, intent(in) :: type_id
494 : character(len=:), allocatable :: name
495 :
496 2 : select case (type_id)
497 : case (FIELD_TYPE_ANY)
498 0 : name = "any"
499 : case (FIELD_TYPE_STRING)
500 1 : name = "string"
501 : case (FIELD_TYPE_INTEGER)
502 1 : name = "integer"
503 : case (FIELD_TYPE_REAL)
504 0 : name = "real"
505 : case (FIELD_TYPE_LOGICAL)
506 0 : name = "logical"
507 : case (FIELD_TYPE_ARRAY)
508 0 : name = "array"
509 : case (FIELD_TYPE_COMPLEX)
510 0 : name = "complex"
511 : case (FIELD_TYPE_TABLE)
512 0 : name = "table"
513 : case default
514 0 : name = "unknown"
515 : end select
516 :
517 7 : end function get_type_name
518 :
519 : !> Make integer range error
520 7 : subroutine make_range_error(error, path, val, min_val, max_val)
521 : type(hsd_error_t), allocatable, intent(out) :: error
522 : character(len=*), intent(in) :: path
523 : integer, intent(in) :: val, min_val, max_val
524 :
525 : character(len=64) :: val_str, min_str, max_str
526 :
527 7 : write(val_str, '(I0)') val
528 7 : write(min_str, '(I0)') min_val
529 7 : write(max_str, '(I0)') max_val
530 :
531 : call make_error(error, HSD_STAT_SCHEMA_ERROR, &
532 : "Field '" // path // "' value " // trim(val_str) // &
533 7 : " is outside range [" // trim(min_str) // ", " // trim(max_str) // "]")
534 :
535 2 : end subroutine make_range_error
536 :
537 : !> Make real range error
538 5 : subroutine make_range_error_real(error, path, val, min_val, max_val)
539 : type(hsd_error_t), allocatable, intent(out) :: error
540 : character(len=*), intent(in) :: path
541 : real(dp), intent(in) :: val, min_val, max_val
542 :
543 : character(len=64) :: val_str, min_str, max_str
544 :
545 5 : write(val_str, '(G0)') val
546 5 : write(min_str, '(G0)') min_val
547 5 : write(max_str, '(G0)') max_val
548 :
549 : call make_error(error, HSD_STAT_SCHEMA_ERROR, &
550 : "Field '" // path // "' value " // trim(val_str) // &
551 5 : " is outside range [" // trim(min_str) // ", " // trim(max_str) // "]")
552 :
553 7 : end subroutine make_range_error_real
554 :
555 : !> Make enum error
556 1 : subroutine make_enum_error(error, path, val, field_def)
557 : type(hsd_error_t), allocatable, intent(out) :: error
558 : character(len=*), intent(in) :: path, val
559 : type(hsd_field_def_t), intent(in) :: field_def
560 :
561 : character(len=1024) :: allowed_list
562 1 : integer :: i
563 :
564 1 : allowed_list = ""
565 4 : do i = 1, field_def%num_allowed
566 3 : if (i > 1) allowed_list = trim(allowed_list) // ", "
567 4 : allowed_list = trim(allowed_list) // "'" // trim(field_def%allowed_values(i)) // "'"
568 : end do
569 :
570 : call make_error(error, HSD_STAT_SCHEMA_ERROR, &
571 : "Field '" // path // "' value '" // val // &
572 1 : "' is not one of: " // trim(allowed_list))
573 :
574 5 : end subroutine make_enum_error
575 :
576 130 : end module hsd_schema
|
