diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs --- a/Yesod/Dispatch.hs +++ b/Yesod/Dispatch.hs @@ -17,6 +17,7 @@ , mkYesodSubData , mkYesodDispatch , mkYesodSubDispatch + , mkDispatchInstance -- ** Path pieces , PathPiece (..) , PathMultiPiece (..) @@ -35,6 +36,7 @@ import Yesod.Widget (GWidget) import Web.PathPieces +import Language.Haskell.TH import Language.Haskell.TH.Syntax import qualified Network.Wai as W @@ -108,50 +110,58 @@ mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True where (name':rest) = words name -mkYesodGeneral :: String -- ^ foundation type - -> [String] - -> Cxt -- ^ classes - -> Bool -- ^ is subsite? +mkYesodGeneral :: String -- ^ foundation type + -> [String] -- ^ arguments for the type + -> Cxt -- ^ the type constraints + -> Bool -- ^ it this a subsite -> [ResourceTree String] - -> Q ([Dec], [Dec]) + -> Q([Dec],[Dec]) mkYesodGeneral name args clazzes isSub resS = do - let args' = map mkName args - arg = foldl AppT (ConT name') $ map VarT args' - let res = map (fmap parseType) resS - renderRouteDec <- mkRenderRouteInstance arg res - - let logger = mkName "logger" - Clause pat body decs <- mkDispatchClause - [|yesodRunner $(return $ VarE logger)|] - [|yesodDispatch $(return $ VarE logger)|] - [|fmap chooseRep|] - res - let disp = Clause (VarP logger : pat) body decs - let master = mkName "master" - let ctx = if isSub - then ClassP (mkName "Yesod") [VarT master] : clazzes - else [] - let ytyp = if isSub - then ConT ''YesodDispatch `AppT` arg `AppT` VarT master - else ConT ''YesodDispatch `AppT` arg `AppT` arg - let yesodDispatch' = - InstanceD ctx ytyp [FunD (mkName "yesodDispatch") [disp]] - - return (renderRouteDec ++ masterTypSyns, [yesodDispatch']) - where - name' = mkName name - masterTypSyns - | isSub = [] - | otherwise = - [ TySynD - (mkName "Handler") - [] - (ConT ''GHandler `AppT` ConT name' `AppT` ConT name') - , TySynD - (mkName "Widget") - [] - (ConT ''GWidget `AppT` ConT name' `AppT` ConT name' `AppT` TupleT 0) - ] + subsite <- sub + masterTypeSyns <- if isSub then return [] + else sequence [handler, widget] + renderRouteDec <- mkRenderRouteInstance subsite res + dispatchDec <- mkDispatchInstance context sub master res + return (renderRouteDec ++ masterTypeSyns, dispatchDec) + where sub = foldl appT subCons subArgs + master = if isSub then (varT $ mkName "master") else sub + context = if isSub then cxt $ yesod : map return clazzes + else return [] + yesod = classP ''Yesod [master] + handler = tySynD (mkName "Handler") [] [t| GHandler $master $master |] + widget = tySynD (mkName "Widget") [] [t| GWidget $master $master () |] + res = map (fmap parseType) resS + subCons = conT $ mkName name + subArgs = map (varT. mkName) args + +-- | 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 :: CxtQ -- ^ The context + -> TypeQ -- ^ The subsite type + -> TypeQ -- ^ The master site type + -> [ResourceTree a] -- ^ The resource + -> DecsQ +mkDispatchInstance context sub master res = do + logger <- newName "logger" + let loggerE = varE logger + loggerP = VarP logger + yDispatch = conT ''YesodDispatch `appT` sub `appT` master + thisDispatch = do + Clause pat body decs <- mkDispatchClause + [|yesodRunner $loggerE |] + [|yesodDispatch $loggerE |] + [|fmap chooseRep|] + res + return $ FunD 'yesodDispatch + [ Clause (loggerP:pat) + body + decs + ] + in sequence [instanceD context yDispatch [thisDispatch]] + -- | Convert the given argument into a WAI application, executable with any WAI -- handler. This is the same as 'toWaiAppPlain', except it includes two diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs --- a/Yesod/Handler.hs +++ b/Yesod/Handler.hs @@ -1034,6 +1034,14 @@ liftIO = GHandler . const . lift instance MonadBase IO (GHandler sub master) where liftBase = GHandler . const . lift +-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s +-- @fork@ function is incompatible with the underlying @ResourceT@ system. +-- Instead, if you must fork a separate thread, you should use +-- @resourceForkIO@. +-- +-- Using fork usually leads to an exception that says +-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed +-- after cleanup. Please contact the maintainers.\" instance MonadBaseControl IO (GHandler sub master) where data StM (GHandler sub master) a = StH (StM (ResourceT IO) a) liftBaseWith f = GHandler $ \reader -> diff --git a/test/YesodCoreTest/Cache.hs b/test/YesodCoreTest/Cache.hs --- a/test/YesodCoreTest/Cache.hs +++ b/test/YesodCoreTest/Cache.hs @@ -4,7 +4,6 @@ module YesodCoreTest.Cache (cacheTest, Widget) where import Test.Hspec -import Test.Hspec.HUnit() import Network.Wai import Network.Wai.Test diff --git a/test/YesodCoreTest/CleanPath.hs b/test/YesodCoreTest/CleanPath.hs --- a/test/YesodCoreTest/CleanPath.hs +++ b/test/YesodCoreTest/CleanPath.hs @@ -4,7 +4,6 @@ module YesodCoreTest.CleanPath (cleanPathTest, Widget) where import Test.Hspec -import Test.Hspec.HUnit() import Yesod.Core hiding (Request) diff --git a/test/YesodCoreTest/ErrorHandling.hs b/test/YesodCoreTest/ErrorHandling.hs --- a/test/YesodCoreTest/ErrorHandling.hs +++ b/test/YesodCoreTest/ErrorHandling.hs @@ -6,7 +6,6 @@ ) where import Yesod.Core import Test.Hspec -import Test.Hspec.HUnit() import Network.Wai import Network.Wai.Test import Text.Hamlet (hamlet) diff --git a/test/YesodCoreTest/Exceptions.hs b/test/YesodCoreTest/Exceptions.hs --- a/test/YesodCoreTest/Exceptions.hs +++ b/test/YesodCoreTest/Exceptions.hs @@ -4,7 +4,6 @@ module YesodCoreTest.Exceptions (exceptionsTest, Widget) where import Test.Hspec -import Test.Hspec.HUnit () import Yesod.Core hiding (Request) import Network.Wai diff --git a/test/YesodCoreTest/JsLoader.hs b/test/YesodCoreTest/JsLoader.hs --- a/test/YesodCoreTest/JsLoader.hs +++ b/test/YesodCoreTest/JsLoader.hs @@ -7,7 +7,6 @@ import YesodCoreTest.JsLoaderSites.Bottom (B(..)) import Test.Hspec -import Test.Hspec.HUnit () import Yesod.Core hiding (Request) import Network.Wai.Test diff --git a/test/YesodCoreTest/Links.hs b/test/YesodCoreTest/Links.hs --- a/test/YesodCoreTest/Links.hs +++ b/test/YesodCoreTest/Links.hs @@ -4,7 +4,6 @@ module YesodCoreTest.Links (linksTest, Widget) where import Test.Hspec -import Test.Hspec.HUnit () import Yesod.Core hiding (Request) import Text.Hamlet diff --git a/test/YesodCoreTest/Media.hs b/test/YesodCoreTest/Media.hs --- a/test/YesodCoreTest/Media.hs +++ b/test/YesodCoreTest/Media.hs @@ -5,7 +5,6 @@ module YesodCoreTest.Media (mediaTest, Widget) where import Test.Hspec -import Test.Hspec.HUnit () import Yesod.Core hiding (Request) import Network.Wai import Network.Wai.Test diff --git a/test/YesodCoreTest/NoOverloadedStrings.hs b/test/YesodCoreTest/NoOverloadedStrings.hs --- a/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/test/YesodCoreTest/NoOverloadedStrings.hs @@ -3,7 +3,6 @@ module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where import Test.Hspec -import Test.Hspec.HUnit () import Yesod.Core hiding (Request) import Network.Wai.Test diff --git a/test/YesodCoreTest/Widget.hs b/test/YesodCoreTest/Widget.hs --- a/test/YesodCoreTest/Widget.hs +++ b/test/YesodCoreTest/Widget.hs @@ -4,7 +4,6 @@ module YesodCoreTest.Widget (widgetTest) where import Test.Hspec -import Test.Hspec.HUnit () import Yesod.Core hiding (Request) import Text.Julius diff --git a/test/YesodCoreTest/YesodTest.hs b/test/YesodCoreTest/YesodTest.hs --- a/test/YesodCoreTest/YesodTest.hs +++ b/test/YesodCoreTest/YesodTest.hs @@ -13,7 +13,6 @@ import Network.Wai.Test import Network.Wai import Test.Hspec -import Test.Hspec.HUnit() yesod :: (YesodDispatch y y, Yesod y) => y -> Session a -> IO a yesod app f = toWaiApp app >>= runSession f diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.1.3.1 +version: 1.1.4 license: MIT license-file: LICENSE author: Michael Snoyman