module Foreign.MathLink.ML ( runMathLink
, runMathLinkWithArgs
, evaluate
, evaluateString
, getLink
, throwOnError
, boolToError
, getType
, putFunctionHead
, getFunctionHead
, putScalarWith
, getScalarWith
, putStringWith
, getStringWith
, withLink0
, withLink1
, withLink2
, withLink3
, withLink4
) where
import Foreign.MathLink.Types
import qualified Foreign.MathLink.IO as MLIO
import Foreign
import Foreign.C
import Foreign.Storable
import Control.Exception (bracket)
import Control.Monad
import Control.Monad.Trans
import qualified Control.Monad.Reader as Rd
import qualified Control.Monad.State as St
import qualified Control.Monad.Error as Er
import Data.IntMap (IntMap)
import qualified Data.IntMap as IM
import Data.Int
import System.IO
import System.Environment
getLink :: ML Link
getLink = Rd.ask >>= (return . link)
updateState :: ML ()
updateState = do
b <- checkMessage
if not b then return () else do
mMsg <- getMessage
case mMsg of
Nothing -> return ()
Just (msg,_) ->
case msg of
TerminateMessage -> do st <- St.get
St.put $ st { done = True }
updateState
InterruptMessage -> do st <- St.get
St.put $ st { abort = True }
updateState
AbortMessage -> do st <- St.get
St.put $ st { abort = True }
updateState
UnknownMessage _ -> return ()
_ -> updateState
runMathLink :: [Function] -> IO ()
runMathLink functions = do
args <- getArgs
runMathLinkWithArgs args functions
runMathLinkWithArgs :: [String] -> [Function] -> IO ()
runMathLinkWithArgs args functions =
bracket MLIO.acquireEnvironment MLIO.releaseEnvironment $ \env ->
bracket (MLIO.acquireLink env args) MLIO.releaseLink $ \lnk -> do
let config = Config { environment = env
, link = lnk
, functionTable =
IM.fromList $ zip [0..] functions
}
state = State { abort = False
, done = False
}
er <- runML runLoop state config
case er of
Left err -> do hPutStrLn stderr err
return ()
Right () -> return ()
runLoop :: ML ()
runLoop = do
installFunctionTable
processPackets
processPackets :: ML ()
processPackets = do
pkt <- answer
case pkt of
ResumePacket -> do
refuseToBeAFrontEnd
processPackets
_ -> return ()
answer :: ML Packet
answer = do
pkt <- getPacket
case pkt of
CallPacket -> do
processCallPacket
endPacket
newPacket
answer
_ -> return $ mkPacket 0
return pkt
printString :: String -> ML ()
printString str = do
evaluate $ "Print[\"" ++ str ++ "\"]"
return ()
processCallPacket :: ML ()
processCallPacket =
do expr <- get
case expr of
ExInt n -> do
config <- Rd.ask
case n `IM.lookup` (functionTable config) of
Just fn -> function fn
_ -> Er.throwError "Function lookup failed."
_ -> Er.throwError "Expected int."
`Er.catchError` \err -> do
clearError
printString err
put $ ExSymbol "$Failed"
refuseToBeAFrontEnd :: ML ()
refuseToBeAFrontEnd = do
putFunctionHead "EvaluatePacket" 1
putFunctionHead "Module" 2
putFunctionHead "List" 1
putFunctionHead "Set" 2
put meSym
put plSym
putFunctionHead "CompoundExpression" 3
putFunctionHead "Set" 2
put plSym
getLink >>= (liftIO . (\l -> MLIO.transferExpression l l))
putFunctionHead "Message" 2
putFunctionHead "MessageName" 2
put plSym
put $ ExString "notfe"
put meSym
put meSym
endPacket
waitForPacket (== SuspendPacket)
where meSym = ExSymbol "me"
plSym = ExSymbol "$ParentLink"
installFunctionTable :: ML ()
installFunctionTable = do
activate
functionPairs <- Rd.ask >>= (return . IM.toList . functionTable)
mapM_ definePattern functionPairs
put $ ExSymbol "End"
flush
definePattern :: (Int,Function) -> ML ()
definePattern (ident,func) =
put $ ExFunction "DefineExternal" [ ExString $ callPattern func
, ExString $ argumentPattern func
, ExInt ident
]
evaluate :: String -> ML Bool
evaluate s =
do put $ ExFunction "EvaluatePacket"
[ ExFunction "ToExpression"
[ ExString s ] ]
endPacket
return True
`Er.catchError` do
return $ return False
evaluateString :: String -> ML Bool
evaluateString s = do
result <- evaluate s
waitForPacket (== ReturnPacket)
return result
waitForPacket :: (Packet -> Bool) -> ML ()
waitForPacket q = do
pkt <- getPacket
newPacket
if q pkt then return () else waitForPacket q
activate :: ML ()
activate = withLink0 MLIO.activate >>= boolToError
flush :: ML ()
flush = withLink0 MLIO.flush >>= boolToError
checkReady :: ML Bool
checkReady = withLink0 MLIO.checkReady
getError :: ML Error
getError = withLink0 MLIO.getError
clearError :: ML Bool
clearError = withLink0 MLIO.clearError
getErrorMessage :: ML String
getErrorMessage = withLink0 MLIO.getErrorMessage
throwOnError :: Integral a => a -> ML ()
throwOnError i =
if i == 0 then
getErrorMessage >>= Er.throwError
else
return ()
boolToError :: Bool -> ML ()
boolToError True = return ()
boolToError False = getErrorMessage >>= Er.throwError
getPacket :: ML Packet
getPacket = withLink0 MLIO.getPacket
newPacket :: ML Bool
newPacket = withLink0 MLIO.newPacket
endPacket :: ML Bool
endPacket = withLink0 MLIO.endPacket
getMessage :: ML (Maybe (Message,Int))
getMessage = withLink0 MLIO.getMessage
putMessage :: Message -> ML Bool
putMessage = withLink1 MLIO.putMessage
checkMessage :: ML Bool
checkMessage = withLink0 MLIO.checkMessage
putScalarWith :: (Link -> b -> IO CInt)
-> (a -> b)
-> a
-> ML ()
putScalarWith fn cnv i = withLink1 fn (cnv i) >>= throwOnError
getScalarWith :: Storable a
=> (Link -> Ptr a -> IO CInt)
-> (a -> b)
-> ML b
getScalarWith fn cnv = do
l <- getLink
eS <- liftIO $ bracket malloc free $ \xPtr -> do
bS <- fn l xPtr >>= MLIO.convToBool
if bS then
peek xPtr >>= (return . Right . cnv)
else
MLIO.getErrorMessage l >>= (return . Left)
case eS of
Left msg -> Er.throwError msg
Right s -> return s
putStringWith :: (Link -> CString -> IO CInt)
-> String
-> ML ()
putStringWith fn str = do
l <- getLink
liftIO (withCString str $ \sPtr -> fn l sPtr) >>= throwOnError
getStringWith :: (Link -> Ptr CString -> IO CInt)
-> (Link -> CString -> IO ())
-> ML String
getStringWith afn rfn = do
l <- getLink
eStr <- liftIO $ bracket malloc free $ \strPtrPtr -> do
bStr <- afn l strPtrPtr >>= MLIO.convToBool
if bStr then do
strPtr <- peek strPtrPtr
str <- peekCString strPtr
rfn l strPtr
return $ Right str
else
MLIO.getErrorMessage l >>= (return . Left)
case eStr of
Left err -> Er.throwError err
Right s -> return s
getType :: ML Type
getType = getLink >>= (liftIO . MLIO.mlGetType) >>= (return . mkType)
putFunctionHead :: String -> Int -> ML ()
putFunctionHead hd n =
putStringWith (\l s -> MLIO.mlPutFunction l s (fromIntegral n)) hd
getFunctionHead :: ML (String,Int)
getFunctionHead = do
l <- getLink
eFn <- liftIO $ bracket malloc free $ \strPtrPtr ->
bracket malloc free $ \nPtr -> do
bFn <- MLIO.mlGetFunction l strPtrPtr nPtr >>= MLIO.convToBool
if bFn then do
strPtr <- peek strPtrPtr
str <- peekCString strPtr
n <- peek nPtr
MLIO.mlReleaseSymbol l strPtr
return $ Right (str,fromIntegral n)
else
MLIO.getErrorMessage l >>= (return . Left)
case eFn of
Left err -> Er.throwError err
Right f -> return f
instance Expressible Expression where
put e =
case e of
ExInt i -> putScalarWith MLIO.mlPutInt fromIntegral i
ExReal r -> putScalarWith MLIO.mlPutReal64 realToFrac r
ExString s -> putStringWith MLIO.mlPutString s
ExSymbol s -> putStringWith MLIO.mlPutSymbol s
ExFunction hd args -> do
putFunctionHead hd (fromIntegral $ length args)
mapM_ put args
get = do
typ <- getType
case typ of
ErrorType -> getErrorMessage >>= Er.throwError
IntType -> getScalarWith MLIO.mlGetInt fromIntegral >>=
(return . ExInt)
RealType -> getScalarWith MLIO.mlGetReal64 realToFrac >>=
(return . ExReal)
StringType ->
getStringWith MLIO.mlGetString MLIO.mlReleaseString >>=
(return . ExString)
SymbolType ->
getStringWith MLIO.mlGetSymbol MLIO.mlReleaseSymbol >>=
(return . ExSymbol)
FunctionType -> do
(hd,nArgs) <- getFunctionHead
args <- mapM id $ take nArgs $ repeat get
return $ ExFunction hd args
withLink0
:: (Link -> IO a)
-> ML a
withLink0 f = getLink >>= (liftIO . f)
withLink1
:: (Link -> a -> IO b)
-> (a -> ML b)
withLink1 f = \x -> getLink >>= (liftIO . (\l -> f l x))
withLink2
:: (Link -> a -> b -> IO c)
-> (a -> b -> ML c)
withLink2 f = \x y -> getLink >>= (liftIO . (\l -> f l x y))
withLink3
:: (Link -> a -> b -> c -> IO d)
-> (a -> b -> c -> ML d)
withLink3 f = \x y z -> getLink >>= (liftIO . (\l -> f l x y z))
withLink4
:: (Link -> a -> b -> c -> d -> IO e)
-> (a -> b -> c -> d -> ML e)
withLink4 f = \x y z w -> getLink >>= (liftIO . (\l -> f l x y z w))