{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
#include "thyme.h"
module Data.Thyme.LocalTime where
import Prelude hiding ((.))
import Control.Applicative
import Control.Arrow
import Control.Category hiding (id)
import Control.DeepSeq
import Control.Lens
import Control.Monad
import Data.AffineSpace
import Data.Bits
import Data.Data
import Data.Int
import Data.Thyme.Internal.Micro
import Data.Thyme.Calendar
import Data.Thyme.Calendar.Internal
import Data.Thyme.Clock
import Data.Thyme.Clock.Internal
import Data.Thyme.Format.Internal
import qualified Data.Time as T
#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 hiding ((.&.))
type Minutes = Int
type Hours = Int
data TimeZone = TimeZone
{ timeZoneMinutes :: {-# UNPACK #-}!Minutes
, timeZoneSummerOnly :: !Bool
, timeZoneName :: String
} deriving (INSTANCES_USUAL)
instance NFData TimeZone
#if SHOW_INTERNAL
deriving instance Show TimeZone
#else
instance Show TimeZone where
show tz@TimeZone {..} = if null timeZoneName
then timeZoneOffsetString tz else timeZoneName
#endif
instance Bounded TimeZone where
minBound = TimeZone (-12 * 60) minBound "AAAA"
maxBound = TimeZone (13 * 60) maxBound "ZZZZ"
instance Random TimeZone where
randomR (l, u) g0 = (TimeZone minutes summer name, g3) where
(minutes, g1) = randomR (timeZoneMinutes l, timeZoneMinutes u) g0
(summer, g2) = randomR (timeZoneSummerOnly l, timeZoneSummerOnly u) g1
(name, g3) = foldr randChar ([], g2) . take 4 $ zip
(timeZoneName l ++ "AAAA") (timeZoneName u ++ "ZZZZ")
randChar nR (ns, g) = (: ns) `first` randomR nR g
random = randomR (minBound, maxBound)
instance Arbitrary TimeZone where
arbitrary = choose (minBound, maxBound)
shrink tz@TimeZone {..}
= [ tz {timeZoneSummerOnly = s} | s <- shrink timeZoneSummerOnly ]
++ [ tz {timeZoneMinutes = m} | m <- shrink timeZoneMinutes ]
++ [ tz {timeZoneName = n} | n <- shrink timeZoneName ]
instance CoArbitrary TimeZone where
coarbitrary (TimeZone m s n)
= coarbitrary m . coarbitrary s . coarbitrary n
{-# INLINEABLE timeZoneOffsetString #-}
timeZoneOffsetString :: TimeZone -> String
timeZoneOffsetString TimeZone {..} = sign : (shows02 h . shows02 m) "" where
(h, m) = divMod offset 60
(sign, offset) = if timeZoneMinutes < 0
then ('-', negate timeZoneMinutes) else ('+', timeZoneMinutes)
minutesToTimeZone :: Minutes -> TimeZone
minutesToTimeZone m = TimeZone m False ""
hoursToTimeZone :: Hours -> TimeZone
hoursToTimeZone i = minutesToTimeZone (60 * i)
utc :: TimeZone
utc = TimeZone 0 False "UTC"
{-# INLINEABLE getTimeZone #-}
getTimeZone :: UTCTime -> IO TimeZone
getTimeZone t = thyme `fmap` T.getTimeZone (T.UTCTime day $ toSeconds dt) where
day = T.ModifiedJulianDay (toInteger mjd)
UTCTime (ModifiedJulianDay mjd) dt = t ^. utcTime
thyme T.TimeZone {..} = TimeZone {..}
{-# INLINE getCurrentTimeZone #-}
getCurrentTimeZone :: IO TimeZone
getCurrentTimeZone = getCurrentTime >>= getTimeZone
type Hour = Int
type Minute = Int
data TimeOfDay = TimeOfDay
{ todHour :: {-# UNPACK #-}!Hour
, todMin :: {-# UNPACK #-}!Minute
, todSec :: {-# UNPACK #-}!DiffTime
} deriving (INSTANCES_USUAL)
derivingUnbox "TimeOfDay" [t| TimeOfDay -> Int64 |]
[| \ TimeOfDay {..} -> fromIntegral (todHour .|. shiftL todMin 8)
.|. shiftL (todSec ^. microseconds) 16 |]
[| \ n -> TimeOfDay (fromIntegral $ n .&. 0xff)
(fromIntegral $ shiftR n 8 .&. 0xff) (microseconds # shiftR n 16) |]
instance NFData TimeOfDay
#if SHOW_INTERNAL
deriving instance Show TimeOfDay
#else
instance Show TimeOfDay where
showsPrec _ (TimeOfDay h m (DiffTime s))
= shows02 h . (:) ':' . shows02 m . (:) ':'
. shows02 (fromIntegral si) . frac where
(si, Micro su) = microQuotRem s (Micro 1000000)
frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su
#endif
instance Bounded TimeOfDay where
minBound = TimeOfDay 0 0 zeroV
maxBound = TimeOfDay 23 59 (microseconds # 60999999)
instance Random TimeOfDay where
randomR = randomIsoR timeOfDay
random = first (^. timeOfDay) . random
instance Arbitrary TimeOfDay where
arbitrary = do
h <- choose (0, 23)
m <- choose (0, 59)
let DiffTime ml = minuteLength h m
TimeOfDay h m . DiffTime <$> choose (zeroV, pred ml)
shrink tod = view timeOfDay . (^+^) noon
<$> shrink (timeOfDay # tod ^-^ noon) where
noon = timeOfDay # midday
instance CoArbitrary TimeOfDay where
coarbitrary (TimeOfDay h m s)
= coarbitrary h . coarbitrary m . coarbitrary s
{-# INLINE minuteLength #-}
minuteLength :: Hour -> Minute -> DiffTime
minuteLength h m = fromSeconds' $ if h == 23 && m == 59 then 61 else 60
midnight :: TimeOfDay
midnight = TimeOfDay 0 0 zeroV
midday :: TimeOfDay
midday = TimeOfDay 12 0 zeroV
{-# INLINE makeTimeOfDayValid #-}
makeTimeOfDayValid :: Hour -> Minute -> DiffTime -> Maybe TimeOfDay
makeTimeOfDayValid h m s = TimeOfDay h m s
<$ guard (0 <= h && h <= 23 && 0 <= m && m <= 59)
<* guard (zeroV <= s && s < minuteLength h m)
{-# INLINE timeOfDay #-}
timeOfDay :: Iso' DiffTime TimeOfDay
timeOfDay = iso fromDiff toDiff where
{-# INLINEABLE fromDiff #-}
fromDiff :: DiffTime -> TimeOfDay
fromDiff (DiffTime t) = TimeOfDay
(fromIntegral h) (fromIntegral m) (DiffTime s) where
(h, ms) = microQuotRem t (Micro 3600000000)
(m, s) = microQuotRem ms (Micro 60000000)
{-# INLINEABLE toDiff #-}
toDiff :: TimeOfDay -> DiffTime
toDiff (TimeOfDay h m s) = s
^+^ fromIntegral m *^ DiffTime (Micro 60000000)
^+^ fromIntegral h *^ DiffTime (Micro 3600000000)
{-# INLINE addMinutes #-}
addMinutes :: Minutes -> TimeOfDay -> (Days, TimeOfDay)
addMinutes dm (TimeOfDay h m s) = (dd, TimeOfDay h' m' s) where
(dd, h') = divMod (h + dh) 24
(dh, m') = divMod (m + dm) 60
{-# INLINE dayFraction #-}
dayFraction :: Iso' TimeOfDay Rational
dayFraction = from timeOfDay . iso toRatio fromRatio where
{-# INLINEABLE toRatio #-}
toRatio :: DiffTime -> Rational
toRatio t = toSeconds t / toSeconds posixDayLength
{-# INLINEABLE fromRatio #-}
fromRatio :: Rational -> DiffTime
fromRatio ((*^ posixDayLength) -> NominalDiffTime r) = DiffTime r
data LocalTime = LocalTime
{ localDay :: {-# UNPACK #-}!Day
, localTimeOfDay :: {-# UNPACK #-}!TimeOfDay
} deriving (INSTANCES_USUAL)
derivingUnbox "LocalTime" [t| LocalTime -> (Day, TimeOfDay) |]
[| \ LocalTime {..} -> (localDay, localTimeOfDay) |]
[| \ (localDay, localTimeOfDay) -> LocalTime {..} |]
instance NFData LocalTime
#if SHOW_INTERNAL
deriving instance Show LocalTime
#else
instance Show LocalTime where
showsPrec p (LocalTime d t) = showsPrec p d . (:) ' ' . showsPrec p t
#endif
instance Bounded LocalTime where
minBound = minBound ^. utcLocalTime maxBound
maxBound = maxBound ^. utcLocalTime minBound
instance Random LocalTime where
randomR = randomIsoR (utcLocalTime utc)
random = randomR (minBound, maxBound)
instance Arbitrary LocalTime where
arbitrary = choose (minBound, maxBound)
shrink lt@LocalTime {..}
= [ lt {localDay = d} | d <- shrink localDay ]
++ [ lt {localTimeOfDay = d} | d <- shrink localTimeOfDay ]
instance CoArbitrary LocalTime where
coarbitrary (LocalTime d t) = coarbitrary d . coarbitrary t
{-# INLINE utcLocalTime #-}
utcLocalTime :: TimeZone -> Iso' UTCTime LocalTime
utcLocalTime TimeZone {..} = utcTime . iso localise globalise where
{-# INLINEABLE localise #-}
localise :: UTCView -> LocalTime
localise (UTCTime day dt) = LocalTime (day .+^ dd) tod where
(dd, tod) = addMinutes timeZoneMinutes (dt ^. timeOfDay)
{-# INLINEABLE globalise #-}
globalise :: LocalTime -> UTCView
globalise (LocalTime day tod) = UTCTime (day .+^ dd)
(timeOfDay # utcToD) where
(dd, utcToD) = addMinutes (negate timeZoneMinutes) tod
{-# INLINE ut1LocalTime #-}
ut1LocalTime :: Rational -> Iso' UniversalTime LocalTime
ut1LocalTime long = iso localise globalise where
NominalDiffTime posixDay@(Micro usDay) = posixDayLength
{-# INLINEABLE localise #-}
localise :: UniversalTime -> LocalTime
localise (UniversalRep (NominalDiffTime t)) = LocalTime
(ModifiedJulianDay $ fromIntegral day)
(DiffTime dt ^. timeOfDay) where
(day, dt) = microDivMod (t ^+^ (long / 360) *^ posixDay) posixDay
{-# INLINEABLE globalise #-}
globalise :: LocalTime -> UniversalTime
globalise (LocalTime day tod) = UniversalRep . NominalDiffTime $
Micro (mjd * usDay) ^+^ dt ^-^ (long / 360) *^ posixDay where
ModifiedJulianDay (fromIntegral -> mjd) = day
DiffTime dt = timeOfDay # tod
data ZonedTime = ZonedTime
{ zonedTimeToLocalTime :: {-# UNPACK #-}!LocalTime
, zonedTimeZone :: !TimeZone
} deriving (INSTANCES_USUAL)
instance NFData ZonedTime where
rnf ZonedTime {..} = rnf zonedTimeZone
instance Bounded ZonedTime where
minBound = ZonedTime minBound maxBound
maxBound = ZonedTime maxBound minBound
instance Random ZonedTime where
randomR (l, u) g0 = (view zonedTime . (,) tz)
`first` randomR (l', u') g1 where
(tz, g1) = random g0
l' = snd $ zonedTime # l
u' = snd $ zonedTime # u
random = randomR (minBound, maxBound)
instance Arbitrary ZonedTime where
arbitrary = choose (minBound, maxBound)
shrink zt@ZonedTime {..}
= [ zt {zonedTimeToLocalTime = lt} | lt <- shrink zonedTimeToLocalTime ]
++ [ zt {zonedTimeZone = tz} | tz <- shrink zonedTimeZone ]
instance CoArbitrary ZonedTime where
coarbitrary (ZonedTime lt tz) = coarbitrary lt . coarbitrary tz
{-# INLINE zonedTime #-}
zonedTime :: Iso' (TimeZone, UTCTime) ZonedTime
zonedTime = iso toZoned fromZoned where
{-# INLINE toZoned #-}
toZoned :: (TimeZone, UTCTime) -> ZonedTime
toZoned (tz, time) = ZonedTime (time ^. utcLocalTime tz) tz
{-# INLINE fromZoned #-}
fromZoned :: ZonedTime -> (TimeZone, UTCTime)
fromZoned (ZonedTime lt tz) = (tz, utcLocalTime tz # lt)
#if SHOW_INTERNAL
deriving instance Show ZonedTime
instance Show UTCTime where
showsPrec p = showsPrec p . view utcTime
#else
instance Show ZonedTime where
showsPrec p (ZonedTime lt tz) = showsPrec p lt . (:) ' ' . showsPrec p tz
instance Show UTCTime where
showsPrec p = showsPrec p . view zonedTime . (,) utc
#endif
{-# INLINE getZonedTime #-}
getZonedTime :: IO ZonedTime
getZonedTime = utcToLocalZonedTime =<< getCurrentTime
{-# INLINEABLE utcToLocalZonedTime #-}
utcToLocalZonedTime :: UTCTime -> IO ZonedTime
utcToLocalZonedTime time = do
tz <- getTimeZone time
return $ (tz, time) ^. zonedTime
LENS(TimeZone,timeZoneMinutes,Minutes)
LENS(TimeZone,timeZoneSummerOnly,Bool)
LENS(TimeZone,timeZoneName,String)
LENS(TimeOfDay,todHour,Hour)
LENS(TimeOfDay,todMin,Minute)
LENS(TimeOfDay,todSec,DiffTime)
LENS(LocalTime,localDay,Day)
LENS(LocalTime,localTimeOfDay,TimeOfDay)
LENS(ZonedTime,zonedTimeToLocalTime,LocalTime)
LENS(ZonedTime,zonedTimeZone,TimeZone)