More incomplete yesod-routes changes

yesod-routes/Yesod/Routes/TH.hs

@@ -19,25 +19,29 @@ import Language.Haskell.TH.Syntax
 import Yesod.Core
     ( Route, RenderRoute (renderRoute), toSinglePiece, toMultiPiece
     )
-import Data.Maybe (maybeToList)
+import Data.Maybe (maybeToList, catMaybes)
 import Control.Monad (replicateM)
 import Data.Text (pack)
 import qualified Yesod.Routes.Dispatch as D
+import qualified Data.Map as Map
+import Data.Char (toLower)
 
 data Resource = Resource
     { resourceName :: String
     , resourcePieces :: [Piece]
-    , resourceMulti :: Maybe Type
     , resourceDispatch :: Dispatch
     }
 
 data Piece = Static String | Dynamic Type
 
-data Dispatch = AllMethods | Methods [String] | Subsite
+data Dispatch = Methods (Maybe Type) [String] | Subsite
     { subsiteType :: Type
     , subsiteFunc :: String
     }
 
+resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
+resourceMulti _ = Nothing
+
 mkRouteCons :: [Resource] -> [Con]
 mkRouteCons =
     map mkRouteCon
@@ -121,8 +125,10 @@ mkRenderRouteInstance name ress = do
         [ FunD (mkName "renderRoute") cls
         ]
 
-mkDispatchClause :: [Resource] -> Q Clause
+mkDispatchClause :: [Resource]
-mkDispatchClause ress = do
+                 -> Q Exp -- ^ convert handler to application
+                 -> Q Clause
+mkDispatchClause ress toApp = do
     let routes = fmap ListE $ mapM toRoute ress
     sub <- newName "sub"
     mkey <- newName "mkey"
@@ -148,8 +154,50 @@ mkDispatchClause ress = do
     toRoute res = do
         let ps = fmap ListE $ mapM toPiece $ resourcePieces res
         let m = maybe [|False|] (const [|True|]) $ resourceMulti res
-        [|D.Route $(ps) $(m) undefined|]
+        case resourceDispatch res of
+            Methods mmulti mds -> do
+                let toPair m = do
+                        key <- [|pack $(lift m)|]
+                        let value = VarE $ mkName $ map toLower m ++ resourceName res
+                        return $ TupE [key, value]
+                let handler =
+                        if null mds
+                            then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|]
+                            else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|]
+                sub <- newName "sub"
+                mkey <- newName "mkey"
+                (dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti
+                master <- newName "master"
+                toMaster <- newName "toMaster"
+                body <- [|$(toApp) $(handler)|]
+                let func = LamE
+                            [ tsPattern
+                            , TupP
+                                [ VarP sub
+                                , VarP mkey
+                                , VarP master
+                                , VarP toMaster
+                                ]
+                            ]
+                            body
+                [|D.Route $(ps) $(m) $(return func)|]
+            Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME
 
     toPiece :: Piece -> Q Exp
     toPiece (Static s) = [|D.Static $ pack $(lift s)|]
     toPiece Dynamic{} = [|D.Dynamic|]
+
+mkTsPattern pieces mmulti = do
+    end <-
+        case mmulti of
+            Nothing -> return (Nothing, ConP (mkName "[]") [])
+            Just{} -> do
+                end <- newName "end"
+                return (Just end, VarP end)
+    pieces' <- mapM go pieces
+    return (catMaybes $ map fst pieces', fst end, foldr (flip InfixP $ mkName ":") (snd end) $ map snd pieces')
+  where
+    go Static{} = return (Nothing, WildP)
+    go Dynamic{} = do
+        dyn <- newName "dyn"
+        return (Just dyn, VarP dyn)

yesod-routes/test/main.hs

@@ -10,6 +10,7 @@ import qualified Yesod.Routes.Dispatch as D
 import Yesod.Routes.TH hiding (Dispatch)
 import qualified Yesod.Core as YC
 import Language.Haskell.TH.Syntax
+import qualified Data.Map as Map
 
 result :: ([Text] -> Maybe Int) -> Dispatch () Int
 result f ts () = f ts
@@ -60,16 +61,19 @@ type instance YC.Route MySub = MySubRoute
 instance YC.RenderRoute MySubRoute where
     renderRoute (MySubRoute x) = x
 
+dispatchHelper :: Either String (Map.Map Text String) -> Maybe String
+dispatchHelper = undefined
+
 do
     texts <- [t|[Text]|]
     let ress =
-            [ Resource "RootR" [] Nothing $ Methods ["GET"]
+            [ Resource "RootR" [] $ Methods Nothing ["GET"]
-            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] Nothing $ Methods ["GET"]
+            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] $ Methods Nothing ["GET"]
-            , Resource "WikiR" [Static "wiki"] (Just texts) AllMethods
+            , Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
-            , Resource "SubsiteR" [Static "subsite"] Nothing $ Subsite (ConT ''MySub) "getMySub"
+            , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
             ]
     rrinst <- mkRenderRouteInstance "MyAppRoute" ress
-    dispatch <- mkDispatchClause ress
+    dispatch <- mkDispatchClause ress [|dispatchHelper|]
     return
         [ mkRouteType "MyAppRoute" ress
         , rrinst
@@ -115,3 +119,17 @@ main = hspecX $ do
     describe "thDispatch" $ do
         let disp x = thDispatch () () [] () ()
         it "routes to root" $ disp [] @?= Just "this is the root"
+        it "routes to blog post" $ disp ["blog", "somepost"] @?= Just "some blog post: somepost"
+
+getRootR :: String
+getRootR = "this is the root"
+
+{- FIXME
+getBlogPostR :: Text -> String
+getBlogPostR t = "some blog post: " ++ unpack t
+-}
+getBlogPostR = undefined
+
+handleWikiR = "the wiki"
+
+handleSubsiteR = "a subsite"