diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,22 @@ +0.2.0.0 +======= + +Breaking changes: + +- `unpinch` no longer returns `Either String a`. Instead it returns a + `Parser a`. +- `Protocol.serialize*` methods no longer produce a `ByteString.Builder` and + the serialized length. Instead, they produce a custom `Builder` type. + +Other changes: + +- Improve deserialization performance significantly by getting rid of + unnecessary calls to `Data.Typeable.{eqT, cast}`. +- Improve serialization performance by allocating the output buffer in one go + rather than using `ByteString.Builder`. +- Improve serialization and deserialization performance further by changing + the intermediate representation of lists, sets, and maps. + 0.1.0.2 ======= diff --git a/Pinch.hs b/Pinch.hs --- a/Pinch.hs +++ b/Pinch.hs @@ -30,6 +30,8 @@ -- * Pinchable , Pinchable(..) + , Parser + , runParser -- ** Automatically deriving instances @@ -144,13 +146,11 @@ ) where import Control.Monad -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (toStrict) -import Data.Int (Int32) -import Data.Text (Text) - -import qualified Data.ByteString.Builder as BB +import Data.ByteString (ByteString) +import Data.Int (Int32) +import Data.Text (Text) +import Pinch.Internal.Builder (runBuilder) import Pinch.Internal.Generic import Pinch.Internal.Message import Pinch.Internal.Pinchable @@ -159,13 +159,6 @@ import Pinch.Protocol import Pinch.Protocol.Binary -builderToStrict :: BB.Builder -> ByteString -builderToStrict = toStrict . BB.toLazyByteString -{-# INLINE builderToStrict #-} - --- TODO we know the size of the serialized payload. can probably pre-allocate --- the byte string before filling it with the contents of the builder. - ------------------------------------------------------------------------------ -- $encodeDecodeValues @@ -200,7 +193,7 @@ -- [11,0,0,0,2,0,0,0,1,97,0,0,0,1,98] -- encode :: Pinchable a => Protocol -> a -> ByteString -encode p = builderToStrict . snd . serializeValue p . pinch +encode p = runBuilder . serializeValue p . pinch {-# INLINE encode #-} -- | Decode a 'Pinchable' value from the using the given 'Protocol'. @@ -210,7 +203,7 @@ -- Right ["a","b"] -- decode :: Pinchable a => Protocol -> ByteString -> Either String a -decode p = deserializeValue p >=> unpinch +decode p = deserializeValue p >=> runParser . unpinch {-# INLINE decode #-} ------------------------------------------------------------------------------ @@ -289,7 +282,7 @@ -- @ -- encodeMessage :: Protocol -> Message -> ByteString -encodeMessage p = builderToStrict . snd . serializeMessage p +encodeMessage p = runBuilder . serializeMessage p {-# INLINE encodeMessage #-} -- | Decode a 'Message' using the given 'Protocol'. @@ -323,7 +316,7 @@ -- requested type. getMessageBody :: (Pinchable a, Tag a ~ TStruct) => Message -> Either String a -getMessageBody = unpinch . messagePayload +getMessageBody = runParser . unpinch . messagePayload {-# INLINE getMessageBody #-} ------------------------------------------------------------------------------ diff --git a/Pinch/Internal/Bits.hs b/Pinch/Internal/Bits.hs new file mode 100644 --- /dev/null +++ b/Pinch/Internal/Bits.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +-- | +-- Module : Pinch.Internal.Bits +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- Provides unchecked bitwise shift operations. Similar versions of @shiftR@ +-- are used by @ByteString.Builder.Prim@. +module Pinch.Internal.Bits + ( w16ShiftL + , w32ShiftL + , w64ShiftL + ) where + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base (Int (..), uncheckedShiftL#) +import GHC.Word (Word16 (..), Word32 (..), Word64 (..)) +#else +import Data.Bits (shiftL) +import Data.Word (Word16, Word32, Word64) +#endif + +{-# INLINE w16ShiftL #-} +w16ShiftL :: Word16 -> Int -> Word16 + +{-# INLINE w32ShiftL #-} +w32ShiftL :: Word32 -> Int -> Word32 + +{-# INLINE w64ShiftL #-} +w64ShiftL :: Word64 -> Int -> Word64 + +-- If we're not on GHC, the regular shiftL will be returned. + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +w16ShiftL (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) +w32ShiftL (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) +w64ShiftL (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) +#else +w16ShiftL = shiftL +w32ShiftL = shiftL +w64ShiftL = shiftL +#endif diff --git a/Pinch/Internal/Builder.hs b/Pinch/Internal/Builder.hs --- a/Pinch/Internal/Builder.hs +++ b/Pinch/Internal/Builder.hs @@ -7,87 +7,121 @@ -- Maintainer : Abhinav Gupta -- Stability : experimental -- --- This module provides a wrapper around @Data.ByteString.Builder@ that keeps --- track of the final size of the generated ByteString. +-- This module implements a ByteString builder very similar to +-- 'Data.ByteString.Builder' except that it keeps track of its final serialized +-- length. This allows it to allocate the target ByteString in one @malloc@ and +-- simply write the bytes to it. module Pinch.Internal.Builder ( Builder - , Build - , run + , runBuilder + , append , int8 - , int16 - , int32 - , int64 - , double + , int16BE + , int32BE + , int64BE + , doubleBE , byteString ) where #if __GLASGOW_HASKELL__ < 709 -import Control.Applicative +import Data.Monoid #endif -import Data.ByteString (ByteString) +import Data.ByteString (ByteString) +import Data.ByteString.Builder.Prim ((>*<)) import Data.Int -import Data.Monoid -import Prelude hiding (length) +import Data.Word (Word8) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr, plusPtr) -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Builder.Prim as BP +import qualified Data.ByteString.Builder.Prim.Internal as BPI +import qualified Data.ByteString.Internal as BI --- | Alias for a build that produces no results. -type Build = Builder () +-- | A ByteString Builder that knows its final size. +data Builder = B {-# UNPACK #-} !Int (Ptr Word8 -> IO ()) --- We're using big endian byte order for now. We can add little endian later --- if needed. +-- | Build a ByteString from the given ByteString builder. +runBuilder :: Builder -> ByteString +runBuilder (B size fill) = BI.unsafeCreate size fill +{-# INLINE runBuilder #-} --- | Used for building a long chain of ByteStrings. -data Builder a = B !a {-# UNPACK #-} !Int64 !BB.Builder - -- TODO CPS? +-- | Append two Builders into one. +append :: Builder -> Builder -> Builder +append (B ll lf) (B rl rf) = B (ll + rl) (\p -> lf p >> rf (p `plusPtr` ll)) +{-# INLINE [1] append #-} + -- Don't inline append until phase 1. This ensures that the + -- append/primFixed* rules have a chance to fire. -instance Functor Builder where - fmap f (B a l b) = B (f a) l b +instance Monoid Builder where + {-# INLINE mempty #-} + mempty = B 0 (\_ -> return ()) -instance Applicative Builder where - pure a = B a 0 mempty - B f l0 b0 <*> B a l1 b1 = B (f a) (l0 + l1) (b0 <> b1) + {-# INLINE mappend #-} + mappend = append -instance Monad Builder where - (>>) = (*>) - return = pure - B a l0 b0 >>= k = - let B b l1 b1 = k a - in B b (l0 + l1) (b0 <> b1) + {-# INLINE mconcat #-} + mconcat = foldr mappend mempty --- | Returns the ByteString Builder for this build and its length. -run :: Build -> (Int64, BB.Builder) -run (B () l b) = (l, b) +primFixed :: BP.FixedPrim a -> a -> Builder +primFixed prim a = B (BPI.size prim) (BPI.runF prim a) +{-# INLINE [1] primFixed #-} + -- Don't inline append until phase 1. This ensures that the + -- append/primFixed* rules have a chance to fire. +-- The following rules try to join together instances of primFixed that are +-- being appended together. These were adapted almost as-is from +-- ByteString.Builder.Prim's rules around this. --- | Writes a byte. -int8 :: Int8 -> Build -int8 = B () 1 . BB.int8 +{-# RULES +"append/primFixed" forall p1 p2 v1 v2. + append (primFixed p1 v1) (primFixed p2 v2) = + primFixed (p1 >*< p2) (v1, v2) --- | Writes a 16-bit integer. -int16 :: Int16 -> Build -int16 = B () 2 . BB.int16BE +"append/primFixed/rightAssociative" forall p1 p2 v1 v2 b. + append (primFixed p1 v1) (append (primFixed p2 v2) b) = + append (primFixed (p1 >*< p2) (v1, v2)) b +"append/primFixed/leftAssociative" forall p1 p2 v1 v2 b. + append (append b (primFixed p1 v1)) (primFixed p2 v2) = + append b (primFixed (p1 >*< p2) (v1, v2)) --- | Writes a 32-bit integer. -int32 :: Int32 -> Build -int32 = B () 4 . BB.int32BE + #-} +-- | Serialize a single signed byte. +int8 :: Int8 -> Builder +int8 = primFixed BP.int8 +{-# INLINE int8 #-} --- | Writes a 64-bit integer. -int64 :: Int64 -> Build -int64 = B () 8 . BB.int64BE +-- | Serialize a signed 16-bit integer in big endian format. +int16BE :: Int16 -> Builder +int16BE = primFixed BP.int16BE +{-# INLINE int16BE #-} +-- | Serialize a signed 32-bit integer in big endian format. +int32BE :: Int32 -> Builder +int32BE = primFixed BP.int32BE +{-# INLINE int32BE #-} --- | Writes a 64-bit double. -double :: Double -> Build -double = B () 8 . BB.doubleBE +-- | Serialize a signed 64-bit integer in big endian format. +int64BE :: Int64 -> Builder +int64BE = primFixed BP.int64BE +{-# INLINE int64BE #-} +-- | Serialize a signed 64-bit floating point number in big endian format. +doubleBE :: Double -> Builder +doubleBE = primFixed BP.doubleBE +{-# INLINE doubleBE #-} --- | Writes an arbitrary ByteString. -byteString :: ByteString -> Build -byteString bs = B () (fromIntegral $ B.length bs) (BB.byteString bs) +-- | Inlcude the given ByteString as-is in the builder. +-- +-- Note that because this operation is applied lazily, we will maintain a +-- reference to the ByteString until the builder is executed. +byteString :: ByteString -> Builder +byteString (BI.PS fp off len) = + B len $ \dst -> + withForeignPtr fp $ \src -> + BI.memcpy dst (src `plusPtr` off) len +{-# INLINE byteString #-} diff --git a/Pinch/Internal/FoldList.hs b/Pinch/Internal/FoldList.hs new file mode 100644 --- /dev/null +++ b/Pinch/Internal/FoldList.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Pinch.Internal.FoldList +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- Implements a representation of a list as a fold over it. +module Pinch.Internal.FoldList + ( FoldList + , map + , replicate + , replicateM + , F.foldl' + , F.foldr + , F.toList + , fromFoldable + , fromMap + , T.mapM + , T.sequence + ) where + +import Prelude hiding (foldr, map, mapM, replicate, sequence) + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + +import Control.DeepSeq (NFData (..)) +import Data.Hashable (Hashable (..)) +import Data.List (intercalate) +import Data.Monoid +import Data.Typeable (Typeable) + +import qualified Control.Monad as M +import qualified Data.Foldable as F +import qualified Data.List as L +import qualified Data.Traversable as T + +-- | FoldList represents a list as a @foldl'@ traversal over it. +-- +-- This allows us to avoid allocating new collections for an intermediate +-- representation of various data types that users provide. +newtype FoldList a = FoldList (forall r. (r -> a -> r) -> r -> r) + deriving Typeable + +-- | Builds a FoldList over pairs of items of a map. +fromMap + :: (forall r. (r -> k -> v -> r) -> r -> m k v -> r) + -- ^ @foldlWithKey@ provided by the map implementation. + -> m k v + -> FoldList (k, v) +fromMap foldlWithKey m = FoldList (\k r -> foldlWithKey (go k) r m) + where + go k r a b = k r (a, b) + {-# INLINE go #-} +{-# INLINE fromMap #-} + +-- | Builds a FoldList from a Foldable. +fromFoldable :: F.Foldable f => f a -> FoldList a +fromFoldable l = FoldList (\k r -> F.foldl' k r l) +{-# INLINE fromFoldable #-} + +-- | Applies the given function to all elements in the FoldList. +-- +-- Note that the function is applied lazily when the results are requested. If +-- the results of the same FoldList are requested multiple times, the function +-- will be called multiple times on the same elements. +map :: (a -> b) -> FoldList a -> FoldList b +map f (FoldList l) = FoldList $ \k r0 -> l (\r1 a -> k r1 (f a)) r0 +{-# INLINE map #-} + +-- | Returns a FoldList with the given item repeated @n@ times. +replicate :: Int -> a -> FoldList a +replicate n a = fromFoldable (L.replicate n a) +{-# INLINE replicate #-} + +-- | Executes the given monadic action the given number of times and returns +-- a FoldList of the results. +replicateM :: Monad m => Int -> m a -> m (FoldList a) +replicateM n = M.liftM fromFoldable . M.replicateM n +{-# INLINE replicateM #-} + +instance Show a => Show (FoldList a) where + show l = "[" ++ intercalate ", " (F.foldr go [] l) ++ "]" + where + go a xs = show a:xs + +instance Functor FoldList where + fmap = map + {-# INLINE fmap #-} + +instance F.Foldable FoldList where + foldMap f (FoldList l) = l (\r a -> r <> f a) mempty + {-# INLINE foldMap #-} + + foldl' f r (FoldList l) = l f r + {-# INLINE foldl' #-} + +instance T.Traversable FoldList where + sequenceA (FoldList f) = + f (\l a -> go <$> l <*> a) (pure (FoldList (\_ r -> r))) + where + go (FoldList xs) x = FoldList (\k r -> k (xs k r) x) + {-# INLINE go #-} + {-# INLINE sequenceA #-} + +instance Eq a => Eq (FoldList a) where + l == r = F.toList l == F.toList r + +instance NFData a => NFData (FoldList a) where + rnf (FoldList l) = l (\() a -> rnf a `seq` ()) () + +instance Hashable a => Hashable (FoldList a) where + hashWithSalt s (FoldList l) = l hashWithSalt s diff --git a/Pinch/Internal/Generic.hs b/Pinch/Internal/Generic.hs --- a/Pinch/Internal/Generic.hs +++ b/Pinch/Internal/Generic.hs @@ -83,9 +83,10 @@ instance (Datatype d, GPinchable a) => GPinchable (D1 d a) where type GTag (D1 d a) = GTag a gPinch = gPinch . unM1 - gUnpinch v = case gUnpinch v of - Left msg -> Left $ "Failed to read '" ++ name ++ "': " ++ msg - Right a -> Right $ M1 a + gUnpinch v = + parserCatch (gUnpinch v) + (\msg -> fail $ "Failed to read '" ++ name ++ "': " ++ msg) + (return . M1) where name = datatypeName (undefined :: D1 d a b) @@ -197,10 +198,10 @@ gPinch (K1 Enumeration) = VInt32 . fromIntegral $ natVal (Proxy :: Proxy n) gUnpinch (VInt32 i) | i == val = return (K1 Enumeration) - | otherwise = Left $ "Couldn't match enum value " ++ show i + | otherwise = fail $ "Couldn't match enum value " ++ show i where val = fromIntegral $ natVal (Proxy :: Proxy n) - gUnpinch x = Left $ "Failed to read enum. Got " ++ show x + gUnpinch x = fail $ "Failed to read enum. Got " ++ show x ------------------------------------------------------------------------------ @@ -234,6 +235,6 @@ gPinch (K1 Void) = struct [] -- If the map isn't empty, there's probably an exception in there. - gUnpinch (VStruct m) | HM.null m = Right $ K1 Void - gUnpinch x = Left $ + gUnpinch (VStruct m) | HM.null m = return $ K1 Void + gUnpinch x = fail $ "Failed to read response. Expected void, got: " ++ show x diff --git a/Pinch/Internal/Parser.hs b/Pinch/Internal/Parser.hs --- a/Pinch/Internal/Parser.hs +++ b/Pinch/Internal/Parser.hs @@ -28,7 +28,7 @@ import Control.Monad import Control.Monad.ST (ST) -import Data.Bits (shiftL, (.|.)) +import Data.Bits ((.|.)) import Data.ByteString (ByteString) import Data.Int (Int16, Int32, Int64, Int8) import Prelude hiding (take) @@ -39,6 +39,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as BU +import Pinch.Internal.Bits -- | Failure continuation. Called with the failure message. type Failure r = String -> r @@ -57,14 +58,17 @@ instance Functor Parser where + {-# INLINE fmap #-} fmap f (Parser g) = Parser $ \b0 kFail kSucc -> g b0 kFail $ \b1 a -> kSucc b1 (f a) instance Applicative Parser where + {-# INLINE pure #-} pure a = Parser $ \b _ kSucc -> kSucc b a + {-# INLINE (<*>) #-} Parser f' <*> Parser a' = Parser $ \b0 kFail kSucc -> f' b0 kFail $ \b1 f -> a' b1 kFail @@ -72,11 +76,16 @@ instance Monad Parser where + {-# INLINE return #-} return = pure + + {-# INLINE (>>) #-} (>>) = (*>) + {-# INLINE fail #-} fail msg = Parser $ \_ kFail _ -> kFail msg + {-# INLINE (>>=) #-} Parser m >>= k = Parser $ \b0 kFail kSucc -> m b0 kFail $ \b1 a -> unParser (k a) b1 kFail kSucc @@ -117,8 +126,8 @@ int16 = mk <$> take 2 where {-# INLINE mk #-} - mk b = - (fromIntegral (b `BU.unsafeIndex` 0) `shiftL` 8) .|. + mk b = fromIntegral $ + (fromIntegral (b `BU.unsafeIndex` 0) `w16ShiftL` 8) .|. fromIntegral (b `BU.unsafeIndex` 1) {-# INLINE int16 #-} @@ -128,10 +137,10 @@ int32 = mk <$> take 4 where {-# INLINE mk #-} - mk b = - (fromIntegral (b `BU.unsafeIndex` 0) `shiftL` 24) .|. - (fromIntegral (b `BU.unsafeIndex` 1) `shiftL` 16) .|. - (fromIntegral (b `BU.unsafeIndex` 2) `shiftL` 8) .|. + mk b = fromIntegral $ + (fromIntegral (b `BU.unsafeIndex` 0) `w32ShiftL` 24) .|. + (fromIntegral (b `BU.unsafeIndex` 1) `w32ShiftL` 16) .|. + (fromIntegral (b `BU.unsafeIndex` 2) `w32ShiftL` 8) .|. fromIntegral (b `BU.unsafeIndex` 3) {-# INLINE int32 #-} @@ -141,23 +150,21 @@ int64 = mk <$> take 8 where {-# INLINE mk #-} - mk b = - (fromIntegral (b `BU.unsafeIndex` 0) `shiftL` 56) .|. - (fromIntegral (b `BU.unsafeIndex` 1) `shiftL` 48) .|. - (fromIntegral (b `BU.unsafeIndex` 2) `shiftL` 40) .|. - (fromIntegral (b `BU.unsafeIndex` 3) `shiftL` 32) .|. - (fromIntegral (b `BU.unsafeIndex` 4) `shiftL` 24) .|. - (fromIntegral (b `BU.unsafeIndex` 5) `shiftL` 16) .|. - (fromIntegral (b `BU.unsafeIndex` 6) `shiftL` 8) .|. + mk b = fromIntegral $ + (fromIntegral (b `BU.unsafeIndex` 0) `w64ShiftL` 56) .|. + (fromIntegral (b `BU.unsafeIndex` 1) `w64ShiftL` 48) .|. + (fromIntegral (b `BU.unsafeIndex` 2) `w64ShiftL` 40) .|. + (fromIntegral (b `BU.unsafeIndex` 3) `w64ShiftL` 32) .|. + (fromIntegral (b `BU.unsafeIndex` 4) `w64ShiftL` 24) .|. + (fromIntegral (b `BU.unsafeIndex` 5) `w64ShiftL` 16) .|. + (fromIntegral (b `BU.unsafeIndex` 6) `w64ShiftL` 8) .|. fromIntegral (b `BU.unsafeIndex` 7) {-# INLINE int64 #-} -- | Produces a 64-bit floating point number and advances the parser. double :: Parser Double -double = do - i <- int64 - return (ST.runST (cast i)) +double = int64 >>= \i -> return (ST.runST (cast i)) {-# INLINE double #-} diff --git a/Pinch/Internal/Pinchable.hs b/Pinch/Internal/Pinchable.hs --- a/Pinch/Internal/Pinchable.hs +++ b/Pinch/Internal/Pinchable.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -34,32 +36,42 @@ , GPinchable(..) , genericPinch , genericUnpinch + + , Parser + , runParser + , parserCatch ) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif -import Data.ByteString (ByteString) -import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Text (Text) -import Data.Typeable ((:~:) (..), eqT) -import Data.Vector (Vector) -import GHC.Generics (Generic, Rep) +import Data.ByteString (ByteString) +import Data.Hashable (Hashable) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.List (foldl') +import Data.Text (Text) +import Data.Typeable ((:~:) (..)) +import Data.Vector (Vector) +import GHC.Generics (Generic, Rep) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Map.Strict as M -import qualified Data.Set as S -import qualified Data.Text.Encoding as TE -import qualified Data.Vector as V -import qualified GHC.Generics as G +import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TLE +import qualified Data.Vector as V +import qualified GHC.Generics as G +import Pinch.Internal.Pinchable.Parser import Pinch.Internal.TType import Pinch.Internal.Value +import qualified Pinch.Internal.FoldList as FL + -- | Implementation of 'pinch' based on 'GPinchable'. genericPinch :: (Generic a, GPinchable (Rep a)) => a -> Value (GTag (Rep a)) @@ -67,8 +79,7 @@ -- | Implementation of 'unpinch' based on 'GPinchable'. genericUnpinch - :: (Generic a, GPinchable (Rep a)) - => Value (GTag (Rep a)) -> Either String a + :: (Generic a, GPinchable (Rep a)) => Value (GTag (Rep a)) -> Parser a genericUnpinch = fmap G.to . gUnpinch @@ -83,7 +94,7 @@ -- | Converts a 'Value' back into the generic representation of the -- object. - gUnpinch :: Value (GTag f) -> Either String (f a) + gUnpinch :: Value (GTag f) -> Parser (f a) -- | The Pinchable type class is implemented by types that can be sent or @@ -108,7 +119,7 @@ -- | Read a 'Value' back into an @a@. -- -- For structs, '.:' and '.:?' may be used to retrieve field values. - unpinch :: Value (Tag a) -> Either String a + unpinch :: Value (Tag a) -> Parser a default pinch :: (Generic a, GPinchable (Rep a)) => a -> Value (GTag (Rep a)) @@ -116,7 +127,7 @@ default unpinch :: (Generic a, GPinchable (Rep a)) - => Value (GTag (Rep a)) -> Either String a + => Value (GTag (Rep a)) -> Parser a unpinch = genericUnpinch @@ -140,10 +151,10 @@ -- -- > struct [1 .= ("Hello" :: Text), 2 .= (42 :: Int16)] struct :: [FieldPair] -> Value TStruct -struct = VStruct . foldr go HM.empty +struct = VStruct . foldl' go HM.empty where - go (_, Nothing) m = m - go (k, Just v) m = HM.insert k v m + go m (_, Nothing) = m + go m (k, Just v) = HM.insert k v m -- | Constructs a 'Value' tagged with 'TUnion'. -- @@ -155,44 +166,43 @@ -- | Given a field ID and a @Value TStruct@, get the value stored in the -- struct under that field ID. The lookup fails if the field is absent or if -- it's not the same type as expected by this call's context. -(.:) :: forall a. Pinchable a => Value TStruct -> Int16 -> Either String a +(.:) :: forall a. Pinchable a => Value TStruct -> Int16 -> Parser a (VStruct items) .: fieldId = do - someValue <- note ("Field " ++ show fieldId ++ " is absent.") + SomeValue someValue <- note ("Field " ++ show fieldId ++ " is absent.") $ fieldId `HM.lookup` items (value :: Value (Tag a)) <- note ("Field " ++ show fieldId ++ " has the incorrect type. " ++ "Expected '" ++ show (ttype :: TType (Tag a)) ++ "' but " ++ - "got '" ++ showSomeValueTType someValue ++ "'") + "got '" ++ show (valueTType someValue) ++ "'") $ castValue someValue unpinch value where - showSomeValueTType (SomeValue v) = show (valueTType v) note msg m = case m of - Nothing -> Left msg - Just v -> Right v + Nothing -> fail msg + Just v -> return v -- | Given a field ID and a @Value TStruct@, get the optional value stored in -- the struct under the given field ID. The value returned is @Nothing@ if it -- was absent or the wrong type. The lookup fails only if the value retrieved -- fails to 'unpinch'. (.:?) :: forall a. Pinchable a - => Value TStruct -> Int16 -> Either String (Maybe a) + => Value TStruct -> Int16 -> Parser (Maybe a) (VStruct items) .:? fieldId = case value of Nothing -> return Nothing Just v -> Just <$> unpinch v where value :: Maybe (Value (Tag a)) - value = fieldId `HM.lookup` items >>= castValue + value = fieldId `HM.lookup` items >>= \(SomeValue v) -> castValue v ------------------------------------------------------------------------------ -- | Helper to 'unpinch' values by matching TTypes. checkedUnpinch :: forall a b. (Pinchable a, IsTType b) - => Value b -> Either String a -checkedUnpinch = case eqT of - Nothing -> const . Left $ + => Value b -> Parser a +checkedUnpinch = case ttypeEqT of + Nothing -> const . fail $ "Type mismatch. Expected " ++ show ttypeA ++ ". Got " ++ show ttypeB Just (Refl :: Tag a :~: b) -> unpinch where @@ -201,87 +211,106 @@ -- | Helper to 'pinch' maps. pinchMap - :: forall k v kval vval m. - ( Pinchable k - , Pinchable v - , kval ~ Value (Tag k) - , vval ~ Value (Tag v) - ) - => ((k -> v -> HashMap kval vval -> HashMap kval vval) - -> HashMap kval vval -> m -> HashMap kval vval) - -- ^ @foldrWithKey@ - -> m -- ^ map that implements @foldrWithKey@ + :: (Pinchable k, Pinchable v) + => (forall r. (r -> k -> v -> r) -> r -> m k v -> r) + -- ^ @foldlWithKey@ + -> m k v -> Value TMap -pinchMap folder = VMap . folder go HM.empty +pinchMap foldlWithKey = VMap . FL.map go . FL.fromMap foldlWithKey where - go k v = HM.insert (pinch k) (pinch v) + go (!k, !v) = MapItem (pinch k) (pinch v) +unpinchMap + :: (Pinchable k, Pinchable v) + => (k -> v -> m -> m) -> m -> Value a -> Parser m +unpinchMap mapInsert mapEmpty (VMap xs) = + FL.foldl' (\m (!k, !v) -> mapInsert k v m) mapEmpty <$> FL.mapM go xs + where + go (MapItem k v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v +unpinchMap _ _ x = fail $ "Failed to read map. Got " ++ show x instance IsTType a => Pinchable (Value a) where type Tag (Value a) = a pinch = id - unpinch = Right + unpinch = return instance Pinchable ByteString where type Tag ByteString = TBinary pinch = VBinary - unpinch (VBinary b) = Right b - unpinch x = Left $ "Failed to read binary. Got " ++ show x + unpinch (VBinary b) = return b + unpinch x = fail $ "Failed to read binary. Got " ++ show x +instance Pinchable BL.ByteString where + type Tag BL.ByteString = TBinary + pinch = VBinary . BL.toStrict + unpinch (VBinary b) = return (BL.fromStrict b) + unpinch x = fail $ "Failed to read binary. Got " ++ show x + instance Pinchable Text where type Tag Text = TBinary pinch = VBinary . TE.encodeUtf8 - unpinch (VBinary b) = Right . TE.decodeUtf8 $ b - unpinch x = Left $ "Failed to read string. Got " ++ show x + unpinch (VBinary b) = return . TE.decodeUtf8 $ b + unpinch x = fail $ "Failed to read string. Got " ++ show x +instance Pinchable TL.Text where + type Tag TL.Text = TBinary + pinch = VBinary . BL.toStrict . TLE.encodeUtf8 + unpinch (VBinary b) = return . TL.fromStrict . TE.decodeUtf8 $ b + unpinch x = fail $ "Failed to read string. Got " ++ show x + instance Pinchable Bool where type Tag Bool = TBool pinch = VBool - unpinch (VBool x) = Right x - unpinch x = Left $ "Failed to read boolean. Got " ++ show x + unpinch (VBool x) = return x + unpinch x = fail $ "Failed to read boolean. Got " ++ show x instance Pinchable Int8 where type Tag Int8 = TByte pinch = VByte - unpinch (VByte x) = Right x - unpinch x = Left $ "Failed to read byte. Got " ++ show x + unpinch (VByte x) = return x + unpinch x = fail $ "Failed to read byte. Got " ++ show x instance Pinchable Double where type Tag Double = TDouble pinch = VDouble - unpinch (VDouble x) = Right x - unpinch x = Left $ "Failed to read double. Got " ++ show x + unpinch (VDouble x) = return x + unpinch x = fail $ "Failed to read double. Got " ++ show x instance Pinchable Int16 where type Tag Int16 = TInt16 pinch = VInt16 - unpinch (VInt16 x) = Right x - unpinch x = Left $ "Failed to read i16. Got " ++ show x + unpinch (VInt16 x) = return x + unpinch x = fail $ "Failed to read i16. Got " ++ show x instance Pinchable Int32 where type Tag Int32 = TInt32 pinch = VInt32 - unpinch (VInt32 x) = Right x - unpinch x = Left $ "Failed to read i32. Got " ++ show x + unpinch (VInt32 x) = return x + unpinch x = fail $ "Failed to read i32. Got " ++ show x instance Pinchable Int64 where type Tag Int64 = TInt64 pinch = VInt64 - unpinch (VInt64 x) = Right x - unpinch x = Left $ "Failed to read i64. Got " ++ show x + unpinch (VInt64 x) = return x + unpinch x = fail $ "Failed to read i64. Got " ++ show x instance Pinchable a => Pinchable (Vector a) where type Tag (Vector a) = TList - pinch = VList . V.map pinch - unpinch (VList xs) = V.mapM checkedUnpinch xs - unpinch x = Left $ "Failed to read list. Got " ++ show x + pinch = VList . FL.map pinch . FL.fromFoldable + + unpinch (VList xs) = + V.fromList . FL.toList <$> FL.mapM checkedUnpinch xs + unpinch x = fail $ "Failed to read list. Got " ++ show x + instance Pinchable a => Pinchable [a] where type Tag [a] = TList - pinch = VList . V.fromList . map pinch - unpinch (VList xs) = mapM checkedUnpinch $ V.toList xs - unpinch x = Left $ "Failed to read list. Got " ++ show x + pinch = VList . FL.map pinch . FL.fromFoldable + + unpinch (VList xs) = FL.toList <$> FL.mapM checkedUnpinch xs + unpinch x = fail $ "Failed to read list. Got " ++ show x + instance ( Eq k , Hashable k @@ -289,32 +318,28 @@ , Pinchable v ) => Pinchable (HM.HashMap k v) where type Tag (HM.HashMap k v) = TMap - pinch = pinchMap HM.foldrWithKey - - unpinch (VMap xs) = - fmap HM.fromList . mapM go $ HM.toList xs - where go (k, v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v - unpinch x = Left $ "Failed to read map. Got " ++ show x + pinch = pinchMap HM.foldlWithKey' + unpinch = unpinchMap HM.insert HM.empty instance (Ord k, Pinchable k, Pinchable v) => Pinchable (M.Map k v) where type Tag (M.Map k v) = TMap - pinch = pinchMap M.foldrWithKey - - unpinch (VMap xs) = - fmap M.fromList . mapM go $ HM.toList xs - where go (k, v) = (,) <$> checkedUnpinch k <*> checkedUnpinch v - unpinch x = Left $ "Failed to read map. Got " ++ show x + pinch = pinchMap M.foldlWithKey' + unpinch = unpinchMap M.insert M.empty instance (Eq a, Hashable a, Pinchable a) => Pinchable (HS.HashSet a) where type Tag (HS.HashSet a) = TSet - pinch = VSet . HS.map pinch + pinch = VSet . FL.map pinch . FL.fromFoldable + unpinch (VSet xs) = - fmap HS.fromList . mapM checkedUnpinch $ HS.toList xs - unpinch x = Left $ "Failed to read set. Got " ++ show x + FL.foldl' (\s !a -> HS.insert a s) HS.empty + <$> FL.mapM checkedUnpinch xs + unpinch x = fail $ "Failed to read set. Got " ++ show x instance (Ord a, Pinchable a) => Pinchable (S.Set a) where type Tag (S.Set a) = TSet - pinch = VSet . S.foldr (HS.insert . pinch) HS.empty + pinch = VSet . FL.map pinch . FL.fromFoldable + unpinch (VSet xs) = - fmap S.fromList . mapM checkedUnpinch $ HS.toList xs - unpinch x = Left $ "Failed to read set. Got " ++ show x + FL.foldl' (\s !a -> S.insert a s) S.empty + <$> FL.mapM checkedUnpinch xs + unpinch x = fail $ "Failed to read set. Got " ++ show x diff --git a/Pinch/Internal/Pinchable/Parser.hs b/Pinch/Internal/Pinchable/Parser.hs new file mode 100644 --- /dev/null +++ b/Pinch/Internal/Pinchable/Parser.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE Rank2Types #-} +-- | +-- Module : Pinch.Internal.Pinchable.Parser +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- Implements a continuation based version of the @Either e@ monad. +-- +module Pinch.Internal.Pinchable.Parser + ( Parser + , runParser + , parserCatch + ) where + +import Control.Applicative +import Control.Monad + +-- | Failure continuation. Called with the failure message. +type Failure r = String -> r +type Success a r = a -> r +-- ^ Success continuation. Called with the result. + +-- | A simple continuation-based parser. +-- +-- This is just @Either e a@ in continuation-passing style. +newtype Parser a = Parser + { unParser :: forall r. + Failure r -- Failure continuation + -> Success a r -- Success continuation + -> r + } -- TODO can probably track position in the struct + +instance Functor Parser where + {-# INLINE fmap #-} + fmap f (Parser g) = Parser $ \kFail kSucc -> g kFail (kSucc . f) + +instance Applicative Parser where + {-# INLINE pure #-} + pure a = Parser $ \_ kSucc -> kSucc a + + {-# INLINE (<*>) #-} + Parser f' <*> Parser a' = + Parser $ \kFail kSuccB -> + f' kFail $ \f -> + a' kFail $ \a -> + kSuccB (f a) + +instance Alternative Parser where + {-# INLINE empty #-} + empty = Parser $ \kFail _ -> kFail "Alternative.empty" + + {-# INLINE (<|>) #-} + Parser l' <|> Parser r' = + Parser $ \kFail kSucc -> + l' (\_ -> r' kFail kSucc) kSucc + +instance Monad Parser where + {-# INLINE fail #-} + fail msg = Parser $ \kFail _ -> kFail msg + + {-# INLINE return #-} + return = pure + + {-# INLINE (>>) #-} + (>>) = (*>) + + {-# INLINE (>>=) #-} + Parser a' >>= k = + Parser $ \kFail kSuccB -> + a' kFail $ \a -> + unParser (k a) kFail kSuccB + +instance MonadPlus Parser where + {-# INLINE mzero #-} + mzero = empty + + {-# INLINE mplus #-} + mplus = (<|>) + +-- | Run a @Parser@ and return the result inside an @Either@. +runParser :: Parser a -> Either String a +runParser p = unParser p Left Right + +-- | Allows handling parse errors. +parserCatch + :: Parser a -> (String -> Parser b) -> (a -> Parser b) -> Parser b +parserCatch = unParser +{-# INLINE parserCatch #-} diff --git a/Pinch/Internal/TType.hs b/Pinch/Internal/TType.hs --- a/Pinch/Internal/TType.hs +++ b/Pinch/Internal/TType.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Pinch.Internal.TType -- Copyright : (c) Abhinav Gupta 2015 @@ -20,6 +22,9 @@ , IsTType(..) , SomeTType(..) + , ttypeEquality + , ttypeEqT + -- * Tags , TBool @@ -40,7 +45,7 @@ ) where import Data.Hashable (Hashable (..)) -import Data.Typeable (Typeable) +import Data.Typeable ((:~:) (..), Typeable) -- | > bool data TBool deriving (Typeable) @@ -153,3 +158,26 @@ deriving Typeable deriving instance Show SomeTType + +-- | Witness the equality of two ttypes. +ttypeEquality :: TType a -> TType b -> Maybe (a :~: b) +ttypeEquality TBool TBool = Just Refl +ttypeEquality TByte TByte = Just Refl +ttypeEquality TDouble TDouble = Just Refl +ttypeEquality TInt16 TInt16 = Just Refl +ttypeEquality TInt32 TInt32 = Just Refl +ttypeEquality TInt64 TInt64 = Just Refl +ttypeEquality TBinary TBinary = Just Refl +ttypeEquality TStruct TStruct = Just Refl +ttypeEquality TMap TMap = Just Refl +ttypeEquality TSet TSet = Just Refl +ttypeEquality TList TList = Just Refl +ttypeEquality _ _ = Nothing +{-# INLINE ttypeEquality #-} + +-- | Witness the equality of two TTypes. +-- +-- Implicit version of @ttypeEquality@. +ttypeEqT :: forall a b. (IsTType a, IsTType b) => Maybe (a :~: b) +ttypeEqT = ttypeEquality ttype ttype +{-# INLINE ttypeEqT #-} diff --git a/Pinch/Internal/Value.hs b/Pinch/Internal/Value.hs --- a/Pinch/Internal/Value.hs +++ b/Pinch/Internal/Value.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} @@ -15,6 +16,7 @@ -- functions to work with the intermediate representation. module Pinch.Internal.Value ( Value(..) + , MapItem(..) , SomeValue(..) , castValue , valueTType @@ -24,18 +26,30 @@ import Data.ByteString (ByteString) import Data.Hashable (Hashable (..)) import Data.HashMap.Strict (HashMap) -import Data.HashSet (HashSet) import Data.Int (Int16, Int32, Int64, Int8) -import Data.Typeable ((:~:) (..), Typeable, cast, eqT) -import Data.Vector (Vector) +import Data.List (intercalate) +import Data.Typeable ((:~:) (..), Typeable) +import qualified Data.Foldable as F import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S -import qualified Data.Vector as V +import Pinch.Internal.FoldList (FoldList) import Pinch.Internal.TType +-- | A single item in a map +data MapItem k v = MapItem !(Value k) !(Value v) + deriving (Eq, Typeable) +instance NFData (MapItem k v) where + rnf (MapItem k v) = rnf k `seq` rnf v `seq` () + +instance Hashable (MapItem k v) where + hashWithSalt s (MapItem k v) = s `hashWithSalt` k `hashWithSalt` v + +instance Show (MapItem k v) where + show (MapItem k v) = show k ++ ": " ++ show v + -- | @Value@ maps directly to serialized representation of Thrift types. It -- contains about as much information as what gets sent over the wire. -- @Value@ objects are tagged with different 'TType' values to indicate the @@ -55,13 +69,29 @@ VStruct :: !(HashMap Int16 SomeValue) -> Value TStruct VMap :: forall k v. (IsTType k, IsTType v) - => !(HashMap (Value k) (Value v)) -> Value TMap - VSet :: forall a. IsTType a => !(HashSet (Value a)) -> Value TSet - VList :: forall a. IsTType a => !(Vector (Value a)) -> Value TList + => !(FoldList (MapItem k v)) -> Value TMap + VSet :: forall a. IsTType a => !(FoldList (Value a)) -> Value TSet + VList :: forall a. IsTType a => !(FoldList (Value a)) -> Value TList deriving Typeable -deriving instance Show (Value a) +instance Show (Value a) where + show (VBool x) = show x + show (VByte x) = show x + show (VDouble x) = show x + show (VInt16 x) = "i16(" ++ show x ++ ")" + show (VInt32 x) = "i32(" ++ show x ++ ")" + show (VInt64 x) = "i64(" ++ show x ++ ")" + show (VBinary x) = show x + show (VStruct x) = "{" ++ s ++ "}" + where + s = intercalate ", " (M.foldlWithKey' go [] x) + go xs i (SomeValue val) = (show i ++ ": " ++ show val):xs + + show (VMap x) = show x + show (VSet x) = show x + show (VList x) = show x + instance Eq (Value a) where VBool a == VBool b = a == b VByte a == VByte b = a == b @@ -72,12 +102,16 @@ VBinary a == VBinary b = a == b VStruct a == VStruct b = a == b - VMap as == VMap bs = areEqual as bs - VSet as == VSet bs = areEqual as bs - VList as == VList bs = areEqual as bs - + VList as == VList bs = areEqual1 as bs + VMap as == VMap bs = areEqual2 (toMap as) (toMap bs) + where + toMap = F.foldl' (\m (MapItem k v) -> M.insert k v m) M.empty + VSet as == VSet bs = areEqual1 (toSet as) (toSet bs) _ == _ = False +toSet :: forall f x. (F.Foldable f, Hashable x, Eq x) => f x -> S.HashSet x +toSet = F.foldl' (flip S.insert) S.empty + instance NFData (Value a) where rnf (VBool a) = rnf a rnf (VByte a) = rnf a @@ -107,24 +141,45 @@ instance NFData SomeValue where rnf (SomeValue a) = rnf a --- | Safely attempt to cast 'SomeValue' into a 'Value'. -castValue :: Typeable a => SomeValue -> Maybe (Value a) -castValue (SomeValue v) = cast v - +-- | Safely attempt to cast a Value into another. +castValue :: forall a b. (IsTType a, IsTType b) => Value a -> Maybe (Value b) +castValue v = case ttypeEqT of + Just (Refl :: a :~: b) -> Just v + Nothing -> Nothing +{-# INLINE castValue #-} -- | Get the 'TType' of a 'Value'. valueTType :: IsTType a => Value a -> TType a valueTType _ = ttype +{-# INLINE valueTType #-} --- | Helper to compare two types that are not known to be equal at compile --- time. areEqual - :: forall a b. (Typeable a, Typeable b, Eq a) => a -> b -> Bool -areEqual x y = case eqT of + :: forall a b. (IsTType a, IsTType b) => Value a -> Value b -> Bool +areEqual l r = case ttypeEqT of + Just (Refl :: a :~: b) -> l == r Nothing -> False - Just (Refl :: a :~: b) -> x == y +{-# INLINE areEqual #-} +areEqual1 + :: forall a b f. (IsTType a, IsTType b, Eq (f (Value a))) + => f (Value a) -> f (Value b) -> Bool +areEqual1 l r = case ttypeEqT of + Just (Refl :: a :~: b) -> l == r + Nothing -> False +{-# INLINE areEqual1 #-} +areEqual2 + :: forall f k1 v1 k2 v2. + ( IsTType k1, IsTType v1, IsTType k2, IsTType v2 + , Eq (f (Value k1) (Value v1)) + ) => f (Value k1) (Value v1) -> f (Value k2) (Value v2) -> Bool +areEqual2 l r = case ttypeEqT of + Just (Refl :: k1 :~: k2) -> case ttypeEqT of + Just (Refl :: v1 :~: v2) -> l == r + Nothing -> False + Nothing -> False +{-# INLINE areEqual2 #-} + instance Hashable (Value a) where hashWithSalt s a = case a of VBinary x -> s `hashWithSalt` (0 :: Int) `hashWithSalt` x @@ -134,21 +189,14 @@ VInt16 x -> s `hashWithSalt` (4 :: Int) `hashWithSalt` x VInt32 x -> s `hashWithSalt` (5 :: Int) `hashWithSalt` x VInt64 x -> s `hashWithSalt` (6 :: Int) `hashWithSalt` x - - VList xs -> - V.foldr' (flip hashWithSalt) (s `hashWithSalt` (7 :: Int)) xs - VMap xs -> - M.foldrWithKey - (\k v s' -> s' `hashWithSalt` k `hashWithSalt` v) - (s `hashWithSalt` (8 :: Int)) - xs - VSet xs -> - S.foldr (flip hashWithSalt) (s `hashWithSalt` (9 :: Int)) xs + VList x -> s `hashWithSalt` (7 :: Int) `hashWithSalt` x + VMap x -> s `hashWithSalt` (8 :: Int) `hashWithSalt` x + VSet x -> s `hashWithSalt` (9 :: Int) `hashWithSalt` x VStruct fields -> - M.foldrWithKey (\k v s' -> s' `hashWithSalt` k `hashWithSalt` v) - (s `hashWithSalt` (10 :: Int)) - fields + M.foldlWithKey' (\s' k v -> s' `hashWithSalt` k `hashWithSalt` v) + (s `hashWithSalt` (10 :: Int)) + fields instance Hashable SomeValue where diff --git a/Pinch/Protocol.hs b/Pinch/Protocol.hs --- a/Pinch/Protocol.hs +++ b/Pinch/Protocol.hs @@ -15,21 +15,20 @@ ( Protocol(..) ) where -import Data.ByteString (ByteString) -import Data.ByteString.Builder (Builder) -import Data.Int (Int64) +import Data.ByteString (ByteString) +import Pinch.Internal.Builder (Builder) import Pinch.Internal.Message (Message) import Pinch.Internal.TType (IsTType) import Pinch.Internal.Value (Value) -- | Protocols define a specific way to convert values into binary and back. data Protocol = Protocol - { serializeValue :: forall a. IsTType a => Value a -> (Int64, Builder) + { serializeValue :: forall a. IsTType a => Value a -> Builder -- ^ Serializes a 'Value' into a ByteString builder. -- -- Returns a @Builder@ and the total length of the serialized content. - , serializeMessage :: Message -> (Int64, Builder) + , serializeMessage :: Message -> Builder -- ^ Serializes a 'Message' and its payload into a ByteString builder. -- -- Returns a @Builder@ and the total length of the serialized content. diff --git a/Pinch/Protocol/Binary.hs b/Pinch/Protocol/Binary.hs --- a/Pinch/Protocol/Binary.hs +++ b/Pinch/Protocol/Binary.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,46 +22,42 @@ import Data.Bits (shiftR, (.&.)) import Data.ByteString (ByteString) import Data.HashMap.Strict (HashMap) -import Data.HashSet (HashSet) -import Data.Int (Int16, Int8) -import Data.Vector (Vector) +import Data.Int (Int16, Int32, Int8) +import Data.Monoid import qualified Data.ByteString as B import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S import qualified Data.Text.Encoding as TE -import qualified Data.Vector as V -import Pinch.Internal.Builder (Build) +import Pinch.Internal.Builder (Builder) import Pinch.Internal.Message import Pinch.Internal.Parser (Parser, runParser) import Pinch.Internal.TType import Pinch.Internal.Value import Pinch.Protocol (Protocol (..)) -import qualified Pinch.Internal.Builder as BB -import qualified Pinch.Internal.Parser as P +import qualified Pinch.Internal.Builder as BB +import qualified Pinch.Internal.FoldList as FL +import qualified Pinch.Internal.Parser as P -- | Provides an implementation of the Thrift Binary Protocol. binaryProtocol :: Protocol binaryProtocol = Protocol - { serializeValue = BB.run . binarySerialize + { serializeValue = binarySerialize , deserializeValue = binaryDeserialize ttype - , serializeMessage = BB.run . binarySerializeMessage + , serializeMessage = binarySerializeMessage , deserializeMessage = binaryDeserializeMessage } ------------------------------------------------------------------------------ -binarySerializeMessage :: Message -> Build -binarySerializeMessage msg = do - binarySerialize . VBinary . TE.encodeUtf8 $ messageName msg - BB.int8 $ messageCode (messageType msg) - BB.int32 $ messageId msg +binarySerializeMessage :: Message -> Builder +binarySerializeMessage msg = + string (TE.encodeUtf8 $ messageName msg) <> + BB.int8 (messageCode (messageType msg)) <> BB.int32BE (messageId msg) <> binarySerialize (messagePayload msg) - binaryDeserializeMessage :: ByteString -> Either String Message binaryDeserializeMessage = runParser binaryMessageParser @@ -159,10 +156,10 @@ case (ktype', vtype') of (SomeTType ktype, SomeTType vtype) -> do - pairs <- replicateM (fromIntegral count) $ - (,) <$> binaryParser ktype - <*> binaryParser vtype - return $ VMap (M.fromList pairs) + items <- FL.replicateM (fromIntegral count) $ + MapItem <$> binaryParser ktype + <*> binaryParser vtype + return $ VMap items parseSet :: Parser (Value TSet) @@ -171,9 +168,8 @@ count <- P.int32 case vtype' of - SomeTType vtype -> do - items <- replicateM (fromIntegral count) (binaryParser vtype) - return $ VSet (S.fromList items) + SomeTType vtype -> + VSet <$> FL.replicateM (fromIntegral count) (binaryParser vtype) parseList :: Parser (Value TList) @@ -183,7 +179,7 @@ case vtype' of SomeTType vtype -> - VList <$> V.replicateM (fromIntegral count) (binaryParser vtype) + VList <$> FL.replicateM (fromIntegral count) (binaryParser vtype) parseStruct :: Parser (Value TStruct) @@ -202,60 +198,95 @@ ------------------------------------------------------------------------------ -binarySerialize :: Value a -> Build -binarySerialize v0 = case v0 of - VBinary x -> do - BB.int32 . fromIntegral . B.length $ x - BB.byteString x - VBool x -> BB.int8 $ if x then 1 else 0 - VByte x -> BB.int8 x - VDouble x -> BB.double x - VInt16 x -> BB.int16 x - VInt32 x -> BB.int32 x - VInt64 x -> BB.int64 x - VStruct xs -> serializeStruct xs - VList xs -> serializeList ttype xs - VMap xs -> serializeMap ttype ttype xs - VSet xs -> serializeSet ttype xs +binarySerialize :: forall a. IsTType a => Value a -> Builder +binarySerialize = case (ttype :: TType a) of + TBinary -> serializeBinary + TBool -> serializeBool + TByte -> serializeByte + TDouble -> serializeDouble + TInt16 -> serializeInt16 + TInt32 -> serializeInt32 + TInt64 -> serializeInt64 + TStruct -> serializeStruct + TList -> serializeList + TMap -> serializeMap + TSet -> serializeSet +{-# INLINE binarySerialize #-} +serializeBinary :: Value TBinary -> Builder +serializeBinary (VBinary x) = string x +{-# INLINE serializeBinary #-} -serializeStruct :: HashMap Int16 SomeValue -> Build -serializeStruct fields = do - forM_ (M.toList fields) $ \(fieldId, SomeValue fieldValue) -> - writeField fieldId ttype fieldValue - BB.int8 0 - where - writeField :: Int16 -> TType a -> Value a -> Build - writeField fieldId fieldType fieldValue = do - BB.int8 (toTypeCode fieldType) - BB.int16 fieldId - binarySerialize fieldValue +serializeBool :: Value TBool -> Builder +serializeBool (VBool x) = BB.int8 $ if x then 1 else 0 +{-# INLINE serializeBool #-} +serializeByte :: Value TByte -> Builder +serializeByte (VByte x) = BB.int8 x +{-# INLINE serializeByte #-} -serializeList :: TType a -> Vector (Value a) -> Build -serializeList vtype xs = do - BB.int8 $ toTypeCode vtype - BB.int32 $ fromIntegral (V.length xs) - mapM_ binarySerialize (V.toList xs) +serializeDouble :: Value TDouble -> Builder +serializeDouble (VDouble x) = BB.doubleBE x +{-# INLINE serializeDouble #-} +serializeInt16 :: Value TInt16 -> Builder +serializeInt16 (VInt16 x) = BB.int16BE x +{-# INLINE serializeInt16 #-} -serializeMap :: TType k -> TType v -> HashMap (Value k) (Value v) -> Build -serializeMap kt vt xs = do - BB.int8 $ toTypeCode kt - BB.int8 $ toTypeCode vt - BB.int32 $ fromIntegral (M.size xs) - forM_ (M.toList xs) $ \(k, v) -> do - binarySerialize k - binarySerialize v +serializeInt32 :: Value TInt32 -> Builder +serializeInt32 (VInt32 x) = BB.int32BE x +{-# INLINE serializeInt32 #-} +serializeInt64 :: Value TInt64 -> Builder +serializeInt64 (VInt64 x) = BB.int64BE x +{-# INLINE serializeInt64 #-} -serializeSet :: TType a -> HashSet (Value a) -> Build -serializeSet vtype xs = do - BB.int8 $ toTypeCode vtype - BB.int32 $ fromIntegral (S.size xs) - mapM_ binarySerialize (S.toList xs) +serializeList :: Value TList -> Builder +serializeList (VList xs) = serializeCollection ttype xs +{-# INLINE serializeList #-} +serializeSet :: Value TSet -> Builder +serializeSet (VSet xs) = serializeCollection ttype xs +{-# INLINE serializeSet #-} +serializeStruct :: Value TStruct -> Builder +serializeStruct (VStruct fields) = + M.foldlWithKey' + (\rest fid (SomeValue val) -> rest <> writeField fid ttype val) + mempty fields + <> BB.int8 0 + where + writeField :: IsTType a => Int16 -> TType a -> Value a -> Builder + writeField fieldId fieldType fieldValue = + typeCode fieldType <> BB.int16BE fieldId <> binarySerialize fieldValue + {-# INLINE writeField #-} +{-# INLINE serializeStruct #-} + +serializeMap :: Value TMap -> Builder +serializeMap (VMap items) = serialize ttype ttype items + where + serialize + :: (IsTType k, IsTType v) + => TType k -> TType v -> FL.FoldList (MapItem k v) -> Builder + serialize kt vt xs = + typeCode kt <> typeCode vt <> BB.int32BE size <> body + where + (body, size) = FL.foldl' go (mempty, 0 :: Int32) xs + go (prev, !c) (MapItem k v) = + ( prev <> binarySerialize k <> binarySerialize v + , c + 1 + ) +{-# INLINE serializeMap #-} + +serializeCollection + :: IsTType a + => TType a -> FL.FoldList (Value a) -> Builder +serializeCollection vtype xs = + let go (prev, !c) item = (prev <> binarySerialize item, c + 1) + (body, size) = FL.foldl' go (mempty, 0 :: Int32) xs + in typeCode vtype <> BB.int32BE size <> body +{-# INLINE serializeCollection #-} + ------------------------------------------------------------------------------ @@ -264,6 +295,7 @@ messageCode Reply = 2 messageCode Exception = 3 messageCode Oneway = 4 +{-# INLINE messageCode #-} fromMessageCode :: Int8 -> Maybe MessageType @@ -272,6 +304,7 @@ fromMessageCode 3 = Just Exception fromMessageCode 4 = Just Oneway fromMessageCode _ = Nothing +{-# INLINE fromMessageCode #-} -- | Map a TType to its type code. @@ -287,6 +320,7 @@ toTypeCode TMap = 13 toTypeCode TSet = 14 toTypeCode TList = 15 +{-# INLINE toTypeCode #-} -- | Map a type code to the corresponding TType. @@ -303,3 +337,15 @@ fromTypeCode 14 = Just $ SomeTType TSet fromTypeCode 15 = Just $ SomeTType TList fromTypeCode _ = Nothing +{-# INLINE fromTypeCode #-} + +------------------------------------------------------------------------------ + + +string :: ByteString -> Builder +string b = BB.int32BE (fromIntegral $ B.length b) <> BB.byteString b +{-# INLINE string #-} + +typeCode :: TType a -> Builder +typeCode = BB.int8 . toTypeCode +{-# INLINE typeCode #-} diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,79 @@ + [![build-status]](https://travis-ci.org/abhinav/pinch) `pinch` aims to provide an alternative implementation of Apache Thrift for Haskell. The `pinch` library itself acts only as a serialization library. Types specify their Thrift encoding by defining instances of the `Pinchable` typeclass, which may be done by hand or automatically with the use of Generics. -Check the documentation and examples for more information. + [build-status]: https://travis-ci.org/abhinav/pinch.svg?branch=master + Haddock documentation for this package is avilable on [Hackage] and [here]. - [build-status]: https://travis-ci.org/abhinav/pinch.svg?branch=master [Hackage]: http://hackage.haskell.org/package/pinch [here]: http://abhinavg.net/pinch/ + +Overview +-------- + +Types which can be encoded into Thrift payloads implement the `Pinchable` +typeclass. + +Given the Thrift struct, + +```thrift +struct Person { + 1: required string name + 2: optional i64 dateOfBirth +} +``` + +You can write a `Pinchable` instance like so, + +```haskell +data Person = Person { name :: Text, dateOfBirth :: Maybe Int64 } + deriving (Eq) + +instance Pinchable Person where + type Tag Person = TStruct + -- The Tag tells the system that this represents a struct. + + pinch (Person name dateOfBirth) = + struct [1 .= name, 2 ?= dateOfBirth] + + unpinch value = + Person <$> value .: 1 + <*> value .:? 2 +``` + +Better yet, you can drive an instance automatically. + +```haskell +{-# LANGUAGE DeriveGeneric, DataKinds #-} +import GHC.Generics (Generic) + +data Person = Person + { name :: Field 1 Text + , dateOfBirth :: Field 2 (Maybe Int64) + } deriving (Eq, Generic) + +instance Pinchable Person +``` + +Objects can be serialized and deserialized using the `encode` and `decode` +methods. These methods accept a `Protocol` as an argument. + +```haskell +decode binaryProtocol (encode binaryProtocol person) == person +``` + +For more information, check the documentation and the examples. + +Caveats +------- + +- Only the Thrift Binary Protocol is supported right now. (Pull + requests welcome.) +- There is no code generation or template haskell support yet so types from + the Thrift file will have to be translated by hand. + diff --git a/pinch.cabal b/pinch.cabal --- a/pinch.cabal +++ b/pinch.cabal @@ -1,5 +1,5 @@ name: pinch -version: 0.1.0.2 +version: 0.2.0.0 synopsis: An alternative implementation of Thrift for Haskell. homepage: https://github.com/abhinav/pinch license: BSD3 @@ -32,8 +32,9 @@ library - exposed-modules : Pinch.Internal.Generic - , Pinch.Internal.Builder + exposed-modules : Pinch.Internal.Builder + , Pinch.Internal.FoldList + , Pinch.Internal.Generic , Pinch.Internal.Message , Pinch.Internal.Parser , Pinch.Internal.Pinchable @@ -42,6 +43,8 @@ , Pinch.Protocol , Pinch.Protocol.Binary , Pinch + other-modules : Pinch.Internal.Bits + , Pinch.Internal.Pinchable.Parser ghc-options : -Wall build-depends : base >= 4.7 && < 4.9 @@ -49,6 +52,7 @@ , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 , deepseq >= 1.3 && < 1.5 + , ghc-prim , hashable >= 1.2 && < 1.3 , text >= 1.2 && < 1.3 , unordered-containers >= 0.2 && < 0.3 @@ -65,6 +69,8 @@ , Pinch.Expectations , Pinch.Protocol.BinarySpec , Pinch.Internal.BuilderSpec + , Pinch.Internal.BuilderParserSpec + , Pinch.Internal.FoldListSpec , Pinch.Internal.GenericSpec , Pinch.Internal.ParserSpec , Pinch.Internal.PinchableSpec diff --git a/tests/Pinch/Arbitrary.hs b/tests/Pinch/Arbitrary.hs --- a/tests/Pinch/Arbitrary.hs +++ b/tests/Pinch/Arbitrary.hs @@ -13,19 +13,19 @@ import Control.Applicative #endif -import Data.ByteString (ByteString) -import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.Text (Text) import Test.QuickCheck import qualified Data.ByteString as B import qualified Data.HashMap.Strict as M import qualified Data.HashSet as S import qualified Data.Text as Tx -import qualified Data.Vector as V -import qualified Pinch.Internal.Message as TM -import qualified Pinch.Internal.TType as T -import qualified Pinch.Internal.Value as V +import qualified Pinch.Internal.FoldList as FL +import qualified Pinch.Internal.Message as TM +import qualified Pinch.Internal.TType as T +import qualified Pinch.Internal.Value as V #if !MIN_VERSION_QuickCheck(2, 8, 0) scale :: (Int -> Int) -> Gen a -> Gen a @@ -81,6 +81,10 @@ shrink (V.SomeValue v) = V.SomeValue <$> shrink v +instance (T.IsTType k, T.IsTType v) => Arbitrary (V.MapItem k v) where + arbitrary = V.MapItem <$> arbitrary <*> arbitrary + shrink (V.MapItem k v) = [V.MapItem k' v' | (k', v') <- shrink (k, v)] + instance T.IsTType a => Arbitrary (V.Value a) where arbitrary = case T.ttype :: T.TType a of T.TBool -> V.VBool <$> arbitrary @@ -98,23 +102,32 @@ (T.SomeTType kt, T.SomeTType vt) -> V.VMap <$> genMap kt vt T.TSet -> arbitrary >>= \(T.SomeTType t) -> V.VSet <$> genSet t - T.TList -> arbitrary >>= \(T.SomeTType t) -> V.VList <$> genVec t + T.TList -> arbitrary >>= \(T.SomeTType t) -> V.VList <$> genList t where genStruct = halfSize $ V.VStruct . M.fromList <$> listOf genField where genField = (,) <$> (getPositive <$> arbitrary) <*> arbitrary - genMap :: (T.IsTType k, T.IsTType v) - => T.TType k -> T.TType v - -> Gen (M.HashMap (V.Value k) (V.Value v)) - genMap _ _ = M.fromList <$> halfSize arbitrary + genMap + :: forall k v. (T.IsTType k, T.IsTType v) + => T.TType k -> T.TType v -> Gen (FL.FoldList (V.MapItem k v)) + genMap _ _ = + FL.fromFoldable . map (uncurry V.MapItem) . M.toList . M.fromList + <$> halfSize (arbitrary :: Gen [(V.Value k, V.Value v)]) + -- Need to build a map first to ensure no dupes - genSet :: T.IsTType x => T.TType x -> Gen (S.HashSet (V.Value x)) - genSet _ = S.fromList <$> halfSize arbitrary + genSet + :: forall x. T.IsTType x + => T.TType x -> Gen (FL.FoldList (V.Value x)) + genSet _ = + FL.fromFoldable . S.fromList + <$> halfSize (arbitrary :: Gen [V.Value x]) - genVec :: T.IsTType x => T.TType x -> Gen (V.Vector (V.Value x)) - genVec _ = V.fromList <$> halfSize arbitrary + genList + :: forall x. T.IsTType x + => T.TType x -> Gen (FL.FoldList (V.Value x)) + genList _ = FL.fromFoldable <$> halfSize (arbitrary :: Gen [V.Value x]) shrink = case T.ttype :: T.TType a of T.TByte -> \(V.VByte x) -> V.VByte <$> shrink x @@ -126,11 +139,11 @@ T.TStruct -> \(V.VStruct xs) -> V.VStruct . M.fromList <$> shrink (M.toList xs) T.TMap -> - \(V.VMap xs) -> V.VMap . M.fromList <$> shrink (M.toList xs) + \(V.VMap xs) -> V.VMap . FL.fromFoldable <$> shrink (FL.toList xs) T.TSet -> - \(V.VSet xs) -> V.VSet . S.fromList <$> shrink (S.toList xs) + \(V.VSet xs) -> V.VSet . FL.fromFoldable <$> shrink (FL.toList xs) T.TList -> - \(V.VList xs) -> V.VList . V.fromList <$> shrink (V.toList xs) + \(V.VList xs) -> V.VList . FL.fromFoldable <$> shrink (FL.toList xs) _ -> const [] where shrinkBinary :: V.Value T.TBinary -> [V.Value T.TBinary] diff --git a/tests/Pinch/Internal/BuilderParserSpec.hs b/tests/Pinch/Internal/BuilderParserSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Internal/BuilderParserSpec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +module Pinch.Internal.BuilderParserSpec (spec) where + +#if __GLASGOW_HASKELL__ < 709 +import Control.Applicative +#endif + +import Data.Monoid +import Test.Hspec +import Test.Hspec.QuickCheck + +import qualified Data.ByteString as B + +import Pinch.Arbitrary + +import qualified Pinch.Internal.Builder as BB +import qualified Pinch.Internal.Parser as P + +roundTrip + :: (Show a, Eq a) + => P.Parser a -> (a -> BB.Builder) -> a -> Expectation +roundTrip parser builder a = + P.runParser parser (BB.runBuilder (builder a)) `shouldBe` Right a + +spec :: Spec +spec = describe "Builder and Parser" $ do + + prop "can round trip 8-bit integers" $ + roundTrip P.int8 BB.int8 + + prop "can round trip 16-bit integers" $ + roundTrip P.int16 BB.int16BE + + prop "can round trip 32-bit integers" $ + roundTrip P.int32 BB.int32BE + + prop "can round trip 64-bit integers" $ + roundTrip P.int64 BB.int64BE + + prop "can round trip doubles" $ + roundTrip P.double BB.doubleBE + + prop "can round trip bytestrings" $ \(SomeByteString bs) -> + roundTrip (P.take (B.length bs)) BB.byteString bs + + prop "can round trip primitive appends" $ + roundTrip + ((,) <$> P.int32 <*> P.int64) + (\(a, b) -> BB.int32BE a <> BB.int64BE b) + + prop "can round trip byteString appends" $ + \(SomeByteString l) (SomeByteString r) -> + roundTrip + ((,) <$> P.take (B.length l) <*> P.take (B.length r)) + (\(a, b) -> BB.byteString a <> BB.byteString b) + (l, r) + + prop "can round trip byteString-primitive appends" $ + \(SomeByteString l) r -> + roundTrip + ((,) <$> P.take (B.length l) <*> P.double) + (\(a, b) -> BB.byteString a <> BB.doubleBE b) + (l, r) + + prop "can round trip primitive-byteString appends" $ + \l (SomeByteString r) -> + roundTrip + ((,) <$> P.int64 <*> P.take (B.length r)) + (\(a, b) -> BB.int64BE a <> BB.byteString b) + (l, r) diff --git a/tests/Pinch/Internal/BuilderSpec.hs b/tests/Pinch/Internal/BuilderSpec.hs --- a/tests/Pinch/Internal/BuilderSpec.hs +++ b/tests/Pinch/Internal/BuilderSpec.hs @@ -2,41 +2,28 @@ {-# LANGUAGE OverloadedStrings #-} module Pinch.Internal.BuilderSpec (spec) where -import Control.Arrow (second) -import Data.ByteString (ByteString) -import Data.ByteString.Builder (toLazyByteString) -import Data.ByteString.Lazy (toStrict) -import Data.Int (Int64) -import Data.Word (Word8) +import Data.Monoid +import Data.Word (Word8) import Test.Hspec import Test.Hspec.QuickCheck -import Test.QuickCheck import qualified Data.ByteString as B import Pinch.Arbitrary -import Pinch.Internal.Builder (Build) import qualified Pinch.Internal.Builder as BB -run :: Build -> (Int64, ByteString) -run = second (toStrict . toLazyByteString) . BB.run - - -encodeCases - :: (a -> Build) -> [([Word8], a)] -> Expectation -encodeCases encode = mapM_ . uncurry $ \bytes a -> do - let (size, encoded) = run (encode a) - expected = B.pack bytes - encoded `shouldBe` expected - fromIntegral size `shouldBe` B.length expected - +builderCases + :: (Show a, Eq a) + => (a -> BB.Builder) -> [([Word8], a)] -> Expectation +builderCases build = mapM_ . uncurry $ \expected a -> + B.unpack (BB.runBuilder (build a)) `shouldBe` expected spec :: Spec spec = describe "Builder" $ do - it "can encode 8-bit integers" $ - encodeCases BB.int8 + it "can serialize 8-bit integers (1)" $ + builderCases BB.int8 [ ([0x01], 1) , ([0x05], 5) , ([0x7f], 127) @@ -44,8 +31,11 @@ , ([0x80], -128) ] - it "can encode 16-bit integers" $ - encodeCases BB.int16 + prop "can serialize 8-bit integers (2)" $ \b -> + B.unpack (BB.runBuilder (BB.int8 b)) `shouldBe` [fromIntegral b] + + it "can serialize 16-bit integers" $ + builderCases BB.int16BE [ ([0x00, 0x01], 1) , ([0x00, 0xff], 255) , ([0x01, 0x00], 256) @@ -58,8 +48,8 @@ , ([0x80, 0x00], -32768) ] - it "can encode 32-bit integers" $ - encodeCases BB.int32 + it "can serialize 32-bit integers" $ + builderCases BB.int32BE [ ([0x00, 0x00, 0x00, 0x01], 1) , ([0x00, 0x00, 0x00, 0xff], 255) , ([0x00, 0x00, 0xff, 0xff], 65535) @@ -72,8 +62,8 @@ , ([0x80, 0x00, 0x00, 0x00], -2147483648) ] - it "can encode 64-bit integers" $ - encodeCases BB.int64 + it "can serialize 64-bit integers" $ + builderCases BB.int64BE [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01], 1) , ([0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff], 4294967295) , ([0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff], 1099511627775) @@ -88,8 +78,8 @@ , ([0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], -9223372036854775808) ] - it "can encode doubles" $ - encodeCases BB.double + it "can serialize doubles" $ + builderCases BB.doubleBE [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 0.0) , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], 1.0) , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], 1.0000000001) @@ -99,25 +89,17 @@ , ([0xbf, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], -1.0000000001) ] - prop "can encode bytestrings" $ \(SomeByteString bs) -> - run (BB.byteString bs) === (fromIntegral $ B.length bs, bs) + prop "can serialize byte strings" $ \(SomeByteString bs) -> + BB.runBuilder (BB.byteString bs) `shouldBe` bs - it "can join multiple operations using (>>)" $ - encodeCases (\(a, b) -> BB.int16 a >> BB.byteString b) - [ ( [0x12, 0x34, 0x61, 0x62, 0x63, 0x64] - , (4660, "abcd") - ) - , ( [0x00, 0x00, 0x68, 0x65, 0x6c, 0x6c, 0x6f] - , (0, "hello") - ) - ] + prop "can append primitives" $ + BB.runBuilder (BB.int8 1 <> BB.int32BE 2) + `shouldBe` B.pack [1, 0, 0, 0, 2] - it "can join multiple operations using (>>=)" $ - encodeCases (\(a, b) -> BB.int16 a >>= \() -> BB.byteString b) - [ ( [0x12, 0x34, 0x61, 0x62, 0x63, 0x64] - , (4660, "abcd") - ) - , ( [0x00, 0x00, 0x68, 0x65, 0x6c, 0x6c, 0x6f] - , (0, "hello") - ) - ] + prop "can append byte strings" $ \(SomeByteString l) (SomeByteString r) -> + BB.runBuilder (BB.byteString l <> BB.byteString r) + `shouldBe` (l <> r) + + prop "can append primitives with bytestrings" $ \(SomeByteString r) -> + B.unpack (BB.runBuilder (BB.int32BE 5 <> BB.byteString r)) + `shouldBe` (0:0:0:5:B.unpack r) diff --git a/tests/Pinch/Internal/FoldListSpec.hs b/tests/Pinch/Internal/FoldListSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Pinch/Internal/FoldListSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Pinch.Internal.FoldListSpec (spec) where + +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import qualified Data.Foldable as F +import qualified Data.IORef as IORef +import qualified Data.Vector as V +import qualified Pinch.Internal.FoldList as FL + +spec :: Spec +spec = describe "FoldList" $ do + + prop "is equal to itself" $ \(xs :: [Int]) -> + FL.fromFoldable xs === FL.fromFoldable xs + + prop "is equal if the elements are the same" $ \(xs :: [Int]) -> + FL.fromFoldable xs === FL.fromFoldable (V.fromList xs) + + prop "can convert to and from lists" $ \(xs :: [Int]) -> + F.toList (FL.fromFoldable xs) === xs + + describe "replicate" $ do + + it "can be empty" $ + F.toList (FL.replicate 0 'a') `shouldBe` [] + + it "produces the requested number of duplicates" $ + F.toList (FL.replicate 5 'a') `shouldBe` "aaaaa" + + describe "replicateM" $ + + it "preserves order" $ do + ref <- IORef.newIORef (1 :: Int) + let get = IORef.atomicModifyIORef' ref (\a -> (a + 1, a)) + + result <- FL.replicateM 100 get + F.toList result `shouldBe` [1..100] + diff --git a/tests/Pinch/Internal/GenericSpec.hs b/tests/Pinch/Internal/GenericSpec.hs --- a/tests/Pinch/Internal/GenericSpec.hs +++ b/tests/Pinch/Internal/GenericSpec.hs @@ -22,6 +22,8 @@ import qualified Pinch.Internal.TType as T import qualified Pinch.Internal.Value as V +unpinch' :: P.Pinchable a => V.Value (P.Tag a) -> Either String a +unpinch' = P.runParser . P.unpinch data AnEnum = EnumA (G.Enumeration 1) @@ -40,12 +42,12 @@ P.pinch (EnumB G.enum) `shouldBe` vi32 2 P.pinch (EnumC G.enum) `shouldBe` vi32 3 - P.unpinch (vi32 1) `shouldBe` Right (EnumA G.enum) - P.unpinch (vi32 2) `shouldBe` Right (EnumB G.enum) - P.unpinch (vi32 3) `shouldBe` Right (EnumC G.enum) + unpinch' (vi32 1) `shouldBe` Right (EnumA G.enum) + unpinch' (vi32 2) `shouldBe` Right (EnumB G.enum) + unpinch' (vi32 3) `shouldBe` Right (EnumC G.enum) it "reject invalid values" $ - (P.unpinch :: V.Value T.TInt32 -> Either String AnEnum) + (unpinch' :: V.Value T.TInt32 -> Either String AnEnum) (vi32 4) `leftShouldContain` "Couldn't match enum value 4" data AUnion @@ -93,41 +95,41 @@ P.pinch (UnionVoid G.Void) `shouldBe` vstruct [] it "can unpinch" $ do - P.unpinch (vstruct [(1, vdub_ 12.34)]) + unpinch' (vstruct [(1, vdub_ 12.34)]) `shouldBe` Right (UnionDouble $ G.putField 12.34) - P.unpinch (vstruct [(2, vbyt_ 123)]) + unpinch' (vstruct [(2, vbyt_ 123)]) `shouldBe` Right (UnionByte $ G.putField 123) - P.unpinch + unpinch' (vstruct [(5, vset_ [vi32 1, vi32 2])]) `shouldBe` Right (UnionSet . G.putField . S.fromList $ [EnumA G.enum, EnumB G.enum]) - P.unpinch (vstruct [(1, vbyt_ 42)]) + unpinch' (vstruct [(1, vbyt_ 42)]) `shouldBe` Right (UnionVoidBefore $ G.putField 42) - P.unpinch (vstruct [(2, vbin_ "foo")]) + unpinch' (vstruct [(2, vbin_ "foo")]) `shouldBe` Right (UnionVoidAfter $ G.putField "foo") - P.unpinch (vstruct []) `shouldBe` Right (UnionVoid G.Void) + unpinch' (vstruct []) `shouldBe` Right (UnionVoid G.Void) it "reject invalid types" $ do - (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (unpinch' :: V.Value T.TUnion -> Either String AUnion) (vstruct [(1, vi32_ 1)]) `leftShouldContain` "is absent" - (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (unpinch' :: V.Value T.TUnion -> Either String AUnion) (vstruct [(2, vbool_ True)]) `leftShouldContain` "is absent" - (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (unpinch' :: V.Value T.TUnion -> Either String AUnion) (vstruct [(5, vlist_ [vi32 1, vi32 2])]) `leftShouldContain` "has the incorrect type" it "reject invalid IDs" $ - (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (unpinch' :: V.Value T.TUnion -> Either String AUnion) (vstruct [(3, vdub_ 1.0)]) `leftShouldContain` "is absent" @@ -151,11 +153,11 @@ , (5, vi32_ 42) ] - P.unpinch (vstruct [(1, vbin_ "hello")]) + unpinch' (vstruct [(1, vbin_ "hello")]) `shouldBe` Right (AStruct (G.putField "hello") (G.putField Nothing)) - P.unpinch + unpinch' (vstruct [ (1, vbin_ "hello") , (5, vi32_ 42) @@ -163,14 +165,14 @@ Right (AStruct (G.putField "hello") (G.putField $ Just 42)) it "ignores unrecognized fields" $ do - P.unpinch + unpinch' (vstruct [ (1, vbin_ "foo") , (2, vi32_ 42) ]) `shouldBe` Right (AStruct (G.putField "foo") (G.putField Nothing)) - P.unpinch + unpinch' (vstruct [ (1, vbin_ "foo") , (4, vbyt_ 12) @@ -179,14 +181,14 @@ Right (AStruct (G.putField "foo") (G.putField $ Just 34)) it "rejects missing required fields" $ - (P.unpinch :: V.Value T.TStruct -> Either String AStruct) + (unpinch' :: V.Value T.TStruct -> Either String AStruct) (vstruct [ (4, vbyt_ 12) , (5, vi32_ 34) ]) `leftShouldContain` "1 is absent" it "rejects invalid types" $ - (P.unpinch :: V.Value T.TStruct -> Either String AStruct) + (unpinch' :: V.Value T.TStruct -> Either String AStruct) (vstruct [ (1, vlist_ [vi32 42]) ]) `leftShouldContain` "has the incorrect type" diff --git a/tests/Pinch/Internal/PinchableSpec.hs b/tests/Pinch/Internal/PinchableSpec.hs --- a/tests/Pinch/Internal/PinchableSpec.hs +++ b/tests/Pinch/Internal/PinchableSpec.hs @@ -43,11 +43,14 @@ pinch EnumC = P.pinch (3 :: Int32) unpinch = P.unpinch >=> \v -> case (v :: Int32) of - 1 -> Right EnumA - 2 -> Right EnumB - 3 -> Right EnumC - _ -> Left "Unknown enum value" + 1 -> return EnumA + 2 -> return EnumB + 3 -> return EnumC + _ -> fail "Unknown enum value" +unpinch' :: P.Pinchable a => V.Value (P.Tag a) -> Either String a +unpinch' = P.runParser . P.unpinch + enumSpec :: Spec enumSpec = describe "Enum" $ do @@ -56,12 +59,12 @@ P.pinch EnumB `shouldBe` vi32 2 P.pinch EnumC `shouldBe` vi32 3 - P.unpinch (vi32 1) `shouldBe` Right EnumA - P.unpinch (vi32 2) `shouldBe` Right EnumB - P.unpinch (vi32 3) `shouldBe` Right EnumC + unpinch' (vi32 1) `shouldBe` Right EnumA + unpinch' (vi32 2) `shouldBe` Right EnumB + unpinch' (vi32 3) `shouldBe` Right EnumC it "reject invalid values" $ - P.unpinch (vi32 4) `shouldBe` + unpinch' (vi32 4) `shouldBe` (Left "Unknown enum value" :: Either String AnEnum) @@ -99,31 +102,31 @@ vstruct [(5, vset_ [vi32 1, vi32 2])] it "can unpinch" $ do - P.unpinch (vstruct [(1, vdub_ 12.34)]) + unpinch' (vstruct [(1, vdub_ 12.34)]) `shouldBe` Right (UnionDouble 12.34) - P.unpinch (vstruct [(2, vbyt_ 123)]) + unpinch' (vstruct [(2, vbyt_ 123)]) `shouldBe` Right (UnionByte 123) - P.unpinch + unpinch' (vstruct [(5, vset_ [vi32 1, vi32 2])]) `shouldBe` Right (UnionSet $ S.fromList [EnumA, EnumB]) it "reject invalid types" $ do - (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (unpinch' :: V.Value T.TUnion -> Either String AUnion) (vstruct [(1, vi32_ 1)]) `leftShouldContain` "is absent" - (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (unpinch' :: V.Value T.TUnion -> Either String AUnion) (vstruct [(2, vbool_ True)]) `leftShouldContain` "is absent" - (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (unpinch' :: V.Value T.TUnion -> Either String AUnion) (vstruct [(5, vlist_ [vi32 1, vi32 2])]) `leftShouldContain` "has the incorrect type" it "reject invalid IDs" $ - (P.unpinch :: V.Value T.TUnion -> Either String AUnion) + (unpinch' :: V.Value T.TUnion -> Either String AUnion) (vstruct [(3, vdub_ 1.0)]) `leftShouldContain` "is absent" @@ -150,23 +153,23 @@ , (5, vi32_ 42) ] - P.unpinch (vstruct [(1, vbin_ "hello")]) + unpinch' (vstruct [(1, vbin_ "hello")]) `shouldBe` Right (AStruct "hello" Nothing) - P.unpinch + unpinch' (vstruct [ (1, vbin_ "hello") , (5, vi32_ 42) ]) `shouldBe` Right (AStruct "hello" (Just 42)) it "ignores unrecognized fields" $ do - P.unpinch + unpinch' (vstruct [ (1, vbin_ "foo") , (2, vi32_ 42) ]) `shouldBe` Right (AStruct "foo" Nothing) - P.unpinch + unpinch' (vstruct [ (1, vbin_ "foo") , (4, vbyt_ 12) @@ -174,14 +177,14 @@ ]) `shouldBe` Right (AStruct "foo" (Just 34)) it "rejects missing required fields" $ - (P.unpinch :: V.Value T.TStruct -> Either String AStruct) + (unpinch' :: V.Value T.TStruct -> Either String AStruct) (vstruct [ (4, vbyt_ 12) , (5, vi32_ 34) ]) `leftShouldContain` "1 is absent" it "rejects invalid types" $ - (P.unpinch :: V.Value T.TStruct -> Either String AStruct) + (unpinch' :: V.Value T.TStruct -> Either String AStruct) (vstruct [ (1, vlist_ [vi32 42]) ]) `leftShouldContain` "has the incorrect type" @@ -194,34 +197,34 @@ P.pinch True `shouldBe` vbool True P.pinch False `shouldBe` vbool False - P.unpinch (vbool True) `shouldBe` Right True - P.unpinch (vbool False) `shouldBe` Right False + unpinch' (vbool True) `shouldBe` Right True + unpinch' (vbool False) `shouldBe` Right False prop "can pinch and unpinch Int8" $ \i -> do P.pinch i `shouldBe` vbyt i - P.unpinch (vbyt i) `shouldBe` Right i + unpinch' (vbyt i) `shouldBe` Right i prop "can pinch and unpinch Int32" $ \i -> do P.pinch i `shouldBe` vi32 i - P.unpinch (vi32 i) `shouldBe` Right i + unpinch' (vi32 i) `shouldBe` Right i prop "can pinch and unpinch Int64" $ \i -> do P.pinch i `shouldBe` vi64 i - P.unpinch (vi64 i) `shouldBe` Right i + unpinch' (vi64 i) `shouldBe` Right i prop "can pinch and unpinch Double" $ \d -> do P.pinch d `shouldBe` vdub d - P.unpinch (vdub d) `shouldBe` Right d + unpinch' (vdub d) `shouldBe` Right d prop "can pinch and unpinch ByteString" $ \(SomeByteString bs) -> do P.pinch bs `shouldBe` vbin bs - P.unpinch (vbin bs) `shouldBe` Right bs + unpinch' (vbin bs) `shouldBe` Right bs it "can pinch and unpinch Text" $ do P.pinch ("☕️" :: Text) `shouldBe` vbin (B.pack [0xe2, 0x98, 0x95, 0xef, 0xb8, 0x8f]) - P.unpinch (vbin (B.pack [0xe2, 0x98, 0x95, 0xef, 0xb8, 0x8f])) + unpinch' (vbin (B.pack [0xe2, 0x98, 0x95, 0xef, 0xb8, 0x8f])) `shouldBe` Right ("☕️" :: Text) @@ -234,11 +237,11 @@ P.pinch (Vec.fromList [1, 2, 3 :: Int32]) `shouldBe` vlist [vi32 1, vi32 2, vi32 3] - P.unpinch (vlist [vi32 1, vi32 2, vi32 3]) + unpinch' (vlist [vi32 1, vi32 2, vi32 3]) `shouldBe` Right (Vec.fromList [1, 2, 3 :: Int32]) it "rejects type mismatch" $ - (P.unpinch :: V.Value T.TList -> Either String (Vector Int8)) + (unpinch' :: V.Value T.TList -> Either String (Vector Int8)) (vlist [vi32 1, vi32 2, vi32 3]) `leftShouldContainAll` ["Type mismatch", "Expected TByte", "Got TInt32"] @@ -250,11 +253,11 @@ P.pinch ([1, 2, 3] :: [Int32]) `shouldBe` vlist [vi32 1, vi32 2, vi32 3] - P.unpinch (vlist [vi32 1, vi32 2, vi32 3]) + unpinch' (vlist [vi32 1, vi32 2, vi32 3]) `shouldBe` Right ([1, 2, 3] :: [Int32]) it "rejects type mismatch" $ - (P.unpinch :: V.Value T.TList -> Either String [Int8]) + (unpinch' :: V.Value T.TList -> Either String [Int8]) (vlist [vi32 1, vi32 2, vi32 3]) `leftShouldContain` "Type mismatch" @@ -264,11 +267,11 @@ P.pinch (HS.fromList [1, 2, 3 :: Int32]) `shouldBe` vset [vi32 1, vi32 2, vi32 3] - P.unpinch (vset [vi32 1, vi32 2, vi32 3]) + unpinch' (vset [vi32 1, vi32 2, vi32 3]) `shouldBe` Right (HS.fromList [1, 2, 3 :: Int32]) it "rejects type mismatch" $ - (P.unpinch :: V.Value T.TSet -> Either String (HashSet Int8)) + (unpinch' :: V.Value T.TSet -> Either String (HashSet Int8)) (vset [vi32 1, vi32 2, vi32 3]) `leftShouldContain` "Type mismatch" @@ -278,11 +281,11 @@ P.pinch (S.fromList [1, 2, 3 :: Int32]) `shouldBe` vset [vi32 1, vi32 2, vi32 3] - P.unpinch (vset [vi32 1, vi32 2, vi32 3]) + unpinch' (vset [vi32 1, vi32 2, vi32 3]) `shouldBe` Right (S.fromList [1, 2, 3 :: Int32]) it "rejects type mismatch" $ - (P.unpinch :: V.Value T.TSet -> Either String (Set Int8)) + (unpinch' :: V.Value T.TSet -> Either String (Set Int8)) (vset [vi32 1, vi32 2, vi32 3]) `leftShouldContain` "Type mismatch" @@ -296,7 +299,7 @@ , (vbin "b", vi16 2) ] - P.unpinch + unpinch' (vmap [ (vbin "a", vi16 1) , (vbin "b", vi16 2) ]) `shouldBe` @@ -305,12 +308,12 @@ [("a", 1), ("b", 2) :: (ByteString, Int16)]) it "rejects key type mismatch" $ - (P.unpinch :: V.Value T.TMap -> Either String (HashMap Int32 Int16)) + (unpinch' :: V.Value T.TMap -> Either String (HashMap Int32 Int16)) (vmap [(vbin "a", vi16 1)]) `leftShouldContain` "Type mismatch" it "rejects value type mismatch" $ - (P.unpinch :: V.Value T.TMap -> Either String (HashMap ByteString Bool)) + (unpinch' :: V.Value T.TMap -> Either String (HashMap ByteString Bool)) (vmap [(vbin "a", vi16 1)]) `leftShouldContain` "Type mismatch" @@ -324,7 +327,7 @@ , (vbin "b", vi16 2) ] - P.unpinch + unpinch' (vmap [ (vbin "a", vi16 1) , (vbin "b", vi16 2) ]) `shouldBe` @@ -333,12 +336,12 @@ [("a", 1), ("b", 2) :: (ByteString, Int16)]) it "rejects key type mismatch" $ - (P.unpinch :: V.Value T.TMap -> Either String (Map Int32 Int16)) + (unpinch' :: V.Value T.TMap -> Either String (Map Int32 Int16)) (vmap [(vbin "a", vi16 1)]) `leftShouldContain` "Type mismatch" it "rejects value type mismatch" $ - (P.unpinch :: V.Value T.TMap -> Either String (Map ByteString Bool)) + (unpinch' :: V.Value T.TMap -> Either String (Map ByteString Bool)) (vmap [(vbin "a", vi16 1)]) `leftShouldContain` "Type mismatch" diff --git a/tests/Pinch/Internal/Util.hs b/tests/Pinch/Internal/Util.hs --- a/tests/Pinch/Internal/Util.hs +++ b/tests/Pinch/Internal/Util.hs @@ -29,12 +29,12 @@ import Data.Int import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Vector as V import Pinch.Internal.TType import Pinch.Internal.Value +import qualified Pinch.Internal.FoldList as FL + vsome :: IsTType a => Value a -> SomeValue vsome = SomeValue @@ -75,13 +75,13 @@ vstruct = VStruct . HM.fromList vset :: IsTType a => [Value a] -> Value TSet -vset = VSet . HS.fromList +vset = VSet . FL.fromFoldable vlist :: IsTType a => [Value a] -> Value TList -vlist = VList . V.fromList +vlist = VList . FL.fromFoldable vmap :: (IsTType k, IsTType v) => [(Value k, Value v)] -> Value TMap -vmap = VMap . HM.fromList +vmap = VMap . FL.fromFoldable . map (uncurry MapItem) vdub :: Double -> Value TDouble vdub = VDouble diff --git a/tests/Pinch/Internal/ValueSpec.hs b/tests/Pinch/Internal/ValueSpec.hs --- a/tests/Pinch/Internal/ValueSpec.hs +++ b/tests/Pinch/Internal/ValueSpec.hs @@ -1,18 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module Pinch.Internal.ValueSpec (spec) where +import Data.Function (on) +import Data.List (nubBy) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Pinch.Arbitrary () -import qualified Pinch.Internal.Value as V +import qualified Pinch.Internal.FoldList as FL +import qualified Pinch.Internal.TType as T +import qualified Pinch.Internal.Value as V + +#if !MIN_VERSION_QuickCheck(2, 8, 0) +import Control.Applicative ((<$>)) +import Control.Arrow (second) + +shuffle :: [a] -> Gen [a] +shuffle [] = return [] +shuffle xs = do + (y, ys) <- elements (selectOne xs) + (y:) <$> shuffle ys + where + selectOne [] = [] + selectOne (y:ys) = (y,ys) : map (second (y:)) (selectOne ys) +#endif + + spec :: Spec spec = describe "Value" $ do prop "is equal to itself" $ \(V.SomeValue v) -> v === v - prop "can be cast via SomeValue" $ \(V.SomeValue v) -> - V.castValue (V.SomeValue v) === Just v + prop "can be cast" $ \(V.SomeValue v) -> + V.castValue v === Just v + + prop "list equality" $ \(xs, ys :: [V.Value T.TInt32]) -> + (xs /= ys) ==> + (V.VList (FL.fromFoldable xs) /= V.VList (FL.fromFoldable ys)) + === True + + prop "sets are unordered" $ \(xs :: [V.Value T.TInt32]) -> do + xs' <- generate (shuffle xs) + V.VSet (FL.fromFoldable xs) `shouldBe` V.VSet (FL.fromFoldable xs') + + prop "maps are unordered" $ \(xs0 :: [V.MapItem T.TInt32 T.TByte]) -> do + let xs = nubBy ((==) `on` (\(V.MapItem k _) -> k)) xs0 + xs' <- generate (shuffle xs) + V.VMap (FL.fromFoldable xs) `shouldBe` V.VMap (FL.fromFoldable xs') diff --git a/tests/Pinch/Protocol/BinarySpec.hs b/tests/Pinch/Protocol/BinarySpec.hs --- a/tests/Pinch/Protocol/BinarySpec.hs +++ b/tests/Pinch/Protocol/BinarySpec.hs @@ -4,16 +4,15 @@ module Pinch.Protocol.BinarySpec (spec) where import Data.ByteString (ByteString) -import Data.ByteString.Lazy (toStrict) import Data.Word (Word8) import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString as B import Pinch.Arbitrary () +import Pinch.Internal.Builder (runBuilder) import Pinch.Internal.Message import Pinch.Internal.TType import Pinch.Internal.Util @@ -23,7 +22,7 @@ serialize :: IsTType a => Value a -> ByteString -serialize = toStrict . BB.toLazyByteString . snd . serializeValue binaryProtocol +serialize = runBuilder . serializeValue binaryProtocol deserialize :: IsTType a => ByteString -> Either String (Value a) @@ -31,8 +30,7 @@ serializeMsg :: Message -> ByteString -serializeMsg = - toStrict . BB.toLazyByteString . snd . serializeMessage binaryProtocol +serializeMsg = runBuilder . serializeMessage binaryProtocol deserializeMsg :: ByteString -> Either String Message deserializeMsg = deserializeMessage binaryProtocol @@ -106,6 +104,65 @@ , ([ 0x00, 0x00, 0x00, 0x05 -- length = 5 , 0x68, 0x65, 0x6c, 0x6c, 0x6f -- hello ], vbin "hello") + ] + + it "can read and write 8-bit integers" $ readWriteCases + [ ([0x01], vbyt 1) + , ([0x05], vbyt 5) + , ([0x7f], vbyt 127) + , ([0xff], vbyt -1) + , ([0x80], vbyt -128) + ] + + it "can read and write 16-bit integers" $ readWriteCases + [ ([0x00, 0x01], vi16 1) + , ([0x00, 0xff], vi16 255) + , ([0x01, 0x00], vi16 256) + , ([0x01, 0x01], vi16 257) + , ([0x7f, 0xff], vi16 32767) + , ([0xff, 0xff], vi16 -1) + , ([0xff, 0xfe], vi16 -2) + , ([0xff, 0x00], vi16 -256) + , ([0xff, 0x01], vi16 -255) + , ([0x80, 0x00], vi16 -32768) + ] + + it "can readd and write 32-bit integers" $ readWriteCases + [ ([0x00, 0x00, 0x00, 0x01], vi32 1) + , ([0x00, 0x00, 0x00, 0xff], vi32 255) + , ([0x00, 0x00, 0xff, 0xff], vi32 65535) + , ([0x00, 0xff, 0xff, 0xff], vi32 16777215) + , ([0x7f, 0xff, 0xff, 0xff], vi32 2147483647) + , ([0xff, 0xff, 0xff, 0xff], vi32 -1) + , ([0xff, 0xff, 0xff, 0x00], vi32 -256) + , ([0xff, 0xff, 0x00, 0x00], vi32 -65536) + , ([0xff, 0x00, 0x00, 0x00], vi32 -16777216) + , ([0x80, 0x00, 0x00, 0x00], vi32 -2147483648) + ] + + it "can readd and write 64-bit integers" $ readWriteCases + [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01], vi64 1) + , ([0x00, 0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff], vi64 4294967295) + , ([0x00, 0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff], vi64 1099511627775) + , ([0x00, 0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], vi64 281474976710655) + , ([0x00, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], vi64 72057594037927935) + , ([0x7f, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], vi64 9223372036854775807) + , ([0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff], vi64 -1) + , ([0xff, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00], vi64 -4294967296) + , ([0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00], vi64 -1099511627776) + , ([0xff, 0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], vi64 -281474976710656) + , ([0xff, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], vi64 -72057594037927936) + , ([0x80, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], vi64 -9223372036854775808) + ] + + it "can read and write doubles" $ readWriteCases + [ ([0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], vdub 0.0) + , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00], vdub 1.0) + , ([0x3f, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], vdub 1.0000000001) + , ([0x3f, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], vdub 1.1) + , ([0xbf, 0xf1, 0x99, 0x99, 0x99, 0x99, 0x99, 0x9a], vdub -1.1) + , ([0x40, 0x09, 0x21, 0xfb, 0x54, 0x44, 0x2d, 0x18], vdub 3.141592653589793) + , ([0xbf, 0xf0, 0x00, 0x00, 0x00, 0x06, 0xdf, 0x38], vdub -1.0000000001) ] it "can read and write structs" $ readWriteCases