JsonValue.fs

// --------------------------------------------------------------------------------------
// Copyright (c) Microsoft Corporation 2005-2012.
// This sample code is provided "as is" without warranty of any kind.
// We disclaim all warranties, either express or implied, including the
// warranties of merchantability and fitness for a particular purpose.
//
// A simple F# portable parser for JSON data
// --------------------------------------------------------------------------------------

namespace FSharp.Data

open System
open System.IO
open System.ComponentModel
open System.Globalization
open System.Runtime.InteropServices
open System.Text
open FSharp.Data.Runtime

/// Specifies the formatting behaviour of JSON values
// [<RequireQualifiedAccess>]
type JsonSaveOptions =
    /// Format (indent) the JsonValue
    | None = 0

    /// Print the JsonValue in one line in a compact way
    | DisableFormatting = 1

    /// Print the JsonValue in one line in a compact way,
    /// but place a single space after every comma
    /// https://github.com/fsprojects/FSharp.Data/issues/1482
    | CompactSpaceAfterComma = 2

/// Represents a JSON value. Large numbers that do not fit in the
/// Decimal type are represented using the Float case, while
/// smaller numbers are represented as decimals to avoid precision loss.
[<RequireQualifiedAccess>]
[<StructuredFormatDisplay("{_Print}")>]
type JsonValue =
    /// A JSON string value
    | String of string
    /// A JSON number stored as a decimal (used for numbers that fit in the decimal range)
    | Number of decimal
    /// A JSON number stored as a float (used for large numbers that do not fit in decimal)
    | Float of float
    /// A JSON object, represented as an array of name-value pairs
    | Record of properties: (string * JsonValue)[]
    /// A JSON array of values
    | Array of elements: JsonValue[]
    /// A JSON boolean value
    | Boolean of bool
    /// A JSON null value
    | Null

    /// <exclude />
    [<EditorBrowsableAttribute(EditorBrowsableState.Never)>]
    [<CompilerMessageAttribute("This method is intended for use in generated code only.",
                               10001,
                               IsHidden = true,
                               IsError = false)>]
    member x._Print =
        let str = x.ToString()

        if str.Length > 512 then
            str.Substring(0, 509) + "..."
        else
            str

    /// <summary>Serializes the JsonValue to the specified System.IO.TextWriter.</summary>
    /// <param name="w">The writer to serialize to.</param>
    /// <param name="saveOptions">Controls formatting: indented, compact, or compact with spaces.</param>
    /// <param name="indentationSpaces">Number of spaces per indentation level (default 2). Only used when saveOptions is <see cref="JsonSaveOptions.None"/>.</param>
    member x.WriteTo(w: TextWriter, saveOptions, ?indentationSpaces: int) =
        let indentationSpaces = defaultArg indentationSpaces 2

        let newLine =
            if saveOptions = JsonSaveOptions.None then
                fun indentation plus ->
                    w.WriteLine()
                    System.String(' ', indentation + plus) |> w.Write
            else
                fun _ _ -> ()

        let propSep = if saveOptions = JsonSaveOptions.None then "\": " else "\":"

        let comma () =
            match saveOptions with
            | JsonSaveOptions.None -> w.Write ","
            | JsonSaveOptions.DisableFormatting -> w.Write ","
            | JsonSaveOptions.CompactSpaceAfterComma -> w.Write ", "
            | _ -> failwith "Invalid JsonSaveOptions"

        let rec serialize indentation =
            function
            | Null -> w.Write "null"
            | Boolean b -> w.Write(if b then "true" else "false")
            | Number number -> w.Write number
            | Float v when Double.IsInfinity v || Double.IsNaN v -> w.Write "null"
            | Float number ->
                let s = number.ToString("R", CultureInfo.InvariantCulture)
                w.Write s
                // Ensure the output looks like a float (has a decimal point or exponent),
                // so that round-tripping through JSON preserves the Float type.
                if s.IndexOfAny([| '.'; 'E'; 'e' |]) = -1 then
                    w.Write ".0"
            | String s ->
                w.Write "\""
                JsonValue.JsonStringEncodeTo w s
                w.Write "\""
            | Record properties ->
                w.Write "{"

                for i = 0 to properties.Length - 1 do
                    let k, v = properties.[i]

                    if i > 0 then
                        comma ()

                    newLine indentation indentationSpaces
                    w.Write "\""
                    JsonValue.JsonStringEncodeTo w k
                    w.Write propSep
                    serialize (indentation + indentationSpaces) v

                newLine indentation 0
                w.Write "}"
            | Array elements ->
                w.Write "["

                for i = 0 to elements.Length - 1 do
                    if i > 0 then
                        comma ()

                    newLine indentation indentationSpaces
                    serialize (indentation + indentationSpaces) elements.[i]

                if elements.Length > 0 then
                    newLine indentation 0

                w.Write "]"

        serialize 0 x

    // Optimized JSON string encoding with reduced allocations and bulk writing
    // Encode characters that are not valid in JS string. The implementation is based
    // on https://github.com/mono/mono/blob/master/mcs/class/System.Web/System.Web/HttpUtility.cs
    static member internal JsonStringEncodeTo (w: TextWriter) (value: string) =
        if not (String.IsNullOrEmpty value) then
            let mutable lastWritePos = 0

            for i = 0 to value.Length - 1 do
                let c = value.[i]
                let ci = int c

                let needsEscaping =
                    ci >= 0 && ci <= 7
                    || ci = 11
                    || ci >= 14 && ci <= 31
                    || c = '\b'
                    || c = '\t'
                    || c = '\n'
                    || c = '\f'
                    || c = '\r'
                    || c = '"'
                    || c = '\\'

                if needsEscaping then
                    // Write all accumulated unescaped characters in one operation
                    if i > lastWritePos then
#if NETSTANDARD2_0
                        w.Write(value.Substring(lastWritePos, i - lastWritePos))
#else
                        w.Write(value.AsSpan(lastWritePos, i - lastWritePos))
#endif

                    // Write the escaped character
                    if ci >= 0 && ci <= 7 || ci = 11 || ci >= 14 && ci <= 31 then
                        w.Write("\\u{0:x4}", ci) |> ignore
                    else
                        match c with
                        | '\b' -> w.Write "\\b"
                        | '\t' -> w.Write "\\t"
                        | '\n' -> w.Write "\\n"
                        | '\f' -> w.Write "\\f"
                        | '\r' -> w.Write "\\r"
                        | '"' -> w.Write "\\\""
                        | '\\' -> w.Write "\\\\"
                        | _ -> w.Write c

                    lastWritePos <- i + 1

            // Write any remaining unescaped characters
            if lastWritePos < value.Length then
#if NETSTANDARD2_0
                w.Write(value.Substring(lastWritePos))
#else
                w.Write(value.AsSpan(lastWritePos))
#endif

    /// <summary>Serializes this JsonValue to a string with the specified formatting options.</summary>
    /// <param name="saveOptions">Controls formatting: indented, compact, or compact with spaces.</param>
    /// <param name="indentationSpaces">Number of spaces per indentation level (default 2). Only used when saveOptions is <see cref="JsonSaveOptions.None"/>.</param>
    /// <returns>The JSON string representation.</returns>
    member x.ToString(saveOptions, ?indentationSpaces: int) =
        let w = new StringWriter(CultureInfo.InvariantCulture)
        x.WriteTo(w, saveOptions, ?indentationSpaces = indentationSpaces)
        w.GetStringBuilder().ToString()

    /// <summary>Serializes this JsonValue to a formatted (indented) string.</summary>
    /// <param name="indentationSpaces">Number of spaces per indentation level (default 2).</param>
    /// <returns>The formatted JSON string representation.</returns>
    member x.ToString(?indentationSpaces: int) =
        x.ToString(JsonSaveOptions.None, ?indentationSpaces = indentationSpaces)

    override x.ToString() = x.ToString(JsonSaveOptions.None)

/// <exclude />
[<CompilationRepresentation(CompilationRepresentationFlags.ModuleSuffix)>]
module JsonValue =

    /// Active Pattern to view a `JsonValue.Record of (string * JsonValue)[]` as a `JsonValue.Object of Map<string, JsonValue>` for
    /// backwards compatibility reaons
    [<Obsolete("Please use JsonValue.Record instead")>]
    let (|Object|_|) x =
        match x with
        | JsonValue.Record properties -> Map.ofArray properties |> Some
        | _ -> None

    /// Constructor to create a `JsonValue.Record of (string * JsonValue)[]` as a `JsonValue.Object of Map<string, JsonValue>` for
    /// backwards compatibility reaons
    [<Obsolete("Please use JsonValue.Record instead")>]
    let Object = Map.toArray >> JsonValue.Record

// --------------------------------------------------------------------------------------
// JSON parser
// --------------------------------------------------------------------------------------

type private JsonParser(jsonText: string) =

    let mutable i = 0
    let s = jsonText

    let buf = StringBuilder() // pre-allocate buffers for strings

    // Helper functions

    let isNumChar c =
        Char.IsDigit c || c = '.' || c = 'e' || c = 'E' || c = '+' || c = '-'

    let throw () =
        let msg =
            sprintf
                "Invalid JSON starting at character %d, snippet = \n----\n%s\n-----\njson = \n------\n%s\n-------"
                i
                (jsonText.[(max 0 (i - 10)) .. (min (jsonText.Length - 1) (i + 10))])
                (if jsonText.Length > 1000 then
                     jsonText.Substring(0, 1000)
                 else
                     jsonText)

        failwith msg

    let ensure cond =
        if not cond then
            throw ()


    let rec skipCommentsAndWhitespace () =
        let skipComment () =
            // Supported comment syntax:
            // - // ...{newLine}
            // - /* ... */
            if i < s.Length && s.[i] = '/' then
                i <- i + 1

                if i < s.Length && s.[i] = '/' then
                    i <- i + 1

                    while i < s.Length && (s.[i] <> '\r' && s.[i] <> '\n') do
                        i <- i + 1
                else if i < s.Length && s.[i] = '*' then
                    i <- i + 1

                    while i + 1 < s.Length && (s.[i] <> '*' || s.[i + 1] <> '/') do
                        i <- i + 1

                    ensure (i + 1 < s.Length && s.[i] = '*' && s.[i + 1] = '/')
                    i <- i + 2

                true

            else
                false

        let skipWhitespace () =
            let initialI = i

            while i < s.Length && Char.IsWhiteSpace s.[i] do
                i <- i + 1

            initialI <> i // return true if some whitespace was skipped

        if skipWhitespace () || skipComment () then
            skipCommentsAndWhitespace ()

    // Recursive descent parser for JSON that uses global mutable index
    let rec parseValue cont =
        skipCommentsAndWhitespace ()
        ensure (i < s.Length)

        match s.[i] with
        | '"' -> cont (JsonValue.String(parseString ()))
        | '-' -> cont (parseNum ())
        | c when Char.IsDigit(c) -> cont (parseNum ())
        | '{' -> parseObject cont
        | '[' -> parseArray cont
        | 't' -> cont (parseLiteral ("true", JsonValue.Boolean true))
        | 'f' -> cont (parseLiteral ("false", JsonValue.Boolean false))
        | 'n' -> cont (parseLiteral ("null", JsonValue.Null))
        | _ -> throw ()

    and parseString () =
        ensure (i < s.Length && s.[i] = '"')
        i <- i + 1

        // Track start of current unescaped run; flush as a bulk chunk when an escape or end is hit.
        // This avoids per-character StringBuilder.Append calls for strings with few/no escapes,
        // which is the common case in real-world JSON.
        let mutable chunkStart = i

        let inline flushChunk upTo =
            if upTo > chunkStart then
                buf.Append(s, chunkStart, upTo - chunkStart) |> ignore

        while i < s.Length && s.[i] <> '"' do
            if s.[i] = '\\' then
                flushChunk i
                ensure (i + 1 < s.Length)

                match s.[i + 1] with
                | 'b' -> buf.Append('\b') |> ignore
                | 'f' -> buf.Append('\f') |> ignore
                | 'n' -> buf.Append('\n') |> ignore
                | 't' -> buf.Append('\t') |> ignore
                | 'r' -> buf.Append('\r') |> ignore
                | '\\' -> buf.Append('\\') |> ignore
                | '/' -> buf.Append('/') |> ignore
                | '"' -> buf.Append('"') |> ignore
                | 'u' ->
                    ensure (i + 5 < s.Length)

                    let inline hexdigit (d: char) =
                        if d >= '0' && d <= '9' then int32 d - int32 '0'
                        elif d >= 'a' && d <= 'f' then int32 d - int32 'a' + 10
                        elif d >= 'A' && d <= 'F' then int32 d - int32 'A' + 10
                        else failwith "hexdigit"

                    // Direct indexing avoids a Substring allocation per \uXXXX escape.
                    let ch =
                        char (
                            hexdigit s.[i + 2] * 4096
                            + hexdigit s.[i + 3] * 256
                            + hexdigit s.[i + 4] * 16
                            + hexdigit s.[i + 5]
                        )

                    buf.Append(ch) |> ignore
                    i <- i + 4 // the \ and u will also be skipped past further below
                | 'U' ->
                    ensure (i + 9 < s.Length)

                    let unicodeChar (s: string) =
                        if s.Length <> 8 then
                            failwithf "unicodeChar (%O)" s

                        if s.[0] <> '0' || s.[1] <> '0' then
                            failwithf "unicodeChar (%O)" s

                        UnicodeHelper.getUnicodeSurrogatePair
                        <| System.UInt32.Parse(s, NumberStyles.HexNumber)

                    let lead, trail = unicodeChar (s.Substring(i + 2, 8))
                    buf.Append(lead) |> ignore
                    buf.Append(trail) |> ignore
                    i <- i + 8 // the \ and u will also be skipped past further below
                | _ -> throw ()

                i <- i + 2 // skip past \ and next char
                chunkStart <- i
            else
                i <- i + 1

        // Flush any remaining unescaped characters
        flushChunk i
        ensure (i < s.Length && s.[i] = '"')
        i <- i + 1
        let str = buf.ToString()
        buf.Clear() |> ignore
        str

    and parseNum () =
        let start = i

        while i < s.Length && (isNumChar s.[i]) do
            i <- i + 1

        let len = i - start
#if NETSTANDARD2_0
        let sub = s.Substring(start, len)

        match TextConversions.AsDecimal CultureInfo.InvariantCulture sub with
        | Some x -> JsonValue.Number x
        | _ ->
            match TextConversions.AsFloat [||] false CultureInfo.InvariantCulture sub with
            | Some x -> JsonValue.Float x
            | _ -> throw ()
#else
        // Span-based parsing avoids a Substring allocation per number token.
        let span = s.AsSpan(start, len)

        match Decimal.TryParse(span, NumberStyles.Currency, CultureInfo.InvariantCulture) with
        | true, x -> JsonValue.Number x
        | false, _ ->
            match Double.TryParse(span, NumberStyles.Any, CultureInfo.InvariantCulture) with
            | true, x -> JsonValue.Float x
            | false, _ -> throw ()
#endif

    and parsePair cont =
        let key = parseString ()
        skipCommentsAndWhitespace ()
        ensure (i < s.Length && s.[i] = ':')
        i <- i + 1
        skipCommentsAndWhitespace ()
        parseValue (fun v -> cont (key, v))

    and parseObject cont =
        ensure (i < s.Length && s.[i] = '{')
        i <- i + 1
        skipCommentsAndWhitespace ()
        let pairs = ResizeArray<_>()

        let parseObjectEnd () =
            ensure (i < s.Length && s.[i] = '}')
            i <- i + 1
            let res = pairs.ToArray() |> JsonValue.Record
            cont res

        if i < s.Length && s.[i] = '"' then
            parsePair (fun p ->
                pairs.Add(p)
                skipCommentsAndWhitespace ()

                let rec parsePairItem () =
                    if i < s.Length && s.[i] = ',' then
                        i <- i + 1
                        skipCommentsAndWhitespace ()

                        parsePair (fun p ->
                            pairs.Add(p)
                            skipCommentsAndWhitespace ()
                            parsePairItem ())
                    else
                        parseObjectEnd ()

                parsePairItem ())
        else
            parseObjectEnd ()

    and parseArray cont =
        ensure (i < s.Length && s.[i] = '[')
        i <- i + 1
        skipCommentsAndWhitespace ()
        let vals = ResizeArray<_>()

        let parseArrayEnd () =
            ensure (i < s.Length && s.[i] = ']')
            i <- i + 1
            let res = vals.ToArray() |> JsonValue.Array
            cont res

        if i < s.Length && s.[i] <> ']' then
            parseValue (fun v ->
                vals.Add(v)
                skipCommentsAndWhitespace ()

                let rec parseArrayItem () =
                    if i < s.Length && s.[i] = ',' then
                        i <- i + 1
                        skipCommentsAndWhitespace ()

                        parseValue (fun v ->
                            vals.Add(v)
                            skipCommentsAndWhitespace ()
                            parseArrayItem ())
                    else
                        parseArrayEnd ()

                parseArrayItem ())
        else
            parseArrayEnd ()

    and parseLiteral (expected, r) =
        ensure (i + expected.Length <= s.Length)

        for j in 0 .. expected.Length - 1 do
            ensure (s.[i + j] = expected.[j])

        i <- i + expected.Length
        r

    // Start by parsing the top-level value
    member x.Parse() =
        let value = parseValue id
        skipCommentsAndWhitespace ()

        if i <> s.Length then
            throw ()

        value

    member x.ParseMultiple() =
        seq {
            while i <> s.Length do
                yield parseValue id
                skipCommentsAndWhitespace ()
        }

type JsonValue with

    /// <summary>Parses the specified JSON string.</summary>
    /// <param name="text">The JSON string to parse.</param>
    /// <returns>A <see cref="JsonValue"/> representing the parsed JSON.</returns>
    static member Parse(text) = JsonParser(text).Parse()

    /// <summary>Attempts to parse the specified JSON string.</summary>
    /// <param name="text">The JSON string to parse.</param>
    /// <returns>Some <see cref="JsonValue"/> if parsing succeeds, or None if parsing fails.</returns>
    static member TryParse(text) =
        try
            Some <| JsonParser(text).Parse()
        with _ ->
            None

    /// <summary>Loads JSON from the specified stream.</summary>
    /// <param name="stream">The stream to read JSON from.</param>
    /// <returns>A <see cref="JsonValue"/> representing the parsed JSON.</returns>
    static member Load(stream: Stream) =
        use reader = new StreamReader(stream)
        let text = reader.ReadToEnd()
        JsonParser(text).Parse()

    /// <summary>Loads JSON from the specified reader.</summary>
    /// <param name="reader">The text reader to read JSON from.</param>
    /// <returns>A <see cref="JsonValue"/> representing the parsed JSON.</returns>
    static member Load(reader: TextReader) =
        let text = reader.ReadToEnd()
        JsonParser(text).Parse()

    /// <summary>Loads JSON from the specified URI asynchronously.</summary>
    /// <param name="uri">The URI to load JSON from (file path or URL).</param>
    /// <param name="encoding">The text encoding to use (default: UTF-8).</param>
    /// <returns>An async computation yielding a <see cref="JsonValue"/> representing the parsed JSON.</returns>
    static member AsyncLoad(uri: string, [<Optional>] ?encoding) =
        async {
            let encoding = defaultArg encoding Encoding.UTF8
            let! reader = IO.asyncReadTextAtRuntime false "" "" "JSON" encoding.WebName uri
            let text = reader.ReadToEnd()
            return JsonParser(text).Parse()
        }

    /// <summary>Loads JSON from the specified URI.</summary>
    /// <param name="uri">The URI to load JSON from (file path or URL).</param>
    /// <param name="encoding">The text encoding to use (default: UTF-8).</param>
    /// <returns>A <see cref="JsonValue"/> representing the parsed JSON.</returns>
    static member Load(uri: string, [<Optional>] ?encoding) =
        JsonValue.AsyncLoad(uri, ?encoding = encoding) |> Async.RunSynchronously

    /// <summary>Parses the specified string into multiple JSON values (e.g. newline-delimited JSON).</summary>
    /// <param name="text">The string containing multiple JSON values.</param>
    /// <returns>A sequence of <see cref="JsonValue"/> instances.</returns>
    static member ParseMultiple(text) = JsonParser(text).ParseMultiple()

    member private x.PrepareRequest(httpMethod, headers) =
        let httpMethod = defaultArg httpMethod HttpMethod.Post
        let headers = defaultArg (Option.map List.ofSeq headers) []

        let headers =
            if headers |> List.exists (fst >> (=) (fst (HttpRequestHeaders.UserAgent ""))) then
                headers
            else
                HttpRequestHeaders.UserAgent "FSharp.Data JSON Type Provider" :: headers

        let headers =
            HttpRequestHeaders.ContentTypeWithEncoding(HttpContentTypes.Json, Encoding.UTF8)
            :: headers

        TextRequest(x.ToString(JsonSaveOptions.DisableFormatting)), headers, httpMethod

    /// <summary>Sends the JSON to the specified URL synchronously. Defaults to a POST request.</summary>
    /// <param name="url">The URL to send the JSON to.</param>
    /// <param name="httpMethod">The HTTP method to use (default: POST).</param>
    /// <param name="headers">Additional HTTP headers to include.</param>
    /// <returns>An <see cref="HttpResponse"/> containing the server's response.</returns>
    member x.Request(url: string, [<Optional>] ?httpMethod, [<Optional>] ?headers: seq<_>) =
        let body, headers, httpMethod = x.PrepareRequest(httpMethod, headers)
        Http.Request(url, body = body, headers = headers, httpMethod = httpMethod)

    /// <summary>Sends the JSON to the specified URL asynchronously. Defaults to a POST request.</summary>
    /// <param name="url">The URL to send the JSON to.</param>
    /// <param name="httpMethod">The HTTP method to use (default: POST).</param>
    /// <param name="headers">Additional HTTP headers to include.</param>
    /// <returns>An async computation yielding an <see cref="HttpResponse"/> containing the server's response.</returns>
    member x.RequestAsync(url: string, [<Optional>] ?httpMethod, [<Optional>] ?headers: seq<_>) =
        let body, headers, httpMethod = x.PrepareRequest(httpMethod, headers)
        Http.AsyncRequest(url, body = body, headers = headers, httpMethod = httpMethod)

    [<Obsolete("Please use JsonValue.Request instead")>]
    member x.Post(uri: string, [<Optional>] ?headers) = x.Request(uri, ?headers = headers)