{-# 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.Format.C
import Data.Time.Format.HTTP
import Data.Time.Format.RFC733
import Data.Time.Format.RFC822
import Data.Time.Format.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

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 ("Sun Nov  6 08:49:37 1994" ∷ Ascii))
                     ≡ Just (Tagged referenceLocalTime ∷ Tagged C LocalTime)
                   )

        , property ( ("Sun Nov  6 08:49:37 1994" ∷ Ascii)
                     ≡ cs (Tagged referenceLocalTime ∷ Tagged C LocalTime)
                   )

        , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ Tagged C LocalTime) ∷ Ascii))

          -- RFC733
        , property ( fromAttempt (ca ("Sunday, 06-Nov-94 08:49:37 GMT" ∷ Ascii))
                     ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime)
                   )

        , property ( ("Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Ascii)
                     ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime)
                   )

        , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC733 ZonedTime) ∷ Ascii))

          -- RFC822
        , property ( fromAttempt (ca ("Sun, 06 Nov 94 08:49:37 GMT" ∷ Ascii))
                     ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC822 ZonedTime)
                   )

        , 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 (retag (zt ∷ Tagged Cent20 ZonedTime) ∷ Tagged RFC822 ZonedTime)
                                        ca (a ∷ Ascii) ∷ Attempt (Tagged RFC822 ZonedTime)
                           in
                             fromAttempt zt' ≡ Just (retag zt)

          -- RFC1123
        , property ( fromAttempt (ca ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii))
                     ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime)
                   )

        , property ( ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii)
                     ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime)
                   )

        , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC1123 ZonedTime) ∷ Ascii))

          -- HTTP
        , 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 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 (Tagged zt ∷ Tagged RFC822 ZonedTime)
                                        ca (a ∷ Ascii) ∷ Attempt (Tagged HTTP UTCTime)
                           in
                             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
      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