web-routing 0.5.0 → 0.6.0
raw patch · 4 files changed
+121/−45 lines, 4 filesdep ~base
Dependency ranges changed: base
Files
- bench/main.hs +46/−9
- src/Network/Routing.hs +64/−34
- src/Network/Routing/Dict/Internal.hs +10/−0
- web-routing.cabal +1/−2
bench/main.hs view
@@ -36,8 +36,8 @@ Right (i, "") -> Just i _ -> Nothing -test :: Path '[] Maybe Int-test = root $ exact "foo" $+largePath :: Path '[] Maybe Int+largePath = root $ exact "foo" $ r p0 $ r p1 $ r p2 $ r p3 $ r p4 $ r p5 $ r p6 $ r p7 $ r p8 $ r p9 $ r p10 $ r p11 $ r p12 $ r p13 $ r p14 $@@ -50,16 +50,53 @@ where r p = fetch p readInt -route :: Router '[] Maybe Int-route = test +| empty+largePathRoute :: Router '[] Maybe Int+largePathRoute = largePath +| empty -testPath :: [T.Text]-testPath = "foo" : map (T.pack . show) [0..19::Int]+testLargePath :: [T.Text]+testLargePath = "foo" : map (T.pack . show) [0..19::Int] +benchLargePath :: [T.Text] -> Maybe Int+benchLargePath = execute largePathRoute "GET"++testRoute :: Router '[] Maybe T.Text+testRoute =+ hello +| param +| (foldr (\i r -> deep i +| r) (after +| empty) [0..100])+ where+ hello = exact "echo" $ exact "hello-world" $ action (Just "GET") $ \_ -> Just "Hello World"++ pS = Proxy :: Proxy "S"+ pI = Proxy :: Proxy "I"+ param = exact "echo" $ exact "plain" $ fetch pS Just $ fetch pI readInt $ action (Just "GET") $ \d ->+ Just $ T.replicate (get pI d) (get pS d)++ deep i = exact "deep" $ exact "foo" $ exact "bar" $ exact "baz" $ exact (T.pack $ show i) $ action (Just "GET") $ \_ ->+ Just (T.pack $ show (i :: Int))++ after = exact "after" $ action (Just "GET") $ \_ -> Just "after"++benchApiaryBenchmark :: [T.Text] -> Maybe T.Text+benchApiaryBenchmark = execute testRoute "GET"+ main :: IO () main = do- unless ((execute route "GET") testPath == Just 190) $- fail "result not matched"+ unless (benchLargePath testLargePath == Just 190) $ fail "largePath: result not matched"++ let hello = ["echo", "hello-world"]+ param = ["echo", "plain", "foo", "12"]+ deep = ["deep", "foo", "bar", "baz", "100"]+ after = ["after"]+ unless (benchApiaryBenchmark hello == Just "Hello World") $ fail "hello: result not matched"+ unless (benchApiaryBenchmark param == Just (T.replicate 12 "foo")) $ fail "param: result not matched"+ unless (benchApiaryBenchmark deep == Just "100") $ fail "deep: result not matched"+ unless (benchApiaryBenchmark after == Just "after") $ fail "after: result not matched"+ defaultMain- [ bench "routing" $ nf (execute route "GET") testPath+ [ bench "largePath" $ nf benchLargePath testLargePath+ , bgroup "apiary"+ [ bench "hello" $ nf benchApiaryBenchmark hello+ , bench "param" $ nf benchApiaryBenchmark param+ , bench "deep" $ nf benchApiaryBenchmark deep+ , bench "after" $ nf benchApiaryBenchmark after + ] ]
src/Network/Routing.hs view
@@ -63,6 +63,7 @@ ( Method -- * Path , Path+ , showPath, getMethod , root -- ** children , exact@@ -119,19 +120,19 @@ type Method = S.ByteString data Params d m a where- PCons :: (D.Store d -> [T.Text] -> m (D.Store d', [T.Text]))- -> Router d' m a- -> Params d m a -> Params d m a+ PCons :: !(D.Store d -> [T.Text] -> m (D.Store d', [T.Text]))+ -> !(Router d' m a)+ -> !(Params d m a) -> Params d m a PNil :: Params d m a -- | routing path data Path d m a where- Exact :: T.Text -> Path d m a -> Path d m a+ Exact :: !T.Text -> !(Path d m a) -> Path d m a - Param :: String -> (D.Store d -> [T.Text] -> m (D.Store d', [T.Text]))- -> Path d' m a -> Path d m a+ Param :: !String -> (D.Store d -> [T.Text] -> m (D.Store d', [T.Text]))+ -> !(Path d' m a) -> Path d m a - Action :: Maybe Method+ Action :: !(Maybe Method) -> (D.Dict d -> m a) -> Path d m a -- | root@@ -141,10 +142,12 @@ -- @ root :: Path '[] m a -> Path '[] m a root = id+{-# INLINABLE root #-} -- | exact matching path exact :: T.Text -> Path d m a -> Path d m a exact = Exact+{-# INLINABLE exact #-} type Raw m d d' = D.Store d -- ^ input dictionary@@ -158,6 +161,7 @@ -> Raw m d d' -> Path d' m a -> Path d m a raw = Param+{-# INLINABLE raw #-} -- ^ get one directory as parameter. fetch :: (MonadPlus m, KnownSymbol k, k D.</ d)@@ -170,12 +174,14 @@ go d (t:ts) = case f t of Nothing -> mzero Just v -> return (D.add p v d, ts)+{-# INLINABLE fetch #-} -- | drop any pathes any :: Monad m => Path d m a -> Path d m a any = Param "**" go where go d _ = return (d, [])+{-# INLINABLE any #-} -- | take any pathes as [Text] rest :: (KnownSymbol k, Monad m, k D.</ d) => proxy k -- ^ dictionary key@@ -183,27 +189,42 @@ rest k = Param (':': symbolVal k ++ "**") go where go d r = return (D.add k r d, [])+{-# INLINABLE rest #-} -- | action action :: Maybe Method -- ^ if Nothing, any method allowed -> (D.Dict d -> m a) -- ^ action when route matching -> Path d m a action = Action+{-# INLINABLE action #-} instance Show (Path d m a) where- show = go id- where- go :: (String -> String) -> Path d m a -> String- go s (Exact t ps) = go (s . (++) ('/' : T.unpack t)) ps- go s (Param l _ ps) = go (s . (++) ('/': l)) ps- go s (Action m _) = maybe "*" SC.unpack m ++ ' ': s []+ show p = maybe "*" SC.unpack (getMethod p) ++ ' ': showPath p +-- | show path. since v0.6.0.+showPath :: Path d m a -> String+showPath = go id+ where+ go :: (String -> String) -> Path d m a -> String+ go s (Exact t ps) = go (s . (++) ('/' : T.unpack t)) ps+ go s (Param l _ ps) = go (s . (++) ('/' : l)) ps+ go s (Action _ _) = s []++-- | get method. since v0.6.0.+getMethod :: Path d m a -> Maybe Method+getMethod = go+ where+ go :: Path d m a -> Maybe Method+ go (Action m _) = m+ go (Exact _ ps) = go ps+ go (Param _ _ ps) = go ps+ -- | router data Router d m a where Router ::- { params :: Params d m a- , children :: H.HashMap T.Text (Router d m a)- , methods :: H.HashMap Method (D.Dict d -> m a)+ { params :: !(Params d m a)+ , children :: !(H.HashMap T.Text (Router d m a))+ , methods :: !(H.HashMap Method (D.Dict d -> m a)) , anyMethod :: D.Dict d -> m a } -> Router d m a @@ -213,64 +234,73 @@ , methods = H.empty , anyMethod = const mzero }+{-# INLINABLE emptyRouter #-} -- | empty router empty :: MonadPlus m => Router '[] m a empty = emptyRouter+{-# INLINABLE empty #-} -add' :: MonadPlus m => Path d m a -> Router d m a -> Router d m a-add' (Exact p n) r =+insert' :: MonadPlus m => Path d m a -> Router d m a -> Router d m a+insert' (Exact p n) r = let c = H.lookupDefault emptyRouter p (children r)- in r { children = H.insert p (add' n c) (children r) }+ in r { children = H.insert p (insert' n c) (children r) } -add' (Param _ f n) Router{..} = Router- { params = PCons f (add' n emptyRouter) params+insert' (Param _ f n) Router{..} = Router+ { params = PCons f (insert' n emptyRouter) params , children = children , methods = methods , anyMethod = anyMethod } -add' (Action (Just m) n) r = +insert' (Action (Just m) n) r = let c = case H.lookup m (methods r) of Nothing -> \d -> n d Just p -> \d -> p d `mplus` n d in r { methods = H.insert m c (methods r) } -add' (Action Nothing n) r =+insert' (Action Nothing n) r = r { anyMethod = \d -> anyMethod r d `mplus` n d }+{-# INLINABLE insert' #-} -- | insert path to router insert :: MonadPlus m => Path '[] m a -> Router '[] m a -> Router '[] m a-insert = add'+insert = insert'+{-# INLINABLE insert #-} -- | infix version of `insert` (+|) :: MonadPlus m => Path '[] m a -> Router '[] m a -> Router '[] m a (+|) = insert+{-# INLINABLE (+|) #-} infixr `insert` infixr +| -- | execute router execute :: MonadPlus m => Router '[] m a -> Method -> [T.Text] -> m a-execute = execute' D.emptyStore+execute = {-# SCC execute #-} execute' D.emptyStore+{-# INLINABLE execute #-} execute' :: MonadPlus m => D.Store d -> Router d m a -> Method -> [T.Text] -> m a-execute' d Router{params, methods, anyMethod} m [] = fetching d m [] params `mplus`- case H.lookup m methods of+execute' d Router{params, methods, anyMethod} m [] = {-# SCC execute' #-} fetching next d m [] params+ where+ next = case H.lookup m methods of Nothing -> anyMethod (D.mkDict d) Just f -> f (D.mkDict d) -execute' d Router{params, children} m pps@(p:ps) = child `mplus` fetching d m pps params+execute' d Router{params, children} m pps@(p:ps) = {-# SCC execute' #-} case H.lookup p children of+ Nothing -> next+ Just c -> execute' d c m ps `mplus` next where- child = case H.lookup p children of- Nothing -> mzero- Just c -> execute' d c m ps+ next = fetching mzero d m pps params+{-# INLINABLE execute' #-} -fetching :: MonadPlus m => D.Store d -> Method -> [T.Text] -> Params d m a -> m a-fetching d m pps = loop+fetching :: MonadPlus m => m a -> D.Store d -> Method -> [T.Text] -> Params d m a -> m a+fetching next d m pps = {-# SCC fetching #-} loop where- loop PNil = mzero+ loop PNil = next loop (PCons f r o) = do (d', pps') <- f d pps execute' d' r m pps' `mplus` loop o+{-# INLINABLE fetching #-}
src/Network/Routing/Dict/Internal.hs view
@@ -41,9 +41,11 @@ unsafeToAny :: a -> Any unsafeToAny = unsafeCoerce+{-# INLINABLE unsafeToAny #-} unsafeFromAny :: Any -> a unsafeFromAny = unsafeCoerce+{-# INLINABLE unsafeFromAny #-} -- | (kind) key-value pair data KV v = Symbol := v@@ -67,9 +69,11 @@ emptyStore :: Store '[] emptyStore = Store 0 Empty+{-# INLINABLE emptyStore #-} emptyDict :: Dict '[] emptyDict = mkDict emptyStore+{-# INLINABLE emptyDict #-} -- | (kind) pretty print type error of 'add'. --@@ -105,6 +109,7 @@ -- Store {bar = "baz" :: [Char], foo = 12 :: Int} add :: (k </ kvs) => proxy k -> v -> Store kvs -> Store (k := v ': kvs) add _ v (Store l c) = Store (l + 1) (Cons v c)+{-# INLINABLE add #-} -- | heterogeneous dictionary --@@ -141,10 +146,12 @@ P.writeArray array i (unsafeToAny v) loop (i + 1) ss loop _ Empty = return ()+{-# INLINABLE mkDict' #-} -- | O(n) convert "Store" to "Dictionary". mkDict :: Store kvs -> Dict kvs mkDict store = runST $ mkDict' store+{-# INLINABLE mkDict #-} -- | O(1) (>= ghc-7.8), O(n) (< ghc-7.8) get key from dictionary --@@ -180,6 +187,7 @@ getImpl :: forall i proxy k kvs v. (Index i ~ Ix k kvs, KnownNat i) => proxy (k :: Symbol) -> Dict kvs -> v getImpl _ (Dict d) = unsafeFromAny $ d `P.indexArray` fromIntegral (natVal (Proxy :: Proxy i))+{-# INLINABLE getImpl #-} class Member (k :: Symbol) (v :: *) (kvs :: [KV *]) | k kvs -> v where get' :: proxy k -> Dict kvs -> v@@ -199,9 +207,11 @@ instance Member k v (k := v ': kvs) where get' !i _ (Dict d) = unsafeFromAny $ d `P.indexArray` i+ {-# INLINE get' #-} instance Member k v kvs => Member k v (k' := v' ': kvs) where get' !i k d = get' (i + 1) k (unsafeCoerce d :: Dict kvs)+ {-# INLINE get' #-} get = get' 0 #endif
web-routing.cabal view
@@ -1,7 +1,6 @@ name: web-routing-version: 0.5.0+version: 0.6.0 synopsis: simple routing library--- description: license: MIT license-file: LICENSE author: HirotomoMoriwaki<philopon.dependence@gmail.com>