diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index d778f937..370956b8 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TupleSections #-} @@ -15,6 +16,20 @@ import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase, ExceptionT (..)) import Control.Monad.Trans.Class (lift) +import Data.Monoid (Monoid) +import Data.Conduit.Internal (Pipe, ConduitM) + +import Control.Monad.Trans.Identity ( IdentityT) +import Control.Monad.Trans.List ( ListT ) +import Control.Monad.Trans.Maybe ( MaybeT ) +import Control.Monad.Trans.Error ( ErrorT, Error) +import Control.Monad.Trans.Reader ( ReaderT ) +import Control.Monad.Trans.State ( StateT ) +import Control.Monad.Trans.Writer ( WriterT ) +import Control.Monad.Trans.RWS ( RWST ) +import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) +import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) +import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) class MonadResource m => MonadHandler m where type HandlerSite m @@ -33,13 +48,45 @@ instance MonadResourceBase m => MonadHandler (WidgetT site m) where liftHandlerT (HandlerT f) = WidgetT $ liftIO . liftM (, mempty) . f . replaceToParent {-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ liftM (, mempty) . f #-} -instance MonadHandler m => MonadHandler (ExceptionT m) where - type HandlerSite (ExceptionT m) = HandlerSite m - liftHandlerT = lift . liftHandlerT --- FIXME add a bunch of transformer instances +#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT +#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT +GO(IdentityT) +GO(ListT) +GO(MaybeT) +GOX(Error e, ErrorT e) +GO(ReaderT r) +GO(StateT s) +GOX(Monoid w, WriterT w) +GOX(Monoid w, RWST r w s) +GOX(Monoid w, Strict.RWST r w s) +GO(Strict.StateT s) +GOX(Monoid w, Strict.WriterT w) +GO(ExceptionT) +GO(Pipe l i o u) +GO(ConduitM i o) +#undef GO +#undef GOX class MonadHandler m => MonadWidget m where liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a instance MonadResourceBase m => MonadWidget (WidgetT site m) where liftWidgetT (WidgetT f) = WidgetT $ liftIO . f . replaceToParent --- FIXME add a bunch of transformer instances + +#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT +#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT +GO(IdentityT) +GO(ListT) +GO(MaybeT) +GOX(Error e, ErrorT e) +GO(ReaderT r) +GO(StateT s) +GOX(Monoid w, WriterT w) +GOX(Monoid w, RWST r w s) +GOX(Monoid w, Strict.RWST r w s) +GO(Strict.StateT s) +GOX(Monoid w, Strict.WriterT w) +GO(ExceptionT) +GO(Pipe l i o u) +GO(ConduitM i o) +#undef GO +#undef GOX diff --git a/yesod-core/Yesod/Core/Content.hs b/yesod-core/Yesod/Core/Content.hs index c697dd31..b7268e00 100644 --- a/yesod-core/Yesod/Core/Content.hs +++ b/yesod-core/Yesod/Core/Content.hs @@ -54,9 +54,6 @@ import Data.Text.Lazy (Text, pack) import qualified Data.Text as T import Control.Monad (liftM) -import qualified Data.Text.Encoding -import qualified Data.Text.Lazy.Encoding - import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString) import Data.Monoid (mempty) diff --git a/yesod-core/test/YesodCoreTest/Json.hs b/yesod-core/test/YesodCoreTest/Json.hs index 1b5b1e97..09050ac7 100644 --- a/yesod-core/test/YesodCoreTest/Json.hs +++ b/yesod-core/test/YesodCoreTest/Json.hs @@ -24,6 +24,7 @@ getHomeR = do Nothing -> invalidArgs ["foo not found"] Just foo -> return $ RepPlain $ toContent (foo :: Text) +getMultiplePiecesR :: Int -> Int -> Handler () getMultiplePiecesR _ _ = return () test :: String diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index ee25da06..7e344f5e 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs @@ -29,8 +29,13 @@ getBinR = do |] lift $ defaultLayout widget +getOnePiecesR :: Monad m => Int -> m () getOnePiecesR _ = return () + +getTwoPiecesR :: Monad m => Int -> Int -> m () getTwoPiecesR _ _ = return () + +getThreePiecesR :: Monad m => Int -> Int -> Int -> m () getThreePiecesR _ _ _ = return () data Y = Y diff --git a/yesod-core/test/YesodCoreTest/Streaming.hs b/yesod-core/test/YesodCoreTest/Streaming.hs index 2206c7a8..fa7d82d8 100644 --- a/yesod-core/test/YesodCoreTest/Streaming.hs +++ b/yesod-core/test/YesodCoreTest/Streaming.hs @@ -4,10 +4,8 @@ module YesodCoreTest.Streaming (specs) where import Yesod.Core import Test.Hspec import Network.Wai.Test -import Data.Conduit import Data.Text (Text) import Data.ByteString (ByteString) -import Blaze.ByteString.Builder (fromByteString) app :: LiteApp app = dispatchTo $ respondSource typeHtml $ do diff --git a/yesod-persistent/Yesod/Persist.hs b/yesod-persistent/Yesod/Persist.hs index 2d427ebe..cafdc59e 100644 --- a/yesod-persistent/Yesod/Persist.hs +++ b/yesod-persistent/Yesod/Persist.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Persist ( YesodPersist (..) , defaultRunDB @@ -150,3 +151,9 @@ getBy404 key = do case mres of Nothing -> lift notFound Just res -> return res + +instance MonadHandler m => MonadHandler (SqlPersist m) where + type HandlerSite (SqlPersist m) = HandlerSite m + liftHandlerT = lift . liftHandlerT +instance MonadWidget m => MonadWidget (SqlPersist m) where + liftWidgetT = lift . liftWidgetT diff --git a/yesod-persistent/test/Yesod/PersistSpec.hs b/yesod-persistent/test/Yesod/PersistSpec.hs index e89734cc..158a9c5c 100644 --- a/yesod-persistent/test/Yesod/PersistSpec.hs +++ b/yesod-persistent/test/Yesod/PersistSpec.hs @@ -10,7 +10,6 @@ import Database.Persist.Store import Data.Conduit import Blaze.ByteString.Builder.Char.Utf8 (fromText) import Yesod.Persist -import qualified Data.Conduit.List as CL import Data.Text (Text) share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist| @@ -39,9 +38,9 @@ getHomeR = do runDB $ do runMigration migrateAll deleteWhere ([] :: [Filter Person]) - insert $ Person "Charlie" - insert $ Person "Alice" - insert $ Person "Bob" + insert_ $ Person "Charlie" + insert_ $ Person "Alice" + insert_ $ Person "Bob" respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder where toBuilder (Entity _ (Person name)) = do