git.iko.soy/typeable/aeson
on master help sign in
Split out ZonedTime tests into their own thing
297b5bdBryan O'Sullivan
aeson.cabal+1
compare with master
unifiedsplit
@@ -135,6 +135,7 @@ test-suite tests
135 Functions
135 Functions
136 Instances
136 Instances
137 Options
137 Options
138+ Properties.ZonedTime
138 Types
139 Types
139
140
140 ghc-options: -Wall -threaded -rtsopts
141 ghc-options: -Wall -threaded -rtsopts
tests/Properties.hs+2−73
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
1+{-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
2
2
3import Control.Monad (forM)
3import Control.Monad (forM)
4import Data.Aeson (eitherDecode)
4import Data.Aeson (eitherDecode)
@@ -22,15 +22,9 @@ import Data.Time
22import Instances ()
22import Instances ()
23import Types
23import Types
24import Encoders
24import Encoders
25−import System.IO
26−import System.IO.Unsafe (unsafePerformIO)
27import Data.Int
25import Data.Int
28import qualified Data.Map as Map
26import qualified Data.Map as Map
29−
27+import Properties.ZonedTime (zonedTimeToJSON)
30−#if !MIN_VERSION_time(1,5,0)
31−import System.Locale (defaultTimeLocale, dateTimeFmt)
32−#endif
33−
34
28
35roundTripCamel :: String -> Assertion
29roundTripCamel :: String -> Assertion
36roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
30roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
@@ -72,71 +66,6 @@ toFromJSON x = case fromJSON . toJSON $ x of
72 Error _ -> property False
66 Error _ -> property False
73 Success x' -> x === x'
67 Success x' -> x === x'
74
68
75−zonedTimeToJSON :: ZonedTime -> Bool
76−zonedTimeToJSON t = and $
77− toFromJSON' "%FT%T%QZ" t (clearTimeZone t) : -- (javascript new Date().toISOString())
78− toFromJSON' "%F %T%Q%z" t t : -- (postgres)
79− toFromJSON' "%F %T%Q %Z" t t : -- (time's Show format)
80− toFromJSON' "%FT%T%Q%z" t t :
81− toFromJSON' "%Y-%mT%T%Q" t (clearTimeZone . clearDay $ t) :
82− toFromJSON' "%Y-%mT%R" t (clearTimeZone . clearDay . clearSeconds $ t) :
83− toFromJSON' "%Y-%mT%T" t (clearTimeZone . clearDay $ t) :
84− toFromJSON' "%Y-%mT%T%QZ" t (clearTimeZone . clearDay $ t) :
85− toFromJSON' "%Y-%mT%T%Q%z" t (clearDay t) :
86− toFromJSON' "%YT%T%Q" t (clearTimeZone . clearMonth . clearDay $ t) :
87− toFromJSON' "%YT%R" t (clearTimeZone . clearMonth . clearDay . clearSeconds $ t) :
88− toFromJSON' "%YT%T" t (clearTimeZone . clearMonth . clearDay $ t) :
89− toFromJSON' "%YT%T%QZ" t (clearTimeZone . clearMonth . clearDay $ t) :
90− toFromJSON' "%YT%T%Q%z" t (clearMonth . clearDay $ t) :
91− toFromJSON' "%FT%T%Q" t (clearTimeZone t) :
92− toFromJSON' "%FT%R" t (clearTimeZone . clearSeconds $ t) :
93− toFromJSON' "%FT%T" t (clearTimeZone t) :
94− toFromJSON' (dateTimeFmt defaultTimeLocale) t t :
95− []
96− where
97− toJSON' :: String -> ZonedTime -> Value
98− toJSON' format = toJSON . formatTime defaultTimeLocale format
99−
100− toFromJSON' :: String -> ZonedTime -> ZonedTime -> Bool
101− toFromJSON' format t_ t_' = case fromJSON . toJSON' format $ t_ of
102− Error msg -> error' msg
103− Success t_'' -> if t_'' == t_' then True else error' (show t_'')
104− where
105− error' :: String -> Bool
106− error' msg = unsafePerformIO (hPutStrLn stderr . ("zonedTimeToJSON: " ++) $ show
107− (format, t_, toJSON' format t_, t_', msg))
108− `seq` False
109−
110−clearTimeZone :: ZonedTime -> ZonedTime
111−clearTimeZone t = t { zonedTimeZone = TimeZone 0 False "" }
112−
113−clearMonth :: ZonedTime -> ZonedTime
114−clearMonth = f
115− where
116− f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
117− g lt = lt { localDay = h $ localDay lt }
118−
119− h :: Day -> Day
120− h = maybe (error "clearMonth") id . parseTime defaultTimeLocale "%Y-%m-%d" . formatTime defaultTimeLocale "%Y-01-%d"
121−
122−clearDay :: ZonedTime -> ZonedTime
123−clearDay = f
124− where
125− f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
126− g lt = lt { localDay = h $ localDay lt }
127−
128− h :: Day -> Day
129− h = maybe (error "clearDay") id . parseTime defaultTimeLocale "%Y-%m-%d" . formatTime defaultTimeLocale "%Y-%m-01"
130−
131−clearSeconds :: ZonedTime -> ZonedTime
132−clearSeconds = f
133− where
134− f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
135− g lt = lt { localTimeOfDay = h $ localTimeOfDay lt }
136−
137− h :: TimeOfDay -> TimeOfDay
138− h = maybe (error "clearSeconds") id . parseTime defaultTimeLocale "%H:%M:%S" . formatTime defaultTimeLocale "%H:%M:00"
139−
140modifyFailureProp :: String -> String -> Bool
69modifyFailureProp :: String -> String -> Bool
141modifyFailureProp orig added =
70modifyFailureProp orig added =
142 result == Error (added ++ orig)
71 result == Error (added ++ orig)
tests/Properties/ZonedTime.hsnew file+81
@@ -0,0 +1,81 @@
1+{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, ScopedTypeVariables #-}
2+
3+module Properties.ZonedTime (zonedTimeToJSON) where
4+
5+import Data.Aeson.Types
6+import Test.Framework (Test, defaultMain, testGroup)
7+import Test.Framework.Providers.QuickCheck2 (testProperty)
8+import Test.QuickCheck (Arbitrary(..), Property, (===), property)
9+import Data.Time
10+import Instances ()
11+import System.IO
12+import System.IO.Unsafe (unsafePerformIO)
13+
14+#if !MIN_VERSION_time(1,5,0)
15+import System.Locale (defaultTimeLocale, dateTimeFmt)
16+#endif
17+
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+ []
39+ where
40+ toJSON' :: String -> ZonedTime -> Value
41+ toJSON' format = toJSON . formatTime defaultTimeLocale format
42+
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_'')
47+ where
48+ error' :: String -> Bool
49+ error' msg = unsafePerformIO (hPutStrLn stderr . ("zonedTimeToJSON: " ++) $ show
50+ (format, t_, toJSON' format t_, t_', msg))
51+ `seq` False
52+
53+clearTimeZone :: ZonedTime -> ZonedTime
54+clearTimeZone t = t { zonedTimeZone = TimeZone 0 False "" }
55+
56+clearMonth :: ZonedTime -> ZonedTime
57+clearMonth = f
58+ where
59+ f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
60+ g lt = lt { localDay = h $ localDay lt }
61+
62+ h :: Day -> Day
63+ h = maybe (error "clearMonth") id . parseTime defaultTimeLocale "%Y-%m-%d" . formatTime defaultTimeLocale "%Y-01-%d"
64+
65+clearDay :: ZonedTime -> ZonedTime
66+clearDay = f
67+ where
68+ f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
69+ g lt = lt { localDay = h $ localDay lt }
70+
71+ h :: Day -> Day
72+ h = maybe (error "clearDay") id . parseTime defaultTimeLocale "%Y-%m-%d" . formatTime defaultTimeLocale "%Y-%m-01"
73+
74+clearSeconds :: ZonedTime -> ZonedTime
75+clearSeconds = f
76+ where
77+ f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
78+ g lt = lt { localTimeOfDay = h $ localTimeOfDay lt }
79+
80+ h :: TimeOfDay -> TimeOfDay
81+ h = maybe (error "clearSeconds") id . parseTime defaultTimeLocale "%H:%M:%S" . formatTime defaultTimeLocale "%H:%M:00"