From cf77d86a6af7cd842adb430fb94cbf05cc1cf8e3 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 19 Mar 2013 15:17:28 +0200
Subject: [PATCH] Use new mkParseRouteInstance in yesod-core

---
 yesod-core/Yesod/Core/Internal/TH.hs          | 19 +------------------
 yesod-core/test/YesodCoreTest/Json.hs         |  3 +++
 .../test/YesodCoreTest/NoOverloadedStrings.hs |  4 ++++
 .../YesodCoreTest/NoOverloadedStringsSub.hs   |  3 +++
 4 files changed, 11 insertions(+), 18 deletions(-)

diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs
index 5012fbf8..5b8318fd 100644
--- a/yesod-core/Yesod/Core/Internal/TH.hs
+++ b/yesod-core/Yesod/Core/Internal/TH.hs
@@ -76,7 +76,7 @@ mkYesodGeneral :: String                   -- ^ foundation type
 mkYesodGeneral name args isSub resS = do
      renderRouteDec <- mkRenderRouteInstance site res
      dispatchDec    <- mkDispatchInstance site res
-     parse <- mkParseRoute site res
+     parse <- mkParseRouteInstance site res
      return (parse : renderRouteDec ++ if isSub then [] else masterTypeSyns site, dispatchDec)
   where site    = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args)
         res     = map (fmap parseType) resS
@@ -116,23 +116,6 @@ mkDispatchInstance master res = do
   where
     yDispatch = ConT ''YesodDispatch `AppT` master
 
-mkParseRoute :: Type -> [ResourceTree a] -> Q Dec
-mkParseRoute typ res = do
-    Clause [VarP getEnv, req] body decs <- mkDispatchClause mds res
-    let clause = Clause [req] body $ FunD getEnv [Clause [] (NormalB $ ConE '()) []] : decs
-    return $ InstanceD [] (ConT ''ParseRoute `AppT` typ) [FunD 'parseRoute [clause]]
-  where
-    mds = MkDispatchSettings
-        { mdsRunHandler = [|\_ _ route _ -> route |]
-        , mdsSubDispatcher = [|\_ _ toParent _ req -> fmap toParent $ parseRoute req|]
-        , mdsGetPathInfo = [|fst|]
-        , mdsSetPathInfo = [|\p (_, q) -> (p, q)|]
-        , mdsMethod = [|const $ S8.pack "GET"|]
-        , mds404 = [|const ()|]
-        , mds405 = [|const ()|]
-        , mdsGetHandler = \_ _ -> [|const ()|]
-        }
-
 mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
 mkYesodSubDispatch res = do
     clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
diff --git a/yesod-core/test/YesodCoreTest/Json.hs b/yesod-core/test/YesodCoreTest/Json.hs
index 67191790..1b5b1e97 100644
--- a/yesod-core/test/YesodCoreTest/Json.hs
+++ b/yesod-core/test/YesodCoreTest/Json.hs
@@ -12,6 +12,7 @@ data App = App
 
 mkYesod "App" [parseRoutes|
 / HomeR GET
+/has-multiple-pieces/#Int/#Int MultiplePiecesR GET
 |]
 
 instance Yesod App
@@ -23,6 +24,8 @@ getHomeR = do
         Nothing -> invalidArgs ["foo not found"]
         Just foo -> return $ RepPlain $ toContent (foo :: Text)
 
+getMultiplePiecesR _ _ = return ()
+
 test :: String
      -> ByteString
      -> (SResponse -> Session ())
diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
index cd8b80ed..ee25da06 100644
--- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
+++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
@@ -29,6 +29,10 @@ getBinR = do
     |]
     lift $ defaultLayout widget
 
+getOnePiecesR _ = return ()
+getTwoPiecesR _ _ = return ()
+getThreePiecesR _ _ _ = return ()
+
 data Y = Y
 mkYesod "Y" [parseRoutes|
 / RootR GET
diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs
index 3888a893..aa5d7c0e 100644
--- a/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs
+++ b/yesod-core/test/YesodCoreTest/NoOverloadedStringsSub.hs
@@ -13,6 +13,9 @@ mkYesodSubData "Subsite" [parseRoutes|
 /bar BarR GET
 /baz BazR GET
 /bin BinR GET
+/has-one-piece/#Int OnePiecesR GET
+/has-two-pieces/#Int/#Int TwoPiecesR GET
+/has-three-pieces/#Int/#Int/#Int ThreePiecesR GET
 |]
 
 instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where