yesod-routes 1.0.1.2 → 1.1.0

raw patch · 8 files changed

+281/−85 lines, 8 filesdep ~hspecPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hspec

API changes (from Hackage documentation)

Files

• Yesod/Routes/Overlap.hs +33/−14
• Yesod/Routes/Parse.hs +21/−11
• Yesod/Routes/TH/Dispatch.hs +44/−14
• Yesod/Routes/TH/RenderRoute.hs +51/−11
• Yesod/Routes/TH/Types.hs +21/−0
• test/Hierarchy.hs +103/−0
• test/main.hs +5/−33
• yesod-routes.cabal +3/−2

@@ -2,27 +2,41 @@ module Yesod.Routes.Overlap     ( findOverlaps     , findOverlapNames+    , Overlap (..)     ) where  import Yesod.Routes.TH.Types-import Control.Arrow ((***))-import Data.Maybe (mapMaybe)+import Data.List (intercalate) -findOverlaps :: [Resource t] -> [(Resource t, Resource t)]-findOverlaps [] = []-findOverlaps (x:xs) = mapMaybe (findOverlap x) xs ++ findOverlaps xs+data Overlap t = Overlap+    { overlapParents :: [String] -> [String] -- ^ parent resource trees+    , overlap1 :: ResourceTree t+    , overlap2 :: ResourceTree t+    } -findOverlap :: Resource t -> Resource t -> Maybe (Resource t, Resource t)-findOverlap x y-    | overlaps (resourcePieces x) (resourcePieces y) (hasSuffix x) (hasSuffix y) = Just (x, y)-    | otherwise = Nothing+findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t]+findOverlaps _ [] = []+findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs -hasSuffix :: Resource t -> Bool-hasSuffix r =+findOverlap :: ([String] -> [String]) -> ResourceTree t -> ResourceTree t -> [Overlap t]+findOverlap front x y =+    here rest+  where+    here+        | overlaps (resourceTreePieces x) (resourceTreePieces y) (hasSuffix x) (hasSuffix y) = (Overlap front x y:)+        | otherwise = id+    rest =+        case x of+            ResourceParent name _ children -> findOverlaps (front . (name:)) children+            ResourceLeaf{} -> []++hasSuffix :: ResourceTree t -> Bool+hasSuffix (ResourceLeaf r) =     case resourceDispatch r of         Subsite{} -> True         Methods Just{} _ -> True         Methods Nothing _ -> False+hasSuffix ResourceParent{} = True  overlaps :: [(CheckOverlap, Piece t)] -> [(CheckOverlap, Piece t)] -> Bool -> Bool -> Bool @@ -50,9 +64,14 @@ piecesOverlap (Static x) (Static y) = x == y piecesOverlap _ _ = True -findOverlapNames :: [Resource t] -> [(String, String)]-findOverlapNames = map (resourceName *** resourceName) . findOverlaps-+findOverlapNames :: [ResourceTree t] -> [(String, String)]+findOverlapNames =+    map go . findOverlaps id+  where+    go (Overlap front x y) =+        (go' $ resourceTreeName x, go' $ resourceTreeName y)+      where+        go' = intercalate "/" . front . return {- -- n^2, should be a way to speed it up findOverlaps :: [Resource a] -> [[Resource a]]

@@ -10,7 +10,6 @@     ) where  import Language.Haskell.TH.Syntax-import Data.Maybe import Data.Char (isUpper) import Language.Haskell.TH.Quote import qualified System.IO as SIO@@ -55,18 +54,29 @@ -- | Convert a multi-line string to a set of resources. See documentation for -- the format of this string. This is a partial function which calls 'error' on -- invalid input.-resourcesFromString :: String -> [Resource String]+resourcesFromString :: String -> [ResourceTree String] resourcesFromString =-    mapMaybe go . lines+    fst . parse 0 . lines   where-    go s =-        case takeWhile (/= "--") $ words s of-            (pattern:constr:rest) ->-                let (pieces, mmulti) = piecesFromString $ drop1Slash pattern-                    disp = dispatchFromString rest mmulti-                 in Just $ Resource constr pieces disp-            [] -> Nothing-            _ -> error $ "Invalid resource line: " ++ s+    parse _ [] = ([], [])+    parse indent (thisLine:otherLines)+        | length spaces < indent = ([], thisLine : otherLines)+        | otherwise = (this others, remainder)+      where+        spaces = takeWhile (== ' ') thisLine+        (others, remainder) = parse indent otherLines'+        (this, otherLines') =+            case takeWhile (/= "--") $ words thisLine of+                [pattern, constr] | last constr == ':' ->+                    let (children, otherLines'') = parse (length spaces + 1) otherLines+                        (pieces, Nothing) = piecesFromString $ drop1Slash pattern+                     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)+                [] -> (id, otherLines)+                _ -> error $ "Invalid resource line: " ++ thisLine  dispatchFromString :: [String] -> Maybe String -> Dispatch String dispatchFromString rest mmulti

@@ -17,6 +17,16 @@ import Control.Applicative ((<$>)) import Data.List (foldl') +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+ -- | -- -- This function will generate a single clause that will address all@@ -83,9 +93,9 @@ mkDispatchClause :: Q Exp -- ^ runHandler function                  -> Q Exp -- ^ dispatcher function                  -> Q Exp -- ^ fixHandler function-                 -> [Resource a]+                 -> [ResourceTree a]                  -> Q Clause-mkDispatchClause runHandler dispatcher fixHandler ress = do+mkDispatchClause runHandler dispatcher fixHandler ress' = do     -- Allocate the names to be used. Start off with the names passed to the     -- function itself (with a 0 suffix).     --@@ -130,22 +140,25 @@             Nothing -> $(return $ VarE app4040)           |]     return $ Clause pats (NormalB u) $ dispatchFun : methodMaps+  where+    ress = flatten ress'  -- | Determine the name of the method map for a given resource name. methodMapName :: String -> Name methodMapName s = mkName $ "methods" ++ s  buildMethodMap :: Q Exp -- ^ fixHandler-               -> Resource a+               -> FlatResource a                -> Q (Maybe Dec)-buildMethodMap _ (Resource _ _ (Methods _ [])) = return Nothing -- single handle function-buildMethodMap fixHandler (Resource name pieces (Methods mmulti methods)) = do+buildMethodMap _ (FlatResource _ _ _ (Methods _ [])) = return Nothing -- single handle function+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@@ -156,28 +169,31 @@         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]-buildMethodMap _ (Resource _ _ Subsite{}) = return Nothing+buildMethodMap _ (FlatResource _ _ _ Subsite{}) = return Nothing  -- | Build a single 'D.Route' expression.-buildRoute :: Q Exp -> Q Exp -> Q Exp -> Resource a -> Q Exp-buildRoute runHandler dispatcher fixHandler (Resource name resPieces resDisp) = do+buildRoute :: Q Exp -> Q Exp -> Q Exp -> FlatResource a -> Q Exp+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@@ -216,7 +232,7 @@             _ -> 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|]@@ -239,11 +255,12 @@             -> 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"@@ -254,7 +271,7 @@     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@@ -309,3 +326,16 @@ 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']

@@ -14,17 +14,19 @@ import Data.Text (pack) import Web.PathPieces (PathPiece (..), PathMultiPiece (..)) import Yesod.Routes.Class+import Data.Monoid (mconcat)  -- | Generate the constructors of a route data type.-mkRouteCons :: [Resource Type] -> [Con]+mkRouteCons :: [ResourceTree Type] -> ([Con], [Dec]) mkRouteCons =-    map mkRouteCon+    mconcat . map mkRouteCon   where-    mkRouteCon res =-        NormalC (mkName $ resourceName res)+    mkRouteCon (ResourceLeaf res) =+        ([con], [])+      where+        con = NormalC (mkName $ resourceName res)             $ map (\x -> (NotStrict, x))             $ concat [singles, multi, sub]-      where         singles = concatMap (toSingle . snd) $ resourcePieces res         toSingle Static{} = []         toSingle (Dynamic typ) = [typ]@@ -35,16 +37,53 @@             case resourceDispatch res of                 Subsite { subsiteType = typ } -> [ConT ''Route `AppT` typ]                 _ -> []+    mkRouteCon (ResourceParent name pieces children) =+        ([con], dec : decs)+      where+        (cons, decs) = mkRouteCons children+        con = NormalC (mkName name)+            $ map (\x -> (NotStrict, x))+            $ concat [singles, [ConT $ mkName name]]+        dec = DataD [] (mkName name) [] cons [''Show, ''Read, ''Eq] +        singles = concatMap (toSingle . snd) pieces+        toSingle Static{} = []+        toSingle (Dynamic typ) = [typ]+ -- | Clauses for the 'renderRoute' method.-mkRenderRouteClauses :: [Resource Type] -> Q [Clause]+mkRenderRouteClauses :: [ResourceTree Type] -> Q [Clause] mkRenderRouteClauses =     mapM go   where     isDynamic Dynamic{} = True     isDynamic _ = False -    go res = do+    go (ResourceParent name pieces children) = do+        let cnt = length $ filter (isDynamic . snd) pieces+        dyns <- replicateM cnt $ newName "dyn"+        child <- newName "child"+        let pat = ConP (mkName name) $ map VarP $ dyns ++ [child]++        pack' <- [|pack|]+        tsp <- [|toPathPiece|]+        let piecesSingle = mkPieces (AppE pack' . LitE . StringL) tsp (map snd pieces) dyns++        childRender <- newName "childRender"+        let rr = VarE childRender+        childClauses <- mkRenderRouteClauses children++        a <- newName "a"+        b <- newName "b"++        colon <- [|(:)|]+        let cons y ys = InfixE (Just y) colon (Just ys)+        let pieces' = foldr cons (VarE a) piecesSingle++        let body = LamE [TupP [VarP a, VarP b]] (TupE [pieces', VarE b]) `AppE` (rr `AppE` VarE child)++        return $ Clause [pat] (NormalB body) [FunD childRender childClauses]++    go (ResourceLeaf res) = do         let cnt = length (filter (isDynamic . snd) $ resourcePieces res) + maybe 0 (const 1) (resourceMulti res)         dyns <- replicateM cnt $ newName "dyn"         sub <-@@ -93,18 +132,19 @@ -- This includes both the 'Route' associated type and the -- 'renderRoute' method.  This function uses both 'mkRouteCons' and -- 'mkRenderRouteClasses'.-mkRenderRouteInstance :: Type -> [Resource Type] -> Q Dec+mkRenderRouteInstance :: Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance = mkRenderRouteInstance' []  -- | A more general version of 'mkRenderRouteInstance' which takes an -- additional context. -mkRenderRouteInstance' :: Cxt -> Type -> [Resource Type] -> Q Dec+mkRenderRouteInstance' :: Cxt -> Type -> [ResourceTree Type] -> Q [Dec] mkRenderRouteInstance' cxt typ ress = do     cls <- mkRenderRouteClauses ress+    let (cons, decs) = mkRouteCons ress     return $ InstanceD cxt (ConT ''RenderRoute `AppT` typ)-        [ DataInstD [] ''Route [typ] (mkRouteCons ress) clazzes+        [ DataInstD [] ''Route [typ] cons clazzes         , FunD (mkName "renderRoute") cls-        ]+        ] : decs   where     clazzes = [''Show, ''Eq, ''Read]

@@ -2,15 +2,36 @@ module Yesod.Routes.TH.Types     ( -- * Data types       Resource (..)+    , ResourceTree (..)     , Piece (..)     , Dispatch (..)     , CheckOverlap       -- ** Helper functions     , resourceMulti+    , resourceTreePieces+    , resourceTreeName     ) where  import Language.Haskell.TH.Syntax import Control.Arrow (second)++data ResourceTree typ = ResourceLeaf (Resource typ) | ResourceParent String [(CheckOverlap, Piece typ)] [ResourceTree typ]++resourceTreePieces :: ResourceTree typ -> [(CheckOverlap, Piece typ)]+resourceTreePieces (ResourceLeaf r) = resourcePieces r+resourceTreePieces (ResourceParent _ x _) = x++resourceTreeName :: ResourceTree typ -> String+resourceTreeName (ResourceLeaf r) = resourceName r+resourceTreeName (ResourceParent x _ _) = x++instance Functor ResourceTree where+    fmap f (ResourceLeaf r) = ResourceLeaf (fmap f r)+    fmap f (ResourceParent a b c) = ResourceParent a (map (second $ fmap f) b) $ map (fmap f) c++instance Lift t => Lift (ResourceTree t) where+    lift (ResourceLeaf r) = [|ResourceLeaf $(lift r)|]+    lift (ResourceParent a b c) = [|ResourceParent $(lift a) $(lift b) $(lift c)|]  data Resource typ = Resource     { resourceName :: String

@@ -0,0 +1,103 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# 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++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 = 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")

@@ -20,12 +20,7 @@ import Yesod.Routes.Overlap (findOverlapNames) import Yesod.Routes.TH hiding (Dispatch) import Language.Haskell.TH.Syntax--class ToText a where-    toText :: a -> Text--instance ToText Text where toText = id-instance ToText String where toText = pack+import Hierarchy  result :: ([Text] -> Maybe Int) -> Dispatch Int result f ts = f ts@@ -101,32 +96,9 @@ 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 =+    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) []@@ -137,14 +109,13 @@     rrinst <- mkRenderRouteInstance (ConT ''MyApp) ress     dispatch <- mkDispatchClause [|runHandler|] [|dispatcher|] [|toText|] ress     return-        [ rrinst-        , InstanceD+        $ InstanceD             []             (ConT ''Dispatcher                 `AppT` ConT ''MyApp                 `AppT` ConT ''MyApp)             [FunD (mkName "dispatcher") [dispatch]]-        ]+        : rrinst  instance RunHandler MyApp master where     runHandler h _ _ subRoute toMaster = (h, fmap toMaster subRoute)@@ -328,6 +299,7 @@ /bar/baz Foo3 |]             findOverlapNames routes @?= []+    hierarchy  getRootR :: Text getRootR = pack "this is the root"

@@ -1,5 +1,5 @@ name:            yesod-routes-version:         1.0.1.2+version:         1.1.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -36,12 +36,13 @@     type: exitcode-stdio-1.0     main-is: main.hs     hs-source-dirs: test+    other-modules: Hierarchy      build-depends: base                      >= 4.3      && < 5                  , yesod-routes                  , text                      >= 0.5      && < 0.12                  , HUnit                     >= 1.2      && < 1.3-                 , hspec                     >= 0.6      && < 1.2+                 , hspec                     >= 1.3      && < 1.4                  , containers                  , template-haskell                  , path-pieces