{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
module Main where

import qualified Data.Aeson as JS
import qualified Data.Binary as Binary
import qualified Data.Bytes.Serial as S
import qualified Data.Bytes.Get as Get
import qualified Data.Bytes.Put as Put
import           Data.Deriving.Time
import           Data.Proxy
import           Data.Time
import           GHC.TypeLits
import           Hedgehog ((===), Gen, property, forAll)
import qualified Hedgehog.Gen as Hog
import           Safe
import           Test.Tasty
import           Test.Tasty.Hedgehog

newtype TimeDerived t (s :: Symbol) = DT { actualTime :: t }
  deriving Eq
  deriving Read via (Time t s)
  deriving Show via (Time t s)
  deriving JS.ToJSON via (Time t s)
  deriving JS.FromJSON via (Time t s)
  deriving Binary.Binary via (Time t s)
--  deriving Serial via (Time t s)

main :: IO ()
main = defaultMain $ testGroup "Data.Deriving.Time"
  [ testSecondType "LocalTime - \"%m/%d/%Y %H:%M:%S\""
      ((DT :: (LocalTime -> TimeDerived LocalTime "%m/%d/%Y %H:%M:%S")) <$> secondAccurateLocal)
  , testSecondType "UTCTime - ISO8601"
      ((DT :: (UTCTime -> TimeDerived UTCTime "%Y-%m-%dT%H:%M:%SZ")) <$> secondAccurateUTC)
  ]

secondAccurateLocal :: Gen LocalTime
secondAccurateLocal = do
  y <- Hog.enum (000) 8000
  m <- Hog.enum 1 12
  d <- Hog.enum 1 31
  h <- Hog.enum 0 23
  m <- Hog.enum 0 59
  s <- Hog.enum 0 60
  let mday = fromGregorianValid y m d
  let tod = TimeOfDay h m (fromInteger s)
  case mday of
    Nothing -> secondAccurateLocal
    Just day -> pure $ LocalTime day tod

secondAccurateUTC :: Gen UTCTime
secondAccurateUTC = do
  y <- Hog.enum (000) 8000
  m <- Hog.enum 1 12
  d <- Hog.enum 1 31
  s <- Hog.enum 0 (24*60*60+1)
  let mday = fromGregorianValid y m d
  case mday of
    Nothing -> secondAccurateUTC
    Just day -> pure $ UTCTime day (secondsToDiffTime s)

testSecondType :: forall dt
                . (Eq dt, Show dt, Read dt, JS.ToJSON dt, JS.FromJSON dt, Binary.Binary dt)
               => TestName -> Gen dt -> TestTree
testSecondType nm gen = testGroup nm
  [ testProperty "Read/Show" . property $ do
      lt <- forAll gen
      (Just lt) === (readMay . show $ lt)
  , testProperty "JS From/To" . property $ do
      lt <- forAll gen
      (Just lt) === (JS.decode' . JS.encode $ lt)
  , testProperty "binary" . property $ do
      lt <- forAll gen
      lt === (Binary.decode . Binary.encode $ lt)
--  , testProperty "bytes" . property $ do
--      lt <- forAll gen
--      (Right lt) === (Get.runGetS deserialize . Put.runPutS $ serialize lt)
  ]