{-# LANGUAGE DeriveDataTypeable,CPP,FlexibleInstances,UndecidableInstances #-}

-- | This module provides the 'Serializable' type class and
-- functions to convert to and from 'Payload's. It's implemented
-- in terms of Haskell's "Data.Binary". The message sending
-- and receiving functionality in "Remote.Process" depends on this.
module Remote.Encoding (
          Serializable,
          serialEncode,
          serialEncodePure,
          serialDecode,
          serialDecodePure,
          dynamicDecodePure,
          dynamicEncodePure,
          Payload,
          DynamicPayload,
          PayloadLength,
          hPutPayload,
          hGetPayload,
          payloadLength,
          getPayloadType,
          getDynamicPayloadType,
          getPayloadContent,
          genericPut,
          genericGet) where

import Prelude hiding (id)
import qualified Prelude as Prelude

import Data.Binary (Binary,encode,decode,Put,Get,put,get,putWord8,getWord8)
import Control.Monad (liftM)
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B (hPut,hGet,length)
import Control.Exception (try,evaluate,ErrorCall)
import Data.Int (Int64)
import System.IO (Handle)
import Data.Typeable (typeOf,typeOf,Typeable)
import Data.Dynamic (Dynamic,toDyn,fromDynamic,dynTypeRep)
import Data.Generics (Data,gfoldl,gunfold, toConstr,constrRep,ConstrRep(..),repConstr,extQ,extR,dataTypeOf)

-- | Data that can be sent as a message must implement
-- this class. The class has no functions of its own,
-- but instead simply requires that the type implement
-- both 'Typeable' and 'Binary'. Typeable can usually
-- be derived automatically. Binary requires the put and get
-- functions, which can be easily implemented by hand,
-- or you can use the 'genericGet' and 'genericPut' flavors,
-- which will work automatically for types implementing
-- 'Data'.
class (Binary a,Typeable a) => Serializable a
instance (Binary a,Typeable a) => Serializable a

data Payload = Payload
                { 
                  payloadType :: !ByteString,
                  payloadContent :: !ByteString
                } deriving (Typeable)
data DynamicPayload = DynamicPayload
                {
                  dynamicPayloadContent :: Dynamic
                }
type PayloadLength = Int64

instance Binary Payload where
  put pl = put (payloadType pl) >> put (payloadContent pl)
  get = get >>= \a -> get >>= \b -> return $ Payload {payloadType = a,payloadContent=b}

payloadLength :: Payload -> PayloadLength
payloadLength (Payload t c) = B.length t + B.length c

getPayloadContent :: Payload -> ByteString
getPayloadContent = payloadContent

getPayloadType :: Payload -> String
getPayloadType pl = decode $ payloadType pl

hPutPayload :: Handle -> Payload -> IO ()
hPutPayload h (Payload t c) = B.hPut h (encode (B.length t :: PayloadLength)) >>  
                       B.hPut h t >>
                       B.hPut h (encode (B.length c :: PayloadLength)) >>
                       B.hPut h c

hGetPayload :: Handle -> IO Payload
hGetPayload h = do tl <- B.hGet h (fromIntegral baseLen)
                   t <- B.hGet h (fromIntegral (decode tl :: PayloadLength))
                   cl <- B.hGet h (fromIntegral baseLen)
                   c <- B.hGet h (fromIntegral (decode cl :: PayloadLength))
                   return $ Payload {payloadType = t,payloadContent = c}
    where baseLen = B.length (encode (0::PayloadLength))

serialEncodePure :: (Serializable a) => a -> Payload
serialEncodePure a = let encoding = encode a
                      in encoding `seq` Payload {payloadType = encode $ show $ typeOf a,
                                                 payloadContent = encoding}

dynamicEncodePure :: (Serializable a) => a -> DynamicPayload
dynamicEncodePure a = DynamicPayload {dynamicPayloadContent = toDyn a}

dynamicDecodePure :: (Serializable a) => DynamicPayload -> Maybe a
dynamicDecodePure a = fromDynamic (dynamicPayloadContent a)

getDynamicPayloadType :: DynamicPayload -> String
getDynamicPayloadType a = show (dynTypeRep (dynamicPayloadContent a))

-- TODO I suspect that we will get better performance for big messages if let this be lazy
-- see also serialDecode
serialEncode :: (Serializable a) => a -> IO Payload
serialEncode a = do encoded <- evaluate $ encode a -- this evaluate is actually necessary, it turns out; it might be better to just use strict ByteStrings
                    return $ Payload {payloadType = encode $ show $ typeOf a,
                                        payloadContent = encoded}


serialDecodePure :: (Serializable a) => Payload -> Maybe a
serialDecodePure a = (\id -> 
                      let pc = payloadContent a
                      in
                        pc `seq`
                        if (decode $! payloadType a) == 
                              show (typeOf $ id undefined)
                          then Just (id $! decode pc)
                          else Nothing ) Prelude.id


serialDecode :: (Serializable a) => Payload -> IO (Maybe a)
serialDecode a = (\id ->
                      if (decode $ payloadType a) == 
                            show (typeOf $ id undefined)
                         then do
                                 res <- try (evaluate $ decode (payloadContent a)) 
                                    :: (Serializable a) => IO (Either ErrorCall a)
                                 case res of
                                  Left _ -> return $ Nothing
                                  Right v -> return $ Just $ id v
                         else return Nothing ) Prelude.id


-- | Data types that can be used in messaging must
-- be serializable, which means that they must implement
-- the 'get' and 'put' methods from 'Binary'. If you
-- are too lazy to write these functions yourself,
-- you can delegate responsibility to this function.
-- It's usually sufficient to do something like this:
--
-- > import Data.Data (Data)
-- > import Data.Typeable (Typeable)
-- > import Data.Binary (Binary, get, put)
-- > data MyType = MkMyType Foobar Int [(String, Waddle Baz)]
-- >             | MkSpatula
-- >                  deriving (Data, Typeable)
-- > instance Binary MyType where
-- >    put = genericPut
-- >    get = genericGet
genericPut :: (Data a) => a ->  Put
genericPut = generic `extQ` genericString
   where generic what = fst $ gfoldl 
            (\(before, a_to_b) a -> (before >> genericPut a, a_to_b a))
            (\x -> (serializeConstr (constrRep (toConstr what)), x))
            what
         genericString :: String -> Put
         genericString = put.encode

-- | This is the counterpart 'genericPut'
genericGet :: Data a => Get a
genericGet = generic `extR` genericString
   where generic = (\id -> liftM id $ deserializeConstr $ \constr_rep ->
                   gunfold (\n -> do n' <- n
                                     g' <- genericGet
                                     return $ n' g')
                           (return)
                           (repConstr (dataTypeOf (id undefined)) constr_rep)) Prelude.id
         genericString :: Get String
         genericString = do q <- get
                            return $ decode q

serializeConstr :: ConstrRep -> Put
serializeConstr (AlgConstr ix)   = putWord8 1 >> put ix
serializeConstr (IntConstr i)    = putWord8 2 >> put i
serializeConstr (FloatConstr r)  = putWord8 3 >> put r
#if __GLASGOW_HASKELL__ >= 611
serializeConstr (CharConstr c)   = putWord8 4 >> put c
#else
serializeConstr (StringConstr c)   = putWord8 4 >> put (head c)
#endif

deserializeConstr :: (ConstrRep -> Get a) -> Get a
deserializeConstr k = 
      do constr_ix <- getWord8
         case constr_ix of
          1 -> get >>= \ix -> k (AlgConstr ix)
          2 -> get >>= \i -> k (IntConstr i)
          3 -> get >>= \r -> k (FloatConstr r)
#if __GLASGOW_HASKELL__ >= 611
          4 -> get >>= \c -> k (CharConstr c)
#else
          4 -> get >>= \c -> k (StringConstr (c:[]))
#endif