From 3db837215af4e430b722e979a877b23f188097b2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 15 Apr 2013 21:02:33 -0400 Subject: yesod-routes stuff for android build --- standalone/android/evilsplicer-headers.hs | 1 + ...e-TH-and-export-module-used-by-TH-splices.patch | 674 +++++++++++++++++++ ...esod-routes-1.1.2_0001-remove-TH-hack-job.patch | 715 --------------------- 3 files changed, 675 insertions(+), 715 deletions(-) create mode 100644 standalone/android/haskell-patches/yesod-routes-1.1.2_0001-remove-TH-and-export-module-used-by-TH-splices.patch delete mode 100644 standalone/android/haskell-patches/yesod-routes-1.1.2_0001-remove-TH-hack-job.patch (limited to 'standalone') diff --git a/standalone/android/evilsplicer-headers.hs b/standalone/android/evilsplicer-headers.hs index 3df99191b..29fe5caa7 100644 --- a/standalone/android/evilsplicer-headers.hs +++ b/standalone/android/evilsplicer-headers.hs @@ -14,6 +14,7 @@ import qualified Text.Css import qualified "blaze-markup" Text.Blaze.Internal import qualified Data.Monoid import qualified Yesod.Widget +import qualified Yesod.Routes.TH.Types {- End EvilSplicer headers. -} 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 +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 + diff --git a/standalone/android/haskell-patches/yesod-routes-1.1.2_0001-remove-TH-hack-job.patch b/standalone/android/haskell-patches/yesod-routes-1.1.2_0001-remove-TH-hack-job.patch deleted file mode 100644 index 1d6538e02..000000000 --- a/standalone/android/haskell-patches/yesod-routes-1.1.2_0001-remove-TH-hack-job.patch +++ /dev/null @@ -1,715 +0,0 @@ -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 - -- cgit v1.2.3