polysemy-time 0.1.3.2 → 0.1.4.0

raw patch · 9 files changed

+182/−32 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +7/−0
• lib/Polysemy/Time.hs +23/−11
• lib/Polysemy/Time/At.hs +69/−14
• lib/Polysemy/Time/Data/TimeUnit.hs +8/−0
• lib/Polysemy/Time/Debug.hs +3/−3
• lib/Polysemy/Time/Ghc.hs +18/−2
• lib/Polysemy/Time/Loop.hs +49/−0
• polysemy-time.cabal +2/−1
• test/Polysemy/Time/Test/TimeUnitTest.hs +3/−1

@@ -1,3 +1,10 @@+# Unreleased++# 0.1.4.0+* Add `secondsFrac`, a combinator that converts a unit into a fractional number of seconds.+* Add combinators for repeatedly running an action with a sleep interval+* Add interpreters that remain at a fixed instant+ # 0.1.3.0 * Added `measure`, a combinator that returns the time span an action takes. 

@@ -10,11 +10,16 @@   -- * Interpreters   interpretTimeGhc,   interpretTimeGhcAt,+  interpretTimeGhcConstant,+  interpretTimeGhcConstantNow,   -- * Data types   module Polysemy.Time.Data.TimeUnit,   module Polysemy.Time.Calendar,   -- * Combinators   measure,+  while,+  loop,+  loop_, ) where  import Polysemy.Time.Calendar (@@ -29,20 +34,27 @@   ) import Polysemy.Time.Data.Time (Time (..), adjust, now, setDate, setTime, sleep, today) import Polysemy.Time.Data.TimeUnit (-  Days (Days),-  Hours (Hours),-  MicroSeconds (MicroSeconds),-  MilliSeconds (MilliSeconds),-  Minutes (Minutes),-  Months (Months),-  NanoSeconds (NanoSeconds),-  Seconds (Seconds),+  Days (..),+  Hours (..),+  MicroSeconds (..),+  MilliSeconds (..),+  Minutes (..),+  Months (..),+  NanoSeconds (..),+  Seconds (..),   TimeUnit,-  Weeks (Weeks),-  Years (Years),+  Weeks (..),+  Years (..),   convert,   )-import Polysemy.Time.Ghc (GhcTime, interpretTimeGhc, interpretTimeGhcAt)+import Polysemy.Time.Ghc (+  GhcTime,+  interpretTimeGhc,+  interpretTimeGhcAt,+  interpretTimeGhcConstant,+  interpretTimeGhcConstantNow,+  )+import Polysemy.Time.Loop (loop, loop_, while) import Polysemy.Time.Measure (measure) import Polysemy.Time.Orphans () 

@@ -1,7 +1,7 @@ module Polysemy.Time.At where  import Polysemy (intercept)-import Torsor (Torsor(add), difference)+import Torsor (Torsor (add), difference)  import Polysemy.Time.Calendar (HasDate, date, dateToTime) import qualified Polysemy.Time.Data.Time as Time@@ -13,24 +13,24 @@ dateCurrentRelative ::   ∀ diff t d r .   Torsor t diff =>-  Members [Time t d, Embed IO, State (t, t)] r =>+  Members [Time t d, AtomicState (t, t)] r =>   Sem r t dateCurrentRelative = do-  (startAt, startActual) <- get @(t, t)+  (startAt, startActual) <- atomicGet @(t, t)   (`add` startAt) . (`difference` startActual) <$> Time.now @t @d  -- |Given real and adjusted start time, change all calls to 'Time.Now' and 'Time.Today' to be relative to that start -- time. -- This needs to be interpreted with a vanilla interpreter for 'Time' once more.-interpretTimeAtWithStart ::+interceptTimeAtWithStart ::   ∀ diff t d r a .   Torsor t diff =>   TimeUnit diff =>   HasDate t d =>-  Members [Time t d, Embed IO, State (t, t)] r =>+  Members [Time t d, AtomicState (t, t)] r =>   Sem r a ->   Sem r a-interpretTimeAtWithStart =+interceptTimeAtWithStart =   intercept @(Time t d) \case     Time.Now ->       dateCurrentRelative @diff @t @d@@ -40,16 +40,16 @@       Time.sleep @t @d t     Time.SetTime startAt -> do       startActual <- Time.now @t @d-      put @(t, t) (startAt, startActual)+      atomicPut @(t, t) (startAt, startActual)     Time.Adjust diff -> do-      modify' @(t, t) \ (old, actual) -> (addTimeUnit diff old, actual)+      atomicModify' @(t, t) \ (old, actual) -> (addTimeUnit diff old, actual)     Time.SetDate startAt -> do       startActual <- Time.now @t @d-      put @(t, t) (dateToTime startAt, startActual)-{-# INLINE interpretTimeAtWithStart #-}+      atomicPut @(t, t) (dateToTime startAt, startActual)+{-# inline interceptTimeAtWithStart #-}  -- |Interpret 'Time' so that the time when the program starts is @startAt@.-interpretTimeAt ::+interceptTimeAt ::   ∀ (diff :: Type) t d r a .   TimeUnit diff =>   Torsor t diff =>@@ -58,7 +58,62 @@   t ->   Sem r a ->   Sem r a-interpretTimeAt startAt sem = do+interceptTimeAt startAt sem = do   startActual <- Time.now @t @d-  evalState (startAt, startActual) . interpretTimeAtWithStart @diff @t @d . raise $ sem-{-# INLINE interpretTimeAt #-}+  tv <- newTVarIO (startAt, startActual)+  runAtomicStateTVar tv . interceptTimeAtWithStart @diff @t @d . raise $ sem+{-# inline interceptTimeAt #-}++-- |Change all calls to 'Time.Now' and 'Time.Today' to return the given start time.+-- This needs to be interpreted with a vanilla interpreter for 'Time' once more.+interceptTimeConstantState ::+  ∀ t d r a .+  HasDate t d =>+  Members [Time t d, AtomicState t] r =>+  Sem r a ->+  Sem r a+interceptTimeConstantState =+  intercept @(Time t d) \case+    Time.Now ->+      atomicGet+    Time.Today ->+      atomicGets @t date+    Time.Sleep t ->+      Time.sleep @t @d t+    Time.SetTime now ->+      atomicPut now+    Time.Adjust diff ->+      atomicModify' @t (addTimeUnit diff)+    Time.SetDate startAt ->+      atomicPut @t (dateToTime startAt)+{-# inline interceptTimeConstantState #-}++-- |Interpret 'Time' so that the time is always @startAt@.+--+-- The time can still be changed with 'Time.setTime', 'Time.adjust' and 'Time.setDate'.+interceptTimeConstant ::+  ∀ t d r a .+  HasDate t d =>+  Members [Time t d, Embed IO] r =>+  t ->+  Sem r a ->+  Sem r a+interceptTimeConstant startAt sem = do+  tv <- newTVarIO startAt+  runAtomicStateTVar tv . interceptTimeConstantState @t . raise $ sem+{-# inline interceptTimeConstant #-}++-- |Interpret 'Time' so that the time is always the time at the start of interpretation.+--+-- The time can still be changed with 'Time.setTime', 'Time.adjust' and 'Time.setDate'.+interceptTimeConstantNow ::+  ∀ t d r a .+  HasDate t d =>+  Members [Time t d, Embed IO] r =>+  Sem r a ->+  Sem r a+interceptTimeConstantNow sem = do+  now <- Time.now @t @d+  tv <- newTVarIO now+  runAtomicStateTVar tv . interceptTimeConstantState @t . raise $ sem+{-# inline interceptTimeConstantNow #-}

@@ -172,6 +172,14 @@ addTimeUnit =   add . convert +-- |Convert a unit into a number of seconds, keeping the subsecond part as fractional digits.+secondsFrac ::+  TimeUnit u =>+  u ->+  Double+secondsFrac u =+  fromIntegral (unNanoSeconds (convert u)) / 1e9+ defaultJson ''Years defaultJson ''Months defaultJson ''Weeks

@@ -79,7 +79,7 @@   a tr msg a =   unsafePerformIO (a <$ debugPrint (srcLoc callStack) msg)-{-# INLINE tr #-}+{-# inline tr #-}  trs ::   Show a =>@@ -88,7 +88,7 @@   a trs a =   unsafePerformIO (a <$ debugPrint (srcLoc callStack) (show a))-{-# INLINE trs #-}+{-# inline trs #-}  trs' ::   Show b =>@@ -98,4 +98,4 @@   a trs' b a =   unsafePerformIO (a <$ debugPrint (srcLoc callStack) (show b))-{-# INLINE trs' #-}+{-# inline trs' #-}

@@ -4,7 +4,7 @@ import Data.Time (Day, NominalDiffTime, UTCTime, utctDay) import Data.Time.Clock.System (getSystemTime, systemToUTCTime) -import Polysemy.Time.At (interpretTimeAt)+import Polysemy.Time.At (interceptTimeAt, interceptTimeConstant, interceptTimeConstantNow) import qualified Polysemy.Time.Data.Time as Time import Polysemy.Time.Data.Time (Time) import Polysemy.Time.Data.TimeUnit (MicroSeconds (MicroSeconds), convert)@@ -45,4 +45,20 @@   UTCTime ->   InterpreterFor GhcTime r interpretTimeGhcAt t =-  interpretTimeGhc . interpretTimeAt @NominalDiffTime t+  interpretTimeGhc . interceptTimeAt @NominalDiffTime t++-- |Interpret 'Time' with the types from 'Data.Time', customizing the current time to be constant.+interpretTimeGhcConstant ::+  Member (Embed IO) r =>+  UTCTime ->+  InterpreterFor GhcTime r+interpretTimeGhcConstant t =+  interpretTimeGhc . interceptTimeConstant t++-- |Interpret 'Time' with the types from 'Data.Time', customizing the current time to be constantly the time at the+-- start of interpretation.+interpretTimeGhcConstantNow ::+  Member (Embed IO) r =>+  InterpreterFor GhcTime r+interpretTimeGhcConstantNow =+  interpretTimeGhc . interceptTimeConstantNow @UTCTime

@@ -0,0 +1,49 @@+module Polysemy.Time.Loop where++import Polysemy.Time.Data.Time (Time)+import Polysemy.Time.Data.TimeUnit (TimeUnit)+import qualified Polysemy.Time.Data.Time as Time++-- |Repeatedly run the @action@, sleeping for @interval@ between executions.+-- Stops when @action@ returns @False@.+while ::+  ∀ t d u r .+  Member (Time t d) r =>+  TimeUnit u =>+  u ->+  Sem r Bool ->+  Sem r ()+while interval action =+  spin+  where+    spin =+      whenM action (Time.sleep @t @d interval *> spin)++-- |Repeatedly run the @action@, sleeping for @interval@ between executions.+-- The result of @action@ is passed back to it for the next run, starting with @initial@.+loop ::+  ∀ t d u a r .+  Member (Time t d) r =>+  TimeUnit u =>+  u ->+  a ->+  (a -> Sem r a) ->+  Sem r ()+loop interval initial action =+  forever (spin initial)+  where+    spin a = do+      new <- action a+      Time.sleep @t @d interval+      spin new++-- |Repeatedly run the @action@, sleeping for @interval@ between executions.+loop_ ::+  ∀ t d u r .+  Member (Time t d) r =>+  TimeUnit u =>+  u ->+  Sem r () ->+  Sem r ()+loop_ interval action =+  forever (action *> Time.sleep @t @d interval)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-time-version:        0.1.3.2+version:        0.1.4.0 synopsis:       Polysemy Effect for Time description:    Please see the readme on Github at <https://github.com/tek/polysemy-time> category:       Time@@ -30,6 +30,7 @@       Polysemy.Time.Debug       Polysemy.Time.Diff       Polysemy.Time.Ghc+      Polysemy.Time.Loop       Polysemy.Time.Measure       Polysemy.Time.Orphans       Polysemy.Time.Prelude

@@ -2,7 +2,7 @@  import Polysemy.Test (UnitTest, assertEq, runTestAuto) -import Polysemy.Time.Data.TimeUnit (MicroSeconds (MicroSeconds), MilliSeconds (MilliSeconds))+import Polysemy.Time.Data.TimeUnit (MicroSeconds (MicroSeconds), MilliSeconds (MilliSeconds), secondsFrac)  test_fractional :: UnitTest test_fractional =@@ -10,3 +10,5 @@     assertEq @_ @IO (MilliSeconds 50) 0.05     assertEq @_ @IO (MicroSeconds 200) 0.0002     assertEq @_ @IO (MilliSeconds 50) (MilliSeconds 100 / MilliSeconds 2)+    assertEq @_ @IO (MilliSeconds 50) (MilliSeconds 100 / 2)+    assertEq @_ @IO 0.05 (secondsFrac (MilliSeconds 50))