Merge pull request #1122 from pseudonom/master

Add hook to apply arbitrary function to all handlers

yesod-core/Yesod/Core/Internal.hs

@@ -5,3 +5,4 @@ module Yesod.Core.Internal
     ) where
 
 import Yesod.Core.Internal.Request as X (randomString, parseWaiRequest)
+import Yesod.Core.Internal.TH as X (mkYesodGeneral)

yesod-core/Yesod/Core/Internal/TH.hs

@@ -32,13 +32,13 @@ import Yesod.Core.Internal.Run
 mkYesod :: String -- ^ name of the argument datatype
         -> [ResourceTree String]
         -> Q [Dec]
-mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False
+mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return
 
 mkYesodWith :: String
             -> [Either String [String]]
             -> [ResourceTree String]
             -> Q [Dec]
-mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False
+mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False return
 
 -- | Sometimes, you will want to declare your routes in one file and define
 -- your handlers elsewhere. For example, this is the only way to break up a
@@ -53,11 +53,11 @@ mkYesodSubData name res = mkYesodDataGeneral name True res
 mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec]
 mkYesodDataGeneral name isSub res = do
     let (name':rest) = words name
-    fmap fst $ mkYesodGeneral name' (fmap Left rest) isSub res
+    fmap fst $ mkYesodGeneral name' (fmap Left rest) isSub return res
 
 -- | See 'mkYesodData'.
 mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
-mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False
+mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return
 
 -- | Get the Handler and Widget type synonyms for the given site.
 masterTypeSyns :: [Name] -> Type -> [Dec]
@@ -71,12 +71,13 @@ masterTypeSyns vs site =
 -- | 'Left' arguments indicate a monomorphic type, a 'Right' argument
 --   indicates a polymorphic type, and provides the list of classes
 --   the type must be instance of.
-mkYesodGeneral :: String                   -- ^ foundation type
-               -> [Either String [String]] -- ^ arguments for the type
-               -> Bool                     -- ^ is this a subsite
+mkYesodGeneral :: String                    -- ^ foundation type
+               -> [Either String [String]]  -- ^ arguments for the type
+               -> Bool                      -- ^ is this a subsite
+               -> (Exp -> Q Exp)            -- ^ unwrap handler
                -> [ResourceTree String]
                -> Q([Dec],[Dec])
-mkYesodGeneral namestr args isSub resS = do
+mkYesodGeneral namestr args isSub f resS = do
     mname <- lookupTypeName namestr
     arity <- case mname of
                Just name -> do
@@ -112,7 +113,7 @@ mkYesodGeneral namestr args isSub resS = do
         res = map (fmap parseType) resS
     renderRouteDec <- mkRenderRouteInstance site res
     routeAttrsDec  <- mkRouteAttrsInstance site res
-    dispatchDec    <- mkDispatchInstance site cxt res
+    dispatchDec    <- mkDispatchInstance site cxt f res
     parse <- mkParseRouteInstance site res
     let rname = mkName $ "resources" ++ namestr
     eres <- lift resS
@@ -129,8 +130,8 @@ mkYesodGeneral namestr args isSub resS = do
             ]
     return (dataDec, dispatchDec)
 
-mkMDS :: Q Exp -> MkDispatchSettings
-mkMDS rh = MkDispatchSettings
+mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh = MkDispatchSettings
     { mdsRunHandler = rh
     , mdsSubDispatcher =
         [|\parentRunner getSub toParent env -> yesodSubDispatch
@@ -147,27 +148,29 @@ mkMDS rh = MkDispatchSettings
     , mds404 = [|notFound >> return ()|]
     , mds405 = [|badMethod >> return ()|]
     , mdsGetHandler = defaultGetHandler
+    , mdsUnwrapper = f
     }
 
 -- | If the generation of @'YesodDispatch'@ instance require finer
 -- control of the types, contexts etc. using this combinator. You will
 -- hardly need this generality. However, in certain situations, like
 -- when writing library/plugin for yesod, this combinator becomes
 -- handy.
-mkDispatchInstance :: Type                -- ^ The master site type
-                   -> Cxt                 -- ^ Context of the instance
-                   -> [ResourceTree a]    -- ^ The resource
+mkDispatchInstance :: Type                      -- ^ The master site type
+                   -> Cxt                       -- ^ Context of the instance
+                   -> (Exp -> Q Exp)            -- ^ Unwrap handler
+                   -> [ResourceTree c]          -- ^ The resource
                    -> DecsQ
-mkDispatchInstance master cxt res = do
-    clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res
+mkDispatchInstance master cxt f res = do
+    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
     let thisDispatch = FunD 'yesodDispatch [clause']
     return [InstanceD cxt yDispatch [thisDispatch]]
   where
     yDispatch = ConT ''YesodDispatch `AppT` master
 
 mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
 mkYesodSubDispatch res = do
-    clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
+    clause' <- mkDispatchClause (mkMDS return [|subHelper . fmap toTypedContent|]) res
     inner <- newName "inner"
     let innerFun = FunD inner [clause']
     helper <- newName "helper"

yesod-core/Yesod/Routes/TH/Dispatch.hs

@@ -16,7 +16,7 @@ import System.Random (randomRIO)
 import Yesod.Routes.TH.Types
 import Data.Char (toLower)
 
-data MkDispatchSettings = MkDispatchSettings
+data MkDispatchSettings b site c = MkDispatchSettings
     { mdsRunHandler :: Q Exp
     , mdsSubDispatcher :: Q Exp
     , mdsGetPathInfo :: Q Exp
@@ -25,6 +25,7 @@ data MkDispatchSettings = MkDispatchSettings
     , mds404 :: Q Exp
     , mds405 :: Q Exp
     , mdsGetHandler :: Maybe String -> String -> Q Exp
+    , mdsUnwrapper :: Exp -> Q Exp
     }
 
 data SDC = SDC
@@ -39,7 +40,7 @@ data SDC = SDC
 -- view patterns.
 --
 -- Since 1.4.0
-mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause
+mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause
 mkDispatchClause MkDispatchSettings {..} resources = do
     suffix <- qRunIO $ randomRIO (1000, 9999 :: Int)
     envName <- newName $ "env" ++ show suffix
@@ -141,7 +142,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do
                         mkRunExp mmethod = do
                             runHandlerE <- mdsRunHandler
                             handlerE' <- mdsGetHandler mmethod name
-                            let handlerE = foldl' AppE handlerE' allDyns
+                            handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns
                             return $ runHandlerE
                                 `AppE` handlerE
                                 `AppE` envExp

yesod-core/Yesod/Routes/TH/ParseRoute.hs

@@ -22,6 +22,7 @@ mkParseRouteInstance typ ress = do
             , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|]
             , mdsSetPathInfo = [|\p (_, q) -> (p, q)|]
             , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|]
+            , mdsUnwrapper = return
             }
         (map removeMethods ress)
     helper <- newName "helper"

yesod-core/test/Hierarchy.hs

@@ -119,6 +119,7 @@ do
         , mds404 = [|pack "404"|]
         , mds405 = [|pack "405"|]
         , mdsGetHandler = defaultGetHandler
+        , mdsUnwrapper = return
         } resources
     return
         $ InstanceD

yesod-core/test/RouteSpec.hs

@@ -92,6 +92,7 @@ do
         , mds404 = [|pack "404"|]
         , mds405 = [|pack "405"|]
         , mdsGetHandler = defaultGetHandler
+        , mdsUnwrapper = return
         } ress
     return
         $ InstanceD