SpiseMisu.ParserCombinator 0.11.18

SpiseMisu.ParserCombinator

Efficient string parser-combinator in F#.

Project structure

├── SpiseMisu.ParserCombinator
│   ├── SpiseMisu.ParserCombinator.fsproj
│   └── parser.fs
├── demo
│   ├── foobar.fsx
│   └── json.fsx
├── imgs
│   ├── licenses
│   └── nuget
├── SpiseMisu.ParserCombinator.sln
├── global.json
├── license.txt
├── license_cil-bytecode_agpl-3.0-only.txt
├── license_knowhow_cc-by-nc-nd-40.txt
└── readme.md

Demo

#!/usr/bin/env -S dotnet fsi --langversion:10.0 --optimize --warnaserror+:25,26

//#I @"../SpiseMisu.ParserCombinator/bin/Release/net10.0/"
//#r @"SpiseMisu.ParserCombinator.dll"

#r "nuget: SpiseMisu.ParserCombinator, 00.11.18"

#time "on"

open System

open SpiseMisu.Parser

module rec FooBar =
  
  type t =
    | Foo of t seq
    | Bar of int
  
  let foobarP () =
        barP
    <|> fooP
  
  let barP =
    ( int >> Bar
    )
    <!> digitsP
  
  let foobarsP =
    sepByP
      ( deferP foobarP )
      ( skipSpacesP *> charP ',' <* skipSpacesP )
  
  let fooP =
    ( Foo
    )
    <!> charP '[' *> skipSpacesP *> foobarsP <* skipSpacesP <* charP ']'

open FooBar

let _ =
  
  "[\t00, [ \n1337,2     , 42]     ]"
  
  (* Should be parsed as:
     > Foo (seq [Bar 0; Foo (seq [Bar 1337; Bar 2; Bar 42])])
  *)
  
  |> runP (deferP foobarP)
  |> function
    | Ok    a -> printfn "# Parse:\n%A" a
    | Error e -> printfn "# Error:\n%s" e
  
  00

NOTE: The demo script is available at: ./demo/foobar.fsx.

Non-trivial JSON example

#!/usr/bin/env -S dotnet fsi --langversion:10.0 --optimize --warnaserror+:25,26

//#I @"../SpiseMisu.ParserCombinator/bin/Release/net10.0/"
//#r @"SpiseMisu.ParserCombinator.dll"

#r "nuget: SpiseMisu.ParserCombinator, 00.11.18"

open System

open SpiseMisu.Parser

module JSON =
  
  module PC = SpiseMisu.Parser
  
  (* Introducing JSON: https://www.json.org/  *)
  
  module Number =
      
    type t =
      | Dec of double
      | Int of int
  
  type t =
    | Null
    | Boolean of bool
    | Number  of Number.t
    | String  of string
    | Array   of t list
    | Object  of (string * t) list
  
  let rec pprint x =
    match x with
      | Null                  -> "null"
      | Boolean            b  -> sprintf "%b" b
      | Number (Number.Dec d) -> sprintf "%f" d
      | Number (Number.Int i) -> sprintf "%i" i
      | String             s  -> sprintf "%A" s
      | Array             es  ->
        let aux =
          es
          |> List.map pprint
          |> fun xs ->
            if List.isEmpty xs then
              ""
            else
              xs
              |> List.reduce (sprintf "%s,%s")
        "[" + aux + "]"
      | Object            ms  ->
        let aux =
          ms
          |> List.map
            ( fun (k,v) ->
                sprintf "%A" k + ":" + pprint v
            )
          |> fun xs ->
            if List.isEmpty xs then
              ""
            else
              xs
              |> List.reduce (sprintf "%s,%s")
        "{" + aux + "}"
  
  module Parser =
    
    let private hexLower =
      Array.append [| '0' .. '9' |] [|'a' .. 'z'|]
    let private hexUpper =
      Array.append [| '0' .. '9' |] [|'A' .. 'Z'|]
    
    let rec jsonP () : t parser =
      (* NOTE: `<|>` is equivalent to using `choiceP`:
          (deferP objectP)
      <|> (deferP arrayP)
      <|> stringP
      <|> numberP
      <|> booleanP
      <|> nullP
      *)
      choiceP
        [ deferP objectP
        ; deferP arrayP
        ; stringP
        ; numberP
        ; booleanP
        ; nullP
        ]
    
    and charsP : string parser =
      let auxP = 
        let rec aux (s : State.t) =
          match Source.get s.off s.off s.src with
            | Some cs ->
              match cs with
              // NOTE: All except:
              // - Quotation Mark
              | "\034"                                      ->
                Result.Ok s
              // - Invalid reverse slash sequence
              | "\092"                                      ->
                esc { s with off = s.off + 1 }
              // - Control Codes
              | ctrlc when ctrlc < "\032" || ctrlc = "\127" ->
                "charsP > aux > there is atleast a control code in the string"
                |> Result.Error
              | ___________________________________________ ->
                aux { s with off = s.off + 1 }
            | None    ->
              "charsP > aux > not enough chars to comply with JSON string"
              |> Result.Error
        and esc (s : State.t) =
          match Source.get s.off s.off s.src with
            | Some cs ->
              match cs with
              // - Backspace: "\b"
              | "\098"
              // - Horizontal tab: "\t"
              | "\116"
              // - Line feed: "\n
              | "\110"
              // - Form feed: "\f"
              | "\102"
              // - Carriage return: "\r
              | "\114"
              // - Double quotes: "\\":"""
              | "\034"
              // - Forward slash: "\\":"/"
              | "\047"
              // - Reverse slash: "\\":"\\"
              | "\092" ->
                aux { s with off = s.off + 1 }
              // - Unicode: '\\':'u':'0':'0':'0':'0' - '\\':'u':'F':'F':'F':'F'
              | "\117" ->
                uni { s with off = s.off + 1 }
              | ______ ->
                "charsP > esc > invalid reverse slash sequence"
                |> Result.Error
            | None ->
              "charsP > esc > not enough chars to comply with reverse slash"
              |> Result.Error
        and uni (s : State.t) =
          let n = 4
          let i = s.off
          let j = i + (n - 1)
          match Source.get i j s.src with
            | Some cs ->
              if ( Seq.forall (fun c -> Array.exists ((=) c) hexLower) cs ||
                   Seq.forall (fun c -> Array.exists ((=) c) hexUpper) cs
                 )
              then
                aux { s with off = s.off + n }
              else
                "charsP > uni > invalid hex unicode"
                |> Result.Error
            | None ->
              "charsP > uni > not enough chars to comply with Unicode format"
              |> Result.Error
        ( fun s ->
            match aux s with
              | Result.Ok n    ->
                let i = s.off
                let j = n.off - 1 (* Last char failed, so skip it *)
                match Source.get i j s.src with
                  | Some cs ->
                    Step.Okay (cs, n)
                  | None -> 
                    error n "charsP"
                    |> Step.Fail
              | Result.Error e ->
                error s e
                |> Step.Fail
        )
        |> Parser
      charP '"' *> auxP <* charP '"'
    
    and objectP () : t parser =
      let keyValueP : (string * t) parser =
        ( fun k _ v -> (k, v)
        )
        <!> charsP
        <*> skipSpacesP *> charP ':' <* skipSpacesP
        <*> (deferP jsonP)
      let membersP : (string * t) seq parser =
        sepByP
          ( keyValueP )
          ( skipSpacesP *> charP ',' <* skipSpacesP )
      ( Seq.toList >> Object
      )
      <!> charP '{' *> skipSpacesP *> membersP <* skipSpacesP <* charP '}'
    
    and arrayP () : t parser =
      let elemsP : t seq parser =
        sepByP
          ( deferP jsonP )
          ( skipSpacesP *> charP ',' <* skipSpacesP )
      ( Seq.toList >> Array
      )
      <!> charP '[' *> skipSpacesP *> elemsP <* skipSpacesP <* charP ']'
    
    and stringP : t parser =
      String <!> charsP
    
    and numberHelpP : string parser =
      let auxP sign =
        ( fun s ds ->
            s + ds
        )
        <!> charP sign
        <*> digitsP
      choiceP
        [ auxP '-'
        ; auxP '+'
        ; digitsP
        ]
    
    and intP : t parser =
      ( int >> Number.Int >> Number
      )
      <!> numberHelpP
    
    and decP : t parser =
      ( fun ns sep ds ->
          ns + sep + ds
          |> double
          |> Number.Dec
          |> Number
      )
      <!> numberHelpP
      <*> charP '.'
      <*> digitsP
      
    and numberP : t parser =
      choiceP
        [ decP
        ; intP
        ]
    
    and falseP : t parser =
      ( fun _ -> Boolean false
      )
      <!> PC.stringP "false"
    
    and trueP : t parser =
      ( fun _ -> Boolean true
      )
      <!> PC.stringP "true"
    
    and booleanP : t parser =
      choiceP
        [ falseP
        ; trueP
        ]
    
    and nullP : t parser =
      ( fun _ -> Null
      )
      <!> PC.stringP "null"

open JSON
open JSON.Parser

let json =

  Console.ReadLine()

#time "off"
#time "on"

let _ =

  (*
    {"kind":"Listing", …,"children":[…],"before":null}}
    Real: 00:00:03.727, CPU: 00:00:16.500, GC gen0: 96, gen1: 96, gen2: 96
  *)
  
  json
  |> runP (deferP jsonP)
  |> function
    | Ok    a -> printfn "# Parse:\n%s" (pprint a)
    | Error e -> printfn "# %s"                 e

  00

NOTE: The non-trivial JSON script is available at: ./demo/json.fsx.

NOTE: You SHOULD NOT use this approach for datastructures that already have built-in logic.

module JSON =
  
  …
  
  module Native =
    
    open System.Text.Json
    open System.Text.Json.Nodes
    
    let decode (json) : t option =
      let deserialize (str:string) =
        try
          JsonSerializer.Deserialize<JsonDocument>(json = str)
          |> Some
        with _ ->
          None
      
      let rec aux (json:JsonElement) =
        match json.ValueKind with
          | JsonValueKind.Undefined ->
            (* 0 - There is no value (as distinct from Null). *)
            JsonValueKind.Undefined
            |> sprintf "NOT part of the JSON-specs: %A" 
            |> failwith
          | JsonValueKind.Object ->
            (* 1 - A JSON object. *)
            json.EnumerateObject()
            |> Seq.map (fun kv -> kv.Name, aux kv.Value)
            |> Seq.toList
            |> Object
          | JsonValueKind.Array ->
            (* 2 - A JSON array. *)
            json.EnumerateArray()
            |> Seq.map aux
            |> Seq.toList
            |> Array
          | JsonValueKind.String ->
            (* 3 - A JSON string. *)
            json.GetString()
            |> String
          | JsonValueKind.Number ->
            (* 4 - A JSON number. *)
            match json.TryGetInt32() with
              | (true, num) -> Number (Number.Int num)
              | ___________ -> Number (Number.Dec (json.GetDouble()))
          | JsonValueKind.True ->
            (* 5 - The JSON value true. *)
            json.GetBoolean()
            |> Boolean
          | JsonValueKind.False ->
            (* 6 - The JSON value false. *)
            json.GetBoolean()
            |> Boolean
          | JsonValueKind.Null ->
            (* 7 - The JSON value null. *)
            Null
          | otherwise ->
            otherwise
            |> sprintf "NOT possible: %A" 
            |> failwith
      deserialize json
      |> Option.map (fun jdoc -> aux jdoc.RootElement)

…

#time "off"
#time "on"

let _ =

  (*
    {"kind":"Listing", …,"children":[…],"before":null}}
    Real: 00:00:00.034, CPU: 00:00:00.040, GC gen0: 0, gen1: 0, gen2: 0
  *)
  
  json
  |> JSON.Native.decode
  |> function
    | Some v ->
      printfn "%s" (pprint v)
    | None   ->
      printfn "Not valid JSON value"

  00

The difference is around a factor x100:

Real: 00:00:03.727, CPU: 00:00:16.500, GC gen0: 96, gen1: 96, gen2: 96

vs

Real: 00:00:00.034, CPU: 00:00:00.040, GC gen0: 0, gen1: 0, gen2: 0

Licenses

Source code in this repository is ONLY covered by a Server Side Public License, v 1 while the rest (knowhow, text, media, …), is covered by the Creative Commons Attribution-NonCommercial-NoDerivatives 4.0 International license.

However, as it's not permitted to deploy a nuget package with non OSI nor FSF licenses. The CIL-bytecode content of the nuget package is therefore dual-licensed under the GNU Affero General Public License v3.0 only and the rest (knowhow, text, media, …), is covered by the Creative Commons Attribution-NonCommercial-NoDerivatives 4.0 International license.

For more info on compatible nuget packages licenses, see SPDX License List.