added test for validFlat along with Ref and Imp Decoders

cborg/tests/Tests/FlatTerm.hs

@@ -2,120 +2,113 @@ module Tests.FlatTerm
   ( testTree -- :: TestTree
   ) where
 
-import           Codec.CBOR.FlatTerm
-
-import           Tests.Reference.Implementation
-import           Tests.Reference.Generators
+import           Control.Applicative
+import           Codec.CBOR.FlatTerm ( TermToken(..), fromFlatTerm, validFlatTerm )
+import           Codec.CBOR.Write    ( toLazyByteString)
+import           Codec.CBOR.Term     ( decodeTerm  )
+import           Codec.CBOR.Encoding ( Encoding(..)
+                                     , encodeInt  
+                                     , encodeInteger
+                                     , encodeBytes
+                                     , encodeBytesIndef
+                                     , encodeString
+                                     , encodeStringIndef
+                                     , encodeListLen
+                                     , encodeListLenIndef
+                                     , encodeMapLen
+                                     , encodeMapLenIndef
+                                     , encodeBreak 
+                                     , encodeTag64
+                                     , encodeBool
+                                     , encodeNull
+                                     , encodeSimple
+                                     , encodeFloat16
+                                     , encodeFloat
+                                     , encodeDouble )
+import qualified Tests.Reference.Implementation as Imp
+import           Tests.Term ( toRefTerm )
 import qualified Data.ByteString      as BS
+import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text as T
-import           Numeric.Half
+import           Data.Word
+import           Prelude         hiding (encodeFloat)
 
 import           Test.QuickCheck
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 
 --------------------------------------------------------------------------------
 
-
-newtype ValidFlat = ValidFlat [TermToken]
-  deriving (Eq, Show)
-
-instance Arbitrary ValidFlat where
-  arbitrary = ValidFlat . termToValidTermTokens <$> arbitrary
-
-newtype InValidFlat = InValidFlat [TermToken]
-  deriving (Eq, Show)
-
-instance Arbitrary InValidFlat where
-  arbitrary =
-    oneof [ genInValidFlatType1
-          , genInValidFlatType2
-          , genInValidFlatType3
-          , genInValidFlatType4
-          , InValidFlat . termToInValidTermTokens <$> arbitrary
-          ]
-
--- InValid FlatTerms with Trailing elements
-genInValidFlatType1 :: Gen InValidFlat
-genInValidFlatType1 = do
-  ValidFlat ts <- arbitrary
-  return $ InValidFlat (TkBreak : ts)
-
--- InValid FlatTerms with wrong ByteString order
-genInValidFlatType2 :: Gen InValidFlat
-genInValidFlatType2 = do
-  ValidFlat ts <- arbitrary
-  let ts' = TkBytesBegin : TkNull : ts
-  return $ InValidFlat ts'
-
--- InValid FlatTerms with wrong String order
-genInValidFlatType3 :: Gen InValidFlat
-genInValidFlatType3 = do
-  ValidFlat ts <- arbitrary
-  let ts' = TkStringBegin : TkNull : ts
-  return $ InValidFlat ts'
-
--- InValid FlatTerms with too long List / Map Length
-genInValidFlatType4 :: Gen InValidFlat
-genInValidFlatType4 = do
-  tok <- elements [TkListLen maxBound, TkMapLen maxBound]
-  let ts' = tok : repeat TkNull
-  return $ InValidFlat ts'
-
-
--- Convert Term to List of Invalid TermTokens deliberately
-termToInValidTermTokens :: Term -> [TermToken]
-termToInValidTermTokens (TBytess ws)   = TkBytesBegin : ((TkBytes . BS.pack) <$> ws) ++ [TkBytesBegin]
-termToInValidTermTokens (TStrings ss)  = TkStringBegin : (TkString . T.pack <$> ss) ++ [TkBytesBegin]
-termToInValidTermTokens (TArray ts)    =
-  TkListLen (fromIntegral $ length ts) : (mconcat $ termToInValidTermTokens <$> ts) ++ [TkNull]
-termToInValidTermTokens (TArrayI ts)   =
-  TkListBegin : TkListBegin : (mconcat $ termToInValidTermTokens <$> ts) ++ [TkBreak]
-termToInValidTermTokens (TMap kvs)     =
-  let kvList = mconcat $ (\ (a, _) -> [a]) <$> kvs
-  in TkMapLen (fromIntegral $ length kvList) : (mconcat $ termToInValidTermTokens <$> kvList) ++ [TkNull]
-termToInValidTermTokens (TMapI kvs)    =
-  let kvList = mconcat $ (\ (a, _) -> [a]) <$> kvs
-  in TkMapBegin : TkStringBegin : (mconcat $ termToInValidTermTokens <$> kvList) ++ [TkBreak]
-termToInValidTermTokens x = TkStringBegin : TkNull : TkBreak : termToValidTermTokens x
-
-
--- Convert Term to List of Valid TermTokens
-termToValidTermTokens :: Term -> [TermToken]
-termToValidTermTokens (TUInt u )     = [ TkInt . fromIntegral $ fromUInt u ]
-termToValidTermTokens (TNInt u )     = [ TkInt . fromIntegral $ fromUInt u ]
-termToValidTermTokens (TBigInt i)    = [ TkInteger i ]
-termToValidTermTokens (TBytes w)     = [ TkBytes (BS.pack w) ]
-termToValidTermTokens (TBytess ws)   = TkBytesBegin : ((TkBytes . BS.pack) <$> ws) ++ [TkBreak]
-termToValidTermTokens (TString s)    = [ TkString (T.pack s) ]
-termToValidTermTokens (TStrings ss)  = TkStringBegin : (TkString . T.pack <$> ss) ++ [TkBreak]
-termToValidTermTokens (TArray ts)    =
-  TkListLen (fromIntegral $ length ts) : (mconcat $ termToValidTermTokens <$> ts)
-termToValidTermTokens (TArrayI ts)   = TkListBegin : (mconcat $ termToValidTermTokens <$> ts) ++ [TkBreak]
-termToValidTermTokens (TMap kvs)     =
-  let kvList = mconcat $ (\ (a, b) -> [a,b]) <$> kvs
-  in TkMapLen (fromIntegral $ length kvs) : (mconcat $ termToValidTermTokens <$> kvList)
-termToValidTermTokens (TMapI kvs)    =
-  let kvList = mconcat $ (\ (a, b) -> [a,b]) <$> kvs
-  in TkMapBegin : (mconcat $ termToValidTermTokens <$> kvList) ++ [TkBreak]
-termToValidTermTokens (TTagged ui t) = TkTag (fromUInt ui) : termToValidTermTokens t
-termToValidTermTokens TTrue          = [ TkBool True ]
-termToValidTermTokens TFalse         = [ TkBool False ]
-termToValidTermTokens TNull          = [ TkNull ]
-termToValidTermTokens TUndef         = [ TkNull ]
-termToValidTermTokens (TSimple s)    = [ TkSimple (fromSimple s) ]
-termToValidTermTokens (TFloat16 hs)  = [ TkFloat16 (fromHalf . getHalfSpecials $ hs) ]
-termToValidTermTokens (TFloat32 fs)  = [ TkFloat32 (getFloatSpecials fs) ]
-termToValidTermTokens (TFloat64 ds)  = [ TkFloat64 (getDoubleSpecials ds) ]
-
-prop_validateValidFlat :: ValidFlat -> Property
-prop_validateValidFlat (ValidFlat ts) = property $ validFlatTerm ts
-
-prop_validateInValidFlat :: InValidFlat -> Property
-prop_validateInValidFlat (InValidFlat ts) = property $ validFlatTerm ts == False
+instance Arbitrary TermToken where
+  arbitrary = oneof
+    [ TkInt <$> arbitrary
+    , TkInteger <$> arbitrary
+    , TkBytes . BS.pack <$> arbitrary 
+    , pure TkBytesBegin
+    , TkString . T.pack <$> arbitrary
+    , pure TkStringBegin
+    , TkListLen <$> arbitrary
+    , pure TkListBegin
+    , TkMapLen <$> arbitrary
+    , pure TkMapBegin
+    , pure TkBreak
+    , TkTag <$> arbitrary
+    , TkBool <$> arbitrary
+    , pure TkNull
+    , TkSimple <$> arbitrary
+    , TkFloat16 <$> arbitrary
+    , TkFloat32 <$> arbitrary
+    , TkFloat64 <$> arbitrary ]
+
+-- | Converts a FlatTerm to Encoding
+tokenToEncoding :: TermToken -> Encoding
+tokenToEncoding (TkInt n)      = encodeInt n  
+tokenToEncoding (TkInteger i)  = encodeInteger i
+tokenToEncoding (TkBytes bs)   = encodeBytes bs
+tokenToEncoding TkBytesBegin   = encodeBytesIndef
+tokenToEncoding (TkString txt) = encodeString txt
+tokenToEncoding TkStringBegin  = encodeStringIndef
+tokenToEncoding (TkListLen w)  = encodeListLen w
+tokenToEncoding TkListBegin    = encodeListLenIndef
+tokenToEncoding (TkMapLen w)   = encodeMapLen w
+tokenToEncoding TkMapBegin     = encodeMapLenIndef 
+tokenToEncoding TkBreak        = encodeBreak 
+tokenToEncoding (TkTag w64)    = encodeTag64 w64
+tokenToEncoding (TkBool bool)  = encodeBool bool
+tokenToEncoding TkNull         = encodeNull
+tokenToEncoding (TkSimple w8)  = encodeSimple w8
+tokenToEncoding (TkFloat16 f)  = encodeFloat16 f
+tokenToEncoding (TkFloat32 f)  = encodeFloat f
+tokenToEncoding (TkFloat64 d)  = encodeDouble d
+
+-- | Changes a FlatTerm to List of Word8.    
+termTokensToWord :: [TermToken] -> [Word8]
+termTokensToWord ts = LBS.unpack bytes
+  where
+    bytes = toLazyByteString enc
+    enc = mconcat $ tokenToEncoding <$> ts 
+
+-- | Given a FlatTerm returns a tuple Decoded by Reference and Implementation
+-- decoders respectively as First and Second element of the tuple.
+refImpDecode :: [TermToken] -> (Maybe Imp.Term, Maybe Imp.Term)
+refImpDecode ts = (((Imp.canonicaliseTerm . toRefTerm ) <$> maybeRdecoded), (Imp.canonicaliseTerm <$> maybeIdecoded ))
+  where
+    impDecoded = Imp.runDecoder Imp.decodeTerm (termTokensToWord ts)
+    refDecoded = fromFlatTerm decodeTerm ts
+    maybeRdecoded = either (const Nothing) Just refDecoded 
+    maybeIdecoded = case impDecoded of
+      Just (term, []) -> Just term
+      _               -> Nothing
+
+-- | Given a FlatTerm checks whether the results of Refernce and Implementation
+-- decoders tally or not, also matches the result with @validFlatTerm@ function.
+prop_validFlatTerm :: [TermToken] -> Property
+prop_validFlatTerm ts = property $ case refImpDecode ts of
+  (Just x, Just y)   -> x == y && validFlatTerm ts
+  (Nothing, Nothing) -> True && (not $ validFlatTerm ts)
+  _                  -> False
 
 testTree :: TestTree
-testTree = testGroup "tests the function validFlatTerm"
-  [ testProperty "validFlatTerm ValidFlat == True "    prop_validateValidFlat
-  , testProperty "validFlatTerm InValidFlat == False " prop_validateInValidFlat
+testTree = testGroup "tests the function validFlatTerm and different decoders"
+  [ testProperty "all should agree: RefDecoder, ImpDecoder, validFlatTerm "    prop_validFlatTerm
   ]

cborg/tests/Tests/Properties.hs

@@ -1,8 +1,9 @@
 {-# LANGUAGE CPP                  #-}
-{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE RankNTypes           #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE DefaultSignatures    #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Tests.Properties (
@@ -45,14 +46,13 @@ import           Data.Bits (complement)
 import qualified Numeric.Half as Half
 import           Data.Function (on)
 import           Data.Proxy
-import           Control.Applicative (liftA2)
 
 import           Codec.CBOR.Term
 import           Codec.CBOR.Read
 import           Codec.CBOR.Write
 import           Codec.CBOR.Decoding
 import           Codec.CBOR.Encoding
-import           Codec.CBOR.FlatTerm (toFlatTerm, fromFlatTerm)
+import           Codec.CBOR.FlatTerm
 
 import           Test.Tasty (TestTree, testGroup, localOption)
 import           Test.Tasty.QuickCheck (testProperty, QuickCheckMaxSize(..))
@@ -399,20 +399,26 @@ prop_decodeRefdecodeImp _ x =
 -- >                Imp ─────────────────────▶Imp
 -- >                              id
 --
--- > (fromFlatTerm dec_imp . toFlatTerm . enc_imp) imp = Right imp
+-- > (fromFlatTerm dec_imp . toFlatTerm . enc_imp) imp = imp
 --
 prop_toFromFlatTerm :: forall t. Token t => Proxy t -> t -> Bool
 prop_toFromFlatTerm _ x =    
 
-    liftA2 eq (fn enc) (Right imp) == Right True
+  (deserialiseFromFlatTerm (decodeImp t) . toFlatTerm . encodeImp t) imp  `eq`  imp
 
   where
     imp  = fromRef . canonicaliseRef $ x
     eq   = eqImp t
     enc  = encodeImp t imp 
-    fn e = fromFlatTerm  (decodeImp (Proxy :: Proxy t)) $ toFlatTerm e
+    fn e = fromFlatTerm (decodeImp t) $ toFlatTerm e
     t    = Proxy :: Proxy t
 
+    deserialiseFromFlatTerm :: (forall s. Decoder s a) -> FlatTerm -> a
+    deserialiseFromFlatTerm dec flatTerm =
+      case fromFlatTerm dec flatTerm of
+        Left _ -> error "fromFlatTerm: decode failure"
+        Right x -> x
+
 
 --------------------------------------------------------------------------------
 -- Token class instances for unsigned types