diff options
Diffstat (limited to 'standalone/android/haskell-patches/yesod-routes_1.1.2_0001-remove-TH-and-export-module-used-by-TH-splices.patch')
| -rw-r--r-- | standalone/android/haskell-patches/yesod-routes_1.1.2_0001-remove-TH-and-export-module-used-by-TH-splices.patch | 674 |
1 files changed, 674 insertions, 0 deletions
diff --git a/standalone/android/haskell-patches/yesod-routes_1.1.2_0001-remove-TH-and-export-module-used-by-TH-splices.patch b/standalone/android/haskell-patches/yesod-routes_1.1.2_0001-remove-TH-and-export-module-used-by-TH-splices.patch new file mode 100644 index 000000000..33bcff447 --- /dev/null +++ b/standalone/android/haskell-patches/yesod-routes_1.1.2_0001-remove-TH-and-export-module-used-by-TH-splices.patch @@ -0,0 +1,674 @@ +From 06176b0f3dbbe559490f0971e0db205287793286 Mon Sep 17 00:00:00 2001 +From: Joey Hess <joey@kitenet.net> +Date: Mon, 15 Apr 2013 21:01:12 -0400 +Subject: [PATCH] remove TH and export module used by TH splices + +--- + 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 | 16 --- + yesod-routes.cabal | 21 --- + 6 files changed, 582 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 + +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 +index 52cd446..18208d3 100644 +--- a/Yesod/Routes/TH/Types.hs ++++ b/Yesod/Routes/TH/Types.hs +@@ -29,10 +29,6 @@ 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)] +@@ -45,9 +41,6 @@ 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 + +@@ -55,10 +48,6 @@ 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 +@@ -74,11 +63,6 @@ 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..dc6a12c 100644 +--- a/yesod-routes.cabal ++++ b/yesod-routes.cabal +@@ -23,31 +23,10 @@ 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 + type: git + location: https://github.com/yesodweb/yesod +-- +1.8.2.rc3 + |