content: {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  {-# LANGUAGE DataKinds, TypeOperators #-}
  {-# LANGUAGE TypeOperators, ScopedTypeVariables, FlexibleContexts #-}
  {-# LANGUAGE MonoLocalBinds #-}
  
  -- | Easy FFI via MessagePack.
  --
  -- You can use this module to expose any Haskell function to other Programming languages.
  --
  -- It allows to convert functions that take multiple arguments
  -- into functions that take one argument:
  -- A 'ByteString' which contains all arguments encoded as a MessagePack array.
  --
  -- Common use cases:
  --
  -- * Write functions in fast native Haskell code, compile them into a dynamic.
  --   library (@.so@ \/ @.dll@) and call them via C\/Python\/Ruby\/whatever via @dlopen()@ or equivalents.
  --
  -- * Expose Haskell functions via a socket / the web
  module FFI.Anything.TypeUncurry.Msgpack (
    MessagePackRec (..)
  , getTypeListFromMsgpackArray
  , uncurryMsgpack
  , tryUncurryMsgpack
  , tryUncurryMsgpackIO
  , byteStringToCStringFun
  , byteStringToCStringFunIO
  , export
  , exportIO
  ) where
  
  import           Data.ByteString (ByteString)
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Lazy as BSL
  import           Data.ByteString.Unsafe (unsafeUseAsCStringLen)
  import           Data.Int (Int64)
  import           Data.Maybe (fromMaybe)
  import qualified Data.MessagePack as MSG
  import           Data.Proxy
  import           Data.Storable.Endian (peekBE, pokeBE)
  import           Foreign.C
  import           Foreign.Marshal.Alloc (mallocBytes)
  import           Foreign.Marshal.Utils (copyBytes)
  import           Foreign.Ptr (castPtr, plusPtr)
  
  import FFI.Anything.TypeUncurry
  
  
  -- | Helper to allow writing a 'MSG.MessagePack' instance for 'TypeList's.
  --
  -- We need this because we have to call 'parseArray' at the top-level
  -- 'MSG.MessagePack' instance, but not at each function argument step.
  class MessagePackRec l where
    fromObjectRec :: (MonadFail m) => [MSG.Object] -> m (TypeList l)
  
  -- | When no more types need to be unpacked, we are done.
  instance MessagePackRec '[] where
    fromObjectRec v | null v = pure Nil
    fromObjectRec _          = fail "fromObjectRec: passed object is not expected []"
  
  -- | Unpack one type by just parsing the next element.
  instance (MSG.MessagePack a, MessagePackRec l) => MessagePackRec (a ': l) where
    fromObjectRec (x:xs) = (:::) <$> MSG.fromObject x <*> fromObjectRec xs
    fromObjectRec _      = fail "fromObjectRec: passed object is not expected (x:xs)"
  
  -- | Parses a tuple of arbitrary size ('TypeList's) from a MessagePack array.
  getTypeListFromMsgpackArray :: forall m l . (MessagePackRec l, ParamLength l, MonadFail m) => MSG.Object -> m (TypeList l)
  getTypeListFromMsgpackArray obj = case obj of
      MSG.ObjectArray v | length v == len -> fromObjectRec v
      _                                   -> fail "getTypeListFromMsgpackArray: wrong object length"
    where
      len = paramLength (Proxy :: Proxy l)
  
  instance (MessagePackRec l, ParamLength l) => MSG.MessagePack (TypeList l) where
    fromObject = getTypeListFromMsgpackArray
    toObject = error "call-haskell-from-anything: Serialising a TypeList is not supported (and not needed)!"
  
  
  -- | Standard error message when unpacking failed.
  errorMsg :: String -> String
  errorMsg locationStr = "call-haskell-from-anything: " ++ locationStr ++ ": got wrong number of function arguments or non-array"
  
  
  -- | Translates a function of type @a -> b -> ... -> r@ to
  -- a function that:
  --
  -- * takes as a single argument a 'ByteString' containing all arguments serialized in a MessagePack array
  --
  -- * returns its result serialized in a 'ByteString' via MessagePack 'MSG.pack'
  --
  -- This function throws an 'error' if the de-serialization of the arguments fails!
  -- It is recommended to use 'tryUncurryMsgpack' instead.
  uncurryMsgpack :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> (ByteString -> ByteString)
  uncurryMsgpack f = \bs -> BSL.toStrict . MSG.pack $ (translate f $ fromMaybe (error (errorMsg "uncurryMsgpack")) $ MSG.unpack $ BSL.fromStrict bs)
  
  
  -- | Like 'uncurryMsgpack', but for 'IO' functions.
  --
  -- This function throws an 'error' if the de-serialization of the arguments fails!
  -- It is recommended to use 'tryUncurryMsgpackIO' instead.
  uncurryMsgpackIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> (ByteString -> IO ByteString)
  uncurryMsgpackIO f = \bs -> BSL.toStrict . MSG.pack <$> (translate f $ fromMaybe (error (errorMsg "uncurryMsgpackIO")) $ MSG.unpack $ BSL.fromStrict bs)
  
  
  -- | Like 'uncurryMsgpack', but makes it clear when the 'ByteString' containing
  -- the function arguments does not contain the right number/types of arguments.
  tryUncurryMsgpack :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> (ByteString -> Maybe ByteString)
  tryUncurryMsgpack f = \bs -> case MSG.unpack $ BSL.fromStrict bs of
    Nothing   -> Nothing
    Just args -> Just . BSL.toStrict . MSG.pack $ (translate f $ args)
  
  
  -- | Like 'uncurryMsgpack', but makes it clear when the 'ByteString' containing
  -- the function arguments does not contain the right number/types of arguments.
  tryUncurryMsgpackIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> (ByteString -> Maybe (IO ByteString))
  tryUncurryMsgpackIO f = \bs -> case MSG.unpack $ BSL.fromStrict bs of
    Nothing   -> Nothing
    Just args -> Just $ BSL.toStrict . MSG.pack <$> (translate f $ args)
  
  
  -- | O(n). Makes a copy of the ByteString's contents into a malloc()ed area.
  -- You need to free() the returned string when you're done with it.
  byteStringToMallocedCStringWith64bitLength :: ByteString -> IO CString
  byteStringToMallocedCStringWith64bitLength bs =
    unsafeUseAsCStringLen bs $ \(ptr, len) -> do
      targetPtr <- mallocBytes (8 + len)
      pokeBE (castPtr targetPtr) (fromIntegral len :: Int64)
      copyBytes (targetPtr `plusPtr` 8) ptr len
      return targetPtr
  
  
  -- * Exporting
  
  -- TODO implement via byteStringToCStringFunIO?
  -- | Transforms a 'ByteString'-mapping function to 'CString'-mapping function
  -- for use in the FFI.
  byteStringToCStringFun :: (ByteString -> ByteString) -> CString -> IO CString
  byteStringToCStringFun f cs = do
    msgLength :: Int64 <- peekBE (castPtr cs)
    cs_bs <- BS.packCStringLen (cs `plusPtr` 8, fromIntegral msgLength)
    let res_bs = f cs_bs
    res_cs <- byteStringToMallocedCStringWith64bitLength res_bs
    return res_cs
  
  
  -- | Transforms a 'ByteString'-mapping 'IO' function to 'CString'-mapping function
  -- for use in the FFI.
  byteStringToCStringFunIO :: (ByteString -> IO ByteString) -> CString -> IO CString
  byteStringToCStringFunIO f cs = do
    msgLength :: Int64 <- peekBE (castPtr cs)
    cs_bs <- BS.packCStringLen (cs `plusPtr` 8, fromIntegral msgLength)
    res_bs <- f cs_bs
    res_cs <- byteStringToMallocedCStringWith64bitLength res_bs
    return res_cs
  
  
  -- | Exports a "pure" function
  -- to an FFI function that takes its arguments as a serialized MessagePack message.
  --
  -- Calling this function throws an 'error' if the de-serialization of the arguments fails!
  -- Use 'tryExport' if you want to handle this case.
  export :: (MSG.MessagePack (TypeList l), ToTypeList f l r, MSG.MessagePack r) => f -> CString -> IO CString
  export = byteStringToCStringFun . uncurryMsgpack
  
  
  -- | Exports an 'IO' function to an FFI function that takes its arguments as a serialized MessagePack message.
  --
  -- Calling this function throws an 'error' if the de-serialization of the arguments fails!
  -- Use 'tryExportIO' if you want to handle this case.
  exportIO :: (MSG.MessagePack (TypeList l), ToTypeList f l (IO r), MSG.MessagePack r) => f -> CString -> IO CString
  exportIO = byteStringToCStringFunIO . uncurryMsgpackIO
  
  
  -- TODO make equivalent using tryUncurryMsgpack (tryExport)
  -- TODO make equivalent using tryUncurryMsgpackIO (tryExport)
  