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.7.0 +version: 0.8.0 license: BSD3 license-file: LICENSE copyright: 2016-2018 Timo Koepke, Sven Heyll @@ -49,7 +49,7 @@ hs-source-dirs: src default-language: Haskell2010 default-extensions: OverloadedStrings NamedFieldPuns - FlexibleContexts + FlexibleContexts PatternSynonyms ViewPatterns ghc-options: -Wall -O2 -funbox-strict-fields build-depends: QuickCheck >=2.11.3 && <2.12, @@ -98,5 +98,6 @@ bytestring >=0.10.8.2, hinterface -any, hspec >=2.4 && <2.6, - monad-logger >=0.3.29, - transformers >=0.5.5.0 + monad-logger >=0.3.30, + transformers >=0.5.5.0, + vector >=0.12.0.1 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 @@ -5,13 +5,37 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} module Foreign.Erlang.Term ( -- * External Term Format - Term() + Term(.. + , Tuple2 + , Tuple3 + , Tuple4 + , Tuple5 + , Tuple6 + , Tuple7 + , List1 + , List2 + , List3 + , List4 + , List5 + , List6 + , List7 + , Map1 + , Map2 + , Map3 + , Map4 + , Map5 + , Map6 + , Map7 + ) , putTerm , getTerm + , MapEntry(.., (:=>)) -- ** Conversion to and from External Term Format , ToTerm(..) , FromTerm(..) @@ -85,8 +109,6 @@ ) import Data.Vector ( (!) , Vector - , fromList - , toList ) import qualified Data.Vector as V ( length @@ -108,9 +130,11 @@ , (.&.) ) import Data.Monoid +import GHC.Exts as E import GHC.Generics -------------------------------------------------------------------------------- + data Term = Integer Integer | Float Double | Atom ByteString @@ -128,6 +152,105 @@ instance NFData Term +-- ** Pattern Synonyms for 'Term's +pattern Tuple2 :: Term -> Term -> Term +pattern Tuple2 t1 t2 <- Tuple (toList -> [t1,t2]) where + Tuple2 t1 t2 = Tuple (fromList [t1,t2]) + +pattern Tuple3 :: Term -> Term -> Term -> Term +pattern Tuple3 t1 t2 t3 <- Tuple (toList -> [t1,t2,t3]) where + Tuple3 t1 t2 t3 = Tuple (fromList [t1,t2,t3]) + +pattern Tuple4 :: Term -> Term -> Term -> Term -> Term +pattern Tuple4 t1 t2 t3 t4 <- Tuple (toList -> [t1,t2,t3,t4]) where + Tuple4 t1 t2 t3 t4 = Tuple (fromList [t1,t2,t3,t4]) + +pattern Tuple5 :: Term -> Term -> Term -> Term -> Term -> Term +pattern Tuple5 t1 t2 t3 t4 t5 <- Tuple (toList -> [t1,t2,t3,t4,t5]) where + Tuple5 t1 t2 t3 t4 t5 = Tuple (fromList [t1,t2,t3,t4,t5]) + +pattern Tuple6 :: Term + -> Term -> Term -> Term -> Term -> Term -> Term +pattern Tuple6 t1 t2 t3 t4 t5 t6 <- Tuple (toList -> [t1,t2,t3,t4,t5,t6]) where + Tuple6 t1 t2 t3 t4 t5 t6 = Tuple (fromList [t1,t2,t3,t4,t5,t6]) + +pattern Tuple7 :: Term + -> Term -> Term -> Term -> Term -> Term -> Term -> Term +pattern Tuple7 t1 t2 t3 t4 t5 t6 t7 <- Tuple (toList -> [t1,t2,t3,t4,t5,t6,t7]) where + Tuple7 t1 t2 t3 t4 t5 t6 t7 = Tuple (fromList [t1,t2,t3,t4,t5,t6,t7]) + +pattern List1 :: Term -> Term +pattern List1 t1 <- List (toList -> [t1]) Nil where + List1 t1 = List (fromList [t1]) Nil + +pattern List2 :: Term -> Term -> Term +pattern List2 t1 t2 <- List (toList -> [t1,t2]) Nil where + List2 t1 t2 = List (fromList [t1,t2]) Nil + +pattern List3 :: Term -> Term -> Term -> Term +pattern List3 t1 t2 t3 <- List (toList -> [t1,t2,t3]) Nil where + List3 t1 t2 t3 = List (fromList [t1,t2,t3]) Nil + +pattern List4 :: Term -> Term -> Term -> Term -> Term +pattern List4 t1 t2 t3 t4 <- List (toList -> [t1,t2,t3,t4]) Nil where + List4 t1 t2 t3 t4 = List (fromList [t1,t2,t3,t4]) Nil + +pattern List5 :: Term -> Term -> Term -> Term -> Term -> Term +pattern List5 t1 t2 t3 t4 t5 <- List (toList -> [t1,t2,t3,t4,t5]) Nil where + List5 t1 t2 t3 t4 t5 = List (fromList [t1,t2,t3,t4,t5]) Nil + +pattern List6 :: Term + -> Term -> Term -> Term -> Term -> Term -> Term +pattern List6 t1 t2 t3 t4 t5 t6 <- List (toList -> [t1,t2,t3,t4,t5,t6]) Nil where + List6 t1 t2 t3 t4 t5 t6 = List (fromList [t1,t2,t3,t4,t5,t6]) Nil + +pattern List7 :: Term + -> Term -> Term -> Term -> Term -> Term -> Term -> Term +pattern List7 t1 t2 t3 t4 t5 t6 t7 <- List (toList -> [t1,t2,t3,t4,t5,t6,t7]) Nil where + List7 t1 t2 t3 t4 t5 t6 t7 = List (fromList [t1,t2,t3,t4,t5,t6,t7]) Nil + +pattern (:=>) :: Term -> Term -> MapEntry +pattern k :=> v = MapEntry k v + +pattern Map1 :: MapEntry -> Term +pattern Map1 t1 <- Map (toList -> [t1]) where + Map1 t1 = Map (fromList [t1]) + +pattern Map2 :: MapEntry -> MapEntry -> Term +pattern Map2 t1 t2 <- Map (toList -> [t1,t2]) where + Map2 t1 t2 = Map (fromList [t1,t2]) + +pattern Map3 :: MapEntry -> MapEntry -> MapEntry -> Term +pattern Map3 t1 t2 t3 <- Map (toList -> [t1,t2,t3]) where + Map3 t1 t2 t3 = Map (fromList [t1,t2,t3]) + +pattern Map4 :: MapEntry + -> MapEntry -> MapEntry -> MapEntry -> Term +pattern Map4 t1 t2 t3 t4 <- Map (toList -> [t1,t2,t3,t4]) where + Map4 t1 t2 t3 t4 = Map (fromList [t1,t2,t3,t4]) + +pattern Map5 :: MapEntry + -> MapEntry -> MapEntry -> MapEntry -> MapEntry -> Term +pattern Map5 t1 t2 t3 t4 t5 <- Map (toList -> [t1,t2,t3,t4,t5]) where + Map5 t1 t2 t3 t4 t5 = Map (fromList [t1,t2,t3,t4,t5]) + +pattern Map6 :: MapEntry + -> MapEntry -> MapEntry -> MapEntry -> MapEntry -> MapEntry -> Term +pattern Map6 t1 t2 t3 t4 t5 t6 <- Map (toList -> [t1,t2,t3,t4,t5,t6]) where + Map6 t1 t2 t3 t4 t5 t6 = Map (fromList [t1,t2,t3,t4,t5,t6]) + +pattern Map7 :: MapEntry + -> MapEntry + -> MapEntry + -> MapEntry + -> MapEntry + -> MapEntry + -> MapEntry + -> Term +pattern Map7 t1 t2 t3 t4 t5 t6 t7 <- Map (toList -> [t1,t2,t3,t4,t5,t6,t7]) where + Map7 t1 t2 t3 t4 t5 t6 t7 = Map (fromList [t1,t2,t3,t4,t5,t6,t7]) + + data MapEntry = MapEntry { key :: Term , value :: Term } @@ -258,13 +381,39 @@ instance IsString Term where fromString = atom . CS.pack +instance E.IsList Term where + type Item Term = Term + fromList xs = List (fromList xs) Nil + toList (List xs Nil) = toList xs + toList _ = [] + instance FromTerm Term where fromTerm = Just instance ToTerm Term where toTerm = P.id + +instance Num Term where + (Integer x) + (Integer y) = Integer (x+y) + (Float x) + (Float y) = Float (x+y) + _ + _ = error "non numeric arguments to (+)" + (Integer x) * (Integer y) = Integer (x*y) + (Float x) * (Float y) = Float (x*y) + _ * _ = error "non numeric arguments to (*)" + abs (Integer x) = Integer (abs x) + abs (Float x) = Float (abs x) + abs _ = error "non numeric arguments to 'abs'" + signum (Integer x) = Integer (signum x) + signum (Float x) = Float (signum x) + signum _ = error "non numeric arguments to 'signum'" + negate (Integer x) = Integer (negate x) + negate (Float x) = Float (negate x) + negate _ = error "non numeric arguments to 'negate'" + fromInteger = integer + -------------------------------------------------------------------------------- + class ToTerm a where toTerm :: a -> Term diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -4,4 +4,4 @@ - . pvp-bounds: lower extra-deps: [] -resolver: lts-12.9 +resolver: lts-12.19 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 @@ -1,66 +1,339 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedLists #-} -module Foreign.Erlang.TermSpec ( spec ) where +module Foreign.Erlang.TermSpec + ( spec + ) +where -import Data.Binary (decode, encode) -import Data.ByteString.Char8 () -import qualified Data.ByteString.Lazy as B -import Data.Word () +import Data.Binary ( decode + , encode + ) +import Data.ByteString.Char8 ( ) +import qualified Data.ByteString.Lazy as B +import Data.Word ( ) import Foreign.Erlang.Term import Test.Hspec import Test.QuickCheck +import Data.Vector ( fromList ) spec :: Spec spec = do - 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) + 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) describe "Integer" $ it "has a Binary instance such that decode is the inverse of encode" $ property - $ \ (i :: Integer) -> + $ \(i :: Integer) -> fromTerm (decode (encode (integer i))) `shouldBe` (Just i) - describe "The largest small_big_ext 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 largest small_big_ext 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) - describe "Term" - $ it "has a Binary instance such that decode is the inverse of encode" - $ property - $ \ (t :: Term) -> - decode (encode t) `shouldBe` t + $ 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" + describe "Pattern Synonyms" $ do + it "Tuple3" $ do + 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 + it "List4" $ do + 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 + it "Map2" $ do + 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)