module Data.Thyme.Clock.UTC where
import Prelude
import Control.DeepSeq
import Control.Lens
import Data.AdditiveGroup
import Data.AffineSpace
import Data.Basis
import Data.Bits
import Data.Data
import Data.Int
import Data.Ix
import Data.Micro
import Data.Thyme.Calendar
import Data.Thyme.Clock.Scale
import Data.VectorSpace
newtype NominalDiffTime = NominalDiffTime Micro
deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)
#if SHOW_INTERNAL
deriving instance Show NominalDiffTime
#else
instance Show NominalDiffTime where
showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest)
#endif
instance VectorSpace NominalDiffTime where
type Scalar NominalDiffTime = Rational
s *^ NominalDiffTime t = NominalDiffTime (s *^ t)
instance HasBasis NominalDiffTime where
type Basis NominalDiffTime = ()
basisValue () = NominalDiffTime (basisValue ())
decompose (NominalDiffTime a) = decompose a
decompose' (NominalDiffTime a) = decompose' a
#if INSTANCE_NUM
deriving instance Num NominalDiffTime
deriving instance Real NominalDiffTime
deriving instance Fractional NominalDiffTime
deriving instance RealFrac NominalDiffTime
#endif
posixDayLength :: NominalDiffTime
posixDayLength = NominalDiffTime (toMicro 86400)
newtype UTCTime = UTCPacked Int64
deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)
data UTCView = UTCTime
{ utctDay :: !Day
, utctDayTime :: !DiffTime
} deriving (Eq, Ord, Data, Typeable, Show)
instance NFData UTCView
_utctDay :: Simple Lens UTCTime Day
_utctDay = utcTime . lens utctDay (\ (UTCTime _ t) d -> UTCTime d t)
_utctDayTime :: Simple Lens UTCTime DiffTime
_utctDayTime = utcTime . lens utctDayTime (\ (UTCTime d _) t -> UTCTime d t)
instance AffineSpace UTCTime where
type Diff UTCTime = NominalDiffTime
(view utcTime -> UTCTime da ta) .-. (view utcTime -> UTCTime db tb) =
fromIntegral (da .-. db) *^ posixDayLength ^+^ NominalDiffTime td where
DiffTime td = ta ^-^ tb
(view utcTime -> UTCTime day (DiffTime dt)) .+^ NominalDiffTime d
= review utcTime $ UTCTime day (DiffTime (dt ^+^ d))
utcTime :: Simple Iso UTCTime UTCView
utcTime = iso unpack pack where
unpack :: UTCTime -> UTCView
unpack (UTCPacked n) = UTCTime
(ModifiedJulianDay mjd) (DiffTime (Micro dt)) where
mjd = shiftR n bitsDayTime
dt = n .&. maskDayTime
pack :: UTCView -> UTCTime
pack (UTCTime (ModifiedJulianDay mjd) (DiffTime dt)) =
UTCPacked (shiftL (mjd + dd) bitsDayTime .|. pt) where
NominalDiffTime posixDay = posixDayLength
(dd, Micro pt) = microDivMod dt posixDay
bitsDayTime :: Int
bitsDayTime = 37
maskDayTime :: Int64
maskDayTime = shiftL 1 bitsDayTime 1