time-domain 1.6 → 1.7

raw patch · 3 files changed

+80/−51 lines, 3 filesdep +changesetdep +groups

Dependencies added: changeset, groups

Files

• CHANGELOG.md +6/−0
• src/Data/TimeDomain.hs +71/−50
• time-domain.cabal +3/−1

@@ -1,5 +1,11 @@ # Revision history for time-domain +## 1.7++* Introduce `Seconds` time domain+* Base the `TimeDomain` class hierarchy on `Group` (from `monoid-extras`) and `RightAction` (from `changeset`)+* Extend the `TimeDifference` type class+ ## 0.1.0.5  * Support GHC 9.10

@@ -1,7 +1,12 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {- | This module defines the 'TimeDomain' class.@@ -15,9 +20,18 @@ ) where +-- base+import Data.Monoid (Sum (..))+ -- time import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime) +-- groups+import Data.Group (Group (..))++-- changeset+import Data.Monoid.RightAction (RightAction (actRight), RightTorsor (differenceRight))+ {- | A time domain is an affine space representing a notion of time, such as real time, simulated time, steps, or a completely different notion.@@ -28,86 +42,93 @@ * @(t `addTime` dt) `diffTime` t = dt@ * @(t `addTime` dt1) `addTime` dt2 = t `addTime` (dt1 `add` dt2)@ -}-class (TimeDifference (Diff time)) => TimeDomain time where+class (RightAction (Diff time) time, RightTorsor (Diff time) time, TimeDifference (Diff time)) => TimeDomain time where   -- | The type of differences or durations between two timestamps   type Diff time -  -- | Compute the difference between two timestamps.-  ---  --   Mnemonic: 'diffTime' behaves like the '(-)' operator:-  ---  --   @'diffTime' earlier later = later `'diffTime'` earlier@ is the duration it takes from @earlier@ to @later@.+  {- | Compute the difference between two timestamps.++  Mnemonic: 'diffTime' behaves like the '(-)' operator:++  @'diffTime' earlier later = later `'diffTime'` earlier@ is the duration it takes from @earlier@ to @later@.+  -}   diffTime :: time -> time -> Diff time+  diffTime = differenceRight    -- | Add a time difference to a timestamp.   addTime :: time -> Diff time -> time+  addTime = actRight  {- | A type of durations, or differences betweens time stamps.  Expected laws: +* @dt `add` 'zero' = dt@ and @dt `difference` 'zero' = dt@ * `add` is commutative and associative * @(dt1 `difference` dt2) `add` dt2 = dt1@ -}-class TimeDifference d where-  -- | Calculate the difference between two durations,-  --   compatibly with 'diffTime'.+class (Group d) => TimeDifference d where+  {- | The zero duration, i.e. no time has passed.+  Additive identity for 'difference' and 'add'.+  -}+  zero :: d+  zero = mempty++  {- | Calculate the difference between two durations,+  compatibly with 'diffTime'.+  -}   difference :: d -> d -> d+  difference = (~~)    -- | Add two time differences.   add :: d -> d -> d+  add = (<>) --- | Differences between 'UTCTime's are measured in seconds.+-- | Differences between 'UTCTime's are measured in Secondss. instance TimeDomain UTCTime where-  type Diff UTCTime = Double-  diffTime t1 t2 = realToFrac $ diffUTCTime t1 t2-  addTime = flip $ addUTCTime . realToFrac--instance TimeDifference Double where-  difference = (-)-  add = (+)--instance TimeDomain Double where-  type Diff Double = Double-  diffTime = (-)-  addTime = (+)--instance TimeDifference Float where-  difference = (-)-  add = (+)--instance TimeDomain Float where-  type Diff Float = Float-  diffTime = (-)-  addTime = (+)+  type Diff UTCTime = Seconds Double -instance TimeDifference Integer where-  difference = (-)-  add = (+)+instance RightAction (Seconds Double) UTCTime where+  actRight = flip $ addUTCTime . realToFrac . getSeconds -instance TimeDomain Integer where-  type Diff Integer = Integer-  diffTime = (-)-  addTime = (+)+instance RightTorsor (Seconds Double) UTCTime where+  differenceRight t1 t2 = Seconds $ realToFrac $ diffUTCTime t1 t2  instance TimeDifference () where+  zero = ()   difference _ _ = ()   add _ _ = ()  instance TimeDomain () where   type Diff () = ()-  diffTime _ _ = ()-  addTime _ _ = () --- | Any 'Num' can be wrapped to form a 'TimeDomain'.-newtype NumTimeDomain a = NumTimeDomain {fromNumTimeDomain :: a}-  deriving (Num)+{- | Any 'Num' can be wrapped to form a 'TimeDomain'. -instance (Num a) => TimeDifference (NumTimeDomain a) where-  difference = (-)-  add = (+)+The number 1 is interpreted as one second.+-}+newtype Seconds a = Seconds {getSeconds :: a}+  deriving newtype (Show, Read, Eq, Ord, Num, Fractional, Floating, Real, RealFrac, RealFloat, Enum, Bounded, Integral)+  deriving stock (Functor, Foldable, Traversable) -instance (Num a) => TimeDomain (NumTimeDomain a) where-  type Diff (NumTimeDomain a) = NumTimeDomain a-  diffTime = (-)-  addTime = (+)+deriving via Sum (Seconds a) instance (Num a) => Semigroup (Seconds a)+deriving via Sum (Seconds a) instance (Num a) => Monoid (Seconds a)+deriving via Sum (Seconds a) instance (Num a) => Group (Seconds a)+instance (Num a) => TimeDifference (Seconds a)++-- I would have thought I shouldn't be needing this, but it seems to overlap with the Zip instance for some reason.+instance {-# OVERLAPPING #-} (Num a) => RightAction (Seconds a) (Seconds a) where+  actRight = (+)++instance (Num a) => RightTorsor (Seconds a) (Seconds a) where+  differenceRight = (-)++instance (Num a) => TimeDomain (Seconds a) where+  type Diff (Seconds a) = Seconds a++-- | Scale time differences by a factor.+instance (Num a) => RightAction a (Seconds a) where+  actRight seconds factor = fmap (* factor) seconds++-- | Compute the quotient of two time differences.+instance (Fractional a) => RightTorsor a (Seconds a) where+  differenceRight (Seconds secondsOrig) (Seconds secondsScaled) = secondsOrig / secondsScaled

@@ -1,6 +1,6 @@ cabal-version: 2.4 name: time-domain-version: 1.6+version: 1.7 license: MIT license-file: LICENSE author: Manuel Bärenz@@ -32,6 +32,8 @@   exposed-modules: Data.TimeDomain   build-depends:     base >=4.13.0 && <4.22,+    changeset ^>=0.2.1,+    groups ^>=0.5.3,     time >=1.11 && <1.16,    hs-source-dirs: src