yesod-routes refactor

yesod-routes/Yesod/Routes/TH.hs

@@ -1,208 +1,12 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Yesod.Routes.TH
-    ( -- * Data types
+    ( module Yesod.Routes.TH.Types
-      Resource (..)
-    , Piece (..)
-    , Dispatch (..)
       -- * Functions
-      -- ** RenderRoute
+    , module Yesod.Routes.TH.RenderRoute
-    , mkRenderRouteInstance
-    , mkRouteCons
-    , mkRenderRouteClauses
       -- ** Dispatch
-    --, mkDispatchClause
+    , module Yesod.Routes.TH.Dispatch
     ) where
 
-import Language.Haskell.TH.Syntax
+import Yesod.Routes.TH.Types
-import Data.Maybe (maybeToList, catMaybes)
+import Yesod.Routes.TH.RenderRoute
-import Control.Monad (replicateM)
+import Yesod.Routes.TH.Dispatch
-import Data.Text (pack)
-import qualified Yesod.Routes.Dispatch as D
-import qualified Data.Map as Map
-import Data.Char (toLower)
-import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
-import Yesod.Routes.Class
-
-data Resource = Resource
-    { resourceName :: String
-    , resourcePieces :: [Piece]
-    , resourceDispatch :: Dispatch
-    }
-
-data Piece = Static String | Dynamic Type
-
-data Dispatch = Methods (Maybe Type) [String] | Subsite
-    { subsiteType :: Type
-    , subsiteFunc :: String
-    }
-
-resourceMulti :: Resource -> Maybe Type
-resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
-resourceMulti _ = Nothing
-
--- | Generate the constructors of a route data type.
-mkRouteCons :: [Resource] -> [Con]
-mkRouteCons =
-    map mkRouteCon
-  where
-    mkRouteCon res =
-        NormalC (mkName $ resourceName res)
-            $ map (\x -> (NotStrict, x))
-            $ concat [singles, multi, sub]
-      where
-        singles = concatMap toSingle $ resourcePieces res
-        toSingle Static{} = []
-        toSingle (Dynamic typ) = [typ]
-
-        multi = maybeToList $ resourceMulti res
-
-        sub =
-            case resourceDispatch res of
-                Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
-                _ -> []
-
--- | Clauses for the 'renderRoute' method.
-mkRenderRouteClauses :: [Resource] -> Q [Clause]
-mkRenderRouteClauses =
-    mapM go
-  where
-    isDynamic Dynamic{} = True
-    isDynamic _ = False
-
-    go res = do
-        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
-        dyns <- replicateM cnt $ newName "dyn"
-        sub <-
-            case resourceDispatch res of
-                Subsite{} -> fmap return $ newName "sub"
-                _ -> return []
-        let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
-
-        pack' <- [|pack|]
-        tsp <- [|toPathPiece|]
-        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns
-
-        piecesMulti <-
-            case resourceMulti res of
-                Nothing -> return $ ListE []
-                Just{} -> do
-                    tmp <- [|toPathMultiPiece|]
-                    return $ tmp `AppE` VarE (last dyns)
-
-        body <-
-            case sub of
-                [x] -> do
-                    rr <- [|renderRoute|]
-                    a <- newName "a"
-                    b <- newName "b"
-
-                    colon <- [|(:)|]
-                    let cons y ys = InfixE (Just y) colon (Just ys)
-                    let pieces = foldr cons (VarE a) piecesSingle
-
-                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
-                _ -> do
-                    colon <- [|(:)|]
-                    let cons a b = InfixE (Just a) colon (Just b)
-                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
-
-        return $ Clause [pat] (NormalB body) []
-
-    mkPieces _ _ [] _ = []
-    mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
-    mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
-    mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120"
-
--- | Generate the 'RenderRoute' instance.
---
--- This includes both the 'Route' associated type and the 'renderRoute' method.
--- This function uses both 'mkRouteCons' and 'mkRenderRouteClasses'.
-mkRenderRouteInstance :: Type -> [Resource] -> Q Dec
-mkRenderRouteInstance typ ress = do
-    cls <- mkRenderRouteClauses ress
-    return $ InstanceD [] (ConT ''RenderRoute `AppT` typ)
-        [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes
-        , FunD (mkName "renderRoute") cls
-        ]
-  where
-    clazzes = [''Show, ''Eq, ''Read]
-
-{- FIXME
-mkDispatchClause :: [Resource]
-                 -> Q Exp -- ^ convert handler to application
-                 -> Q Clause
-mkDispatchClause ress toApp = do
-    let routes = fmap ListE $ mapM toRoute ress
-    sub <- newName "sub"
-    mkey <- newName "mkey"
-    ts <- newName "ts"
-    master <- newName "master"
-    toMaster <- newName "toMaster"
-    let pats =
-            [ VarP sub
-            , VarP mkey
-            , VarP ts
-            , VarP master
-            , VarP toMaster
-            ]
-
-    dispatch <- newName "dispatch"
-    body <- [|D.toDispatch $(routes)|]
-    return $ Clause
-        pats
-        (NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster]))
-        [FunD dispatch [Clause [] (NormalB body) []]]
-  where
-    toRoute :: Resource -> Q Exp
-    toRoute res = do
-        let ps = fmap ListE $ mapM toPiece $ resourcePieces res
-        let m = maybe [|False|] (const [|True|]) $ resourceMulti res
-        case resourceDispatch res of
-            Methods mmulti mds -> do
-                let toPair m' = do
-                        key <- [|pack $(lift m')|]
-                        let value = VarE $ mkName $ map toLower m' ++ resourceName res
-                        return $ TupE [key, value]
-                let handler =
-                        if null mds
-                            then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|]
-                            else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|]
-                sub <- newName "sub"
-                mkey <- newName "mkey"
-                (dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti
-                master <- newName "master"
-                toMaster <- newName "toMaster"
-                body <- [|$(toApp) $(handler)|]
-                let func = LamE
-                            [ tsPattern
-                            , TupP
-                                [ VarP sub
-                                , VarP mkey
-                                , VarP master
-                                , VarP toMaster
-                                ]
-                            ]
-                            body
-                [|D.Route $(ps) $(m) $(return func)|]
-            Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME
-
-    toPiece :: Piece -> Q Exp
-    toPiece (Static s) = [|D.Static $ pack $(lift s)|]
-    toPiece Dynamic{} = [|D.Dynamic|]
-
-mkTsPattern :: [Piece] -> Maybe t -> Q ([Name], Maybe Name, Pat)
-mkTsPattern pieces mmulti = do
-    end <-
-        case mmulti of
-            Nothing -> return (Nothing, ConP (mkName "[]") [])
-            Just{} -> do
-                end <- newName "end"
-                return (Just end, VarP end)
-    pieces' <- mapM go pieces
-    return (catMaybes $ map fst pieces', fst end, foldr (flip InfixP $ mkName ":") (snd end) $ map snd pieces')
-  where
-    go Static{} = return (Nothing, WildP)
-    go Dynamic{} = do
-        dyn <- newName "dyn"
-        return (Just dyn, VarP dyn)
--}

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

@@ -0,0 +1,98 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Routes.TH.Dispatch
+    ( -- ** Dispatch
+      mkDispatchClause
+    ) where
+
+import Yesod.Routes.TH.Types
+import Language.Haskell.TH.Syntax
+import Data.Maybe (maybeToList, catMaybes)
+import Control.Monad (replicateM)
+import Data.Text (pack)
+import qualified Yesod.Routes.Dispatch as D
+import qualified Data.Map as Map
+import Data.Char (toLower)
+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
+import Yesod.Routes.Class
+
+mkDispatchClause :: [Resource]
+                 -> Q Clause
+mkDispatchClause ress = undefined
+{- FIXME
+    let routes = fmap ListE $ mapM toRoute ress
+    sub <- newName "sub"
+    mkey <- newName "mkey"
+    ts <- newName "ts"
+    master <- newName "master"
+    toMaster <- newName "toMaster"
+    let pats =
+            [ VarP sub
+            , VarP mkey
+            , VarP ts
+            , VarP master
+            , VarP toMaster
+            ]
+
+    dispatch <- newName "dispatch"
+    body <- [|D.toDispatch $(routes)|]
+    return $ Clause
+        pats
+        (NormalB $ VarE dispatch `AppE` VarE ts `AppE` TupE (map VarE [sub, mkey, master, toMaster]))
+        [FunD dispatch [Clause [] (NormalB body) []]]
+  where
+
+mkTsPattern :: [Piece] -> Maybe t -> Q ([Name], Maybe Name, Pat)
+mkTsPattern pieces mmulti = do
+    end <-
+        case mmulti of
+            Nothing -> return (Nothing, ConP (mkName "[]") [])
+            Just{} -> do
+                end <- newName "end"
+                return (Just end, VarP end)
+    pieces' <- mapM go pieces
+    return (catMaybes $ map fst pieces', fst end, foldr (flip InfixP $ mkName ":") (snd end) $ map snd pieces')
+  where
+    go Static{} = return (Nothing, WildP)
+    go Dynamic{} = do
+        dyn <- newName "dyn"
+        return (Just dyn, VarP dyn)
+-}
+
+-- | Convert a 'Piece' into a 'D.Piece'.
+toPiece :: Piece -> Q Exp
+toPiece (Static s) = [|D.Static $ pack $(lift s)|]
+toPiece Dynamic{} = [|D.Dynamic|]
+
+-- | Convert a 'Resource' into a 'D.Route'.
+toRoute :: Resource -> Q Exp
+toRoute res = do
+    let ps = fmap ListE $ mapM toPiece $ resourcePieces res
+    let m = maybe [|False|] (const [|True|]) $ resourceMulti res
+    case resourceDispatch res of
+        Methods mmulti mds -> do
+            let toPair m' = do
+                    key <- [|pack $(lift m')|]
+                    let value = VarE $ mkName $ map toLower m' ++ resourceName res
+                    return $ TupE [key, value]
+            let handler =
+                    if null mds
+                        then [|Left $(return $ VarE $ mkName $ "handle" ++ resourceName res)|]
+                        else [|Right $ Map.fromList $(fmap ListE $ mapM toPair mds)|]
+            sub <- newName "sub"
+            mkey <- newName "mkey"
+            (dyns, mend, tsPattern) <- mkTsPattern (resourcePieces res) mmulti
+            master <- newName "master"
+            toMaster <- newName "toMaster"
+            body <- [|$(toApp) $(handler)|]
+            let func = LamE
+                        [ tsPattern
+                        , TupP
+                            [ VarP sub
+                            , VarP mkey
+                            , VarP master
+                            , VarP toMaster
+                            ]
+                        ]
+                        body
+            [|D.Route $(ps) $(m) $(return func)|]
+        Subsite _ func -> [|D.Route $(ps) $(m) $ $(toApp) $(return $ VarE $ mkName $ "handle" ++ resourceName res)|] -- FIXME

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

@@ -0,0 +1,102 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Routes.TH.RenderRoute
+    ( -- ** RenderRoute
+      mkRenderRouteInstance
+    , mkRouteCons
+    , mkRenderRouteClauses
+    ) where
+
+import Yesod.Routes.TH.Types
+import Language.Haskell.TH.Syntax
+import Data.Maybe (maybeToList)
+import Control.Monad (replicateM)
+import Data.Text (pack)
+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
+import Yesod.Routes.Class
+
+-- | Generate the constructors of a route data type.
+mkRouteCons :: [Resource] -> [Con]
+mkRouteCons =
+    map mkRouteCon
+  where
+    mkRouteCon res =
+        NormalC (mkName $ resourceName res)
+            $ map (\x -> (NotStrict, x))
+            $ concat [singles, multi, sub]
+      where
+        singles = concatMap toSingle $ resourcePieces res
+        toSingle Static{} = []
+        toSingle (Dynamic typ) = [typ]
+
+        multi = maybeToList $ resourceMulti res
+
+        sub =
+            case resourceDispatch res of
+                Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
+                _ -> []
+
+-- | Clauses for the 'renderRoute' method.
+mkRenderRouteClauses :: [Resource] -> Q [Clause]
+mkRenderRouteClauses =
+    mapM go
+  where
+    isDynamic Dynamic{} = True
+    isDynamic _ = False
+
+    go res = do
+        let cnt = length (filter isDynamic $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)
+        dyns <- replicateM cnt $ newName "dyn"
+        sub <-
+            case resourceDispatch res of
+                Subsite{} -> fmap return $ newName "sub"
+                _ -> return []
+        let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
+
+        pack' <- [|pack|]
+        tsp <- [|toPathPiece|]
+        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns
+
+        piecesMulti <-
+            case resourceMulti res of
+                Nothing -> return $ ListE []
+                Just{} -> do
+                    tmp <- [|toPathMultiPiece|]
+                    return $ tmp `AppE` VarE (last dyns)
+
+        body <-
+            case sub of
+                [x] -> do
+                    rr <- [|renderRoute|]
+                    a <- newName "a"
+                    b <- newName "b"
+
+                    colon <- [|(:)|]
+                    let cons y ys = InfixE (Just y) colon (Just ys)
+                    let pieces = foldr cons (VarE a) piecesSingle
+
+                    return $ LamE [TupP [VarP a, VarP b]] (TupE [pieces, VarE b]) `AppE` (rr `AppE` VarE x)
+                _ -> do
+                    colon <- [|(:)|]
+                    let cons a b = InfixE (Just a) colon (Just b)
+                    return $ TupE [foldr cons piecesMulti piecesSingle, ListE []]
+
+        return $ Clause [pat] (NormalB body) []
+
+    mkPieces _ _ [] _ = []
+    mkPieces toText tsp (Static s:ps) dyns = toText s : mkPieces toText tsp ps dyns
+    mkPieces toText tsp (Dynamic{}:ps) (d:dyns) = tsp `AppE` VarE d : mkPieces toText tsp ps dyns
+    mkPieces _ _ ((Dynamic _) : _) [] = error "mkPieces 120"
+
+-- | Generate the 'RenderRoute' instance.
+--
+-- This includes both the 'Route' associated type and the 'renderRoute' method.
+-- This function uses both 'mkRouteCons' and 'mkRenderRouteClasses'.
+mkRenderRouteInstance :: Type -> [Resource] -> Q Dec
+mkRenderRouteInstance typ ress = do
+    cls <- mkRenderRouteClauses ress
+    return $ InstanceD [] (ConT ''RenderRoute `AppT` typ)
+        [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes
+        , FunD (mkName "renderRoute") cls
+        ]
+  where
+    clazzes = [''Show, ''Eq, ''Read]

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

@@ -0,0 +1,32 @@
+module Yesod.Routes.TH.Types
+    ( -- * Data types
+      Resource (..)
+    , Piece (..)
+    , Dispatch (..)
+      -- ** Helper functions
+    , resourceMulti
+    ) where
+
+import Language.Haskell.TH.Syntax
+
+data Resource = Resource
+    { resourceName :: String
+    , resourcePieces :: [Piece]
+    , resourceDispatch :: Dispatch
+    }
+
+data Piece = Static String | Dynamic Type
+
+data Dispatch =
+    Methods
+        { methodsMulti :: Maybe Type -- ^ type of the multi piece at the end
+        , methodsMethods :: [String] -- ^ supported request methods
+        }
+    | Subsite
+        { subsiteType :: Type
+        , subsiteFunc :: String
+        }
+
+resourceMulti :: Resource -> Maybe Type
+resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t
+resourceMulti _ = Nothing

yesod-routes/test/main.hs

@@ -64,9 +64,6 @@ instance RenderRoute MySub where
         deriving (Show, Eq, Read)
     renderRoute (MySubRoute x) = x
 
-dispatchHelper :: Either String (Map.Map Text String) -> Maybe String
-dispatchHelper = undefined
-
 do
     texts <- [t|[Text]|]
     let ress =
@@ -76,12 +73,34 @@ do
             , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
             ]
     rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
-    dispatch <- [|error "FIXME dispatch"|]
+    dispatch <- mkDispatchClause ress
     return
         [ rrinst
-        , FunD (mkName "thDispatch") [Clause [] (NormalB dispatch) []]
+        , FunD (mkName "thDispatch") [dispatch]
         ]
 
+type RunHandler handler master sub app =
+        handler
+     -> master
+     -> sub
+     -> YRC.Route sub
+     -> (YRC.Route sub -> YRC.Route master)
+     -> app
+
+thDispatchAlias
+    :: (master ~ MyApp, handler ~ String)
+    => master
+    -> sub
+    -> (YRC.Route sub -> YRC.Route master)
+    -> RunHandler handler master sub app
+    -> app
+    -> [Text]
+    -> app
+thDispatchAlias = thDispatch
+
+runHandler :: RunHandler String MyApp sub (String, Maybe (YRC.Route MyApp))
+runHandler h _ _ subRoute toMaster = (h, Just $ toMaster subRoute)
+
 main :: IO ()
 main = hspecX $ do
     describe "justRoot" $ do
@@ -119,9 +138,10 @@ main = hspecX $ do
             @?= (["subsite", "foo", "bar"], [("baz", "bin")])
 
     describe "thDispatch" $ do
-        let disp x = thDispatch () () [] () ()
+        let disp = thDispatchAlias MyApp MyApp id runHandler ("404", Nothing)
-        it "routes to root" $ disp [] @?= Just "this is the root"
+        it "routes to root" $ disp [] @?= ("this is the root", Just RootR)
-        it "routes to blog post" $ disp ["blog", "somepost"] @?= Just "some blog post: somepost"
+        it "routes to blog post" $ disp ["blog", "somepost"]
+            @?= ("some blog post: somepost", Just $ BlogPostR "somepost")
 
 getRootR :: String
 getRootR = "this is the root"