Merge branch 'data-default'

[time-http.git] / Test / Time / Format / HTTP.hs

diff --git a/Test/Time/Format/HTTP.hs b/Test/Time/Format/HTTP.hs
index 67cdfc1bebaaccfb5153ff739f67e85bea794d8d..c5abaf1c9db87a2490c7be9414fb291e8ea75034 100644 (file)
--- a/Test/Time/Format/HTTP.hs
+++ b/Test/Time/Format/HTTP.hs
@@ -87,66 +87,85 @@ instance Arbitrary UTCTime where
 instance Arbitrary (Tagged Cent20 UTCTime) where
     arbitrary = (Tagged ∘) ∘ UTCTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary
 
+instance Arbitrary (Tagged C LocalTime) where
+    arbitrary = Tagged <$> arbitrary
+
+instance Arbitrary (Tagged RFC733 ZonedTime) where
+    arbitrary = Tagged <$> arbitrary
+
+instance Arbitrary (Tagged RFC1123 ZonedTime) where
+    arbitrary = Tagged <$> arbitrary
+
+instance Arbitrary (Tagged HTTP UTCTime) where
+    arbitrary = Tagged <$> arbitrary
+
 tests ∷ [Property]
 tests = [ -- Asctime
-          property ( fromAttempt (ca (Tagged "Sun Nov  6 08:49:37 1994" ∷ Tagged C Ascii))
-                     ≡ Just referenceLocalTime
+          property ( fromAttempt (ca ("Sun Nov  6 08:49:37 1994" ∷ Ascii))
+                     ≡ Just (Tagged referenceLocalTime ∷ Tagged C LocalTime)
                    )
 
-        , property ( (Tagged "Sun Nov  6 08:49:37 1994" ∷ Tagged C Ascii)
-                     ≡ cs referenceLocalTime
+        , property ( ("Sun Nov  6 08:49:37 1994" ∷ Ascii)
+                     ≡ cs (Tagged referenceLocalTime ∷ Tagged C LocalTime)
                    )
 
-        , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime) ∷ Tagged C Ascii))
+        , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ Tagged C LocalTime) ∷ Ascii))
 
           -- RFC733
-        , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii))
-                     ≡ Just referenceZonedTime
+        , property ( fromAttempt (ca ("Sunday, 06-Nov-94 08:49:37 GMT" ∷ Ascii))
+                     ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime)
                    )
 
-        , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii)
-                     ≡ cs referenceZonedTime
+        , property ( ("Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Ascii)
+                     ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime)
                    )
 
-        , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC733 Ascii))
+        , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC733 ZonedTime) ∷ Ascii))
 
           -- RFC822
-        , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii))
-                     ≡ Just referenceZonedTime
+        , property ( fromAttempt (ca ("Sun, 06 Nov 94 08:49:37 GMT" ∷ Ascii))
+                     ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC822 ZonedTime)
                    )
 
-        , property ( Just (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)
-                     ≡ fromAttempt (ca referenceZonedTime)
+        , property ( Just ("Sun, 06 Nov 94 08:49:37 GMT" ∷ Ascii)
+                     ≡ fromAttempt (ca (Tagged referenceZonedTime ∷ Tagged RFC822 ZonedTime))
                    )
-        , property $ \zt → let zt' = do a ← ca $ untag (zt ∷ Tagged Cent20 ZonedTime)
-                                        ca (a ∷ Tagged RFC822 Ascii)
+
+        , property $ \zt → let zt' = do a ← ca (retag (zt ∷ Tagged Cent20 ZonedTime) ∷ Tagged RFC822 ZonedTime)
+                                        ca (a ∷ Ascii) ∷ Attempt (Tagged RFC822 ZonedTime)
                            in
-                             fromAttempt zt' ≡ Just (untag zt)
+                             fromAttempt zt' ≡ Just (retag zt)
 
           -- RFC1123
-        , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii))
-                     ≡ Just referenceZonedTime
+        , property ( fromAttempt (ca ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii))
+                     ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime)
                    )
 
-        , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)
-                     ≡ cs referenceZonedTime
+        , property ( ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii)
+                     ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime)
                    )
 
-        , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC1123 Ascii))
+        , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC1123 ZonedTime) ∷ Ascii))
 
           -- HTTP
-        , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii)
-                     ≡ cs referenceUTCTime
+        , property ( ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii)
+                     ≡ cs (Tagged referenceUTCTime ∷ Tagged HTTP UTCTime)
                    )
-        , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime)
-        , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged C Ascii)))
-        , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)))
+        , property $ \ut → Just ut ≡ fromAttempt (ca (cs (ut ∷ Tagged HTTP UTCTime) ∷ Ascii))
+        , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2lt <$> (ut ∷ Tagged HTTP UTCTime))
+                                                            ∷ Tagged C LocalTime)
+                                                        ∷ Ascii))
+        , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2zt <$> (ut ∷ Tagged HTTP UTCTime))
+                                                            ∷ Tagged RFC733 ZonedTime)
+                                                        ∷ Ascii))
         , property $ \ut → let zt  = ut2zt $ untag (ut ∷ Tagged Cent20 UTCTime)
-                               ut' = do a ← ca zt
-                                        ca $ retagHTTP (a ∷ Tagged RFC822 Ascii)
+                               ut' = do a ← ca (Tagged zt ∷ Tagged RFC822 ZonedTime)
+                                        ca (a ∷ Ascii) ∷ Attempt (Tagged HTTP UTCTime)
                            in
-                             fromAttempt ut' ≡ Just (untag ut)
-        , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)))
+                             fromAttempt ut' ≡ Just (retag ut)
+        , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2zt <$> (ut ∷ Tagged HTTP UTCTime))
+                                                            ∷ Tagged RFC1123 ZonedTime)
+                                                        ∷ Ascii))
         ]
     where
       referenceLocalTime ∷ LocalTime
@@ -166,6 +185,3 @@ tests = [ -- Asctime
 
       ut2zt ∷ UTCTime → ZonedTime
       ut2zt = utcToZonedTime utc
-
-      retagHTTP ∷ Tagged s b → Tagged HTTP b
-      retagHTTP = retag