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