@@ -3,79 +3,76 @@
33module Properties.ZonedTime (zonedTimeToJSON) where
44
55import Data.Aeson.Types
6−import Test.Framework (Test, defaultMain, testGroup)
7−import Test.Framework.Providers.QuickCheck2 (testProperty)
8−import Test.QuickCheck (Arbitrary(..), Property, (===), property)
96import Data.Time
107import Instances ()
11−import System.IO
12−import System.IO.Unsafe (unsafePerformIO)
8+import Test.Framework (Test, testGroup)
9+import Test.Framework.Providers.QuickCheck2 (testProperty)
10+import Test.QuickCheck ((===))
11+import Types
1312
1413#if !MIN_VERSION_time(1,5,0)
1514import System.Locale (defaultTimeLocale, dateTimeFmt)
1615#endif
1716
18−zonedTimeToJSON :: ZonedTime -> Bool
19−zonedTimeToJSON t = and $
20− toFromJSON' "%FT%T%QZ" t (clearTimeZone t) : -- (javascript new Date().toISOString())
21− toFromJSON' "%F %T%Q%z" t t : -- (postgres)
22− toFromJSON' "%F %T%Q %Z" t t : -- (time's Show format)
23− toFromJSON' "%FT%T%Q%z" t t :
24− toFromJSON' "%Y-%mT%T%Q" t (clearTimeZone . clearDay $ t) :
25− toFromJSON' "%Y-%mT%R" t (clearTimeZone . clearDay . clearSeconds $ t) :
26− toFromJSON' "%Y-%mT%T" t (clearTimeZone . clearDay $ t) :
27− toFromJSON' "%Y-%mT%T%QZ" t (clearTimeZone . clearDay $ t) :
28− toFromJSON' "%Y-%mT%T%Q%z" t (clearDay t) :
29− toFromJSON' "%YT%T%Q" t (clearTimeZone . clearMonth . clearDay $ t) :
30− toFromJSON' "%YT%R" t (clearTimeZone . clearMonth . clearDay . clearSeconds $ t) :
31− toFromJSON' "%YT%T" t (clearTimeZone . clearMonth . clearDay $ t) :
32− toFromJSON' "%YT%T%QZ" t (clearTimeZone . clearMonth . clearDay $ t) :
33− toFromJSON' "%YT%T%Q%z" t (clearMonth . clearDay $ t) :
34− toFromJSON' "%FT%T%Q" t (clearTimeZone t) :
35− toFromJSON' "%FT%R" t (clearTimeZone . clearSeconds $ t) :
36− toFromJSON' "%FT%T" t (clearTimeZone t) :
37− toFromJSON' (dateTimeFmt defaultTimeLocale) t t :
38− []
17+zonedTimeToJSON :: Test
18+zonedTimeToJSON = testGroup "ZonedTime" [
19+ test "%FT%T%QZ" clearTimeZone -- javascript new Date().toISOString()
20+ , test "%F %T%Q%z" id -- postgres
21+ , test "%F %T%Q %Z" id -- time's Show format
22+ , test "%FT%T%Q%z" id
23+ , test "%Y-%mT%T%Q" (clearTimeZone . clearDay)
24+ , test "%Y-%mT%R" (clearTimeZone . clearDay . clearSeconds)
25+ , test "%Y-%mT%T" (clearTimeZone . clearDay)
26+ , test "%Y-%mT%T%QZ" (clearTimeZone . clearDay)
27+ , test "%Y-%mT%T%Q%z" clearDay
28+ , test "%YT%T%Q" (clearTimeZone . clearMonth . clearDay)
29+ , test "%YT%R" (clearTimeZone . clearMonth . clearDay . clearSeconds)
30+ , test "%YT%T" (clearTimeZone . clearMonth . clearDay)
31+ , test "%YT%T%QZ" (clearTimeZone . clearMonth . clearDay)
32+ , test "%YT%T%Q%z" (clearMonth . clearDay)
33+ , test "%FT%T%Q" clearTimeZone
34+ , test "%FT%R" (clearTimeZone . clearSeconds)
35+ , test "%FT%T" clearTimeZone
36+ , test (dateTimeFmt defaultTimeLocale) id
37+ ]
3938 where
4039 toJSON' :: String -> ZonedTime -> Value
4140 toJSON' format = toJSON . formatTime defaultTimeLocale format
4241
43− toFromJSON' :: String -> ZonedTime -> ZonedTime -> Bool
44− toFromJSON' format t_ t_' = case fromJSON . toJSON' format $ t_ of
45− Error msg -> error' msg
46− Success t_'' -> if t_'' == t_' then True else error' (show t_'')
42+ test :: String -> (ZonedTime -> ZonedTime) -> Test
43+ test format f = testProperty format go
4744 where
48− error' :: String -> Bool
49− error' msg = unsafePerformIO (hPutStrLn stderr . ("zonedTimeToJSON: " ++) $ show
50− (format, t_, toJSON' format t_, t_', msg))
51− `seq` False
45+ go t = case fromJSON (toJSON' format t) of
46+ Error msg -> failure "fromJSON" msg t
47+ Success t' -> t' === f t
5248
5349clearTimeZone :: ZonedTime -> ZonedTime
5450clearTimeZone t = t { zonedTimeZone = TimeZone 0 False "" }
5551
5652clearMonth :: ZonedTime -> ZonedTime
57−clearMonth = f
53+clearMonth zt = zt { zonedTimeToLocalTime = g (zonedTimeToLocalTime zt) }
5854 where
59− f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
60− g lt = lt { localDay = h $ localDay lt }
55+ g lt = lt { localDay = h (localDay lt) }
6156
6257 h :: Day -> Day
63− h = maybe (error "clearMonth") id . parseTime defaultTimeLocale "%Y-%m-%d" . formatTime defaultTimeLocale "%Y-01-%d"
58+ h = maybe (error "clearMonth") id . parseTime defaultTimeLocale "%Y-%m-%d" .
59+ formatTime defaultTimeLocale "%Y-01-%d"
6460
6561clearDay :: ZonedTime -> ZonedTime
66−clearDay = f
62+clearDay zt = zt { zonedTimeToLocalTime = g (zonedTimeToLocalTime zt) }
6763 where
68− f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
69− g lt = lt { localDay = h $ localDay lt }
64+ g lt = lt { localDay = h (localDay lt) }
7065
7166 h :: Day -> Day
72− h = maybe (error "clearDay") id . parseTime defaultTimeLocale "%Y-%m-%d" . formatTime defaultTimeLocale "%Y-%m-01"
67+ h = maybe (error "clearDay") id . parseTime defaultTimeLocale "%Y-%m-%d" .
68+ formatTime defaultTimeLocale "%Y-%m-01"
7369
7470clearSeconds :: ZonedTime -> ZonedTime
75−clearSeconds = f
71+clearSeconds zt = zt { zonedTimeToLocalTime = g (zonedTimeToLocalTime zt) }
7672 where
77− f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
78− g lt = lt { localTimeOfDay = h $ localTimeOfDay lt }
73+ g lt = lt { localTimeOfDay = h (localTimeOfDay lt) }
7974
8075 h :: TimeOfDay -> TimeOfDay
81− h = maybe (error "clearSeconds") id . parseTime defaultTimeLocale "%H:%M:%S" . formatTime defaultTimeLocale "%H:%M:00"
76+ h = maybe (error "clearSeconds") id .
77+ parseTime defaultTimeLocale "%H:%M:%S" .
78+ formatTime defaultTimeLocale "%H:%M:00"