diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,17 +1,19 @@ +module Main where + +import Criterion.Main import qualified Data.Serialize as Cereal -import Data.String.ToString -import Gauge.Main import qualified Ptr.Read as Read import Prelude +main :: IO () main = defaultMain - [ bench "int32InBe" $ - nf + [ bench "int32InBe" + $ nf (Read.runOnByteStringFinishing (Read.int32InBe)) - $! Cereal.runPut (Cereal.putInt32be 1), - bench "int32InBe*3" $ - nf + $! Cereal.runPut (Cereal.putInt32be 1), + bench "int32InBe*3" + $ nf (Read.runOnByteStringFinishing ((,,) <$> Read.int32InBe <*> Read.int32InBe <*> Read.int32InBe)) - $! Cereal.runPut (Cereal.putInt32be 1 <> Cereal.putInt32be 2 <> Cereal.putInt32be 3) + $! Cereal.runPut (Cereal.putInt32be 1 <> Cereal.putInt32be 2 <> Cereal.putInt32be 3) ] diff --git a/library/Ptr/ByteString.hs b/library/Ptr/ByteString.hs --- a/library/Ptr/ByteString.hs +++ b/library/Ptr/ByteString.hs @@ -15,8 +15,9 @@ parse :: B.ByteString -> C.Parse result -> (Int -> result) -> (Text -> result) -> result parse (B.PS fp offset length) (C.Parse parseIO) eoi error = {-# SCC "parse" #-} - unsafePerformIO $ - withForeignPtr fp $ \ptr -> + unsafePerformIO + $ withForeignPtr fp + $ \ptr -> parseIO length (plusPtr ptr offset) (return . eoi) (return . error) (\result _ _ -> return result) {-# INLINE peek #-} @@ -24,8 +25,9 @@ peek (B.PS fp offset length) (D.Peek amount io) = {-# SCC "peek" #-} if amount <= length - then Just $ - unsafePerformIO $ - withForeignPtr fp $ \ptr -> - io (plusPtr ptr offset) + then Just + $ unsafePerformIO + $ withForeignPtr fp + $ \ptr -> + io (plusPtr ptr offset) else Nothing diff --git a/library/Ptr/IO.hs b/library/Ptr/IO.hs --- a/library/Ptr/IO.hs +++ b/library/Ptr/IO.hs @@ -8,7 +8,7 @@ import qualified Ptr.UncheckedShifting as D {-# INLINE peekStorable #-} -peekStorable :: Storable storable => Ptr Word8 -> IO storable +peekStorable :: (Storable storable) => Ptr Word8 -> IO storable peekStorable = peek . castPtr @@ -155,11 +155,11 @@ #endif -- | --- Allocate a new byte array with @memcpy@. +-- Allocate a new byte array with @copyBytes@. {-# INLINE peekBytes #-} peekBytes :: Ptr Word8 -> Int -> IO ByteString peekBytes ptr amount = - A.create amount $ \destPtr -> A.memcpy destPtr ptr amount + A.create amount $ \destPtr -> copyBytes destPtr ptr amount {-# INLINE peekShortByteString #-} peekShortByteString :: Ptr Word8 -> Int -> IO ShortByteString @@ -174,12 +174,12 @@ cont length (B.createFromPtr ptr length) {-# INLINE pokeStorable #-} -pokeStorable :: Storable a => Ptr Word8 -> a -> IO () +pokeStorable :: (Storable a) => Ptr Word8 -> a -> IO () pokeStorable = poke . castPtr {-# INLINE pokeStorableByteOff #-} -pokeStorableByteOff :: Storable a => Ptr Word8 -> Int -> a -> IO () +pokeStorableByteOff :: (Storable a) => Ptr Word8 -> Int -> a -> IO () pokeStorableByteOff = pokeByteOff . castPtr @@ -369,14 +369,14 @@ {-# INLINE pokeBytesTrimming #-} pokeBytesTrimming :: Ptr Word8 -> Int -> ByteString -> IO () pokeBytesTrimming ptr maxLength (A.PS fptr offset length) = - withForeignPtr fptr $ \bytesPtr -> A.memcpy ptr (plusPtr bytesPtr offset) (min length maxLength) + withForeignPtr fptr $ \bytesPtr -> copyBytes ptr (plusPtr bytesPtr offset) (min length maxLength) {-# INLINE pokeBytes #-} pokeBytes :: Ptr Word8 -> ByteString -> IO () #if MIN_VERSION_bytestring(0,11,0) pokeBytes ptr (A.BS fptr length) = - withForeignPtr fptr $ \bytesPtr -> A.memcpy ptr bytesPtr length + withForeignPtr fptr $ \bytesPtr -> copyBytes ptr bytesPtr length #else pokeBytes ptr (A.PS fptr offset length) = - withForeignPtr fptr $ \bytesPtr -> A.memcpy ptr (plusPtr bytesPtr offset) length + withForeignPtr fptr $ \bytesPtr -> copyBytes ptr (plusPtr bytesPtr offset) length #endif diff --git a/library/Ptr/List.hs b/library/Ptr/List.hs --- a/library/Ptr/List.hs +++ b/library/Ptr/List.hs @@ -4,7 +4,7 @@ {-# INLINE reverseDigits #-} reverseDigits :: - Integral a => + (Integral a) => -- | Radix a -> -- | Number diff --git a/library/Ptr/Parse.hs b/library/Ptr/Parse.hs --- a/library/Ptr/Parse.hs +++ b/library/Ptr/Parse.hs @@ -1,7 +1,6 @@ module Ptr.Parse where import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Short.Internal as E import qualified Ptr.IO as D import qualified Ptr.PokeAndPeek as A import Ptr.Prelude hiding (peek, take) @@ -224,7 +223,7 @@ -- | -- Unsigned integral number encoded in ASCII. {-# INLINE unsignedASCIIIntegral #-} -unsignedASCIIIntegral :: Integral a => Parse a +unsignedASCIIIntegral :: (Integral a) => Parse a unsignedASCIIIntegral = {-# SCC "unsignedASCIIIntegral" #-} foldWhile byteIsDigit step 0 diff --git a/library/Ptr/ParseUnbound.hs b/library/Ptr/ParseUnbound.hs --- a/library/Ptr/ParseUnbound.hs +++ b/library/Ptr/ParseUnbound.hs @@ -1,7 +1,6 @@ module Ptr.ParseUnbound where import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Short.Internal as E import qualified Ptr.IO as D import qualified Ptr.PokeAndPeek as A import Ptr.Prelude hiding (peek, take) @@ -147,7 +146,7 @@ -- | -- Unsigned integral number encoded in ASCII. {-# INLINE unsignedASCIIIntegral #-} -unsignedASCIIIntegral :: Integral a => ParseUnbound a +unsignedASCIIIntegral :: (Integral a) => ParseUnbound a unsignedASCIIIntegral = {-# SCC "unsignedASCIIIntegral" #-} foldWhile byteIsDigit step 0 diff --git a/library/Ptr/Poking.hs b/library/Ptr/Poking.hs --- a/library/Ptr/Poking.hs +++ b/library/Ptr/Poking.hs @@ -2,7 +2,6 @@ import qualified Data.ByteString.Internal as B import qualified Data.List as List -import qualified Data.Vector as F import qualified Data.Vector.Generic as GenericVector import qualified Ptr.IO as A import qualified Ptr.List as List @@ -95,7 +94,7 @@ {-# INLINE bytes #-} bytes :: ByteString -> Poking bytes (B.PS bytesFPtr offset length) = - Poking length (\ptr -> withForeignPtr bytesFPtr (\bytesPtr -> B.memcpy ptr (plusPtr bytesPtr offset) length)) + Poking length (\ptr -> withForeignPtr bytesFPtr (\bytesPtr -> copyBytes ptr (plusPtr bytesPtr offset) length)) {-# INLINE poke #-} poke :: C.Poke input -> input -> Poking @@ -124,7 +123,7 @@ word8 . fromIntegral . ord {-# INLINEABLE asciiPaddedAndTrimmedIntegral #-} -asciiPaddedAndTrimmedIntegral :: Integral a => Int -> a -> Poking +asciiPaddedAndTrimmedIntegral :: (Integral a) => Int -> a -> Poking asciiPaddedAndTrimmedIntegral !length !integral = if length > 0 then @@ -142,7 +141,8 @@ -} asciiUtcTimeInIso8601 :: UTCTime -> Poking asciiUtcTimeInIso8601 utcTime = - asciiPaddedAndTrimmedIntegral 4 year <> word8 45 + asciiPaddedAndTrimmedIntegral 4 year + <> word8 45 <> asciiPaddedAndTrimmedIntegral 2 month <> word8 45 <> asciiPaddedAndTrimmedIntegral 2 day @@ -168,7 +168,7 @@ _ -> state <> word8 0 {-# INLINEABLE vector #-} -vector :: GenericVector.Vector vector element => (element -> Poking) -> vector element -> Poking +vector :: (GenericVector.Vector vector element) => (element -> Poking) -> vector element -> Poking vector element vectorValue = Poking byteSize io where @@ -188,7 +188,7 @@ return (plusPtr ptr elementByteSize) {-# INLINEABLE intercalateVector #-} -intercalateVector :: GenericVector.Vector vector element => (element -> Poking) -> Poking -> vector element -> Poking +intercalateVector :: (GenericVector.Vector vector element) => (element -> Poking) -> Poking -> vector element -> Poking intercalateVector element (Poking separatorLength separatorIo) vectorValue = Poking length io where length = GenericVector.foldl' step 0 vectorValue + ((GenericVector.length vectorValue - 1) * separatorLength) diff --git a/library/Ptr/Prelude.hs b/library/Ptr/Prelude.hs --- a/library/Ptr/Prelude.hs +++ b/library/Ptr/Prelude.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + module Ptr.Prelude ( module Exports, ) @@ -27,14 +30,19 @@ import Data.Fixed as Exports import Data.Foldable as Exports hiding (toList) import Data.Function as Exports hiding (id, (.)) -import Data.Functor as Exports +import Data.Functor as Exports hiding (unzip) import Data.Functor.Compose as Exports import Data.Functor.Contravariant as Exports import Data.Functor.Contravariant.Divisible as Exports import Data.IORef as Exports import Data.Int as Exports import Data.Ix as Exports +import Foreign.Marshal.Utils as Exports (copyBytes) +#if MIN_VERSION_base(4,20,0) +import Data.List as Exports hiding (List, all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +#else import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons) +#endif import Data.List.NonEmpty as Exports (NonEmpty (..)) import Data.Maybe as Exports import Data.Monoid as Exports hiding (Alt, (<>)) diff --git a/library/Ptr/Read.hs b/library/Ptr/Read.hs --- a/library/Ptr/Read.hs +++ b/library/Ptr/Read.hs @@ -23,7 +23,6 @@ import Ptr.Prelude hiding (Read) import qualified Ptr.Util.ByteString as ByteString import qualified Ptr.Util.Word8Predicates as Word8Predicates -import qualified StrictList -- | -- Deserializer highly optimized for reading from pointers. @@ -74,8 +73,9 @@ runOnByteString :: Read a -> ByteString -> Either (Read a) (a, ByteString) runOnByteString (Read read) (ByteString.PS bsFp bsOff bsSize) = - unsafePerformIO $ - withForeignPtr bsFp $ \p -> + unsafePerformIO + $ withForeignPtr bsFp + $ \p -> let startP = plusPtr p bsOff endP = plusPtr startP bsSize in read startP endP <&> \case @@ -278,7 +278,7 @@ -- | -- Integral number encoded in ASCII. -asciiIntegral :: Integral a => Read a +asciiIntegral :: (Integral a) => Read a asciiIntegral = foldlWhile' Word8Predicates.asciiDigit step 0 where diff --git a/library/Ptr/Receive/Core.hs b/library/Ptr/Receive/Core.hs --- a/library/Ptr/Receive/Core.hs +++ b/library/Ptr/Receive/Core.hs @@ -1,6 +1,5 @@ module Ptr.Receive.Core where -import qualified Data.ByteString.Internal as A import Ptr.Prelude write :: (Ptr Word8 -> Int -> IO (Either Text Int)) -> ForeignPtr Word8 -> IORef (Int, Int) -> Int -> Int -> Ptr Word8 -> IO (Either Text ()) @@ -16,11 +15,11 @@ in if amountInBuffer >= howMany then -- Buffer contains all we need, so we don't need to fetch at all do - A.memcpy destination (plusPtr bufferPtr offset) howMany + copyBytes destination (plusPtr bufferPtr offset) howMany writeIORef bufferStateRef (offset + howMany, end) return (Right ()) else do - A.memcpy destination (plusPtr bufferPtr offset) amountInBuffer + copyBytes destination (plusPtr bufferPtr offset) amountInBuffer fetchMany fetch bufferFP bufferStateRef chunkSize (howMany - amountInBuffer) (plusPtr destination amountInBuffer) fetchMany :: (Ptr Word8 -> Int -> IO (Either Text Int)) -> ForeignPtr Word8 -> IORef (Int, Int) -> Int -> Int -> Ptr Word8 -> IO (Either Text ()) @@ -39,7 +38,7 @@ withForeignPtr bufferFP $ \bufferPtr -> fetchingSome bufferPtr chunkSize $ \amountFetched -> do - A.memcpy destination bufferPtr remaining + copyBytes destination bufferPtr remaining writeIORef bufferStateRef (remaining, amountFetched) return (Right ()) where @@ -75,7 +74,7 @@ else -- We still have something in the buffer, so we'll read from it first withForeignPtr bufferFP $ \bufferPtr -> do - A.memcpy tmpPtr (plusPtr bufferPtr offset) amountInBuffer + copyBytes tmpPtr (plusPtr bufferPtr offset) amountInBuffer fetchMany fetch bufferFP bufferStateRef chunkSize (howMany - amountInBuffer) (plusPtr tmpPtr amountInBuffer) case writeResult of Right () -> do diff --git a/library/Ptr/UncheckedShifting.hs b/library/Ptr/UncheckedShifting.hs --- a/library/Ptr/UncheckedShifting.hs +++ b/library/Ptr/UncheckedShifting.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} -- | -- Copyright : (c) 2010 Simon Meier diff --git a/library/Ptr/Util/ByteString.hs b/library/Ptr/Util/ByteString.hs --- a/library/Ptr/Util/ByteString.hs +++ b/library/Ptr/Util/ByteString.hs @@ -1,8 +1,8 @@ module Ptr.Util.ByteString where import Data.ByteString -import qualified Data.ByteString as ByteString import Data.ByteString.Internal +import Foreign.Marshal.Utils import Ptr.Prelude hiding (length) import qualified StrictList @@ -18,7 +18,7 @@ \case StrictList.Cons (PS fp off len) tail -> do - withForeignPtr fp $ \src -> memcpy ptr (plusPtr src off) len + withForeignPtr fp $ \src -> copyBytes ptr (plusPtr src off) len loop ptr tail where ptr = plusPtr endPtr (negate len) @@ -33,4 +33,4 @@ fromPtr :: Int -> Ptr Word8 -> ByteString fromPtr size src = - unsafeCreate size (\dst -> memcpy dst src size) + unsafeCreate size (\dst -> copyBytes dst src size) diff --git a/library/Ptr/Util/Word8Predicates.hs b/library/Ptr/Util/Word8Predicates.hs --- a/library/Ptr/Util/Word8Predicates.hs +++ b/library/Ptr/Util/Word8Predicates.hs @@ -2,6 +2,8 @@ import Ptr.Prelude -asciiUpperLetter :: Word8 -> Bool = \x -> x - 65 <= 25 +asciiUpperLetter :: Word8 -> Bool +asciiUpperLetter x = x - 65 <= 25 -asciiDigit :: Word8 -> Bool = \x -> x - 48 <= 9 +asciiDigit :: Word8 -> Bool +asciiDigit x = x - 48 <= 9 diff --git a/ptr.cabal b/ptr.cabal --- a/ptr.cabal +++ b/ptr.cabal @@ -1,27 +1,67 @@ -name: ptr -version: 0.16.8.4 -category: Ptr, Data -synopsis: Experimental abstractions for operations on pointers +cabal-version: 3.0 +name: ptr +version: 0.16.8.5 +category: Ptr, Data +synopsis: Experimental abstractions for operations on pointers description: Collection of experimental abstractions over pointer operations. -homepage: https://github.com/nikita-volkov/ptr -bug-reports: https://github.com/nikita-volkov/ptr/issues -author: Nikita Volkov -maintainer: Nikita Volkov -copyright: (c) 2017, Nikita Volkov -license: MIT -license-file: LICENSE -build-type: Simple -cabal-version: >=1.10 +homepage: https://github.com/nikita-volkov/ptr +bug-reports: https://github.com/nikita-volkov/ptr/issues +author: Nikita Volkov +maintainer: Nikita Volkov +copyright: (c) 2017, Nikita Volkov +license: MIT +license-file: LICENSE + source-repository head - type: git + type: git location: git://github.com/nikita-volkov/ptr.git library - hs-source-dirs: library - default-extensions: Arrows, BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 + hs-source-dirs: library + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + Arrows + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + PatternSynonyms + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + + default-language: Haskell2010 exposed-modules: Ptr.ByteString Ptr.IO @@ -33,6 +73,7 @@ Ptr.Poking Ptr.Read Ptr.Receive + other-modules: Ptr.List Ptr.PokeIO @@ -41,43 +82,123 @@ Ptr.UncheckedShifting Ptr.Util.ByteString Ptr.Util.Word8Predicates + build-depends: - base >=4.11 && <5, - bytestring >=0.10 && <0.12, - contravariant >=1.3 && <2, - profunctors >=5.1 && <6, - strict-list >=0.1.5 && <0.2, - text >=1 && <3, - time >=1 && <2, - vector >=0.12 && <0.14 + , base >=4.11 && <5 + , bytestring >=0.10 && <0.12 + , contravariant >=1.3 && <2 + , profunctors >=5.1 && <6 + , strict-list >=0.1.5 && <0.2 + , text >=1 && <3 + , time >=1 && <2 + , vector >=0.12 && <0.14 test-suite tests - type: exitcode-stdio-1.0 - hs-source-dirs: tests - main-is: Main.hs - ghc-options: -O2 -threaded "-with-rtsopts=-N" - default-extensions: Arrows, BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + ghc-options: -O2 -threaded -with-rtsopts=-N + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + Arrows + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + PatternSynonyms + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + + default-language: Haskell2010 build-depends: - cereal >=0.5.8 && <0.6, - ptr, - QuickCheck >=2.8.1 && <3, - quickcheck-instances >=0.3.11 && <0.4, - rerebase <2, - tasty >=0.12 && <2, - tasty-hunit >=0.9 && <0.11, - tasty-quickcheck >=0.9 && <0.11 + , cereal >=0.5.8 && <0.6 + , ptr + , QuickCheck >=2.8.1 && <3 + , quickcheck-instances >=0.3.11 && <0.4 + , rerebase <2 + , tasty >=0.12 && <2 + , tasty-hunit >=0.9 && <0.11 + , tasty-quickcheck >=0.9 && <0.11 benchmark bench - type: exitcode-stdio-1.0 - hs-source-dirs: bench - main-is: Main.hs - ghc-options: -O2 -threaded "-with-rtsopts=-N" - default-extensions: Arrows, BangPatterns, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples - default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + ghc-options: -O2 -threaded -with-rtsopts=-N + default-extensions: + NoImplicitPrelude + NoMonomorphismRestriction + Arrows + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MagicHash + MultiParamTypeClasses + MultiWayIf + OverloadedStrings + ParallelListComp + PatternGuards + PatternSynonyms + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + UnboxedTuples + + default-language: Haskell2010 build-depends: - cereal >=0.5.8 && <0.6, - gauge >=0.2.5 && <0.3, - ptr, - rerebase >=1.10.0.1 && <2, - tostring >=0.2.1.1 && <0.3 + , cereal >=0.5.8 && <0.6 + , criterion ^>=1.6 + , ptr + , rerebase >=1.10.0.1 && <2 diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -12,16 +12,16 @@ import qualified Ptr.Poking as F import qualified Ptr.Read as H import Test.QuickCheck -import Test.QuickCheck.Instances +import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Test.Tasty.Runners import Prelude hiding (choose) +main :: IO () main = - defaultMain $ - testGroup + defaultMain + $ testGroup "All tests" [ testProperty "ASCII Numbers ByteString Roundtrip" $ \(numbers :: [Word64]) -> let expected = foldMap (fromString . show) numbers @@ -48,91 +48,91 @@ parsing, testGroup "Regression" - [ testCase "https://github.com/nikita-volkov/hasql-dynamic-statements/issues/2" $ - assertEqual "" "$1000" (A.poking (F.word8 36 <> F.asciiIntegral 1000)) + [ testCase "https://github.com/nikita-volkov/hasql-dynamic-statements/issues/2" + $ assertEqual "" "$1000" (A.poking (F.word8 36 <> F.asciiIntegral 1000)) ], - testGroup "Read" $ - let consumeManyByteStrings :: H.Read a -> [ByteString] -> Maybe a - consumeManyByteStrings read = \case - head : tail -> - H.runOnByteString read head & \case - Left newRead -> consumeManyByteStrings newRead tail - Right (res, rem) -> Just res - _ -> - Nothing - againstByteString :: (Eq a, Show a) => H.Read a -> (ByteString -> a) -> [ByteString] -> Property - againstByteString read fromByteString chunks = - consumeManyByteStrings read chunks & \case - Nothing -> - discard - Just res -> - fromByteString (mconcat chunks) === res - againstCereal :: (Eq a, Show a) => H.Read a -> J.Get a -> [ByteString] -> Property - againstCereal read get chunks = - consumeManyByteStrings read chunks & \res -> - J.runGet get (mconcat chunks) === maybe (Left "Not enough input") Right res - in [ testProperty "byteString" $ \a -> - againstByteString (H.byteString (max 0 a)) (D.take a), - testProperty "skip & byteString" $ \a b -> - againstByteString - (H.skip (max 0 a) *> H.byteString (max 0 b)) - (D.take b . D.drop a), - testProperty "skipWhile" $ \a b -> - againstByteString - (H.skipWhile (< a) *> H.byteString (max 0 b)) - (D.dropWhile (< a) >>> D.take b), - testProperty "byteStringWhile" $ \a -> - againstByteString - (H.byteStringWhile (< a)) - (D.takeWhile (< a)), - testProperty "asciiIntegral" $ - forAll (arbitrary @Int >>= splitRandomly . fromString . (<> " ") . show . abs) $ - againstByteString (H.asciiIntegral) (read . I.unpack), - testProperty "int16InBe" $ - forAll (arbitrary @Int16 >>= splitRandomly . J.runPut . J.putInt16be) $ - againstCereal H.int16InBe J.getInt16be, - testProperty "int32InBe" $ - forAll (arbitrary @Int32 >>= splitRandomly . J.runPut . J.putInt32be) $ - againstCereal H.int32InBe J.getInt32be, - testProperty "int64InBe" $ - forAll (arbitrary @Int64 >>= splitRandomly . J.runPut . J.putInt64be) $ - againstCereal H.int64InBe J.getInt64be, - testProperty "nullTerminatedByteString" $ - againstByteString - (H.nullTerminatedByteString) - (D.takeWhile (/= 0)), - testCase "Pure does not hold on empty input" $ - assertEqual "" (Just ()) (consumeManyByteStrings (pure ()) [""]), - testCase "Monadic composition" $ - do - let input = J.runPut (J.putInt32be 1 <> J.putInt32be 2) - consumeManyByteStrings (liftM2 (,) H.int32InBe H.int32InBe) [input] - & assertEqual "" (Just (1, 2)), - testCase "Applicative composition" $ - do - let input = J.runPut (J.putInt32be 1 <> J.putInt32be 2) - consumeManyByteStrings (liftA2 (,) H.int32InBe H.int32InBe) [input] - & assertEqual "" (Just (1, 2)), - testProperty "Composition over chunks" $ - let gen = do - (a, b, c) <- arbitrary - splitRandomly (J.runPut (J.putInt16be a <> J.putInt32be b <> J.putInt32be c)) - in forAll gen $ - againstCereal - ((,,) <$> H.int16InBe <*> H.int32InBe <*> H.int32InBe) - ((,,) <$> J.getInt16be <*> J.getInt32be <*> J.getInt32be) - ] + testGroup "Read" + $ let consumeManyByteStrings :: H.Read a -> [ByteString] -> Maybe a + consumeManyByteStrings read = \case + head : tail -> + H.runOnByteString read head & \case + Left newRead -> consumeManyByteStrings newRead tail + Right (res, rem) -> Just res + _ -> + Nothing + againstByteString :: (Eq a, Show a) => H.Read a -> (ByteString -> a) -> [ByteString] -> Property + againstByteString read fromByteString chunks = + consumeManyByteStrings read chunks & \case + Nothing -> + discard + Just res -> + fromByteString (mconcat chunks) === res + againstCereal :: (Eq a, Show a) => H.Read a -> J.Get a -> [ByteString] -> Property + againstCereal read get chunks = + consumeManyByteStrings read chunks & \res -> + J.runGet get (mconcat chunks) === maybe (Left "Not enough input") Right res + in [ testProperty "byteString" $ \a -> + againstByteString (H.byteString (max 0 a)) (D.take a), + testProperty "skip & byteString" $ \a b -> + againstByteString + (H.skip (max 0 a) *> H.byteString (max 0 b)) + (D.take b . D.drop a), + testProperty "skipWhile" $ \a b -> + againstByteString + (H.skipWhile (< a) *> H.byteString (max 0 b)) + (D.dropWhile (< a) >>> D.take b), + testProperty "byteStringWhile" $ \a -> + againstByteString + (H.byteStringWhile (< a)) + (D.takeWhile (< a)), + testProperty "asciiIntegral" + $ forAll (arbitrary @Int >>= splitRandomly . fromString . (<> " ") . show . abs) + $ againstByteString (H.asciiIntegral) (read . I.unpack), + testProperty "int16InBe" + $ forAll (arbitrary @Int16 >>= splitRandomly . J.runPut . J.putInt16be) + $ againstCereal H.int16InBe J.getInt16be, + testProperty "int32InBe" + $ forAll (arbitrary @Int32 >>= splitRandomly . J.runPut . J.putInt32be) + $ againstCereal H.int32InBe J.getInt32be, + testProperty "int64InBe" + $ forAll (arbitrary @Int64 >>= splitRandomly . J.runPut . J.putInt64be) + $ againstCereal H.int64InBe J.getInt64be, + testProperty "nullTerminatedByteString" + $ againstByteString + (H.nullTerminatedByteString) + (D.takeWhile (/= 0)), + testCase "Pure does not hold on empty input" + $ assertEqual "" (Just ()) (consumeManyByteStrings (pure ()) [""]), + testCase "Monadic composition" + $ do + let input = J.runPut (J.putInt32be 1 <> J.putInt32be 2) + consumeManyByteStrings (liftM2 (,) H.int32InBe H.int32InBe) [input] + & assertEqual "" (Just (1, 2)), + testCase "Applicative composition" + $ do + let input = J.runPut (J.putInt32be 1 <> J.putInt32be 2) + consumeManyByteStrings (liftA2 (,) H.int32InBe H.int32InBe) [input] + & assertEqual "" (Just (1, 2)), + testProperty "Composition over chunks" + $ let gen = do + (a, b, c) <- arbitrary + splitRandomly (J.runPut (J.putInt16be a <> J.putInt32be b <> J.putInt32be c)) + in forAll gen + $ againstCereal + ((,,) <$> H.int16InBe <*> H.int32InBe <*> H.int32InBe) + ((,,) <$> J.getInt16be <*> J.getInt32be <*> J.getInt32be) + ] ] parsing :: TestTree parsing = - testGroup "Parsing" $ - let assertParsesTo expected input parser = - assertEqual "" (Right expected) (A.parse input (fmap Right parser) (Left . Left) (Left . Right)) - in [ testCase "bytesWhile" $ assertParsesTo "123" "123456" $ G.bytesWhile (< 52), - testCase "bytesWhile on full input" $ assertParsesTo "123456" "123456" $ G.bytesWhile (< 59), - testCase "skipWhile on full input" $ assertParsesTo () "123456" $ G.skipWhile (< 59) - ] + testGroup "Parsing" + $ let assertParsesTo expected input parser = + assertEqual "" (Right expected) (A.parse input (fmap Right parser) (Left . Left) (Left . Right)) + in [ testCase "bytesWhile" $ assertParsesTo "123" "123456" $ G.bytesWhile (< 52), + testCase "bytesWhile on full input" $ assertParsesTo "123456" "123456" $ G.bytesWhile (< 59), + testCase "skipWhile on full input" $ assertParsesTo () "123456" $ G.skipWhile (< 59) + ] pokeThenPeek :: B.Poke a -> C.Peek a -> Maybe (a -> a) pokeThenPeek (B.Poke pokeSize pokeIO) (C.Peek peekSize peekIO) =