From 4d8c19becd38ae32eb7ddcbba59972f76fed5eb9 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 19 Mar 2013 15:13:56 +0200 Subject: [PATCH] yesod-routes: parsing included --- yesod-routes/Yesod/Routes/TH.hs | 2 + yesod-routes/Yesod/Routes/TH/Dispatch.hs | 10 -- yesod-routes/Yesod/Routes/TH/ParseRoute.hs | 191 +++++++++++++++++++++ yesod-routes/Yesod/Routes/TH/Types.hs | 12 ++ yesod-routes/test/Hierarchy.hs | 7 + yesod-routes/test/main.hs | 13 ++ yesod-routes/yesod-routes.cabal | 1 + 7 files changed, 226 insertions(+), 10 deletions(-) create mode 100644 yesod-routes/Yesod/Routes/TH/ParseRoute.hs diff --git a/yesod-routes/Yesod/Routes/TH.hs b/yesod-routes/Yesod/Routes/TH.hs index 41045b3c..3c9d8a8b 100644 --- a/yesod-routes/Yesod/Routes/TH.hs +++ b/yesod-routes/Yesod/Routes/TH.hs @@ -3,10 +3,12 @@ module Yesod.Routes.TH ( module Yesod.Routes.TH.Types -- * Functions , module Yesod.Routes.TH.RenderRoute + , module Yesod.Routes.TH.ParseRoute -- ** 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.Dispatch diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index 281842fe..0bf6141b 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -20,16 +20,6 @@ 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) - -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 - data MkDispatchSettings = MkDispatchSettings { mdsRunHandler :: Q Exp , mdsSubDispatcher :: Q Exp diff --git a/yesod-routes/Yesod/Routes/TH/ParseRoute.hs b/yesod-routes/Yesod/Routes/TH/ParseRoute.hs new file mode 100644 index 00000000..59b6689d --- /dev/null +++ b/yesod-routes/Yesod/Routes/TH/ParseRoute.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Routes.TH.ParseRoute + ( -- ** ParseRoute + mkParseRouteInstance + ) 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 +import Data.Monoid (mconcat) +import qualified Yesod.Routes.Dispatch as D +import Data.List (foldl') +import Control.Applicative ((<$>)) +import Yesod.Routes.TH.Types +import Language.Haskell.TH.Syntax +import Data.Maybe (catMaybes) +import Control.Monad (forM, 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 Control.Applicative ((<$>)) +import Data.List (foldl') +import Data.Text.Encoding (encodeUtf8) +import Control.Monad (join) + +-- | Clauses for the 'parseRoute' method. +mkParseRouteClauses :: [ResourceTree a] -> Q [Clause] +mkParseRouteClauses ress' = do + pieces <- newName "pieces" + 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'] diff --git a/yesod-routes/Yesod/Routes/TH/Types.hs b/yesod-routes/Yesod/Routes/TH/Types.hs index 52cd446f..2b69a594 100644 --- a/yesod-routes/Yesod/Routes/TH/Types.hs +++ b/yesod-routes/Yesod/Routes/TH/Types.hs @@ -6,10 +6,12 @@ module Yesod.Routes.TH.Types , Piece (..) , Dispatch (..) , CheckOverlap + , FlatResource (..) -- ** Helper functions , resourceMulti , resourceTreePieces , resourceTreeName + , flatten ) where import Language.Haskell.TH.Syntax @@ -82,3 +84,13 @@ instance Lift t => Lift (Dispatch t) where 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 diff --git a/yesod-routes/test/Hierarchy.hs b/yesod-routes/test/Hierarchy.hs index 1ed649ae..72a041b9 100644 --- a/yesod-routes/test/Hierarchy.hs +++ b/yesod-routes/test/Hierarchy.hs @@ -81,6 +81,7 @@ do /table/#Text TableR GET |] rrinst <- mkRenderRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources + prinst <- mkParseRouteInstance (ConT ''Hierarchy) $ map (fmap parseType) resources dispatch <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch|] @@ -98,6 +99,7 @@ do `AppT` ConT ''Hierarchy `AppT` ConT ''Hierarchy) [FunD (mkName "dispatcher") [dispatch]] + : prinst : rrinst getHomeR :: Handler sub master String @@ -130,3 +132,8 @@ hierarchy = describe "hierarchy" $ do (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)) diff --git a/yesod-routes/test/main.hs b/yesod-routes/test/main.hs index 60dcb2cb..178449b1 100644 --- a/yesod-routes/test/main.hs +++ b/yesod-routes/test/main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns#-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} @@ -78,6 +79,8 @@ instance RenderRoute MySub where 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 @@ -93,6 +96,9 @@ instance RenderRoute MySubParam where 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 @@ -108,6 +114,7 @@ do ] addCheck = map ((,) True) rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress + prinst <- mkParseRouteInstance (ConT ''MyApp) ress dispatch <- mkDispatchClause MkDispatchSettings { mdsRunHandler = [|runHandler|] , mdsSubDispatcher = [|subDispatch dispatcher|] @@ -125,6 +132,7 @@ do `AppT` ConT ''MyApp `AppT` ConT ''MyApp) [FunD (mkName "dispatcher") [dispatch]] + : prinst : rrinst instance Dispatcher MySub master where @@ -272,6 +280,11 @@ main = hspec $ do 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| diff --git a/yesod-routes/yesod-routes.cabal b/yesod-routes/yesod-routes.cabal index 7fdb7a0a..a9d8f800 100644 --- a/yesod-routes/yesod-routes.cabal +++ b/yesod-routes/yesod-routes.cabal @@ -29,6 +29,7 @@ library Yesod.Routes.Overlap other-modules: Yesod.Routes.TH.Dispatch Yesod.Routes.TH.RenderRoute + Yesod.Routes.TH.ParseRoute Yesod.Routes.TH.Types ghc-options: -Wall