module Control.Monad.Trans.Time
( MonadTime (..)
, MonadTimeFormat (..)
, TimeT ()
, runTimeT
, TimeCacheT ()
, runTimeCacheT
, runTimeCacheTWithGetter
, askTimeGetter
)
where
import Control.Arrow ((&&&))
import Control.AutoUpdate
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (MonadTrans)
import Control.Monad.Trans.Reader
import Data.Text (Text, pack)
import Data.Time.Cache
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Format (TimeLocale, formatTime)
import Data.Time.Units (TimeUnit (toMicroseconds))
class Monad m => MonadTime m where
askTime :: m UTCTime
class MonadTime m => MonadTimeFormat m where
askFormattedTime :: m Text
askTimeAndFormat :: m (UTCTime, Text)
askTimeAndFormat = (,) <$> askTime <*> askFormattedTime
newtype TimeT m a = TimeT
{ unTimeT :: ReaderT (TimeLocale, String) m a
}
deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans)
runTimeT :: TimeT m a -> TimeLocale -> String -> m a
runTimeT act locale format = runReaderT (unTimeT act) (locale, format)
instance MonadIO m => MonadTime (TimeT m) where
askTime = liftIO getCurrentTime
instance MonadIO m => MonadTimeFormat (TimeT m) where
askFormattedTime = do
(locale, format) <- TimeT ask
pack . formatTime locale format <$> askTime
askTimeAndFormat = do
(locale, format) <- TimeT ask
(id &&& pack . formatTime locale format) <$> askTime
newtype TimeCacheT m a = TimeCacheT
{ unTimeCacheT :: ReaderT (IO (UTCTime, Text)) m a
}
deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans)
instance MonadIO m => MonadTime (TimeCacheT m) where
askTime = fst <$> askTimeAndFormat
instance MonadIO m => MonadTimeFormat (TimeCacheT m) where
askFormattedTime = snd <$> askTimeAndFormat
askTimeAndFormat = do
get <- TimeCacheT ask
liftIO get
runTimeCacheT
:: (TimeUnit t, MonadIO m)
=> TimeCacheT m a
-> t
-> TimeLocale
-> String
-> m a
runTimeCacheT act interval locale format = do
getter <- liftIO $ mkTimeGetter interval locale format
runTimeCacheTWithGetter act getter
runTimeCacheTWithGetter
:: TimeCacheT m a
-> TimeGetter
-> m a
runTimeCacheTWithGetter act getter = runReaderT (unTimeCacheT act) getter
askTimeGetter :: Monad m => TimeCacheT m TimeGetter
askTimeGetter = TimeCacheT ask