{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS -Wno-missing-signatures #-}

import GHC.Generics
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
import Data.SafeCopy
import Data.SafeCopy.Internal
import Data.Serialize (runGet, runPut, Serialize)
import Text.Printf
import Test.HUnit (Test(..), assertEqual, runTestTT)
--import Generic.Data as G hiding (unpack)

-- Debugging
import Data.Typeable hiding (Proxy)
--import Debug.Trace
import Data.ByteString (ByteString, unpack)
import Data.Char (chr)
import Data.Word (Word8, Word32)

-- Test types
data Foo = Foo Int Char deriving (Generic, Show, Eq)
data Bar = Bar Float Foo deriving (Generic, Show, Eq)
data Baz = Baz1 Int | Baz2 Bool deriving (Generic, Show, Eq)

#if 0
safePutTest :: forall a. (SafeCopy' a, Generic a, GPutCopy (Rep a) DatatypeInfo, GConstructors (Rep a)) => a -> Put
safePutTest a =
  case runPut p1 == runPut p2 of
    True -> p1
    False -> trace ("safePutTest failed for " ++ show (typeRep (Proxy :: Proxy a)) ++ "\n custom: " ++ showBytes (runPut p1) ++ "\n generic: " ++ showBytes (runPut p2)) p1
  where
    p1 = safePut a
    p2 = safePutGeneric a
#endif

----------------------------------------------

-- Compare a value to the result of encoding and then decoding it.
roundTrip :: forall a. (SafeCopy a, Typeable a, Eq a, Show a) => a -> Test
roundTrip x = do
  -- putStrLn ("\n========== " ++ show x ++ " :: " ++ show (typeRep (Proxy :: Proxy a)) ++ " ==========")
  let d = runPut (safePut x) -- Use custom putCopy/getCopy implementation if present
      a :: Either String a
      a = runGet safeGet d
  TestCase (assertEqual ("roundTrip " ++ show x ++ " :: " ++ show (typeRep (Proxy :: Proxy a))) (Right x) a)

-- Test whether two values of different types have the same encoded
-- representation.  This is used here on types of similar shape to
-- test whether the generic SafeCopy instance matches the template
-- haskell instance.
compareBytes ::
  forall expected actual. (SafeCopy expected, Typeable expected,
                           SafeCopy actual, Typeable actual)
  => expected -> actual -> Test
compareBytes e a =
  TestCase (assertEqual ("compareBytes " ++ show (typeRep (Proxy :: Proxy expected)) ++ " " ++
                                            show (typeRep (Proxy :: Proxy actual)))
              (showBytes (runPut $ safePut e))
              (showBytes (runPut $ safePut a)))

showBytes :: ByteString -> String
showBytes b = mconcat (fmap f (unpack b))
   where f :: Word8 -> String
         f 192 = "[G|"
         f 193 = "[C|"
         f 194 = "[T|"
         f 195 = "]_ "
         f 196 = " _<"
         f 197 = ">_ "
         f c | c >= 32 && c < 127 = [' ', chr (fromIntegral c), ' ']
         f c | c == 0 = " __"
         f c = printf " %02x" c

-----------------------------
-- Test Types and Values
-----------------------------

foo = Foo maxBound 'x'
bar = Bar 1.5 foo
baz1 = Baz1 3
baz2 = Baz2 True

-- These instances will use the generic putCopy and getCopy
instance SafeCopy Foo where version = 3; kind = base
instance SafeCopy Bar where version = 4; kind = base
instance SafeCopy Baz where version = 5; kind = base

-- Copies of the types above with generated SafeCopy instances
data FooTH = FooTH Int Char deriving (Generic, Serialize, Show, Eq)
data BarTH = BarTH Float FooTH deriving (Generic, Serialize, Show, Eq)
data BazTH = Baz1TH Int | Baz2TH Bool deriving (Generic, Serialize, Show, Eq)

fooTH = FooTH maxBound 'x'
barTH = BarTH 1.5 fooTH
baz1TH = Baz1TH 3
baz2TH = Baz2TH True

-- For comparison, these instances have the generated implementations
-- of putCopy and getCopy
#if 1
$(deriveSafeCopy 3 'base ''FooTH)
$(deriveSafeCopy 4 'base ''BarTH)
$(deriveSafeCopy 5 'base ''BazTH)
#else
instance SafeCopy FooTH where
      putCopy (FooTH a1_aeVVN a2_aeVVO)
        = contain
            (do safePut_Int_aeVVP <- getSafePut
                safePut_Char_aeVVQ <- getSafePut
                safePut_Int_aeVVP a1_aeVVN
                safePut_Char_aeVVQ a2_aeVVO
                return ())
      getCopy
        = contain
            ((Data.Serialize.Get.label "Main.FooTH:")
               (do safeGet_Int_aeVVR <- getSafeGet
                   safeGet_Char_aeVVS <- getSafeGet
                   ((return FooTH <*> safeGet_Int_aeVVR) <*> safeGet_Char_aeVVS)))
      version = 3
      kind = base
      errorTypeName _ = "Main.FooTH"

instance SafeCopy BarTH where
      putCopy (BarTH a1_aeVXE a2_aeVXF)
        = contain
            (do safePut_Float_aeVXG <- getSafePut
                safePut_FooTH_aeVXH <- getSafePut
                safePut_Float_aeVXG a1_aeVXE
                safePut_FooTH_aeVXH a2_aeVXF
                return ())
      getCopy
        = contain
            ((Data.Serialize.Get.label "Main.BarTH:")
               (do safeGet_Float_aeVXI <- getSafeGet
                   safeGet_FooTH_aeVXJ <- getSafeGet
                   ((return BarTH <*> safeGet_Float_aeVXI) <*> safeGet_FooTH_aeVXJ)))
      version = 4
      kind = base
      errorTypeName _ = "Main.BarTH"

instance SafeCopy BazTH where
      putCopy (Baz1TH a1_aeVZv)
        = contain
            (do Data.Serialize.Put.putWord8 0
                safePut_Int_aeVZw <- getSafePut
                safePut_Int_aeVZw a1_aeVZv
                return ())
      putCopy (Baz2TH a1_aeVZx)
        = contain
            (do Data.Serialize.Put.putWord8 1
                safePut_Bool_aeVZy <- getSafePut
                safePut_Bool_aeVZy a1_aeVZx
                return ())
      getCopy
        = contain
            ((Data.Serialize.Get.label "Main.BazTH:")
               (do tag_aeVZz <- Data.Serialize.Get.getWord8
                   case tag_aeVZz of
                     0 -> do safeGet_Int_aeVZA <- getSafeGet
                             (return Baz1TH <*> safeGet_Int_aeVZA)
                     1 -> do safeGet_Bool_aeVZB <- getSafeGet
                             (return Baz2TH <*> safeGet_Bool_aeVZB)
                     _ -> fail
                            ("Could not identify tag \""
                               ++
                                 (show tag_aeVZz
                                    ++
                                      "\" for type \"Main.BazTH\" that has only 2 constructors.  Maybe your data is corrupted?"))))
      version = 5
      kind = base
      errorTypeName _ = "Main.BazTH"
#endif

data File
    = File { _fileChksum :: Checksum             -- ^ The checksum of the file's contents
           , _fileMessages :: [String]           -- ^ Messages received while manipulating the file
           , _fileExt :: String                  -- ^ Name is formed by appending this to checksum
           } deriving (Generic, Eq, Ord, Show)

data FileSource
    = TheURI String
    | ThePath FilePath
    deriving (Generic, Eq, Ord, Show)

type Checksum = String

$(deriveSafeCopy 10 'base ''File)
$(deriveSafeCopy 11 'base ''FileSource)

file1 = File ("checksum") [] ".jpg"
file2 = File ("checksum") [] ".jpg"
file3 = File ("checksum") [] ".jpg"

----------------------------------------------
-- Demonstration of the ordering issue
----------------------------------------------

data T1 = T1 Char T2 T3 deriving (Generic, Show)
data T2 = T2 Char deriving (Generic, Show)
data T3 = T3 Char deriving (Generic, Show)
data T4 = T4 Word32 Word32 Word32 deriving (Generic, Show)

t1 = T1 'a' (T2 'b') (T3 'c')
t2 = (T2 'b')
t3 = (T3 'c')
t4 = T4 100 200 300

$(deriveSafeCopy 4 'base ''T2)
$(deriveSafeCopy 5 'base ''T3)
$(deriveSafeCopy 3 'base ''T1)
$(deriveSafeCopy 6 'base ''T4)

data T1G = T1G Char T2G T3G deriving (Generic, Show)
data T2G = T2G Char deriving (Generic, Show)
data T3G = T3G Char deriving (Generic, Show)
data T4G = T4G Word32 Word32 Word32 deriving (Generic, Show)

t1g = T1G 'a' (T2G 'b') (T3G 'c')
t2g = (T2G 'b')
t3g = (T3G 'c')
t4g = T4G 100 200 300

instance SafeCopy T1G where version = 3; kind = base
instance SafeCopy T2G where version = 4; kind = base
instance SafeCopy T3G where version = 5; kind = base
instance SafeCopy T4G where version = 6; kind = base

orderTests :: Test
orderTests =
  let -- When I thought to myself "what should the output be type Baz"
      -- without reference to reality, this is what I came up with.
      _expected :: ByteString
      _expected = ("\NUL\NUL\NUL\ETX" <> "\NUL\NUL\NUL\NUL" <> "a" <> "\NUL\NUL\NUL\EOT" <> "\NUL\NUL\NUL\NUL" <> "b" <> "\NUL\NUL\NUL\ENQ" <> "\NUL\NUL\NUL\NUL" <> "c")
      --                  T1                   Char            'a'            T2                    Char          'b'            T3                   Char           'c'
      -- But this is reality - the type, followed by its three field
      -- types, followed by its three field values.
      actual :: ByteString
      actual = ("\NUL\NUL\NUL\ETX" <> "\NUL\NUL\NUL\NUL" <> "\NUL\NUL\NUL\EOT" <> "\NUL\NUL\NUL\ENQ" <> "a" <> "\NUL\NUL\NUL\NUL" <> "b" <> "\NUL\NUL\NUL\NUL" <> "c") in
      --               T1                   Char                    T2                    T3            'a'           Char           'b'            Char          'c'
  TestList
     [ TestCase (assertEqual "actual template haskell safeput output" (showBytes actual) (showBytes (runPut (safePut t1))))
     , TestCase (assertEqual "what the new implementation does"       (showBytes actual) (showBytes (runPut (safePut t1g))))
     ]

main = do
  runTestTT
    (TestList
      [ orderTests
      , roundTrip ()
      , roundTrip ("hello" :: String)
      , roundTrip foo
      , roundTrip fooTH
      , roundTrip bar
      , roundTrip barTH
      , roundTrip baz1
      , roundTrip baz1TH
      , roundTrip baz2
      , roundTrip baz2TH
      , roundTrip (Just 'x')
      , roundTrip (Nothing :: Maybe Char)
      , roundTrip ('a', (123 :: Int), ("hello" :: String))
      , roundTrip file1
      , roundTrip file2
      , roundTrip file3
      , compareBytes fooTH foo
      , compareBytes barTH bar
      , compareBytes baz1TH baz1
      , compareBytes baz2TH baz2
      ])