Added TH module, creates route type and RenderRoute instance
This commit is contained in:
Michael Snoyman
parent
6a325f9e4c
commit
140a6e6d5f
117
yesod-routes/Yesod/Routes/TH.hs
Normal file
117
yesod-routes/Yesod/Routes/TH.hs
Normal file
@ -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
|
||||
]
|
||||
@ -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")])
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user