{-# 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)