{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where

import Data.Binary               (Binary, decode, encode)
import Data.Coerce               (coerce)
import Data.Either               (isLeft)
import Data.Functor.Identity     (Identity (..))
import Data.Monoid               (Product (..), Sum (..))
import Data.Proxy                (Proxy (..))
import Data.Singletons.Bool      (SBoolI, reflectBool)
import Data.Typeable             (Typeable)
import GHC.Generics              (Generic)
import Test.QuickCheck
       (Arbitrary (..), Property, counterexample, ioProperty, property, (===))
import Test.QuickCheck.Instances ()
import Test.Tasty                (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit          (testCase, (@?=))
import Test.Tasty.QuickCheck     (testProperty)

import Data.Binary.Tagged

import qualified Rec1
import qualified Rec2

main :: IO ()
main = defaultMain $ testGroup "Tests"
  [ roundtrips
  , wrongRoundtrips
  , failedRoundtrips
  , testCase "An example hash" $ do
    let hash = structureHash (Proxy :: Proxy [Either (Maybe Char) (Sum Int)])
    hash @?= md5FromInteger 0xbfc698fe96db703b44e5925381902ef2
  ]

proxyRec1 :: Proxy Rec1.Rec
proxyRec1 = Proxy

proxyRec2 :: Proxy Rec2.Rec
proxyRec2 = Proxy

proxyRec1Ver0 :: Proxy (VerTagged 'False Rec1.Rec)
proxyRec1Ver0 = Proxy

proxyRec1Ver1 :: Proxy (VerTagged 'True Rec1.Rec)
proxyRec1Ver1 = Proxy

proxyRec2Ver0 :: Proxy (VerTagged 'False Rec2.Rec)
proxyRec2Ver0 = Proxy

-- proxyRec2Ver1 :: Proxy (VerTagged 'True Rec2.Rec)
-- proxyRec2Ver1 = Proxy

eqRec1Rec2 :: Rec1.Rec -> Rec2.Rec -> Bool
eqRec1Rec2 (Rec1.Rec (Sum a) (Product b)) (Rec2.Rec (Product a') (Sum b')) =
  a == a' && b == b'

roundtrips :: TestTree
roundtrips = testGroup "Roundtrip"
  [ testProperty "Rec1"                $ roundtrip proxyRec1
  , testProperty "Rec2"                $ roundtrip proxyRec2
  ]

wrongRoundtrips :: TestTree
wrongRoundtrips = testGroup "Decode successful, data invalid"
  [ testProperty "Rec1 -> Rec2" $ wrongRoundtrip eqRec1Rec2
  , testProperty "Rec2 -> Rec1" $ wrongRoundtrip eqRec1Rec2
  ]

failedRoundtrips :: TestTree
failedRoundtrips = testGroup "Failed roundtrips"
  [ testProperty "Different version" $ failedRoundtrip proxyRec1Ver0 proxyRec1Ver1
  , testProperty "Different structure" $ failedRoundtrip proxyRec1Ver0 proxyRec2Ver0
  ]

roundtrip :: (Eq a, Show a, Arbitrary a, Binary a, Structured a) => Proxy a -> a -> Property
roundtrip _ x = x === structuredDecode (structuredEncode x)

wrongRoundtrip :: (Arbitrary a, Binary a, Binary b, Structured a, Structured b) => (a -> b -> Bool) -> a -> Property
wrongRoundtrip eq x = property $ eq x $ decode (encode x)

isLeftProperty :: (Show a, Show b) => Either a b -> Property
isLeftProperty x = counterexample ("not isLeft: " ++ show x) (isLeft x)

failedRoundtrip :: forall a b. (Arbitrary a, Binary a, Binary b, Structured a, Structured b, Show b) => Proxy a -> Proxy b -> a -> Property
failedRoundtrip _ _ x = ioProperty $ do
    x' <- structuredDecodeOrFailIO (structuredEncode x) :: IO (Either String b)
    return (isLeftProperty x')

-------------------------------------------------------------------------------
-- VerTagged
-------------------------------------------------------------------------------

newtype VerTagged (v :: Bool) a = VT a deriving (Eq, Show, Generic, Typeable)

instance Binary a => Binary (VerTagged v a)

instance (SBoolI v, Typeable v, Structured a) => Structured (VerTagged v a) where
    structure = set typeVersion (fromBool $ reflectBool (Proxy :: Proxy v)) . genericStructure

fromBool :: Integral a => Bool -> a
fromBool True  = 1
fromBool False = 0

instance Arbitrary a => Arbitrary (VerTagged v a) where
    arbitrary     = fmap VT arbitrary
    shrink (VT x) = fmap VT (shrink x)

-------------------------------------------------------------------------------
-- Lens
-------------------------------------------------------------------------------

over :: ((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
over = coerce

set :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
set l b = over l (const b)