{-# LANGUAGE TypeSynonymInstances #-}
{- |
Module : ./Common/MathLink.hs
Description : A Haskell MathLink interface
Copyright : (c) Ewaryst Schulz, DFKI Bremen 2011
License : GPLv2 or higher, see LICENSE.txt
Maintainer : Ewaryst.Schulz@dfki.de
Stability : experimental
Portability : non-portable (see language extensions)
A Haskell MathLink interface based on the Foreign.MathLink.Bindings module
-}
module Common.MathLink where
import Foreign.C -- get the C types
import Foreign.Marshal -- get the array marshalling utils
import Foreign.Storable
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.MathLink.Bindings
import Control.Monad.Reader
import System.Timeout
import System.IO
import Data.Maybe
import Common.Utils (verbMsg, verbMsgLn, verbMsgIOLn)
-- * Constants for the MathLink interface
dfMLTKAEND, dfMLTKALL_DECODERS, dfMLTKAPCTEND, dfMLTKARRAY,
dfMLTKARRAY_DECODER , dfMLTKCONT, dfMLTKDIM, dfMLTKELEN, dfMLTKEND,
dfMLTKERR, dfMLTKERROR , dfMLTKFUNC, dfMLTKINT,
dfMLTKMODERNCHARS_DECODER, dfMLTKNULL , dfMLTKNULLSEQUENCE_DECODER,
dfMLTKOLDINT, dfMLTKOLDREAL, dfMLTKOLDSTR , dfMLTKOLDSYM,
dfMLTKPACKED_DECODER, dfMLTKPACKED, dfMLTKPCTEND, dfMLTKREAL ,
dfMLTKSEND, dfMLTKSTR, dfMLTKSYM, dfILLEGALPKT, dfCALLPKT,
dfEVALUATEPKT , dfRETURNPKT, dfINPUTNAMEPKT, dfENTERTEXTPKT,
dfENTEREXPRPKT, dfOUTPUTNAMEPKT, dfRETURNTEXTPKT, dfRETURNEXPRPKT,
dfDISPLAYPKT, dfDISPLAYENDPKT, dfMESSAGEPKT, dfTEXTPKT, dfINPUTPKT,
dfINPUTSTRPKT, dfMENUPKT, dfSYNTAXPKT, dfSUSPENDPKT, dfRESUMEPKT,
dfBEGINDLGPKT, dfENDDLGPKT, dfFIRSTUSERPKT, dfLASTUSERPKT :: CInt
dfILLEGALPKT = 0
dfCALLPKT = 7
dfEVALUATEPKT = 13
dfRETURNPKT = 3
dfINPUTNAMEPKT = 8
dfENTERTEXTPKT = 14
dfENTEREXPRPKT = 15
dfOUTPUTNAMEPKT = 9
dfRETURNTEXTPKT = 4
dfRETURNEXPRPKT = 16
dfDISPLAYPKT = 11
dfDISPLAYENDPKT = 12
dfMESSAGEPKT = 5
dfTEXTPKT = 2
dfINPUTPKT = 1
dfINPUTSTRPKT = 21
dfMENUPKT = 6
dfSYNTAXPKT = 10
dfSUSPENDPKT = 17
dfRESUMEPKT = 18
dfBEGINDLGPKT = 19
dfENDDLGPKT = 20
dfFIRSTUSERPKT = 128
dfLASTUSERPKT = 255
dfMLTKAEND = 13
dfMLTKALL_DECODERS = 983040
dfMLTKAPCTEND = 10
dfMLTKARRAY = 65
dfMLTKARRAY_DECODER = 262144
dfMLTKCONT = 92
dfMLTKDIM = 68
dfMLTKELEN = 32
dfMLTKEND = 10
dfMLTKERR = 0
dfMLTKERROR = 0
dfMLTKFUNC = 70
dfMLTKINT = 43
dfMLTKMODERNCHARS_DECODER = 524288
dfMLTKNULL = 46
dfMLTKNULLSEQUENCE_DECODER = 0
dfMLTKOLDINT = 73
dfMLTKOLDREAL = 82
dfMLTKOLDSTR = 83
dfMLTKOLDSYM = 89
dfMLTKPACKED_DECODER = 131072
dfMLTKPACKED = 80
dfMLTKPCTEND = 93
dfMLTKREAL = 42
dfMLTKSEND = 44
dfMLTKSTR = 34
dfMLTKSYM = 35
showPKT :: CInt -> String
showPKT i | i == dfILLEGALPKT = "ILLEGALPKT"
| i == dfCALLPKT = "CALLPKT"
| i == dfEVALUATEPKT = "EVALUATEPKT"
| i == dfRETURNPKT = "RETURNPKT"
| i == dfINPUTNAMEPKT = "INPUTNAMEPKT"
| i == dfENTERTEXTPKT = "ENTERTEXTPKT"
| i == dfENTEREXPRPKT = "ENTEREXPRPKT"
| i == dfOUTPUTNAMEPKT = "OUTPUTNAMEPKT"
| i == dfRETURNTEXTPKT = "RETURNTEXTPKT"
| i == dfRETURNEXPRPKT = "RETURNEXPRPKT"
| i == dfDISPLAYPKT = "DISPLAYPKT"
| i == dfDISPLAYENDPKT = "DISPLAYENDPKT"
| i == dfMESSAGEPKT = "MESSAGEPKT"
| i == dfTEXTPKT = "TEXTPKT"
| i == dfINPUTPKT = "INPUTPKT"
| i == dfINPUTSTRPKT = "INPUTSTRPKT"
| i == dfMENUPKT = "MENUPKT"
| i == dfSYNTAXPKT = "SYNTAXPKT"
| i == dfSUSPENDPKT = "SUSPENDPKT"
| i == dfRESUMEPKT = "RESUMEPKT"
| i == dfBEGINDLGPKT = "BEGINDLGPKT"
| i == dfENDDLGPKT = "ENDDLGPKT"
| i == dfFIRSTUSERPKT = "FIRSTUSERPKT"
| i == dfLASTUSERPKT = "LASTUSERPKT"
| otherwise = "UNRECOGNIZED PACKET"
showTK :: CInt -> String
showTK i | i == dfMLTKAEND = "MLTKAEND"
| i == dfMLTKALL_DECODERS = "MLTKALL_DECODERS"
| i == dfMLTKAPCTEND = "MLTKAPCTEND"
| i == dfMLTKARRAY = "MLTKARRAY"
| i == dfMLTKARRAY_DECODER = "MLTKARRAY_DECODER"
| i == dfMLTKCONT = "MLTKCONT"
| i == dfMLTKDIM = "MLTKDIM"
| i == dfMLTKELEN = "MLTKELEN"
| i == dfMLTKEND = "MLTKEND"
| i == dfMLTKERR = "MLTKERR"
| i == dfMLTKERROR = "MLTKERROR"
| i == dfMLTKFUNC = "MLTKFUNC"
| i == dfMLTKINT = "MLTKINT"
| i == dfMLTKMODERNCHARS_DECODER = "MLTKMODERNCHARS_DECODER"
| i == dfMLTKNULL = "MLTKNULL"
| i == dfMLTKNULLSEQUENCE_DECODER = "MLTKNULLSEQUENCE_DECODER"
| i == dfMLTKOLDINT = "MLTKOLDINT"
| i == dfMLTKOLDREAL = "MLTKOLDREAL"
| i == dfMLTKOLDSTR = "MLTKOLDSTR"
| i == dfMLTKOLDSYM = "MLTKOLDSYM"
| i == dfMLTKPACKED_DECODER = "MLTKPACKED_DECODER"
| i == dfMLTKPACKED = "MLTKPACKED"
| i == dfMLTKPCTEND = "MLTKPCTEND"
| i == dfMLTKREAL = "MLTKREAL"
| i == dfMLTKSEND = "MLTKSEND"
| i == dfMLTKSTR = "MLTKSTR"
| i == dfMLTKSYM = "MLTKSYM"
| otherwise = "UNRECOGNIZED TK"
-- * MathLink monad as Reader IO monad
data MLState =
MLState
{ mlink :: MLINK
, menv :: MLEnvironment
, mverbosity :: Int
, logHdl :: Maybe Handle
}
type ML = ReaderT MLState IO
-- | Prints a message dependent on the verbosity level
verbMsgML :: Int -> String -> ML ()
verbMsgML lvl msg = do
hdl <- getHandle
v <- asks mverbosity
liftIO $ verbMsg hdl v lvl msg
-- | Prints a message dependent on the verbosity level
verbMsgMLLn :: Int -> String -> ML ()
verbMsgMLLn lvl msg = do
hdl <- getHandle
v <- asks mverbosity
liftIO $ verbMsgLn hdl v lvl msg
getHandle :: ML Handle
getHandle = liftM (fromMaybe stdout) $ asks logHdl
mkState :: MLINK -> MLEnvironment -> Int -> MLState
mkState mlp env v = MLState { mlink = mlp, menv = env, mverbosity = v
, logHdl = Nothing }
addLogging :: MLState -> Handle -> MLState
addLogging st hdl = st { logHdl = Just hdl }
askMLink :: ML MLINK
askMLink = asks mlink
liftMLIO :: (MLINK -> IO b) -> ML b
liftMLIO f = askMLink >>= liftIO . f
-- * MathLink connection handling
-- | Open connection to MathLink or return error code on failure
openLink :: Int -- ^ Verbosity
-> Maybe String {- ^ Connection name
(launches a new kernel if not specified) -}
-> IO (Either Int MLState)
openLink v mName = do
env <- cMlInitialize nullPtr
if env == nullPtr then return $ Left 1
else do
verbMsgIOLn v 2 "Initialized"
let (name, mode) = case mName of
Just n -> (n, "connect")
_ -> ("math -mathlink", "launch")
let openargs = ["-linkname", name, "-linkmode", mode]
lp <- mlOpen 4 openargs
mB <- if lp == nullPtr then return Nothing
-- else liftM Just $ connectLink lp
else timeout 3000000 $ connectLink lp v
case mB of
Nothing -> return $ Left 2
Just False -> return $ Left 3
_ -> return $ Right $ mkState lp env v
-- | Close connection to MathLink
closeLink :: MLState -> IO ()
closeLink st = do
mlClose $ mlink st
cMlDeinitialize $ menv st
-- | Run ML-program on an opened connection to MathLink
withLink :: MLState -- ^ MathLink connection
-> Maybe FilePath -- ^ Log low level messages into this file (or STDOUT)
-> ML a -- ^ The program to run
-> IO a
withLink st mFp mlprog =
case mFp of
Just fp ->
withFile fp WriteMode $ runReaderT mlprog . addLogging st
Nothing ->
runReaderT mlprog st
{- | Run ML-program on a new connection to MathLink which is closed right
after the execution and return the prgram result or error code on failure -}
runLink :: Maybe FilePath -- ^ Log low level messages into this file (or STDOUT)
-> Int -- ^ Verbosity
-> Maybe String {- ^ Connection name
(launches a new kernel if not specified) -}
-> ML a -- ^ The program to run
-> IO (Either Int a)
runLink mFp v mName mlprog = do
eSt <- openLink v mName
case eSt of
Left i -> return $ Left i
Right st ->
do
verbMsgIOLn v 2 "Opened"
x <- withLink st mFp mlprog
closeLink st
return $ Right x
-- | Low level: open connection
mlOpen :: CInt -> [String] -> IO MLINK
mlOpen i l = withStringArray l $ cMlOpen i
-- | Low level: check connection
connectLink :: MLINK
-> Int -- ^ Verbosity
-> IO Bool
connectLink lp v = do
let p i j = do
i' <- cMlReady lp
if toBool i' || j > 3000 then return j
else cMlFlush lp >> if i > 1000 then p 0 (j + 1) else p (i + 1) j
p (0 :: Int) (0 :: Int) >>= verbMsgIOLn v 2 . ("ready after " ++) . show
res <- cMlConnect lp
return $ toBool res
-- | Low level: close connection
mlClose :: MLINK -> IO CInt
mlClose = cMlClose
-- * C to Haskell utilities
withStringArray :: MonadIO m => [String] -> (Ptr CString -> IO b) -> m b
withStringArray l f = liftIO $ mapM newCString l >>= flip withArray f
mlGetA :: (Storable a, Show a, Show b) => (Ptr a -> IO b) -> IO a
mlGetA f = let g ptr = f ptr >> peek ptr in alloca g
-- TODO: maybe better via foreign pointer, check later
mlGetCString :: Show b => (Ptr CString -> IO b) -> (CString -> IO ()) -> IO String
mlGetCString f disownF =
let g ptr = do
cs <- f ptr >> peek ptr
s <- peekCString cs
disownF cs
return s
in alloca g
-- * C Type conversions
cintToInteger :: CInt -> Integer
cintToInteger = fromIntegral
intToCInt :: Int -> CInt
intToCInt = fromIntegral
-- | This function is unsafe, it may overflow...
cintToInt :: CInt -> Int
cintToInt = fromIntegral
cdblToDbl :: CDouble -> Double
cdblToDbl = realToFrac
dblToCDbl :: Double -> CDouble
dblToCDbl = realToFrac
-- * MathLink interface using the ML monad, built on top of the raw bindings
mlFlush :: ML CInt
mlFlush = liftMLIO cMlFlush
mlReady :: ML CInt
mlReady = liftMLIO cMlReady
mlConnect :: ML CInt
mlConnect = liftMLIO cMlConnect
mlEndPacket :: ML CInt
mlEndPacket = liftMLIO cMlEndPacket
mlNextPacket :: ML CInt
mlNextPacket = liftMLIO cMlNextPacket
mlNewPacket :: ML CInt
mlNewPacket = liftMLIO cMlNewPacket
mlGetNext :: ML CInt
mlGetNext = liftMLIO cMlGetNext
mlGetArgCount :: ML CInt
mlGetArgCount = askMLink >>= liftIO . mlGetA . cMlGetArgCount
mlGetArgCount' :: ML Int
mlGetArgCount' = liftM cintToInt mlGetArgCount
-- cMlGetSymbol :: MLINK -> Ptr CString -> IO CInt
mlGetSymbol :: ML String
mlGetSymbol = do
ml <- askMLink
liftIO $ mlGetCString (cMlGetSymbol ml) $ cMlDisownSymbol ml
-- cMlGetString :: MLINK -> Ptr CString -> IO CInt
mlGetString :: ML String
-- mlGetString = askMLink >>= liftIO . mlGetCString . cMlGetString
mlGetString = do
ml <- askMLink
liftIO $ mlGetCString (cMlGetString ml) $ cMlDisownString ml
-- cMlGetReal :: MLINK -> Ptr CDouble -> IO CInt
mlGetReal :: ML CDouble
mlGetReal = askMLink >>= liftIO . mlGetA . cMlGetReal
mlGetReal' :: ML Double
mlGetReal' = liftM cdblToDbl mlGetReal
-- cMlGetInteger :: MLINK -> Ptr CInt -> IO CInt
mlGetInteger :: ML CInt
mlGetInteger = askMLink >>= liftIO . mlGetA . cMlGetInteger
mlGetInteger' :: ML Int
mlGetInteger' = liftM cintToInt mlGetInteger
{- | Integers are received as strings, because the interface supports only
machine integers with fixed length not arbitrary sized integers. -}
mlGetInteger'' :: ML Integer
mlGetInteger'' = liftM read mlGetString
mlPutString :: String -> ML CInt
mlPutString s = liftMLIO f where
f ml = withCString s $ cMlPutString ml
mlPutSymbol :: String -> ML CInt
mlPutSymbol s = liftMLIO f where
f ml = withCString s $ cMlPutSymbol ml
mlPutFunction :: String -> CInt -> ML CInt
mlPutFunction s i = liftMLIO f where
f ml = withCString s $ flip (cMlPutFunction ml) i
mlPutFunction' :: String -> Int -> ML CInt
mlPutFunction' s = mlPutFunction s . intToCInt
mlPutInteger :: CInt -> ML CInt
mlPutInteger = liftMLIO . flip cMlPutInteger
mlPutInteger' :: Int -> ML CInt
mlPutInteger' = mlPutInteger . intToCInt
{- | Integers are sent as strings, because the interface supports only
machine integers with fixed length not arbitrary sized integers. -}
mlPutInteger'' :: Integer -> ML CInt
mlPutInteger'' i = mlPutFunction' "ToExpression" 1 >> mlPutString (show i)
mlPutReal :: CDouble -> ML CInt
mlPutReal = liftMLIO . flip cMlPutReal
mlPutReal' :: Double -> ML CInt
mlPutReal' = mlPutReal . dblToCDbl
mlError :: ML CInt
mlError = liftMLIO cMlError
mlErrorMessage :: ML String
mlErrorMessage = liftMLIO (cMlErrorMessage >=> peekCString)
-- * MathLink interface utils
mlProcError :: ML a
mlProcError = do
eid <- mlError
s <- if toBool eid then liftM ("Error detected by MathLink: " ++)
mlErrorMessage
else return "Error detected by Interface"
verbMsgMLLn 1 s
error $ "mlProcError: " ++ s
sendEvalPacket :: ML a -> ML a
sendEvalPacket ml = do
mlPutFunction "EvaluatePacket" 1
res <- ml
mlEndPacket
return res
sendTextPacket :: String -> ML ()
sendTextPacket s = do
mlPutFunction "EvaluatePacket" 1
mlPutFunction "ToExpression" 1
mlPutString s
mlEndPacket
return ()
sendTextResultPacket :: String -> ML ()
sendTextResultPacket s = do
mlPutFunction "EvaluatePacket" 1
mlPutFunction "ToString" 1
mlPutFunction "ToExpression" 1
mlPutString s
mlEndPacket
return ()
{-
-- these variants does not work as expected
sendTextPacket' :: String -> ML ()
sendTextPacket' s = do
mlPutFunction "EnterTextPacket" 1
mlPutString s
mlEndPacket
return ()
sendTextPacket'' :: String -> ML ()
sendTextPacket'' s = do
mlPutFunction "EnterExpressionPacket" 1
mlPutFunction "ToExpression" 1
mlPutString s
mlEndPacket
return ()
sendTextPacket3 :: String -> ML ()
sendTextPacket3 s = do
mlPutFunction "EvaluatePacket" 1
mlPutFunction "ToString" 1
mlPutFunction "ToExpression" 1
mlPutString s
mlEndPacket
return ()
sendTextPacket4 :: String -> ML ()
sendTextPacket4 s = do
mlPutFunction "EnterExpressionPacket" 1
mlPutFunction "ToString" 1
mlPutFunction "ToExpression" 1
mlPutString s
mlEndPacket
return ()
-}
waitForAnswer :: ML CInt
waitForAnswer = do
-- skip any packets before the first ReturnPacket
i <- waitUntilPacket (0 :: Int) [ dfRETURNPKT, dfRETURNEXPRPKT
, dfRETURNTEXTPKT, dfILLEGALPKT]
if elem i [dfILLEGALPKT, dfRETURNEXPRPKT, dfRETURNTEXTPKT]
then error $ "waitForAnswer: encountered a " ++ showPKT i
else return i
-- wait for the answer and skip it
skipAnswer :: ML CInt
skipAnswer = waitForAnswer >> mlNewPacket
waitUntilPacket :: Num a => a -> [CInt] -> ML CInt
waitUntilPacket i l = do
np <- mlNextPacket
if elem np l then do
verbMsgMLLn 2 $ "GotReturn after " ++ show i ++ " iterations"
return np
else verbMsgMLLn 2 ("wap: " ++ show np) >> mlNewPacket
>> waitUntilPacket (i + 1) l