{-# LANGUAGE OverlappingInstances #-}
{-# OPTIONS -XFlexibleInstances -XTypeSynonymInstances #-}

-- |
-- Module      : Foreign.Erlang.OTP
-- Copyright   : (c) Eric Sessoms, 2008
--               (c) Artúr Poór, 2015
--               (c) Arnold Szederjesi-Dragomir, 2021
-- License     : GPL3
--
-- Maintainer  : szederjesiarnold@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           Control.Exception            (assert)
import           Control.Monad                (forM, liftM)
import           Prelude                      hiding (id)
import qualified Prelude                      (id)

import           Data.Binary
import           Data.Binary.Get
import qualified Data.ByteString.Char8        as BB
import qualified Data.ByteString.Lazy         as B
import           Data.ByteString.Lazy.Builder
import qualified Data.ByteString.Lazy.Char8   as C
import           Data.Char                    (chr, isPrint, ord)
--import Data.Int (Int64)
import           Data.Monoid                  (mconcat, (<>))

import           Control.Applicative
import           Data.Bits                    (complement, shiftL, (.|.))
import           Data.ByteString              (ByteString)
import qualified Data.ByteString              as Byte

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 (ErlBinary xs) = map (chr . fromEnum) xs
  fromErlang x              = error $ "can't convert to string: " ++ show x

instance Erlang [Word8] where
  toErlang x = ErlBinary x
  fromErlang (ErlBinary x) = x

instance Erlang ByteString where
  toErlang x = ErlBinary $ Byte.unpack x
  fromErlang (ErlBinary x) = Byte.pack x

instance Erlang B.ByteString where
  toErlang x = ErlBinary $ B.unpack x
  fromErlang (ErlBinary x) = B.pack 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