{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NoStarIsType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Time.Units
(
Time (..)
, Second
, Millisecond
, Microsecond
, Nanosecond
, Picosecond
, Minute
, Hour
, Day
, Week
, Fortnight
, UnitName
, KnownUnitName
, KnownRatName
, unitNameVal
, time
, floorUnit
, floorRat
, ceilingUnit
, ceilingRat
, toNum
, toFractional
, sec
, ms
, mcs
, ns
, ps
, minute
, hour
, day
, week
, fortnight
, toUnit
, threadDelay
, getCPUTime
, timeout
) where
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Char (isDigit, isLetter)
import Data.Coerce (coerce)
import Data.Foldable (foldl')
import Data.Proxy (Proxy (..))
import Data.Semigroup (Semigroup (..))
import GHC.Generics (Generic)
import GHC.Natural (Natural)
import GHC.Read (Read (readPrec))
import GHC.Real (denominator, numerator, (%))
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Text.ParserCombinators.ReadP (ReadP, char, munch1, option, pfail, (+++))
import Text.ParserCombinators.ReadPrec (ReadPrec, lift)
#ifdef HAS_aeson
import Data.Aeson (FromJSON (..), ToJSON (..), withText)
import qualified Data.Text as Text
import Text.Read (readMaybe)
#endif
import Time.Rational (KnownDivRat, KnownRat, Rat, RatioNat, ratVal, type (*), type (/), type (:%))
import qualified Control.Concurrent as Concurrent
import qualified System.CPUTime as CPUTime
import qualified System.Timeout as Timeout
type Second = 1 / 1
type Millisecond = Second / 1000
type Microsecond = Millisecond / 1000
type Nanosecond = Microsecond / 1000
type Picosecond = Nanosecond / 1000
type Minute = 60 * Second
type Hour = 60 * Minute
type Day = 24 * Hour
type Week = 7 * Day
type Fortnight = 2 * Week
newtype Time (rat :: Rat) = Time { forall (rat :: Rat). Time rat -> RatioNat
unTime :: RatioNat }
deriving (Time rat -> Time rat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (rat :: Rat). Time rat -> Time rat -> Bool
/= :: Time rat -> Time rat -> Bool
$c/= :: forall (rat :: Rat). Time rat -> Time rat -> Bool
== :: Time rat -> Time rat -> Bool
$c== :: forall (rat :: Rat). Time rat -> Time rat -> Bool
Eq, Time rat -> Time rat -> Bool
Time rat -> Time rat -> Ordering
Time rat -> Time rat -> Time rat
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (rat :: Rat). Eq (Time rat)
forall (rat :: Rat). Time rat -> Time rat -> Bool
forall (rat :: Rat). Time rat -> Time rat -> Ordering
forall (rat :: Rat). Time rat -> Time rat -> Time rat
min :: Time rat -> Time rat -> Time rat
$cmin :: forall (rat :: Rat). Time rat -> Time rat -> Time rat
max :: Time rat -> Time rat -> Time rat
$cmax :: forall (rat :: Rat). Time rat -> Time rat -> Time rat
>= :: Time rat -> Time rat -> Bool
$c>= :: forall (rat :: Rat). Time rat -> Time rat -> Bool
> :: Time rat -> Time rat -> Bool
$c> :: forall (rat :: Rat). Time rat -> Time rat -> Bool
<= :: Time rat -> Time rat -> Bool
$c<= :: forall (rat :: Rat). Time rat -> Time rat -> Bool
< :: Time rat -> Time rat -> Bool
$c< :: forall (rat :: Rat). Time rat -> Time rat -> Bool
compare :: Time rat -> Time rat -> Ordering
$ccompare :: forall (rat :: Rat). Time rat -> Time rat -> Ordering
Ord, Int -> Time rat
Time rat -> Int
Time rat -> [Time rat]
Time rat -> Time rat
Time rat -> Time rat -> [Time rat]
Time rat -> Time rat -> Time rat -> [Time rat]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
forall (rat :: Rat). Int -> Time rat
forall (rat :: Rat). Time rat -> Int
forall (rat :: Rat). Time rat -> [Time rat]
forall (rat :: Rat). Time rat -> Time rat
forall (rat :: Rat). Time rat -> Time rat -> [Time rat]
forall (rat :: Rat). Time rat -> Time rat -> Time rat -> [Time rat]
enumFromThenTo :: Time rat -> Time rat -> Time rat -> [Time rat]
$cenumFromThenTo :: forall (rat :: Rat). Time rat -> Time rat -> Time rat -> [Time rat]
enumFromTo :: Time rat -> Time rat -> [Time rat]
$cenumFromTo :: forall (rat :: Rat). Time rat -> Time rat -> [Time rat]
enumFromThen :: Time rat -> Time rat -> [Time rat]
$cenumFromThen :: forall (rat :: Rat). Time rat -> Time rat -> [Time rat]
enumFrom :: Time rat -> [Time rat]
$cenumFrom :: forall (rat :: Rat). Time rat -> [Time rat]
fromEnum :: Time rat -> Int
$cfromEnum :: forall (rat :: Rat). Time rat -> Int
toEnum :: Int -> Time rat
$ctoEnum :: forall (rat :: Rat). Int -> Time rat
pred :: Time rat -> Time rat
$cpred :: forall (rat :: Rat). Time rat -> Time rat
succ :: Time rat -> Time rat
$csucc :: forall (rat :: Rat). Time rat -> Time rat
Enum, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (rat :: Rat) x. Rep (Time rat) x -> Time rat
forall (rat :: Rat) x. Time rat -> Rep (Time rat) x
$cto :: forall (rat :: Rat) x. Rep (Time rat) x -> Time rat
$cfrom :: forall (rat :: Rat) x. Time rat -> Rep (Time rat) x
Generic)
instance Semigroup (Time (rat :: Rat)) where
<> :: Time rat -> Time rat -> Time rat
(<>) = coerce :: forall a b. Coercible a b => a -> b
coerce (forall a. Num a => a -> a -> a
(+) :: RatioNat -> RatioNat -> RatioNat)
{-# INLINE (<>) #-}
sconcat :: NonEmpty (Time rat) -> Time rat
sconcat = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Semigroup a => a -> a -> a
(<>) forall a. Monoid a => a
mempty
{-# INLINE sconcat #-}
stimes :: forall b. Integral b => b -> Time rat -> Time rat
stimes b
n (Time RatioNat
t) = forall (rat :: Rat). RatioNat -> Time rat
Time (forall a b. (Integral a, Num b) => a -> b
fromIntegral b
n forall a. Num a => a -> a -> a
* RatioNat
t)
{-# INLINE stimes #-}
instance Monoid (Time (rat :: Rat)) where
mempty :: Time rat
mempty = forall (rat :: Rat). RatioNat -> Time rat
Time RatioNat
0
{-# INLINE mempty #-}
mappend :: Time rat -> Time rat -> Time rat
mappend = forall a. Semigroup a => a -> a -> a
(<>)
{-# INLINE mappend #-}
mconcat :: [Time rat] -> Time rat
mconcat = forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Semigroup a => a -> a -> a
(<>) forall a. Monoid a => a
mempty
{-# INLINE mconcat #-}
#ifdef HAS_aeson
instance (KnownUnitName unit) => ToJSON (Time (unit :: Rat)) where
toJSON = toJSON . show
instance (KnownUnitName unit) => FromJSON (Time (unit :: Rat)) where
parseJSON = withText "time" $ maybe parseFail pure . maybeTime
where
parseFail = fail $ "Can not parse Time. Expected unit: " ++ unitNameVal @unit
maybeTime = readMaybe @(Time unit) . Text.unpack
#endif
type family UnitName (unit :: Rat) :: Symbol
type instance UnitName (1 :% 1) = "s"
type instance UnitName (1 :% 1000) = "ms"
type instance UnitName (1 :% 1000000) = "mcs"
type instance UnitName (1 :% 1000000000) = "ns"
type instance UnitName (1 :% 1000000000000) = "ps"
type instance UnitName (60 :% 1) = "m"
type instance UnitName (3600 :% 1) = "h"
type instance UnitName (86400 :% 1) = "d"
type instance UnitName (604800 :% 1) = "w"
type instance UnitName (1209600 :% 1) = "fn"
type KnownUnitName unit = KnownSymbol (UnitName unit)
type KnownRatName unit = (KnownUnitName unit, KnownRat unit)
unitNameVal :: forall (unit :: Rat) . (KnownUnitName unit) => String
unitNameVal :: forall (unit :: Rat). KnownUnitName unit => String
unitNameVal = forall (n :: Symbol) (proxy :: Symbol -> Type).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @(UnitName unit))
instance KnownUnitName unit => Show (Time unit) where
showsPrec :: Int -> Time unit -> ShowS
showsPrec Int
p (Time RatioNat
t) = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
6)
forall a b. (a -> b) -> a -> b
$ forall {a}. (Integral a, Show a) => Ratio a -> ShowS
showsMixed RatioNat
t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (forall (unit :: Rat). KnownUnitName unit => String
unitNameVal @unit)
where
showsMixed :: Ratio a -> ShowS
showsMixed Ratio a
0 = String -> ShowS
showString String
"0"
showsMixed Ratio a
rat =
let (a
n,a
d) = (forall a. Ratio a -> a
numerator Ratio a
rat, forall a. Ratio a -> a
denominator Ratio a
rat)
(a
q,a
r) = a
n forall a. Integral a => a -> a -> (a, a)
`quotRem` a
d
op :: String
op = if a
q forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
|| a
r forall a. Eq a => a -> a -> Bool
== a
0 then String
"" else String
"+"
quotStr :: ShowS
quotStr = if a
q forall a. Eq a => a -> a -> Bool
== a
0
then forall a. a -> a
id
else forall a. Show a => a -> ShowS
shows a
q
remStr :: ShowS
remStr = if a
r forall a. Eq a => a -> a -> Bool
== a
0
then forall a. a -> a
id
else forall a. Show a => a -> ShowS
shows a
r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"/"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows a
d
in
ShowS
quotStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
op forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
remStr
instance KnownUnitName unit => Read (Time unit) where
readPrec :: ReadPrec (Time unit)
readPrec :: ReadPrec (Time unit)
readPrec = forall a. ReadP a -> ReadPrec a
lift ReadP (Time unit)
readP
where
readP :: ReadP (Time unit)
readP :: ReadP (Time unit)
readP = do
let naturalP :: ReadP Natural
naturalP = forall a. Read a => String -> a
read forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
munch1 Char -> Bool
isDigit
let fullMixedExpr :: ReadP (Natural, Natural, Natural)
fullMixedExpr = (,,) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadP Natural
naturalP forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
char Char
'+')
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> (ReadP Natural
naturalP forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
char Char
'/')
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> ReadP Natural
naturalP
let improperExpr :: ReadP (Natural, Natural, Natural)
improperExpr = (,,) Natural
0 forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Natural
naturalP
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall a. a -> ReadP a -> ReadP a
option Natural
1 (Char -> ReadP Char
char Char
'/' forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> ReadP Natural
naturalP)
(Natural
q,Natural
r,Natural
d) <- ReadP (Natural, Natural, Natural)
fullMixedExpr forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP (Natural, Natural, Natural)
improperExpr
let n :: Natural
n = (Natural
q forall a. Num a => a -> a -> a
* Natural
d forall a. Num a => a -> a -> a
+ Natural
r)
String
timeUnitStr <- (Char -> Bool) -> ReadP String
munch1 Char -> Bool
isLetter
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (String
timeUnitStr forall a. Eq a => a -> a -> Bool
== forall (unit :: Rat). KnownUnitName unit => String
unitNameVal @unit) forall a. ReadP a
pfail
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (rat :: Rat). RatioNat -> Time rat
Time (Natural
n forall a. Integral a => a -> a -> Ratio a
% Natural
d)
time :: RatioNat -> Time unit
time :: forall (rat :: Rat). RatioNat -> Time rat
time RatioNat
n = forall (rat :: Rat). RatioNat -> Time rat
Time RatioNat
n
{-# INLINE time #-}
sec :: RatioNat -> Time Second
sec :: RatioNat -> Time Second
sec = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE sec #-}
ms :: RatioNat -> Time Millisecond
ms :: RatioNat -> Time Millisecond
ms = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE ms #-}
mcs :: RatioNat -> Time Microsecond
mcs :: RatioNat -> Time Microsecond
mcs = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE mcs #-}
ns :: RatioNat -> Time Nanosecond
ns :: RatioNat -> Time Nanosecond
ns = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE ns #-}
ps :: RatioNat -> Time Picosecond
ps :: RatioNat -> Time Picosecond
ps = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE ps #-}
minute :: RatioNat -> Time Minute
minute :: RatioNat -> Time Minute
minute = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE minute #-}
hour :: RatioNat -> Time Hour
hour :: RatioNat -> Time Hour
hour = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE hour #-}
day :: RatioNat -> Time Day
day :: RatioNat -> Time Day
day = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE day #-}
week :: RatioNat -> Time Week
week :: RatioNat -> Time Week
week = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE week #-}
fortnight :: RatioNat -> Time Fortnight
fortnight :: RatioNat -> Time Fortnight
fortnight = forall (rat :: Rat). RatioNat -> Time rat
time
{-# INLINE fortnight #-}
floorRat :: forall b (unit :: Rat) . Integral b => Time unit -> b
floorRat :: forall b (unit :: Rat). Integral b => Time unit -> b
floorRat = forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rat :: Rat). Time rat -> RatioNat
unTime
floorUnit :: forall (unit :: Rat) . Time unit -> Time unit
floorUnit :: forall (rat :: Rat). Time rat -> Time rat
floorUnit = forall (rat :: Rat). RatioNat -> Time rat
time forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (unit :: Rat). Integral b => Time unit -> b
floorRat
ceilingRat :: forall b (unit :: Rat) . (Integral b) => Time unit -> b
ceilingRat :: forall b (unit :: Rat). Integral b => Time unit -> b
ceilingRat = forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rat :: Rat). Time rat -> RatioNat
unTime
ceilingUnit :: forall (unit :: Rat) . Time unit -> Time unit
ceilingUnit :: forall (rat :: Rat). Time rat -> Time rat
ceilingUnit = forall (rat :: Rat). RatioNat -> Time rat
time forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (unit :: Rat). Integral b => Time unit -> b
ceilingRat
toNum :: forall (unitTo :: Rat) n (unit :: Rat) . (KnownDivRat unit unitTo, Num n)
=> Time unit -> n
toNum :: forall (unitTo :: Rat) n (unit :: Rat).
(KnownDivRat unit unitTo, Num n) =>
Time unit -> n
toNum = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Natural forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (unit :: Rat). Integral b => Time unit -> b
floorRat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @unitTo
{-# DEPRECATED toNum
[ "May lead to unexpected flooring of the fractional time."
, "Use 'toFractional' to avoid rounding or 'floorRat' to keep the flooring behaviour."
] #-}
toFractional :: forall r (unit :: Rat) . Fractional r => Time unit -> r
toFractional :: forall r (unit :: Rat). Fractional r => Time unit -> r
toFractional = forall a. Fractional a => Rational -> a
fromRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rat :: Rat). Time rat -> RatioNat
unTime
toUnit :: forall (unitTo :: Rat) (unitFrom :: Rat) . KnownDivRat unitFrom unitTo
=> Time unitFrom
-> Time unitTo
toUnit :: forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit Time{RatioNat
unTime :: RatioNat
unTime :: forall (rat :: Rat). Time rat -> RatioNat
..} = forall (rat :: Rat). RatioNat -> Time rat
Time forall a b. (a -> b) -> a -> b
$ RatioNat
unTime forall a. Num a => a -> a -> a
* forall (r :: Rat). KnownRat r => RatioNat
ratVal @(unitFrom / unitTo)
{-# INLINE toUnit #-}
threadDelay :: forall (unit :: Rat) m . (KnownDivRat unit Microsecond, MonadIO m)
=> Time unit
-> m ()
threadDelay :: forall (unit :: Rat) (m :: Type -> Type).
(KnownDivRat unit Microsecond, MonadIO m) =>
Time unit -> m ()
threadDelay = forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
Concurrent.threadDelay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (unit :: Rat). Integral b => Time unit -> b
floorRat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Microsecond
{-# INLINE threadDelay #-}
getCPUTime :: forall (unit :: Rat) m . (KnownDivRat Picosecond unit, MonadIO m)
=> m (Time unit)
getCPUTime :: forall (unit :: Rat) (m :: Type -> Type).
(KnownDivRat Picosecond unit, MonadIO m) =>
m (Time unit)
getCPUTime = forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit forall b c a. (b -> c) -> (a -> b) -> a -> c
. RatioNat -> Time Picosecond
ps forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO Integer
CPUTime.getCPUTime
{-# INLINE getCPUTime #-}
timeout :: forall (unit :: Rat) m a . (MonadIO m, KnownDivRat unit Microsecond)
=> Time unit
-> IO a
-> m (Maybe a)
timeout :: forall (unit :: Rat) (m :: Type -> Type) a.
(MonadIO m, KnownDivRat unit Microsecond) =>
Time unit -> IO a -> m (Maybe a)
timeout Time unit
t = forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> IO a -> IO (Maybe a)
Timeout.timeout (forall b (unit :: Rat). Integral b => Time unit -> b
floorRat forall a b. (a -> b) -> a -> b
$ forall (unitTo :: Rat) (unitFrom :: Rat).
KnownDivRat unitFrom unitTo =>
Time unitFrom -> Time unitTo
toUnit @Microsecond Time unit
t)
{-# INLINE timeout #-}