Time.hs

{- This file is part of time-cache.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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