Skip to content

Commit 5ef0a88

Browse files
rousonrouson
authored
Merge pull request #56 from sourceryinstitute/json
Parse a restricted subset of JSON strings
2 parents 9f9411c + 4c7dd11 commit 5ef0a88

File tree

3 files changed

+249
-5
lines changed

3 files changed

+249
-5
lines changed

‎src/sourcery/sourcery_string_m.f90‎

Lines changed: 58 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,25 @@
11
module sourcery_string_m
2+
use assert_m, only : characterizable_t
23
implicit none
34

45
private
56
public :: string_t
67
public :: array_of_strings
78

8-
type string_t
9+
type, extends(characterizable_t) :: string_t
910
private
1011
character(len=:), allocatable :: string_
1112
contains
12-
procedure :: string
13+
procedure :: as_character
14+
generic :: string => as_character
1315
procedure :: is_allocated
16+
procedure :: get_json_key
17+
procedure, private :: &
18+
get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real
19+
generic :: get_json_value => &
20+
get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real
21+
procedure, private :: equivalent
22+
generic :: operator(==) => equivalent
1423
end type
1524

1625
interface string_t
@@ -25,7 +34,7 @@ elemental module function construct(string) result(new_string)
2534

2635
interface
2736

28-
pure module function string(self) result(raw_string)
37+
pure module function as_character(self) result(raw_string)
2938
implicit none
3039
class(string_t), intent(in) :: self
3140
character(len=:), allocatable :: raw_string
@@ -43,6 +52,52 @@ elemental module function is_allocated(self) result(string_allocated)
4352
logical string_allocated
4453
end function
4554

55+
elemental module function get_json_key(self) result(unquoted_key)
56+
implicit none
57+
class(string_t), intent(in) :: self
58+
type(string_t) unquoted_key
59+
end function
60+
61+
elemental module function get_json_real(self, key, mold) result(value_)
62+
implicit none
63+
class(string_t), intent(in) :: self, key
64+
real, intent(in) :: mold
65+
real value_
66+
end function
67+
68+
elemental module function get_json_string(self, key, mold) result(value_)
69+
implicit none
70+
class(string_t), intent(in) :: self, key, mold
71+
type(string_t) :: value_
72+
end function
73+
74+
elemental module function get_json_integer(self, key, mold) result(value_)
75+
implicit none
76+
class(string_t), intent(in) :: self, key
77+
integer, intent(in) :: mold
78+
integer value_
79+
end function
80+
81+
elemental module function get_json_logical(self, key, mold) result(value_)
82+
implicit none
83+
class(string_t), intent(in) :: self, key
84+
logical, intent(in) :: mold
85+
logical value_
86+
end function
87+
88+
pure module function get_json_integer_array(self, key, mold) result(value_)
89+
implicit none
90+
class(string_t), intent(in) :: self, key
91+
integer, intent(in) :: mold(:)
92+
integer, allocatable :: value_(:)
93+
end function
94+
95+
elemental module function equivalent(lhs, rhs) result(lhs_eqv_rhs)
96+
implicit none
97+
class(string_t), intent(in) :: lhs, rhs
98+
logical lhs_eqv_rhs
99+
end function
100+
46101
end interface
47102

48103
end module sourcery_string_m

‎src/sourcery/sourcery_string_s.f90‎

Lines changed: 123 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
11
submodule(sourcery_string_m) sourcery_string_s
2+
use assert_m, only : assert
3+
use sourcery_m, only : csv
24
implicit none
35

46
contains
@@ -7,7 +9,7 @@
79
new_string%string_ = string
810
end procedure
911

10-
module procedure string
12+
module procedure as_character
1113
raw_string = self%string_
1214
end procedure
1315

@@ -37,4 +39,124 @@
3739

3840
end procedure
3941

42+
module procedure get_json_key
43+
character(len=:), allocatable :: raw_line
44+
45+
raw_line = self%string()
46+
associate(opening_key_quotes => index(raw_line, '"'), separator => index(raw_line, ':'))
47+
associate(closing_key_quotes => opening_key_quotes + index(raw_line(opening_key_quotes+1:), '"'))
48+
unquoted_key = string_t(trim(raw_line(opening_key_quotes+1:closing_key_quotes-1)))
49+
end associate
50+
end associate
51+
52+
end procedure
53+
54+
module procedure get_json_real
55+
character(len=:), allocatable :: raw_line, string_value
56+
57+
call assert(key==self%get_json_key(), "string_s(get_json_real): key==self%get_json_key()", key)
58+
59+
raw_line = self%string()
60+
associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
61+
associate(trailing_comma => index(text_after_colon, ','))
62+
if (trailing_comma == 0) then
63+
string_value = trim(adjustl((text_after_colon)))
64+
else
65+
string_value = trim(adjustl((text_after_colon(:trailing_comma-1))))
66+
end if
67+
read(string_value, fmt=*) value_
68+
end associate
69+
end associate
70+
71+
end procedure
72+
73+
module procedure get_json_string
74+
75+
character(len=:), allocatable :: raw_line
76+
77+
call assert(key==self%get_json_key(), "key==self%get_string_json()", key)
78+
79+
raw_line = self%string()
80+
associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
81+
associate(opening_value_quotes => index(text_after_colon, '"'))
82+
associate(closing_value_quotes => opening_value_quotes + index(text_after_colon(opening_value_quotes+1:), '"'))
83+
if (any([opening_value_quotes, closing_value_quotes] == 0)) then
84+
value_ = string_t(trim(adjustl((text_after_colon))))
85+
else
86+
value_ = string_t(text_after_colon(opening_value_quotes+1:closing_value_quotes-1))
87+
end if
88+
end associate
89+
end associate
90+
end associate
91+
92+
end procedure
93+
94+
module procedure get_json_logical
95+
character(len=:), allocatable :: raw_line, string_value
96+
97+
call assert(key==self%get_json_key(), "string_s(get_json_logical): key==self%get_json_key()", key)
98+
99+
raw_line = self%string()
100+
associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
101+
associate(trailing_comma => index(text_after_colon, ','))
102+
if (trailing_comma == 0) then
103+
string_value = trim(adjustl((text_after_colon)))
104+
else
105+
string_value = trim(adjustl((text_after_colon(:trailing_comma-1))))
106+
end if
107+
call assert(string_value=="true" .or. string_value=="false", &
108+
'string_s(get_json_logical): string_value=="true" .or. string_value="false"', string_value)
109+
value_ = string_value == "true"
110+
end associate
111+
end associate
112+
113+
end procedure
114+
115+
module procedure get_json_integer
116+
character(len=:), allocatable :: raw_line, string_value
117+
118+
call assert(key==self%get_json_key(), "string_s(get_json_logical): key==self%get_json_key()", key)
119+
120+
raw_line = self%string()
121+
associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
122+
associate(trailing_comma => index(text_after_colon, ','))
123+
if (trailing_comma == 0) then
124+
string_value = trim(adjustl((text_after_colon)))
125+
else
126+
string_value = trim(adjustl((text_after_colon(:trailing_comma-1))))
127+
end if
128+
read(string_value, fmt=*) value_
129+
end associate
130+
end associate
131+
132+
end procedure
133+
134+
module procedure get_json_integer_array
135+
character(len=:), allocatable :: raw_line
136+
real, allocatable :: real_array(:)
137+
integer i
138+
139+
call assert(key==self%get_json_key(), "string_s(get_json_integer_array): key==self%get_json_key()", key)
140+
141+
raw_line = self%string()
142+
associate(colon => index(raw_line, ":"))
143+
associate(opening_bracket => colon + index(raw_line(colon+1:), "["))
144+
associate(closing_bracket => opening_bracket + index(raw_line(opening_bracket+1:), "]"))
145+
associate(commas => count("," == [(raw_line(i:i), i=opening_bracket+1,closing_bracket-1)]))
146+
associate(num_inputs => commas + 1)
147+
allocate(real_array(num_inputs))
148+
read(raw_line(opening_bracket+1:closing_bracket-1), fmt=*) real_array
149+
value_ = int(real_array)
150+
end associate
151+
end associate
152+
end associate
153+
end associate
154+
end associate
155+
156+
end procedure
157+
158+
module procedure equivalent
159+
lhs_eqv_rhs = lhs%string() == rhs%string()
160+
end procedure
161+
40162
end submodule sourcery_string_s

‎test/string_test.f90‎

Lines changed: 68 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@ module string_test_m
22
use sourcery_m, only : test_t, test_result_t, string_t
33
implicit none
44

5+
56
private
67
public :: string_test_t
78

@@ -22,7 +23,13 @@ function results() result(test_results)
2223
type(test_result_t), allocatable :: test_results(:)
2324

2425
test_results = [ &
25-
test_result_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", check_allocation()) &
26+
test_result_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", check_allocation()), &
27+
test_result_t("extracting a key string from a colon-separated key/value pair", extracts_key()), &
28+
test_result_t("extracting a real value from a colon-separated key/value pair", extracts_real_value()), &
29+
test_result_t("extracting a string value from a colon-separated key/value pair", extracts_string_value()), &
30+
test_result_t("extracting a logical value from a colon-separated key/value pair", extracts_logical_value()), &
31+
test_result_t("extracting an integer array value from a colon-separated key/value pair", extracts_integer_array_value()), &
32+
test_result_t("extracting an integer value from a colon-separated key/value pair", extracts_integer_value()) &
2633
]
2734
end function
2835

@@ -36,4 +43,64 @@ pure function check_allocation() result(passed)
3643
(all([scalar_allocated%is_allocated(), array_allocated%is_allocated()]))
3744
end function
3845

46+
function extracts_key() result(passed)
47+
logical passed
48+
49+
associate(line => string_t('"foo" : "bar"'))
50+
passed = line%get_json_key() == string_t("foo")
51+
end associate
52+
end function
53+
54+
function extracts_real_value() result(passed)
55+
logical passed
56+
57+
associate(line => string_t('"pi" : 3.14159'))
58+
passed = line%get_json_value(key=string_t("pi"), mold=2.71828) == 3.14159
59+
end associate
60+
end function
61+
62+
function extracts_string_value() result(passed)
63+
logical passed
64+
65+
associate(line => string_t('"foo" : "bar"'))
66+
passed = line%get_json_value(key=string_t("foo"), mold=string_t("")) == string_t("bar")
67+
end associate
68+
end function
69+
70+
function extracts_integer_value() result(passed)
71+
logical passed
72+
73+
associate(line => string_t('"an integer" : 99'))
74+
passed = line%get_json_value(key=string_t("an integer"), mold=0) == 99
75+
end associate
76+
end function
77+
78+
function extracts_logical_value() result(passed)
79+
logical passed
80+
81+
associate( &
82+
key_true_pair => string_t('"yada yada" : true'), &
83+
key_false_pair => string_t('"blah blah" : false'), &
84+
trailing_comma => string_t('"trailing comma" : true,') &
85+
)
86+
associate( &
87+
true => key_true_pair%get_json_value(key=string_t("yada yada"), mold=.true.), &
88+
false => key_false_pair%get_json_value(key=string_t("blah blah"), mold=.true.), &
89+
true_too => trailing_comma%get_json_value(key=string_t("trailing comma"), mold=.true.) &
90+
)
91+
passed = true .and. true_too .and. .not. false
92+
end associate
93+
end associate
94+
end function
95+
96+
function extracts_integer_array_value() result(passed)
97+
logical passed
98+
99+
associate(key_integer_array_pair => string_t('"some key" : [1, 2, 3],'))
100+
associate(integer_array => key_integer_array_pair%get_json_value(key=string_t("some key"), mold=[integer::]))
101+
passed = all(integer_array == [1, 2, 3])
102+
end associate
103+
end associate
104+
end function
105+
39106
end module string_test_m

0 commit comments

Comments
 (0)