Added TH module, creates route type and RenderRoute instance

yesod-routes/Yesod/Routes/TH.hs

@@ -0,0 +1,117 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Yesod.Routes.TH
+    ( -- * Data types
+      Resource (..)
+    , Piece (..)
+    , Dispatch (..)
+      -- * Functions
+      -- ** Route data type
+    , mkRouteType
+    , mkRouteCons
+      -- ** RenderRoute
+    , mkRenderRouteClauses
+    , mkRenderRouteInstance
+    ) where
+
+import Language.Haskell.TH.Syntax
+import Yesod.Core (Route, RenderRoute (renderRoute), toSinglePiece, toMultiPiece)
+import Data.Maybe (maybeToList)
+import Control.Monad (replicateM)
+import Data.Text (pack)
+
+data Resource = Resource
+    { resourceName :: String
+    , resourcePieces :: [Piece]
+    , resourceMulti :: Maybe Type
+    , resourceDispatch :: Dispatch
+    }
+
+data Piece = Static String | Dynamic Type
+
+data Dispatch = AllMethods | Methods [String] | Subsite
+    { subsiteType :: Type
+    , subsiteFunc :: String
+    }
+
+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]
+                _ -> []
+
+mkRouteType :: String -> [Resource] -> Dec
+mkRouteType name res =
+    DataD [] (mkName name) [] (mkRouteCons res) clazzes
+  where
+    clazzes = [''Show, ''Eq, ''Read]
+
+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 <- [|toSinglePiece|]
+        let piecesSingle = mkPieces (AppE pack . LitE . StringL) tsp (resourcePieces res) dyns
+
+        piecesMulti <-
+            case resourceMulti res of
+                Nothing -> return $ ListE []
+                Just{} -> do
+                    tmp <- [|toMultiPiece|]
+                    return $ tmp `AppE` VarE (last dyns)
+
+        body <-
+            case sub of
+                [x] -> do
+                    rr <- [|renderRoute|]
+                    a <- newName "a"
+                    b <- newName "b"
+
+                    colon <- [|(:)|]
+                    let cons a b = InfixE (Just a) colon (Just b)
+                    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
+
+mkRenderRouteInstance :: String -> [Resource] -> Q Dec
+mkRenderRouteInstance name ress = do
+    cls <- mkRenderRouteClauses ress
+    return $ InstanceD [] (ConT ''RenderRoute `AppT` ConT (mkName name))
+        [ FunD (mkName "renderRoute") cls
+        ]

yesod-routes/test/main.hs

@@ -1,9 +1,15 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 import Test.Hspec.Monadic
 import Test.Hspec.HUnit ()
 import Test.HUnit ((@?=))
 import Data.Text (Text, unpack)
-import Yesod.Routes.Dispatch
+import Yesod.Routes.Dispatch hiding (Static, Dynamic)
+import qualified Yesod.Routes.Dispatch as D
+import Yesod.Routes.TH hiding (Dispatch)
+import qualified Yesod.Core as YC
+import Language.Haskell.TH.Syntax
 
 result :: ([Text] -> Maybe Int) -> Dispatch () Int
 result f ts () = f ts
@@ -15,20 +21,20 @@ justRoot = toDispatch
 
 twoStatics :: Dispatch () Int
 twoStatics = toDispatch
-    [ Route [Static "foo"] False $ result $ const $ Just 2
+    [ Route [D.Static "foo"] False $ result $ const $ Just 2
-    , Route [Static "bar"] False $ result $ const $ Just 3
+    , Route [D.Static "bar"] False $ result $ const $ Just 3
     ]
 
 multi :: Dispatch () Int
 multi = toDispatch
-    [ Route [Static "foo"] False $ result $ const $ Just 4
+    [ Route [D.Static "foo"] False $ result $ const $ Just 4
-    , Route [Static "bar"] True $ result $ const $ Just 5
+    , Route [D.Static "bar"] True $ result $ const $ Just 5
     ]
 
 dynamic :: Dispatch () Int
 dynamic = toDispatch
-    [ Route [Static "foo"] False $ result $ const $ Just 6
+    [ Route [D.Static "foo"] False $ result $ const $ Just 6
-    , Route [Dynamic] False $ result $ \ts ->
+    , Route [D.Dynamic] False $ result $ \ts ->
         case ts of
             [t] ->
                 case reads $ unpack t of
@@ -39,14 +45,35 @@ dynamic = toDispatch
 
 overlap :: Dispatch () Int
 overlap = toDispatch
-    [ Route [Static "foo"] False $ result $ const $ Just 20
+    [ Route [D.Static "foo"] False $ result $ const $ Just 20
-    , Route [Static "foo"] True $ result $ const $ Just 21
+    , Route [D.Static "foo"] True $ result $ const $ Just 21
     , Route [] True $ result $ const $ Just 22
     ]
 
 test :: Dispatch () Int -> [Text] -> Maybe Int
 test dispatch ts = dispatch ts ()
 
+data MySub = MySub
+data MySubRoute = MySubRoute ([Text], [(Text, Text)])
+    deriving (Show, Read, Eq)
+type instance YC.Route MySub = MySubRoute
+instance YC.RenderRoute MySubRoute where
+    renderRoute (MySubRoute x) = x
+
+do
+    texts <- [t|[Text]|]
+    let ress =
+            [ Resource "RootR" [] Nothing $ Methods ["GET"]
+            , Resource "BlogPostR" [Static "blog", Dynamic $ ConT ''Text] Nothing $ Methods ["GET"]
+            , Resource "WikiR" [Static "wiki"] (Just texts) AllMethods
+            , Resource "SubsiteR" [Static "subsite"] Nothing $ Subsite (ConT ''MySub) "getMySub"
+            ]
+    rrinst <- mkRenderRouteInstance "MyAppRoute" ress
+    return
+        [ mkRouteType "MyAppRoute" ress
+        , rrinst
+        ]
+
 main :: IO ()
 main = hspecX $ do
     describe "justRoot" $ do
@@ -75,3 +102,10 @@ main = hspecX $ do
         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" $ YC.renderRoute RootR @?= ([], [])
+        it "renders blog post correctly" $ YC.renderRoute (BlogPostR "foo") @?= (["blog", "foo"], [])
+        it "renders wiki correctly" $ YC.renderRoute (WikiR ["foo", "bar"]) @?= (["wiki", "foo", "bar"], [])
+        it "renders subsite correctly" $ YC.renderRoute (SubsiteR $ MySubRoute (["foo", "bar"], [("baz", "bin")]))
+            @?= (["subsite", "foo", "bar"], [("baz", "bin")])

yesod-routes/yesod-routes.cabal

@@ -18,8 +18,10 @@ library
                    , vector                    >= 0.8      && < 0.10
                    , clientsession             >= 0.7      && < 0.8
                    , containers                >= 0.2      && < 0.5
+                   , template-haskell
 
     exposed-modules: Yesod.Routes.Dispatch
+                     Yesod.Routes.TH
     ghc-options:     -Wall
 
 test-suite runtests
@@ -32,6 +34,7 @@ test-suite runtests
                  , text                      >= 0.5      && < 0.12
                  , HUnit                     >= 1.2      && < 1.3
                  , hspec                     >= 0.6      && < 0.10
+                 , yesod-core                >= 0.9.3    && < 0.10
     ghc-options:     -Wall
 
 source-repository head