Merge branch 'yesod-routes'

package-list.sh

@@ -1,6 +1,7 @@
 #!/bin/bash
 
-pkgs=(      ./yesod-core
+pkgs=(      ./yesod-routes
+            ./yesod-core
             ./yesod-json
             ./yesod-static
             ./yesod-persistent

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
 

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

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.Routes.Parse (parseRoutes, parseRoutesNoCheck, parseRoutesFile, parseRoutesFileNoCheck)
 import Language.Haskell.TH.Syntax
 
 import qualified Network.Wai as W
@@ -44,6 +43,15 @@ 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
+import Network.HTTP.Types (status301)
+import Yesod.Routes.TH
+import Yesod.Content (chooseRep)
+import Yesod.Routes.Parse
 
 type Texts = [Text]
 
@@ -51,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
-        -> [Resource]
+        -> [Resource String]
         -> Q [Dec]
 mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
 
@@ -62,7 +70,7 @@ mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] [] False
 -- be embedded in other sites.
 mkYesodSub :: String -- ^ name of the argument datatype
            -> Cxt
-           -> [Resource]
+           -> [Resource String]
            -> Q [Dec]
 mkYesodSub name clazzes =
     fmap (uncurry (++)) . mkYesodGeneral name' rest clazzes True
@@ -73,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 -> [Resource] -> Q [Dec]
+mkYesodData :: String -> [Resource String] -> Q [Dec]
 mkYesodData name res = mkYesodDataGeneral name [] False res
 
-mkYesodSubData :: String -> Cxt -> [Resource] -> Q [Dec]
+mkYesodSubData :: String -> Cxt -> [Resource String] -> Q [Dec]
 mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res
 
-mkYesodDataGeneral :: String -> Cxt -> Bool -> [Resource] -> 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 <- 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 -> [Resource] -> Q [Dec]
+mkYesodDispatch :: String -> [Resource String] -> Q [Dec]
 mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False
 
-mkYesodSubDispatch :: String -> Cxt -> [Resource] -> Q [Dec]
+mkYesodSubDispatch :: String -> Cxt -> [Resource String] -> Q [Dec]
 mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True 
   where (name':rest) = words name
 
@@ -102,40 +110,26 @@ mkYesodGeneral :: String -- ^ foundation name
                -> [String] -- ^ parameters for foundation
                -> Cxt -- ^ classes
                -> Bool -- ^ is subsite?
-               -> [Resource]
+               -> [Resource String]
                -> Q ([Dec], [Dec])
-mkYesodGeneral name args clazzes isSub res = do
+mkYesodGeneral name args clazzes isSub resS = do
-    let args' = map mkName args
+    let res = map (fmap parseType) resS
-        arg = foldl AppT (ConT name') $ map VarT args'
+    renderRouteDec <- mkRenderRouteInstance (ConT name') res
-    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
 
-    render <- createRender th
+    disp <- mkDispatchClause [|yesodRunner|] [|yesodDispatch|] [|fmap chooseRep|] res
-    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
     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]]
+    let yesodDispatch =
-    return ([w, x, x'] ++ masterTypSyns, [y])
+            InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]]
+
+    return (renderRouteDec : masterTypSyns, [yesodDispatch])
   where
     name' = mkName name
     masterTypSyns
@@ -151,45 +145,49 @@ 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)
+toWaiApp' :: ( Yesod master
-          => y
+             , YesodDispatch master master
+             )
+          => master
           -> Maybe Key
           -> W.Application
 toWaiApp' y key' env =
-    case yesodDispatch y key' (W.pathInfo env) y id of
+    case cleanPath y $ W.pathInfo env of
-        Just app -> app env
+        Left pieces -> sendRedirect y pieces env
-        Nothing -> yesodRunner y y id key' Nothing notFound 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
+    method = decodeUtf8With lenientDecode $ W.requestMethod env
+
+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))

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
-
+import Yesod.Routes.Class
--- | The type-safe URLs associated with a site argument.
-type family Route a
 
 class YesodSubRoute s y where
     fromSubRoute :: s -> y -> Route s -> Route y
@@ -603,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

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]
+        -> W.Application
-        -> master
-        -> (Route a -> Route master)
-        -> Maybe W.Application
 
     yesodRunner :: Yesod master
-                => a
+                => GHandler sub master ChooseRep
                 -> master
-                -> (Route a -> Route master)
+                -> sub
-                -> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
+                -> 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

yesod-core/Yesod/Internal/Dispatch.hs

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

yesod-core/Yesod/Internal/RouteParsing.hs

@@ -1,354 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
-module Yesod.Internal.RouteParsing
-    ( createRoutes
-    , createRender
-    , createParse
-    , createDispatch
-    , Pieces (..)
-    , THResource
-    , parseRoutes
-    , parseRoutesFile
-    , parseRoutesNoCheck
-    , parseRoutesFileNoCheck
-    , Resource (..)
-    , Piece (..)
-    ) where
-
-import Web.PathPieces
-import Language.Haskell.TH.Syntax
-import Data.Maybe
-import Data.Either
-import Data.List
-import Data.Char (toLower)
-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)) []
-
--- | 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
--- checking. See documentation site for details on syntax.
-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
-
-parseRoutesFile :: FilePath -> Q Exp
-parseRoutesFile fp = do
-    s <- qRunIO $ readUtf8File fp
-    quoteExp parseRoutes s
-
-parseRoutesFileNoCheck :: FilePath -> Q Exp
-parseRoutesFileNoCheck fp = do
-    s <- qRunIO $ readUtf8File fp
-    quoteExp parseRoutesNoCheck s
-
-readUtf8File :: FilePath -> IO String
-readUtf8File fp = do
-    h <- SIO.openFile fp SIO.ReadMode
-    SIO.hSetEncoding h SIO.utf8_bom
-    SIO.hGetContents h
-
--- | Same as 'parseRoutes', but performs no overlap checking.
-parseRoutesNoCheck :: QuasiQuoter
-parseRoutesNoCheck = QuasiQuoter
-    { quoteExp = x
-    , quotePat = y
-    }
-  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
--- invalid input.
-resourcesFromString :: String -> [Resource]
-resourcesFromString =
-    mapMaybe go . lines
-  where
-    go s =
-        case takeWhile (/= "--") $ words s of
-            (pattern:constr:rest) ->
-                let pieces = piecesFromString $ drop1Slash pattern
-                 in Just $ Resource constr pieces rest
-            [] -> Nothing
-            _ -> error $ "Invalid resource line: " ++ s
-
-drop1Slash :: String -> String
-drop1Slash ('/':x) = x
-drop1Slash x = x
-
-piecesFromString :: String -> [Piece]
-piecesFromString "" = []
-piecesFromString x =
-    let (y, z) = break (== '/') x
-     in pieceFromString y : piecesFromString (drop1Slash z)
-
-pieceFromString :: String -> Piece
-pieceFromString ('#':x) = SinglePiece x
-pieceFromString ('*':x) = MultiPiece x
-pieceFromString x = StaticPiece x
-
--- n^2, should be a way to speed it up
-findOverlaps :: [Resource] -> [(Resource, Resource)]
-findOverlaps = go . map justPieces
-  where
-    justPieces :: Resource -> ([Piece], Resource)
-    justPieces r@(Resource _ ps _) = (ps, r)
-
-    go [] = []
-    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)
-        | x == y = mOverlap (xs, xr) (ys, yr)
-        | otherwise = Nothing
-    mOverlap (MultiPiece _:_, xr) (_, yr) = Just (xr, yr)
-    mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
-    mOverlap ([], xr) ([], yr) = Just (xr, yr)
-    mOverlap ([], _) (_, _) = Nothing
-    mOverlap (_, _) ([], _) = Nothing
-    mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)

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)

yesod-core/test/YesodCoreTest/CleanPath.hs

@@ -20,14 +20,13 @@ data Subsite = Subsite
 getSubsite :: a -> Subsite
 getSubsite = const Subsite
 
-data SubsiteRoute = SubsiteRoute [TS.Text]
+instance RenderRoute Subsite where
-    deriving (Eq, Show, Read)
+    data Route Subsite = SubsiteRoute [TS.Text]
-type instance Route Subsite = SubsiteRoute
+        deriving (Eq, Show, Read)
-instance RenderRoute SubsiteRoute where
     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
@@ -43,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 =

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,8 +95,6 @@ library
                      Yesod.Internal.Core
                      Yesod.Internal.Session
                      Yesod.Internal.Request
-                     Yesod.Internal.Dispatch
-                     Yesod.Internal.RouteParsing
                      Paths_yesod_core
     ghc-options:     -Wall
 

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,

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)

yesod-newsfeed/Yesod/AtomFeed.hs

@@ -22,9 +22,7 @@ module Yesod.AtomFeed
     , module Yesod.FeedTypes
     ) where
 
-import Yesod.Content
+import Yesod.Core
-import Yesod.Handler
-import Yesod.Widget
 import Yesod.FeedTypes
 import Text.Hamlet (HtmlUrl, xhamlet, hamlet)
 import qualified Data.ByteString.Char8 as S8

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

yesod-newsfeed/Yesod/RssFeed.hs

@@ -18,9 +18,7 @@ module Yesod.RssFeed
     , module Yesod.FeedTypes
     ) where
 
-import Yesod.Handler
+import Yesod.Core
-import Yesod.Content
-import Yesod.Widget
 import Yesod.FeedTypes
 import Text.Hamlet (HtmlUrl, xhamlet, hamlet)
 import qualified Data.ByteString.Char8 as S8

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.

yesod-routes/Setup.lhs

@@ -0,0 +1,7 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain

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

yesod-routes/Yesod/Routes/Dispatch.lhs

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

yesod-routes/Yesod/Routes/Parse.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter
+module Yesod.Routes.Parse
+    ( parseRoutes
+    , parseRoutesFile
+    , parseRoutesNoCheck
+    , parseRoutesFileNoCheck
+    , parseType
+    ) where
+
+import Web.PathPieces
+import Language.Haskell.TH.Syntax
+import Data.Maybe
+import Data.Either
+import Data.List
+import Data.Char (toLower, isUpper)
+import qualified Data.Text
+import Language.Haskell.TH.Quote
+import Data.Data
+import qualified System.IO as SIO
+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
+-- checking. See documentation site for details on syntax.
+parseRoutes :: QuasiQuoter
+parseRoutes = QuasiQuoter
+    { quoteExp = x
+    }
+  where
+    x s = do
+        let res = resourcesFromString s
+        case findOverlaps res of
+            [] -> lift res
+            z -> error $ "Overlapping routes: " ++ unlines (map (unwords . map resourceName) z)
+
+parseRoutesFile :: FilePath -> Q Exp
+parseRoutesFile fp = do
+    s <- qRunIO $ readUtf8File fp
+    quoteExp parseRoutes s
+
+parseRoutesFileNoCheck :: FilePath -> Q Exp
+parseRoutesFileNoCheck fp = do
+    s <- qRunIO $ readUtf8File fp
+    quoteExp parseRoutesNoCheck s
+
+readUtf8File :: FilePath -> IO String
+readUtf8File fp = do
+    h <- SIO.openFile fp SIO.ReadMode
+    SIO.hSetEncoding h SIO.utf8_bom
+    SIO.hGetContents h
+
+-- | Same as 'parseRoutes', but performs no overlap checking.
+parseRoutesNoCheck :: QuasiQuoter
+parseRoutesNoCheck = QuasiQuoter
+    { 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 String]
+resourcesFromString =
+    mapMaybe go . lines
+  where
+    go s =
+        case takeWhile (/= "--") $ words s of
+            (pattern:constr: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 String -> Dispatch String
+dispatchFromString rest mmulti
+    | null rest = Methods mmulti []
+    | all (all isUpper) rest = Methods mmulti rest
+dispatchFromString [subTyp, subFun] Nothing =
+    Subsite 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 String], Maybe String)
+piecesFromString "" = ([], Nothing)
+piecesFromString x =
+    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
+
+parseType :: String -> Type
+parseType = ConT . mkName -- FIXME handle more complicated stuff
+
+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 a] -> [[Resource a]]
+findOverlaps = go . map justPieces
+  where
+    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 a], Resource a) -> ([Piece a], Resource a) ->
+                Maybe [Resource a]
+    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)
+    mOverlap (_, xr) (MultiPiece _:_, yr) = Just (xr, yr)
+    mOverlap ([], xr) ([], yr) = Just (xr, yr)
+    mOverlap ([], _) (_, _) = Nothing
+    mOverlap (_, _) ([], _) = Nothing
+    mOverlap (_:xs, xr) (_:ys, yr) = mOverlap (xs, xr) (ys, yr)
+    -}

yesod-routes/Yesod/Routes/TH.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Routes.TH
+    ( module Yesod.Routes.TH.Types
+      -- * Functions
+    , module Yesod.Routes.TH.RenderRoute
+      -- ** Dispatch
+    , module Yesod.Routes.TH.Dispatch
+    ) where
+
+import Yesod.Routes.TH.Types
+import Yesod.Routes.TH.RenderRoute
+import Yesod.Routes.TH.Dispatch

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

@@ -0,0 +1,295 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Routes.TH.Dispatch
+    ( -- ** Dispatch
+      mkDispatchClause
+    ) where
+
+import Prelude hiding (exp)
+import Yesod.Routes.TH.Types
+import Language.Haskell.TH.Syntax
+import Data.Maybe (catMaybes)
+import Control.Monad (forM, 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 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
+                 -> Q Exp -- ^ fixHandler function
+                 -> [Resource a]
+                 -> Q Clause
+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).
+    --
+    -- 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"
+    app4040 <- newName "app4040"
+    handler4050 <- newName "handler4050"
+    method0 <- newName "method0"
+    pieces0 <- newName "pieces0"
+
+    -- 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 fixHandler) 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 fixHandler) ress
+
+    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
+
+-- | Determine the name of the method map for a given resource name.
+methodMapName :: String -> Name
+methodMapName s = mkName $ "methods" ++ s
+
+buildMethodMap :: Q Exp -- ^ fixHandler
+               -> Resource a
+               -> 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'
+    let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
+    return $ Just fun
+  where
+    go method = do
+        fh <- fixHandler
+        let func = VarE $ mkName $ map toLower method ++ name
+        pack' <- [|pack|]
+        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 -> 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
+    isMulti <-
+        case resDisp of
+            Methods Nothing _ -> [|False|]
+            _ -> [|True|]
+
+    [|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 a]
+          -> Dispatch a
+          -> Q Exp
+routeArg3 runHandler dispatcher fixHandler 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 fixHandler xrest name resDisp $ map snd ys ++ yrest'
+
+    -- Put together all the statements
+    just <- [|Just|]
+    let stmts = concat
+            [ xstmts
+            , reststmts
+            , [NoBindS $ just `AppE` caller]
+            ]
+
+    errorMsg <- [|error "Invariant violated"|]
+    let matches =
+            [ Match pat (NormalB $ DoE stmts) []
+            , Match WildP (NormalB errorMsg) []
+            ]
+
+    return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches
+
+-- | 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 a
+            -> [Name] -- ^ ys
+            -> Q Exp
+buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
+    master <- newName "master"
+    sub <- newName "sub"
+    toMaster <- newName "toMaster"
+    app404 <- newName "_app404"
+    handler405 <- newName "_handler405"
+    method <- newName "_method"
+
+    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"
+
+                -- Run the whole thing
+                runner <- [|$(runHandler)
+                                $(return $ VarE handler)
+                                $(return $ VarE master)
+                                $(return $ VarE sub)
+                                (Just $(return route))
+                                $(return $ VarE toMaster)|]
+
+                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)
+                    $(return $ VarE master)
+                    $(return sub2)
+                    ($(return $ VarE toMaster) . $(return route))
+                    $(return $ VarE app404)
+                    ($(return $ VarE handler405) . $(return route))
+                    $(return $ VarE method)
+                    $(return $ VarE xrest)
+                 |]
+
+    return $ LamE pat exp
+
+-- | Convert a 'Piece' to a 'D.Piece'
+convertPiece :: Piece a -> Q Exp
+convertPiece (Static s) = [|D.Static (pack $(lift s))|]
+convertPiece (Dynamic _) = [|D.Dynamic|]

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

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

@@ -0,0 +1,59 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Routes.TH.Types
+    ( -- * Data types
+      Resource (..)
+    , Piece (..)
+    , Dispatch (..)
+      -- ** Helper functions
+    , resourceMulti
+    ) where
+
+import Language.Haskell.TH.Syntax
+
+data Resource typ = Resource
+    { resourceName :: String
+    , resourcePieces :: [Piece typ]
+    , resourceDispatch :: Dispatch typ
+    }
+    deriving Show
+
+instance Functor Resource where
+    fmap f (Resource a b c) = Resource a (map (fmap f) b) (fmap f c)
+
+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 Functor Piece where
+    fmap _ (Static s) = (Static s)
+    fmap f (Dynamic t) = Dynamic (f t)
+
+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 typ -- ^ type of the multi piece at the end
+        , methodsMethods :: [String] -- ^ supported request methods
+        }
+    | Subsite
+        { subsiteType :: typ
+        , subsiteFunc :: String
+        }
+    deriving Show
+
+instance Functor Dispatch where
+    fmap f (Methods a b) = Methods (fmap f a) b
+    fmap f (Subsite a b) = Subsite (f a) b
+
+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

yesod-routes/test/main.hs

@@ -0,0 +1,273 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+import Test.Hspec.Monadic
+import Test.Hspec.HUnit ()
+import Test.HUnit ((@?=))
+import Data.Text (Text, pack, unpack, singleton)
+import Yesod.Routes.Dispatch hiding (Static, Dynamic)
+import Yesod.Routes.Class hiding (Route)
+import qualified Yesod.Routes.Class as YRC
+import qualified Yesod.Routes.Dispatch as D
+import Yesod.Routes.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
+
+justRoot :: Dispatch Int
+justRoot = toDispatch
+    [ Route [] False $ result $ const $ Just 1
+    ]
+
+twoStatics :: Dispatch Int
+twoStatics = toDispatch
+    [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 2
+    , Route [D.Static $ pack "bar"] False $ result $ const $ Just 3
+    ]
+
+multi :: Dispatch Int
+multi = toDispatch
+    [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 4
+    , Route [D.Static $ pack "bar"] True $ result $ const $ Just 5
+    ]
+
+dynamic :: Dispatch Int
+dynamic = toDispatch
+    [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 6
+    , Route [D.Dynamic] False $ result $ \ts ->
+        case ts of
+            [t] ->
+                case reads $ unpack t of
+                    [] -> Nothing
+                    (i, _):_ -> Just i
+            _ -> error $ "Called dynamic with: " ++ show ts
+    ]
+
+overlap :: Dispatch Int
+overlap = toDispatch
+    [ Route [D.Static $ pack "foo"] False $ result $ const $ Just 20
+    , Route [D.Static $ pack "foo"] True $ result $ const $ Just 21
+    , Route [] True $ result $ const $ Just 22
+    ]
+
+test :: Dispatch Int -> [String] -> Maybe Int
+test dispatch ts = dispatch $ map pack ts
+
+data MyApp = MyApp
+
+data MySub = MySub
+instance RenderRoute MySub where
+    data YRC.Route MySub = MySubRoute ([Text], [(Text, Text)])
+        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
+
+type Handler sub master = Text
+type App sub master = (Text, Maybe (YRC.Route master))
+
+class Dispatcher sub master where
+    dispatcher
+        :: master
+        -> sub
+        -> (YRC.Route sub -> YRC.Route master)
+        -> App sub master -- ^ 404 page
+        -> (YRC.Route sub -> App sub master) -- ^ 405 page
+        -> Text -- ^ method
+        -> [Text]
+        -> App sub master
+
+class RunHandler sub master where
+    runHandler
+        :: Handler sub master
+        -> master
+        -> sub
+        -> Maybe (YRC.Route sub)
+        -> (YRC.Route sub -> YRC.Route master)
+        -> App sub master
+
+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|] [|toText|] ress
+    return
+        [ rrinst
+        , InstanceD
+            []
+            (ConT ''Dispatcher
+                `AppT` ConT ''MyApp
+                `AppT` ConT ''MyApp)
+            [FunD (mkName "dispatcher") [dispatch]]
+        ]
+
+instance RunHandler MyApp master where
+    runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
+
+instance Dispatcher MySub master where
+    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]] -> (pack $ "subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)
+            _ -> app404
+
+{-
+thDispatchAlias
+    :: (master ~ MyApp, sub ~ MyApp, handler ~ String, app ~ (String, Maybe (YRC.Route MyApp)))
+    => master
+    -> sub
+    -> (YRC.Route sub -> YRC.Route master)
+    -> app -- ^ 404 page
+    -> handler -- ^ 405 page
+    -> Text -- ^ method
+    -> [Text]
+    -> app
+--thDispatchAlias = thDispatch
+thDispatchAlias master sub toMaster app404 handler405 method0 pieces0 =
+    case dispatch pieces0 of
+        Just f -> f master sub toMaster app404 handler405 method0
+        Nothing -> app404
+  where
+    dispatch = toDispatch
+        [ Route [] False $ \pieces ->
+            case pieces of
+                [] -> do
+                    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 $ \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 $ \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 $ \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 $ \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
+    describe "justRoot" $ do
+        it "dispatches correctly" $ test justRoot [] @?= Just 1
+        it "fails correctly" $ test justRoot ["foo"] @?= Nothing
+    describe "twoStatics" $ do
+        it "dispatches correctly to foo" $ test twoStatics ["foo"] @?= Just 2
+        it "dispatches correctly to bar" $ test twoStatics ["bar"] @?= Just 3
+        it "fails correctly (1)" $ test twoStatics [] @?= Nothing
+        it "fails correctly (2)" $ test twoStatics ["bar", "baz"] @?= Nothing
+    describe "multi" $ do
+        it "dispatches correctly to foo" $ test multi ["foo"] @?= Just 4
+        it "dispatches correctly to bar" $ test multi ["bar"] @?= Just 5
+        it "dispatches correctly to bar/baz" $ test multi ["bar", "baz"] @?= Just 5
+        it "fails correctly (1)" $ test multi [] @?= Nothing
+        it "fails correctly (2)" $ test multi ["foo", "baz"] @?= Nothing
+    describe "dynamic" $ do
+        it "dispatches correctly to foo" $ test dynamic ["foo"] @?= Just 6
+        it "dispatches correctly to 7" $ test dynamic ["7"] @?= Just 7
+        it "dispatches correctly to 42" $ test dynamic ["42"] @?= Just 42
+        it "fails correctly on five" $ test dynamic ["five"] @?= Nothing
+        it "fails correctly on too many" $ test dynamic ["foo", "baz"] @?= Nothing
+        it "fails correctly on too few" $ test dynamic [] @?= Nothing
+    describe "overlap" $ do
+        it "dispatches correctly to foo" $ test overlap ["foo"] @?= Just 20
+        it "dispatches correctly to foo/bar" $ test overlap ["foo", "bar"] @?= Just 21
+        it "dispatches correctly to bar" $ test overlap ["bar"] @?= Just 22
+        it "dispatches correctly to []" $ test overlap [] @?= Just 22
+
+    describe "RenderRoute instance" $ do
+        it "renders root correctly" $ renderRoute RootR @?= ([], [])
+        it "renders blog post correctly" $ renderRoute (BlogPostR $ pack "foo") @?= (map pack ["blog", "foo"], [])
+        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')
+            @?= (map pack ["subparam", "6", "c"], [])
+
+    describe "thDispatch" $ do
+        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"]
+            @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost")
+        it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"]
+            @?= (pack "POST some blog post: somepost2", Just $ BlogPostR $ pack "somepost2")
+        it "routes to wiki" $ disp "DELETE" ["wiki", "foo", "bar"]
+            @?= (pack "the wiki: [\"foo\",\"bar\"]", Just $ WikiR $ map pack ["foo", "bar"])
+        it "routes to subsite" $ disp "PUT" ["subsite", "baz"]
+            @?= (pack "subsite: [\"baz\"]", Just $ SubsiteR $ MySubRoute ([pack "baz"], []))
+        it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"]
+            @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q')
+
+getRootR :: Text
+getRootR = pack "this is the root"
+
+getBlogPostR :: Text -> String
+getBlogPostR t = "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

yesod-routes/yesod-routes.cabal

@@ -0,0 +1,49 @@
+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.
+description:     Provides an efficient routing system, a parser and TH code generation.
+category:        Web, Yesod
+stability:       Stable
+cabal-version:   >= 1.8
+build-type:      Simple
+homepage:        http://www.yesodweb.com/
+
+library
+    build-depends:   base                      >= 4        && < 5
+                   , text                      >= 0.5      && < 0.12
+                   , vector                    >= 0.8      && < 0.10
+                   , containers                >= 0.2      && < 0.5
+                   , template-haskell
+                   , path-pieces               >= 0.1      && < 0.2
+
+    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
+    ghc-options:     -Wall
+
+test-suite runtests
+    type: exitcode-stdio-1.0
+    main-is: main.hs
+    hs-source-dirs: test
+
+    build-depends: base                      >= 4.3      && < 5
+                 , yesod-routes
+                 , text                      >= 0.5      && < 0.12
+                 , HUnit                     >= 1.2      && < 1.3
+                 , hspec                     >= 0.6      && < 0.10
+                 , containers
+                 , template-haskell
+                 , path-pieces
+    ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: git://github.com/yesodweb/yesod.git

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)

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))
         })|]
 
-
+instance RenderRoute Static where
--- | A route on the static subsite (see also 'staticFiles').
+    -- | A route on the static subsite (see also 'staticFiles').
---
+    --
--- You may use this constructor directly to manually link to a
+    -- You may use this constructor directly to manually link to a
--- static file.  The first argument is the sub-path to the file
+    -- static file.  The first argument is the sub-path to the file
--- being served whereas the second argument is the key-value
+    -- being served whereas the second argument is the key-value
--- pairs in the query string.  For example,
+    -- pairs in the query string.  For example,
---
+    --
--- > StaticRoute $ StaticR [\"thumb001.jpg\"] [(\"foo\", \"5\"), (\"bar\", \"choc\")]
+    -- > StaticRoute $ StaticR [\"thumb001.jpg\"] [(\"foo\", \"5\"), (\"bar\", \"choc\")]
---
+    --
--- would generate a url such as
+    -- would generate a url such as
--- @http://www.example.com/static/thumb001.jpg?foo=5&bar=choc@
+    -- @http://www.example.com/static/thumb001.jpg?foo=5&bar=choc@
--- The StaticRoute constructor can be used when the URL cannot be
+    -- The StaticRoute constructor can be used when the URL cannot be
--- statically generated at compile-time (e.g. when generating
+    -- statically generated at compile-time (e.g. when generating
--- image galleries).
+    -- image galleries).
-data StaticRoute = StaticRoute [Text] [(Text, Text)]
+    data Route Static = StaticRoute [Text] [(Text, Text)]
-    deriving (Eq, Show, Read)
+        deriving (Eq, Show, Read)
-
-type instance Route Static = StaticRoute
-
-instance RenderRoute StaticRoute where
     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 $
+    yesodDispatch _ _ _ _ _ _ [] _ req =
-        \req -> return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
+        return $ responseLBS status301 [("Location", rawPathInfo req `S.append` "/")] ""
 
-    yesodDispatch (Static set) _ textPieces  _ _ = Just $
+    yesodDispatch _ (Static set) _ _ _ _ textPieces  _ req =
-        \req -> staticApp set req { pathInfo = textPieces }
+        staticApp set req { pathInfo = textPieces }
 
 notHidden :: Prelude.FilePath -> Bool
 notHidden "tmp" = False

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