+++ /dev/null
-{-# LANGUAGE
- FlexibleInstances
- , OverloadedStrings
- , UnicodeSyntax
- #-}
-module Main (main) where
-import Control.Applicative
-import Control.Applicative.Unicode
-import Data.Ascii (Ascii)
-import Data.Attempt hiding (Failure, Success)
-import Data.Convertible.Base
-import Data.Proxy
-import Data.Tagged
-import Data.Time
-import Data.Time.Asctime
-import Data.Time.HTTP
-import Data.Time.RFC733
-import Data.Time.RFC822
-import Data.Time.RFC1123
-import System.Exit
-import Prelude.Unicode
-import Test.QuickCheck
-
-main ∷ IO ()
-main = mapM_ runTest tests
-
-runTest ∷ Property → IO ()
-runTest prop
- = do r ← quickCheckResult prop
- case r of
- Success {} → return ()
- GaveUp {} → exitFailure
- Failure {} → exitFailure
- NoExpectedFailure {} → exitFailure
-
-data Cent20
-
-cent20 ∷ Proxy Cent20
-cent20 = Proxy
-
-instance Arbitrary Day where
- arbitrary = ModifiedJulianDay <$> arbitrary
-
-instance Arbitrary (Tagged Cent20 Day) where
- arbitrary = ((Tagged ∘) ∘) ∘ fromGregorian
- <$> choose (1900, 1999)
- ⊛ arbitrary
- ⊛ arbitrary
-
-instance Arbitrary TimeOfDay where
- arbitrary
- = do h ← choose (0, 23)
- m ← choose (0, 59)
- s ← choose (0, 60)
- return $ TimeOfDay h m (fromIntegral (s ∷ Int))
-
-instance Arbitrary LocalTime where
- arbitrary = LocalTime <$> arbitrary ⊛ arbitrary
-
-instance Arbitrary (Tagged Cent20 LocalTime) where
- arbitrary = (Tagged ∘) ∘ LocalTime <$>
- (flip proxy cent20 <$> arbitrary)
- ⊛ arbitrary
-
-instance Eq ZonedTime where
- a == b = zonedTimeToUTC a ≡ zonedTimeToUTC b
-
-instance Arbitrary TimeZone where
- arbitrary
- = do m ← choose (-1439, 1439)
- s ← arbitrary
- n ← arbitrary
- return $ TimeZone m s n
-
-instance Arbitrary ZonedTime where
- arbitrary = ZonedTime <$> arbitrary ⊛ arbitrary
-
-instance Arbitrary (Tagged Cent20 ZonedTime) where
- arbitrary = (Tagged ∘) ∘ ZonedTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary
-
-instance Arbitrary DiffTime where
- arbitrary = secondsToDiffTime <$> choose (0, 86400)
-
-instance Arbitrary UTCTime where
- arbitrary = UTCTime <$> arbitrary ⊛ arbitrary
-
-instance Arbitrary (Tagged Cent20 UTCTime) where
- arbitrary = (Tagged ∘) ∘ UTCTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary
-
-tests ∷ [Property]
-tests = [ -- Asctime
- property ( fromAttempt (ca (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged Asctime Ascii))
- ≡ Just referenceLocalTime
- )
-
- , property ( (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged Asctime Ascii)
- ≡ cs referenceLocalTime
- )
-
- , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime)
- ∷ Tagged Asctime Ascii))
-
- -- RFC733
- , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii))
- ≡ Just referenceZonedTime
- )
-
- , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii)
- ≡ cs referenceZonedTime
- )
-
- , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime)
- ∷ Tagged RFC733 Ascii))
-
- -- RFC822
- , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii))
- ≡ Just referenceZonedTime
- )
-
- , property ( (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)
- ≡ cs referenceZonedTime
- )
- , property $ \zt → Just (untag zt) ≡ fromAttempt (ca (cs (untag (zt ∷ Tagged Cent20 ZonedTime))
- ∷ Tagged RFC822 Ascii))
-
- -- RFC1123
- , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii))
- ≡ Just referenceZonedTime
- )
-
- , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)
- ≡ cs referenceZonedTime
- )
-
- , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime)
- ∷ Tagged RFC1123 Ascii))
-
- -- HTTP
- , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii)
- ≡ cs referenceUTCTime
- )
- , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime)
- , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged Asctime Ascii)))
- , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)))
- , property $ \ut → Just (untag ut) ≡ fromAttempt (ca (retagHTTP (cs (ut2zt (untag (ut ∷ Tagged Cent20 UTCTime)))
- ∷ Tagged RFC822 Ascii)))
- , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)))
- ]
- where
- referenceLocalTime ∷ LocalTime
- referenceLocalTime
- = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
-
- referenceZonedTime ∷ ZonedTime
- referenceZonedTime
- = ZonedTime referenceLocalTime utc
-
- referenceUTCTime ∷ UTCTime
- referenceUTCTime
- = zonedTimeToUTC referenceZonedTime
-
- ut2lt ∷ UTCTime → LocalTime
- ut2lt = utcToLocalTime utc
-
- ut2zt ∷ UTCTime → ZonedTime
- ut2zt = utcToZonedTime utc
-
- retagHTTP ∷ Tagged s b → Tagged HTTP b
- retagHTTP = retag