From 3178a584d010929307c97b4927a9cbd020929722 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 28 Sep 2011 10:42:14 +0300
Subject: [PATCH 01/28] Initial yesod-routes, doesn't do much yet

---
 yesod-routes/LICENSE            | 25 +++++++++++++++
 yesod-routes/Setup.lhs          |  7 ++++
 yesod-routes/Yesod/Routes.hs    | 57 +++++++++++++++++++++++++++++++++
 yesod-routes/test/main.hs       | 25 +++++++++++++++
 yesod-routes/yesod-routes.cabal | 39 ++++++++++++++++++++++
 5 files changed, 153 insertions(+)
 create mode 100644 yesod-routes/LICENSE
 create mode 100755 yesod-routes/Setup.lhs
 create mode 100644 yesod-routes/Yesod/Routes.hs
 create mode 100644 yesod-routes/test/main.hs
 create mode 100644 yesod-routes/yesod-routes.cabal

diff --git a/yesod-routes/LICENSE b/yesod-routes/LICENSE
new file mode 100644
index 00000000..8643e5d8
--- /dev/null
+++ b/yesod-routes/LICENSE
@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/yesod-routes/Setup.lhs b/yesod-routes/Setup.lhs
new file mode 100755
index 00000000..06e2708f
--- /dev/null
+++ b/yesod-routes/Setup.lhs
@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
diff --git a/yesod-routes/Yesod/Routes.hs b/yesod-routes/Yesod/Routes.hs
new file mode 100644
index 00000000..7a4816fd
--- /dev/null
+++ b/yesod-routes/Yesod/Routes.hs
@@ -0,0 +1,57 @@
+module Yesod.Routes
+    ( Piece (..)
+    , RouteHandler (..)
+    , toDispatch
+    , Dispatch
+    ) where
+
+import Data.Text (Text)
+import Web.ClientSession (Key)
+import Yesod.Core (Route)
+import qualified Data.Vector as V
+import Data.Maybe (fromMaybe)
+
+data Piece = StaticPiece Text | SinglePiece
+
+data RouteHandler sub master res = RouteHandler
+    { rhPieces :: [Piece]
+    , rhHasMulti :: Bool
+    , rhHandler :: Dispatch sub master res
+    }
+
+type Dispatch sub master res = sub -> Maybe Key -> [Text] -> master -> (Route sub -> Route master) -> 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 vec rest) sub mkey ts master toMaster =
+    go rhs
+  where
+    len = length ts
+    rhs = fromMaybe rest $ vec V.!? len
+
+    go [] = Nothing
+    go (x:xs) = maybe (go xs) Just $ rhHandler x sub mkey ts master toMaster
+
+data ByCount sub master res = ByCount
+    { bcVector :: !(V.Vector [RouteHandler sub master res])
+    , bcRest :: ![RouteHandler sub master res]
+    }
+
+toBC :: [RouteHandler sub master res] -> ByCount sub master res
+toBC rhs =
+    ByCount
+        { bcVector = V.map (\i -> filter (canHaveLength i) rhs) $ V.enumFromN 0 (maxLen + 1)
+        , bcRest = filter rhHasMulti rhs
+        }
+  where
+    maxLen = maximum $ map (length . rhPieces) rhs
+
+    canHaveLength i rh =
+        len == i || (len < i && rhHasMulti rh)
+      where
+        len = length $ rhPieces rh
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
new file mode 100644
index 00000000..f2726638
--- /dev/null
+++ b/yesod-routes/test/main.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+import Test.Hspec.Monadic
+import Test.Hspec.HUnit ()
+import Test.HUnit ((@?=))
+import Data.Text (Text)
+import Yesod.Routes
+
+data Dummy = Dummy
+
+result :: ([Text] -> Maybe Int) -> Dispatch sub master Int
+result f _ _ ts _ _ = f ts
+
+justRoot :: Dispatch Dummy Dummy Int
+justRoot = toDispatch
+    [ RouteHandler [] False $ result $ const $ Just 1
+    ]
+
+test :: Dispatch Dummy Dummy Int -> [Text] -> Maybe Int
+test dispatch ts = dispatch Dummy Nothing ts Dummy id
+
+main :: IO ()
+main = hspecX $ do
+    describe "justRoot" $ do
+        it "dispatches correctly" $ test justRoot [] @?= Just 1
+        it "fails correctly" $ test justRoot ["foo"] @?= Nothing
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
new file mode 100644
index 00000000..6627ff50
--- /dev/null
+++ b/yesod-routes/yesod-routes.cabal
@@ -0,0 +1,39 @@
+name:            yesod-routes
+version:         0.0.0
+license:         BSD3
+license-file:    LICENSE
+author:          Michael Snoyman <michael@snoyman.com>
+maintainer:      Michael Snoyman <michael@snoyman.com>
+synopsis:        Efficient routing for Yesod.
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.8
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+
+library
+    build-depends:   base                      >= 4        && < 5
+                   , yesod-core                >= 0.9.3    && < 0.10
+                   , text                      >= 0.5      && < 0.12
+                   , vector                    >= 0.8      && < 0.10
+                   , clientsession             >= 0.7      && < 0.8
+
+    exposed-modules: Yesod.Routes
+    ghc-options:     -Wall
+
+test-suite runtests
+    type: exitcode-stdio-1.0
+    main-is: main.hs
+    hs-source-dirs: test
+
+    type: exitcode-stdio-1.0
+    build-depends: base                      >= 4.3      && < 5
+                 , yesod-routes
+                 , text                      >= 0.5      && < 0.12
+                 , HUnit                     >= 1.2      && < 1.3
+                 , hspec                     >= 0.6      && < 0.9
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/yesodweb/yesod.git

From 691abb6823b21f3418374d34e94e1caad5a3aa86 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 28 Sep 2011 14:41:21 +0300
Subject: [PATCH 02/28] checkStatics

---
 yesod-routes/Yesod/Routes.hs |  9 ++++++++-
 yesod-routes/test/main.hs    | 23 +++++++++++++++++++++++
 2 files changed, 31 insertions(+), 1 deletion(-)

diff --git a/yesod-routes/Yesod/Routes.hs b/yesod-routes/Yesod/Routes.hs
index 7a4816fd..97423953 100644
--- a/yesod-routes/Yesod/Routes.hs
+++ b/yesod-routes/Yesod/Routes.hs
@@ -35,7 +35,14 @@ bcToDispatch (ByCount vec rest) sub mkey ts master toMaster =
     rhs = fromMaybe rest $ vec V.!? len
 
     go [] = Nothing
-    go (x:xs) = maybe (go xs) Just $ rhHandler x sub mkey ts master toMaster
+    go (x:xs) = maybe (go xs) Just $ if checkStatics ts (rhPieces x) (rhHasMulti x) then rhHandler x sub mkey ts master toMaster else Nothing
+
+    checkStatics [] [] _ = True
+    checkStatics [] _ _ = False
+    checkStatics _ [] isMulti = isMulti
+    checkStatics (_:paths) (SinglePiece:pieces) isMulti = checkStatics paths pieces isMulti
+    checkStatics (path:paths) (StaticPiece piece:pieces) isMulti =
+        path == piece && checkStatics paths pieces isMulti
 
 data ByCount sub master res = ByCount
     { bcVector :: !(V.Vector [RouteHandler sub master res])
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index f2726638..5f628b63 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -15,6 +15,18 @@ justRoot = toDispatch
     [ RouteHandler [] False $ result $ const $ Just 1
     ]
 
+twoStatics :: Dispatch Dummy Dummy 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 = toDispatch
+    [ RouteHandler [StaticPiece "foo"] False $ result $ const $ Just 4
+    , RouteHandler [StaticPiece "bar"] True $ result $ const $ Just 5
+    ]
+
 test :: Dispatch Dummy Dummy Int -> [Text] -> Maybe Int
 test dispatch ts = dispatch Dummy Nothing ts Dummy id
 
@@ -23,3 +35,14 @@ main = hspecX $ 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

From 820adf2971ede75831bc7085b23510c8829d59c6 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 3 Oct 2011 18:03:07 +0200
Subject: [PATCH 03/28] dynamic test

---
 yesod-routes/test/main.hs       | 21 ++++++++++++++++++++-
 yesod-routes/yesod-routes.cabal |  2 +-
 2 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 5f628b63..51415e2f 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -2,7 +2,7 @@
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
 import Test.HUnit ((@?=))
-import Data.Text (Text)
+import Data.Text (Text, unpack)
 import Yesod.Routes
 
 data Dummy = Dummy
@@ -27,6 +27,18 @@ multi = toDispatch
     , RouteHandler [StaticPiece "bar"] True $ result $ const $ Just 5
     ]
 
+dynamic :: Dispatch Dummy Dummy Int
+dynamic = toDispatch
+    [ RouteHandler [StaticPiece "foo"] False $ result $ const $ Just 6
+    , RouteHandler [SinglePiece] False $ result $ \ts ->
+        case ts of
+            [t] ->
+                case reads $ unpack t of
+                    [] -> Nothing
+                    (i, _):_ -> Just i
+            _ -> error $ "Called dynamic with: " ++ show ts
+    ]
+
 test :: Dispatch Dummy Dummy Int -> [Text] -> Maybe Int
 test dispatch ts = dispatch Dummy Nothing ts Dummy id
 
@@ -46,3 +58,10 @@ main = hspecX $ do
         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
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 6627ff50..4c05e81f 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -31,7 +31,7 @@ test-suite runtests
                  , yesod-routes
                  , text                      >= 0.5      && < 0.12
                  , HUnit                     >= 1.2      && < 1.3
-                 , hspec                     >= 0.6      && < 0.9
+                 , hspec                     >= 0.6      && < 0.10
     ghc-options:     -Wall
 
 source-repository head

From 619e74dd451a9e593159f905e7c5757a367f7c85 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Wed, 5 Oct 2011 07:19:12 +0200
Subject: [PATCH 04/28] Incomplete route changes

---
 yesod-routes/Yesod/Routes.hs    | 9 +++++++++
 yesod-routes/yesod-routes.cabal | 1 +
 2 files changed, 10 insertions(+)

diff --git a/yesod-routes/Yesod/Routes.hs b/yesod-routes/Yesod/Routes.hs
index 97423953..010014dc 100644
--- a/yesod-routes/Yesod/Routes.hs
+++ b/yesod-routes/Yesod/Routes.hs
@@ -10,6 +10,7 @@ import Web.ClientSession (Key)
 import Yesod.Core (Route)
 import qualified Data.Vector as V
 import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
 
 data Piece = StaticPiece Text | SinglePiece
 
@@ -44,6 +45,14 @@ bcToDispatch (ByCount vec rest) sub mkey ts master toMaster =
     checkStatics (path:paths) (StaticPiece piece:pieces) isMulti =
         path == piece && checkStatics paths pieces isMulti
 
+data PieceMap sub master res = PieceMap
+    { pmHandlers :: Either (PieceMap sub master res) [(Int, RouteHandler sub master res)]
+    , pmStatic :: Map.Map Text (PieceMap sub master res)
+    }
+
+toPieceMap :: [RouteHandler sub master res] -> PieceMap sub master res
+toPieceMap = undefined
+
 data ByCount sub master res = ByCount
     { bcVector :: !(V.Vector [RouteHandler sub master res])
     , bcRest :: ![RouteHandler sub master res]
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 4c05e81f..a960d2e2 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -17,6 +17,7 @@ library
                    , text                      >= 0.5      && < 0.12
                    , vector                    >= 0.8      && < 0.10
                    , clientsession             >= 0.7      && < 0.8
+                   , containers                >= 0.2      && < 0.5
 
     exposed-modules: Yesod.Routes
     ghc-options:     -Wall

From 3ee8e3c7f31d180be2f35dd2545988227d246ef5 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 7 Oct 2011 07:58:01 +0200
Subject: [PATCH 05/28] PieceMap-based dispatch

---
 yesod-routes/Yesod/Routes.hs | 75 +++++++++++++++++++++++++++---------
 1 file changed, 57 insertions(+), 18 deletions(-)

diff --git a/yesod-routes/Yesod/Routes.hs b/yesod-routes/Yesod/Routes.hs
index 010014dc..e0d83318 100644
--- a/yesod-routes/Yesod/Routes.hs
+++ b/yesod-routes/Yesod/Routes.hs
@@ -9,8 +9,11 @@ import Data.Text (Text)
 import Web.ClientSession (Key)
 import Yesod.Core (Route)
 import qualified Data.Vector as V
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, mapMaybe, listToMaybe)
 import qualified Data.Map as Map
+import Data.List (sortBy)
+import Data.Ord (comparing)
+import Control.Arrow (second)
 
 data Piece = StaticPiece Text | SinglePiece
 
@@ -30,39 +33,75 @@ toDispatch rhs =
 
 bcToDispatch :: ByCount sub master res -> Dispatch sub master res
 bcToDispatch (ByCount vec rest) sub mkey ts master toMaster =
-    go rhs
+    case go ts rhs of
+        Nothing -> Nothing
+        Just dispatch -> dispatch sub mkey ts master toMaster
   where
     len = length ts
     rhs = fromMaybe rest $ vec V.!? len
 
-    go [] = Nothing
-    go (x:xs) = maybe (go xs) Just $ if checkStatics ts (rhPieces x) (rhHasMulti x) then rhHandler x sub mkey ts master toMaster else Nothing
+go :: [Text]
+   -> PieceMap sub master res
+   -> Maybe (Dispatch sub master res)
+go _ (PieceMapEnd r) =
+    listToMaybe $ map snd $ sortBy (comparing fst) r
+go (t:ts) (PieceMap dyn sta) = go ts $
+    case Map.lookup t sta of
+        Nothing -> dyn
+        Just pm -> append dyn pm
+go [] _ = Nothing
 
-    checkStatics [] [] _ = True
-    checkStatics [] _ _ = False
-    checkStatics _ [] isMulti = isMulti
-    checkStatics (_:paths) (SinglePiece:pieces) isMulti = checkStatics paths pieces isMulti
-    checkStatics (path:paths) (StaticPiece piece:pieces) isMulti =
-        path == piece && checkStatics paths pieces isMulti
+append :: PieceMap a b c -> PieceMap a b c -> PieceMap a b c
+append (PieceMapEnd a) (PieceMapEnd b) = PieceMapEnd $ a ++ b
+append (PieceMap a x) (PieceMap b y) =
+    PieceMap (append a b) (Map.unionWith append x y)
+append _ _ = error "Mismatched PieceMaps for append"
 
 data PieceMap sub master res = PieceMap
-    { pmHandlers :: Either (PieceMap sub master res) [(Int, RouteHandler sub master res)]
+    { pmDynamic :: PieceMap sub master res
     , pmStatic :: Map.Map Text (PieceMap sub master res)
-    }
+    } | PieceMapEnd [(Int, Dispatch sub master res)]
 
-toPieceMap :: [RouteHandler sub master res] -> PieceMap sub master res
-toPieceMap = undefined
+toPieceMap :: Int -> [RouteHandler sub master res] -> PieceMap sub master res
+toPieceMap depth = toPieceMap' depth . zip [1..]
+
+toPieceMap' :: Int
+            -> [(Int, RouteHandler sub master res)]
+            -> PieceMap sub master res
+toPieceMap' 0 rhs =
+    PieceMapEnd $ take 1
+                $ map (second rhHandler)
+                $ sortBy (comparing fst) rhs
+toPieceMap' depth rhs = PieceMap
+    { pmDynamic = toPieceMap' depth' dynamics
+    , pmStatic = Map.map (toPieceMap' depth') statics
+    }
+  where
+    depth' = depth - 1
+
+    pairs = map toPair rhs
+    toPair (i, RouteHandler (p:ps) b c) = (p, (i, RouteHandler ps b c))
+    toPair _ = error "toPieceMap' received a route with empty pieces"
+
+    getDynamic (SinglePiece, rh) = Just rh
+    getDynamic _ = Nothing
+    dynamics = mapMaybe getDynamic pairs
+
+    getStatic (StaticPiece t, rh) = Just $ Map.singleton t [rh]
+    getStatic _ = Nothing
+    statics = Map.unionsWith (++) $ mapMaybe getStatic pairs
 
 data ByCount sub master res = ByCount
-    { bcVector :: !(V.Vector [RouteHandler sub master res])
-    , bcRest :: ![RouteHandler sub master res]
+    { bcVector :: !(V.Vector (PieceMap sub master res))
+    , bcRest :: !(PieceMap sub master res)
     }
 
 toBC :: [RouteHandler sub master res] -> ByCount sub master res
 toBC rhs =
     ByCount
-        { bcVector = V.map (\i -> filter (canHaveLength i) rhs) $ V.enumFromN 0 (maxLen + 1)
-        , bcRest = filter rhHasMulti rhs
+        { bcVector = V.map (\i -> toPieceMap i $ filter (canHaveLength i) rhs)
+                   $ V.enumFromN 0 (maxLen + 1)
+        , bcRest = toPieceMap maxLen $ filter rhHasMulti rhs
         }
   where
     maxLen = maximum $ map (length . rhPieces) rhs

From fbf58cbc95e065084123feec0adc5bb23427cb38 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 7 Oct 2011 08:22:27 +0200
Subject: [PATCH 06/28] Better overlapping support

---
 yesod-routes/Yesod/Routes.hs | 36 +++++++++++++++++++++---------------
 yesod-routes/test/main.hs    | 12 ++++++++++++
 2 files changed, 33 insertions(+), 15 deletions(-)

diff --git a/yesod-routes/Yesod/Routes.hs b/yesod-routes/Yesod/Routes.hs
index e0d83318..4ab1a906 100644
--- a/yesod-routes/Yesod/Routes.hs
+++ b/yesod-routes/Yesod/Routes.hs
@@ -9,7 +9,7 @@ import Data.Text (Text)
 import Web.ClientSession (Key)
 import Yesod.Core (Route)
 import qualified Data.Vector as V
-import Data.Maybe (fromMaybe, mapMaybe, listToMaybe)
+import Data.Maybe (fromMaybe, mapMaybe)
 import qualified Data.Map as Map
 import Data.List (sortBy)
 import Data.Ord (comparing)
@@ -33,28 +33,33 @@ toDispatch rhs =
 
 bcToDispatch :: ByCount sub master res -> Dispatch sub master res
 bcToDispatch (ByCount vec rest) sub mkey ts master toMaster =
-    case go ts rhs of
-        Nothing -> Nothing
-        Just dispatch -> dispatch sub mkey ts master toMaster
+    go (\x -> x sub mkey ts master toMaster) ts pm
   where
-    len = length ts
-    rhs = fromMaybe rest $ vec V.!? len
+    --pm :: PieceMap sub master res
+    pm = fromMaybe rest $ vec V.!? length ts
 
-go :: [Text]
+go :: (Dispatch sub master res -> Maybe res)
+   -> [Text]
    -> PieceMap sub master res
-   -> Maybe (Dispatch sub master res)
-go _ (PieceMapEnd r) =
-    listToMaybe $ map snd $ sortBy (comparing fst) r
-go (t:ts) (PieceMap dyn sta) = go ts $
+   -> Maybe res
+go runDispatch _ (PieceMapEnd r) =
+    firstJust runDispatch $ map snd $ sortBy (comparing fst) r
+go runDispatch (t:ts) (PieceMap dyn sta) = go runDispatch ts $
     case Map.lookup t sta of
         Nothing -> dyn
         Just pm -> append dyn pm
-go [] _ = Nothing
+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 (PieceMapEnd a) (PieceMapEnd b) = PieceMapEnd $ a ++ b
 append (PieceMap a x) (PieceMap b y) =
     PieceMap (append a b) (Map.unionWith append x y)
+-- I'm sure there's some nice type-level trickery we could employ here somehow
+-- to ensure this never happens.
 append _ _ = error "Mismatched PieceMaps for append"
 
 data PieceMap sub master res = PieceMap
@@ -69,8 +74,7 @@ toPieceMap' :: Int
             -> [(Int, RouteHandler sub master res)]
             -> PieceMap sub master res
 toPieceMap' 0 rhs =
-    PieceMapEnd $ take 1
-                $ map (second rhHandler)
+    PieceMapEnd $ map (second rhHandler)
                 $ sortBy (comparing fst) rhs
 toPieceMap' depth rhs = PieceMap
     { pmDynamic = toPieceMap' depth' dynamics
@@ -81,7 +85,9 @@ toPieceMap' depth rhs = PieceMap
 
     pairs = map toPair rhs
     toPair (i, RouteHandler (p:ps) b c) = (p, (i, RouteHandler ps b c))
-    toPair _ = error "toPieceMap' received a route with empty pieces"
+    -- if we have no more pieces, that means this is a rhHasMulti, so fill in
+    -- with dynamic
+    toPair (i, RouteHandler [] b c) = (SinglePiece, (i, RouteHandler [] b c))
 
     getDynamic (SinglePiece, rh) = Just rh
     getDynamic _ = Nothing
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 51415e2f..7abce23b 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -39,6 +39,13 @@ dynamic = toDispatch
             _ -> error $ "Called dynamic with: " ++ show ts
     ]
 
+overlap :: Dispatch Dummy Dummy 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 ts = dispatch Dummy Nothing ts Dummy id
 
@@ -65,3 +72,8 @@ main = hspecX $ do
         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

From 29a9bfd7e89e2d2eccd1cc611655a43d8f728098 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 7 Oct 2011 09:29:33 +0200
Subject: [PATCH 07/28] Removed some Yesod-specific components (simplified)

---
 yesod-routes/Yesod/Routes.hs | 68 ++++++++++++++++--------------------
 yesod-routes/test/main.hs    | 20 +++++------
 2 files changed, 40 insertions(+), 48 deletions(-)

diff --git a/yesod-routes/Yesod/Routes.hs b/yesod-routes/Yesod/Routes.hs
index 4ab1a906..99b4be65 100644
--- a/yesod-routes/Yesod/Routes.hs
+++ b/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 sub master res] -> Dispatch sub master res
+toDispatch :: [RouteHandler req res] -> [Text] -> req -> Maybe res
 toDispatch rhs =
     bcToDispatch bc
   where
     bc = toBC rhs
 
-bcToDispatch :: ByCount sub master res -> Dispatch sub master res
-bcToDispatch (ByCount vec rest) sub mkey ts master toMaster =
-    go (\x -> x sub mkey ts master toMaster) ts pm
+bcToDispatch :: ByCount req res -> Dispatch req res
+bcToDispatch (ByCount vec rest) ts0 req =
+    bcToDispatch' ts0 pm0
   where
-    --pm :: PieceMap sub master res
-    pm = fromMaybe rest $ vec V.!? length ts
+    --pm0 :: PieceMap sub master res
+    pm0 = fromMaybe rest $ vec V.!? length ts0
 
-go :: (Dispatch sub master res -> Maybe res)
-   -> [Text]
-   -> PieceMap sub master res
-   -> Maybe res
-go runDispatch _ (PieceMapEnd r) =
-    firstJust runDispatch $ map snd $ sortBy (comparing fst) r
-go runDispatch (t:ts) (PieceMap dyn sta) = go runDispatch ts $
-    case Map.lookup t sta of
-        Nothing -> dyn
-        Just pm -> append dyn pm
-go _ [] _ = Nothing
+    --bcToDispatch' :: [Text] -> PieceMap req res -> Maybe res
+    bcToDispatch' _ (PieceMapEnd r) =
+        firstJust (\f -> f ts0 req) $ map snd $ sortBy (comparing fst) r
+    bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $
+        case Map.lookup t sta of
+            Nothing -> dyn
+            Just pm -> append dyn pm
+    bcToDispatch' [] _ = 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
-    { pmDynamic :: PieceMap sub master res
-    , pmStatic :: Map.Map Text (PieceMap sub master res)
-    } | PieceMapEnd [(Int, Dispatch sub master res)]
+data PieceMap req res = PieceMap
+    { pmDynamic :: PieceMap req res
+    , pmStatic :: Map.Map Text (PieceMap req 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)]
-            -> PieceMap sub master res
+            -> [(Int, RouteHandler req 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
-    { bcVector :: !(V.Vector (PieceMap sub master res))
-    , bcRest :: !(PieceMap sub master res)
+data ByCount req res = ByCount
+    { bcVector :: !(V.Vector (PieceMap req 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)
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 7abce23b..06be0cce 100644
--- a/yesod-routes/test/main.hs
+++ b/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
-result f _ _ ts _ _ = f ts
-
-justRoot :: Dispatch Dummy Dummy Int
+justRoot :: Dispatch () 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 ts = dispatch Dummy Nothing ts Dummy id
+test :: Dispatch () Int -> [Text] -> Maybe Int
+test dispatch ts = dispatch ts ()
 
 main :: IO ()
 main = hspecX $ do

From 1a40b16e4caff619c9d502f3f5f5871ad3036691 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 7 Oct 2011 09:32:46 +0200
Subject: [PATCH 08/28] Switch to Literate Haskell

---
 yesod-routes/Yesod/Routes.hs           | 112 -------------------------
 yesod-routes/Yesod/Routes/Dispatch.lhs | 112 +++++++++++++++++++++++++
 yesod-routes/test/main.hs              |   2 +-
 yesod-routes/yesod-routes.cabal        |   2 +-
 4 files changed, 114 insertions(+), 114 deletions(-)
 delete mode 100644 yesod-routes/Yesod/Routes.hs
 create mode 100644 yesod-routes/Yesod/Routes/Dispatch.lhs

diff --git a/yesod-routes/Yesod/Routes.hs b/yesod-routes/Yesod/Routes.hs
deleted file mode 100644
index 99b4be65..00000000
--- a/yesod-routes/Yesod/Routes.hs
+++ /dev/null
@@ -1,112 +0,0 @@
-module Yesod.Routes
-    ( Piece (..)
-    , RouteHandler (..)
-    , 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)
-
-data Piece = StaticPiece Text | SinglePiece
-type Dispatch req res = [Text] -> req -> Maybe res
-
-data RouteHandler req res = RouteHandler
-    { rhPieces :: [Piece]
-    , rhHasMulti :: Bool
-    , rhDispatch :: Dispatch req res
-    }
-
-toDispatch :: [RouteHandler req res] -> [Text] -> req -> Maybe res
-toDispatch rhs =
-    bcToDispatch bc
-  where
-    bc = toBC rhs
-
-bcToDispatch :: ByCount req res -> Dispatch req res
-bcToDispatch (ByCount vec rest) ts0 req =
-    bcToDispatch' ts0 pm0
-  where
-    --pm0 :: PieceMap sub master res
-    pm0 = fromMaybe rest $ vec V.!? length ts0
-
-    --bcToDispatch' :: [Text] -> PieceMap req res -> Maybe res
-    bcToDispatch' _ (PieceMapEnd r) =
-        firstJust (\f -> f ts0 req) $ map snd $ sortBy (comparing fst) r
-    bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $
-        case Map.lookup t sta of
-            Nothing -> dyn
-            Just pm -> append dyn pm
-    bcToDispatch' [] _ = 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 -> 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)
--- I'm sure there's some nice type-level trickery we could employ here somehow
--- to ensure this never happens.
-append _ _ = error "Mismatched PieceMaps for append"
-
-data PieceMap req res = PieceMap
-    { pmDynamic :: PieceMap req res
-    , pmStatic :: Map.Map Text (PieceMap req res)
-    } | PieceMapEnd [(Int, Dispatch req res)]
-
-toPieceMap :: Int -> [RouteHandler req res] -> PieceMap req res
-toPieceMap depth = toPieceMap' depth . zip [1..]
-
-toPieceMap' :: Int
-            -> [(Int, RouteHandler req res)]
-            -> PieceMap req res
-toPieceMap' 0 rhs =
-    PieceMapEnd $ map (second rhDispatch)
-                $ sortBy (comparing fst) rhs
-toPieceMap' depth rhs = PieceMap
-    { pmDynamic = toPieceMap' depth' dynamics
-    , pmStatic = Map.map (toPieceMap' depth') statics
-    }
-  where
-    depth' = depth - 1
-
-    pairs = map toPair rhs
-    toPair (i, RouteHandler (p:ps) b c) = (p, (i, RouteHandler ps b c))
-    -- if we have no more pieces, that means this is a rhHasMulti, so fill in
-    -- with dynamic
-    toPair (i, RouteHandler [] b c) = (SinglePiece, (i, RouteHandler [] b c))
-
-    getDynamic (SinglePiece, rh) = Just rh
-    getDynamic _ = Nothing
-    dynamics = mapMaybe getDynamic pairs
-
-    getStatic (StaticPiece t, rh) = Just $ Map.singleton t [rh]
-    getStatic _ = Nothing
-    statics = Map.unionsWith (++) $ mapMaybe getStatic pairs
-
-data ByCount req res = ByCount
-    { bcVector :: !(V.Vector (PieceMap req res))
-    , bcRest :: !(PieceMap req res)
-    }
-
-toBC :: [RouteHandler req res] -> ByCount req res
-toBC rhs =
-    ByCount
-        { bcVector = V.map (\i -> toPieceMap i $ filter (canHaveLength i) rhs)
-                   $ V.enumFromN 0 (maxLen + 1)
-        , bcRest = toPieceMap maxLen $ filter rhHasMulti rhs
-        }
-  where
-    maxLen = maximum $ map (length . rhPieces) rhs
-
-    canHaveLength i rh =
-        len == i || (len < i && rhHasMulti rh)
-      where
-        len = length $ rhPieces rh
diff --git a/yesod-routes/Yesod/Routes/Dispatch.lhs b/yesod-routes/Yesod/Routes/Dispatch.lhs
new file mode 100644
index 00000000..04ffc0ca
--- /dev/null
+++ b/yesod-routes/Yesod/Routes/Dispatch.lhs
@@ -0,0 +1,112 @@
+> module Yesod.Routes.Dispatch
+>     ( Piece (..)
+>     , RouteHandler (..)
+>     , 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)
+>
+> data Piece = StaticPiece Text | SinglePiece
+> type Dispatch req res = [Text] -> req -> Maybe res
+>
+> data RouteHandler req res = RouteHandler
+>     { rhPieces :: [Piece]
+>     , rhHasMulti :: Bool
+>     , rhDispatch :: Dispatch req res
+>     }
+>
+> toDispatch :: [RouteHandler req res] -> [Text] -> req -> Maybe res
+> toDispatch rhs =
+>     bcToDispatch bc
+>   where
+>     bc = toBC rhs
+>
+> bcToDispatch :: ByCount req res -> Dispatch req res
+> bcToDispatch (ByCount vec rest) ts0 req =
+>     bcToDispatch' ts0 pm0
+>   where
+>     --pm0 :: PieceMap sub master res
+>     pm0 = fromMaybe rest $ vec V.!? length ts0
+>
+>     --bcToDispatch' :: [Text] -> PieceMap req res -> Maybe res
+>     bcToDispatch' _ (PieceMapEnd r) =
+>         firstJust (\f -> f ts0 req) $ map snd $ sortBy (comparing fst) r
+>     bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $
+>         case Map.lookup t sta of
+>             Nothing -> dyn
+>             Just pm -> append dyn pm
+>     bcToDispatch' [] _ = 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 -> 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)
+> -- I'm sure there's some nice type-level trickery we could employ here somehow
+> -- to ensure this never happens.
+> append _ _ = error "Mismatched PieceMaps for append"
+>
+> data PieceMap req res = PieceMap
+>     { pmDynamic :: PieceMap req res
+>     , pmStatic :: Map.Map Text (PieceMap req res)
+>     } | PieceMapEnd [(Int, Dispatch req res)]
+>
+> toPieceMap :: Int -> [RouteHandler req res] -> PieceMap req res
+> toPieceMap depth = toPieceMap' depth . zip [1..]
+>
+> toPieceMap' :: Int
+>             -> [(Int, RouteHandler req res)]
+>             -> PieceMap req res
+> toPieceMap' 0 rhs =
+>     PieceMapEnd $ map (second rhDispatch)
+>                 $ sortBy (comparing fst) rhs
+> toPieceMap' depth rhs = PieceMap
+>     { pmDynamic = toPieceMap' depth' dynamics
+>     , pmStatic = Map.map (toPieceMap' depth') statics
+>     }
+>   where
+>     depth' = depth - 1
+>
+>     pairs = map toPair rhs
+>     toPair (i, RouteHandler (p:ps) b c) = (p, (i, RouteHandler ps b c))
+>     -- if we have no more pieces, that means this is a rhHasMulti, so fill in
+>     -- with dynamic
+>     toPair (i, RouteHandler [] b c) = (SinglePiece, (i, RouteHandler [] b c))
+>
+>     getDynamic (SinglePiece, rh) = Just rh
+>     getDynamic _ = Nothing
+>     dynamics = mapMaybe getDynamic pairs
+>
+>     getStatic (StaticPiece t, rh) = Just $ Map.singleton t [rh]
+>     getStatic _ = Nothing
+>     statics = Map.unionsWith (++) $ mapMaybe getStatic pairs
+>
+> data ByCount req res = ByCount
+>     { bcVector :: !(V.Vector (PieceMap req res))
+>     , bcRest :: !(PieceMap req res)
+>     }
+>
+> toBC :: [RouteHandler req res] -> ByCount req res
+> toBC rhs =
+>     ByCount
+>         { bcVector = V.map (\i -> toPieceMap i $ filter (canHaveLength i) rhs)
+>                    $ V.enumFromN 0 (maxLen + 1)
+>         , bcRest = toPieceMap maxLen $ filter rhHasMulti rhs
+>         }
+>   where
+>     maxLen = maximum $ map (length . rhPieces) rhs
+>
+>     canHaveLength i rh =
+>         len == i || (len < i && rhHasMulti rh)
+>       where
+>         len = length $ rhPieces rh
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 06be0cce..c78c93d9 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -3,7 +3,7 @@ import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
 import Test.HUnit ((@?=))
 import Data.Text (Text, unpack)
-import Yesod.Routes
+import Yesod.Routes.Dispatch
 
 result :: ([Text] -> Maybe Int) -> Dispatch () Int
 result f ts () = f ts
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index a960d2e2..4761c6ab 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -19,7 +19,7 @@ library
                    , clientsession             >= 0.7      && < 0.8
                    , containers                >= 0.2      && < 0.5
 
-    exposed-modules: Yesod.Routes
+    exposed-modules: Yesod.Routes.Dispatch
     ghc-options:     -Wall
 
 test-suite runtests

From 6a325f9e4c04dcefbc916b778692b3391c09ab98 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 7 Oct 2011 11:11:40 +0200
Subject: [PATCH 09/28] Extensive comments on dispatch code

---
 yesod-routes/Yesod/Routes/Dispatch.lhs | 341 ++++++++++++++++++++-----
 yesod-routes/test/main.hs              |  20 +-
 yesod-routes/yesod-routes.cabal        |   1 -
 3 files changed, 286 insertions(+), 76 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/Dispatch.lhs b/yesod-routes/Yesod/Routes/Dispatch.lhs
index 04ffc0ca..70846f87 100644
--- a/yesod-routes/Yesod/Routes/Dispatch.lhs
+++ b/yesod-routes/Yesod/Routes/Dispatch.lhs
@@ -1,6 +1,10 @@
+Title: Experimental, optimized route dispatch code
+
+Let's start with our module declaration and imports.
+
 > module Yesod.Routes.Dispatch
 >     ( Piece (..)
->     , RouteHandler (..)
+>     , Route (..)
 >     , Dispatch
 >     , toDispatch
 >     ) where
@@ -12,101 +16,308 @@
 > import Data.List (sortBy)
 > import Data.Ord (comparing)
 > import Control.Arrow (second)
->
-> data Piece = StaticPiece Text | SinglePiece
+> 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 req res = [Text] -> req -> Maybe res
->
-> data RouteHandler req res = RouteHandler
+
+The req and res arguments are application-specific. For example, in a simple
+WAI application, they could be the Request and Respone datatypes. 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 having
+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 req res = Route
 >     { rhPieces :: [Piece]
 >     , rhHasMulti :: Bool
 >     , rhDispatch :: Dispatch req res
 >     }
->
-> toDispatch :: [RouteHandler req res] -> [Text] -> req -> Maybe res
+
+Your application needs to provide this moudle with a list of routes, and then
+this module will give you back a new dispatch function. In other words:
+
+> toDispatch :: [Route req res] -> Dispatch req res
 > toDispatch rhs =
 >     bcToDispatch bc
 >   where
 >     bc = toBC rhs
->
-> bcToDispatch :: ByCount req res -> Dispatch req res
-> bcToDispatch (ByCount vec rest) ts0 req =
->     bcToDispatch' ts0 pm0
+
+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 req res = ByCount
+>     { bcVector :: !(V.Vector (PieceMap req res))
+>     , bcRest :: !(PieceMap req 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 req res] -> ByCount req res
+> toBC rhs =
+>     ByCount
+>         { bcVector = groups
+>         , bcRest = allMultis
+>         }
 >   where
->     --pm0 :: PieceMap sub master res
->     pm0 = fromMaybe rest $ vec V.!? length ts0
->
->     --bcToDispatch' :: [Text] -> PieceMap req res -> Maybe res
->     bcToDispatch' _ (PieceMapEnd r) =
->         firstJust (\f -> f ts0 req) $ map snd $ sortBy (comparing fst) r
->     bcToDispatch' (t:ts) (PieceMap dyn sta) = bcToDispatch' ts $
->         case Map.lookup t sta of
->             Nothing -> dyn
->             Just pm -> append dyn pm
->     bcToDispatch' [] _ = 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 -> 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)
-> -- I'm sure there's some nice type-level trickery we could employ here somehow
-> -- to ensure this never happens.
-> append _ _ = error "Mismatched PieceMaps for append"
+
+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 req 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 req res = PieceMap
 >     { pmDynamic :: PieceMap req res
 >     , pmStatic :: Map.Map Text (PieceMap req res)
 >     } | PieceMapEnd [(Int, Dispatch req res)]
->
-> toPieceMap :: Int -> [RouteHandler req res] -> PieceMap req 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 req res] -> PieceMap req res
 > toPieceMap depth = toPieceMap' depth . zip [1..]
 >
 > toPieceMap' :: Int
->             -> [(Int, RouteHandler req res)]
+>             -> [(Int, Route req res)]
 >             -> PieceMap req 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, RouteHandler (p:ps) b c) = (p, (i, RouteHandler ps b c))
->     -- if we have no more pieces, that means this is a rhHasMulti, so fill in
->     -- with dynamic
->     toPair (i, RouteHandler [] b c) = (SinglePiece, (i, RouteHandler [] b c))
->
->     getDynamic (SinglePiece, rh) = Just rh
+>     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
->
->     getStatic (StaticPiece t, rh) = Just $ Map.singleton t [rh]
+
+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
->
-> data ByCount req res = ByCount
->     { bcVector :: !(V.Vector (PieceMap req res))
->     , bcRest :: !(PieceMap req res)
->     }
->
-> toBC :: [RouteHandler req res] -> ByCount req res
-> toBC rhs =
->     ByCount
->         { bcVector = V.map (\i -> toPieceMap i $ filter (canHaveLength i) rhs)
->                    $ V.enumFromN 0 (maxLen + 1)
->         , bcRest = toPieceMap maxLen $ filter rhHasMulti rhs
->         }
+
+The time has come to actually dispatch.
+
+> bcToDispatch :: ByCount req res -> Dispatch req res
+> bcToDispatch (ByCount vec rest) ts0 req =
+>     bcToDispatch' ts0 pm0
 >   where
->     maxLen = maximum $ map (length . rhPieces) rhs
->
->     canHaveLength i rh =
->         len == i || (len < i && rhHasMulti rh)
->       where
->         len = length $ rhPieces rh
+
+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 req) $ 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 a b -> PieceMap a b -> PieceMap a b
+
+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
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index c78c93d9..7a82f97c 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -10,25 +10,25 @@ result f ts () = f ts
 
 justRoot :: Dispatch () Int
 justRoot = toDispatch
-    [ RouteHandler [] False $ result $ const $ Just 1
+    [ Route [] False $ result $ const $ Just 1
     ]
 
 twoStatics :: Dispatch () Int
 twoStatics = toDispatch
-    [ RouteHandler [StaticPiece "foo"] False $ result $ const $ Just 2
-    , RouteHandler [StaticPiece "bar"] False $ result $ const $ Just 3
+    [ Route [Static "foo"] False $ result $ const $ Just 2
+    , Route [Static "bar"] False $ result $ const $ Just 3
     ]
 
 multi :: Dispatch () Int
 multi = toDispatch
-    [ RouteHandler [StaticPiece "foo"] False $ result $ const $ Just 4
-    , RouteHandler [StaticPiece "bar"] True $ result $ const $ Just 5
+    [ Route [Static "foo"] False $ result $ const $ Just 4
+    , Route [Static "bar"] True $ result $ const $ Just 5
     ]
 
 dynamic :: Dispatch () Int
 dynamic = toDispatch
-    [ RouteHandler [StaticPiece "foo"] False $ result $ const $ Just 6
-    , RouteHandler [SinglePiece] False $ result $ \ts ->
+    [ Route [Static "foo"] False $ result $ const $ Just 6
+    , Route [Dynamic] False $ result $ \ts ->
         case ts of
             [t] ->
                 case reads $ unpack t of
@@ -39,9 +39,9 @@ dynamic = toDispatch
 
 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
+    [ Route [Static "foo"] False $ result $ const $ Just 20
+    , Route [Static "foo"] True $ result $ const $ Just 21
+    , Route [] True $ result $ const $ Just 22
     ]
 
 test :: Dispatch () Int -> [Text] -> Maybe Int
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 4761c6ab..1e388ae6 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -27,7 +27,6 @@ test-suite runtests
     main-is: main.hs
     hs-source-dirs: test
 
-    type: exitcode-stdio-1.0
     build-depends: base                      >= 4.3      && < 5
                  , yesod-routes
                  , text                      >= 0.5      && < 0.12

From 140a6e6d5f48fe2fc7c6efe8cc9fae199acb2e69 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 7 Oct 2011 13:29:11 +0200
Subject: [PATCH 10/28] Added TH module, creates route type and RenderRoute
 instance

---
 yesod-routes/Yesod/Routes/TH.hs | 117 ++++++++++++++++++++++++++++++++
 yesod-routes/test/main.hs       |  52 +++++++++++---
 yesod-routes/yesod-routes.cabal |   3 +
 3 files changed, 163 insertions(+), 9 deletions(-)
 create mode 100644 yesod-routes/Yesod/Routes/TH.hs

diff --git a/yesod-routes/Yesod/Routes/TH.hs b/yesod-routes/Yesod/Routes/TH.hs
new file mode 100644
index 00000000..9cb76bb7
--- /dev/null
+++ b/yesod-routes/Yesod/Routes/TH.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Routes.TH
+    ( -- * Data types
+      Resource (..)
+    , Piece (..)
+    , Dispatch (..)
+      -- * Functions
+      -- ** Route data type
+    , mkRouteType
+    , mkRouteCons
+      -- ** RenderRoute
+    , mkRenderRouteClauses
+    , mkRenderRouteInstance
+    ) where
+
+import Language.Haskell.TH.Syntax
+import Yesod.Core (Route, RenderRoute (renderRoute), toSinglePiece, toMultiPiece)
+import Data.Maybe (maybeToList)
+import Control.Monad (replicateM)
+import Data.Text (pack)
+
+data Resource = Resource
+    { resourceName :: String
+    , resourcePieces :: [Piece]
+    , resourceMulti :: Maybe Type
+    , resourceDispatch :: Dispatch
+    }
+
+data Piece = Static String | Dynamic Type
+
+data Dispatch = AllMethods | Methods [String] | Subsite
+    { subsiteType :: Type
+    , subsiteFunc :: String
+    }
+
+mkRouteCons :: [Resource] -> [Con]
+mkRouteCons =
+    map mkRouteCon
+  where
+    mkRouteCon res =
+        NormalC (mkName $ resourceName res)
+            $ map (\x -> (NotStrict, x))
+            $ concat [singles, multi, sub]
+      where
+        singles = concatMap toSingle $ resourcePieces res
+        toSingle Static{} = []
+        toSingle (Dynamic typ) = [typ]
+
+        multi = maybeToList $ resourceMulti res
+
+        sub =
+            case resourceDispatch res of
+                Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
+                _ -> []
+
+mkRouteType :: String -> [Resource] -> Dec
+mkRouteType name res =
+    DataD [] (mkName name) [] (mkRouteCons res) clazzes
+  where
+    clazzes = [''Show, ''Eq, ''Read]
+
+mkRenderRouteClauses :: [Resource] -> Q [Clause]
+mkRenderRouteClauses =
+    mapM go
+  where
+    isDynamic Dynamic{} = True
+    isDynamic _ = False
+
+    go res = do
+        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
+        dyns <- replicateM cnt $ newName "dyn"
+        sub <-
+            case resourceDispatch res of
+                Subsite{} -> fmap return $ newName "sub"
+                _ -> return []
+        let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
+
+        pack <- [|pack|]
+        tsp <- [|toSinglePiece|]
+        let piecesSingle = mkPieces (AppE pack . LitE . StringL) tsp (resourcePieces res) dyns
+
+        piecesMulti <-
+            case resourceMulti res of
+                Nothing -> return $ ListE []
+                Just{} -> do
+                    tmp <- [|toMultiPiece|]
+                    return $ tmp `AppE` VarE (last dyns)
+
+        body <-
+            case sub of
+                [x] -> do
+                    rr <- [|renderRoute|]
+                    a <- newName "a"
+                    b <- newName "b"
+
+                    colon <- [|(:)|]
+                    let cons a b = InfixE (Just a) colon (Just b)
+                    let pieces = foldr cons (VarE a) piecesSingle
+
+                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
+                _ -> do
+                    colon <- [|(:)|]
+                    let cons a b = InfixE (Just a) colon (Just b)
+                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
+
+        return $ Clause [pat] (NormalB body) []
+
+    mkPieces _ _ [] _ = []
+    mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
+    mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
+
+mkRenderRouteInstance :: String -> [Resource] -> Q Dec
+mkRenderRouteInstance name ress = do
+    cls <- mkRenderRouteClauses ress
+    return $ InstanceD [] (ConT ''RenderRoute `AppT` ConT (mkName name))
+        [ FunD (mkName "renderRoute") cls
+        ]
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 7a82f97c..d7a657fe 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -1,9 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
 import Test.HUnit ((@?=))
 import Data.Text (Text, unpack)
-import Yesod.Routes.Dispatch
+import Yesod.Routes.Dispatch hiding (Static, Dynamic)
+import qualified Yesod.Routes.Dispatch as D
+import Yesod.Routes.TH hiding (Dispatch)
+import qualified Yesod.Core as YC
+import Language.Haskell.TH.Syntax
 
 result :: ([Text] -> Maybe Int) -> Dispatch () Int
 result f ts () = f ts
@@ -15,20 +21,20 @@ justRoot = toDispatch
 
 twoStatics :: Dispatch () Int
 twoStatics = toDispatch
-    [ Route [Static "foo"] False $ result $ const $ Just 2
-    , Route [Static "bar"] False $ result $ const $ Just 3
+    [ Route [D.Static "foo"] False $ result $ const $ Just 2
+    , Route [D.Static "bar"] False $ result $ const $ Just 3
     ]
 
 multi :: Dispatch () Int
 multi = toDispatch
-    [ Route [Static "foo"] False $ result $ const $ Just 4
-    , Route [Static "bar"] True $ result $ const $ Just 5
+    [ Route [D.Static "foo"] False $ result $ const $ Just 4
+    , Route [D.Static "bar"] True $ result $ const $ Just 5
     ]
 
 dynamic :: Dispatch () Int
 dynamic = toDispatch
-    [ Route [Static "foo"] False $ result $ const $ Just 6
-    , Route [Dynamic] False $ result $ \ts ->
+    [ Route [D.Static "foo"] False $ result $ const $ Just 6
+    , Route [D.Dynamic] False $ result $ \ts ->
         case ts of
             [t] ->
                 case reads $ unpack t of
@@ -39,14 +45,35 @@ dynamic = toDispatch
 
 overlap :: Dispatch () Int
 overlap = toDispatch
-    [ Route [Static "foo"] False $ result $ const $ Just 20
-    , Route [Static "foo"] True $ result $ const $ Just 21
+    [ Route [D.Static "foo"] False $ result $ const $ Just 20
+    , Route [D.Static "foo"] True $ result $ const $ Just 21
     , Route [] True $ result $ const $ Just 22
     ]
 
 test :: Dispatch () Int -> [Text] -> Maybe Int
 test dispatch ts = dispatch ts ()
 
+data MySub = MySub
+data MySubRoute = MySubRoute ([Text], [(Text, Text)])
+    deriving (Show, Read, Eq)
+type instance YC.Route MySub = MySubRoute
+instance YC.RenderRoute MySubRoute where
+    renderRoute (MySubRoute x) = x
+
+do
+    texts <- [t|[Text]|]
+    let ress =
+            [ Resource "RootR" [] Nothing $ Methods ["GET"]
+            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] Nothing $ Methods ["GET"]
+            , Resource "WikiR" [Static "wiki"] (Just texts) AllMethods
+            , Resource "SubsiteR" [Static "subsite"] Nothing $ Subsite (ConT ''MySub) "getMySub"
+            ]
+    rrinst <- mkRenderRouteInstance "MyAppRoute" ress
+    return
+        [ mkRouteType "MyAppRoute" ress
+        , rrinst
+        ]
+
 main :: IO ()
 main = hspecX $ do
     describe "justRoot" $ do
@@ -75,3 +102,10 @@ main = hspecX $ do
         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" $ YC.renderRoute RootR @?= ([], [])
+        it "renders blog post correctly" $ YC.renderRoute (BlogPostR "foo") @?= (["blog", "foo"], [])
+        it "renders wiki correctly" $ YC.renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], [])
+        it "renders subsite correctly" $ YC.renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")]))
+            @?= (["subsite", "foo", "bar"], [("baz", "bin")])
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 1e388ae6..20153acb 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -18,8 +18,10 @@ library
                    , vector                    >= 0.8      && < 0.10
                    , clientsession             >= 0.7      && < 0.8
                    , containers                >= 0.2      && < 0.5
+                   , template-haskell
 
     exposed-modules: Yesod.Routes.Dispatch
+                     Yesod.Routes.TH
     ghc-options:     -Wall
 
 test-suite runtests
@@ -32,6 +34,7 @@ test-suite runtests
                  , text                      >= 0.5      && < 0.12
                  , HUnit                     >= 1.2      && < 1.3
                  , hspec                     >= 0.6      && < 0.10
+                 , yesod-core                >= 0.9.3    && < 0.10
     ghc-options:     -Wall
 
 source-repository head

From 55ac0ac52cf5099f3d882678a15dfdb7b5d71831 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 7 Oct 2011 13:59:09 +0200
Subject: [PATCH 11/28] Beginning of dispatch implementation, not yet complete

---
 yesod-routes/Yesod/Routes/TH.hs | 40 ++++++++++++++++++++++++++++++++-
 yesod-routes/test/main.hs       |  6 +++++
 2 files changed, 45 insertions(+), 1 deletion(-)

diff --git a/yesod-routes/Yesod/Routes/TH.hs b/yesod-routes/Yesod/Routes/TH.hs
index 9cb76bb7..402a913c 100644
--- a/yesod-routes/Yesod/Routes/TH.hs
+++ b/yesod-routes/Yesod/Routes/TH.hs
@@ -11,13 +11,18 @@ module Yesod.Routes.TH
       -- ** RenderRoute
     , mkRenderRouteClauses
     , mkRenderRouteInstance
+      -- ** Dispatch
+    , mkDispatchClause
     ) where
 
 import Language.Haskell.TH.Syntax
-import Yesod.Core (Route, RenderRoute (renderRoute), toSinglePiece, toMultiPiece)
+import Yesod.Core
+    ( Route, RenderRoute (renderRoute), toSinglePiece, toMultiPiece
+    )
 import Data.Maybe (maybeToList)
 import Control.Monad (replicateM)
 import Data.Text (pack)
+import qualified Yesod.Routes.Dispatch as D
 
 data Resource = Resource
     { resourceName :: String
@@ -115,3 +120,36 @@ mkRenderRouteInstance name ress = do
     return $ InstanceD [] (ConT ''RenderRoute `AppT` ConT (mkName name))
         [ FunD (mkName "renderRoute") cls
         ]
+
+mkDispatchClause :: [Resource] -> Q Clause
+mkDispatchClause ress = do
+    let routes = fmap ListE $ mapM toRoute ress
+    sub <- newName "sub"
+    mkey <- newName "mkey"
+    ts <- newName "ts"
+    master <- newName "master"
+    toMaster <- newName "toMaster"
+    let pats =
+            [ VarP sub
+            , VarP mkey
+            , VarP ts
+            , VarP master
+            , VarP toMaster
+            ]
+
+    dispatch <- newName "dispatch"
+    body <- [|D.toDispatch $(routes)|]
+    return $ Clause
+        pats
+        (NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster]))
+        [FunD dispatch [Clause [] (NormalB body) []]]
+  where
+    toRoute :: Resource -> Q Exp
+    toRoute res = do
+        let ps = fmap ListE $ mapM toPiece $ resourcePieces res
+        let m = maybe [|False|] (const [|True|]) $ resourceMulti res
+        [|D.Route $(ps) $(m) undefined|]
+
+    toPiece :: Piece -> Q Exp
+    toPiece (Static s) = [|D.Static $ pack $(lift s)|]
+    toPiece Dynamic{} = [|D.Dynamic|]
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index d7a657fe..ec5f1197 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -69,9 +69,11 @@ do
             , Resource "SubsiteR" [Static "subsite"] Nothing $ Subsite (ConT ''MySub) "getMySub"
             ]
     rrinst <- mkRenderRouteInstance "MyAppRoute" ress
+    dispatch <- mkDispatchClause ress
     return
         [ mkRouteType "MyAppRoute" ress
         , rrinst
+        , FunD (mkName "thDispatch") [dispatch]
         ]
 
 main :: IO ()
@@ -109,3 +111,7 @@ main = hspecX $ do
         it "renders wiki correctly" $ YC.renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], [])
         it "renders subsite correctly" $ YC.renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")]))
             @?= (["subsite", "foo", "bar"], [("baz", "bin")])
+
+    describe "thDispatch" $ do
+        let disp x = thDispatch () () [] () ()
+        it "routes to root" $ disp [] @?= Just "this is the root"

From 3e0507d6cd5ef89a4a72eaa2d9d006233d518d8a Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 14 Oct 2011 08:04:16 +0200
Subject: [PATCH 12/28] More incomplete yesod-routes changes

---
 yesod-routes/Yesod/Routes/TH.hs | 60 +++++++++++++++++++++++++++++----
 yesod-routes/test/main.hs       | 28 ++++++++++++---
 2 files changed, 77 insertions(+), 11 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/TH.hs b/yesod-routes/Yesod/Routes/TH.hs
index 402a913c..f4a9918d 100644
--- a/yesod-routes/Yesod/Routes/TH.hs
+++ b/yesod-routes/Yesod/Routes/TH.hs
@@ -19,25 +19,29 @@ import Language.Haskell.TH.Syntax
 import Yesod.Core
     ( Route, RenderRoute (renderRoute), toSinglePiece, toMultiPiece
     )
-import Data.Maybe (maybeToList)
+import Data.Maybe (maybeToList, catMaybes)
 import Control.Monad (replicateM)
 import Data.Text (pack)
 import qualified Yesod.Routes.Dispatch as D
+import qualified Data.Map as Map
+import Data.Char (toLower)
 
 data Resource = Resource
     { resourceName :: String
     , resourcePieces :: [Piece]
-    , resourceMulti :: Maybe Type
     , resourceDispatch :: Dispatch
     }
 
 data Piece = Static String | Dynamic Type
 
-data Dispatch = AllMethods | Methods [String] | Subsite
+data Dispatch = Methods (Maybe Type) [String] | Subsite
     { subsiteType :: Type
     , subsiteFunc :: String
     }
 
+resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
+resourceMulti _ = Nothing
+
 mkRouteCons :: [Resource] -> [Con]
 mkRouteCons =
     map mkRouteCon
@@ -121,8 +125,10 @@ mkRenderRouteInstance name ress = do
         [ FunD (mkName "renderRoute") cls
         ]
 
-mkDispatchClause :: [Resource] -> Q Clause
-mkDispatchClause ress = do
+mkDispatchClause :: [Resource]
+                 -> Q Exp -- ^ convert handler to application
+                 -> Q Clause
+mkDispatchClause ress toApp = do
     let routes = fmap ListE $ mapM toRoute ress
     sub <- newName "sub"
     mkey <- newName "mkey"
@@ -148,8 +154,50 @@ mkDispatchClause ress = do
     toRoute res = do
         let ps = fmap ListE $ mapM toPiece $ resourcePieces res
         let m = maybe [|False|] (const [|True|]) $ resourceMulti res
-        [|D.Route $(ps) $(m) undefined|]
+        case resourceDispatch res of
+            Methods mmulti mds -> do
+                let toPair m = do
+                        key <- [|pack $(lift m)|]
+                        let value = VarE $ mkName $ map toLower m ++ resourceName res
+                        return $ TupE [key, value]
+                let handler =
+                        if null mds
+                            then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|]
+                            else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|]
+                sub <- newName "sub"
+                mkey <- newName "mkey"
+                (dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti
+                master <- newName "master"
+                toMaster <- newName "toMaster"
+                body <- [|$(toApp) $(handler)|]
+                let func = LamE
+                            [ tsPattern
+                            , TupP
+                                [ VarP sub
+                                , VarP mkey
+                                , VarP master
+                                , VarP toMaster
+                                ]
+                            ]
+                            body
+                [|D.Route $(ps) $(m) $(return func)|]
+            Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME
 
     toPiece :: Piece -> Q Exp
     toPiece (Static s) = [|D.Static $ pack $(lift s)|]
     toPiece Dynamic{} = [|D.Dynamic|]
+
+mkTsPattern pieces mmulti = do
+    end <-
+        case mmulti of
+            Nothing -> return (Nothing, ConP (mkName "[]") [])
+            Just{} -> do
+                end <- newName "end"
+                return (Just end, VarP end)
+    pieces' <- mapM go pieces
+    return (catMaybes $ map fst pieces', fst end, foldr (flip InfixP $ mkName ":") (snd end) $ map snd pieces')
+  where
+    go Static{} = return (Nothing, WildP)
+    go Dynamic{} = do
+        dyn <- newName "dyn"
+        return (Just dyn, VarP dyn)
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index ec5f1197..35d93567 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -10,6 +10,7 @@ import qualified Yesod.Routes.Dispatch as D
 import Yesod.Routes.TH hiding (Dispatch)
 import qualified Yesod.Core as YC
 import Language.Haskell.TH.Syntax
+import qualified Data.Map as Map
 
 result :: ([Text] -> Maybe Int) -> Dispatch () Int
 result f ts () = f ts
@@ -60,16 +61,19 @@ type instance YC.Route MySub = MySubRoute
 instance YC.RenderRoute MySubRoute where
     renderRoute (MySubRoute x) = x
 
+dispatchHelper :: Either String (Map.Map Text String) -> Maybe String
+dispatchHelper = undefined
+
 do
     texts <- [t|[Text]|]
     let ress =
-            [ Resource "RootR" [] Nothing $ Methods ["GET"]
-            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] Nothing $ Methods ["GET"]
-            , Resource "WikiR" [Static "wiki"] (Just texts) AllMethods
-            , Resource "SubsiteR" [Static "subsite"] Nothing $ Subsite (ConT ''MySub) "getMySub"
+            [ Resource "RootR" [] $ Methods Nothing ["GET"]
+            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET"]
+            , Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
+            , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
             ]
     rrinst <- mkRenderRouteInstance "MyAppRoute" ress
-    dispatch <- mkDispatchClause ress
+    dispatch <- mkDispatchClause ress [|dispatchHelper|]
     return
         [ mkRouteType "MyAppRoute" ress
         , rrinst
@@ -115,3 +119,17 @@ main = hspecX $ do
     describe "thDispatch" $ do
         let disp x = thDispatch () () [] () ()
         it "routes to root" $ disp [] @?= Just "this is the root"
+        it "routes to blog post" $ disp ["blog", "somepost"] @?= Just "some blog post: somepost"
+
+getRootR :: String
+getRootR = "this is the root"
+
+{- FIXME
+getBlogPostR :: Text -> String
+getBlogPostR t = "some blog post: " ++ unpack t
+-}
+getBlogPostR = undefined
+
+handleWikiR = "the wiki"
+
+handleSubsiteR = "a subsite"

From f909669dd0f2e46042c9e3f08996ddecd86e3e63 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 1 Jan 2012 17:24:16 +0200
Subject: [PATCH 13/28] Get tests to compile

---
 yesod-routes/test/main.hs       | 2 +-
 yesod-routes/yesod-routes.cabal | 2 ++
 2 files changed, 3 insertions(+), 1 deletion(-)

diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 35d93567..f2e6ffc9 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -73,7 +73,7 @@ do
             , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
             ]
     rrinst <- mkRenderRouteInstance "MyAppRoute" ress
-    dispatch <- mkDispatchClause ress [|dispatchHelper|]
+    dispatch <- mkDispatchClause ress [|error "FIXME" dispatchHelper|]
     return
         [ mkRouteType "MyAppRoute" ress
         , rrinst
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 20153acb..0727af45 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -35,6 +35,8 @@ test-suite runtests
                  , HUnit                     >= 1.2      && < 1.3
                  , hspec                     >= 0.6      && < 0.10
                  , yesod-core                >= 0.9.3    && < 0.10
+                 , containers
+                 , template-haskell
     ghc-options:     -Wall
 
 source-repository head

From d69ee53a1770f08cef0c54ff30d31bd321596a78 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 1 Jan 2012 17:32:25 +0200
Subject: [PATCH 14/28] yesod-routes: removed yesod-core dependency

---
 yesod-routes/Yesod/Routes/TH.hs |  9 ++++-----
 yesod-routes/test/main.hs       | 19 ++++++++++---------
 yesod-routes/yesod-routes.cabal |  5 ++---
 3 files changed, 16 insertions(+), 17 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/TH.hs b/yesod-routes/Yesod/Routes/TH.hs
index f4a9918d..4552c014 100644
--- a/yesod-routes/Yesod/Routes/TH.hs
+++ b/yesod-routes/Yesod/Routes/TH.hs
@@ -16,15 +16,14 @@ module Yesod.Routes.TH
     ) where
 
 import Language.Haskell.TH.Syntax
-import Yesod.Core
-    ( Route, RenderRoute (renderRoute), toSinglePiece, toMultiPiece
-    )
 import Data.Maybe (maybeToList, catMaybes)
 import Control.Monad (replicateM)
 import Data.Text (pack)
 import qualified Yesod.Routes.Dispatch as D
 import qualified Data.Map as Map
 import Data.Char (toLower)
+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
+import Yesod.Routes.Class
 
 data Resource = Resource
     { resourceName :: String
@@ -85,14 +84,14 @@ mkRenderRouteClauses =
         let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
 
         pack <- [|pack|]
-        tsp <- [|toSinglePiece|]
+        tsp <- [|toPathPiece|]
         let piecesSingle = mkPieces (AppE pack . LitE . StringL) tsp (resourcePieces res) dyns
 
         piecesMulti <-
             case resourceMulti res of
                 Nothing -> return $ ListE []
                 Just{} -> do
-                    tmp <- [|toMultiPiece|]
+                    tmp <- [|toPathMultiPiece|]
                     return $ tmp `AppE` VarE (last dyns)
 
         body <-
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index f2e6ffc9..bafb5420 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -1,14 +1,16 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
 import Test.HUnit ((@?=))
 import Data.Text (Text, unpack)
 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.TH hiding (Dispatch)
-import qualified Yesod.Core as YC
 import Language.Haskell.TH.Syntax
 import qualified Data.Map as Map
 
@@ -55,10 +57,9 @@ test :: Dispatch () Int -> [Text] -> Maybe Int
 test dispatch ts = dispatch ts ()
 
 data MySub = MySub
-data MySubRoute = MySubRoute ([Text], [(Text, Text)])
-    deriving (Show, Read, Eq)
-type instance YC.Route MySub = MySubRoute
-instance YC.RenderRoute MySubRoute where
+data instance YRC.Route MySub = MySubRoute ([Text], [(Text, Text)])
+    deriving (Show, Eq, Read)
+instance RenderRoute (YRC.Route MySub) where
     renderRoute (MySubRoute x) = x
 
 dispatchHelper :: Either String (Map.Map Text String) -> Maybe String
@@ -110,10 +111,10 @@ main = hspecX $ do
         it "dispatches correctly to []" $ test overlap [] @?= Just 22
 
     describe "RenderRoute instance" $ do
-        it "renders root correctly" $ YC.renderRoute RootR @?= ([], [])
-        it "renders blog post correctly" $ YC.renderRoute (BlogPostR "foo") @?= (["blog", "foo"], [])
-        it "renders wiki correctly" $ YC.renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], [])
-        it "renders subsite correctly" $ YC.renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")]))
+        it "renders root correctly" $ renderRoute RootR @?= ([], [])
+        it "renders blog post correctly" $ renderRoute (BlogPostR "foo") @?= (["blog", "foo"], [])
+        it "renders wiki correctly" $ renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], [])
+        it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")]))
             @?= (["subsite", "foo", "bar"], [("baz", "bin")])
 
     describe "thDispatch" $ do
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 0727af45..8f8b9ba6 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -13,15 +13,15 @@ homepage:        http://www.yesodweb.com/
 
 library
     build-depends:   base                      >= 4        && < 5
-                   , yesod-core                >= 0.9.3    && < 0.10
                    , text                      >= 0.5      && < 0.12
                    , vector                    >= 0.8      && < 0.10
-                   , clientsession             >= 0.7      && < 0.8
                    , containers                >= 0.2      && < 0.5
                    , template-haskell
+                   , path-pieces               >= 0.1      && < 0.2
 
     exposed-modules: Yesod.Routes.Dispatch
                      Yesod.Routes.TH
+                     Yesod.Routes.Class
     ghc-options:     -Wall
 
 test-suite runtests
@@ -34,7 +34,6 @@ test-suite runtests
                  , text                      >= 0.5      && < 0.12
                  , HUnit                     >= 1.2      && < 1.3
                  , hspec                     >= 0.6      && < 0.10
-                 , yesod-core                >= 0.9.3    && < 0.10
                  , containers
                  , template-haskell
     ghc-options:     -Wall

From 144b215a38cfe75c17212acfd9d6fb4a2f96ce61 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 1 Jan 2012 17:57:49 +0200
Subject: [PATCH 15/28] Route is a data family, part of RenderRoute class

---
 yesod-routes/Yesod/Routes/Class.hs | 12 ++++++++
 yesod-routes/Yesod/Routes/TH.hs    | 48 +++++++++++++++++-------------
 yesod-routes/test/main.hs          | 17 ++++++-----
 3 files changed, 48 insertions(+), 29 deletions(-)
 create mode 100644 yesod-routes/Yesod/Routes/Class.hs

diff --git a/yesod-routes/Yesod/Routes/Class.hs b/yesod-routes/Yesod/Routes/Class.hs
new file mode 100644
index 00000000..92024165
--- /dev/null
+++ b/yesod-routes/Yesod/Routes/Class.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Yesod.Routes.Class
+    ( RenderRoute (..)
+    ) where
+
+import Data.Text (Text)
+
+class Eq (Route a) => RenderRoute a where
+    -- | The type-safe URLs associated with a site argument.
+    data Route a
+    renderRoute :: Route a -> ([Text], [(Text, Text)])
diff --git a/yesod-routes/Yesod/Routes/TH.hs b/yesod-routes/Yesod/Routes/TH.hs
index 4552c014..4aa7afed 100644
--- a/yesod-routes/Yesod/Routes/TH.hs
+++ b/yesod-routes/Yesod/Routes/TH.hs
@@ -5,14 +5,12 @@ module Yesod.Routes.TH
     , Piece (..)
     , Dispatch (..)
       -- * Functions
-      -- ** Route data type
-    , mkRouteType
-    , mkRouteCons
       -- ** RenderRoute
-    , mkRenderRouteClauses
     , mkRenderRouteInstance
+    , mkRouteCons
+    , mkRenderRouteClauses
       -- ** Dispatch
-    , mkDispatchClause
+    --, mkDispatchClause
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -38,9 +36,11 @@ data Dispatch = Methods (Maybe Type) [String] | Subsite
     , subsiteFunc :: String
     }
 
+resourceMulti :: Resource -> Maybe Type
 resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
 resourceMulti _ = Nothing
 
+-- | Generate the constructors of a route data type.
 mkRouteCons :: [Resource] -> [Con]
 mkRouteCons =
     map mkRouteCon
@@ -61,12 +61,7 @@ mkRouteCons =
                 Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
                 _ -> []
 
-mkRouteType :: String -> [Resource] -> Dec
-mkRouteType name res =
-    DataD [] (mkName name) [] (mkRouteCons res) clazzes
-  where
-    clazzes = [''Show, ''Eq, ''Read]
-
+-- | Clauses for the 'renderRoute' method.
 mkRenderRouteClauses :: [Resource] -> Q [Clause]
 mkRenderRouteClauses =
     mapM go
@@ -83,9 +78,9 @@ mkRenderRouteClauses =
                 _ -> return []
         let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
 
-        pack <- [|pack|]
+        pack' <- [|pack|]
         tsp <- [|toPathPiece|]
-        let piecesSingle = mkPieces (AppE pack . LitE . StringL) tsp (resourcePieces res) dyns
+        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns
 
         piecesMulti <-
             case resourceMulti res of
@@ -102,7 +97,7 @@ mkRenderRouteClauses =
                     b <- newName "b"
 
                     colon <- [|(:)|]
-                    let cons a b = InfixE (Just a) colon (Just b)
+                    let cons y ys = InfixE (Just y) colon (Just ys)
                     let pieces = foldr cons (VarE a) piecesSingle
 
                     return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
@@ -116,14 +111,23 @@ mkRenderRouteClauses =
     mkPieces _ _ [] _ = []
     mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
     mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
+    mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120"
 
-mkRenderRouteInstance :: String -> [Resource] -> Q Dec
-mkRenderRouteInstance name ress = do
+-- | Generate the 'RenderRoute' instance.
+--
+-- This includes both the 'Route' associated type and the 'renderRoute' method.
+-- This function uses both 'mkRouteCons' and 'mkRenderRouteClasses'.
+mkRenderRouteInstance :: Type -> [Resource] -> Q Dec
+mkRenderRouteInstance typ ress = do
     cls <- mkRenderRouteClauses ress
-    return $ InstanceD [] (ConT ''RenderRoute `AppT` ConT (mkName name))
-        [ FunD (mkName "renderRoute") cls
+    return $ InstanceD [] (ConT ''RenderRoute `AppT` typ)
+        [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes
+        , FunD (mkName "renderRoute") cls
         ]
+  where
+    clazzes = [''Show, ''Eq, ''Read]
 
+{- FIXME
 mkDispatchClause :: [Resource]
                  -> Q Exp -- ^ convert handler to application
                  -> Q Clause
@@ -155,9 +159,9 @@ mkDispatchClause ress toApp = do
         let m = maybe [|False|] (const [|True|]) $ resourceMulti res
         case resourceDispatch res of
             Methods mmulti mds -> do
-                let toPair m = do
-                        key <- [|pack $(lift m)|]
-                        let value = VarE $ mkName $ map toLower m ++ resourceName res
+                let toPair m' = do
+                        key <- [|pack $(lift m')|]
+                        let value = VarE $ mkName $ map toLower m' ++ resourceName res
                         return $ TupE [key, value]
                 let handler =
                         if null mds
@@ -186,6 +190,7 @@ mkDispatchClause ress toApp = do
     toPiece (Static s) = [|D.Static $ pack $(lift s)|]
     toPiece Dynamic{} = [|D.Dynamic|]
 
+mkTsPattern :: [Piece] -> Maybe t -> Q ([Name], Maybe Name, Pat)
 mkTsPattern pieces mmulti = do
     end <-
         case mmulti of
@@ -200,3 +205,4 @@ mkTsPattern pieces mmulti = do
     go Dynamic{} = do
         dyn <- newName "dyn"
         return (Just dyn, VarP dyn)
+-}
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index bafb5420..09c83351 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -56,10 +56,12 @@ overlap = toDispatch
 test :: Dispatch () Int -> [Text] -> Maybe Int
 test dispatch ts = dispatch ts ()
 
+data MyApp = MyApp
+
 data MySub = MySub
-data instance YRC.Route MySub = MySubRoute ([Text], [(Text, Text)])
-    deriving (Show, Eq, Read)
-instance RenderRoute (YRC.Route MySub) where
+instance RenderRoute MySub where
+    data YRC.Route MySub = MySubRoute ([Text], [(Text, Text)])
+        deriving (Show, Eq, Read)
     renderRoute (MySubRoute x) = x
 
 dispatchHelper :: Either String (Map.Map Text String) -> Maybe String
@@ -73,12 +75,11 @@ do
             , Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
             , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
             ]
-    rrinst <- mkRenderRouteInstance "MyAppRoute" ress
-    dispatch <- mkDispatchClause ress [|error "FIXME" dispatchHelper|]
+    rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
+    dispatch <- [|error "FIXME dispatch"|]
     return
-        [ mkRouteType "MyAppRoute" ress
-        , rrinst
-        , FunD (mkName "thDispatch") [dispatch]
+        [ rrinst
+        , FunD (mkName "thDispatch") [Clause [] (NormalB dispatch) []]
         ]
 
 main :: IO ()

From 6d6c4817b27f1f5e1b40ba13d57fc9ccb5399ca1 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Sun, 1 Jan 2012 18:11:22 +0200
Subject: [PATCH 16/28] Simplified Dispatch: do not pass req around

---
 yesod-routes/Yesod/Routes/Dispatch.lhs | 46 +++++++++++++-------------
 yesod-routes/test/main.hs              | 18 +++++-----
 2 files changed, 32 insertions(+), 32 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/Dispatch.lhs b/yesod-routes/Yesod/Routes/Dispatch.lhs
index 70846f87..b29955b7 100644
--- a/yesod-routes/Yesod/Routes/Dispatch.lhs
+++ b/yesod-routes/Yesod/Routes/Dispatch.lhs
@@ -41,12 +41,12 @@ 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 req res = [Text] -> req -> Maybe res
+> type Dispatch res = [Text] -> Maybe res
 
-The req and res arguments are application-specific. For example, in a simple
-WAI application, they could be the Request and Respone datatypes. The important
+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 having
+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.
 
@@ -55,16 +55,16 @@ module handles that for you automatically.
 
 So each route is specified by:
 
-> data Route req res = Route
+> data Route res = Route
 >     { rhPieces :: [Piece]
 >     , rhHasMulti :: Bool
->     , rhDispatch :: Dispatch req res
+>     , rhDispatch :: Dispatch res
 >     }
 
 Your application needs to provide this moudle with a list of routes, and then
 this module will give you back a new dispatch function. In other words:
 
-> toDispatch :: [Route req res] -> Dispatch req res
+> toDispatch :: [Route res] -> Dispatch res
 > toDispatch rhs =
 >     bcToDispatch bc
 >   where
@@ -98,9 +98,9 @@ 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 req res = ByCount
->     { bcVector :: !(V.Vector (PieceMap req res))
->     , bcRest :: !(PieceMap req res)
+> 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
@@ -109,7 +109,7 @@ 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 req res] -> ByCount req res
+> toBC :: [Route res] -> ByCount res
 > toBC rhs =
 >     ByCount
 >         { bcVector = groups
@@ -135,7 +135,7 @@ 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 req res -> Bool
+>     canHaveLength :: Int -> Route res -> Bool
 >     canHaveLength i rh =
 >         len == i || (len < i && rhHasMulti rh)
 >       where
@@ -190,10 +190,10 @@ What we need is then two extra features on our datatype:
 
 What we end up with is:
 
-> data PieceMap req res = PieceMap
->     { pmDynamic :: PieceMap req res
->     , pmStatic :: Map.Map Text (PieceMap req res)
->     } | PieceMapEnd [(Int, Dispatch req res)]
+> 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
@@ -203,12 +203,12 @@ 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 req res] -> PieceMap req res
+> toPieceMap :: Int -> [Route res] -> PieceMap res
 > toPieceMap depth = toPieceMap' depth . zip [1..]
 >
 > toPieceMap' :: Int
->             -> [(Int, Route req res)]
->             -> PieceMap req res
+>             -> [(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
@@ -260,8 +260,8 @@ appropriate here, since it would only keep one route per Text.
 
 The time has come to actually dispatch.
 
-> bcToDispatch :: ByCount req res -> Dispatch req res
-> bcToDispatch (ByCount vec rest) ts0 req =
+> bcToDispatch :: ByCount res -> Dispatch res
+> bcToDispatch (ByCount vec rest) ts0 =
 >     bcToDispatch' ts0 pm0
 >   where
 
@@ -274,7 +274,7 @@ 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 req) $ map snd r
+>     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.
@@ -296,7 +296,7 @@ Helper function: get the first Just response.
 
 Combine two PieceMaps together.
 
-> append :: PieceMap a b -> PieceMap a b -> PieceMap a b
+> 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
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 09c83351..3f679293 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -14,27 +14,27 @@ import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
 import qualified Data.Map as Map
 
-result :: ([Text] -> Maybe Int) -> Dispatch () Int
-result f ts () = f ts
+result :: ([Text] -> Maybe Int) -> Dispatch Int
+result f ts = f ts
 
-justRoot :: Dispatch () Int
+justRoot :: Dispatch Int
 justRoot = toDispatch
     [ Route [] False $ result $ const $ Just 1
     ]
 
-twoStatics :: Dispatch () Int
+twoStatics :: Dispatch Int
 twoStatics = toDispatch
     [ Route [D.Static "foo"] False $ result $ const $ Just 2
     , Route [D.Static "bar"] False $ result $ const $ Just 3
     ]
 
-multi :: Dispatch () Int
+multi :: Dispatch Int
 multi = toDispatch
     [ Route [D.Static "foo"] False $ result $ const $ Just 4
     , Route [D.Static "bar"] True $ result $ const $ Just 5
     ]
 
-dynamic :: Dispatch () Int
+dynamic :: Dispatch Int
 dynamic = toDispatch
     [ Route [D.Static "foo"] False $ result $ const $ Just 6
     , Route [D.Dynamic] False $ result $ \ts ->
@@ -46,15 +46,15 @@ dynamic = toDispatch
             _ -> error $ "Called dynamic with: " ++ show ts
     ]
 
-overlap :: Dispatch () Int
+overlap :: Dispatch Int
 overlap = toDispatch
     [ Route [D.Static "foo"] False $ result $ const $ Just 20
     , Route [D.Static "foo"] True $ result $ const $ Just 21
     , Route [] True $ result $ const $ Just 22
     ]
 
-test :: Dispatch () Int -> [Text] -> Maybe Int
-test dispatch ts = dispatch ts ()
+test :: Dispatch Int -> [Text] -> Maybe Int
+test dispatch ts = dispatch ts
 
 data MyApp = MyApp
 

From 666e242ee955507474b03352f8f4a7c64bcdd1c7 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 2 Jan 2012 21:02:42 +0200
Subject: [PATCH 17/28] yesod-routes refactor

---
 yesod-routes/Yesod/Routes/TH.hs             | 208 +-------------------
 yesod-routes/Yesod/Routes/TH/Dispatch.hs    |  98 +++++++++
 yesod-routes/Yesod/Routes/TH/RenderRoute.hs | 102 ++++++++++
 yesod-routes/Yesod/Routes/TH/Types.hs       |  32 +++
 yesod-routes/test/main.hs                   |  36 +++-
 5 files changed, 266 insertions(+), 210 deletions(-)
 create mode 100644 yesod-routes/Yesod/Routes/TH/Dispatch.hs
 create mode 100644 yesod-routes/Yesod/Routes/TH/RenderRoute.hs
 create mode 100644 yesod-routes/Yesod/Routes/TH/Types.hs

diff --git a/yesod-routes/Yesod/Routes/TH.hs b/yesod-routes/Yesod/Routes/TH.hs
index 4aa7afed..41045b3c 100644
--- a/yesod-routes/Yesod/Routes/TH.hs
+++ b/yesod-routes/Yesod/Routes/TH.hs
@@ -1,208 +1,12 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Yesod.Routes.TH
-    ( -- * Data types
-      Resource (..)
-    , Piece (..)
-    , Dispatch (..)
+    ( module Yesod.Routes.TH.Types
       -- * Functions
-      -- ** RenderRoute
-    , mkRenderRouteInstance
-    , mkRouteCons
-    , mkRenderRouteClauses
+    , module Yesod.Routes.TH.RenderRoute
       -- ** Dispatch
-    --, mkDispatchClause
+    , module Yesod.Routes.TH.Dispatch
     ) where
 
-import Language.Haskell.TH.Syntax
-import Data.Maybe (maybeToList, catMaybes)
-import Control.Monad (replicateM)
-import Data.Text (pack)
-import qualified Yesod.Routes.Dispatch as D
-import qualified Data.Map as Map
-import Data.Char (toLower)
-import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
-import Yesod.Routes.Class
-
-data Resource = Resource
-    { resourceName :: String
-    , resourcePieces :: [Piece]
-    , resourceDispatch :: Dispatch
-    }
-
-data Piece = Static String | Dynamic Type
-
-data Dispatch = Methods (Maybe Type) [String] | Subsite
-    { subsiteType :: Type
-    , subsiteFunc :: String
-    }
-
-resourceMulti :: Resource -> Maybe Type
-resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
-resourceMulti _ = Nothing
-
--- | Generate the constructors of a route data type.
-mkRouteCons :: [Resource] -> [Con]
-mkRouteCons =
-    map mkRouteCon
-  where
-    mkRouteCon res =
-        NormalC (mkName $ resourceName res)
-            $ map (\x -> (NotStrict, x))
-            $ concat [singles, multi, sub]
-      where
-        singles = concatMap toSingle $ resourcePieces res
-        toSingle Static{} = []
-        toSingle (Dynamic typ) = [typ]
-
-        multi = maybeToList $ resourceMulti res
-
-        sub =
-            case resourceDispatch res of
-                Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
-                _ -> []
-
--- | Clauses for the 'renderRoute' method.
-mkRenderRouteClauses :: [Resource] -> Q [Clause]
-mkRenderRouteClauses =
-    mapM go
-  where
-    isDynamic Dynamic{} = True
-    isDynamic _ = False
-
-    go res = do
-        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
-        dyns <- replicateM cnt $ newName "dyn"
-        sub <-
-            case resourceDispatch res of
-                Subsite{} -> fmap return $ newName "sub"
-                _ -> return []
-        let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
-
-        pack' <- [|pack|]
-        tsp <- [|toPathPiece|]
-        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns
-
-        piecesMulti <-
-            case resourceMulti res of
-                Nothing -> return $ ListE []
-                Just{} -> do
-                    tmp <- [|toPathMultiPiece|]
-                    return $ tmp `AppE` VarE (last dyns)
-
-        body <-
-            case sub of
-                [x] -> do
-                    rr <- [|renderRoute|]
-                    a <- newName "a"
-                    b <- newName "b"
-
-                    colon <- [|(:)|]
-                    let cons y ys = InfixE (Just y) colon (Just ys)
-                    let pieces = foldr cons (VarE a) piecesSingle
-
-                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
-                _ -> do
-                    colon <- [|(:)|]
-                    let cons a b = InfixE (Just a) colon (Just b)
-                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
-
-        return $ Clause [pat] (NormalB body) []
-
-    mkPieces _ _ [] _ = []
-    mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
-    mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
-    mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120"
-
--- | Generate the 'RenderRoute' instance.
---
--- This includes both the 'Route' associated type and the 'renderRoute' method.
--- This function uses both 'mkRouteCons' and 'mkRenderRouteClasses'.
-mkRenderRouteInstance :: Type -> [Resource] -> Q Dec
-mkRenderRouteInstance typ ress = do
-    cls <- mkRenderRouteClauses ress
-    return $ InstanceD [] (ConT ''RenderRoute `AppT` typ)
-        [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes
-        , FunD (mkName "renderRoute") cls
-        ]
-  where
-    clazzes = [''Show, ''Eq, ''Read]
-
-{- FIXME
-mkDispatchClause :: [Resource]
-                 -> Q Exp -- ^ convert handler to application
-                 -> Q Clause
-mkDispatchClause ress toApp = do
-    let routes = fmap ListE $ mapM toRoute ress
-    sub <- newName "sub"
-    mkey <- newName "mkey"
-    ts <- newName "ts"
-    master <- newName "master"
-    toMaster <- newName "toMaster"
-    let pats =
-            [ VarP sub
-            , VarP mkey
-            , VarP ts
-            , VarP master
-            , VarP toMaster
-            ]
-
-    dispatch <- newName "dispatch"
-    body <- [|D.toDispatch $(routes)|]
-    return $ Clause
-        pats
-        (NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster]))
-        [FunD dispatch [Clause [] (NormalB body) []]]
-  where
-    toRoute :: Resource -> Q Exp
-    toRoute res = do
-        let ps = fmap ListE $ mapM toPiece $ resourcePieces res
-        let m = maybe [|False|] (const [|True|]) $ resourceMulti res
-        case resourceDispatch res of
-            Methods mmulti mds -> do
-                let toPair m' = do
-                        key <- [|pack $(lift m')|]
-                        let value = VarE $ mkName $ map toLower m' ++ resourceName res
-                        return $ TupE [key, value]
-                let handler =
-                        if null mds
-                            then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|]
-                            else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|]
-                sub <- newName "sub"
-                mkey <- newName "mkey"
-                (dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti
-                master <- newName "master"
-                toMaster <- newName "toMaster"
-                body <- [|$(toApp) $(handler)|]
-                let func = LamE
-                            [ tsPattern
-                            , TupP
-                                [ VarP sub
-                                , VarP mkey
-                                , VarP master
-                                , VarP toMaster
-                                ]
-                            ]
-                            body
-                [|D.Route $(ps) $(m) $(return func)|]
-            Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME
-
-    toPiece :: Piece -> Q Exp
-    toPiece (Static s) = [|D.Static $ pack $(lift s)|]
-    toPiece Dynamic{} = [|D.Dynamic|]
-
-mkTsPattern :: [Piece] -> Maybe t -> Q ([Name], Maybe Name, Pat)
-mkTsPattern pieces mmulti = do
-    end <-
-        case mmulti of
-            Nothing -> return (Nothing, ConP (mkName "[]") [])
-            Just{} -> do
-                end <- newName "end"
-                return (Just end, VarP end)
-    pieces' <- mapM go pieces
-    return (catMaybes $ map fst pieces', fst end, foldr (flip InfixP $ mkName ":") (snd end) $ map snd pieces')
-  where
-    go Static{} = return (Nothing, WildP)
-    go Dynamic{} = do
-        dyn <- newName "dyn"
-        return (Just dyn, VarP dyn)
--}
+import Yesod.Routes.TH.Types
+import Yesod.Routes.TH.RenderRoute
+import Yesod.Routes.TH.Dispatch
diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
new file mode 100644
index 00000000..02f78103
--- /dev/null
+++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Routes.TH.Dispatch
+    ( -- ** Dispatch
+      mkDispatchClause
+    ) where
+
+import Yesod.Routes.TH.Types
+import Language.Haskell.TH.Syntax
+import Data.Maybe (maybeToList, catMaybes)
+import Control.Monad (replicateM)
+import Data.Text (pack)
+import qualified Yesod.Routes.Dispatch as D
+import qualified Data.Map as Map
+import Data.Char (toLower)
+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
+import Yesod.Routes.Class
+
+mkDispatchClause :: [Resource]
+                 -> Q Clause
+mkDispatchClause ress = undefined
+{- FIXME
+    let routes = fmap ListE $ mapM toRoute ress
+    sub <- newName "sub"
+    mkey <- newName "mkey"
+    ts <- newName "ts"
+    master <- newName "master"
+    toMaster <- newName "toMaster"
+    let pats =
+            [ VarP sub
+            , VarP mkey
+            , VarP ts
+            , VarP master
+            , VarP toMaster
+            ]
+
+    dispatch <- newName "dispatch"
+    body <- [|D.toDispatch $(routes)|]
+    return $ Clause
+        pats
+        (NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster]))
+        [FunD dispatch [Clause [] (NormalB body) []]]
+  where
+
+mkTsPattern :: [Piece] -> Maybe t -> Q ([Name], Maybe Name, Pat)
+mkTsPattern pieces mmulti = do
+    end <-
+        case mmulti of
+            Nothing -> return (Nothing, ConP (mkName "[]") [])
+            Just{} -> do
+                end <- newName "end"
+                return (Just end, VarP end)
+    pieces' <- mapM go pieces
+    return (catMaybes $ map fst pieces', fst end, foldr (flip InfixP $ mkName ":") (snd end) $ map snd pieces')
+  where
+    go Static{} = return (Nothing, WildP)
+    go Dynamic{} = do
+        dyn <- newName "dyn"
+        return (Just dyn, VarP dyn)
+-}
+
+-- | Convert a 'Piece' into a 'D.Piece'.
+toPiece :: Piece -> Q Exp
+toPiece (Static s) = [|D.Static $ pack $(lift s)|]
+toPiece Dynamic{} = [|D.Dynamic|]
+
+-- | Convert a 'Resource' into a 'D.Route'.
+toRoute :: Resource -> Q Exp
+toRoute res = do
+    let ps = fmap ListE $ mapM toPiece $ resourcePieces res
+    let m = maybe [|False|] (const [|True|]) $ resourceMulti res
+    case resourceDispatch res of
+        Methods mmulti mds -> do
+            let toPair m' = do
+                    key <- [|pack $(lift m')|]
+                    let value = VarE $ mkName $ map toLower m' ++ resourceName res
+                    return $ TupE [key, value]
+            let handler =
+                    if null mds
+                        then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|]
+                        else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|]
+            sub <- newName "sub"
+            mkey <- newName "mkey"
+            (dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti
+            master <- newName "master"
+            toMaster <- newName "toMaster"
+            body <- [|$(toApp) $(handler)|]
+            let func = LamE
+                        [ tsPattern
+                        , TupP
+                            [ VarP sub
+                            , VarP mkey
+                            , VarP master
+                            , VarP toMaster
+                            ]
+                        ]
+                        body
+            [|D.Route $(ps) $(m) $(return func)|]
+        Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME
diff --git a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs
new file mode 100644
index 00000000..17dd6e60
--- /dev/null
+++ b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Routes.TH.RenderRoute
+    ( -- ** RenderRoute
+      mkRenderRouteInstance
+    , mkRouteCons
+    , mkRenderRouteClauses
+    ) where
+
+import Yesod.Routes.TH.Types
+import Language.Haskell.TH.Syntax
+import Data.Maybe (maybeToList)
+import Control.Monad (replicateM)
+import Data.Text (pack)
+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
+import Yesod.Routes.Class
+
+-- | Generate the constructors of a route data type.
+mkRouteCons :: [Resource] -> [Con]
+mkRouteCons =
+    map mkRouteCon
+  where
+    mkRouteCon res =
+        NormalC (mkName $ resourceName res)
+            $ map (\x -> (NotStrict, x))
+            $ concat [singles, multi, sub]
+      where
+        singles = concatMap toSingle $ resourcePieces res
+        toSingle Static{} = []
+        toSingle (Dynamic typ) = [typ]
+
+        multi = maybeToList $ resourceMulti res
+
+        sub =
+            case resourceDispatch res of
+                Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
+                _ -> []
+
+-- | Clauses for the 'renderRoute' method.
+mkRenderRouteClauses :: [Resource] -> Q [Clause]
+mkRenderRouteClauses =
+    mapM go
+  where
+    isDynamic Dynamic{} = True
+    isDynamic _ = False
+
+    go res = do
+        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
+        dyns <- replicateM cnt $ newName "dyn"
+        sub <-
+            case resourceDispatch res of
+                Subsite{} -> fmap return $ newName "sub"
+                _ -> return []
+        let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
+
+        pack' <- [|pack|]
+        tsp <- [|toPathPiece|]
+        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns
+
+        piecesMulti <-
+            case resourceMulti res of
+                Nothing -> return $ ListE []
+                Just{} -> do
+                    tmp <- [|toPathMultiPiece|]
+                    return $ tmp `AppE` VarE (last dyns)
+
+        body <-
+            case sub of
+                [x] -> do
+                    rr <- [|renderRoute|]
+                    a <- newName "a"
+                    b <- newName "b"
+
+                    colon <- [|(:)|]
+                    let cons y ys = InfixE (Just y) colon (Just ys)
+                    let pieces = foldr cons (VarE a) piecesSingle
+
+                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
+                _ -> do
+                    colon <- [|(:)|]
+                    let cons a b = InfixE (Just a) colon (Just b)
+                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
+
+        return $ Clause [pat] (NormalB body) []
+
+    mkPieces _ _ [] _ = []
+    mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
+    mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
+    mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120"
+
+-- | Generate the 'RenderRoute' instance.
+--
+-- This includes both the 'Route' associated type and the 'renderRoute' method.
+-- This function uses both 'mkRouteCons' and 'mkRenderRouteClasses'.
+mkRenderRouteInstance :: Type -> [Resource] -> Q Dec
+mkRenderRouteInstance typ ress = do
+    cls <- mkRenderRouteClauses ress
+    return $ InstanceD [] (ConT ''RenderRoute `AppT` typ)
+        [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes
+        , FunD (mkName "renderRoute") cls
+        ]
+  where
+    clazzes = [''Show, ''Eq, ''Read]
diff --git a/yesod-routes/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs
new file mode 100644
index 00000000..bd262c21
--- /dev/null
+++ b/yesod-routes/Yesod/Routes/TH/Types.hs
@@ -0,0 +1,32 @@
+module Yesod.Routes.TH.Types
+    ( -- * Data types
+      Resource (..)
+    , Piece (..)
+    , Dispatch (..)
+      -- ** Helper functions
+    , resourceMulti
+    ) where
+
+import Language.Haskell.TH.Syntax
+
+data Resource = Resource
+    { resourceName :: String
+    , resourcePieces :: [Piece]
+    , resourceDispatch :: Dispatch
+    }
+
+data Piece = Static String | Dynamic Type
+
+data Dispatch =
+    Methods
+        { methodsMulti :: Maybe Type -- ^ type of the multi piece at the end
+        , methodsMethods :: [String] -- ^ supported request methods
+        }
+    | Subsite
+        { subsiteType :: Type
+        , subsiteFunc :: String
+        }
+
+resourceMulti :: Resource -> Maybe Type
+resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
+resourceMulti _ = Nothing
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 3f679293..5430af84 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -64,9 +64,6 @@ instance RenderRoute MySub where
         deriving (Show, Eq, Read)
     renderRoute (MySubRoute x) = x
 
-dispatchHelper :: Either String (Map.Map Text String) -> Maybe String
-dispatchHelper = undefined
-
 do
     texts <- [t|[Text]|]
     let ress =
@@ -76,12 +73,34 @@ do
             , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
             ]
     rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
-    dispatch <- [|error "FIXME dispatch"|]
+    dispatch <- mkDispatchClause ress
     return
         [ rrinst
-        , FunD (mkName "thDispatch") [Clause [] (NormalB dispatch) []]
+        , FunD (mkName "thDispatch") [dispatch]
         ]
 
+type RunHandler handler master sub app =
+        handler
+     -> master
+     -> sub
+     -> YRC.Route sub
+     -> (YRC.Route sub -> YRC.Route master)
+     -> app
+
+thDispatchAlias
+    :: (master ~ MyApp, handler ~ String)
+    => master
+    -> sub
+    -> (YRC.Route sub -> YRC.Route master)
+    -> RunHandler handler master sub app
+    -> app
+    -> [Text]
+    -> app
+thDispatchAlias = thDispatch
+
+runHandler :: RunHandler String MyApp sub (String, Maybe (YRC.Route MyApp))
+runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)
+
 main :: IO ()
 main = hspecX $ do
     describe "justRoot" $ do
@@ -119,9 +138,10 @@ main = hspecX $ do
             @?= (["subsite", "foo", "bar"], [("baz", "bin")])
 
     describe "thDispatch" $ do
-        let disp x = thDispatch () () [] () ()
-        it "routes to root" $ disp [] @?= Just "this is the root"
-        it "routes to blog post" $ disp ["blog", "somepost"] @?= Just "some blog post: somepost"
+        let disp = thDispatchAlias MyApp MyApp id runHandler ("404", Nothing)
+        it "routes to root" $ disp [] @?= ("this is the root", Just RootR)
+        it "routes to blog post" $ disp ["blog", "somepost"]
+            @?= ("some blog post: somepost", Just $ BlogPostR "somepost")
 
 getRootR :: String
 getRootR = "this is the root"

From a14851d95642f0721e5c051a7d8afea6f6ba8a94 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 3 Jan 2012 08:37:23 +0200
Subject: [PATCH 18/28] Get it to build again

---
 yesod-routes/Yesod/Routes/TH/Dispatch.hs | 6 ++++--
 yesod-routes/yesod-routes.cabal          | 3 +++
 2 files changed, 7 insertions(+), 2 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
index 02f78103..53e4247d 100644
--- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs
+++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
@@ -17,7 +17,9 @@ import Yesod.Routes.Class
 
 mkDispatchClause :: [Resource]
                  -> Q Clause
-mkDispatchClause ress = undefined
+mkDispatchClause ress = do
+    u <- [|error "mkDispatchClause"|]
+    return $ Clause [] (NormalB u) []
 {- FIXME
     let routes = fmap ListE $ mapM toRoute ress
     sub <- newName "sub"
@@ -56,7 +58,6 @@ mkTsPattern pieces mmulti = do
     go Dynamic{} = do
         dyn <- newName "dyn"
         return (Just dyn, VarP dyn)
--}
 
 -- | Convert a 'Piece' into a 'D.Piece'.
 toPiece :: Piece -> Q Exp
@@ -96,3 +97,4 @@ toRoute res = do
                         body
             [|D.Route $(ps) $(m) $(return func)|]
         Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME
+-}
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 8f8b9ba6..fee0102f 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -22,6 +22,9 @@ library
     exposed-modules: Yesod.Routes.Dispatch
                      Yesod.Routes.TH
                      Yesod.Routes.Class
+    other-modules:   Yesod.Routes.TH.Dispatch
+                     Yesod.Routes.TH.RenderRoute
+                     Yesod.Routes.TH.Types
     ghc-options:     -Wall
 
 test-suite runtests

From 928f39b795f463a7f6bca492df03eb4e7145cd6f Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 3 Jan 2012 11:11:41 +0200
Subject: [PATCH 19/28] Manually wrote proper dispatch function, need to
 translate to TH

---
 yesod-routes/test/main.hs       | 150 +++++++++++++++++++++++++++-----
 yesod-routes/yesod-routes.cabal |   1 +
 2 files changed, 127 insertions(+), 24 deletions(-)

diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 5430af84..a48e2eaf 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -2,17 +2,22 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
 import Test.HUnit ((@?=))
-import Data.Text (Text, unpack)
+import Data.Text (Text, unpack, singleton)
 import Yesod.Routes.Dispatch hiding (Static, Dynamic)
 import Yesod.Routes.Class hiding (Route)
 import qualified Yesod.Routes.Class as YRC
+import Web.PathPieces
 import qualified Yesod.Routes.Dispatch as D
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
 import qualified Data.Map as Map
+import Data.Maybe (fromMaybe)
 
 result :: ([Text] -> Maybe Int) -> Dispatch Int
 result f ts = f ts
@@ -64,13 +69,26 @@ instance RenderRoute MySub where
         deriving (Show, Eq, Read)
     renderRoute (MySubRoute x) = x
 
+getMySub :: MyApp -> MySub
+getMySub MyApp = MySub
+
+data MySubParam = MySubParam Int
+instance RenderRoute MySubParam where
+    data YRC.Route MySubParam = ParamRoute Char
+        deriving (Show, Eq, Read)
+    renderRoute (ParamRoute x) = ([singleton x], [])
+
+getMySubParam :: MyApp -> Int -> MySubParam
+getMySubParam _ = MySubParam
+
 do
     texts <- [t|[Text]|]
     let ress =
             [ Resource "RootR" [] $ Methods Nothing ["GET"]
-            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET"]
+            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET", "POST"]
             , Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
             , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
+            , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
             ]
     rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
     dispatch <- mkDispatchClause ress
@@ -79,27 +97,100 @@ do
         , FunD (mkName "thDispatch") [dispatch]
         ]
 
-type RunHandler handler master sub app =
-        handler
-     -> master
-     -> sub
-     -> YRC.Route sub
-     -> (YRC.Route sub -> YRC.Route master)
-     -> app
+class Dispatcher handler master sub app where
+    dispatcher
+        :: master
+        -> sub
+        -> (YRC.Route sub -> YRC.Route master)
+        -> app -- ^ 404 page
+        -> handler -- ^ 405 page
+        -> Text -- ^ method
+        -> [Text]
+        -> app
+
+class RunHandler handler master sub app where
+    runHandler
+        :: handler
+        -> master
+        -> sub
+        -> YRC.Route sub
+        -> (YRC.Route sub -> YRC.Route master)
+        -> app
+
+instance Dispatcher [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
+    dispatcher = thDispatchAlias
+
+instance RunHandler [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
+    runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)
+
+instance Dispatcher [Char] master MySub ([Char], Maybe (YRC.Route master)) where
+    dispatcher _ _ toMaster _ _ _ pieces = ("subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))
+
+instance Dispatcher [Char] master MySubParam ([Char], Maybe (YRC.Route master)) where
+    dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =
+        case map unpack pieces of
+            [[c]] -> ("subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
+            _ -> app404
 
 thDispatchAlias
-    :: (master ~ MyApp, handler ~ String)
+    :: (master ~ MyApp, sub ~ MyApp, handler ~ String, app ~ (String, Maybe (YRC.Route MyApp)))
     => master
     -> sub
     -> (YRC.Route sub -> YRC.Route master)
-    -> RunHandler handler master sub app
-    -> app
+    -> app -- ^ 404 page
+    -> handler -- ^ 405 page
+    -> Text -- ^ method
     -> [Text]
     -> app
-thDispatchAlias = thDispatch
-
-runHandler :: RunHandler String MyApp sub (String, Maybe (YRC.Route MyApp))
-runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)
+--thDispatchAlias = thDispatch
+thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
+    case dispatch pieces0 of
+        Just (Left (route, mhandler)) ->
+            let handler = fromMaybe handler405 $ mhandler method0
+             in runHandler handler master sub route toMaster
+        Just (Right f) -> f master sub toMaster app404 handler405 method0
+        Nothing -> app404
+  where
+    dispatch = toDispatch
+        [ Route [] False $ \pieces ->
+            case pieces of
+                [] -> do
+                    Just $ Left (RootR, \method ->
+                        case Map.lookup method methodsRootR of
+                            Just f -> Just f
+                            Nothing -> Nothing)
+                _ -> error "Invariant violated"
+        , Route [D.Static "blog", D.Dynamic] False $ \pieces ->
+            case pieces of
+                [_, x2] -> do
+                    y2 <- fromPathPiece x2
+                    Just $ Left (BlogPostR y2, \method ->
+                        case Map.lookup method methodsBlogPostR of
+                            Just f -> Just (f y2)
+                            Nothing -> Nothing)
+                _ -> error "Invariant violated"
+        , Route [D.Static "wiki"] True $ \pieces ->
+            case pieces of
+                _:x2 -> do
+                    y2 <- fromPathMultiPiece x2
+                    Just $ Left (WikiR y2, const $ Just $ handleWikiR y2)
+                _ -> error "Invariant violated"
+        , Route [D.Static "subsite"] True $ \pieces ->
+            case pieces of
+                _:x2 -> do
+                    Just $ Right $ \master' sub' toMaster' app404' handler405' method ->
+                        dispatcher master' (getMySub sub') (toMaster' . SubsiteR) app404' handler405' method x2
+                _ -> error "Invariant violated"
+        , Route [D.Static "subparam", D.Dynamic] True $ \pieces ->
+            case pieces of
+                _:x2:x3 -> do
+                    y2 <- fromPathPiece x2
+                    Just $ Right $ \master' sub' toMaster' app404' handler405' method ->
+                        dispatcher master' (getMySubParam sub' y2) (toMaster' . SubparamR y2) app404' handler405' method x3
+                _ -> error "Invariant violated"
+        ]
+    methodsRootR = Map.fromList [("GET", getRootR)]
+    methodsBlogPostR = Map.fromList [("GET", getBlogPostR), ("POST", postBlogPostR)]
 
 main :: IO ()
 main = hspecX $ do
@@ -136,22 +227,33 @@ main = hspecX $ do
         it "renders wiki correctly" $ renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], [])
         it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")]))
             @?= (["subsite", "foo", "bar"], [("baz", "bin")])
+        it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c')
+            @?= (["subparam", "6", "c"], [])
 
     describe "thDispatch" $ do
-        let disp = thDispatchAlias MyApp MyApp id runHandler ("404", Nothing)
-        it "routes to root" $ disp [] @?= ("this is the root", Just RootR)
-        it "routes to blog post" $ disp ["blog", "somepost"]
+        let disp = thDispatchAlias MyApp MyApp id ("404", Nothing) "405"
+        it "routes to root" $ disp "GET" [] @?= ("this is the root", Just RootR)
+        it "POST root is 405" $ disp "POST" [] @?= ("405", Just RootR)
+        it "invalid page is a 404" $ disp "GET" ["not-found"] @?= ("404", Nothing)
+        it "routes to blog post" $ disp "GET" ["blog", "somepost"]
             @?= ("some blog post: somepost", Just $ BlogPostR "somepost")
+        it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"]
+            @?= ("POST some blog post: somepost2", Just $ BlogPostR "somepost2")
+        it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"]
+            @?= ("the wiki: [\"foo\",\"bar\"]", Just $ WikiR ["foo", "bar"])
+        it "routes to subsite" $ disp "PUT" ["subsite", "baz"]
+            @?= ("subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute (["baz"], []))
+        it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"]
+            @?= ("subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')
 
 getRootR :: String
 getRootR = "this is the root"
 
-{- FIXME
 getBlogPostR :: Text -> String
 getBlogPostR t = "some blog post: " ++ unpack t
--}
-getBlogPostR = undefined
 
-handleWikiR = "the wiki"
+postBlogPostR :: Text -> String
+postBlogPostR t = "POST some blog post: " ++ unpack t
 
-handleSubsiteR = "a subsite"
+handleWikiR :: [Text] -> String
+handleWikiR ts = "the wiki: " ++ show ts
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index fee0102f..8a76e74e 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -39,6 +39,7 @@ test-suite runtests
                  , hspec                     >= 0.6      && < 0.10
                  , containers
                  , template-haskell
+                 , path-pieces
     ghc-options:     -Wall
 
 source-repository head

From dc8f7946dc4e3b6d32c819dfba5b9c330c2442e8 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 3 Jan 2012 11:35:16 +0200
Subject: [PATCH 20/28] Better dispatch sample code

---
 yesod-routes/Yesod/Routes/TH/Dispatch.hs | 56 +++++++++++++++++++++++-
 yesod-routes/test/main.hs                | 33 +++++++-------
 2 files changed, 73 insertions(+), 16 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
index 53e4247d..35b15249 100644
--- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs
+++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
@@ -14,12 +14,66 @@ import qualified Data.Map as Map
 import Data.Char (toLower)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
+import Data.Maybe (catMaybes)
+import Control.Applicative ((<$>))
 
 mkDispatchClause :: [Resource]
                  -> Q Clause
 mkDispatchClause ress = do
+    -- Allocate the names to be used. Start off with the names passed to the
+    -- function itself (with a 0 suffix).
+    master0 <- newName "master0"
+    sub0 <- newName "sub0"
+    toMaster0 <- newName "toMaster0"
+    app4040 <- newName "app4040"
+    handler4050 <- newName "handler4050"
+    method0 <- newName "method0"
+    pieces0 <- newName "pieces0"
+
+    -- The following names will be used internally. We don't reuse names so as
+    -- to avoid shadowing names (triggers warnings with -Wall). Additionally,
+    -- we want to ensure that none of the code passed to toDispatch uses
+    -- variables from the closure to prevent the dispatch data structure from
+    -- being rebuilt on each run.
+    master <- newName "master"
+    sub <- newName "sub"
+    toMaster <- newName "toMaster"
+    app404 <- newName "app404"
+    handler405 <- newName "handler405"
+    method <- newName "method"
+    pieces <- newName "pieces"
+
+    -- Name of the dispatch function itself
+    dispatch <- newName "dispatch"
+
+    -- The input to the clause.
+    let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]
+
+    -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
+    methodMaps <- catMaybes <$> mapM buildMethodMap ress
+
     u <- [|error "mkDispatchClause"|]
-    return $ Clause [] (NormalB u) []
+    return $ Clause pats (NormalB u) methodMaps
+
+-- | Determine the name of the method map for a given resource name.
+methodMapName :: String -> Name
+methodMapName s = mkName $ "methods" ++ s
+
+buildMethodMap :: Resource -> Q (Maybe Dec)
+buildMethodMap (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
+buildMethodMap (Resource name _ (Methods _ methods)) = do
+    fromList <- [|Map.fromList|]
+    methods' <- mapM go methods
+    let exp = fromList `AppE` ListE methods'
+    let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
+    return $ Just fun
+  where
+    go method = do
+        let func = VarE $ mkName $ map toLower method ++ name
+        pack' <- [|pack|]
+        return $ TupE [pack' `AppE` LitE (StringL method), func]
+buildMethodMap (Resource _ _ Subsite{}) = return Nothing
+
 {- FIXME
     let routes = fmap ListE $ mapM toRoute ress
     sub <- newName "sub"
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index a48e2eaf..9d3fd20f 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -145,47 +145,50 @@ thDispatchAlias
 --thDispatchAlias = thDispatch
 thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
     case dispatch pieces0 of
-        Just (Left (route, mhandler)) ->
-            let handler = fromMaybe handler405 $ mhandler method0
-             in runHandler handler master sub route toMaster
-        Just (Right f) -> f master sub toMaster app404 handler405 method0
+        Just f -> f master sub toMaster app404 handler405 method0
         Nothing -> app404
   where
     dispatch = toDispatch
         [ Route [] False $ \pieces ->
             case pieces of
                 [] -> do
-                    Just $ Left (RootR, \method ->
-                        case Map.lookup method methodsRootR of
-                            Just f -> Just f
-                            Nothing -> Nothing)
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                        let handler =
+                                case Map.lookup method methodsRootR of
+                                    Just f -> f
+                                    Nothing -> handler405'
+                         in runHandler handler master' sub' RootR toMaster'
                 _ -> error "Invariant violated"
         , Route [D.Static "blog", D.Dynamic] False $ \pieces ->
             case pieces of
                 [_, x2] -> do
                     y2 <- fromPathPiece x2
-                    Just $ Left (BlogPostR y2, \method ->
-                        case Map.lookup method methodsBlogPostR of
-                            Just f -> Just (f y2)
-                            Nothing -> Nothing)
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                        let handler =
+                                case Map.lookup method methodsBlogPostR of
+                                    Just f -> f y2
+                                    Nothing -> handler405'
+                         in runHandler handler master' sub' (BlogPostR y2) toMaster'
                 _ -> error "Invariant violated"
         , Route [D.Static "wiki"] True $ \pieces ->
             case pieces of
                 _:x2 -> do
                     y2 <- fromPathMultiPiece x2
-                    Just $ Left (WikiR y2, const $ Just $ handleWikiR y2)
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                        let handler = handleWikiR y2
+                         in runHandler handler master' sub' (WikiR y2) toMaster'
                 _ -> error "Invariant violated"
         , Route [D.Static "subsite"] True $ \pieces ->
             case pieces of
                 _:x2 -> do
-                    Just $ Right $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
                         dispatcher master' (getMySub sub') (toMaster' . SubsiteR) app404' handler405' method x2
                 _ -> error "Invariant violated"
         , Route [D.Static "subparam", D.Dynamic] True $ \pieces ->
             case pieces of
                 _:x2:x3 -> do
                     y2 <- fromPathPiece x2
-                    Just $ Right $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' app404' handler405' method ->
                         dispatcher master' (getMySubParam sub' y2) (toMaster' . SubparamR y2) app404' handler405' method x3
                 _ -> error "Invariant violated"
         ]

From c946fd206884bae847a33f9fd8d88b3268dee25a Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 3 Jan 2012 12:34:34 +0200
Subject: [PATCH 21/28] Disaptch TH code mostly written

---
 yesod-routes/Yesod/Routes/TH/Dispatch.hs | 242 ++++++++++++++---------
 yesod-routes/test/main.hs                |  33 ++--
 2 files changed, 167 insertions(+), 108 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
index 35b15249..d017d2d6 100644
--- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs
+++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
@@ -7,7 +7,7 @@ module Yesod.Routes.TH.Dispatch
 import Yesod.Routes.TH.Types
 import Language.Haskell.TH.Syntax
 import Data.Maybe (maybeToList, catMaybes)
-import Control.Monad (replicateM)
+import Control.Monad (replicateM, forM)
 import Data.Text (pack)
 import qualified Yesod.Routes.Dispatch as D
 import qualified Data.Map as Map
@@ -16,12 +16,20 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
 import Data.Maybe (catMaybes)
 import Control.Applicative ((<$>))
+import Data.List (foldl')
 
-mkDispatchClause :: [Resource]
+mkDispatchClause :: Q Exp -- ^ runHandler function
+                 -> Q Exp -- ^ dispatcher function
+                 -> [Resource]
                  -> Q Clause
-mkDispatchClause ress = do
+mkDispatchClause runHandler dispatcher ress = do
     -- Allocate the names to be used. Start off with the names passed to the
     -- function itself (with a 0 suffix).
+    --
+    -- We don't reuse names so as to avoid shadowing names (triggers warnings
+    -- with -Wall). Additionally, we want to ensure that none of the code
+    -- passed to toDispatch uses variables from the closure to prevent the
+    -- dispatch data structure from being rebuilt on each run.
     master0 <- newName "master0"
     sub0 <- newName "sub0"
     toMaster0 <- newName "toMaster0"
@@ -30,30 +38,31 @@ mkDispatchClause ress = do
     method0 <- newName "method0"
     pieces0 <- newName "pieces0"
 
-    -- The following names will be used internally. We don't reuse names so as
-    -- to avoid shadowing names (triggers warnings with -Wall). Additionally,
-    -- we want to ensure that none of the code passed to toDispatch uses
-    -- variables from the closure to prevent the dispatch data structure from
-    -- being rebuilt on each run.
-    master <- newName "master"
-    sub <- newName "sub"
-    toMaster <- newName "toMaster"
-    app404 <- newName "app404"
-    handler405 <- newName "handler405"
-    method <- newName "method"
-    pieces <- newName "pieces"
-
-    -- Name of the dispatch function itself
+    -- Name of the dispatch function
     dispatch <- newName "dispatch"
 
+    -- Dispatch function applied to the pieces
+    let dispatched = VarE dispatch `AppE` VarE pieces0
+
+    -- The 'D.Route's used in the dispatch function
+    routes <- mapM (buildRoute runHandler dispatcher) ress
+
+    -- The dispatch function itself
+    toDispatch <- [|D.toDispatch|]
+    let dispatchFun = FunD dispatch [Clause [] (NormalB $ toDispatch `AppE` ListE routes) []]
+
     -- The input to the clause.
     let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]
 
     -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
     methodMaps <- catMaybes <$> mapM buildMethodMap ress
 
-    u <- [|error "mkDispatchClause"|]
-    return $ Clause pats (NormalB u) methodMaps
+    u <- [|case $(return dispatched) of
+            Just f -> f $(return $ VarE master0)
+                        $(return $ VarE sub0)
+            Nothing -> $(return $ VarE app4040)
+          |]
+    return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
 
 -- | Determine the name of the method map for a given resource name.
 methodMapName :: String -> Name
@@ -74,81 +83,130 @@ buildMethodMap (Resource name _ (Methods _ methods)) = do
         return $ TupE [pack' `AppE` LitE (StringL method), func]
 buildMethodMap (Resource _ _ Subsite{}) = return Nothing
 
-{- FIXME
-    let routes = fmap ListE $ mapM toRoute ress
-    sub <- newName "sub"
-    mkey <- newName "mkey"
-    ts <- newName "ts"
-    master <- newName "master"
-    toMaster <- newName "toMaster"
-    let pats =
-            [ VarP sub
-            , VarP mkey
-            , VarP ts
-            , VarP master
-            , VarP toMaster
+-- | Build a single 'D.Route' expression.
+buildRoute :: Q Exp -> Q Exp -> Resource -> Q Exp
+buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
+    -- First two arguments to D.Route
+    routePieces <- ListE <$> mapM convertPiece resPieces
+    isMulti <-
+        case resDisp of
+            Methods Nothing _ -> [|False|]
+            _ -> [|True|]
+
+    [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher name resPieces resDisp)|]
+
+routeArg3 runHandler dispatcher name resPieces resDisp = do
+    pieces <- newName "pieces"
+
+    -- Allocate input piece variables (xs) and variables that have been
+    -- converted via fromPathPiece (ys)
+    xs <- forM resPieces $ \piece ->
+        case piece of
+            Static _ -> return Nothing
+            Dynamic _ -> Just <$> newName "x"
+
+    ys <- forM (catMaybes xs) $ \x -> do
+        y <- newName "y"
+        return (x, y)
+
+    -- In case we have multi pieces at the end
+    xrest <- newName "xrest"
+    yrest <- newName "yrest"
+
+    -- Determine the pattern for matching the pieces
+    pat <-
+        case resDisp of
+            Methods Nothing _ -> return $ ListP $ map (maybe WildP VarP) xs
+            _ -> do
+                let cons = mkName ":"
+                return $ foldr (\a b -> ConP cons [maybe WildP VarP a, b]) (VarP xrest) xs
+
+    -- Convert the xs
+    fromPathPiece' <- [|fromPathPiece|]
+    xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x)
+
+    -- Convert the xrest if appropriate
+    (reststmts, yrest') <-
+        case resDisp of
+            Methods (Just _) _ -> do
+                fromPathMultiPiece' <- [|fromPathMultiPiece|]
+                return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest])
+            _ -> return ([], [])
+
+    -- The final expression that actually uses the values we've computed
+    caller <- buildCaller runHandler dispatcher name resDisp $ map snd ys ++ yrest'
+
+    -- Put together all the statements
+    just <- [|Just|]
+    let stmts = concat
+            [ xstmts
+            , reststmts
+            , [NoBindS $ just `AppE` caller]
             ]
 
-    dispatch <- newName "dispatch"
-    body <- [|D.toDispatch $(routes)|]
-    return $ Clause
-        pats
-        (NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster]))
-        [FunD dispatch [Clause [] (NormalB body) []]]
-  where
+    errorMsg <- [|error "Invariant violated"|]
+    let matches =
+            [ Match pat (NormalB $ DoE stmts) []
+            , Match WildP (NormalB errorMsg) []
+            ]
 
-mkTsPattern :: [Piece] -> Maybe t -> Q ([Name], Maybe Name, Pat)
-mkTsPattern pieces mmulti = do
-    end <-
-        case mmulti of
-            Nothing -> return (Nothing, ConP (mkName "[]") [])
-            Just{} -> do
-                end <- newName "end"
-                return (Just end, VarP end)
-    pieces' <- mapM go pieces
-    return (catMaybes $ map fst pieces', fst end, foldr (flip InfixP $ mkName ":") (snd end) $ map snd pieces')
-  where
-    go Static{} = return (Nothing, WildP)
-    go Dynamic{} = do
-        dyn <- newName "dyn"
-        return (Just dyn, VarP dyn)
+    return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
 
--- | Convert a 'Piece' into a 'D.Piece'.
-toPiece :: Piece -> Q Exp
-toPiece (Static s) = [|D.Static $ pack $(lift s)|]
-toPiece Dynamic{} = [|D.Dynamic|]
+-- | The final expression in the individual Route definitions.
+buildCaller runHandler dispatcher name resDisp ys = do
+    master <- newName "master"
+    sub <- newName "sub"
+    toMaster <- newName "toMaster"
+    app404 <- newName "app404"
+    handler405 <- newName "handler405"
+    method <- newName "method"
 
--- | Convert a 'Resource' into a 'D.Route'.
-toRoute :: Resource -> Q Exp
-toRoute res = do
-    let ps = fmap ListE $ mapM toPiece $ resourcePieces res
-    let m = maybe [|False|] (const [|True|]) $ resourceMulti res
-    case resourceDispatch res of
-        Methods mmulti mds -> do
-            let toPair m' = do
-                    key <- [|pack $(lift m')|]
-                    let value = VarE $ mkName $ map toLower m' ++ resourceName res
-                    return $ TupE [key, value]
-            let handler =
-                    if null mds
-                        then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|]
-                        else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|]
-            sub <- newName "sub"
-            mkey <- newName "mkey"
-            (dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti
-            master <- newName "master"
-            toMaster <- newName "toMaster"
-            body <- [|$(toApp) $(handler)|]
-            let func = LamE
-                        [ tsPattern
-                        , TupP
-                            [ VarP sub
-                            , VarP mkey
-                            , VarP master
-                            , VarP toMaster
-                            ]
-                        ]
-                        body
-            [|D.Route $(ps) $(m) $(return func)|]
-        Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME
--}
+    let pat = map VarP [master, sub, toMaster, app404, handler405, method]
+
+    -- Create the route
+    let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
+
+    exp <-
+        case resDisp of
+            Methods _ ms -> do
+                handler <- newName "handler"
+
+                -- Figure out what the handler is
+                handlerExp <-
+                    if null ms
+                        then return $ foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
+                        else do
+                            mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
+                            f <- newName "f"
+                            let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
+                            return $ CaseE mf
+                                [ Match (ConP 'Just [VarP f]) (NormalB apply) []
+                                , Match (ConP 'Nothing []) (NormalB $ VarE handler405) []
+                                ]
+
+                -- Run the whole thing
+                runner <- [|$(runHandler)
+                                $(return $ VarE handler)
+                                $(return $ VarE master)
+                                $(return $ VarE sub)
+                                $(return route)
+                                $(return $ VarE toMaster)|]
+
+                return $ LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
+            Subsite _ getSub -> do
+                let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys
+                [|$(dispatcher)
+                    $(return $ VarE master)
+                    $(return sub2)
+                    ($(return $ VarE toMaster) . $(return route))
+                    $(return $ VarE app404)
+                    $(return $ VarE handler405)
+                    $(return $ VarE method)
+                 |]
+
+    return $ LamE pat exp
+
+-- | Convert a 'Piece' to a 'D.Piece'
+convertPiece :: Piece -> Q Exp
+convertPiece (Static s) = [|D.Static $(lift s)|]
+convertPiece (Dynamic _) = [|D.Dynamic|]
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 9d3fd20f..2a0184b2 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -81,22 +81,6 @@ instance RenderRoute MySubParam where
 getMySubParam :: MyApp -> Int -> MySubParam
 getMySubParam _ = MySubParam
 
-do
-    texts <- [t|[Text]|]
-    let ress =
-            [ Resource "RootR" [] $ Methods Nothing ["GET"]
-            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET", "POST"]
-            , Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
-            , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
-            , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
-            ]
-    rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
-    dispatch <- mkDispatchClause ress
-    return
-        [ rrinst
-        , FunD (mkName "thDispatch") [dispatch]
-        ]
-
 class Dispatcher handler master sub app where
     dispatcher
         :: master
@@ -117,8 +101,25 @@ class RunHandler handler master sub app where
         -> (YRC.Route sub -> YRC.Route master)
         -> app
 
+do
+    texts <- [t|[Text]|]
+    let ress =
+            [ Resource "RootR" [] $ Methods Nothing ["GET"]
+            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET", "POST"]
+            , Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
+            , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
+            , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
+            ]
+    rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
+    dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] ress
+    return
+        [ rrinst
+        , FunD (mkName "thDispatch") [dispatch]
+        ]
+
 instance Dispatcher [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
     dispatcher = thDispatchAlias
+    --dispatcher = thDispatch
 
 instance RunHandler [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
     runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)

From 09750605a8476a7f85c990c47fe96f2940f7b281 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 3 Jan 2012 12:55:08 +0200
Subject: [PATCH 22/28] Dispatching works! (w00t)

---
 yesod-routes/Yesod/Routes/TH/Dispatch.hs | 35 +++++++++++++-----
 yesod-routes/test/main.hs                | 45 +++++++++++++-----------
 2 files changed, 51 insertions(+), 29 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
index d017d2d6..e1806d60 100644
--- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs
+++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
@@ -4,17 +4,16 @@ module Yesod.Routes.TH.Dispatch
       mkDispatchClause
     ) where
 
+import Prelude hiding (exp)
 import Yesod.Routes.TH.Types
 import Language.Haskell.TH.Syntax
-import Data.Maybe (maybeToList, catMaybes)
-import Control.Monad (replicateM, forM)
+import Data.Maybe (catMaybes)
+import Control.Monad (forM)
 import Data.Text (pack)
 import qualified Yesod.Routes.Dispatch as D
 import qualified Data.Map as Map
 import Data.Char (toLower)
 import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
-import Yesod.Routes.Class
-import Data.Maybe (catMaybes)
 import Control.Applicative ((<$>))
 import Data.List (foldl')
 
@@ -60,6 +59,10 @@ mkDispatchClause runHandler dispatcher ress = do
     u <- [|case $(return dispatched) of
             Just f -> f $(return $ VarE master0)
                         $(return $ VarE sub0)
+                        $(return $ VarE toMaster0)
+                        $(return $ VarE app4040)
+                        $(return $ VarE handler4050)
+                        $(return $ VarE method0)
             Nothing -> $(return $ VarE app4040)
           |]
     return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
@@ -95,6 +98,12 @@ buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
 
     [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher name resPieces resDisp)|]
 
+routeArg3 :: Q Exp -- ^ runHandler
+          -> Q Exp -- ^ dispatcher
+          -> String -- ^ name of resource
+          -> [Piece]
+          -> Dispatch
+          -> Q Exp
 routeArg3 runHandler dispatcher name resPieces resDisp = do
     pieces <- newName "pieces"
 
@@ -134,7 +143,7 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
             _ -> return ([], [])
 
     -- The final expression that actually uses the values we've computed
-    caller <- buildCaller runHandler dispatcher name resDisp $ map snd ys ++ yrest'
+    caller <- buildCaller runHandler dispatcher xrest name resDisp $ map snd ys ++ yrest'
 
     -- Put together all the statements
     just <- [|Just|]
@@ -153,13 +162,20 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
     return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
 
 -- | The final expression in the individual Route definitions.
-buildCaller runHandler dispatcher name resDisp ys = do
+buildCaller :: Q Exp -- ^ runHandler
+            -> Q Exp -- ^ dispatcher
+            -> Name -- ^ xrest
+            -> String -- ^ name of resource
+            -> Dispatch
+            -> [Name] -- ^ ys
+            -> Q Exp
+buildCaller runHandler dispatcher xrest name resDisp ys = do
     master <- newName "master"
     sub <- newName "sub"
     toMaster <- newName "toMaster"
-    app404 <- newName "app404"
-    handler405 <- newName "handler405"
-    method <- newName "method"
+    app404 <- newName "_app404"
+    handler405 <- newName "_handler405"
+    method <- newName "_method"
 
     let pat = map VarP [master, sub, toMaster, app404, handler405, method]
 
@@ -202,6 +218,7 @@ buildCaller runHandler dispatcher name resDisp ys = do
                     $(return $ VarE app404)
                     $(return $ VarE handler405)
                     $(return $ VarE method)
+                    $(return $ VarE xrest)
                  |]
 
     return $ LamE pat exp
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 2a0184b2..5d40ecec 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -5,6 +5,8 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
 import Test.HUnit ((@?=))
@@ -17,7 +19,6 @@ import qualified Yesod.Routes.Dispatch as D
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
 import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
 
 result :: ([Text] -> Maybe Int) -> Dispatch Int
 result f ts = f ts
@@ -81,25 +82,28 @@ instance RenderRoute MySubParam where
 getMySubParam :: MyApp -> Int -> MySubParam
 getMySubParam _ = MySubParam
 
-class Dispatcher handler master sub app where
+type Handler sub master = String
+type App sub master = (String, Maybe (YRC.Route master))
+
+class Dispatcher sub master where
     dispatcher
         :: master
         -> sub
         -> (YRC.Route sub -> YRC.Route master)
-        -> app -- ^ 404 page
-        -> handler -- ^ 405 page
+        -> App sub master -- ^ 404 page
+        -> Handler sub master -- ^ 405 page
         -> Text -- ^ method
         -> [Text]
-        -> app
+        -> App sub master
 
-class RunHandler handler master sub app where
+class RunHandler sub master where
     runHandler
-        :: handler
+        :: Handler sub master
         -> master
         -> sub
         -> YRC.Route sub
         -> (YRC.Route sub -> YRC.Route master)
-        -> app
+        -> App sub master
 
 do
     texts <- [t|[Text]|]
@@ -114,20 +118,21 @@ do
     dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] ress
     return
         [ rrinst
-        , FunD (mkName "thDispatch") [dispatch]
+        , InstanceD
+            []
+            (ConT ''Dispatcher
+                `AppT` ConT ''MyApp
+                `AppT` ConT ''MyApp)
+            [FunD (mkName "dispatcher") [dispatch]]
         ]
 
-instance Dispatcher [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
-    dispatcher = thDispatchAlias
-    --dispatcher = thDispatch
-
-instance RunHandler [Char] MyApp MyApp ([Char], Maybe (YRC.Route MyApp)) where
+instance RunHandler MyApp master where
     runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)
 
-instance Dispatcher [Char] master MySub ([Char], Maybe (YRC.Route master)) where
+instance Dispatcher MySub master where
     dispatcher _ _ toMaster _ _ _ pieces = ("subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))
 
-instance Dispatcher [Char] master MySubParam ([Char], Maybe (YRC.Route master)) where
+instance Dispatcher MySubParam master where
     dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =
         case map unpack pieces of
             [[c]] -> ("subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
@@ -153,7 +158,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
         [ Route [] False $ \pieces ->
             case pieces of
                 [] -> do
-                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' _app404' handler405' method ->
                         let handler =
                                 case Map.lookup method methodsRootR of
                                     Just f -> f
@@ -164,7 +169,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
             case pieces of
                 [_, x2] -> do
                     y2 <- fromPathPiece x2
-                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' _app404' handler405' method ->
                         let handler =
                                 case Map.lookup method methodsBlogPostR of
                                     Just f -> f y2
@@ -175,7 +180,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
             case pieces of
                 _:x2 -> do
                     y2 <- fromPathMultiPiece x2
-                    Just $ \master' sub' toMaster' app404' handler405' method ->
+                    Just $ \master' sub' toMaster' _app404' _handler405' _method ->
                         let handler = handleWikiR y2
                          in runHandler handler master' sub' (WikiR y2) toMaster'
                 _ -> error "Invariant violated"
@@ -235,7 +240,7 @@ main = hspecX $ do
             @?= (["subparam", "6", "c"], [])
 
     describe "thDispatch" $ do
-        let disp = thDispatchAlias MyApp MyApp id ("404", Nothing) "405"
+        let disp = dispatcher MyApp MyApp id ("404" :: String, Nothing) "405"
         it "routes to root" $ disp "GET" [] @?= ("this is the root", Just RootR)
         it "POST root is 405" $ disp "POST" [] @?= ("405", Just RootR)
         it "invalid page is a 404" $ disp "GET" ["not-found"] @?= ("404", Nothing)

From fa4fd5690fce79d13e3513b0f548c471fa2ba3d0 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 3 Jan 2012 13:41:41 +0200
Subject: [PATCH 23/28] Updated yesod-routes docs

---
 yesod-routes/Yesod/Routes/TH/Dispatch.hs | 47 ++++++++++++++++++++++++
 yesod-routes/test/main.hs                |  4 +-
 2 files changed, 49 insertions(+), 2 deletions(-)

diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
index e1806d60..84b1d9c8 100644
--- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs
+++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
@@ -17,6 +17,53 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Control.Applicative ((<$>))
 import Data.List (foldl')
 
+-- |
+--
+-- This function will generate a single clause that will address all your
+-- routing needs. It takes three arguments. The third (a list of 'Resource's)
+-- is self-explanatory. We\'ll discuss the first two. But first, let\'s cover
+-- the terminology.
+--
+-- Dispatching involves a master type and a sub type. When you dispatch to the
+-- top level type, master and sub are the same. Each time to dispatch to
+-- another subsite, the sub changes. This requires two changes:
+--
+-- * Getting the new sub value. This is handled via 'subsiteFunc'.
+--
+-- * Figure out a way to convert sub routes to the original master route. To
+-- address this, we keep a toMaster function, and each time we dispatch to a
+-- new subsite, we compose it with the constructor for that subsite.
+--
+-- Dispatching acts on two different components: the request method and a list
+-- of path pieces. If we cannot match the path pieces, we need to return a 404
+-- response. If the path pieces match, but the method is not supported, we need
+-- to return a 405 response.
+--
+-- The final result of dispatch is going to be an application type. A simple
+-- example would be the WAI Application type. However, our handler functions
+-- will need more input: the master/subsite, the toMaster function, and the
+-- type-safe route. Therefore, we need to have another type, the handler type,
+-- and a function that turns a handler into an application, i.e.
+--
+-- > runHandler :: handler sub master -> master -> sub -> Route sub -> (Route sub -> Route master) -> app
+--
+-- This is the first argument to our function. Note that this will almost
+-- certainly need to be a method of a typeclass, since it will want to behave
+-- differently based on the subsite.
+--
+-- Note that the 404 response passed in is an application, while the 405
+-- response is a handler, since the former can\'t be passed the type-safe
+-- route.
+--
+-- In the case of a subsite, we don\'t directly deal with a handler function.
+-- Instead, we redispatch to the subsite, passing on the updated sub value and
+-- toMaster function, as well as any remaining, unparsed path pieces. This
+-- function looks like:
+--
+-- > dispatcher :: master -> sub -> (Route sub -> Route master) -> app -> handler sub master -> Text -> [Text] -> app
+--
+-- Where the parameters mean master, sub, toMaster, 404 response, 405 response,
+-- request method and path pieces.
 mkDispatchClause :: Q Exp -- ^ runHandler function
                  -> Q Exp -- ^ dispatcher function
                  -> [Resource]
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 5d40ecec..9384c52e 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -14,11 +14,9 @@ import Data.Text (Text, unpack, singleton)
 import Yesod.Routes.Dispatch hiding (Static, Dynamic)
 import Yesod.Routes.Class hiding (Route)
 import qualified Yesod.Routes.Class as YRC
-import Web.PathPieces
 import qualified Yesod.Routes.Dispatch as D
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
-import qualified Data.Map as Map
 
 result :: ([Text] -> Maybe Int) -> Dispatch Int
 result f ts = f ts
@@ -138,6 +136,7 @@ instance Dispatcher MySubParam master where
             [[c]] -> ("subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
             _ -> app404
 
+{-
 thDispatchAlias
     :: (master ~ MyApp, sub ~ MyApp, handler ~ String, app ~ (String, Maybe (YRC.Route MyApp)))
     => master
@@ -200,6 +199,7 @@ thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
         ]
     methodsRootR = Map.fromList [("GET", getRootR)]
     methodsBlogPostR = Map.fromList [("GET", getBlogPostR), ("POST", postBlogPostR)]
+-}
 
 main :: IO ()
 main = hspecX $ do

From c499e880b62363c5c72080f79d866b7eedbd53e2 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 3 Jan 2012 20:33:51 +0200
Subject: [PATCH 24/28] yesod-core compiles with yesod-routes (tests fail)

---
 package-list.sh                            |   3 +-
 yesod-core/Yesod/Dispatch.hs               | 119 ++++----
 yesod-core/Yesod/Handler.hs                |   7 +-
 yesod-core/Yesod/Internal/Core.hs          |  45 +--
 yesod-core/Yesod/Internal/Dispatch.hs      | 322 ---------------------
 yesod-core/Yesod/Internal/RouteParsing.hs  | 319 ++++----------------
 yesod-core/Yesod/Widget.hs                 |   3 +-
 yesod-core/test/YesodCoreTest/CleanPath.hs |   9 +-
 yesod-core/yesod-core.cabal                |   2 +-
 yesod-routes/Yesod/Routes/TH/Dispatch.hs   |  83 ++++--
 yesod-routes/Yesod/Routes/TH/Types.hs      |  44 +++
 yesod-routes/test/main.hs                  |  79 ++---
 12 files changed, 284 insertions(+), 751 deletions(-)
 delete mode 100644 yesod-core/Yesod/Internal/Dispatch.hs

diff --git a/package-list.sh b/package-list.sh
index 2205ad1d..c461efb3 100644
--- a/package-list.sh
+++ b/package-list.sh
@@ -1,6 +1,7 @@
 #!/bin/bash
 
-pkgs=(      ./yesod-core
+pkgs=(      ./yesod-routes
+            ./yesod-core
             ./yesod-json
             ./yesod-static
             ./yesod-persistent
diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs
index f7d5b174..009b4abd 100644
--- a/yesod-core/Yesod/Dispatch.hs
+++ b/yesod-core/Yesod/Dispatch.hs
@@ -28,11 +28,10 @@ import Data.Either    (partitionEithers)
 import Prelude hiding (exp)
 import Yesod.Internal.Core
 import Yesod.Handler hiding (lift)
-import Yesod.Internal.Dispatch
 import Yesod.Widget (GWidget)
 
 import Web.PathPieces
-import Yesod.Internal.RouteParsing (THResource, Pieces (..), createRoutes, createRender, Resource (..), parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
+import Yesod.Internal.RouteParsing (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
 import Language.Haskell.TH.Syntax
 
 import qualified Network.Wai as W
@@ -44,6 +43,13 @@ import Data.ByteString.Lazy.Char8 ()
 import Web.ClientSession
 import Data.Char (isUpper)
 import Data.Text (Text)
+import Data.Monoid (mappend)
+import qualified Data.ByteString as S
+import qualified Blaze.ByteString.Builder
+import Network.HTTP.Types (status301)
+import Yesod.Routes.TH
+import Yesod.Content (chooseRep)
+import Yesod.Internal.RouteParsing
 
 type Texts = [Text]
 
@@ -51,7 +57,7 @@ type Texts = [Text]
 -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
 -- Use 'parseRoutes' to create the 'Resource's.
 mkYesod :: String -- ^ name of the argument datatype
-        -> [Resource]
+        -> RouteString
         -> Q [Dec]
 mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
 
@@ -62,7 +68,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
 -- be embedded in other sites.
 mkYesodSub :: String -- ^ name of the argument datatype
            -> Cxt
-           -> [Resource]
+           -> RouteString
            -> Q [Dec]
 mkYesodSub name clazzes =
     fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
@@ -73,28 +79,28 @@ mkYesodSub name clazzes =
 -- your handlers elsewhere. For example, this is the only way to break up a
 -- monolithic file into smaller parts. Use this function, paired with
 -- 'mkYesodDispatch', to do just that.
-mkYesodData :: String -> [Resource] -> Q [Dec]
+mkYesodData :: String -> RouteString -> Q [Dec]
 mkYesodData name res = mkYesodDataGeneral name [] False res
 
-mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec]
+mkYesodSubData :: String -> Cxt -> RouteString -> Q [Dec]
 mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
 
-mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> Q [Dec]
+mkYesodDataGeneral :: String -> Cxt -> Bool -> RouteString -> Q [Dec]
 mkYesodDataGeneral name clazzes isSub res = do
     let (name':rest) = words name
     (x, _) <- mkYesodGeneral name' rest clazzes isSub res
     let rname = mkName $ "resources" ++ name
-    eres <- lift res
+    eres <- [|parseRouteString $(lift res)|]
     let y = [ SigD rname $ ListT `AppT` ConT ''Resource
             , FunD rname [Clause [] (NormalB eres) []]
             ]
     return $ x ++ y
 
 -- | See 'mkYesodData'.
-mkYesodDispatch :: String -> [Resource] -> Q [Dec]
+mkYesodDispatch :: String -> RouteString -> Q [Dec]
 mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
 
-mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec]
+mkYesodSubDispatch :: String -> Cxt -> RouteString -> Q [Dec]
 mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True 
   where (name':rest) = words name
 
@@ -102,40 +108,26 @@ mkYesodGeneral :: String -- ^ foundation name
                -> [String] -- ^ parameters for foundation
                -> Cxt -- ^ classes
                -> Bool -- ^ is subsite?
-               -> [Resource]
+               -> RouteString
                -> Q ([Dec], [Dec])
-mkYesodGeneral name args clazzes isSub res = do
-    let args' = map mkName args
-        arg = foldl AppT (ConT name') $ map VarT args'
-    th' <- mapM thResourceFromResource res
-    let th = map fst th'
-    w' <- createRoutes th
-    let routesName = mkName $ name ++ "Route"
-    let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
-    let x = TySynInstD ''Route [arg] $ ConT routesName
+mkYesodGeneral name args clazzes isSub resS = do
+    let res = parseRouteString resS
+    renderRouteDec <- mkRenderRouteInstance (ConT name') res
 
-    render <- createRender th
-    let x' = InstanceD [] (ConT ''RenderRoute `AppT` ConT routesName)
-                [ FunD (mkName "renderRoute") render
-                ]
-
-    let splitter :: (THResource, Maybe String)
-                 -> Either
-                        (THResource, Maybe String)
-                        (THResource, Maybe String)
-        splitter a@((_, SubSite{}), _) = Left a
-        splitter a = Right a
-    let (resSub, resLoc) = partitionEithers $ map splitter th'
-    yd <- mkYesodDispatch' resSub resLoc
+    disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
     let master = mkName "master"
     let ctx = if isSub
                 then ClassP (mkName "Yesod") [VarT master] : clazzes
                 else []
+    let args' = map mkName args
+        arg = foldl AppT (ConT name') $ map VarT args'
     let ytyp = if isSub
                 then ConT ''YesodDispatch `AppT` arg `AppT` VarT master
                 else ConT ''YesodDispatch `AppT` arg `AppT` arg
-    let y = InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [yd]]
-    return ([w, x, x'] ++ masterTypSyns, [y])
+    let yesodDispatch =
+            InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]
+
+    return (renderRouteDec : masterTypSyns, [yesodDispatch])
   where
     name' = mkName name
     masterTypSyns
@@ -151,45 +143,46 @@ mkYesodGeneral name args clazzes isSub res = do
                 (ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0)
             ]
 
-thResourceFromResource :: Resource -> Q (THResource, Maybe String)
-thResourceFromResource (Resource n ps atts)
-    | all (all isUpper) atts = return ((n, Simple ps atts), Nothing)
-thResourceFromResource (Resource n ps [stype, toSubArg]) = do
-    let stype' = ConT $ mkName stype
-    parse <- [|error "ssParse"|]
-    dispatch <- [|error "ssDispatch"|]
-    render <- [|renderRoute|]
-    tmg <- [|error "ssToMasterArg"|]
-    return ((n, SubSite
-        { ssType = ConT ''Route `AppT` stype'
-        , ssParse = parse
-        , ssRender = render
-        , ssDispatch = dispatch
-        , ssToMasterArg = tmg
-        , ssPieces = ps
-        }), Just toSubArg)
-
-thResourceFromResource (Resource n _ _) =
-    error $ "Invalid attributes for resource: " ++ n
-
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This is the same as 'toWaiAppPlain', except it includes two
 -- middlewares: GZIP compression and autohead. This is the
 -- recommended approach for most users.
-toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
+toWaiApp :: ( Yesod master
+            , YesodDispatch master master
+            ) => master -> IO W.Application
 toWaiApp y = gzip (gzipCompressFiles y) . autohead <$> toWaiAppPlain y
 
 -- | Convert the given argument into a WAI application, executable with any WAI
 -- handler. This differs from 'toWaiApp' in that it uses no middlewares.
-toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
+toWaiAppPlain :: ( Yesod master
+                 , YesodDispatch master master
+                 ) => master -> IO W.Application
 toWaiAppPlain a = toWaiApp' a <$> encryptKey a
 
 
-toWaiApp' :: (Yesod y, YesodDispatch y y)
-          => y
+toWaiApp' :: ( Yesod master
+             , YesodDispatch master master
+             )
+          => master
           -> Maybe Key
           -> W.Application
 toWaiApp' y key' env =
-    case yesodDispatch y key' (W.pathInfo env) y id of
-        Just app -> app env
-        Nothing -> yesodRunner y y id key' Nothing notFound env
+    yesodDispatch y y id app404 handler405 method (W.pathInfo env) key' env
+  where
+    app404 = yesodRunner notFound y y Nothing id
+    handler405 = error "handler405"
+    method = error "method"
+
+sendRedirect :: Yesod master => master -> [Text] -> W.Application
+sendRedirect y segments' env =
+     return $ W.responseLBS status301
+            [ ("Content-Type", "text/plain")
+            , ("Location", Blaze.ByteString.Builder.toByteString dest')
+            ] "Redirecting"
+  where
+    dest = joinPath y (approot y) segments' []
+    dest' =
+        if S.null (W.rawQueryString env)
+            then dest
+            else (dest `mappend`
+                 Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs
index 86841b07..3b8813e2 100644
--- a/yesod-core/Yesod/Handler.hs
+++ b/yesod-core/Yesod/Handler.hs
@@ -24,8 +24,7 @@
 ---------------------------------------------------------
 module Yesod.Handler
     ( -- * Type families
-      Route
-    , YesodSubRoute (..)
+      YesodSubRoute (..)
       -- * Handler monad
     , GHandler
       -- ** Read information from handler
@@ -174,9 +173,7 @@ import Network.Wai (requestBody)
 import Data.Conduit (($$))
 import Control.Monad.Trans.Control
 import Control.Monad.Base
-
--- | The type-safe URLs associated with a site argument.
-type family Route a
+import Yesod.Routes.Class
 
 class YesodSubRoute s y where
     fromSubRoute :: s -> y -> Route s -> Route y
diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs
index c522fc5c..17b17085 100644
--- a/yesod-core/Yesod/Internal/Core.hs
+++ b/yesod-core/Yesod/Internal/Core.hs
@@ -33,6 +33,8 @@ module Yesod.Internal.Core
 import Yesod.Content
 import Yesod.Handler hiding (lift)
 
+import Yesod.Routes.Class
+
 import Control.Arrow ((***))
 import Control.Monad (forM)
 import Yesod.Widget
@@ -92,31 +94,34 @@ yesodVersion = "0.9.4"
 #define HAMLET $hamlet
 #endif
 
-class Eq u => RenderRoute u where
-    renderRoute :: u -> ([Text], [(Text, Text)])
-
 -- | This class is automatically instantiated when you use the template haskell
 -- mkYesod function. You should never need to deal with it directly.
-class YesodDispatch a master where
+class YesodDispatch sub master where
     yesodDispatch
         :: Yesod master
-        => a
+        => master
+        -> sub
+        -> (Route sub -> Route master)
+        -> (Maybe CS.Key -> W.Application) -- ^ 404 handler
+        -> (Route sub -> Maybe CS.Key -> W.Application) -- ^ 405 handler
+        -> Text -- ^ request method
+        -> [Text] -- ^ pieces
         -> Maybe CS.Key
-        -> [Text]
-        -> master
-        -> (Route a -> Route master)
-        -> Maybe W.Application
+        -> W.Application
 
     yesodRunner :: Yesod master
-                => a
+                => GHandler sub master ChooseRep
                 -> master
-                -> (Route a -> Route master)
-                -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
+                -> sub
+                -> Maybe (Route sub)
+                -> (Route sub -> Route master)
+                -> Maybe CS.Key
+                -> W.Application
     yesodRunner = defaultYesodRunner
 
 -- | Define settings for a Yesod applications. The only required setting is
 -- 'approot'; other than that, there are intelligent defaults.
-class RenderRoute (Route a) => Yesod a where
+class RenderRoute a => Yesod a where
     -- | An absolute URL to the root of the application. Do not include
     -- trailing slash.
     --
@@ -322,14 +327,14 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
     char = show . snd . loc_start
 
 defaultYesodRunner :: Yesod master
-                   => a
+                   => GHandler sub master ChooseRep
                    -> master
-                   -> (Route a -> Route master)
+                   -> sub
+                   -> Maybe (Route sub)
+                   -> (Route sub -> Route master)
                    -> Maybe CS.Key
-                   -> Maybe (Route a)
-                   -> GHandler a master ChooseRep
                    -> W.Application
-defaultYesodRunner _ m toMaster _ murl _ req
+defaultYesodRunner _ m _ murl toMaster _ req
     | maximumContentLength m (fmap toMaster murl) < len =
         return $ W.responseLBS
             (H.Status 413 "Too Large")
@@ -341,7 +346,7 @@ defaultYesodRunner _ m toMaster _ murl _ req
         case reads $ S8.unpack s of
             [] -> Nothing
             (x, _):_ -> Just x
-defaultYesodRunner s master toMasterRoute mkey murl handler req = do
+defaultYesodRunner handler master sub murl toMasterRoute mkey req = do
     now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime
     let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now
     let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master
@@ -374,7 +379,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
                 handler
     let sessionMap = Map.fromList
                    $ filter (\(x, _) -> x /= nonceKey) session'
-    yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
+    yar <- handlerToYAR master sub toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
     let mnonce = reqNonce rr
     -- FIXME should we be caching this IV value and reusing it for efficiency?
     iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey
diff --git a/yesod-core/Yesod/Internal/Dispatch.hs b/yesod-core/Yesod/Internal/Dispatch.hs
deleted file mode 100644
index 5b0aa73f..00000000
--- a/yesod-core/Yesod/Internal/Dispatch.hs
+++ /dev/null
@@ -1,322 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE OverloadedStrings #-}
--- | A bunch of Template Haskell used in the Yesod.Dispatch module.
-module Yesod.Internal.Dispatch
-    ( mkYesodDispatch'
-    ) where
-
-import Prelude hiding (exp)
-import Language.Haskell.TH.Syntax
-import Web.PathPieces
-import Yesod.Internal.RouteParsing
-import Control.Monad (foldM)
-import Yesod.Handler (badMethod)
-import Yesod.Content (chooseRep)
-import qualified Network.Wai as W
-import Yesod.Internal.Core (yesodRunner, yesodDispatch)
-import Data.List (foldl')
-import Data.Char (toLower)
-import qualified Data.ByteString as S
-import Yesod.Internal.Core (Yesod (joinPath, approot, cleanPath))
-import Network.HTTP.Types (status301)
-import Data.Text (Text)
-import Data.Monoid (mappend)
-import qualified Blaze.ByteString.Builder
-import qualified Data.ByteString.Char8 as S8
-import qualified Data.Text
-
-{-|
-
-Alright, let's explain how routing works. We want to take a [String] and found
-out which route it applies to. For static pieces, we need to ensure an exact
-match against the segment. For a single or multi piece, we need to check the
-result of fromPathPiece/fromMultiPathPiece, respectively.
-
-We want to create a tree of case statements basically resembling:
-
-case testRoute1 of
-    Just app -> Just app
-    Nothing ->
-        case testRoute2 of
-            Just app -> Just app
-            Nothing ->
-                case testRoute3 of
-                    Just app -> Just app
-                    Nothing -> Nothing
-
-Each testRoute* will look something like this (example of parsing a route /name/#String/age/#Int):
-
-case segments of
-    "name" : as ->
-        case as of
-            [] -> Nothing
-            b:bs ->
-                case fromPathPiece b of
-                    Left _ -> Nothing
-                    Right name ->
-                        case bs of
-                            "age":cs ->
-                                case cs of
-                                    [] -> Nothing
-                                    d:ds ->
-                                        case fromPathPiece d of
-                                            Left _ -> Nothing
-                                            Right age ->
-                                                case ds of
-                                                    [] -> Just $ yesodRunner (PersonR name age) (getPersonR name age)...
-                                                    _ -> Nothing
-                            _ -> Nothing
-    _ -> Nothing
-
-Obviously we would never want to write code by hand like this, but generating it is not too bad.
-
-This function generates a clause for the yesodDispatch function based on a set of routes.
-
-NOTE: We deal with subsites first; if none of those match, we try to apply
-cleanPath. If that indicates a redirect, we perform it. Otherwise, we match
-local routes.
-
--}
-
-sendRedirect :: Yesod master => master -> [Text] -> W.Application
-sendRedirect y segments' env =
-     return $ W.responseLBS status301
-            [ ("Content-Type", "text/plain")
-            , ("Location", Blaze.ByteString.Builder.toByteString dest')
-            ] "Redirecting"
-  where
-    dest = joinPath y (approot y) segments' []
-    dest' =
-        if S.null (W.rawQueryString env)
-            then dest
-            else (dest `mappend`
-                 Blaze.ByteString.Builder.fromByteString (W.rawQueryString env))
-
-mkYesodDispatch' :: [((String, Pieces), Maybe String)]
-                 -> [((String, Pieces), Maybe String)]
-                 -> Q Clause
-mkYesodDispatch' resSub resLoc = do
-    sub <- newName "sub"
-    master <- newName "master"
-    mkey <- newName "mkey"
-    segments <- newName "segments"
-    segments' <- newName "segmentsClean"
-    toMasterRoute <- newName "toMasterRoute"
-    nothing <- [|Nothing|]
-    bodyLoc <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments') nothing resLoc
-    cp <- [|cleanPath|]
-    sr <- [|sendRedirect|]
-    just <- [|Just|]
-    let bodyLoc' =
-            CaseE (cp `AppE` VarE master `AppE` VarE segments)
-                [ Match (ConP (mkName "Left") [VarP segments'])
-                        (NormalB $ just `AppE`
-                           (sr `AppE` VarE master `AppE` VarE segments'))
-                        []
-                , Match (ConP (mkName "Right") [VarP segments'])
-                        (NormalB bodyLoc)
-                        []
-                ]
-    body <- foldM (go master (VarE sub) (VarE toMasterRoute) mkey segments) bodyLoc' resSub
-    return $ Clause
-        [VarP sub, VarP mkey, VarP segments, VarP master, VarP toMasterRoute]
-        (NormalB body)
-        []
-  where
-    go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
-        test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, VarE $ mkName toSub)
-        app <- newName "app"
-        return $ CaseE test
-            [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
-            , Match (ConP (mkName "Just") [VarP app]) (NormalB $ VarE app) []
-            ]
-    go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
-        test <- mkSimpleExp (VarE segments) pieces id (master, sub, toMasterRoute, mkey, constr, methods)
-        just <- [|Just|]
-        app <- newName "app"
-        return $ CaseE test
-            [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
-            , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
-            ]
-    go _ _ _ _ _ _ _ = error "Invalid combination"
-
-mkSimpleExp :: Exp -- ^ segments
-            -> [Piece]
-            -> ([Exp] -> [Exp]) -- ^ variables already parsed
-            -> (Name, Exp, Exp, Name, String, [String]) -- ^ master, sub, toMasterRoute, mkey, constructor, methods
-            -> Q Exp
-mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do
-    just <- [|Just|]
-    nothing <- [|Nothing|]
-    onSuccess <- newName "onSuccess"
-    req <- newName "req"
-    badMethod' <- [|badMethod|]
-    rm <- [|S8.unpack . W.requestMethod|]
-    let caseExp = rm `AppE` VarE req
-    yr <- [|yesodRunner|]
-    cr <- [|fmap chooseRep|]
-    eq <- [|(==)|]
-    let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
-    let runHandlerVars h = runHandler' $ cr `AppE` foldl' AppE (VarE $ mkName h) (frontVars [])
-        runHandler' h = yr `AppE` sub
-                           `AppE` VarE master
-                           `AppE` toMasterRoute
-                           `AppE` VarE mkey
-                           `AppE` (just `AppE` url)
-                           `AppE` h
-                           `AppE` VarE req
-    let match :: String -> Q Match
-        match m = do
-            x <- newName "x"
-            return $ Match
-                (VarP x)
-                (GuardedB
-                    [ ( NormalG $ InfixE (Just $ VarE x) eq (Just $ LitE $ StringL m) -- FIXME need to pack, right?
-                      , runHandlerVars $ map toLower m ++ constr
-                      )
-                    ])
-                []
-    clauses <-
-        case methods of
-            [] -> return [Clause [VarP req] (NormalB $ runHandlerVars $ "handle" ++ constr) []]
-            _ -> do
-                matches <- mapM match methods
-                return [Clause [VarP req] (NormalB $ CaseE caseExp $ matches ++
-                                                               [Match WildP (NormalB $ runHandler' badMethod') []]) []]
-    let exp = CaseE segments
-                [ Match
-                    (ConP (mkName "[]") [])
-                    (NormalB $ just `AppE` VarE onSuccess)
-                    [FunD onSuccess clauses]
-                , Match
-                    WildP
-                    (NormalB nothing)
-                    []
-                ]
-    return exp
-mkSimpleExp segments (StaticPiece s:pieces) frontVars x = do
-    srest <- newName "segments"
-    innerExp <- mkSimpleExp (VarE srest) pieces frontVars x
-    nothing <- [|Nothing|]
-    y <- newName "y"
-    pack <- [|Data.Text.pack|]
-    eq <- [|(==)|]
-    let exp = CaseE segments
-                [ Match
-                    (InfixP (VarP y) (mkName ":") (VarP srest))
-                    (GuardedB
-                        [ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
-                          , innerExp
-                          )
-                        ])
-                    []
-                , Match WildP (NormalB nothing) []
-                ]
-    return exp
-mkSimpleExp segments (SinglePiece _:pieces) frontVars x = do
-    srest <- newName "segments"
-    next' <- newName "next'"
-    innerExp <- mkSimpleExp (VarE srest) pieces (frontVars . (:) (VarE next')) x
-    nothing <- [|Nothing|]
-    next <- newName "next"
-    fsp <- [|fromPathPiece|]
-    let exp' = CaseE (fsp `AppE` VarE next)
-                [ Match
-                    (ConP (mkName "Nothing") [])
-                    (NormalB nothing)
-                    []
-                , Match
-                    (ConP (mkName "Just") [VarP next'])
-                    (NormalB innerExp)
-                    []
-                ]
-    let exp = CaseE segments
-                [ Match
-                    (InfixP (VarP next) (mkName ":") (VarP srest))
-                    (NormalB exp')
-                    []
-                , Match WildP (NormalB nothing) []
-                ]
-    return exp
-mkSimpleExp segments [MultiPiece _] frontVars x = do
-    next' <- newName "next'"
-    srest <- [|[]|]
-    innerExp <- mkSimpleExp srest [] (frontVars . (:) (VarE next')) x
-    nothing <- [|Nothing|]
-    fmp <- [|fromPathMultiPiece|]
-    let exp = CaseE (fmp `AppE` segments)
-                [ Match
-                    (ConP (mkName "Nothing") [])
-                    (NormalB nothing)
-                    []
-                , Match
-                    (ConP (mkName "Just") [VarP next'])
-                    (NormalB innerExp)
-                    []
-                ]
-    return exp
-mkSimpleExp _ (MultiPiece _:_) _ _ = error "MultiPiece must be last piece"
-
-mkSubsiteExp :: Name -- ^ segments
-             -> [Piece]
-             -> ([Exp] -> [Exp]) -- ^ variables already parsed
-             -> (Name, Exp, Exp, Name, String, Exp) -- ^ master, sub, toMasterRoute, mkey, constructor, toSub
-             -> Q Exp
-mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do
-    yd <- [|yesodDispatch|]
-    dot <- [|(.)|]
-    let con = InfixE (Just toMasterRoute) dot $ Just $ foldl' AppE (ConE $ mkName constr) $ frontVars []
-    -- proper handling for sub-subsites
-    let sub' = foldl' AppE (toSub `AppE` sub) $ frontVars []
-    let app = yd `AppE` sub'
-                 `AppE` VarE mkey
-                 `AppE` VarE segments
-                 `AppE` VarE master
-                 `AppE` con
-    just <- [|Just|]
-    return $ just `AppE` app
-mkSubsiteExp _ (MultiPiece _:_) _ _ = error "Subsites cannot have MultiPiece"
-mkSubsiteExp segments (StaticPiece s:pieces) frontVars x = do
-    srest <- newName "segments"
-    innerExp <- mkSubsiteExp srest pieces frontVars x
-    nothing <- [|Nothing|]
-    y <- newName "y"
-    pack <- [|Data.Text.pack|]
-    eq <- [|(==)|]
-    let exp = CaseE (VarE segments)
-                [ Match
-                    (InfixP (VarP y) (mkName ":") (VarP srest))
-                    (GuardedB
-                        [ ( NormalG $ InfixE (Just $ VarE y) eq (Just $ pack `AppE` (LitE $ StringL s))
-                          , innerExp
-                          )
-                        ])
-                    []
-                , Match WildP (NormalB nothing) []
-                ]
-    return exp
-mkSubsiteExp segments (SinglePiece _:pieces) frontVars x = do
-    srest <- newName "segments"
-    next' <- newName "next'"
-    innerExp <- mkSubsiteExp srest pieces (frontVars . (:) (VarE next')) x
-    nothing <- [|Nothing|]
-    next <- newName "next"
-    fsp <- [|fromPathPiece|]
-    let exp' = CaseE (fsp `AppE` VarE next)
-                [ Match
-                    (ConP (mkName "Nothing") [])
-                    (NormalB nothing)
-                    []
-                , Match
-                    (ConP (mkName "Just") [VarP next'])
-                    (NormalB innerExp)
-                    []
-                ]
-    let exp = CaseE (VarE segments)
-                [ Match
-                    (InfixP (VarP next) (mkName ":") (VarP srest))
-                    (NormalB exp')
-                    []
-                , Match WildP (NormalB nothing) []
-                ]
-    return exp
diff --git a/yesod-core/Yesod/Internal/RouteParsing.hs b/yesod-core/Yesod/Internal/RouteParsing.hs
index e1f9f734..4d9a1d39 100644
--- a/yesod-core/Yesod/Internal/RouteParsing.hs
+++ b/yesod-core/Yesod/Internal/RouteParsing.hs
@@ -2,18 +2,12 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
 module Yesod.Internal.RouteParsing
-    ( createRoutes
-    , createRender
-    , createParse
-    , createDispatch
-    , Pieces (..)
-    , THResource
-    , parseRoutes
+    ( parseRoutes
     , parseRoutesFile
     , parseRoutesNoCheck
     , parseRoutesFileNoCheck
-    , Resource (..)
-    , Piece (..)
+    , RouteString
+    , parseRouteString
     ) where
 
 import Web.PathPieces
@@ -21,204 +15,12 @@ import Language.Haskell.TH.Syntax
 import Data.Maybe
 import Data.Either
 import Data.List
-import Data.Char (toLower)
+import Data.Char (toLower, isUpper)
 import qualified Data.Text
 import Language.Haskell.TH.Quote
 import Data.Data
 import qualified System.IO as SIO
-
-data Pieces =
-    SubSite
-        { ssType :: Type
-        , ssParse :: Exp
-        , ssRender :: Exp
-        , ssDispatch :: Exp
-        , ssToMasterArg :: Exp
-        , ssPieces :: [Piece]
-        }
-  | Simple [Piece] [String] -- ^ methods
-    deriving Show
-type THResource = (String, Pieces)
-
-createRoutes :: [THResource] -> Q [Con]
-createRoutes res =
-    return $ map go res
-  where
-    go (n, SubSite{ssType = s, ssPieces = pieces}) =
-        NormalC (mkName n) $ mapMaybe go' pieces ++ [(NotStrict, s)]
-    go (n, Simple pieces _) = NormalC (mkName n) $ mapMaybe go' pieces
-    go' (SinglePiece x) = Just (NotStrict, ConT $ mkName x)
-    go' (MultiPiece x) = Just (NotStrict, ConT $ mkName x)
-    go' (StaticPiece _) = Nothing
-
--- | Generates the set of clauses necesary to parse the given 'Resource's. See 'quasiParse'.
-createParse :: [THResource] -> Q [Clause]
-createParse res = do
-    final' <- final
-    clauses <- mapM go res
-    return $ if areResourcesComplete res
-                then clauses
-                else clauses ++ [final']
-  where
-    cons x y = ConP (mkName ":") [x, y]
-    go (constr, SubSite{ssParse = p, ssPieces = ps}) = do
-        ri <- [|Right|]
-        be <- [|ape|]
-        (pat', parse) <- mkPat' be ps $ ri `AppE` ConE (mkName constr)
-        
-        x <- newName "x"
-        let pat = init pat' ++ [VarP x]
-
-        --let pat = foldr (\a b -> cons [LitP (StringL a), b]) (VarP x) pieces
-        let eitherSub = p `AppE` VarE x
-        let bod = be `AppE` parse `AppE` eitherSub
-        --let bod = fmape' `AppE` ConE (mkName constr) `AppE` eitherSub
-        return $ Clause [foldr1 cons pat] (NormalB bod) []
-    go (n, Simple ps _) = do
-        ri <- [|Right|]
-        be <- [|ape|]
-        (pat, parse) <- mkPat' be ps $ ri `AppE` ConE (mkName n)
-        return $ Clause [foldr1 cons pat] (NormalB parse) []
-    final = do
-        no <- [|Left "Invalid URL"|]
-        return $ Clause [WildP] (NormalB no) []
-    mkPat' :: Exp -> [Piece] -> Exp -> Q ([Pat], Exp)
-    mkPat' be [MultiPiece s] parse = do
-        v <- newName $ "var" ++ s
-        fmp <- [|fromPathMultiPiece|]
-        let parse' = InfixE (Just parse) be $ Just $ fmp `AppE` VarE v
-        return ([VarP v], parse')
-    mkPat' _ (MultiPiece _:_) _parse = error "MultiPiece must be last"
-    mkPat' be (StaticPiece s:rest) parse = do
-        (x, parse') <- mkPat' be rest parse
-        let sp = LitP $ StringL s
-        return (sp : x, parse')
-    mkPat' be (SinglePiece s:rest) parse = do
-        fsp <- [|fromPathPiece|]
-        v <- newName $ "var" ++ s
-        let parse' = InfixE (Just parse) be $ Just $ fsp `AppE` VarE v
-        (x, parse'') <- mkPat' be rest parse'
-        return (VarP v : x, parse'')
-    mkPat' _ [] parse = return ([ListP []], parse)
-
--- | 'ap' for 'Either'
-ape :: Either String (a -> b) -> Either String a -> Either String b
-ape (Left e) _ = Left e
-ape (Right _) (Left e) = Left e
-ape (Right f) (Right a) = Right $ f a
-
--- | Generates the set of clauses necesary to render the given 'Resource's. See
--- 'quasiRender'.
-createRender :: [THResource] -> Q [Clause]
-createRender = mapM go
-  where
-    go (n, Simple ps _) = do
-        let ps' = zip [1..] ps
-        let pat = ConP (mkName n) $ mapMaybe go' ps'
-        bod <- mkBod ps'
-        return $ Clause [pat] (NormalB $ TupE [bod, ListE []]) []
-    go (n, SubSite{ssRender = r, ssPieces = pieces}) = do
-        cons' <- [|\a (b, c) -> (a ++ b, c)|]
-        let cons a b = cons' `AppE` a `AppE` b
-        x <- newName "x"
-        let r' = r `AppE` VarE x
-        let pieces' = zip [1..] pieces
-        let pat = ConP (mkName n) $ mapMaybe go' pieces' ++ [VarP x]
-        bod <- mkBod pieces'
-        return $ Clause [pat] (NormalB $ cons bod r') []
-    go' (_, StaticPiece _) = Nothing
-    go' (i, _) = Just $ VarP $ mkName $ "var" ++ show (i :: Int)
-    mkBod :: (Show t) => [(t, Piece)] -> Q Exp
-    mkBod [] = lift ([] :: [String])
-    mkBod ((_, StaticPiece x):xs) = do
-        x' <- lift x
-        pack <- [|Data.Text.pack|]
-        xs' <- mkBod xs
-        return $ ConE (mkName ":") `AppE` (pack `AppE` x') `AppE` xs'
-    mkBod ((i, SinglePiece _):xs) = do
-        let x' = VarE $ mkName $ "var" ++ show i
-        tsp <- [|toPathPiece|]
-        let x'' = tsp `AppE` x'
-        xs' <- mkBod xs
-        return $ ConE (mkName ":") `AppE` x'' `AppE` xs'
-    mkBod ((i, MultiPiece _):_) = do
-        let x' = VarE $ mkName $ "var" ++ show i
-        tmp <- [|toPathMultiPiece|]
-        return $ tmp `AppE` x'
-
--- | Whether the set of resources cover all possible URLs.
-areResourcesComplete :: [THResource] -> Bool
-areResourcesComplete res =
-    let (slurps, noSlurps) = partitionEithers $ mapMaybe go res
-     in case slurps of
-            [] -> False
-            _ -> let minSlurp = minimum slurps
-                  in helper minSlurp $ reverse $ sort noSlurps
-  where
-    go :: THResource -> Maybe (Either Int Int)
-    go (_, Simple ps _) =
-        case reverse ps of
-            [] -> Just $ Right 0
-            (MultiPiece _:rest) -> go' Left rest
-            x -> go' Right x
-    go (n, SubSite{ssPieces = ps}) =
-        go (n, Simple (ps ++ [MultiPiece ""]) [])
-    go' b x = if all isSingle x then Just (b $ length x) else Nothing
-    helper 0 _ = True
-    helper _ [] = False
-    helper m (i:is)
-        | i >= m = helper m is
-        | i + 1 == m = helper i is
-        | otherwise = False
-    isSingle (SinglePiece _) = True
-    isSingle _ = False
-
-notStatic :: Piece -> Bool
-notStatic StaticPiece{} = False
-notStatic _ = True
-
-createDispatch :: Exp -- ^ modify a master handler
-               -> Exp -- ^ convert a subsite handler to a master handler
-               -> [THResource]
-               -> Q [Clause]
-createDispatch modMaster toMaster = mapM go
-  where
-    go :: (String, Pieces) -> Q Clause
-    go (n, Simple ps methods) = do
-        meth <- newName "method"
-        xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
-        let pat = [ ConP (mkName n) $ map VarP xs
-                  , if null methods then WildP else VarP meth
-                  ]
-        bod <- go' n meth xs methods
-        return $ Clause pat (NormalB bod) []
-    go (n, SubSite{ssDispatch = d, ssToMasterArg = tma, ssPieces = ps}) = do
-        meth <- newName "method"
-        x <- newName "x"
-        xs <- mapM newName $ replicate (length $ filter notStatic ps) "x"
-        let pat = [ConP (mkName n) $ map VarP xs ++ [VarP x], VarP meth]
-        let bod = d `AppE` VarE x `AppE` VarE meth
-        fmap' <- [|fmap|]
-        let routeToMaster = foldl AppE (ConE (mkName n)) $ map VarE xs
-            tma' = foldl AppE tma $ map VarE xs
-        let toMaster' = toMaster `AppE` routeToMaster `AppE` tma' `AppE` VarE x
-        let bod' = InfixE (Just toMaster') fmap' (Just bod)
-        let bod'' = InfixE (Just modMaster) fmap' (Just bod')
-        return $ Clause pat (NormalB bod'') []
-    go' n _ xs [] = do
-        jus <- [|Just|]
-        let bod = foldl AppE (VarE $ mkName $ "handle" ++ n) $ map VarE xs
-        return $ jus `AppE` (modMaster `AppE` bod)
-    go' n meth xs methods = do
-        noth <- [|Nothing|]
-        j <- [|Just|]
-        let noMatch = Match WildP (NormalB noth) []
-        return $ CaseE (VarE meth) $ map (go'' n xs j) methods ++ [noMatch]
-    go'' n xs j method =
-        let pat = LitP $ StringL method
-            func = map toLower method ++ n
-            bod = foldl AppE (VarE $ mkName func) $ map VarE xs
-         in Match pat (NormalB $ j `AppE` (modMaster `AppE` bod)) []
+import Yesod.Routes.TH
 
 -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for
 -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the
@@ -226,15 +28,24 @@ createDispatch modMaster toMaster = mapM go
 parseRoutes :: QuasiQuoter
 parseRoutes = QuasiQuoter
     { quoteExp = x
-    , quotePat = y
     }
   where
     x s = do
         let res = resourcesFromString s
         case findOverlaps res of
-            [] -> lift res
-            z -> error $ "Overlapping routes: " ++ unlines (map show z)
-    y = dataToPatQ (const Nothing) . resourcesFromString
+            [] -> liftParse s
+            z -> error $ "Overlapping routes: " ++ unlines (map (unwords . map resourceName) z)
+
+newtype RouteString = RouteString String
+
+liftParse :: String -> Q Exp
+liftParse s = [|RouteString s|]
+
+parseRouteString :: RouteString -> [Resource]
+parseRouteString (RouteString s) = resourcesFromString s
+
+instance Lift RouteString where
+    lift (RouteString s) = [|RouteString $(lift s)|]
 
 parseRoutesFile :: FilePath -> Q Exp
 parseRoutesFile fp = do
@@ -255,51 +66,8 @@ readUtf8File fp = do
 -- | Same as 'parseRoutes', but performs no overlap checking.
 parseRoutesNoCheck :: QuasiQuoter
 parseRoutesNoCheck = QuasiQuoter
-    { quoteExp = x
-    , quotePat = y
+    { quoteExp = liftParse
     }
-  where
-    x = lift . resourcesFromString
-    y = dataToPatQ (const Nothing) . resourcesFromString
-
-instance Lift Resource where
-    lift (Resource s ps h) = do
-        r <- [|Resource|]
-        s' <- lift s
-        ps' <- lift ps
-        h' <- lift h
-        return $ r `AppE` s' `AppE` ps' `AppE` h'
-
--- | A single resource pattern.
---
--- First argument is the name of the constructor, second is the URL pattern to
--- match, third is how to dispatch.
-data Resource = Resource String [Piece] [String]
-    deriving (Read, Show, Eq, Data, Typeable)
-
--- | A single piece of a URL, delimited by slashes.
---
--- In the case of StaticPiece, the argument is the value of the piece; for the
--- other constructors, it is the name of the parameter represented by this
--- piece. That value is not used here, but may be useful elsewhere.
-data Piece = StaticPiece String
-           | SinglePiece String
-           | MultiPiece String
-    deriving (Read, Show, Eq, Data, Typeable)
-
-instance Lift Piece where
-    lift (StaticPiece s) = do
-        c <- [|StaticPiece|]
-        s' <- lift s
-        return $ c `AppE` s'
-    lift (SinglePiece s) = do
-        c <- [|SinglePiece|]
-        s' <- lift s
-        return $ c `AppE` s'
-    lift (MultiPiece s) = do
-        c <- [|MultiPiece|]
-        s' <- lift s
-        return $ c `AppE` s'
 
 -- | Convert a multi-line string to a set of resources. See documentation for
 -- the format of this string. This is a partial function which calls 'error' on
@@ -311,28 +79,48 @@ resourcesFromString =
     go s =
         case takeWhile (/= "--") $ words s of
             (pattern:constr:rest) ->
-                let pieces = piecesFromString $ drop1Slash pattern
-                 in Just $ Resource constr pieces rest
+                let (pieces, mmulti) = piecesFromString $ drop1Slash pattern
+                    disp = dispatchFromString rest mmulti
+                 in Just $ Resource constr pieces disp
             [] -> Nothing
             _ -> error $ "Invalid resource line: " ++ s
 
+dispatchFromString :: [String] -> Maybe Type -> Dispatch
+dispatchFromString rest mmulti
+    | null rest = Methods mmulti []
+    | all (all isUpper) rest = Methods mmulti rest
+dispatchFromString [subTyp, subFun] Nothing =
+    Subsite (parseType subTyp) subFun
+dispatchFromString [subTyp, subFun] Just{} =
+    error "Subsites cannot have a multipiece"
+dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest
+
 drop1Slash :: String -> String
 drop1Slash ('/':x) = x
 drop1Slash x = x
 
-piecesFromString :: String -> [Piece]
-piecesFromString "" = []
+piecesFromString :: String -> ([Piece], Maybe Type)
+piecesFromString "" = ([], Nothing)
 piecesFromString x =
-    let (y, z) = break (== '/') x
-     in pieceFromString y : piecesFromString (drop1Slash z)
+    case (this, rest) of
+        (Left typ, ([], Nothing)) -> ([], Just typ)
+        (Left typ, _) -> error "Multipiece must be last piece"
+        (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp)
+  where
+    (y, z) = break (== '/') x
+    this = pieceFromString y
+    rest = piecesFromString $ drop 1 z
 
-pieceFromString :: String -> Piece
-pieceFromString ('#':x) = SinglePiece x
-pieceFromString ('*':x) = MultiPiece x
-pieceFromString x = StaticPiece x
+parseType :: String -> Type
+parseType = ConT . mkName -- FIXME handle more complicated stuff
+
+pieceFromString :: String -> Either Type Piece
+pieceFromString ('#':x) = Right $ Dynamic $ parseType x
+pieceFromString ('*':x) = Left $ parseType x
+pieceFromString x = Right $ Static x
 
 -- n^2, should be a way to speed it up
-findOverlaps :: [Resource] -> [(Resource, Resource)]
+findOverlaps :: [Resource] -> [[Resource]]
 findOverlaps = go . map justPieces
   where
     justPieces :: Resource -> ([Piece], Resource)
@@ -342,8 +130,10 @@ findOverlaps = go . map justPieces
     go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
 
     mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->
-                Maybe (Resource, Resource)
-    mOverlap (StaticPiece x:xs, xr) (StaticPiece y:ys, yr)
+                Maybe [Resource]
+    mOverlap _ _ = Nothing
+                {- FIXME mOverlap
+    mOverlap (Static x:xs, xr) (Static y:ys, yr)
         | x == y = mOverlap (xs, xr) (ys, yr)
         | otherwise = Nothing
     mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
@@ -352,3 +142,4 @@ findOverlaps = go . map justPieces
     mOverlap ([], _) (_, _) = Nothing
     mOverlap (_, _) ([], _) = Nothing
     mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)
+    -}
diff --git a/yesod-core/Yesod/Widget.hs b/yesod-core/Yesod/Widget.hs
index 475f06e8..54bfcd7e 100644
--- a/yesod-core/Yesod/Widget.hs
+++ b/yesod-core/Yesod/Widget.hs
@@ -63,8 +63,9 @@ import Text.Hamlet
 import Text.Cassius
 import Text.Julius
 import Text.Coffee
+import Yesod.Routes.Class
 import Yesod.Handler
-    ( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
+    ( GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
     , getMessageRender, getUrlRenderParams, MonadLift (..)
     )
 import Yesod.Message (RenderMessage)
diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs
index b07464ea..83999b4a 100644
--- a/yesod-core/test/YesodCoreTest/CleanPath.hs
+++ b/yesod-core/test/YesodCoreTest/CleanPath.hs
@@ -20,14 +20,13 @@ data Subsite = Subsite
 getSubsite :: a -> Subsite
 getSubsite = const Subsite
 
-data SubsiteRoute = SubsiteRoute [TS.Text]
-    deriving (Eq, Show, Read)
-type instance Route Subsite = SubsiteRoute
-instance RenderRoute SubsiteRoute where
+instance RenderRoute Subsite where
+    data Route Subsite = SubsiteRoute [TS.Text]
+        deriving (Eq, Show, Read)
     renderRoute (SubsiteRoute x) = (x, [])
 
 instance YesodDispatch Subsite master where
-    yesodDispatch _ _ pieces _ _ = Just $ const $ return $ responseLBS
+    yesodDispatch _ _ _ _ _ _ pieces _ _ = return $ responseLBS
         status200
         [ ("Content-Type", "SUBSITE")
         ] $ L8.pack $ show pieces
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index 6d44c1e6..24f445ad 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -46,6 +46,7 @@ library
         build-depends: wai-test
 
     build-depends:   time                  >= 1.1.4
+                   , yesod-routes          >= 0.0      && < 0.1
                    , wai                   >= 1.0      && < 1.1
                    , wai-extra             >= 1.0      && < 1.1
                    , bytestring            >= 0.9.1.4  && < 0.10
@@ -94,7 +95,6 @@ library
                      Yesod.Internal.Core
                      Yesod.Internal.Session
                      Yesod.Internal.Request
-                     Yesod.Internal.Dispatch
                      Yesod.Internal.RouteParsing
                      Paths_yesod_core
     ghc-options:     -Wall
diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
index 84b1d9c8..ce483ee1 100644
--- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs
+++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
@@ -8,7 +8,7 @@ import Prelude hiding (exp)
 import Yesod.Routes.TH.Types
 import Language.Haskell.TH.Syntax
 import Data.Maybe (catMaybes)
-import Control.Monad (forM)
+import Control.Monad (forM, replicateM)
 import Data.Text (pack)
 import qualified Yesod.Routes.Dispatch as D
 import qualified Data.Map as Map
@@ -66,9 +66,10 @@ import Data.List (foldl')
 -- request method and path pieces.
 mkDispatchClause :: Q Exp -- ^ runHandler function
                  -> Q Exp -- ^ dispatcher function
+                 -> Q Exp -- ^ fixHandler function
                  -> [Resource]
                  -> Q Clause
-mkDispatchClause runHandler dispatcher ress = do
+mkDispatchClause runHandler dispatcher fixHandler ress = do
     -- Allocate the names to be used. Start off with the names passed to the
     -- function itself (with a 0 suffix).
     --
@@ -91,7 +92,7 @@ mkDispatchClause runHandler dispatcher ress = do
     let dispatched = VarE dispatch `AppE` VarE pieces0
 
     -- The 'D.Route's used in the dispatch function
-    routes <- mapM (buildRoute runHandler dispatcher) ress
+    routes <- mapM (buildRoute runHandler dispatcher fixHandler) ress
 
     -- The dispatch function itself
     toDispatch <- [|D.toDispatch|]
@@ -101,7 +102,7 @@ mkDispatchClause runHandler dispatcher ress = do
     let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]
 
     -- For each resource that dispatches based on methods, build up a map for handling the dispatching.
-    methodMaps <- catMaybes <$> mapM buildMethodMap ress
+    methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) ress
 
     u <- [|case $(return dispatched) of
             Just f -> f $(return $ VarE master0)
@@ -118,9 +119,11 @@ mkDispatchClause runHandler dispatcher ress = do
 methodMapName :: String -> Name
 methodMapName s = mkName $ "methods" ++ s
 
-buildMethodMap :: Resource -> Q (Maybe Dec)
-buildMethodMap (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
-buildMethodMap (Resource name _ (Methods _ methods)) = do
+buildMethodMap :: Q Exp -- ^ fixHandler
+               -> Resource
+               -> Q (Maybe Dec)
+buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
+buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
     fromList <- [|Map.fromList|]
     methods' <- mapM go methods
     let exp = fromList `AppE` ListE methods'
@@ -128,14 +131,20 @@ buildMethodMap (Resource name _ (Methods _ methods)) = do
     return $ Just fun
   where
     go method = do
+        fh <- fixHandler
         let func = VarE $ mkName $ map toLower method ++ name
         pack' <- [|pack|]
-        return $ TupE [pack' `AppE` LitE (StringL method), func]
-buildMethodMap (Resource _ _ Subsite{}) = return Nothing
+        let isDynamic Dynamic{} = True
+            isDynamic _ = False
+        let argCount = length (filter isDynamic pieces) + maybe 0 (const 1) mmulti
+        xs <- replicateM argCount $ newName "arg"
+        let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)
+        return $ TupE [pack' `AppE` LitE (StringL method), rhs]
+buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing
 
 -- | Build a single 'D.Route' expression.
-buildRoute :: Q Exp -> Q Exp -> Resource -> Q Exp
-buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
+buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource -> Q Exp
+buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do
     -- First two arguments to D.Route
     routePieces <- ListE <$> mapM convertPiece resPieces
     isMulti <-
@@ -143,15 +152,16 @@ buildRoute runHandler dispatcher (Resource name resPieces resDisp) = do
             Methods Nothing _ -> [|False|]
             _ -> [|True|]
 
-    [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher name resPieces resDisp)|]
+    [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name resPieces resDisp)|]
 
 routeArg3 :: Q Exp -- ^ runHandler
           -> Q Exp -- ^ dispatcher
+          -> Q Exp -- ^ fixHandler
           -> String -- ^ name of resource
           -> [Piece]
           -> Dispatch
           -> Q Exp
-routeArg3 runHandler dispatcher name resPieces resDisp = do
+routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
     pieces <- newName "pieces"
 
     -- Allocate input piece variables (xs) and variables that have been
@@ -190,7 +200,7 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
             _ -> return ([], [])
 
     -- The final expression that actually uses the values we've computed
-    caller <- buildCaller runHandler dispatcher xrest name resDisp $ map snd ys ++ yrest'
+    caller <- buildCaller runHandler dispatcher fixHandler xrest name resDisp $ map snd ys ++ yrest'
 
     -- Put together all the statements
     just <- [|Just|]
@@ -211,12 +221,13 @@ routeArg3 runHandler dispatcher name resPieces resDisp = do
 -- | The final expression in the individual Route definitions.
 buildCaller :: Q Exp -- ^ runHandler
             -> Q Exp -- ^ dispatcher
+            -> Q Exp -- ^ fixHandler
             -> Name -- ^ xrest
             -> String -- ^ name of resource
             -> Dispatch
             -> [Name] -- ^ ys
             -> Q Exp
-buildCaller runHandler dispatcher xrest name resDisp ys = do
+buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
     master <- newName "master"
     sub <- newName "sub"
     toMaster <- newName "toMaster"
@@ -234,28 +245,36 @@ buildCaller runHandler dispatcher xrest name resDisp ys = do
             Methods _ ms -> do
                 handler <- newName "handler"
 
-                -- Figure out what the handler is
-                handlerExp <-
-                    if null ms
-                        then return $ foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
-                        else do
-                            mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
-                            f <- newName "f"
-                            let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
-                            return $ CaseE mf
-                                [ Match (ConP 'Just [VarP f]) (NormalB apply) []
-                                , Match (ConP 'Nothing []) (NormalB $ VarE handler405) []
-                                ]
-
                 -- Run the whole thing
                 runner <- [|$(runHandler)
                                 $(return $ VarE handler)
                                 $(return $ VarE master)
                                 $(return $ VarE sub)
-                                $(return route)
+                                (Just $(return route))
                                 $(return $ VarE toMaster)|]
 
-                return $ LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
+                let myLet handlerExp =
+                        LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner
+
+                if null ms
+                    then do
+                        -- Just a single handler
+                        fh <- fixHandler
+                        let he = fh `AppE` foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
+                        return $ myLet he
+                    else do
+                        -- Individual methods
+                        mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]
+                        f <- newName "f"
+                        let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
+                        let body405 =
+                                VarE handler405
+                                `AppE` route
+                        return $ CaseE mf
+                            [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) []
+                            , Match (ConP 'Nothing []) (NormalB body405) []
+                            ]
+
             Subsite _ getSub -> do
                 let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys
                 [|$(dispatcher)
@@ -263,7 +282,7 @@ buildCaller runHandler dispatcher xrest name resDisp ys = do
                     $(return sub2)
                     ($(return $ VarE toMaster) . $(return route))
                     $(return $ VarE app404)
-                    $(return $ VarE handler405)
+                    ($(return $ VarE handler405) . $(return route))
                     $(return $ VarE method)
                     $(return $ VarE xrest)
                  |]
@@ -272,5 +291,5 @@ buildCaller runHandler dispatcher xrest name resDisp ys = do
 
 -- | Convert a 'Piece' to a 'D.Piece'
 convertPiece :: Piece -> Q Exp
-convertPiece (Static s) = [|D.Static $(lift s)|]
+convertPiece (Static s) = [|D.Static (pack $(lift s))|]
 convertPiece (Dynamic _) = [|D.Dynamic|]
diff --git a/yesod-routes/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs
index bd262c21..83f55149 100644
--- a/yesod-routes/Yesod/Routes/TH/Types.hs
+++ b/yesod-routes/Yesod/Routes/TH/Types.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Yesod.Routes.TH.Types
     ( -- * Data types
       Resource (..)
@@ -9,13 +10,48 @@ module Yesod.Routes.TH.Types
 
 import Language.Haskell.TH.Syntax
 
+liftOccName :: OccName -> Q Exp
+liftOccName oc = [|mkOccName $(lift $ occString oc)|]
+
+liftNameFlavour :: NameFlavour -> Q Exp
+liftNameFlavour NameS = [|NameS|]
+
+liftName :: Name -> Q Exp
+liftName (Name a b) = [|Name $(liftOccName a) $(liftNameFlavour b)|]
+
+liftType :: Type -> Q Exp
+liftType (VarT name) = [|VarT $(liftName name)|]
+liftType (ConT name) = [|ConT $(liftName name)|]
+liftType (TupleT i) = [|TupleT $(lift i)|]
+liftType ArrowT = [|ArrowT|]
+liftType ListT = [|ListT|]
+liftType (AppT a b) = [|AppT $(liftType a) $(liftType b)|]
+liftType (SigT a b) = [|SigT $(liftType a) $(liftKind b)|]
+
+liftKind :: Kind -> Q Exp
+liftKind StarK = [|StarK|]
+liftKind (ArrowK a b) = [|ArrowK $(liftKind a) $(liftKind b)|]
+
 data Resource = Resource
     { resourceName :: String
     , resourcePieces :: [Piece]
     , resourceDispatch :: Dispatch
     }
+    deriving Show
+
+{-
+instance Lift Resource where
+    lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]
+-}
 
 data Piece = Static String | Dynamic Type
+    deriving Show
+
+{-
+instance Lift Piece where
+    lift (Static s) = [|Static $(lift s)|]
+    lift (Dynamic t) = [|Static $(liftType t)|]
+-}
 
 data Dispatch =
     Methods
@@ -26,6 +62,14 @@ data Dispatch =
         { subsiteType :: Type
         , subsiteFunc :: String
         }
+    deriving Show
+
+{-
+instance Lift Dispatch where
+    lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
+    lift (Methods (Just t) b) = [|Methods (Just $(liftType t)) $(lift b)|]
+    lift (Subsite t b) = [|Subsite $(liftType t) $(lift b)|]
+-}
 
 resourceMulti :: Resource -> Maybe Type
 resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs
index 9384c52e..a8b2b045 100644
--- a/yesod-routes/test/main.hs
+++ b/yesod-routes/test/main.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -10,7 +9,7 @@
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
 import Test.HUnit ((@?=))
-import Data.Text (Text, unpack, singleton)
+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
@@ -18,6 +17,12 @@ import qualified Yesod.Routes.Dispatch as D
 import Yesod.Routes.TH hiding (Dispatch)
 import Language.Haskell.TH.Syntax
 
+class ToText a where
+    toText :: a -> Text
+
+instance ToText Text where toText = id
+instance ToText String where toText = pack
+
 result :: ([Text] -> Maybe Int) -> Dispatch Int
 result f ts = f ts
 
@@ -28,19 +33,19 @@ justRoot = toDispatch
 
 twoStatics :: Dispatch Int
 twoStatics = toDispatch
-    [ Route [D.Static "foo"] False $ result $ const $ Just 2
-    , Route [D.Static "bar"] False $ result $ const $ Just 3
+    [ 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 "foo"] False $ result $ const $ Just 4
-    , Route [D.Static "bar"] True $ result $ const $ Just 5
+    [ 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 "foo"] False $ result $ const $ Just 6
+    [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 6
     , Route [D.Dynamic] False $ result $ \ts ->
         case ts of
             [t] ->
@@ -52,13 +57,13 @@ dynamic = toDispatch
 
 overlap :: Dispatch Int
 overlap = toDispatch
-    [ Route [D.Static "foo"] False $ result $ const $ Just 20
-    , Route [D.Static "foo"] True $ result $ const $ Just 21
+    [ 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 -> [Text] -> Maybe Int
-test dispatch ts = dispatch ts
+test :: Dispatch Int -> [String] -> Maybe Int
+test dispatch ts = dispatch $ map pack ts
 
 data MyApp = MyApp
 
@@ -80,8 +85,8 @@ instance RenderRoute MySubParam where
 getMySubParam :: MyApp -> Int -> MySubParam
 getMySubParam _ = MySubParam
 
-type Handler sub master = String
-type App sub master = (String, Maybe (YRC.Route master))
+type Handler sub master = Text
+type App sub master = (Text, Maybe (YRC.Route master))
 
 class Dispatcher sub master where
     dispatcher
@@ -89,7 +94,7 @@ class Dispatcher sub master where
         -> sub
         -> (YRC.Route sub -> YRC.Route master)
         -> App sub master -- ^ 404 page
-        -> Handler sub master -- ^ 405 page
+        -> (YRC.Route sub -> App sub master) -- ^ 405 page
         -> Text -- ^ method
         -> [Text]
         -> App sub master
@@ -99,7 +104,7 @@ class RunHandler sub master where
         :: Handler sub master
         -> master
         -> sub
-        -> YRC.Route sub
+        -> Maybe (YRC.Route sub)
         -> (YRC.Route sub -> YRC.Route master)
         -> App sub master
 
@@ -113,7 +118,7 @@ do
             , Resource "SubparamR" [Static "subparam", Dynamic $ ConT ''Int] $ Subsite (ConT ''MySubParam) "getMySubParam"
             ]
     rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
-    dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] ress
+    dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress
     return
         [ rrinst
         , InstanceD
@@ -125,15 +130,15 @@ do
         ]
 
 instance RunHandler MyApp master where
-    runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)
+    runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
 
 instance Dispatcher MySub master where
-    dispatcher _ _ toMaster _ _ _ pieces = ("subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))
+    dispatcher _ _ toMaster _ _ _ pieces = (pack $ "subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))
 
 instance Dispatcher MySubParam master where
     dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =
         case map unpack pieces of
-            [[c]] -> ("subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
+            [[c]] -> (pack $ "subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
             _ -> app404
 
 {-
@@ -232,37 +237,37 @@ main = hspecX $ do
 
     describe "RenderRoute instance" $ do
         it "renders root correctly" $ renderRoute RootR @?= ([], [])
-        it "renders blog post correctly" $ renderRoute (BlogPostR "foo") @?= (["blog", "foo"], [])
-        it "renders wiki correctly" $ renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], [])
-        it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")]))
-            @?= (["subsite", "foo", "bar"], [("baz", "bin")])
+        it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], [])
+        it "renders wiki correctly" $ renderRoute (WikiR $ map pack ["foo", "bar"]) @?= (map pack ["wiki", "foo", "bar"], [])
+        it "renders subsite correctly" $ renderRoute (SubsiteR $ MySubRoute (map pack ["foo", "bar"], [(pack "baz", pack "bin")]))
+            @?= (map pack ["subsite", "foo", "bar"], [(pack "baz", pack "bin")])
         it "renders subsite param correctly" $ renderRoute (SubparamR 6 $ ParamRoute 'c')
-            @?= (["subparam", "6", "c"], [])
+            @?= (map pack ["subparam", "6", "c"], [])
 
     describe "thDispatch" $ do
-        let disp = dispatcher MyApp MyApp id ("404" :: String, Nothing) "405"
-        it "routes to root" $ disp "GET" [] @?= ("this is the root", Just RootR)
-        it "POST root is 405" $ disp "POST" [] @?= ("405", Just RootR)
-        it "invalid page is a 404" $ disp "GET" ["not-found"] @?= ("404", Nothing)
+        let disp m ps = dispatcher MyApp MyApp id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
+        it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR)
+        it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR)
+        it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing)
         it "routes to blog post" $ disp "GET" ["blog", "somepost"]
-            @?= ("some blog post: somepost", Just $ BlogPostR "somepost")
+            @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost")
         it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"]
-            @?= ("POST some blog post: somepost2", Just $ BlogPostR "somepost2")
+            @?= (pack "POST some blog post: somepost2", Just $ BlogPostR $ pack "somepost2")
         it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"]
-            @?= ("the wiki: [\"foo\",\"bar\"]", Just $ WikiR ["foo", "bar"])
+            @?= (pack "the wiki: [\"foo\",\"bar\"]", Just $ WikiR $ map pack ["foo", "bar"])
         it "routes to subsite" $ disp "PUT" ["subsite", "baz"]
-            @?= ("subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute (["baz"], []))
+            @?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], []))
         it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"]
-            @?= ("subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')
+            @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')
 
-getRootR :: String
-getRootR = "this is the root"
+getRootR :: Text
+getRootR = pack "this is the root"
 
 getBlogPostR :: Text -> String
 getBlogPostR t = "some blog post: " ++ unpack t
 
-postBlogPostR :: Text -> String
-postBlogPostR t = "POST some blog post: " ++ unpack t
+postBlogPostR :: Text -> Text
+postBlogPostR t = pack $ "POST some blog post: " ++ unpack t
 
 handleWikiR :: [Text] -> String
 handleWikiR ts = "the wiki: " ++ show ts

From 03da3b021ac47b13975771a30ebe643cbc11bb27 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 3 Jan 2012 20:41:48 +0200
Subject: [PATCH 25/28] tests pass, except clean path

---
 yesod-core/Yesod/Dispatch.hs | 6 ++++--
 yesod-core/Yesod/Handler.hs  | 2 +-
 2 files changed, 5 insertions(+), 3 deletions(-)

diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs
index 009b4abd..8951b192 100644
--- a/yesod-core/Yesod/Dispatch.hs
+++ b/yesod-core/Yesod/Dispatch.hs
@@ -43,6 +43,8 @@ import Data.ByteString.Lazy.Char8 ()
 import Web.ClientSession
 import Data.Char (isUpper)
 import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
 import Data.Monoid (mappend)
 import qualified Data.ByteString as S
 import qualified Blaze.ByteString.Builder
@@ -170,8 +172,8 @@ toWaiApp' y key' env =
     yesodDispatch y y id app404 handler405 method (W.pathInfo env) key' env
   where
     app404 = yesodRunner notFound y y Nothing id
-    handler405 = error "handler405"
-    method = error "method"
+    handler405 route = yesodRunner badMethod y y (Just route) id
+    method = decodeUtf8With lenientDecode $ W.requestMethod env
 
 sendRedirect :: Yesod master => master -> [Text] -> W.Application
 sendRedirect y segments' env =
diff --git a/yesod-core/Yesod/Handler.hs b/yesod-core/Yesod/Handler.hs
index 3b8813e2..0b995485 100644
--- a/yesod-core/Yesod/Handler.hs
+++ b/yesod-core/Yesod/Handler.hs
@@ -600,7 +600,7 @@ notFound :: GHandler sub master a
 notFound = hcError NotFound
 
 -- | Return a 405 method not supported page.
-badMethod :: GHandler s m a
+badMethod :: GHandler sub master a
 badMethod = do
     w <- waiRequest
     hcError $ BadMethod $ W.requestMethod w

From 1e8b15acff8ef07c21186c27375ca64d69e5c30a Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 5 Jan 2012 05:38:31 +0200
Subject: [PATCH 26/28] Move route parsing to yesod-routes

---
 yesod-core/Yesod/Dispatch.hs                  | 24 +++---
 yesod-core/yesod-core.cabal                   |  1 -
 .../Yesod/Routes/Parse.hs                     | 42 ++++-------
 yesod-routes/Yesod/Routes/TH/Dispatch.hs      | 14 ++--
 yesod-routes/Yesod/Routes/TH/RenderRoute.hs   |  6 +-
 yesod-routes/Yesod/Routes/TH/Types.hs         | 73 +++++++------------
 yesod-routes/yesod-routes.cabal               |  1 +
 7 files changed, 66 insertions(+), 95 deletions(-)
 rename yesod-core/Yesod/Internal/RouteParsing.hs => yesod-routes/Yesod/Routes/Parse.hs (79%)

diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs
index 8951b192..a1c8691e 100644
--- a/yesod-core/Yesod/Dispatch.hs
+++ b/yesod-core/Yesod/Dispatch.hs
@@ -31,7 +31,7 @@ import Yesod.Handler hiding (lift)
 import Yesod.Widget (GWidget)
 
 import Web.PathPieces
-import Yesod.Internal.RouteParsing (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
+import Yesod.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
 import Language.Haskell.TH.Syntax
 
 import qualified Network.Wai as W
@@ -51,7 +51,7 @@ import qualified Blaze.ByteString.Builder
 import Network.HTTP.Types (status301)
 import Yesod.Routes.TH
 import Yesod.Content (chooseRep)
-import Yesod.Internal.RouteParsing
+import Yesod.Routes.Parse
 
 type Texts = [Text]
 
@@ -59,7 +59,7 @@ type Texts = [Text]
 -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
 -- Use 'parseRoutes' to create the 'Resource's.
 mkYesod :: String -- ^ name of the argument datatype
-        -> RouteString
+        -> [Resource String]
         -> Q [Dec]
 mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
 
@@ -70,7 +70,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
 -- be embedded in other sites.
 mkYesodSub :: String -- ^ name of the argument datatype
            -> Cxt
-           -> RouteString
+           -> [Resource String]
            -> Q [Dec]
 mkYesodSub name clazzes =
     fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
@@ -81,28 +81,28 @@ mkYesodSub name clazzes =
 -- your handlers elsewhere. For example, this is the only way to break up a
 -- monolithic file into smaller parts. Use this function, paired with
 -- 'mkYesodDispatch', to do just that.
-mkYesodData :: String -> RouteString -> Q [Dec]
+mkYesodData :: String -> [Resource String] -> Q [Dec]
 mkYesodData name res = mkYesodDataGeneral name [] False res
 
-mkYesodSubData :: String -> Cxt -> RouteString -> Q [Dec]
+mkYesodSubData :: String -> Cxt -> [Resource String] -> Q [Dec]
 mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
 
-mkYesodDataGeneral :: String -> Cxt -> Bool -> RouteString -> Q [Dec]
+mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource String] -> Q [Dec]
 mkYesodDataGeneral name clazzes isSub res = do
     let (name':rest) = words name
     (x, _) <- mkYesodGeneral name' rest clazzes isSub res
     let rname = mkName $ "resources" ++ name
-    eres <- [|parseRouteString $(lift res)|]
+    eres <- [|fmap parseType $(lift res)|]
     let y = [ SigD rname $ ListT `AppT` ConT ''Resource
             , FunD rname [Clause [] (NormalB eres) []]
             ]
     return $ x ++ y
 
 -- | See 'mkYesodData'.
-mkYesodDispatch :: String -> RouteString -> Q [Dec]
+mkYesodDispatch :: String -> [Resource String] -> Q [Dec]
 mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
 
-mkYesodSubDispatch :: String -> Cxt -> RouteString -> Q [Dec]
+mkYesodSubDispatch :: String -> Cxt -> [Resource String] -> Q [Dec]
 mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True 
   where (name':rest) = words name
 
@@ -110,10 +110,10 @@ mkYesodGeneral :: String -- ^ foundation name
                -> [String] -- ^ parameters for foundation
                -> Cxt -- ^ classes
                -> Bool -- ^ is subsite?
-               -> RouteString
+               -> [Resource String]
                -> Q ([Dec], [Dec])
 mkYesodGeneral name args clazzes isSub resS = do
-    let res = parseRouteString resS
+    let res = map (fmap parseType) resS
     renderRouteDec <- mkRenderRouteInstance (ConT name') res
 
     disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal
index 24f445ad..121e3637 100644
--- a/yesod-core/yesod-core.cabal
+++ b/yesod-core/yesod-core.cabal
@@ -95,7 +95,6 @@ library
                      Yesod.Internal.Core
                      Yesod.Internal.Session
                      Yesod.Internal.Request
-                     Yesod.Internal.RouteParsing
                      Paths_yesod_core
     ghc-options:     -Wall
 
diff --git a/yesod-core/Yesod/Internal/RouteParsing.hs b/yesod-routes/Yesod/Routes/Parse.hs
similarity index 79%
rename from yesod-core/Yesod/Internal/RouteParsing.hs
rename to yesod-routes/Yesod/Routes/Parse.hs
index 4d9a1d39..3440e8a5 100644
--- a/yesod-core/Yesod/Internal/RouteParsing.hs
+++ b/yesod-routes/Yesod/Routes/Parse.hs
@@ -1,13 +1,12 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
-module Yesod.Internal.RouteParsing
+module Yesod.Routes.Parse
     ( parseRoutes
     , parseRoutesFile
     , parseRoutesNoCheck
     , parseRoutesFileNoCheck
-    , RouteString
-    , parseRouteString
+    , parseType
     ) where
 
 import Web.PathPieces
@@ -33,20 +32,9 @@ parseRoutes = QuasiQuoter
     x s = do
         let res = resourcesFromString s
         case findOverlaps res of
-            [] -> liftParse s
+            [] -> lift res
             z -> error $ "Overlapping routes: " ++ unlines (map (unwords . map resourceName) z)
 
-newtype RouteString = RouteString String
-
-liftParse :: String -> Q Exp
-liftParse s = [|RouteString s|]
-
-parseRouteString :: RouteString -> [Resource]
-parseRouteString (RouteString s) = resourcesFromString s
-
-instance Lift RouteString where
-    lift (RouteString s) = [|RouteString $(lift s)|]
-
 parseRoutesFile :: FilePath -> Q Exp
 parseRoutesFile fp = do
     s <- qRunIO $ readUtf8File fp
@@ -66,13 +54,13 @@ readUtf8File fp = do
 -- | Same as 'parseRoutes', but performs no overlap checking.
 parseRoutesNoCheck :: QuasiQuoter
 parseRoutesNoCheck = QuasiQuoter
-    { quoteExp = liftParse
+    { quoteExp = lift . resourcesFromString
     }
 
 -- | Convert a multi-line string to a set of resources. See documentation for
 -- the format of this string. This is a partial function which calls 'error' on
 -- invalid input.
-resourcesFromString :: String -> [Resource]
+resourcesFromString :: String -> [Resource String]
 resourcesFromString =
     mapMaybe go . lines
   where
@@ -85,12 +73,12 @@ resourcesFromString =
             [] -> Nothing
             _ -> error $ "Invalid resource line: " ++ s
 
-dispatchFromString :: [String] -> Maybe Type -> Dispatch
+dispatchFromString :: [String] -> Maybe String -> Dispatch String
 dispatchFromString rest mmulti
     | null rest = Methods mmulti []
     | all (all isUpper) rest = Methods mmulti rest
 dispatchFromString [subTyp, subFun] Nothing =
-    Subsite (parseType subTyp) subFun
+    Subsite subTyp subFun
 dispatchFromString [subTyp, subFun] Just{} =
     error "Subsites cannot have a multipiece"
 dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest
@@ -99,7 +87,7 @@ drop1Slash :: String -> String
 drop1Slash ('/':x) = x
 drop1Slash x = x
 
-piecesFromString :: String -> ([Piece], Maybe Type)
+piecesFromString :: String -> ([Piece String], Maybe String)
 piecesFromString "" = ([], Nothing)
 piecesFromString x =
     case (this, rest) of
@@ -114,23 +102,23 @@ piecesFromString x =
 parseType :: String -> Type
 parseType = ConT . mkName -- FIXME handle more complicated stuff
 
-pieceFromString :: String -> Either Type Piece
-pieceFromString ('#':x) = Right $ Dynamic $ parseType x
-pieceFromString ('*':x) = Left $ parseType x
+pieceFromString :: String -> Either String (Piece String)
+pieceFromString ('#':x) = Right $ Dynamic x
+pieceFromString ('*':x) = Left x
 pieceFromString x = Right $ Static x
 
 -- n^2, should be a way to speed it up
-findOverlaps :: [Resource] -> [[Resource]]
+findOverlaps :: [Resource a] -> [[Resource a]]
 findOverlaps = go . map justPieces
   where
-    justPieces :: Resource -> ([Piece], Resource)
+    justPieces :: Resource a -> ([Piece a], Resource a)
     justPieces r@(Resource _ ps _) = (ps, r)
 
     go [] = []
     go (x:xs) = mapMaybe (mOverlap x) xs ++ go xs
 
-    mOverlap :: ([Piece], Resource) -> ([Piece], Resource) ->
-                Maybe [Resource]
+    mOverlap :: ([Piece a], Resource a) -> ([Piece a], Resource a) ->
+                Maybe [Resource a]
     mOverlap _ _ = Nothing
                 {- FIXME mOverlap
     mOverlap (Static x:xs, xr) (Static y:ys, yr)
diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
index ce483ee1..9563e618 100644
--- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs
+++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs
@@ -67,7 +67,7 @@ import Data.List (foldl')
 mkDispatchClause :: Q Exp -- ^ runHandler function
                  -> Q Exp -- ^ dispatcher function
                  -> Q Exp -- ^ fixHandler function
-                 -> [Resource]
+                 -> [Resource a]
                  -> Q Clause
 mkDispatchClause runHandler dispatcher fixHandler ress = do
     -- Allocate the names to be used. Start off with the names passed to the
@@ -120,7 +120,7 @@ methodMapName :: String -> Name
 methodMapName s = mkName $ "methods" ++ s
 
 buildMethodMap :: Q Exp -- ^ fixHandler
-               -> Resource
+               -> Resource a
                -> Q (Maybe Dec)
 buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function
 buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
@@ -143,7 +143,7 @@ buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do
 buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing
 
 -- | Build a single 'D.Route' expression.
-buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource -> Q Exp
+buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp
 buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do
     -- First two arguments to D.Route
     routePieces <- ListE <$> mapM convertPiece resPieces
@@ -158,8 +158,8 @@ routeArg3 :: Q Exp -- ^ runHandler
           -> Q Exp -- ^ dispatcher
           -> Q Exp -- ^ fixHandler
           -> String -- ^ name of resource
-          -> [Piece]
-          -> Dispatch
+          -> [Piece a]
+          -> Dispatch a
           -> Q Exp
 routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
     pieces <- newName "pieces"
@@ -224,7 +224,7 @@ buildCaller :: Q Exp -- ^ runHandler
             -> Q Exp -- ^ fixHandler
             -> Name -- ^ xrest
             -> String -- ^ name of resource
-            -> Dispatch
+            -> Dispatch a
             -> [Name] -- ^ ys
             -> Q Exp
 buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
@@ -290,6 +290,6 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
     return $ LamE pat exp
 
 -- | Convert a 'Piece' to a 'D.Piece'
-convertPiece :: Piece -> Q Exp
+convertPiece :: Piece a -> Q Exp
 convertPiece (Static s) = [|D.Static (pack $(lift s))|]
 convertPiece (Dynamic _) = [|D.Dynamic|]
diff --git a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs
index 17dd6e60..04edc094 100644
--- a/yesod-routes/Yesod/Routes/TH/RenderRoute.hs
+++ b/yesod-routes/Yesod/Routes/TH/RenderRoute.hs
@@ -15,7 +15,7 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
 import Yesod.Routes.Class
 
 -- | Generate the constructors of a route data type.
-mkRouteCons :: [Resource] -> [Con]
+mkRouteCons :: [Resource Type] -> [Con]
 mkRouteCons =
     map mkRouteCon
   where
@@ -36,7 +36,7 @@ mkRouteCons =
                 _ -> []
 
 -- | Clauses for the 'renderRoute' method.
-mkRenderRouteClauses :: [Resource] -> Q [Clause]
+mkRenderRouteClauses :: [Resource Type] -> Q [Clause]
 mkRenderRouteClauses =
     mapM go
   where
@@ -91,7 +91,7 @@ mkRenderRouteClauses =
 --
 -- This includes both the 'Route' associated type and the 'renderRoute' method.
 -- This function uses both 'mkRouteCons' and 'mkRenderRouteClasses'.
-mkRenderRouteInstance :: Type -> [Resource] -> Q Dec
+mkRenderRouteInstance :: Type -> [Resource Type] -> Q Dec
 mkRenderRouteInstance typ ress = do
     cls <- mkRenderRouteClauses ress
     return $ InstanceD [] (ConT ''RenderRoute `AppT` typ)
diff --git a/yesod-routes/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs
index 83f55149..54428ab8 100644
--- a/yesod-routes/Yesod/Routes/TH/Types.hs
+++ b/yesod-routes/Yesod/Routes/TH/Types.hs
@@ -10,67 +10,50 @@ module Yesod.Routes.TH.Types
 
 import Language.Haskell.TH.Syntax
 
-liftOccName :: OccName -> Q Exp
-liftOccName oc = [|mkOccName $(lift $ occString oc)|]
-
-liftNameFlavour :: NameFlavour -> Q Exp
-liftNameFlavour NameS = [|NameS|]
-
-liftName :: Name -> Q Exp
-liftName (Name a b) = [|Name $(liftOccName a) $(liftNameFlavour b)|]
-
-liftType :: Type -> Q Exp
-liftType (VarT name) = [|VarT $(liftName name)|]
-liftType (ConT name) = [|ConT $(liftName name)|]
-liftType (TupleT i) = [|TupleT $(lift i)|]
-liftType ArrowT = [|ArrowT|]
-liftType ListT = [|ListT|]
-liftType (AppT a b) = [|AppT $(liftType a) $(liftType b)|]
-liftType (SigT a b) = [|SigT $(liftType a) $(liftKind b)|]
-
-liftKind :: Kind -> Q Exp
-liftKind StarK = [|StarK|]
-liftKind (ArrowK a b) = [|ArrowK $(liftKind a) $(liftKind b)|]
-
-data Resource = Resource
+data Resource typ = Resource
     { resourceName :: String
-    , resourcePieces :: [Piece]
-    , resourceDispatch :: Dispatch
+    , resourcePieces :: [Piece typ]
+    , resourceDispatch :: Dispatch typ
     }
     deriving Show
 
-{-
-instance Lift Resource where
-    lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]
--}
+instance Functor Resource where
+    fmap f (Resource a b c) = Resource a (map (fmap f) b) (fmap f c)
 
-data Piece = Static String | Dynamic Type
+instance Lift t => Lift (Resource t) where
+    lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]
+
+data Piece typ = Static String | Dynamic typ
     deriving Show
 
-{-
-instance Lift Piece where
-    lift (Static s) = [|Static $(lift s)|]
-    lift (Dynamic t) = [|Static $(liftType t)|]
--}
+instance Functor Piece where
+    fmap _ (Static s) = (Static s)
+    fmap f (Dynamic t) = Dynamic (f t)
 
-data Dispatch =
+instance Lift t => Lift (Piece t) where
+    lift (Static s) = [|Static $(lift s)|]
+    lift (Dynamic t) = [|Dynamic $(lift t)|]
+
+data Dispatch typ =
     Methods
-        { methodsMulti :: Maybe Type -- ^ type of the multi piece at the end
+        { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end
         , methodsMethods :: [String] -- ^ supported request methods
         }
     | Subsite
-        { subsiteType :: Type
+        { subsiteType :: typ
         , subsiteFunc :: String
         }
     deriving Show
 
-{-
-instance Lift Dispatch where
-    lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
-    lift (Methods (Just t) b) = [|Methods (Just $(liftType t)) $(lift b)|]
-    lift (Subsite t b) = [|Subsite $(liftType t) $(lift b)|]
--}
+instance Functor Dispatch where
+    fmap f (Methods a b) = Methods (fmap f a) b
+    fmap f (Subsite a b) = Subsite (f a) b
 
-resourceMulti :: Resource -> Maybe Type
+instance Lift t => Lift (Dispatch t) where
+    lift (Methods Nothing b) = [|Methods Nothing $(lift b)|]
+    lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|]
+    lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|]
+
+resourceMulti :: Resource typ -> Maybe typ
 resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
 resourceMulti _ = Nothing
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 8a76e74e..4b399d59 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -22,6 +22,7 @@ library
     exposed-modules: Yesod.Routes.Dispatch
                      Yesod.Routes.TH
                      Yesod.Routes.Class
+                     Yesod.Routes.Parse
     other-modules:   Yesod.Routes.TH.Dispatch
                      Yesod.Routes.TH.RenderRoute
                      Yesod.Routes.TH.Types

From 0a9df1076e8a9cb72cc86287e806aa250f3f95ee Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 5 Jan 2012 05:46:20 +0200
Subject: [PATCH 27/28] cleanPath tests again

---
 yesod-core/Yesod/Dispatch.hs               | 5 ++++-
 yesod-core/test/YesodCoreTest/CleanPath.hs | 1 +
 2 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/yesod-core/Yesod/Dispatch.hs b/yesod-core/Yesod/Dispatch.hs
index a1c8691e..45ac2cbe 100644
--- a/yesod-core/Yesod/Dispatch.hs
+++ b/yesod-core/Yesod/Dispatch.hs
@@ -169,7 +169,10 @@ toWaiApp' :: ( Yesod master
           -> Maybe Key
           -> W.Application
 toWaiApp' y key' env =
-    yesodDispatch y y id app404 handler405 method (W.pathInfo env) key' env
+    case cleanPath y $ W.pathInfo env of
+        Left pieces -> sendRedirect y pieces env
+        Right pieces ->
+            yesodDispatch y y id app404 handler405 method pieces key' env
   where
     app404 = yesodRunner notFound y y Nothing id
     handler405 route = yesodRunner badMethod y y (Just route) id
diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs
index 83999b4a..0428164e 100644
--- a/yesod-core/test/YesodCoreTest/CleanPath.hs
+++ b/yesod-core/test/YesodCoreTest/CleanPath.hs
@@ -42,6 +42,7 @@ mkYesod "Y" [parseRoutes|
 
 instance Yesod Y where
     approot _ = "http://test"
+    cleanPath _ s@("subsite":_) = Right s
     cleanPath _ ["bar", ""] = Right ["bar"]
     cleanPath _ ["bar"] = Left ["bar", ""]
     cleanPath _ s =

From 69a5d0e0ed3ecd891423c93e322c7a9a9edf47e3 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 5 Jan 2012 15:27:16 +0200
Subject: [PATCH 28/28] Whole repo builds with new yesod-routes

---
 yesod-auth/Yesod/Auth.hs           |  5 +++-
 yesod-auth/Yesod/Auth/BrowserId.hs |  2 +-
 yesod-form/Yesod/Form/Jquery.hs    |  1 +
 yesod-form/Yesod/Form/Nic.hs       |  1 +
 yesod-newsfeed/Yesod/AtomFeed.hs   |  4 +--
 yesod-newsfeed/Yesod/Feed.hs       |  2 +-
 yesod-newsfeed/Yesod/RssFeed.hs    |  4 +--
 yesod-routes/yesod-routes.cabal    |  1 +
 yesod-sitemap/Yesod/Sitemap.hs     |  2 +-
 yesod-static/Yesod/Static.hs       | 48 ++++++++++++++----------------
 yesod-static/yesod-static.cabal    |  2 +-
 11 files changed, 35 insertions(+), 37 deletions(-)

diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs
index fefc3c97..a1e5a076 100644
--- a/yesod-auth/Yesod/Auth.hs
+++ b/yesod-auth/Yesod/Auth.hs
@@ -9,8 +9,9 @@
 module Yesod.Auth
     ( -- * Subsite
       Auth
+    , AuthRoute
+    , Route (..)
     , AuthPlugin (..)
-    , AuthRoute (..)
     , getAuth
     , YesodAuth (..)
       -- * Plugin interface
@@ -53,6 +54,8 @@ import Yesod.Form (FormMessage)
 
 data Auth = Auth
 
+type AuthRoute = Route Auth
+
 type Method = Text
 type Piece = Text
 
diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs
index d71b5d25..378307c3 100644
--- a/yesod-auth/Yesod/Auth/BrowserId.hs
+++ b/yesod-auth/Yesod/Auth/BrowserId.hs
@@ -21,7 +21,7 @@ import Data.Maybe (fromMaybe)
 pid :: Text
 pid = "browserid"
 
-complete :: AuthRoute
+complete :: Route Auth
 complete = PluginR pid []
 
 authBrowserIdAudience :: YesodAuth m
diff --git a/yesod-form/Yesod/Form/Jquery.hs b/yesod-form/Yesod/Form/Jquery.hs
index 3347b14d..51d1cef4 100644
--- a/yesod-form/Yesod/Form/Jquery.hs
+++ b/yesod-form/Yesod/Form/Jquery.hs
@@ -16,6 +16,7 @@ module Yesod.Form.Jquery
     ) where
 
 import Yesod.Handler
+import Yesod.Core (Route)
 import Yesod.Form
 import Yesod.Widget
 import Data.Time (UTCTime (..), Day, TimeOfDay (..), timeOfDayToTime,
diff --git a/yesod-form/Yesod/Form/Nic.hs b/yesod-form/Yesod/Form/Nic.hs
index 19e0ef7d..299008ea 100644
--- a/yesod-form/Yesod/Form/Nic.hs
+++ b/yesod-form/Yesod/Form/Nic.hs
@@ -11,6 +11,7 @@ module Yesod.Form.Nic
     ) where
 
 import Yesod.Handler
+import Yesod.Core (Route)
 import Yesod.Form
 import Yesod.Widget
 import Text.HTML.SanitizeXSS (sanitizeBalance)
diff --git a/yesod-newsfeed/Yesod/AtomFeed.hs b/yesod-newsfeed/Yesod/AtomFeed.hs
index 5a33841c..dd347e4c 100644
--- a/yesod-newsfeed/Yesod/AtomFeed.hs
+++ b/yesod-newsfeed/Yesod/AtomFeed.hs
@@ -22,9 +22,7 @@ module Yesod.AtomFeed
     , module Yesod.FeedTypes
     ) where
 
-import Yesod.Content
-import Yesod.Handler
-import Yesod.Widget
+import Yesod.Core
 import Yesod.FeedTypes
 import Text.Hamlet (HtmlUrl, xhamlet, hamlet)
 import qualified Data.ByteString.Char8 as S8
diff --git a/yesod-newsfeed/Yesod/Feed.hs b/yesod-newsfeed/Yesod/Feed.hs
index fa2c552e..58673f8d 100644
--- a/yesod-newsfeed/Yesod/Feed.hs
+++ b/yesod-newsfeed/Yesod/Feed.hs
@@ -25,7 +25,7 @@ import Yesod.FeedTypes
 import Yesod.AtomFeed
 import Yesod.RssFeed
 import Yesod.Content (HasReps (chooseRep), typeAtom, typeRss)
-import Yesod.Handler (Route, GHandler)
+import Yesod.Core (Route, GHandler)
 
 data RepAtomRss = RepAtomRss RepAtom RepRss
 instance HasReps RepAtomRss where
diff --git a/yesod-newsfeed/Yesod/RssFeed.hs b/yesod-newsfeed/Yesod/RssFeed.hs
index 83a56064..124e06ff 100644
--- a/yesod-newsfeed/Yesod/RssFeed.hs
+++ b/yesod-newsfeed/Yesod/RssFeed.hs
@@ -18,9 +18,7 @@ module Yesod.RssFeed
     , module Yesod.FeedTypes
     ) where
 
-import Yesod.Handler
-import Yesod.Content
-import Yesod.Widget
+import Yesod.Core
 import Yesod.FeedTypes
 import Text.Hamlet (HtmlUrl, xhamlet, hamlet)
 import qualified Data.ByteString.Char8 as S8
diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal
index 4b399d59..f8d9a83a 100644
--- a/yesod-routes/yesod-routes.cabal
+++ b/yesod-routes/yesod-routes.cabal
@@ -5,6 +5,7 @@ license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
 maintainer:      Michael Snoyman <michael@snoyman.com>
 synopsis:        Efficient routing for Yesod.
+description:     Provides an efficient routing system, a parser and TH code generation.
 category:        Web, Yesod
 stability:       Stable
 cabal-version:   >= 1.8
diff --git a/yesod-sitemap/Yesod/Sitemap.hs b/yesod-sitemap/Yesod/Sitemap.hs
index 348e3e71..75f5b095 100644
--- a/yesod-sitemap/Yesod/Sitemap.hs
+++ b/yesod-sitemap/Yesod/Sitemap.hs
@@ -26,7 +26,7 @@ module Yesod.Sitemap
     ) where
 
 import Yesod.Content (RepXml (..), RepPlain (..), toContent, formatW3)
-import Yesod.Handler (Route, GHandler, getUrlRender)
+import Yesod.Core (Route, GHandler, getUrlRender)
 import Yesod.Handler (hamletToContent)
 import Text.Hamlet (HtmlUrl, xhamlet)
 import Data.Time (UTCTime)
diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs
index e7c2f662..6d3fae35 100644
--- a/yesod-static/Yesod/Static.hs
+++ b/yesod-static/Yesod/Static.hs
@@ -29,7 +29,7 @@
 module Yesod.Static
     ( -- * Subsite
       Static (..)
-    , StaticRoute (..)
+    , Route (..)
       -- * Smart constructor
     , static
     , staticDevel
@@ -120,36 +120,32 @@ embed fp =
         { ssFolder = embeddedLookup (toEmbedded $(embedDir fp))
         })|]
 
-
--- | A route on the static subsite (see also 'staticFiles').
---
--- You may use this constructor directly to manually link to a
--- static file.  The first argument is the sub-path to the file
--- being served whereas the second argument is the key-value
--- pairs in the query string.  For example,
---
--- > StaticRoute $ StaticR [\"thumb001.jpg\"] [(\"foo\", \"5\"), (\"bar\", \"choc\")]
---
--- would generate a url such as
--- @http://www.example.com/static/thumb001.jpg?foo=5&bar=choc@
--- The StaticRoute constructor can be used when the URL cannot be
--- statically generated at compile-time (e.g. when generating
--- image galleries).
-data StaticRoute = StaticRoute [Text] [(Text, Text)]
-    deriving (Eq, Show, Read)
-
-type instance Route Static = StaticRoute
-
-instance RenderRoute StaticRoute where
+instance RenderRoute Static where
+    -- | A route on the static subsite (see also 'staticFiles').
+    --
+    -- You may use this constructor directly to manually link to a
+    -- static file.  The first argument is the sub-path to the file
+    -- being served whereas the second argument is the key-value
+    -- pairs in the query string.  For example,
+    --
+    -- > StaticRoute $ StaticR [\"thumb001.jpg\"] [(\"foo\", \"5\"), (\"bar\", \"choc\")]
+    --
+    -- would generate a url such as
+    -- @http://www.example.com/static/thumb001.jpg?foo=5&bar=choc@
+    -- The StaticRoute constructor can be used when the URL cannot be
+    -- statically generated at compile-time (e.g. when generating
+    -- image galleries).
+    data Route Static = StaticRoute [Text] [(Text, Text)]
+        deriving (Eq, Show, Read)
     renderRoute (StaticRoute x y) = (x, y)
 
 instance Yesod master => YesodDispatch Static master where
     -- Need to append trailing slash to make relative links work
-    yesodDispatch _ _ [] _ _ = Just $
-        \req -> return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
+    yesodDispatch _ _ _ _ _ _ [] _ req =
+        return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
 
-    yesodDispatch (Static set) _ textPieces  _ _ = Just $
-        \req -> staticApp set req { pathInfo = textPieces }
+    yesodDispatch _ (Static set) _ _ _ _ textPieces  _ req =
+        staticApp set req { pathInfo = textPieces }
 
 notHidden :: Prelude.FilePath -> Bool
 notHidden "tmp" = False
diff --git a/yesod-static/yesod-static.cabal b/yesod-static/yesod-static.cabal
index 1867fc8b..bcc3998c 100644
--- a/yesod-static/yesod-static.cabal
+++ b/yesod-static/yesod-static.cabal
@@ -13,7 +13,7 @@ homepage:        http://www.yesodweb.com/
 description:     Static file serving subsite for Yesod Web Framework.
 extra-source-files:
   test/YesodStaticTest.hs
-  tests.hs
+  test/tests.hs
 
 flag test
   description: Build for use with running tests