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, hsd_table, hsd_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_query, 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 :
23 : contains
24 :
25 : !> Require that a path exists and optionally check its type
26 : !>
27 : !> If the path doesn't exist or type doesn't match, creates a descriptive error.
28 13 : subroutine hsd_require(table, path, error, expected_type, context)
29 : type(hsd_table), intent(in), target :: table
30 : character(len=*), intent(in) :: path
31 : type(hsd_error_t), allocatable, intent(out) :: error
32 : integer, intent(in), optional :: expected_type
33 : character(len=*), intent(in), optional :: context
34 :
35 : class(hsd_node), pointer :: child
36 13 : integer :: local_stat, actual_type
37 13 : character(len=:), allocatable :: ctx_prefix
38 :
39 13 : call hsd_get_child(table, path, child, local_stat)
40 :
41 13 : if (present(context)) then
42 2 : ctx_prefix = context // ": "
43 : else
44 11 : ctx_prefix = ""
45 : end if
46 :
47 13 : if (local_stat /= 0 .or. .not. associated(child)) then
48 : call make_error(error, HSD_STAT_NOT_FOUND, &
49 5 : ctx_prefix // "Required field '" // path // "' not found")
50 5 : return
51 : end if
52 :
53 8 : if (present(expected_type)) then
54 : select type (child)
55 : type is (hsd_value)
56 4 : actual_type = child%value_type
57 4 : if (expected_type /= actual_type) then
58 : call make_error(error, HSD_STAT_TYPE_ERROR, &
59 : ctx_prefix // "Field '" // path // "' has wrong type: expected " // &
60 2 : type_name(expected_type) // ", got " // type_name(actual_type))
61 : end if
62 : type is (hsd_table)
63 1 : if (expected_type /= VALUE_TYPE_NONE) then
64 : call make_error(error, HSD_STAT_TYPE_ERROR, &
65 : ctx_prefix // "Field '" // path // "' is a table, expected value of type " // &
66 1 : type_name(expected_type))
67 : end if
68 : end select
69 : end if
70 :
71 13 : end subroutine hsd_require
72 :
73 : !> Get a human-readable name for a value type
74 5 : pure function type_name(val_type) result(name)
75 : integer, intent(in) :: val_type
76 : character(len=:), allocatable :: name
77 :
78 6 : select case (val_type)
79 : case (VALUE_TYPE_NONE)
80 1 : name = "none"
81 : case (VALUE_TYPE_STRING)
82 2 : name = "string"
83 : case (VALUE_TYPE_INTEGER)
84 2 : name = "integer"
85 : case (VALUE_TYPE_REAL)
86 0 : name = "real"
87 : case (VALUE_TYPE_LOGICAL)
88 0 : name = "logical"
89 : case (VALUE_TYPE_ARRAY)
90 0 : name = "array"
91 : case (VALUE_TYPE_COMPLEX)
92 0 : name = "complex"
93 : case default
94 0 : name = "unknown"
95 : end select
96 :
97 13 : end function type_name
98 :
99 : !> Validate that a real value is within a specified range
100 17 : subroutine hsd_validate_range(table, path, min_val, max_val, error, context)
101 : type(hsd_table), intent(in), target :: table
102 : character(len=*), intent(in) :: path
103 : real(dp), intent(in) :: min_val, max_val
104 : type(hsd_error_t), allocatable, intent(out) :: error
105 : character(len=*), intent(in), optional :: context
106 :
107 : class(hsd_node), pointer :: child
108 17 : real(dp) :: val
109 17 : integer :: local_stat
110 : character(len=32) :: min_str, max_str, val_str
111 17 : character(len=:), allocatable :: ctx_prefix
112 :
113 17 : call hsd_get_child(table, path, child, local_stat)
114 :
115 17 : if (present(context)) then
116 2 : ctx_prefix = context // ": "
117 : else
118 15 : ctx_prefix = ""
119 : end if
120 :
121 17 : if (local_stat /= HSD_STAT_OK .or. .not. associated(child)) then
122 : call make_error(error, local_stat, &
123 2 : ctx_prefix // "Field '" // path // "' not found or invalid type for range validation")
124 6 : return
125 : end if
126 :
127 : select type (child)
128 : type is (hsd_value)
129 15 : call child%get_real(val, local_stat)
130 15 : if (local_stat /= HSD_STAT_OK) then
131 : call make_error(error, HSD_STAT_TYPE_ERROR, &
132 4 : ctx_prefix // "Field '" // path // "' is not a real number")
133 4 : return
134 : end if
135 :
136 26 : if (val < min_val .or. val > max_val) then
137 7 : write(min_str, '(G0)') min_val
138 7 : write(max_str, '(G0)') max_val
139 7 : write(val_str, '(G0)') val
140 : call make_error(error, HSD_STAT_TYPE_ERROR, &
141 : ctx_prefix // "Field '" // path // "' value " // trim(val_str) // &
142 7 : " is outside valid range [" // trim(min_str) // ", " // trim(max_str) // "]")
143 : end if
144 : class default
145 : call make_error(error, HSD_STAT_TYPE_ERROR, &
146 0 : ctx_prefix // "Field '" // path // "' is not a value node")
147 : end select
148 :
149 22 : end subroutine hsd_validate_range
150 :
151 : !> Validate that a string value is one of the allowed choices
152 16 : subroutine hsd_validate_one_of(table, path, choices, error, context)
153 : type(hsd_table), intent(in), target :: table
154 : character(len=*), intent(in) :: path
155 : character(len=*), intent(in) :: choices(:)
156 : type(hsd_error_t), allocatable, intent(out) :: error
157 : character(len=*), intent(in), optional :: context
158 :
159 : class(hsd_node), pointer :: child
160 8 : character(len=:), allocatable :: val, choices_str, ctx_prefix
161 8 : integer :: i, local_stat
162 8 : logical :: found
163 :
164 8 : call hsd_get_child(table, path, child, local_stat)
165 :
166 8 : if (present(context)) then
167 1 : ctx_prefix = context // ": "
168 : else
169 7 : ctx_prefix = ""
170 : end if
171 :
172 8 : if (local_stat /= HSD_STAT_OK .or. .not. associated(child)) then
173 : call make_error(error, local_stat, &
174 1 : ctx_prefix // "Field '" // path // "' not found")
175 1 : return
176 : end if
177 :
178 : select type (child)
179 : type is (hsd_value)
180 6 : call child%get_string(val, local_stat)
181 6 : if (local_stat /= HSD_STAT_OK) then
182 : call make_error(error, HSD_STAT_TYPE_ERROR, &
183 0 : ctx_prefix // "Field '" // path // "' is not a string")
184 0 : return
185 : end if
186 :
187 6 : found = .false.
188 18 : do i = 1, size(choices)
189 46 : if (to_lower(val) == to_lower(choices(i))) then
190 2 : found = .true.
191 28 : exit
192 : end if
193 : end do
194 :
195 12 : if (.not. found) then
196 4 : choices_str = ""
197 15 : do i = 1, size(choices)
198 18 : if (i > 1) choices_str = choices_str // ", "
199 15 : choices_str = choices_str // "'" // trim(choices(i)) // "'"
200 : end do
201 : call make_error(error, HSD_STAT_TYPE_ERROR, &
202 : ctx_prefix // "Field '" // path // "' value '" // val // &
203 4 : "' is not one of: " // choices_str)
204 : end if
205 : class default
206 : call make_error(error, HSD_STAT_TYPE_ERROR, &
207 1 : ctx_prefix // "Field '" // path // "' is not a value node")
208 : end select
209 :
210 33 : end subroutine hsd_validate_one_of
211 :
212 : !> Get a real value with automatic unit conversion
213 : !>
214 : !> The unit is read from the node's attribute and converted to the target unit.
215 : !> The converter function takes (value, from_unit, to_unit) and returns the converted value.
216 : !>
217 : !> Example:
218 : !> For input `Temperature [Kelvin] = 300`, calling
219 : !> `hsd_get_with_unit(root, "Temperature", val, "Celsius", converter)`
220 : !> would call `converter(300.0, "Kelvin", "Celsius")` to get the result.
221 6 : subroutine hsd_get_with_unit(table, path, val, target_unit, converter, stat)
222 : type(hsd_table), intent(in), target :: table
223 : character(len=*), intent(in) :: path
224 : real(dp), intent(out) :: val
225 : character(len=*), intent(in) :: target_unit
226 : interface
227 : pure function converter(value, from_unit, to_unit) result(converted)
228 : import :: dp
229 : implicit none (type, external)
230 : real(dp), intent(in) :: value
231 : character(len=*), intent(in) :: from_unit, to_unit
232 : real(dp) :: converted
233 : end function converter
234 : end interface
235 : integer, intent(out), optional :: stat
236 :
237 : class(hsd_node), pointer :: child
238 6 : character(len=:), allocatable :: source_unit
239 6 : real(dp) :: raw_val
240 6 : integer :: local_stat
241 :
242 6 : val = 0.0_dp
243 :
244 6 : call hsd_get_child(table, path, child, local_stat)
245 6 : if (local_stat /= 0 .or. .not. associated(child)) then
246 1 : if (present(stat)) stat = HSD_STAT_NOT_FOUND
247 2 : return
248 : end if
249 :
250 : select type (child)
251 : type is (hsd_value)
252 4 : call child%get_real(raw_val, local_stat)
253 4 : if (local_stat /= HSD_STAT_OK) then
254 1 : if (present(stat)) stat = local_stat
255 1 : return
256 : end if
257 :
258 3 : if (allocated(child%attrib)) then
259 1 : source_unit = child%attrib
260 : else
261 2 : source_unit = target_unit ! No conversion needed
262 : end if
263 :
264 3 : val = converter(raw_val, source_unit, target_unit)
265 7 : if (present(stat)) stat = HSD_STAT_OK
266 :
267 : class default
268 1 : if (present(stat)) stat = HSD_STAT_TYPE_ERROR
269 : end select
270 :
271 20 : end subroutine hsd_get_with_unit
272 :
273 50 : end module hsd_validation
|
