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
type 'a pattern =
{ of_string : string -> 'a option
; label : string
}
type 'a t =
| Return : 'a -> 'a t
| Empty : unit t
| Match : string -> unit t
| Capture : 'a pattern -> 'a t
| Apply : ('a -> 'b) t * 'a t -> 'b t
| SkipLeft : 'a t * 'b t -> 'b t
| SkipRight : 'a t * 'b t -> 'a t
let pattern of_string label = Capture { of_string; label }
module R = Router
module K = R.Key
let get_patterns route =
let rec aux : type a. a t -> (string * R.Key.t) list -> (string * R.Key.t) list =
fun t acc ->
match t with
| Return _ -> acc
| Empty -> acc
| Capture { label; _ } -> (label, K.PCapture) :: acc
| Match w -> (w, K.PMatch w) :: acc
| SkipLeft (l, r) ->
let l = aux l acc in
let r' = aux r [] in
List.concat [ l; r' ]
| SkipRight (l, r) ->
let l = aux l acc in
let r' = aux r [] in
List.concat [ l; r' ]
| Apply (l, r) ->
let l = aux l acc in
let r' = aux r [] in
List.concat [ l; r' ]
in
aux route []
;;
let s x = Match x
let empty = Empty
let return x = Return x
let apply f t = Apply (f, t)
module Infix = struct
let ( <*> ) f t = Apply (f, t)
let ( </> ) f t = Apply (f, t)
let ( <$> ) f p = Apply (return f, p)
let ( *> ) x y = SkipLeft (x, y)
let ( <* ) x y = SkipRight (x, y)
let ( <$ ) f t = SkipLeft (t, return f)
end
let verify f params =
match params with
| [] -> None
| p :: ps ->
(match f p with
| None -> None
| Some r -> Some (r, ps))
;;
let rec strip_route : type a. a t -> a t =
fun t ->
match t with
| SkipLeft (_, r) -> strip_route r
| SkipRight (l, _) -> strip_route l
| Apply (f, t) -> Apply (strip_route f, strip_route t)
| _ -> t
;;
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 () else None) params
| Capture { of_string; _ } -> verify of_string 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)))
;;