type safe routes opium

type_safe_routes.ml

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)