SpiseMisu.ParserCombinator 0.11.13

SpiseMisu.ParserCombinator

Efficient string parser-combinator in F#

Demo

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

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

#r "nuget: SpiseMisu.ParserCombinator, 00.11.13"

#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:8.0 --optimize --warnaserror+:25,26

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

#r "nuget: SpiseMisu.ParserCombinator, 00.11.13"

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 =

  // """{"kind": "t3", "data": {"approved_at_utc": null, "subreddit": "programming", "selftext": "", "author_fullname": "t2_95hql1ur", "saved": false, "mod_reason_title": null, "gilded": 0, "clicked": false, "title": "Announcing 150M developers and a new free tier for GitHub Copilot in VS Code", "link_flair_richtext": [], "subreddit_name_prefixed": "r/programming", "hidden": false, "pwls": 6, "link_flair_css_class": null, "downs": 0, "top_awarded_type": null, "hide_score": false, "name": "t3_1hhbrqr", "quarantine": false, "link_flair_text_color": "dark", "upvote_ratio": 0.88, "author_flair_background_color": null, "subreddit_type": "public", "ups": 139, "total_awards_received": 0, "media_embed": {}, "author_flair_template_id": null, "is_original_content": false, "user_reports": [], "secure_media": null, "is_reddit_media_domain": false, "is_meta": false, "category": null, "secure_media_embed": {}, "link_flair_text": null, "can_mod_post": false, "score": 139, "approved_by": null, "is_created_from_ads_ui": false, "author_premium": false, "thumbnail": "", "edited": false, "author_flair_css_class": null, "author_flair_richtext": [], "gildings": {}, "content_categories": null, "is_self": false, "mod_note": null, "created": 1734555927.0, "link_flair_type": "text", "wls": 6, "removed_by_category": null, "banned_by": null, "author_flair_type": "text", "domain": "github.blog", "allow_live_comments": false, "selftext_html": null, "likes": null, "suggested_sort": null, "banned_at_utc": null, "url_overridden_by_dest": "https://github.blog/news-insights/product-news/github-copilot-in-vscode-free/", "view_count": null, "archived": false, "no_follow": false, "is_crosspostable": false, "pinned": false, "over_18": false, "all_awardings": [], "awarders": [], "media_only": false, "can_gild": false, "spoiler": false, "locked": false, "author_flair_text": null, "treatment_tags": [], "visited": false, "removed_by": null, "num_reports": null, "distinguished": null, "subreddit_id": "t5_2fwo", "author_is_blocked": false, "mod_reason_by": null, "removal_reason": null, "link_flair_background_color": "", "id": "1hhbrqr", "is_robot_indexable": true, "report_reasons": null, "author": "Demon-Souls", "discussion_type": null, "num_comments": 27, "send_replies": true, "contest_mode": false, "mod_reports": [], "author_patreon_flair": false, "author_flair_text_color": null, "permalink": "/r/programming/comments/1hhbrqr/announcing_150m_developers_and_a_new_free_tier/", "stickied": false, "url": "https://github.blog/news-insights/product-news/github-copilot-in-vscode-free/", "subreddit_subscribers": 6677388, "created_utc": 1734555927.0, "num_crossposts": 0, "media": null, "is_video": false}}"""

  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