Title: Experimental, 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