-
Notifications
You must be signed in to change notification settings - Fork 73
/
parser.ml
173 lines (146 loc) · 5.41 KB
/
parser.ml
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
167
168
169
170
171
172
173
module State = struct
type 'a t =
| Partial of 'a partial
| Lazy of 'a t Lazy.t
| Done of int * 'a
| Fail of int * string list * string
and 'a partial =
{ committed : int
; continue : Bigstringaf.t -> off:int -> len:int -> More.t -> 'a t }
end
type 'a with_state = Input.t -> int -> More.t -> 'a
type 'a failure = (string list -> string -> 'a State.t) with_state
type ('a, 'r) success = ('a -> 'r State.t) with_state
type 'a t =
{ run : 'r. ('r failure -> ('a, 'r) success -> 'r State.t) with_state }
let fail_k input pos _ marks msg =
State.Fail(pos - Input.client_committed_bytes input, marks, msg)
let succeed_k input pos _ v =
State.Done(pos - Input.client_committed_bytes input, v)
let rec to_exported_state = function
| State.Partial {committed;continue} ->
Exported_state.Partial
{ committed
; continue =
fun bs ~off ~len more ->
to_exported_state (continue bs ~off ~len more)}
| State.Done (i,x) -> Exported_state.Done (i,x)
| State.Fail (i, sl, s) -> Exported_state.Fail (i, sl, s)
| State.Lazy x -> to_exported_state (Lazy.force x)
let parse p =
let input = Input.create Bigstringaf.empty ~committed_bytes:0 ~off:0 ~len:0 in
to_exported_state (p.run input 0 Incomplete fail_k succeed_k)
let parse_bigstring p input =
let input = Input.create input ~committed_bytes:0 ~off:0 ~len:(Bigstringaf.length input) in
Exported_state.state_to_result (to_exported_state (p.run input 0 Complete fail_k succeed_k))
module Monad = struct
let return v =
{ run = fun input pos more _fail succ ->
succ input pos more v
}
let fail msg =
{ run = fun input pos more fail _succ ->
fail input pos more [] msg
}
let (>>=) p f =
{ run = fun input pos more fail succ ->
let succ' input' pos' more' v = (f v).run input' pos' more' fail succ in
p.run input pos more fail succ'
}
let (>>|) p f =
{ run = fun input pos more fail succ ->
let succ' input' pos' more' v = succ input' pos' more' (f v) in
p.run input pos more fail succ'
}
let (<$>) f m =
m >>| f
let (<*>) f m =
(* f >>= fun f -> m >>| f *)
{ run = fun input pos more fail succ ->
let succ0 input0 pos0 more0 f =
let succ1 input1 pos1 more1 m = succ input1 pos1 more1 (f m) in
m.run input0 pos0 more0 fail succ1
in
f.run input pos more fail succ0 }
let lift f m =
f <$> m
let lift2 f m1 m2 =
{ run = fun input pos more fail succ ->
let succ1 input1 pos1 more1 m1 =
let succ2 input2 pos2 more2 m2 = succ input2 pos2 more2 (f m1 m2) in
m2.run input1 pos1 more1 fail succ2
in
m1.run input pos more fail succ1 }
let lift3 f m1 m2 m3 =
{ run = fun input pos more fail succ ->
let succ1 input1 pos1 more1 m1 =
let succ2 input2 pos2 more2 m2 =
let succ3 input3 pos3 more3 m3 =
succ input3 pos3 more3 (f m1 m2 m3) in
m3.run input2 pos2 more2 fail succ3 in
m2.run input1 pos1 more1 fail succ2
in
m1.run input pos more fail succ1 }
let lift4 f m1 m2 m3 m4 =
{ run = fun input pos more fail succ ->
let succ1 input1 pos1 more1 m1 =
let succ2 input2 pos2 more2 m2 =
let succ3 input3 pos3 more3 m3 =
let succ4 input4 pos4 more4 m4 =
succ input4 pos4 more4 (f m1 m2 m3 m4) in
m4.run input3 pos3 more3 fail succ4 in
m3.run input2 pos2 more2 fail succ3 in
m2.run input1 pos1 more1 fail succ2
in
m1.run input pos more fail succ1 }
let ( *>) a b =
(* a >>= fun _ -> b *)
{ run = fun input pos more fail succ ->
let succ' input' pos' more' _ = b.run input' pos' more' fail succ in
a.run input pos more fail succ'
}
let (<* ) a b =
(* a >>= fun x -> b >>| fun _ -> x *)
{ run = fun input pos more fail succ ->
let succ0 input0 pos0 more0 x =
let succ1 input1 pos1 more1 _ = succ input1 pos1 more1 x in
b.run input0 pos0 more0 fail succ1
in
a.run input pos more fail succ0 }
end
module Choice = struct
let (<?>) p mark =
{ run = fun input pos more fail succ ->
let fail' input' pos' more' marks msg =
fail input' pos' more' (mark::marks) msg in
p.run input pos more fail' succ
}
let (<|>) p q =
{ run = fun input pos more fail succ ->
let fail' input' pos' more' marks msg =
(* The only two constructors that introduce new failure continuations are
* [<?>] and [<|>]. If the initial input position is less than the length
* of the committed input, then calling the failure continuation will
* have the effect of unwinding all choices and collecting marks along
* the way. *)
if pos < Input.parser_committed_bytes input' then
fail input' pos' more marks msg
else
q.run input' pos more' fail succ in
p.run input pos more fail' succ
}
end
module Monad_use_for_debugging = struct
let return = Monad.return
let fail = Monad.fail
let (>>=) = Monad.(>>=)
let (>>|) m f = m >>= fun x -> return (f x)
let (<$>) f m = m >>| f
let (<*>) f m = f >>= fun f -> m >>| f
let lift = (>>|)
let lift2 f m1 m2 = f <$> m1 <*> m2
let lift3 f m1 m2 m3 = f <$> m1 <*> m2 <*> m3
let lift4 f m1 m2 m3 m4 = f <$> m1 <*> m2 <*> m3 <*> m4
let ( *>) a b = a >>= fun _ -> b
let (<* ) a b = a >>= fun x -> b >>| fun _ -> x
end