{-# LANGUAGE OverlappingInstances #-}
{-# OPTIONS -XFlexibleInstances -XTypeSynonymInstances #-}
module Foreign.Erlang.Types (
ErlType(..)
, Erlang(..)
, nth
, getA, getC, getErl, getN, geta, getn
, putA, putC, putErl, putN, puta, putn
, tag
) where
import Prelude hiding (id)
import qualified Prelude (id)
import Control.Exception (assert)
import Control.Monad (forM, liftM)
import Data.Monoid ((<>),mconcat)
import Data.Binary
import Data.Binary.Get
import Data.Char (chr, ord, isPrint)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as C
import qualified Data.ByteString.Char8 as BB
import Data.ByteString.Lazy.Builder
import qualified Data.ByteString as Byte
import Data.ByteString (ByteString)
import Control.Applicative
import Data.Bits(shiftL,complement,(.|.))
nth :: Erlang a => Int -> ErlType -> a
nth i (ErlTuple lst) = fromErlang $ lst !! i
data ErlType = ErlNull
| ErlInt Int
| ErlFloat Double
| ErlBigInt Integer
| ErlString String
| ErlAtom String
| ErlBinary [Word8]
| ErlList [ErlType]
| ErlTuple [ErlType]
| ErlPid ErlType Int Int Int
| ErlPort ErlType Int Int
| ErlRef ErlType Int Int
| ErlNewRef ErlType Int [Word8]
deriving (Eq, Show)
class Erlang a where
toErlang :: a -> ErlType
fromErlang :: ErlType -> a
instance Erlang ErlType where
toErlang = Prelude.id
fromErlang = Prelude.id
instance Erlang Int where
toErlang x
| abs x <= 0x7FFFFFFF = ErlInt x
| otherwise = ErlBigInt (fromIntegral x)
fromErlang (ErlInt x) = x
fromErlang (ErlBigInt x) = fromIntegral x
instance Erlang Double where
toErlang x = ErlFloat x
fromErlang (ErlFloat x) = x
instance Erlang Float where
toErlang x = ErlFloat (realToFrac x)
fromErlang (ErlFloat x) = realToFrac x
instance Erlang Integer where
toErlang x = ErlBigInt x
fromErlang (ErlInt x) = fromIntegral x
fromErlang (ErlBigInt x) = x
instance Erlang String where
toErlang x = ErlString x
fromErlang ErlNull = ""
fromErlang (ErlString x) = x
fromErlang (ErlAtom x) = x
fromErlang (ErlList xs) = map (chr . fromErlang) xs
fromErlang x = error $ "can't convert to string: " ++ show x
instance Erlang Bool where
toErlang True = ErlAtom "true"
toErlang False = ErlAtom "false"
fromErlang (ErlAtom "true") = True
fromErlang (ErlAtom "false") = False
instance Erlang [ErlType] where
toErlang [] = ErlNull
toErlang xs = ErlList xs
fromErlang ErlNull = []
fromErlang (ErlList xs) = xs
instance Erlang a => Erlang [a] where
toErlang [] = ErlNull
toErlang xs = ErlList . map toErlang $ xs
fromErlang ErlNull = []
fromErlang (ErlList xs) = map fromErlang xs
instance (Erlang a, Erlang b) => Erlang (a, b) where
toErlang (x, y) = ErlTuple [toErlang x, toErlang y]
fromErlang (ErlTuple [x, y]) = (fromErlang x, fromErlang y)
instance (Erlang a, Erlang b, Erlang c) => Erlang (a, b, c) where
toErlang (x, y, z) = ErlTuple [toErlang x, toErlang y, toErlang z]
fromErlang (ErlTuple [x, y, z]) = (fromErlang x, fromErlang y, fromErlang z)
instance (Erlang a, Erlang b, Erlang c, Erlang d) => Erlang (a, b, c, d) where
toErlang (x, y, z, w) = ErlTuple [toErlang x, toErlang y, toErlang z, toErlang w]
fromErlang (ErlTuple [x, y, z, w]) = (fromErlang x, fromErlang y, fromErlang z, fromErlang w)
instance (Erlang a, Erlang b, Erlang c, Erlang d, Erlang e) => Erlang (a, b, c, d, e) where
toErlang (x, y, z, w, a) = ErlTuple [toErlang x, toErlang y, toErlang z, toErlang w, toErlang a]
fromErlang (ErlTuple [x, y, z, w, a]) = (fromErlang x, fromErlang y, fromErlang z, fromErlang w, fromErlang a)
instance Binary ErlType where
put = undefined
get = getErl
putErl :: ErlType -> Builder
putErl (ErlInt val)
| 0 <= val && val < 256 = tag 'a' <> putC val
| otherwise = tag 'b' <> putN val
putErl (ErlFloat val) = tag 'c' <> byteString (BB.pack . take 31 $ show val ++ repeat '\NUL')
putErl (ErlAtom val) = tag 'd' <> putn (length val) <> putA val
putErl (ErlTuple val)
| len < 256 = tag 'h' <> putC len <> val'
| otherwise = tag 'i' <> putN len <> val'
where val' = mconcat . map putErl $ val
len = length val
putErl ErlNull = tag 'j'
putErl (ErlString val) = tag 'k' <> putn (length val) <> putA val
putErl (ErlList val) = tag 'l' <> putN (length val) <> val' <> putErl ErlNull
where val' = mconcat . map putErl $ val
putErl (ErlBinary val) = tag 'm' <> putN (length val) <> (lazyByteString . B.pack) val
putErl (ErlBigInt x)
| len > 255 = tag 'o' <> putN len <> byteString val
| otherwise = tag 'n' <> putC len <> byteString val
where
val = integerToBytes x
len = Byte.length val -1
putErl (ErlRef node id creation) =
tag 'e' <>
putErl node <>
putN id <>
putC creation
putErl (ErlPort node id creation) = tag 'f' <> putErl node <> putN id <> putC creation
putErl (ErlPid node id serial creation) = tag 'g' <> putErl node <> putN id <> putN serial <> putC creation
putErl (ErlNewRef node creation id) =
tag 'r' <>
putn (length id `div` 4) <>
putErl node <>
putC creation <>
(lazyByteString . B.pack) id
getErl :: Get ErlType
getErl = do
tag <- liftM chr getC
case tag of
'a' -> liftM ErlInt getC
'b' -> do x <- getN
let valFrom32
| x > 0x7FFFFFFF = x .|. complement 0xFFFFFFFF
| otherwise = x
return (ErlInt valFrom32)
'c' -> do parsed <- reads . BB.unpack <$> getByteString 31
case parsed of
[(x,remains)]
| all (=='\NUL') remains -> return $ ErlFloat x
_ -> fail $ "could not parse float representation: "++show parsed
'd' -> getn >>= liftM ErlAtom . getA
'e' -> do
node <- getErl
id <- getN
creation <- getC
return $ ErlRef node id creation
'f' -> do
node <- getErl
id <- getN
creation <- getC
return $ ErlPort node id creation
'g' -> do
node <- getErl
id <- getN
serial <- getN
creation <- getC
return $ ErlPid node id serial creation
'h' -> getC >>= \len -> liftM ErlTuple $ forM [1..len] (const getErl)
'i' -> getN >>= \len -> liftM ErlTuple $ forM [1..len] (const getErl)
'j' -> return ErlNull
'k' -> do
len <- getn
list <- getA len
case all isPrint list of
True -> return $ ErlString list
False -> return . ErlList $ map (ErlInt . ord) list
'l' -> do
len <- getN
list <- liftM ErlList $ forM [1..len] (const getErl)
null <- getErl
assert (null == ErlNull) $ return list
'm' -> getN >>= liftM ErlBinary . geta
'n' -> do len <- getC
raw <- getByteString (len+1)
ErlBigInt <$> bytesToInteger raw
'o' -> do len <- getN
raw <- getByteString (len+1)
ErlBigInt <$> bytesToInteger raw
'r' -> do
len <- getn
node <- getErl
creation <- getC
id <- forM [1..4*len] (const getWord8)
return $ ErlNewRef node creation id
'v' -> getn >>= liftM ErlAtom . getA
'w' -> getC >>= liftM ErlAtom . getA
x -> fail $ "Unsupported serialization code: " ++ show (ord x)
bytesToInteger :: ByteString -> Get Integer
bytesToInteger bts = case Byte.unpack bts of
0 : bts' -> return $ foldr step 0 bts'
1 : bts' -> return . negate $ foldr step 0 bts'
x : _ -> fail $ "Unexpected sign byte: " ++ show x
_ -> fail $ "Unexpected end of input at function 'bytesToInteger'"
where
step next acc = shiftL acc 8 + fromIntegral next
integerToBytes :: Integer -> ByteString
integerToBytes int = Byte.pack
. fmap (fromIntegral.snd)
. takeWhile not_zero
$ iterate ((`divMod`256).fst) (abs int,sigByte)
where
not_zero (a,b) = a + b /= 0
sigByte | int > 0 = 0
| otherwise = 1
tag :: Char -> Builder
tag = charUtf8
putC :: Integral a => a -> Builder
putC = word8 . fromIntegral
putn :: Integral a => a -> Builder
putn = word16BE . fromIntegral
putN :: Integral a => a -> Builder
putN = word32BE . fromIntegral
puta :: [Word8] -> Builder
puta = lazyByteString . B.pack
putA :: String -> Builder
putA = stringUtf8
getC :: Get Int
getC = liftM fromIntegral getWord8
getn :: Get Int
getn = liftM fromIntegral getWord16be
getN :: Get Int
getN = liftM fromIntegral getWord32be
geta :: Int -> Get [Word8]
geta = liftM B.unpack . getLazyByteString . fromIntegral
getA :: Int -> Get String
getA = liftM C.unpack . getLazyByteString . fromIntegral