added test for validFlat along with Ref and Imp Decoders

cborg/cborg.cabal

@@ -122,6 +122,7 @@ test-suite tests
     Tests.Term
     Tests.UTF8
     Tests.Util
+    Tests.FlatTerm
 
   build-depends:
     array                   >= 0.4     && < 0.6,

cborg/tests/Main.hs

@@ -10,6 +10,7 @@ import qualified Tests.ByteOffset as ByteOffset
 import qualified Tests.Canonical  as Canonical
 import qualified Tests.Regress    as Regress
 import qualified Tests.UTF8       as UTF8
+import qualified Tests.FlatTerm   as FlatTerm
 
 main :: IO ()
 main = defaultMain tests
@@ -25,4 +26,5 @@ tests =
     , Canonical.testTree
     , Regress.testTree
     , UTF8.testTree
+    , FlatTerm.testTree
     ]

cborg/tests/Tests/FlatTerm.hs

@@ -0,0 +1,119 @@
+{-# Language FlexibleInstances #-}
+-- {-# Language OverlappingInstances #-}
+
+module Tests.FlatTerm
+  ( testTree -- :: TestTree
+  ) where
+
+import           Control.Applicative
+import           Codec.CBOR.FlatTerm ( TermToken(..), fromFlatTerm, validFlatTerm, toFlatTerm )
+import           Codec.CBOR.Write    ( toLazyByteString)
+import           Codec.CBOR.Term     ( decodeTerm, encodeTerm )
+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, fromRefTerm )
+import qualified Data.ByteString      as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text as T
+import           Data.Word
+import           Prelude         hiding (encodeFloat)
+
+import           Test.QuickCheck
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+
+--------------------------------------------------------------------------------
+
+instance {-# OVERLAPS #-} Arbitrary [TermToken] where
+  arbitrary = frequency
+    [ (60, termToTermTokens <$> arbitrary)
+    , (40, pure <$> genArbitraryFlatTerm)
+    ]
+
+genArbitraryFlatTerm :: Gen TermToken
+genArbitraryFlatTerm = 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
+
+-- | converts a @Term@ to @FlatTerm@
+termToTermTokens :: Imp.Term -> [TermToken]
+termToTermTokens = toFlatTerm . encodeTerm . fromRefTerm
+
+
+-- | 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 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 (refDecoded, impDecoded) of
+  (Right x, Just (term, []))   -> ((Imp.canonicaliseTerm . toRefTerm $ x) == Imp.canonicaliseTerm term) 
+                                  && validFlatTerm ts
+  (Left _ , _)                 -> not $ validFlatTerm ts
+  _                            -> False
+  where
+    impDecoded = Imp.runDecoder Imp.decodeTerm (termTokensToWord ts)
+    refDecoded = fromFlatTerm decodeTerm ts
+
+testTree :: TestTree
+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

stack.yaml

@@ -1,4 +1,5 @@
-resolver: lts-13.8
+resolver: lts-13.14
+
 packages:
 - 'cborg'
 - 'serialise'