graphql-engine/server/src-lib/Data/Time/Clock/Units.hs

{-# LANGUAGE NumDecimals #-}

{-| Types for time intervals of various units. Each newtype wraps 'DiffTime',
but they have different 'Num' instances. The intent is to use the record
selectors to write literals with particular units, like this:

@
>>> 'milliseconds' 500
0.5s
>>> 'hours' 3
10800s
>>> 'minutes' 1.5 + 'seconds' 30
120s
@

You can also go the other way using the constructors rather than the selectors:

@
>>> 'toRational' '$' 'Minutes' ('seconds' 17)
17 % 60
>>> 'realToFrac' ('Days' ('hours' 12)) :: 'Double'
0.5
@

NOTE: the 'Real' and 'Fractional' instances just essentially add or strip the
unit label (as  above), so you can't use 'realToFrac' to convert between the
units types here. Instead try  'convertDuration' which is less of a foot-gun.

The 'Read' instances for these types mirror the behavior of the 'RealFrac'
instance wrt numeric literals for convenient serialization (e.g. when working
with env vars):

@
>>> read "1.2" :: Milliseconds
Milliseconds {milliseconds = 0.0012s}
@

Generally, if you need to pass around a duration between functions you should
use 'DiffTime' directly. However if storing a duration in a type that will be
serialized, e.g. one having a 'ToJSON' instance, it is better to use one of
these explicit wrapper types so that it's  obvious what units will be used. -}
module Data.Time.Clock.Units
  ( Days(..)
  , Hours(..)
  , Minutes(..)
  , Seconds(..)
  , Milliseconds(..)
  , Microseconds(..)
  , Nanoseconds(..)
  -- * Converting between units
  , Duration(..)
  , convertDuration
  -- * Reexports
  -- | We use 'DiffTime' as the standard type for unit-agnostic duration in our
  -- code. You'll need to convert to a 'NominalDiffTime'  (with 'convertDuration') in
  -- order to do anything useful with 'UTCTime' with these durations.
  --
  -- NOTE: some care must be taken especially when 'NominalDiffTime' interacts
  -- with 'UTCTime':
  --
  --  - a 'DiffTime' or 'NominalDiffTime' may be negative
  --  - 'addUTCTime' and 'diffUTCTime' do not attempt to handle leap seconds
  , DiffTime
  ) where

import           Prelude

import           Control.Applicative ((<|>))
import           Control.Arrow       (first)
import           Data.Aeson
import           Data.Hashable
import           Data.Proxy
import           Data.Text           (unpack)
import           Data.Time.Clock
import           GHC.TypeLits
import           Numeric             (readFloat)

import qualified Text.Read           as TR

newtype Seconds = Seconds { seconds :: DiffTime }
  -- NOTE: we want Show to give a pastable data structure string, even
  -- though Read is custom.
  deriving (Duration, Show, Eq, Ord, ToJSON, FromJSON)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit (SecondsP 1))

-- TODO if needed: deriving (ToJSON, FromJSON) via (TimeUnit ..) making sure
--      to copy Aeson instances (with withBoundedScientific), and e.g.
--         toJSON (5 :: Minutes) == Number 5
newtype Days = Days { days :: DiffTime }
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit (SecondsP 86400))

newtype Hours = Hours { hours :: DiffTime }
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit (SecondsP 3600))

newtype Minutes = Minutes { minutes :: DiffTime }
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit (SecondsP 60))

newtype Milliseconds = Milliseconds { milliseconds :: DiffTime }
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit 1000000000)

-- TODO: Has an alternative string representation instead of a numberic one here
-- in order to clarify what's going on.
-- Rounding is also problematic, but should be ok for now...
instance ToJSON Milliseconds where
  toJSON = toJSON . flip div 1e9 . diffTimeToPicoseconds . milliseconds

instance FromJSON Milliseconds where
  parseJSON v
    =   withScientific "Milliseconds Number" (pure . Milliseconds . picosecondsToDiffTime . (* 1e9) . ceiling) v
    <|> withText       "Milliseconds String" (either (fail . show) pure . TR.readEither . unpack) v


newtype Microseconds = Microseconds { microseconds :: DiffTime }
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit 1000000)

newtype Nanoseconds = Nanoseconds { nanoseconds :: DiffTime }
  deriving (Duration, Show, Eq, Ord)
  deriving (Read, Num, Fractional, Real, Hashable, RealFrac) via (TimeUnit 1000)

-- Internal for deriving via
newtype TimeUnit (picosPerUnit :: Nat) = TimeUnit DiffTime
  deriving (Show, Eq, Ord)

type SecondsP n = n GHC.TypeLits.* 1000000000000

natNum :: forall n a. (KnownNat n, Num a) => a
natNum = fromInteger $ natVal (Proxy @n)

instance (KnownNat picosPerUnit) => Num (TimeUnit picosPerUnit) where
  TimeUnit a + TimeUnit b = TimeUnit $ a + b
  TimeUnit a - TimeUnit b = TimeUnit $ a - b
  TimeUnit a * TimeUnit b = TimeUnit . picosecondsToDiffTime $
    diffTimeToPicoseconds a * diffTimeToPicoseconds b `div` natNum @picosPerUnit
  negate (TimeUnit a) = TimeUnit $ negate a
  abs (TimeUnit a) = TimeUnit $ abs a
  signum (TimeUnit a) = TimeUnit $ signum a
  fromInteger a = TimeUnit . picosecondsToDiffTime $ a * natNum @picosPerUnit

instance (KnownNat picosPerUnit) => Read (TimeUnit picosPerUnit) where
  readsPrec _ = map (first fromRational) . readFloat

instance (KnownNat picosPerUnit) => Fractional (TimeUnit picosPerUnit) where
  TimeUnit a / TimeUnit b = TimeUnit . picosecondsToDiffTime $
    diffTimeToPicoseconds a * natNum @picosPerUnit `div` diffTimeToPicoseconds b
  fromRational a = TimeUnit . picosecondsToDiffTime $ round (a * natNum @picosPerUnit)

instance (KnownNat picosPerUnit) => Real (TimeUnit picosPerUnit) where
  toRational (TimeUnit a) = toRational (diffTimeToPicoseconds a) / natNum @picosPerUnit

instance (KnownNat picosPerUnit) => RealFrac (TimeUnit picosPerUnit) where
  properFraction a = (i, a - fromIntegral i)
    where i = truncate a
  truncate = truncate . toRational
  round = round . toRational
  ceiling = ceiling . toRational
  floor = floor . toRational

-- we can ignore unit:
instance Hashable (TimeUnit a) where
  hashWithSalt salt (TimeUnit dt) = hashWithSalt salt $
    (realToFrac :: DiffTime -> Double) dt


-- | Duration types isomorphic to 'DiffTime', powering 'convertDuration'.
class Duration d where
  fromDiffTime :: DiffTime -> d
  toDiffTime :: d -> DiffTime

instance Duration DiffTime where
  fromDiffTime = id
  toDiffTime = id

instance Duration NominalDiffTime where
  fromDiffTime = realToFrac
  toDiffTime = realToFrac

-- | Safe conversion between duration units.
convertDuration :: (Duration x, Duration y) => x -> y
convertDuration = fromDiffTime . toDiffTime