FsJson.fs

module FsJson
open System
open System.Text.RegularExpressions

type Json = 
    | JsonObject of JsonSlot list
    | JsonString of String
    | JsonNumber of float
    | JsonBool of bool
    | JsonNull
    | JsonArray of list<Json>
and JsonSlot = String * Json
    

let matchToken pattern source =
    let modifiedPattern = pattern |> sprintf "\A(%s)((?s).*)"
    let matched = Regex.Match(source, modifiedPattern)
    if matched.Success then
        (matched.Groups.[1].Value, matched.Groups.[2].Value) |> Some
    else
        None

let (|WS|_|) = matchToken "[ |\t|\n|\n\r|\r]+"

let rec (|Star|_|) f acc s =
    match f s with
    | Some(m, rest) -> (|Star|_|) f (m::acc) rest
    | None -> (acc |> List.rev, s) |> Some

let (|Token|_|) pattern s =
    match (|Star|_|) (|WS|_|) [] s with
    | Some (_, rest) -> matchToken pattern rest
    | _ -> None
        
let (|PJsonNumber|_|) s =
    match s with
    | Token @"-?(?:0|[1-9]\d*)(?:\.\d+)?(?:[eE][+-]?\d+)?\b" (v, rest) ->
        match Double.TryParse(v) with
        | (true, i) -> Some(i, rest)
        | _ -> None
     | _ -> None

let (|PJsonString|_|) s =
    match s with
    | Token  @"""(?s).*?(?<!\\)""" (v, rest) -> (v, rest) |> Some
    | _ -> None
    //Note: Additional work is needed here to resolve quotes, newlines and encoded characters

let rec (|PJsonValue|_|) (s: String) =
    match s with
    | PJsonString (v, rest) -> (JsonString(v), rest) |> Some
    | PJsonNumber (n, rest) -> (JsonNumber(n), rest) |> Some
    | Token "true" (b, rest) -> (JsonBool(Boolean.Parse(b)), rest) |> Some
    | Token "false" (b, rest) -> (JsonBool(Boolean.Parse(b)), rest) |> Some
    | Token "null" (_,rest) -> (JsonNull,rest) |> Some
    | Token "{" (_, PJsonObject(slots, Token "}" (_,rest))) -> (JsonObject(slots), rest) |> Some
    | Token "\[" (_, PJsonArray(values, Token "\]" (_, rest))) -> (JsonArray(values), rest) |> Some
    //we could have returned None for the default case here
    //but the following help us to locate errors better with incorrectly formatted json
    | Token "," (_,_) -> None 
    | Token "\]" (_,_) -> None
    | Token "}" (_,_) -> None
    | _ -> failwith ("unable to parse json value at " + s)
and (|PJsonArray|) s =
    match s with
    | Star (|PArrayValue|_|) [] (values, rest)  -> (values, rest)
    | _ -> failwith "unable to parse array"
and (|PJsonObject|) s =
    match s with
    | Star (|PJsonSlot|_|) [] (slots, rest) -> (slots, rest)
    | _ -> failwith "unable to parse object"
and (|PJsonSlot|_|) s =
    match s with
    | PJsonString(n, Token ":" (_, PSlotValue(v,rest))) -> ((n,v),rest) |> Some
    |_ -> None
and (|PArrayValue|_|) s =
    match s with
    | PJsonValue (v, rest) ->
        match rest with
        | Token "," (_,rest2) -> (v,rest2) |> Some
        | Token "\]" (_,_) -> (v,rest) |> Some
        | _ -> failwith ("Expecting a ',' or ']' at " + rest)
    | _ -> None
and (|PSlotValue|_|) s =
    match s with
    | PJsonValue (v, rest) ->
        match rest with
        | Token "," (_,rest2) -> (v,rest2) |> Some
        | Token "}" (_,_) -> (v,rest) |> Some
        | _ -> failwith ("Expecting a ',' or '}' at " + rest)
    | _ -> None

let parseJson (s:String) =
    match s with
    | PJsonValue (_, json) -> json
    | _ -> failwith "unable to parse"