time-1.16: test/main/Test/Format/ParseTime.hs
{-# OPTIONS -fno-warn-orphans #-}
module Test.Format.ParseTime (
testParseTime,
test_parse_format,
) where
import Control.Monad
import Data.Char
import Data.Maybe
import Data.Proxy
import Data.Time
import Data.Time.Calendar.Month
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.Quarter
import Data.Time.Calendar.WeekDate
import Test.Arbitrary (supportedDayRange)
import Test.QuickCheck.Property
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck hiding (reason)
import Test.TestUtil
format :: FormatTime t => String -> t -> String
format f t = formatTime defaultTimeLocale f t
parse :: ParseTime t => Bool -> String -> String -> Maybe t
parse sp f t = parseTimeM sp defaultTimeLocale f t
data FormatOnly
data ParseAndFormat
data FormatCode pf t = MkFormatCode
{ fcModifier :: String
, fcWidth :: Maybe Int
, fcAlt :: Bool
, fcSpecifier :: Char
}
instance Show (FormatCode pf t) where
show (MkFormatCode m w a s) =
let
ms = m
ws = fromMaybe "" $ fmap show w
as =
if a
then "E"
else ""
ss = [s]
in
'%' : (ms <> ws <> as <> ss)
formatCode :: FormatTime t => FormatCode pf t -> t -> String
formatCode fc = format $ show fc
parseCode :: ParseTime t => FormatCode ParseAndFormat t -> String -> Maybe t
parseCode fc = parse False $ show fc
class HasFormatCodes t where
allFormatCodes :: Proxy t -> [(Bool, Char)]
incompleteS :: Maybe t
incompleteS = Nothing
minCodeWidth :: Char -> Int
minCodeWidth _ = 0
fcShrink :: FormatCode pf t -> [FormatCode pf t]
fcShrink fc =
let
fc1 = case fcWidth fc of
Nothing -> []
Just w
| w > (minCodeWidth $ fcSpecifier fc) -> [fc{fcWidth = Nothing}, fc{fcWidth = Just $ w - 1}]
Just _ -> [fc{fcWidth = Nothing}]
fc2 = case fcAlt fc of
False -> []
True -> [fc{fcAlt = False}]
fc3 = case fcModifier fc of
"" -> []
_ -> [fc{fcModifier = ""}]
in
fc1 ++ fc2 ++ fc3
instance HasFormatCodes t => Arbitrary (FormatCode FormatOnly t) where
arbitrary = do
m <- oneof [return "", oneof $ fmap return ["", "-", "_", "0", "^", "#"]]
(a, s) <- oneof $ fmap return $ allFormatCodes (Proxy :: Proxy t)
w <-
case minCodeWidth s of
0 -> return Nothing
mw -> oneof [return Nothing, fmap Just $ choose (mw, 15)]
return $ MkFormatCode m w a s
shrink = fcShrink
instance HasFormatCodes t => Arbitrary (FormatCode ParseAndFormat t) where
arbitrary = do
(a, s) <- oneof $ fmap return $ allFormatCodes (Proxy :: Proxy t)
m <-
case s of
'Z' -> return ""
'z' -> return ""
_ -> oneof [return "", oneof $ fmap return ["", "-", "_", "0"]]
return $ MkFormatCode m Nothing a s
shrink = fcShrink
testParseTime :: TestTree
testParseTime =
testGroup
"testParseTime"
[ readsTests
, simpleFormatTests
, extests
, spacingTests
, particularParseTests
, badParseTests
, defaultTimeZoneTests
, militaryTimeZoneTests
, propertyTests
]
yearDays :: Integer -> [Day]
yearDays y = [(fromGregorian y 1 1) .. (fromGregorian y 12 31)]
makeExhaustiveTest :: String -> [t] -> (t -> TestTree) -> TestTree
makeExhaustiveTest name cases f = testGroup name (fmap f cases)
extests :: TestTree
extests =
testGroup
"exhaustive"
( [ makeExhaustiveTest "parse %y" [0 .. 99] parseYY
, makeExhaustiveTest "parse %-C %y 1900s" [0, 1, 50, 99] (parseCYY 19)
, makeExhaustiveTest "parse %-C %y 2000s" [0, 1, 50, 99] (parseCYY 20)
, makeExhaustiveTest "parse %-C %y 1400s" [0, 1, 50, 99] (parseCYY 14)
, makeExhaustiveTest "parse %C %y 0700s" [0, 1, 50, 99] (parseCYY2 7)
, makeExhaustiveTest "parse %-C %y 700s" [0, 1, 50, 99] (parseCYY 7)
, makeExhaustiveTest "parse %-C %y -700s" [0, 1, 50, 99] (parseCYY (-7))
, makeExhaustiveTest "parse %-C %y -70000s" [0, 1, 50, 99] (parseCYY (-70000))
, makeExhaustiveTest "parse %-C %y 10000s" [0, 1, 50, 99] (parseCYY 100)
, makeExhaustiveTest "parse %-C centuries" [20 .. 100] (parseCentury " ")
, makeExhaustiveTest "parse %-C century X" [1, 10, 20, 100] (parseCentury "X")
, makeExhaustiveTest "parse %-C century 2sp" [1, 10, 20, 100] (parseCentury " ")
, makeExhaustiveTest "parse %-C century 5sp" [1, 10, 20, 100] (parseCentury " ")
]
++ ( concat $
fmap
( \y ->
[ {- (makeExhaustiveTest "parse %Y%m%d" (yearDays y) parseYMD)
, -} (makeExhaustiveTest "parse %Y %m %d" (yearDays y) parseYearDayD)
, (makeExhaustiveTest "parse %Y %-m %e" (yearDays y) parseYearDayE)
]
)
[1, 4, 20, 753, 2000, 2011, 10001, (-1166)]
)
)
testReads :: (Eq a, Show a, Read a) => [(a, String)] -> String -> TestTree
testReads expected target =
let
found = reads target
result = assertEqual "" expected found
name = show target
in
Test.Tasty.HUnit.testCase name result
readsTestsParensSpaces ::
forall a.
(Eq a, Show a, Read a) =>
a ->
String ->
TestTree
readsTestsParensSpaces expected target =
testGroup
target
[ testReads [(expected, "")] $ target
, testReads [(expected, "")] $ "(" ++ target ++ ")"
, testReads [(expected, "")] $ " (" ++ target ++ ")"
, testReads [(expected, " ")] $ " ( " ++ target ++ " ) "
, testReads [(expected, " ")] $ " (( " ++ target ++ " )) "
, testReads ([] :: [(a, String)]) $ "(" ++ target
, testReads [(expected, ")")] $ "" ++ target ++ ")"
, testReads [(expected, "")] $ "((" ++ target ++ "))"
, testReads [(expected, " ")] $ " ( ( " ++ target ++ " ) ) "
]
readsTests :: TestTree
readsTests =
testGroup
"reads"
[ readsTestsParensSpaces (3 :: Integer) "3"
, readsTestsParensSpaces "a" "\"a\""
, readsTestsParensSpaces testDay "1912-07-08"
, -- , readsTestsParensSpaces testDay "1912-7-8"
readsTestsParensSpaces testTimeOfDay "08:04:02"
-- , readsTestsParensSpaces testTimeOfDay "8:4:2"
]
where
testDay = fromGregorian 1912 7 8
testTimeOfDay = TimeOfDay 8 4 2
epoch :: LocalTime
epoch = LocalTime (fromGregorian 1970 0 0) midnight
testReadSTime :: (Show a, Eq a, ParseTime a) => [(a, String)] -> String -> String -> TestTree
testReadSTime expected formatStr target =
let
found = readSTime False defaultTimeLocale formatStr target
result = assertEqual "" expected found
name = (show formatStr) ++ " of " ++ (show target)
in
Test.Tasty.HUnit.testCase name result
simpleFormatTests :: TestTree
simpleFormatTests =
testGroup
"simple"
[ testReadSTime [(epoch, "")] "" ""
, testReadSTime [(epoch, " ")] "" " "
, testReadSTime [(epoch, "")] " " " "
, testReadSTime [(epoch, "")] " " " "
, testReadSTime [(epoch, "")] "%k" "0"
, testReadSTime [(epoch, "")] "%k" " 0"
, testReadSTime [(epoch, "")] "%m" "01"
, testReadSTime [(epoch, " ")] "%m" "01 "
, testReadSTime [(epoch, " ")] " %m" " 01 "
, testReadSTime [(epoch, "")] " %m" " 01"
, -- https://ghc.haskell.org/trac/ghc/ticket/9150
testReadSTime [(epoch, "")] " %M" " 00"
, testReadSTime [(epoch, "")] "%M " "00 "
, testReadSTime [(epoch, "")] "%Q" ""
, testReadSTime [(epoch, " ")] "%Q" " "
, testReadSTime [(epoch, "X")] "%Q" "X"
, testReadSTime [(epoch, " X")] "%Q" " X"
, testReadSTime [(epoch, "")] "%Q " " "
, testReadSTime [(epoch, "")] "%Q X" " X"
, testReadSTime [(epoch, "")] "%QX" "X"
]
spacingForFormatTests :: (Show t, Eq t, ParseTime t) => t -> String -> String -> TestTree
spacingForFormatTests expected formatStr target =
testGroup
formatStr
[ parseTest False (Just expected) formatStr target
, parseTest True (Just expected) formatStr target
, parseTest False (Just expected) (formatStr ++ " ") (target ++ " ")
, parseTest True (Just expected) (formatStr ++ " ") (target ++ " ")
, parseTest False (Just expected) (" " ++ formatStr) (" " ++ target)
, parseTest True (Just expected) (" " ++ formatStr) (" " ++ target)
, parseTest True (Just expected) ("" ++ formatStr) (" " ++ target)
, parseTest True (Just expected) (" " ++ formatStr) (" " ++ target)
]
spacingTests :: TestTree
spacingTests =
testGroup
"spacing"
[ spacingForFormatTests epoch "%Q" ""
, spacingForFormatTests epoch "%Q" ".0"
, spacingForFormatTests epoch "%k" " 0"
, spacingForFormatTests epoch "%M" "00"
, spacingForFormatTests epoch "%m" "01"
, spacingForFormatTests (TimeZone 120 False "") "%z" "+0200"
, spacingForFormatTests (TimeZone 120 False "") "%Z" "+0200"
, spacingForFormatTests (TimeZone (-480) False "PST") "%Z" "PST"
]
particularParseTests :: TestTree
particularParseTests =
testGroup
"particular"
[ parseTest @Day True Nothing "%-d%-m%0Y" "2122012" -- ISSUE #232
, parseTest @Day True Nothing "%-d%-m%0Y" "2132012" -- ISSUE #232
]
badParseTests :: TestTree
badParseTests = testGroup "bad" [parseTest False (Nothing :: Maybe Day) "%Y" ""]
{-
parseYMD :: Day -> TestTree
parseYMD day = case toGregorian day of
(y, m, d) -> parseTest False (Just day) "%Y%m%d" ((show y) ++ (show2 m) ++ (show2 d))
-}
parseYearDayD :: Day -> TestTree
parseYearDayD day = case toGregorian day of
(y, m, d) -> parseTest False (Just day) "%Y %m %d" ((show y) ++ " " ++ (show2 m) ++ " " ++ (show2 d))
parseYearDayE :: Day -> TestTree
parseYearDayE day = case toGregorian day of
(y, m, d) -> parseTest False (Just day) "%Y %-m %e" ((show y) ++ " " ++ (show m) ++ " " ++ (show d))
-- | 1969 - 2068
expectedYear :: Integer -> Integer
expectedYear i | i >= 69 = 1900 + i
expectedYear i = 2000 + i
show2 :: (Show n, Integral n) => n -> String
show2 i = (show (div i 10)) ++ (show (mod i 10))
parseYY :: Integer -> TestTree
parseYY i = parseTest False (Just (fromGregorian (expectedYear i) 1 1)) "%y" (show2 i)
parseCYY :: Integer -> Integer -> TestTree
parseCYY c i = parseTest False (Just (fromGregorian ((c * 100) + i) 1 1)) "%-C %y" ((show c) ++ " " ++ (show2 i))
parseCYY2 :: Integer -> Integer -> TestTree
parseCYY2 c i = parseTest False (Just (fromGregorian ((c * 100) + i) 1 1)) "%C %y" ((show2 c) ++ " " ++ (show2 i))
parseCentury :: String -> Integer -> TestTree
parseCentury int c =
parseTest False (Just (fromGregorian (c * 100) 1 1)) ("%-C" ++ int ++ "%y") ((show c) ++ int ++ "00")
parseTest :: forall t. (Show t, Eq t, ParseTime t) => Bool -> Maybe t -> String -> String -> TestTree
parseTest sp expected formatStr target =
let
found = parse sp formatStr target
result = assertEqual "" expected found
name =
(show formatStr)
++ " of "
++ (show target)
++ ( if sp
then " allowing spaces"
else ""
)
in
Test.Tasty.HUnit.testCase name result
enumAdd :: Enum a => Int -> a -> a
enumAdd i a = toEnum (i + fromEnum a)
getMilZoneLetter :: Int -> Char
getMilZoneLetter 0 = 'Z'
getMilZoneLetter h | h < 0 = enumAdd (negate h) 'M'
getMilZoneLetter h | h < 10 = enumAdd (h - 1) 'A'
getMilZoneLetter h = enumAdd (h - 10) 'K'
getMilZone :: Int -> TimeZone
getMilZone hour = TimeZone (hour * 60) False [getMilZoneLetter hour]
testParseTimeZone :: TimeZone -> TestTree
testParseTimeZone tz = parseTest False (Just tz) "%Z" (timeZoneName tz)
defaultTimeZoneTests :: TestTree
defaultTimeZoneTests = testGroup "default time zones" (fmap testParseTimeZone (knownTimeZones defaultTimeLocale))
militaryTimeZoneTests :: TestTree
militaryTimeZoneTests = testGroup "military time zones" (fmap (testParseTimeZone . getMilZone) [-12 .. 12])
-- missing from the time package
instance Eq ZonedTime where
ZonedTime t1 tz1 == ZonedTime t2 tz2 = t1 == t2 && tz1 == tz2
compareResult' :: (Eq a, Show a) => String -> a -> a -> Result
compareResult' extra expected found
| expected == found = succeeded
| otherwise = failed{reason = "expected " ++ (show expected) ++ ", found " ++ (show found) ++ extra}
compareResult :: (Eq a, Show a) => a -> a -> Result
compareResult = compareResult' ""
compareParse ::
forall a.
(Eq a, Show a, ParseTime a) =>
a ->
String ->
String ->
Result
compareParse expected fmt text = compareResult' (", parsing " ++ (show text)) (Just expected) (parse False fmt text)
--
-- * tests for debugging failing cases
--
test_parse_format :: (FormatTime t, ParseTime t, Show t) => String -> t -> (String, String, Maybe t)
test_parse_format f t =
let
s = format f t
in
(show t, s, parse False f s `asTypeOf` Just t)
--
-- * show and read
--
reads_expect :: a -> [(a, String)]
reads_expect t = [(t, "")]
prop_read_show :: (Read a, Show a, Eq a) => a -> Result
prop_read_show t = compareResult (reads_expect t) (reads (show t))
prop_read_show_ZonedUTC :: ZonedTime -> Result
prop_read_show_ZonedUTC t = compareResult (reads_expect $ zonedTimeToUTC t) (reads (show t))
prop_read_show_LocalUTC :: LocalTime -> Result
prop_read_show_LocalUTC t = compareResult (reads_expect $ localTimeToUTC utc t) (reads (show t))
prop_read_show_UTC_no_TZ :: UTCTime -> Result
prop_read_show_UTC_no_TZ t = compareResult (reads_expect t) $ reads $ show $ utcToLocalTime utc t
--
-- * special show functions
--
prop_parse_showWeekDate :: Day -> Result
prop_parse_showWeekDate d = compareParse d "%G-W%V-%u" (showWeekDate d)
prop_parse_showGregorian :: Day -> Result
prop_parse_showGregorian d = compareParse d "%Y-%m-%d" (showGregorian d)
prop_parse_showOrdinalDate :: Day -> Result
prop_parse_showOrdinalDate d = compareParse d "%Y-%j" (showOrdinalDate d)
--
-- * fromMondayStartWeek and fromSundayStartWeek
--
prop_fromMondayStartWeek :: Day -> Result
prop_fromMondayStartWeek d =
let
(w, wd) = mondayStartWeek d
(y, _, _) = toGregorian d
in
compareResult d (fromMondayStartWeek y w wd)
prop_fromSundayStartWeek :: Day -> Result
prop_fromSundayStartWeek d =
let
(w, wd) = sundayStartWeek d
(y, _, _) = toGregorian d
in
compareResult d (fromSundayStartWeek y w wd)
-- t == parse (format t)
prop_parse_format :: (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result
prop_parse_format (FormatString f) t = compareParse t f (format f t)
-- t == parse (upper (format t))
prop_parse_format_upper :: (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result
prop_parse_format_upper (FormatString f) t = compareParse t f (map toUpper $ format f t)
-- t == parse (lower (format t))
prop_parse_format_lower :: (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result
prop_parse_format_lower (FormatString f) t = compareParse t f (map toLower $ format f t)
-- Default time is 1970-01-01 00:00:00 +0000 (which was a Thursday)
in1970 :: Maybe String -> Char -> String -> Maybe String
in1970 _ 'j' "366" = Nothing -- 1970 was not a leap year
in1970 _ 'U' "53" = Nothing -- last day of 1970 was Sunday-start-week 52
in1970 _ 'W' "53" = Nothing -- last day of 1970 was Monday-start-week 52
in1970 (Just s) 'S' "60" = Just s -- no leap second without other data
in1970 _ _ s = Just s
-- format t == format (parse (format t))
prop_format_parse_format ::
forall t.
(HasFormatCodes t, FormatTime t, ParseTime t) =>
Proxy t ->
FormatCode ParseAndFormat t ->
t ->
Result
prop_format_parse_format _ fc v =
let
s1 = formatCode fc v
ms1 = in1970 (fmap (formatCode fc) (incompleteS :: Maybe t)) (fcSpecifier fc) s1
mv2 :: Maybe t
mv2 = parseCode fc s1
ms2 = fmap (formatCode fc) mv2
in
compareResult ms1 ms2
instance HasFormatCodes Day where
allFormatCodes _ = [(False, s) | s <- "DFxYyCBbhmdejfVUW"]
instance HasFormatCodes TimeOfDay where
allFormatCodes _ = [(False, s) | s <- "RTXrPpHkIlMSqQ"]
instance HasFormatCodes DayOfWeek where
allFormatCodes _ = [(False, s) | s <- "uwaA"]
instance HasFormatCodes Month where
allFormatCodes _ = [(False, s) | s <- "YyCBbhm"]
instance HasFormatCodes QuarterOfYear where
allFormatCodes _ = [(False, s) | s <- "v"]
instance HasFormatCodes Quarter where
allFormatCodes _ = allFormatCodes (Proxy :: Proxy QuarterOfYear) ++ [(False, s) | s <- "YyC"]
instance HasFormatCodes LocalTime where
allFormatCodes _ = allFormatCodes (Proxy :: Proxy Day) ++ allFormatCodes (Proxy :: Proxy TimeOfDay)
instance HasFormatCodes TimeZone where
allFormatCodes _ = [(a, s) | a <- [False, True], s <- "zZ"]
instance HasFormatCodes ZonedTime where
allFormatCodes _ =
[(False, s) | s <- "cs"]
++ allFormatCodes (Proxy :: Proxy LocalTime)
++ allFormatCodes (Proxy :: Proxy TimeZone)
instance HasFormatCodes UTCTime where
allFormatCodes _ = [(False, s) | s <- "cs"] ++ allFormatCodes (Proxy :: Proxy LocalTime)
incompleteS = Just $ UTCTime (fromGregorian 2000 1 1) 0
instance HasFormatCodes UniversalTime where
allFormatCodes _ = allFormatCodes (Proxy :: Proxy LocalTime)
--
-- * crashes in parse
--
newtype Input
= Input String
instance Show Input where
show (Input s) = s
instance Arbitrary Input where
arbitrary = liftM Input $ list cs
where
cs = elements (['0' .. '9'] ++ ['-', ' ', '/'] ++ ['a' .. 'z'] ++ ['A' .. 'Z'])
list g = sized (\n -> choose (0, n) >>= \l -> replicateM l g)
instance CoArbitrary Input where
coarbitrary (Input s) = coarbitrary (sum (map ord s))
prop_no_crash_bad_input :: (Eq t, ParseTime t) => FormatString t -> Input -> Property
prop_no_crash_bad_input fs@(FormatString f) (Input s) =
property $
case parse False f s of
Nothing -> True
Just t -> t == t `asTypeOf` formatType fs
--
--
--
newtype FormatString a
= FormatString String
formatType :: FormatString t -> t
formatType _ = undefined
instance Show (FormatString a) where
show (FormatString f) = show f
typedTests :: (forall t. (Eq t, FormatTime t, ParseTime t, Show t) => FormatString t -> t -> Result) -> [TestTree]
typedTests prop =
[ nameTest "Day" $ tgroup dayFormats prop
, nameTest "Month" $ tgroup monthFormats prop
, nameTest "Quarter" $ tgroup quarterFormats prop
, nameTest "TimeOfDay" $ tgroup timeOfDayFormats prop
, nameTest "LocalTime" $ tgroup localTimeFormats prop
, nameTest "TimeZone" $ tgroup timeZoneFormats prop
, nameTest "ZonedTime" $ tgroup zonedTimeFormats prop
, nameTest "ZonedTime" $
tgroup zonedTimeAlmostFormats $
\fmt t -> (todSec $ localTimeOfDay $ zonedTimeToLocalTime t) < 60 ==> prop fmt t
, nameTest "UTCTime" $ tgroup utcTimeAlmostFormats $ \fmt t -> utctDayTime t < 86400 ==> prop fmt t
, nameTest "UniversalTime" $ tgroup universalTimeFormats prop
, nameTest "CalendarDiffDays" $ tgroup calendarDiffDaysFormats prop
, nameTest "CalendarDiffTime" $ tgroup calendarDiffTimeFormats prop
, nameTest "DiffTime" $ tgroup diffTimeFormats prop
, nameTest "NominalDiffTime" $ tgroup nominalDiffTimeFormats prop
]
allTypes ::
(forall t. (Eq t, Show t, Arbitrary t, FormatTime t, ParseTime t, HasFormatCodes t) => String -> Proxy t -> r) ->
[r]
allTypes f =
[ f "Day" (Proxy :: Proxy Day)
, f "TimeOfDay" (Proxy :: Proxy TimeOfDay)
, f "DayOfWeek" (Proxy :: Proxy DayOfWeek)
, f "Month" (Proxy :: Proxy Month)
, f "QuarterOfYear" (Proxy :: Proxy QuarterOfYear)
, f "Quarter" (Proxy :: Proxy Quarter)
, f "LocalTime" (Proxy :: Proxy LocalTime)
, f "TimeZone" (Proxy :: Proxy TimeZone)
, f "ZonedTime" (Proxy :: Proxy ZonedTime)
, f "UTCTime" (Proxy :: Proxy UTCTime)
, f "UniversalTime" (Proxy :: Proxy UniversalTime)
]
allLeapSecondTypes ::
(forall t. (Eq t, Show t, Arbitrary t, FormatTime t, ParseTime t, HasFormatCodes t) => String -> t -> r) ->
[r]
allLeapSecondTypes f =
let
day :: Day
day = fromGregorian 2000 01 01
lsTimeOfDay :: TimeOfDay
lsTimeOfDay = TimeOfDay 23 59 60.5
lsLocalTime :: LocalTime
lsLocalTime = LocalTime day lsTimeOfDay
lsZonedTime :: ZonedTime
lsZonedTime = ZonedTime lsLocalTime utc
lsUTCTime :: UTCTime
lsUTCTime = UTCTime day 86400.5
in
[ f "TimeOfDay" lsTimeOfDay
, f "LocalTime" lsLocalTime
, f "ZonedTime" lsZonedTime
, f "UTCTime" lsUTCTime
]
parseEmptyTest ::
forall t.
ParseTime t =>
Proxy t ->
Assertion
parseEmptyTest _ =
case parse False "" "" :: Maybe t of
Just _ -> return ()
Nothing -> assertFailure "failed"
parseEmptyTests :: TestTree
parseEmptyTests = nameTest "parse empty" $ allTypes $ \name p -> nameTest name $ parseEmptyTest p
class (Eq a, Show a, ParseTime a) => TestParse a where
nonPosixValue :: a -> Bool
nonPosixValue _ = False
instance TestParse UTCTime where
nonPosixValue (UTCTime _ dt) = dt >= 86400 || dt < 0
instance TestParse ZonedTime where
nonPosixValue (ZonedTime t _) = nonPosixValue t
instance TestParse TimeZone
instance TestParse LocalTime where
nonPosixValue (LocalTime _ t) = nonPosixValue t
instance TestParse Day
instance TestParse Month
instance TestParse DayOfWeek
instance TestParse TimeOfDay where
nonPosixValue (TimeOfDay _ _ s) = s >= 60 || s < 0
prop_parse_s :: forall a. TestParse a => (UTCTime -> a) -> UTCTime -> Result
prop_parse_s f t =
if nonPosixValue t
then succeeded
else
let
str = format "%s%Q" t
found = parse False "%s%Q" str
expected = f t
in
compareResult (Just expected) found
prop_parse_sz :: forall a. TestParse a => (ZonedTime -> a) -> ZonedTime -> Result
prop_parse_sz f t =
if nonPosixValue t
then succeeded
else
let
str = format "%s%Q %z" t
found = parse False "%s%Q %z" str
expected = f t
in
compareResult (Just expected) found
zeroTimeZone :: TimeZone
zeroTimeZone = TimeZone 0 False ""
parse_s_tests :: TestTree
parse_s_tests =
nameTest
"parse_s"
[ nameTest "UTCTime" $ prop_parse_s @UTCTime id
, nameTest "ZonedTime" $ prop_parse_s @ZonedTime $ utcToZonedTime zeroTimeZone
, nameTest "TimeZone" $ prop_parse_s @TimeZone $ \_ -> zeroTimeZone
, nameTest "LocalTime" $ prop_parse_s @LocalTime $ utcToLocalTime zeroTimeZone
, nameTest "Day" $ prop_parse_s @Day utctDay
, nameTest "Month" $ prop_parse_s @Month $ (\(MonthDay m _) -> m) . utctDay
, nameTest "DayOfWeek" $ prop_parse_s @DayOfWeek $ dayOfWeek . utctDay
, nameTest "TimeOfDay" $ prop_parse_s @TimeOfDay $ localTimeOfDay . utcToLocalTime zeroTimeZone
]
parse_sz_tests :: TestTree
parse_sz_tests =
nameTest
"parse_sz"
[ nameTest "UTCTime" $ prop_parse_sz @UTCTime zonedTimeToUTC
, nameTest "ZonedTime" $ prop_parse_sz @ZonedTime id
, nameTest "TimeZone" $ prop_parse_sz @TimeZone zonedTimeZone
, nameTest "LocalTime" $ prop_parse_sz @LocalTime zonedTimeToLocalTime
, nameTest "Day" $ prop_parse_sz @Day $ localDay . zonedTimeToLocalTime
, nameTest "Month" $ prop_parse_sz @Month $ (\(MonthDay m _) -> m) . localDay . zonedTimeToLocalTime
, nameTest "DayOfWeek" $ prop_parse_sz @DayOfWeek $ dayOfWeek . localDay . zonedTimeToLocalTime
, nameTest "TimeOfDay" $ prop_parse_sz @TimeOfDay $ localTimeOfDay . zonedTimeToLocalTime
]
formatParseFormatTests :: TestTree
formatParseFormatTests =
nameTest
"format_parse_format"
[ localOption (QuickCheckTests 50000) $
nameTest "general" $
allTypes $
\name p -> nameTest name $ prop_format_parse_format p
, nameTest "#177" $
[ nameTest "start" $ \fc -> prop_format_parse_format Proxy fc (fst supportedDayRange)
, nameTest "end" $ \fc -> prop_format_parse_format Proxy fc (snd supportedDayRange)
]
, nameTest "leapsecond" $ allLeapSecondTypes $ \name t -> nameTest name $ \fc -> prop_format_parse_format Proxy fc t
]
badInputTests :: TestTree
badInputTests =
nameTest
"no_crash_bad_input"
[ nameTest "Day" $ tgroup (dayFormats ++ partialDayFormats ++ failingPartialDayFormats) prop_no_crash_bad_input
, nameTest "TimeOfDay" $ tgroup (timeOfDayFormats ++ partialTimeOfDayFormats) prop_no_crash_bad_input
, nameTest "LocalTime" $ tgroup (localTimeFormats ++ partialLocalTimeFormats) prop_no_crash_bad_input
, nameTest "TimeZone" $ tgroup (timeZoneFormats) prop_no_crash_bad_input
, nameTest "ZonedTime" $
tgroup (zonedTimeFormats ++ zonedTimeAlmostFormats ++ partialZonedTimeFormats) prop_no_crash_bad_input
, nameTest "UTCTime" $ tgroup (utcTimeAlmostFormats ++ partialUTCTimeFormats) prop_no_crash_bad_input
, nameTest "UniversalTime" $
tgroup (universalTimeFormats ++ partialUniversalTimeFormats) prop_no_crash_bad_input
]
readShowTests :: TestTree
readShowTests =
nameTest
"read_show"
[ nameTest "Day" (prop_read_show :: Day -> Result)
, nameTest "Month" (prop_read_show :: Month -> Result)
, nameTest "QuarterOfYear" (prop_read_show :: QuarterOfYear -> Result)
, nameTest "Quarter" (prop_read_show :: Quarter -> Result)
, nameTest "TimeOfDay" (prop_read_show :: TimeOfDay -> Result)
, nameTest "LocalTime" (prop_read_show :: LocalTime -> Result)
, nameTest "TimeZone" (prop_read_show :: TimeZone -> Result)
, nameTest "ZonedTime" (prop_read_show :: ZonedTime -> Result)
, nameTest "UTCTime" (prop_read_show :: UTCTime -> Result)
, nameTest "UTCTime (zoned)" prop_read_show_ZonedUTC
, nameTest "UTCTime (local)" prop_read_show_LocalUTC
, nameTest "UTCTime (no TZ)" prop_read_show_UTC_no_TZ
, nameTest "UniversalTime" (prop_read_show :: UniversalTime -> Result)
, nameTest "NominalDiffTime" (prop_read_show :: NominalDiffTime -> Result)
, nameTest "DiffTime" (prop_read_show :: DiffTime -> Result)
, nameTest "CalendarDiffDays" (prop_read_show :: CalendarDiffDays -> Result)
, nameTest "CalendarDiffTime" (prop_read_show :: CalendarDiffTime -> Result)
]
parseShowTests :: TestTree
parseShowTests =
nameTest
"parse_show"
[ nameTest "showWeekDate" prop_parse_showWeekDate
, nameTest "showGregorian" prop_parse_showGregorian
, nameTest "showOrdinalDate" prop_parse_showOrdinalDate
]
propertyTests :: TestTree
propertyTests =
localOption (QuickCheckTests 2000) $
nameTest
"properties"
[ readShowTests
, parseShowTests
, nameTest "fromMondayStartWeek" prop_fromMondayStartWeek
, nameTest "fromSundayStartWeek" prop_fromSundayStartWeek
, nameTest "parse_format" $ typedTests prop_parse_format
, nameTest "parse_format_lower" $ typedTests prop_parse_format_lower
, nameTest "parse_format_upper" $ typedTests prop_parse_format_upper
, parseEmptyTests
, parse_s_tests
, parse_sz_tests
, formatParseFormatTests
, badInputTests
]
dayFormats :: [FormatString Day]
dayFormats =
map
FormatString
-- numeric year, month, day
[ "%Y-%m-%d"
, "%Y%m%d"
, "%C%y%m%d"
, "%Y %m %e"
, "%m/%d/%Y"
, "%d/%m/%Y"
, "%Y/%d/%m"
, "%D %C"
, "%F"
, -- month names
"%Y-%B-%d"
, "%Y-%b-%d"
, "%Y-%h-%d"
, "%C-%y-%B-%d"
, "%C-%y-%b-%d"
, "%C-%y-%h-%d"
, -- ordinal dates
"%Y-%j"
, "%C-%y-%j"
, -- ISO week dates
"%G-%V-%u"
, "%G-%V-%a"
, "%G-%V-%A"
, "%G-%V-%w"
, "%A week %V, %G"
, "day %V, week %A, %G"
, "%G-W%V-%u"
, "%f%g-%V-%u"
, "%f%g-%V-%a"
, "%f%g-%V-%A"
, "%f%g-%V-%w"
, "%A week %V, %f%g"
, "day %V, week %A, %f%g"
, "%f%g-W%V-%u"
, -- monday and sunday week dates
"%Y-w%U-%A"
, "%Y-w%W-%A"
, "%Y-%A-w%U"
, "%Y-%A-w%W"
, "%A week %U, %Y"
, "%A week %W, %Y"
]
monthFormats :: [FormatString Month]
monthFormats =
map
FormatString
-- numeric year, month
[ "%Y-%m"
, "%Y%m"
, "%C%y%m"
, "%Y %m"
, "%m/%Y"
, "%m/%Y"
, "%Y/%m"
, "%C %y %m"
, -- month names
"%Y-%B"
, "%Y-%b"
, "%Y-%h"
, "%C-%y-%B"
, "%C-%y-%b"
, "%C-%y-%h"
]
quarterFormats :: [FormatString Quarter]
quarterFormats =
map
FormatString
-- numeric year, quarter
[ "%Y-%v"
, "%Y-Q%v"
, "%YQ%v"
, "%C%y%v"
, "%Y %v"
, "%v/%Y"
, "%v/%Y"
, "%Y/%vm"
, "%C %y %v"
]
timeOfDayFormats :: [FormatString TimeOfDay]
timeOfDayFormats =
map
FormatString
-- 24 h formats
[ "%H:%M:%S.%q"
, "%k:%M:%S.%q"
, "%H%M%S.%q"
, "%T.%q"
, "%X.%q"
, "%R:%S.%q"
, "%H:%M:%S%Q"
, "%k:%M:%S%Q"
, "%H%M%S%Q"
, "%T%Q"
, "%X%Q"
, "%R:%S%Q"
, -- 12 h formats
"%I:%M:%S.%q %p"
, "%I:%M:%S.%q %P"
, "%l:%M:%S.%q %p"
, "%r %q"
, "%I:%M:%S%Q %p"
, "%I:%M:%S%Q %P"
, "%l:%M:%S%Q %p"
, "%r %Q"
]
localTimeFormats :: [FormatString LocalTime]
localTimeFormats = map FormatString [] {-"%Q","%Q ","%QX"-}
timeZoneFormats :: [FormatString TimeZone]
timeZoneFormats = map FormatString ["%z", "%z%Z", "%Z%z", "%Z", "%Ez", "%EZ"]
zonedTimeFormats :: [FormatString ZonedTime]
zonedTimeFormats =
map
FormatString
[ "%a, %d %b %Y %H:%M:%S.%q %z"
, "%a, %d %b %Y %H:%M:%S%Q %z"
, "%a, %d %b %Y %H:%M:%S.%q %Z"
, "%a, %d %b %Y %H:%M:%S%Q %Z"
]
zonedTimeAlmostFormats :: [FormatString ZonedTime]
zonedTimeAlmostFormats = map FormatString ["%s.%q %z", "%s%Q %z", "%s.%q %Z", "%s%Q %Z"]
utcTimeAlmostFormats :: [FormatString UTCTime]
utcTimeAlmostFormats = map FormatString ["%s.%q", "%s%Q"]
universalTimeFormats :: [FormatString UniversalTime]
universalTimeFormats = map FormatString []
calendarDiffDaysFormats :: [FormatString CalendarDiffDays]
calendarDiffDaysFormats = map FormatString ["%yy%Bm%ww%Dd", "%yy%Bm%dd", "%bm%ww%Dd", "%bm%dd"]
calendarDiffTimeFormats :: [FormatString CalendarDiffTime]
calendarDiffTimeFormats =
map
FormatString
[ "%yy%Bm%ww%Dd%Hh%Mm%ESs"
, "%bm%ww%Dd%Hh%Mm%ESs"
, "%bm%dd%Hh%Mm%ESs"
, "%bm%hh%Mm%ESs"
, "%bm%mm%ESs"
, "%bm%mm%0ESs"
, "%bm%Ess"
, "%bm%0Ess"
]
diffTimeFormats :: [FormatString DiffTime]
diffTimeFormats =
map FormatString ["%ww%Dd%Hh%Mm%ESs", "%dd%Hh%Mm%ESs", "%hh%Mm%ESs", "%mm%ESs", "%mm%0ESs", "%Ess", "%0Ess"]
nominalDiffTimeFormats :: [FormatString NominalDiffTime]
nominalDiffTimeFormats =
map FormatString ["%ww%Dd%Hh%Mm%ESs", "%dd%Hh%Mm%ESs", "%hh%Mm%ESs", "%mm%ESs", "%mm%0ESs", "%Ess", "%0Ess"]
--
-- * Formats that do not include all the information
--
partialDayFormats :: [FormatString Day]
partialDayFormats = map FormatString []
partialTimeOfDayFormats :: [FormatString TimeOfDay]
partialTimeOfDayFormats = map FormatString ["%H", "%M", "%S", "%H:%M"]
partialLocalTimeFormats :: [FormatString LocalTime]
partialLocalTimeFormats = map FormatString []
partialZonedTimeFormats :: [FormatString ZonedTime]
partialZonedTimeFormats =
map
FormatString
-- %s does not include second decimals
[ "%s %z"
, -- %S does not include second decimals
"%c"
, "%a, %d %b %Y %H:%M:%S %Z"
]
partialUTCTimeFormats :: [FormatString UTCTime]
partialUTCTimeFormats =
map
FormatString
-- %s does not include second decimals
[ "%s"
, -- %c does not include second decimals
"%c"
]
partialUniversalTimeFormats :: [FormatString UniversalTime]
partialUniversalTimeFormats = map FormatString []
failingPartialDayFormats :: [FormatString Day]
failingPartialDayFormats =
map
FormatString
-- ISO week dates with two digit year.
-- This can fail in the beginning or the end of a year where
-- the ISO week date year does not match the gregorian year.
["%g-%V-%u", "%g-%V-%a", "%g-%V-%A", "%g-%V-%w", "%A week %V, %g", "day %V, week %A, %g", "%g-W%V-%u"]