diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +BSD 3-Clause License + +Copyright (c) 2017, TAKAHASHI Yuto +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,135 @@ +time-machine +============ + +[![Build Status](https://travis-ci.org/y-taka-23/time-machine.svg?branch=master)](https://travis-ci.org/y-taka-23/time-machine) +[![Hackage](https://img.shields.io/hackage/v/time-machine.svg)](https://hackage.haskell.org/package/time-machine) + +A library to mock the current time and relevant `IO` functions +by using a type class. +You can get the great command of the current time in UTC, +time zones, and the speed of time. + +```haskell +module Main where + +import Control.Monad.TimeMachine +import Control.Monad.Trans ( liftIO ) + +main :: IO () +main = backTo (the future) $ do + t <- getCurrentTime + liftIO . putStrLn $ "We are at " ++ show t + +-- We are at 1985-10-26 08:24:00.035889 UTC +``` + +As you know, time-dependent `IO` actions are extremely hard to test. +Assume, for example, the following simple action. +It should return `"Good morning"` only in the morning, +thus the results of its unit tests are fatally fragile. + +```haskell +getGreeting :: IO String +getGreeting = do + t <- getCurrentTime + if utctDayTime t <= 12 * 60 * 60 + then return "Good morning" + else return "Hello" +``` + +This library aims to make such actions testable with minimal changes. +Actually what you have to do is just: + +1. Use `MonadTime` type class instead of `IO` +1. Wrap `IO` actions in `liftIO` if necessary + +Here is the testable version of `getGreeting`. +You can see that nothing is changed excepting the signature. + +```haskell +getGreeting :: (MonadTime m) => m String +getGreeting = do + t <- getCurrentTime + if utctDayTime t <= 12 * 60 * 60 + then return "Good morning" + else return "Hello" +``` + +Examples +-------- + +### Mocking the Current Time + +`travelTo` changes the result of `getCurrentTime` and relevant actions. + +Other than pointing the target `UTCTime` explicitly, +you have two ways to determine how to mock the current time. +This library provides a small DSL to construct the destinations of your time travels. + +```haskell +-- By a date-time according to your local time zone +main = travelTo (oct 26 1985 am 1 24) $ do + getCurrentTime >>= (liftIO . print) +``` + +```haskell +-- By a relative date +main = travelTo (3 `days` ago) $ do + getCurrentTime >>= (liftIO . print) +``` + +For more detail, +see the [document](https://hackage.haskell.org/package/time-machine). + +### Mocking Time Zones + +`jumpTo` switch the time zone which is used for calculating the local time. +By this function, you can test time-zone-sensitive actions. + +```haskell +import qualified Data.Time.Zones as TZ + +main = jumpTo "Asia/Shanghai" $ do + t <- getCurrentTime + tz <- loadLocalTZ + liftIO . print $ TZ.timeZoneForUTCTime tz t -- CST +``` + +### Mocking the Speed of Time + +`accelerate` changes the speed of time. +In the following example, time flies 60 times faster than the real. + +```haskell +main = accelerate (x 60) $ do + getCurrentTime >>= (liftIO . print) -- (*) + liftIO . threadDelay $ 1000 * 1000 -- wait a second + getCurrentTime >>= (liftIO . print) -- around a minute after (*) +``` + +Moreover, as a special case of `accelerate`, `halt` stops the time. +That is remarkably useful to fix the point of time during your tests. + +```haskell +main = halt $ do + getCurrentTime >>= (liftIO . print) -- (*) + liftIO . threadDelay $ 1000 * 1000 -- wait a second + getCurrentTime >>= (liftIO . print) -- exactly same as (*) +``` + +Installation +------------ + +The project is managed by Stack, so you can install it simply: + +```console +$ git clone https://github.com/y-taka-23/time-machine.git +$ cd time-machine +$ stack install +``` + +License +------- + +This project is released under the BSD 3-clause license. +For more details, see [LICENSE](./LICENSE) file. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Control/Monad/TimeMachine.hs b/src/Control/Monad/TimeMachine.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/TimeMachine.hs @@ -0,0 +1,7 @@ +module Control.Monad.TimeMachine ( + module Control.Monad.TimeMachine.Engine + , module Control.Monad.TimeMachine.Cockpit + ) where + +import Control.Monad.TimeMachine.Engine +import Control.Monad.TimeMachine.Cockpit diff --git a/src/Control/Monad/TimeMachine/Cockpit.hs b/src/Control/Monad/TimeMachine/Cockpit.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/TimeMachine/Cockpit.hs @@ -0,0 +1,194 @@ +module Control.Monad.TimeMachine.Cockpit ( + -- * Destinations + -- ** Absolute Destinations + the, future + -- ** Zoned Destinations + , Hour, Minute, DayOfMonth, Month, Year + , HalfDay, am, pm + , jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec + -- ** Reletive Destinations + , minutes, hours, days, weeks, months, years + , Direction, later, ago + , tomorrow, yesterday + -- * Acceleration + -- ** Absolute Acceleration + , at + , TimeScaleUnit, secondsPerSec, minutesPerSec, hoursPerSec, daysPerSec + -- ** Relative Acceleration + , x + ) where + +import Control.Monad.TimeMachine.Engine + +import qualified Data.Time as T +import qualified Data.Time.Zones as TZ + +-- | A piese of the DSL to construct 'Absolute' destinations. +the :: T.UTCTime -> Destination +the = Absolute + +-- | The point of time where Marty McFly arrived back from 1955 by DeLorean. +future :: T.UTCTime +future = T.localTimeToUTC zone lt + where + zone = T.TimeZone (-420) True "PDT" + lt = T.LocalTime d tod + d = T.fromGregorian 1985 10 26 + tod = T.TimeOfDay 1 24 00 + +type Minute = Int +type Hour = Int +type DayOfMonth = Int +type Month = Int +type Year = Integer + +mkZonedDestination :: Month -> DayOfMonth -> Year -> HalfDay -> Hour -> Minute + -> Destination +mkZonedDestination month day year hd hour min = Zoned $ T.LocalTime d tod + where + d = T.fromGregorian year month day + tod = T.TimeOfDay h m 0 + h = case hd of + AM -> clip 0 11 hour + PM -> clip 0 11 hour + 12 + m = clip 0 59 min + +clip :: (Ord a) => a -> a -> a -> a +clip lo hi x + | x < lo = lo + | hi < x = hi + | otherwise = x + +-- | A piese of the DSL to construct 'Zoned' destinations. +-- If the arguments are in the invalid ranges like @jan 32 1970 am 12 60@, +-- they will be clipped as @jan 31 1970 am 11 59@. +jan :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +jan = mkZonedDestination 1 + +feb :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +feb = mkZonedDestination 2 + +mar :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +mar = mkZonedDestination 3 + +apr :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +apr = mkZonedDestination 4 + +may :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +may = mkZonedDestination 5 + +jun :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +jun = mkZonedDestination 6 + +jul :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +jul = mkZonedDestination 7 + +aug :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +aug = mkZonedDestination 8 + +sep :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +sep = mkZonedDestination 9 + +oct :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +oct = mkZonedDestination 10 + +nov :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +nov = mkZonedDestination 11 + +dec :: DayOfMonth -> Year -> HalfDay -> Hour -> Minute -> Destination +dec = mkZonedDestination 12 + +-- | A piese of the DSL to construct 'Zoned' destinations. +data HalfDay = AM | PM + deriving ( Eq, Show, Ord, Enum ) + +am :: HalfDay +am = AM + +pm :: HalfDay +pm = PM + +-- | A piese of the DSL to construct 'Relative' destinations, +-- which represents an unit of the interval. +minutes :: Integer -> Direction -> Destination +minutes n Forward = Relative $ Minutes n +minutes n Backward = Relative $ Minutes (-n) + +hours :: Integer -> Direction -> Destination +hours n Forward = Relative $ Hours n +hours n Backward = Relative $ Hours (-n) + +days :: Integer -> Direction -> Destination +days n Forward = Relative $ Days n +days n Backward = Relative $ Days (-n) + +weeks :: Integer -> Direction -> Destination +weeks n Forward = Relative $ Weeks n +weeks n Backward = Relative $ Weeks (-n) + +months :: Integer -> Direction -> Destination +months n Forward = Relative $ Months n +months n Backward = Relative $ Months (-n) + +years :: Integer -> Direction -> Destination +years n Forward = Relative $ Years n +years n Backward = Relative $ Years (-n) + +-- | A piese of the DSL to construct 'Relative' destinations. +-- It represents the direction of a time travel, +-- namely which of going forward or back. +data Direction = Forward | Backward + deriving ( Eq, Show, Enum ) + +later :: Direction +later = Forward + +ago :: Direction +ago = Backward + +-- | An alias of @1 `days` later@. +tomorrow :: Destination +tomorrow = 1 `days` later + +-- | An alias of @1 `days` ago@. +yesterday :: Destination +yesterday = 1 `days` ago + +-- | A piese of the DSL to construct 'Velocity' acceleration. +at :: T.NominalDiffTime -> TimeScaleUnit -> Acceleration +at v unit = Velocity . TimeScale $ v * (normarizeToSecondsPerSec unit) + +-- | A piese of the DSL to construct 'Velocity' acceleration. +-- It represents how long it spends within the real one seconds. +data TimeScaleUnit = + SecondsPerSec + | MinutesPerSec + | HoursPerSec + | DaysPerSec + deriving ( Show, Enum ) + +instance Eq TimeScaleUnit where + x == y = normarizeToSecondsPerSec x == normarizeToSecondsPerSec y + +normarizeToSecondsPerSec :: TimeScaleUnit -> T.NominalDiffTime +normarizeToSecondsPerSec SecondsPerSec = 1 +normarizeToSecondsPerSec MinutesPerSec = 60 +normarizeToSecondsPerSec HoursPerSec = 60 * 60 +normarizeToSecondsPerSec DaysPerSec = 60 * 60 * 24 + +secondsPerSec :: TimeScaleUnit +secondsPerSec = SecondsPerSec + +minutesPerSec :: TimeScaleUnit +minutesPerSec = MinutesPerSec + +hoursPerSec :: TimeScaleUnit +hoursPerSec = HoursPerSec + +daysPerSec :: TimeScaleUnit +daysPerSec = DaysPerSec + +-- | A piese of the DSL to construct 'Factor' acceleration. +-- For example @x 60@ makes the current speed of time x60 faster. +x :: T.NominalDiffTime -> Acceleration +x = Factor . TimeScale diff --git a/src/Control/Monad/TimeMachine/Engine.hs b/src/Control/Monad/TimeMachine/Engine.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/TimeMachine/Engine.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +module Control.Monad.TimeMachine.Engine ( + -- * MonadTime Class + MonadTime(..) + , getTimeZone + , getCurrentTimeZone + , utcToLocalZonedTime + , getZonedTime + , loadLocalTZ + -- * Functions + , departFor + , travelTo + , backTo + , jumpTo + , accelerate + , halt + -- * Configurations + , TimeScale(..) + , Destination(..) + , TimeInterval(..) + , TimeZoneName + , Acceleration(..) + -- * Monad Transformer + , 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 + +-- | A data type to represents the speed of time. +-- It corresponds how many seconds are in the real second, +-- i.e. @TimeScale 1@ is equivalent to the real speed of time. +newtype TimeScale = TimeScale { unTimeScale :: T.NominalDiffTime } + deriving ( Eq, Show, Ord, Num ) + +-- | A class of monads in which you can obrain the mocked current time +-- and relevant information. +class (Monad m) => MonadTime m where + getCurrentTime :: m T.UTCTime -- ^ foo + getCurrentTZ :: m TZ.TZ + getCurrentTimeScale :: m TimeScale + +-- | Returns the mocked time zone at the given point of time. +getTimeZone :: (MonadTime m) => T.UTCTime -> m T.TimeZone +getTimeZone ut = do + tz <- getCurrentTZ + return $ TZ.timeZoneForUTCTime tz ut + +-- | Returns the mocked time zone at the mocked current time. +getCurrentTimeZone :: (MonadTime m) => m T.TimeZone +getCurrentTimeZone = getCurrentTime >>= getTimeZone + +-- | Returns the mocked local time at the given point of time. +utcToLocalZonedTime :: (MonadTime m) => T.UTCTime -> m T.ZonedTime +utcToLocalZonedTime ut = do + tz <- getCurrentTZ + zone <- getTimeZone ut + return $ T.ZonedTime (TZ.utcToLocalTimeTZ tz ut) zone + +-- | Returns the mocked local time at the mocked current time. +getZonedTime :: (MonadTime m) => m T.ZonedTime +getZonedTime = getCurrentTime >>= utcToLocalZonedTime + +-- | An alias of 'getCurrentTZ'. +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 ) + +-- | A monad transformer to stack the 'MonadTime' contexts. +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 + +-- | A data type to represent a point of time for mocking. +data Destination = + None -- ^ Nothing to mock. + | Absolute T.UTCTime -- ^ An absolute point in UTC. + | Zoned T.LocalTime -- ^ A local time in the mocked current time zone. + | Relative TimeInterval -- ^ An interval from the mocked current time. + deriving ( Eq, Show ) + +-- | A data type to represent intervals for constructing a 'Destination'. +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 + +-- | A data type to represent how to change the mocked speed of time. +data Acceleration = + Keep -- ^ Nothing to change. + | Velocity TimeScale -- ^ Sets the speed to the given scale. + | Factor TimeScale -- ^ Sets the speed acccording to the current speed. + deriving ( Eq, Show ) + +-- | Names of time zones, e.g. @"Asia/Tokyo"@ or @"Europe/Paris"@. +type TimeZoneName = String + +-- | Switches the 'MonadTime' contexts. +-- You can specify all of the point of time, the time zone and +-- the setting of speed for mocking at once. +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 + +-- | Switches the mocked current time in the context. +travelTo :: (MonadIO m, MonadTime m) => Destination -> TimeMachineT m a -> m a +travelTo dest = departFor dest "" Keep + +-- | An alias of 'travelTo'. +backTo :: (MonadIO m, MonadTime m) => Destination -> TimeMachineT m a -> m a +backTo = travelTo + +-- | Switches the mocked current time zone in the context. +jumpTo :: (MonadIO m, MonadTime m) => TimeZoneName -> TimeMachineT m a -> m a +jumpTo zoneName = departFor None zoneName Keep + +-- | Changes the mocked speed of time in the context. +accelerate :: (MonadIO m, MonadTime m) + => Acceleration -> TimeMachineT m a -> m a +accelerate acc = departFor None "" acc + +-- | Stops the time to advence in the context. +halt :: (MonadIO m, MonadTime m) => TimeMachineT m a -> m a +halt = accelerate (Velocity 0) diff --git a/test/Control/Monad/TimeMachine/CockpitSpec.hs b/test/Control/Monad/TimeMachine/CockpitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Monad/TimeMachine/CockpitSpec.hs @@ -0,0 +1,52 @@ +module Control.Monad.TimeMachine.CockpitSpec ( spec ) where + +import Test.Hspec +import Test.Hspec.QuickCheck ( prop ) + +import Control.Monad.TimeMachine.Cockpit + +spec :: Spec +spec = do + describe "jan/feb/.../dec" $ do + it "clips too large day, hour and minmute values" $ do + jan 32 1970 am 12 60 `shouldBe` jan 31 1970 am 11 59 + it "clips too small day, hour and minmute values" $ do + jan 0 1970 am (-1) (-1) `shouldBe` jan 1 1970 am 0 0 + + describe "feb" $ do + it "can handle common years" $ do + feb 30 1970 am 0 0 `shouldBe` feb 28 1970 am 0 0 + it "can handle leap years" $ do + feb 30 1972 am 0 0 `shouldBe` feb 29 1972 am 0 0 + it "can handle exceptional common years" $ do + feb 30 1900 am 0 0 `shouldBe` feb 28 1900 am 0 0 + it "can handle exceptional leap years" $ do + feb 30 2000 am 0 0 `shouldBe` feb 29 2000 am 0 0 + + describe "hours" $ do + prop "A hour is equivalent to 60 minutes" $ \n -> do + n `hours` later == (60 * n) `minutes` later + + describe "days" $ do + prop "A day is equivalent to 24 hours" $ \n -> do + n `days` later == (24 * n) `hours` later + + describe "weeks" $ do + prop "A week is equivalent to 7 days" $ \n -> do + n `weeks` later == (7 * n) `days` later + + describe "later/ago" $ do + prop "'-n days later' means 'n days ago'" $ \n -> do + (-n) `days` later == n `days` ago + + describe "minutesPerSec" $ do + it "is x60 faster than secondsPerSec" $ do + at 1 minutesPerSec == at 60 secondsPerSec + + describe "hoursPerSec" $ do + it "is x60 faster than minutesPerSec" $ do + at 1 hoursPerSec == at 60 minutesPerSec + + describe "daysDerSec" $ do + it "is x24 faster than hoursPerSec" $ do + at 1 daysPerSec == at 24 hoursPerSec diff --git a/test/Control/Monad/TimeMachine/EngineSpec.hs b/test/Control/Monad/TimeMachine/EngineSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Monad/TimeMachine/EngineSpec.hs @@ -0,0 +1,104 @@ +module Control.Monad.TimeMachine.EngineSpec ( spec ) where + +import Test.Hspec +import Test.HUnit ( Assertion ) + +import Control.Monad.TimeMachine.Engine + +import Control.Concurrent ( threadDelay ) +import Control.Monad.Trans ( MonadIO, liftIO ) +import qualified Data.Time as T +import qualified Data.Time.Zones as TZ + +spec :: Spec +spec = do + describe "travelTo" $ do + it "switches the current time" $ do + let itinerary = halt $ do + travelTo (Absolute $ fromOrigin 0) $ do + getCurrentTime + itinerary `shouldReturn` (fromOrigin 0) + it "overwrites the time if you have explicit dates" $ do + let itinerary = halt $ do + travelTo (Absolute $ fromOrigin 0) $ do + travelTo (Absolute $ fromOrigin 1) $ do + getCurrentTime + itinerary `shouldReturn` (fromOrigin 1) + it "determines the destination according to the current TZ" $ do + let itinerary = halt $ do + shanghai <- jumpTo "Asia/Shanghai" $ do + travelTo (Zoned localOrigin) $ do + getCurrentTime + tokyo <- jumpTo "Asia/Tokyo" $ do + travelTo (Zoned localOrigin) $ do + getCurrentTime + return $ T.diffUTCTime shanghai tokyo + itinerary `shouldReturn` (1 * 60 * 60) + it "calculates the destination if you have relative dates" $ do + let itinerary = halt $ do + travelTo (Absolute $ fromOrigin 0) $ do + travelTo (Relative $ Days 2) $ do + travelTo (Relative $ Days (-1)) $ do + getCurrentTime + itinerary `shouldReturn` (fromOrigin 1) + + describe "jumpTo" $ do + it "switches the current TZ" $ do + let itinerary = jumpTo "Europe/Paris" $ do + getCurrentTZ + tz <- TZ.loadTZFromDB "Europe/Paris" + itinerary `shouldReturn` tz + it "overwrites the TZ of outer contexts" $ do + let itinerary = jumpTo "Europe/Paris" $ do + jumpTo "Europe/London" $ do + getCurrentTZ + tz <- TZ.loadTZFromDB "Europe/London" + itinerary `shouldReturn` tz + it "inherits the outer TZ if the TZ name is not found" $ do + let itinerary = jumpTo "Europe/Paris" $ do + jumpTo "Not/Found" $ do + getCurrentTZ + tz <- TZ.loadTZFromDB "Europe/Paris" + itinerary `shouldReturn` tz + + describe "accelerate" $ do + it "rescales the speed of time" $ do + let itinerary = accelerate (Velocity 60) $ do + measureSeconds 1 + itinerary `shouldReturnBetweenInMinutes` (1, 2) + it "overwrites the outer scale if you have explicit velocity" $ do + let itinerary = accelerate (Velocity 60) $ do + accelerate (Velocity 120) $ do + measureSeconds 1 + itinerary `shouldReturnBetweenInMinutes` (2, 4) + it "multiplies the scale if you have an acceleration factor" $ do + let itinerary = accelerate (Velocity 60) $ do + accelerate (Factor 4) $ do + measureSeconds 1 + itinerary `shouldReturnBetweenInMinutes` (4, 8) + + describe "halt" $ do + it "stops the time to advance in its context" $ do + let itinerary = halt $ do + measureSeconds 1 + itinerary `shouldReturn` 0 + +fromOrigin :: Integer -> T.UTCTime +fromOrigin n = T.UTCTime (T.ModifiedJulianDay n) 0 + +localOrigin :: T.LocalTime +localOrigin = T.LocalTime (T.fromGregorian 1970 1 1) (T.TimeOfDay 0 0 0) + +measureSeconds :: (MonadIO m, MonadTime m) => Int -> m T.NominalDiffTime +measureSeconds n = do + t0 <- getCurrentTime + liftIO . threadDelay $ 1000 * 1000 * n + t1 <- getCurrentTime + return $ T.diffUTCTime t1 t0 + +shouldReturnBetweenInMinutes :: IO T.NominalDiffTime -> (Int, Int) -> Assertion +shouldReturnBetweenInMinutes action (lo, hi) = + action >>= (`shouldSatisfy` (\d -> loDiff <= d && d <= hiDiff)) + where + loDiff = fromIntegral $ 60 * lo + hiDiff = fromIntegral $ 60 * hi diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/time-machine.cabal b/time-machine.cabal new file mode 100644 --- /dev/null +++ b/time-machine.cabal @@ -0,0 +1,49 @@ +name: time-machine +version: 0.1.0 +synopsis: A library to mock the current time. +description: + A library to mock the current time and relevant IO functions + by using a type class. + You can get the great command of the current time in UTC, + time zones, and the speed of time. +homepage: https://github.com/y-taka-23/time-machine#readme +license: BSD3 +license-file: LICENSE +author: TAKAHASHI Yuto +maintainer: TAKAHASHI Yuto +copyright: Copyright (C) 2017 TAKAHASHI Yuto +category: Control +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Control.Monad.TimeMachine + , Control.Monad.TimeMachine.Engine + , Control.Monad.TimeMachine.Cockpit + build-depends: base >= 4.7 && < 5 + , mtl + , time + , tz + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Control.Monad.TimeMachine.EngineSpec + , Control.Monad.TimeMachine.CockpitSpec + build-depends: base + , hspec + , HUnit + , mtl + , time + , tz + , time-machine + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/y-taka-23/time-machine