4 people like it.

Generic Parser Generator for F# values

Generic Parser Generator for F# values using TypeShape and FParsec. Supports recursive types.

Implementation

  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: 
 96: 
 97: 
 98: 
 99: 
100: 
101: 
102: 
103: 
104: 
105: 
106: 
107: 
108: 
109: 
110: 
111: 
112: 
113: 
114: 
115: 
116: 
117: 
118: 
119: 
120: 
121: 
122: 
123: 
124: 
125: 
126: 
127: 
128: 
129: 
130: 
131: 
132: 
133: 
open System
open FParsec
open TypeShape
open TypeShape_Utils

type Parser<'T> = Parser<'T, unit>

let inline delay (f : unit -> 'T) : Parser<'T> =
    fun _ -> Reply(f())

let spaced p = between spaces spaces p

let (<*>) (f : Parser<'T -> 'S>) (t : Parser<'T>) : Parser<'S> = 
    parse {
        let! tv = t
        let! fv = f
        return fv tv
    }

/// Generates a parser for supplied type
let rec genParser<'T> () : Parser<'T> =
    match cache.TryFind<Parser<'T>> () with
    | Some p -> p
    | None ->
        // create a delayed uninitialized instance for recursive type definitions
        let _ = cache.CreateUninitialized<Parser<'T>>(fun c s -> c.Value s)
        let p = genParserAux<'T> ()
        cache.Commit (spaced p)
    
and genParserAux<'T> () : Parser<'T> =
    let token str = spaced (pstring str) >>% ()
    let paren p = between (pchar '(') (pchar ')') (spaced p)
    let wrap (p : Parser<'a>) = unbox<Parser<'T>>(spaced p)

    let mkMemberParser (shape : IShapeWriteMember<'Class>) =
        shape.Accept { new IWriteMemberVisitor<'Class, Parser<'Class -> 'Class>> with
            member __.Visit (shape : ShapeWriteMember<'Class, 'Field>) =
                let fp = genParser<'Field>()
                fp |>> fun f dt -> shape.Inject dt f
        }

    let combineMemberParsers 
        (init : Parser<'Class>)
        (injectors : Parser<'Class -> 'Class> [])
        (separator : Parser<'Sep>) =

        match Array.toList injectors with
        | [] -> init
        | hd :: tl -> List.fold (fun acc i -> (separator >>. i) <*> acc) (hd <*> init) tl

    match shapeof<'T> with
    | Shape.Unit -> wrap(paren spaces)
    | Shape.Bool -> wrap(stringReturn "true" true <|> stringReturn "false" false)
    | Shape.Byte -> wrap(puint8)
    | Shape.Int32 -> wrap(pint32)
    | Shape.Int64 -> wrap(pint64)
    | Shape.String -> wrap(between (pchar '\"') (pchar '\"') (manySatisfy ((<>) '\"')))
    | Shape.FSharpOption s ->
        s.Accept {
            new IFSharpOptionVisitor<Parser<'T>> with
                member __.Visit<'t> () =
                    let tp = genParser<'t>() |>> Some
                    let nP = stringReturn "None" None
                    let vp = attempt (paren tp) <|> tp
                    let sP = token "Some" >>. vp
                    wrap(nP <|> sP)
        }

    | Shape.FSharpList s ->
        s.Accept {
            new IFSharpListVisitor<Parser<'T>> with
                member __.Visit<'t> () =
                    let tp = genParser<'t>()
                    let sep = pchar ';'
                    let lp = between (pchar '[') (pchar ']') (sepBy tp sep)
                    wrap lp
        }

    | Shape.Array s when s.Rank = 1 ->
        s.Accept {
            new IArrayVisitor<Parser<'T>> with
                member __.Visit<'t> _ =
                    let tp = genParser<'t> ()
                    let sep = pchar ';'
                    let lp = between (pstring "[|") (pstring "|]") (sepBy tp sep)
                    wrap(lp |>> Array.ofList)
        }

    | Shape.Tuple (:? ShapeTuple<'T> as shape) ->
        let init = delay shape.CreateUninitialized
        let eps = shape.Elements |> Array.map mkMemberParser
        let composed = combineMemberParsers init eps (pchar ',')
        paren composed

    | Shape.FSharpRecord (:? ShapeFSharpRecord<'T> as shape) ->
        let init = delay shape.CreateUninitialized
        let fps = 
            shape.Fields 
            |> Array.map (fun f -> token f.Label >>. pchar '=' >>. mkMemberParser f)

        let composed = combineMemberParsers init fps (pchar ';')
        between (pchar '{') (pchar '}') composed

    | Shape.FSharpUnion (:? ShapeFSharpUnion<'T> as shape) ->
        let mkUnionCaseParser (case : ShapeFSharpUnionCase<'T>) =
            let caseName = pstring case.CaseInfo.Name
            let init = delay case.CreateUninitialized
            match case.Fields |> Array.map mkMemberParser with
            | [||] -> caseName >>. init
            | fps ->
                let composed = combineMemberParsers init fps (pchar ',')
                let valueP = 
                    if fps.Length = 1 then paren composed <|> composed
                    else paren composed

                caseName >>. spaces >>. valueP

        shape.UnionCases
        |> Array.map mkUnionCaseParser
        |> choice

    | _ -> failwithf "unsupported type '%O'" typeof<'T>
 
and private cache : TypeCache = new TypeCache()


/// Generates a string parser for given type
let mkParser<'T> () : string -> 'T = 
    let fp = genParser<'T>() .>> eof
    fun inp -> 
        match run fp inp with
        | Success(r,_,_) -> r
        | Failure(msg,_,_) -> failwithf "Parse error: %s" msg

Examples

 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: 
let p1 = mkParser<int * int list>()
p1 "(42, [1;2;3])"

let p2 = mkParser<int * string list option * string ref>()
p2 """(42, Some (["1" ;  "2"]), { contents= "value" } ) """

type Foo = { A : int ; B : string }

type Bar =
    | Foo of Foo
    | Bar of int
    | C
    | D of string option

let p3 = mkParser<Bar list []>()

p3 """ [| [ Bar 42 ; Bar(42) ; Foo { A = 12 ; B = "Foo" } ; C ] ; [] ; [D (Some "42")]|] """

// Recursive type parsing

type BinTree<'T> = Leaf | Node of 'T * BinTree<'T> * BinTree<'T>

let p4 = mkParser<BinTree<int>> ()

p4 "Node(3, Node(1, Leaf, Node(2, Leaf,Leaf)), Leaf)"
namespace System
namespace FParsec
module TypeShape
module TypeShape_Utils
Multiple items
type Parser<'T> = Parser<'T,unit>

Full name: Script.Parser<_>

--------------------
type Parser<'Result,'UserState> = CharStream<'UserState> -> Reply<'Result>

Full name: FParsec.Primitives.Parser<_,_>
type unit = Unit

Full name: Microsoft.FSharp.Core.unit
val delay : f:(unit -> 'T) -> CharStream<unit> -> Reply<'T>

Full name: Script.delay
val f : (unit -> 'T)
Multiple items
type Reply<'TResult> =
  struct
    new : result:'TResult -> Reply<'TResult> + 2 overloads
    val Error : ErrorMessageList
    val Result : 'TResult
    val Status : ReplyStatus
    member Equals : other:obj -> bool + 1 overload
    member GetHashCode : unit -> int
  end

Full name: FParsec.Reply<_>

--------------------
Reply()
Reply(result: 'TResult) : unit
Reply(status: ReplyStatus, error: ErrorMessageList) : unit
Reply(status: ReplyStatus, result: 'TResult, error: ErrorMessageList) : unit
val spaced : p:Parser<'a,'b> -> Parser<'a,'b>

Full name: Script.spaced
val p : Parser<'a,'b>
val between : Parser<'a,'u> -> Parser<'b,'u> -> Parser<'c,'u> -> Parser<'c,'u>

Full name: FParsec.Primitives.between
val spaces : Parser<unit,'u>

Full name: FParsec.CharParsers.spaces
val f : Parser<('T -> 'S)>
val t : Parser<'T>
val parse : ParserCombinator

Full name: FParsec.Primitives.parse
val tv : 'T
val fv : ('T -> 'S)
val genParser : unit -> Parser<'T>

Full name: Script.genParser


 Generates a parser for supplied type
val private cache : TypeCache

Full name: Script.cache
member TypeCache.TryFind : unit -> 'T option
union case Option.Some: Value: 'T -> Option<'T>
val p : Parser<'T>
union case Option.None: Option<'T>
member TypeCache.CreateUninitialized : delay:(Cell<'T> -> 'T) -> 'T
val c : Cell<Parser<'T>>
val s : CharStream<unit>
property Cell.Value: Parser<'T>
val genParserAux : unit -> Parser<'T>

Full name: Script.genParserAux
member TypeCache.Commit : value:'T -> 'T
val token : (string -> Parser<unit,'a>)
val str : string
val pstring : string -> Parser<string,'u>

Full name: FParsec.CharParsers.pstring
val paren : (Parser<'a,'b> -> Parser<'a,'b>)
val pchar : char -> Parser<char,'u>

Full name: FParsec.CharParsers.pchar
val wrap : (Parser<'a> -> CharStream<unit> -> Reply<'T>)
val p : Parser<'a>
val unbox : value:obj -> 'T

Full name: Microsoft.FSharp.Core.Operators.unbox
val mkMemberParser : (IShapeWriteMember<'Class> -> Parser<('Class -> 'Class)>)
val shape : IShapeWriteMember<'Class>
type IShapeWriteMember<'Record> =
  interface
    inherit IShapeMember<'Record>
    abstract member Accept : IWriteMemberVisitor<'Record,'R> -> 'R
  end

Full name: TypeShape.IShapeWriteMember<_>
Multiple items
type ClassAttribute =
  inherit Attribute
  new : unit -> ClassAttribute

Full name: Microsoft.FSharp.Core.ClassAttribute

--------------------
new : unit -> ClassAttribute
abstract member IShapeMember.Accept : IMemberVisitor<'DeclaringType,'R> -> 'R
abstract member IShapeWriteMember.Accept : IWriteMemberVisitor<'Record,'R> -> 'R
type IWriteMemberVisitor<'TRecord,'R> =
  interface
    abstract member Visit : ShapeWriteMember<'TRecord,'Field> -> 'R
  end

Full name: TypeShape.IWriteMemberVisitor<_,_>
val shape : ShapeWriteMember<'Class,'a>
type ShapeWriteMember<'DeclaringType,'MemberType> =
  interface IShapeWriteMember<'DeclaringType>
  interface IShapeMember<'DeclaringType>
  private new : label:string * memberInfo:MemberInfo * path:MemberInfo [] * readOnly:ShapeMember<'DeclaringType,'MemberType> -> ShapeWriteMember<'DeclaringType,'MemberType>
  member Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
  member InjectExpr : instance:Expr<'DeclaringType> -> field:Expr<'MemberType> -> Expr<'DeclaringType>
  member Project : instance:'DeclaringType -> 'MemberType
  member ProjectExpr : instance:Expr<'DeclaringType> -> Expr<'MemberType>
  member IsPublic : bool
  member IsStructMember : bool
  member Label : string
  ...

Full name: TypeShape.ShapeWriteMember<_,_>
val fp : Parser<'a>
val f : 'a
val dt : 'Class
member ShapeWriteMember.Inject : instance:'DeclaringType -> field:'MemberType -> 'DeclaringType
val combineMemberParsers : (Parser<'Class> -> Parser<('Class -> 'Class)> [] -> Parser<'Sep> -> Parser<'Class>)
val init : Parser<'Class>
val injectors : Parser<('Class -> 'Class)> []
val separator : Parser<'Sep>
Multiple items
union case TypeShapeInfo.Array: element: Type * rank: int -> TypeShapeInfo

--------------------
type Array =
  member Clone : unit -> obj
  member CopyTo : array:Array * index:int -> unit + 1 overload
  member GetEnumerator : unit -> IEnumerator
  member GetLength : dimension:int -> int
  member GetLongLength : dimension:int -> int64
  member GetLowerBound : dimension:int -> int
  member GetUpperBound : dimension:int -> int
  member GetValue : [<ParamArray>] indices:int[] -> obj + 7 overloads
  member Initialize : unit -> unit
  member IsFixedSize : bool
  ...

Full name: System.Array
val toList : array:'T [] -> 'T list

Full name: Microsoft.FSharp.Collections.Array.toList
val hd : Parser<('Class -> 'Class)>
val tl : Parser<('Class -> 'Class)> list
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member GetSlice : startIndex:int option * endIndex:int option -> 'T list
  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 fold : folder:('State -> 'T -> 'State) -> state:'State -> list:'T list -> 'State

Full name: Microsoft.FSharp.Collections.List.fold
val acc : Parser<'Class>
val i : Parser<('Class -> 'Class),unit>
val shapeof<'T> : TypeShape<'T>

Full name: TypeShape.shapeof
module Shape

from TypeShape
active recognizer Unit: TypeShape -> unit option

Full name: TypeShape.Shape.( |Unit|_| )
active recognizer Bool: TypeShape -> unit option

Full name: TypeShape.Shape.( |Bool|_| )
val stringReturn : string -> 'a -> Parser<'a,'u>

Full name: FParsec.CharParsers.stringReturn
active recognizer Byte: TypeShape -> unit option

Full name: TypeShape.Shape.( |Byte|_| )
val puint8 : Parser<uint8,'u>

Full name: FParsec.CharParsers.puint8
active recognizer Int32: TypeShape -> unit option

Full name: TypeShape.Shape.( |Int32|_| )
val pint32 : Parser<int32,'u>

Full name: FParsec.CharParsers.pint32
active recognizer Int64: TypeShape -> unit option

Full name: TypeShape.Shape.( |Int64|_| )
val pint64 : Parser<int64,'u>

Full name: FParsec.CharParsers.pint64
active recognizer String: TypeShape -> unit option

Full name: TypeShape.Shape.( |String|_| )
val manySatisfy : (char -> bool) -> Parser<string,'u>

Full name: FParsec.CharParsers.manySatisfy
active recognizer FSharpOption: TypeShape -> IShapeFSharpOption option

Full name: TypeShape.Shape.( |FSharpOption|_| )
val s : IShapeFSharpOption
abstract member IShapeFSharpOption.Accept : IFSharpOptionVisitor<'R> -> 'R
type IFSharpOptionVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.IFSharpOptionVisitor<_>
val tp : Parser<'t option,unit>
val nP : Parser<'t option,unit>
val vp : Parser<'t option,unit>
val attempt : Parser<'a,'u> -> Parser<'a,'u>

Full name: FParsec.Primitives.attempt
val sP : Parser<'t option,unit>
active recognizer FSharpList: TypeShape -> IShapeFSharpList option

Full name: TypeShape.Shape.( |FSharpList|_| )
val s : IShapeFSharpList
abstract member IShapeFSharpList.Accept : IFSharpListVisitor<'R> -> 'R
type IFSharpListVisitor<'R> =
  interface
    abstract member Visit : unit -> 'R
  end

Full name: TypeShape.IFSharpListVisitor<_>
val tp : Parser<'t>
val sep : Parser<char,unit>
val lp : Parser<'t list,unit>
val sepBy : Parser<'a,'u> -> Parser<'b,'u> -> Parser<'a list,'u>

Full name: FParsec.Primitives.sepBy
active recognizer Array: TypeShape -> IShapeArray option

Full name: TypeShape.Shape.( |Array|_| )
val s : IShapeArray
property IShapeArray.Rank: int
abstract member IShapeArray.Accept : IArrayVisitor<'R> -> 'R
type IArrayVisitor<'R> =
  interface
    abstract member Visit : rank:int -> 'R
  end

Full name: TypeShape.IArrayVisitor<_>
val ofList : list:'T list -> 'T []

Full name: Microsoft.FSharp.Collections.Array.ofList
active recognizer Tuple: TypeShape -> IShapeTuple option

Full name: TypeShape.Shape.( |Tuple|_| )
type ShapeTuple<'Tuple> =
  interface IShapeTuple
  private new : unit -> ShapeTuple<'Tuple>
  member CreateUninitialized : unit -> 'Tuple
  member CreateUninitializedExpr : unit -> Expr<'Tuple>
  member Elements : IShapeWriteMember<'Tuple> []

Full name: TypeShape.ShapeTuple<_>
val shape : ShapeTuple<'T>
val init : Parser<'T>
member ShapeTuple.CreateUninitialized : unit -> 'Tuple
val eps : (CharStream<unit> -> Reply<('T -> 'T)>) []
property ShapeTuple.Elements: IShapeWriteMember<'T> []
val map : mapping:('T -> 'U) -> array:'T [] -> 'U []

Full name: Microsoft.FSharp.Collections.Array.map
val composed : Parser<'T>
active recognizer FSharpRecord: TypeShape -> IShapeFSharpRecord option

Full name: TypeShape.Shape.( |FSharpRecord|_| )
type ShapeFSharpRecord<'Record> =
  interface IShapeFSharpRecord
  private new : unit -> ShapeFSharpRecord<'Record>
  member CreateUninitialized : unit -> 'Record
  member CreateUninitializedExpr : unit -> Expr<'Record>
  member Fields : IShapeWriteMember<'Record> []

Full name: TypeShape.ShapeFSharpRecord<_>
val shape : ShapeFSharpRecord<'T>
member ShapeFSharpRecord.CreateUninitialized : unit -> 'Record
val fps : Parser<('T -> 'T),unit> []
property ShapeFSharpRecord.Fields: IShapeWriteMember<'T> []
val f : IShapeWriteMember<'T>
property IShapeMember.Label: string
active recognizer FSharpUnion: TypeShape -> IShapeFSharpUnion option

Full name: TypeShape.Shape.( |FSharpUnion|_| )
type ShapeFSharpUnion<'U> =
  interface IShapeFSharpUnion
  private new : unit -> ShapeFSharpUnion<'U>
  member GetTag : caseName:string -> int
  member GetTag : union:'U -> int
  member GetTagExpr : union:Expr<'U> -> Expr<int>
  member UnionCases : ShapeFSharpUnionCase<'U> []

Full name: TypeShape.ShapeFSharpUnion<_>
val shape : ShapeFSharpUnion<'T>
val mkUnionCaseParser : (ShapeFSharpUnionCase<'T> -> Parser<'T,unit>)
val case : ShapeFSharpUnionCase<'T>
type ShapeFSharpUnionCase<'Union> =
  interface IShapeFSharpUnionCase
  private new : uci:UnionCaseInfo -> ShapeFSharpUnionCase<'Union>
  member CreateUninitialized : unit -> 'Union
  member CreateUninitializedExpr : unit -> Expr<'Union>
  member CaseInfo : UnionCaseInfo
  member Fields : IShapeWriteMember<'Union> []

Full name: TypeShape.ShapeFSharpUnionCase<_>
val caseName : Parser<string,unit>
property ShapeFSharpUnionCase.CaseInfo: Reflection.UnionCaseInfo
property Reflection.UnionCaseInfo.Name: string
member ShapeFSharpUnionCase.CreateUninitialized : unit -> 'Union
property ShapeFSharpUnionCase.Fields: IShapeWriteMember<'T> []
val fps : (CharStream<unit> -> Reply<('T -> 'T)>) []
val valueP : Parser<'T,unit>
property Array.Length: int
property ShapeFSharpUnion.UnionCases: ShapeFSharpUnionCase<'T> []
val choice : seq<Parser<'a,'u>> -> Parser<'a,'u>

Full name: FParsec.Primitives.choice
val failwithf : format:Printf.StringFormat<'T,'Result> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.failwithf
val typeof<'T> : Type

Full name: Microsoft.FSharp.Core.Operators.typeof
Multiple items
type TypeCache =
  new : unit -> TypeCache
  member Commit : value:'T -> 'T
  member CreateUninitialized : delay:(Cell<'T> -> 'T) -> 'T
  member TryFind : unit -> 'T option
  member TryGetValue : result:byref<'T> -> bool

Full name: TypeShape_Utils.TypeCache

--------------------
new : unit -> TypeCache
val mkParser : unit -> (string -> 'T)

Full name: Script.mkParser


 Generates a string parser for given type
Multiple items
val string : value:'T -> string

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

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

Full name: Microsoft.FSharp.Core.string
val fp : Parser<'T,unit>
val eof : Parser<unit,'u>

Full name: FParsec.CharParsers.eof
val inp : string
val run : Parser<'Result,unit> -> string -> ParserResult<'Result,unit>

Full name: FParsec.CharParsers.run
union case ParserResult.Success: 'Result * 'UserState * Position -> ParserResult<'Result,'UserState>
val r : 'T
union case ParserResult.Failure: string * ParserError * 'UserState -> ParserResult<'Result,'UserState>
val msg : string
val p1 : (string -> int * int list)

Full name: Script.p1
Multiple items
val int : value:'T -> int (requires member op_Explicit)

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

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
val p2 : (string -> int * string list option * string ref)

Full name: Script.p2
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
Multiple items
val ref : value:'T -> 'T ref

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

--------------------
type 'T ref = Ref<'T>

Full name: Microsoft.FSharp.Core.ref<_>
type Foo =
  {A: int;
   B: string;}

Full name: Script.Foo
Foo.A: int
Foo.B: string
Multiple items
union case Bar.Bar: int -> Bar

--------------------
type Bar =
  | Foo of Foo
  | Bar of int
  | C
  | D of string option

Full name: Script.Bar
Multiple items
union case Bar.Foo: Foo -> Bar

--------------------
type Foo =
  {A: int;
   B: string;}

Full name: Script.Foo
union case Bar.C: Bar
union case Bar.D: string option -> Bar
val p3 : (string -> Bar list [])

Full name: Script.p3
type BinTree<'T> =
  | Leaf
  | Node of 'T * BinTree<'T> * BinTree<'T>

Full name: Script.BinTree<_>
union case BinTree.Leaf: BinTree<'T>
union case BinTree.Node: 'T * BinTree<'T> * BinTree<'T> -> BinTree<'T>
val p4 : (string -> BinTree<int>)

Full name: Script.p4

More information

Link:http://fssnip.net/7RB
Posted:7 years ago
Author:Eirik Tsarpalis
Tags: fparsec , generic programming , typeshape