Unified parsing and dispatching code (still ugly)

yesod-routes/Yesod/Routes/Dispatch.lhs

@@ -1,323 +0,0 @@
-Title: Optimized route dispatch code
-
-Let's start with our module declaration and imports.
-
-> module Yesod.Routes.Dispatch
->     ( Piece (..)
->     , Route (..)
->     , Dispatch
->     , toDispatch
->     ) where
->
-> import Data.Text (Text)
-> import qualified Data.Vector as V
-> import Data.Maybe (fromMaybe, mapMaybe)
-> import qualified Data.Map as Map
-> import Data.List (sortBy)
-> import Data.Ord (comparing)
-> import Control.Arrow (second)
-> import Control.Exception (assert)
-
-This module provides an efficient routing system. The code is pure, requires no
-fancy extensions, has no Template Haskell involved and is not Yesod specific.
-It does, however, assume a routing system similar to that of Yesod.
-
-Routing works based on splitting up a path into its components. This is handled
-very well by both the web-routes and http-types packages, and this module does
-not duplicate that functionality. Instead, it assumes that the requested path
-will be provided as a list of 'Text's.
-
-A route will be specified by a list of pieces (using the 'Piece' datatype).
-
-> data Piece = Static Text | Dynamic
-
-Each piece is either a static piece- which is required to match a component of
-the path precisely- or a dynamic piece, which will match any component.
-Additionally, a route can optionally match all remaining components in the
-path, or fail if extra components exist.
-
-Usually, the behavior of dynamic is not what you really want. Often times, you
-will want to match integers, or slugs, or some other limited format. This
-brings us nicely to the dispatch function. Each route provides a function of
-type:
-
-> type Dispatch res = [Text] -> Maybe res
-
-The res argument is application-specific. For example, in a simple
-WAI application, it could be the Application datatype. The important
-thing to point out about Dispatch is that is takes a list of 'Text's and
-returns its response in a Maybe. This gives you a chance to have
-finer-grained control over how individual components are parsed. If you don't
-want to deal with it, you return 'Nothing' and routing continues.
-
-Note: You do *not* need to perform any checking on your static pieces, this
-module handles that for you automatically.
-
-So each route is specified by:
-
-> data Route res = Route
->     { rhPieces :: [Piece]
->     , rhHasMulti :: Bool
->     , rhDispatch :: Dispatch res
->     }
-
-Your application needs to provide this module with a list of routes, and then
-this module will give you back a new dispatch function. In other words:
-
-> toDispatch :: [Route res] -> Dispatch res
-> toDispatch rhs =
->     bcToDispatch bc
->   where
->     bc = toBC rhs
-
-In addition to the requirements listed above for routing, we add one extra
-rule: your specified list of routes is treated as ordered, with the earlier
-ones matching first. If you have an overlap between two routes, the first one
-will be dispatched.
-
-The simplest approach would be to loop through all of your routes and compare
-against the path components. But this has linear complexity. Many existing
-frameworks (Rails and Django at least) have such algorithms, usually based on
-regular expressions. But we can provide two optimizations:
-
-* Break up routes based on how many components they can match. We can then
-  select which group of routes to continue testing. This lookup runs in
-  constant time.
-
-* Use a Map to reduce string comparisons for each route to logarithmic
-  complexity.
-
-Let's start with the first one. Each route has a fixed number of pieces. Let's
-call this *n*. If that route can also match trailing components (rhHasMulti
-above), then it will match *n* and up. Otherwise, it will match specifically on
-*n*.
-
-If *max(n)* is the maximum value of *n* for all routes, what we need is
-(*max(n)* + 2) groups: a zero group (matching a request for the root of the
-application), 1 - *max(n)* groups, and a final extra group containing all
-routes that can match more than *max(n)* components. This group will consist of
-all the routes with rhHasMulti, and only those routes.
-
-> data ByCount res = ByCount
->     { bcVector :: !(V.Vector (PieceMap res))
->     , bcRest :: !(PieceMap res)
->     }
-
-We haven't covered PieceMap yet; it is used for the second optimization. We'll
-discuss it below.
-
-The following function breaks up a list of routes into groups. Again, please
-ignore the PieceMap references for the moment.
-
-> toBC :: [Route res] -> ByCount res
-> toBC rhs =
->     ByCount
->         { bcVector = groups
->         , bcRest = allMultis
->         }
->   where
-
-Determine the value of *max(n)*.
-
->     maxLen
->       | null rhs = 0
->       | otherwise = maximum $ map (length . rhPieces) rhs
-
-Get the list of all routes which can have multis. This will make up the *rest*
-group.
-
->     allMultis = toPieceMap maxLen $ filter rhHasMulti rhs
-
-And now get all the numbered groups. For each group, we need to get all routes
-with *n* components, __and__ all routes with less than *n* components and that
-have rhHasMulti set to True.
-
->     groups = V.map group $ V.enumFromN 0 (maxLen + 1)
->     group i = toPieceMap i $ filter (canHaveLength i) rhs
->
->     canHaveLength :: Int -> Route res -> Bool
->     canHaveLength i rh =
->         len == i || (len < i && rhHasMulti rh)
->       where
->         len = length $ rhPieces rh
-
-Next we'll set up our routing by maps. What we need is a bunch of nested Maps.
-For example, if we have the following routings:
-
-    /foo/bar/1
-    /foo/baz/2
-
-We would want something that looks vaguely like:
-
-    /foo
-        /bar
-            /1
-        /baz
-            /2
-
-But there's an added complication: we need to deal with dynamic compnents and HasMulti as well. So what we'd really have is routes looking like:
-
-    /foo/bar/1
-    /foo/baz/2
-    /*dynamic*/bin/3
-    /multi/*bunch of multis*
-
-We can actually simplify away the multi business. Remember that for each group,
-we will have a fixed number of components to match. In the list above, it's
-three. Even though the last route only has one component, we can actually just
-fill up the missing components with *dynamic*, which will give the same result
-for routing. In other words, we'll treat it as:
-
-    /foo
-        /bar
-            /1
-        /baz
-            /2
-    /*dynamic*
-        /bin
-            /3
-    /multi
-        /*dynamic*
-            /*dynamic*
-
-What we need is then two extra features on our datatype:
-
-* Support both a 'Map Text PieceMap' for static pieces, and a general
-  'PieceMap' for all dynamic pieces.
-
-* An extra constructive after we've gone three levels deep, to provide all
-  matching routes.
-
-What we end up with is:
-
-> data PieceMap res = PieceMap
->     { pmDynamic :: PieceMap res
->     , pmStatic :: Map.Map Text (PieceMap res)
->     } | PieceMapEnd [(Int, Dispatch res)]
-
-Note that the PieceMapEnd is a list of pairs, including an Int. Since the map
-process will confuse the original order of our routes, we need some way to get
-that back to make sure overlapping is handled correctly.
-
-We'll need two pieces of information to make a PieceMap: the depth to drill
-down to, and the routes in the current group. We'll immediately zip up those
-routes with an Int to indicate route priority.
-
-> toPieceMap :: Int -> [Route res] -> PieceMap res
-> toPieceMap depth = toPieceMap' depth . zip [1..]
->
-> toPieceMap' :: Int
->             -> [(Int, Route res)]
->             -> PieceMap res
-
-The stopping case: we've exhausted the full depth, so let's put together a
-PieceMapEnd. Technically speaking, the sort here is unnecessary, since we'll
-sort again later. However, that second sorting occurs during each dispatch
-occurrence, whereas this sorting only occurs once, in the initial construction
-of the PieceMap. Therefore, we presort here.
-
-> toPieceMap' 0 rhs =
->     PieceMapEnd $ map (second rhDispatch)
->                 $ sortBy (comparing fst) rhs
-
-Note also that we apply rhDispatch to the route. We are no longer interested in
-the rest of the route information, so it can be discarded.
-
-Now the heart of this algorithm: we construct the pmDynamic and pmStatic
-records. For both, we recursively call toPieceMap' again, with the depth
-knocked down by 1.
-
-> toPieceMap' depth rhs = PieceMap
->     { pmDynamic = toPieceMap' depth' dynamics
->     , pmStatic = Map.map (toPieceMap' depth') statics
->     }
->   where
->     depth' = depth - 1
-
-We turn our list of routes into a list of pairs. The first item in the pair
-gives the next piece, and the second gives the route again, minus that piece.
-
->     pairs = map toPair rhs
->     toPair (i, Route (p:ps) b c) = (p, (i, Route ps b c))
-
-And as we mentioned above, for multi pieces we fill in the remaining pieces
-with Dynamic.
-
->     toPair (i, Route [] b c) = assert b (Dynamic, (i, Route [] b c))
-
-Next, we break up our list of dynamics.
-
->     getDynamic (Dynamic, rh) = Just rh
->     getDynamic _ = Nothing
->     dynamics = mapMaybe getDynamic pairs
-
-And now we make a Map for statics. Note that Map.fromList would not be
-appropriate here, since it would only keep one route per Text.
-
->     getStatic (Static t, rh) = Just $ Map.singleton t [rh]
->     getStatic _ = Nothing
->     statics = Map.unionsWith (++) $ mapMaybe getStatic pairs
-
-The time has come to actually dispatch.
-
-> bcToDispatch :: ByCount res -> Dispatch res
-> bcToDispatch (ByCount vec rest) ts0 =
->     bcToDispatch' ts0 pm0
->   where
-
-Get the PieceMap for the appropriate group. If the length of the requested path
-is greater than *max(n)*, then use the "rest" group.
-
->     pm0 = fromMaybe rest $ vec V.!? length ts0
-
-Stopping case: we've found our list of routes. Sort them, then starting
-applying their dispatch functions. If the first one returns Nothing, go to the
-next, and so on.
-
->     bcToDispatch' _ (PieceMapEnd r) = firstJust (\f -> f ts0) $ map snd r
-
-For each component, get the static PieceMap and the dynamic one, combine them
-together, and then continue dispatching.
-
->     bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $
->         case Map.lookup t sta of
->             Nothing -> dyn
->             Just pm -> append dyn pm
-
-Handle an impossible case that should never happen.
-
->     bcToDispatch' [] _ = assert False Nothing
-
-Helper function: get the first Just response.
-
-> firstJust :: (a -> Maybe b) -> [a] -> Maybe b
-> firstJust _ [] = Nothing
-> firstJust f (a:as) = maybe (firstJust f as) Just $ f a
-
-Combine two PieceMaps together.
-
-> append :: PieceMap res -> PieceMap res -> PieceMap res
-
-At the end, just combine the list of routes. But we combine them in such a way
-so as to preserve their order. Since a and b come presorted (as mentioned
-above), we can just merge the two lists together in linear time.
-
-> append (PieceMapEnd a) (PieceMapEnd b) = PieceMapEnd $ merge a b
-
-Combine the dynamic and static portions of the maps.
-
-> append (PieceMap a x) (PieceMap b y) =
->     PieceMap (append a b) (Map.unionWith append x y)
-
-An impossible case.
-
-> append _ _ = assert False $ PieceMapEnd []
-
-Our O(n) merge.
-
-> merge :: Ord a => [(a, b)] -> [(a, b)] -> [(a, b)]
-> merge x [] = x
-> merge [] y = y
-> merge x@(a@(ai, _):xs) y@(b@(bi, _):ys)
->   | ai < bi   = a : merge xs y
->   | otherwise = b : merge x ys

yesod-routes/Yesod/Routes/TH/ParseRoute.hs

@@ -6,16 +6,17 @@ module Yesod.Routes.TH.ParseRoute
 
 import Yesod.Routes.TH.Types
 import Language.Haskell.TH.Syntax
-import Data.Text (pack)
+import Data.Text (Text, pack)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
-import qualified Yesod.Routes.Dispatch as D
+import Yesod.Routes.TH.Dispatch
 import Data.List (foldl')
 import Control.Applicative ((<$>))
 import Data.Maybe (catMaybes)
 import Control.Monad (forM)
 import Control.Monad (join)
 
+{- FIXME
 -- | Clauses for the 'parseRoute' method.
 mkParseRouteClauses :: [ResourceTree a] -> Q [Clause]
 mkParseRouteClauses ress' = do
@@ -46,13 +47,31 @@ mkParseRouteClauses ress' = do
     noMethods (FlatResource a b c d e) = FlatResource a b c (noMethods' d) e
     noMethods' (Methods a _) = Methods a []
     noMethods' (Subsite a b) = Subsite a b
+-}
 
 mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
 mkParseRouteInstance typ ress = do
-    cls <- mkParseRouteClauses ress
+    cls <- mkDispatchClause
+        MkDispatchSettings
+            { mdsRunHandler = [|\_ _ x _ -> x|]
+            , mds404 = [|error "mds404"|]
+            , mds405 = [|error "mds405"|]
+            , mdsGetPathInfo = [|fst|]
+            , mdsMethod = [|const ("GET" :: Text)|] -- FIXME wouldn't it be nice to get rid of method dispatching here
+            , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|]
+            , mdsSetPathInfo = [|\p (_, q) -> (p, q)|]
+            , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env (p, q) -> fmap toMaster (parseRoute (p :: [Text], q :: [(Text, Text)]))|]
+            }
+        ress
+    helper <- newName "helper"
+    fixer <- [|(\f x -> f () x) :: (() -> ([Text], [(Text, Text)]) -> Maybe (Route a)) -> ([Text], [(Text, Text)]) -> Maybe (Route a)|]
     return $ InstanceD [] (ConT ''ParseRoute `AppT` typ)
-        [ FunD 'parseRoute cls
+        [ FunD 'parseRoute $ return $ Clause
+            []
+            (NormalB $ fixer `AppE` VarE helper)
+            [FunD helper [cls]]
         ]
+        {- FIXME
 
 -- | Build a single 'D.Route' expression.
 buildRoute :: Name -> FlatResource a -> Q Exp
@@ -176,3 +195,4 @@ routeFromDynamics ((parent, pieces):rest) name ys =
     isDynamic Dynamic{} = True
     isDynamic _ = False
     here = map VarE here' ++ [routeFromDynamics rest name ys']
+-}

yesod-routes/test/Hierarchy.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -ddump-splices #-}
 module Hierarchy
     ( hierarchy
     , Dispatcher (..)

yesod-routes/test/main.hs

@@ -15,10 +15,8 @@
 import Test.Hspec
 import Test.HUnit ((@?=))
 import Data.Text (Text, pack, unpack, singleton)
-import Yesod.Routes.Dispatch hiding (Static, Dynamic)
 import Yesod.Routes.Class hiding (Route)
 import qualified Yesod.Routes.Class as YRC
-import qualified Yesod.Routes.Dispatch as D
 import Yesod.Routes.Parse (parseRoutesNoCheck, parseTypeTree, TypeTree (..))
 import Yesod.Routes.Overlap (findOverlapNames)
 import Yesod.Routes.TH hiding (Dispatch)
@@ -27,48 +25,6 @@ import Hierarchy
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.Set as Set
 
-result :: ([Text] -> Maybe Int) -> Dispatch Int
-result f ts = f ts
-
-justRoot :: Dispatch Int
-justRoot = toDispatch
-    [ Route [] False $ result $ const $ Just 1
-    ]
-
-twoStatics :: Dispatch Int
-twoStatics = toDispatch
-    [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 2
-    , Route [D.Static $ pack "bar"] False $ result $ const $ Just 3
-    ]
-
-multi :: Dispatch Int
-multi = toDispatch
-    [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 4
-    , Route [D.Static $ pack "bar"] True $ result $ const $ Just 5
-    ]
-
-dynamic :: Dispatch Int
-dynamic = toDispatch
-    [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 6
-    , Route [D.Dynamic] False $ result $ \ts ->
-        case ts of
-            [t] ->
-                case reads $ unpack t of
-                    [] -> Nothing
-                    (i, _):_ -> Just i
-            _ -> error $ "Called dynamic with: " ++ show ts
-    ]
-
-overlap :: Dispatch Int
-overlap = toDispatch
-    [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 20
-    , Route [D.Static $ pack "foo"] True $ result $ const $ Just 21
-    , Route [] True $ result $ const $ Just 22
-    ]
-
-test :: Dispatch Int -> [String] -> Maybe Int
-test dispatch ts = dispatch $ map pack ts
-
 data MyApp = MyApp
 
 data MySub = MySub
@@ -235,33 +191,6 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
 
 main :: IO ()
 main = hspec $ do
-    describe "justRoot" $ do
-        it "dispatches correctly" $ test justRoot [] @?= Just 1
-        it "fails correctly" $ test justRoot ["foo"] @?= Nothing
-    describe "twoStatics" $ do
-        it "dispatches correctly to foo" $ test twoStatics ["foo"] @?= Just 2
-        it "dispatches correctly to bar" $ test twoStatics ["bar"] @?= Just 3
-        it "fails correctly (1)" $ test twoStatics [] @?= Nothing
-        it "fails correctly (2)" $ test twoStatics ["bar", "baz"] @?= Nothing
-    describe "multi" $ do
-        it "dispatches correctly to foo" $ test multi ["foo"] @?= Just 4
-        it "dispatches correctly to bar" $ test multi ["bar"] @?= Just 5
-        it "dispatches correctly to bar/baz" $ test multi ["bar", "baz"] @?= Just 5
-        it "fails correctly (1)" $ test multi [] @?= Nothing
-        it "fails correctly (2)" $ test multi ["foo", "baz"] @?= Nothing
-    describe "dynamic" $ do
-        it "dispatches correctly to foo" $ test dynamic ["foo"] @?= Just 6
-        it "dispatches correctly to 7" $ test dynamic ["7"] @?= Just 7
-        it "dispatches correctly to 42" $ test dynamic ["42"] @?= Just 42
-        it "fails correctly on five" $ test dynamic ["five"] @?= Nothing
-        it "fails correctly on too many" $ test dynamic ["foo", "baz"] @?= Nothing
-        it "fails correctly on too few" $ test dynamic [] @?= Nothing
-    describe "overlap" $ do
-        it "dispatches correctly to foo" $ test overlap ["foo"] @?= Just 20
-        it "dispatches correctly to foo/bar" $ test overlap ["foo", "bar"] @?= Just 21
-        it "dispatches correctly to bar" $ test overlap ["bar"] @?= Just 22
-        it "dispatches correctly to []" $ test overlap [] @?= Just 22
-
     describe "RenderRoute instance" $ do
         it "renders root correctly" $ renderRoute RootR @?= ([], [])
         it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], [])

yesod-routes/yesod-routes.cabal

@@ -24,8 +24,7 @@ library
                    , bytestring
                    , random
 
-    exposed-modules: Yesod.Routes.Dispatch
+    exposed-modules: Yesod.Routes.TH
-                     Yesod.Routes.TH
                      Yesod.Routes.Class
                      Yesod.Routes.Parse
                      Yesod.Routes.Overlap