mathlink-1.0.0.0: src/Foreign/MathLink/IO.hs
{-# LANGUAGE CPP, ForeignFunctionInterface, FlexibleContexts, DeriveDataTypeable #-}
{-# CFILES src/state.c #-}
module Foreign.MathLink.IO ( Link
, MessageCode(..)
, firstUserMessageCode
, lastUserMessageCode
, mkMessageCode
, TypeCode(..)
, mkTypeCode
, PacketCode(..)
, firstUserPacketCode
, lastUserPacketCode
, mkPacketCode
, ErrorCode(..)
, mkErrorCode
, MathLinkError(..)
, getLink
, checkAbort
, checkDone
, clearAbort
, initializeMathLink
, finalizeMathLink
, activate
, flush
, checkReady
, getError
, clearError
, getPacket
, endPacket
, newPacket
, getMessage
, putMessage
, checkMessage
, transferExpression
, putInt16
, getInt16
, putInt32
, getInt32
, putInt
, getInt
, putFloat
, getFloat
, putDouble
, getDouble
, putInt16List
, getInt16List
, putInt32List
, getInt32List
, putIntList
, getIntList
, putFloatList
, getFloatList
, putDoubleList
, getDoubleList
, putInt16Array
, getInt16Array
, putInt32Array
, getInt32Array
, putIntArray
, getIntArray
, putFloatArray
, getFloatArray
, putDoubleArray
, getDoubleArray
, putString
, getString
, putSymbol
, getSymbol
, putFunction
, getFunction
, getType
) where
import Foreign ( Ptr
, nullPtr
, malloc
, free
, peek
, poke
, Storable
, withArray
, peekArray
)
import Foreign.C ( peekCString
, withCString
, CString
, CInt
, CShort
, CLong
, CFloat
, CDouble
)
import Control.Exception
import Data.Int
import Data.Typeable
-- 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
-- | An enumeration of some error codes defined in @mathlink.h@.
data ErrorCode = NoErrorCode
| DeadLnkErrorCode
| GetInconsistentErrorCode
| GetOutOfSeqErrorCode
| PutBadTokErrorCode
| PutOutOfSeqErrorCode
| PutTooBigErrorCode
| MachineOverflowErrorCode
| OutOfMemoryErrorCode
| SocketUnacceptedErrorCode
| UnconnectedErrorCode
| PutEndPacketErrorCode
| NextIncompleteCurrentPacketErrorCode
| NextUnknownPacketErrorCode
| GetEndPacketErrorCode
| AbortErrorCode
| ClosedErrorCode
| InitErrorCode
| ArgvErrorCode
| ProtocolErrorCode
| ModeErrorCode
| LaunchErrorCode
| RelaunchErrorCode
| LaunchSpaceErrorCode
| NoParentErrorCode
| NameTakenErrorCode
| NoListenErrorCode
| BadNameErrorCode
| BadHostErrorCode
| LaunchFailedErrorCode
| LaunchNameErrorCode
| PutConvertErrorCode
| GetConvertErrorCode
| PutBadEncodingErrorCode
| UnknownErrorCode Int
deriving (Eq,Show)
instance Enum ErrorCode where
fromEnum r =
case r of
NoErrorCode -> 0
DeadLnkErrorCode -> 1
GetInconsistentErrorCode -> 2
GetOutOfSeqErrorCode -> 3
PutBadTokErrorCode -> 4
PutOutOfSeqErrorCode -> 5
PutTooBigErrorCode -> 6
MachineOverflowErrorCode -> 7
OutOfMemoryErrorCode -> 8
SocketUnacceptedErrorCode -> 9
UnconnectedErrorCode -> 10
PutEndPacketErrorCode -> 21
NextIncompleteCurrentPacketErrorCode -> 22
NextUnknownPacketErrorCode -> 23
GetEndPacketErrorCode -> 24
AbortErrorCode -> 25
ClosedErrorCode -> 11
InitErrorCode -> 32
ArgvErrorCode -> 33
ProtocolErrorCode -> 34
ModeErrorCode -> 35
LaunchErrorCode -> 36
RelaunchErrorCode -> 37
LaunchSpaceErrorCode -> 38
NoParentErrorCode -> 39
NameTakenErrorCode -> 40
NoListenErrorCode -> 41
BadNameErrorCode -> 42
BadHostErrorCode -> 43
LaunchFailedErrorCode -> 45
LaunchNameErrorCode -> 46
PutConvertErrorCode -> 48
GetConvertErrorCode -> 49
PutBadEncodingErrorCode -> 47
UnknownErrorCode i -> i
toEnum i =
case i of
0 -> NoErrorCode
1 -> DeadLnkErrorCode
2 -> GetInconsistentErrorCode
3 -> GetOutOfSeqErrorCode
4 -> PutBadTokErrorCode
5 -> PutOutOfSeqErrorCode
6 -> PutTooBigErrorCode
7 -> MachineOverflowErrorCode
8 -> OutOfMemoryErrorCode
9 -> SocketUnacceptedErrorCode
10 -> UnconnectedErrorCode
21 -> PutEndPacketErrorCode
22 -> NextIncompleteCurrentPacketErrorCode
23 -> NextUnknownPacketErrorCode
24 -> GetEndPacketErrorCode
25 -> AbortErrorCode
11 -> ClosedErrorCode
32 -> InitErrorCode
33 -> ArgvErrorCode
34 -> ProtocolErrorCode
35 -> ModeErrorCode
36 -> LaunchErrorCode
37 -> RelaunchErrorCode
38 -> LaunchSpaceErrorCode
39 -> NoParentErrorCode
40 -> NameTakenErrorCode
41 -> NoListenErrorCode
42 -> BadNameErrorCode
43 -> BadHostErrorCode
45 -> LaunchFailedErrorCode
46 -> LaunchNameErrorCode
48 -> PutConvertErrorCode
49 -> GetConvertErrorCode
47 -> PutBadEncodingErrorCode
i -> UnknownErrorCode i
instance Ord ErrorCode where
compare e1 e2 = compare (fromEnum e1) (fromEnum e2)
-- | Turns an 'Integral' into the corresponding 'ErrorCode'.
mkErrorCode :: Integral a => a -> ErrorCode
mkErrorCode = toEnum . fromIntegral
-- | An enumeration of /MathLink/ message types.
data MessageCode = TerminateMessageCode
| InterruptMessageCode
| AbortMessageCode
| EndPacketMessageCode
| SynchronizeMessageCode
| ImDyingMessageCode
| WaitingAcknowledgementMessageCode
| MarkTopLevelMessageCode
| LinkClosingMessageCode
| AuthenticateFailureMessageCode
| UserMessageCode Int
| UnknownMessageCode Int
deriving (Eq,Show)
instance Enum MessageCode where
fromEnum m =
case m of
TerminateMessageCode -> 1
InterruptMessageCode -> 2
AbortMessageCode -> 3
EndPacketMessageCode -> 4
SynchronizeMessageCode -> 5
ImDyingMessageCode -> 6
WaitingAcknowledgementMessageCode -> 7
MarkTopLevelMessageCode -> 8
LinkClosingMessageCode -> 9
AuthenticateFailureMessageCode -> 10
UserMessageCode i -> i
UnknownMessageCode i -> i
toEnum i =
case i of
i | i >= 128 && i <= 255 -> UserMessageCode i
1 -> TerminateMessageCode
2 -> InterruptMessageCode
3 -> AbortMessageCode
4 -> EndPacketMessageCode
5 -> SynchronizeMessageCode
6 -> ImDyingMessageCode
7 -> WaitingAcknowledgementMessageCode
8 -> MarkTopLevelMessageCode
9 -> LinkClosingMessageCode
10 -> AuthenticateFailureMessageCode
i -> UnknownMessageCode i
instance Ord MessageCode where
compare m1 m2 = compare (fromEnum m1) (fromEnum m2)
firstUserMessageCode :: MessageCode
firstUserMessageCode = UserMessageCode 128
lastUserMessageCode :: MessageCode
lastUserMessageCode = UserMessageCode 255
mkMessageCode :: Integral a => a -> MessageCode
mkMessageCode = toEnum . fromIntegral
-- | An enumeration of /MathLink/ packet types
data PacketCode = IllegalPacketCode
| CallPacketCode
| EvaluatePacketCode
| ReturnPacketCode
| InputNamePacketCode
| EnterTextPacketCode
| EnterExpressionPacketCode
| OutputNamePacketCode
| ReturnTextPacketCode
| ReturnExpressionPacketCode
| DisplayPacketCode
| DisplayEndPacketCode
| MessagePacketCode
| TextPacketCode
| InputPacketCode
| InputStringPacketCode
| MenuPacketCode
| SyntaxPacketCode
| SuspendPacketCode
| ResumePacketCode
| BeginDialogPacketCode
| EndDialogPacketCode
| UserPacketCode Int
| UnknownPacketCode Int
deriving (Eq,Show)
instance Enum PacketCode where
fromEnum p =
case p of
IllegalPacketCode -> 0
CallPacketCode -> 7
EvaluatePacketCode -> 13
ReturnPacketCode -> 3
InputNamePacketCode -> 8
EnterTextPacketCode -> 14
EnterExpressionPacketCode -> 15
OutputNamePacketCode -> 9
ReturnTextPacketCode -> 4
ReturnExpressionPacketCode -> 16
DisplayPacketCode -> 11
DisplayEndPacketCode -> 12
MessagePacketCode -> 5
TextPacketCode -> 2
InputPacketCode -> 1
InputStringPacketCode -> 21
MenuPacketCode -> 6
SyntaxPacketCode -> 10
SuspendPacketCode -> 17
ResumePacketCode -> 18
BeginDialogPacketCode -> 19
EndDialogPacketCode -> 20
UserPacketCode i -> i
UnknownPacketCode i -> i
toEnum i =
case i of
0 -> IllegalPacketCode
7 -> CallPacketCode
13 -> EvaluatePacketCode
3 -> ReturnPacketCode
8 -> InputNamePacketCode
14 -> EnterTextPacketCode
15 -> EnterExpressionPacketCode
9 -> OutputNamePacketCode
4 -> ReturnTextPacketCode
16 -> ReturnExpressionPacketCode
11 -> DisplayPacketCode
12 -> DisplayEndPacketCode
5 -> MessagePacketCode
2 -> TextPacketCode
1 -> InputPacketCode
21 -> InputStringPacketCode
6 -> MenuPacketCode
10 -> SyntaxPacketCode
17 -> SuspendPacketCode
18 -> ResumePacketCode
19 -> BeginDialogPacketCode
20 -> EndDialogPacketCode
i | i >= 128 && i <= 255 -> UserPacketCode i
i -> UnknownPacketCode i
instance Ord PacketCode where
compare p1 p2 = compare (fromEnum p1) (fromEnum p2)
firstUserPacketCode :: PacketCode
firstUserPacketCode = UserPacketCode 128
lastUserPacketCode :: PacketCode
lastUserPacketCode = UserPacketCode 255
mkPacketCode :: Integral a => a -> PacketCode
mkPacketCode = toEnum . fromIntegral
-- | An enumeriation of possible return values from the /MathLink/ functions @MLGetNext@ or @MLGetType@.
data TypeCode = ErrorTypeCode
| IntTypeCode
| RealTypeCode
| StringTypeCode
| SymbolTypeCode
| FunctionTypeCode
| UnknownTypeCode Int
deriving (Eq,Show)
instance Enum TypeCode where
fromEnum t =
case t of
ErrorTypeCode -> 0
IntTypeCode -> 43
RealTypeCode -> 42
StringTypeCode -> 34
SymbolTypeCode -> 35
FunctionTypeCode -> 70
UnknownTypeCode i -> i
toEnum i =
case i of
0 -> ErrorTypeCode
43 -> IntTypeCode
42 -> RealTypeCode
34 -> StringTypeCode
35 -> SymbolTypeCode
70 -> FunctionTypeCode
73 -> IntTypeCode -- old int type
82 -> RealTypeCode -- old real type
83 -> StringTypeCode -- old string type
89 -> SymbolTypeCode -- old symbol type
i -> UnknownTypeCode i
instance Ord TypeCode where
compare t1 t2 = compare (fromEnum t1) (fromEnum t2)
mkTypeCode :: Integral a => a -> TypeCode
mkTypeCode = toEnum . fromIntegral
data MathLinkError = MathLinkError ErrorCode String
deriving (Eq,Show,Typeable)
instance Exception MathLinkError where
toException = SomeException
fromException (SomeException e) = cast e
type MathLinkMessage = (MessageCode,Int)
newtype Link = Link (Ptr ()) deriving (Eq)
-- state
foreign import ccall safe "mathlink.h & MLAbort" abortPtr
:: Ptr CInt
foreign import ccall safe "mathlink.h & MLDone" donePtr
:: Ptr CInt
foreign import ccall safe "mathlink.h & stdlink" stdlinkPtr
:: Ptr (Ptr ())
checkAbort :: IO Bool
checkAbort = do
i <- peek abortPtr
if i == 0 then
return False
else
return True
checkDone :: IO Bool
checkDone = do
i <- peek donePtr
if i == 0 then
return False
else
return True
clearAbort :: IO ()
clearAbort = poke abortPtr 0
getLink :: IO Link
getLink = peek stdlinkPtr >>= (return . Link)
-- initialization / termination
foreign import ccall safe "MLInitializeMathLink" mlInitializeMathLink
:: CString -> IO CInt
initializeMathLink :: String -> IO Bool
initializeMathLink str= do
i <- withCString str (\cstr -> mlInitializeMathLink cstr)
if i == 0 then return False else return True
foreign import ccall safe "MLFinalizeMathLink" mlFinalizeMathLink
:: IO ()
finalizeMathLink :: IO ()
finalizeMathLink = mlFinalizeMathLink
foreign import ccall safe "mathlink.h MLActivate" mlActivate
:: Link -> IO CInt
activate :: IO (Maybe MathLinkError)
activate = getLink >>= mlActivate >>= maybeError
foreign import ccall safe "mathlink.h MLFlush" mlFlush
:: Link -> IO CInt
flush :: IO (Maybe MathLinkError)
flush = getLink >>= mlFlush >>= maybeError
foreign import ccall safe "mathlink.h MLReady" mlReady
:: Link -> IO CInt
checkReady :: IO Bool
checkReady = do
i <- getLink >>= mlReady
if i /= 0 then
return True
else
return False
-- errors
foreign import ccall safe "mathlink.h MLError" mlError
:: Link -> IO CInt
foreign import ccall safe "mathlink.h MLErrorMessage" mlErrorMessage
:: Link -> IO CString
foreign import ccall safe "mathlink.h MLClearError" mlClearError
:: Link -> IO CInt
getErrorCode :: IO ErrorCode
getErrorCode = getLink >>= mlError >>= (return . mkErrorCode)
getErrorMessage :: IO String
getErrorMessage = getLink >>= mlErrorMessage >>= peekCString
getError :: IO MathLinkError
getError = do code <- getErrorCode
msg <- getErrorMessage
return $ MathLinkError code msg
clearError :: IO (Maybe MathLinkError)
clearError = getLink >>= mlClearError >>= maybeError
maybeError :: Integral a => a -> IO (Maybe MathLinkError)
maybeError i =
if i /= 0 then
return Nothing
else
getError >>= (return . Just)
valueOrError :: Integral a => b -> a -> IO (Either MathLinkError b)
valueOrError val i =
if i /= 0 then
return $ Right val
else
getError >>= (return . Left)
-- packets
foreign import ccall safe "mathlink.h MLNextPacket" mlNextPacket
:: Link -> IO CInt
getPacket :: IO PacketCode
getPacket = getLink >>= mlNextPacket >>= (return . toEnum . fromIntegral)
foreign import ccall safe "mathlink.h MLEndPacket" mlEndPacket
:: Link -> IO CInt
endPacket :: IO (Maybe MathLinkError)
endPacket = getLink >>= mlEndPacket >>= maybeError
foreign import ccall safe "mathlink.h MLNewPacket" mlNewPacket
:: Link -> IO CInt
newPacket :: IO (Maybe MathLinkError)
newPacket = getLink >>= mlNewPacket >>= maybeError
-- messages
foreign import ccall safe "mathlink.h MLGetMessage" mlGetMessage
:: Link -> Ptr CInt -> Ptr CInt -> IO CInt
getMessage :: IO (Maybe MathLinkMessage)
getMessage = do
l <- getLink
bracket malloc free $ \mPtr ->
bracket malloc free $ \aPtr -> do
i <- mlGetMessage l mPtr aPtr
if i /= 0 then do
msgId <- peek mPtr
arg <- peek aPtr
return $ Just (mkMessageCode msgId, fromIntegral arg)
else
return $ Nothing
foreign import ccall safe "mathlink.h MLPutMessage" mlPutMessage
:: Link -> CInt -> IO CInt
putMessage :: MessageCode -> IO (Maybe MathLinkError)
putMessage m = do
l <- getLink
mlPutMessage l (fromIntegral $ fromEnum m) >>= maybeError
foreign import ccall safe "mathlink.h MLMessageReady" mlMessageReady
:: Link -> IO CInt
checkMessage :: IO Bool
checkMessage = do
i <- getLink >>= mlMessageReady
if i /= 0 then
return True
else
return False
-- misc
foreign import ccall safe "mathlink.h MLTransferExpression" mlTransferExpression
:: Link -> Link -> IO CInt
transferExpression :: Link -> Link -> IO (Maybe MathLinkError)
transferExpression l1 l2 = mlTransferExpression l1 l2 >>= maybeError
-- ** data marshalling **
-- scalars
foreign import ccall safe "mathlink.h MLPutInteger16" mlPutInt16
:: Link -> CInt -> IO CInt
foreign import ccall safe "mathlink.h MLPutInteger32" mlPutInt32
:: Link -> CInt -> IO CInt
#ifdef USE_INT32
mlPutInt = mlPutInt32
#elif defined USE_INT64
foreign import ccall safe "mathlink.h MLPutInteger64" mlPutInt
:: Link -> CLong -> IO CInt
#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 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
putScalarWith :: (Link -> b -> IO CInt)
-> (a -> b)
-> a
-> IO (Maybe MathLinkError)
putScalarWith fn cnv i = do
l <- getLink
fn l (cnv i) >>= maybeError
getScalarWith :: Storable a
=> (Link -> Ptr a -> IO CInt)
-> (a -> b)
-> IO (Either MathLinkError b)
getScalarWith fn cnv = do
l <- getLink
bracket malloc free $ \xPtr -> do
result <- fn l xPtr >>= maybeError
case result of
Nothing ->
peek xPtr >>= (return . Right . cnv)
Just err ->
return $ Left err
putInt16 :: Integral a => a -> IO (Maybe MathLinkError)
putInt16 = putScalarWith mlPutInt16 fromIntegral
getInt16 :: Num a => IO (Either MathLinkError a)
getInt16 = getScalarWith mlGetInt16 fromIntegral
putInt32 :: Integral a => a -> IO (Maybe MathLinkError)
putInt32 = putScalarWith mlPutInt32 fromIntegral
getInt32 :: Num a => IO (Either MathLinkError a)
getInt32 = getScalarWith mlGetInt32 fromIntegral
putInt :: Integral a => a -> IO (Maybe MathLinkError)
putInt = putScalarWith mlPutInt fromIntegral
getInt :: Num a => IO (Either MathLinkError a)
getInt = getScalarWith mlGetInt fromIntegral
putFloat :: Real a => a -> IO (Maybe MathLinkError)
putFloat = putScalarWith mlPutReal32 realToFrac
getFloat :: Fractional a => IO (Either MathLinkError a)
getFloat = getScalarWith mlGetReal32 realToFrac
putDouble :: Real a => a -> IO (Maybe MathLinkError)
putDouble = putScalarWith mlPutReal64 realToFrac
getDouble :: Fractional a => IO (Either MathLinkError a)
getDouble = getScalarWith mlGetReal64 realToFrac
-- string-like data
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 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 MLGetFunction" mlGetFunction
:: Link -> Ptr CString -> Ptr CInt -> IO CInt
putStringWith :: (Link -> CString -> IO CInt)
-> String
-> IO (Maybe MathLinkError)
putStringWith fn str = do
l <- getLink
withCString str $ \sPtr -> fn l sPtr >>= maybeError
getStringWith :: (Link -> Ptr CString -> IO CInt)
-> (Link -> CString -> IO ())
-> IO (Either MathLinkError String)
getStringWith afn rfn = do
l <- getLink
bracket malloc free $ \strPtrPtr -> do
result <- afn l strPtrPtr >>= maybeError
case result of
Nothing -> do
strPtr <- peek strPtrPtr
str <- peekCString strPtr
rfn l strPtr
return $ Right str
Just err ->
return $ Left err
putString :: String -> IO (Maybe MathLinkError)
putString = putStringWith mlPutString
getString :: IO (Either MathLinkError String)
getString = getStringWith mlGetString mlReleaseString
putSymbol :: String -> IO (Maybe MathLinkError)
putSymbol = putStringWith mlPutSymbol
getSymbol :: IO (Either MathLinkError String)
getSymbol = getStringWith mlGetSymbol mlReleaseSymbol
putFunction :: String -> Int -> IO (Maybe MathLinkError)
putFunction hd n =
putStringWith (\l' s -> mlPutFunction l' s (fromIntegral n)) hd
getFunction :: IO (Either MathLinkError (String,Int))
getFunction = do
l <- getLink
bracket malloc free $ \strPtrPtr ->
bracket malloc free $ \nPtr -> do
result <- mlGetFunction l strPtrPtr nPtr >>= maybeError
case result of
Nothing -> do
strPtr <- peek strPtrPtr
str <- peekCString strPtr
n <- peek nPtr
mlReleaseSymbol l strPtr
return $ Right (str,fromIntegral n)
Just err ->
return $ Left err
-- lists
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 = 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 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 = 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 = 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
putListWith :: Storable a
=> (Link -> Ptr a -> CInt -> IO CInt)
-> (b -> a)
-> [b]
-> IO (Maybe MathLinkError)
putListWith fn cnv xs = do
l <- getLink
withArray (map cnv xs) $ \xPtr -> fn l xPtr n >>= maybeError
where n = fromIntegral $ length xs
getListWith :: Storable a
=> (Link -> Ptr (Ptr a) -> Ptr CInt -> IO CInt)
-> (Link -> Ptr a -> CInt -> IO CInt)
-> (a -> b)
-> IO (Either MathLinkError [b])
getListWith afn rfn cnv = do
l <- getLink
bracket malloc free $ \xPtrPtr ->
bracket malloc free $ \nPtr -> do
result <- afn l xPtrPtr nPtr >>= maybeError
case result of
Nothing -> do
xPtr <- peek xPtrPtr
n <- peek nPtr
xs <- peekArray (fromIntegral n) xPtr
rfn l xPtr n
return $ Right (map cnv xs)
Just err ->
return $ Left err
putInt16List :: Integral a => [a] -> IO (Maybe MathLinkError)
putInt16List = putListWith mlPutInt16List fromIntegral
getInt16List :: Num a => IO (Either MathLinkError [a])
getInt16List =
getListWith mlGetInt16List mlReleaseInt16List fromIntegral
putInt32List :: Integral a => [a] -> IO (Maybe MathLinkError)
putInt32List = putListWith mlPutInt32List fromIntegral
getInt32List :: Num a => IO (Either MathLinkError [a])
getInt32List =
getListWith mlGetInt32List mlReleaseInt32List fromIntegral
putIntList :: Integral a => [a] -> IO (Maybe MathLinkError)
putIntList = putListWith mlPutIntList fromIntegral
getIntList :: Num a => IO (Either MathLinkError [a])
getIntList =
getListWith mlGetIntList mlReleaseIntList fromIntegral
putFloatList :: Real a => [a] -> IO (Maybe MathLinkError)
putFloatList = putListWith mlPutReal32List realToFrac
getFloatList :: Fractional a => IO (Either MathLinkError [a])
getFloatList =
getListWith mlGetReal32List mlReleaseReal32List realToFrac
putDoubleList :: Real a => [a] -> IO (Maybe MathLinkError)
putDoubleList = putListWith mlPutReal64List realToFrac
getDoubleList :: Fractional a => IO (Either MathLinkError [a])
getDoubleList =
getListWith mlGetReal64List mlReleaseReal64List realToFrac
-- arrays
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 = 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
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 ()
putArrayWith :: ( Storable a
)
=> (Link -> Ptr a -> Ptr CInt -> Ptr CString -> CInt -> IO CInt)
-> (b -> a)
-> [Int]
-> [b]
-> IO (Maybe MathLinkError)
putArrayWith fn cnv dims xs = do
l <- getLink
(withArray (take sz (map cnv xs)) $ \xPtr ->
withArray (map fromIntegral dims) $ \dimPtr ->
withCString "List" $ \strPtr ->
withArray (replicate rank strPtr) $ \hdsPtr ->
fn l xPtr dimPtr hdsPtr (fromIntegral rank)) >>= maybeError
where rank = length dims
sz = product dims
getArrayWith :: ( Storable a
)
=> (Link -> Ptr (Ptr a) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt)
-> (Link -> Ptr a -> Ptr CInt -> Ptr CString -> CInt -> IO ())
-> (a -> b)
-> IO (Either MathLinkError ([Int],[b]))
getArrayWith afn rfn cnv = do
l <- getLink
bracket malloc free $ \xPtrPtr ->
bracket malloc free $ \dimPtrPtr ->
bracket malloc free $ \headPtrPtr ->
bracket malloc free $ \rankPtr -> do
result <-
afn l xPtrPtr dimPtrPtr headPtrPtr rankPtr >>= maybeError
case result of
Nothing -> do
rank' <- peek rankPtr
let rank = fromIntegral rank'
dimPtr <- peek dimPtrPtr
dims' <- peekArray rank dimPtr
let dims = map fromIntegral dims'
sz = product dims
xPtr <- peek xPtrPtr
xs' <- peekArray sz xPtr
headPtr <- peek headPtrPtr
rfn l xPtr dimPtr headPtr rank'
return $ Right $ (dims,(map cnv xs'))
Just err ->
return $ Left err
putInt16Array :: Integral a => [Int] -> [a] -> IO (Maybe MathLinkError)
putInt16Array = putArrayWith mlPutInt16Array fromIntegral
putInt32Array :: Integral a => [Int] -> [a] -> IO (Maybe MathLinkError)
putInt32Array = putArrayWith mlPutInt32Array fromIntegral
putIntArray :: Integral a => [Int] -> [a] -> IO (Maybe MathLinkError)
putIntArray = putArrayWith mlPutIntArray fromIntegral
putFloatArray :: Real a => [Int] -> [a] -> IO (Maybe MathLinkError)
putFloatArray = putArrayWith mlPutReal32Array realToFrac
putDoubleArray :: Real a => [Int] -> [a] -> IO (Maybe MathLinkError)
putDoubleArray = putArrayWith mlPutReal64Array realToFrac
getInt16Array :: Num a => IO (Either MathLinkError ([Int],[a]))
getInt16Array =
getArrayWith mlGetInt16Array mlReleaseInt16Array fromIntegral
getInt32Array :: Num a => IO (Either MathLinkError ([Int],[a]))
getInt32Array =
getArrayWith mlGetInt32Array mlReleaseInt32Array fromIntegral
getIntArray :: Num a => IO (Either MathLinkError ([Int],[a]))
getIntArray =
getArrayWith mlGetIntArray mlReleaseIntArray fromIntegral
getFloatArray :: Fractional a => IO (Either MathLinkError ([Int],[a]))
getFloatArray =
getArrayWith mlGetReal32Array mlReleaseReal32Array realToFrac
getDoubleArray :: Fractional a => IO (Either MathLinkError ([Int],[a]))
getDoubleArray =
getArrayWith mlGetReal64Array mlReleaseReal64Array realToFrac
-- input testing
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 MLTestHead" mlTestHead
:: Link -> CString -> Ptr CInt -> IO CInt
getType :: IO TypeCode
getType = getLink >>= mlGetType >>= (return . mkTypeCode)