yesod-routes 1.1.2 → 1.2.0
raw patch · 11 files changed
+583/−131 lines, 11 filesdep +bytestringPVP ok
version bump matches the API change (PVP)
Dependencies added: bytestring
API changes (from Hackage documentation)
+ Yesod.Routes.Class: class RenderRoute a => ParseRoute a
+ Yesod.Routes.Class: class RenderRoute a => RouteAttrs a
+ Yesod.Routes.Class: parseRoute :: ParseRoute a => ([Text], [(Text, Text)]) -> Maybe (Route a)
+ Yesod.Routes.Class: routeAttrs :: RouteAttrs a => Route a -> Set Text
+ Yesod.Routes.Parse: TTApp :: TypeTree -> TypeTree -> TypeTree
+ Yesod.Routes.Parse: TTList :: TypeTree -> TypeTree
+ Yesod.Routes.Parse: TTTerm :: String -> TypeTree
+ Yesod.Routes.Parse: data TypeTree
+ Yesod.Routes.Parse: instance Eq TypeTree
+ Yesod.Routes.Parse: instance Show TypeTree
+ Yesod.Routes.Parse: parseTypeTree :: String -> Maybe TypeTree
+ Yesod.Routes.TH: FlatResource :: [(String, [(CheckOverlap, Piece a)])] -> String -> [(CheckOverlap, Piece a)] -> (Dispatch a) -> FlatResource a
+ Yesod.Routes.TH: MkDispatchSettings :: Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> Q Exp -> (Maybe String -> String -> Q Exp) -> MkDispatchSettings
+ Yesod.Routes.TH: data FlatResource a
+ Yesod.Routes.TH: data MkDispatchSettings
+ Yesod.Routes.TH: defaultGetHandler :: Maybe String -> String -> Q Exp
+ Yesod.Routes.TH: flatten :: [ResourceTree a] -> [FlatResource a]
+ Yesod.Routes.TH: mds404 :: MkDispatchSettings -> Q Exp
+ Yesod.Routes.TH: mds405 :: MkDispatchSettings -> Q Exp
+ Yesod.Routes.TH: mdsGetHandler :: MkDispatchSettings -> Maybe String -> String -> Q Exp
+ Yesod.Routes.TH: mdsGetPathInfo :: MkDispatchSettings -> Q Exp
+ Yesod.Routes.TH: mdsMethod :: MkDispatchSettings -> Q Exp
+ Yesod.Routes.TH: mdsRunHandler :: MkDispatchSettings -> Q Exp
+ Yesod.Routes.TH: mdsSetPathInfo :: MkDispatchSettings -> Q Exp
+ Yesod.Routes.TH: mdsSubDispatcher :: MkDispatchSettings -> Q Exp
+ Yesod.Routes.TH: mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec
+ Yesod.Routes.TH: mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec
+ Yesod.Routes.TH: resourceAttrs :: Resource typ -> [String]
- Yesod.Routes.TH: Resource :: String -> [(CheckOverlap, Piece typ)] -> Dispatch typ -> Resource typ
+ Yesod.Routes.TH: Resource :: String -> [(CheckOverlap, Piece typ)] -> Dispatch typ -> [String] -> Resource typ
- Yesod.Routes.TH: mkDispatchClause :: Q Exp -> Q Exp -> Q Exp -> [ResourceTree a] -> Q Clause
+ Yesod.Routes.TH: mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause
Files
- Yesod/Routes/Class.hs +9/−0
- Yesod/Routes/Dispatch.lhs +1/−1
- Yesod/Routes/Parse.hs +78/−3
- Yesod/Routes/TH.hs +4/−0
- Yesod/Routes/TH/Dispatch.hs +103/−77
- Yesod/Routes/TH/ParseRoute.hs +178/−0
- Yesod/Routes/TH/RouteAttrs.hs +38/−0
- Yesod/Routes/TH/Types.hs +15/−2
- test/Hierarchy.hs +67/−30
- test/main.hs +86/−17
- yesod-routes.cabal +4/−1
Yesod/Routes/Class.hs view
@@ -2,11 +2,20 @@ {-# LANGUAGE FlexibleContexts #-} module Yesod.Routes.Class ( RenderRoute (..)+ , ParseRoute (..)+ , RouteAttrs (..) ) where import Data.Text (Text)+import Data.Set (Set) class Eq (Route a) => RenderRoute a where -- | The type-safe URLs associated with a site argument. data Route a renderRoute :: Route a -> ([Text], [(Text, Text)])++class RenderRoute a => ParseRoute a where+ parseRoute :: ([Text], [(Text, Text)]) -> Maybe (Route a)++class RenderRoute a => RouteAttrs a where+ routeAttrs :: Route a -> Set Text
Yesod/Routes/Dispatch.lhs view
@@ -1,4 +1,4 @@-Title: Experimental, optimized route dispatch code+Title: Optimized route dispatch code Let's start with our module declaration and imports.
Yesod/Routes/Parse.hs view
@@ -7,6 +7,8 @@ , parseRoutesNoCheck , parseRoutesFileNoCheck , parseType+ , parseTypeTree+ , TypeTree (..) ) where import Language.Haskell.TH.Syntax@@ -15,6 +17,7 @@ import qualified System.IO as SIO import Yesod.Routes.TH import Yesod.Routes.Overlap (findOverlapNames)+import Data.List (foldl') -- | A quasi-quoter to parse a string into a list of 'Resource's. Checks for -- overlapping routes, failing if present; use 'parseRoutesNoCheck' to skip the@@ -73,11 +76,22 @@ in ((ResourceParent (init constr) pieces children :), otherLines'') (pattern:constr:rest) -> let (pieces, mmulti) = piecesFromString $ drop1Slash pattern- disp = dispatchFromString rest mmulti- in ((ResourceLeaf (Resource constr pieces disp):), otherLines)+ (attrs, rest') = takeAttrs rest+ disp = dispatchFromString rest' mmulti+ in ((ResourceLeaf (Resource constr pieces disp attrs):), otherLines) [] -> (id, otherLines) _ -> error $ "Invalid resource line: " ++ thisLine +-- | Take attributes out of the list and put them in the first slot in the+-- result tuple.+takeAttrs :: [String] -> ([String], [String])+takeAttrs =+ go id id+ where+ go x y [] = (x [], y [])+ go x y (('!':attr):rest) = go (x . (attr:)) y rest+ go x y (z:rest) = go x (y . (z:)) rest+ dispatchFromString :: [String] -> Maybe String -> Dispatch String dispatchFromString rest mmulti | null rest = Methods mmulti []@@ -105,11 +119,72 @@ rest = piecesFromString $ drop 1 z parseType :: String -> Type-parseType = ConT . mkName -- FIXME handle more complicated stuff+parseType orig =+ maybe (error $ "Invalid type: " ++ show orig) ttToType $ parseTypeTree orig +parseTypeTree :: String -> Maybe TypeTree+parseTypeTree orig =+ toTypeTree pieces+ where+ pieces = filter (not . null) $ splitOn '-' $ addDashes orig+ addDashes [] = []+ addDashes (x:xs) =+ front $ addDashes xs+ where+ front rest+ | x `elem` "()[]" = '-' : x : '-' : rest+ | otherwise = x : rest+ splitOn c s =+ case y' of+ _:y -> x : splitOn c y+ [] -> [x]+ where+ (x, y') = break (== c) s++data TypeTree = TTTerm String+ | TTApp TypeTree TypeTree+ | TTList TypeTree+ deriving (Show, Eq)++toTypeTree :: [String] -> Maybe TypeTree+toTypeTree orig = do+ (x, []) <- gos orig+ return x+ where+ go [] = Nothing+ go ("(":xs) = do+ (x, rest) <- gos xs+ case rest of+ ")":rest' -> Just (x, rest')+ _ -> Nothing+ go ("[":xs) = do+ (x, rest) <- gos xs+ case rest of+ "]":rest' -> Just (TTList x, rest')+ _ -> Nothing+ go (x:xs) = Just (TTTerm x, xs)++ gos xs1 = do+ (t, xs2) <- go xs1+ (ts, xs3) <- gos' id xs2+ Just (foldl' TTApp t ts, xs3)++ gos' front [] = Just (front [], [])+ gos' front (x:xs)+ | x `elem` words ") ]" = Just (front [], x:xs)+ | otherwise = do+ (t, xs') <- go $ x:xs+ gos' (front . (t:)) xs'++ttToType :: TypeTree -> Type+ttToType (TTTerm s) = ConT $ mkName s+ttToType (TTApp x y) = ttToType x `AppT` ttToType y+ttToType (TTList t) = ListT `AppT` ttToType t+ pieceFromString :: String -> Either String (CheckOverlap, Piece String) pieceFromString ('#':'!':x) = Right $ (False, Dynamic x) pieceFromString ('#':x) = Right $ (True, Dynamic x) pieceFromString ('*':x) = Left x+pieceFromString ('+':x) = Left x pieceFromString ('!':x) = Right $ (False, Static x) pieceFromString x = Right $ (True, Static x)
Yesod/Routes/TH.hs view
@@ -3,10 +3,14 @@ ( module Yesod.Routes.TH.Types -- * Functions , module Yesod.Routes.TH.RenderRoute+ , module Yesod.Routes.TH.ParseRoute+ , module Yesod.Routes.TH.RouteAttrs -- ** Dispatch , module Yesod.Routes.TH.Dispatch ) where import Yesod.Routes.TH.Types import Yesod.Routes.TH.RenderRoute+import Yesod.Routes.TH.ParseRoute+import Yesod.Routes.TH.RouteAttrs import Yesod.Routes.TH.Dispatch
Yesod/Routes/TH/Dispatch.hs view
@@ -2,6 +2,8 @@ module Yesod.Routes.TH.Dispatch ( -- ** Dispatch mkDispatchClause+ , MkDispatchSettings (..)+ , defaultGetHandler ) where import Prelude hiding (exp)@@ -16,16 +18,22 @@ import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Control.Applicative ((<$>)) import Data.List (foldl')+import Data.Text.Encoding (encodeUtf8) -data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)+data MkDispatchSettings = MkDispatchSettings+ { mdsRunHandler :: Q Exp+ , mdsSubDispatcher :: Q Exp+ , mdsGetPathInfo :: Q Exp+ , mdsSetPathInfo :: Q Exp+ , mdsMethod :: Q Exp+ , mds404 :: Q Exp+ , mds405 :: Q Exp+ , mdsGetHandler :: Maybe String -> String -> Q Exp+ } -flatten :: [ResourceTree a] -> [FlatResource a]-flatten =- concatMap (go id)- where- go front (ResourceLeaf (Resource a b c)) = [FlatResource (front []) a b c]- go front (ResourceParent name pieces children) =- concatMap (go (front . ((name, pieces):))) children+defaultGetHandler :: Maybe String -> String -> Q Exp+defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s+defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s -- | --@@ -90,12 +98,10 @@ -- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and -- @fmap 'chooseRep'@. -mkDispatchClause :: Q Exp -- ^ runHandler function- -> Q Exp -- ^ dispatcher function- -> Q Exp -- ^ fixHandler function+mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause-mkDispatchClause runHandler dispatcher fixHandler ress' = do+mkDispatchClause mds ress' = do -- Allocate the names to be used. Start off with the names passed to the -- function itself (with a 0 suffix). --@@ -103,41 +109,42 @@ -- with -Wall). Additionally, we want to ensure that none of the code -- passed to toDispatch uses variables from the closure to prevent the -- dispatch data structure from being rebuilt on each run.- master0 <- newName "master0"- sub0 <- newName "sub0"- toMaster0 <- newName "toMaster0"- app4040 <- newName "app4040"- handler4050 <- newName "handler4050"- method0 <- newName "method0"- pieces0 <- newName "pieces0"+ getEnv0 <- newName "yesod_dispatch_env0"+ req0 <- newName "req0"+ pieces <- [|$(mdsGetPathInfo mds) $(return $ VarE req0)|] -- Name of the dispatch function dispatch <- newName "dispatch" -- Dispatch function applied to the pieces- let dispatched = VarE dispatch `AppE` VarE pieces0+ let dispatched = VarE dispatch `AppE` pieces -- The 'D.Route's used in the dispatch function- routes <- mapM (buildRoute runHandler dispatcher fixHandler) ress+ routes <- mapM (buildRoute mds) ress -- The dispatch function itself toDispatch <- [|D.toDispatch|]- let dispatchFun = FunD dispatch [Clause [] (NormalB $ toDispatch `AppE` ListE routes) []]+ let dispatchFun = FunD dispatch+ [Clause+ []+ (NormalB $ toDispatch `AppE` ListE routes)+ []+ ] -- The input to the clause.- let pats = map VarP [master0, sub0, toMaster0, app4040, handler4050, method0, pieces0]+ let pats = map VarP [getEnv0, req0] -- For each resource that dispatches based on methods, build up a map for handling the dispatching.- methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) ress+ methodMaps <- catMaybes <$> mapM (buildMethodMap mds) ress u <- [|case $(return dispatched) of- Just f -> f $(return $ VarE master0)- $(return $ VarE sub0)- $(return $ VarE toMaster0)- $(return $ VarE app4040)- $(return $ VarE handler4050)- $(return $ VarE method0)- Nothing -> $(return $ VarE app4040)+ Just f -> f $(return $ VarE getEnv0)+ $(return $ VarE req0)+ Nothing -> $(mdsRunHandler mds)+ $(mds404 mds)+ $(return $ VarE getEnv0)+ Nothing+ $(return $ VarE req0) |] return $ Clause pats (NormalB u) $ dispatchFun : methodMaps where@@ -147,11 +154,11 @@ methodMapName :: String -> Name methodMapName s = mkName $ "methods" ++ s -buildMethodMap :: Q Exp -- ^ fixHandler+buildMethodMap :: MkDispatchSettings -> FlatResource a -> Q (Maybe Dec) buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function-buildMethodMap fixHandler (FlatResource parents name pieces' (Methods mmulti methods)) = do+buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods)) = do fromList <- [|Map.fromList|] methods' <- mapM go methods let exp = fromList `AppE` ListE methods'@@ -160,20 +167,27 @@ where pieces = concat $ map snd parents ++ [pieces'] go method = do- fh <- fixHandler- let func = VarE $ mkName $ map toLower method ++ name- pack' <- [|pack|]+ func <- mdsGetHandler mds (Just method) name+ pack' <- [|encodeUtf8 . pack|] let isDynamic Dynamic{} = True isDynamic _ = False let argCount = length (filter (isDynamic . snd) pieces) + maybe 0 (const 1) mmulti xs <- replicateM argCount $ newName "arg"- let rhs = LamE (map VarP xs) $ fh `AppE` (foldl' AppE func $ map VarE xs)- return $ TupE [pack' `AppE` LitE (StringL method), rhs]+ runHandler <- mdsRunHandler mds+ let rhs+ | null xs = runHandler `AppE` func+ | otherwise =+ LamE (map VarP xs) $+ runHandler `AppE` (foldl' AppE func $ map VarE xs)+ return $ TupE+ [ pack' `AppE` LitE (StringL method)+ , rhs+ ] 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 parents name resPieces resDisp) = do+buildRoute :: MkDispatchSettings -> FlatResource a -> Q Exp+buildRoute mds (FlatResource parents name resPieces resDisp) = do -- First two arguments to D.Route routePieces <- ListE <$> mapM (convertPiece . snd) allPieces isMulti <-@@ -181,19 +195,26 @@ Methods Nothing _ -> [|False|] _ -> [|True|] - [|D.Route $(return routePieces) $(return isMulti) $(routeArg3 runHandler dispatcher fixHandler parents name (map snd allPieces) resDisp)|]+ [|D.Route+ $(return routePieces)+ $(return isMulti)+ $(routeArg3+ mds+ parents+ name+ (map snd allPieces)+ resDisp)+ |] where allPieces = concat $ map snd parents ++ [resPieces] -routeArg3 :: Q Exp -- ^ runHandler- -> Q Exp -- ^ dispatcher- -> Q Exp -- ^ fixHandler+routeArg3 :: MkDispatchSettings -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> [Piece a] -> Dispatch a -> Q Exp-routeArg3 runHandler dispatcher fixHandler parents name resPieces resDisp = do+routeArg3 mds parents name resPieces resDisp = do pieces <- newName "pieces" -- Allocate input piece variables (xs) and variables that have been@@ -235,7 +256,7 @@ _ -> return ([], []) -- The final expression that actually uses the values we've computed- caller <- buildCaller runHandler dispatcher fixHandler xrest parents name resDisp $ map snd ys ++ yrest'+ caller <- buildCaller mds xrest parents name resDisp $ map snd ys ++ yrest' -- Put together all the statements just <- [|Just|]@@ -254,25 +275,21 @@ return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches -- | The final expression in the individual Route definitions.-buildCaller :: Q Exp -- ^ runHandler- -> Q Exp -- ^ dispatcher- -> Q Exp -- ^ fixHandler+buildCaller :: MkDispatchSettings -> Name -- ^ xrest -> [(String, [(CheckOverlap, Piece a)])] -> String -- ^ name of resource -> Dispatch a -> [Name] -- ^ ys -> Q Exp-buildCaller runHandler dispatcher fixHandler xrest parents name resDisp ys = do- master <- newName "master"- sub <- newName "sub"- toMaster <- newName "toMaster"- app404 <- newName "_app404"- handler405 <- newName "_handler405"- method <- newName "_method"+buildCaller mds xrest parents name resDisp ys = do+ getEnv <- newName "yesod_dispatch_env"+ req <- newName "req" - let pat = map VarP [master, sub, toMaster, app404, handler405, method]+ method <- [|$(mdsMethod mds) $(return $ VarE req)|] + let pat = map VarP [getEnv, req]+ -- Create the route let route = routeFromDynamics parents name ys @@ -281,13 +298,14 @@ Methods _ ms -> do handler <- newName "handler" + env <- [|$(return $ VarE getEnv) (Just $(return route))|]+ -- Run the whole thing- runner <- [|$(runHandler)- $(return $ VarE handler)- $(return $ VarE master)- $(return $ VarE sub)+ runner <- [|$(return $ VarE handler)+ $(return $ VarE getEnv) (Just $(return route))- $(return $ VarE toMaster)|]+ $(return $ VarE req)+ |] let myLet handlerExp = LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner@@ -295,32 +313,40 @@ if null ms then do -- Just a single handler- fh <- fixHandler- let he = fh `AppE` foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys- return $ myLet he+ base <- mdsGetHandler mds Nothing name+ let he = foldl' (\a b -> a `AppE` VarE b) base ys+ runHandler <- mdsRunHandler mds+ return $ myLet $ runHandler `AppE` he else do -- Individual methods- mf <- [|Map.lookup $(return $ VarE method) $(return $ VarE $ methodMapName name)|]+ mf <- [|Map.lookup $(return method) $(return $ VarE $ methodMapName name)|] f <- newName "f" let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys- let body405 =- VarE handler405- `AppE` route+ body405 <-+ [|$(mdsRunHandler mds)+ $(mds405 mds)+ $(return $ VarE getEnv)+ (Just $(return route))+ $(return $ VarE req)+ |] return $ CaseE mf [ Match (ConP 'Just [VarP f]) (NormalB $ myLet apply) [] , Match (ConP 'Nothing []) (NormalB body405) [] ] Subsite _ getSub -> do- let sub2 = foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys- [|$(dispatcher)- $(return $ VarE master)+ sub <- newName "sub"+ let sub2 = LamE [VarP sub]+ (foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys)+ [|$(mdsSubDispatcher mds)+ $(mdsRunHandler mds) $(return sub2)- ($(return $ VarE toMaster) . $(return route))- $(return $ VarE app404)- ($(return $ VarE handler405) . $(return route))- $(return $ VarE method)- $(return $ VarE xrest)+ $(return route)+ $(return $ VarE getEnv)+ ($(mdsSetPathInfo mds)+ $(return $ VarE xrest)+ $(return $ VarE req)+ ) |] return $ LamE pat exp
+ Yesod/Routes/TH/ParseRoute.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE TemplateHaskell #-}+module Yesod.Routes.TH.ParseRoute+ ( -- ** ParseRoute+ mkParseRouteInstance+ ) where++import Yesod.Routes.TH.Types+import Language.Haskell.TH.Syntax+import Data.Text (pack)+import Web.PathPieces (PathPiece (..), PathMultiPiece (..))+import Yesod.Routes.Class+import qualified Yesod.Routes.Dispatch as D+import Data.List (foldl')+import Control.Applicative ((<$>))+import Data.Maybe (catMaybes)+import Control.Monad (forM)+import Control.Monad (join)++-- | Clauses for the 'parseRoute' method.+mkParseRouteClauses :: [ResourceTree a] -> Q [Clause]+mkParseRouteClauses ress' = do+ pieces <- newName "pieces0"+ dispatch <- newName "dispatch"+ query <- newName "_query"++ -- The 'D.Route's used in the dispatch function+ routes <- mapM (buildRoute query) ress++ -- The dispatch function itself+ toDispatch <- [|D.toDispatch|]+ let dispatchFun = FunD dispatch+ [Clause+ []+ (NormalB $ toDispatch `AppE` ListE routes)+ []+ ]++ join' <- [|join|]+ let body = join' `AppE` (VarE dispatch `AppE` VarE pieces)+ return $ return $ Clause+ [TupP [VarP pieces, VarP query]]+ (NormalB body)+ [dispatchFun]+ where+ ress = map noMethods $ flatten ress'+ noMethods (FlatResource a b c d) = FlatResource a b c $ noMethods' d+ noMethods' (Methods a _) = Methods a []+ noMethods' (Subsite a b) = Subsite a b++mkParseRouteInstance :: Type -> [ResourceTree a] -> Q Dec+mkParseRouteInstance typ ress = do+ cls <- mkParseRouteClauses ress+ return $ InstanceD [] (ConT ''ParseRoute `AppT` typ)+ [ FunD 'parseRoute cls+ ]++-- | Build a single 'D.Route' expression.+buildRoute :: Name -> FlatResource a -> Q Exp+buildRoute query (FlatResource parents name resPieces resDisp) = do+ -- First two arguments to D.Route+ routePieces <- ListE <$> mapM (convertPiece . snd) allPieces+ isMulti <-+ case resDisp of+ Methods Nothing _ -> [|False|]+ _ -> [|True|]++ [|D.Route+ $(return routePieces)+ $(return isMulti)+ $(routeArg3+ query+ parents+ name+ (map snd allPieces)+ resDisp)+ |]+ where+ allPieces = concat $ map snd parents ++ [resPieces]++routeArg3 :: Name -- ^ query string parameters+ -> [(String, [(CheckOverlap, Piece a)])]+ -> String -- ^ name of resource+ -> [Piece a]+ -> Dispatch a+ -> Q Exp+routeArg3 query parents name resPieces resDisp = do+ pieces <- newName "pieces"++ -- Allocate input piece variables (xs) and variables that have been+ -- converted via fromPathPiece (ys)+ xs <- forM resPieces $ \piece ->+ case piece of+ Static _ -> return Nothing+ Dynamic _ -> Just <$> newName "x"++ -- Note: the zipping with Ints is just a workaround for (apparently) a bug+ -- in GHC where the identifiers are considered to be overlapping. Using+ -- newName should avoid the problem, but it doesn't.+ ys <- forM (zip (catMaybes xs) [1..]) $ \(x, i) -> do+ y <- newName $ "y" ++ show (i :: Int)+ return (x, y)++ -- In case we have multi pieces at the end+ xrest <- newName "xrest"+ yrest <- newName "yrest"++ -- Determine the pattern for matching the pieces+ pat <-+ case resDisp of+ Methods Nothing _ -> return $ ListP $ map (maybe WildP VarP) xs+ _ -> do+ let cons = mkName ":"+ return $ foldr (\a b -> ConP cons [maybe WildP VarP a, b]) (VarP xrest) xs++ -- Convert the xs+ fromPathPiece' <- [|fromPathPiece|]+ xstmts <- forM ys $ \(x, y) -> return $ BindS (VarP y) (fromPathPiece' `AppE` VarE x)++ -- Convert the xrest if appropriate+ (reststmts, yrest') <-+ case resDisp of+ Methods (Just _) _ -> do+ fromPathMultiPiece' <- [|fromPathMultiPiece|]+ return ([BindS (VarP yrest) (fromPathMultiPiece' `AppE` VarE xrest)], [yrest])+ _ -> return ([], [])++ -- The final expression that actually uses the values we've computed+ caller <- buildCaller query xrest parents name resDisp $ map snd ys ++ yrest'++ -- Put together all the statements+ just <- [|Just|]+ let stmts = concat+ [ xstmts+ , reststmts+ , [NoBindS $ just `AppE` caller]+ ]++ errorMsg <- [|error "Invariant violated"|]+ let matches =+ [ Match pat (NormalB $ DoE stmts) []+ , Match WildP (NormalB errorMsg) []+ ]++ return $ LamE [VarP pieces] $ CaseE (VarE pieces) matches++-- | The final expression in the individual Route definitions.+buildCaller :: Name -- ^ query string parameters+ -> Name -- ^ xrest+ -> [(String, [(CheckOverlap, Piece a)])]+ -> String -- ^ name of resource+ -> Dispatch a+ -> [Name] -- ^ ys+ -> Q Exp+buildCaller query xrest parents name resDisp ys = do+ -- Create the route+ let route = routeFromDynamics parents name ys++ case resDisp of+ Methods _ _ -> [|Just $(return route)|]+ Subsite _ _ -> [|fmap $(return route) $ parseRoute ($(return $ VarE xrest), $(return $ VarE query))|]++-- | Convert a 'Piece' to a 'D.Piece'+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']
+ Yesod/Routes/TH/RouteAttrs.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecordWildCards #-}+module Yesod.Routes.TH.RouteAttrs+ ( mkRouteAttrsInstance+ ) where++import Yesod.Routes.TH.Types+import Yesod.Routes.Class+import Language.Haskell.TH.Syntax+import Data.Set (fromList)+import Data.Text (pack)++mkRouteAttrsInstance :: Type -> [ResourceTree a] -> Q Dec+mkRouteAttrsInstance typ ress = do+ clauses <- mapM (goTree id) ress+ return $ InstanceD [] (ConT ''RouteAttrs `AppT` typ)+ [ FunD 'routeAttrs $ concat clauses+ ]++goTree :: (Pat -> Pat) -> ResourceTree a -> Q [Clause]+goTree front (ResourceLeaf res) = fmap return $ goRes front res+goTree front (ResourceParent name pieces trees) =+ fmap concat $ mapM (goTree front') trees+ where+ ignored = ((replicate toIgnore WildP ++) . return)+ toIgnore = length $ filter (isDynamic . snd) pieces+ isDynamic Dynamic{} = True+ isDynamic Static{} = False+ front' = front . ConP (mkName name) . ignored++goRes :: (Pat -> Pat) -> Resource a -> Q Clause+goRes front Resource {..} =+ return $ Clause+ [front $ RecP (mkName resourceName) []]+ (NormalB $ VarE 'fromList `AppE` ListE (map toText resourceAttrs))+ []+ where+ toText s = VarE 'pack `AppE` LitE (StringL s)
Yesod/Routes/TH/Types.hs view
@@ -6,10 +6,12 @@ , Piece (..) , Dispatch (..) , CheckOverlap+ , FlatResource (..) -- ** Helper functions , resourceMulti , resourceTreePieces , resourceTreeName+ , flatten ) where import Language.Haskell.TH.Syntax@@ -37,16 +39,17 @@ { resourceName :: String , resourcePieces :: [(CheckOverlap, Piece typ)] , resourceDispatch :: Dispatch typ+ , resourceAttrs :: [String] } deriving Show type CheckOverlap = Bool instance Functor Resource where- fmap f (Resource a b c) = Resource a (map (second $ fmap f) b) (fmap f c)+ fmap f (Resource a b c d) = Resource a (map (second $ fmap f) b) (fmap f c) d instance Lift t => Lift (Resource t) where- lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|]+ lift (Resource a b c d) = [|Resource a b c d|] data Piece typ = Static String | Dynamic typ deriving Show@@ -82,3 +85,13 @@ resourceMulti :: Resource typ -> Maybe typ resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t resourceMulti _ = Nothing++data FlatResource a = FlatResource [(String, [(CheckOverlap, Piece a)])] String [(CheckOverlap, Piece a)] (Dispatch a)++flatten :: [ResourceTree a] -> [FlatResource a]+flatten =+ concatMap (go id)+ where+ go front (ResourceLeaf (Resource a b c _)) = [FlatResource (front []) a b c]+ go front (ResourceParent name pieces children) =+ concatMap (go (front . ((name, pieces):))) children
test/Hierarchy.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -8,10 +9,12 @@ module Hierarchy ( hierarchy , Dispatcher (..)- , RunHandler (..)+ , runHandler , Handler , App , toText+ , Env (..)+ , subDispatch ) where import Test.Hspec@@ -22,6 +25,8 @@ import Language.Haskell.TH.Syntax import qualified Yesod.Routes.Class as YRC import Data.Text (Text, pack, append)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8 class ToText a where toText :: a -> Text@@ -29,29 +34,42 @@ 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))+type Handler sub master a = a+type Request = ([Text], ByteString) -- path info, method+type App sub master = Request -> (Text, Maybe (YRC.Route master))+data Env sub master = Env+ { envToMaster :: YRC.Route sub -> YRC.Route master+ , envSub :: sub+ , envMaster :: master+ } +subDispatch+ :: (Env sub master -> App sub master)+ -> (Handler sub master Text -> Env sub master -> Maybe (YRC.Route sub) -> App sub master)+ -> (master -> sub)+ -> (YRC.Route sub -> YRC.Route master)+ -> Env master master+ -> App sub master+subDispatch handler _runHandler getSub toMaster env req =+ handler env' req+ where+ env' = env+ { envToMaster = envToMaster env . toMaster+ , envSub = getSub $ envMaster env+ }+ 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+ dispatcher :: Env sub master -> 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+runHandler+ :: ToText a+ => Handler sub master a+ -> Env sub master+ -> Maybe (Route sub)+ -> App sub master+runHandler h Env {..} route _ = (toText h, fmap envToMaster route) + data Hierarchy = Hierarchy do@@ -63,7 +81,17 @@ /table/#Text TableR GET |] rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources- dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] resources+ prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources+ dispatch <- mkDispatchClause MkDispatchSettings+ { mdsRunHandler = [|runHandler|]+ , mdsSubDispatcher = [|subDispatch|]+ , mdsGetPathInfo = [|fst|]+ , mdsMethod = [|snd|]+ , mdsSetPathInfo = [|\p (_, m) -> (p, m)|]+ , mds404 = [|pack "404"|]+ , mds405 = [|pack "405"|]+ , mdsGetHandler = defaultGetHandler+ } resources return $ InstanceD []@@ -71,32 +99,41 @@ `AppT` ConT ''Hierarchy `AppT` ConT ''Hierarchy) [FunD (mkName "dispatcher") [dispatch]]+ : prinst : rrinst -getHomeR :: Handler sub master+getHomeR :: Handler sub master String getHomeR = "home" -getAdminRootR :: Int -> Handler sub master+getAdminRootR :: Int -> Handler sub master Text getAdminRootR i = pack $ "admin root: " ++ show i -getLoginR :: Int -> Handler sub master+getLoginR :: Int -> Handler sub master Text getLoginR i = pack $ "login: " ++ show i -postLoginR :: Int -> Handler sub master+postLoginR :: Int -> Handler sub master Text postLoginR i = pack $ "post login: " ++ show i -getTableR :: Int -> Text -> Handler sub master+getTableR :: Int -> Text -> Handler sub master Text getTableR _ t = append "TableR " t -instance RunHandler Hierarchy master where- runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)- hierarchy :: Spec 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)+ let disp m ps = dispatcher+ (Env+ { envToMaster = id+ , envMaster = Hierarchy+ , envSub = Hierarchy+ })+ (map pack ps, S8.pack m) 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")+ it "parses" $ do+ parseRoute ([], []) @?= Just HomeR+ parseRoute ([], [("foo", "bar")]) @?= Just HomeR+ parseRoute (["admin", "5"], []) @?= Just (AdminR 5 AdminRootR)+ parseRoute (["admin!", "5"], []) @?= (Nothing :: Maybe (Route Hierarchy))
test/main.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns#-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification #-}@@ -15,11 +17,13 @@ import Yesod.Routes.Class hiding (Route) import qualified Yesod.Routes.Class as YRC import qualified Yesod.Routes.Dispatch as D-import Yesod.Routes.Parse (parseRoutesNoCheck)+import Yesod.Routes.Parse (parseRoutesNoCheck, parseTypeTree, TypeTree (..)) import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax import Hierarchy+import qualified Data.ByteString.Char8 as S8+import qualified Data.Set as Set result :: ([Text] -> Maybe Int) -> Dispatch Int result f ts = f ts@@ -76,6 +80,8 @@ MySub = MySubRoute ([Text], [(Text, Text)]) deriving (Show, Eq, Read) renderRoute (MySubRoute x) = x+instance ParseRoute MySub where+ parseRoute = Just . MySubRoute getMySub :: MyApp -> MySub getMySub MyApp = MySub@@ -91,22 +97,44 @@ MySubParam = ParamRoute Char deriving (Show, Eq, Read) renderRoute (ParamRoute x) = ([singleton x], [])+instance ParseRoute MySubParam where+ parseRoute ([unpack -> [x]], _) = Just $ ParamRoute x+ parseRoute _ = Nothing getMySubParam :: MyApp -> Int -> MySubParam getMySubParam _ = MySubParam do texts <- [t|[Text]|]- let ress = map ResourceLeaf- [ Resource "RootR" [] $ Methods Nothing ["GET"]- , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) $ Methods Nothing ["GET", "POST"]- , Resource "WikiR" (addCheck [Static "wiki"]) $ Methods (Just texts) []- , Resource "SubsiteR" (addCheck [Static "subsite"]) $ Subsite (ConT ''MySub) "getMySub"- , Resource "SubparamR" (addCheck [Static "subparam", Dynamic $ ConT ''Int]) $ Subsite (ConT ''MySubParam) "getMySubParam"+ let resLeaves = map ResourceLeaf+ [ Resource "RootR" [] (Methods Nothing ["GET"]) ["foo", "bar"]+ , Resource "BlogPostR" (addCheck [Static "blog", Dynamic $ ConT ''Text]) (Methods Nothing ["GET", "POST"]) []+ , Resource "WikiR" (addCheck [Static "wiki"]) (Methods (Just texts) []) []+ , Resource "SubsiteR" (addCheck [Static "subsite"]) (Subsite (ConT ''MySub) "getMySub") []+ , Resource "SubparamR" (addCheck [Static "subparam", Dynamic $ ConT ''Int]) (Subsite (ConT ''MySubParam) "getMySubParam") [] ]+ resParent = ResourceParent+ "ParentR"+ [ (True, Static "foo")+ , (True, Dynamic $ ConT ''Text)+ ]+ [ ResourceLeaf $ Resource "ChildR" [] (Methods Nothing ["GET"]) ["child"]+ ]+ ress = resParent : resLeaves addCheck = map ((,) True) rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress- dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress+ rainst <- mkRouteAttrsInstance (ConT ''MyApp) ress+ prinst <- mkParseRouteInstance (ConT ''MyApp) ress+ dispatch <- mkDispatchClause MkDispatchSettings+ { mdsRunHandler = [|runHandler|]+ , mdsSubDispatcher = [|subDispatch dispatcher|]+ , mdsGetPathInfo = [|fst|]+ , mdsMethod = [|snd|]+ , mdsSetPathInfo = [|\p (_, m) -> (p, m)|]+ , mds404 = [|pack "404"|]+ , mds405 = [|pack "405"|]+ , mdsGetHandler = defaultGetHandler+ } ress return $ InstanceD []@@ -114,19 +142,29 @@ `AppT` ConT ''MyApp `AppT` ConT ''MyApp) [FunD (mkName "dispatcher") [dispatch]]+ : prinst+ : rainst : rrinst -instance RunHandler MyApp master where- runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)- instance Dispatcher MySub master where- dispatcher _ _ toMaster _ _ _ pieces = (pack $ "subsite: " ++ show pieces, Just $ toMaster $ MySubRoute (pieces, []))+ dispatcher env (pieces, _method) =+ ( pack $ "subsite: " ++ show pieces+ , Just $ envToMaster env route+ )+ where+ route = MySubRoute (pieces, []) instance Dispatcher MySubParam master where- dispatcher _ (MySubParam i) toMaster app404 _ _ pieces =+ dispatcher env (pieces, method) = case map unpack pieces of- [[c]] -> (pack $ "subparam " ++ show i ++ ' ' : [c], Just $ toMaster $ ParamRoute c)- _ -> app404+ [[c]] ->+ let route = ParamRoute c+ toMaster = envToMaster env+ MySubParam i = envSub env+ in ( pack $ "subparam " ++ show i ++ ' ' : [c]+ , Just $ toMaster route+ )+ _ -> (pack "404", Nothing) {- thDispatchAlias@@ -232,10 +270,16 @@ @?= (map pack ["subparam", "6", "c"], []) describe "thDispatch" $ do- let disp m ps = dispatcher MyApp MyApp id (pack "404", Nothing) (\route -> (pack "405", Just route)) (pack m) (map pack ps)+ let disp m ps = dispatcher+ (Env+ { envToMaster = id+ , envMaster = MyApp+ , envSub = MyApp+ })+ (map pack ps, S8.pack m) it "routes to root" $ disp "GET" [] @?= (pack "this is the root", Just RootR) it "POST root is 405" $ disp "POST" [] @?= (pack "405", Just RootR)- it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing)+ it "invalid page is a 404" $ disp "GET" ["not-found"] @?= (pack "404", Nothing :: Maybe (YRC.Route MyApp)) it "routes to blog post" $ disp "GET" ["blog", "somepost"] @?= (pack "some blog post: somepost", Just $ BlogPostR $ pack "somepost") it "routes to blog post, POST method" $ disp "POST" ["blog", "somepost2"]@@ -247,6 +291,11 @@ it "routes to subparam" $ disp "PUT" ["subparam", "6", "q"] @?= (pack "subparam 6 q", Just $ SubparamR 6 $ ParamRoute 'q') + describe "parsing" $ do+ it "subsites work" $ do+ parseRoute ([pack "subsite", pack "foo"], [(pack "bar", pack "baz")]) @?=+ Just (SubsiteR $ MySubRoute ([pack "foo"], [(pack "bar", pack "baz")]))+ describe "overlap checking" $ do it "catches overlapping statics" $ do let routes = [parseRoutesNoCheck|@@ -298,7 +347,24 @@ /bar/baz Foo3 |] findOverlapNames routes @?= []+ describe "routeAttrs" $ do+ it "works" $ do+ routeAttrs RootR @?= Set.fromList [pack "foo", pack "bar"]+ it "hierarchy" $ do+ routeAttrs (ParentR (pack "ignored") ChildR) @?= Set.singleton (pack "child") hierarchy+ describe "parseRouteTyoe" $ do+ let success s t = it s $ parseTypeTree s @?= Just t+ failure s = it s $ parseTypeTree s @?= Nothing+ success "Int" $ TTTerm "Int"+ success "(Int)" $ TTTerm "Int"+ failure "(Int"+ failure "(Int))"+ failure "[Int"+ failure "[Int]]"+ success "[Int]" $ TTList $ TTTerm "Int"+ success "Foo-Bar" $ TTApp (TTTerm "Foo") (TTTerm "Bar")+ success "Foo-Bar-Baz" $ TTApp (TTTerm "Foo") (TTTerm "Bar") `TTApp` TTTerm "Baz" getRootR :: Text getRootR = pack "this is the root"@@ -311,3 +377,6 @@ handleWikiR :: [Text] -> String handleWikiR ts = "the wiki: " ++ show ts++getChildR :: Text -> Text+getChildR = id
yesod-routes.cabal view
@@ -1,5 +1,5 @@ name: yesod-routes-version: 1.1.2+version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -29,6 +29,8 @@ Yesod.Routes.Overlap other-modules: Yesod.Routes.TH.Dispatch Yesod.Routes.TH.RenderRoute+ Yesod.Routes.TH.ParseRoute+ Yesod.Routes.TH.RouteAttrs Yesod.Routes.TH.Types ghc-options: -Wall @@ -46,6 +48,7 @@ , containers , template-haskell , path-pieces+ , bytestring ghc-options: -Wall source-repository head