content: {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module Tests.Deriving (testTree) where
  
  import           GHC.Generics
  
  import qualified Codec.Serialise as Serialise
  import           Codec.CBOR.FlatTerm
  
  import           Test.Tasty
  import           Test.Tasty.HUnit
  
  -- | A unit type
  data AUnit = AUnit
             deriving (Generic, Eq, Show)
  instance Serialise.Serialise AUnit
  
  testAUnit :: TestTree
  testAUnit = testAgainstFile "a unit" x rep
    where
      x = AUnit
      rep = [TkListLen 1, TkInt 0]
  
  -- | A simple case exercising many of the cases implemented by the generic
  -- deriving mechinery
  data ARecord = ARecord String Int ARecord
               | ANull
               deriving (Generic, Eq, Show)
  instance Serialise.Serialise ARecord
  
  testARecord :: TestTree
  testARecord = testAgainstFile "a record" x rep
    where
      x = ARecord "hello" 42 (ARecord "world" 52 ANull)
      rep = [TkListLen 4, TkInt 0, TkString "hello", TkInt 42,
             TkListLen 4, TkInt 0, TkString "world", TkInt 52,
             TkListLen 1, TkInt 1
            ]
  
  newtype ANewtype = ANewtype Int
                   deriving (Generic, Eq, Show)
  instance Serialise.Serialise ANewtype
  
  testANewtype :: TestTree
  testANewtype = testAgainstFile "a newtype" x rep
    where
      x = ANewtype 42
      rep = [TkListLen 2, TkInt 0, TkInt 42]
  
  testAgainstFile :: (Eq a, Show a, Serialise.Serialise a)
                  => String -> a -> FlatTerm -> TestTree
  testAgainstFile name x expected =
      testGroup name
        [ testCase "serialise" $ do
              let actual = toFlatTerm $ Serialise.encode x
              expected @=? actual
        , testCase "deserialise" $ do
              case fromFlatTerm Serialise.decode expected of
                Left err -> fail err
                Right actual -> x @=? actual
        ]
  
  testTree :: TestTree
  testTree =
      testGroup "Stability of derived instances"
        [ testAUnit
        , testARecord
        , testANewtype
        ]
  