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
type 'a t =
| Return : 'a -> 'a t
| Empty : unit t
| Match : string -> string t
| Apply : ('a -> 'b) t * 'a t -> 'b t
| SkipLeft : 'a t * 'b t -> 'b t
| SkipRight : 'a t * 'b t -> 'a t
| Choice : 'a t list -> 'a t
| Int : int t
| Int32 : int32 t
| Int64 : int64 t
| Bool : bool t
| Str : string t
let return x = Return x
let apply f t = Apply (f, t)
let s x = Match x
let int = Int
let int32 = Int32
let int64 = Int64
let bool = Bool
let str = Str
let empty = Empty
let verify f params =
match params with
| [] -> None
| p :: ps ->
(match f p with
| None -> None
| Some r -> Some (r, ps))
;;
let bool_of_string = function
| "true" -> Some true
| "false" -> Some false
| _ -> None
;;
let rec parse : type a. a t -> string list -> (a * string list) option =
fun t params ->
match t with
| Return x -> Some (x, params)
| Empty ->
(match params with
| [] -> Some ((), params)
| _ -> None)
| Match s -> verify (fun w -> if String.compare w s = 0 then Some w else None) params
| Int -> verify int_of_string_opt params
| Int32 -> verify Int32.of_string_opt params
| Int64 -> verify Int64.of_string_opt params
| Bool -> verify bool_of_string params
| Str -> verify (fun w -> Some w) params
| Apply (f, t) ->
(match parse f params with
| None -> None
| Some (f, params) ->
(match parse t params with
| None -> None
| Some (t, params) -> Some (f t, params)))
| SkipLeft (a, b) ->
(match parse a params with
| None -> None
| Some (_, rest) -> parse b rest)
| SkipRight (a, b) ->
(match parse a params with
| None -> None
| Some (a', rest) ->
(match parse b rest with
| None -> None
| Some (_, rest) -> Some (a', rest)))
| Choice ps ->
(match ps with
| [] -> None
| p :: ps ->
(match parse p params with
| None -> parse (Choice ps) params
| res -> res))
;;
let choice ps = Choice ps
module Infix = struct
let ( <*> ) = apply
let ( </> ) = apply
let ( <$> ) f p = Apply (Return f, p)
let ( *> ) x y = SkipLeft (x, y)
let ( <* ) x y = SkipRight (x, y)
let ( <$ ) f t = SkipRight (Return f, t)
let ( <|> ) p1 p2 = choice [ p1; p2 ]
end