JSON parsing with monads

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
66: 
67: 
68: 
69: 
70: 
71: 
72: 
73: 
74: 
75: 
76: 
77: 
78: 
79: 
80: 
81: 
82: 
83: 
84: 
85: 
86: 
87: 
88: 
89: 
90: 
91: 
92: 
93: 
94: 
95: 

(Parser Monad omitted. Code available here: https://bitbucket.org/ZachBray/parsad)

type expr =
   | JSObject of Map<string, expr>
   | JSNumber of float
   | JSString of string
   | JSArray of expr list
   | JSBool of bool
   | JSNull

let jsBool () = parser {
   let! b = "true|false"
   return JSBool <| Boolean.Parse b
}

let jsNumber() = parser {
   let! n = "[-+]?[0-9]*\.?[0-9]+"
   return JSNumber <| Double.Parse n
}

let jsString() = parser {
   let! str = "\"[^\"]*\""
   return JSString <| str
}

let jsNull() = parser {
   let! _ = "null"
   return JSNull
}

let justAn (pattern:string) (k:unit -> _) () = parser {
   let! _ = pattern
   return! k
}

let followedBy (pattern:string) (k:'a -> unit -> _) (f:unit -> _) () = parser {
   let! x = f
   let! _ = pattern
   return! k x
}

let listOf (startSymbol:string) f endSymbol () =
   let rec listOf (xs:_ list) (f:unit -> _) () = 
      parser {
         return! [
            f |> followedBy "," (fun x -> listOf (x::xs) f)
            f |> followedBy endSymbol (fun x () -> parser { return x::xs })
            justAn endSymbol (fun () -> parser { return xs })
         ]
      }
   parser {
      let! _ = startSymbol
      return! listOf List.empty f
   }

let jsArray f () = parser {
   let! xs = listOf "\[" f "\]"
   return JSArray xs
}

let jsAssign (varValue:unit -> _) () = parser {
   let! name = "\"[^\"]*\""
   let! _ = "\:"
   let! value = varValue
   return name, value
}

let jsObj f () = parser {
   let! assignments = listOf "\{" (jsAssign f) "\}"
   return assignments |> Map.ofList |> JSObject
}

let rec json () = parser {
   return! [
      jsObj json
      jsArray json
      jsNumber
      jsString
      jsBool
      jsNull
   ]
}

// Example
let exampleJson = @"
{  ""name"": ""Zach"",
   ""age"": 24,
   ""isMale"": true,
   ""bosses"": [
      { ""name"": ""Phil"" },
      { ""name"": ""Mark"" }
   ]
}"

printfn "%A" (json().Parse exampleJson)

open System.Text.RegularExpressions
open System

type text = string
type error = string

[<AutoOpen>]
module String =
   let isEmpty(str:string) =
      str.Trim().Length = 0

   let (|Empty|_|) str =
      if isEmpty str then Some()
      else None

type 'a Parser =
   | Parser of (text -> error ref -> ('a * text) option)
   member x.Evaluate(text, error) =
      let (Parser f) = x
      f text error
   member x.Parse text =
      let error = ref ""
      match x.Evaluate(text, error) with
      | Some (y, Empty) -> y
      | Some _ | None ->
         failwith !error

type ParserBuilder() =
   let parse patterns text =
      let pattern =
         patterns |> Seq.map (sprintf "(%s)")
         |> String.concat ""
      let regex = Regex (sprintf "^\s*%s" pattern, RegexOptions.Singleline)
      let matchAttempt = regex.Match text
      let groups =
         [ for group in matchAttempt.Groups -> group.Value ]
      match groups with
      | [] -> []
      | x::xs -> xs

   let parsePattern pattern (f:string -> 'a Parser) text error =
      match text |> parse [pattern; ".*"] with
      | [value; rest] ->
         let g = f value
         g.Evaluate(rest, error)
      | _ ->
         error := sprintf "Expected '%s' but found '%s'" pattern text
         None
         
   let parseInfix (left:unit -> 'a Parser) op (right:unit -> 'b Parser) (f:('a*string*'b) -> 'c Parser) text error =
      match text |> parse [".*"; op; ".*"] with
      | [x; op; y] ->
         match left().Evaluate(x, error) with
         | Some(x, Empty) ->
            match right().Evaluate(y, error) with
            | Some(y, rest) ->
               f(x, op, y).Evaluate(rest, error)
            | None ->
               error := sprintf "Expected expression but found '%s'" y
               None
         | Some _ | None ->
            error := sprintf "Expected expression but found '%s'" x
            None
      | _ ->
         error := sprintf "Expected '<x> %s <y>' but found '%s'" op text
         None

   let parseAny (parsers:(unit -> 'a Parser) list) (f: 'a -> 'b Parser) text error =
      parsers |> Seq.tryPick (fun parser ->
         match parser().Evaluate(text, error) with
         | Some(x, rest) ->
            let g = f x
            g.Evaluate(rest, error)
         | None -> None
      )

   member b.Bind (parsers, f) =
      Parser(parseAny parsers f)
   member b.Bind ((left, op, right), f) =
      Parser(parseInfix left op right f)
   member b.Bind (parser, f) =
      b.Bind([parser], f)
   member b.Bind (pattern:string, f) =
      Parser(parsePattern pattern f)
   member b.Return x =
      Parser(fun text error -> Some(x, text))
   member b.ReturnFrom(parsers:_ list) =
      b.Bind(parsers, b.Return)
   member b.ReturnFrom(parser:unit -> _ Parser) =
      b.Bind(parser, b.Return)

let parser = ParserBuilder()

type expr =
  | JSObject of Map<string,expr>
  | JSNumber of float
  | JSString of string
  | JSArray of expr list
  | JSBool of bool
  | JSNull

Full name: Script.expr

union case expr.JSObject: Map<string,expr> -> expr

Multiple items
module Map

from Microsoft.FSharp.Collections

--------------------
type Map<'Key,'Value (requires comparison)> =
  interface IEnumerable
  interface IComparable
  interface IEnumerable<KeyValuePair<'Key,'Value>>
  interface ICollection<KeyValuePair<'Key,'Value>>
  interface IDictionary<'Key,'Value>
  new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>
  member Add : key:'Key * value:'Value -> Map<'Key,'Value>
  member ContainsKey : key:'Key -> bool
  override Equals : obj -> bool
  member Remove : key:'Key -> Map<'Key,'Value>
  ...

Full name: Microsoft.FSharp.Collections.Map<_,_>

--------------------
new : elements:seq<'Key * 'Value> -> Map<'Key,'Value>

Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = String

Full name: Microsoft.FSharp.Core.string

union case expr.JSNumber: float -> expr

Multiple items
val float : value:'T -> float (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.float

--------------------
type float = Double

Full name: Microsoft.FSharp.Core.float

--------------------
type float<'Measure> = float

Full name: Microsoft.FSharp.Core.float<_>

union case expr.JSString: string -> expr

union case expr.JSArray: expr list -> expr

type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>

union case expr.JSBool: bool -> expr

type bool = Boolean

Full name: Microsoft.FSharp.Core.bool

union case expr.JSNull: expr

val jsBool : unit -> expr Parser

Full name: Script.jsBool

val parser : ParserBuilder

Full name: Script.parser

val b : string

type Boolean =
  struct
    member CompareTo : obj:obj -> int + 1 overload
    member Equals : obj:obj -> bool + 1 overload
    member GetHashCode : unit -> int
    member GetTypeCode : unit -> TypeCode
    member ToString : unit -> string + 1 overload
    static val TrueString : string
    static val FalseString : string
    static member Parse : value:string -> bool
    static member TryParse : value:string * result:bool -> bool
  end

Full name: System.Boolean

Boolean.Parse(value: string) : bool

val jsNumber : unit -> expr Parser

Full name: Script.jsNumber

val n : string

type Double =
  struct
    member CompareTo : value:obj -> int + 1 overload
    member Equals : obj:obj -> bool + 1 overload
    member GetHashCode : unit -> int
    member GetTypeCode : unit -> TypeCode
    member ToString : unit -> string + 3 overloads
    static val MinValue : float
    static val MaxValue : float
    static val Epsilon : float
    static val NegativeInfinity : float
    static val PositiveInfinity : float
    ...
  end

Full name: System.Double

Double.Parse(s: string) : float
Double.Parse(s: string, provider: IFormatProvider) : float
Double.Parse(s: string, style: Globalization.NumberStyles) : float
Double.Parse(s: string, style: Globalization.NumberStyles, provider: IFormatProvider) : float

val jsString : unit -> expr Parser

Full name: Script.jsString

val str : string

val jsNull : unit -> expr Parser

Full name: Script.jsNull

val justAn : pattern:string -> k:(unit -> 'a Parser) -> unit -> 'a Parser

Full name: Script.justAn

val pattern : string

val k : (unit -> 'a Parser)

type unit = Unit

Full name: Microsoft.FSharp.Core.unit

val followedBy : pattern:string -> k:('a -> unit -> 'a0 Parser) -> f:(unit -> 'a Parser) -> unit -> 'a0 Parser

Full name: Script.followedBy

val k : ('a -> unit -> 'a0 Parser)

val f : (unit -> 'a Parser)

val x : 'a

val listOf : startSymbol:string -> f:(unit -> 'a Parser) -> endSymbol:string -> unit -> 'a list Parser

Full name: Script.listOf

val startSymbol : string

val endSymbol : string

val listOf : ('b list -> (unit -> 'b Parser) -> unit -> 'b list Parser)

val xs : 'b list

val f : (unit -> 'b Parser)

val x : 'b

Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>

val empty<'T> : 'T list

Full name: Microsoft.FSharp.Collections.List.empty

val jsArray : f:(unit -> expr Parser) -> unit -> expr Parser

Full name: Script.jsArray

val f : (unit -> expr Parser)

val xs : expr list

val jsAssign : varValue:(unit -> 'a Parser) -> unit -> (string * 'a) Parser

Full name: Script.jsAssign

val varValue : (unit -> 'a Parser)

val name : string

val value : 'a

val jsObj : f:(unit -> expr Parser) -> unit -> expr Parser

Full name: Script.jsObj

val assignments : (string * expr) list

val ofList : elements:('Key * 'T) list -> Map<'Key,'T> (requires comparison)

Full name: Microsoft.FSharp.Collections.Map.ofList

val json : unit -> expr Parser

Full name: Script.json

val exampleJson : string

Full name: Script.exampleJson

val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn