A simplistic JSON parser for ReScript

Json.res

// (C) Christopher Armstrong 2021
// Licenced under MIT license (https://opensource.org/licenses/MIT)
open Js.Json

module Decode = {
  let map_result = Belt.Result.map
  let flatMap_result = Belt.Result.flatMap
  let identity = x => x
  let mapOptionWithError = (~mapper: 'a => 'b, opt, error) =>
    Belt.Option.mapWithDefault(opt, Error(error), x => Ok(mapper(x)))

  let optionToResult = (opt, errorString) =>
    switch opt {
    | Some(result) => Ok(result)
    | None => Error(errorString)
    }

  type jsonTreeRef = {
    tree: Js.Json.t,
    path: string,
  }

  type jsonObjectRef = {
    object: Js.Dict.t<Js.Json.t>,
    path: string,
  }

  type jsonParseError =
    | SyntaxError(string)
    | WrongType(string, string)
    | NoValueError(string)
    | RecordParseError(string, string)
    | CustomError(string)

  let jsonParseErrorToString = error =>
    switch error {
    | SyntaxError(error) => `Syntax Error: ${error}`
    | WrongType(path, expected) => `Wrong Type Error: ${expected} was expected at path ${path}`
    | NoValueError(path) => `No Value Error: expected a value at ${path}`
    | RecordParseError(path, suberror) =>
      `Record parse error: at path ${path} received record parse error - ${suberror}`
    | CustomError(error) => `Other parse error: ${error}`
    }

  let d_json = (jsonString, rootParser) => {
    let treeResult = try Ok(parseExn(jsonString)) catch {
    | Js.Exn.Error(payload) =>
      Error(SyntaxError(Js.Option.getWithDefault("unknown", Js.Exn.message(payload))))
    }
    flatMap_result(treeResult, tree => rootParser(Ok({tree: tree, path: "$"})))
  }

  type parser<'a> = Belt.Result.t<jsonTreeRef, jsonParseError> => Belt.Result.t<'a, jsonParseError>

  let d_object = (x: Belt.Result.t<jsonTreeRef, jsonParseError>) =>
    x
    ->map_result(({tree, path}) => (decodeObject(tree), path))
    ->flatMap_result(((dictOption, path)) =>
      mapOptionWithError(dictOption, NoValueError(path), ~mapper=object => {
        object: object,
        path: path,
      })
    )

  let d_record = (recordObject: Belt.Result.t<jsonTreeRef, jsonParseError>, recordParser) =>
    recordObject
    ->d_object
    ->map_result(({object, path}) => (Js.Dict.entries(object), path))
    ->flatMap_result(((entries, path)) =>
      Belt.Array.reduce(entries, Ok([]), (records, (key, value)) =>
        flatMap_result(records, recordsValue => {
          let record = recordParser(key, Ok({path: `${path}.${key}`, tree: value}))
          switch record {
          | Ok(recordValue) => Ok(Js.Array.concat(recordsValue, [recordValue]))
          | Error(error) =>
            switch error {
            | CustomError(y) => Error(RecordParseError(`${path}.${key}`, y))
            | _ => Error(error)
            }
          }
        })
      )
    )

  let d_string = x =>
    x
    ->map_result(({tree, path}) => (decodeString(tree), path))
    ->flatMap_result(((stringOption, path)) =>
      mapOptionWithError(stringOption, WrongType(path, "string"), ~mapper=identity)
    )
  let d_number = x =>
    x
    ->map_result(({tree, path}) => (decodeNumber(tree), path))
    ->flatMap_result(((numberOption, path)) =>
      switch numberOption {
      | Some(num) => Ok(num)
      | None => Error(WrongType(path, "number"))
      }
    )
  let d_integer = x =>
    x
    ->map_result(({tree, path}) => (decodeNumber(tree), path))
    ->flatMap_result(((numberOption, path)) =>
      mapOptionWithError(numberOption, WrongType(path, "integer"), ~mapper=num =>
        Belt.Float.toInt(num)
      )
    )
  let d_boolean = x =>
    x
    ->map_result(({tree, path}) => (decodeBoolean(tree), path))
    ->flatMap_result(((boolOption, path)) =>
      mapOptionWithError(boolOption, WrongType(path, "boolean"), ~mapper=identity)
    )

  let d_null = x =>
    x
    ->map_result(({tree, path}) => (decodeNull(tree), path))
    ->flatMap_result(((nullOption, path)) =>
      mapOptionWithError(nullOption, WrongType(path, "null"), ~mapper=identity)
    )

  let d_array = (arrayRef, itemParser) =>
    arrayRef
    ->map_result(({tree, path}) => (decodeArray(tree), path))
    ->flatMap_result(((arrayOption, path)) =>
      mapOptionWithError(arrayOption, WrongType(path, "array"), ~mapper=arr =>
        Belt.Array.reduceWithIndex(arr, Ok([]), (progress, next, i) =>
          flatMap_result(progress, items => {
            let record = itemParser(Ok({path: `${path}.${Belt.Int.toString(i)}`, tree: next}))
            map_result(record, recordValue => Belt.Array.concat(items, [recordValue]))
          })
        )
      )
    )

  let d_field = (objectRef, fieldName) =>
    objectRef
    ->map_result(({object, path}) => (Js.Dict.get(object, fieldName), path))
    ->flatMap_result(((fieldValueOption, path)) =>
      mapOptionWithError(
        fieldValueOption,
        NoValueError(`${path}.${fieldName}`),
        ~mapper=fieldValue => {tree: fieldValue, path: `${path}.${fieldName}`},
      )
    )

  let d_optional = (decodedResult: Belt.Result.t<'a, jsonParseError>, mapper) =>
    switch decodedResult {
    | Ok(value) => switch mapper(Ok(value)) {
      | Ok(result) => Ok(Some(result))
      | Error(error) => Error(error)
    }
    | Error(error) =>
      switch error {
      | NoValueError(_) => Ok(None)
      | _ => Error(error)
      }
    }
}

module ResultHelpers = {
  let fold = (res, apply) => Belt.Result.map(res, x => apply(x))
  let feed = (mapped, res) => Belt.Result.flatMap(mapped, fold(res))
  let applyTo = mapper => Ok(mapper)
}