-
Notifications
You must be signed in to change notification settings - Fork 37
/
parser.fs
166 lines (131 loc) · 5.37 KB
/
parser.fs
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
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
module Parser
open System
open FParsec
open TypeShape.Core
open TypeShape.Core.Utils
// Generic value type parser using parser combinators
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> =
let ctx = new TypeGenerationContext()
genParserCached<'T> ctx
and private genParserCached<'T> (ctx : TypeGenerationContext) : Parser<'T> =
match ctx.InitOrGetCachedValue<Parser<'T>>(fun c s -> c.Value s) with
| Cached(value = p) -> p
| NotCached t ->
let p = genParserAux<'T> ctx
ctx.Commit t (spaced p)
and private genParserAux<'T> (ctx : TypeGenerationContext) : 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 : IShapeMember<'Class>) =
shape.Accept { new IMemberVisitor<'Class, Parser<'Class -> 'Class>> with
member _.Visit (shape : ShapeMember<'Class, 'Field>) =
let fp = genParserCached<'Field> ctx
fp |>> fun f dt -> shape.Set 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.Element.Accept {
new ITypeVisitor<Parser<'T>> with
member _.Visit<'t> () =
let tp = genParserCached<'t> ctx |>> Some
let nP = stringReturn "None" None
let vp = attempt (paren tp) <|> tp
let sP = token "Some" >>. vp
wrap(nP <|> sP)
}
| Shape.FSharpList s ->
s.Element.Accept {
new ITypeVisitor<Parser<'T>> with
member _.Visit<'t> () =
let tp = genParserCached<'t> ctx
let sep = pchar ';'
let lp = between (pchar '[') (pchar ']') (sepBy tp sep)
wrap lp
}
| Shape.Array s when s.Rank = 1 ->
s.Element.Accept {
new ITypeVisitor<Parser<'T>> with
member _.Visit<'t> () =
let tp = genParserCached<'t> ctx
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>
/// 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
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)"