@@ -18,8 +18,7 @@ import qualified Data.Text as T
1818import qualified Data.Text.Lazy.Builder as TLB
1919import qualified Data.Text.Lazy.Encoding as TLE
2020import qualified Data.HashMap.Strict as H
21−import Data.Time.Clock (UTCTime(..))
22−import Data.Time (ZonedTime(..))
21+import Data.Time
2322import Instances ()
2423import Types
2524import Encoders
@@ -29,9 +28,14 @@ import Data.Int
2928import qualified Data.Map as Map
3029#endif
3130
31+import System.IO
32+import System.IO.Unsafe (unsafePerformIO)
33+import System.Locale
3234
3335roundTripCamel :: String -> Assertion
3436roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
37+
38+
3539 where
3640 camelFrom c s = let (p:ps) = split c s
3741 in concat $ p : map capitalize ps
@@ -67,6 +71,69 @@ toFromJSON x = case fromJSON . toJSON $ x of
6771 Error _ -> False
6872 Success x' -> x == x'
6973
74+zonedTimeToJSON :: ZonedTime -> Bool
75+zonedTimeToJSON t = and $
76+ toFromJSON' "%FT%T%QZ" t (clearTimeZone t) :
77+ toFromJSON' "%FT%T%Q%z" t t :
78+ toFromJSON' "%Y-%mT%T%Q" t (clearTimeZone . clearDay $ t) :
79+ toFromJSON' "%Y-%mT%R" t (clearTimeZone . clearDay . clearSeconds $ t) :
80+ toFromJSON' "%Y-%mT%T" t (clearTimeZone . clearDay $ t) :
81+ toFromJSON' "%Y-%mT%T%QZ" t (clearTimeZone . clearDay $ t) :
82+ toFromJSON' "%Y-%mT%T%Q%z" t (clearDay t) :
83+ toFromJSON' "%YT%T%Q" t (clearTimeZone . clearMonth . clearDay $ t) :
84+ toFromJSON' "%YT%R" t (clearTimeZone . clearMonth . clearDay . clearSeconds $ t) :
85+ toFromJSON' "%YT%T" t (clearTimeZone . clearMonth . clearDay $ t) :
86+ toFromJSON' "%YT%T%QZ" t (clearTimeZone . clearMonth . clearDay $ t) :
87+ toFromJSON' "%YT%T%Q%z" t (clearMonth . clearDay $ t) :
88+ toFromJSON' "%FT%T%Q" t (clearTimeZone t) :
89+ toFromJSON' "%FT%R" t (clearTimeZone . clearSeconds $ t) :
90+ toFromJSON' "%FT%T" t (clearTimeZone t) :
91+ toFromJSON' (dateTimeFmt defaultTimeLocale) t t :
92+ []
93+ where
94+ toJSON' :: String -> ZonedTime -> Value
95+ toJSON' format = toJSON . formatTime defaultTimeLocale format
96+
97+ toFromJSON' :: String -> ZonedTime -> ZonedTime -> Bool
98+ toFromJSON' format t_ t_' = case fromJSON . toJSON' format $ t_ of
99+ Error msg -> error' msg
100+ Success t_'' -> if t_'' == t_' then True else error' (show t_'')
101+ where
102+ error' :: String -> Bool
103+ error' msg = unsafePerformIO (hPutStrLn stderr . ("zonedTimeToJSON: " ++) $ show
104+ (format, t_, toJSON' format t_, t_', msg))
105+ `seq` False
106+
107+clearTimeZone :: ZonedTime -> ZonedTime
108+clearTimeZone t = t { zonedTimeZone = TimeZone 0 False "" }
109+
110+clearMonth :: ZonedTime -> ZonedTime
111+clearMonth = f
112+ where
113+ f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
114+ g lt = lt { localDay = h $ localDay lt }
115+
116+ h :: Day -> Day
117+ h = maybe (error "clearMonth") id . parseTime defaultTimeLocale "%Y-%m-%d" . formatTime defaultTimeLocale "%Y-01-%d"
118+
119+clearDay :: ZonedTime -> ZonedTime
120+clearDay = f
121+ where
122+ f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
123+ g lt = lt { localDay = h $ localDay lt }
124+
125+ h :: Day -> Day
126+ h = maybe (error "clearDay") id . parseTime defaultTimeLocale "%Y-%m-%d" . formatTime defaultTimeLocale "%Y-%m-01"
127+
128+clearSeconds :: ZonedTime -> ZonedTime
129+clearSeconds = f
130+ where
131+ f zt = zt { zonedTimeToLocalTime = g $ zonedTimeToLocalTime zt }
132+ g lt = lt { localTimeOfDay = h $ localTimeOfDay lt }
133+
134+ h :: TimeOfDay -> TimeOfDay
135+ h = maybe (error "clearSeconds") id . parseTime defaultTimeLocale "%H:%M:%S" . formatTime defaultTimeLocale "%H:%M:00"
136+
70137modifyFailureProp :: String -> String -> Bool
71138modifyFailureProp orig added =
72139 result == Error (added ++ orig)
@@ -149,6 +216,7 @@ tests = [
149216 , testProperty "Maybe Integer" (toFromJSON :: Maybe Integer -> Bool)
150217 , testProperty "Either Integer Double" (toFromJSON :: Either Integer Double -> Bool)
151218 , testProperty "Either Integer Integer" (toFromJSON :: Either Integer Integer -> Bool)
219+ , testProperty "ZonedTime" $ zonedTimeToJSON
152220 ],
153221 testGroup "deprecated" deprecatedTests,
154222 testGroup "failure messages" [