{-# LANGUAGE
    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.Tagged
import Data.Time
import Data.Time.Asctime
import Data.Time.HTTP
import Data.Time.RFC733
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

instance Arbitrary Day where
    arbitrary = ModifiedJulianDay <$> 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 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 DiffTime where
    arbitrary = secondsToDiffTime <$> choose (0, 86400)

instance Arbitrary UTCTime where
    arbitrary = UTCTime <$> 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))

          -- 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 $ \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 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

      ut2lt ∷ UTCTime → LocalTime
      ut2lt = utcToLocalTime utc

      ut2zt ∷ UTCTime → ZonedTime
      ut2zt = utcToZonedTime utc

      retagHTTP ∷ Tagged s b → Tagged HTTP b
      retagHTTP = retag