diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -5,3 +5,7 @@ - `unflatWith` now takes a decoder for the unpadded value (previously it expected a padded decoder) and decodes the padded value - Added some decoding primitives - Added Data.ByteString.Convert + +Version 0.3.1: + - Tested with ghc 8.2.1 + - Dropped dependencies on the 'cpu', 'derive' and 'tasty' packages to make it compatible with the Eta compiler (https://github.com/typelead/eta) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,8 @@ -[![Build Status](https://travis-ci.org/tittoassini/flat.svg?branch=master)](https://travis-ci.org/tittoassini/flat) [![Hackage version](https://img.shields.io/hackage/v/flat.svg)](http://hackage.haskell.org/package/flat) +[![Build Status](https://travis-ci.org/Quid2/flat.svg?branch=master)](https://travis-ci.org/Quid2/flat) +[![Hackage version](https://img.shields.io/hackage/v/flat.svg)](http://hackage.haskell.org/package/flat) +[![Stackage Nightly](http://stackage.org/package/flat/badge/nightly)](http://stackage.org/nightly/package/flat) +[![Stackage LTS](http://stackage.org/package/flat/badge/lts)](http://stackage.org/lts/package/flat) Haskell implementation of [Flat](http://quid2.org/docs/Flat.pdf), a principled, portable and efficient binary data format ([specs](http://quid2.org)). @@ -39,13 +42,13 @@ ``` -For the decoding to work correctly, you will naturally need to know the type of the serialised data. This is ok for applications that do not require long-term storage and that do not need to communicate across independently evolving agents. For those who do, you will need to supplement `flat` with something like [typed](https://github.com/tittoassini/typed). +For the decoding to work correctly, you will naturally need to know the type of the serialised data. This is ok for applications that do not require long-term storage and that do not need to communicate across independently evolving agents. For those who do, you will need to supplement `flat` with something like [zm](https://github.com/Quid2/zm). #### Define Instances for Abstract/Primitive types A set of primitives are available to define `Flat` instances for abstract or primitive types. - Instances for some common, primitive or abstract data types (Bool,Words,Int,String,Text,ByteStrings,Tuples, Lists, Sequences, Maps ..) are already defined in [Data.Flat.Instances](https://github.com/tittoassini/flat/blob/master/src/Data/Flat/Instances.hs). + Instances for some common, primitive or abstract data types (Bool,Words,Int,String,Text,ByteStrings,Tuples, Lists, Sequences, Maps ..) are already defined in [Data.Flat.Instances](https://github.com/Quid2/flat/blob/master/src/Data/Flat/Instances.hs). #### Optimal Bit-Encoding @@ -121,7 +124,7 @@ One thing that is not shown by the benchmarks is that, if the serialized data is to be transferred over a network, the total transfer time (encoding time + transmission time + decoding time) is usually dominated by the transmission time and that's where the smaller binaries produced by flat give it a significant advantage. - Consider for example the Cars dataset. As you can see in the following comparison with `store`, the overall top performer for encoding/decoding speed, the transfer time is actually significantly lower for `flat` for all except the highest transmission speeds. + Consider for example the Cars dataset. As you can see in the following comparison with `store`, the overall top performer for encoding/decoding speed, the transfer time is actually significantly lower for `flat` for all except the highest transmission speeds (about 4 times faster at typical ADSL speeds, 2 times faster at 4G-LTE mobile speeds). ||Store|Flat| |---|---|---| @@ -139,17 +142,19 @@ ### Haskell Compatibility Tested with: - * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.1 and 8.0.2 (x64) + * [ghc](https://www.haskell.org/ghc/) 7.10.3, 8.0.2, 8.2.2, 8.4.2 and 8.4.3 (x64) * [ghc](https://www.haskell.org/ghc/) 7.10.3/LLVM 3.5.2 (Arm7) * [ghcjs](https://github.com/ghcjs/ghcjs) +It also seems to be working with [Eta](https://eta-lang.org/) though the full test suite could not be run due to Eta's issues compiling `quickcheck` and `doctest`. + ### Installation Get the latest stable version from [hackage](https://hackage.haskell.org/package/flat). ### Acknowledgements - `flat` reuses ideas and readapts code from various packages, mainly: `store`, `binary-bits` and `binary`. + `flat` reuses ideas and readapts code from various packages, mainly: `store`, `binary-bits` and `binary` and includes contributions from Justus Sagemüller. ### Known Bugs and Infelicities diff --git a/flat.cabal b/flat.cabal --- a/flat.cabal +++ b/flat.cabal @@ -1,27 +1,27 @@ name: flat -version: 0.3 +version: 0.3.2 synopsis: Principled and efficient bit-oriented binary serialization. -description: See the . -homepage: http://github.com/tittoassini/flat +description: Principled and efficient bit-oriented binary serialization, check the . +homepage: http://github.com/Quid2/flat +category: Data,Parsing,Serialization license: BSD3 license-file: LICENSE author: Pasqualino `Titto` Assini maintainer: tittoassini@gmail.com copyright: Copyright: (c) 2016 Pasqualino `Titto` Assini -category: Data,Parsing,Serialization cabal-version: >=1.10 build-type: Simple -Tested-With: GHC == 7.10.3 GHC == 8.0.1 GHC == 8.0.2 +-- The library (but not its tests) compiles with ETA == 0.7.2 (see https://eta-lang.org/) +Tested-With: GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 GHC == 8.4.2 + extra-source-files: stack.yaml - stack801.yaml - stack802.yaml README.md CHANGELOG source-repository head type: git - location: https://github.com/tittoassini/flat + location: https://github.com/Quid2/flat library exposed-modules: @@ -45,21 +45,23 @@ Data.Flat Data.FloatCast Data.ZigZag + other-modules: System.Endian build-depends: - array >=0.5.1.0, - base >=4.8 && <5, - bytestring >=0.10.6.0, - containers >=0.5.6.2, - cpu >=0.1.2, - deepseq >=1.4.1.1, - dlist >=0.7.1.2, - ghc-prim >=0.3.1, - mono-traversable >=1.0.1, - pretty >=1.1.2.0, - primitive >=0.6.1.0, - text >=1.2.2.1, - transformers >=0.4.2.0, - vector >=0.11.0.0 + array >= 0.5.1.0 && <0.6, + base >=4.8 && <5, + bytestring>=0.10.6.0 && < 0.11, + containers == 0.5.*, + deepseq == 1.4.*, + dlist >=0.6 && <0.9, + ghc-prim, + mono-traversable >=0.10.0.2 && <1.1, + pretty >= 1.1.2 && < 1.2, + primitive, + text, + vector + if impl(ghc < 8.0) + build-depends: semigroups + default-language: Haskell2010 default-extensions: CPP other-extensions: DataKinds DefaultSignatures DeriveAnyClass @@ -70,24 +72,22 @@ hs-source-dirs: src ghc-options: -O2 -funbox-strict-fields -Wall -fno-warn-orphans -fno-warn-name-shadowing -test-suite flat-test +test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs build-depends: - base >=4.8 && <5, - cpu >=0.1.2, - ghc-prim >=0.3.1.0, - tasty >=0.11.0.2, - tasty-hunit >=0.9.2, - tasty-quickcheck >=0.8.4, - pretty >=1.1.2.0, - containers >=0.5.6.2, - derive >=2.5.26, - text >=1.2.2.1, - bytestring >=0.10.6.0, - deepseq >=1.4.1.1, - text >=1.2.2.1, - flat >=0.1.3 + base >=4.8 && <5 + , ghc-prim + , tasty >= 0.11 + , tasty-hunit >= 0.8 + , tasty-quickcheck >=0.8.1 + , containers == 0.5.* + , deepseq == 1.4.* + , quickcheck-instances>=0.3.12 + , text + , bytestring + , flat + default-language: Haskell2010 hs-source-dirs: test cpp-options: -DLIST_BIT @@ -98,4 +98,19 @@ Test.Data.Flat Test.Data2.Flat Test.Data.Values + -- if impl(eta) + -- cpp-options: -DETA_COMPILER +test-suite docs + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: DocSpec.hs + build-depends: base, doctest>=0.11.2 && <0.16,filemanip>=0.3.6.3 && < 0.3.7 + HS-Source-Dirs: test + +-- executable qtest +-- default-language: Haskell2010 +-- main-is: Test.hs +-- hs-source-dirs: test +-- build-depends: base, flat, time + diff --git a/src/Data/Flat/Decoder/Prim.hs b/src/Data/Flat/Decoder/Prim.hs --- a/src/Data/Flat/Decoder/Prim.hs +++ b/src/Data/Flat/Decoder/Prim.hs @@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} -- |Strict Decoder Primitives module Data.Flat.Decoder.Prim ( @@ -68,10 +67,10 @@ {-# INLINE dBEBits8 #-} -- |Return the n most significant bits (up to maximum of 8) --- The bits are returned right shifted. -- --- >>> unflatWith (dBEBits8 3) [128+64+32+1::Word8] --- Right 7 +-- The bits are returned right shifted: +-- +-- unflatWith (dBEBits8 3) [128+64+32+1::Word8] == Right 7 dBEBits8 :: Int -> Get Word8 dBEBits8 n = Get $ \endPtr s -> do ensureBits endPtr s n diff --git a/src/Data/Flat/Encoder.hs b/src/Data/Flat/Encoder.hs --- a/src/Data/Flat/Encoder.hs +++ b/src/Data/Flat/Encoder.hs @@ -64,4 +64,4 @@ import Data.Flat.Encoder.Size(arrayBits) import Data.Flat.Encoder.Strict import Data.Flat.Encoder.Types -import Data.Monoid +import Data.Monoid((<>)) diff --git a/src/Data/Flat/Encoder/Strict.hs b/src/Data/Flat/Encoder/Strict.hs --- a/src/Data/Flat/Encoder/Strict.hs +++ b/src/Data/Flat/Encoder/Strict.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ScopedTypeVariables #-} + -- |Strict encoder module Data.Flat.Encoder.Strict where @@ -12,7 +13,7 @@ import Data.Flat.Encoder.Types import Data.Flat.Types import Data.Foldable -import Data.Monoid +import Data.Semigroup -- (Semigroup(..)) -- |Strict encoder strictEncoder :: NumBits -> Encoding -> B.ByteString @@ -26,6 +27,10 @@ newtype Encoding = Encoding { run :: Prim } instance Show Encoding where show _ = "Encoding" + +instance Semigroup Encoding where + {-# INLINE (<>) #-} + (<>) = mappend instance Monoid Encoding where {-# INLINE mempty #-} diff --git a/src/Data/Flat/Instances.hs b/src/Data/Flat/Instances.hs --- a/src/Data/Flat/Instances.hs +++ b/src/Data/Flat/Instances.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE BangPatterns #-} +-- {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} +-- {-# LANGUAGE UndecidableInstances #-} +-- {-# LANGUAGE IncoherentInstances #-} + -- |Flat Instances for common, primitive and abstract data types for which instances cannot be automatically derived module Data.Flat.Instances ( sizeMap, diff --git a/src/Data/Flat/Memory.hs b/src/Data/Flat/Memory.hs --- a/src/Data/Flat/Memory.hs +++ b/src/Data/Flat/Memory.hs @@ -3,26 +3,36 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} -- |Memory access primitives -module Data.Flat.Memory ( - chunksToByteString, - chunksToByteArray, - ByteArray(..), - pokeByteArray, - pokeByteString, - unsafeCreateUptoN', - minusPtr, - ) where +module Data.Flat.Memory + ( chunksToByteString + , chunksToByteArray + , ByteArray + , pokeByteArray + , pokeByteString + , unsafeCreateUptoN' + , minusPtr + ) +where import Control.Monad -import Control.Monad.Primitive (PrimMonad (..)) -import qualified Data.ByteString.Internal as BS -import Data.Primitive.ByteArray -import Foreign hiding (void) -import GHC.Prim (copyAddrToByteArray#,copyByteArrayToAddr#) -import GHC.Ptr (Ptr (..)) -import GHC.Types (IO (..), Int (..)) +import Control.Monad.Primitive ( PrimMonad(..) ) +import qualified Data.ByteString.Internal as BS +import Data.Primitive.ByteArray ( MutableByteArray(..) + , ByteArray# + , ByteArray + , newByteArray + , unsafeFreezeByteArray + ) +import Foreign hiding ( void ) +import GHC.Prim ( copyAddrToByteArray# + , copyByteArrayToAddr# + ) +import GHC.Ptr ( Ptr(..) ) +import GHC.Types ( IO(..) + , Int(..) + ) import System.IO.Unsafe -import qualified Data.ByteString as B +import qualified Data.ByteString as B unsafeCreateUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> (BS.ByteString, a) unsafeCreateUptoN' l f = unsafeDupablePerformIO (createUptoN' l f) @@ -30,52 +40,74 @@ createUptoN' :: Int -> (Ptr Word8 -> IO (Int, a)) -> IO (BS.ByteString, a) createUptoN' l f = do - fp <- BS.mallocByteString l + fp <- BS.mallocByteString l (l', res) <- withForeignPtr fp $ \p -> f p --print (unwords ["Buffer allocated:",show l,"bytes, used:",show l',"bytes"]) - when (l'> l) $ error (unwords ["Buffer overflow, allocated:",show l,"bytes, used:",show l',"bytes"]) + when (l' > l) $ error + (unwords + ["Buffer overflow, allocated:", show l, "bytes, used:", show l', "bytes"] + ) return (BS.PS fp 0 l', res) -- , minusPtr l') {-# INLINE createUptoN' #-} -- |Copy bytestring to given pointer, returns new pointer pokeByteString :: B.ByteString -> Ptr Word8 -> IO (Ptr Word8) -pokeByteString (BS.PS foreignPointer sourceOffset sourceLength) destPointer = do - withForeignPtr foreignPointer $ \sourcePointer -> - BS.memcpy destPointer (sourcePointer `plusPtr` sourceOffset) sourceLength +pokeByteString (BS.PS foreignPointer sourceOffset sourceLength) destPointer = + do + withForeignPtr foreignPointer $ \sourcePointer -> BS.memcpy + destPointer + (sourcePointer `plusPtr` sourceOffset) + sourceLength return (destPointer `plusPtr` sourceLength) pokeByteArray :: ByteArray# -> Int -> Int -> Ptr Word8 -> IO (Ptr Word8) pokeByteArray sourceArr sourceOffset len dest = do - copyByteArrayToAddr sourceArr sourceOffset dest len - let !dest' = dest `plusPtr` len - return dest' + copyByteArrayToAddr sourceArr sourceOffset dest len + let !dest' = dest `plusPtr` len + return dest' {-# INLINE pokeByteArray #-} -- | Wrapper around @copyByteArrayToAddr#@ primop. -- Copied from the store-core package copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO () copyByteArrayToAddr arr (I# offset) (Ptr addr) (I# len) = - IO (\s -> (# copyByteArrayToAddr# arr offset addr len s, () #)) -{-# INLINE copyByteArrayToAddr #-} + IO (\s -> (#copyByteArrayToAddr# arr offset addr len s, ()#)) +{-# INLINE copyByteArrayToAddr #-} -- toByteString :: Ptr Word8 -> Int -> BS.ByteString -- toByteString sourcePtr sourceLength = BS.unsafeCreate sourceLength $ \destPointer -> BS.memcpy destPointer sourcePtr sourceLength -chunksToByteString :: (Ptr Word8,[Int]) -> BS.ByteString -chunksToByteString (sourcePtr,lens) = - BS.unsafeCreate (sum lens) $ \destPtr -> void $ foldM (\(destPtr,sourcePtr) sourceLength -> BS.memcpy destPtr sourcePtr sourceLength >> return (destPtr `plusPtr` sourceLength,sourcePtr `plusPtr` (sourceLength+1))) (destPtr,sourcePtr) lens +chunksToByteString :: (Ptr Word8, [Int]) -> BS.ByteString +chunksToByteString (sourcePtr0, lens) = + BS.unsafeCreate (sum lens) $ \destPtr0 -> void $ foldM + (\(destPtr, sourcePtr) sourceLength -> + BS.memcpy destPtr sourcePtr sourceLength + >> return + ( destPtr `plusPtr` sourceLength + , sourcePtr `plusPtr` (sourceLength + 1) + ) + ) + (destPtr0, sourcePtr0) + lens -chunksToByteArray :: (Ptr Word8,[Int]) -> (ByteArray,Int) -chunksToByteArray (sourcePtr,lens) = unsafePerformIO $ do +chunksToByteArray :: (Ptr Word8, [Int]) -> (ByteArray, Int) +chunksToByteArray (sourcePtr0, lens) = unsafePerformIO $ do let len = sum lens arr <- newByteArray len - foldM_ (\(destOff,sourcePtr) sourceLength -> copyAddrToByteArray sourcePtr arr destOff sourceLength >> return (destOff + sourceLength,sourcePtr `plusPtr` (sourceLength+1))) (0,sourcePtr) lens + foldM_ + (\(destOff, sourcePtr) sourceLength -> + copyAddrToByteArray sourcePtr arr destOff sourceLength >> return + (destOff + sourceLength, sourcePtr `plusPtr` (sourceLength + 1)) + ) + (0, sourcePtr0) + lens farr <- unsafeFreezeByteArray arr - return (farr,len) + return (farr, len) -- from store-core -- | Wrapper around @copyAddrToByteArray#@ primop. -copyAddrToByteArray :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO () +copyAddrToByteArray + :: Ptr a -> MutableByteArray (PrimState IO) -> Int -> Int -> IO () copyAddrToByteArray (Ptr addr) (MutableByteArray arr) (I# offset) (I# len) = - IO (\s -> (# copyAddrToByteArray# addr arr offset len s, () #)) -{-# INLINE copyAddrToByteArray #-} + IO (\s -> (#copyAddrToByteArray# addr arr offset len s, ()#)) +{-# INLINE copyAddrToByteArray #-} diff --git a/src/System/Endian.hs b/src/System/Endian.hs new file mode 100644 --- /dev/null +++ b/src/System/Endian.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} +module System.Endian + ( + toBE32 + , toBE64 + , toBE16 + ) where + +#include "MachDeps.h" + +import Data.Word + +-- | Convert a 64 bit value in cpu endianess to big endian +toBE64 :: Word64 -> Word64 +#ifdef WORDS_BIGENDIAN +toBE64 = id +#else +toBE64 = byteSwap64 +#endif + +-- | Convert a 32 bit value in cpu endianess to big endian +toBE32 :: Word32 -> Word32 +#ifdef WORDS_BIGENDIAN +toBE32 = id +#else +toBE32 = byteSwap32 +#endif + +-- | Convert a 16 bit value in cpu endianess to big endian +toBE16 :: Word16 -> Word16 +#ifdef WORDS_BIGENDIAN +toBE16 = id +#else +toBE16 = byteSwap16 +#endif diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,3 @@ -resolver: lts-6.31 - -extra-deps: -- mono-traversable-1.0.2 +resolver: lts-9.21 +#resolver: lts-11.13 +#resolver: nightly-2018-06-16 diff --git a/stack801.yaml b/stack801.yaml deleted file mode 100644 --- a/stack801.yaml +++ /dev/null @@ -1,1 +0,0 @@ -resolver: lts-7.21 diff --git a/stack802.yaml b/stack802.yaml deleted file mode 100644 --- a/stack802.yaml +++ /dev/null @@ -1,1 +0,0 @@ -resolver: lts-8.13 diff --git a/test/DocSpec.hs b/test/DocSpec.hs new file mode 100644 --- /dev/null +++ b/test/DocSpec.hs @@ -0,0 +1,15 @@ +module Main where +import Test.DocTest +import System.FilePath.Find +import Data.List ( isSuffixOf ) + +main :: IO () +-- main = find always ((extension ==? ".hs") &&? exceptFiles ["Data/Convertible/Base.hs","Data/Convertible/Utils.hs","Data/Convertible/Instances/Num.hs"]) "src" >>= doctest +main = find always ((extension ==? ".hs") &&? exceptFiles []) "src" >>= doctest + +exceptFiles :: Foldable t => t String -> FindClause Bool +exceptFiles mdls = + -- let excludes = liftOp (\fp mdls -> not $ any (\mdl -> isSuffixOf mdl (traceShowId fp)) mdls) + let excludes = liftOp + (\fp modules -> not $ any (`isSuffixOf` fp) modules) + in filePath `excludes` mdls diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -15,7 +15,6 @@ import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Short as SBS import Data.Char -import Data.DeriveTH import Data.Either import Data.Flat import Data.Flat.Bits @@ -29,8 +28,8 @@ import qualified Data.Text as T import Data.Word import Numeric.Natural -import System.Arch -import System.Endian +-- import System.Arch +-- import System.Endian import System.Exit import Test.Data import Test.Data.Arbitrary @@ -38,16 +37,16 @@ import Test.Data.Values import Test.Tasty import Test.Tasty.HUnit -import Test.Tasty.QuickCheck as QC +import Test.Tasty.QuickCheck as QC hiding (getSize) main = do - printInfo + -- printInfo mainTest -- main = mainShow -printInfo = do - print getSystemArch - print getSystemEndianness +-- printInfo = do +-- print getSystemArch +-- print getSystemEndianness mainShow = do mapM_ (\_ -> generate (arbitrary :: Gen Int) >>= print) [1..10] @@ -122,9 +121,9 @@ ,sz '经' 24 ,sz (0::Word8) 8 ,sz (1::Word8) 8 - ,concat $ map (uncurry sz) $ ns - ,concat $ map (uncurry sz) $ nsI - ,concat $ map (uncurry sz) $ nsII + ,concatMap (uncurry sz) ns + ,concatMap (uncurry sz) $ nsI + ,concatMap (uncurry sz) $ nsII ,sz (1.1::Float) 32 ,sz (1.1::Double) 64 ,sz "" 1 @@ -361,8 +360,6 @@ errDec :: forall a . (Flat a, Eq a, Show a) => Proxy a -> [Word8] -> [TestTree] --errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in ev @?= Left ""] errDec _ bs = [testCase "bad decode" $ let ev = (des bs::Decoded a) in isRight ev @?= False] - -uc = map ord "\x4444\x5555\x10001\xD800" ser :: Flat a => a -> [Word8] ser = B.unpack . flat diff --git a/test/Test/Data.hs b/test/Test/Data.hs --- a/test/Test/Data.hs +++ b/test/Test/Data.hs @@ -1,23 +1,27 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE MultiParamTypeClasses ,DeriveGeneric ,DeriveDataTypeable ,ScopedTypeVariables ,GADTs ,NoMonomorphismRestriction ,DeriveGeneric ,DefaultSignatures ,TemplateHaskell ,TypeFamilies ,FlexibleContexts ,FlexibleInstances ,EmptyDataDecls #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {- A collection of data types used for testing. -} + module Test.Data where -import Control.Exception -import Data.Char +import Data.Data import Data.Int import Data.Word - -import Data.Typeable -import Data.Data import GHC.Generics -import Data.Data -import qualified Test.Data2 as D2 -import Data.Foldable -import GHC.Exts hiding (toList) +import qualified Test.Data2 as D2 +import Test.Tasty.QuickCheck data Void deriving Generic @@ -203,3 +207,69 @@ ,fuel::String -- constant Petrol } deriving (Eq, Ord, Read, Show, Typeable, Data, Generic) +-- To generate Arbitrary instances while avoiding a direct dependency on 'derive' (that is not supported by Eta), run in the project directory: derive -a test/Test/Data.hs +{-! +deriving instance Arbitrary N +deriving instance Arbitrary Tree +deriving instance Arbitrary List +deriving instance Arbitrary Unit +deriving instance Arbitrary Un +deriving instance Arbitrary A +deriving instance Arbitrary B +!-} + +-- GENERATED START + +instance () => Arbitrary N where + arbitrary + = do x <- choose (0 :: Int, 4) + case x of + 0 -> return One + 1 -> return Two + 2 -> return Three + 3 -> return Four + 4 -> return Five + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance (Arbitrary a) => Arbitrary (Tree a) where + arbitrary + = do x <- choose (0 :: Int, 1) + case x of + 0 -> do x1 <- arbitrary + x2 <- arbitrary + return (Node x1 x2) + 1 -> Leaf <$> arbitrary + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance (Arbitrary a) => Arbitrary (List a) where + arbitrary + = do x <- choose (0 :: Int, 1) + case x of + 0 -> do x1 <- arbitrary + x2 <- arbitrary + return (C x1 x2) + 1 -> return N + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary Unit where + arbitrary = return Unit + +instance () => Arbitrary Un where + arbitrary + = Un <$> arbitrary +instance () => Arbitrary A where + arbitrary + = do x <- choose (0 :: Int, 1) + case x of + 0 -> A <$> arbitrary + 1 -> AA <$> arbitrary + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" + +instance () => Arbitrary B where + arbitrary + = do x <- choose (0 :: Int, 1) + case x of + 0 -> B <$> arbitrary + 1 -> BB <$> arbitrary + _ -> error "FATAL ERROR: Arbitrary instance, logic bug" +-- GENERATED STOP diff --git a/test/Test/Data/Arbitrary.hs b/test/Test/Data/Arbitrary.hs --- a/test/Test/Data/Arbitrary.hs +++ b/test/Test/Data/Arbitrary.hs @@ -1,28 +1,27 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +-- {-# LANGUAGE TemplateHaskell #-} + module Test.Data.Arbitrary where -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Short as SBS -import Data.DeriveTH -import qualified Data.Text as T -import Test.Data +-- import qualified Data.ByteString as B +-- import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short as SBS +-- import qualified Data.Text as T +-- import Test.Data +-- import Data.DeriveTH +import Test.QuickCheck.Instances import Test.Tasty.QuickCheck +-- import Test.QuickCheck -- xxx = generate (arbitrary :: Gen (Large (Int))) +#if !MIN_VERSION_quickcheck_instances(0,3,17) instance Arbitrary SBS.ShortByteString where arbitrary = fmap SBS.pack arbitrary +#endif -instance Arbitrary B.ByteString where arbitrary = fmap B.pack arbitrary -instance Arbitrary L.ByteString where arbitrary = fmap L.pack arbitrary - -instance Arbitrary T.Text where arbitrary = fmap T.pack arbitrary - --- instance Arbitrary a => Arbitrary (List a) where arbitrary = fmap l2L arbitrary - -derive makeArbitrary ''N - +{- +-- derive makeArbitrary ''N derive makeArbitrary ''Tree derive makeArbitrary ''List @@ -34,7 +33,7 @@ derive makeArbitrary ''A derive makeArbitrary ''B +-} -- instance Arbitrary Word7 where arbitrary = toEnum <$> choose (0, 127) -- derive makeArbitrary ''ASCII - diff --git a/test/Test/Data/Flat.hs b/test/Test/Data/Flat.hs --- a/test/Test/Data/Flat.hs +++ b/test/Test/Data/Flat.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE UndecidableInstances ,DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts ,FlexibleInstances ,LambdaCase ,StandaloneDeriving #-} + +{-# LANGUAGE UndecidableInstances ,DeriveGeneric, FlexibleContexts, FlexibleInstances,StandaloneDeriving #-} module Test.Data.Flat(module Test.Data) where import Data.Flat import Data.Flat.Encoder @@ -8,7 +7,6 @@ import Test.Data import Test.Data2.Flat() import Data.Word ---import Data.Flat.Poke import Data.Foldable import Data.Int import GHC.Generics diff --git a/test/Test/Data/Values.hs b/test/Test/Data/Values.hs --- a/test/Test/Data/Values.hs +++ b/test/Test/Data/Values.hs @@ -1,23 +1,24 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NoMonomorphismRestriction #-} module Test.Data.Values where import Control.DeepSeq import Control.Exception -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Short.Internal as SBS import Data.Char +import Data.Flat +import Data.Foldable import Data.Int import Data.List -import qualified Data.Text as T +import qualified Data.Map as M +import qualified Data.Sequence as Seq +import qualified Data.Text as T import Data.Word import Test.Data -import qualified Test.Data2 as D2 -import qualified Data.ByteString.Short.Internal as SBS -import Data.Foldable -import qualified Data.Sequence as Seq -import qualified Data.Map as M -import Data.Flat +import qualified Test.Data2 as D2 instance NFData Various instance NFData a => NFData (List a) @@ -187,9 +188,9 @@ notLongS = take 1000 . concat . repeat -arr0 = ("[Bool]",map (odd . ord) $ unicodeStr :: [Bool]) +arr0 = ("[Bool]",map (odd . ord) unicodeStr :: [Bool]) -arr1 = ("[Word]",map (fromIntegral . ord) $ unicodeStr :: [Word]) +arr1 = ("[Word]",map (fromIntegral . ord) unicodeStr :: [Word]) arr2 = ("ByteString from String",B.pack . map (fromIntegral . ord) $ unicodeStr) sbs = ("StrictByteString",b2)