Parse a restricted subset of JSON strings

src/sourcery/sourcery_string_m.f90

@@ -1,16 +1,25 @@
 module sourcery_string_m
+  use assert_m, only : characterizable_t
   implicit none
 
   private
   public :: string_t
   public :: array_of_strings
 
-  type string_t
+  type, extends(characterizable_t) :: string_t
     private
     character(len=:), allocatable :: string_
   contains
-    procedure :: string
+    procedure :: as_character
+    generic :: string => as_character
     procedure :: is_allocated
+    procedure :: get_json_key
+    procedure, private :: &
+      get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real
+    generic :: get_json_value => &
+      get_json_integer_array, get_json_logical, get_json_integer, get_json_string, get_json_real
+    procedure, private :: equivalent
+    generic :: operator(==) => equivalent
   end type
 
   interface string_t
@@ -25,7 +34,7 @@ elemental module function construct(string) result(new_string)
 
   interface
 
-    pure module function string(self) result(raw_string)
+    pure module function as_character(self) result(raw_string)
       implicit none
       class(string_t), intent(in) :: self
       character(len=:), allocatable :: raw_string
@@ -43,6 +52,52 @@ elemental module function is_allocated(self) result(string_allocated)
       logical string_allocated
     end function
 
+    elemental module function get_json_key(self) result(unquoted_key)
+     implicit none
+      class(string_t), intent(in) :: self
+      type(string_t) unquoted_key
+    end function
+
+    elemental module function get_json_real(self, key, mold) result(value_)
+      implicit none
+      class(string_t), intent(in) :: self, key
+      real, intent(in) :: mold
+      real value_
+    end function
+
+    elemental module function get_json_string(self, key, mold) result(value_)
+      implicit none
+      class(string_t), intent(in) :: self, key, mold
+      type(string_t) :: value_
+    end function
+
+    elemental module function get_json_integer(self, key, mold) result(value_)
+      implicit none
+      class(string_t), intent(in) :: self, key
+      integer, intent(in) ::  mold
+      integer value_
+    end function
+
+    elemental module function get_json_logical(self, key, mold) result(value_)
+      implicit none
+      class(string_t), intent(in) :: self, key
+      logical, intent(in) :: mold
+      logical value_
+    end function
+
+    pure module function get_json_integer_array(self, key, mold) result(value_)
+      implicit none
+      class(string_t), intent(in) :: self, key
+      integer, intent(in) :: mold(:)
+      integer, allocatable :: value_(:)
+    end function
+
+    elemental module function equivalent(lhs, rhs) result(lhs_eqv_rhs)
+      implicit none
+      class(string_t), intent(in) :: lhs, rhs
+      logical lhs_eqv_rhs
+    end function
+
   end interface
 
 end module sourcery_string_m

src/sourcery/sourcery_string_s.f90

@@ -1,4 +1,6 @@
 submodule(sourcery_string_m) sourcery_string_s
+  use assert_m, only : assert
+  use sourcery_m, only : csv
   implicit none
 
 contains
@@ -7,7 +9,7 @@
     new_string%string_ = string
   end procedure
 
-  module procedure string
+  module procedure as_character
     raw_string = self%string_
   end procedure
 
@@ -37,4 +39,124 @@
 
   end procedure
 
+  module procedure get_json_key
+    character(len=:), allocatable :: raw_line
+
+    raw_line = self%string()
+    associate(opening_key_quotes => index(raw_line, '"'), separator => index(raw_line, ':'))
+      associate(closing_key_quotes => opening_key_quotes + index(raw_line(opening_key_quotes+1:), '"'))
+        unquoted_key = string_t(trim(raw_line(opening_key_quotes+1:closing_key_quotes-1)))
+      end associate
+    end associate
+
+  end procedure
+
+  module procedure get_json_real
+    character(len=:), allocatable :: raw_line, string_value
+
+    call assert(key==self%get_json_key(), "string_s(get_json_real): key==self%get_json_key()", key)
+
+    raw_line = self%string()
+    associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
+      associate(trailing_comma => index(text_after_colon, ','))
+        if (trailing_comma == 0) then
+          string_value = trim(adjustl((text_after_colon)))
+        else 
+          string_value = trim(adjustl((text_after_colon(:trailing_comma-1))))
+        end if
+        read(string_value, fmt=*) value_
+      end associate
+    end associate
+
+  end procedure
+
+  module procedure get_json_string
+
+    character(len=:), allocatable :: raw_line
+
+    call assert(key==self%get_json_key(), "key==self%get_string_json()", key)
+
+    raw_line = self%string()
+    associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
+      associate(opening_value_quotes => index(text_after_colon, '"'))
+        associate(closing_value_quotes => opening_value_quotes + index(text_after_colon(opening_value_quotes+1:), '"'))
+          if (any([opening_value_quotes, closing_value_quotes] == 0)) then
+            value_ = string_t(trim(adjustl((text_after_colon))))
+          else
+            value_ = string_t(text_after_colon(opening_value_quotes+1:closing_value_quotes-1))
+          end if
+        end associate
+      end associate
+    end associate
+
+  end procedure
+
+  module procedure get_json_logical
+    character(len=:), allocatable :: raw_line, string_value
+
+    call assert(key==self%get_json_key(), "string_s(get_json_logical): key==self%get_json_key()", key)
+
+    raw_line = self%string()
+    associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
+      associate(trailing_comma => index(text_after_colon, ','))
+        if (trailing_comma == 0) then
+          string_value = trim(adjustl((text_after_colon)))
+        else 
+          string_value = trim(adjustl((text_after_colon(:trailing_comma-1))))
+        end if
+        call assert(string_value=="true" .or. string_value=="false", &
+          'string_s(get_json_logical): string_value=="true" .or. string_value="false"', string_value)
+        value_ = string_value == "true"
+      end associate
+    end associate
+
+  end procedure
+
+  module procedure get_json_integer
+    character(len=:), allocatable :: raw_line, string_value
+
+    call assert(key==self%get_json_key(), "string_s(get_json_logical): key==self%get_json_key()", key)
+
+    raw_line = self%string()
+    associate(text_after_colon => raw_line(index(raw_line, ':')+1:))
+      associate(trailing_comma => index(text_after_colon, ','))
+        if (trailing_comma == 0) then
+          string_value = trim(adjustl((text_after_colon)))
+        else 
+          string_value = trim(adjustl((text_after_colon(:trailing_comma-1))))
+        end if
+        read(string_value, fmt=*) value_
+      end associate
+    end associate
+
+  end procedure
+
+  module procedure get_json_integer_array
+    character(len=:), allocatable :: raw_line
+    real, allocatable :: real_array(:)
+    integer i
+
+    call assert(key==self%get_json_key(), "string_s(get_json_integer_array): key==self%get_json_key()", key)
+
+    raw_line = self%string()
+    associate(colon => index(raw_line, ":"))
+      associate(opening_bracket => colon + index(raw_line(colon+1:), "["))
+        associate(closing_bracket => opening_bracket + index(raw_line(opening_bracket+1:), "]"))
+          associate(commas => count("," == [(raw_line(i:i), i=opening_bracket+1,closing_bracket-1)]))
+            associate(num_inputs => commas + 1)
+              allocate(real_array(num_inputs))
+              read(raw_line(opening_bracket+1:closing_bracket-1), fmt=*) real_array
+              value_ = int(real_array)
+            end associate
+          end associate
+        end associate
+      end associate
+    end associate
+
+  end procedure
+
+  module procedure equivalent
+    lhs_eqv_rhs = lhs%string() == rhs%string()
+  end procedure
+
 end submodule sourcery_string_s

test/string_test.f90

@@ -2,6 +2,7 @@ module string_test_m
   use sourcery_m, only : test_t, test_result_t, string_t
   implicit none
 
+
   private
   public :: string_test_t
 
@@ -22,7 +23,13 @@ function results() result(test_results)
     type(test_result_t), allocatable :: test_results(:)
 
     test_results = [ &
-      test_result_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", check_allocation()) &
+      test_result_t("is_allocated() result .true. if & only if the string_t component(s) is/are allocated", check_allocation()), &
+      test_result_t("extracting a key string from a colon-separated key/value pair", extracts_key()), &
+      test_result_t("extracting a real value from a colon-separated key/value pair", extracts_real_value()), &
+      test_result_t("extracting a string value from a colon-separated key/value pair", extracts_string_value()), &
+      test_result_t("extracting a logical value from a colon-separated key/value pair", extracts_logical_value()), &
+      test_result_t("extracting an integer array value from a colon-separated key/value pair", extracts_integer_array_value()), &
+      test_result_t("extracting an integer value from a colon-separated key/value pair", extracts_integer_value()) &
     ]
   end function
 
@@ -36,4 +43,64 @@ pure function check_allocation() result(passed)
              (all([scalar_allocated%is_allocated(), array_allocated%is_allocated()]))
   end function
 
+  function extracts_key() result(passed)
+    logical passed
+
+    associate(line => string_t('"foo" : "bar"'))
+      passed = line%get_json_key() == string_t("foo")
+    end associate
+  end function
+
+  function extracts_real_value() result(passed)
+    logical passed
+
+    associate(line => string_t('"pi" : 3.14159'))
+      passed = line%get_json_value(key=string_t("pi"), mold=2.71828) == 3.14159
+    end associate
+  end function
+
+  function extracts_string_value() result(passed)
+    logical passed
+
+    associate(line => string_t('"foo" : "bar"'))
+      passed = line%get_json_value(key=string_t("foo"), mold=string_t("")) == string_t("bar")
+    end associate
+  end function
+
+  function extracts_integer_value() result(passed)
+    logical passed
+
+    associate(line => string_t('"an integer" : 99'))
+      passed = line%get_json_value(key=string_t("an integer"), mold=0) == 99
+    end associate
+  end function
+
+  function extracts_logical_value() result(passed)
+    logical passed
+
+    associate( &
+      key_true_pair => string_t('"yada yada" : true'), &
+      key_false_pair => string_t('"blah blah" : false'), &
+      trailing_comma => string_t('"trailing comma" : true,') &
+    )
+      associate( &
+         true => key_true_pair%get_json_value(key=string_t("yada yada"), mold=.true.), &
+         false => key_false_pair%get_json_value(key=string_t("blah blah"), mold=.true.), &
+         true_too => trailing_comma%get_json_value(key=string_t("trailing comma"), mold=.true.) &
+      )
+        passed = true .and. true_too .and. .not. false
+      end associate
+    end associate
+  end function
+
+  function extracts_integer_array_value() result(passed)
+    logical passed
+
+    associate(key_integer_array_pair => string_t('"some key" : [1, 2, 3],'))
+      associate(integer_array => key_integer_array_pair%get_json_value(key=string_t("some key"), mold=[integer::]))
+        passed = all(integer_array == [1, 2, 3])
+      end associate
+    end associate
+  end function
+
 end module string_test_m