{-# LANGUAGE CPP, ForeignFunctionInterface #-}

module Foreign.MathLink.IO ( acquireEnvironment
                           , acquireLink
                           , releaseEnvironment 
                           , releaseLink
                           , activate
                           , flush
                           , checkReady
                           , getError
                           , clearError
                           , getErrorMessage
                           , convToBool
                           , valueOrErrorMsg
                           , getPacket
                           , endPacket
                           , newPacket
                           , getMessage
                           , putMessage
                           , checkMessage
                           , transferExpression
                           , mlGetNext
                           , mlGetType
                           , mlTestHead
                           , mlPutInt16
                           , mlGetInt16
                           , mlPutInt32
                           , mlGetInt32
                           , mlPutInt
                           , mlGetInt
                           , mlPutReal32
                           , mlGetReal32
                           , mlPutReal64
                           , mlGetReal64
                           , mlPutInt16List
                           , mlGetInt16List
                           , mlReleaseInt16List
                           , mlPutInt32List
                           , mlGetInt32List
                           , mlReleaseInt32List
                           , mlPutIntList
                           , mlGetIntList
                           , mlReleaseIntList
                           , mlPutReal32List
                           , mlGetReal32List
                           , mlReleaseReal32List
                           , mlPutReal64List
                           , mlGetReal64List
                           , mlReleaseReal64List
                           , mlPutInt16Array
                           , mlGetInt16Array
                           , mlReleaseInt16Array
                           , mlPutInt32Array
                           , mlGetInt32Array
                           , mlReleaseInt32Array
                           , mlPutIntArray
                           , mlGetIntArray
                           , mlReleaseIntArray
                           , mlPutReal32Array
                           , mlGetReal32Array
                           , mlReleaseReal32Array
                           , mlPutReal64Array
                           , mlGetReal64Array
                           , mlReleaseReal64Array
                           , mlPutString
                           , mlGetString
                           , mlReleaseString
                           , mlPutSymbol
                           , mlGetSymbol
                           , mlReleaseSymbol
                           , mlPutFunction
                           , mlGetFunction
                           ) where

import Foreign
import Foreign.C
import Foreign.MathLink.Types
import Control.Exception
import Control.Monad (liftM)


-- decide which size of C int to use
#if (HS_INT_MIN >= __INT32_MIN) && (HS_INT_MAX <= __INT32_MAX)
#  define USE_INT32
#elif (HS_INT_MIN >= __INT64_MIN) && (HS_INT_MAX <= __INT64_MAX)
#  define USE_INT64
#else
#  error "Unexpected size of Int."
#endif


-- initialization / termination

foreign import ccall safe "mathlink.h MLInitialize" mlInitialize
    :: Ptr () -> IO Environment

acquireEnvironment :: IO Environment
acquireEnvironment = do
  env@(Environment ptr) <- mlInitialize nullPtr
  if ptr == nullPtr then
      error "Unable to initialize MathLink environment."
    else
      return env

foreign import ccall safe "mathlink.h MLOpenString" mlOpenString
    :: Environment -> CString -> Ptr CInt -> IO Link

foreign import ccall safe "mathlink.h MLErrorString" mlErrorString
    :: Environment -> CLong -> IO CString

acquireLink :: Environment -> [String] -> IO Link
acquireLink env args = do
  (lnk@(Link ptr),err) <- withCString (unwords args) $ \argPtr ->
                            bracket malloc free $ \errPtr -> do
                              l <- mlOpenString env argPtr errPtr
                              e <- peek errPtr
                              return (l,e)
  if ptr == nullPtr || err /= 0 then
      mlErrorString env (fromIntegral err) >>= peekCString >>= error
    else
      return lnk

foreign import ccall safe "mathlink.h MLClose" mlClose
    :: Link -> IO ()

releaseLink :: Link -> IO ()
releaseLink = mlClose

foreign import ccall safe "mathlink.h MLDeinitialize" mlDeinitialize
    :: Environment -> IO ()

releaseEnvironment :: Environment -> IO ()
releaseEnvironment = mlDeinitialize

foreign import ccall safe "mathlink.h MLActivate" mlActivate
    :: Link -> IO CInt
 
activate :: Link -> IO Bool
activate l = mlActivate l >>= convToBool

foreign import ccall safe "mathlink.h MLFlush" mlFlush
    :: Link -> IO CInt

flush :: Link -> IO Bool
flush l = mlFlush l >>= convToBool

foreign import ccall safe "mathlink.h MLReady" mlReady
    :: Link -> IO CInt

checkReady :: Link -> IO Bool
checkReady l = mlReady l >>= convToBool


-- errors

foreign import ccall safe "mathlink.h MLError" mlError
    :: Link -> IO CInt

getError :: Link -> IO Error
getError l = mlError l >>= (return . toEnum . fromIntegral)

convToBool :: Integral a => a -> IO Bool
convToBool = return . (/= 0)

foreign import ccall safe "mathlink.h MLClearError" mlClearError
    :: Link -> IO CInt

clearError :: Link -> IO Bool
clearError l = mlClearError l >>= convToBool

foreign import ccall safe "mathlink.h MLErrorMessage" mlErrorMessage
    :: Link -> IO CString

getErrorMessage :: Link -> IO String
getErrorMessage l = mlErrorMessage l >>= peekCString

valueOrErrorMsg :: Integral a => Link -> b -> a -> IO (Either String b)
valueOrErrorMsg l val i = 
  if i /= 0 then 
      return $ Right val 
    else 
      getErrorMessage l >>= (return . Left)


-- packets
                          
foreign import ccall safe "mathlink.h MLNextPacket" mlNextPacket
    :: Link -> IO CInt

getPacket :: Link -> IO Packet
getPacket l = mlNextPacket l >>= (return . toEnum . fromIntegral)

foreign import ccall safe "mathlink.h MLEndPacket" mlEndPacket
    :: Link -> IO CInt

endPacket :: Link -> IO Bool
endPacket l = mlEndPacket l >>= convToBool

foreign import ccall safe "mathlink.h MLNewPacket" mlNewPacket
    :: Link -> IO CInt

newPacket :: Link -> IO Bool
newPacket l = mlNewPacket l >>= convToBool


-- messages

foreign import ccall safe "mathlink.h MLGetMessage" mlGetMessage
    :: Link -> Ptr CInt -> Ptr CInt -> IO CInt

getMessage :: Link -> IO (Maybe (Message,Int))
getMessage l =
  bracket malloc free $ \mPtr ->
    bracket malloc free $ \aPtr -> do
      present <- mlGetMessage l mPtr aPtr >>= convToBool
      if present then do
          msgId <- peek mPtr
          arg <- peek aPtr
          return $ Just (mkMessage msgId, fromIntegral arg)
        else
          return Nothing
      
foreign import ccall safe "mathlink.h MLPutMessage" mlPutMessage
    :: Link -> CInt -> IO CInt

putMessage :: Link -> Message -> IO Bool
putMessage l m = mlPutMessage l (fromIntegral $ fromEnum m) >>= convToBool

foreign import ccall safe "mathlink.h MLMessageReady" mlMessageReady
    :: Link -> IO CInt

checkMessage :: Link -> IO Bool
checkMessage l = mlMessageReady l >>= convToBool

 -- misc

foreign import ccall safe "mathlink.h MLTransferExpression" mlTransferExpression
    :: Link -> Link -> IO CInt

transferExpression :: Link -> Link -> IO Bool
transferExpression l1 l2 = mlTransferExpression l1 l2 >>= convToBool


-- puts

foreign import ccall safe "mathlink.h MLPutInteger16" mlPutInt16
    :: Link -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLPutInteger32"  mlPutInt32
    :: Link -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLPutInteger64"  mlPutInt64
    :: Link -> CLong -> IO CInt

#ifdef USE_INT32
mlPutInt = mlPutInt32
#elif defined USE_INT64
mlPutInt = mlPutInt64
#endif

foreign import ccall safe "mathlink.h MLPutReal32" mlPutReal32
    :: Link -> CFloat -> IO CInt

foreign import ccall safe "mathlink.h MLPutReal64" mlPutReal64
    :: Link -> CDouble -> IO CInt

foreign import ccall safe "mathlink.h MLPutString" mlPutString
    :: Link -> CString -> IO CInt

foreign import ccall safe "mathlink.h MLPutSymbol" mlPutSymbol
    :: Link -> CString -> IO CInt

foreign import ccall safe "mathlink.h MLPutFunction" mlPutFunction
    :: Link -> CString -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLPutInteger16List" mlPutInt16List
    :: Link -> Ptr CShort -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLPutInteger32List" mlPutInt32List
    :: Link -> Ptr CInt -> CInt -> IO CInt

#ifdef USE_INT32
mlPutIntList 
    :: Link -> Ptr CInt -> CInt -> IO CInt
mlPutIntList = mlPutInt32List
#elif defined USE_INT64
foreign import ccall safe "mathlink.h MLPutInteger64List" mlPutIntList
    :: Link -> Ptr CLong -> CInt -> IO CInt
#endif

foreign import ccall safe "mathlink.h MLPutReal32List" mlPutReal32List
    :: Link -> Ptr CFloat -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLPutReal64List" mlPutReal64List
    :: Link -> Ptr CDouble -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLPutInteger16Array" mlPutInt16Array
    :: Link -> Ptr CShort -> Ptr CInt -> Ptr CString -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLPutInteger32Array" mlPutInt32Array
    :: Link -> Ptr CInt -> Ptr CInt -> Ptr CString -> CInt -> IO CInt

#ifdef USE_INT32
mlPutIntArray 
    :: Link -> Ptr CInt -> Ptr CInt -> Ptr CString -> CInt -> IO CInt
mlPutIntArray = mlPutInt32Array
#elif defined USE_INT64
foreign import ccall safe "mathlink.h MLPutInteger64Array" mlPutIntArray
    :: Link -> Ptr CLong -> Ptr CInt -> Ptr CString -> CInt -> IO CInt
#endif

foreign import ccall safe "mathlink.h MLPutReal32Array" mlPutReal32Array
    :: Link -> Ptr CFloat -> Ptr CInt -> Ptr CString -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLPutReal64Array" mlPutReal64Array
    :: Link -> Ptr CDouble -> Ptr CInt -> Ptr CString -> CInt -> IO CInt


-- gets

foreign import ccall safe "mathlink.h MLGetNext" mlGetNext
    :: Link -> IO CInt

foreign import ccall safe "mathlink.h MLGetType" mlGetType
    :: Link -> IO CInt

foreign import ccall safe "mathlink.h MLGetInteger16" mlGetInt16
    :: Link -> Ptr CInt -> IO CInt

foreign import ccall safe "mathlink.h MLGetInteger32" mlGetInt32
    :: Link -> Ptr CInt -> IO CInt

#ifdef USE_INT32
mlGetInt
    :: Link -> Ptr CInt -> IO CInt
mlGetInt = mlGetInt32
#elif defined USE_INT64
foreign import ccall safe "mathlink.h MLGetInteger64" mlGetInt
    :: Link -> Ptr CLong -> IO CInt
#endif

foreign import ccall safe "mathlink.h MLGetReal32" mlGetReal32
    :: Link -> Ptr CFloat -> IO CInt

foreign import ccall safe "mathlink.h MLGetReal64" mlGetReal64
    :: Link -> Ptr CDouble -> IO CInt

foreign import ccall safe "mathlink.h MLGetString" mlGetString
    :: Link -> Ptr CString -> IO CInt

foreign import ccall safe "mathlink.h MLReleaseString" mlReleaseString
    :: Link -> CString -> IO ()

foreign import ccall safe "mathlink.h MLGetSymbol" mlGetSymbol
    :: Link -> Ptr CString -> IO CInt

foreign import ccall safe "mathlink.h MLReleaseSymbol" mlReleaseSymbol
    :: Link -> CString -> IO ()

foreign import ccall safe "mathlink.h MLTestHead" mlTestHead
    :: Link -> CString -> Ptr CInt -> IO CInt

foreign import ccall safe "mathlink.h MLGetFunction" mlGetFunction
    :: Link -> Ptr CString -> Ptr CInt -> IO CInt

foreign import ccall safe "mathlink.h MLGetInteger16List" mlGetInt16List
    :: Link -> Ptr (Ptr CShort) -> Ptr CInt -> IO CInt

foreign import ccall safe "mathlink.h MLGetInteger32List" mlGetInt32List
    :: Link -> Ptr (Ptr CInt) -> Ptr CInt -> IO CInt

#ifdef USE_INT32
mlGetIntList
    :: Link -> Ptr (Ptr CInt) -> Ptr CInt -> IO CInt
mlGetIntList = mlGetInt32List
#elif defined USE_INT64
foreign import ccall safe "mathlink.h MLGetInteger64List" mlGetIntList
    :: Link -> Ptr (Ptr CLong) -> Ptr CInt -> IO CInt
#endif

foreign import ccall safe "mathlink.h MLGetReal32List" mlGetReal32List
    :: Link -> Ptr (Ptr CFloat) -> Ptr CInt -> IO CInt

foreign import ccall safe "mathlink.h MLGetReal64List" mlGetReal64List
    :: Link -> Ptr (Ptr CDouble) -> Ptr CInt -> IO CInt

foreign import ccall safe "mathlink.h MLReleaseInteger16List" mlReleaseInt16List
    :: Link -> Ptr CShort -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLReleaseInteger32List" mlReleaseInt32List
    :: Link -> Ptr CInt -> CInt -> IO CInt

#ifdef USE_INT32
mlReleaseIntList
    :: Link -> Ptr CInt -> CInt -> IO CInt
mlReleaseIntList = mlReleaseInt32List
#elif defined USE_INT64
foreign import ccall safe "mathlink.h MLReleaseInteger64List" mlReleaseIntList
    :: Link -> Ptr CLong -> CInt -> IO CInt
#endif

foreign import ccall safe "mathlink.h MLReleaseReal32List" mlReleaseReal32List
    :: Link -> Ptr CFloat -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLReleaseReal64List" mlReleaseReal64List
    :: Link -> Ptr CDouble -> CInt -> IO CInt

foreign import ccall safe "mathlink.h MLGetInteger16Array" mlGetInt16Array
    :: Link -> Ptr (Ptr CShort) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt

foreign import ccall safe "mathlink.h MLGetInteger32Array" mlGetInt32Array
    :: Link -> Ptr (Ptr CInt) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt

#ifdef USE_INT32
mlGetIntArray
    :: Link -> Ptr (Ptr CInt) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt
mlGetIntArray = mlGetInt32Array
#elif defined USE_INT64
foreign import ccall safe "mathlink.h MLGetInteger64Array" mlGetIntArray
    :: Link -> Ptr (Ptr CLong) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt
#endif

foreign import ccall safe "mathlink.h MLReleaseInteger16Array" mlReleaseInt16Array
    :: Link -> Ptr CShort -> Ptr CInt -> Ptr CString -> CInt -> IO ()

foreign import ccall safe "mathlink.h MLReleaseInteger32Array" mlReleaseInt32Array
    :: Link -> Ptr CInt -> Ptr CInt -> Ptr CString -> CInt -> IO ()

#ifdef USE_INT32
mlReleaseIntArray
    :: Link -> Ptr CInt -> Ptr CInt -> Ptr CString -> CInt -> IO ()
mlReleaseIntArray = mlReleaseInt32Array
#elif defined USE_INT64
foreign import ccall safe "mathlink.h MLReleaseInteger64Array" mlReleaseIntArray
    :: Link -> Ptr CLong -> Ptr CInt -> Ptr CString -> CInt -> IO ()
#endif

foreign import ccall safe "mathlink.h MLGetReal32Array" mlGetReal32Array
    :: Link -> Ptr (Ptr CFloat) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt

foreign import ccall safe "mathlink.h MLGetReal64Array" mlGetReal64Array
    :: Link -> Ptr (Ptr CDouble) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt

foreign import ccall safe "mathlink.h MLReleaseReal32Array" mlReleaseReal32Array
    :: Link -> Ptr CFloat -> Ptr CInt -> Ptr CString -> CInt -> IO ()

foreign import ccall safe "mathlink.h MLReleaseReal64Array" mlReleaseReal64Array
    :: Link -> Ptr CDouble -> Ptr CInt -> Ptr CString -> CInt -> IO ()