yesod-routes refactor
This commit is contained in:
Michael Snoyman
parent
6d6c4817b2
commit
666e242ee9
@ -1,208 +1,12 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Yesod.Routes.TH
|
||||
( -- * Data types
|
||||
Resource (..)
|
||||
, Piece (..)
|
||||
, Dispatch (..)
|
||||
( module Yesod.Routes.TH.Types
|
||||
-- * Functions
|
||||
-- ** RenderRoute
|
||||
, mkRenderRouteInstance
|
||||
, mkRouteCons
|
||||
, mkRenderRouteClauses
|
||||
, module Yesod.Routes.TH.RenderRoute
|
||||
-- ** Dispatch
|
||||
--, mkDispatchClause
|
||||
, module Yesod.Routes.TH.Dispatch
|
||||
) where
|
||||
|
||||
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
|
||||
|
||||
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)
|
||||
-}
|
||||
import Yesod.Routes.TH.Types
|
||||
import Yesod.Routes.TH.RenderRoute
|
||||
import Yesod.Routes.TH.Dispatch
|
||||
|
||||
98
yesod-routes/Yesod/Routes/TH/Dispatch.hs
Normal file
98
yesod-routes/Yesod/Routes/TH/Dispatch.hs
Normal file
@ -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
|
||||
102
yesod-routes/Yesod/Routes/TH/RenderRoute.hs
Normal file
102
yesod-routes/Yesod/Routes/TH/RenderRoute.hs
Normal file
@ -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]
|
||||
32
yesod-routes/Yesod/Routes/TH/Types.hs
Normal file
32
yesod-routes/Yesod/Routes/TH/Types.hs
Normal file
@ -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
|
||||
@ -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 () () [] () ()
|
||||
it "routes to root" $ disp [] @?= Just "this is the root"
|
||||
it "routes to blog post" $ disp ["blog", "somepost"] @?= Just "some blog post: somepost"
|
||||
let disp = thDispatchAlias MyApp MyApp id runHandler ("404", Nothing)
|
||||
it "routes to root" $ disp [] @?= ("this is the root", Just RootR)
|
||||
it "routes to blog post" $ disp ["blog", "somepost"]
|
||||
@?= ("some blog post: somepost", Just $ BlogPostR "somepost")
|
||||
|
||||
getRootR :: String
|
||||
getRootR = "this is the root"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user