1{-# LANGUAGE CPP                  #-}
2{-# LANGUAGE ScopedTypeVariables  #-}
3{-# LANGUAGE RankNTypes           #-}
4
5module Tests.Canonical (testTree) where
6
7import           Prelude hiding (decodeFloat, encodeFloat)
8
9#if !MIN_VERSION_base(4,8,0)
10import           Control.Applicative
11#endif
12
13import qualified Data.ByteString.Lazy as LBS
14import           Data.Proxy
15
16import           Codec.CBOR.Read (deserialiseFromBytes)
17import           Codec.CBOR.Decoding
18
19import           Test.Tasty (TestTree, testGroup)
20import           Test.Tasty.QuickCheck (testProperty)
21import           Test.QuickCheck
22
23import           Tests.Properties hiding (testTree)
24
25
26-- | This is a version of 'prop_decodeRefdecodeImp' but where we restrict the
27-- encoded input to non-canonical forms. These forms are covered by the
28-- original property. This property just ensures that we have good coverage of
29-- this case.
30--
31prop_decode_nonCanonical :: forall t. Token t => t -> Property
32prop_decode_nonCanonical x =
33    let enc  = serialiseRef x
34        y    = deserialiseRef t enc
35        y'   = deserialiseImp t enc
36        enc' = serialiseImp t y'
37        isCanonical = enc == enc'
38     in not isCanonical ==>
39        -- This property holds without this pre-condition, as demonstrated by
40        -- prop_decodeRefdecodeImp, but using it ensures we get good coverage
41        -- of the non-canonical cases
42        y' `eq` fromRef y
43
44  where
45    eq = eqImp t
46    t  = Proxy :: Proxy t
47
48
49-- | Check that the special checked canonical form decoder primitives work.
50--
51-- We decode with the normal and canonical decoder, and check that they agree
52-- in the canonical cases, and that the canonical decoder rejects the
53-- non-canonical cases.
54--
55-- We have a QC coverage check to make sure we are covering enough of both
56-- canonical and non-canonical cases.
57--
58prop_decodeCanonical :: forall t. Token t
59                     => (forall s. Decoder s (Imp t))
60                     -> t -> Property
61prop_decodeCanonical decodeCanonical x =
62    classify isCanonical "canonical" $
63    case deserialiseFromBytes decodeCanonical enc of
64      Left  _failure       -> not isCanonical
65      Right (trailing, y') ->     isCanonical
66                               && eqImp t y y'
67                               && LBS.null trailing
68  where
69    enc = serialiseRef x
70    y   = deserialiseImp t enc
71    -- It is canonical if it re-encodes to the same bytes we decoded
72    isCanonical = serialiseImp t y == enc
73    t   = Proxy :: Proxy t
74
75
76
77prop_decodeCanonical_Word :: TokWord -> Property
78prop_decodeCanonical_Word = prop_decodeCanonical decodeWordCanonical
79
80prop_decodeCanonical_Word8 :: TokWord8 -> Property
81prop_decodeCanonical_Word8 = prop_decodeCanonical decodeWord8Canonical
82
83prop_decodeCanonical_Word16 :: TokWord16 -> Property
84prop_decodeCanonical_Word16 = prop_decodeCanonical decodeWord16Canonical
85
86prop_decodeCanonical_Word32 :: TokWord32 -> Property
87prop_decodeCanonical_Word32 = prop_decodeCanonical decodeWord32Canonical
88
89prop_decodeCanonical_Word64 :: TokWord64 -> Property
90prop_decodeCanonical_Word64 = prop_decodeCanonical decodeWord64Canonical
91
92--prop_decodeCanonical_NegWord :: TokNegWord -> Property
93--prop_decodeCanonical_NegWord = prop_decodeCanonical decodeNegWordCanonical
94
95prop_decodeCanonical_Int :: TokInt -> Property
96prop_decodeCanonical_Int = prop_decodeCanonical decodeIntCanonical
97
98prop_decodeCanonical_Int8 :: TokInt8 -> Property
99prop_decodeCanonical_Int8 = prop_decodeCanonical decodeInt8Canonical
100
101prop_decodeCanonical_Int16 :: TokInt16 -> Property
102prop_decodeCanonical_Int16 = prop_decodeCanonical decodeInt16Canonical
103
104prop_decodeCanonical_Int32 :: TokInt32 -> Property
105prop_decodeCanonical_Int32 = prop_decodeCanonical decodeInt32Canonical
106
107prop_decodeCanonical_Int64 :: TokInt64 -> Property
108prop_decodeCanonical_Int64 = prop_decodeCanonical decodeInt64Canonical
109
110prop_decodeCanonical_Integer :: TokInteger -> Property
111prop_decodeCanonical_Integer = prop_decodeCanonical decodeIntegerCanonical
112
113prop_decodeCanonical_Half :: TokHalf -> Property
114prop_decodeCanonical_Half = prop_decodeCanonical decodeFloat16Canonical
115
116prop_decodeCanonical_Float :: TokFloat -> Property
117prop_decodeCanonical_Float = prop_decodeCanonical decodeFloatCanonical
118
119prop_decodeCanonical_Double :: TokDouble -> Property
120prop_decodeCanonical_Double = prop_decodeCanonical decodeDoubleCanonical
121
122prop_decodeCanonical_Tag :: TokTag -> Property
123prop_decodeCanonical_Tag = prop_decodeCanonical decodeTagCanonical
124
125prop_decodeCanonical_Tag64 :: TokTag64 -> Property
126prop_decodeCanonical_Tag64 = prop_decodeCanonical decodeTag64Canonical
127
128prop_decodeCanonical_Simple :: Simple -> Property
129prop_decodeCanonical_Simple = prop_decodeCanonical decodeSimpleCanonical
130
131
132{-
133  , decodeNegWordCanonical   -- :: Decoder s Word
134  , decodeNegWord64Canonical -- :: Decoder s Word64
135  , decodeBytesCanonical -- :: Decoder s ByteString
136  , decodeByteArrayCanonical -- :: Decoder s ByteArray
137  , decodeStringCanonical -- :: Decoder s Text
138  , decodeUtf8ByteArrayCanonical -- :: Decoder s ByteArray
139  , decodeListLenCanonical -- :: Decoder s Int
140  , decodeMapLenCanonical -- :: Decoder s Int
141-}
142
143--------------------------------------------------------------------------------
144-- TestTree API
145
146testTree :: TestTree
147testTree =
148  testGroup "properties"
149  [ testGroup "decode non-canonical encoding"
150    [ testProperty "Word8"   (prop_decode_nonCanonical :: TokWord8   -> Property)
151    , testProperty "Word16"  (prop_decode_nonCanonical :: TokWord16  -> Property)
152    , testProperty "Word32"  (prop_decode_nonCanonical :: TokWord32  -> Property)
153    , testProperty "Word64"  (prop_decode_nonCanonical :: TokWord64  -> Property)
154    , testProperty "Word"    (prop_decode_nonCanonical :: TokWord    -> Property)
155--  , testProperty "NegWord" (prop_decode_nonCanonical :: TokNegWord -> Property)
156    , testProperty "Int8"    (prop_decode_nonCanonical :: TokInt8    -> Property)
157    , testProperty "Int16"   (prop_decode_nonCanonical :: TokInt16   -> Property)
158    , testProperty "Int32"   (prop_decode_nonCanonical :: TokInt32   -> Property)
159    , testProperty "Int64"   (prop_decode_nonCanonical :: TokInt64   -> Property)
160    , testProperty "Int"     (prop_decode_nonCanonical :: TokInt     -> Property)
161    , testProperty "Integer" (prop_decode_nonCanonical :: TokInteger -> Property)
162    , testProperty "Half"    (prop_decode_nonCanonical :: TokHalf    -> Property)
163    , testProperty "Float"   (prop_decode_nonCanonical :: TokFloat   -> Property)
164    , testProperty "Double"  (prop_decode_nonCanonical :: TokDouble  -> Property)
165    , testProperty "Tag"     (prop_decode_nonCanonical :: TokTag     -> Property)
166    , testProperty "Tag64"   (prop_decode_nonCanonical :: TokTag64   -> Property)
167    , testProperty "Simple"  (prop_decode_nonCanonical :: Simple     -> Property)
168    , testProperty "Term"    (prop_decode_nonCanonical :: Term       -> Property)
169    ]
170
171  , testGroup "canonical decoding"
172    [ testProperty "Word"     prop_decodeCanonical_Word
173    , testProperty "Word8"    prop_decodeCanonical_Word8
174    , testProperty "Word16"   prop_decodeCanonical_Word16
175    , testProperty "Word32"   prop_decodeCanonical_Word32
176    , testProperty "Word64"   prop_decodeCanonical_Word64
177    , testProperty "Int"      prop_decodeCanonical_Int
178    , testProperty "Int8"     prop_decodeCanonical_Int8
179    , testProperty "Int16"    prop_decodeCanonical_Int16
180    , testProperty "Int32"    prop_decodeCanonical_Int32
181    , testProperty "Int64"    prop_decodeCanonical_Int64
182    , testProperty "Integer"  prop_decodeCanonical_Integer
183    , testProperty "Half"     prop_decodeCanonical_Half
184    , testProperty "Float"    prop_decodeCanonical_Float
185    , testProperty "Double"   prop_decodeCanonical_Double
186    , testProperty "Tag"      prop_decodeCanonical_Tag
187    , testProperty "Tag64"    prop_decodeCanonical_Tag64
188    , testProperty "Simple"   prop_decodeCanonical_Simple
189    ]
190  ]
191
192