Route is a data family, part of RenderRoute class

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/TH.hs

@@ -5,14 +5,12 @@ module Yesod.Routes.TH
     , Piece (..)
     , Dispatch (..)
       -- * Functions
-      -- ** Route data type
-    , mkRouteType
-    , mkRouteCons
       -- ** RenderRoute
-    , mkRenderRouteClauses
     , mkRenderRouteInstance
+    , mkRouteCons
+    , mkRenderRouteClauses
       -- ** Dispatch
-    , mkDispatchClause
+    --, mkDispatchClause
     ) where
 
 import Language.Haskell.TH.Syntax
@@ -38,9 +36,11 @@ data Dispatch = Methods (Maybe Type) [String] | Subsite
     , 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
@@ -61,12 +61,7 @@ mkRouteCons =
                 Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]
                 _ -> []
 
-mkRouteType :: String -> [Resource] -> Dec
+-- | Clauses for the 'renderRoute' method.
-mkRouteType name res =
-    DataD [] (mkName name) [] (mkRouteCons res) clazzes
-  where
-    clazzes = [''Show, ''Eq, ''Read]
-
 mkRenderRouteClauses :: [Resource] -> Q [Clause]
 mkRenderRouteClauses =
     mapM go
@@ -83,9 +78,9 @@ mkRenderRouteClauses =
                 _ -> return []
         let pat = ConP (mkName $ resourceName res) $ map VarP $ dyns ++ sub
 
-        pack <- [|pack|]
+        pack' <- [|pack|]
         tsp <- [|toPathPiece|]
-        let piecesSingle = mkPieces (AppE pack . LitE . StringL) tsp (resourcePieces res) dyns
+        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (resourcePieces res) dyns
 
         piecesMulti <-
             case resourceMulti res of
@@ -102,7 +97,7 @@ mkRenderRouteClauses =
                     b <- newName "b"
 
                     colon <- [|(:)|]
-                    let cons a b = InfixE (Just a) colon (Just b)
+                    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)
@@ -116,14 +111,23 @@ mkRenderRouteClauses =
     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"
 
-mkRenderRouteInstance :: String -> [Resource] -> Q Dec
+-- | Generate the 'RenderRoute' instance.
-mkRenderRouteInstance name ress = do
+--
+-- 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` ConT (mkName name))
+    return $ InstanceD [] (ConT ''RenderRoute `AppT` typ)
-        [ FunD (mkName "renderRoute") cls
+        [ 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
@@ -155,9 +159,9 @@ mkDispatchClause ress toApp = do
         let m = maybe [|False|] (const [|True|]) $ resourceMulti res
         case resourceDispatch res of
             Methods mmulti mds -> do
-                let toPair m = do
+                let toPair m' = do
-                        key <- [|pack $(lift m)|]
+                        key <- [|pack $(lift m')|]
-                        let value = VarE $ mkName $ map toLower m ++ resourceName res
+                        let value = VarE $ mkName $ map toLower m' ++ resourceName res
                         return $ TupE [key, value]
                 let handler =
                         if null mds
@@ -186,6 +190,7 @@ mkDispatchClause ress toApp = do
     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
@@ -200,3 +205,4 @@ mkTsPattern pieces mmulti = do
     go Dynamic{} = do
         dyn <- newName "dyn"
         return (Just dyn, VarP dyn)
+-}

yesod-routes/test/main.hs

@@ -56,10 +56,12 @@ overlap = toDispatch
 test :: Dispatch () Int -> [Text] -> Maybe Int
 test dispatch ts = dispatch ts ()
 
+data MyApp = MyApp
+
 data MySub = MySub
-data instance YRC.Route MySub = MySubRoute ([Text], [(Text, Text)])
+instance RenderRoute MySub where
-    deriving (Show, Eq, Read)
+    data YRC.Route MySub = MySubRoute ([Text], [(Text, Text)])
-instance RenderRoute (YRC.Route MySub) where
+        deriving (Show, Eq, Read)
     renderRoute (MySubRoute x) = x
 
 dispatchHelper :: Either String (Map.Map Text String) -> Maybe String
@@ -73,12 +75,11 @@ do
             , Resource "WikiR" [Static "wiki"] $ Methods (Just texts) []
             , Resource "SubsiteR" [Static "subsite"] $ Subsite (ConT ''MySub) "getMySub"
             ]
-    rrinst <- mkRenderRouteInstance "MyAppRoute" ress
+    rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress
-    dispatch <- mkDispatchClause ress [|error "FIXME" dispatchHelper|]
+    dispatch <- [|error "FIXME dispatch"|]
     return
-        [ mkRouteType "MyAppRoute" ress
+        [ rrinst
-        , rrinst
+        , FunD (mkName "thDispatch") [Clause [] (NormalB dispatch) []]
-        , FunD (mkName "thDispatch") [dispatch]
         ]
 
 main :: IO ()