diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,6 @@ +##### 2.2.0 + add DatePartSmall + ##### 2.1.0 add serializeable UTCTimeBin: close copy of UTCTime. @@ -5,7 +8,6 @@ fromUTC is now a class function. It may be necessary to specify the result type. -##### 2.0.3 Tz derive Eq, Ord ##### 2.0.2 diff --git a/hora.cabal b/hora.cabal --- a/hora.cabal +++ b/hora.cabal @@ -1,5 +1,5 @@ name: hora -version: 2.1.0 +version: 2.2.0 build-type: Simple cabal-version: >=1.10 @@ -32,7 +32,11 @@ Data.Time.Hora.Zone Data.Time.Hora.Some - ghc-options: -fwarn-unused-imports + other-modules: + Data.Time.Hora.Internal.Span + Data.Time.Hora.Internal.DatePartSmall + Data.Time.Hora.Internal.Pad + ghc-options: -fwarn-unused-imports build-depends: base >=4.7 && <5.0, time, @@ -102,6 +106,16 @@ Test.TestSome Test.TestFormat Test.TestUTCTimeBin + Test.TestAncientDate + Test.TestDatePartSmall + Test.TestStorageSize + Test.TestDatePartSmallConvert + Test.TestRoundtripPicoMilli + Test.TestDatePartSmallDoc + Data.Time.Hora.Internal.Span + Data.Time.Hora.Internal.DatePartSmall + Test.TestCheckOverflow + Data.Time.Hora.Internal.Pad build-depends: base >= 4.8, hspec >= 2.1.7, QuickCheck >= 2.8.1, diff --git a/src/Data/Time/Hora/Format.hs b/src/Data/Time/Hora/Format.hs --- a/src/Data/Time/Hora/Format.hs +++ b/src/Data/Time/Hora/Format.hs @@ -3,13 +3,18 @@ Format(..), -- * format format, - format') where + format', + show') where +import Data.Maybe import Data.String import Data.Time.Clock import Data.Time.Format (formatTime,defaultTimeLocale,FormatTime(..)) -import Data.Time.Hora.Type +import Data.Time.Hora.Type hiding (Min) import Data.Time.LocalTime as L +import Data.Time.Hora.Part +import qualified Data.Time.Hora.Internal.DatePartSmall as S +import Data.Time.Hora.Internal.Pad -- | format as UTC @@ -114,3 +119,67 @@ D_week -> "%A" Wk_year_Sun -> "%U" Wk_year_Mon -> "%W" + + + +{- | pretty print 'DatePartSmall' + +incremental values are prefixed with + or - + +>>> show' $ mkDay 2018 08 17 + 2018-08-17 + +>>> show' $ mkMin 4 3 + 04:03 + +>>> show' $ mkMs 7 318 + 07.318 + +>>> let (Day d1) = mkDay 2018 08 17 + (Min m1) = mkMin 15 17 + (Ms ms1) = mkMs 7 358 + show' $ DatePartSmall d1 m1 ms1 + 2018-08-17 15:17:07.358 + +>>> show' $ Day' 3 + +3 + +>>> show' $ toSpan $ mkMin 0 53 + +00:53 + +>>> show' $ toSpan $ mkMs 7 0 + +07.000 + +>>> show' $ T.negate $ Day' 3 + -3 + +>>> show' $ T.negate $ toSpan $ mkMin 14 53 + -14:53 +-} +show'::DatePartSmall -> String +show' dp0 + | (Day d0) <- dp0 + = format [Y_m_d] $ fromJust $ toUtc $ DatePartSmall d0 0 0 + | (Day' d0) <- dp0 + = "+" <> (show d0) + | (S.Min m0) <- dp0 + = let hr1 = m0 `div` 60 + min1 = m0 `rem` 60 + in pad1 (show hr1) <> ":" <> pad1 (show min1) + | (S.Min' m0) <- dp0 + = "+" <> (show' $ S.Min m0) + | (S.Ms ms0) <- dp0 + = let sec1 = ms0 `div` 1000 + ms1 = ms0 `rem` 1000 + in pad1 (show sec1) <> "." <> (pad '0' 3 $ show ms1) + | (S.Ms' ms0) <- dp0 + = "+" <> (show' $ S.Ms ms0) + | (S.Time m0 ms0) <- dp0 + = show' (S.Min m0) <> ":" <> show' (S.Ms ms0) + | (S.DatePartSmall d0 m0 ms0) <- dp0 + = show' (S.Day d0) <> " " <> show' (S.Min m0) <> ":" <> show' (S.Ms ms0) + | (S.Neg dp0) <- dp0 + = let _:s1 = show' dp0 + in "-" <> s1 + | otherwise = show dp0 + where pad1 = pad '0' 2 diff --git a/src/Data/Time/Hora/Internal/DatePartSmall.hs b/src/Data/Time/Hora/Internal/DatePartSmall.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Hora/Internal/DatePartSmall.hs @@ -0,0 +1,257 @@ +module Data.Time.Hora.Internal.DatePartSmall where + +import Data.Binary +import Data.Time.Hora.Internal.Span +import GHC.Generics +import Prelude hiding (negate) + +{- | 'DatePartSmall' uses fixed-size storage. Storage (as encoded with "Data.Binary".encode) varies with the constructor used, is noted as \".. bytes\" against each constructor. + + allows to operate with dates only .. + + .. or time (minute / millisecond precision) only + + is convenient for dealing with intervals / timespans + + day count begins at 1 Jan 0001: 1 Jan 0001 is day 1 + + max date is: 11759222-01-19. That's 19 Jan 11759222 + + see "Data.Time.Hora.Part" for conversion between 'UTCTime' and 'DatePartSmall' + + only values constructed with 'DatePartSmall' can be converted to 'UTCTime' + -} +data DatePartSmall = Day Word32 {- ^ days after 31 Dec 1 BC: 1 Jan AD 1 is day 1. See https://en.wikipedia.org/wiki/Anno_Domini + + 5 bytes -} + | Min Word16 {- ^ minutes (includes hours) + + 3 bytes + -} + | Ms Word32 {- ^ milliseconds (includes seconds) + +5 bytes + -} + | Time Word16 Word32 {- ^ minutes, milliseconds + + 7 bytes + -} + | DatePartSmall Word32 Word16 Word32 {- ^ date, minutes, milliseconds + + 11 bytes + -} + | Day' Word32 {- ^ date span in days + + 5 bytes + -} + | Min' Word16 {- ^ time span in minutes + + 3 bytes + -} + | Ms' Word32 {- ^ time span in milliseconds + + 5 bytes + -} + | Neg DatePartSmall -- ^ negate. Hidden constructor + | Error ErrorDetail -- ^ result of failed operation + deriving (Eq, Show, Generic) + + +{- | substitutes constructor: + + 'Day' -> 'Day'' + + 'Min' -> 'Min'' + + 'Ms' -> 'Ms'' +-} +toSpan::DatePartSmall -> DatePartSmall +toSpan dp0 = case dp0 of + Day d1 -> Day' d1 + Min m1 -> Min' m1 + Ms ms1 -> Ms' ms1 + otherwise -> dp0 + +{- | adds hidden Neg constructor to 'Day'', 'Min'' or 'Ms'' +to enable negative spans -} +negate::DatePartSmall -> DatePartSmall +negate dp0 = case dp0 of + Neg dp1 -> dp1 + Day' d1 -> Neg dp0 + Min' m1 -> Neg dp0 + Ms' ms1 -> Neg dp0 + otherwise -> dp0 + +-- | checks if 'DatePartSmall' is a negative span +isNegative::DatePartSmall -> Bool +isNegative dp0 = case dp0 of + (Neg _) -> True + otherwise -> False + +data ErrorDetail = Invalid -- ^ operation is not possible with these constructors + | Overflow -- ^ data type maxed out + | Invalid_Overflow -- ^ 'Invalid' <> 'Overflow' + deriving (Eq, Show, Generic) + +instance Binary ErrorDetail +instance Binary DatePartSmall + +instance Semigroup DatePartSmall where +-- combine / merge + (<>) (Day d0) (Time m0 ms0) = DatePartSmall d0 m0 ms0 -- 1 + (<>) (Min m0) (Ms ms0) = Time m0 ms0 -- 2 + +-- increment + (<>) d1@(DatePartSmall _ _ _) d2@(Day' _) = incrDecr (+) d1 d2 -- 3 + (<>) d1@(DatePartSmall d0 m0 ms0) d2@(Min' m1) = incrDecr (+) d1 d2 -- 4 + (<>) d1@(DatePartSmall d0 m0 ms0) d2@(Ms' ms1) = incrDecr (+) d1 d2 -- 5 + (<>) d1@(Time m0 ms0) d2@(Min' m1) = incrDecr (+) d1 d2 -- 6 + (<>) d1@(Time m0 ms0) d2@(Ms' ms1) = incrDecr (+) d1 d2 -- 7 + + (<>) d1@(Day m0) d2@(Day' m1) = incrDecr (+) d1 d2 -- 8 + (<>) d1@(Min m0) d2@(Min' m1) = incrDecr (+) d1 d2 -- 9 + (<>) d1@(Ms m0) d2@(Ms' m1) = incrDecr (+) d1 d2 -- 10 + + (<>) d1@(Day' m0) d2@(Day' m1) = incrDecr (+) d1 d2 -- 8 + (<>) d1@(Min' m0) d2@(Min' m1) = incrDecr (+) d1 d2 -- 9 + (<>) d1@(Ms' m0) d2@(Ms' m1) = incrDecr (+) d1 d2 -- 10 + +-- decrement + (<>) (Neg d1) (Neg d2) = negate $ incrDecr (+) d1 d2 + (<>) d1 (Neg d2) = incrDecr (-) d1 d2 + +-- overwrite + (<>) (DatePartSmall _ _ _) (DatePartSmall d1 m1 ms1) = DatePartSmall d1 m1 ms1 -- 11 + (<>) (Time _ _) (Time m1 ms1) = Time m1 ms1 -- 12 + (<>) (Day _) (Day d1) = Day d1 -- 13 + (<>) (Min _) (Min m1) = Min m1 -- 14 + (<>) (Ms _) (Ms ms1) = Ms ms1 -- 15 +-- update + (<>) (DatePartSmall d0 _ _) (Time m1 ms1) = DatePartSmall d0 m1 ms1 -- 16 + (<>) (Time _ ms0) (Min m1) = Time m1 ms0 -- 17 + (<>) (Time m0 _) (Ms ms1) = Time m0 ms1 -- 18 +-- errors + (<>) (Error Invalid) (Error Invalid) = Error Invalid -- 19 + (<>) (Error Invalid) (Error Overflow) = Error Invalid_Overflow -- 20 + (<>) (Error Overflow) (Error Overflow) = Error Overflow -- 21 + (<>) (Error Overflow) (Error Invalid) = Error Invalid_Overflow -- 22 + (<>) (Error Invalid_Overflow) _ = Error Invalid_Overflow -- 23 + (<>) _ (Error Invalid_Overflow) = Error Invalid_Overflow -- 24 + (<>) e0@(Error _) _ = e0 -- 25 + (<>) _ e0@(Error _) = e0 -- 26 + (<>) _ _ = Error Invalid -- 27 + +{- ^ '<>' can be used both to combine parts (e.g. 'Day', 'Time') and + to add date/time span to the existing parts + + combining parts: + + 'Day' <> 'Time' -> 'DatePartSmall' + +>>> show' (mkDay 2018 08 20 <> mkMin 10 2 <> mkMs 30 9) +2018-08-20 10:02:30.009 + + 'Min' <> 'Ms' -> 'Time' + + adding span: + + 'Day' <> 'Day'' -> 'Day' + +>>> show' (mkDay 2018 1 1 <> Day' 20) +2018-01-21 + +>>> show' (mkDay 2018 1 1 <> Day' 180) +2018-06-30 + + 'Min' <> 'Min'' -> 'Min' + +>>> show' (mkMin 3 15 <> Min' 200) +06:35 + + 'Ms' <> 'Ms'' -> 'Ms' + +>>> show' $ normalize $ mkMin 14 59 <> mkMs 132 9 <> Ms' 5308 +15:01:17.317 + +when incrementing and decrementing, overflow is checked on both upper (max for Word16, Word32) and lower (0) bounds + +when incrementing, it is possible to normalize time by recalculating minutes from seconds, days from minutes. See 'normalize' in "Data.Time.Hora.Part" + +when decrementing, normalization is not yet implemented. todo +-} + +incrDecr::(Int -> Int -> Int) -- ^ op (+) (-) + -> DatePartSmall + -> DatePartSmall + -> DatePartSmall +incrDecr op0 dp1 dp2 + | (DatePartSmall d0 m0 ms0) <- dp1, + (Day' d1) <- dp2 + = checkOverflow + (\d2 -> DatePartSmall d2 m0 ms0) d0 op0 d1 -- 3 + + | (DatePartSmall d0 m0 ms0) <- dp1, + (Min' m1) <- dp2 + = checkOverflow + (\m2 -> DatePartSmall d0 m2 ms0) m0 op0 m1 -- 4 + + | (DatePartSmall d0 m0 ms0) <- dp1, + (Ms' ms1) <- dp2 + = checkOverflow + (DatePartSmall d0 m0) ms0 op0 ms1 -- 5 + + | (Time m0 ms0) <- dp1, + (Min' m1) <- dp2 + = checkOverflow (\m2 -> Time m2 ms0) m0 op0 m1 -- 6 + + | (Time m0 ms0) <- dp1, + (Ms' ms1) <- dp2 + = checkOverflow (Time m0) ms0 op0 ms1 -- 7 + + | (Day m0) <- dp1, + (Day' m1) <- dp2 + = checkOverflow Day m0 op0 m1 -- 8 + + | (Min m0) <- dp1, + (Min' m1) <- dp2 + = checkOverflow Min m0 op0 m1 -- 9 + + | (Ms m0) <- dp1, + (Ms' m1) <- dp2 + = checkOverflow Ms m0 op0 m1 -- 10 + + | (Day' m0) <- dp1, + (Day' m1) <- dp2 + = checkOverflow Day' m0 op0 m1 -- 8 + + | (Min' m0) <- dp1, + (Min' m1) <- dp2 + = checkOverflow Min' m0 op0 m1 -- 9 + + | (Ms' m0) <- dp1, + (Ms' m1) <- dp2 + = checkOverflow Ms' m0 op0 m1 -- 10 + + | otherwise = Error Invalid + + + + +checkOverflow::forall a b. (Bounded a, Integral a, Num a) => + (a -> DatePartSmall) -- ^ ctor + -> a + -> (Int -> Int -> Int) -- ^ op (+) (-) + -> a + -> DatePartSmall +checkOverflow ctor0 a1 op0 a2 = + if result1 >= min_aInt1 + && result1 <= max_aInt1 + then ctor0 $ fi result1 + else Error Overflow + where b1 = fi a1::Int + b2 = fi a2::Int + min_a1 = minBound::a + min_aInt1 = fi min_a1::Int + max_a1 = maxBound::a + max_aInt1 = fi max_a1::Int + result1 = op0 b1 b2::Int diff --git a/src/Data/Time/Hora/Internal/Pad.hs b/src/Data/Time/Hora/Internal/Pad.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Hora/Internal/Pad.hs @@ -0,0 +1,29 @@ +module Data.Time.Hora.Internal.Pad + (pad,pad') where + + +{- | pad String with Char to total length of Int + + pad on left + + >>> pad '-' 5 "abc" + + "--abc" -} + +pad::Char -> Int -> String -> String +pad c0 tot0 txt0 = p1 ++ txt0 + where p1 = pad_ c0 tot0 txt0 + + +{- | pad on right + + >>> pad' '-' 5 "abc" + + "abc--" -} +pad'::Char -> Int -> String -> String +pad' c0 tot0 txt0 = txt0 ++ p1 + where p1 = pad_ c0 tot0 txt0 + + +pad_::Char -> Int -> String -> String +pad_ c0 tot0 txt0 = [const c0 p1 | p1 <- [1..(tot0 - (length txt0))]] diff --git a/src/Data/Time/Hora/Internal/Span.hs b/src/Data/Time/Hora/Internal/Span.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Hora/Internal/Span.hs @@ -0,0 +1,59 @@ +module Data.Time.Hora.Internal.Span where + +{- | second and fractions + +see "Data.Time.Hora.Span" for conversion -} +data TimeSpan a = Sec a + | Pico a + | Milli a deriving (Show, Functor) + +-- | constraint +type TwoInt a b = (Integral a, Integral b) + +fi::TwoInt a b => a -> b +fi = fromIntegral + +withPico::Integral a => (a -> a -> a) -> + TimeSpan a -> TimeSpan a -> TimeSpan a +withPico fn0 a0 b0 = Pico $ fn0 a1 b1 + where a1 = toPico a0 + b1 = toPico b0 + + +{- | >>> toPico (Milli 1) +1000000000 -} +toPico::TwoInt a b => TimeSpan a -> b +toPico (Pico i0) = fromIntegral i0 +toPico (Milli i0) = fromIntegral $ i0 * picoMs +toPico (Sec i0) = fromIntegral $ i0 * picoSec + + + +{- | >>> toMilli $ Sec 5 +5000 -} +toMilli::TwoInt a b => TimeSpan a -> b +toMilli (Pico i0) = fromIntegral $ i0 `div` picoMs +toMilli (Milli i0) = fromIntegral $ i0 +toMilli (Sec i0) = fromIntegral $ i0 * msSec + + +{- | >>> toSec $ Milli 781200 +781 -} +toSec::TwoInt a b => TimeSpan a -> b +toSec (Pico i0) = fromIntegral $ i0 `div` picoSec +toSec (Milli i0) = fromIntegral $ i0 `div` msSec +toSec (Sec i0) = fromIntegral $ i0 + + +-- | pico in 1 second +picoSec::Integral a => a +picoSec = 1000000000000 -- 12 + +-- | pico in 1 milli +picoMs::Integral a => a +picoMs = 1000000000 -- 9 + + +-- | milli in 1 sec +msSec::Integral a => a +msSec = 1000 diff --git a/src/Data/Time/Hora/Part.hs b/src/Data/Time/Hora/Part.hs --- a/src/Data/Time/Hora/Part.hs +++ b/src/Data/Time/Hora/Part.hs @@ -1,18 +1,27 @@ --- | convert between 'UTCTime', 'UTCTimeBin' and 'DatePart' +-- | convert between 'UTCTime', 'UTCTimeBin', 'DatePart', 'DatePartSmall' module Data.Time.Hora.Part (-- * FromUTC FromUTC(..), fromUtc', -- * ToUTC - ToUTC(..)) where + ToUTC(..), + -- * 'DatePartSmall' + mkDay, + mkMin, + mkMs, + normalize, + julian_day_offset + ) where import Data.Fixed +import Data.Ratio import Data.Time.Calendar import Data.Time.Clock +import Data.Time.Hora.Internal.Span import Data.Time.Hora.Span import Data.Time.Hora.Type import Data.Time.LocalTime as L - +import Data.Word class FromUTC a where fromUtc::UTCTime -> a @@ -24,9 +33,7 @@ let day1 = utctDay t0::Day dt1 = utctDayTime t0::DiffTime (y1,m1,d1) = toGregorian day1 - tod1 = timeToTimeOfDay dt1::TimeOfDay - pico4 = todSec tod1::Fixed E12 - (sec5, MkFixed pico5) = properFraction pico4 + (tod1, sec5, pico5) = todSecPico dt1 in DatePart { year = fi y1, month = fi m1, @@ -38,13 +45,43 @@ } +-- | extract (TimeIfDay, 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 + 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 @@ -107,10 +144,114 @@ 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 + toUtc (UTCTimeBin day0 pico0) = Just $ UTCTime day1 diff1 + where day1 = ModifiedJulianDay day0 + diff1 = picosecondsToDiffTime pico0 -fi::TwoInt a b => a -> b -fi = fromIntegral + +instance ToUTC DatePartSmall where + toUtc dp0@(DatePartSmall _ _ _) = Just utc1 + where (DatePartSmall d0 m0 ms0) = normalize dp0 + utc1 = UTCTime day2 diff2 + day1 = fi d0 - julian_day_offset::Integer + day2 = ModifiedJulianDay day1 + diff2 = diffTime hr1 min1 pico2 + min1 = fi $ m0 `rem` 60 + hr1 = fi $ m0 `div` 60 + sec1 = fi $ ms0 `div` 1000 + sec2 = MkFixed $ sec1 * picoSec::Fixed E12 + ms1 = fi ms0::Integer + pico1 = fromRational $ (ms1 `rem` 1000) % 1000::Fixed E12 + pico2 = sec2 + pico1 + 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 = fromIntegral 678576 + + +-- | day / date +mkDay::Integral a => + a -- ^ year + -> a -- ^ month + -> a -- ^ day + -> DatePartSmall -- ^ 'Day' +mkDay y0 m0 d0 = maybe (Error Invalid) id mday2 + where mday2 = valid2 <$> mday1::Maybe DatePartSmall + mday1 = fromGregorianValid y1 m1 d1 + valid2 = Day . fromIntegral . (+ julian_day_offset) . toModifiedJulianDay + y1 = fromIntegral y0 + m1 = fromIntegral m0 + d1 = fromIntegral d0 + + +-- | minutes including hours +mkMin::(Num a, Integral a) => + a -- ^ hour + -> a -- ^ minute + -> DatePartSmall -- ^ 'Min' +mkMin h0 m0 = Min $ fromIntegral $ h0 * 60 + m0 + + +-- | milliseconds including seconds +mkMs::(Num a, Integral a) => + a -- ^ second + -> a -- ^ millisecond + -> DatePartSmall -- ^ 'Ms' +mkMs s0 ms0 = Ms $ fromIntegral $ 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 + +tm::Integral a => a -> a +tm = toMilli . Sec + +ts::Integral a => a -> a +ts = toSec . Milli diff --git a/src/Data/Time/Hora/Span.hs b/src/Data/Time/Hora/Span.hs --- a/src/Data/Time/Hora/Span.hs +++ b/src/Data/Time/Hora/Span.hs @@ -19,40 +19,7 @@ import Data.Ratio import Data.Time.Clock import Data.Time.Hora.Type - - --- | pico in 1 second -picoSec::Integral a => a -picoSec = 1000000000000 -- 12 - --- | pico in 1 milli -picoMs::Integral a => a -picoMs = 1000000000 -- 9 - --- | milli in 1 sec -msSec::Integral a => a -msSec = 1000 - -{- | >>> toPico $ Milli 3 -3000000000 -} -toPico::TwoInt a b => TimeSpan a -> b -toPico (Pico i0) = fromIntegral i0 -toPico (Milli i0) = fromIntegral $ i0 * picoMs -toPico (Sec i0) = fromIntegral $ i0 * picoSec - -{- | >>> toMilli $ Sec 5 -5000 -} -toMilli::TwoInt a b => TimeSpan a -> b -toMilli (Pico i0) = fromIntegral $ i0 `div` picoMs -toMilli (Milli i0) = fromIntegral $ i0 -toMilli (Sec i0) = fromIntegral $ i0 * msSec - -{- | >>> toSec $ Milli 781200 -781 -} -toSec::TwoInt a b => TimeSpan a -> b -toSec (Pico i0) = fromIntegral $ i0 `div` picoSec -toSec (Milli i0) = fromIntegral $ i0 `div` msSec -toSec (Sec i0) = fromIntegral $ i0 +import Data.Time.Hora.Internal.Span toDiffTime::Integral a => TimeSpan a -> DiffTime @@ -66,11 +33,10 @@ in fromRational $ s1 % picoSec - picoTimeSpan::Integral a => Pico -> TimeSpan a picoTimeSpan (MkFixed p0) = Pico $ fromIntegral p0 timeSpanPico::Integral a => TimeSpan a -> Pico timeSpanPico ts0 = MkFixed $ fromIntegral p0 - where p0 = toPico ts0 + where p0 = toPico ts0 diff --git a/src/Data/Time/Hora/Type.hs b/src/Data/Time/Hora/Type.hs --- a/src/Data/Time/Hora/Type.hs +++ b/src/Data/Time/Hora/Type.hs @@ -1,6 +1,12 @@ module Data.Time.Hora.Type - (-- * DatePart + (-- * DatePart DatePart(..), + -- * DatePartSmall + DatePartSmall(Day, Min, Ms, Time, DatePartSmall, Day', Min', Ms', Error), + toSpan, + negate, + isNegative, + ErrorDetail(..), -- * UTCTimeBin UTCTimeBin(..), -- * Tz @@ -12,9 +18,12 @@ import Data.Binary import Data.Time.Clock +import Data.Time.Hora.Internal.DatePartSmall +import Data.Time.Hora.Internal.Span import Data.Time.LocalTime import Data.Time.LocalTime.TimeZone.Series import GHC.Generics +import Prelude hiding (negate) {- | serializeable structure for essential Date, Time parts @@ -29,7 +38,7 @@ hour::a, minute::a, second::a, - pico::a -- ^ excludes seconds. Just fraction as Num + pico::a -- ^ excludes seconds. Just fraction as Integral } deriving (Show, Generic) @@ -81,9 +90,9 @@ -- private data Ord_ = Stop Bool | Continue -{- | 'UTCTimeBin' closely mimicks UTCTime. +{- | 'UTCTimeBin' closely mimicks 'UTCTime' without loss of precision -'UTCTimeBin' has 'Binary' instance. The only purpose of 'UTCTimeBin' is to offer faster conversion and more compact serialization of 'UTCTime' compared with 'DatePart'. +'UTCTimeBin' has 'Binary' instance. The only purpose of 'UTCTimeBin' is to offer faster conversion from / to 'UTCTime' and more compact serialization compared with 'DatePart'. see "Data.Time.Hora.Part" for conversion between 'UTCTime' and 'UTCTimeBin' -} data UTCTimeBin = UTCTimeBin { @@ -119,18 +128,8 @@ use of 'TimeZoneSeries' is preferred when converting from 'UTCTime' to 'DatePart' -} -{- | second and fractions -see "Data.Time.Hora.Span" for conversion -} -data TimeSpan a = Sec a - | Pico a - | Milli a deriving (Show, Functor) - --- | constraint -type TwoInt a b = (Integral a, Integral b) - - {- | ! fromInteger returns 'Pico'. assumes the value is Pico seconds >>> Milli 397100 + (Sec 2) + 37891470000 @@ -176,27 +175,3 @@ where a1 = toPico a0::Integer b1 = toPico b0::Integer - -withPico::Integral a => (a -> a -> a) -> - TimeSpan a -> TimeSpan a -> TimeSpan a -withPico fn0 a0 b0 = Pico $ fn0 a1 b1 - where a1 = toPico a0 - b1 = toPico b0 - - -{- | >>> toPico (Milli 1) - 1000000000 -} -toPico::TwoInt a b => TimeSpan a -> b -toPico (Pico i0) = fromIntegral i0 -toPico (Milli i0) = fromIntegral $ i0 * picoMs -toPico (Sec i0) = fromIntegral $ i0 * picoSec - - - --- | pico in 1 second -picoSec::Integral a => a -picoSec = 1000000000000 -- 12 - --- | pico in 1 milli -picoMs::Integral a => a -picoMs = 1000000000 -- 9 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -13,10 +13,17 @@ import qualified Test.TestTime as Tt import qualified Test.TestUTCTimeBin as Bin import qualified Test.TestZone as Z - +import qualified Test.TestAncientDate as A +import qualified Test.TestDatePartSmall as Sm +import qualified Test.TestStorageSize as Sto +import qualified Test.TestDatePartSmallConvert as Smc +import qualified Test.TestRoundtripPicoMilli as Pm +import qualified Test.TestDatePartSmallDoc as Smd +import qualified Test.TestCheckOverflow as Of main::IO() main = do + Of.main T.main Conv.main Fut.main @@ -30,3 +37,9 @@ Tcom.main Tf.main Bin.main + A.main + Sm.main + Sto.main + Smc.main + Pm.main + Smd.main diff --git a/test/Test/TestAncientDate.hs b/test/Test/TestAncientDate.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestAncientDate.hs @@ -0,0 +1,31 @@ +module Test.TestAncientDate where + +import Data.Maybe +import Data.Time.Hora.Part +import Data.Time.Hora.Type +import Debug.Trace +import Test.Hspec + +main::IO() +main = hspec $ do + describe "day way in the past" $ do + it "year 1" $ do + traceIO $ "year 1: " <> (show utc1) + traceIO $ "year 1: " <> (show utcbin1) + 1 `shouldBe` 1 + it "year 500" $ do + isJust utc2 `shouldBe` True + dp3 `shouldBe` (dp1 500) + where utc1 = fromJust $ toUtc $ dp1 1 + utcbin1 = fromUtc utc1::UTCTimeBin + dp1 y1 = DatePart { + year = y1, + month = 1, + day = 1, + hour = 0, + minute = 0, + second = 0, + pico = 0 + }::DatePart Int + utc2 = toUtc $ dp1 500 + dp3 = fromUtc $ fromJust utc2::DatePart Int diff --git a/test/Test/TestCheckOverflow.hs b/test/Test/TestCheckOverflow.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestCheckOverflow.hs @@ -0,0 +1,20 @@ +module Test.TestCheckOverflow where + +import Data.Word +import Data.Time.Hora.Internal.DatePartSmall +import Test.Hspec + + +main::IO() +main = hspec $ do + describe "TestCheckOverflow" $ do + it "addition succeeds" $ do + let result1 = checkOverflow Min' 3 (+) 10 + result1 `shouldBe` (Min' 13) + it "addition maxes out" $ do + let result1 = checkOverflow Min' max16 (+) 10 + result1 `shouldBe` (Error Overflow) + it "negation maxes out" $ do + let result1 = checkOverflow Min' 20 (-) 100 + result1 `shouldBe` (Error Overflow) + where max16 = maxBound::Word16 diff --git a/test/Test/TestDatePartSmall.hs b/test/Test/TestDatePartSmall.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestDatePartSmall.hs @@ -0,0 +1,118 @@ +module Test.TestDatePartSmall where + +import Data.Semigroup hiding (Min) +import Data.Time.Hora.Internal.DatePartSmall +import Prelude hiding (negate) +import Test.Hspec + + +main::IO() +main = hspec $ do + describe "TestDatePartSmall merge" $ do + it "1 Day <> Time" $ do + Day 2 <> Time 3 5 `shouldBe` DatePartSmall 2 3 5 + it "2 Min <> Ms" $ do + Min 2 <> Ms 3 `shouldBe` Time 2 3 + + describe "TestDatePartSmall increment" $ do + it "3" $ do + DatePartSmall 1 2 3 <> Day' 2 `shouldBe` DatePartSmall 3 2 3 + it "4" $ do + DatePartSmall 1 2 3 <> Min' 2 `shouldBe` DatePartSmall 1 4 3 + it "5" $ do + DatePartSmall 1 2 3 <> Ms' 2 `shouldBe` DatePartSmall 1 2 5 + it "6" $ do + Time 2 3 <> Min' 2 `shouldBe` Time 4 3 + it "7" $ do + Time 2 3 <> Ms' 2 `shouldBe` Time 2 5 + it "8" $ do + Day 1 <> Day' 2 `shouldBe` Day 3 + it "9" $ do + Min 1 <> Min' 2 `shouldBe` Min 3 + it "10" $ do + Ms 1 <> Ms' 2 `shouldBe` Ms 3 + + it "8: 2 x spans" $ do + Day' 1 <> Day' 2 `shouldBe` Day' 3 + it "9: 2 x spans" $ do + Min' 1 <> Min' 2 `shouldBe` Min' 3 + it "10: 2 x spans" $ do + Ms' 1 <> Ms' 2 `shouldBe` Ms' 3 + + describe "TestDatePartSmall decrement" $ do + it "3" $ do + DatePartSmall 10 2 3 <> negate (Day' 2) `shouldBe` DatePartSmall 8 2 3 + it "4" $ do + DatePartSmall 1 2 3 <> negate (Min' 2) `shouldBe` DatePartSmall 1 0 3 + it "5" $ do + DatePartSmall 1 2 3 <> negate (Ms' 2) `shouldBe` DatePartSmall 1 2 1 + it "6" $ do + Time 20 3 <> negate (Min' 2) `shouldBe` Time 18 3 + it "7" $ do + Time 2 30 <> negate (Ms' 5) `shouldBe` Time 2 25 + it "8" $ do + Day 10 <> negate (Day' 2) `shouldBe` Day 8 + it "9" $ do + Min 10 <> negate (Min' 3) `shouldBe` Min 7 + it "10" $ do + Ms 100 <> negate (Ms' 12) `shouldBe` Ms 88 + + it "8: 2 x spans" $ do + Day' 10 <> negate (Day' 4) `shouldBe` Day' 6 + it "9: 2 x spans" $ do + Min' 14 <> negate (Min' 2) `shouldBe` Min' 12 + it "10: 2 x spans" $ do + Ms' 23 <> negate (Ms' 2) `shouldBe` Ms' 21 + + it "8: 2 x spans" $ do + Day' 10 <> negate (Day' 4) `shouldBe` Day' 6 + it "9: 2 x spans" $ do + Min' 14 <> negate (Min' 2) `shouldBe` Min' 12 + it "10: 2 x spans" $ do + Ms' 23 <> negate (Ms' 2) `shouldBe` Ms' 21 + + it "8: 2 x spans" $ do + negate (Day' 10) <> negate (Day' 4) `shouldBe` (negate $ Day' 14) + it "9: 2 x spans" $ do + negate (Min' 14) <> negate (Min' 2) `shouldBe` (negate $ Min' 16) + it "10: 2 x spans" $ do + negate (Ms' 23) <> negate (Ms' 2) `shouldBe` (negate $ Ms' 25) + + describe "TestDatePartSmall overwrite" $ do + it "11" $ do + DatePartSmall 1 2 3 <> DatePartSmall 5 6 7 `shouldBe` DatePartSmall 5 6 7 + it "12" $ do + Time 2 3 <> Time 7 8 `shouldBe` Time 7 8 + it "13" $ do + Day 3 <> Day 8 `shouldBe` Day 8 + it "14" $ do + Min 1 <> Min 20 `shouldBe` Min 20 + it "15" $ do + Ms 1 <> Ms 20 `shouldBe` Ms 20 + + describe "TestDatePartSmall update" $ do + it "16" $ do + DatePartSmall 1 2 3 <> Time 5 6 `shouldBe` DatePartSmall 1 5 6 + it "17" $ do + Time 2 3 <> Min 8 `shouldBe` Time 8 3 + it "18" $ do + Time 2 3 <> Ms 8 `shouldBe` Time 2 8 + + it "19" $ do + Error Invalid <> Error Invalid `shouldBe` Error Invalid + it "20" $ do + Error Invalid <> Error Overflow `shouldBe` Error Invalid_Overflow + it "21" $ do + Error Overflow <> Error Overflow `shouldBe` Error Overflow + it "22" $ do + Error Overflow <> Error Invalid ` shouldBe ` Error Invalid_Overflow + it "23" $ do + Error Invalid_Overflow <> Min 1 ` shouldBe ` Error Invalid_Overflow + it "24" $ do + Min 1 <> Error Invalid_Overflow ` shouldBe ` Error Invalid_Overflow + it "25" $ do + Error Overflow <> Min 1 ` shouldBe ` Error Overflow + it "26" $ do + Day 3 <> Error Invalid ` shouldBe ` Error Invalid + it "27" $ do + Time 1 2 <> Day 3 `shouldBe` Error Invalid diff --git a/test/Test/TestDatePartSmallConvert.hs b/test/Test/TestDatePartSmallConvert.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestDatePartSmallConvert.hs @@ -0,0 +1,40 @@ +module Test.TestDatePartSmallConvert where + +import Data.Maybe +import Data.Time.Clock +import Data.Time.Hora.Future as F +import Data.Time.Hora.Internal.DatePartSmall +import Data.Time.Hora.Internal.Span +import Data.Time.Hora.Part +import Data.Time.Hora.Stamp +import Data.Time.Hora.Type +import Debug.Trace +import Prelude as P +import Test.Hspec + +main::IO() +main = hspec $ do + describe "TestDatePartSmallConvert" $ do + it "now <-> DatePartSmall" $ do + now1 <- now::IO UTCTime + let small1 = fromUtc now1::DatePartSmall + Just utc2 = toUtc small1 + span3 = utc2 F.- now1::TimeSpan Integer + traceIO $ show small1 + abs span3 `shouldSatisfy` (< (Milli 1)) + it "normalize DatePartSmall" $ do + normalize (Time 0 $ toMilli $ Sec 62) `shouldBe` (Time 1 $ toMilli $ Sec 2) + normalize (DatePartSmall 0 (60 * 24 + 10) $ toMilli $ Sec 62) `shouldBe` (DatePartSmall 1 11 $ toMilli $ Sec 2) + (mkMin 14 59 <> mkMs 132 9 <> Ms' 5300) `shouldBe` (mkMin 14 59) <> (mkMs 132 5309) + normalize (mkMin 14 59 <> mkMs 132 9 <> Ms' 5300) `shouldBe` (mkMin 15 1) <> (mkMs 17 309) + it "increment DatePartSmall by 1 day in minutes" $ do + now1 <- now::IO UTCTime + let small1 = fromUtc now1::DatePartSmall + incremented1 = small1 <> (toSpan $ mkMin 24 0) + Just utcNow2 = toUtc small1 + Just utcIncr3 = toUtc incremented1 + dp2 = fromUtc utcNow2::DatePart Int + dp3 = fromUtc utcIncr3::DatePart Int + traceIO $ "increment DatePartSmall by 1 day in minutes dp2: " <> show dp2 + traceIO $ "increment DatePartSmall by 1 day in minutes dp3: " <>show dp3 + day dp3 P.- day dp2 `shouldBe` 1 diff --git a/test/Test/TestDatePartSmallDoc.hs b/test/Test/TestDatePartSmallDoc.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestDatePartSmallDoc.hs @@ -0,0 +1,47 @@ +module Test.TestDatePartSmallDoc where + +import Data.Maybe +import Data.Semigroup hiding (Min) +import Data.Time.Clock +import Data.Time.Hora.Part +import Data.Time.Hora.Format +import Data.Time.Hora.Type +import Data.Word +import Debug.Trace +import Prelude +import Test.Hspec + + +main::IO() +main = hspec $ do + describe "TestDatePartSmall" $ do + it "day 1" $ do + mkDay 1 1 1 `shouldBe` (Day 1) + it "Modified Julian day" $ do + mkDay 1858 11 17 `shouldBe` (Day julian_day_offset) + it "mkDay" $ do + mkDay 2018 08 16 `shouldBe` (Day 736922) + it "max day" $ do + let d1 = Day (maxBound::Word32) + Just utc2 = toUtc $ d1 <> (Time 0 0) + traceIO $ "max date: " <> (show utc2) + 1 `shouldBe` 1 + it "round trip DatePartSmall <-> UTCTime <-> DatePart" $ do + let d1 = mkDay 2018 8 16::DatePartSmall + dt1 = d1 <> Time 0 0::DatePartSmall + utc2 = fromJust $ toUtc dt1::UTCTime + dp3 = fromUtc utc2 + DatePartSmall d4 _ _ = fromUtc utc2::DatePartSmall + year dp3 `shouldBe` 2018 + month dp3 `shouldBe` 8 + day dp3 `shouldBe` 16 + d4 `shouldBe` 736922 + describe "TestDatePartSmall show results" $ do + it "display " $ do + show' (mkDay 2018 8 20 <> mkMin 10 2 <> mkMs 30 9) `shouldBe` "2018-08-20 10:02:30.009" + show' (mkDay 2018 1 1 <> Day' 20) `shouldBe` "2018-01-21" + show' (mkDay 2018 1 1 <> Day' 180) `shouldBe` "2018-06-30" + show' (mkMin 3 15 <> Min' 200) `shouldBe` "06:35" + show' (normalize $ mkMin 14 59 <> mkMs 132 9 <> Ms' 5308) `shouldBe` "15:01:17.317" + show' (mkMs 132 9) `shouldBe` "132.009" + show' (mkMs 132 9 <> Ms' 5300) `shouldBe` "137.309" diff --git a/test/Test/TestFormat.hs b/test/Test/TestFormat.hs --- a/test/Test/TestFormat.hs +++ b/test/Test/TestFormat.hs @@ -1,8 +1,9 @@ module Test.TestFormat where import Data.Time.Hora.Format +import Data.Time.Hora.Part import Data.Time.Hora.Stamp -import Data.Time.Hora.Type +import Data.Time.Hora.Type as T import Debug.Trace import Test.Hspec @@ -28,6 +29,38 @@ it "week of year" $ do ts [Wk_year_Mon, " ", Wk_year_Sun] >>= utc 1 `shouldBe` 1 + + describe "TestFormat show DatePartSmall" $ do + it "Day" $ do + show' (mkDay 2018 08 17) `shouldBe` "2018-08-17" + it "Min" $ do + show' (mkMin 4 3) `shouldBe` "04:03" + it "Ms" $ do + show' (mkMs 7 318) `shouldBe` "07.318" + it "Time" $ do + let (T.Min m1) = mkMin 5 7 + (T.Ms ms1) = mkMs 7 58 + show' (T.Time m1 ms1) `shouldBe` "05:07:07.058" + it "DatePartSmall" $ do + let (T.Day d1) = mkDay 2018 08 17 + (T.Min m1) = mkMin 15 17 + (T.Ms ms1) = mkMs 7 358 + show' (T.DatePartSmall d1 m1 ms1) `shouldBe` "2018-08-17 15:17:07.358" + it "Day'" $ do + show' (Day' 3) `shouldBe` "+3" + it "Min'" $ do + show' (toSpan $ mkMin 14 53) `shouldBe` "+14:53" + show' (toSpan $ mkMin 0 53) `shouldBe` "+00:53" + it "Ms'" $ do + show' (toSpan $ mkMs 7 0) `shouldBe` "+07.000" + it "Neg Day'" $ do + show' (T.negate $ Day' 3) `shouldBe` "-3" + it "Neg Min'" $ do + show' (T.negate $ toSpan $ mkMin 14 53) `shouldBe` "-14:53" + show' (T.negate $ toSpan $ mkMin 0 53) `shouldBe` "-00:53" + it "Neg Ms'" $ do + show' (T.negate $ toSpan $ mkMs 7 358) `shouldBe` "-07.358" + show' (T.negate $ toSpan $ mkMs 0 0) `shouldBe` "-00.000" utc::Tz String -> IO() diff --git a/test/Test/TestRoundtripPicoMilli.hs b/test/Test/TestRoundtripPicoMilli.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestRoundtripPicoMilli.hs @@ -0,0 +1,32 @@ +module Test.TestRoundtripPicoMilli where + +import Data.Time.Clock +import Data.Time.Hora.Part +import Data.Time.Hora.Span +import Data.Time.Hora.Stamp +import Data.Time.Hora.Type +import Data.Word +import Debug.Trace +import Test.Hspec + + +main::IO() +main = hspec $ do + describe "TestRoundtripPicoMilli" $ do + it "round trip pico" $ do + now1 <- now::IO UTCTime + let dp1 = fromUtc now1::DatePart Int + pico1 = pico dp1::Int + milli2 = fromSec3 + fromPico3::Word32 + + fromSec3 = toMilli (Sec $ second dp1)::Word32 + fromPico3 = toMilli $ Pico pico1 + tr1 "pico1: " pico1 + tr1 "sec1: " $ second dp1 + tr1 "milli2: " milli2 + + -- back + let pico5 = toPico $ Milli milli2::Int + tr1 "pico5: " pico5 + 1 `shouldBe` 1 + where tr1 desc1 data1 = traceIO $ "TestRoundtripPicoMilli " <> desc1 <> show data1 diff --git a/test/Test/TestStorageSize.hs b/test/Test/TestStorageSize.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestStorageSize.hs @@ -0,0 +1,71 @@ +module Test.TestStorageSize where + +import Data.Binary +import qualified Data.ByteString as B (concat,length) +import qualified Data.ByteString.Lazy as L (toChunks) +import Data.Int +import Data.Time.Clock +import Data.Time.Hora.Part +import Data.Time.Hora.Stamp +import Data.Time.Hora.Type +import Debug.Trace +import Prelude as P +import Test.Hspec + + +main::IO() +main = hspec $ do + describe "compare binary size" $ do + it "Min 10" $ do + let result1 = Min 10 + bin2 = encode result1 + tr1 "Min 10 size is " bin2 + size1 bin2 `shouldBe` 3 + it "Day 10" $ do + let result1 = Day 10 + bin2 = encode result1 + tr1 "Day 10 size is " bin2 + size1 bin2 `shouldBe` 5 + it "Day max" $ do + let result1 = Day (maxBound::Word32) + bin2 = encode result1 + tr1 "Day max size is " bin2 + size1 bin2 `shouldBe` 5 + it "Ms 10" $ do + let result1 = Ms 10 + bin2 = encode result1 + tr1 "Ms 10 size is " bin2 + size1 bin2 `shouldBe` 5 + it "Time 1 2" $ do + let result1 = Time 1 2 + bin2 = encode result1 + tr1 "Time 1 2 size is " bin2 + size1 bin2 `shouldBe` 7 + it "DatePartSmall 10 2 1" $ do + let result1 = DatePartSmall 10 2 1 + bin2 = encode result1 + tr1 "DatePartSmall size is " bin2 + size1 bin2 `shouldBe` 11 + it "DatePartSmall from now" $ do + now20 <- now::IO UTCTime + let result1 = fromUtc now20::DatePartSmall + bin1 = encode result1 + tr1 "DatePartSmall now size is " bin1 + size1 bin1 `shouldBe` 11 + let result2 = fromUtc now20::UTCTimeBin + bin2 = encode result2 + tr1 "UTCTimeBin now size is " bin2 +-- size1 bin2 `shouldBe` 22 + let result3 = fromUtc now20::DatePart Int + bin3 = encode result3 + tr1 "DatePart Int now size is " bin3 +-- size1 bin3 `shouldBe` 56 + it "Int64" $ do + let result1 = 10::Int64 + bin2 = encode result1 + tr1 "Int64 size is " bin2 + size1 bin2 `shouldBe` 8 + where tr1 desc1 bin1 = traceIO $ desc1 <> (show $ size1 bin1) + size1 bin1 = B.length $ B.concat $ L.toChunks bin1 + + diff --git a/test/Test/TestUTCTimeBin.hs b/test/Test/TestUTCTimeBin.hs --- a/test/Test/TestUTCTimeBin.hs +++ b/test/Test/TestUTCTimeBin.hs @@ -3,6 +3,7 @@ import Data.Binary import Data.ByteString.Lazy import Data.Maybe +import Data.Time.Clock import Data.Time.Hora.Part import Data.Time.Hora.Stamp import Data.Time.Hora.Type @@ -14,7 +15,7 @@ main = hspec $ do describe "round trip convert & serialize UTCTime via UTCTimeBin" $ do it "round trip convert" $ do - utc1 <- now + utc1 <- now::IO UTCTime let utcbin2 = fromUtc utc1::UTCTimeBin utc2 = fromJust $ toUtc utcbin2 traceIO $ show utc1 @@ -22,7 +23,7 @@ traceIO $ show utc2 utc2 `shouldBe` utc1 it "round trip convert & serialize" $ do - utc10 <- now + utc10 <- now::IO UTCTime let utcbin10 = fromUtc utc10::UTCTimeBin bin11 = encode utcbin10::ByteString utcbin12 = decode bin11::UTCTimeBin