json-parser.re

type result('a, 'b) =
  | Ok('a)
  | Error('b)

let inject = value => input => (Ok(value), input)

let error = e => input => (Error(e), input)

let item = input => {
  let (index, source) = input

  switch (String.get(source, index)) {
  | x => (Ok(x), (index + 1, source))
  | exception (Invalid_argument("index out of bounds")) => (Error("EOF"), (index, source))
  }
}

let map = f => parser => input => {
  let (value, input') = parser(input)

  switch (value) {
  | Ok(a) => (f(a), input')
  | Error(message) => (Error(message), input)
  }
}

let apply = parserA => parserF => input => {
  let (value, input') = parserF(input)

  let next = f => {
    let (value, input'') = parserA(input')
    
    switch (value) {
    | Ok(a) => (Ok(f(a)), input'')
    | Error(message) => (Error(message), input'')
    }
  }

  switch (value) {
  | Ok(f) => next(f)
  | Error(message) => (Error(message), input')
  }
}

let either = (left, right) => input => {
  let (value, input') = left(input)

  switch (value) {
  | Ok(a) => (Ok(a), input')
  | _ => right(input)
  }
}

let satisfy = predicate => input => {
  let (value, input') = item(input)

  let handleOk = a => {
    let (index, _) = input

    if (predicate(a)) {
      (Ok(a), input')
    } else {
      (Error("Unexpected char " ++ String.make(1, a) ++ ", at position:" ++ string_of_int(index)), input')
    }
  }

  switch (value) {
  | Ok(a) => handleOk(a)
  | Error(message) => (Error(message), input')
  }
}

let digit = satisfy(c => c >= '0' && c <= '9')

let lower = satisfy(c => c >= 'a' && c <= 'z')

let uppper = satisfy(c => c >= 'A' && c <= 'Z')

let char = target => satisfy(c => c == target)

let exclude = x => satisfy(value => value != x)

let rec oneOf = parsers => switch (parsers) {
| [] => error("Can't not call oneOf([]), at least put a parser in it")
| [parser] => parser
| [parser, ...restParsers] => either(parser, oneOf(restParsers))
}

let space = satisfy(c => c == ' ' || c == '\n' || c == '\t')

let rec many = parser => {
  let f = inject(item => list => [item, ...list])

  let item = parser -> apply

  let list = (source => many(parser)(source)) -> apply

  either(f -> item -> list, inject([]))
}

let many1 = parser => {
  let f = inject(item => list => [item, ...list])
  let item  = either(parser, error("At least matched once")) -> apply
  let list = many(parser) -> apply

  f -> item -> list
}

let rec string = str => {
  let length = String.length(str)

  if (length === 0) {
    inject("")
  } else {
    let f = inject(x => xs => String.make(1, x) ++ xs)
    let x = char(String.get(str, 0)) -> apply
    let xs = string(String.sub(str, 1, length - 1)) -> apply

    f -> x -> xs
  }
}

let list_to_string = list => List.fold_left((a, b) => a ++ String.make(1, b), "", list)

let positiveInteger = {
  let toString = map(list => Ok(list_to_string(list)))
  let toNumber = map(str => Ok(int_of_string(str)))

  many1(digit) -> toString -> toNumber
}

let negativeInteger = {
  let f = inject(_ => int => -int)
  let negative = apply(char('-'))
  let integer = apply(positiveInteger)

  f -> negative -> integer
}

let integer = either(positiveInteger, negativeInteger)

let combineFloat = a => _ => c => List.concat([a, ['.'], c]) -> list_to_string -> float_of_string

let positiveFloat = {
  let f = inject(combineFloat)
  let integer = apply(many1(digit))
  let dot = apply(char('.'))
  let decimal = apply(many1(digit))

  f -> integer -> dot -> decimal
}

let negativeFloat = {
  let f = inject(_ => float => -.float)
  let negative = apply(char('-'))
  let float = apply(positiveFloat)

  f -> negative -> float
}

let float = either(positiveFloat, negativeFloat)

let skip = (ignored, parser) => {
  let f = inject(_ => b => b)
  let a = apply(ignored)
  let b = apply(parser)

  f -> a -> b
}

let separate = (parser, separator) => {
  let f = inject(x => xs => [x, ...xs])
  let x = apply(parser)
  let xs = apply(many(skip(separator, parser)))

  f -> x -> xs
}

let bracket = (left, parser, right) => {
  let f = inject(_ => b => _ => b)
  let a = apply(left)
  let b = apply(parser)
  let c = apply(right)

  f -> a -> b -> c
}

let arround = (parser, surround) => bracket(many(surround), parser, many(surround))

let spaceArround = parser => arround(parser, space)

let comma = char(',')

type json = 
  | JSON_Null
  | JSON_Boolean(bool)
  | JSON_Number(float)
  | JSON_String(string)
  | JSON_Array(list(json))
  | JSON_Object(list((string, json)))

let rec join = (char: string, list: list(string)): string => {
  switch(list) {
  | [] => ""
  | [tail] => tail
  | [head, ...tail] => head ++ char ++ join(char, tail)
  }
}

let rec show_json = json => switch (json) {
  | JSON_Null => "null"
  | JSON_Boolean(b) => string_of_bool(b)
  | JSON_Number(f) => mod_float(f, 1.0) == 0.0 ? string_of_int(int_of_float(f)) : Js.Float.toString(f)
  | JSON_String(str) => "\"" ++ str ++ "\""
  | JSON_Array(list) => "[" ++ join(",", List.map(show_json, list)) ++ "]"
  | JSON_Object(entries) => "{" ++ join(",", List.map(show_pair, entries)) ++ "}"
}
and show_pair = ((key, value): (string, json)): string => {
  "\"" ++ key ++ "\"" ++ ":" ++ show_json(value)
}

let json_null = {
  let f = inject((_) => JSON_Null)
  let null = apply(string("null"))

  f -> null
}

let json_boolean = {
  let f = inject(str => JSON_Boolean(str == "true"))
  let true_or_false = either(string("true"), string("false")) -> apply
  f -> true_or_false
}

let json_int = {
  let f = inject(x => JSON_Number(float_of_int(x)))
  let x = integer -> apply

  f -> x
}

let json_float = {
  let f = inject(x => JSON_Number(x))
  let x = float -> apply

  f -> x
}

let json_number = either(json_float, json_int)

let string_parser = {
  let f = inject(_ => list => _ => list_to_string(list))
  let left_quote = char('"') -> apply
  let content = exclude('"') -> many -> apply
  let right_quote = char('"') -> apply

  f -> left_quote -> content -> right_quote
}

let json_string = {
  let f = inject(str => JSON_String(str))
  let str = string_parser -> apply

  f -> str
}
  
let rec json_parser = input => {
  oneOf([
    json_null,
    json_boolean,
    json_number,
    json_string,
    json_array,
    json_object
  ])(input)
}

and json_array = input => {
  let left_bracket = char('[') -> spaceArround
  let right_bracket = char(']') -> spaceArround
  let comma_separator = comma -> spaceArround
  let json_value = json_parser -> spaceArround

  let values = either(separate(json_value, comma_separator), inject([]))

  let array = bracket(left_bracket, values, right_bracket) -> apply

  let f = inject(list => JSON_Array(list))

  let parser = f -> array

  parser(input)
}

and json_object = input => {
  let f = inject(key => _ => value => (key, value))
  let key = string_parser -> spaceArround -> apply
  let colon = char(':') -> spaceArround -> apply
  let value = json_parser -> spaceArround -> apply
  let pair = f -> key -> colon -> value
  let comma_separator = comma -> spaceArround
  let f' = inject(list => JSON_Object(list))
  let pairs = either(separate(pair, comma_separator), inject([])) -> apply
  let left_brace = char('{') -> spaceArround
  let right_brace = char('}') -> spaceArround
  let object_parser = bracket(left_brace, f' -> pairs, right_brace)

  object_parser(input)
}

let json = source => json_parser((0, source))

let show = result => switch (result) {
| (Ok(json), _) => show_json(json)
| (Error(e), _) => e
}

/* Js.log(json_parser("{ \"number\" : \"-0.1\" }"))
let test = float("-123.344");
/* Js.log(test) */
switch (test) {
| (Ok(a), _) => Js.log("parse success, result: " ++ string_of_float(a))
| (Error(message), _) => Js.log("failed to parse, " ++ message)
} */