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.Asctime
17 import Data.Time.RFC733
18 import Data.Time.RFC822
19 import Data.Time.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 Asctime Ascii))
93 ≡ Just referenceLocalTime
96 , property ( (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged Asctime Ascii)
97 ≡ cs referenceLocalTime
100 , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime)
101 ∷ Tagged Asctime Ascii))
104 , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii))
105 ≡ Just referenceZonedTime
108 , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii)
109 ≡ cs referenceZonedTime
112 , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime)
113 ∷ Tagged RFC733 Ascii))
116 , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii))
117 ≡ Just referenceZonedTime
120 , property ( (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)
121 ≡ cs referenceZonedTime
123 , property $ \zt → Just (untag zt) ≡ fromAttempt (ca (cs (untag (zt ∷ Tagged Cent20 ZonedTime))
124 ∷ Tagged RFC822 Ascii))
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)
136 ∷ Tagged RFC1123 Ascii))
139 , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii)
140 ≡ cs referenceUTCTime
142 , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime)
143 , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged Asctime Ascii)))
144 , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)))
145 , property $ \ut → Just (untag ut) ≡ fromAttempt (ca (retagHTTP (cs (ut2zt (untag (ut ∷ Tagged Cent20 UTCTime)))
146 ∷ Tagged RFC822 Ascii)))
147 , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)))
150 referenceLocalTime ∷ LocalTime
152 = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
154 referenceZonedTime ∷ ZonedTime
156 = ZonedTime referenceLocalTime utc
158 referenceUTCTime ∷ UTCTime
160 = zonedTimeToUTC referenceZonedTime
162 ut2lt ∷ UTCTime → LocalTime
163 ut2lt = utcToLocalTime utc
165 ut2zt ∷ UTCTime → ZonedTime
166 ut2zt = utcToZonedTime utc
168 retagHTTP ∷ Tagged s b → Tagged HTTP b