diff --git a/hinterface.cabal b/hinterface.cabal --- a/hinterface.cabal +++ b/hinterface.cabal @@ -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 diff --git a/src/Foreign/Erlang/ControlMessage.hs b/src/Foreign/Erlang/ControlMessage.hs --- a/src/Foreign/Erlang/ControlMessage.hs +++ b/src/Foreign/Erlang/ControlMessage.hs @@ -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 diff --git a/src/Foreign/Erlang/LocalNode.hs b/src/Foreign/Erlang/LocalNode.hs --- a/src/Foreign/Erlang/LocalNode.hs +++ b/src/Foreign/Erlang/LocalNode.hs @@ -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) diff --git a/src/Foreign/Erlang/NodeData.hs b/src/Foreign/Erlang/NodeData.hs --- a/src/Foreign/Erlang/NodeData.hs +++ b/src/Foreign/Erlang/NodeData.hs @@ -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) diff --git a/src/Foreign/Erlang/Term.hs b/src/Foreign/Erlang/Term.hs --- a/src/Foreign/Erlang/Term.hs +++ b/src/Foreign/Erlang/Term.hs @@ -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 diff --git a/src/Util/Binary.hs b/src/Util/Binary.hs --- a/src/Util/Binary.hs +++ b/src/Util/Binary.hs @@ -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 diff --git a/test/Foreign/Erlang/TermSpec.hs b/test/Foreign/Erlang/TermSpec.hs --- a/test/Foreign/Erlang/TermSpec.hs +++ b/test/Foreign/Erlang/TermSpec.hs @@ -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)