yesod-routes: parsing included

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

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

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']

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

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))

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|

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