diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 93eb9418..b0ef6e15 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -86,8 +86,8 @@ mkYesodSub name clazzes = mkYesodData :: String -> [ResourceTree String] -> Q [Dec] mkYesodData name res = mkYesodDataGeneral name [] False res -mkYesodSubData :: String -> Cxt -> [ResourceTree String] -> Q [Dec] -mkYesodSubData name clazzes res = mkYesodDataGeneral name clazzes True res +mkYesodSubData :: String -> [ResourceTree String] -> Q [Dec] +mkYesodSubData name res = mkYesodDataGeneral name [] True res mkYesodDataGeneral :: String -> Cxt -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral name clazzes isSub res = do @@ -104,10 +104,6 @@ mkYesodDataGeneral name clazzes isSub res = do mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] mkYesodDispatch name = fmap snd . mkYesodGeneral name [] [] False -mkYesodSubDispatch :: String -> Cxt -> [ResourceTree String] -> Q [Dec] -mkYesodSubDispatch name clazzes = fmap snd . mkYesodGeneral name' rest clazzes True - where (name':rest) = words name - mkYesodGeneral :: String -- ^ foundation type -> [String] -- ^ arguments for the type -> Cxt -- ^ the type constraints @@ -122,7 +118,7 @@ mkYesodGeneral name args clazzes isSub resS = do dispatchDec <- mkDispatchInstance context (if isSub then Just sub else Nothing) master res return (renderRouteDec ++ masterTypeSyns, dispatchDec) where sub = foldl appT subCons subArgs - master = if isSub then (varT $ mkName "master") else sub + master = if isSub then (varT $ mkName "m") else sub context = if isSub then cxt $ yesod : map return clazzes else return [] yesod = classP ''HandlerReader [master] @@ -142,7 +138,7 @@ mkDispatchInstance :: CxtQ -- ^ The context -> TypeQ -- ^ The master site type -> [ResourceTree a] -- ^ The resource -> DecsQ -mkDispatchInstance context Nothing master res = do +mkDispatchInstance context _sub master res = do let yDispatch = conT ''YesodDispatch `appT` master `appT` master thisDispatch = do clause' <- mkDispatchClause MkDispatchSettings @@ -156,8 +152,10 @@ mkDispatchInstance context Nothing master res = do } res return $ FunD 'yesodDispatch [clause'] in sequence [instanceD context yDispatch [thisDispatch]] -mkDispatchInstance context (Just sub) master res = do - yDispatch <- conT ''YesodSubDispatch `appT` sub `appT` master + + +mkYesodSubDispatch :: [ResourceTree String] -> Q Exp +mkYesodSubDispatch res = do parentRunner <- newName "parentRunner" getSub <- newName "getSub" toMaster <- newName "toMaster" @@ -177,7 +175,6 @@ mkDispatchInstance context (Just sub) master res = do , mds405 = [|badMethod >> return ()|] } res inner <- newName "inner" - err <- [|error "FIXME"|] let innerFun = FunD inner [clause'] runnerFun = FunD runner [ Clause @@ -189,14 +186,14 @@ mkDispatchInstance context (Just sub) master res = do ) [] ] - context' <- context - let fun = FunD 'yesodSubDispatch + helper <- newName "helper" + let fun = FunD helper [ Clause [VarP parentRunner, VarP getSub, VarP toMaster] (NormalB $ VarE inner) [innerFun, runnerFun] ] - return [InstanceD context' yDispatch [fun]] + return $ LetE [fun] (VarE helper) -- | 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-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index 84549fa5..e94da292 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -22,6 +22,7 @@ module Yesod.Core.Handler ( -- * Handler monad GHandler + , HandlerT -- ** Read information from handler , getYesod , getYesodSub @@ -169,6 +170,7 @@ import Data.Maybe (listToMaybe) import Data.Typeable (Typeable, typeOf) import Yesod.Core.Class.Handler import Yesod.Core.Types +import Yesod.Core.Types.Orphan () import Yesod.Routes.Class (Route) get :: HandlerState m => m GHState diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index eae78512..f7c29094 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -14,6 +14,7 @@ import Control.Exception (Exception, throwIO) import Control.Failure (Failure (..)) import Control.Monad (liftM) import Control.Monad.Trans.Class (MonadTrans) +import qualified Control.Monad.Trans.Class as Trans import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (LogLevel, LogSource, @@ -202,7 +203,6 @@ newtype HandlerT sub m a = HandlerT { unHandlerT :: HandlerData sub sub -> m a } -instance MonadTrans (HandlerT sub) instance Monad m => Monad (HandlerT sub m) where return = HandlerT . const . return HandlerT f >>= g = HandlerT $ \hd -> f hd >>= \x -> unHandlerT (g x) hd diff --git a/yesod-core/Yesod/Core/Types/Orphan.hs b/yesod-core/Yesod/Core/Types/Orphan.hs new file mode 100644 index 00000000..25f8fc03 --- /dev/null +++ b/yesod-core/Yesod/Core/Types/Orphan.hs @@ -0,0 +1,7 @@ +module Yesod.Core.Types.Orphan where + +import Yesod.Core.Types +import Control.Monad.Trans.Class + +instance MonadTrans (HandlerT sub) where + lift = HandlerT . const diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index 244276a2..798aa09b 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs @@ -3,6 +3,7 @@ module YesodCoreTest.NoOverloadedStrings (noOverloadedTest, Widget) where import Test.Hspec +import YesodCoreTest.NoOverloadedStringsSub import Yesod.Core import Network.Wai @@ -11,18 +12,18 @@ import Data.Monoid (mempty) import qualified Data.Text as T import qualified Data.ByteString.Lazy.Char8 as L8 -data Subsite = Subsite - getSubsite :: a -> Subsite getSubsite = const Subsite -mkYesodSub "Subsite" [] [parseRoutes| -/bar BarR GET -|] +instance YesodSubDispatch Subsite (GHandler master master) where + yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite) getBarR :: Monad m => m T.Text getBarR = return $ T.pack "BarR" +getBazR :: Yesod master => HandlerT Subsite (GHandler master master) RepHtml +getBazR = lift $ defaultLayout [whamlet|Used Default Layout|] + data Y = Y mkYesod "Y" [parseRoutes| / RootR GET @@ -54,7 +55,16 @@ case_subsite = runner $ do assertBody (L8.pack "BarR") res assertStatus 200 res +case_deflayout :: IO () +case_deflayout = runner $ do + res <- request defaultRequest + { pathInfo = map T.pack ["subsite", "baz"] + } + assertBodyContains (L8.pack "Used Default Layout") res + assertStatus 200 res + noOverloadedTest :: Spec noOverloadedTest = describe "Test.NoOverloadedStrings" $ do it "sanity" case_sanity it "subsite" case_subsite + it "deflayout" case_deflayout diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index dd44cec1..0f3c6e51 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -106,6 +106,7 @@ library Yesod.Core.Class.Dispatch Yesod.Core.Class.Breadcrumbs Yesod.Core.Types + Yesod.Core.Types.Orphan Paths_yesod_core ghc-options: -Wall