packages feed

reroute 0.1.0.0 → 0.2.0.0

raw patch · 8 files changed

+483/−196 lines, 8 filesdep +deepseqdep +graph-coredep −HList

Dependencies added: deepseq, graph-core

Dependencies removed: HList

Files

reroute.cabal view
@@ -1,5 +1,5 @@ name:                reroute-version:             0.1.0.0+version:             0.2.0.0 synopsis:            abstract implementation of typed and untyped web routing description:         abstraction over how urls with/without parameters are mapped to their corresponding handlers homepage:            http://github.com/agrafix/reroute@@ -13,18 +13,20 @@ cabal-version:       >=1.10  library-  exposed-modules:     Web.Routing.AbstractRouter, Web.Routing.SafeRouting, Web.Routing.TextRouting+  exposed-modules:     Data.HVect, Web.Routing.AbstractRouter, Web.Routing.SafeRouting, Web.Routing.TextRouting+  other-modules:       Data.PolyMap   build-depends:       base >=4.6 && <4.8,                        transformers >=0.3 && <0.5,                        text >= 0.11.3.1 && <1.3,                        unordered-containers ==0.2.*,-                       HList >=0.3,                        regex-compat ==0.95.*,                        hashable >=1.2 && <1.3,                        mtl >=2.1 && <2.3,                        path-pieces >=0.1 && <0.2,                        hspec2 >=0.4 && <0.5,-                       vector >=0.10 && <0.11+                       vector >=0.10 && <0.11,+                       deepseq >= 1.1.0.2 && < 1.4,+                       graph-core >=0.2 && <0.3   hs-source-dirs:      src   default-language:    Haskell2010 @@ -38,13 +40,14 @@                        transformers >=0.3 && <0.5,                        text >= 0.11.3.1 && <1.3,                        unordered-containers ==0.2.*,-                       HList >=0.3,                        regex-compat ==0.95.*,                        hashable >=1.2 && <1.3,                        mtl >=2.1 && <2.3,                        path-pieces >=0.1 && <0.2,                        hspec2 >=0.4 && <0.5,-                       vector >=0.10 && <0.11+                       vector >=0.10 && <0.11,+                       deepseq >= 1.1.0.2 && < 1.4,+                       graph-core >=0.2 && <0.3   default-language:    Haskell2010   ghc-options: -Wall -fno-warn-orphans
+ src/Data/HVect.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE UndecidableInstances #-} -- for ReverseLoop type family+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module Data.HVect+  ( HVect (..)+  , HVectElim+  , Append, hVectAppend+  , ReverseLoop, Reverse, hVectReverse+  , hVectUncurry+  , Rep (..), HasRep (..)+  , hVectCurryExpl, hVectCurry+  , packExpl, pack+  ) where++data HVect (ts :: [*]) where+  HNil :: HVect '[]+  HCons :: t -> HVect ts -> HVect (t ': ts)++-- todo: use a closed type family once GHC 7.6 compatibility is dropped+type family HVectElim (ts :: [*]) (a :: *) :: *+type instance HVectElim '[] a = a+type instance HVectElim (t ': ts) a = t -> HVectElim ts a++-- todo: use a closed type family once GHC 7.6 compatibility is dropped+type family Append (as :: [*]) (bs :: [*]) :: [*]+type instance Append '[] bs = bs+type instance Append (a ': as) bs = a ': (Append as bs)++hVectAppend :: HVect as -> HVect bs -> HVect (Append as bs)+hVectAppend HNil bs = bs+hVectAppend (HCons a as) bs = HCons a (hVectAppend as bs)++type family ReverseLoop (as :: [*]) (bs :: [*]) :: [*]+type instance ReverseLoop '[] bs = bs+type instance ReverseLoop (a ': as) bs = ReverseLoop as (a ': bs)++type Reverse as = ReverseLoop as '[]++hVectReverse :: HVect as -> HVect (Reverse as)+hVectReverse vs = go vs HNil+  where+    go :: HVect as -> HVect bs -> HVect (ReverseLoop as bs)+    go HNil bs = bs+    go (HCons a as) bs = go as (HCons a bs)++hVectUncurry :: HVectElim ts a -> HVect ts -> a+hVectUncurry f HNil = f+hVectUncurry f (HCons x xs) = hVectUncurry (f x) xs++data Rep (ts :: [*]) where+  RNil :: Rep '[]+  RCons :: Rep ts -> Rep (t ': ts)++class HasRep (ts :: [*]) where+  hasRep :: Rep ts++instance HasRep '[] where+  hasRep = RNil++instance HasRep ts => HasRep (t ': ts) where+  hasRep = RCons hasRep++hVectCurryExpl :: Rep ts -> (HVect ts -> a) -> HVectElim ts a+hVectCurryExpl RNil f = f HNil+hVectCurryExpl (RCons r) f = \x -> hVectCurryExpl r (f . HCons x)++hVectCurry :: HasRep ts => (HVect ts -> a) -> HVectElim ts a+hVectCurry = hVectCurryExpl hasRep++buildElim :: Rep ts -> (HVect ts -> HVect ss) -> HVectElim ts (HVect ss)+buildElim RNil f = f HNil+buildElim (RCons r) f = \x -> buildElim r (f . HCons x)++packExpl :: Rep ts -> (forall a. HVectElim ts a -> a) -> HVect ts+packExpl rep f = f (buildElim rep id)++pack :: HasRep ts => (forall a. HVectElim ts a -> a) -> HVect ts+pack = packExpl hasRep
+ src/Data/PolyMap.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GADTs #-}++module Data.PolyMap+  ( PolyMap, empty, rnfHelper+  , lookup, lookupApply, lookupApplyAll, lookupConcat+  , alter,  updateAll, insertWith+  , unionWith, union+  , zipWith', zipWith, zip, ap+  ) where++import Prelude hiding (lookup, zipWith, zip)+import Data.Typeable+import Control.Applicative (Applicative (..), Alternative ((<|>)), liftA2)+import Data.Monoid (Monoid (..))+import GHC.Exts (Constraint)++data PolyMap (c :: * -> Constraint) (f :: * -> *) (a :: *) where+  PMNil :: PolyMap c f a+  PMCons :: (Typeable p, c p) => f (p -> a) -> PolyMap c f a -> PolyMap c f a++instance Functor f => Functor (PolyMap c f) where+  fmap _ PMNil = PMNil+  fmap f (PMCons v pm) = PMCons (fmap ((.) f) v) (fmap f pm)++instance Alternative f => Monoid (PolyMap c f a) where+  mempty = empty+  mappend = union++empty :: PolyMap c f a+empty = PMNil++rnfHelper :: (forall p. c p => f (p -> a) -> ()) -> PolyMap c f a -> ()+rnfHelper _ PMNil = ()+rnfHelper h (PMCons v pm) = h v `seq` rnfHelper h pm++lookup ::+  Typeable p+  => PolyMap c f a+  -> Maybe (f (p -> a))+lookup PMNil = Nothing+lookup (PMCons w polyMap') =+  case gcast1 w of+    Just w' -> Just w'+    Nothing -> lookup polyMap'++lookupApply ::+  (Typeable p, Functor f)+  => p+  -> PolyMap c f a+  -> Maybe (f a)+lookupApply _ PMNil = Nothing+lookupApply p (PMCons w polyMap') =+  case gcast1 w of+    Just w' -> Just (fmap ($ p) w')+    Nothing -> lookupApply p polyMap'++lookupApplyAll ::+  Functor f+  => (forall p. c p => Maybe p)+  -> PolyMap c f a+  -> [f a]+lookupApplyAll maybeGet polyMap =+  case polyMap of+    PMNil -> []+    PMCons w polyMap' ->+      let rest = lookupApplyAll maybeGet polyMap'+      in case maybeGet of+           Nothing -> rest+           Just p  -> (fmap ($ p) w) : rest++lookupConcat ::+  (Monoid m, Functor f)+  => (forall p. c p => Maybe p)+  -> (forall p. c p => p -> f (p -> a) -> m)+  -> PolyMap c f a+  -> m+lookupConcat maybeGet comp polyMap =+  case polyMap of+    PMNil -> mempty+    PMCons w polyMap' ->+      let rest = lookupConcat maybeGet comp polyMap'+      in case maybeGet of+           Nothing -> rest+           Just p  -> comp p w `mappend` rest+++maybeInsertHere ::+  (c p, Typeable p)+  => Maybe (f (p -> a))+  -> PolyMap c f a+  -> PolyMap c f a+maybeInsertHere = maybe id PMCons++alter ::+  (Typeable p, c p)+  => (Maybe (f (p -> a)) -> Maybe (f (p -> a)))+  -> PolyMap c f a+  -> PolyMap c f a+alter (g :: Maybe (f (p -> a)) -> Maybe (f (p -> a))) polyMap =+  case polyMap of+    PMNil -> insertHere PMNil+    PMCons (w :: f (q -> a)) polyMap' ->+      case gcast1 w of+        Just w' ->+          case g (Just w') of+            Just w'' -> PMCons w'' polyMap'+            Nothing -> polyMap'+        Nothing ->+          if typeOf (undefined :: p) < typeOf (undefined :: q)+          then insertHere polyMap+          else PMCons w (alter g polyMap')+  where insertHere = maybe id PMCons (g Nothing)++updateAll ::+     (forall p. c p => f (p -> a) -> g (p -> b))+  -> PolyMap c f a+  -> PolyMap c g b+updateAll _ PMNil = PMNil+updateAll f (PMCons v pm) = PMCons (f v) (updateAll f pm)++insertWith ::+  (Typeable p, c p)+  => (f (p -> a) -> f (p -> a) -> f (p -> a))+  -> f (p -> a)+  -> PolyMap c f a+  -> PolyMap c f a+insertWith combine val = alter (Just . maybe val (combine val))++unionWith ::+     (forall p. c p => f (p -> a) -> f (p -> a) -> f (p -> a))+  -> PolyMap c f a+  -> PolyMap c f a+  -> PolyMap c f a+unionWith _ PMNil pm2 = pm2+unionWith _ pm1 PMNil = pm1+unionWith combine pm1@(PMCons (v :: f (p -> a)) pm1')+                  pm2@(PMCons (w :: f (q -> a)) pm2') =+  case gcast1 v of+    Just v' -> PMCons (combine v' w) (unionWith combine pm1' pm2')+    Nothing ->+        if typeOf (undefined :: p) < typeOf (undefined :: q)+        then PMCons v (unionWith combine pm1' pm2)+        else PMCons w (unionWith combine pm1 pm2')++union ::+  Alternative f+  => PolyMap c f a+  -> PolyMap c f a+  -> PolyMap c f a+union = unionWith (<|>)++zipWith' :: +     (forall p. c p => Maybe (f (p -> a)) -> Maybe (f (p -> b)) -> Maybe (f (p -> d)))+  -> PolyMap c f a+  -> PolyMap c f b+  -> PolyMap c f d+zipWith' f = go+  where+    go PMNil PMNil = PMNil+    go PMNil (PMCons w pm2') = maybeInsertHere (f Nothing (Just w)) (go PMNil pm2')+    go (PMCons v pm1') PMNil = maybeInsertHere (f (Just v) Nothing) (go pm1' PMNil)+    go pm1@(PMCons (v :: f (p -> a)) pm1') pm2@(PMCons (w :: f (q -> b)) pm2') =+      case gcast1 v of+        Just v' -> maybeInsertHere (f (Just v') (Just w)) (go pm1 pm2)+        Nothing ->+          if typeOf (undefined :: p) < typeOf (undefined :: q)+          then maybeInsertHere (f (Just v) Nothing) (go pm1' pm2)+          else maybeInsertHere (f Nothing (Just w)) (go pm1 pm2')++zipWith ::+  Applicative f+  => (a -> b -> d)+  -> PolyMap c f a+  -> PolyMap c f b+  -> PolyMap c f d+zipWith f = zipWith' $ liftA2 $ liftA2 $ \a b p -> f (a p) (b p)++zip ::+  Applicative f+  => PolyMap c f a+  -> PolyMap c f b+  -> PolyMap c f (a, b)+zip = zipWith (,)++ap ::+  Applicative f+  => PolyMap c f (a -> b)+  -> PolyMap c f a+  -> PolyMap c f b+ap = zipWith ($)
src/Web/Routing/AbstractRouter.hs view
@@ -10,6 +10,7 @@ import Data.Maybe import qualified Data.HashMap.Strict as HM import qualified Data.Text as T+import Control.DeepSeq (NFData (..))  class AbstractRouter r where     data Registry r :: *@@ -26,7 +27,7 @@  newtype CaptureVar       = CaptureVar { unCaptureVar :: T.Text }-      deriving (Show, Eq, Hashable)+      deriving (Show, Eq, Hashable, NFData)  newtype RegistryT r middleware reqTypes (m :: * -> *) a     = RegistryT { runRegistryT :: RWST (RoutePath r '[]) [middleware] (RegistryState r reqTypes) m a }@@ -48,12 +49,13 @@           -> RouteAction r as           -> RegistryT r middleware reqTypes m () hookRoute reqType path action =-    modify $ \rs ->-        rs { rs_registry =-                 let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs))-                     reg' = defRoute path action reg-                 in HM.insert reqType reg' (rs_registry rs)-           }+    do basePath <- ask+       modify $ \rs ->+           rs { rs_registry =+                    let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs))+                        reg' = defRoute (basePath `subcompCombine` path) action reg+                    in HM.insert reqType reg' (rs_registry rs)+              }  middleware :: Monad m            => middleware
src/Web/Routing/SafeRouting.hs view
@@ -1,32 +1,38 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+ module Web.Routing.SafeRouting where +import qualified Data.PolyMap as PM+import Data.HVect import Web.Routing.AbstractRouter -import Data.HList import Data.Maybe-import Data.Monoid+import Data.List (foldl')+import Data.Monoid (Monoid (..))+import Control.Applicative (Applicative (..), Alternative (..)) import Data.String+import Data.Typeable (Typeable)+import Control.DeepSeq (NFData (..)) import Web.PathPieces import qualified Data.HashMap.Strict as HM import qualified Data.Text as T  data RouteHandle m a-   = forall as. RouteHandle (Path as) (HListElim as (m a))+   = forall as. RouteHandle (Path as) (HVectElim as (m a)) -newtype HListElim' x ts = HListElim' { flipHListElim :: HListElim ts x }+newtype HVectElim' x ts = HVectElim' { flipHVectElim :: HVectElim ts x }  data SafeRouter (m :: * -> *) a = SafeRouter  instance AbstractRouter (SafeRouter m a) where     newtype Registry (SafeRouter m a) = SafeRouterReg (PathMap (m a))     newtype RoutePath (SafeRouter m a) xs = SafeRouterPath (Path xs)-    type RouteAction (SafeRouter m a) = HListElim' (m a)+    type RouteAction (SafeRouter m a) = HVectElim' (m a)     type RouteAppliedAction (SafeRouter m a) = m a     subcompCombine (SafeRouterPath p1) (SafeRouterPath p2) =         SafeRouterPath $@@ -35,81 +41,72 @@     rootPath = SafeRouterPath Empty     defRoute (SafeRouterPath path) action (SafeRouterReg m) =         SafeRouterReg $-        insertPathMap (RouteHandle path (flipHListElim action)) m+        insertPathMap (RouteHandle path (flipHVectElim action)) m     matchRoute (SafeRouterReg m) pathPieces =         let matches = match m pathPieces         in zip (replicate (length matches) HM.empty) matches -type family HListElim (ts :: [*]) (a :: *) :: *-type instance HListElim '[] a = a-type instance HListElim (t ': ts) a = t -> HListElim ts a -hListUncurry :: HListElim ts a -> HList ts -> a-hListUncurry f HNil = f-hListUncurry f (HCons x xs) = hListUncurry (f x) xs- data Path (as :: [*]) where   Empty :: Path '[] -- the empty path   StaticCons :: T.Text -> Path as -> Path as -- append a static path piece to path   VarCons :: (PathPiece a, Typeable a) => Path as -> Path (a ': as) -- append a param to path -data PolyMap x where-  PMNil :: PolyMap x-  PMCons :: (Typeable a, PathPiece a) => PathMap (a -> x) -> PolyMap x -> PolyMap x--data Id a = Id { getId :: a }--castDefType :: (Typeable a, Typeable b) => (a -> c) -> Maybe (b -> c)-castDefType x = fmap getId (gcast1 (Id x))--insertPolyMap ::-  (Typeable a, PathPiece a)-  => Path ts-  -> (a -> HList ts -> x)-  -> PolyMap x-  -> PolyMap x-insertPolyMap path (action :: a -> HList ts -> x) polyMap =-  case polyMap of-    PMNil -> PMCons (insertPathMap' path (flip action) emptyPathMap) PMNil-    PMCons (pathMap :: PathMap (b -> x)) polyMap' ->-        case castDefType action of-          Just action' ->-              PMCons (insertPathMap' path (flip action') pathMap) polyMap'-          Nothing ->-               PMCons pathMap (insertPolyMap path action polyMap')+data PathMap x =+  PathMap+  { pm_here :: [x]+  , pm_staticMap :: HM.HashMap T.Text (PathMap x)+  , pm_polyMap :: PM.PolyMap PathPiece PathMap x+  } -lookupPolyMap :: T.Text -> [T.Text] -> PolyMap x -> [x]-lookupPolyMap _ _ PMNil = []-lookupPolyMap pp pps (PMCons pathMap polyMap') =-  (maybeToList (fromPathPiece pp) >>= \val -> fmap ($ val) (match pathMap pps))-  ++ lookupPolyMap pp pps polyMap'+instance Functor PathMap where+  fmap f (PathMap h s p) = PathMap (fmap f h) (fmap (fmap f) s) (fmap f p) +instance Applicative PathMap where+  pure x = PathMap [x] mempty PM.empty+  PathMap h s p <*> y =+    let start = PathMap mempty (fmap (<*> y) s) (PM.updateAll (\a -> fmap flip a <*> y) p)+    in foldl' (\pm f -> pm `mappend` fmap f y) start h -emptyPolyMap :: PolyMap x-emptyPolyMap = PMNil+instance Alternative PathMap where+  empty = emptyPathMap+  (<|>) = mappend -data PathMap x = PathMap [x] (HM.HashMap T.Text (PathMap x)) (PolyMap x)+instance NFData x => NFData (PathMap x) where+  rnf (PathMap h s p) = rnf h `seq` rnf s `seq` PM.rnfHelper rnf p  emptyPathMap :: PathMap x-emptyPathMap = PathMap mempty mempty emptyPolyMap+emptyPathMap = PathMap mempty mempty PM.empty -insertPathMap' :: Path ts -> (HList ts -> x) -> PathMap x -> PathMap x-insertPathMap' path action (PathMap as m pm) =+instance Monoid (PathMap x) where+  mempty = emptyPathMap+  mappend (PathMap h1 s1 p1) (PathMap h2 s2 p2) =+    PathMap (h1 `mappend` h2) (HM.unionWith mappend s1 s2) (PM.unionWith mappend p1 p2)++insertPathMap' :: Path ts -> (HVect ts -> x) -> PathMap x -> PathMap x+insertPathMap' path action (PathMap h s p) =   case path of-    Empty -> PathMap (action HNil : as) m pm-    StaticCons pathPiece xs ->-      let subPathMap = fromMaybe emptyPathMap (HM.lookup pathPiece m)-      in PathMap as (HM.insert pathPiece (insertPathMap' xs action subPathMap) m) pm-    VarCons xs -> PathMap as m (insertPolyMap xs (\v vs -> action (HCons v vs)) pm)+    Empty -> PathMap (action HNil : h) s p+    StaticCons pathPiece path' ->+      let subPathMap = fromMaybe emptyPathMap (HM.lookup pathPiece s)+      in PathMap h (HM.insert pathPiece (insertPathMap' path' action subPathMap) s) p+    VarCons path' ->+      let alterFn = Just . insertPathMap' path' (\vs v -> action (HCons v vs))+                         . fromMaybe emptyPathMap+      in PathMap h s (PM.alter alterFn p) +singleton :: Path ts -> HVectElim ts x -> PathMap x+singleton path action = insertPathMap' path (hVectUncurry action) mempty+ insertPathMap :: RouteHandle m a -> PathMap (m a) -> PathMap (m a)-insertPathMap (RouteHandle path action) = insertPathMap' path (hListUncurry action)+insertPathMap (RouteHandle path action) = insertPathMap' path (hVectUncurry action)  match :: PathMap x -> [T.Text] -> [x]-match (PathMap as _ _) [] = as-match (PathMap _ m pm) (pp:pps) =-  let staticMatches = maybeToList (HM.lookup pp m) >>= flip match pps-      varMatches = lookupPolyMap pp pps pm+match (PathMap h _ _) [] = h+match (PathMap _ s p) (pp:pps) =+  let staticMatches = maybeToList (HM.lookup pp s) >>= flip match pps+      varMatches = PM.lookupConcat (fromPathPiece pp)+                     (\piece pathMap' -> fmap ($ piece) (match pathMap' pps)) p   in staticMatches ++ varMatches  -- | A route parameter@@ -120,7 +117,9 @@  -- | A static route piece static :: String -> Path '[]-static s = StaticCons (T.pack s) Empty+static s =+  let pieces = filter (not . T.null) $ T.splitOn "/" $ T.pack s+  in foldr StaticCons Empty pieces  instance (a ~ '[]) => IsString (Path a) where     fromString = static@@ -129,16 +128,16 @@ root :: Path '[] root = Empty -(</>) :: Path as -> Path bs -> Path (HAppendList as bs)+(</>) :: Path as -> Path bs -> Path (Append as bs) (</>) Empty xs = xs (</>) (StaticCons pathPiece xs) ys = (StaticCons pathPiece (xs </> ys)) (</>) (VarCons xs) ys = (VarCons (xs </> ys)) -renderRoute :: Path as -> HList as -> T.Text+renderRoute :: Path as -> HVect as -> T.Text renderRoute p h =     T.intercalate "/" $ renderRoute' p h -renderRoute' :: Path as -> HList as -> [T.Text]+renderRoute' :: Path as -> HVect as -> [T.Text] renderRoute' Empty _ = [] renderRoute' (StaticCons pathPiece pathXs) paramXs =     ( pathPiece : renderRoute' pathXs paramXs )@@ -147,7 +146,7 @@ renderRoute' _ _ =     error "This will never happen." -parse :: Path as -> [T.Text] -> Maybe (HList as)+parse :: Path as -> [T.Text] -> Maybe (HVect as) parse Empty [] = Just HNil parse _ [] = Nothing parse path (pathComp : xs) =
src/Web/Routing/Specs/SafeRoutingSpec.hs view
@@ -8,10 +8,13 @@ module Web.Routing.Specs.SafeRoutingSpec where  import Test.Hspec+import Data.HVect  import Control.Monad.Identity import Web.Routing.SafeRouting import Web.Routing.AbstractRouter+import Data.Monoid (mconcat)+import Control.Applicative (Applicative (..)) import qualified Data.Text as T  data ReturnVar@@ -21,14 +24,14 @@    | ListVar [ReturnVar]    deriving (Show, Eq, Read) -defR :: (Monad m, HListElim ts (m ReturnVar) ~ HListElim ts x) => Path ts -> HListElim ts x -> RegistryT (SafeRouter m ReturnVar) middleware Bool m ()-defR path action = hookRoute True (SafeRouterPath path) (HListElim' action)+defR :: (Monad m, HVectElim ts (m ReturnVar) ~ HVectElim ts x) => Path ts -> HVectElim ts x -> RegistryT (SafeRouter m ReturnVar) middleware Bool m ()+defR path action = hookRoute True (SafeRouterPath path) (HVectElim' action)   spec :: Spec spec =     describe "SafeRouting Spec" $-    do it "shoud match known routes" $+    do it "should match known routes" $           do checkRoute "" [StrVar "root"]              checkRoute "/bar" [StrVar "bar"]        it "shoudn't match unknown routes" $@@ -45,10 +48,29 @@           do checkRoute "/bar/5" [IntVar 5, StrVar "5"]              checkRoute "/bar/bingo" [StrVar "bar/bingo", StrVar "bingo"]              checkRoute "/entry/1/audit" [IntVar 1,ListVar [IntVar 1,StrVar "audit"]]+       it "should provide an Applicative interface" $+          do let numbers =+                   mconcat+                   [ singleton var id+                   , singleton ("forty" </> "two") (42 :: Int)+                   ]+                 operators =+                   mconcat+                   [ singleton "plus" ((+) :: Int -> Int -> Int)+                   , singleton "mult" (*)+                   ]+                 routes = operators <*> numbers <*> numbers+                 check path val = match routes (pieces path) `shouldBe` [val]+             check "/plus/forty/two/forty/two" (42+42)+             check "/mult/forty/two/3" (42*3)+             check "/plus/5/89" 94     where+      pieces :: T.Text -> [T.Text]+      pieces = filter (not . T.null) . T.splitOn "/"+             checkRoute :: T.Text -> [ReturnVar] -> Expectation       checkRoute r x =-          let matches = handleFun (filter (not . T.null) $ T.splitOn "/" r)+          let matches = handleFun (pieces r)           in (map (runIdentity . snd) matches) `shouldBe` x        handleFun :: [T.Text] -> [(ParamMap, Identity ReturnVar)]@@ -67,7 +89,7 @@                  return (ListVar [IntVar i, IntVar i2])              defR ("entry" </> var </> var) $ \i st ->                  return (ListVar [IntVar i, StrVar st])-             defR ("entry" </> "bytags" </> var </> var) $ \i st ->+             defR ("entry/bytags" </> var </> var) $ \i st ->                  return (ListVar [IntVar i, StrVar st])              defR ("entry" </> var </> "rel" </> var) $ \i i2 ->                  return (ListVar [IntVar i, IntVar i2])
src/Web/Routing/Specs/TextRoutingSpec.hs view
@@ -5,7 +5,6 @@  import Web.Routing.TextRouting import qualified Web.Routing.AbstractRouter as R-import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM  spec :: Spec@@ -13,7 +12,6 @@     do matchNodeDesc        matchRouteDesc        parseRouteNodeDesc-       addToRoutingTreeDesc  matchNodeDesc :: Spec matchNodeDesc =@@ -52,8 +50,8 @@           ((oneMatch emptyParamMap [5])             ++ oneMatch (vMap [("baz", "bingo")]) [3])       multiMatch' =-          ((oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6])-           ++ (oneMatch (vMap [("eid", "1")]) [8]))+          ((oneMatch (vMap [("eid", "1")]) [8])+           ++ (oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6]))       noMatches = []       oneMatch pm m = [(pm, m)]       routingTree =@@ -81,30 +79,3 @@           parseRouteNode ":bar" `shouldBe` RouteNodeCapture (R.CaptureVar "bar")        it "parses regex capture variables" $           parseRouteNode "{bar:^[0-9]$}" `shouldBe` RouteNodeRegex (R.CaptureVar "bar") (buildRegex "^[0-9]$")--addToRoutingTreeDesc :: Spec-addToRoutingTreeDesc =-    describe "addToRoutingTree" $-    do it "adds the root node correctly" $-          addToRoutingTree "/" [True] emptyT `shouldBe` baseRoute-       it "adds a new branch correctly" $-          addToRoutingTree "/foo/:bar" [True] emptyT `shouldBe` fooBar []-       it "add a new subbranch correctly" $-          addToRoutingTree "/foo/:bar/baz" [True] (fooBar []) `shouldBe` fooBar baz-    where-      emptyT = emptyRoutingTree-      baseRoute = RoutingTree { rt_node = RouteData{rd_node = RouteNodeRoot, rd_data = Just [True]}, rt_children = V.empty}-      baz = [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeText "baz", rd_data = Just [True] },rt_children = V.empty }]-      fooBar xs =-          RoutingTree-          { rt_node =-                RouteData {rd_node = RouteNodeRoot, rd_data = Nothing }-          , rt_children =-              V.fromList-                   [ RoutingTree { rt_node = RouteData{rd_node = RouteNodeText "foo", rd_data = Nothing}-                                 , rt_children =-                                     V.fromList-                                          [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeCapture (R.CaptureVar "bar")-                                                                              , rd_data = Just [True]-                                                                              }-                                                        , rt_children = V.fromList xs}]}]}
src/Web/Routing/TextRouting.hs view
@@ -7,11 +7,13 @@  import Web.Routing.AbstractRouter -import Data.Maybe import Data.String+import Control.DeepSeq (NFData (..))+import qualified Data.Graph as G import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Mutable as VM import qualified Text.Regex as Regex @@ -76,6 +78,9 @@ instance Show RegexWrapper where     show (RegexWrapper _ x) = show x +instance NFData RegexWrapper where+  rnf (RegexWrapper _ t) = rnf t+ data RouteNode    = RouteNodeRegex !CaptureVar !RegexWrapper    | RouteNodeCapture !CaptureVar@@ -83,62 +88,111 @@    | RouteNodeRoot    deriving (Show, Eq) +instance NFData RouteNode where+  rnf (RouteNodeRegex v w) = rnf v `seq` rnf w+  rnf (RouteNodeCapture v) = rnf v+  rnf (RouteNodeText t) = rnf t+  rnf RouteNodeRoot = ()+ data RouteData a    = RouteData    { rd_node :: !RouteNode-   , rd_data :: Maybe a+   , rd_data :: !(V.Vector a)    }    deriving (Show, Eq) +instance NFData a => NFData (RouteData a) where+  rnf (RouteData n d) = rnf n `seq` rnf d+ data RoutingTree a    = RoutingTree-   { rt_node :: !(RouteData a)-   , rt_children :: !(V.Vector (RoutingTree a))-   }-   deriving (Show, Eq)+   { rm_graph :: G.Graph+   , rm_nodeManager :: V.Vector (RouteData a)+   , rm_rootNode :: G.Node+   } deriving (Show, Eq) -buildRegex :: T.Text -> RegexWrapper-buildRegex t =-    RegexWrapper (Regex.mkRegex $ T.unpack t) t+instance NFData a => NFData (RoutingTree a) where+  rnf (RoutingTree g v r) = rnf g `seq` rnf v `seq` rnf r  emptyRoutingTree :: RoutingTree a emptyRoutingTree =-    RoutingTree (RouteData RouteNodeRoot Nothing) V.empty+    let rootNode = 0+        nodeManager = V.singleton (RouteData RouteNodeRoot V.empty)+    in RoutingTree (G.addNode rootNode G.empty) nodeManager rootNode -mergeData :: Maybe a -> Maybe a -> Maybe a-mergeData (Just _) (Just _) =-    error "Spock error: Don't define the same route twice!"-mergeData (Just a) _ = Just a-mergeData _ (Just b) = Just b-mergeData _ _ = Nothing+spawnNode :: G.Node -> RouteData a -> RoutingTree a -> (G.Node, RoutingTree a)+spawnNode parent nodeData rm =+    let nm' = V.snoc (rm_nodeManager rm) nodeData+        nodeId = (V.length nm') - 1+        g' = G.addNode nodeId (rm_graph rm)+        g'' = G.addEdge parent nodeId g'+    in (nodeId, RoutingTree g'' nm' (rm_rootNode rm)) +addActionToNode :: G.Node -> a -> RoutingTree a -> RoutingTree a+addActionToNode nodeId nodeAction rm =+    let routeDataOld = (rm_nodeManager rm) V.! nodeId+        routeDataNew =+            routeDataOld+            { rd_data = V.snoc (rd_data routeDataOld) nodeAction+            }+        nm' = V.modify (\v -> VM.write v nodeId routeDataNew) (rm_nodeManager rm)+    in rm { rm_nodeManager = nm' }+ addToRoutingTree :: T.Text -> a -> RoutingTree a -> RoutingTree a-addToRoutingTree route dat currTree =-    let applyTree [] tree = tree-        applyTree (current:xs) tree =-            let children = V.map (\(RoutingTree d _) -> rd_node d) (rt_children tree)-                currentDat =-                    case xs of-                      [] -> Just dat-                      _ -> Nothing-                children' =-                    case V.findIndex (==current) children of-                      Nothing ->-                          let h = applyTree xs $ RoutingTree (RouteData current currentDat) V.empty-                          in V.cons h (rt_children tree)-                      Just idx ->-                          let origNode = (V.!) (rt_children tree) idx-                              matchingNode = rt_node $ origNode-                              appliedNode = matchingNode { rd_data = mergeData (rd_data matchingNode) currentDat }-                          in V.modify (\v -> VM.write v idx (applyTree xs $ RoutingTree appliedNode (rt_children origNode))) (rt_children tree)-            in tree { rt_children = children' }-    in case filter (not . T.null) $ T.splitOn "/" route of-         [] ->-             let currNode = rt_node currTree-                 currNode' = currNode { rd_data = mergeData (rd_data currNode) (Just dat) }-             in currTree { rt_node = currNode' }-         xs -> applyTree (map parseRouteNode xs) currTree+addToRoutingTree route action origRm =+    case chunks of+      [] ->+          addActionToNode (rm_rootNode origRm) action origRm+      _ ->+          treeTraversal (map parseRouteNode chunks) (rm_rootNode origRm) origRm+    where+      chunks = filter (not . T.null) $ T.splitOn "/" route+      treeTraversal [] _ rm = rm+      treeTraversal (node : xs) parentGraphNode rm =+          let graph = rm_graph rm+              children = G.children graph parentGraphNode+              nm = rm_nodeManager rm+              matchingChild =+                  VU.find (\nodeId -> node == rd_node (nm V.! nodeId)) children+          in case matchingChild of+               Just childId ->+                   treeTraversal xs childId (if null xs then addActionToNode childId action rm else rm)+               Nothing ->+                   let (childId, rm') =+                           spawnNode parentGraphNode (RouteData node (if null xs then V.singleton action else V.empty)) rm+                   in treeTraversal xs childId rm' +matchRoute :: T.Text -> RoutingTree a -> [(ParamMap, a)]+matchRoute route globalMap =+    matchRoute' (T.splitOn "/" route) globalMap++matchRoute' :: [T.Text] -> RoutingTree a -> [(ParamMap, a)]+matchRoute' routeParts globalRm =+    findRoute (filter (not . T.null) routeParts) (rm_rootNode globalRm) emptyParamMap []+    where+      globalGraph = rm_graph globalRm+      nodeManager = rm_nodeManager globalRm++      findRoute [] parentId paramMap outMap =+          outMap ++ (V.toList $ V.map (\action -> (paramMap, action)) (rd_data (nodeManager V.! parentId)))+      findRoute (chunk : xs) parentId paramMap outMap =+          let children = G.children globalGraph parentId+          in VU.foldl' (\outV nodeId ->+                           case matchNode chunk (rd_node $ nodeManager V.! nodeId) of+                             (False, _) -> outV+                             (True, mCapture) ->+                                 let paramMap' =+                                         case mCapture of+                                           Nothing -> paramMap+                                           Just (var, val) ->+                                               HM.insert var val paramMap+                                 in (findRoute xs nodeId paramMap' outMap) ++ outV+                      ) [] children++buildRegex :: T.Text -> RegexWrapper+buildRegex t =+    RegexWrapper (Regex.mkRegex $ T.unpack t) t+ parseRouteNode :: T.Text -> RouteNode parseRouteNode node =     case T.uncons node of@@ -163,48 +217,6 @@  emptyParamMap :: ParamMap emptyParamMap = HM.empty--matchRoute :: T.Text -> RoutingTree a -> [(ParamMap, a)]-matchRoute route globalTree =-    matchRoute' (T.splitOn "/" route) globalTree--matchRoute' :: [T.Text] -> RoutingTree a -> [(ParamMap, a)]-matchRoute' routeParts globalTree =-    case filter (not . T.null) routeParts of-      [] ->-          case rd_data $ rt_node globalTree of-            Nothing -> []-            Just action -> [(emptyParamMap, action)]-      xs ->-          findRoute xs (rt_children globalTree)-    where-      findRoute :: [T.Text] -> V.Vector (RoutingTree a) -> [(ParamMap, a)]-      findRoute fullPath trees =-          let foundPaths = V.foldl' (matchTree fullPath emptyParamMap) V.empty trees-          in V.toList foundPaths-          where-            matchTree :: [T.Text] -> ParamMap -> V.Vector (ParamMap, a) -> RoutingTree a -> V.Vector (ParamMap, a)-            matchTree [] _ vec _ = vec-            matchTree (textNode : xs) paramMap vec rt =-                case matchNode textNode (rd_node $ rt_node rt) of-                  (False, _) ->-                      vec-                  (True, mCapture) ->-                      let paramMap' =-                              case mCapture of-                                Nothing -> paramMap-                                Just (var, value) ->-                                    HM.insert var value paramMap-                          nodeData = rd_data $ rt_node rt-                          nodeChildren = rt_children rt-                      in case xs of-                           [] | isJust nodeData ->-                                  V.snoc vec (paramMap', fromJust nodeData)-                              | otherwise ->-                                  vec-                           _ ->-                               let foundPaths = V.foldl' (matchTree xs paramMap') V.empty nodeChildren-                               in V.concat [foundPaths, vec]  matchNode :: T.Text -> RouteNode -> (Bool, Maybe (CaptureVar, T.Text)) matchNode _ RouteNodeRoot = (False, Nothing)