From bf9b294fd3a4ae4e550844504f3ac4ed0dc226c0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 28 Feb 2013 23:40:44 -0400 Subject: [PATCH] remove TH (hack job) --- Yesod/Routes/Overlap.hs | 74 ---------- Yesod/Routes/Parse.hs | 115 --------------- Yesod/Routes/TH.hs | 12 -- Yesod/Routes/TH/Dispatch.hs | 344 ------------------------------------------- Yesod/Routes/TH/Types.hs | 84 ----------- yesod-routes.cabal | 22 --- 6 files changed, 651 deletions(-) delete mode 100644 Yesod/Routes/Overlap.hs delete mode 100644 Yesod/Routes/Parse.hs delete mode 100644 Yesod/Routes/TH.hs delete mode 100644 Yesod/Routes/TH/Dispatch.hs delete mode 100644 Yesod/Routes/TH/Types.hs diff --git a/Yesod/Routes/Overlap.hs b/Yesod/Routes/Overlap.hs deleted file mode 100644 index ae45a02..0000000 --- a/Yesod/Routes/Overlap.hs +++ /dev/null @@ -1,74 +0,0 @@ --- | Check for overlapping routes. -module Yesod.Routes.Overlap - ( findOverlaps - , findOverlapNames - , Overlap (..) - ) where - -import Yesod.Routes.TH.Types -import Data.List (intercalate) - -data Overlap t = Overlap - { overlapParents :: [String] -> [String] -- ^ parent resource trees - , overlap1 :: ResourceTree t - , overlap2 :: ResourceTree t - } - -findOverlaps :: ([String] -> [String]) -> [ResourceTree t] -> [Overlap t] -findOverlaps _ [] = [] -findOverlaps front (x:xs) = concatMap (findOverlap front x) xs ++ findOverlaps front xs - -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 - --- No pieces on either side, will overlap regardless of suffix -overlaps [] [] _ _ = True - --- No pieces on the left, will overlap if the left side has a suffix -overlaps [] _ suffixX _ = suffixX - --- Ditto for the right -overlaps _ [] _ suffixY = suffixY - --- As soon as we ignore a single piece (via CheckOverlap == False), we say that --- the routes don't overlap at all. In other words, disabling overlap checking --- on a single piece disables it on the whole route. -overlaps ((False, _):_) _ _ _ = False -overlaps _ ((False, _):_) _ _ = False - --- Compare the actual pieces -overlaps ((True, pieceX):xs) ((True, pieceY):ys) suffixX suffixY = - piecesOverlap pieceX pieceY && overlaps xs ys suffixX suffixY - -piecesOverlap :: Piece t -> Piece t -> Bool --- Statics only match if they equal. Dynamics match with anything -piecesOverlap (Static x) (Static y) = x == y -piecesOverlap _ _ = True - -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 diff --git a/Yesod/Routes/Parse.hs b/Yesod/Routes/Parse.hs deleted file mode 100644 index fc16eef..0000000 --- a/Yesod/Routes/Parse.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- QuasiQuoter -module Yesod.Routes.Parse - ( parseRoutes - , parseRoutesFile - , parseRoutesNoCheck - , parseRoutesFileNoCheck - , parseType - ) where - -import Language.Haskell.TH.Syntax -import Data.Char (isUpper) -import Language.Haskell.TH.Quote -import qualified System.IO as SIO -import Yesod.Routes.TH -import Yesod.Routes.Overlap (findOverlapNames) - --- | 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 --- checking. See documentation site for details on syntax. -parseRoutes :: QuasiQuoter -parseRoutes = QuasiQuoter { quoteExp = x } - where - x s = do - let res = resourcesFromString s - case findOverlapNames res of - [] -> lift res - z -> error $ "Overlapping routes: " ++ unlines (map show z) - -parseRoutesFile :: FilePath -> Q Exp -parseRoutesFile = parseRoutesFileWith parseRoutes - -parseRoutesFileNoCheck :: FilePath -> Q Exp -parseRoutesFileNoCheck = parseRoutesFileWith parseRoutesNoCheck - -parseRoutesFileWith :: QuasiQuoter -> FilePath -> Q Exp -parseRoutesFileWith qq fp = do - s <- qRunIO $ readUtf8File fp - quoteExp qq s - -readUtf8File :: FilePath -> IO String -readUtf8File fp = do - h <- SIO.openFile fp SIO.ReadMode - SIO.hSetEncoding h SIO.utf8_bom - SIO.hGetContents h - --- | Same as 'parseRoutes', but performs no overlap checking. -parseRoutesNoCheck :: QuasiQuoter -parseRoutesNoCheck = QuasiQuoter - { quoteExp = lift . resourcesFromString - } - --- | 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 -> [ResourceTree String] -resourcesFromString = - fst . parse 0 . lines - where - 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 - | null rest = Methods mmulti [] - | all (all isUpper) rest = Methods mmulti rest -dispatchFromString [subTyp, subFun] Nothing = - Subsite subTyp subFun -dispatchFromString [_, _] Just{} = - error "Subsites cannot have a multipiece" -dispatchFromString rest _ = error $ "Invalid list of methods: " ++ show rest - -drop1Slash :: String -> String -drop1Slash ('/':x) = x -drop1Slash x = x - -piecesFromString :: String -> ([(CheckOverlap, Piece String)], Maybe String) -piecesFromString "" = ([], Nothing) -piecesFromString x = - case (this, rest) of - (Left typ, ([], Nothing)) -> ([], Just typ) - (Left _, _) -> error "Multipiece must be last piece" - (Right piece, (pieces, mtyp)) -> (piece:pieces, mtyp) - where - (y, z) = break (== '/') x - this = pieceFromString y - rest = piecesFromString $ drop 1 z - -parseType :: String -> Type -parseType = ConT . mkName -- FIXME handle more complicated stuff - -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) = Right $ (False, Static x) -pieceFromString x = Right $ (True, Static x) diff --git a/Yesod/Routes/TH.hs b/Yesod/Routes/TH.hs deleted file mode 100644 index 41045b3..0000000 --- a/Yesod/Routes/TH.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Yesod.Routes.TH - ( module Yesod.Routes.TH.Types - -- * Functions - , module Yesod.Routes.TH.RenderRoute - -- ** Dispatch - , module Yesod.Routes.TH.Dispatch - ) where - -import Yesod.Routes.TH.Types -import Yesod.Routes.TH.RenderRoute -import Yesod.Routes.TH.Dispatch diff --git a/Yesod/Routes/TH/Dispatch.hs b/Yesod/Routes/TH/Dispatch.hs deleted file mode 100644 index a52f69a..0000000 --- a/Yesod/Routes/TH/Dispatch.hs +++ /dev/null @@ -1,344 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Yesod.Routes.TH.Dispatch - ( -- ** Dispatch - mkDispatchClause - ) where - -import Prelude hiding (exp) -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') - -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 --- your routing needs. It takes four arguments. The fourth (a list of --- 'Resource's) is self-explanatory. We\'ll discuss the first --- three. But first, let\'s cover the terminology. --- --- Dispatching involves a master type and a sub type. When you dispatch to the --- top level type, master and sub are the same. Each time to dispatch to --- another subsite, the sub changes. This requires two changes: --- --- * Getting the new sub value. This is handled via 'subsiteFunc'. --- --- * Figure out a way to convert sub routes to the original master route. To --- address this, we keep a toMaster function, and each time we dispatch to a --- new subsite, we compose it with the constructor for that subsite. --- --- Dispatching acts on two different components: the request method and a list --- of path pieces. If we cannot match the path pieces, we need to return a 404 --- response. If the path pieces match, but the method is not supported, we need --- to return a 405 response. --- --- The final result of dispatch is going to be an application type. A simple --- example would be the WAI Application type. However, our handler functions --- will need more input: the master/subsite, the toMaster function, and the --- type-safe route. Therefore, we need to have another type, the handler type, --- and a function that turns a handler into an application, i.e. --- --- > runHandler :: handler sub master -> master -> sub -> Route sub -> (Route sub -> Route master) -> app --- --- This is the first argument to our function. Note that this will almost --- certainly need to be a method of a typeclass, since it will want to behave --- differently based on the subsite. --- --- Note that the 404 response passed in is an application, while the 405 --- response is a handler, since the former can\'t be passed the type-safe --- route. --- --- In the case of a subsite, we don\'t directly deal with a handler function. --- Instead, we redispatch to the subsite, passing on the updated sub value and --- toMaster function, as well as any remaining, unparsed path pieces. This --- function looks like: --- --- > dispatcher :: master -> sub -> (Route sub -> Route master) -> app -> handler sub master -> Text -> [Text] -> app --- --- Where the parameters mean master, sub, toMaster, 404 response, 405 response, --- request method and path pieces. This is the second argument of our function. --- --- Finally, we need a way to decide which of the possible formats --- should the handler send the data out. Think of each URL holding an --- abstract object which has multiple representation (JSON, plain HTML --- etc). Each client might have a preference on which format it wants --- the abstract object in. For example, a javascript making a request --- (on behalf of a browser) might prefer a JSON object over a plain --- HTML file where as a user browsing with javascript disabled would --- want the page in HTML. The third argument is a function that --- converts the abstract object to the desired representation --- depending on the preferences sent by the client. --- --- The typical values for the first three arguments are, --- @'yesodRunner'@ for the first, @'yesodDispatch'@ for the second and --- @fmap 'chooseRep'@. - -mkDispatchClause :: Q Exp -- ^ runHandler function - -> Q Exp -- ^ dispatcher function - -> Q Exp -- ^ fixHandler function - -> [ResourceTree a] - -> Q Clause -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). - -- - -- We don't reuse names so as to avoid shadowing names (triggers warnings - -- 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" - - -- Name of the dispatch function - dispatch <- newName "dispatch" - - -- Dispatch function applied to the pieces - let dispatched = VarE dispatch `AppE` VarE pieces0 - - -- The 'D.Route's used in the dispatch function - routes <- mapM (buildRoute runHandler dispatcher fixHandler) ress - - -- The dispatch function itself - toDispatch <- [|D.toDispatch|] - 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] - - -- For each resource that dispatches based on methods, build up a map for handling the dispatching. - methodMaps <- catMaybes <$> mapM (buildMethodMap fixHandler) 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) - |] - 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 - -> FlatResource a - -> Q (Maybe Dec) -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 - pack' <- [|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] -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 - -- 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 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 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 runHandler dispatcher fixHandler 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 :: 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 parents name resDisp ys = do - master <- newName "master" - sub <- newName "sub" - toMaster <- newName "toMaster" - app404 <- newName "_app404" - handler405 <- newName "_handler405" - method <- newName "_method" - - let pat = map VarP [master, sub, toMaster, app404, handler405, method] - - -- Create the route - let route = routeFromDynamics parents name ys - - exp <- - case resDisp of - Methods _ ms -> do - handler <- newName "handler" - - -- Run the whole thing - runner <- [|$(runHandler) - $(return $ VarE handler) - $(return $ VarE master) - $(return $ VarE sub) - (Just $(return route)) - $(return $ VarE toMaster)|] - - let myLet handlerExp = - LetE [FunD handler [Clause [] (NormalB handlerExp) []]] runner - - 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 - else do - -- Individual methods - mf <- [|Map.lookup $(return $ VarE 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 - 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) - $(return sub2) - ($(return $ VarE toMaster) . $(return route)) - $(return $ VarE app404) - ($(return $ VarE handler405) . $(return route)) - $(return $ VarE method) - $(return $ VarE xrest) - |] - - return $ LamE pat exp - --- | 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/TH/Types.hs b/Yesod/Routes/TH/Types.hs deleted file mode 100644 index 52cd446..0000000 --- a/Yesod/Routes/TH/Types.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -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 - , resourcePieces :: [(CheckOverlap, Piece typ)] - , resourceDispatch :: Dispatch typ - } - 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) - -instance Lift t => Lift (Resource t) where - lift (Resource a b c) = [|Resource $(lift a) $(lift b) $(lift c)|] - -data Piece typ = Static String | Dynamic typ - deriving Show - -instance Functor Piece where - fmap _ (Static s) = (Static s) - fmap f (Dynamic t) = Dynamic (f t) - -instance Lift t => Lift (Piece t) where - lift (Static s) = [|Static $(lift s)|] - lift (Dynamic t) = [|Dynamic $(lift t)|] - -data Dispatch typ = - Methods - { methodsMulti :: Maybe typ -- ^ type of the multi piece at the end - , methodsMethods :: [String] -- ^ supported request methods - } - | Subsite - { subsiteType :: typ - , subsiteFunc :: String - } - deriving Show - -instance Functor Dispatch where - fmap f (Methods a b) = Methods (fmap f a) b - fmap f (Subsite a b) = Subsite (f a) b - -instance Lift t => Lift (Dispatch t) where - lift (Methods Nothing b) = [|Methods Nothing $(lift b)|] - lift (Methods (Just t) b) = [|Methods (Just $(lift t)) $(lift b)|] - lift (Subsite t b) = [|Subsite $(lift t) $(lift b)|] - -resourceMulti :: Resource typ -> Maybe typ -resourceMulti Resource { resourceDispatch = Methods (Just t) _ } = Just t -resourceMulti _ = Nothing diff --git a/yesod-routes.cabal b/yesod-routes.cabal index eb367b3..0984dfe 100644 --- a/yesod-routes.cabal +++ b/yesod-routes.cabal @@ -23,29 +23,7 @@ library , path-pieces >= 0.1 && < 0.2 exposed-modules: Yesod.Routes.Dispatch - Yesod.Routes.TH Yesod.Routes.Class - Yesod.Routes.Parse - Yesod.Routes.Overlap - other-modules: Yesod.Routes.TH.Dispatch - Yesod.Routes.TH.RenderRoute - Yesod.Routes.TH.Types - ghc-options: -Wall - -test-suite runtests - 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 >= 1.3 - , containers - , template-haskell - , path-pieces ghc-options: -Wall source-repository head -- 1.7.10.4