diff --git a/yesod-routes/Yesod/Routes/TH.hs b/yesod-routes/Yesod/Routes/TH.hs new file mode 100644 index 00000000..9cb76bb7 --- /dev/null +++ b/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 + ] diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index 7a82f97c..d7a657fe 100644 --- a/yesod-routes/test/main.hs +++ b/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 [Static "bar"] False $ result $ const $ Just 3 + [ Route [D.Static "foo"] False $ result $ const $ Just 2 + , Route [D.Static "bar"] False $ result $ const $ Just 3 ] multi :: Dispatch () Int multi = toDispatch - [ Route [Static "foo"] False $ result $ const $ Just 4 - , Route [Static "bar"] True $ result $ const $ Just 5 + [ Route [D.Static "foo"] False $ result $ const $ Just 4 + , Route [D.Static "bar"] True $ result $ const $ Just 5 ] dynamic :: Dispatch () Int dynamic = toDispatch - [ Route [Static "foo"] False $ result $ const $ Just 6 - , Route [Dynamic] False $ result $ \ts -> + [ Route [D.Static "foo"] False $ result $ const $ Just 6 + , 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 [Static "foo"] True $ result $ const $ Just 21 + [ Route [D.Static "foo"] False $ result $ const $ Just 20 + , 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")]) diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index 1e388ae6..20153acb 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/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