haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Hierarchy dispatching

Browse Source
This commit is contained in:
Michael 2012-06-13 10:00:20 +03:00
parent 255d71171c
commit 0e0880dfe4
3 changed files with 114 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
yesod-routes/Yesod/Routes/TH/Dispatch.hs
View File

@ -17,15 +17,15 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..))
import Control.Applicative ((<$>))
import Data.List (foldl')
data FlatResource a = FlatResource ([String] -> [String]) String [(CheckOverlap, Piece a)] (Dispatch a)
data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)
flatten :: [ResourceTree a] -> [FlatResource a]
flatten =
concatMap (go id id)
concatMap (go id)
where
go front1 front2 (ResourceLeaf (Resource a b c)) = [FlatResource front1 a (front2 b) c]
go front1 front2 (ResourceParent name pieces children) =
concatMap (go (front1 . (name:)) (front2 . (pieces++))) children
go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c]
go front (ResourceParent name pieces children) =
concatMap (go (front . ((name, pieces):))) children
-- |
--
@ -151,13 +151,14 @@ buildMethodMap :: Q Exp -- ^ fixHandler
-> FlatResource a
-> Q (Maybe Dec)
buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function
buildMethodMap fixHandler (FlatResource names name pieces (Methods mmulti methods)) = do
buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do
fromList <- [|Map.fromList|]
methods' <- mapM go methods
let exp = fromList `AppE` ListE methods'
let fun = FunD (methodMapName name) [Clause [] (NormalB exp) []]
return $ Just fun
where
pieces = concat $ map snd parents ++ [pieces']
go method = do
fh <- fixHandler
let func = VarE $ mkName $ map toLower method ++ name
@ -172,24 +173,27 @@ buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing
-- | Build a single 'D.Route' expression.
buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp
buildRoute runHandler dispatcher fixHandler (FlatResource names name resPieces resDisp) = do
buildRoute runHandler dispatcher fixHandler (FlatResource parents name resPieces resDisp) = do
-- First two arguments to D.Route
routePieces <- ListE <$> mapM (convertPiece . snd) resPieces
routePieces <- ListE <$> mapM (convertPiece . snd) allPieces
isMulti <-
case resDisp of
Methods Nothing _ -> [|False|]
_ -> [|True|]
[|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler name (map snd resPieces) resDisp)|]
[|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|]
where
allPieces = concat $ map snd parents ++ [resPieces]
routeArg3 :: Q Exp -- ^ runHandler
-> Q Exp -- ^ dispatcher
-> Q Exp -- ^ fixHandler
-> [(String, [(CheckOverlap, Piece a)])]
-> String -- ^ name of resource
-> [Piece a]
-> Dispatch a
-> Q Exp
routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do
pieces <- newName "pieces"
-- Allocate input piece variables (xs) and variables that have been
@ -228,7 +232,7 @@ routeArg3 runHandler dispatcher fixHandler name resPieces resDisp = do
_ -> return ([], [])
-- The final expression that actually uses the values we've computed
caller <- buildCaller runHandler dispatcher fixHandler xrest name resDisp $ map snd ys ++ yrest'
caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest'
-- Put together all the statements
just <- [|Just|]
@ -251,11 +255,12 @@ buildCaller :: Q Exp -- ^ runHandler
-> Q Exp -- ^ dispatcher
-> Q Exp -- ^ fixHandler
-> Name -- ^ xrest
-> [(String, [(CheckOverlap, Piece a)])]
-> String -- ^ name of resource
-> Dispatch a
-> [Name] -- ^ ys
-> Q Exp
buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do
master <- newName "master"
sub <- newName "sub"
toMaster <- newName "toMaster"
@ -266,7 +271,7 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
let pat = map VarP [master, sub, toMaster, app404, handler405, method]
-- Create the route
let route = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
let route = routeFromDynamics parents name ys
exp <-
case resDisp of
@ -321,3 +326,16 @@ buildCaller runHandler dispatcher fixHandler xrest name resDisp ys = do
convertPiece :: Piece a -> Q Exp
convertPiece (Static s) = [|D.Static (pack $(lift s))|]
convertPiece (Dynamic _) = [|D.Dynamic|]
routeFromDynamics :: [(String, [(CheckOverlap, Piece a)])] -- ^ parents
-> String -- ^ constructor name
-> [Name]
-> Exp
routeFromDynamics [] name ys = foldl' (\a b -> a `AppE` VarE b) (ConE $ mkName name) ys
routeFromDynamics ((parent, pieces):rest) name ys =
foldl' (\a b -> a `AppE` b) (ConE $ mkName parent) here
where
(here', ys') = splitAt (length $ filter (isDynamic . snd) pieces) ys
isDynamic Dynamic{} = True
isDynamic _ = False
here = map VarE here' ++ [routeFromDynamics rest name ys']

86
yesod-routes/test/Hierarchy.hs
View File

@ -1,23 +1,103 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hierarchy (hierarchy) where
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Hierarchy
( hierarchy
, Dispatcher (..)
, RunHandler (..)
, Handler
, App
, toText
) where
import Test.Hspec.Monadic
import Test.Hspec.HUnit ()
import Test.HUnit
import Yesod.Routes.Parse
import Yesod.Routes.TH
import Yesod.Routes.Class
import Language.Haskell.TH.Syntax
import qualified Yesod.Routes.Class as YRC
import Data.Text (Text, pack, append)
class ToText a where
toText :: a -> Text
instance ToText Text where toText = id
instance ToText String where toText = pack
type Handler sub master = Text
type App sub master = (Text, Maybe (YRC.Route master))
class Dispatcher sub master where
dispatcher
:: master
-> sub
-> (YRC.Route sub -> YRC.Route master)
-> App sub master -- ^ 404 page
-> (YRC.Route sub -> App sub master) -- ^ 405 page
-> Text -- ^ method
-> [Text]
-> App sub master
class RunHandler sub master where
runHandler
:: Handler sub master
-> master
-> sub
-> Maybe (YRC.Route sub)
-> (YRC.Route sub -> YRC.Route master)
-> App sub master
data Hierarchy = Hierarchy
mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) [parseRoutes|
do
let resources = [parseRoutes|
/ HomeR GET
/admin/#Int AdminR:
/ AdminRootR GET
/login LoginR GET POST
/table/#Text TableR GET
|]
rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources
dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] resources
return
$ InstanceD
[]
(ConT ''Dispatcher
`AppT` ConT ''Hierarchy
`AppT` ConT ''Hierarchy)
[FunD (mkName "dispatcher") [dispatch]]
: rrinst
getHomeR :: Handler sub master
getHomeR = "home"
getAdminRootR :: Int -> Handler sub master
getAdminRootR i = pack $ "admin root: " ++ show i
getLoginR :: Int -> Handler sub master
getLoginR i = pack $ "login: " ++ show i
postLoginR :: Int -> Handler sub master
postLoginR i = pack $ "post login: " ++ show i
getTableR :: Int -> Text -> Handler sub master
getTableR _ t = append "TableR " t
instance RunHandler Hierarchy master where
runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)
hierarchy :: Specs
hierarchy = return ()
hierarchy = describe "hierarchy" $ do
it "renders root correctly" $
renderRoute (AdminR 5 AdminRootR) @?= (["admin", "5"], [])
it "renders table correctly" $
renderRoute (AdminR 6 $ TableR "foo") @?= (["admin", "6", "table", "foo"], [])
let disp m ps = dispatcher Hierarchy Hierarchy id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)
it "dispatches root correctly" $ disp "GET" ["admin", "7"] @?= ("admin root: 7", Just $ AdminR 7 AdminRootR)
it "dispatches table correctly" $ disp "GET" ["admin", "8", "table", "bar"] @?= ("TableR bar", Just $ AdminR 8 $ TableR "bar")

29
yesod-routes/test/main.hs
View File

@ -22,12 +22,6 @@ import Yesod.Routes.TH hiding (Dispatch)
import Language.Haskell.TH.Syntax
import Hierarchy
class ToText a where
toText :: a -> Text
instance ToText Text where toText = id
instance ToText String where toText = pack
result :: ([Text] -> Maybe Int) -> Dispatch Int
result f ts = f ts
@ -102,29 +96,6 @@ instance RenderRoute MySubParam where
getMySubParam :: MyApp -> Int -> MySubParam
getMySubParam _ = MySubParam
type Handler sub master = Text
type App sub master = (Text, Maybe (YRC.Route master))
class Dispatcher sub master where
dispatcher
:: master
-> sub
-> (YRC.Route sub -> YRC.Route master)
-> App sub master -- ^ 404 page
-> (YRC.Route sub -> App sub master) -- ^ 405 page
-> Text -- ^ method
-> [Text]
-> App sub master
class RunHandler sub master where
runHandler
:: Handler sub master
-> master
-> sub
-> Maybe (YRC.Route sub)
-> (YRC.Route sub -> YRC.Route master)
-> App sub master
do
texts <- [t|[Text]|]
let ress = map ResourceLeaf