Code cleanup and transformer instances

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
+#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
-    type HandlerSite (ExceptionT m) = HandlerSite m
+#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT
-    liftHandlerT = lift . liftHandlerT
+GO(IdentityT)
--- FIXME add a bunch of transformer instances
+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

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)
 

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

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

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

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

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 "Charlie"
-        insert $ Person "Alice"
+        insert_ $ Person "Alice"
-        insert $ Person "Bob"
+        insert_ $ Person "Bob"
     respondSourceDB typePlain $ selectSource [] [Asc PersonName] $= awaitForever toBuilder
   where
     toBuilder (Entity _ (Person name)) = do