diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,3 @@ +Changes in 0.6.0.0 + + * Initial release diff --git a/Data/Vector/Fixed/Instances/CBOR.hs b/Data/Vector/Fixed/Instances/CBOR.hs new file mode 100644 --- /dev/null +++ b/Data/Vector/Fixed/Instances/CBOR.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Module with binary instances for data types defined in fixed +-- vector +module Data.Vector.Fixed.Instances.CBOR where + +import Codec.Serialise +import Codec.CBOR.Encoding (Encoding,encodeListLen,encodeNull) +import Codec.CBOR.Decoding (Decoder,decodeListLenOf,decodeNull) +import Data.Monoid ((<>)) +import Data.Typeable (Proxy(..)) + +import Data.Vector.Fixed (Arity) +import qualified Data.Vector.Fixed as F +import Data.Vector.Fixed.Cont (arity,Dim) +import qualified Data.Vector.Fixed.Boxed as B +import qualified Data.Vector.Fixed.Unboxed as U +import qualified Data.Vector.Fixed.Primitive as P +import qualified Data.Vector.Fixed.Storable as S + + + +instance (Arity n, Serialise a) => Serialise (B.Vec n a) where + encode = encodeFixedVector + decode = decodeFixedVector + +instance (Arity n, P.Prim a, Serialise a) => Serialise (P.Vec n a) where + encode = encodeFixedVector + decode = decodeFixedVector + +instance (Arity n, S.Storable a, Serialise a) => Serialise (S.Vec n a) where + encode = encodeFixedVector + decode = decodeFixedVector + +instance (U.Unbox n a, Serialise a) => Serialise (U.Vec n a) where + encode = encodeFixedVector + decode = decodeFixedVector + +instance (Arity n, Serialise a) => Serialise (F.VecList n a) where + encode = encodeFixedVector + decode = decodeFixedVector + +instance (Serialise a) => Serialise (F.Only a) where + encode = encodeFixedVector + decode = decodeFixedVector + +instance Serialise (F.Empty a) where + encode = const encodeNull + decode = F.Empty <$ decodeNull + +-- | Encode vector with statically known size as CBOR list. There's no +-- type tag +encodeFixedVector :: (F.Vector v a, Serialise a) => v a -> Encoding +{-# INLINE encodeFixedVector #-} +encodeFixedVector v = encodeListLen (fromIntegral $ F.length v) + <> F.foldMap encode v + +-- | Decode vector with statically known size as CBOR list. There's no +-- type tag +decodeFixedVector :: forall v s a. (F.Vector v a, Serialise a) => Decoder s (v a) +{-# INLINE decodeFixedVector #-} +decodeFixedVector = do + decodeListLenOf (fromIntegral $ arity (Proxy :: Proxy (Dim v))) + F.replicateM decode diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) Aleksey Khudyakov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fixed-vector-cborg.cabal b/fixed-vector-cborg.cabal new file mode 100644 --- /dev/null +++ b/fixed-vector-cborg.cabal @@ -0,0 +1,42 @@ +Name: fixed-vector-cborg +Version: 1.0.0.0 +Synopsis: Binary instances for fixed-vector +Description: + CBOR serialization instances for fixed-vector's types. Generic + serialization functions are proviede as well + +Cabal-Version: >= 1.8 +License: BSD3 +License-File: LICENSE +Author: Aleksey Khudyakov +Maintainer: Aleksey Khudyakov +Bug-reports: https://github.com/Shimuuar/fixed-vector/issues +Category: Data +Build-Type: Simple +extra-source-files: + ChangeLog + +source-repository head + type: git + location: http://github.com/Shimuuar/fixed-vector + +Library + Ghc-options: -Wall + Build-Depends: base >=4.8 && <5 + , fixed-vector >=1.0 + , cborg + , serialise + Exposed-modules: + Data.Vector.Fixed.Instances.CBOR + +Test-Suite test + Type: exitcode-stdio-1.0 + Hs-source-dirs: test + Main-is: QC.hs + Build-Depends: + base >=3 && <5, + fixed-vector, + fixed-vector-cborg, + serialise, + tasty, + tasty-quickcheck diff --git a/test/QC.hs b/test/QC.hs new file mode 100644 --- /dev/null +++ b/test/QC.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +import Test.Tasty +import Test.Tasty.QuickCheck as QC + +import Codec.Serialise +import Data.Typeable +import qualified Data.Vector.Fixed as F +import qualified Data.Vector.Fixed.Unboxed as U +import qualified Data.Vector.Fixed.Boxed as B +import qualified Data.Vector.Fixed.Storable as S +import qualified Data.Vector.Fixed.Primitive as P +import Data.Vector.Fixed.Instances.CBOR () + + + +tests = testGroup "cereal" + [ testTagged p_serialize (T :: T (F.Only Int)) + , testTagged p_serialize (T :: T (F.VecList 2 Int)) + , testTagged p_serialize (T :: T (F.VecList 3 Int)) + , testTagged p_serialize (T :: T (F.VecList 4 Int)) + -- + , testTagged p_serialize (T :: T (U.Vec 2 Int)) + , testTagged p_serialize (T :: T (U.Vec 3 Int)) + , testTagged p_serialize (T :: T (U.Vec 4 Int)) + -- + , testTagged p_serialize (T :: T (B.Vec 2 Int)) + , testTagged p_serialize (T :: T (B.Vec 3 Int)) + , testTagged p_serialize (T :: T (B.Vec 4 Int)) + -- + , testTagged p_serialize (T :: T (S.Vec 2 Int)) + , testTagged p_serialize (T :: T (S.Vec 3 Int)) + , testTagged p_serialize (T :: T (S.Vec 4 Int)) + -- + , testTagged p_serialize (T :: T (P.Vec 2 Int)) + , testTagged p_serialize (T :: T (P.Vec 3 Int)) + , testTagged p_serialize (T :: T (P.Vec 4 Int)) + ] + +p_serialize :: (Serialise a, Arbitrary a, Eq a) => T a -> a -> Bool +p_serialize _ a = a == (deserialise . serialise) a + +data T a = T + +testTagged :: forall a b. (Testable b, Typeable a) => (T a -> b) -> T a -> TestTree +testTagged prop t + = testProperty (show $ typeOf (undefined :: a)) (prop t) + +main :: IO () +main = defaultMain tests + +---------------------------------------------------------------- +instance Arbitrary a => Arbitrary (F.Only a) where + arbitrary = F.replicateM arbitrary +instance Arbitrary a => Arbitrary (F.Empty a) where + arbitrary = F.replicateM arbitrary + +instance (F.Arity n, Arbitrary a) => Arbitrary (F.VecList n a) where + arbitrary = F.replicateM arbitrary +instance (U.Unbox n a, Arbitrary a) => Arbitrary (U.Vec n a) where + arbitrary = F.replicateM arbitrary +instance (F.Arity n, Arbitrary a) => Arbitrary (B.Vec n a) where + arbitrary = F.replicateM arbitrary +instance (F.Arity n, S.Storable a, Arbitrary a) => Arbitrary (S.Vec n a) where + arbitrary = F.replicateM arbitrary +instance (F.Arity n, P.Prim a, Arbitrary a) => Arbitrary (P.Vec n a) where + arbitrary = F.replicateM arbitrary + + +