module Control.Monad.TimeMachine.Engine (
MonadTime(..)
, getTimeZone
, getCurrentTimeZone
, utcToLocalZonedTime
, getZonedTime
, loadLocalTZ
, departFor
, travelTo
, backTo
, jumpTo
, accelerate
, halt
, TimeScale(..)
, Destination(..)
, TimeInterval(..)
, TimeZoneName
, Acceleration(..)
, TimeMachineT
) where
import Control.Exception ( IOException, catch )
import Control.Monad.Reader ( ReaderT, ask, runReaderT )
import Control.Monad.Trans ( MonadIO, liftIO, MonadTrans )
import Data.Maybe ( fromMaybe )
import qualified Data.Time as T
import qualified Data.Time.Zones as TZ
newtype TimeScale = TimeScale { unTimeScale :: T.NominalDiffTime }
deriving ( Eq, Show, Ord, Num )
class (Monad m) => MonadTime m where
getCurrentTime :: m T.UTCTime
getCurrentTZ :: m TZ.TZ
getCurrentTimeScale :: m TimeScale
getTimeZone :: (MonadTime m) => T.UTCTime -> m T.TimeZone
getTimeZone ut = do
tz <- getCurrentTZ
return $ TZ.timeZoneForUTCTime tz ut
getCurrentTimeZone :: (MonadTime m) => m T.TimeZone
getCurrentTimeZone = getCurrentTime >>= getTimeZone
utcToLocalZonedTime :: (MonadTime m) => T.UTCTime -> m T.ZonedTime
utcToLocalZonedTime ut = do
tz <- getCurrentTZ
zone <- getTimeZone ut
return $ T.ZonedTime (TZ.utcToLocalTimeTZ tz ut) zone
getZonedTime :: (MonadTime m) => m T.ZonedTime
getZonedTime = getCurrentTime >>= utcToLocalZonedTime
loadLocalTZ :: (MonadTime m) => m TZ.TZ
loadLocalTZ = getCurrentTZ
instance MonadTime IO where
getCurrentTime = T.getCurrentTime
getCurrentTZ = TZ.loadLocalTZ
getCurrentTimeScale = return $ TimeScale 1
data Spacetime = Spacetime {
stSimulatedOrigin :: T.UTCTime
, stRealOrigin :: T.UTCTime
, stTZ :: TZ.TZ
, stTimeScale :: TimeScale
} deriving ( Eq, Show )
newtype TimeMachineT m a =
TimeMachineT { timeMachineT :: ReaderT Spacetime m a }
deriving instance (Functor m) => Functor (TimeMachineT m)
deriving instance (Applicative m) => Applicative (TimeMachineT m)
deriving instance (Monad m) => Monad (TimeMachineT m)
deriving instance (MonadIO m) => MonadIO (TimeMachineT m)
deriving instance MonadTrans TimeMachineT
instance (MonadIO m) => MonadTime (TimeMachineT m) where
getCurrentTime = TimeMachineT $ do
realCurr <- liftIO T.getCurrentTime
Spacetime simOrigin realOrigin _ scale <- ask
let diff = scaledDiffUTCTime scale realCurr realOrigin
return $ T.addUTCTime diff simOrigin
getCurrentTZ = TimeMachineT $ ask >>= return . stTZ
getCurrentTimeScale = TimeMachineT $ ask >>= return . stTimeScale
scaledDiffUTCTime :: TimeScale -> T.UTCTime -> T.UTCTime -> T.NominalDiffTime
scaledDiffUTCTime scale t1 t0 = (unTimeScale scale) * T.diffUTCTime t1 t0
runTimeMachineT :: TimeMachineT m a -> Spacetime -> m a
runTimeMachineT = runReaderT . timeMachineT
data Destination =
None
| Absolute T.UTCTime
| Zoned T.LocalTime
| Relative TimeInterval
deriving ( Eq, Show )
data TimeInterval =
Minutes Integer
| Hours Integer
| Days Integer
| Weeks Integer
| Months Integer
| Years Integer
deriving ( Show )
instance Eq TimeInterval where
x == y = case (normarizeToMinutes x, normarizeToMinutes y) of
(Minutes n1, Minutes n2) -> n1 == n2
(Months n1, Months n2) -> n1 == n2
(Years n1, Years n2) -> n1 == n2
(_ , _ ) -> False
normarizeToMinutes :: TimeInterval -> TimeInterval
normarizeToMinutes (Hours n) = Minutes $ n * 60
normarizeToMinutes (Days n) = Minutes $ n * 60 * 24
normarizeToMinutes (Weeks n) = Minutes $ n * 60 * 24 * 7
normarizeToMinutes ti = ti
data Acceleration =
Keep
| Velocity TimeScale
| Factor TimeScale
deriving ( Eq, Show )
type TimeZoneName = String
departFor :: (MonadIO m, MonadTime m)
=> Destination -> TimeZoneName -> Acceleration
-> TimeMachineT m a -> m a
departFor dest zoneName acc act = do
realCurr <- liftIO T.getCurrentTime
simCurr <- getCurrentTime
tz <- getCurrentTZ
scale <- getCurrentTimeScale
mTZ <- liftIO $ safeLoadTZFromDB zoneName
let newTZ = fromMaybe tz mTZ
newSim = calcSimulatedOrigin dest newTZ simCurr
newScale = calcTimeScale acc scale
newST = Spacetime newSim realCurr newTZ newScale
runTimeMachineT act newST
safeLoadTZFromDB :: TimeZoneName -> IO (Maybe TZ.TZ)
safeLoadTZFromDB zoneName =
(do
tz <- liftIO $ TZ.loadTZFromDB zoneName
return $ Just tz
) `catch` (\(e :: IOException) -> do
return Nothing
)
calcSimulatedOrigin :: Destination -> TZ.TZ -> T.UTCTime -> T.UTCTime
calcSimulatedOrigin None _ t0 = t0
calcSimulatedOrigin (Absolute t) _ _ = t
calcSimulatedOrigin (Zoned lt) tz _ = TZ.localTimeToUTCTZ tz lt
calcSimulatedOrigin (Relative ti) tz t0 = addTimeInterval ti tz t0
addTimeInterval :: TimeInterval -> TZ.TZ -> T.UTCTime -> T.UTCTime
addTimeInterval (Minutes n) _ = T.addUTCTime $ fromIntegral (60 * n)
addTimeInterval (Hours n) _ = T.addUTCTime $ fromIntegral (3600 * n)
addTimeInterval (Days n) _ = T.addUTCTime $ fromIntegral (86400 * n)
addTimeInterval (Weeks n) _ = T.addUTCTime $ fromIntegral (604800 * n)
addTimeInterval (Months n) tz = calcTargetDay (T.addGregorianMonthsClip n) tz
addTimeInterval (Years n) tz = calcTargetDay (T.addGregorianYearsClip n) tz
calcTargetDay :: (T.Day -> T.Day) -> TZ.TZ -> T.UTCTime -> T.UTCTime
calcTargetDay f tz t0 =
let T.LocalTime d tod = TZ.utcToLocalTimeTZ tz t0
in TZ.localTimeToUTCTZ tz $ T.LocalTime (f d) tod
calcTimeScale :: Acceleration -> TimeScale -> TimeScale
calcTimeScale Keep s0 = s0
calcTimeScale (Velocity v) s0 = v
calcTimeScale (Factor f) s0 = f * s0
travelTo :: (MonadIO m, MonadTime m) => Destination -> TimeMachineT m a -> m a
travelTo dest = departFor dest "" Keep
backTo :: (MonadIO m, MonadTime m) => Destination -> TimeMachineT m a -> m a
backTo = travelTo
jumpTo :: (MonadIO m, MonadTime m) => TimeZoneName -> TimeMachineT m a -> m a
jumpTo zoneName = departFor None zoneName Keep
accelerate :: (MonadIO m, MonadTime m)
=> Acceleration -> TimeMachineT m a -> m a
accelerate acc = departFor None "" acc
halt :: (MonadIO m, MonadTime m) => TimeMachineT m a -> m a
halt = accelerate (Velocity 0)