nested-routes 7.2.2 → 8.0.0
raw patch · 2 files changed
+44/−26 lines, 2 filesdep +bifunctorsdep ~composition-extradep ~wai-middleware-content-type
Dependencies added: bifunctors
Dependency ranges changed: composition-extra, wai-middleware-content-type
Files
- nested-routes.cabal +3/−3
- src/Web/Routes/Nested.hs +41/−23
nested-routes.cabal view
@@ -1,5 +1,5 @@ Name: nested-routes-Version: 7.2.2+Version: 8.0.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -38,8 +38,8 @@ Web.Routes.Nested.Types Build-Depends: base >= 4.8 && < 5 , attoparsec+ , bifunctors , bytestring- , composition-extra >= 2.0.0 , errors , exceptions , hashable@@ -55,7 +55,7 @@ , tries , unordered-containers , wai-transformers >= 0.0.7- , wai-middleware-content-type >= 0.4.1+ , wai-middleware-content-type >= 0.5.0.1 , wai-middleware-verbs >= 0.3.1
src/Web/Routes/Nested.hs view
@@ -81,23 +81,23 @@ import Network.Wai.Middleware.Verbs import Network.Wai.Middleware.ContentType hiding (responseStatus, responseHeaders, responseData) -import Data.Foldable (foldlM) import Data.Trie.Pred.Base (RootedPredTrie (..), PredTrie (..)) import Data.Trie.Pred.Base.Step (PredStep (..), PredSteps (..)) import qualified Data.Trie.Pred.Interface as Interface import Data.Trie.Pred.Interface.Types (Singleton (..), Extrude (..), CatMaybes)-import Data.Trie.HashMap (HashMapTrie (..), HashMapStep (..), HashMapChildren (..))+import Data.Trie.HashMap (HashMapStep (..), HashMapChildren (..)) import Data.List.NonEmpty (NonEmpty (..), fromList) import qualified Data.Text as T import Data.Hashable import qualified Data.HashMap.Strict as HM import Data.Monoid import Data.Function.Poly-import Data.Typeable+import Data.Bifunctor (bimap) import qualified Control.Monad.State as S import Control.Monad.Catch import Control.Monad.Trans+import Control.Arrow import Control.Monad.ST @@ -334,9 +334,7 @@ -> m (Maybe r) extractNearestVia path extr hs = do trie <- extr hs- liftIO . stToIO $ do- let mResult = Interface.match path trie- pure (mid <$> mResult)+ pure (mid <$> Interface.match path trie) where mid (_,r,_) = r @@ -348,7 +346,12 @@ -- | Removes @.txt@ from @foo.txt@ trimFileExt :: T.Text -> T.Text-trimFileExt !s = fst $! T.breakOn "." s+trimFileExt !s =+ case T.breakOnEnd "." s of+ (f,e) | f /= ""+ && e /= ""+ && T.length f > 0 -> T.dropEnd 1 f+ _ -> s {-# INLINEABLE trimFileExt #-} @@ -356,23 +359,38 @@ -- | A quirky function for processing the last element of a lookup path, only -- on /literal/ matches. lookupWithLPT :: ( Hashable s- , Eq s- ) => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)-lookupWithLPT f (t:|ts) (PredTrie (HashMapStep ls) (PredSteps ps))- | null ts = getFirst $ First ((goLit $! f t) ls) <> foldMap (First . goPred) ps- | otherwise = getFirst $ First (goLit t ls) <> foldMap (First . goPred) ps- where- goLit t' xs = do- (HashMapChildren mx mxs) <- HM.lookup t' xs- if null ts- then ([t],) <$> mx- else fmap (\(ts',x) -> (t:ts',x)) $! lookupWithLPT f (fromList ts) =<< mxs+ , Eq s+ ) => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)+lookupWithLPT f tss (PredTrie (HashMapStep ls) (PredSteps ps)) =+ getFirst $ First (goLit f tss ls)+ <> foldMap (First . goPred f tss) ps - goPred (PredStep _ predicate mx xs) = do- d <- predicate t- if null ts- then ([t],) <$> (($ d) <$> mx)- else fmap (\(ts',x) -> (t:ts',x d)) $! lookupWithLPT f (fromList ts) xs+goLit :: ( Hashable s+ , Eq s+ ) => (s -> s)+ -> NonEmpty s+ -> HM.HashMap s (HashMapChildren PredTrie s a)+ -> Maybe ([s], a)+goLit f (t:|ts) xs = do+ (HashMapChildren mx mxs) <- getFirst $ First (HM.lookup t xs)+ <> First ( if null ts+ then HM.lookup (f t) xs+ else Nothing)+ if null ts+ then ([f t],) <$> mx+ else first (t:) <$> (lookupWithLPT f (fromList ts) =<< mxs)++goPred :: ( Hashable s+ , Eq s+ ) => (s -> s)+ -> NonEmpty s+ -> PredStep s PredTrie s a+ -> Maybe ([s], a)+goPred f (t:|ts) (PredStep _ predicate mx xs) = do+ d <- predicate t+ if null ts+ then (([t],) . ($ d)) <$> mx+ else bimap (t:) ($ d) <$> lookupWithLPT f (fromList ts) xs -- lookupWithLPT :: ( Eq k -- , Hashable k