{-# LANGUAGE BinaryLiterals            #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE NegativeLiterals          #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}

-- | Tests for the flat module
module Main where

import           Data.Bits
import qualified Data.ByteString       as B
import qualified Data.ByteString.Lazy  as L
import qualified Data.ByteString.Short as SBS
import           Data.Char
import           Data.Either
import           Data.Flat
import           Data.Flat.Bits
import           Data.Flat.Decoder
import           Data.Int
import           Data.List
import qualified Data.Map              as M
import           Data.Ord
import           Data.Proxy
import qualified Data.Sequence         as Seq
import qualified Data.Text             as T
import           Data.Word
import           Numeric.Natural
-- import           System.Arch
-- import           System.Endian
import           System.Exit
import           Test.Data
import           Test.Data.Arbitrary
import           Test.Data.Flat
import           Test.Data.Values
import           Test.Tasty
import           Test.Tasty.HUnit
import           Test.Tasty.QuickCheck as QC hiding (getSize)

main = do
  -- printInfo
  mainTest
-- main = mainShow

-- printInfo = do
--   print getSystemArch
--   print getSystemEndianness

mainShow = do
  mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1..10]
  exitFailure

mainTest = defaultMain tests

tests :: TestTree
tests = testGroup "Tests" [properties
                           ,unitTests
                          ]

properties = testGroup "Properties"
  [  rt "()" (prop_Flat_roundtrip:: RT ())
    ,rt "Bool" (prop_Flat_roundtrip::RT Bool)
    ,rt "(Bool,Word8,Bool)" (prop_Flat_roundtrip:: RT (Bool,Word8,Bool))
    ,rt "Word8" (prop_Flat_Large_roundtrip:: RTL Word8)
    ,rt "Word16" (prop_Flat_Large_roundtrip:: RTL Word16)
    ,rt "Word32" (prop_Flat_Large_roundtrip:: RTL Word32)
    ,rt "Word64" (prop_Flat_Large_roundtrip:: RTL Word64)
    ,rt "Word" (prop_Flat_Large_roundtrip:: RTL Word)
    ,rt "Int8" (prop_Flat_Large_roundtrip:: RTL Int8)
    ,rt "Int16" (prop_Flat_Large_roundtrip:: RTL Int16)
    ,rt "Int32" (prop_Flat_Large_roundtrip:: RTL Int32)
    ,rt "Int64" (prop_Flat_Large_roundtrip:: RTL Int64)
    ,rt "Int" (prop_Flat_Large_roundtrip:: RTL Int)
    ,rt "Integer" (prop_Flat_roundtrip:: RT Integer)
    ,rt "Natural" (prop_Flat_roundtrip:: RT Natural)
    ,rt "(Bool,Integer)" (prop_Flat_roundtrip:: RT (Bool,Integer))
    ,rt "Float" (prop_Flat_roundtrip:: RT Float)
    ,rt "(Bool,Float)" (prop_Flat_roundtrip:: RT (Bool,Float))
    ,rt "Double" (prop_Flat_roundtrip:: RT Double)
    ,rt "(Bool,Double)" (prop_Flat_roundtrip:: RT (Bool,Double))
    ,rt "Char" (prop_Flat_roundtrip:: RT Char)
    ,rt "(Bool,Char)" (prop_Flat_roundtrip:: RT (Bool,Char))
    --,rt "ASCII" (prop_Flat_roundtrip:: RT ASCII)
    ,rt "Unit" (prop_Flat_roundtrip:: RT Unit)
    ,rt "Un" (prop_Flat_roundtrip:: RT Un )
    ,rt "N" (prop_Flat_roundtrip:: RT N )
    ,rt "A" (prop_Flat_roundtrip:: RT A )
    ,rt "B" (prop_Flat_roundtrip:: RT B )
    ,rt "Maybe N" (prop_Flat_roundtrip:: RT (Maybe N))
    ,rt "Either N Bool" (prop_Flat_roundtrip:: RT (Either N Bool))
    ,rt "Either Int Char" (prop_Flat_roundtrip:: RT (Either Int Char))
    -- ,rt "Tree Bool" (prop_Flat_roundtrip:: RT (Tree Bool))
    -- ,rt "Tree N" (prop_Flat_roundtrip:: RT (Tree N))
    ,rt "List N" (prop_Flat_roundtrip:: RT (List N))
    ,rt "[Int16]" (prop_Flat_roundtrip:: RT [Int16])
    ,rt "String" (prop_Flat_roundtrip:: RT String)
    -- Generates incorrect ascii chars?
    ,rt "Text" (prop_Flat_roundtrip:: RT T.Text)
    ,rt "ByteString" (prop_Flat_roundtrip:: RT B.ByteString)
    ,rt "Lazy ByteString" (prop_Flat_roundtrip:: RT L.ByteString)
    ,rt "Short ByteString" (prop_Flat_roundtrip:: RT SBS.ShortByteString)
  ]
   where rt n = QC.testProperty (unwords ["round trip",n])

instance Flat [Int16]
instance Flat [Word8]
instance Flat [Bool]

unitTests = testGroup "De/Serialisation Unit tests" $ concat [
  sz () 0
  ,sz True 1
  ,sz One 2
  ,sz Two 2
  ,sz Three 2
  ,sz Four 3
  ,sz Five 3
  ,sz 'a' 8
  ,sz 'à' 16
  ,sz '经' 24
  ,sz (0::Word8) 8
  ,sz (1::Word8) 8
  ,concatMap (uncurry sz) ns
  ,concatMap (uncurry sz) $ nsI
  ,concatMap (uncurry sz) $ nsII
  ,sz (1.1::Float) 32
  ,sz (1.1::Double) 64
  ,sz "" 1
  ,sz "abc" (4+3*8)
  ,sz ((),(),Unit) 0
  ,sz (True,False,One,Five) 7
  ,sz map1 7
  ,sz bs (4+3*8)
  ,sz stBS bsSize
  ,sz lzBS bsSize
  ,sz shBS bsSize
  ,sz tx utf8Size
  ,sz (UTF8Text tx) utf8Size
  ,sz (UTF16Text tx) utf16Size
  ,errDec (Proxy::Proxy Bool) [] -- no data
  ,errDec (Proxy::Proxy Bool) [128] -- no filler
  ,errDec (Proxy::Proxy Bool) [128+1,1,2,4,8] -- additional bytes
  ,s () []
  ,s ((),(),Unit) []
  ,s (Unit,'a',Unit,'a',Unit,'a',Unit) [97,97,97]
  ,a () [1]
  ,a True [128+1]
  ,a (True,True) [128+64+1]
  ,a (True,False,True) [128+32+1]
  ,a (True,False,True,True) [128+32+16+1]
  ,a (True,False,True,True,True) [128+32+16+8+1]
  ,a (True,False,True,True,True,True) [128+32+16+8+4+1]
  ,a (True,False,True,True,True,True,True) [128+32+16+8+4+2+1]
  ,a (True,False,True,True,(True,True,True,True)) [128+32+16+8+4+2+1,1]
  ,s (True,False,True,True) [128+32+16]
  ,s ((True,True,False,True,False),(False,False,True,False,True,True)) [128+64+16+1,64+32]
  ,s ('\0','\1','\127') [0,1,127]
  ,s (33::Word32,44::Word32) [33,44]
    --,s (Elem True) [64]
    --,s (NECons True (NECons False (Elem True))) [128+64+32+4]
  ,s (0::Word8) [0]
  ,s (1::Word8) [1]
  ,s (255::Word8) [255]
  ,s (0::Word16) [0]
  ,s (1::Word16) [1]
  ,s (255::Word16) [255,1]
  ,s (256::Word16) [128,2]
  ,s (65535::Word16) [255,255,3]
  ,s (127::Word32) [127]
  ,s (128::Word32) [128,1]
  ,s (129::Word32) [129,1]
  ,s (255::Word32) [255,1]
  ,s (16383::Word32) [255,127]
  ,s (16384::Word32) [128,128,1]
  ,s (16385::Word32) [129,128,1]
  ,s (32767::Word32) [255,255,1]
  ,s (32768::Word32) [128,128,2]
  ,s (32769::Word32) [129,128,2]
  ,s (65535::Word32) [255,255,3]
  ,s (2097151::Word32) [255,255,127]
  ,s (2097152::Word32) [128,128,128,1]
  ,s (2097153::Word32) [129,128,128,1]
  ,s (4294967295::Word32) [255,255,255,255,15]
  ,s (255::Word64) [255,1]
  ,s (65535::Word64) [255,255,3]
  ,s (4294967295::Word64) [255,255,255,255,15]
  ,s (18446744073709551615::Word64) [255,255,255,255,255,255,255,255,255,1]
  ,s (255::Word) [255,1]
  ,s (65535::Word) [255,255,3]
  ,s (4294967295::Word) [255,255,255,255,15]
  ,tstI [0::Int8,2,-2]
  ,s (127::Int8) [254]
  ,s (-128::Int8) [255]
  ,tstI [0::Int16,2,-2,127,-128]
  ,tstI [0::Int32,2,-2,127,-128]
  ,tstI [0::Int64,2,-2,127,-128]
  ,s (-1024::Int64) [255,15]
  ,s (maxBound::Word64) [255,255,255,255,255,255,255,255,255,1]
  ,s (minBound::Int64) [255,255,255,255,255,255,255,255,255,1]
  ,s (maxBound::Int64) [254,255,255,255,255,255,255,255,255,1]
  ,tstI [0::Int,2,-2,127,-128]
  ,tstI [0::Integer,2,-2,127,-128,-256,-512]
  ,s (-1024::Integer) [255,15]
  ,s (-0.15625::Float)  [0b10111110,0b00100000,0,0]
  ,s (-0.15625::Double) [0b10111111,0b11000100,0,0,0,0,0,0]
  ,s (-123.2325E-23::Double) [0b10111011,0b10010111,0b01000111,0b00101000,0b01110101,0b01111011,0b01000111,0b10111010]
  ,dec ((,,,) <$> dropBits 13 <*> dBool <*> dBool <*> dBool) [0b10111110,0b10011010] ((),False,True,False)
  ,dec ((,,,) <$> dropBits 1 <*> dBE16 <*> dBool <*> dropBits 6) [0b11000000
                                                                 ,0b00000001
                                                                 ,0b01000000] ((),2^15+2,True,())
  ,dec ((,,,) <$> dropBits 1 <*> dBE32 <*> dBool <*> dropBits 6) [0b11000000
                                                                 ,0b00000000
                                                                 ,0b00000000
                                                                 ,0b00000001
                                                                 ,0b01000000] ((),2^31+2,True,())
  ,dec ((,,,) <$> dropBits 1 <*> dBE64 <*> dBool <*> dropBits 6) [0b11000000
                                                                 ,0b00000000
                                                                 ,0b00000000
                                                                 ,0b00000000
                                                                 ,0b00000000
                                                                 ,0b00000000
                                                                 ,0b00000000
                                                                 ,0b00000001
                                                                 ,0b01000000] ((),2^63+2,True,())

  ,decBitsN dBEBits8
  ,decBitsN dBEBits16
  ,decBitsN dBEBits32
  ,decBitsN dBEBits64
  ,map trip [maxBound::Word16]
  ,map trip [maxBound::Word32]
  ,map trip [maxBound::Word64]
  ,map trip [minBound::Int8,maxBound::Int8]
  ,map trip [minBound::Int16,maxBound::Int16]
  ,map trip [minBound::Int32,maxBound::Int32]
  ,map trip [minBound::Int64,maxBound::Int64]
  ,map trip [0::Float,-0::Float,0/0::Float,1/0::Float]
  ,map trip [0::Double,-0::Double,0/0::Double,1/0::Double]
  ,s '\0' [0]
  ,s '\1' [1]
  ,s '\127' [127]
  ,s 'a' [97]
  ,s 'à' [224,1]
  ,s '经' [207,253,1]
  ,[trip [chr 0x10FFFF]]
  ,s Unit []
  ,s (Un False) [0]
  ,s (One,Two,Three) [16+8]
  ,s (Five,Five,Five) [255,128]
    --,s (NECons True (Elem True)) [128+64+16]
  ,s "" [0]
#ifdef LIST_BIT
  ,s "abc" [176,216,172,96]
  ,s [False,True,False,True] [128
                               +32+16
                               +8
                               +2+1,0]
#elif defined(LIST_BYTE)
  ,s "abc" s3
  ,s (cs 600) s600
#endif
    -- Aligned structures
    --,s (T.pack "") [1,0]
    --,s (Just $ T.pack "abc") [128+1,3,97,98,99,0]
    --,s (T.pack "abc") (al s3)
    --,s (T.pack $ cs 600) (al s600)
  ,s map1 [0b10111000]
  ,s (B.pack $ csb 3) (bsl c3)
  ,s (B.pack $ csb 600) (bsl s600)
  ,s (L.pack $ csb 3) (bsl c3)
   -- Long LazyStrings can have internal sections shorter than 255
   --,s (L.pack $ csb 600) (bsl s600)
  ,[trip [1..100::Int16]]
  ,[trip asciiStrT,trip "维护和平正",trip (T.pack "abc"),trip unicodeText,trip unicodeTextUTF8T,trip unicodeTextUTF16T]
  ,[trip longBS,trip longLBS,trip longSBS]
  ,[trip longSeq]
  ,[trip mapV]
  ,[trip map1]
  ]
    where
      map1 = M.fromList [(False,True),(True,False)]

      ns :: [(Word64, Int)]
      ns =  [( (-) (2 ^(i*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]

      nsI :: [(Int64, Int)]
      nsI = nsI_
      nsII :: [(Integer, Int)]
      nsII = nsI_
      nsI_ =  [( (-) (2 ^(((-) i 1)*7)) 1,fromIntegral (8*i)) | i <- [1 .. 10]]

      --al = (1:) -- prealign
      bsl = id -- noalign
      s3 = [3,97,98,99,0]
      c3a = [3,99,99,99,0] -- Array Word8
      c3 = pre c3a
      s600 = pre s600a
      pre = (1:)
      tx = T.pack "txt"
      utf8Size = 8+8+3*32+8
      utf16Size = 8+8+3*16+8
      shBS = SBS.toShort stBS
      lzBS = L.pack bs
      stBS = B.pack bs
      bs = [32,32,32::Word8]
      bsSize = 8+8+3*8+8
      s600a = concat [[255],csb 255,[255],csb 255,[90],csb 90,[0]]
      s600B = concat [[55],csb 55,[255],csb 255,[90],csb 90,[200],csb 200,[0]]
      longSeq :: Seq.Seq Word8
      longSeq = Seq.fromList lbs
      longSBS = SBS.toShort longBS
      longBS = B.pack lbs
      longLBS = L.concat $ concat $ replicate 10 [L.pack lbs]
      lbs = concat $ replicate 100 [234,123,255,0]
      tstI = map ti

      ti v | v >= 0    = testCase (unwords ["Int",show v]) $ teq v (2 * fromIntegral v ::Word64)
           | otherwise = testCase (unwords ["Int",show v]) $ teq v (2 * fromIntegral (-v) - 1 ::Word64)

      teq a b = ser a @?= ser b

      sz v e = [testCase (unwords ["size of",sshow v]) $ getSize v @?= e]

      s v e = [testCase (unwords ["flat raw",sshow v]) $ serRaw v @?= e]
              --,testCase (unwords ["unflat raw",sshow v]) $ desRaw e @?= Right v]

      dec decOp v e = [testCase (unwords ["decode",sshow v]) $ unflatRawWith decOp (B.pack v) @?= Right e]

      decBitsN :: forall a. (Num a,FiniteBits a,Show a,Flat a) => (Int -> Get a) -> [TestTree]
      decBitsN dec = let s = finiteBitSize (undefined::a)
                     in [decBits_ dec v n pre | n <- [0 .. s], v <- [0::a ,1+2^(s - 2)+2^(s - 5) ,fromIntegral $ (2^s::Integer) - 1],pre <- [0,1,7]]

      -- why Flat a?
      decBits_ :: forall a. (FiniteBits a,Show a,Flat a) => (Int -> Get a) -> a -> Int -> Int -> TestTree
      decBits_ deco v n pre =
        let vs = B.pack . asBytes . fromBools $ replicate pre False ++ toBools (asBits v)
            len = B.length vs
            s = finiteBitSize (undefined::a)
            dec = do
              dropBits pre
              r <- deco n
              dropBits (len*8-n-pre)
              return r
            e = v `shiftR` (s - n)
        in testCase (unwords ["take",show n,"bits from",show v,"of size",show s,"with prefix",show pre]) $ unflatRawWith dec vs @?= Right e

      -- Aligned values unflat to the original value, modulo the added filler.
      a v e = [testCase (unwords ["flat",sshow v]) $ ser v @?= e
              ,testCase (unwords ["unflat",sshow v]) $ let Right v' = des e in v @?= v']
      -- a v e = [testCase (unwords ["flat postAligned",show v]) $ ser (postAligned v) @?= e
      --         ,testCase (unwords ["unflat postAligned",show v]) $ let Right (PostAligned v' _) = des e in v @?= v']
      cs n = replicate n 'c' -- take n $ cycle ['a'..'z']
      csb = map (fromIntegral . ord) . cs
      sshow = take 80 . show

      trip :: forall a .(Show a,Flat a) => a -> TestTree
      trip v = testCase (unwords ["roundtrip",sshow v]) $ show (unflat (flat v::B.ByteString)::Decoded a) @?= show (Right v::Decoded a) -- we use show to get Right NaN == Right NaN

errDec :: forall a . (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree]
--errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""]
errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in isRight ev @?= False]

ser :: Flat a => a -> [Word8]
ser = B.unpack . flat

des :: Flat a => [Word8] -> Decoded a
des = unflat

serRaw :: Flat a => a -> [Word8]
-- serRaw = B.unpack . flatRaw
-- serRaw = L.unpack . flatRaw
serRaw = asBytes . bits

--desRaw :: Flat a => [Word8] -> Decoded a
--desRaw = unflatRaw . L.pack

type RT a = a -> Bool
type RTL a = Large a -> Bool

prop_Flat_roundtrip :: (Flat a, Eq a) => a -> Bool
prop_Flat_roundtrip = rtrip2

prop_Flat_Large_roundtrip :: (Eq b, Flat b) => Large b -> Bool
prop_Flat_Large_roundtrip (Large x) = rtrip2 x

rtrip x = unflat (flat x::B.ByteString) == Right x
rtrip2 x = rtrip x && rtrip (True,x,False)

{-
prop_common_unsigned :: (Num l,Num h,Flat l,Flat h) => l -> h -> Bool
prop_common_unsigned n _ = let n2 :: h = fromIntegral n
                           in flat n == flat n2
-}

-- e :: Stream Bool
-- e = unflatIncremental . flat $ stream1

-- el :: List Bool
-- el = unflatIncremental . flat $ infList

-- deflat = unflat

-- b1 :: BLOB UTF8
-- b1 = BLOB UTF8 (preAligned (List255 [97,98,99]))
-- -- b1 = BLOB (preAligned (UTF8 (List255 [97,98,99])))

