674 lines
26 KiB
Diff
674 lines
26 KiB
Diff
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
|
|
|