{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE PatternSynonyms #-}
#endif
{-# 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.Hashable
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
type Hour = Int
type Minute = Int
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 :: forall t n. (TimeDiff t, Fractional n) => t -> n
toSeconds = (forall a. Num a => a -> a -> a
* forall a. Fractional a => a -> a
recip n
1000000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting a s a -> s -> a
view forall t. TimeDiff t => Iso' t Int64
microseconds
{-# INLINE[0] fromSeconds #-}
fromSeconds :: (Real n, TimeDiff t) => n -> t
fromSeconds :: forall n t. (Real n, TimeDiff t) => n -> t
fromSeconds = forall t. TimeDiff t => Rational -> t
fromSeconds' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Real a => a -> Rational
toRational
{-# INLINE toSeconds' #-}
toSeconds' :: (TimeDiff t) => t -> Rational
toSeconds' :: forall t. TimeDiff t => t -> Rational
toSeconds' = (forall v. HasBasis v => v -> Basis v -> Scalar v
`decompose'` ())
{-# INLINE fromSeconds' #-}
fromSeconds' :: (TimeDiff t) => Rational -> t
fromSeconds' :: forall t. TimeDiff t => Rational -> t
fromSeconds' = (forall v. VectorSpace v => Scalar v -> v -> v
*^ forall v. HasBasis v => Basis v -> v
basisValue ())
{-# INLINE fromSecondsRealFrac #-}
fromSecondsRealFrac :: (RealFrac n, TimeDiff t) => n -> n -> t
fromSecondsRealFrac :: forall n t. (RealFrac n, TimeDiff t) => n -> n -> t
fromSecondsRealFrac n
_ = forall s t a b. AReview s t a b -> b -> t
review forall t. TimeDiff t => Iso' t Int64
microseconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
(*) n
1000000
{-# INLINE fromSecondsIntegral #-}
fromSecondsIntegral :: (Integral n, TimeDiff t) => n -> n -> t
fromSecondsIntegral :: forall n t. (Integral n, TimeDiff t) => n -> n -> t
fromSecondsIntegral n
_ = forall s t a b. AReview s t a b -> b -> t
review forall t. TimeDiff t => Iso' t Int64
microseconds forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
(*) Int64
1000000 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
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 :: Hour -> DiffTime -> ShowS
showsPrec Hour
p (DiffTime Micro
a) = forall a. Show a => Hour -> a -> ShowS
showsPrec Hour
p Micro
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) Char
's'
instance Read DiffTime where
{-# INLINEABLE readPrec #-}
readPrec :: ReadPrec DiffTime
readPrec = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> DiffTime
DiffTime) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall a. Read a => ReadPrec a
readPrec forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall a. ReadP a -> ReadPrec a
lift (Char -> ReadP Char
char Char
's')
#endif
instance VectorSpace DiffTime where
type Scalar DiffTime = Rational
{-# INLINE (*^) #-}
*^ :: Scalar DiffTime -> DiffTime -> DiffTime
(*^) = \ Scalar DiffTime
s (DiffTime Micro
t) -> Micro -> DiffTime
DiffTime (Scalar DiffTime
s forall v. VectorSpace v => Scalar v -> v -> v
*^ Micro
t)
instance HasBasis DiffTime where
type Basis DiffTime = ()
{-# INLINE basisValue #-}
basisValue :: Basis DiffTime -> DiffTime
basisValue = \ Basis DiffTime
_ -> Micro -> DiffTime
DiffTime (forall v. HasBasis v => Basis v -> v
basisValue ())
{-# INLINE decompose #-}
decompose :: DiffTime -> [(Basis DiffTime, Scalar DiffTime)]
decompose = \ (DiffTime Micro
a) -> forall v. HasBasis v => v -> [(Basis v, Scalar v)]
decompose Micro
a
{-# INLINE decompose' #-}
decompose' :: DiffTime -> Basis DiffTime -> Scalar DiffTime
decompose' = \ (DiffTime Micro
a) -> forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' Micro
a
instance TimeDiff DiffTime where
{-# INLINE microseconds #-}
microseconds :: Iso' DiffTime Int64
microseconds = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\ (DiffTime (Micro Int64
u)) -> Int64
u) (Micro -> DiffTime
DiffTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Micro
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 :: Hour -> NominalDiffTime -> ShowS
showsPrec Hour
p (NominalDiffTime Micro
a) String
rest = forall a. Show a => Hour -> a -> ShowS
showsPrec Hour
p Micro
a (Char
's' forall a. a -> [a] -> [a]
: String
rest)
instance Read NominalDiffTime where
{-# INLINEABLE readPrec #-}
readPrec :: ReadPrec NominalDiffTime
readPrec = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. Micro -> NominalDiffTime
NominalDiffTime) forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall a. Read a => ReadPrec a
readPrec forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
`ap` forall a. ReadP a -> ReadPrec a
lift (Char -> ReadP Char
char Char
's')
#endif
instance VectorSpace NominalDiffTime where
type Scalar NominalDiffTime = Rational
{-# INLINE (*^) #-}
*^ :: Scalar NominalDiffTime -> NominalDiffTime -> NominalDiffTime
(*^) = \ Scalar NominalDiffTime
s (NominalDiffTime Micro
t) -> Micro -> NominalDiffTime
NominalDiffTime (Scalar NominalDiffTime
s forall v. VectorSpace v => Scalar v -> v -> v
*^ Micro
t)
instance HasBasis NominalDiffTime where
type Basis NominalDiffTime = ()
{-# INLINE basisValue #-}
basisValue :: Basis NominalDiffTime -> NominalDiffTime
basisValue = \ Basis NominalDiffTime
_ -> Micro -> NominalDiffTime
NominalDiffTime (forall v. HasBasis v => Basis v -> v
basisValue ())
{-# INLINE decompose #-}
decompose :: NominalDiffTime
-> [(Basis NominalDiffTime, Scalar NominalDiffTime)]
decompose = \ (NominalDiffTime Micro
a) -> forall v. HasBasis v => v -> [(Basis v, Scalar v)]
decompose Micro
a
{-# INLINE decompose' #-}
decompose' :: NominalDiffTime -> Basis NominalDiffTime -> Scalar NominalDiffTime
decompose' = \ (NominalDiffTime Micro
a) -> forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' Micro
a
instance TimeDiff NominalDiffTime where
{-# INLINE microseconds #-}
microseconds :: Iso' NominalDiffTime Int64
microseconds = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\ (NominalDiffTime (Micro Int64
u)) -> Int64
u) (Micro -> NominalDiffTime
NominalDiffTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Micro
Micro)
{-# INLINE posixDayLength #-}
posixDayLength :: NominalDiffTime
posixDayLength :: NominalDiffTime
posixDayLength = forall t. TimeDiff t => Iso' t Int64
microseconds forall s t a b. AReview s t a b -> b -> t
# Int64
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' UniversalTime Rational
modJulianDate = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso
(\ (UniversalRep NominalDiffTime
t) -> forall t n. (TimeDiff t, Fractional n) => t -> n
toSeconds NominalDiffTime
t forall a. Fractional a => a -> a -> a
/ forall t n. (TimeDiff t, Fractional n) => t -> n
toSeconds NominalDiffTime
posixDayLength)
(NominalDiffTime -> UniversalTime
UniversalRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall v. VectorSpace v => Scalar v -> v -> v
*^ NominalDiffTime
posixDayLength))
#if __GLASGOW_HASKELL__ >= 710
pattern UniversalTime :: Rational -> UniversalTime
pattern $bUniversalTime :: Rational -> UniversalTime
$mUniversalTime :: forall {r}. UniversalTime -> (Rational -> r) -> ((# #) -> r) -> r
UniversalTime mjd <- (view modJulianDate -> mjd) where
UniversalTime Rational
mjd = Iso' UniversalTime Rational
modJulianDate forall s t a b. AReview s t a b -> b -> t
# Rational
mjd
#elif __GLASGOW_HASKELL__ >= 708
pattern UniversalTime mjd <- (view modJulianDate -> mjd)
#endif
newtype UTCTime = UTCRep NominalDiffTime deriving (INSTANCES_MICRO)
derivingUnbox "UTCTime" [t| UTCTime -> NominalDiffTime |]
[| \ (UTCRep a) -> a |] [| UTCRep |]
data UTCView = UTCView
{ UTCView -> Day
utcvDay :: {-# UNPACK #-}!Day
, UTCView -> DiffTime
utcvDayTime :: {-# UNPACK #-}!DiffTime
} deriving (INSTANCES_USUAL, Show)
LENS(UTCView,utcvDay,Day)
LENS(UTCView,utcvDayTime,DiffTime)
derivingUnbox "UTCView" [t| UTCView -> (Day, DiffTime) |]
[| \ UTCView {..} -> (utcvDay, utcvDayTime) |]
[| \ (utcvDay, utcvDayTime) -> UTCView {..} |]
instance Hashable UTCView
instance NFData UTCView
_utctDay :: Lens' UTCTime Day
_utctDay :: Lens' UTCTime Day
_utctDay = Iso' UTCTime UTCView
utcTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens UTCView -> Day
utcvDay
(\ UTCView {Day
DiffTime
utcvDayTime :: DiffTime
utcvDay :: Day
utcvDayTime :: UTCView -> DiffTime
utcvDay :: UTCView -> Day
..} Day
d -> Day -> DiffTime -> UTCView
UTCView Day
d DiffTime
utcvDayTime)
_utctDayTime :: Lens' UTCTime DiffTime
_utctDayTime :: Lens' UTCTime DiffTime
_utctDayTime = Iso' UTCTime UTCView
utcTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens UTCView -> DiffTime
utcvDayTime
(\ UTCView {Day
DiffTime
utcvDayTime :: DiffTime
utcvDay :: Day
utcvDayTime :: UTCView -> DiffTime
utcvDay :: UTCView -> Day
..} DiffTime
t -> Day -> DiffTime -> UTCView
UTCView Day
utcvDay DiffTime
t)
utctDay :: UTCTime -> Day
utctDay :: UTCTime -> Day
utctDay = forall a s. Getting a s a -> s -> a
view Lens' UTCTime Day
_utctDay
utctDayTime :: UTCTime -> DiffTime
utctDayTime :: UTCTime -> DiffTime
utctDayTime = forall a s. Getting a s a -> s -> a
view Lens' UTCTime DiffTime
_utctDayTime
instance AffineSpace UTCTime where
type Diff UTCTime = NominalDiffTime
{-# INLINE (.-.) #-}
.-. :: UTCTime -> UTCTime -> Diff UTCTime
(.-.) = \ (UTCRep NominalDiffTime
a) (UTCRep NominalDiffTime
b) -> NominalDiffTime
a forall v. AdditiveGroup v => v -> v -> v
^-^ NominalDiffTime
b
{-# INLINE (.+^) #-}
.+^ :: UTCTime -> Diff UTCTime -> UTCTime
(.+^) = \ (UTCRep NominalDiffTime
a) Diff UTCTime
d -> NominalDiffTime -> UTCTime
UTCRep (NominalDiffTime
a forall v. AdditiveGroup v => v -> v -> v
^+^ Diff UTCTime
d)
{-# INLINE utcTime #-}
utcTime :: Iso' UTCTime UTCView
utcTime :: Iso' UTCTime UTCView
utcTime = forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso UTCTime -> UTCView
toView UTCView -> UTCTime
fromView where
NominalDiffTime posixDay :: Micro
posixDay@(Micro Int64
uPosixDay) = NominalDiffTime
posixDayLength
{-# INLINE toView #-}
toView :: UTCTime -> UTCView
toView :: UTCTime -> UTCView
toView (UTCRep (NominalDiffTime Micro
a)) = Day -> DiffTime -> UTCView
UTCView
(Hour -> Day
ModifiedJulianDay Hour
mjd) (Micro -> DiffTime
DiffTime Micro
dt) where
(forall a b. (Integral a, Num b) => a -> b
fromIntegral -> Hour
mjd, Micro
dt) = Micro -> Micro -> (Int64, Micro)
microDivMod Micro
a Micro
posixDay
{-# INLINE fromView #-}
fromView :: UTCView -> UTCTime
fromView :: UTCView -> UTCTime
fromView (UTCView (ModifiedJulianDay Hour
mjd) (DiffTime Micro
dt)) = NominalDiffTime -> UTCTime
UTCRep NominalDiffTime
a where
a :: NominalDiffTime
a = Micro -> NominalDiffTime
NominalDiffTime (Int64 -> Micro
Micro (forall a b. (Integral a, Num b) => a -> b
fromIntegral Hour
mjd forall a. Num a => a -> a -> a
* Int64
uPosixDay) forall v. AdditiveGroup v => v -> v -> v
^+^ Micro
dt)
#if __GLASGOW_HASKELL__ >= 710
pattern UTCTime :: Day -> DiffTime -> UTCTime
pattern $bUTCTime :: Day -> DiffTime -> UTCTime
$mUTCTime :: forall {r}. UTCTime -> (Day -> DiffTime -> r) -> ((# #) -> r) -> r
UTCTime d t <- (view utcTime -> UTCView d t) where
UTCTime Day
d DiffTime
t = Iso' UTCTime UTCView
utcTime forall s t a b. AReview s t a b -> b -> t
# Day -> DiffTime -> UTCView
UTCView Day
d DiffTime
t
#elif __GLASGOW_HASKELL__ >= 708
pattern UTCTime d t <- (view utcTime -> UTCView d t)
#endif
{-# INLINE mkUTCTime #-}
mkUTCTime :: Year -> Month -> DayOfMonth -> Hour -> Minute -> Double -> UTCTime
mkUTCTime :: Hour -> Hour -> Hour -> Hour -> Hour -> Double -> UTCTime
mkUTCTime Hour
yy Hour
mm Hour
dd Hour
h Hour
m Double
s = Iso' UTCTime UTCView
utcTime forall s t a b. AReview s t a b -> b -> t
# Day -> DiffTime -> UTCView
UTCView
(Iso' Day YearMonthDay
gregorian forall s t a b. AReview s t a b -> b -> t
# Hour -> Hour -> Hour -> YearMonthDay
YearMonthDay Hour
yy Hour
mm Hour
dd)
(forall n t. (Real n, TimeDiff t) => n -> t
fromSeconds (Hour
3600 forall a. Num a => a -> a -> a
* Hour
h forall a. Num a => a -> a -> a
+ Hour
60 forall a. Num a => a -> a -> a
* Hour
m) forall v. AdditiveGroup v => v -> v -> v
^+^ forall n t. (Real n, TimeDiff t) => n -> t
fromSeconds Double
s)