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.Micro
import Data.Thyme.Calendar
import Data.VectorSpace
#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 ~ ()) => TimeDiff t where
microTimeDiff :: t -> Micro
instance TimeDiff DiffTime where microTimeDiff (DiffTime d) = d
instance TimeDiff NominalDiffTime where microTimeDiff (NominalDiffTime d) = d
seconds :: (HasBasis s, Basis s ~ (), HasBasis t, Basis t ~ ()) => Iso s t (Scalar s) (Scalar t)
seconds = iso (`decompose'` ()) (*^ basisValue ())
toSeconds :: (TimeDiff s, Real (Scalar s), Fractional n) => s -> n
toSeconds = realToFrac . simply view seconds
fromSeconds :: (TimeDiff t, Real n, Fractional (Scalar t)) => n -> t
fromSeconds = simply review seconds . realToFrac
toSeconds' :: (HasBasis s, Basis s ~ ()) => s -> Scalar s
toSeconds' = simply view seconds
fromSeconds' :: (HasBasis t, Basis t ~ ()) => Scalar t -> t
fromSeconds' = simply review seconds
newtype DiffTime = DiffTime Micro
deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)
#if SHOW_INTERNAL
deriving instance Show DiffTime
deriving instance Read DiffTime
#else
instance Show DiffTime where
showsPrec p (DiffTime a) = showsPrec p a . (:) 's'
instance Read DiffTime where
readPrec = return (const . DiffTime) `ap` readPrec `ap` lift (char 's')
#endif
instance VectorSpace DiffTime where
type Scalar DiffTime = Rational
s *^ DiffTime t = DiffTime (s *^ t)
instance HasBasis DiffTime where
type Basis DiffTime = ()
basisValue () = DiffTime (basisValue ())
decompose (DiffTime a) = decompose a
decompose' (DiffTime a) = decompose' a
microDiffTime :: Iso' Int64 DiffTime
microDiffTime = iso (DiffTime . Micro) (\ (DiffTime (Micro u)) -> u)
newtype NominalDiffTime = NominalDiffTime Micro
deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable, AdditiveGroup)
#if SHOW_INTERNAL
deriving instance Show NominalDiffTime
deriving instance Read NominalDiffTime
#else
instance Show NominalDiffTime where
showsPrec p (NominalDiffTime a) rest = showsPrec p a ('s' : rest)
instance Read NominalDiffTime where
readPrec = return (const . NominalDiffTime) `ap` readPrec `ap` lift (char 's')
#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
microNominalDiffTime :: Iso' Int64 NominalDiffTime
microNominalDiffTime = iso (NominalDiffTime . Micro)
(\ (NominalDiffTime (Micro u)) -> u)
posixDayLength :: NominalDiffTime
posixDayLength = NominalDiffTime (toMicro 86400)
newtype UniversalTime = UniversalRep NominalDiffTime
deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)
modJulianDate :: Iso' UniversalTime Rational
modJulianDate = iso ( \ (UniversalRep t) ->
simply view seconds t / simply view seconds posixDayLength )
(UniversalRep . (*^ posixDayLength))
newtype UTCTime = UTCRep NominalDiffTime
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 :: 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
UTCRep a .-. UTCRep b = a ^-^ b
UTCRep a .+^ d = UTCRep (a ^+^ d)
utcTime :: Iso' UTCTime UTCView
utcTime = iso toView fromView where
NominalDiffTime posixDay@(Micro uPosixDay) = posixDayLength
toView :: UTCTime -> UTCView
toView (UTCRep (NominalDiffTime a)) = UTCTime
(ModifiedJulianDay mjd) (DiffTime dt) where
(fromIntegral -> mjd, dt) = microDivMod a posixDay
fromView :: UTCView -> UTCTime
fromView (UTCTime (ModifiedJulianDay mjd) (DiffTime dt)) = UTCRep a where
a = NominalDiffTime (Micro (fromIntegral mjd * uPosixDay) ^+^ dt)