Removed some Yesod-specific components (simplified)

yesod-routes/Yesod/Routes.hs

@@ -1,13 +1,11 @@
 module Yesod.Routes
     ( Piece (..)
     , RouteHandler (..)
-    , toDispatch
     , Dispatch
+    , toDispatch
     ) where
 
 import Data.Text (Text)
-import Web.ClientSession (Key)
-import Yesod.Core (Route)
 import qualified Data.Vector as V
 import Data.Maybe (fromMaybe, mapMaybe)
 import qualified Data.Map as Map
@@ -16,45 +14,41 @@ import Data.Ord (comparing)
 import Control.Arrow (second)
 
 data Piece = StaticPiece Text | SinglePiece
+type Dispatch req res = [Text] -> req -> Maybe res
 
-data RouteHandler sub master res = RouteHandler
+data RouteHandler req res = RouteHandler
     { rhPieces :: [Piece]
     , rhHasMulti :: Bool
-    , rhHandler :: Dispatch sub master res
+    , rhDispatch :: Dispatch req res
     }
 
-type Dispatch sub master res = sub -> Maybe Key -> [Text] -> master -> (Route sub -> Route master) -> Maybe res
+toDispatch :: [RouteHandler req res] -> [Text] -> req -> Maybe res
-
-toDispatch :: [RouteHandler sub master res] -> Dispatch sub master res
 toDispatch rhs =
     bcToDispatch bc
   where
     bc = toBC rhs
 
-bcToDispatch :: ByCount sub master res -> Dispatch sub master res
+bcToDispatch :: ByCount req res -> Dispatch req res
-bcToDispatch (ByCount vec rest) sub mkey ts master toMaster =
+bcToDispatch (ByCount vec rest) ts0 req =
-    go (\x -> x sub mkey ts master toMaster) ts pm
+    bcToDispatch' ts0 pm0
   where
-    --pm :: PieceMap sub master res
+    --pm0 :: PieceMap sub master res
-    pm = fromMaybe rest $ vec V.!? length ts
+    pm0 = fromMaybe rest $ vec V.!? length ts0
 
-go :: (Dispatch sub master res -> Maybe res)
+    --bcToDispatch' :: [Text] -> PieceMap req res -> Maybe res
-   -> [Text]
+    bcToDispatch' _ (PieceMapEnd r) =
-   -> PieceMap sub master res
+        firstJust (\f -> f ts0 req) $ map snd $ sortBy (comparing fst) r
-   -> Maybe res
+    bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $
-go runDispatch _ (PieceMapEnd r) =
+        case Map.lookup t sta of
-    firstJust runDispatch $ map snd $ sortBy (comparing fst) r
+            Nothing -> dyn
-go runDispatch (t:ts) (PieceMap dyn sta) = go runDispatch ts $
+            Just pm -> append dyn pm
-    case Map.lookup t sta of
+    bcToDispatch' [] _ = Nothing
-        Nothing -> dyn
-        Just pm -> append dyn pm
-go _ [] _ = Nothing
 
 firstJust :: (a -> Maybe b) -> [a] -> Maybe b
 firstJust _ [] = Nothing
 firstJust f (a:as) = maybe (firstJust f as) Just $ f a
 
-append :: PieceMap a b c -> PieceMap a b c -> PieceMap a b c
+append :: PieceMap a b -> PieceMap a b -> PieceMap a b
 append (PieceMapEnd a) (PieceMapEnd b) = PieceMapEnd $ a ++ b
 append (PieceMap a x) (PieceMap b y) =
     PieceMap (append a b) (Map.unionWith append x y)
@@ -62,19 +56,19 @@ append (PieceMap a x) (PieceMap b y) =
 -- to ensure this never happens.
 append _ _ = error "Mismatched PieceMaps for append"
 
-data PieceMap sub master res = PieceMap
+data PieceMap req res = PieceMap
-    { pmDynamic :: PieceMap sub master res
+    { pmDynamic :: PieceMap req res
-    , pmStatic :: Map.Map Text (PieceMap sub master res)
+    , pmStatic :: Map.Map Text (PieceMap req res)
-    } | PieceMapEnd [(Int, Dispatch sub master res)]
+    } | PieceMapEnd [(Int, Dispatch req res)]
 
-toPieceMap :: Int -> [RouteHandler sub master res] -> PieceMap sub master res
+toPieceMap :: Int -> [RouteHandler req res] -> PieceMap req res
 toPieceMap depth = toPieceMap' depth . zip [1..]
 
 toPieceMap' :: Int
-            -> [(Int, RouteHandler sub master res)]
+            -> [(Int, RouteHandler req res)]
-            -> PieceMap sub master res
+            -> PieceMap req res
 toPieceMap' 0 rhs =
-    PieceMapEnd $ map (second rhHandler)
+    PieceMapEnd $ map (second rhDispatch)
                 $ sortBy (comparing fst) rhs
 toPieceMap' depth rhs = PieceMap
     { pmDynamic = toPieceMap' depth' dynamics
@@ -97,12 +91,12 @@ toPieceMap' depth rhs = PieceMap
     getStatic _ = Nothing
     statics = Map.unionsWith (++) $ mapMaybe getStatic pairs
 
-data ByCount sub master res = ByCount
+data ByCount req res = ByCount
-    { bcVector :: !(V.Vector (PieceMap sub master res))
+    { bcVector :: !(V.Vector (PieceMap req res))
-    , bcRest :: !(PieceMap sub master res)
+    , bcRest :: !(PieceMap req res)
     }
 
-toBC :: [RouteHandler sub master res] -> ByCount sub master res
+toBC :: [RouteHandler req res] -> ByCount req res
 toBC rhs =
     ByCount
         { bcVector = V.map (\i -> toPieceMap i $ filter (canHaveLength i) rhs)

yesod-routes/test/main.hs

@@ -5,29 +5,27 @@ import Test.HUnit ((@?=))
 import Data.Text (Text, unpack)
 import Yesod.Routes
 
-data Dummy = Dummy
+result :: ([Text] -> Maybe Int) -> Dispatch () Int
+result f ts () = f ts
 
-result :: ([Text] -> Maybe Int) -> Dispatch sub master Int
+justRoot :: Dispatch () Int
-result f _ _ ts _ _ = f ts
-
-justRoot :: Dispatch Dummy Dummy Int
 justRoot = toDispatch
     [ RouteHandler [] False $ result $ const $ Just 1
     ]
 
-twoStatics :: Dispatch Dummy Dummy Int
+twoStatics :: Dispatch () Int
 twoStatics = toDispatch
     [ RouteHandler [StaticPiece "foo"] False $ result $ const $ Just 2
     , RouteHandler [StaticPiece "bar"] False $ result $ const $ Just 3
     ]
 
-multi :: Dispatch Dummy Dummy Int
+multi :: Dispatch () Int
 multi = toDispatch
     [ RouteHandler [StaticPiece "foo"] False $ result $ const $ Just 4
     , RouteHandler [StaticPiece "bar"] True $ result $ const $ Just 5
     ]
 
-dynamic :: Dispatch Dummy Dummy Int
+dynamic :: Dispatch () Int
 dynamic = toDispatch
     [ RouteHandler [StaticPiece "foo"] False $ result $ const $ Just 6
     , RouteHandler [SinglePiece] False $ result $ \ts ->
@@ -39,15 +37,15 @@ dynamic = toDispatch
             _ -> error $ "Called dynamic with: " ++ show ts
     ]
 
-overlap :: Dispatch Dummy Dummy Int
+overlap :: Dispatch () Int
 overlap = toDispatch
     [ RouteHandler [StaticPiece "foo"] False $ result $ const $ Just 20
     , RouteHandler [StaticPiece "foo"] True $ result $ const $ Just 21
     , RouteHandler [] True $ result $ const $ Just 22
     ]
 
-test :: Dispatch Dummy Dummy Int -> [Text] -> Maybe Int
+test :: Dispatch () Int -> [Text] -> Maybe Int
-test dispatch ts = dispatch Dummy Nothing ts Dummy id
+test dispatch ts = dispatch ts ()
 
 main :: IO ()
 main = hspecX $ do