MathLink.hs revision a3b8d685ae08bf3f83a6c2930e872183c487c844
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz{-# LANGUAGE TypeSynonymInstances #-}
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzModule : $Header$
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzDescription : A Haskell MathLink interface
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzCopyright : (c) Ewaryst Schulz, DFKI Bremen 2011
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzLicense : GPLv2 or higher, see LICENSE.txt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzMaintainer : Ewaryst.Schulz@dfki.de
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzStability : experimental
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzPortability : non-portable (see language extensions)
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzA Haskell MathLink interface based on the Foreign.MathLink.Bindings module
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport Foreign.C -- get the C types
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport Foreign.Marshal -- get the array marshalling utils
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport Foreign.Ptr (Ptr,nullPtr)
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * Constants for the MathLink interface
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKAEND, dfMLTKALL_DECODERS, dfMLTKAPCTEND, dfMLTKARRAY, dfMLTKARRAY_DECODER
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz , dfMLTKCONT, dfMLTKDIM, dfMLTKELEN, dfMLTKEND, dfMLTKERR, dfMLTKERROR
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz , dfMLTKFUNC, dfMLTKINT, dfMLTKMODERNCHARS_DECODER, dfMLTKNULL
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz , dfMLTKNULLSEQUENCE_DECODER, dfMLTKOLDINT, dfMLTKOLDREAL, dfMLTKOLDSTR
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz , dfMLTKOLDSYM, dfMLTKPACKED_DECODER, dfMLTKPACKED, dfMLTKPCTEND, dfMLTKREAL
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz , dfMLTKSEND, dfMLTKSTR, dfMLTKSYM, dfRETURNPKT, dfRETURNTEXTPKT
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz , dfRETURNEXPRPKT :: CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfRETURNPKT = 3
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfRETURNTEXTPKT = 4
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfRETURNEXPRPKT = 16
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKALL_DECODERS=983040
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKAPCTEND=10
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKARRAY=65
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKARRAY_DECODER=262144
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKMODERNCHARS_DECODER=524288
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKNULLSEQUENCE_DECODER=0
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKOLDINT=73
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKOLDREAL=82
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKOLDSTR=83
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKOLDSYM=89
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKPACKED_DECODER=131072
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKPACKED=80
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfMLTKPCTEND=93
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * MathLink monad as Reader IO monad
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzdata MLState =
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz { mlink :: MLINK
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz , logHdl :: Maybe Handle
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmkState :: MLINK -> MLState
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmkState mlp = MLState { mlink = mlp, logHdl = Nothing }
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmkStateWithLog :: MLINK -> Handle -> MLState
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmkStateWithLog mlp hdl = MLState { mlink = mlp, logHdl = Just hdl }
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulztype ML = ReaderT MLState IO
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzaskMLink :: ML MLINK
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzaskMLink = asks mlink
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzlogMessage :: String -> ML ()
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzlogMessage s = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz mHdl <- asks logHdl
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Just hdl -> liftIO $ hPutStr hdl s
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Nothing -> liftIO $ putStr s
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzlogMessageLn :: String -> ML ()
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzlogMessageLn s = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz mHdl <- asks logHdl
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Just hdl -> liftIO $ hPutStrLn hdl s
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Nothing -> liftIO $ putStrLn s
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzliftMLIO :: (MLINK -> IO b) -> ML b
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzliftMLIO f = askMLink >>= liftIO . f
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * MathLink connection handling
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzconnectLink :: MLINK -> IO Bool
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzconnectLink lp = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz let p i j = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz i' <- cMlReady lp
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz if toBool i' || j > 3000 then return j
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz else cMlFlush lp >> if i > 1000 then p 0 (j+1) else p (i+1) j
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz p (0::Int) (0::Int) >>= putStrLn . ("ready after " ++) . show
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz res <- cMlConnect lp
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz return $ toBool res
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzrunLink :: Maybe FilePath -> Maybe String -> ML a -> IO (Either Int a)
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzrunLink mFP mName mlprog = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- env <- mlInitialize ""
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz env <- cMlInitialize nullPtr
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz if (env == nullPtr) then return $ Left 1
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz putStrLn "Initialized"
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz let (name, mode) = case mName of
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Just n -> (n, "connect")
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz _ -> ("math -mathlink", "launch")
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz let openargs = ["-linkname", name, "-linkmode", mode]
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz lp <- mlOpen 4 openargs
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz mB <- if lp == nullPtr then return Nothing
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- else liftM Just $ connectLink lp
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz else timeout 3000000 $ connectLink lp
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Nothing -> return $ Left 2
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Just False -> return $ Left 3
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz putStrLn "Opened"
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz x <- case mFP of
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz withFile fp WriteMode $ runReaderT mlprog . mkStateWithLog lp
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz runReaderT mlprog $ mkState lp
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz mlDeinitialize env
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz return $ Right x
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlInitialize :: String -> IO MLEnvironment
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlInitialize = flip withCString cMlInitialize
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlDeinitialize :: MLEnvironment -> IO ()
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlDeinitialize = cMlDeinitialize
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlOpen :: CInt -> [String] -> IO MLINK
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlOpen i l = withStringArray l $ cMlOpen i
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * C to Haskell utilities
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzwithStringArray :: MonadIO m => [String] -> (Ptr CString -> IO b) -> m b
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzwithStringArray l f = liftIO $ mapM newCString l >>= flip withArray f
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetA :: (Storable a, Show a, Show b) => (Ptr a -> IO b) -> IO a
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetA f = let g ptr = f ptr >> peek ptr in alloca g
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- maybe better via foreign pointer, check later
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetCString :: Show b => (Ptr CString -> IO b) -> (CString -> IO ()) -> IO String
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetCString f disownF =
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz let g ptr = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz cs <- f ptr >> peek ptr
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz s <- peekCString cs
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * Haskell friendly MathLink interface built on top of the raw bindings
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlClose :: MLINK -> IO CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlClose = cMlClose
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlFlush :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlFlush = liftMLIO cMlFlush
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlReady :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlReady = liftMLIO cMlReady
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlConnect :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlConnect = liftMLIO cMlConnect
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlEndPacket :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlEndPacket = liftMLIO cMlEndPacket
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlNextPacket :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlNextPacket = liftMLIO cMlNextPacket
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlNewPacket :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlNewPacket = liftMLIO cMlNewPacket
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetNext :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetNext = liftMLIO cMlGetNext
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetArgCount :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetArgCount = askMLink >>= liftIO . mlGetA . cMlGetArgCount
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- cMlGetSymbol :: MLINK -> Ptr CString -> IO CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetSymbol :: ML String
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetSymbol = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz ml <- askMLink
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz liftIO $ mlGetCString (cMlGetSymbol ml) $ cMlDisownSymbol ml
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- cMlGetString :: MLINK -> Ptr CString -> IO CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetString :: ML String
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz--mlGetString = askMLink >>= liftIO . mlGetCString . cMlGetString
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetString = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz ml <- askMLink
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz liftIO $ mlGetCString (cMlGetString ml) $ cMlDisownString ml
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- cMlGetReal :: MLINK -> Ptr CDouble -> IO CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetReal :: ML CDouble
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetReal = askMLink >>= liftIO . mlGetA . cMlGetReal
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- cMlGetInteger :: MLINK -> Ptr CInt -> IO CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetInteger :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetInteger = askMLink >>= liftIO . mlGetA . cMlGetInteger
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutString :: String -> ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutString s = liftMLIO f where
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz f ml = withCString s $ cMlPutString ml
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutSymbol :: String -> ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutSymbol s = liftMLIO f where
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz f ml = withCString s $ cMlPutSymbol ml
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutFunction :: String -> CInt -> ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutFunction s i = liftMLIO f where
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz f ml = withCString s $ flip (cMlPutFunction ml) i
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutInteger :: CInt -> ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutInteger = liftMLIO . flip cMlPutInteger
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlError :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlError = liftMLIO cMlError
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlErrorMessage :: ML String
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlErrorMessage = liftMLIO (cMlErrorMessage >=> peekCString)
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * MathLink interface utils
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlProcError :: ML ()
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlProcError = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz eid <- mlError
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz if toBool eid then mlErrorMessage >>= logMessageLn . ("Error detected by MathLink: " ++)
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz else logMessageLn "Error detected by Interface"
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzreceivePacket :: ML ()
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzreceivePacket = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz -- skip any packets before the first ReturnPacket
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz waitUntilPacket (0::Int) [dfRETURNPKT, dfRETURNEXPRPKT, dfRETURNTEXTPKT]
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzwaitUntilPacket :: Num a => a -> [CInt] -> ML ()
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzwaitUntilPacket i l = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz np <- mlNextPacket
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz if elem np l then logMessageLn $ "GotReturn after " ++ show i ++ " iterations"
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz else (logMessageLn $ "wap: " ++ show np) >> mlNewPacket >> waitUntilPacket (i+1) l