{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}

module BitRecordsSpec (spec) where

import Data.Bits
import qualified Data.ByteString.Lazy as B
import Data.Kind.Extra
import Data.Proxy
import Data.Type.BitRecords
import Data.Type.Equality ()
import GHC.TypeLits
import Test.Hspec
import Test.QuickCheck (property)
import Test.TypeSpecCrazy
import Text.Printf
import Util
import Prelude hiding (id, (.))

basicsSpec :: Spec
basicsSpec = do
  describe "Maybe, Lists, Either, Bool, 'True, 'False, FlagJust, FlagNothing" $ do
    let checkFlagJust ::
          "Type Level Bool, 'True, 'False, FlagJust, FlagNothing Accessors"
            ################################################################## "The record size works"
            ~~~~~~~~~~~~~~~~~~~~~~~~ 1 `ShouldBe` FieldWidth (FlagJust 'Nothing)
            -* 1 `ShouldBe` FieldWidth (FlagJust ('Just "Blah"))
            -* 1 `ShouldBe` FieldWidth (FlagNothing ('Just "Blah"))
            -* 0 `ShouldBe` SizeInBits (From (BitRecordOfList (Konst 'BitRecordMember) '[]))
            -* 10 `ShouldBe` SizeInBits (From (BitRecordOfList (Konst 'BitRecordMember) '[Field 10]))
            -* 20 `ShouldBe` SizeInBits (From (BitRecordOfList (Konst 'BitRecordMember) '[Field 10, Field 10]))
            -* 1 `ShouldBe` SizeInBits ('BitRecordMember Flag)
            -* 1 `ShouldBe` FieldWidth (Flag := 'True)
            -* 1 `ShouldBe` SizeInBits ('BitRecordMember (Flag := 'False))

        checkFlagJust = Valid
    runIO $ print checkFlagJust
  describe "bitBuffer64Printer" $ do
    describe "Just x" $
      it "writes x" $
        bitBuffer64Printer (Proxy :: Proxy (OptionalRecord ('Just ('BitRecordMember (Flag := 'True))))) `shouldBe` "<< 80 >>"
    describe "Nothing" $
      it "writes nothing" $
        bitBuffer64Printer (Proxy :: Proxy (OptionalRecord ('Nothing))) `shouldBe` "<<  >>"
    describe "'[]" $
      it "writes nothing" $
        bitBuffer64Printer (Proxy :: Proxy (BitRecordOfList (Konst 'BitRecordMember) ('[]))) `shouldBe` "<<  >>"
    describe "'[x1, x2]" $
      it "writes x1 then x2" $
        bitBuffer64Printer (Proxy :: Proxy (BitRecordOfList (Konst 'BitRecordMember) ('[FieldU8 := 1, FieldU8 := 2]))) `shouldBe` "<< 01 02 >>"
    describe "'True" $
      it "writes a single bit with a 1" $
        bitBuffer64Printer (Proxy :: Proxy (RecordField (Flag := 'True))) `shouldBe` "<< 80 >>"
    describe "'False" $
      it "writes a single bit with a 0" $
        bitBuffer64Printer (Proxy :: Proxy (RecordField (Flag := 'False))) `shouldBe` "<< 00 >>"
    describe "@: labelled fields" $ do
      it "writes them ..." $
        let fld = Proxy @(From (RecordField ("foo" @: FlagJust 'Nothing)))
         in bitBuffer64Printer fld `shouldBe` "<< 00 >>"
    describe "FlagJust" $ do
      it "writes a single bit '1' for a 'Just ...' parameter" $
        bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagJust ('Just "test")))) `shouldBe` "<< 80 >>"
      it "writes a single bit '0' for a 'Nothing' parameter" $
        bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagJust 'Nothing))) `shouldBe` "<< 00 >>"
    describe "FlagNothing" $ do
      it "writes a single bit '0' for a 'Just ...' parameter" $
        bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagNothing ('Just "test")))) `shouldBe` "<< 00 >>"
      it "writes a single bit '1' for a 'Nothing' parameter" $
        bitBuffer64Printer (Proxy :: Proxy (RecordField (FlagNothing 'Nothing))) `shouldBe` "<< 80 >>"
  describe "showRecord" $ do
    describe "Maybe" $ do
      it "prints 'Just x'" $
        showRecord (Proxy :: Proxy (From (OptionalRecord ('Just ('BitRecordMember FieldU32))))) `shouldBe` "U32"
      it "prints nothing for 'Nothing'" $
        showRecord (Proxy :: Proxy (From (OptionalRecord 'Nothing))) `shouldBe` "\n"
    describe "List" $ do
      it "prints '[ FieldI32 ]'" $
        showRecord (Proxy :: Proxy (From (BitRecordOfList (Konst 'BitRecordMember) '[FieldI32])))
          `shouldBe` "I32"
      it "prints '[Flag := True, Flag := False]'" $
        showRecord (Proxy :: Proxy (From (BitRecordOfList (Konst 'BitRecordMember) '[Flag := 'True, Flag := 'False])))
          `shouldBe` "boolean := yes\nboolean := no"
    describe "Bool" $ do
      it "prints 'True" $
        showRecord (Proxy :: Proxy ('BitRecordMember (Flag := 'True))) `shouldBe` "boolean := yes"
      it "prints 'False" $
        showRecord (Proxy :: Proxy ('BitRecordMember (Flag := 'False))) `shouldBe` "boolean := no"
      it "prints a Bool" $
        showRecord (Proxy :: Proxy ('BitRecordMember Flag)) `shouldBe` "boolean"
    describe "FlagJust" $ do
      it "prints a 'FlagJust 'Just ..'" $
        showRecord (Proxy :: Proxy ('BitRecordMember (FlagJust ('Just "123")))) `shouldBe` "boolean := yes"
      it "prints a 'FlagJust 'Nothing'" $
        showRecord (Proxy :: Proxy ('BitRecordMember (FlagJust 'Nothing))) `shouldBe` "boolean := no"
    describe "FlagNothing" $ do
      it "prints 'FlagNothing 'Just ..'" $
        showRecord (Proxy :: Proxy ('BitRecordMember (FlagNothing ('Just "123")))) `shouldBe` "boolean := no"
      it "prints a 'FlagNothing 'Nothing'" $
        showRecord (Proxy :: Proxy ('BitRecordMember (FlagNothing 'Nothing))) `shouldBe` "boolean := yes"

#ifdef COMPLEXTESTS
arraySpec :: SpecWith ()
arraySpec =
    describe "RecArray" $ do
      describe "level record accessors" $ do
        let checkArrayRec ::
              "BitRecord accessors involving RecArray"
              #######################################

              "The record size works"
              ~~~~~~~~~~~~~~~~~~~~~~~~
                  1 `ShouldBe` SizeInBits (From (RecArray ('BitRecordMember Flag) 1))
              -* 91 `ShouldBe` SizeInBits (From (("foo" @: Flag .+. FieldU8) ^^ 10) :+. Flag)
              -* 91 `ShouldBe` SizeInBits (From (RecArray ("foo" @: Flag .+. FieldU8) 10) :+. Flag)
            checkArrayRec = Valid
        runIO $ print checkArrayRec
      describe "showRecord" $
        it "appends its body n times" $
        let expected = "utf-8(40) := <<hello>> [5 Bytes]\nutf-8(40) := <<hello>> [5 Bytes]\nutf-8(40) := <<hello>> [5 Bytes]\nutf-8(40) := <<hello>> [5 Bytes]\nutf-8(40) := <<hello>> [5 Bytes]"
            actual = showARecord (Proxy @ (('BitRecordMember [utf8|hello|] ^^ 5)))
            in actual `shouldBe` expected
      describe "bitBuffer64Printer" $
        it "writes its contents n times to the builder" $
          let actual = bitBuffer64Printer (Proxy :: Proxy (('BitRecordMember (Field 24 := 0x010203) ^^ 4)))
              expected = "<< 01 02 03 01 02 03 01 02 03 01 02 03 >>"
              in actual `shouldBe` expected

sizedSpec :: SpecWith ()
sizedSpec =
  describe "Sized" $ do
    describe "TypeChecks" $
      let
          checkSized ::
             "Sized"
            #########

            "SizedString"
            ~~~~~~~~~~~~~~~
                88 `ShouldBe` FieldWidth [utf8|Hello World|]
            -* 104 `ShouldBe` SizeInBits (From (RecordField [utf8|Heλλo World|]))

            -/-

            "Sized BitRecord Members"
            ~~~~~~~~~~~~~~~~~~~~~~~~
                8 `ShouldBe` SizeInBits (From (Sized8 'EmptyBitRecord))
            -*  9 `ShouldBe` SizeInBits (From (Sized8 ('BitRecordMember Flag)))
            -*  0 `ShouldBe` SizeInBytes 'EmptyBitRecord
            -*  1 `ShouldBe` SizeInBytes ('BitRecordMember Flag)

            -/-

            "SizedField"
            ~~~~~~~~~~~~
                9 `ShouldBe` SizeInBits (From (SizedField8 Flag))
            -*  SizeInBits (From (SizedField8 Flag) :+: (Flag .+: 'BitRecordMember FieldU32)) `ShouldBe` 42
            -*  1 `ShouldBe` SizeInBytes  Flag

            -- TODO add more Sized tests, especially for SizedField
          checkSized = Valid
      in runIO $ print checkSized
    describe "showRecord" $ do
      describe "SizedString" $
        it "renders a string containing wide utf-8 characters to a header containing the number of chars and the actual string" $
        showARecord (Proxy :: Proxy (RecordField [utf8|Heλλo World!|])) `shouldBe` "utf-8(112) := <<He\955\955o World!>> [14 Bytes]"
      describe "Sized SizeField16 SizedString" $
        it "renders the number bytes not chars as the size field value" $
        showARecord (Proxy :: Proxy (SizedField16 [utf8|Heλλo World!|])) `shouldBe` "size: U16 := hex: 000e (dec: 14)\nutf-8(112) := <<He\955\955o World!>> [14 Bytes]"
    describe "bitBuffer64Printer" $ do
      describe "no length prefix" $
        it "renders no size prefix and the string as UTF-8 bytes" $
        bitBuffer64Printer (Proxy :: Proxy (RecordField [utf8|ABC|]))
        `shouldBe`
        "<< 41 42 43 >>"
      describe "8-bit length prefix" $
        it "renders a single byte size prefix and the string as UTF-8 bytes" $
        bitBuffer64Printer (Proxy :: Proxy (SizedField8 [utf8|ABC|]))
        `shouldBe`
        "<< 03 41 42 43 >>"
      describe "16-bit length prefix" $
        it "renders a big endian 16 bit size prefix and the string as UTF-8 bytes" $
        bitBuffer64Printer (Proxy :: Proxy (SizedField16 [utf8|ABC|]))
        `shouldBe`
        "<< 00 03 41 42 43 >>"
      describe "32-bit length prefix" $
        it "renders a big endian 32 bit size prefix and the string as UTF-8 bytes" $
        bitBuffer64Printer (Proxy :: Proxy (SizedField32 [utf8|ABC|]))
        `shouldBe`
        "<< 00 00 00 03 41 42 43 >>"
      describe "64-bit length prefix" $
        it "renders a big endian 64 bit size prefix and the string as UTF-8 bytes" $
        bitBuffer64Printer (Proxy :: Proxy (SizedField64 [utf8|ABC|]))
        `shouldBe`
        "<< 00 00 00 00 00 00 00 03 41 42 43 >>"

type TestRecAligned =
  "bar" @: Field 8       .+:
            Field 8  := 0 .+:
  "baz" @: Field 8       .+:
            Field 32 := 0 .+:
  "foo" @: Field 8       .+:
            Field 8  := 0 .+:
  "oof" @: Field 8       .+:
            Field 8  := 0 .+.
  "rab" @: Field 8

checkTestRecAligned
  :: Expect '[ ShouldBe 96        (SizeInBits TestRecAligned)  ]
checkTestRecAligned = Valid

type TestRecUnAligned =
  "bar" @: Field 8       .+:
            Field 8  := 0 .+:
  "baz" @: Field 7       .+:
            Field 32 := 0 .+:
  "foo" @: Field 8       .+.
            Field 8  := 0xfe

checkTestRecUnAligned
  :: Expect '[ ShouldBe 71        (SizeInBits TestRecUnAligned) ]
checkTestRecUnAligned = Valid

testTakeLastN ::
  "Taking the last n elements of a list" #######################################

       TakeLastN 0 '[1,2,3] `ShouldBe` ('[] :: [Nat])
    -* TakeLastN 1 '[1,2,3] `ShouldBe` '[3]
    -* TakeLastN 2 '[1,2,3] `ShouldBe` '[2,3]
    -* TakeLastN 5 '[1,2,3] `ShouldBe` '[1,2,3]

testTakeLastN = Valid

testRem
  :: Expect '[ Mod 0 3 `ShouldBe` 0
             , Mod 1 3 `ShouldBe` 1
             , Mod 2 3 `ShouldBe` 2
             , Mod 3 3 `ShouldBe` 0
             , Mod 4 3 `ShouldBe` 1
             , Mod 5 3 `ShouldBe` 2
             , Mod 6 3 `ShouldBe` 0
            ]
testRem = Valid

testRemPow2
  ::
  "ModPow2"
  #########

  "Remainder of '1'"
  ~~~~~~~~~~~~~~~~~~

      It "1 `ModPow2` 1 is 1"  (Is 1 (ModPow2 1 1))
  -*  It "1 `ModPow2` 8 is 1"  (Is 1 (ModPow2 1 8))

  -/-

   "Remainder of '3916441'"
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~

      It " `ModPow2` 1 is 1"   (Is 1 (ModPow2 3916441 1))
  -*  It " `ModPow2` 4 is 9"   (Is 9 (ModPow2 3916441 4))
  -*  It " `ModPow2` 8 is 153" (Is 153 (ModPow2 3916441 8))

testRemPow2 = Valid

testDiv
  :: Expect '[ Div 0 3 `ShouldBe` 0
             , Div 1 3 `ShouldBe` 0
             , Div 2 3 `ShouldBe` 0
             , Div 3 3 `ShouldBe` 1
             , Div 4 3 `ShouldBe` 1
             , Div 5 3 `ShouldBe` 1
             , Div 6 3 `ShouldBe` 2
             , Div 144 13 `ShouldBe` 11
             -- , Div 512 128 `ShouldBe` 11
            ]
testDiv = Valid

testNatBits
  :: "Type Level bit operations"
     ###########################

     "TestHighBit"
     ~~~~~~~~~~~~

        ShouldBeFalse (TestHighBit 127 8)
     -* ShouldBeFalse (TestHighBit 127 7)
     -* ShouldBeTrue  (TestHighBit 127 6)
     -* ShouldBeFalse (TestHighBit  32 6)
     -* ShouldBeTrue  (TestHighBit  32 5)
     -* ShouldBeFalse (TestHighBit  16 5)
     -* ShouldBeTrue  (TestHighBit  16 4)
     -* ShouldBeFalse (TestHighBit   8 4)
     -* ShouldBeTrue  (TestHighBit   8 3)
     -* ShouldBeFalse (TestHighBit   4 3)
     -* ShouldBeTrue  (TestHighBit   4 2)
     -* ShouldBeFalse (TestHighBit   2 2)
     -* ShouldBeTrue  (TestHighBit   2 1)
     -* ShouldBeFalse (TestHighBit   0 1)
     -* ShouldBeTrue  (TestHighBit   1 0)

  -/-

    "ToBits"
    ~~~~~~~~~

       It "returns the empty list for a zero bit length"
          (ToBits 1023 0 `ShouldBe` ('[] :: [Bool]) )

    -* It "returns [] for a single unset bit"
          (ShouldBe ('[] :: [Bool]) (ToBits 0 1))

    -* It "returns [True] for a single set bit"
          (ShouldBe '[ 'True] (ToBits 1 1))

    -* It "returns [True, False] when getting two bits from 0x2"
          (ShouldBe '[ 'True, 'False] (ToBits 0x2 2))

    -* It "returns the list of bits in correct order"
          (ShouldBe '[ 'True, 'True, 'True, 'True
                     , 'False, 'False, 'False, 'False]
                     (ToBits 0xf0 8))

    -* It "returns no leading 'False (i.e. it omits leading zero bits)"
          (ShouldBe '[ 'True, 'True, 'True, 'True]
                     (ToBits 0x0000000f 32))
  -/-

    "FromBits"
    ~~~~~~~~~

      It "returns 0 for '[]"
          (ShouldBe 0   (FromBits ('[] :: [Bool])))

    -* It "returns 0 for [False]"
          (ShouldBe 0   (FromBits '[ 'False]))

    -* It "returns 1 for [True]"
          (ShouldBe 1   (FromBits '[ 'True]))

    -* It "returns 2 for [True, False]"
          (ShouldBe 2   (FromBits '[ 'True, 'False]))

    -* It "returns 4 for [True, False, False]"
          (ShouldBe 4   (FromBits '[ 'True, 'False, 'False]))

    -* It "returns 5 for [True, False, True]"
          (ShouldBe 5   (FromBits '[ 'True, 'False, 'True]))
  -/-

    "ShiftBitsR"
    ~~~~~~~~~~~~

      It "returns the input bits for n == 0"
        (ShouldBe '[ 'True, 'False] (ShiftBitsR ['True, 'False] 0))

    -* It "returns '[] when shifting [True] 1 bits"
        (ShouldBe ('[] :: [Bool]) (ShiftBitsR '[ 'True ] 1))

    -* It "returns '[True] when shifting [True, True] 1 bits"
        (ShouldBe '[ 'True] (ShiftBitsR '[ 'True, 'True ] 1))

    -* It "returns (ToBits 12 8) when shifting (ToBits 97 8) 3 bits to the right"
        (ShouldBe (ToBits 12 8) (ShiftBitsR (ToBits 97 8) 3))
  -/-

     "GetMostSignificantBitIndex"
    ~~~~~~~~~~~~~~~

      It "returns 1 for 0"
        (ShouldBe 1 (GetMostSignificantBitIndex 64 0))

    -* It "returns 1 for 1"
        (ShouldBe 1 (GetMostSignificantBitIndex 64 1))

    -* It "returns 1 for 2"
        (ShouldBe 1 (GetMostSignificantBitIndex 64 2))

    -* It "returns 1 for 3"
        (ShouldBe 1 (GetMostSignificantBitIndex 64 3))

    -* It "returns 2 for 4"
        (ShouldBe 2 (GetMostSignificantBitIndex 64 4))

    -* It "returns 2 for 5"
        (ShouldBe 2 (GetMostSignificantBitIndex 64 4))

    -* It "returns 8 for 511"
        (ShouldBe 8 (GetMostSignificantBitIndex 64 511))

    -* It "returns 63 for (2^64 - 1)"
        (ShouldBe 63 (GetMostSignificantBitIndex 64 (2^64 - 1)))

  -/-


    "ShiftR"
    ~~~~~~~~~

       It "returns '0' when shifting '42' 6 bits to the right"
        (ShouldBe 0 (ShiftR 64 42 6))
    -* It "returns 2 when shifting 512 8 bits to the right"
        (ShouldBe 2 (ShiftR 64 512 8))

testNatBits = Valid
#endif

spec :: Spec
spec = do
  basicsSpec

#ifdef COMPLEXTESTS
  sizedSpec
  arraySpec
  describe "The Set of Type Functions" $
    it "is sound" $ do
      print (Valid :: Expect (SizeInBits (Flag .+. Field 7) `Is` 8))
      print testTakeLastN
      print testRem
      print testRemPow2
      print testDiv
      print testNatBits
      print checkTestRecAligned
      print checkTestRecUnAligned
  describe "showARecord" $ do
    it "prints (Field 4 .+. (Field 4 := 0x96)) to \"<..>0110\"" $
      let actual = showRecord (Proxy :: Proxy (Field 4 .+. Field 4 := 0x96))
          in actual `shouldBe` "bits(4)\nbits(4) := 10010110 (hex: 96 dec: 150)"
  describe "StaticLazybytestringbuilder" $ do
    it "writes (and flushes) bits" $
        let rec = Proxy
            rec :: Proxy TestRecUnAligned
            actualB :: B.ByteString
            actualB =
                  writeBits
                    (toFunction (toFunctionBuilder rec :: FunctionBuilder BitBuilder BitBuilder (B 8 -> B 7 -> B 8 -> BitBuilder))
                            1
                            3
                            7)
            actual = printByteString actualB
            in  actual `shouldBe`
                  "<< 01 00 06 00 00 00 00 0f fc >>"
    describe "Formatting sub-byte fields" $ do
      it "only the addressed bits are copied to the output" $
        property $ \value ->
          let rec = Proxy
              rec :: Proxy (Field 4 := 0 .+. "here" @: Field 4)
              actualB :: B.ByteString
              actualB = writeBits (toFunction (toFunctionBuilder rec :: FunctionBuilder BitBuilder BitBuilder (B 4 -> BitBuilder)) value)
              actual = printByteString actualB
              expected = printf "<< %.2x >>" (value .&. 0xf)
              in actual `shouldBe` expected
      it "renders (Flag := 0 .+. Field 7 := 130) to << 02 >>" $
        let rec = Proxy
            rec :: Proxy (Flag := 'False .+. Field 7 := 130)
            actual = printByteString b
              where b = writeBits (toFunction (toFunctionBuilder rec :: FunctionBuilder BitBuilder BitBuilder BitBuilder))
        in actual `shouldBe` "<< 02 >>"
  describe "LazyByteStringBuilder" $
    describe "writeBits" $
      it "0x01020304050607 to << 00 01 02 03 04 05 06 07 >>" $
        let expected = "<< 00 01 02 03 04 05 06 07 >>"
            actual =
               printByteString
                (writeBits
                 (toFunction
                   (toFunctionBuilder
                      (bitBuffer64 64 0x01020304050607) :: FunctionBuilder BitBuilder BitBuilder BitBuilder)))
            in actual `shouldBe` expected
#endif
