rgrinberg · December 14, 2014 20:11 · Dec 14, 2014
diff --git a/type_safe_routes.ml b/type_safe_routes.ml
@@ -0,0 +1,133 @@
+open Core.Std
+
+module Substring = struct
+  include Substring
+  let get t i = (Substring.base t).[(Substring.pos t) + i]
+
+  let drop_prefix_str t ~prefix =
+    let len = String.length prefix in
+    if len > Substring.length t then None
+    else
+      try
+        for i = 0 to len - 1 do
+          if get t i <> prefix.[i] then raise_notrace Exit
+        done;
+        Some (Substring.drop_prefix t len)
+      with Exit -> None
+
+  let take_while_i t ~f =
+    let len = Substring.length t in
+    let rec loop i =
+      if i = len then i
+      else if f (get t i) then loop (i + 1)
+      else i
+    in loop 0
+
+  let take_while t ~f =
+    let i = take_while_i t ~f in
+    (i |> Substring.prefix t, Substring.drop_prefix t i)
+
+  let drop_while t ~f =
+    let drop_count = take_while_i t ~f:(Fn.compose not f) in
+    Substring.drop_prefix t drop_count
+end
+
+module type Parser_intf = sig
+  type 'a t (* parser that produces a value of type 'a *)
+  (* monadic operations *)
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  (* validate/map input with f. If f returns none then the parser fails.
+     If f return Some x then x is the result returned *)
+  val filter_map : 'a t -> f:('a -> 'b option) -> 'b t
+  (* run the parser against the string and return None if parsing fails. On
+     success Some (x, rest) where x is the result and rest is the remaining
+     string that needs to be parsed *)
+  val run : 'a t -> Substring.t -> ('a * Substring.t) option
+  (* little helpers *)
+  val drop_prefix : string -> unit t
+  val drop_while  : (char -> bool) -> unit t
+  val take_while  : (char -> bool) -> string t
+end
+
+module Parser = struct
+  type 'a t = Substring.t -> ('a * Substring.t) option
+
+  let drop_while f t = Some ((), Substring.drop_while t ~f)
+
+  let drop_prefix prefix t =
+    Substring.drop_prefix_str t ~prefix |> Option.map ~f:(fun s -> ((), s))
+
+  let take_while f t =
+    t
+    |> Substring.take_while ~f
+    |> Tuple2.map1 ~f:Substring.to_string
+    |> Option.some
+
+  let filter_map t ~f x =
+    let open Option.Monad_infix in
+    t x >>= fun (s, rest) ->
+    f s >>| (fun x -> (x, rest))
+
+  let run t s = t s
+
+  type 'a tt = 'a t
+  include Monad.Make(struct
+    type 'a t = 'a tt
+    let return x s = Some (x, s)
+    let bind t f s =
+      match t s with
+      | None -> None
+      | Some (x, s') ->
+        let t' = f x in
+        t' s'
+    let map = `Define_using_bind
+  end)
+end
+
+let () = let module M = (Parser : Parser_intf) in ()
+
+type (_, _) t =
+  | Try_parse : unit Parser.t -> ('a, 'a) t
+  | Parse     : 'b Parser.t -> ('a, 'b -> 'a) t
+  | Concat    : ('b, 'c) t * ('a, 'b) t -> ('a, 'c) t
+
+let rec ints : type a b . (a, b) t -> b -> a Parser.t =
+  let open Option.Monad_infix in
+  fun t f inp ->
+    match t with
+    | Try_parse p -> Parser.run p inp >>| fun ((), inp') -> (f, inp')
+    | Parse p -> Parser.run p inp >>| fun (v, s) -> (f v, s)
+    | Concat (a, b) ->
+      ints a f inp >>= fun (vb, inp') ->
+      ints b vb inp'
+
+let match_url t s cb =
+  let s = Substring.of_string s in
+  match ints t cb s with
+  | None -> None
+  | Some (x, subs) ->
+    if subs |> Substring.to_string |> String.is_empty then
+      Some x
+    else (* we did not consume the whole string so no match *)
+      None
+
+(* little combinator that guarantees that the parsed string isn't empty *)
+let non_empty = Parser.filter_map ~f:(fun x ->
+  if String.is_empty x
+  then None
+  else Some x)
+
+let int = Parse (fun x ->
+  (Char.is_digit
+   |> Parser.take_while
+   |> non_empty
+   |> Parser.map ~f:Int.of_string) x)
+
+let s x = Try_parse (Parser.drop_prefix x)
+
+let (</>) x1 x2 =
+  let lead_slash x = Concat (s "/", x) in
+  Concat (x1, lead_slash x2)
+
+let str = Parse (fun x -> (Parser.take_while ((<>) '/') |> non_empty) x)