diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,8 @@ # Change Log +## [1.7] +- Data.Time.Clock.TAI: change LeapSecondTable to LeapSecondMap with Maybe type; remove parseTAIUTCDATFile + ## [1.6.0.1] - Get building with earlier GHC versions - Set lower bound of base correctly diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([Haskell time package], [1.6.0.1], [ashley@semantic.org], [time]) +AC_INIT([Haskell time package], [1.7], [ashley@semantic.org], [time]) # Safety check: Ensure that we are in the correct source directory. AC_CONFIG_SRCDIR([lib/include/HsTime.h]) diff --git a/lib/Data/Time/Clock/TAI.hs b/lib/Data/Time/Clock/TAI.hs --- a/lib/Data/Time/Clock/TAI.hs +++ b/lib/Data/Time/Clock/TAI.hs @@ -1,24 +1,23 @@ {-# OPTIONS -fno-warn-unused-imports #-} #include "HsConfigure.h" --- | TAI and leap-second tables for converting to UTC: most people won't need this module. +-- | TAI and leap-second maps for converting to UTC: most people won't need this module. module Data.Time.Clock.TAI ( -- TAI arithmetic AbsoluteTime,taiEpoch,addAbsoluteTime,diffAbsoluteTime, - -- leap-second table type - LeapSecondTable, + -- leap-second map type + LeapSecondMap, - -- conversion between UTC and TAI with table + -- conversion between UTC and TAI with map utcDayLength,utcToTAITime,taiToUTCTime, - - parseTAIUTCDATFile ) where import Data.Time.LocalTime import Data.Time.Calendar.Days import Data.Time.Clock import Control.DeepSeq +import Data.Maybe import Data.Typeable import Data.Fixed #if LANGUAGE_Rank2Types @@ -26,7 +25,7 @@ #endif -- | AbsoluteTime is TAI, time as measured by a clock. -newtype AbsoluteTime = MkAbsoluteTime {unAbsoluteTime :: DiffTime} deriving (Eq,Ord +newtype AbsoluteTime = MkAbsoluteTime DiffTime deriving (Eq,Ord #if LANGUAGE_DeriveDataTypeable #if LANGUAGE_Rank2Types #if HAS_DataPico @@ -40,7 +39,7 @@ rnf (MkAbsoluteTime a) = rnf a instance Show AbsoluteTime where - show t = show (utcToLocalTime utc (taiToUTCTime (const 0) t)) ++ " TAI" -- ugly, but standard apparently + show t = show (utcToLocalTime utc (fromJust (taiToUTCTime (const (Just 0)) t))) ++ " TAI" -- ugly, but standard apparently -- | The epoch of TAI, which is 1858-11-17 00:00:00 TAI. taiEpoch :: AbsoluteTime @@ -57,87 +56,31 @@ -- | TAI - UTC during this day. -- No table is provided, as any program compiled with it would become -- out of date in six months. -type LeapSecondTable = Day -> Integer - -utcDayLength :: LeapSecondTable -> Day -> DiffTime -utcDayLength table day = realToFrac (86400 + (table (addDays 1 day)) - (table day)) - -dayStart :: LeapSecondTable -> Day -> AbsoluteTime -dayStart table day = MkAbsoluteTime (realToFrac ((toModifiedJulianDay day) * 86400 + (table day))) - -utcToTAITime :: LeapSecondTable -> UTCTime -> AbsoluteTime -utcToTAITime table (UTCTime day dtime) = MkAbsoluteTime (t + dtime) where - MkAbsoluteTime t = dayStart table day - -taiToUTCTime :: LeapSecondTable -> AbsoluteTime -> UTCTime -taiToUTCTime table abstime = stable (ModifiedJulianDay (div' (unAbsoluteTime abstime) 86400)) where - stable day = if (day == day') then UTCTime day dtime else stable day' where - dayt = dayStart table day - dtime = diffAbsoluteTime abstime dayt - day' = addDays (div' dtime (utcDayLength table day)) day - --- | Parse the contents of a tai-utc.dat file. --- This does not do any kind of validation and will return a bad table for input --- not in the correct format. -parseTAIUTCDATFile :: String -> LeapSecondTable -parseTAIUTCDATFile ss = offsetlist 0 (parse (lines ss)) where - offsetlist :: Integer -> [(Day,Integer)] -> LeapSecondTable - offsetlist i [] _ = i - offsetlist i ((d0,_):_) d | d < d0 = i - offsetlist _ ((_,i0):xx) d = offsetlist i0 xx d - - parse :: [String] -> [(Day,Integer)] - parse [] = [] - parse (a:as) = let - ps = parse as - in case matchLine a of - Just di -> di:ps - Nothing -> ps - - matchLine :: String -> Maybe (Day,Integer) - matchLine s = do - check0S s - (d,s') <- findJD s - i <- findOffset s' - return (d,i) - - -- a bit fragile - check0S :: String -> Maybe () - check0S "X 0.0 S" = Just () - check0S [] = Nothing - check0S (_:cs) = check0S cs - - findJD :: String -> Maybe (Day,String) - findJD ('=':'J':'D':s) = do - d <- getInteger '5' s - return (ModifiedJulianDay (d - 2400000),s) - findJD [] = Nothing - findJD (_:cs) = findJD cs - - findOffset :: String -> Maybe Integer - findOffset ('T':'A':'I':'-':'U':'T':'C':'=':s) = getInteger '0' s - findOffset [] = Nothing - findOffset (_:cs) = findOffset cs - - getInteger :: Char -> String -> Maybe Integer - getInteger p s = do - digits <- getDigits p s - fromDigits 0 digits +type LeapSecondMap = Day -> Maybe Int - getDigits :: Char -> String -> Maybe String - getDigits p (' ':s) = getDigits p s - getDigits p (c:cs) | c >= '0' && c <= '9' = do - s <- getDigits p cs - return (c:s) - getDigits p ('.':p1:_) = if p == p1 then Just [] else Nothing - getDigits _ _ = Nothing +utcDayLength :: LeapSecondMap -> Day -> Maybe DiffTime +utcDayLength lsmap day = do + i0 <- lsmap day + i1 <- lsmap $ addDays 1 day + return $ realToFrac (86400 + i1 - i0) +dayStart :: LeapSecondMap -> Day -> Maybe AbsoluteTime +dayStart lsmap day = do + i <- lsmap day + return $ addAbsoluteTime (realToFrac $ (toModifiedJulianDay day) * 86400 + toInteger i) taiEpoch - fromDigits :: Integer -> String -> Maybe Integer - fromDigits i [] = Just i - fromDigits i (c:cs) | c >= '0' && c <= '9' = fromDigits ((i * 10) + (fromIntegral ((fromEnum c) - (fromEnum '0')))) cs - fromDigits _ _ = Nothing +utcToTAITime :: LeapSecondMap -> UTCTime -> Maybe AbsoluteTime +utcToTAITime lsmap (UTCTime day dtime) = do + t <- dayStart lsmap day + return $ addAbsoluteTime dtime t --- typical line format: --- 1972 JAN 1 =JD 2441317.5 TAI-UTC= 10.0 S + (MJD - 41317.) X 0.0 S --- 1972 JUL 1 =JD 2441499.5 TAI-UTC= 11.0 S + (MJD - 41317.) X 0.0 S +taiToUTCTime :: LeapSecondMap -> AbsoluteTime -> Maybe UTCTime +taiToUTCTime lsmap abstime = let + stable day = do + dayt <- dayStart lsmap day + len <- utcDayLength lsmap day + let + dtime = diffAbsoluteTime abstime dayt + day' = addDays (div' dtime len) day + if day == day' then return (UTCTime day dtime) else stable day' + in stable $ ModifiedJulianDay $ div' (diffAbsoluteTime abstime taiEpoch) 86400 diff --git a/test/Test/TAI_UTC_DAT.hs b/test/Test/TAI_UTC_DAT.hs deleted file mode 100644 --- a/test/Test/TAI_UTC_DAT.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Test.TAI_UTC_DAT where - -taiUTC_DAT :: String -taiUTC_DAT = - unlines - [ "1961 JAN 1 =JD 2437300.5 TAI-UTC= 1.4228180 S + (MJD - 37300.) X 0.001296 S" - , "1961 AUG 1 =JD 2437512.5 TAI-UTC= 1.3728180 S + (MJD - 37300.) X 0.001296 S" - , "1962 JAN 1 =JD 2437665.5 TAI-UTC= 1.8458580 S + (MJD - 37665.) X 0.0011232S" - , "1963 NOV 1 =JD 2438334.5 TAI-UTC= 1.9458580 S + (MJD - 37665.) X 0.0011232S" - , "1964 JAN 1 =JD 2438395.5 TAI-UTC= 3.2401300 S + (MJD - 38761.) X 0.001296 S" - , "1964 APR 1 =JD 2438486.5 TAI-UTC= 3.3401300 S + (MJD - 38761.) X 0.001296 S" - , "1964 SEP 1 =JD 2438639.5 TAI-UTC= 3.4401300 S + (MJD - 38761.) X 0.001296 S" - , "1965 JAN 1 =JD 2438761.5 TAI-UTC= 3.5401300 S + (MJD - 38761.) X 0.001296 S" - , "1965 MAR 1 =JD 2438820.5 TAI-UTC= 3.6401300 S + (MJD - 38761.) X 0.001296 S" - , "1965 JUL 1 =JD 2438942.5 TAI-UTC= 3.7401300 S + (MJD - 38761.) X 0.001296 S" - , "1965 SEP 1 =JD 2439004.5 TAI-UTC= 3.8401300 S + (MJD - 38761.) X 0.001296 S" - , "1966 JAN 1 =JD 2439126.5 TAI-UTC= 4.3131700 S + (MJD - 39126.) X 0.002592 S" - , "1968 FEB 1 =JD 2439887.5 TAI-UTC= 4.2131700 S + (MJD - 39126.) X 0.002592 S" - , "1972 JAN 1 =JD 2441317.5 TAI-UTC= 10.0 S + (MJD - 41317.) X 0.0 S" - , "1972 JUL 1 =JD 2441499.5 TAI-UTC= 11.0 S + (MJD - 41317.) X 0.0 S" - , "1973 JAN 1 =JD 2441683.5 TAI-UTC= 12.0 S + (MJD - 41317.) X 0.0 S" - , "1974 JAN 1 =JD 2442048.5 TAI-UTC= 13.0 S + (MJD - 41317.) X 0.0 S" - , "1975 JAN 1 =JD 2442413.5 TAI-UTC= 14.0 S + (MJD - 41317.) X 0.0 S" - , "1976 JAN 1 =JD 2442778.5 TAI-UTC= 15.0 S + (MJD - 41317.) X 0.0 S" - , "1977 JAN 1 =JD 2443144.5 TAI-UTC= 16.0 S + (MJD - 41317.) X 0.0 S" - , "1978 JAN 1 =JD 2443509.5 TAI-UTC= 17.0 S + (MJD - 41317.) X 0.0 S" - , "1979 JAN 1 =JD 2443874.5 TAI-UTC= 18.0 S + (MJD - 41317.) X 0.0 S" - , "1980 JAN 1 =JD 2444239.5 TAI-UTC= 19.0 S + (MJD - 41317.) X 0.0 S" - , "1981 JUL 1 =JD 2444786.5 TAI-UTC= 20.0 S + (MJD - 41317.) X 0.0 S" - , "1982 JUL 1 =JD 2445151.5 TAI-UTC= 21.0 S + (MJD - 41317.) X 0.0 S" - , "1983 JUL 1 =JD 2445516.5 TAI-UTC= 22.0 S + (MJD - 41317.) X 0.0 S" - , "1985 JUL 1 =JD 2446247.5 TAI-UTC= 23.0 S + (MJD - 41317.) X 0.0 S" - , "1988 JAN 1 =JD 2447161.5 TAI-UTC= 24.0 S + (MJD - 41317.) X 0.0 S" - , "1990 JAN 1 =JD 2447892.5 TAI-UTC= 25.0 S + (MJD - 41317.) X 0.0 S" - , "1991 JAN 1 =JD 2448257.5 TAI-UTC= 26.0 S + (MJD - 41317.) X 0.0 S" - , "1992 JUL 1 =JD 2448804.5 TAI-UTC= 27.0 S + (MJD - 41317.) X 0.0 S" - , "1993 JUL 1 =JD 2449169.5 TAI-UTC= 28.0 S + (MJD - 41317.) X 0.0 S" - , "1994 JUL 1 =JD 2449534.5 TAI-UTC= 29.0 S + (MJD - 41317.) X 0.0 S" - , "1996 JAN 1 =JD 2450083.5 TAI-UTC= 30.0 S + (MJD - 41317.) X 0.0 S" - , "1997 JUL 1 =JD 2450630.5 TAI-UTC= 31.0 S + (MJD - 41317.) X 0.0 S" - , "1999 JAN 1 =JD 2451179.5 TAI-UTC= 32.0 S + (MJD - 41317.) X 0.0 S" - , "2006 JAN 1 =JD 2453736.5 TAI-UTC= 33.0 S + (MJD - 41317.) X 0.0 S" ] diff --git a/test/Test/TestParseDAT.hs b/test/Test/TestParseDAT.hs deleted file mode 100644 --- a/test/Test/TestParseDAT.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Test.TestParseDAT where - -import Data.Time -import Data.Time.Clock.TAI -import Test.TestUtil -import Test.TestParseDAT_Ref -import Test.TAI_UTC_DAT - -tods :: [TimeOfDay] -tods = [ - TimeOfDay 0 0 0, - TimeOfDay 0 0 0.5, - TimeOfDay 0 0 1, - TimeOfDay 0 0 1.5, - TimeOfDay 0 0 2, - TimeOfDay 23 59 28, - TimeOfDay 23 59 28.5, - TimeOfDay 23 59 29, - TimeOfDay 23 59 29.5, - TimeOfDay 23 59 30, - TimeOfDay 23 59 30.5, - TimeOfDay 23 59 31, - TimeOfDay 23 59 31.5, - TimeOfDay 23 59 32, - TimeOfDay 23 59 59, - TimeOfDay 23 59 59.5, - TimeOfDay 23 59 60, - TimeOfDay 23 59 60.5 - ] - -times :: [LocalTime] -times = - fmap (LocalTime (fromGregorian 1998 04 02)) tods ++ - fmap (LocalTime (fromGregorian 1998 12 30)) tods ++ - fmap (LocalTime (fromGregorian 1998 12 31)) tods ++ - fmap (LocalTime (fromGregorian 1999 01 01)) tods ++ - fmap (LocalTime (fromGregorian 1999 01 02)) tods - -testParseDAT :: Test -testParseDAT = pureTest "testParseDAT" $ diff testParseDAT_Ref parseDAT where - parseDAT = - let lst = parseTAIUTCDATFile taiUTC_DAT in - unlines $ map - (\lt -> - let - utcTime = localTimeToUTC utc lt - taiTime = utcToTAITime lst utcTime - utcTime' = taiToUTCTime lst taiTime - in if utcTime == utcTime' - then unwords [show utcTime, "==", show taiTime] - else unwords [ "correction:", show utcTime, "->", show taiTime, "->", show utcTime'] - ) - times diff --git a/test/Test/TestParseDAT_Ref.hs b/test/Test/TestParseDAT_Ref.hs deleted file mode 100644 --- a/test/Test/TestParseDAT_Ref.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Test.TestParseDAT_Ref where - -testParseDAT_Ref :: String -testParseDAT_Ref = - unlines - [ "1998-04-02 00:00:00 UTC == 1998-04-02 00:00:31 TAI" - , "1998-04-02 00:00:00.5 UTC == 1998-04-02 00:00:31.5 TAI" - , "1998-04-02 00:00:01 UTC == 1998-04-02 00:00:32 TAI" - , "1998-04-02 00:00:01.5 UTC == 1998-04-02 00:00:32.5 TAI" - , "1998-04-02 00:00:02 UTC == 1998-04-02 00:00:33 TAI" - , "1998-04-02 23:59:28 UTC == 1998-04-02 23:59:59 TAI" - , "1998-04-02 23:59:28.5 UTC == 1998-04-02 23:59:59.5 TAI" - , "1998-04-02 23:59:29 UTC == 1998-04-03 00:00:00 TAI" - , "1998-04-02 23:59:29.5 UTC == 1998-04-03 00:00:00.5 TAI" - , "1998-04-02 23:59:30 UTC == 1998-04-03 00:00:01 TAI" - , "1998-04-02 23:59:30.5 UTC == 1998-04-03 00:00:01.5 TAI" - , "1998-04-02 23:59:31 UTC == 1998-04-03 00:00:02 TAI" - , "1998-04-02 23:59:31.5 UTC == 1998-04-03 00:00:02.5 TAI" - , "1998-04-02 23:59:32 UTC == 1998-04-03 00:00:03 TAI" - , "1998-04-02 23:59:59 UTC == 1998-04-03 00:00:30 TAI" - , "1998-04-02 23:59:59.5 UTC == 1998-04-03 00:00:30.5 TAI" - , "correction: 1998-04-02 23:59:60 UTC -> 1998-04-03 00:00:31 TAI -> 1998-04-03 00:00:00 UTC" - , "correction: 1998-04-02 23:59:60.5 UTC -> 1998-04-03 00:00:31.5 TAI -> 1998-04-03 00:00:00.5 UTC" - , "1998-12-30 00:00:00 UTC == 1998-12-30 00:00:31 TAI" - , "1998-12-30 00:00:00.5 UTC == 1998-12-30 00:00:31.5 TAI" - , "1998-12-30 00:00:01 UTC == 1998-12-30 00:00:32 TAI" - , "1998-12-30 00:00:01.5 UTC == 1998-12-30 00:00:32.5 TAI" - , "1998-12-30 00:00:02 UTC == 1998-12-30 00:00:33 TAI" - , "1998-12-30 23:59:28 UTC == 1998-12-30 23:59:59 TAI" - , "1998-12-30 23:59:28.5 UTC == 1998-12-30 23:59:59.5 TAI" - , "1998-12-30 23:59:29 UTC == 1998-12-31 00:00:00 TAI" - , "1998-12-30 23:59:29.5 UTC == 1998-12-31 00:00:00.5 TAI" - , "1998-12-30 23:59:30 UTC == 1998-12-31 00:00:01 TAI" - , "1998-12-30 23:59:30.5 UTC == 1998-12-31 00:00:01.5 TAI" - , "1998-12-30 23:59:31 UTC == 1998-12-31 00:00:02 TAI" - , "1998-12-30 23:59:31.5 UTC == 1998-12-31 00:00:02.5 TAI" - , "1998-12-30 23:59:32 UTC == 1998-12-31 00:00:03 TAI" - , "1998-12-30 23:59:59 UTC == 1998-12-31 00:00:30 TAI" - , "1998-12-30 23:59:59.5 UTC == 1998-12-31 00:00:30.5 TAI" - , "correction: 1998-12-30 23:59:60 UTC -> 1998-12-31 00:00:31 TAI -> 1998-12-31 00:00:00 UTC" - , "correction: 1998-12-30 23:59:60.5 UTC -> 1998-12-31 00:00:31.5 TAI -> 1998-12-31 00:00:00.5 UTC" - , "1998-12-31 00:00:00 UTC == 1998-12-31 00:00:31 TAI" - , "1998-12-31 00:00:00.5 UTC == 1998-12-31 00:00:31.5 TAI" - , "1998-12-31 00:00:01 UTC == 1998-12-31 00:00:32 TAI" - , "1998-12-31 00:00:01.5 UTC == 1998-12-31 00:00:32.5 TAI" - , "1998-12-31 00:00:02 UTC == 1998-12-31 00:00:33 TAI" - , "1998-12-31 23:59:28 UTC == 1998-12-31 23:59:59 TAI" - , "1998-12-31 23:59:28.5 UTC == 1998-12-31 23:59:59.5 TAI" - , "1998-12-31 23:59:29 UTC == 1999-01-01 00:00:00 TAI" - , "1998-12-31 23:59:29.5 UTC == 1999-01-01 00:00:00.5 TAI" - , "1998-12-31 23:59:30 UTC == 1999-01-01 00:00:01 TAI" - , "1998-12-31 23:59:30.5 UTC == 1999-01-01 00:00:01.5 TAI" - , "1998-12-31 23:59:31 UTC == 1999-01-01 00:00:02 TAI" - , "1998-12-31 23:59:31.5 UTC == 1999-01-01 00:00:02.5 TAI" - , "1998-12-31 23:59:32 UTC == 1999-01-01 00:00:03 TAI" - , "1998-12-31 23:59:59 UTC == 1999-01-01 00:00:30 TAI" - , "1998-12-31 23:59:59.5 UTC == 1999-01-01 00:00:30.5 TAI" - , "1998-12-31 23:59:60 UTC == 1999-01-01 00:00:31 TAI" - , "1998-12-31 23:59:60.5 UTC == 1999-01-01 00:00:31.5 TAI" - , "1999-01-01 00:00:00 UTC == 1999-01-01 00:00:32 TAI" - , "1999-01-01 00:00:00.5 UTC == 1999-01-01 00:00:32.5 TAI" - , "1999-01-01 00:00:01 UTC == 1999-01-01 00:00:33 TAI" - , "1999-01-01 00:00:01.5 UTC == 1999-01-01 00:00:33.5 TAI" - , "1999-01-01 00:00:02 UTC == 1999-01-01 00:00:34 TAI" - , "1999-01-01 23:59:28 UTC == 1999-01-02 00:00:00 TAI" - , "1999-01-01 23:59:28.5 UTC == 1999-01-02 00:00:00.5 TAI" - , "1999-01-01 23:59:29 UTC == 1999-01-02 00:00:01 TAI" - , "1999-01-01 23:59:29.5 UTC == 1999-01-02 00:00:01.5 TAI" - , "1999-01-01 23:59:30 UTC == 1999-01-02 00:00:02 TAI" - , "1999-01-01 23:59:30.5 UTC == 1999-01-02 00:00:02.5 TAI" - , "1999-01-01 23:59:31 UTC == 1999-01-02 00:00:03 TAI" - , "1999-01-01 23:59:31.5 UTC == 1999-01-02 00:00:03.5 TAI" - , "1999-01-01 23:59:32 UTC == 1999-01-02 00:00:04 TAI" - , "1999-01-01 23:59:59 UTC == 1999-01-02 00:00:31 TAI" - , "1999-01-01 23:59:59.5 UTC == 1999-01-02 00:00:31.5 TAI" - , "correction: 1999-01-01 23:59:60 UTC -> 1999-01-02 00:00:32 TAI -> 1999-01-02 00:00:00 UTC" - , "correction: 1999-01-01 23:59:60.5 UTC -> 1999-01-02 00:00:32.5 TAI -> 1999-01-02 00:00:00.5 UTC" - , "1999-01-02 00:00:00 UTC == 1999-01-02 00:00:32 TAI" - , "1999-01-02 00:00:00.5 UTC == 1999-01-02 00:00:32.5 TAI" - , "1999-01-02 00:00:01 UTC == 1999-01-02 00:00:33 TAI" - , "1999-01-02 00:00:01.5 UTC == 1999-01-02 00:00:33.5 TAI" - , "1999-01-02 00:00:02 UTC == 1999-01-02 00:00:34 TAI" - , "1999-01-02 23:59:28 UTC == 1999-01-03 00:00:00 TAI" - , "1999-01-02 23:59:28.5 UTC == 1999-01-03 00:00:00.5 TAI" - , "1999-01-02 23:59:29 UTC == 1999-01-03 00:00:01 TAI" - , "1999-01-02 23:59:29.5 UTC == 1999-01-03 00:00:01.5 TAI" - , "1999-01-02 23:59:30 UTC == 1999-01-03 00:00:02 TAI" - , "1999-01-02 23:59:30.5 UTC == 1999-01-03 00:00:02.5 TAI" - , "1999-01-02 23:59:31 UTC == 1999-01-03 00:00:03 TAI" - , "1999-01-02 23:59:31.5 UTC == 1999-01-03 00:00:03.5 TAI" - , "1999-01-02 23:59:32 UTC == 1999-01-03 00:00:04 TAI" - , "1999-01-02 23:59:59 UTC == 1999-01-03 00:00:31 TAI" - , "1999-01-02 23:59:59.5 UTC == 1999-01-03 00:00:31.5 TAI" - , "correction: 1999-01-02 23:59:60 UTC -> 1999-01-03 00:00:32 TAI -> 1999-01-03 00:00:00 UTC" - , "correction: 1999-01-02 23:59:60.5 UTC -> 1999-01-03 00:00:32.5 TAI -> 1999-01-03 00:00:00.5 UTC" ] diff --git a/test/Test/TestTAI.hs b/test/Test/TestTAI.hs new file mode 100644 --- /dev/null +++ b/test/Test/TestTAI.hs @@ -0,0 +1,60 @@ +module Test.TestTAI(testTAI) where + +import Data.Time +import Data.Time.Clock.TAI +import Test.TestUtil + + +sampleLeapSecondMap :: LeapSecondMap +sampleLeapSecondMap d | d < fromGregorian 1972 1 1 = Nothing +sampleLeapSecondMap d | d < fromGregorian 1972 7 1 = Just 10 +sampleLeapSecondMap d | d < fromGregorian 1975 1 1 = Just 11 +sampleLeapSecondMap _ = Nothing + +testTAI :: TestTree; +testTAI = testGroup "leap second transition" $ let + dayA = fromGregorian 1972 6 30 + dayB = fromGregorian 1972 7 1 + + utcTime1 = UTCTime dayA 86399 + utcTime2 = UTCTime dayA 86400 + utcTime3 = UTCTime dayB 0 + + mAbsTime1 = utcToTAITime sampleLeapSecondMap utcTime1 + mAbsTime2 = utcToTAITime sampleLeapSecondMap utcTime2 + mAbsTime3 = utcToTAITime sampleLeapSecondMap utcTime3 + in + [ + testCase "mapping" $ do + assertEqual "dayA" (Just 10) $ sampleLeapSecondMap dayA + assertEqual "dayB" (Just 11) $ sampleLeapSecondMap dayB + , + testCase "day length" $ do + assertEqual "dayA" (Just 86401) $ utcDayLength sampleLeapSecondMap dayA + assertEqual "dayB" (Just 86400) $ utcDayLength sampleLeapSecondMap dayB + , + testCase "differences" $ do + absTime1 <- assertJust mAbsTime1 + absTime2 <- assertJust mAbsTime2 + absTime3 <- assertJust mAbsTime3 + assertEqual "absTime2 - absTime1" 1 $ diffAbsoluteTime absTime2 absTime1 + assertEqual "absTime3 - absTime2" 1 $ diffAbsoluteTime absTime3 absTime2 + , + testGroup "round-trip" + [ + testCase "1" $ do + absTime <- assertJust mAbsTime1 + utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime + assertEqual "round-trip" utcTime1 utcTime + , + testCase "2" $ do + absTime <- assertJust mAbsTime2 + utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime + assertEqual "round-trip" utcTime2 utcTime + , + testCase "3" $ do + absTime <- assertJust mAbsTime3 + utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime + assertEqual "round-trip" utcTime3 utcTime + ] + ] diff --git a/test/Test/TestUtil.hs b/test/Test/TestUtil.hs --- a/test/Test/TestUtil.hs +++ b/test/Test/TestUtil.hs @@ -37,3 +37,23 @@ diff expected found | expected == found = Pass diff expected found = Fail ("expected " ++ (show expected) ++ " but found " ++ (show found)) + +-- for tasty-like test code + +type TestTree = Test +type Assertion = Either String () + +testCase :: String -> Assertion -> Test +testCase name (Right ()) = pureTest name Pass +testCase name (Left s) = pureTest name (Fail s) + +assertFailure :: String -> Either String a +assertFailure = Left + +assertEqual :: (Show a,Eq a) => String -> a -> a -> Assertion +assertEqual _ expected found | expected == found = return () +assertEqual name expected found = assertFailure $ name ++ ": expected " ++ (show expected) ++ " but found " ++ (show found) + +assertJust :: Maybe a -> Either String a +assertJust (Just a) = return a +assertJust Nothing = assertFailure "Nothing" diff --git a/test/Test/Tests.hs b/test/Test/Tests.hs --- a/test/Test/Tests.hs +++ b/test/Test/Tests.hs @@ -10,8 +10,8 @@ import Test.TestEaster import Test.TestFormat import Test.TestMonthDay -import Test.TestParseDAT import Test.TestParseTime +import Test.TestTAI import Test.TestTime import Test.TestTimeZone import Test.TestValid @@ -25,8 +25,8 @@ , testEaster , testFormat , testMonthDay - , testParseDAT , testParseTime + , testTAI , testTime , testTimeZone , testValid ] diff --git a/time.cabal b/time.cabal --- a/time.cabal +++ b/time.cabal @@ -1,5 +1,5 @@ name: time -version: 1.6.0.1 +version: 1.7 stability: stable license: BSD3 license-file: LICENSE @@ -100,7 +100,7 @@ ghc-options: -Wall -fwarn-tabs build-depends: base, - time == 1.6.0.1 + time == 1.7 main-is: ShowDefaultTZAbbreviations.hs test-suite tests @@ -122,7 +122,7 @@ build-depends: base, deepseq, - time == 1.6.0.1, + time == 1.7, QuickCheck >= 2.5.1, test-framework >= 0.8, test-framework-quickcheck2 >= 0.3, @@ -132,9 +132,6 @@ Test.Tests Test.TestTime Test.TestTimeRef - Test.TestParseDAT - Test.TAI_UTC_DAT - Test.TestParseDAT_Ref Test.TestParseTime Test.TestMonthDay Test.TestMonthDayRef @@ -143,6 +140,7 @@ Test.TestEasterRef Test.TestCalendars Test.TestCalendarsRef + Test.TestTAI Test.TestTimeZone Test.TestValid Test.LongWeekYears