Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
type safe routes opium
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment