hora-2.2.1: src/Data/Time/Hora/Part.hs
-- | convert between 'C.UTCTime', 'UTCTimeBin', 'DatePart', 'DatePartSmall'
module Data.Time.Hora.Part
(-- * FromUTC
FromUTC(..),
fromUtc',
-- * ToUTC
ToUTC(..),
-- * 'DatePartSmall'
mkDay,
mkMin,
mkMs,
toSmall,
normalize,
julian_day_offset
) where
import Data.Fixed
import Data.Ratio
import Data.Word
import Data.Time.Calendar as C
import Data.Time.Clock as C
import Data.Time.Hora.Internal.DatePartSmall as S
import Data.Time.Hora.Internal.Span as S
import Data.Time.Hora.Span
import Data.Time.Hora.Type as T
import Data.Time.LocalTime as L
import Data.Time.Hora.Internal.FromIntegral (fi)
-- | convert 'C.UTCTime' to implemented types
class FromUTC a where
fromUtc :: UTCTime -> a
-- | returns DatePart a in UTC timezone
instance Integral a => FromUTC (DatePart a) where
fromUtc :: Integral a => UTCTime -> DatePart a
fromUtc t0 =
let day1 = utctDay t0 :: Day
dt1 = utctDayTime t0 :: DiffTime
(y1,m1,d1) = toGregorian day1
(tod1, sec5, pico5) = todSecPico dt1
in DatePart {
year = fi y1,
month = fi m1,
day = fi d1,
hour = fi $ todHour tod1,
minute = fi $ todMin tod1,
second = fi sec5,
pico = fi pico5
}
-- | extract ('TimeOfDay', seconds, picoseconds) from 'DiffTime'
todSecPico :: Integral a => DiffTime -> (TimeOfDay, a, Integer)
todSecPico dt0 = (tod1, sec5, pico5)
where tod1 = timeToTimeOfDay dt0 :: TimeOfDay
pico4 = todSec tod1 :: Fixed E12
(sec5, MkFixed pico5) = properFraction pico4
diffTime :: Int -- ^ hour
-> Int -- ^ minute
-> Fixed E12 -- ^ pico
-> DiffTime
diffTime h0 m0 p0 = timeOfDayToTime tod1
where tod1 = TimeOfDay h0 m0 p0
instance FromUTC UTCTimeBin where
fromUtc :: UTCTime -> UTCTimeBin
fromUtc t0 = UTCTimeBin day1 pico1
where day1 = toModifiedJulianDay $ utctDay t0
pico1 = diffTimeToPicoseconds $ utctDayTime t0
instance FromUTC DatePartSmall where
fromUtc :: UTCTime -> DatePartSmall
fromUtc t0 = DatePartSmall day2 minute2 milli2
where dp1 = fromUtc t0 :: DatePart Int
UTCTimeBin julian1 _ = fromUtc t0 :: UTCTimeBin
day2 = fi julian1 + julian_day_offset
minute2 = fi $ hour dp1 * 60 + minute dp1
milli2 = fromSec3 + fromPico3
fromSec3 = toMilli (Sec $ second dp1) :: Word32
fromPico3 = toMilli $ Pico $ pico dp1 :: Word32
{- | specified time zone
Tz (DatePart a) parts show local date & time
see also "Data.Time.Hora.Zone" -}
fromUtc' :: (Tz' tz, Integral a) =>
tz -> UTCTime -> Tz (DatePart a)
fromUtc' tz0 utc0 =
let tz1 = tz' tz0 utc0
lt2 = L.utcToLocalTime tz1 utc0
day2 = localDay lt2
time2 = localTimeOfDay lt2
(y3,m3,d3) = toGregorian day2
d4 = DatePart{
year = fi y3,
month = fi m3,
day = fi d3,
hour = fi $ todHour time2,
minute = fi $ todMin time2,
second = fi sec5,
pico = fi pico5
}
pico4 = todSec time2 :: Fixed E12
(sec5, MkFixed pico5) = properFraction pico4
in Tz tz1 d4
{-| convert 'DatePart' -> 'C.UTCTime'
Invalid date returns Nothing -}
class ToUTC a where
toUtc :: a -> Maybe UTCTime
instance Integral a => ToUTC (DatePart a) where
toUtc dp0 =
let h1 = hour dp0 * 60 * 60 -- as second
min1 = minute dp0 * 60 -- as second
s2 = second dp0 + h1 + min1
diff1 = secondsToDiffTime $ fi s2
diff2 = picosecondsToDiffTime $ fi $ pico dp0
mday1 = fromGregorianValid (fi $ year dp0)
(fi $ month dp0) $ fi $ day dp0
in mday1 >>= \day1 -> Just $ UTCTime day1 $ diff1 + diff2
-- ^ assumes DatePart is UTC
instance Integral a => ToUTC (Tz (DatePart a)) where
toUtc (Tz tz0 dp0) =
let s1 = toPico $ Sec $ second dp0
mtod1 = makeTimeOfDayValid (fi $ hour dp0)
(fi $ minute dp0)
(timeSpanPico $
Pico s1 +
(Pico $ fi $ pico dp0)
)
mday1 :: Maybe C.Day = fromGregorianValid
(fi $ year dp0)
(fi $ month dp0)
(fi $ day dp0)
in mday1 >>= \day1 ->
mtod1 >>= \tod1 ->
let lt1 = LocalTime day1 tod1
zt1 = ZonedTime lt1 tz0
in Just $ zonedTimeToUTC zt1
instance ToUTC UTCTimeBin where
toUtc (UTCTimeBin day0 pico0) = Just $ UTCTime day1 diff1
where day1 = ModifiedJulianDay day0
diff1 = picosecondsToDiffTime pico0
instance ToUTC DatePartSmall where
toUtc dp0@(DatePartSmall _ _ _) = Just utc1
where (DatePartSmall d0 m0 ms0) = normalize dp0
utc1 = UTCTime day2 diff2
day2 = ModifiedJulianDay day1
where day1 = fi d0 - julian_day_offset :: Integer
diff2 = diffTime hr1 min1 pico2
where min1 = fi $ m0 `rem` 60
hr1 = fi $ m0 `div` 60
pico2 = sec2 + pico1
where sec2 = MkFixed $ sec1 * picoSec :: Fixed E12
pico1 = fromRational $ (ms1 `rem` 1000) % 1000 :: Fixed E12
ms1 = fi ms0 :: Integer
sec1 = fi $ ms0 `div` 1000
toUtc _ = Nothing
{- | Julian day offset
https://en.wikipedia.org/wiki/Julian_day
>>> mkDay 1 1 1 `shouldBe` (Day 1)
>>> mkDay 1858 11 17 `shouldBe` (Day julian_day_offset)
-}
julian_day_offset :: Integral a => a
julian_day_offset = fi 678576
-- | convert 'DatePart' to 'DatePartSmall' with some loss of precision
toSmall :: Integral a =>
DatePart a -> DatePartSmall
toSmall DatePart{..} =
let S.Day d = mkDay year month day
S.Min m = mkMin hour minute
S.Ms ms = mkMs second $ toMilli $ Pico pico
in DatePartSmall d m ms
-- | day / date
mkDay :: Integral a =>
a -- ^ year
-> a -- ^ month
-> a -- ^ day
-> DatePartSmall -- ^ 'T.Day'
mkDay y0 m0 d0 = maybe (Error Invalid) id mday2
where mday2 = valid2 <$> mday1 :: Maybe DatePartSmall
mday1 :: Maybe C.Day = fromGregorianValid y1 m1 d1
valid2 = T.Day . fi . (+ julian_day_offset) . toModifiedJulianDay
y1 = fi y0
m1 = fi m0
d1 = fi d0
-- | minutes including hours
mkMin :: (Num a, Integral a) =>
a -- ^ hour
-> a -- ^ minute
-> DatePartSmall -- ^ 'Min'
mkMin h0 m0 = Min $ fi $ h0 * 60 + m0
-- | milliseconds including seconds
mkMs :: (Num a, Integral a) =>
a -- ^ second
-> a -- ^ millisecond
-> DatePartSmall -- ^ 'Ms'
mkMs s0 ms0 = Ms $ fi $ toMilli (Sec s0) + ms0
{- | for ('Time', 'DatePartSmall') increase:
minutes if seconds > 60
days if minutes > 24 * 60
! does not change the constructor. 'Time' remains 'Time'
this function is called by 'toUtc' before the conversion
-}
normalize :: DatePartSmall -> DatePartSmall
normalize dp0
| (Time m1 ms1) <- dp0,
ms2 :: Int <- fi ms1,
sec1 <- ts ms2,
sec1 >= 60
= let m3 = (sec1 `div` 60) + (fi m1::Int)
sec2 = sec1 `rem` 60
ms3 = (tm sec2) + ms2 - (tm sec1)
in Time (fi m3) $ fi ms3
| (DatePartSmall d1 m1 ms1) <- dp0,
ms2 :: Int <- fi ms1,
sec1 <- ts ms2,
sec1 >= 60
= let Time m2 ms2 = normalize $ Time m1 ms1
in normalize $ DatePartSmall d1 m2 ms2
| (DatePartSmall d1 m1 ms1) <- dp0,
m2 <- fi m1::Int,
hr1 <- m2 `div` 60,
hr1 >= 24
= let d2 = hr1 `div` 24 + (fi d1)
hr2 = hr1 `rem` 24
m3 = m2 `rem` 60 + hr2 * 60
in DatePartSmall (fi d2) (fi m3) ms1
| otherwise = dp0
where ts :: Integral a => a -> a
ts = toSec . Milli
tm :: Integral a => a -> a
tm = toMilli . Sec