# 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  '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 '  ' and ' Binary ' .  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
  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 .  (  )
-- > import Data.Binary (Binary, get, put)
  > data  = MkMyType   [ ( String ,   ) ]
  >              | 
-- >                  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

 | This module provides the 'Serializable' type class and
 functions to convert to and from 'Payload's. It's implemented
 and receiving functionality in "Remote.Process" depends on this.
 | 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
 be derived automatically. Binary requires the put and get
 functions, which can be easily implemented by hand,
 which will work automatically for types implementing
 'Data'.
 TODO I suspect that we will get better performance for big messages if let this be lazy
 see also serialDecode
 | 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.Binary (Binary, get, put)
 >                  deriving (Data, Typeable)
 > instance Binary MyType where
 >    get = genericGet
# LANGUAGE DeriveDataTypeable , CPP , FlexibleInstances , UndecidableInstances #

  in terms of  's " Data . Binary " . The message sending
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)

  both '  ' and ' Binary ' .  can usually
  or you can use the ' genericGet ' and ' genericPut ' flavors ,
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))

serialEncode :: (Serializable a) => a -> IO Payload
  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


  > import Data .  (  )
  > data  = MkMyType   [ ( String ,   ) ]
  >              | 
  >     put = genericPut
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
