{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData          #-}
{-# LANGUAGE Trustworthy         #-}
module Data.MessagePackSpec where

import           Test.Hspec
import           Test.QuickCheck
import qualified Test.QuickCheck.Gen        as Gen

import           Control.Applicative        ((<$>), (<*>))
import qualified Data.ByteString.Char8      as S
import qualified Data.ByteString.Lazy       as L8
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.HashMap.Strict        as HashMap
import           Data.Hashable              (Hashable)
import           Data.Int                   (Int16, Int32, Int64, Int8)
import qualified Data.IntMap                as IntMap
import qualified Data.Map                   as Map
import qualified Data.Maybe                 as Maybe
import qualified Data.Result                as R
import qualified Data.Text.Lazy             as LT
import qualified Data.Vector                as V
import qualified Data.Vector.Storable       as VS
import qualified Data.Vector.Unboxed        as VU
import           Data.Word                  (Word, Word16, Word32, Word64,
                                             Word8)
import           GHC.Generics               (Generic)

import           Data.MessagePack


data Unit = Unit
  deriving (Eq, Show, Generic)

instance MessagePack Unit


data TyConArgs = TyConArgs Int Int Int
  deriving (Eq, Show, Generic)

instance MessagePack TyConArgs


data Record = Record
  { recordField1 :: Int
  , recordField2 :: Double
  , recordField3 :: String
  }
  deriving (Eq, Show, Generic)

instance MessagePack Record


data Foo
  = Foo1
  | Foo2 Int
  | Foo3 Int
  | Foo4 Int
  | Foo5 Int
  | Foo6 { unFoo3 :: Int }
  | Foo7 Int
  | Foo8 Int Int
  | Foo9 Int Int Int
  deriving (Eq, Show, Generic)

instance MessagePack Foo

instance Arbitrary Foo where
  arbitrary = Gen.oneof
    [ return Foo1
    , Foo2 <$> arbitrary
    , Foo3 <$> arbitrary
    , Foo4 <$> arbitrary
    , Foo5 <$> arbitrary
    , Foo6 <$> arbitrary
    , Foo7 <$> arbitrary
    , Foo8 <$> arbitrary <*> arbitrary
    , Foo9 <$> arbitrary <*> arbitrary <*> arbitrary
    ]


instance (Hashable k, Ord k, Eq k, Arbitrary k, Arbitrary v)
    => Arbitrary (HashMap.HashMap k v) where
  arbitrary = HashMap.fromList . Map.assocs <$> arbitrary

instance Arbitrary a => Arbitrary (V.Vector a) where
  arbitrary = V.fromList <$> arbitrary

instance (Arbitrary a, VS.Storable a) => Arbitrary (VS.Vector a) where
  arbitrary = VS.fromList <$> arbitrary

instance (Arbitrary a, VU.Unbox a) => Arbitrary (VU.Vector a) where
  arbitrary = VU.fromList <$> arbitrary

instance Arbitrary S.ByteString where
  arbitrary = S.pack <$> arbitrary

instance Arbitrary L.ByteString where
  arbitrary = L.pack <$> arbitrary

instance Arbitrary LT.Text where
  arbitrary = LT.pack <$> arbitrary

mid :: MessagePack a => a -> a
mid = Maybe.fromJust . unpack . pack


intMid :: Int64 -> Int64
intMid = mid


coerce :: (MessagePack a, MessagePack b) => a -> Maybe b
coerce = unpack . pack


checkMessage :: Show a => R.Result a -> Expectation
checkMessage (R.Success res) =
  expectationFailure $ "unexpected success: " ++ show res
checkMessage (R.Failure msg) =
  msg `shouldContain` "invalid encoding for "


spec :: Spec
spec = do
  describe "unpack" $
    it "does not throw exceptions on arbitrary data" $
      property $ \bs ->
        case unpack bs of
          Just "" -> return () :: IO ()
          _       -> return () :: IO ()

  describe "Assoc" $ do
    it "supports read/show" $
      property $ \(a :: Assoc [(Int, Int)]) ->
        read (show a) `shouldBe` a

    it "inherits ordering from its contained type" $
      property $ \(a :: Assoc Int) b ->
        (unAssoc a < unAssoc b) `shouldBe` (a < b)

  describe "failures" $
    it "should contain the same start of the failure message for all types" $ do
      checkMessage (unpack (pack $ ObjectInt (-1)) :: R.Result Foo)
      checkMessage (unpack (pack [ObjectInt (-1), ObjectInt 0]) :: R.Result Foo)
      checkMessage (unpack (pack $ ObjectArray []) :: R.Result TyConArgs)
      checkMessage (unpack (pack $ ObjectArray []) :: R.Result Record)
      checkMessage (unpack (pack [0 :: Int, 1, 2, 3]) :: R.Result Record)
      checkMessage (unpack (pack "") :: R.Result Unit)
      checkMessage (unpack (pack "") :: R.Result TyConArgs)
      checkMessage (unpack (pack "") :: R.Result Record)
      checkMessage (unpack (pack "") :: R.Result ())
      checkMessage (unpack (pack ()) :: R.Result Int)
      checkMessage (unpack (pack ()) :: R.Result Bool)
      checkMessage (unpack (pack ()) :: R.Result Float)
      checkMessage (unpack (pack ()) :: R.Result Double)
      checkMessage (unpack (pack ()) :: R.Result S.ByteString)
      checkMessage (unpack (pack ()) :: R.Result LT.Text)
      checkMessage (unpack (pack "") :: R.Result [String])
      checkMessage (unpack (pack ()) :: R.Result (V.Vector Int))
      checkMessage (unpack (pack ()) :: R.Result (VS.Vector Int))
      checkMessage (unpack (pack ()) :: R.Result (VU.Vector Int))
      checkMessage (unpack (pack "") :: R.Result (Assoc [(Int, Int)]))
      checkMessage (unpack (pack ()) :: R.Result (Int, Int))
      checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int))
      checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int))
      checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int))
      checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int))
      checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int))
      checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int, Int))
      checkMessage (unpack (pack ()) :: R.Result (Int, Int, Int, Int, Int, Int, Int, Int, Int))

  describe "type coercion" $ do
    it "bool<-int" $
      property $ \(a :: Int) -> coerce a `shouldBe` (Nothing :: Maybe Bool)

    it "int<-bool" $
      property $ \(a :: Bool) -> coerce a `shouldBe` (Nothing :: Maybe Int)

    it "float<-int" $
      property $ \(a :: Int) -> coerce a `shouldBe` Just (fromIntegral a :: Float)
    it "float<-double" $
      property $ \(a :: Double) -> coerce a `shouldBe` Just (realToFrac a :: Float)
    it "float<-string" $
      property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe Float)

    it "double<-int" $
      property $ \(a :: Int) -> coerce a `shouldBe` Just (fromIntegral a :: Double)
    it "double<-float" $
      property $ \(a :: Float) -> coerce a `shouldBe` Just (realToFrac a :: Double)
    it "double<-string" $
      property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe Double)

    it "bin<-string" $
      property $ \(a :: S.ByteString) -> coerce a `shouldBe` (Nothing :: Maybe String)

    it "string<-bin" $
      property $ \(a :: String) -> coerce a `shouldBe` (Nothing :: Maybe S.ByteString)

  describe "Identity Properties" $ do
    let sizes = [0xf, 0x10, 0x1f, 0x20, 0xff, 0x100, 0xffff, 0x10000]

    it "unit encoding" $
      Unit `shouldBe` mid Unit

    it "map encodings" $ do
      let rt n = let a = IntMap.fromList [(x, -x) | x <- [0..n]] in a `shouldBe` mid a
      mapM_ rt sizes

    it "list encodings" $ do
      let rt n = let a = replicate n "hello" in a `shouldBe` mid a
      mapM_ rt sizes

    it "vector encodings" $ do
      let rt n = let a = V.fromList [0..n] in a `shouldBe` mid a
      mapM_ rt sizes

    it "storable-vector encodings" $ do
      let rt n = let a = VS.fromList [0..n] in a `shouldBe` mid a
      mapM_ rt sizes

    it "unboxed-vector encodings" $ do
      let rt n = let a = VU.fromList [0..n] in a `shouldBe` mid a
      mapM_ rt sizes

    it "string encodings" $ do
      let rt n = let a = replicate n 'a' in a `shouldBe` mid a
      mapM_ rt sizes

    it "bytestring encodings" $ do
      let rt n = let a = S.pack $ replicate n 'a' in a `shouldBe` mid a
      mapM_ rt sizes

    it "ext encodings" $ do
      let rt n = let a = ObjectExt 0 $ S.pack $ replicate n 'a' in a `shouldBe` mid a
      mapM_ rt [0..20]
      mapM_ rt sizes

    it "int encodings" $ do
      (-0x7fffffffffffffff) `shouldBe` intMid (-0x7fffffffffffffff)
      (-0x80000000) `shouldBe` intMid (-0x80000000)
      (-0x7fffffff) `shouldBe` intMid (-0x7fffffff)
      (-0x8000) `shouldBe` intMid (-0x8000)
      (-0x7fff) `shouldBe` intMid (-0x7fff)
      (-1) `shouldBe` intMid (-1)
      0 `shouldBe` intMid 0
      1 `shouldBe` intMid 1
      0x7fff `shouldBe` intMid 0x7fff
      0x8000 `shouldBe` intMid 0x8000
      0x7fffffff `shouldBe` intMid 0x7fffffff
      0x80000000 `shouldBe` intMid 0x80000000
      0x7fffffffffffffff `shouldBe` intMid 0x7fffffffffffffff

    it "int"    $ property $ \(a :: Int   ) -> a `shouldBe` mid a
    it "int8"   $ property $ \(a :: Int8  ) -> a `shouldBe` mid a
    it "int16"  $ property $ \(a :: Int16 ) -> a `shouldBe` mid a
    it "int32"  $ property $ \(a :: Int32 ) -> a `shouldBe` mid a
    it "int64"  $ property $ \(a :: Int64 ) -> a `shouldBe` mid a
    it "word"   $ property $ \(a :: Word  ) -> a `shouldBe` mid a
    it "word8"  $ property $ \(a :: Word8 ) -> a `shouldBe` mid a
    it "word16" $ property $ \(a :: Word16) -> a `shouldBe` mid a
    it "word32" $ property $ \(a :: Word32) -> a `shouldBe` mid a
    it "word64" $ property $ \(a :: Word64) -> a `shouldBe` mid a

    it "ext" $
      property $ \(n, a) -> ObjectExt n a `shouldBe` mid (ObjectExt n a)
    it "nil" $
      property $ \(a :: ()) -> a `shouldBe` mid a
    it "bool" $
      property $ \(a :: Bool) -> a `shouldBe` mid a
    it "float" $
      property $ \(a :: Float) -> a `shouldBe` mid a
    it "double" $
      property $ \(a :: Double) -> a `shouldBe` mid a
    it "string" $
      property $ \(a :: String) -> a `shouldBe` mid a
    it "bytestring" $
      property $ \(a :: S.ByteString) -> a `shouldBe` mid a
    it "lazy-bytestring" $
      property $ \(a :: L.ByteString) -> a `shouldBe` mid a
    it "lazy-text" $
      property $ \(a :: LT.Text) -> a `shouldBe` mid a
    it "[int]" $
      property $ \(a :: [Int]) -> a `shouldBe` mid a
    it "vector int" $
      property $ \(a :: V.Vector Int) -> a `shouldBe` mid a
    it "storable-vector int" $
      property $ \(a :: VS.Vector Int) -> a `shouldBe` mid a
    it "unboxed-vector int" $
      property $ \(a :: VU.Vector Int) -> a `shouldBe` mid a
    it "[string]" $
      property $ \(a :: [String]) -> a `shouldBe` mid a
    it "(int, int)" $
      property $ \(a :: (Int, Int)) -> a `shouldBe` mid a
    it "(int, int, int)" $
      property $ \(a :: (Int, Int, Int)) -> a `shouldBe` mid a
    it "(int, int, int, int)" $
      property $ \(a :: (Int, Int, Int, Int)) -> a `shouldBe` mid a
    it "(int, int, int, int, int)" $
      property $ \(a :: (Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
    it "(int, int, int, int, int, int)" $
      property $ \(a :: (Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
    it "(int, int, int, int, int, int, int)" $
      property $ \(a :: (Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
    it "(int, int, int, int, int, int, int, int)" $
      property $ \(a :: (Int, Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
    it "(int, int, int, int, int, int, int, int, int)" $
      property $ \(a :: (Int, Int, Int, Int, Int, Int, Int, Int, Int)) -> a `shouldBe` mid a
    it "[(int, double)]" $
      property $ \(a :: [(Int, Double)]) -> a `shouldBe` mid a
    it "[(string, string)]" $
      property $ \(a :: [(String, String)]) -> a `shouldBe` mid a
    it "Assoc [(string, int)]" $
      property $ \(a :: Assoc [(String, Int)]) -> a `shouldBe` mid a
    it "Map String Int" $
      property $ \(a :: Map.Map String Int) -> a `shouldBe` mid a
    it "IntMap Int" $
      property $ \(a :: IntMap.IntMap Int) -> a `shouldBe` mid a
    it "HashMap String Int" $
      property $ \(a :: HashMap.HashMap String Int) -> a `shouldBe` mid a

    it "generics" $
      property $ \(a :: Foo) -> a `shouldBe` mid a
    it "arbitrary message" $
      property $ \(a :: Object) -> a `shouldBe` mid a

  describe "encoding validation" $ do
    it "word64 2^64-1" $
      pack (0xffffffffffffffff :: Word64) `shouldBe` L8.pack [0xCF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF]

    it "decodes empty array as ()" $
      unpack (pack ([] :: [Int])) `shouldBe` Just ()

  describe "show" $ do
    it "Foo" $ do
      show (toObject defaultConfig Foo1) `shouldBe` "ObjectWord 0"
      show (toObject defaultConfig $ Foo3 3) `shouldBe` "ObjectArray [ObjectWord 2,ObjectWord 3]"
      show (toObject defaultConfig $ Foo3 (-3)) `shouldBe` "ObjectArray [ObjectWord 2,ObjectInt (-3)]"
      show (toObject defaultConfig $ Foo8 3 5) `shouldBe` "ObjectArray [ObjectWord 7,ObjectArray [ObjectWord 3,ObjectWord 5]]"
      show (toObject defaultConfig $ Foo8 (-3) (-5)) `shouldBe` "ObjectArray [ObjectWord 7,ObjectArray [ObjectInt (-3),ObjectInt (-5)]]"
      show (toObject defaultConfig $ Foo9 3 5 7) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]]"
      show (toObject defaultConfig $ Foo9 (-3) (-5) 7) `shouldBe` "ObjectArray [ObjectWord 8,ObjectArray [ObjectInt (-3),ObjectInt (-5),ObjectWord 7]]"

    it "TyConArgs" $
      show (toObject defaultConfig $ TyConArgs 3 5 7) `shouldBe` "ObjectArray [ObjectWord 3,ObjectWord 5,ObjectWord 7]"

    it "Record" $
      show (toObject defaultConfig $ Record 3 5 "7") `shouldBe` "ObjectArray [ObjectWord 3,ObjectDouble 5.0,ObjectStr \"7\"]"