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] 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