{-# 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.Asctime
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

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