polysemy-time 0.4.0.0 → 0.5.0.0

raw patch · 12 files changed

+158/−158 lines, 12 filesdep ~basedep ~incipit-coredep ~polysemy-testPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, incipit-core, polysemy-test

API changes (from Hackage documentation)

Files

• changelog.md +0/−16
• lib/Polysemy/Time.hs +2/−1
• lib/Polysemy/Time/At.hs +38/−6
• lib/Polysemy/Time/Data/TimeUnit.hs +12/−12
• lib/Polysemy/Time/Diff.hs +19/−2
• lib/Polysemy/Time/Interpreter/Ghc.hs +3/−1
• lib/Polysemy/Time/Json.hs +13/−5
• polysemy-time.cabal +26/−15
• readme.md +0/−89
• test/Main.hs +2/−3
• test/Polysemy/Time/Test/GhcTimeTest.hs +40/−5
• test/Polysemy/Time/Test/TimeUnitTest.hs +3/−3

@@ -1,16 +0,0 @@-# 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.--# 0.1.1.0-* Added `Time.Adjust`, an action that takes a time unit and adds it to the custom start time, if available.-* Added `Fractional` instances for sub-second time units that treat literals as seconds.--# 0.1.0.0-* initial release

@@ -31,6 +31,7 @@   loop,   loop_,   diff,+  since, ) where  import Polysemy.Time.Calendar (@@ -57,7 +58,7 @@   Years (..),   convert,   )-import Polysemy.Time.Diff (diff)+import Polysemy.Time.Diff (diff, since) import Polysemy.Time.Effect.Time (Time (..), adjust, now, setDate, setTime, sleep, today) import Polysemy.Time.Interpreter.Ghc (   GhcTime,

@@ -5,7 +5,7 @@ import Torsor (Torsor (add), difference)  import Polysemy.Time.Calendar (HasDate, date, dateToTime)-import Polysemy.Time.Data.TimeUnit (TimeUnit, addTimeUnit)+import Polysemy.Time.Data.TimeUnit (MilliSeconds (MilliSeconds), TimeUnit, addTimeUnit, convert) import qualified Polysemy.Time.Effect.Time as Time import Polysemy.Time.Effect.Time (Time) @@ -43,7 +43,7 @@       startActual <- Time.now @t @d       atomicPut @(t, t) (startAt, startActual)     Time.Adjust diff -> do-      atomicModify' @(t, t) \ (old, actual) -> (addTimeUnit diff old, actual)+      atomicModify' @(t, t) (first (addTimeUnit diff))     Time.SetDate startAt -> do       startActual <- Time.now @t @d       atomicPut @(t, t) (dateToTime startAt, startActual)@@ -65,11 +65,35 @@   runAtomicStateTVar tv . interceptTimeAtWithStart @diff @t @d . raise $ sem {-# inline interceptTimeAt #-} +sleepPoll ::+  ∀ t d diff u r .+  Ord diff =>+  TimeUnit u =>+  TimeUnit diff =>+  Torsor t diff =>+  Members [Time t d, AtomicState t] r =>+  u ->+  t ->+  Sem r ()+sleepPoll duration start =+  spin+  where+    spin = do+      Time.sleep @t @d (MilliSeconds 10)+      unlessM (later <$> atomicGet @t) spin+    later now =+      difference now start >= diff+    diff =+      convert @u @diff duration+ -- |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 .+  ∀ t d diff r a .+  Ord diff =>   HasDate t d =>+  TimeUnit diff =>+  Torsor t diff =>   Members [Time t d, AtomicState t] r =>   Sem r a ->   Sem r a@@ -80,7 +104,7 @@     Time.Today ->       atomicGets @t date     Time.Sleep t ->-      Time.sleep @t @d t+      sleepPoll @t @d t =<< atomicGet     Time.SetTime now ->       atomicPut now     Time.Adjust diff ->@@ -92,9 +116,13 @@ -- |Interpret 'Time' so that the time is always @startAt@. -- -- The time can still be changed with 'Time.setTime', 'Time.adjust' and 'Time.setDate'.+-- Sleeping will only terminate after the time has been advanced by `Time.adjust`. interceptTimeConstant ::-  ∀ t d r a .+  ∀ t d diff r a .+  Ord diff =>   HasDate t d =>+  TimeUnit diff =>+  Torsor t diff =>   Members [Time t d, Embed IO] r =>   t ->   Sem r a ->@@ -107,9 +135,13 @@ -- |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'.+-- Sleeping will only terminate after the time has been advanced by `Time.adjust`. interceptTimeConstantNow ::-  ∀ t d r a .+  ∀ t d diff r a .+  Ord diff =>   HasDate t d =>+  TimeUnit diff =>+  Torsor t diff =>   Members [Time t d, Embed IO] r =>   Sem r a ->   Sem r a

@@ -12,7 +12,7 @@ -- |For deriving via. newtype FromSeconds a =   FromSeconds a-  deriving (Eq, Show)+  deriving stock (Eq, Show)   deriving newtype (Num)  instance (Integral a, TimeUnit a) => Fractional (FromSeconds a) where@@ -41,19 +41,19 @@ -- |Years. newtype Years =   Years { unYear :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)  -- |Months. newtype Months =   Months { unMonths :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)  -- |Weeks. newtype Weeks =   Weeks { unWeeks :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)  instance TimeUnit Weeks where@@ -63,7 +63,7 @@ -- |Days. newtype Days =   Days { unDays :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)  instance TimeUnit Days where@@ -73,7 +73,7 @@ -- |Hours. newtype Hours =   Hours { unHours :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)  instance TimeUnit Hours where@@ -83,7 +83,7 @@ -- |Minutes. newtype Minutes =   Minutes { unMinutes :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)  instance TimeUnit Minutes where@@ -93,7 +93,7 @@ -- |Seconds. newtype Seconds =   Seconds { unSeconds :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)  instance TimeUnit Seconds where@@ -103,7 +103,7 @@ -- |Milliseconds. newtype MilliSeconds =   MilliSeconds { unMilliSeconds :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)   deriving (Fractional) via (FromSeconds MilliSeconds) @@ -114,7 +114,7 @@ -- |Microseconds. newtype MicroSeconds =   MicroSeconds { unMicroSeconds :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)   deriving (Fractional) via (FromSeconds MicroSeconds) @@ -126,7 +126,7 @@ -- This is the base unit for all conversions. newtype NanoSeconds =   NanoSeconds { unNanoSeconds :: Int64 }-  deriving (Eq, Show, Generic)+  deriving stock (Eq, Show, Generic)   deriving newtype (Num, Real, Enum, Integral, Ord, Additive)   deriving (Fractional) via (FromSeconds NanoSeconds) @@ -203,7 +203,7 @@   u ->   Double secondsFrac u =-  fromIntegral (unNanoSeconds (convert u)) / 1e9+  fromMaybe 0 (fromIntegral (unNanoSeconds (convert u)) / 1e9)  json ''Years json ''Months

@@ -5,12 +5,15 @@  import Polysemy.Time.Class.Instant (Instant, dateTime) import Polysemy.Time.Data.TimeUnit (TimeUnit, convert)+import Polysemy.Time.Effect.Time (Time)+import qualified Polysemy.Time.Effect.Time as Time  -- |Subtract two arbitrary values that can be converted to an 'Instant'. diff ::-  ∀ dt u i1 i2 .+  ∀ dt u i1 i2 diff .+  TimeUnit diff =>   TimeUnit u =>-  Torsor dt u =>+  Torsor dt diff =>   Instant i1 dt =>   Instant i2 dt =>   i1 ->@@ -18,3 +21,17 @@   u diff i1 i2 =   convert (difference (dateTime i1) (dateTime i2))++-- |Calculate the duration between the given 'Instant' and the current time.+since ::+  ∀ u t d dt diff r .+  TimeUnit diff =>+  TimeUnit u =>+  Instant t dt =>+  Torsor dt diff =>+  Member (Time t d) r =>+  t ->+  Sem r u+since time = do+  now <- Time.now @t @d+  pure (diff @dt now time)

@@ -8,9 +8,9 @@ import Data.Time.Clock.System (getSystemTime, systemToUTCTime)  import Polysemy.Time.At (interceptTimeAt, interceptTimeConstant, interceptTimeConstantNow)+import Polysemy.Time.Data.TimeUnit (MicroSeconds (MicroSeconds), convert) import qualified Polysemy.Time.Effect.Time as Time import Polysemy.Time.Effect.Time (Time)-import Polysemy.Time.Data.TimeUnit (MicroSeconds (MicroSeconds), convert) import Polysemy.Time.Orphans ()  -- |Convenience alias for 'Data.Time'.@@ -51,6 +51,7 @@   interpretTimeGhc . interceptTimeAt @NominalDiffTime t  -- |Interpret 'Time' with the types from 'Data.Time', customizing the current time to be constant.+-- Sleeping will only terminate after the time has been advanced by `Time.adjust`. interpretTimeGhcConstant ::   Member (Embed IO) r =>   UTCTime ->@@ -60,6 +61,7 @@  -- |Interpret 'Time' with the types from 'Data.Time', customizing the current time to be constantly the time at the -- start of interpretation.+-- Sleeping will only terminate after the time has been advanced by `Time.adjust`. interpretTimeGhcConstantNow ::   Member (Embed IO) r =>   InterpreterFor GhcTime r

@@ -3,12 +3,20 @@  import qualified Data.Aeson as Aeson import Data.Aeson.TH (deriveJSON)+import Data.List (dropWhileEnd) import qualified Language.Haskell.TH.Syntax as TH --- |Derive Aeson codecs with custom settings.+-- |Aeson codec options that remove leading and trailing underscores.+basicOptions :: Aeson.Options+basicOptions =+  Aeson.defaultOptions { Aeson.fieldLabelModifier = dropWhileEnd ('_' ==) . dropWhile ('_' ==) }++-- |Derive Aeson codecs that strip underscores and unwrap data/newtype with single fields. json :: TH.Name -> TH.Q [TH.Dec] json =-  deriveJSON Aeson.defaultOptions {-    Aeson.fieldLabelModifier = dropWhile ('_' ==),-    Aeson.unwrapUnaryRecords = True-  }+  deriveJSON basicOptions { Aeson.unwrapUnaryRecords = True }++-- |Derive Aeson codecs that strip underscores.+unaryJson :: TH.Name -> TH.Q [TH.Dec]+unaryJson =+  deriveJSON basicOptions

@@ -5,20 +5,23 @@ -- see: https://github.com/sol/hpack  name:           polysemy-time-version:        0.4.0.0-synopsis:       Polysemy Effect for Time-description:    Please see the readme on Github at <https://github.com/tek/polysemy-time>+version:        0.5.0.0+synopsis:       Polysemy effects for time+description:    See https://hackage.haskell.org/package/polysemy-time/docs/Polysemy-Time.html category:       Time+homepage:       https://github.com/tek/polysemy-time#readme+bug-reports:    https://github.com/tek/polysemy-time/issues author:         Torsten Schmits-maintainer:     tek@tryp.io-copyright:      2021 Torsten Schmits+maintainer:     hackage@tryp.io+copyright:      2022 Torsten Schmits license:        BSD-2-Clause-Patent license-file:   LICENSE build-type:     Simple-extra-source-files:-    readme.md-    changelog.md +source-repository head+  type: git+  location: https://github.com/tek/polysemy-time+ library   exposed-modules:       Polysemy.Time@@ -50,6 +53,7 @@       DeriveFoldable       DeriveFunctor       DeriveGeneric+      DeriveLift       DeriveTraversable       DerivingStrategies       DerivingVia@@ -82,6 +86,7 @@       RankNTypes       RecordWildCards       RecursiveDo+      RoleAnnotations       ScopedTypeVariables       StandaloneDeriving       TemplateHaskell@@ -94,17 +99,19 @@       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -Wredundant-constraints -Wunused-packages+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages   build-depends:       aeson >=1.4-    , base ==4.*-    , incipit-core >=0.2+    , base >=4.12 && <5+    , incipit-core >=0.3     , stm     , template-haskell     , time     , torsor >=0.1   mixins:       base hiding (Prelude)+    , incipit-core (IncipitCore as Prelude)+    , incipit-core hiding (IncipitCore)   default-language: Haskell2010  test-suite polysemy-time-unit@@ -130,6 +137,7 @@       DeriveFoldable       DeriveFunctor       DeriveGeneric+      DeriveLift       DeriveTraversable       DerivingStrategies       DerivingVia@@ -162,6 +170,7 @@       RankNTypes       RecordWildCards       RecursiveDo+      RoleAnnotations       ScopedTypeVariables       StandaloneDeriving       TemplateHaskell@@ -174,14 +183,16 @@       UndecidableInstances       UnicodeSyntax       ViewPatterns-  ghc-options: -flate-specialise -fspecialise-aggressively -Wall -Wredundant-constraints -Wunused-packages -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -Wredundant-constraints -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Widentities -Wunused-packages -threaded -rtsopts -with-rtsopts=-N   build-depends:-      base ==4.*-    , incipit-core-    , polysemy-test+      base >=4.12 && <5+    , incipit-core >=0.3+    , polysemy-test >=0.6     , polysemy-time     , tasty     , time   mixins:       base hiding (Prelude)+    , incipit-core (IncipitCore as Prelude)+    , incipit-core hiding (IncipitCore)   default-language: Haskell2010

@@ -1,89 +0,0 @@-# About--This Haskell library provides a [Polysemy] effect for accessing the current time and date, and interpreters using-[time].--# Example--```haskell-import Data.Time (UTCTime)-import Polysemy (Members, runM)-import qualified Polysemy.Time as Time-import Polysemy.Time (MilliSeconds(MilliSeconds), Seconds(Seconds), Time, interpretTimeGhcAt, mkDatetime, year)--prog ::-  Ord t =>-  Members [Time t d, Embed IO] r =>-  Sem r ()-prog = do-  time1 <- Time.now-  Time.sleep (MilliSeconds 10)-  time2 <- Time.now-  print (time1 < time2)-  -- True--testTime :: UTCTime-testTime =-  mkDatetime 1845 12 31 23 59 59--main :: IO ()-main =-  runM do-    interpretTimeGhcAt testTime do-      Time.sleep (Seconds 1)-      time <- Time.now-      print (year time)-      -- Years { unYear = 1846 }-```--# Effect--The only effect contained in **polysemy-time** is:--```haskell-data Time (time :: Type) (date :: Type) :: Effect where-  Now :: Time t d m t-  Today :: Time t d m d-  Sleep :: TimeUnit u => u -> Time t d m ()-  SetTime :: t -> Time t d m ()-  SetDate :: d -> Time t d m ()-```--Interpreters are provided for the [time library](time) bundled with GHC.-The project [polysemy-chronos] contains an alternative implementation for [chronos].--The type parameters correspond to the representations in the implementation,-like `Data.Time.UTCTime`/`Chronos.Time` and `Data.Time.Day`/`Chronos.Date`.--`SetTime` and `SetDate` only have meaning when you're running in a testing context.--A special interpreter variant suffixed with `At` exists for both-implementations, with which the current time is overridden to be relative to-the supplied override fixed at the start of interpretation.-This is useful for testing.--# Utilities--A set of newtypes representing timespans are provided for convenience.-Internally, the interpreters operate on `NanoSecond`s.--The class `TimeUnit` ties those types, and the types `Chronos.Timespan` and-`Data.Time.DiffTime`, together to allow you to convert between them with the-function `convert`:--```haskell->>> convert (picosecondsToDiffTime 50000000) :: MicroSeconds-MicroSeconds {unMicroSeconds = 50}-->>> convert (Days 5) :: Timespan-Timespan {getTimespan = 432000000000000}-```--The class `Calendar` allows you to construct `UTCTime` and `Chronos.Datetime`-from integers with the function `mkDatetime`, as demonstrated in the first-example.--[Polysemy]: https://hackage.haskell.org/package/polysemy-[time]: https://hackage.haskell.org/package/time-[chronos]: https://hackage.haskell.org/package/chronos-[polysemy-chronos]: https://hackage.haskell.org/package/polysemy-chronos

@@ -1,7 +1,7 @@ module Main where  import Polysemy.Test (unitTest)-import Polysemy.Time.Test.GhcTimeTest (test_ghcTime, test_ghcTimeAt)+import Polysemy.Time.Test.GhcTimeTest (test_ghcTime) import Polysemy.Time.Test.MeasureTest (test_measure) import Polysemy.Time.Test.TimeUnitTest (test_fractional) import Test.Tasty (TestTree, defaultMain, testGroup)@@ -9,8 +9,7 @@ tests :: TestTree tests =   testGroup "unit" [-    unitTest "ghc time" test_ghcTime,-    unitTest "ghc time at instant" test_ghcTimeAt,+    test_ghcTime,     unitTest "convert Fractional to TimeUnit" test_fractional,     unitTest "measure time an action takes" test_measure   ]

@@ -1,14 +1,17 @@ module Polysemy.Time.Test.GhcTimeTest where  import Data.Time (Day, UTCTime)-import Polysemy.Test (UnitTest, assert, assertEq, runTestAuto)+import Polysemy.Test (UnitTest, assert, assertEq, assertJust, runTestAuto, unitTest) import Polysemy.Test.Data.Hedgehog (Hedgehog)+import Test.Tasty (testGroup)+import Test.Tasty.Providers (TestTree) +import Polysemy.Time.At (interceptTimeConstant) import Polysemy.Time.Calendar (mkDatetime, year)+import Polysemy.Time.Data.TimeUnit (Days (Days), Hours (Hours), Seconds (Seconds)) import qualified Polysemy.Time.Effect.Time as Time import Polysemy.Time.Effect.Time (Time)-import Polysemy.Time.Data.TimeUnit (Days (Days), Seconds (Seconds))-import Polysemy.Time.Interpreter.Ghc (interpretTimeGhc, interpretTimeGhcAt)+import Polysemy.Time.Interpreter.Ghc (GhcTime, interpretTimeGhc, interpretTimeGhcAt)  prog ::   ∀ t d r .@@ -20,8 +23,8 @@   time2 <- Time.now @t @d   assert @IO (time1 < time2) -test_ghcTime :: UnitTest-test_ghcTime =+test_ghcTimeNow :: UnitTest+test_ghcTimeNow =   runTestAuto do     interpretTimeGhc (prog @UTCTime @Day) @@ -39,3 +42,35 @@       Time.adjust @UTCTime @Day (Days 366)       time1 <- Time.now @UTCTime @Day       assertEq @_ @IO 1847 (year time1)++interceptSignal ::+  Members [GhcTime, Embed IO] r =>+  MVar () ->+  Sem r a ->+  Sem r a+interceptSignal signal =+  intercept @GhcTime \case+    Time.Sleep t -> do+      embed (putMVar signal ())+      Time.sleep @UTCTime @Day t+    e ->+      send @GhcTime (coerce e)++test_ghcTimeConstant :: UnitTest+test_ghcTimeConstant =+  runTestAuto $ asyncToIOFinal $ interpretTimeGhc do+    signal <- embed newEmptyMVar+    interceptSignal signal $ interceptTimeConstant testTime do+      handle <- async do+        Time.sleep @UTCTime @Day (Hours 1)+      embed (takeMVar signal)+      Time.adjust @UTCTime @Day (Hours 1)+      assertJust @_ @IO () =<< await handle++test_ghcTime :: TestTree+test_ghcTime =+  testGroup "ghc time" [+    unitTest "now monotony" test_ghcTimeNow,+    unitTest "start at instant" test_ghcTimeAt,+    unitTest "constant at instant" test_ghcTimeConstant+  ]

@@ -1,6 +1,6 @@ module Polysemy.Time.Test.TimeUnitTest where -import Polysemy.Test (UnitTest, assertEq, runTestAuto)+import Polysemy.Test (UnitTest, assertEq, runTestAuto, assertJust)  import Polysemy.Time.Data.TimeUnit (MicroSeconds (MicroSeconds), MilliSeconds (MilliSeconds), secondsFrac) @@ -9,6 +9,6 @@   runTestAuto do     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)+    assertJust @_ @IO (MilliSeconds 50) (MilliSeconds 100 / MilliSeconds 2)+    assertJust @_ @IO (MilliSeconds 50) (MilliSeconds 100 / 2)     assertEq @_ @IO 0.05 (secondsFrac (MilliSeconds 50))