hinterface 0.11.0 → 1.0.0

raw patch · 7 files changed

+546/−617 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hinterface.cabal +1/−1
• src/Foreign/Erlang/ControlMessage.hs +22/−22
• src/Foreign/Erlang/LocalNode.hs +2/−2
• src/Foreign/Erlang/NodeData.hs +1/−1
• src/Foreign/Erlang/Term.hs +167/−240
• src/Util/Binary.hs +30/−31
• test/Foreign/Erlang/TermSpec.hs +323/−320

@@ -1,6 +1,6 @@ cabal-version: >=1.22 name: hinterface-version: 0.11.0+version: 1.0.0 license: BSD3 license-file: LICENSE copyright: 2016-2019 Timo Koepke, Sven Heyll

@@ -37,31 +37,31 @@       where         put' TICK = fail "Unreachable code" -        put' (LINK fromPid toPid) = do-            putTerm (linkTag, fromPid, toPid)+        put' (LINK fromPid toPid) =+            put (MkExternalTerm (toTerm (linkTag, fromPid, toPid)))          put' (SEND toPid message) = do-            putTerm (sendTag, unused, toPid)-            putTerm message+            put (MkExternalTerm (toTerm (sendTag, unused, toPid)))+            put (MkExternalTerm (toTerm message)) -        put' (EXIT fromPid toPid reason) = do-            putTerm (exitTag, fromPid, toPid, reason)+        put' (EXIT fromPid toPid reason) =+            put (MkExternalTerm (toTerm (exitTag, fromPid, toPid, reason))) -        put' (UNLINK fromPid toPid) = do-            putTerm (unlinkTag, fromPid, toPid)+        put' (UNLINK fromPid toPid) =+            put (MkExternalTerm (toTerm (unlinkTag, fromPid, toPid))) -        put' NODE_LINK = do-            putTerm (Tuple1 nodeLinkTag)+        put' NODE_LINK =+            put (MkExternalTerm (toTerm (Tuple1 nodeLinkTag)))          put' (REG_SEND fromPid toName message) = do-            putTerm (regSendTag, fromPid, unused, toName)-            putTerm message+            put (MkExternalTerm (toTerm (regSendTag, fromPid, unused, toName)))+            put (MkExternalTerm (toTerm message)) -        put' (GROUP_LEADER fromPid toPid) = do-            putTerm (groupLeaderTag, fromPid, toPid)+        put' (GROUP_LEADER fromPid toPid) =+            put (MkExternalTerm (toTerm (groupLeaderTag, fromPid, toPid))) -        put' (EXIT2 fromPid toPid reason) = do-            putTerm (exit2Tag, fromPid, toPid, reason)+        put' (EXIT2 fromPid toPid reason) =+            put (MkExternalTerm (toTerm (exit2Tag, fromPid, toPid, reason)))     get = do         expectedLen <- getWord32be         if expectedLen == 0@@ -72,15 +72,15 @@                 controlMessage <- get'                 pos1 <- bytesRead                 let actualLen = pos1 - pos0-                if (fromIntegral expectedLen) == actualLen-                    then do+                if fromIntegral expectedLen == actualLen+                    then                         return controlMessage-                    else do+                    else                         fail "Bad control message length"       where         badControlMsg term = fail ("Bad control message: " ++ show term)         get' = do-            term <- getTerm+            MkExternalTerm term <- get             res <- runMaybeT $ get'' term             maybe (badControlMsg term) return res           where@@ -99,7 +99,7 @@                     return (LINK p2 p3)                 getSEND = do                     (_ :: TsendTag, _ :: Term, p1) <- fromTermA term-                    message <- lift getTerm+                    MkExternalTerm message <- lift get                     return (SEND p1 message)                 getEXIT = do                     (_ :: TexitTag, p2, p3, p4) <- fromTermA term@@ -112,7 +112,7 @@                     return NODE_LINK                 getREG_SEND = do                     (_ :: TregSendTag, p2, _p3 :: Term, p4) <- fromTermA term-                    message <- lift getTerm+                    MkExternalTerm message <- lift get                     return (REG_SEND p2 p4 message)                 getGROUP_LEADER = do                     (_ :: TgroupLeaderTag, p2, p3) <- fromTermA term

@@ -209,7 +209,7 @@      => Pid      -> Term      -> NodeT m ()-send toPid message = getOrCreateConnection (atom_name (node (toTerm toPid)))+send toPid message = getOrCreateConnection (atomName (node (toTerm toPid)))     >>= maybe (return ()) (sendControlMessage (SEND toPid message))  sendReg :: (MonadMask m, MonadBaseControl IO m, MonadResource m, MonadLoggerIO m)@@ -219,7 +219,7 @@         -> Term         -> NodeT m () sendReg MkMailbox{self} regName nodeName message =-    getOrCreateConnection (atom_name nodeName) >>=+    getOrCreateConnection (atomName nodeName) >>=         maybe (return ()) (sendControlMessage (REG_SEND self regName message))  splitNodeName :: CS.ByteString -> (CS.ByteString, CS.ByteString)

@@ -53,7 +53,7 @@                       | NEW_FLOATS           --  The node understands new float format                       | UNICODE_IO                       | DIST_HDR_ATOM_CACHE  --  The node implements atom cache in distribution header.-                      | SMALL_ATOM_TAGS      --  The node understand the SMALL_ATOM_EXT tag+                      | SMALL_ATOM_TAGS      --  The node understand the smallAtomExt tag                       | UTF8_ATOMS           --  The node understand UTF-8 encoded atoms     deriving (Eq, Show, Enum, Bounded, Ord) 

@@ -10,8 +10,9 @@ {-# OPTIONS_GHC -fno-warn-unused-binds  #-}  module Foreign.Erlang.Term-    ( -- * External Term Format-      Term(..+    ( ExternalTerm(..)+     , -- * Term Format+       Term(..           , Tuple2           , Tuple3           , Tuple4@@ -33,8 +34,6 @@           , Map6           , Map7           )-    , putTerm-    , getTerm     , MapEntry(.., (:=>))       -- ** Conversion to and from External Term Format     , ToTerm(..)@@ -60,26 +59,26 @@     , improperList     , ref       -- ** Recognizers-    , is_integer-    , is_float-    , is_atom-    , is_reference-    , is_port-    , is_pid-    , is_tuple-    , is_map-    , is_list-    , is_binary+    , isInteger+    , isFloat+    , isAtom+    , isReference+    , isPort+    , isPid+    , isTuple+    , isMap+    , isList+    , isBinary       -- ** Accessors     , node-    , atom_name+    , atomName     , length     , element-    , to_string-    , to_integer+    , toString+    , toIntegerTerm       -- ** Matchers-    , match_atom-    , match_tuple+    , matchAtom+    , matchTuple     ) where @@ -95,7 +94,7 @@ import           Control.Monad                 as M                                                 ( replicateM ) import           Data.String-import           Data.ByteString                ( ByteString )+import           Data.ByteString                ( ByteString, pack ) import           Data.ByteString.Char8          ( unpack ) import qualified Data.ByteString               as BS                                                 ( head@@ -135,9 +134,23 @@ import           Data.Monoid import           GHC.Exts as E import           GHC.Generics+import GHC.Stack (HasCallStack)  -------------------------------------------------------------------------------- +newtype ExternalTerm = MkExternalTerm { fromExternalTerm :: Term }+  deriving (Eq, Generic, Show, NFData, Arbitrary)++instance Binary ExternalTerm where+  put (MkExternalTerm t) = do+    putWord8 magicVersion+    put t+  get = do+    matchWord8 magicVersion+    MkExternalTerm <$> get++--------------------------------------------------------------------------------+ data Term = Integer Integer           | Float Double           | Atom ByteString@@ -266,14 +279,14 @@     (Integer i) `compare` (Integer i') =         i `compare` i'     (Integer i) `compare` (Float d') =-        (fromIntegral i) `compare` d'+        fromIntegral i `compare` d'     (Integer _) `compare` _ =         LT      (Float d) `compare` (Float d') =         d `compare` d'     (Float d) `compare` (Integer i') =-        d `compare` (fromIntegral i')+        d `compare` fromIntegral i'     (Float _) `compare` _ = LT      (Atom a) `compare` (Atom a') =@@ -282,22 +295,22 @@      (Reference node' id creation) `compare` (Reference node'' id' creation') =         (node', id, creation) `compare` (node'', id', creation')-    (Reference _ _ _) `compare` _ =+    Reference{} `compare` _ =         LT      (NewReference node' creation ids) `compare` (NewReference node'' creation' ids') =         (node', creation, ids) `compare` (node'', creation', ids')-    (NewReference _ _ _) `compare` _ =+    NewReference{} `compare` _ =         LT      (Port node' id creation) `compare` (Port node'' id' creation') =         (node', id, creation) `compare` (node'', id', creation')-    (Port _ _ _) `compare` _ =+    Port{} `compare` _ =         LT      (Pid node' id serial creation) `compare` (Pid node'' id' serial' creation') =         (node', id, serial, creation) `compare` (node'', id', serial', creation')-    (Pid _ _ _ _) `compare` _ =+    Pid{} `compare` _ =         LT      (Tuple v) `compare` (Tuple v') =@@ -361,25 +374,22 @@     showsPrec _ MapEntry{key,value} =         shows key . showString " => " . shows value -showsVectorAsList :: Show a => (Vector a) -> ShowS+showsVectorAsList :: Show a => Vector a -> ShowS showsVectorAsList v-    | V.length v == 0 = \s -> s-    | V.length v == 1 = shows (v ! 0)-    | otherwise = shows (v ! 0)-    . appEndo (foldMap (\t -> Endo (showChar ',' . shows t)) (V.tail v))+  | V.length v == 0 = P.id+  | V.length v == 1 = shows (v ! 0)+  | otherwise =+    shows (v ! 0) .+    appEndo (foldMap (\t -> Endo (showChar ',' . shows t)) (V.tail v))  showsByteStringAsIntList :: ByteString -> ShowS showsByteStringAsIntList b-    | BS.length b == 0-    = \s -> s-    | BS.length b == 1-    = shows (BS.head b)-    | otherwise-    = shows (BS.head b)-        . appEndo-              (foldMap (\t -> Endo (showChar ',' . shows t))-                       (BS.unpack (BS.tail b))-              )+  | BS.length b == 0 = P.id+  | BS.length b == 1 = shows (BS.head b)+  | otherwise =+    shows (BS.head b) .+    appEndo+      (foldMap (\t -> Endo (showChar ',' . shows t)) (BS.unpack (BS.tail b)))  instance IsString Term where     fromString = atom . CS.pack@@ -659,50 +669,50 @@ ref = NewReference  ---------------------------------------------------------------------------------is_integer, is_float, is_atom, is_reference, is_port, is_pid, is_tuple, is_map, is_list, is_binary+isInteger, isFloat, isAtom, isReference, isPort, isPid, isTuple, isMap, isList, isBinary     :: Term -> Bool -- | Test if term is an integer-is_integer (Integer _) = True-is_integer _           = False+isInteger (Integer _) = True+isInteger _           = False  -- | Test if term is a float-is_float (Float _) = True-is_float _         = False+isFloat (Float _) = True+isFloat _         = False  -- | Test if term is an atom-is_atom (Atom _) = True-is_atom _        = False+isAtom (Atom _) = True+isAtom _        = False  -- | Test if term is a reference-is_reference (Reference    _ _ _) = True-is_reference (NewReference _ _ _) = True-is_reference _                    = False+isReference Reference {} = True+isReference NewReference {} = True+isReference _                    = False  -- | Test if term is a port-is_port (Port _ _ _) = True-is_port _            = False+isPort Port {} = True+isPort _            = False  -- | Test if term is a pid-is_pid (Pid _ _ _ _) = True-is_pid _             = False+isPid Pid {} = True+isPid _             = False  -- | Test if term is a tuple-is_tuple (Tuple _) = True-is_tuple _         = False+isTuple (Tuple _) = True+isTuple _         = False  -- | Test if term is a map-is_map (Map _) = True-is_map _       = False+isMap (Map _) = True+isMap _       = False  -- | Test if term is a list-is_list Nil        = True-is_list (String _) = True-is_list (List _ _) = True-is_list _          = False+isList Nil        = True+isList (String _) = True+isList (List _ _) = True+isList _          = False  -- | Test if term is a binary-is_binary (Binary _) = True-is_binary _          = False+isBinary (Binary _) = True+isBinary _          = False  -------------------------------------------------------------------------------- node :: Term -> Term@@ -712,9 +722,9 @@ node (NewReference nodeName _creation _ids) = atom nodeName node term = error $ "Bad arg for node: " ++ show term -atom_name :: Term -> ByteString-atom_name (Atom name) = name-atom_name term        = error $ "Bad arg for atom_name: " ++ show term+atomName :: Term -> ByteString+atomName (Atom name) = name+atomName term        = error $ "Bad arg for atomName: " ++ show term  length :: Term -> Int length (Tuple  v  ) = V.length v@@ -726,38 +736,38 @@ element n (Tuple v) = v ! (n - 1) element _ term      = error $ "Not a tuple: " ++ show term -to_string :: Term -> Maybe ByteString-to_string (String bs) = Just bs-to_string _           = Nothing+toString :: Term -> Maybe ByteString+toString (String bs) = Just bs+toString _           = Nothing -to_integer :: Term -> Maybe Integer-to_integer (Integer i) = Just i-to_integer _           = Nothing+toIntegerTerm :: Term -> Maybe Integer+toIntegerTerm (Integer i) = Just i+toIntegerTerm _           = Nothing -match_tuple :: Term -> Maybe [Term]-match_tuple (Tuple v) = Just (toList v)-match_tuple _         = Nothing+matchTuple :: Term -> Maybe [Term]+matchTuple (Tuple v) = Just (toList v)+matchTuple _         = Nothing -match_atom :: Term -> ByteString -> Maybe ByteString-match_atom (Atom n) m | m == n    = Just n+matchAtom :: Term -> ByteString -> Maybe ByteString+matchAtom (Atom n) m | m == n    = Just n                       | otherwise = Nothing-match_atom _ _ = Nothing+matchAtom _ _ = Nothing  -------------------------------------------------------------------------------- instance Binary Term where     put (Integer i)         | i >= 0x00 && i <= 0xFF = do-              putWord8 small_integer_ext+              putWord8 smallIntegerExt               putWord8 (fromIntegral i)         | i >= -0x80000000 && i <= 0x7FFFFFFF = do-              putWord8 integer_ext+              putWord8 integerExt               putWord32be (fromIntegral i)         | otherwise =             -- NOTE: the biggest number presentable is 2^maxBits bits long where             -- maxBits = 2^32 * 8 = 2^35 - OTOH addressable main memory: 2^64 *             -- 8 bits = 2^67 bits, even with tomorrows 2048 bit address buses             -- for 256 bit words this would be at most 2^2056 addressable bits.-            -- large_big_ext allows 2^(2^35) = 2^34359738368 addressable bits ..+            -- largeBigIntegerExt allows 2^(2^35) = 2^34359738368 addressable bits ..             -- hence YES by all practical means 'otherwise' is the correct             -- function clause guard.            do let digits = L.unfoldr takeLSB (abs i)@@ -765,276 +775,192 @@                             | x == 0     = Nothing                             | otherwise = Just (fromIntegral (x Data.Bits..&. 0xff), x `shiftR` 8)               if L.length digits < 256-                then do putWord8 small_big_ext+                then do putWord8 smallBigIntegerExt                         putWord8 (fromIntegral (L.length digits))-                else do putWord8 large_big_ext+                else do putWord8 largeBigIntegerExt                         putWord32be (fromIntegral (L.length digits))               putWord8 (if i >= 0 then 0 else 1)               mapM_ putWord8 digits      put (Float d) = do-        putWord8 new_float_ext+        putWord8 newFloatExt         putDoublebe d      put (Atom n) = putAtom n      put (Reference nodeName id creation) = do-        putWord8 reference_ext+        putWord8 referenceExt         putAtom nodeName         putWord32be id         putWord8 creation      put (Port nodeName id creation) = do-        putWord8 port_ext+        putWord8 portExt         putAtom nodeName         putWord32be id         putWord8 creation      put (Pid nodeName id serial creation) = do-        putWord8 pid_ext+        putWord8 pidExt         putAtom nodeName         putWord32be id         putWord32be serial         putWord8 creation      put (Tuple v)-        | (V.length v) < 256 = do-              putWord8 small_tuple_ext+        | V.length v < 256 = do+              putWord8 smallTupleExt               putWord8 $ fromIntegral (V.length v)               mapM_ put v         | otherwise = do-              putWord8 large_tuple_ext+              putWord8 largeTupleExt               putWord32be $ fromIntegral (V.length v)               mapM_ put v      put (Map e) = do-        putWord8 map_ext+        putWord8 mapExt         putWord32be $ fromIntegral (V.length e)         mapM_ put e -    put Nil = putWord8 nil_ext+    put Nil = putWord8 nilExt      put (String s) = do-        putWord8 string_ext+        putWord8 stringExt         putLength16beByteString s      put (List v t) = do-        putWord8 list_ext+        putWord8 listExt         putWord32be $ fromIntegral (V.length v)         mapM_ put v         put t      put (Binary b) = do-        putWord8 binary_ext+        putWord8 binaryExt         putLength32beByteString b      put (NewReference node' creation ids) = do-        putWord8 new_reference_ext+        putWord8 newReferenceExt         putWord16be $ fromIntegral (L.length ids)         putAtom node'         putWord8 creation         mapM_ putWord32be ids-    get = lookAhead getWord8 >>= get'++    get = getWord8 >>= get'       where         get' :: Word8 -> Get Term         get' tag-            | tag == small_integer_ext =-                  getSmallInteger (Integer . fromIntegral)-            | tag == integer_ext = getInteger (Integer . toInteger . (fromIntegral :: Word32 -> Int32))-            | tag == small_big_ext = getWord8 *> getWord8    >>= getBigInteger . fromIntegral-            | tag == large_big_ext = getWord8 *> getWord32be >>= getBigInteger . fromIntegral-            | tag == atom_ext = getAtom Atom-            | tag == port_ext = getPort Port-            | tag == pid_ext = getPid Pid-            | tag == small_tuple_ext =-                  getSmallTuple Tuple-            | tag == large_tuple_ext =-                  getLargeTuple Tuple-            | tag == map_ext = getMap Map-            | tag == nil_ext = getNil (const Nil)-            | tag == string_ext = getString String-            | tag == list_ext = getList List-            | tag == binary_ext = getBinary Binary-            | tag == new_reference_ext =-                  getNewReference NewReference-            | tag == small_atom_ext = getSmallAtom Atom-            | tag == new_float_ext = getNewFloat Float+            | tag == smallIntegerExt = Integer . fromIntegral <$> getWord8+            | tag == integerExt = Integer . toInteger . (fromIntegral :: Word32 -> Int32) <$> getWord32be+            | tag == smallBigIntegerExt = getWord8    >>= getBigInteger . fromIntegral+            | tag == largeBigIntegerExt = getWord32be >>= getBigInteger . fromIntegral+            | tag == atomExt = Atom <$> getLength16beByteString+            | tag == portExt = matchWord8 atomExt *> (Port <$> getLength16beByteString <*> getWord32be <*> getWord8)+            | tag == pidExt = matchWord8 atomExt *> (Pid <$> getLength16beByteString <*> getWord32be <*> getWord32be <*> getWord8)+            | tag == smallTupleExt = Tuple <$> (getWord8 >>= _getVector . fromIntegral)+            | tag == largeTupleExt = Tuple <$> (getWord32be >>= _getVector . fromIntegral)+            | tag == mapExt = Map <$> (getWord32be >>= _getVector . fromIntegral)+            | tag == nilExt = pure Nil+            | tag == stringExt = String <$> getLength16beByteString+            | tag == listExt = List <$> (getWord32be >>= _getVector . fromIntegral) <*> get+            | tag == binaryExt = Binary <$> getLength32beByteString+            | tag == newReferenceExt = do+                      len <- getWord16be+                      matchWord8 atomExt+                      NewReference <$> getLength16beByteString <*> getWord8 <*> _getList (fromIntegral len)+            | tag == smallAtomExt = Atom <$> getLength8ByteString+            | tag == newFloatExt = Float <$> getDoublebe             | otherwise = fail $ "Unsupported tag: " ++ show tag  instance Binary MapEntry where     put MapEntry{key,value} = do         put key         put value-    get = do-        MapEntry <$> get <*> get+    get = MapEntry <$> get <*> get  ---------------------------------------------------------------------------------putTerm :: (ToTerm t) => t -> Put-putTerm t = do-    putWord8 magicVersion-    put (toTerm t) -putAtom :: ByteString -> Put+putAtom :: HasCallStack => ByteString -> Put putAtom a = do-    putWord8 atom_ext+    putWord8 atomExt     putLength16beByteString a  ---------------------------------------------------------------------------------getTerm :: Get Term-getTerm = do-    matchWord8 magicVersion-    get -getSmallInteger :: (Word8 -> a) -> Get a-getSmallInteger f = do-    matchWord8 small_integer_ext-    f <$> getWord8--getInteger :: (Word32 -> a) -> Get a-getInteger f = do-    matchWord8 integer_ext-    f <$> getWord32be--getBigInteger :: Int -> Get Term+getBigInteger :: HasCallStack => Int -> Get Term getBigInteger len = mkBigInteger <$> getWord8 <*> getByteString len   where     mkBigInteger signByte bs = Integer         ((if signByte == 0 then 1 else (-1)) * absInt)         where absInt = BS.foldr' (\b acc -> 256 * acc + fromIntegral b) 0 bs -getAtom :: (ByteString -> a) -> Get a-getAtom f = do-    matchWord8 atom_ext-    f <$> getLength16beByteString--getPort :: (ByteString -> Word32 -> Word8 -> a) -> Get a-getPort f = do-    matchWord8 port_ext-    f <$> getAtom P.id <*> getWord32be <*> getWord8--getPid :: (ByteString -> Word32 -> Word32 -> Word8 -> a) -> Get a-getPid f = do-    matchWord8 pid_ext-    f <$> getAtom P.id <*> getWord32be <*> getWord32be <*> getWord8--getSmallTuple :: (Vector Term -> a) -> Get a-getSmallTuple f = do-    matchWord8 small_tuple_ext-    f <$> (getWord8 >>= _getVector . fromIntegral)--getLargeTuple :: (Vector Term -> a) -> Get a-getLargeTuple f = do-    matchWord8 large_tuple_ext-    f <$> (getWord32be >>= _getVector . fromIntegral)--getMap :: (Vector MapEntry -> a) -> Get a-getMap f = do-    matchWord8 map_ext-    f <$> (getWord32be >>= _getVector . fromIntegral)--getNil :: (() -> a) -> Get a-getNil f =-    f <$> matchWord8 nil_ext--getString :: (ByteString -> a) -> Get a-getString f = do-    matchWord8 string_ext-    f <$> getLength16beByteString--getList :: (Vector Term -> Term -> a) -> Get a-getList f = do-    matchWord8 list_ext-    f <$> (getWord32be >>= _getVector . fromIntegral) <*> get--getBinary :: (ByteString -> a) -> Get a-getBinary f = do-    matchWord8 binary_ext-    f <$> getLength32beByteString--getNewReference :: (ByteString -> Word8 -> [Word32] -> a) -> Get a-getNewReference f = do-    matchWord8 new_reference_ext-    len <- getWord16be-    f <$> getAtom P.id <*> getWord8 <*> _getList (fromIntegral len)--getSmallAtom :: (ByteString -> a) -> Get a-getSmallAtom f = do-    matchWord8 small_atom_ext-    f <$> getLength8ByteString--getNewFloat :: (Double -> a) -> Get a-getNewFloat f = do-    matchWord8 new_float_ext-    f <$> getDoublebe- ---------------------------------------------------------------------------------_getVector :: Binary a => Int -> Get (Vector a)+_getVector :: HasCallStack => Binary a => Int -> Get (Vector a) _getVector len = V.replicateM len get -_getList :: Binary a => Int -> Get [a]+_getList :: HasCallStack => Binary a => Int -> Get [a] _getList len = M.replicateM len get  -------------------------------------------------------------------------------- magicVersion :: Word8 magicVersion = 131 -small_integer_ext, integer_ext, float_ext, atom_ext, reference_ext, port_ext, pid_ext+smallIntegerExt, integerExt, floatExt, atomExt, referenceExt, portExt, pidExt     :: Word8-small_tuple_ext, large_tuple_ext, map_ext, nil_ext, string_ext, list_ext, binary_ext+smallTupleExt, largeTupleExt, mapExt, nilExt, stringExt, listExt, binaryExt     :: Word8-small_big_ext, large_big_ext, new_reference_ext, small_atom_ext, fun_ext, new_fun_ext+smallBigIntegerExt, largeBigIntegerExt, newReferenceExt, smallAtomExt, functionExt, newFunctionExt     :: Word8-export_ext, bit_binary_ext, new_float_ext, atom_utf8_ext, small_atom_utf8_ext+exportExt, bitBinaryExt, newFloatExt, atomUtf8Ext, smallAtomUtf8Ext     :: Word8-small_integer_ext = 97+smallIntegerExt = 97 -integer_ext = 98+integerExt = 98 -float_ext = 99+floatExt = 99 -atom_ext = 100+atomExt = 100 -reference_ext = 101+referenceExt = 101 -port_ext = 102+portExt = 102 -pid_ext = 103+pidExt = 103 -small_tuple_ext = 104+smallTupleExt = 104 -large_tuple_ext = 105+largeTupleExt = 105 -map_ext = 116+mapExt = 116 -nil_ext = 106+nilExt = 106 -string_ext = 107+stringExt = 107 -list_ext = 108+listExt = 108 -binary_ext = 109+binaryExt = 109 -small_big_ext = 110+smallBigIntegerExt = 110 -large_big_ext = 111+largeBigIntegerExt = 111 -new_reference_ext = 114+newReferenceExt = 114 -small_atom_ext = 115+smallAtomExt = 115 -fun_ext = 117+functionExt = 117 -new_fun_ext = 112+newFunctionExt = 112 -export_ext = 113+exportExt = 113 -bit_binary_ext = 77+bitBinaryExt = 77 -new_float_ext = 70+newFloatExt = 70 -atom_utf8_ext = 118+atomUtf8Ext = 118 -small_atom_utf8_ext = 119+smallAtomUtf8Ext = 119  instance Arbitrary Term where     arbitrary = oneof [ atom <$> scale (`div` 2) arbitraryUnquotedAtom@@ -1051,6 +977,7 @@                       , (toTerm :: Pid -> Term) <$> scale smaller arbitrary                       , float <$> scale smaller arbitrary                       , (toTerm :: Integer -> Term) <$> scale smaller arbitrary+                      , Binary . pack <$> arbitrary                       ]  smaller :: (Eq a, Num a) => a -> a@@ -1059,7 +986,7 @@  arbitraryUnquotedAtom :: Gen CS.ByteString arbitraryUnquotedAtom =-    CS.pack <$> (listOf1 (elements (['a' .. 'z'] ++ ['_'] ++ ['0' .. '9'])))+  CS.pack <$> listOf1 (elements (['a' .. 'z'] ++ ['_'] ++ ['0' .. '9']))  instance Arbitrary Pid where     arbitrary = pid <$> scale smaller arbitraryUnquotedAtom

@@ -41,9 +41,10 @@ import           Util.FloatCast #endif import           Util.IOExtra+import GHC.Stack (HasCallStack)  ---------------------------------------------------------------------------------runGetA :: (Monad m)+runGetA :: (HasCallStack, Monad m)         => (Int -> m BS.ByteString)         -> (BS.ByteString -> m ())         -> Get a@@ -68,7 +69,7 @@  instance Exception BinaryGetError -runPutA :: (LBS.ByteString -> m ()) -> Put -> m ()+runPutA :: HasCallStack => (LBS.ByteString -> m ()) -> Put -> m () runPutA = (. runPut)  #if !MIN_VERSION_binary(0,8,5)@@ -76,62 +77,62 @@ ------------------------------------------------------------------------ -- Floats/Doubles -- | Write a 'Float' in big endian IEEE-754 format.-putFloatbe :: Float -> Put+putFloatbe :: HasCallStack => Float -> Put putFloatbe = putWord32be . floatToWord  {-# INLINE putFloatbe #-}  -- | Write a 'Float' in little endian IEEE-754 format.-putFloatle :: Float -> Put+putFloatle :: HasCallStack => Float -> Put putFloatle = putWord32le . floatToWord  {-# INLINE putFloatle #-}  -- | Write a 'Float' in native in IEEE-754 format and host endian.-putFloathost :: Float -> Put+putFloathost :: HasCallStack => Float -> Put putFloathost = putWord32host . floatToWord  {-# INLINE putFloathost #-}  -- | Write a 'Double' in big endian IEEE-754 format.-putDoublebe :: Double -> Put+putDoublebe :: HasCallStack => Double -> Put putDoublebe = putWord64be . doubleToWord  {-# INLINE putDoublebe #-}  -- | Write a 'Double' in little endian IEEE-754 format.-putDoublele :: Double -> Put+putDoublele :: HasCallStack => Double -> Put putDoublele = putWord64le . doubleToWord  {-# INLINE putDoublele #-}  -- | Write a 'Double' in native in IEEE-754 format and host endian.-putDoublehost :: Double -> Put+putDoublehost :: HasCallStack => Double -> Put putDoublehost = putWord64host . doubleToWord  {-# INLINE putDoublehost #-} #endif  ---------------------------------------------------------------------------------putLength16beByteString :: BS.ByteString -> Put+putLength16beByteString :: HasCallStack => BS.ByteString -> Put putLength16beByteString bs = do     putWord16be (fromIntegral (BS.length bs))     putByteString bs -putLength32beByteString :: BS.ByteString -> Put+putLength32beByteString :: HasCallStack => BS.ByteString -> Put putLength32beByteString bs = do     putWord32be (fromIntegral (BS.length bs))     putByteString bs  ---------------------------------------------------------------------------------putWithLength16be :: Put -> Put+putWithLength16be :: HasCallStack => Put -> Put putWithLength16be putA = do     let bl = runPut putA         len = LBS.length bl     putWord16be (fromIntegral len)     putLazyByteString bl -putWithLength32be :: Put -> Put+putWithLength32be :: HasCallStack => Put -> Put putWithLength32be putA = do     let bl = runPut putA         len = LBS.length bl@@ -139,67 +140,66 @@     putLazyByteString bl  ---------------------------------------------------------------------------------putChar8 :: Char -> Put-putChar8 c = do-    putWord8 $ fromIntegral $ ord c+putChar8 :: HasCallStack => Char -> Put+putChar8 = putWord8 . fromIntegral . ord -getChar8 :: Get Char-getChar8 = (chr . fromIntegral) <$> getWord8+getChar8 :: HasCallStack => Get Char+getChar8 = chr . fromIntegral <$> getWord8  #if !MIN_VERSION_binary(0,8,5) ------------------------------------------------------------------------ -- Double/Float reads -- | Read a 'Float' in big endian IEEE-754 format.-getFloatbe :: Get Float+getFloatbe :: HasCallStack => Get Float getFloatbe = wordToFloat <$> getWord32be  {-# INLINE getFloatbe #-}  -- | Read a 'Float' in little endian IEEE-754 format.-getFloatle :: Get Float+getFloatle :: HasCallStack => Get Float getFloatle = wordToFloat <$> getWord32le  {-# INLINE getFloatle #-}  -- | Read a 'Float' in IEEE-754 format and host endian.-getFloathost :: Get Float+getFloathost :: HasCallStack => Get Float getFloathost = wordToFloat <$> getWord32host  {-# INLINE getFloathost #-}  -- | Read a 'Double' in big endian IEEE-754 format.-getDoublebe :: Get Double+getDoublebe :: HasCallStack => Get Double getDoublebe = wordToDouble <$> getWord64be  {-# INLINE getDoublebe #-}  -- | Read a 'Double' in little endian IEEE-754 format.-getDoublele :: Get Double+getDoublele :: HasCallStack => Get Double getDoublele = wordToDouble <$> getWord64le  {-# INLINE getDoublele #-}  -- | Read a 'Double' in IEEE-754 format and host endian.-getDoublehost :: Get Double+getDoublehost :: HasCallStack => Get Double getDoublehost = wordToDouble <$> getWord64host  {-# INLINE getDoublehost #-} #endif  ---------------------------------------------------------------------------------getLength8ByteString :: Get BS.ByteString+getLength8ByteString :: HasCallStack => Get BS.ByteString getLength8ByteString = getWord8 >>= getByteString . fromIntegral -getLength16beByteString :: Get BS.ByteString+getLength16beByteString :: HasCallStack => Get BS.ByteString getLength16beByteString =     getWord16be >>= getByteString . fromIntegral -getLength32beByteString :: Get BS.ByteString+getLength32beByteString :: HasCallStack => Get BS.ByteString getLength32beByteString =     getWord32be >>= getByteString . fromIntegral  ---------------------------------------------------------------------------------getWithLength16be :: Get a -> Get (a, Word16)+getWithLength16be :: HasCallStack => Get a -> Get (a, Word16) getWithLength16be getA = do     pos0 <- bytesRead     res <- getA@@ -207,11 +207,10 @@     return (res, fromIntegral (pos1 - pos0))  ---------------------------------------------------------------------------------matchWord8 :: Word8 -> Get ()+matchWord8 :: HasCallStack => Word8 -> Get () matchWord8 expected = do     actual <- getWord8     if expected == actual then return () else fail $ "expected " ++ show expected ++ ", actual " ++ show actual -matchChar8 :: Char -> Get ()-matchChar8 expected = do-    matchWord8 $ fromIntegral $ ord expected+matchChar8 :: HasCallStack => Char -> Get ()+matchChar8 = matchWord8 . fromIntegral . ord

@@ -11,7 +11,6 @@ import           Data.Binary                    ( decode                                                 , encode                                                 )-import           Data.ByteString.Char8          ( ) import qualified Data.ByteString.Lazy          as B import           Data.Word                      ( ) import           Data.List.NonEmpty             (NonEmpty(..))@@ -19,335 +18,339 @@ import           Test.Hspec import           Test.QuickCheck import           Data.Vector                    ( fromList )+-- import           Debug.Trace -spec :: Spec+traceShowIdBS :: B.ByteString -> B.ByteString+traceShowIdBS bs = bs+-- traceShowIdBS bs = traceShow (B.unpack bs) bs++spec :: HasCallStack => Spec spec = do+  describe "Binary instances of arbitrary ExternalTerm" $+    it "decode . encode = id" $+    property $ \(t :: ExternalTerm) -> decode (traceShowIdBS (encode t)) === t+  describe "Binary instances of arbitrary Term" $+    it "decode . encode = id" $+    property $ \(MkExternalTerm t) -> decode (traceShowIdBS (encode t)) === t   describe "Pid" $ do-    it "has a Binary instance such that decode is the inverse of encode"-      $ property-      $ \(p :: Pid) -> fromTerm (decode (encode (toTerm p))) `shouldBe` (Just p)-    it "represents all valid Erlang pids" $ property $ \x y z ->-      let p = pid "nodename" x y z-      in  fromTerm (decode (encode (toTerm p))) `shouldBe` (Just p)+    it "has a Binary instance such that decode is the inverse of encode" $+      property $ \(p :: Pid) ->+        fromTerm (decode (encode (toTerm p))) `shouldBe` Just p+    it "represents all valid Erlang pids" $+      property $ \x y z ->+        let p = pid "nodename" x y z+         in fromTerm (decode (encode (toTerm p))) `shouldBe` Just p   describe "FromTerm/ToTerm" $ do-    it "converts '[a]' back and forth"-      $ property-      $ \(xs :: [Integer]) -> fromTerms (toTerms xs) `shouldBe` Just xs-    it "converts 'Maybe a' back and forth"-      $ property-      $ \(x :: Maybe Bool) -> fromTerm (toTerm x) `shouldBe` Just x-    it "converts 'Either a b' back and forth"-      $ property-      $ \(x :: Either Integer Double) -> fromTerm (toTerm x) `shouldBe` Just x-    it "converts 'NonEmpty a' back and forth"-      $ property-      $ \(h :: Integer) (t :: [Integer]) -> let xs = h :| t in fromTerm (toTerm xs) `shouldBe` Just xs-  describe "Integer"-    $ it "has a Binary instance such that decode is the inverse of encode"-    $ property-    $ \(i :: Integer) ->-        fromTerm (decode (encode (integer i))) `shouldBe` (Just i)-  describe "The largest small_big_ext Integer" $ do+    it "converts '[Integer]' back and forth" $+      property $ \(xs :: [Integer]) -> fromTerms (toTerms xs) `shouldBe` Just xs+    it "converts 'Maybe Bool' back and forth" $+      property $ \(x :: Maybe Bool) -> fromTerm (toTerm x) `shouldBe` Just x+    it "converts 'Either a b' back and forth" $+      property $ \(x :: Either Integer Double) ->+        fromTerm (toTerm x) `shouldBe` Just x+    it "converts 'NonEmpty a' back and forth" $+      property $ \(h :: Integer) (t :: [Integer]) ->+        let xs = h :| t+         in fromTerm (toTerm xs) `shouldBe` Just xs+  describe "Integer" $+    it "has a Binary instance such that decode is the inverse of encode" $+    property $ \(i :: Integer) ->+      fromTerm (decode (encode (integer i))) `shouldBe` Just i+  describe "The largest smallBigIntegerExt Integer" $ do     let i = 2 ^ (8 * 255) - 1-    it "has a Binary instance such that decode is the inverse of encode"-      $          fromTerm (decode (encode (integer i)))-      `shouldBe` (Just i)-    it "is converted to a valid erlang binary"-      $          B.unpack (encode (integer i))-      `shouldBe` [ 110-                 , 255-                 , 0-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 , 255-                 ]-  describe "The smallest large_big_ext Integer"-    $ it "has a Binary instance such that decode is the inverse of encode"-    $ let i = 2 ^ (8 * 255)-      in  fromTerm (decode (encode (integer i))) `shouldBe` (Just i)+    it "has a Binary instance such that decode is the inverse of encode" $+      fromTerm (decode (encode (integer i))) `shouldBe` Just i+    it "is converted to a valid erlang binary" $+      B.unpack (encode (integer i)) `shouldBe`+      [ 110+      , 255+      , 0+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      , 255+      ]+  describe "The smallest largeBigIntegerExt Integer" $+    it "has a Binary instance such that decode is the inverse of encode" $+    let i = 2 ^ (8 * 255)+     in fromTerm (decode (encode (integer i))) `shouldBe` Just i   describe "Term" $ do-    it "has a Binary instance such that decode is the inverse of encode"-      $ property-      $ \(t :: Term) -> decode (encode t) `shouldBe` t-    it "has an IsString instance that makes atoms" $ "testatom" `shouldBe` atom-      "testatom"+    it "has a Binary instance such that decode is the inverse of encode" $+      property $ \(t :: Term) -> decode (encode t) `shouldBe` t+    it "has an IsString instance that makes atoms" $+      "testatom" `shouldBe` atom "testatom"     describe "Pattern Synonyms" $ do       it "Tuple3" $ do-        toTerm (Atom "test-atom", integer 1, integer 2)-          `shouldBe` Tuple3 "test-atom" (integer 1) (integer 2)+        toTerm (Atom "test-atom", integer 1, integer 2) `shouldBe`+          Tuple3 "test-atom" (integer 1) (integer 2)         (case toTerm (Atom "test-atom", integer 1, integer 2) of-            Tuple3 "test-atom" _ _ -> True-            _                      -> False-          )-          `shouldBe` True+           Tuple3 "test-atom" _ _ -> True+           _ -> False) `shouldBe`+          True       it "List4" $ do-        List (fromList [integer 0, integer 1, integer 2]) Nil-          `shouldBe` toTerm (List3 (integer 0) (integer 1) (integer 2))+        List (fromList [integer 0, integer 1, integer 2]) Nil `shouldBe`+          toTerm (List3 (integer 0) (integer 1) (integer 2))         (case List (fromList [integer 0, integer 1, integer 2]) Nil of-            List3 _ _ _ -> True-            _           -> False-          )-          `shouldBe` True+           List3 {} -> True+           _ -> False) `shouldBe`+          True       it "Map2" $ do-        Map (fromList [MapEntry "k1" "v1", MapEntry "k2" "v2"])-          `shouldBe` toTerm (Map2 ("k1" :=> "v1") ("k2" :=> "v2"))+        Map (fromList [MapEntry "k1" "v1", MapEntry "k2" "v2"]) `shouldBe`+          toTerm (Map2 ("k1" :=> "v1") ("k2" :=> "v2"))         (case Map (fromList [MapEntry "k1" "v1", MapEntry "k2" "v2"]) of-            Map2 ("k1" :=> "v1") ("k2" :=> "v2") -> True-            _           -> False-          )-          `shouldBe` True-      it "has an IsList that generates lists" $ do-        ["a1", "a2"]-          `shouldBe` toTerm (List (fromList ["a1", "a2"]) Nil)+           Map2 ("k1" :=> "v1") ("k2" :=> "v2") -> True+           _ -> False) `shouldBe`+          True+      it "has an IsList that generates lists" $+        ["a1", "a2"] `shouldBe` toTerm (List (fromList ["a1", "a2"]) Nil)