hinterface 0.6.0.0 → 0.7.0
raw patch · 2 files changed
+181/−127 lines, 2 filesdep +deepseqdep ~asyncdep ~binarydep ~bytestring
Dependencies added: deepseq
Dependency ranges changed: async, binary, bytestring, containers, hspec, monad-logger, network, stm, transformers
Files
- hinterface.cabal +11/−10
- src/Foreign/Erlang/Term.hs +170/−117
hinterface.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.22 name: hinterface-version: 0.6.0.0+version: 0.7.0 license: BSD3 license-file: LICENSE copyright: 2016-2018 Timo Koepke, Sven Heyll@@ -58,8 +58,9 @@ base >=4.9 && <5, binary >=0.8.5.1 && <0.9, bytestring >=0.10.8.2 && <0.11,- containers >=0.5.11.0 && <0.6,+ containers >=0.5.11.0 && <0.7, cryptonite ==0.25.*,+ deepseq ==1.4.*, exceptions >=0.10.0 && <0.11, lifted-async >=0.10.0.2 && <0.11, lifted-base >=0.2.3.12 && <0.3,@@ -67,11 +68,11 @@ monad-control >=1.0.2.3 && <1.1, monad-logger >=0.3.29 && <0.4, mtl >=2.2.2 && <2.3,- network >=2.6.3.6 && <2.7,+ network >=2.6.3.6 && <2.9, random ==1.1.*, resourcet >=1.2.1 && <1.3, safe-exceptions >=0.1.7.0 && <0.2,- stm >=2.4.5.0 && <2.5,+ stm >=2.4.5.0 && <2.6, text >=1.2.3.0 && <1.3, transformers >=0.5.5.0 && <0.6, transformers-base >=0.4.5.2 && <0.5,@@ -91,11 +92,11 @@ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: QuickCheck >=2.11.3 && <2.12,- async >=2.2.1 && <2.3,+ async >=2.2.1, base >=4.9 && <5,- binary >=0.8.5.1 && <0.9,- bytestring >=0.10.8.2 && <0.11,+ binary >=0.8.5.1,+ bytestring >=0.10.8.2, hinterface -any,- hspec >=2.5.5 && <2.6,- monad-logger >=0.3.29 && <0.4,- transformers >=0.5.5.0 && <0.6+ hspec >=2.4 && <2.6,+ monad-logger >=0.3.29,+ transformers >=0.5.5.0
src/Foreign/Erlang/Term.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE Strict #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -53,29 +54,61 @@ -- ** Matchers , match_atom , match_tuple- ) where+ )+where import GHC.TypeLits-import Prelude hiding ( id, length )-import qualified Prelude as P ( id )-import Control.Applicative ( Alternative(..) )-import Control.Category ( (>>>) )-import Control.Monad as M ( replicateM )+import Prelude hiding ( id+ , length+ )+import qualified Prelude as P+ ( id )+import Control.Applicative ( Alternative(..) )+import Control.Category ( (>>>) )+import Control.DeepSeq+import Control.Monad as M+ ( replicateM ) import Data.String-import Data.ByteString ( ByteString )-import Data.ByteString.Char8 ( unpack )-import qualified Data.ByteString as BS ( head, length, tail, unpack, foldr' )-import qualified Data.ByteString.Char8 as CS ( ByteString, pack, unpack )-import Data.Vector ( (!), Vector, fromList, toList )-import qualified Data.Vector as V ( length, replicateM, tail )-import qualified Data.List as L ( length, unfoldr, length )+import Data.ByteString ( ByteString )+import Data.ByteString.Char8 ( unpack )+import qualified Data.ByteString as BS+ ( head+ , length+ , tail+ , unpack+ , foldr'+ )+import qualified Data.ByteString.Char8 as CS+ ( ByteString+ , pack+ , unpack+ )+import Data.Vector ( (!)+ , Vector+ , fromList+ , toList+ )+import qualified Data.Vector as V+ ( length+ , replicateM+ , tail+ )+import qualified Data.List as L+ ( length+ , unfoldr+ , length+ ) import Data.Binary import Data.Binary.Put-import Data.Binary.Get hiding ( getBytes )+import Data.Binary.Get hiding ( getBytes ) import Util.Binary import Test.QuickCheck import Data.Int-import Data.Bits (shiftR, (.&.))+import Data.Bits ( shiftR+ , (.&.)+ )+import Data.Monoid+import GHC.Generics -------------------------------------------------------------------------------- data Term = Integer Integer@@ -91,13 +124,17 @@ | List (Vector Term) Term | Binary ByteString | NewReference ByteString Word8 [Word32]- deriving (Eq)+ deriving (Eq, Generic) +instance NFData Term+ data MapEntry = MapEntry { key :: Term , value :: Term }- deriving (Eq)+ deriving (Eq, Generic) +instance NFData MapEntry+ -- number < atom < reference < fun < port < pid < tuple < map < nil < list < bit string instance Ord Term where (Integer i) `compare` (Integer i') =@@ -175,40 +212,48 @@ (k, v) `compare` (k', v') -- FIXME integer keys are less than float keys instance Show Term where- show (Integer i) = show i- show (Float d) = show d- show (Atom a) = "'" ++ unpack a ++ "'"- show (Reference nodeName id _creation) =- "#Ref<" ++ unpack nodeName ++ "." ++ show id ++ ">"- show (Port nodeName id _creation) =- "#Port<" ++ unpack nodeName ++ "." ++ show id ++ ">"- show (Pid nodeName id serial _creation) =- "#Pid<" ++ unpack nodeName ++ "." ++ show id ++ "." ++ show serial ++ ">"- show (Tuple v) = "{" ++ showVectorAsList v ++ "}"- show (Map e) = "#{" ++ showVectorAsList e ++ "}"- show Nil = "[]"- show (String s) = show s- show (List v Nil) = "[" ++ showVectorAsList v ++ "]"- show (List v t) = "[" ++ showVectorAsList v ++ "|" ++ show t ++ "]"- show (Binary b) = "<<" ++ showByteStringAsIntList b ++ ">>"- show (NewReference nodeName _creation ids) =- "#Ref<" ++ unpack nodeName ++ concat (map (\id -> "." ++ show id) ids) ++ ">"+ showsPrec _ (Integer i) = shows i+ showsPrec _ (Float d) = shows d+ showsPrec _ (Atom a) = showChar '\'' . showString (unpack a) . showChar '\''+ showsPrec _ (Reference nodeName id _creation) =+ showString "#Ref<" . showString (unpack nodeName) . showChar '.' . shows id . showChar '>'+ showsPrec _ (Port nodeName id _creation) =+ showString "#Port<" . showString (unpack nodeName) . showChar '.' . shows id . showChar '>'+ showsPrec _ (Pid nodeName id serial _creation) =+ showString "#Pid<" . showString (unpack nodeName) . showChar '.' . shows id . showChar '.' . shows serial . showChar '>'+ showsPrec _ (Tuple v) = showChar '{' . showsVectorAsList v . showChar '}'+ showsPrec _ (Map e) = showString "#{" . showsVectorAsList e . showChar '}'+ showsPrec _ Nil = showString "[]"+ showsPrec _ (String s) = shows s+ showsPrec _ (List v Nil) = showChar '[' . showsVectorAsList v . showChar ']'+ showsPrec _ (List v t) = showChar '[' . showsVectorAsList v . showChar '|' . shows t . showChar ']'+ showsPrec _ (Binary b) = showString "<<" . showsByteStringAsIntList b . showString ">>"+ showsPrec _ (NewReference nodeName _creation ids) =+ showString "#Ref<" . showString (unpack nodeName) . appEndo (foldMap (\i -> Endo (showChar '.' . shows i)) ids) . showChar '>' instance Show MapEntry where- show MapEntry{key,value} =- show key ++ " => " ++ show value+ showsPrec _ MapEntry{key,value} =+ shows key . showString " => " . shows value -showVectorAsList :: Show a => (Vector a) -> String-showVectorAsList v- | V.length v == 0 = ""- | V.length v == 1 = show (v ! 0)- | otherwise = show (v ! 0) ++ concat (map (\t -> "," ++ show t) $ toList $ V.tail v)+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)) -showByteStringAsIntList :: ByteString -> String-showByteStringAsIntList b- | BS.length b == 0 = ""- | BS.length b == 1 = show (BS.head b)- | otherwise = show (BS.head b) ++ concat (map (\t -> "," ++ show t) $ BS.unpack $ BS.tail b)+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))+ ) instance IsString Term where fromString = atom . CS.pack@@ -227,9 +272,8 @@ fromTerm :: Term -> Maybe a fromTermA :: (FromTerm a, Alternative m) => Term -> m a-fromTermA t =- case fromTerm t of- Just x -> pure x+fromTermA t = case fromTerm t of+ Just x -> pure x Nothing -> empty instance FromTerm () where@@ -298,8 +342,9 @@ -------------------------------------------------------------------------------- -- | Construct an integer-integer :: Integer -- ^ Int- -> Term+integer+ :: Integer -- ^ Int+ -> Term integer = Integer -- | A static/constant number.@@ -320,13 +365,15 @@ toTerm = integer . natVal -- | Construct a float-float :: Double -- ^ IEEE float- -> Term+float+ :: Double -- ^ IEEE float+ -> Term float = Float -- | Construct an atom-atom :: ByteString -- ^ AtomName- -> Term+atom+ :: ByteString -- ^ AtomName+ -> Term atom = Atom -- | A static/constant atom.@@ -345,13 +392,15 @@ -- reference -- | Construct a port-port :: ByteString -- ^ Node name- -> Word32 -- ^ ID- -> Word8 -- ^ Creation- -> Term+port+ :: ByteString -- ^ Node name+ -> Word32 -- ^ ID+ -> Word8 -- ^ Creation+ -> Term port = Port -pid :: ByteString -- ^ Node name+pid+ :: ByteString -- ^ Node name -> Word32 -- ^ ID -> Word32 -- ^ Serial -> Word8 -- ^ Creation@@ -365,8 +414,9 @@ show (MkPid p) = show p -- | Construct a tuple-tuple :: [Term] -- ^ Elements- -> Term+tuple+ :: [Term] -- ^ Elements+ -> Term tuple = Tuple . fromList newtype Tuple1 a = Tuple1 a@@ -377,122 +427,118 @@ -- map -- | Construct a list-string :: ByteString -- ^ Characters- -> Term+string+ :: ByteString -- ^ Characters+ -> Term string = String -- | Construct a list-list :: [Term] -- ^ Elements- -> Term+list+ :: [Term] -- ^ Elements+ -> Term list [] = Nil list ts = improperList ts Nil -- | Construct an improper list (if Tail is not Nil)-improperList :: [Term] -- ^ Elements- -> Term -- ^ Tail- -> Term+improperList+ :: [Term] -- ^ Elements+ -> Term -- ^ Tail+ -> Term improperList [] _ = error "Illegal improper list" improperList ts t = List (fromList ts) t -- FIXME could check if is string -- binary -- | Construct a new reference-ref :: ByteString -- ^ Node name+ref+ :: ByteString -- ^ Node name -> Word8 -- ^ Creation -> [Word32] -- ^ ID ... -> Term ref = NewReference ---------------------------------------------------------------------------------is_integer, is_float, is_atom, is_reference, is_port, is_pid, is_tuple, is_map, is_list, is_binary :: Term -> Bool+is_integer, is_float, is_atom, is_reference, is_port, is_pid, is_tuple, is_map, is_list, is_binary+ :: Term -> Bool -- | Test if term is an integer-is_integer (Integer _) =- True-is_integer _ = False+is_integer (Integer _) = True+is_integer _ = False -- | Test if term is a float is_float (Float _) = True-is_float _ = False+is_float _ = False -- | Test if term is an atom is_atom (Atom _) = True-is_atom _ = False+is_atom _ = False -- | Test if term is a reference-is_reference (Reference _ _ _) =- True-is_reference (NewReference _ _ _) =- True-is_reference _ = False+is_reference (Reference _ _ _) = True+is_reference (NewReference _ _ _) = True+is_reference _ = False -- | Test if term is a port is_port (Port _ _ _) = True-is_port _ = False+is_port _ = False -- | Test if term is a pid is_pid (Pid _ _ _ _) = True-is_pid _ = False+is_pid _ = False -- | Test if term is a tuple is_tuple (Tuple _) = True-is_tuple _ = False+is_tuple _ = False -- | Test if term is a map is_map (Map _) = True-is_map _ = False+is_map _ = False -- | Test if term is a list-is_list Nil = True+is_list Nil = True is_list (String _) = True is_list (List _ _) = True-is_list _ = False+is_list _ = False -- | Test if term is a binary is_binary (Binary _) = True-is_binary _ = False+is_binary _ = False -------------------------------------------------------------------------------- node :: Term -> Term-node (Reference nodeName _id _creation) =- atom nodeName-node (Port nodeName _id _creation) =- atom nodeName-node (Pid nodeName _id _serial _creation) =- atom nodeName-node (NewReference nodeName _creation _ids) =- atom nodeName+node (Reference nodeName _id _creation) = atom nodeName+node (Port nodeName _id _creation) = atom nodeName+node (Pid nodeName _id _serial _creation) = atom nodeName+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+atom_name term = error $ "Bad arg for atom_name: " ++ show term length :: Term -> Int-length (Tuple v) = V.length v-length (String bs) = BS.length bs+length (Tuple v ) = V.length v+length (String bs ) = BS.length bs length (List v Nil) = V.length v-length term = error $ "Bad arg for length: " ++ show term+length term = error $ "Bad arg for length: " ++ show term element :: Int -> Term -> Term element n (Tuple v) = v ! (n - 1)-element _ term = error $ "Not a tuple: " ++ show term+element _ term = error $ "Not a tuple: " ++ show term to_string :: Term -> Maybe ByteString to_string (String bs) = Just bs-to_string _ = Nothing+to_string _ = Nothing to_integer :: Term -> Maybe Integer-to_integer (Integer i) =- Just i-to_integer _ = Nothing+to_integer (Integer i) = Just i+to_integer _ = Nothing match_tuple :: Term -> Maybe [Term] match_tuple (Tuple v) = Just (toList v)-match_tuple _ = Nothing+match_tuple _ = Nothing match_atom :: Term -> ByteString -> Maybe ByteString-match_atom (Atom n) m- | m == n = Just n- | otherwise = Nothing+match_atom (Atom n) m | m == n = Just n+ | otherwise = Nothing match_atom _ _ = Nothing --------------------------------------------------------------------------------@@ -652,8 +698,10 @@ getBigInteger :: 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+ 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@@ -731,10 +779,14 @@ magicVersion :: Word8 magicVersion = 131 -small_integer_ext, integer_ext, float_ext, atom_ext, reference_ext, port_ext, pid_ext :: Word8-small_tuple_ext, large_tuple_ext, map_ext, nil_ext, string_ext, list_ext, binary_ext :: Word8-small_big_ext, large_big_ext, new_reference_ext, small_atom_ext, fun_ext, new_fun_ext :: Word8-export_ext, bit_binary_ext, new_float_ext, atom_utf8_ext, small_atom_utf8_ext :: Word8+small_integer_ext, integer_ext, float_ext, atom_ext, reference_ext, port_ext, pid_ext+ :: Word8+small_tuple_ext, large_tuple_ext, map_ext, nil_ext, string_ext, list_ext, binary_ext+ :: Word8+small_big_ext, large_big_ext, new_reference_ext, small_atom_ext, fun_ext, new_fun_ext+ :: Word8+export_ext, bit_binary_ext, new_float_ext, atom_utf8_ext, small_atom_utf8_ext+ :: Word8 small_integer_ext = 97 integer_ext = 98@@ -807,7 +859,8 @@ smaller n = n - 1 arbitraryUnquotedAtom :: Gen CS.ByteString-arbitraryUnquotedAtom = CS.pack <$> (listOf1 (elements (['a' .. 'z'] ++ [ '_' ] ++ ['0' .. '9'])))+arbitraryUnquotedAtom =+ CS.pack <$> (listOf1 (elements (['a' .. 'z'] ++ ['_'] ++ ['0' .. '9']))) instance Arbitrary Pid where arbitrary = pid <$> scale smaller arbitraryUnquotedAtom