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
module type S =
sig
type 'a t
val ( <$> ): ('a, 'b) Bijection.texn -> 'a t -> 'b t
val ( <*> ): 'a t -> 'b t -> ('a * 'b) t
val ( <|> ): 'a t -> 'a t -> 'a t
val ( *> ): unit t -> 'a t -> 'a t
val ( <* ): 'a t -> unit t -> 'a t
val ( $> ): unit t -> (unit, 'a) Bijection.texn -> 'a t
val ( <$ ): 'a t -> (unit, 'a) Bijection.texn -> unit t
val fix: ('a t -> 'a t) -> 'a t
val nop: unit t
val any: char t
val fail: string -> 'a t
val pure: compare:('a -> 'a -> int) -> 'a -> 'a t
val take: int -> string t
val peek: 'a t -> 'b t -> ('a, 'b) Either.t t
val const: string -> string t
val commit: unit t
val while0: (char -> bool) -> string t
val while1: (char -> bool) -> string t
val bigstring_while0: (char -> bool) -> Encoder.bigstring t
val bigstring_while1: (char -> bool) -> Encoder.bigstring t
val buffer: string t
val bigstring_buffer: Encoder.bigstring t
module Option:
sig
val (<$>) : ('a, 'b) Bijection.topt -> 'a t -> 'b t
val ( $>) : unit t -> (unit, 'a) Bijection.topt -> 'a t
val (<$ ) : 'a t -> (unit, 'a) Bijection.topt -> unit t
end
end
module type T =
sig
include S
val sequence: 'a t list -> 'a list t
val choice: 'a t list -> 'a t
val option: 'a t -> 'a option t
val between: unit t -> unit t -> 'a t -> 'a t
val count: int -> 'a t -> 'a list t
val rep0: 'a t -> 'a list t
val rep1: 'a t -> 'a list t
val sep_by0: sep:unit t -> 'a t -> 'a list t
val sep_by1: sep:unit t -> 'a t -> 'a list t
val end_by0: sep:unit t -> 'a t -> 'a list t
val end_by1: sep:unit t -> 'a t -> 'a list t
val lower: char t
val upper: char t
val alpha: char t
val digit: char t
end
module Make (S: S): T with type 'a t = 'a S.t =
struct
include S
open Bijection
let pure_nil () =
let compare a b = match a, b with
| [], [] -> 0
| (_ :: _ | []), (_ :: _ | []) -> 1 in
pure ~compare []
let pure_none () =
let compare a b = match a, b with
| None, None -> 0
| (Some _ | None), (Some _ | None) -> 1 in
pure ~compare None
let sequence ps =
List.fold_right (fun hd tl -> Exn.cons ~tag:"" <$> (hd <*> tl)) ps (pure_nil ())
let choice ps =
List.fold_right (<|>) ps (fail "choice")
let option p =
(Exn.some ~tag:"" <$> p) <|> (pure_none ())
let count n p =
let rec make acc = function
| 0 -> acc
| n -> make (p :: acc) (n - 1) in
sequence (make [] n)
let rep1 p =
let pure_nil = pure_nil () in
fix @@ fun m -> Exn.cons ~tag:"" <$> (p <*> (m <|> pure_nil))
let rep0 p =
rep1 p <|> (pure_nil ())
let sep_by1 ~sep p =
Exn.cons ~tag:"" <$> (p <*> rep0 (sep *> p))
let sep_by0 ~sep p =
sep_by1 ~sep p <|> (pure_nil ())
let end_by1 ~sep p =
rep1 (p <* sep)
let end_by0 ~sep p =
rep0 (p <* sep)
let between x y v =
x *> v <* y
let is_lower = function 'a' .. 'z' -> true | _ -> false
let is_upper = function 'A' .. 'Z' -> true | _ -> false
let is_digit = function '0' .. '9' -> true | _ -> false
let is_alpha = function 'a'.. 'z' | 'A' .. 'Z' -> true | _ -> false
let lower = Exn.subset is_lower <$> any
let upper = Exn.subset is_upper <$> any
let digit = Exn.subset is_digit <$> any
let alpha = Exn.subset is_alpha <$> any
end