time-machine (empty) → 0.1.0
raw patch · 10 files changed
+798/−0 lines, 10 filesdep +HUnitdep +basedep +hspecsetup-changed
Dependencies added: HUnit, base, hspec, mtl, time, time-machine, tz
Files
- LICENSE +29/−0
- README.md +135/−0
- Setup.hs +2/−0
- src/Control/Monad/TimeMachine.hs +7/−0
- src/Control/Monad/TimeMachine/Cockpit.hs +194/−0
- src/Control/Monad/TimeMachine/Engine.hs +225/−0
- test/Control/Monad/TimeMachine/CockpitSpec.hs +52/−0
- test/Control/Monad/TimeMachine/EngineSpec.hs +104/−0
- test/Spec.hs +1/−0
- time-machine.cabal +49/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,135 @@+time-machine+============++[](https://travis-ci.org/y-taka-23/time-machine)+[](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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Control/Monad/TimeMachine.hs view
@@ -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
+ src/Control/Monad/TimeMachine/Cockpit.hs view
@@ -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
+ src/Control/Monad/TimeMachine/Engine.hs view
@@ -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)
+ test/Control/Monad/TimeMachine/CockpitSpec.hs view
@@ -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
+ test/Control/Monad/TimeMachine/EngineSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ time-machine.cabal view
@@ -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 <ytaka23dev@gmail.com>+maintainer: TAKAHASHI Yuto <ytaka23dev@gmail.com>+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