From b1659c13c3d1d4de2d6573cba6c27d9d7278392d Mon Sep 17 00:00:00 2001 From: Spiros Eliopoulos Date: Mon, 27 Apr 2020 20:54:37 -0400 Subject: [PATCH] constructor: add a create function The previous interface wasn't great in that required users to know that they should partially apply the dispatch function. Now, for both regular route description and the DSL route description, there's constructor to the same shared type t. With values of this type, users can now call a single dispatch function to get a handler for a path. --- js/dispatch_js.ml | 11 ----------- js/dispatch_js.mli | 19 +++++------------- lib/dispatch.ml | 12 +++++------ lib/dispatch.mli | 11 +++++++---- test/test_dispatch.ml | 46 +++++++++++++++++++++++-------------------- 5 files changed, 42 insertions(+), 57 deletions(-) diff --git a/js/dispatch_js.ml b/js/dispatch_js.ml index 608f629..051f3e2 100644 --- a/js/dispatch_js.ml +++ b/js/dispatch_js.ml @@ -32,14 +32,3 @@ let dispatch_on_fragment ?(on_failure=default_on_failure) ?(default="/") routes frag_loop | current -> go current >>= fun _ -> frag_loop - -module DSL = struct - let convert routes = - List.map (fun (m, x) -> - let ts, t = Dispatch.of_dsl m in - ts, t, x) - routes - - let dispatch_on_fragment ?on_failure ?default routes = - dispatch_on_fragment ?on_failure ?default (convert routes) -end diff --git a/js/dispatch_js.mli b/js/dispatch_js.mli index 9ece5fb..15fb676 100644 --- a/js/dispatch_js.mli +++ b/js/dispatch_js.mli @@ -36,22 +36,13 @@ Dispatch_js makes it easy for js_of_ocaml applications to monitor and react to changes in URI fragments. *) -open Dispatch - -val dispatch_on_fragment : - ?on_failure:(string -> unit Lwt.t) -> ?default:string -> - unit Lwt.t route list -> unit Lwt.t +val dispatch_on_fragment + : ?on_failure:(string -> unit Lwt.t) + -> ?default:string + -> unit Lwt.t Dispatch.t + -> unit Lwt.t (** [dispatch_on_fragment ?on_failure ?default routes] will monitor the URL fragment and dispatch to the appropriate hander in [routes]. In the event that the fragment does not match any routes, [on_failure] will be called, if provided, with the fragment. On setup the fragment will be set to [default], or ["/"] if no default is provided. *) - -module DSL : sig - - val dispatch_on_fragment : - ?on_failure:(string -> unit Lwt.t) -> ?default:string -> - unit Lwt.t DSL.route list -> unit Lwt.t - (** [dispatch_on_fragment ?on_failure ?default routes] is the same as the - non-DSL version with the exception of the route type. *) -end diff --git a/lib/dispatch.ml b/lib/dispatch.ml index 38ef6da..2b475ef 100644 --- a/lib/dispatch.ml +++ b/lib/dispatch.ml @@ -40,6 +40,10 @@ type typ = type assoc = (string * string) list type 'a route = (tag * string) list * typ * (assoc -> string option -> 'a) +type 'a t = 'a route list + +let create t = t + let path_split path = (* NOTE(seliopou): This was implemented manually to minimize dependencies for * js_of_ocaml. Ain't nobody got time for another regular expression library @@ -129,15 +133,9 @@ let dispatch_exn routes path = module DSL = struct type 'a route = string * (assoc -> string option -> 'a) - let convert routes = + let create routes = List.map (fun (m, x) -> let ts, t = of_dsl m in ts, t, x) routes - - let dispatch routes = - dispatch (convert routes) - - let dispatch_exn routes = - dispatch_exn (convert routes) end diff --git a/lib/dispatch.mli b/lib/dispatch.mli index d533102..27b4f6c 100644 --- a/lib/dispatch.mli +++ b/lib/dispatch.mli @@ -68,8 +68,12 @@ type 'a route = (tag * string) list * typ * (assoc -> string option -> 'a) route match, the matching information will be passed to the handler to produce a value of tyoe ['a] that will be returned. *) -val dispatch : 'a route list -> string -> 'a option -val dispatch_exn : 'a route list -> string -> 'a +type 'a t + +val create : 'a route list -> 'a t + +val dispatch : 'a t -> string -> 'a option +val dispatch_exn : 'a t -> string -> 'a (** [dispatch routes path] iterates through [routes] and selects the first one that matches [path]. It then applies the route handler to any component mappings and trailing path components (in the case of a prefix match) and @@ -104,6 +108,5 @@ module DSL : sig # of_dsk "/user/:id/settings";; = ([`Lit, "user"; `Var, "id"; `Lit, "settings"], `Exact) v} *) - val dispatch : 'a route list -> string -> 'a option - val dispatch_exn : 'a route list -> string -> 'a + val create : 'a route list -> 'a t end diff --git a/test/test_dispatch.ml b/test/test_dispatch.ml index 62f6b4b..c5fe263 100644 --- a/test/test_dispatch.ml +++ b/test/test_dispatch.ml @@ -44,29 +44,31 @@ open Alcotest let assoc = list (pair string string) -open Dispatch.DSL +open Dispatch let literals = "literals", [ "base cases", `Quick, begin fun () -> - let t0, t1 = ["/", fun _ _ -> ()], ["", fun _ _ -> ()] in + let t0, t1 = DSL.create ["/", fun _ _ -> ()], DSL.create ["", fun _ _ -> ()] in + let empty = DSL.create [] in let check = Alcotest.check (option unit) in let test_ok ~msg tbl p = check msg (dispatch tbl p) (Some ()) in let test_err ~msg tbl p = check msg (dispatch tbl p) None in - test_err [] "/" ~msg:"empty table produces errors"; - test_ok t0 "/" ~msg:"empty path string maps to root"; - test_ok t1 "" ~msg:"empty route path matches root"; - test_err t0 "/foo" ~msg:"root entry won't dispatch others"; + test_err empty "/" ~msg:"empty table produces errors"; + test_ok t0 "/" ~msg:"empty path string maps to root"; + test_ok t1 "" ~msg:"empty route path matches root"; + test_err t0 "/foo" ~msg:"root entry won't dispatch others"; end; "overlaping paths", `Quick, begin fun () -> let t0 = - [ ("/foo" , base_path "/foo") - ; ("/foo/bar", base_path "/foo/bar") - ; ("/foo/baz", base_path "/foo/baz") - ; ("/bar/baz", base_path "/bar/baz") - ; ("/bar/foo", base_path "/bar/foo") - ; ("/bar" , base_path "/bar") - ] + DSL.create + [ ("/foo" , base_path "/foo") + ; ("/foo/bar", base_path "/foo/bar") + ; ("/foo/baz", base_path "/foo/baz") + ; ("/bar/baz", base_path "/bar/baz") + ; ("/bar/foo", base_path "/bar/foo") + ; ("/bar" , base_path "/bar") + ] in let check = Alcotest.check (option string) in let test_ok ~msg p = check msg (dispatch t0 p) (Some p) in @@ -80,10 +82,11 @@ let params = "params", [ "base cases", `Quick, begin fun () -> let t0 = - [ ("/foo/:id" , param_path "id") - ; ("/foo/:id/:bar" , param_path "bar") - ; ("/foo/:id/bar/:baz", param_path "baz") - ] + DSL.create + [ ("/foo/:id" , param_path "id") + ; ("/foo/:id/:bar" , param_path "bar") + ; ("/foo/:id/bar/:baz", param_path "baz") + ] in let check = Alcotest.check (option string) in let test_ok ~msg p v = check msg (dispatch t0 p) (Some v) in @@ -93,9 +96,10 @@ let params = end; "variable ordering", `Quick, begin fun () -> let t0 = - [ ("/test/:z/:x/:y/" , params) - ; ("/test/:x/:y/order/:z/", params) - ] + DSL.create + [ ("/test/:z/:x/:y/" , params) + ; ("/test/:x/:y/order/:z/", params) + ] in let check = Alcotest.check (option assoc) in let test_ok ~msg p v = check msg (dispatch t0 p) (Some v) in @@ -109,7 +113,7 @@ let params = let wildcards = "wildcard", [ - let t0 = ["/foo/*", disp_path] in + let t0 = DSL.create ["/foo/*", disp_path] in let check = Alcotest.check (option string) in let test_ok ~msg p v = check msg (dispatch t0 p) (Some v) in "base cases", `Quick, begin fun () ->