6 module Main (main) where
7 import Control.Applicative
8 import Control.Applicative.Unicode
9 import Data.Ascii (Ascii)
10 import Data.Attempt hiding (Failure, Success)
11 import Data.Convertible.Base
15 import Data.Time.Format.C
16 import Data.Time.Format.HTTP
17 import Data.Time.Format.RFC733
18 import Data.Time.Format.RFC822
19 import Data.Time.Format.RFC1123
21 import Prelude.Unicode
22 import Test.QuickCheck
25 main = mapM_ runTest tests
27 runTest ∷ Property → IO ()
29 = do r ← quickCheckResult prop
31 Success {} → return ()
32 GaveUp {} → exitFailure
33 Failure {} → exitFailure
34 NoExpectedFailure {} → exitFailure
41 instance Arbitrary Day where
42 arbitrary = ModifiedJulianDay <$> arbitrary
44 instance Arbitrary (Tagged Cent20 Day) where
45 arbitrary = ((Tagged ∘) ∘) ∘ fromGregorian
46 <$> choose (1900, 1999)
50 instance Arbitrary TimeOfDay where
52 = do h ← choose (0, 23)
55 return $ TimeOfDay h m (fromIntegral (s ∷ Int))
57 instance Arbitrary LocalTime where
58 arbitrary = LocalTime <$> arbitrary ⊛ arbitrary
60 instance Arbitrary (Tagged Cent20 LocalTime) where
61 arbitrary = (Tagged ∘) ∘ LocalTime <$>
62 (flip proxy cent20 <$> arbitrary)
65 instance Eq ZonedTime where
66 a == b = zonedTimeToUTC a ≡ zonedTimeToUTC b
68 instance Arbitrary TimeZone where
70 = do m ← choose (-1439, 1439)
73 return $ TimeZone m s n
75 instance Arbitrary ZonedTime where
76 arbitrary = ZonedTime <$> arbitrary ⊛ arbitrary
78 instance Arbitrary (Tagged Cent20 ZonedTime) where
79 arbitrary = (Tagged ∘) ∘ ZonedTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary
81 instance Arbitrary DiffTime where
82 arbitrary = secondsToDiffTime <$> choose (0, 86400)
84 instance Arbitrary UTCTime where
85 arbitrary = UTCTime <$> arbitrary ⊛ arbitrary
87 instance Arbitrary (Tagged Cent20 UTCTime) where
88 arbitrary = (Tagged ∘) ∘ UTCTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary
92 property ( fromAttempt (ca (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged C Ascii))
93 ≡ Just referenceLocalTime
96 , property ( (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged C Ascii)
97 ≡ cs referenceLocalTime
100 , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime) ∷ Tagged C Ascii))
103 , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii))
104 ≡ Just referenceZonedTime
107 , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii)
108 ≡ cs referenceZonedTime
111 , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC733 Ascii))
114 , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii))
115 ≡ Just referenceZonedTime
118 , property ( Just (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)
119 ≡ fromAttempt (ca referenceZonedTime)
121 , property $ \zt → let zt' = do a ← ca $ untag (zt ∷ Tagged Cent20 ZonedTime)
122 ca (a ∷ Tagged RFC822 Ascii)
124 fromAttempt zt' ≡ Just (untag zt)
127 , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii))
128 ≡ Just referenceZonedTime
131 , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)
132 ≡ cs referenceZonedTime
135 , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC1123 Ascii))
138 , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii)
139 ≡ cs referenceUTCTime
141 , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime)
142 , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged C Ascii)))
143 , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)))
144 , property $ \ut → let zt = ut2zt $ untag (ut ∷ Tagged Cent20 UTCTime)
146 ca $ retagHTTP (a ∷ Tagged RFC822 Ascii)
148 fromAttempt ut' ≡ Just (untag ut)
149 , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)))
152 referenceLocalTime ∷ LocalTime
154 = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
156 referenceZonedTime ∷ ZonedTime
158 = ZonedTime referenceLocalTime utc
160 referenceUTCTime ∷ UTCTime
162 = zonedTimeToUTC referenceZonedTime
164 ut2lt ∷ UTCTime → LocalTime
165 ut2lt = utcToLocalTime utc
167 ut2zt ∷ UTCTime → ZonedTime
168 ut2zt = utcToZonedTime utc
170 retagHTTP ∷ Tagged s b → Tagged HTTP b