content: {-# LANGUAGE OverlappingInstances #-}
  {-# OPTIONS -XFlexibleInstances -XTypeSynonymInstances #-}
  
  -- |
  -- Module      : Foreign.Erlang.OTP
  -- Copyright   : (c) Eric Sessoms, 2008
  --               (c) Artúr Poór, 2015
  -- License     : GPL3
  -- 
  -- Maintainer  : gombocarti@gmail.com
  -- Stability   : experimental
  -- Portability : portable
  --
  
  module Foreign.Erlang.Types (
    -- * Native Erlang data types
      ErlType(..)
    -- ** Conversion between native Haskell types and ErlType
    , Erlang(..)
    -- ** Easy type-safe access to tuple members
    , nth
  
    -- ** Internal packing functions
    , 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.Int (Int64)
  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     -- node id serial creation
               | ErlPort ErlType Int Int        -- node id creation
               | ErlRef ErlType Int Int         -- node id creation
               | ErlNewRef ErlType Int [Word8]  -- node creation id
               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) -- Haskell Int (might) use 64 bits whether erlang's small Int use only 32 bit
  
      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
  