pinch 0.1.0.2 → 0.2.0.0

raw patch · 24 files changed

+1177/−444 lines, 24 filesdep +ghc-primPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-prim

API changes (from Hackage documentation)

Files

• CHANGES.md +19/−0
• Pinch.hs +10/−17
• Pinch/Internal/Bits.hs +46/−0
• Pinch/Internal/Builder.hs +87/−53
• Pinch/Internal/FoldList.hs +120/−0
• Pinch/Internal/Generic.hs +8/−7
• Pinch/Internal/Parser.hs +25/−18
• Pinch/Internal/Pinchable.hs +112/−87
• Pinch/Internal/Pinchable/Parser.hs +91/−0
• Pinch/Internal/TType.hs +33/−5
• Pinch/Internal/Value.hs +82/−34
• Pinch/Protocol.hs +4/−5
• Pinch/Protocol/Binary.hs +114/−68
• README.md +68/−2
• pinch.cabal +9/−3
• tests/Pinch/Arbitrary.hs +31/−18
• tests/Pinch/Internal/BuilderParserSpec.hs +70/−0
• tests/Pinch/Internal/BuilderSpec.hs +32/−50
• tests/Pinch/Internal/FoldListSpec.hs +41/−0
• tests/Pinch/Internal/GenericSpec.hs +22/−20
• tests/Pinch/Internal/PinchableSpec.hs +46/−43
• tests/Pinch/Internal/Util.hs +5/−5
• tests/Pinch/Internal/ValueSpec.hs +39/−3
• tests/Pinch/Protocol/BinarySpec.hs +63/−6

@@ -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 ======= 

@@ -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 #-}  ------------------------------------------------------------------------------

@@ -0,0 +1,46 @@+{-# LANGUAGE CPP       #-}+{-# LANGUAGE MagicHash #-}+-- |+-- Module      :  Pinch.Internal.Bits+-- Copyright   :  (c) Abhinav Gupta 2015+-- License     :  BSD3+--+-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>+-- 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

@@ -7,87 +7,121 @@ -- Maintainer  :  Abhinav Gupta <mail@abhinavg.net> -- 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 #-}

@@ -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 <mail@abhinavg.net>+-- 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

@@ -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

@@ -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 #-}  

@@ -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

@@ -0,0 +1,91 @@+{-# LANGUAGE Rank2Types #-}+-- |+-- Module      :  Pinch.Internal.Pinchable.Parser+-- Copyright   :  (c) Abhinav Gupta 2015+-- License     :  BSD3+--+-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>+-- 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 #-}

@@ -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 #-}

@@ -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

@@ -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.

@@ -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 #-}

@@ -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.+

@@ -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

@@ -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]

@@ -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)

@@ -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)

@@ -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]+

@@ -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"

@@ -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" 

@@ -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

@@ -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')

@@ -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