{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_HADDOCK hide #-}
#include "thyme.h"
module Data.Thyme.Clock.Internal where
import Prelude
import Control.DeepSeq
import Control.Lens
import Data.AdditiveGroup
import Data.AffineSpace
import Data.Basis
import Data.Data
import Data.Int
import Data.Ix
import Data.Thyme.Internal.Micro
import Data.Thyme.Calendar.Internal
#if __GLASGOW_HASKELL__ == 704
import qualified Data.Vector.Generic
import qualified Data.Vector.Generic.Mutable
#endif
import Data.Vector.Unboxed.Deriving
import Data.VectorSpace
import GHC.Generics (Generic)
import System.Random
import Test.QuickCheck
#if !SHOW_INTERNAL
import Control.Monad
import Text.ParserCombinators.ReadPrec (lift)
import Text.ParserCombinators.ReadP (char)
import Text.Read (readPrec)
#endif
class (HasBasis t, Basis t ~ (), Scalar t ~ Rational) => TimeDiff t where
microseconds :: Iso' t Int64
{-# INLINE toSeconds #-}
toSeconds :: (TimeDiff t, Fractional n) => t -> n
toSeconds = (* recip 1000000) . fromIntegral . view microseconds
{-# INLINE[0] fromSeconds #-}
fromSeconds :: (Real n, TimeDiff t) => n -> t
fromSeconds = fromSeconds' . toRational
{-# INLINE toSeconds' #-}
toSeconds' :: (TimeDiff t) => t -> Rational
toSeconds' = (`decompose'` ())
{-# INLINE fromSeconds' #-}
fromSeconds' :: (TimeDiff t) => Rational -> t
fromSeconds' = (*^ basisValue ())
{-# INLINE picoseconds #-}
picoseconds :: (TimeDiff t) => Iso' t Integer
picoseconds = microseconds . iso ((*) 1000000 . toInteger)
(\ ps -> fromInteger $ quot (ps + signum ps * 500000) 1000000)
{-# INLINE fromSecondsRealFrac #-}
fromSecondsRealFrac :: (RealFrac n, TimeDiff t) => n -> n -> t
fromSecondsRealFrac _ = review microseconds . round . (*) 1000000
{-# INLINE fromSecondsIntegral #-}
fromSecondsIntegral :: (Integral n, TimeDiff t) => n -> n -> t
fromSecondsIntegral _ = review microseconds . (*) 1000000 . fromIntegral
{-# RULES
"fromSeconds/Float" [~0] fromSeconds = fromSecondsRealFrac (0 :: Float)
"fromSeconds/Double" [~0] fromSeconds = fromSecondsRealFrac (0 :: Double)
"fromSeconds/Int" [~0] fromSeconds = fromSecondsIntegral (0 :: Int)
"fromSeconds/Int64" [~0] fromSeconds = fromSecondsIntegral (0 :: Int64)
"fromSeconds/Integer" [~0] fromSeconds = fromSecondsIntegral (0 :: Integer)
#-}
newtype DiffTime = DiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup)
derivingUnbox "DiffTime" [t| DiffTime -> Micro |]
[| \ (DiffTime a) -> a |] [| DiffTime |]
#if SHOW_INTERNAL
deriving instance Show DiffTime
deriving instance Read DiffTime
#else
instance Show DiffTime where
{-# INLINEABLE showsPrec #-}
showsPrec p (DiffTime a) = showsPrec p a . (:) 's'
instance Read DiffTime where
{-# INLINEABLE readPrec #-}
readPrec = return (const . DiffTime) `ap` readPrec `ap` lift (char 's')
#endif
instance VectorSpace DiffTime where
type Scalar DiffTime = Rational
{-# INLINE (*^) #-}
(*^) = \ s (DiffTime t) -> DiffTime (s *^ t)
instance HasBasis DiffTime where
type Basis DiffTime = ()
{-# INLINE basisValue #-}
basisValue = \ _ -> DiffTime (basisValue ())
{-# INLINE decompose #-}
decompose = \ (DiffTime a) -> decompose a
{-# INLINE decompose' #-}
decompose' = \ (DiffTime a) -> decompose' a
instance TimeDiff DiffTime where
{-# INLINE microseconds #-}
microseconds = iso (\ (DiffTime (Micro u)) -> u) (DiffTime . Micro)
newtype NominalDiffTime = NominalDiffTime Micro deriving (INSTANCES_MICRO, AdditiveGroup)
derivingUnbox "NominalDiffTime" [t| NominalDiffTime -> Micro |]
[| \ (NominalDiffTime a) -> a |] [| NominalDiffTime |]
#if SHOW_INTERNAL
deriving instance Show NominalDiffTime
deriving instance Read NominalDiffTime
#else
instance Show NominalDiffTime where
{-# INLINEABLE showsPrec #-}
showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest)
instance Read NominalDiffTime where
{-# INLINEABLE readPrec #-}
readPrec = return (const . NominalDiffTime) `ap` readPrec `ap` lift (char 's')
#endif
instance VectorSpace NominalDiffTime where
type Scalar NominalDiffTime = Rational
{-# INLINE (*^) #-}
(*^) = \ s (NominalDiffTime t) -> NominalDiffTime (s *^ t)
instance HasBasis NominalDiffTime where
type Basis NominalDiffTime = ()
{-# INLINE basisValue #-}
basisValue = \ _ -> NominalDiffTime (basisValue ())
{-# INLINE decompose #-}
decompose = \ (NominalDiffTime a) -> decompose a
{-# INLINE decompose' #-}
decompose' = \ (NominalDiffTime a) -> decompose' a
instance TimeDiff NominalDiffTime where
{-# INLINE microseconds #-}
microseconds = iso (\ (NominalDiffTime (Micro u)) -> u) (NominalDiffTime . Micro)
{-# INLINE posixDayLength #-}
posixDayLength :: NominalDiffTime
posixDayLength = microseconds # 86400000000
newtype UniversalTime = UniversalRep NominalDiffTime deriving (INSTANCES_MICRO)
derivingUnbox "UniversalTime" [t| UniversalTime -> NominalDiffTime |]
[| \ (UniversalRep a) -> a |] [| UniversalRep |]
{-# INLINE modJulianDate #-}
modJulianDate :: Iso' UniversalTime Rational
modJulianDate = iso
(\ (UniversalRep t) -> toSeconds t / toSeconds posixDayLength)
(UniversalRep . (*^ posixDayLength))
newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO)
derivingUnbox "UTCTime" [t| UTCTime -> NominalDiffTime |]
[| \ (UTCRep a) -> a |] [| UTCRep |]
data UTCView = UTCTime
{ utctDay :: {-# UNPACK #-}!Day
, utctDayTime :: {-# UNPACK #-}!DiffTime
} deriving (INSTANCES_USUAL, Show)
derivingUnbox "UTCView" [t| UTCView -> (Day, DiffTime) |]
[| \ UTCTime {..} -> (utctDay, utctDayTime) |]
[| \ (utctDay, utctDayTime) -> UTCTime {..} |]
instance NFData UTCView
_utctDay :: Lens' UTCTime Day
_utctDay = utcTime . lens utctDay (\ (UTCTime _ t) d -> UTCTime d t)
_utctDayTime :: Lens' UTCTime DiffTime
_utctDayTime = utcTime . lens utctDayTime (\ (UTCTime d _) t -> UTCTime d t)
instance AffineSpace UTCTime where
type Diff UTCTime = NominalDiffTime
{-# INLINE (.-.) #-}
(.-.) = \ (UTCRep a) (UTCRep b) -> a ^-^ b
{-# INLINE (.+^) #-}
(.+^) = \ (UTCRep a) d -> UTCRep (a ^+^ d)
{-# INLINE utcTime #-}
utcTime :: Iso' UTCTime UTCView
utcTime = iso toView fromView where
NominalDiffTime posixDay@(Micro uPosixDay) = posixDayLength
{-# INLINE toView #-}
toView :: UTCTime -> UTCView
toView (UTCRep (NominalDiffTime a)) = UTCTime
(ModifiedJulianDay mjd) (DiffTime dt) where
(fromIntegral -> mjd, dt) = microDivMod a posixDay
{-# INLINE fromView #-}
fromView :: UTCView -> UTCTime
fromView (UTCTime (ModifiedJulianDay mjd) (DiffTime dt)) = UTCRep a where
a = NominalDiffTime (Micro (fromIntegral mjd * uPosixDay) ^+^ dt)