MonadUnliftIO instances

This commit is contained in:
Michael Snoyman 2017-12-12 12:46:49 +02:00
parent 5c8b1b542a
commit 1c2914eded
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
3 changed files with 16 additions and 0 deletions

View File

@ -13,3 +13,5 @@ packages:
- ./yesod - ./yesod
- ./yesod-eventsource - ./yesod-eventsource
- ./yesod-websockets - ./yesod-websockets
extra-deps:
- unliftio-core-0.1.0.0

View File

@ -66,6 +66,7 @@ import Data.Conduit.Lazy (MonadActive, monadActive)
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
import Control.Monad.Logger (MonadLoggerIO (..)) import Control.Monad.Logger (MonadLoggerIO (..))
import Data.Semigroup (Semigroup) import Data.Semigroup (Semigroup)
import Control.Monad.IO.Unlift (MonadUnliftIO (..), UnliftIO (..), withUnliftIO)
-- Sessions -- Sessions
type SessionMap = Map Text ByteString type SessionMap = Map Text ByteString
@ -424,6 +425,12 @@ instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
liftBaseWith $ \runInBase -> liftBaseWith $ \runInBase ->
f $ runInBase . (\(WidgetT w) -> w ref reader') f $ runInBase . (\(WidgetT w) -> w ref reader')
restoreM = WidgetT . const . const . restoreM restoreM = WidgetT . const . const . restoreM
-- | @since 1.4.38
instance MonadUnliftIO m => MonadUnliftIO (WidgetT site m) where
{-# INLINE askUnliftIO #-}
askUnliftIO = WidgetT $ \ref r ->
withUnliftIO $ \u ->
return (UnliftIO (\(WidgetT w) -> unliftIO u $ w ref r))
instance Monad m => MonadReader site (WidgetT site m) where instance Monad m => MonadReader site (WidgetT site m) where
ask = WidgetT $ \_ hd -> return (rheSite $ handlerEnv hd) ask = WidgetT $ \_ hd -> return (rheSite $ handlerEnv hd)
local f (WidgetT g) = WidgetT $ \ref hd -> g ref hd local f (WidgetT g) = WidgetT $ \ref hd -> g ref hd
@ -511,6 +518,12 @@ instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
liftBaseWith $ \runInBase -> liftBaseWith $ \runInBase ->
f $ runInBase . (\(HandlerT r) -> r reader') f $ runInBase . (\(HandlerT r) -> r reader')
restoreM = HandlerT . const . restoreM restoreM = HandlerT . const . restoreM
-- | @since 1.4.38
instance MonadUnliftIO m => MonadUnliftIO (HandlerT site m) where
{-# INLINE askUnliftIO #-}
askUnliftIO = HandlerT $ \r ->
withUnliftIO $ \u ->
return (UnliftIO (unliftIO u . flip unHandlerT r))
instance MonadThrow m => MonadThrow (HandlerT site m) where instance MonadThrow m => MonadThrow (HandlerT site m) where
throwM = lift . monadThrow throwM = lift . monadThrow

View File

@ -70,6 +70,7 @@ library
, auto-update , auto-update
, semigroups , semigroups
, byteable , byteable
, unliftio-core
exposed-modules: Yesod.Core exposed-modules: Yesod.Core
Yesod.Core.Content Yesod.Core.Content