diff --git a/Foreign/MathLink.hs b/Foreign/MathLink.hs new file mode 100644 --- /dev/null +++ b/Foreign/MathLink.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , ExistentialQuantification + , MultiParamTypeClasses + #-} +module Foreign.MathLink + ( + -- * An example package + -- $example + + -- * Notes + -- $notes + + -- * Package declarations + MLSpec + , MLDecl(..) + + -- * Running the /MathLink/ loop + , runMathLinkWithArgs + , runMathLink + + -- * /Mathematica/ expressions and data marshaling + , module Foreign.MathLink.Expression + + -- * Known limitations + -- $limitations + ) where + +import Prelude hiding (catch) +import Control.Concurrent +import Control.Exception hiding (evaluate) +import Control.Monad + +import Foreign.MathLink.Internal +import Foreign.MathLink.Expression + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM + +import System.Environment + +-- | A /Mathematica/ package specification. +type MLSpec = [MLDecl] + +-- | A declaration for a /Mathematica/ package. +data MLDecl = forall a . MLPut a => Eval a + -- ^ A value to be sent to /Mathematica/ for evaluation. + | EvalStr String + -- ^ A /Mathematica/ expression, expressed as a 'String', + -- to be sent to /Mathematica/ for evaluation. + -- + -- The 'String' is wrapped with a @ToExpression@ before + -- being sent. + | DeclMsg String String String + -- ^ Defines a /Mathematica/ message. + -- + -- @'DeclMsg' /sym/ /tag/ /defn/@ in Haskell maps to + -- @/sym/::/tag/ = /defn/@ in /Mathematica/. + | forall a b . (MLGet a, MLPut b) => + DeclFn { -- | A /Mathematica/ pattern, expressed as a + -- 'String', such that a matching expression + -- should signal a call to this Haskell function. + callPattern :: String + -- | A /Mathematica/ pattern, specifying the + -- expression that is to be marshaled to the + -- Haskell function. + -- + -- Pattern variables bound in the 'callPattern' + -- match are in scope for 'argPattern'. + , argPattern :: String + -- | The function to be called on the Haskell side. + , func :: a -> IO b + } + + +globalSpec :: MLSpec +globalSpec = [ DeclMsg "MathLink" "usage" + "Symbol whose only purpose is to provide a place to \ + \define system-wide messages for the mathlink Haskell \ + \package." + , DeclMsg "MathLink" "exn" + "Exception caught: `1`" + , DeclMsg "MathLink" "fnix" + "Call packet received with invalid function index: `1`." + ] + +tryCalcAndPut :: MVar (Either SomeException (Maybe a)) -> IO a -> IO () +tryCalcAndPut var comp = do ans <- comp + ans `seq` putMVar var (Right (Just ans)) + `catch` (\e -> putMVar var (Left e)) + +putWhenTrue :: MVar (Either SomeException (Maybe a)) -> IO Bool -> IO () +putWhenTrue var comp = do bl <- comp + if bl then putMVar var (Right (Nothing)) else + do threadDelay 100000 + putWhenTrue var comp + `catch` (\e -> putMVar var (Left e)) + +wrapFn :: (MLGet a, MLPut b) => (a -> IO b) -> IO () +wrapFn fn = do + arg <- mlGet + newPacket + clearAbort + clearInterrupt + result <- do + vres <- newEmptyMVar + idComp <- forkIO $ tryCalcAndPut vres $ fn arg + idInt <- forkIO $ putWhenTrue vres checkInterrupt + res <- takeMVar vres + killThread idComp + killThread idInt + return res + clearMLError + case result of + Right (Just ans) -> mlPut ans >> endPacket + Right Nothing -> (mlPut $ Sy "$Aborted") >> endPacket + Left err -> do printMessage "MathLink" "exn" + [St $ show (err :: SomeException)] + mlPut $ Sy "$Failed" + endPacket + +-- | Like 'runMathLinkWithArgs', but gets the arguments from 'getArgs'. +runMathLink :: MLSpec -> IO () +runMathLink spec = do + args <- getArgs + runMathLinkWithArgs args spec + +-- | Run the /MathLink/ loop. +runMathLinkWithArgs + :: [String] -- ^ The command line arguments to be passed to + -- @MLOpenString@ (/e.g./, the link name). + -> MLSpec -- ^ The package specification + -> IO () +runMathLinkWithArgs args spec = + bracket (initializeMathLink (unwords args)) + (const finalizeMathLink) $ \_ -> do + result <- try $ runSpec spec + case result of + Right () -> return () + Left (MLErr 1 _) -> return () -- link dead + Left (MLErr 11 _) -> return () -- link closed + Left err -> putStrLn $ "Error occurred: " ++ show err + +runSpec :: MLSpec -> IO () +runSpec spec = do + (_,fns) <- foldM processDecl (0,[]) (globalSpec ++ spec) + mlPut $ Sy "End" + flush + answer $ IM.fromList fns + +processDecl :: (Int,[(Int,IO ())]) + -> MLDecl + -> IO (Int,[(Int,IO ())]) +processDecl pr (Eval v) = do + send v + return pr +processDecl pr (EvalStr str) = do + sendString str + return pr +processDecl pr (DeclMsg sym tag defn) = do + defineMessage sym tag defn + return pr +processDecl (n,fns) (DeclFn callPat argPat fn) = do + send ("DefineExternal":@[St callPat, St argPat, I (fromIntegral n)]) + return (n+1,(n, wrapFn fn):fns) + +answer :: IntMap (IO ()) -> IO () +answer fnMap = do + waitForPacket (== (MLPacket PktCall)) + n <- mlGet + case IM.lookup (fromInteger n) fnMap of + Nothing -> do newPacket + printMessage "MathLink" "fnix" [I n] + mlPut $ Sy "$Failed" + endPacket + Just fn -> fn + answer fnMap + +{- $example + +@ +module Main where + +import "Foreign.MathLink" + +addFour :: ('Int','Int','Int','Int') -> IO 'Int' +addFour (a,b,c,d) = 'return' '$' a '+' b '+' c '+' d + +ackermann :: ('Integer','Integer') -> 'IO' 'Integer' +ackermann (m,n) = 'return' '$' ack m n + +ack :: 'Integer' -> 'Integer' -> 'Integer' +ack 0 n = n '+' 1 +ack 1 n = n '+' 2 +ack 2 n = 2 '*' n '+' 3 +ack m 0 = ack (m '-' 1) 1 +ack m n = ack (m '-' 1) (ack m (n '-' 1)) + +decl :: 'MLSpec' +decl = + [ 'Eval' $ \"BeginPackage\":\@['St' \"Test\`\"] + +\ , 'DeclMsg' \"AddFour\" \"usage\" \"...\" + , 'DeclMsg' \"Ackermann\" \"usage\" \"...\" + , 'Eval' $ \"Begin\":\@['St' \"\`Private\`\"] + +\ , 'DeclFn' { + 'callPattern' = \"AddFour[a_Integer,b_Integer,c_Integer,d_Integer]\" + , 'argPattern' = \"{a,b,c,d}\" + , 'func' = addFour + } + +\ , 'DeclFn' { + 'callPattern' = \"Ackermann[i_Integer,j_Integer]\" + , 'argPattern' = \"{i,j}\" + , 'func' = ackermann + } + +\ , 'Eval' $ \"End\":\@[] + , 'Eval' $ \"EndPackage\":\@[] + ] +@ +-} + +{- $notes + + * The library implementation uses multiple threads so that execution of + a Haskell function called from /Mathematica/ will respond immediately + to an abort request. + + * Exceptions thrown during the evaluation of a Haskell function are + caught and a corresponding message is sent to the /Mathematica/ front + end. + + * The message loop can be run within @ghci@. Unfortunately, however, + setting breakpoints causes a segmentation fault. +-} + +{- $limitations + + * In the current implementation, only one /MathLink/ connection may be + made per process. + + * The library was written for, and has, as of yet, only been tested on + a 64-bit Linux platform. Some tweaking of the cabal file and minor + edits to the "Foreign.MathLink.Internal" module would be necessary + to get it to work on a 32-bit platform. +-} diff --git a/Foreign/MathLink/Expression.hs b/Foreign/MathLink/Expression.hs new file mode 100644 --- /dev/null +++ b/Foreign/MathLink/Expression.hs @@ -0,0 +1,570 @@ +{-# LANGUAGE RankNTypes + , FlexibleContexts + , FlexibleInstances + , TypeSynonymInstances + , OverlappingInstances + #-} +module Foreign.MathLink.Expression + ( + -- * Generic /Mathematica/ expression + MLExpr(..) + , (-=-) + , (-::-) + + -- * /Mathematica/ evaluation + , send + , sendString + , evaluate + , defineMessage + , printMessage + + -- * Data marshaling + , MLPut(..) + , MLGet(..) + , Packable + , putArray + , getArray + + ) where + +import Control.Monad +import Data.Word +import Data.Int +import Data.Complex +import GHC.Real + +import Foreign.MathLink.Internal +import Foreign.Storable + +import Data.Array.IArray +import Data.Ix.Shapable +import Data.Array (Array) +import Data.Array.Unboxed (UArray) + +import System.IO + +-- | Haskell representation of a generic /Mathematica/ expression. +data MLExpr = I Integer -- ^ Atomic integer value. + | R Rational -- ^ Atomic real value. + | St String -- ^ Atomic string value, as a string. + | Sy String -- ^ Atomic string value, as a symbol. + | String :@ [MLExpr] -- ^ Compound expression. + deriving (Eq, Ord, Show) + +-- | Sugar for the @Set@ /Mathematica/ expression +(-=-) :: MLExpr -> MLExpr -> MLExpr +ex1 -=- ex2 = "Set":@[ex1,ex2] + +-- | Sugar for the @MessageName@ /Mathematica/ expression +(-::-) :: String -> String -> MLExpr +sym -::- tag = "MessageName":@[Sy sym, St tag] + + +------------------- Evaluation --------------------- + +-- | Sends a value (most likely an 'MLExpr') to /Mathematica/ for +-- evaluation and gets the result (appropriately marshaled to the +-- desired type). +-- +-- Does not call 'endPacket'. +evaluate :: (MLPut a, MLGet b) => a -> IO b +evaluate v = do + send v + waitForPacket (== (MLPacket PktReturn)) + res <- mlGet + newPacket + return res + +-- | Puts a value to the /MathLink/ connection. +-- +-- Does not wait for a return packet or call 'endPacket'. +send :: MLPut a => a -> IO () +send v = do + putFunction "EvaluatePacket" 1 + mlPut v + +-- | Puts a value, as a string, to the /MathLink/ connection. +-- +-- Does not wait for a return packet or call 'endPacket'. +sendString :: String -> IO () +sendString str = send $ "ToExpression":@[St str] + +-- | Defines a message. +-- +-- The message definition can contain backquoted numbers to +-- represent the positions of where string representations of +-- the corresponding extra values passed in a call to +-- 'printMessage' are to be interpolated. An example of a message +-- definition that interpolates two values is: +-- +-- @ +-- 'defineMessage' \"Foo\" \"bar\" \"Thingy `1` doesn't go with thingy `2`.\" +-- @ +-- +-- Does not wait for a return packet or call 'endPacket'. +defineMessage + :: String -- ^ The symbol associated with this message. + -> String -- ^ The tag associated with this message. + -> String -- ^ The message definition. + -> IO () +defineMessage sym tag defn = + send (sym-::-tag -=- St defn) + +-- | Causes the specified message to be sent to /Mathematica/. +-- +-- Making the call (corresponding the the 'defineMessage' example): +-- +-- @ +-- 'printMessage' \"Foo\" \"bar\" ['St' \"fish\", 'St' \"bicycle\"] +-- @ +-- +-- would yield a message to appear on the /Mathematica/ end looking +-- something like: +-- +-- @ +-- Foo::bar : Thingy fish doesn't go with thingy bicycle. +-- @ +-- +-- Does not call 'endPacket'. +printMessage + :: String -- ^ The symbol associated with the message. + -> String -- ^ The tag associated with the message. + -> [MLExpr] -- ^ A list of expressions whose string values are + -- to be interpolated in to the message. + -> IO () +printMessage sym tag args = do + v <- evaluate ("Message":@[sym-::-tag,"Sequence":@args]) + (v :: MLExpr) `seq` return () + +--------------------- MLPut ------------------------- + +-- | The class of types that can be marshaled to /Mathematica/. +class MLPut a where + -- | Send a value to /Mathematica/. + mlPut :: a -> IO () + +instance MLPut MLExpr where + mlPut (I i) = mlPut i + mlPut (R r) = mlPut r + mlPut (St str) = mlPut str + mlPut (Sy sym) = putSymbol sym + mlPut (hd :@ exs) = do + putFunction hd (length exs) + mapM_ mlPut exs + +instance MLPut Bool where + mlPut True = putSymbol "True" + mlPut False = putSymbol "False" + +instance MLPut Int16 where + mlPut = putInt16 + +instance MLPut Int32 where + mlPut = putInt32 + +instance MLPut Int where + mlPut = putInt + +instance MLPut Integer where + mlPut i = do putFunction "ToExpression" 1 + putString $ show i + +instance MLPut Float where + mlPut = putFloat + +instance MLPut Double where + mlPut = putDouble + +instance MLPut String where + mlPut = putString + +instance MLPut [Int16] where + mlPut = putInt16List + +instance MLPut [Int32] where + mlPut = putInt32List + +instance MLPut [Int] where + mlPut = putIntList + +instance MLPut [Float] where + mlPut = putFloatList + +instance MLPut [Double] where + mlPut = putDoubleList + +instance (RealFloat a, MLPut a) => MLPut (Complex a) where + mlPut (r :+ i) = do putFunction "Complex" 2 + mlPut r + mlPut i + +instance (Integral a, MLPut a) => MLPut (Ratio a) where + mlPut (n :% d) = do putFunction "Rational" 2 + mlPut n + mlPut d + +instance (MLPut a) => MLPut [a] where + mlPut xs = do putFunction "List" (length xs) + mapM_ mlPut xs + +instance MLPut () where + mlPut () = mlPut $ Sy "Null" + +instance ( MLPut t1 + , MLPut t2 + ) => MLPut (t1,t2) where + mlPut (v1,v2) = do + putFunction "List" 2 + mlPut v1 + mlPut v2 + +instance ( MLPut t1 + , MLPut t2 + , MLPut t3 + ) => MLPut (t1,t2,t3) where + mlPut (v1,v2,v3) = do + putFunction "List" 3 + mlPut v1 + mlPut v2 + mlPut v3 + +instance ( MLPut t1 + , MLPut t2 + , MLPut t3 + , MLPut t4 + ) => MLPut (t1,t2,t3,t4) where + mlPut (v1,v2,v3,v4) = do + putFunction "List" 4 + mlPut v1 + mlPut v2 + mlPut v3 + mlPut v4 + +instance ( MLPut t1 + , MLPut t2 + , MLPut t3 + , MLPut t4 + , MLPut t5 + ) => MLPut (t1,t2,t3,t4,t5) where + mlPut (v1,v2,v3,v4,v5) = do + putFunction "List" 5 + mlPut v1 + mlPut v2 + mlPut v3 + mlPut v4 + mlPut v5 + +instance ( MLPut t1 + , MLPut t2 + , MLPut t3 + , MLPut t4 + , MLPut t5 + , MLPut t6 + ) => MLPut (t1,t2,t3,t4,t5,t6) where + mlPut (v1,v2,v3,v4,v5,v6) = do + putFunction "List" 6 + mlPut v1 + mlPut v2 + mlPut v3 + mlPut v4 + mlPut v5 + mlPut v6 + +instance ( MLPut t1 + , MLPut t2 + , MLPut t3 + , MLPut t4 + , MLPut t5 + , MLPut t6 + , MLPut t7 + ) => MLPut (t1,t2,t3,t4,t5,t6,t7) where + mlPut (v1,v2,v3,v4,v5,v6,v7) = do + putFunction "List" 7 + mlPut v1 + mlPut v2 + mlPut v3 + mlPut v4 + mlPut v5 + mlPut v6 + mlPut v7 + + +-------------------------- MLGet --------------------------- + +-- | The class of types that can be marshaled from /Mathematica/. +class MLGet a where + -- | Get a value from /Mathematica/. + mlGet :: IO a + +instance MLGet MLExpr where + mlGet = do + typ <- getType + case typ of + MLType TypI -> mlGet >>= (return . I) + MLType TypR -> mlGet >>= (return . R) + MLType TypSt -> mlGet >>= (return . St) + MLType TypSy -> getSymbol >>= (return . Sy) + MLType TypFn -> do (hd,nargs) <- getFunction + exs <- replicateM nargs mlGet + return $ hd:@exs + MLType TypErr -> throwMLError + _ -> throwMsg "mlGet/Expression: unexpected type" + +instance MLGet Bool where + mlGet = do + str <- getSymbol + case str of + "True" -> return True + "False" -> return False + _ -> throwMsg "mlGet/Bool: unexpected symbol" + +instance MLGet Int16 where + mlGet = getInt16 + +instance MLGet Int32 where + mlGet = getInt32 + +instance MLGet Int where + mlGet = getInt + +instance MLGet Integer where + mlGet = getString >>= (return . read) + +instance MLGet Float where + mlGet = getFloat + +instance MLGet Double where + mlGet = getDouble + +instance MLGet String where + mlGet = getString + +instance MLGet [Int16] where + mlGet = getInt16List + +instance MLGet [Int32] where + mlGet = getInt32List + +instance MLGet [Int] where + mlGet = getIntList + +instance MLGet [Float] where + mlGet = getFloatList + +instance MLGet [Double] where + mlGet = getDoubleList + +instance (RealFloat a, MLGet a) => MLGet (Complex a) where + mlGet = do + typ <- getType + case typ of + MLType TypI -> fromReal + MLType TypFn -> fromFunc + _ -> throwMsg "mlGet/Complex: unexpected type" + where fromReal = do + r <- mlGet + return $ r :+ 0 + + fromFunc = do + testFunction (== "Complex") (== 2) + r <- mlGet + i <- mlGet + return (r :+ i) + +instance (Integral a, MLGet a) => MLGet (Ratio a) where + mlGet = do + typ <- getType + case typ of + MLType TypI -> fromInt + MLType TypR -> fromReal + MLType TypFn -> fromFunc + _ -> throwMsg "mlGet/Ratio: unexpected type" + where fromInt = do + i <- mlGet + return $ i :% 1 + + fromReal = do + r <- mlGet + let (m,n) = decodeFloat (r :: Double) + b = floatRadix r + return $ (fromIntegral m) * (fromIntegral b)^^n + + fromFunc = do + testFunction (== "Rational") (== 2) + n <- mlGet + d <- mlGet + return (n :% d) + +instance (MLGet a) => MLGet [a] where + mlGet = do (_,nargs) <- testFunction (== "List") (>= 0) + replicateM nargs mlGet + +instance MLGet () where + mlGet = do + typ <- getType + case typ of + (MLType TypSy) -> do + sy <- getSymbol + if sy == "Null" then + return () + else + throwMsg "mlGet/(): unexpected symbol" + (MLType TypFn) -> do + testFunction (== "List") (== 0) + return () + _ -> throwMsg "mlGet/(): unexpected type" + +instance ( MLGet t1 + , MLGet t2 + ) => MLGet (t1,t2) where + mlGet = do testFunction (== "List") (== 2) + v1 <- mlGet + v2 <- mlGet + return (v1,v2) + +instance ( MLGet t1 + , MLGet t2 + , MLGet t3 + ) => MLGet (t1,t2,t3) where + mlGet = do testFunction (== "List") (== 3) + v1 <- mlGet + v2 <- mlGet + v3 <- mlGet + return (v1,v2,v3) + +instance ( MLGet t1 + , MLGet t2 + , MLGet t3 + , MLGet t4 + ) => MLGet (t1,t2,t3,t4) where + mlGet = do testFunction (== "List") (== 4) + v1 <- mlGet + v2 <- mlGet + v3 <- mlGet + v4 <- mlGet + return (v1,v2,v3,v4) + +instance ( MLGet t1 + , MLGet t2 + , MLGet t3 + , MLGet t4 + , MLGet t5 + ) => MLGet (t1,t2,t3,t4,t5) where + mlGet = do testFunction (== "List") (== 5) + v1 <- mlGet + v2 <- mlGet + v3 <- mlGet + v4 <- mlGet + v5 <- mlGet + return (v1,v2,v3,v4,v5) + +instance ( MLGet t1 + , MLGet t2 + , MLGet t3 + , MLGet t4 + , MLGet t5 + , MLGet t6 + ) => MLGet (t1,t2,t3,t4,t5,t6) where + mlGet = do testFunction (== "List") (== 6) + v1 <- mlGet + v2 <- mlGet + v3 <- mlGet + v4 <- mlGet + v5 <- mlGet + v6 <- mlGet + return (v1,v2,v3,v4,v5,v6) + +instance ( MLGet t1 + , MLGet t2 + , MLGet t3 + , MLGet t4 + , MLGet t5 + , MLGet t6 + , MLGet t7 + ) => MLGet (t1,t2,t3,t4,t5,t6,t7) where + mlGet = do testFunction (== "List") (== 7) + v1 <- mlGet + v2 <- mlGet + v3 <- mlGet + v4 <- mlGet + v5 <- mlGet + v6 <- mlGet + v7 <- mlGet + return (v1,v2,v3,v4,v5,v6,v7) + + +-------------------------- Packable -------------------------- + +-- | The class of types that can be marshaled to and from +-- /Mathematica/ via packed storage. +class Storable a => Packable a where + putPackedArray :: [a] -> [(Int,String)] -> IO () + getPackedArray :: IO ([a],[(Int,String)]) + +instance Packable Word8 where + putPackedArray xs dims = putInt16Array (map fromIntegral xs) dims + getPackedArray = do (xs,dims) <- getInt16Array + return (map fromIntegral xs, dims) + +instance Packable Int16 where + putPackedArray = putInt16Array + getPackedArray = getInt16Array + +instance Packable Int32 where + putPackedArray = putInt32Array + getPackedArray = getInt32Array + +instance Packable Int where + putPackedArray = putIntArray + getPackedArray = getIntArray + +instance Packable Float where + putPackedArray = putFloatArray + getPackedArray = getFloatArray + +instance Packable Double where + putPackedArray = putDoubleArray + getPackedArray = getDoubleArray + +-- | Send an array to /Mathematica/. +putArray :: ( IArray a e + , Ix ix + , Shapable ix + , Packable e + ) => a ix e -> IO () +putArray arr = putPackedArray xs dims + where xs = elems arr + sh = shape arr + dims = zip sh $ repeat "List" + +-- | Get an array from /Mathematica/. +getArray :: ( IArray a e + , Ix ix + , Shapable ix + , Packable e + ) => IO (a ix e) +getArray = do + (xs,dims) <- getPackedArray + let (shp,_) = unzip dims + bnds = sBounds shp + return $ listArray bnds xs + +instance (Packable e, Ix ix, Shapable ix) => MLPut (Array ix e) where + mlPut = putArray + +instance (Packable e, Ix ix, Shapable ix) => MLGet (Array ix e) where + mlGet = getArray + +instance ( IArray UArray e + , Packable e + , Ix ix + , Shapable ix + ) => MLPut (UArray ix e) where + mlPut = putArray + +instance ( IArray UArray e + , Packable e + , Ix ix + , Shapable ix + ) => MLGet (UArray ix e) where + mlGet = getArray diff --git a/Foreign/MathLink/Internal.chs b/Foreign/MathLink/Internal.chs new file mode 100644 --- /dev/null +++ b/Foreign/MathLink/Internal.chs @@ -0,0 +1,1041 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches #-} +{-# LANGUAGE + ForeignFunctionInterface + , DeriveDataTypeable + #-} + +module Foreign.MathLink.Internal + ( + + -- * Intitialization/finalization + initializeMathLink + , activate + , finalizeMathLink + + -- * Checking types + , Typ(..) + , MLType(..) + , getType + , testHead + , testFunction + + -- * Data marshaling + + -- ** Marshaling data to /Mathematica/ + + -- *** Scalars + , putInt16 + , putInt32 + , putInt + , putFloat + , putDouble + + -- *** Lists + , putInt16List + , putInt32List + , putIntList + , putFloatList + , putDoubleList + + -- *** Arrays + , putInt16Array + , putInt32Array + , putIntArray + , putFloatArray + , putDoubleArray + + -- *** String-like data + , putString + , putSymbol + , putFunction + + -- ** Marshaling data from /Mathematica/ + + -- *** Scalars + , getInt16 + , getInt32 + , getInt + , getFloat + , getDouble + + -- *** Lists + , getInt16List + , getInt32List + , getIntList + , getFloatList + , getDoubleList + + -- *** Arrays + , getInt16Array + , getInt32Array + , getIntArray + , getFloatArray + , getDoubleArray + + -- *** String-like data + , getString + , getSymbol + , getFunction + + -- * Out-of-band messaging + , checkInterrupt + , clearInterrupt + , checkAbort + , clearAbort + , checkDone + , putMessage + , Msg(..) + + -- * Errors + , Err(..) + , MLErr(..) + , throwErr + , throwCode + , throwMsg + , getErrorMessage + , getMLError + , throwMLError + , clearMLError + + -- * Packets + , Pkt(..) + , MLPacket(..) + + , nextPacket + , newPacket + , endPacket + , flush + , ready + , waitForPacket + + ) where + +import Foreign +import Foreign.C +import Control.Monad +import Control.Exception +import Data.Typeable + +import System.IO + +#include "mathlink.h" +#include "ml.h" +#include "arch.h" + +------------------------ Types ------------------------- + +{# enum define Pkt + { ILLEGALPKT as PktIllegal + , CALLPKT as PktCall + , EVALUATEPKT as PktEvaluate + , RETURNPKT as PktReturn + , INPUTNAMEPKT as PktInputName + , ENTERTEXTPKT as PktEnterText + , ENTEREXPRPKT as PktEnterExpr + , OUTPUTNAMEPKT as PktOutputName + , RETURNTEXTPKT as PktReturnText + , RETURNEXPRPKT as PktReturnExpr + , DISPLAYPKT as PktDisplay + , DISPLAYENDPKT as PktDisplayEnd + , MESSAGEPKT as PktMessage + , TEXTPKT as PktText + , INPUTPKT as PktInput + , INPUTSTRPKT as PktInputStr + , MENUPKT as PktMenu + , SYNTAXPKT as PktSyntax + , SUSPENDPKT as PktSuspend + , RESUMEPKT as PktResume + , BEGINDLGPKT as PktBeginDlg + , ENDDLGPKT as PktEndDlg + , FIRSTUSERPKT as PktFirstUser + , LASTUSERPKT as PktLastUser + } + deriving (Eq,Show) + #} + +data MLPacket = MLPacket Pkt + | UserPacket Int + | UnknownPacket Int + deriving (Eq,Show) + +instance Ord MLPacket where + p1 `compare` p2 = (fromEnum p1) `compare` (fromEnum p2) + +instance Enum MLPacket where + toEnum i + | i == fromEnum PktIllegal = MLPacket PktIllegal + | i == fromEnum PktCall = MLPacket PktCall + | i == fromEnum PktEvaluate = MLPacket PktEvaluate + | i == fromEnum PktReturn = MLPacket PktReturn + | i == fromEnum PktInputName = MLPacket PktInputName + | i == fromEnum PktEnterText = MLPacket PktEnterText + | i == fromEnum PktEnterExpr = MLPacket PktEnterExpr + | i == fromEnum PktOutputName = MLPacket PktOutputName + | i == fromEnum PktReturnText = MLPacket PktReturnText + | i == fromEnum PktReturnExpr = MLPacket PktReturnExpr + | i == fromEnum PktDisplay = MLPacket PktDisplay + | i == fromEnum PktDisplayEnd = MLPacket PktDisplayEnd + | i == fromEnum PktMessage = MLPacket PktMessage + | i == fromEnum PktText = MLPacket PktText + | i == fromEnum PktInput = MLPacket PktInput + | i == fromEnum PktInputStr = MLPacket PktInputStr + | i == fromEnum PktMenu = MLPacket PktMenu + | i == fromEnum PktSyntax = MLPacket PktSyntax + | i == fromEnum PktSuspend = MLPacket PktSuspend + | i == fromEnum PktResume = MLPacket PktResume + | i == fromEnum PktBeginDlg = MLPacket PktBeginDlg + | i == fromEnum PktEndDlg = MLPacket PktEndDlg + | i >= fromEnum PktFirstUser && + i <= fromEnum PktLastUser = UserPacket i + | otherwise = UnknownPacket i + + fromEnum (MLPacket pkt) = fromEnum pkt + fromEnum (UserPacket i) = i + fromEnum (UnknownPacket i) = i + +{# enum define Msg + { MLTerminateMessage as MsgTerminate + , MLInterruptMessage as MsgInterrupt + , MLAbortMessage as MsgAbort + , MLEndPacketMessage as MsgEndPacket + , MLSynchronizeMessage as MsgSynchronize + , MLImDyingMessage as MsgImDying + , MLWaitingAcknowledgment as MsgWaitingAcknowledgement + , MLMarkTopLevelMessage as MsgMarkTopLevel + , MLLinkClosingMessage as MsgLinkClosing + , MLAuthenticateFailure as MsgAuthenticateFailure + , MLFirstUserMessage as MsgFirstUser + , MLLastUserMessage as MsgLastUser + } + deriving (Eq,Show) + #} + +{# enum define Typ + { MLTKFUNC as TypFn + , MLTKERROR as TypErr + , MLTKSTR as TypSt + , MLTKSYM as TypSy + , MLTKREAL as TypR + , MLTKINT as TypI + } + deriving (Eq,Show) + #} + +data MLType = MLType Typ + | UnknownType Int + deriving (Eq,Show) + +instance Ord MLType where + t1 `compare` t2 = (fromEnum t1) `compare` (fromEnum t2) + +instance Enum MLType where + toEnum i + | i == fromEnum TypFn = MLType TypFn + | i == fromEnum TypErr = MLType TypErr + | i == fromEnum TypSt = MLType TypSt + | i == fromEnum TypSy = MLType TypSy + | i == fromEnum TypR = MLType TypR + | i == fromEnum TypI = MLType TypI + | otherwise = UnknownType i + + fromEnum (MLType typ) = fromEnum typ + fromEnum (UnknownType i) = i + +{# enum define Err + { MLEUNKNOWN as ErrUnknown + , MLEOK as ErrOK + , MLEDEAD as ErrDead + , MLEGBAD as ErrGBad + , MLEGSEQ as ErrGSeq + , MLEPBTK as ErrPBad + , MLEPSEQ as ErrPSeq + , MLEPBIG as ErrPBig + , MLEOVFL as ErrOvfl + , MLEMEM as ErrMem + , MLEACCEPT as ErrAccept + , MLECONNECT as ErrConnect + , MLEPUTENDPACKET as ErrPutEndPacket + , MLENEXTPACKET as ErrNextPacket + , MLEUNKNOWNPACKET as ErrUnknownPacket + , MLEGETENDPACKET as ErrGetEndPacket + , MLEABORT as ErrAbort + , MLECLOSED as ErrClosed + , MLEINIT as ErrInt + , MLEARGV as ErrArgv + , MLEPROTOCOL as ErrProtocol + , MLEMODE as ErrMode + , MLELAUNCH as ErrLaunch + , MLELAUNCHAGAIN as ErrLaunchAgain + , MLELAUNCHSPACE as ErrLaunchSpace + , MLENOPARENT as ErrNoParent + , MLENAMETAKEN as ErrNameTaken + , MLENOLISTEN as ErrNoListen + , MLEBADNAME as ErrBadName + , MLEBADHOST as ErrBadHost + , MLELAUNCHFAILED as ErrLaunchFailed + , MLELAUNCHNAME as ErrLaunchName + , MLEPSCONVERT as ErrPSConvert + , MLEGSCONVERT as ErrGSConvert + , MLEPDATABAD as ErrPDataBad + , MLEUSER as ErrUser + } + deriving (Eq,Show) + #} + +data MLErr = MLErr Int String + | MLErrCode Int + | MLErrMsg String + deriving (Eq,Show,Typeable) + +instance Exception MLErr where + + +--------------------- Initialization ----------------------- + +{# pointer MLINK as Link newtype #} + +foreign import ccall safe "mathlink.h & stdlink" stdlinkPtr + :: Ptr (Ptr ()) + +withLink :: (Link -> IO a) -> IO a +withLink fn = peek stdlinkPtr >>= fn . Link . castPtr + +-- | Initialize the /MathLink/ connection. +{# fun MLInitializeMathLink as initializeMathLink + { `String' + } -> `Bool' + #} + +-- | Shut down the /MathLink/ connection. +{# fun MLFinalizeMathLink as finalizeMathLink + { + } -> `()' id + #} + +-- | Activate the /MathLink/ connection. +{# fun MLActivate as activate + { withLink- `Link' + } -> `Bool' + #} + +---------------------- Messages ----------------------------- + +foreign import ccall safe "mathlink.h & MLInterrupt" interruptPtr + :: Ptr CInt +foreign import ccall safe "mathlink.h & MLAbort" abortPtr + :: Ptr CInt +foreign import ccall safe "mathlink.h & MLDone" donePtr + :: Ptr CInt + +checkPtr :: Ptr CInt -> IO Bool +checkPtr ptr = peek ptr >>= (return . (/= 0)) + +clearPtr :: Ptr CInt -> IO () +clearPtr ptr = poke ptr 0 + +-- | Check if the an interrupt message was received. +checkInterrupt :: IO Bool +checkInterrupt = checkPtr interruptPtr + +-- | Clear any interrupt messages. +clearInterrupt :: IO () +clearInterrupt = clearPtr interruptPtr + +-- | Check if an abort message was received. +checkAbort :: IO Bool +checkAbort = checkPtr abortPtr + +-- | Clear any abort messages. +clearAbort :: IO () +clearAbort = clearPtr abortPtr + +-- | Check if a done message was received. +checkDone :: IO Bool +checkDone = checkPtr donePtr + +-- | Send a /MathLink/ message to the other end of the +-- /MathLink/ connection. +{# fun MLPutMessage as putMessage + { withLink- `Link' + , cFromEnum `Msg' + } -> `Bool' + #} + + +-------------------- Errors ------------------------- + +-- | Throw an 'MLErr' with the given error code and message. +throwErr :: Int -> String -> IO a +throwErr code msg = throw $ MLErr code msg + +-- | Throw an 'MLErr' with just an error code. +throwCode :: Int -> IO a +throwCode code = throw $ MLErrCode code + +-- | Throw an 'MLErr' with just an error message. +throwMsg :: String -> IO a +throwMsg msg = throw $ MLErrMsg msg + +-- | Get the error code associated with the last /MathLink/ error. +{# fun MLError as getErrorCode + { withLink- `Link' + } -> `Int' cIntConv + #} + +-- | Get a string associated with the last /MathLink/ error. +{# fun MLErrorMessage as getErrorMessage + { withLink- `Link' + } -> `String' + #} + +-- | Get the last /MathLink/ error as an 'MLErr'. +getMLError :: IO MLErr +getMLError = do + code <- getErrorCode + msg <- getErrorMessage + return $ MLErr code msg + +-- | Throw an 'MLErr' corresponding to the last /MathLink/ error. +throwMLError :: IO a +throwMLError = getMLError >>= throw + +-- | Clear the last /MathLink/ error. +{# fun MLClearError as clearMLError + { withLink- `Link' + } -> `()' throwUnless- + #} + +throwUnless :: Integral a => a -> IO () +throwUnless 0 = throwMLError +throwUnless _ = return () + +----------------------- Packets -------------------------- + +-- | Goes to the beginning of the next packet and returns its type. +{# fun MLNextPacket as nextPacket + { withLink- `Link' + } -> `MLPacket' cToEnum + #} + +-- | Skips to the beginning of the next packet. +{# fun MLNewPacket as newPacket + { withLink- `Link' + } -> `()' throwUnless- + #} + +-- | Marks the end of the packet being put on the link. +{# fun MLEndPacket as endPacket + { withLink- `Link' + } -> `()' throwUnless- + #} + +-- | Forces any pending data to be sent. +{# fun MLFlush as flush + { withLink- `Link' + } -> `()' throwUnless- + #} + +-- | Checks if a packet is available for getting. +-- +-- Requires that there be no pending data to be sent (/i.e./, +-- call 'flush' first). +{# fun MLReady as ready + { withLink- `Link' + } -> `()' throwUnless- + #} + +-- | Drops packets until one satisfying the given predicate is received. +waitForPacket :: (MLPacket -> Bool) -> IO () +waitForPacket q = do + pkt <- nextPacket + if pkt == MLPacket PktIllegal then throwMLError else return () + if q pkt then return () else do + hPutStrLn stderr $ "Dropping packet: " ++ show pkt + newPacket + + +---------------------- Marshaling (puts) --------------------- + +{# fun MLPutInteger16 as putInt16 + { withLink- `Link' + , `Int16' + } -> `()' throwUnless- + #} + +{# fun MLPutInteger32 as putInt32 + { withLink- `Link' + , `Int32' + } -> `()' throwUnless- + #} + +#ifdef IS_64_BIT +{# fun MLPutInteger64 as putInt + { withLink- `Link' + , `Int' + } -> `()' throwUnless- + #} +#else +{# fun MLPutInteger32 as putInt + { withLink- `Link' + , `Int' + } -> `()' throwUnless- + #} +#endif + +{# fun MLPutReal32 as putFloat + { withLink- `Link' + , `Float' + } -> `()' throwUnless- + #} + +{# fun MLPutReal64 as putDouble + { withLink- `Link' + , `Double' + } -> `()' throwUnless- + #} + +{# fun MLPutString as putString + { withLink- `Link' + , `String' + } -> `()' throwUnless- + #} + +{# fun MLPutSymbol as putSymbol + { withLink- `Link' + , `String' + } -> `()' throwUnless- + #} + +{# fun MLPutFunction as putFunction + { withLink- `Link' + , `String' + , `Int' + } -> `()' throwUnless- + #} + +putList :: Storable b + => (a -> b) + -> (Ptr b -> Int -> IO ()) + -> [a] -> IO () +putList cnv pfn xs = do + withArray (map cnv xs) $ \ptr -> pfn ptr (length xs) + +{# fun MLPutInteger16List as putInt16List' + { withLink- `Link' + , id `Ptr CShort' + , `Int' + } -> `()' throwUnless- + #} +putInt16List :: [Int16] -> IO () +putInt16List = putList cIntConv putInt16List' + +{# fun MLPutInteger32List as putInt32List' + { withLink- `Link' + , id `Ptr CInt' + , `Int' + } -> `()' throwUnless- + #} +putInt32List :: [Int32] -> IO () +putInt32List = putList cIntConv putInt32List' + +#ifdef IS_64_BIT +{# fun MLPutInteger64List as putIntList' + { withLink- `Link' + , id `Ptr CLong' + , `Int' + } -> `()' throwUnless- + #} +#else +{# fun MLPutInteger32List as putIntList' + { withLink- `Link' + , id `Ptr CInt' + , `Int' + } -> `()' throwUnless- + #} +#endif +putIntList :: [Int] -> IO () +putIntList = putList cIntConv putIntList' + +{# fun MLPutReal32List as putFloatList' + { withLink- `Link' + , id `Ptr CFloat' + , `Int' + } -> `()' throwUnless- + #} +putFloatList :: [Float] -> IO () +putFloatList = putList cFloatConv putFloatList' + +{# fun MLPutReal64List as putDoubleList' + { withLink- `Link' + , id `Ptr CDouble' + , `Int' + } -> `()' throwUnless- + #} +putDoubleList :: [Double] -> IO () +putDoubleList = putList cFloatConv putDoubleList' + +putArray :: (Storable b) + => (a -> b) + -> (Ptr b -> Ptr CInt -> Ptr CString -> Int -> IO ()) + -> [a] -> [(Int,String)] -> IO () +putArray cnv pfn xs dims = do + withArray es $ \esPtr -> + bracket (mapM newCString hds) (mapM_ free) $ \hdCStrs -> + withArray hdCStrs $ \hdsPtr -> + withArray (map cIntConv shape) $ \shpPtr -> + pfn esPtr shpPtr hdsPtr rank + where es = map cnv xs + rank = length dims + (shape,hds) = unzip dims + +{# fun MLPutInteger16Array as putInt16Array' + { withLink- `Link' + , id `Ptr CShort' + , id `Ptr CInt' + , id `Ptr CString' + , `Int' + } -> `()' throwUnless- + #} +putInt16Array :: [Int16] -> [(Int,String)] -> IO () +putInt16Array = putArray (cIntConv) putInt16Array' + +{# fun MLPutInteger32Array as putInt32Array' + { withLink- `Link' + , id `Ptr CInt' + , id `Ptr CInt' + , id `Ptr CString' + , `Int' + } -> `()' throwUnless- + #} +putInt32Array :: [Int32] -> [(Int,String)] -> IO () +putInt32Array = putArray (cIntConv) putInt32Array' + +#ifdef IS_64_BIT +{# fun MLPutInteger64Array as putIntArray' + { withLink- `Link' + , id `Ptr CLong' + , id `Ptr CInt' + , id `Ptr CString' + , `Int' + } -> `()' throwUnless- + #} +#else +{# fun MLPutInteger32Array as putIntArray' + { withLink- `Link' + , id `Ptr CInt' + , id `Ptr CInt' + , id `Ptr CString' + , `Int' + } -> `()' throwUnless- + #} +#endif +putIntArray :: [Int] -> [(Int,String)] -> IO () +putIntArray = putArray (cIntConv) putIntArray' + +{# fun MLPutReal32Array as putFloatArray' + { withLink- `Link' + , id `Ptr CFloat' + , id `Ptr CInt' + , id `Ptr CString' + , `Int' + } -> `()' throwUnless- + #} +putFloatArray :: [Float] -> [(Int,String)] -> IO () +putFloatArray = putArray (cFloatConv) putFloatArray' + +{# fun MLPutReal64Array as putDoubleArray' + { withLink- `Link' + , id `Ptr CDouble' + , id `Ptr CInt' + , id `Ptr CString' + , `Int' + } -> `()' throwUnless- + #} +putDoubleArray :: [Double] -> [(Int,String)] -> IO () +putDoubleArray = putArray (cFloatConv) putDoubleArray' + + +----------------------- Marshaling (gets) -------------------- + +{# fun MLGetInteger16 as getInt16 + { withLink- `Link' + , alloca- `Int16' peekIntConv* + } -> `()' throwUnless- + #} + +{# fun MLGetInteger32 as getInt32 + { withLink- `Link' + , alloca- `Int32' peekIntConv* + } -> `()' throwUnless- + #} + +#ifdef IS_64_BIT +{# fun MLGetInteger64 as getInt + { withLink- `Link' + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +#else +{# fun MLGetInteger32 as getInt + { withLink- `Link' + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +#endif + +{# fun MLGetReal32 as getFloat + { withLink- `Link' + , alloca- `Float' peekFloatConv* + } -> `()' throwUnless- + #} + +{# fun MLGetReal64 as getDouble + { withLink- `Link' + , alloca- `Double' peekFloatConv* + } -> `()' throwUnless- + #} + +{# fun MLReleaseString as releaseString + { withLink- `Link' + , id `CString' + } -> `()' id + #} +{# fun MLGetString as getString' + { withLink- `Link' + , alloca- `CString' peek* + } -> `()' throwUnless- + #} +getString :: IO String +getString = do + cstr <- getString' + str <- peekCString cstr + releaseString cstr + return str + +{# fun MLReleaseSymbol as releaseSymbol + { withLink- `Link' + , id `CString' + } -> `()' id + #} +{# fun MLGetSymbol as getSymbol' + { withLink- `Link' + , alloca- `CString' peek* + } -> `()' throwUnless- + #} +getSymbol :: IO String +getSymbol = do + cstr <- getSymbol' + str <- peekCString cstr + releaseSymbol cstr + return str + +{# fun MLGetFunction as getFunction' + { withLink- `Link' + , alloca- `CString' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +getFunction :: IO (String,Int) +getFunction = do + (cstr, n) <- getFunction' + str <- peekCString cstr + releaseSymbol cstr + return (str, n) + +getList :: Storable a + => (a -> b) + -> (IO (Ptr a, Int)) + -> (Ptr a -> Int -> IO ()) + -> IO [b] +getList cnv gfn rfn = do + (ptr, n) <- gfn + l <- peekArray n ptr + rfn ptr n + return (map cnv l) + +{# fun MLReleaseInteger16List as releaseInt16List' + { withLink- `Link' + , id `Ptr CShort' + , `Int' + } -> `()' id + #} +{# fun MLGetInteger16List as getInt16List' + { withLink- `Link' + , alloca- `Ptr CShort' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +getInt16List :: IO [Int16] +getInt16List = getList cIntConv getInt16List' releaseInt16List' + +{# fun MLReleaseInteger32List as releaseInt32List' + { withLink- `Link' + , id `Ptr CInt' + , `Int' + } -> `()' id + #} +{# fun MLGetInteger32List as getInt32List' + { withLink- `Link' + , alloca- `Ptr CInt' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +getInt32List :: IO [Int32] +getInt32List = getList cIntConv getInt32List' releaseInt32List' + +#ifdef IS_64_BIT +{# fun MLReleaseInteger64List as releaseIntList' + { withLink- `Link' + , id `Ptr CLong' + , `Int' + } -> `()' id + #} +{# fun MLGetInteger64List as getIntList' + { withLink- `Link' + , alloca- `Ptr CLong' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +#else +{# fun MLReleaseInteger32List as releaseIntList' + { withLink- `Link' + , id `Ptr CInt' + , `Int' + } -> `()' id + #} +{# fun MLGetInteger32List as getIntList' + { withLink- `Link' + , alloca- `Ptr CInt' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +#endif +getIntList :: IO [Int] +getIntList = getList cIntConv getIntList' releaseIntList' + +{# fun MLReleaseReal32List as releaseFloatList' + { withLink- `Link' + , id `Ptr CFloat' + , `Int' + } -> `()' id + #} +{# fun MLGetReal32List as getFloatList' + { withLink- `Link' + , alloca- `Ptr CFloat' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +getFloatList :: IO [Float] +getFloatList = getList cFloatConv getFloatList' releaseFloatList' + +{# fun MLReleaseReal64List as releaseDoubleList' + { withLink- `Link' + , id `Ptr CDouble' + , `Int' + } -> `()' id + #} +{# fun MLGetReal64List as getDoubleList' + { withLink- `Link' + , alloca- `Ptr CDouble' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +getDoubleList :: IO [Double] +getDoubleList = getList cFloatConv getDoubleList' releaseDoubleList' + +getArray :: (Storable a) + => (a -> b) + -> (IO (Ptr a, Ptr CInt, Ptr CString, Int)) + -> (Ptr a -> Ptr CInt -> Ptr CString -> Int -> IO ()) + -> IO ([b],[(Int,String)]) +getArray cnv gfn rfn = do + (esPtr, shpPtr, hdsPtr, rnk) <- gfn + shape <- peekArray rnk shpPtr >>= (return . map cIntConv) + hds <- peekArray rnk hdsPtr >>= (mapM peekCString) + es <- peekArray (product shape) esPtr >>= (return . map cnv) + rfn esPtr shpPtr hdsPtr rnk + return (es,zip shape hds) + +{# fun MLGetInteger16Array as getInt16Array' + { withLink- `Link' + , alloca- `Ptr CShort' peek* + , alloca- `Ptr CInt' peek* + , alloca- `Ptr CString' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +{# fun MLReleaseInteger16Array as releaseInt16Array' + { withLink- `Link' + , id `Ptr CShort' + , id `Ptr CInt' + , id `Ptr CString' + , cIntConv `Int' + } -> `()' id + #} +getInt16Array :: IO ([Int16],[(Int,String)]) +getInt16Array = + getArray cIntConv getInt16Array' releaseInt16Array' + +{# fun MLGetInteger32Array as getInt32Array' + { withLink- `Link' + , alloca- `Ptr CInt' peek* + , alloca- `Ptr CInt' peek* + , alloca- `Ptr CString' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +{# fun MLReleaseInteger32Array as releaseInt32Array' + { withLink- `Link' + , id `Ptr CInt' + , id `Ptr CInt' + , id `Ptr CString' + , cIntConv `Int' + } -> `()' id + #} +getInt32Array :: IO ([Int32],[(Int,String)]) +getInt32Array = + getArray cIntConv getInt32Array' releaseInt32Array' + +#ifdef IS_64_BIT +{# fun MLGetInteger64Array as getIntArray' + { withLink- `Link' + , alloca- `Ptr CLong' peek* + , alloca- `Ptr CInt' peek* + , alloca- `Ptr CString' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +{# fun MLReleaseInteger64Array as releaseIntArray' + { withLink- `Link' + , id `Ptr CLong' + , id `Ptr CInt' + , id `Ptr CString' + , cIntConv `Int' + } -> `()' id + #} +#else +{# fun MLGetInteger32Array as getIntArray' + { withLink- `Link' + , alloca- `Ptr CLong' peek* + , alloca- `Ptr CInt' peek* + , alloca- `Ptr CString' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +{# fun MLReleaseInteger32Array as releaseIntArray' + { withLink- `Link' + , id `Ptr CLong' + , id `Ptr CInt' + , id `Ptr CString' + , cIntConv `Int' + } -> `()' id + #} +#endif +getIntArray :: IO ([Int],[(Int,String)]) +getIntArray = + getArray cIntConv getIntArray' releaseIntArray' + +{# fun MLGetReal32Array as getFloatArray' + { withLink- `Link' + , alloca- `Ptr CFloat' peek* + , alloca- `Ptr CInt' peek* + , alloca- `Ptr CString' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +{# fun MLReleaseReal32Array as releaseFloatArray' + { withLink- `Link' + , id `Ptr CFloat' + , id `Ptr CInt' + , id `Ptr CString' + , cIntConv `Int' + } -> `()' id + #} +getFloatArray :: IO ([Float],[(Int,String)]) +getFloatArray = + getArray cFloatConv getFloatArray' releaseFloatArray' + +{# fun MLGetReal64Array as getDoubleArray' + { withLink- `Link' + , alloca- `Ptr CDouble' peek* + , alloca- `Ptr CInt' peek* + , alloca- `Ptr CString' peek* + , alloca- `Int' peekIntConv* + } -> `()' throwUnless- + #} +{# fun MLReleaseReal64Array as releaseDoubleArray' + { withLink- `Link' + , id `Ptr CDouble' + , id `Ptr CInt' + , id `Ptr CString' + , cIntConv `Int' + } -> `()' id + #} +getDoubleArray :: IO ([Double],[(Int,String)]) +getDoubleArray = + getArray cFloatConv getDoubleArray' releaseDoubleArray' + +-- | Gets the type of the next value to be gotten over the link. +{# fun MLGetType as getType + { withLink- `Link' + } -> `MLType' cToEnum + #} + +-- | Returns the number of arguments of a compound expression, +-- given that the expression's head is identical to the 'String' +-- given. +-- +-- Throws an exception on failure. +{# fun MLTestHead as testHead + { withLink- `Link' + , `String' + , alloca- `Int' peekIntConv* + } -> `Bool' + #} + +-- | Checks that the incoming value is of a composite (function) +-- type and applies the given predicates to the expression's head +-- and the number of arguments, throwing an exception on failure. +testFunction + :: (String -> Bool) -- ^ The test for the expression's head. + -> (Int -> Bool) -- ^ The test for the number of arguments. + -> IO (String,Int) -- ^ The head and number of arguments, on success. +testFunction hdQ nargQ = do + typ <- getType + case typ of + MLType TypFn -> do + (hd,nargs) <- getFunction + case (hdQ hd, nargQ nargs) of + (True,True) -> return (hd,nargs) + (False,_) -> throwMsg "testFunction: head failed predicate." + (_,False) -> throwMsg "testFunction: # of args failed predicate." + _ -> throwMsg "testFunction: Expected function type" + +------------------------- C2HS Stuff -------------------------- + +peekIntConv :: (Storable a, Integral a, Integral b) + => Ptr a -> IO b +peekIntConv = liftM cIntConv . peek + +peekFloatConv :: (Storable a, RealFloat a, RealFloat b) + => Ptr a -> IO b +peekFloatConv = liftM cFloatConv . peek + +cIntConv :: (Integral a, Integral b) => a -> b +cIntConv = fromIntegral + +cFloatConv :: (RealFloat a, RealFloat b) => a -> b +cFloatConv = realToFrac +{-# RULES + "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x; + "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x + #-} + +cToBool :: Num a => a -> Bool +cToBool = toBool + +cToEnum :: (Integral i, Enum e) => i -> e +cToEnum = toEnum . cIntConv + +cFromEnum :: (Enum e, Integral i) => e -> i +cFromEnum = cIntConv . fromEnum diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,11 @@ +Installation Notes: + +First make sure that the mathlink.h header file and the ML32i3 (for 32-bit +systems) or ML64i3 (for 64-bit systems) library are in places that can be +found by GHC. + +Otherwise, the usual rules apply: + +> runhaskell Setup.lhs configure +> runhaskell Setup.lhs build +> [sudo] runhaskell Setup.lhs install diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,7 +1,52 @@ -#!/bin/env runhaskell +#!/usr/bin/env runhaskell \begin{code} import Distribution.Simple -main = defaultMain +import Distribution.System +import System.IO +import System.Directory + +buildInfoFileName = "mathlink.buildinfo" +archHeaderFileName = "cbits/arch.h" + +fileNames = [ buildInfoFileName + , archHeaderFileName + ] + +bits = if is64bit then 64 else 32 + where Platform arch _ = buildPlatform + is64bit = case arch of + X86_64 -> True + IA64 -> True + PPC64 -> True + _ -> False + +buildInfoFile = "\ +\Extra-Libraries: ML" ++ show bits ++ "i3, rt\n" + +archHeaderFile = "\ +\#ifndef __ARCH_H__\n\ +\#define __ARCH_H__\n\ +\\n\ +\#define IS_" ++ show bits ++ "_BIT\n\ +\\n\ +\#endif\n" + +removeIfExists fn = do + bl <- doesFileExist fn + if bl then removeFile fn else return () + +makeFiles _ _ _ _ = do + writeFile buildInfoFileName buildInfoFile + writeFile archHeaderFileName archHeaderFile + +removeFiles _ _ _ _ = mapM_ removeIfExists fileNames + +mathLinkHooks = simpleUserHooks { + postConf = makeFiles + , postClean = removeFiles + } + +main = defaultMainWithHooks mathLinkHooks \end{code} diff --git a/cbits/ml.c b/cbits/ml.c new file mode 100644 --- /dev/null +++ b/cbits/ml.c @@ -0,0 +1,49 @@ +#include +#include "ml.h" + +int MLInterrupt = 0; +int MLAbort = 0; +int MLDone = 0; + +MLINK stdlink = 0; +MLEnvironment stdenv = 0; + +MLMessageHandlerObject stdhandler = 0; + +void MLDefaultHandler(MLINK mlp, int message, int n) +{ + switch(message) + { + case MLTerminateMessage: + MLDone = 1; + case MLAbortMessage: + MLAbort = 1; + case MLInterruptMessage: + MLInterrupt = 1; + default: + return; + } +} + +int MLInitializeMathLink(char * commandLine) +{ + int err; + if(!stdenv) stdenv = MLInitialize((MLParametersPointer)0); + if(stdenv == (MLEnvironment)0) return 0; + if(!stdhandler) stdhandler = (MLMessageHandlerObject)MLDefaultHandler; + stdlink = MLOpenString(stdenv, commandLine, &err); + if(stdlink == (MLINK)0) + { + MLDeinitialize(stdenv); + stdenv = (MLEnvironment)0; + return 0; + } + if(stdhandler) MLSetMessageHandler(stdlink, stdhandler); + return 1; +} + +void MLFinalizeMathLink() +{ + MLClose(stdlink); + MLDeinitialize(stdenv); +} diff --git a/example/Test.hs b/example/Test.hs new file mode 100644 --- /dev/null +++ b/example/Test.hs @@ -0,0 +1,48 @@ +-- See the README file for an example session. + +module Main where + +import Foreign.MathLink + +addFour :: (Int,Int,Int,Int) -> IO Int +addFour (a,b,c,d) = return $ a+b+c+d + +-- Note that functions to be exposed need to be uncurried. +ackermann :: (Integer,Integer) -> IO Integer +ackermann (m,n) = return $ ack m n + +ack :: Integer -> Integer -> Integer +ack 0 n = n + 1 +ack 1 n = n + 2 +ack 2 n = 2 * n + 3 +ack m 0 = ack (m-1) 1 +ack m n = ack (m-1) (ack m (n-1)) + +decl :: MLSpec +decl = + [ Eval $ "BeginPackage":@[St "Test`"] + + , DeclMsg "AddFour" "usage" + "AddFour[a,b,c,d] returns the sum of a, b, c, and d." + , DeclMsg "Ackermann" "usage" + "Ackermann[m,n]: the Ackermann function." + + , Eval $ "Begin":@[St "`Private`"] + + , DeclFn { + callPattern = "AddFour[a_Integer,b_Integer,c_Integer,d_Integer]" + , argPattern = "{a,b,c,d}" + , func = addFour + } + , DeclFn { + callPattern = "Ackermann[i_Integer,j_Integer]" + , argPattern = "{i,j}" + , func = ackermann + } + + , Eval $ "End":@[] + , Eval $ "EndPackage":@[] + ] + +main :: IO () +main = runMathLink decl diff --git a/examples/Setup.lhs b/examples/Setup.lhs deleted file mode 100644 --- a/examples/Setup.lhs +++ /dev/null @@ -1,7 +0,0 @@ -#!/bin/env runhaskell -\begin{code} - -import Distribution.Simple -main = defaultMain - -\end{code} diff --git a/examples/mltest.cabal b/examples/mltest.cabal deleted file mode 100644 --- a/examples/mltest.cabal +++ /dev/null @@ -1,20 +0,0 @@ -Name: mltest -Version: 0.1.0 -Cabal-Version: >= 1.2 -Build-Type: Simple -License: BSD3 -Copyright: Copyright (c) Tracy Wadleigh 2008 -Author: Tracy Wadleigh -Maintainer: -Bug-Reports: mailto:tracy.wadleigh@gmail.com?subject=mltest -Stability: experimental -Synopsis: An example of using the MathLink Haskell library - -Executable mltest - Build-Depends: base >= 4.0 && < 4.1, - mathlink >= 1.0 && < 1.1, - array >= 0.2 && < 0.3, - mtl >= 1.1.0.2 && < 1.2 - Hs-Source-Dirs: src - Main-Is: Main.hs - diff --git a/examples/mltest.nb b/examples/mltest.nb deleted file mode 100644 --- a/examples/mltest.nb +++ /dev/null @@ -1,143 +0,0 @@ -(* Content-type: application/mathematica *) - -(*** Wolfram Notebook File ***) -(* http://www.wolfram.com/nb *) - -(* CreatedBy='Mathematica 7.0' *) - -(*CacheID: 234*) -(* Internal cache information: -NotebookFileLineBreakTest -NotebookFileLineBreakTest -NotebookDataPosition[ 145, 7] -NotebookDataLength[ 4548, 134] -NotebookOptionsPosition[ 3912, 110] -NotebookOutlinePosition[ 4270, 126] -CellTagsIndexPosition[ 4227, 123] -WindowFrame->Normal*) - -(* Beginning of Notebook Content *) -Notebook[{ -Cell[BoxData[ - RowBox[{"SetDirectory", "[", "\"\<~/hs/mathlink/examples/\>\"", - "]"}]], "Input", - CellChangeTimes->{{3.439309979806336*^9, 3.439310029119624*^9}, { - 3.439504790090583*^9, 3.439504790564527*^9}}], - -Cell[TextData[{ - "Wrapping the ", - StyleBox["MathLink", - FontSlant->"Italic"], - " executable in a shell script is a nice way to pass extra arguments to the \ -GHC RTS without interfering with the command line arguments that ", - StyleBox["MathLink", - FontSlant->"Italic"], - " needs to pass to establish the connection." -}], "Text", - CellChangeTimes->{{3.440168766081661*^9, 3.440168924034021*^9}, - 3.442004040708877*^9}], - -Cell[BoxData[ - RowBox[{"lnk", "=", - RowBox[{"Install", "[", "\"\\"", "]"}]}]], "Input", - CellChangeTimes->{{3.439310037308844*^9, 3.4393100665348454`*^9}, { - 3.4393123483575773`*^9, 3.439312353820722*^9}, {3.439313763736014*^9, - 3.439313786830782*^9}, {3.439314248568095*^9, 3.439314249330996*^9}}], - -Cell[BoxData[ - RowBox[{"AddTwo", "[", - RowBox[{"2", ",", "3"}], "]"}]], "Input", - CellChangeTimes->{{3.43931006947751*^9, 3.43931007209233*^9}}], - -Cell[BoxData[ - RowBox[{"ReverseNumbers", "[", - RowBox[{ - "1", ",", "2", ",", "3", ",", "\[ImaginaryI]", ",", "\[ExponentialE]", ",", - "\[Pi]"}], "]"}]], "Input", - CellChangeTimes->{{3.4401687018512993`*^9, 3.440168712601337*^9}, { - 3.440180321606152*^9, 3.440180358834758*^9}}], - -Cell[BoxData[ - RowBox[{"ReverseArray", "[", - RowBox[{"{", - RowBox[{ - RowBox[{"{", - RowBox[{"1", ",", "2", ",", "3"}], "}"}], ",", - RowBox[{"{", - RowBox[{"4", ",", "5", ",", "6"}], "}"}]}], "}"}], "]"}]], "Input", - CellChangeTimes->{{3.440168935664534*^9, 3.440168948360408*^9}}], - -Cell[BoxData[ - RowBox[{"TweakExpression", "[", - RowBox[{"{", - RowBox[{"ASymbol", ",", "\"\\"", ",", "3", ",", - RowBox[{"N", "[", "\[Pi]", "]"}], ",", - RowBox[{"a", "+", "b", "+", "c"}]}], "}"}], "]"}]], "Input", - CellChangeTimes->{{3.440177547780761*^9, 3.440177550781266*^9}, { - 3.44017765139118*^9, 3.440177724259131*^9}, {3.440177844791916*^9, - 3.440177845556456*^9}, {3.440178025829589*^9, 3.440178050101166*^9}}], - -Cell[BoxData[ - RowBox[{"AddExtendedComplexes", "[", - RowBox[{ - RowBox[{"1", "+", - RowBox[{"3", "\[ImaginaryI]"}]}], ",", - RowBox[{"2", "+", - RowBox[{"5", "\[ImaginaryI]"}]}]}], "]"}]], "Input", - CellChangeTimes->{{3.440261725819941*^9, 3.44026175272886*^9}, { - 3.440261869617639*^9, 3.440261870522575*^9}, {3.4402623078593616`*^9, - 3.44026232761686*^9}, {3.440264128954616*^9, 3.440264134710162*^9}}], - -Cell[BoxData[ - RowBox[{"AddExtendedComplexes", "[", - RowBox[{"Infinity", ",", - RowBox[{"1", "+", - RowBox[{"3", "\[ImaginaryI]"}]}]}], "]"}]], "Input", - CellChangeTimes->{{3.4402623440640917`*^9, 3.4402623453541613`*^9}, { - 3.440262468823717*^9, 3.440262473845871*^9}, {3.440264138208585*^9, - 3.440264140343564*^9}}], - -Cell[BoxData[ - RowBox[{"AbortTest", "[", "50", "]"}]], "Input", - CellChangeTimes->{{3.4413814839615593`*^9, 3.44138148687442*^9}, { - 3.4413858220378847`*^9, 3.441385824935438*^9}, {3.4413860876215363`*^9, - 3.441386092152405*^9}, {3.441387279931728*^9, 3.4413872801019363`*^9}, { - 3.4414187331544437`*^9, 3.4414187357368517`*^9}}], - -Cell[BoxData[ - RowBox[{"Uninstall", "[", "lnk", "]"}]], "Input", - CellChangeTimes->{{3.439313773653487*^9, 3.439313777607768*^9}}] -}, -WindowSize->{1916, 1165}, -WindowMargins->{{0, Automatic}, {4, Automatic}}, -ShowSelection->True, -FrontEndVersion->"7.0 for Linux x86 (64-bit) (November 11, 2008)", -StyleDefinitions->"Default.nb" -] -(* End of Notebook Content *) - -(* Internal cache information *) -(*CellTagsOutline -CellTagsIndex->{} -*) -(*CellTagsIndex -CellTagsIndex->{} -*) -(*NotebookFileOutline -Notebook[{ -Cell[545, 20, 213, 4, 61, "Input"], -Cell[761, 26, 423, 11, 96, "Text"], -Cell[1187, 39, 315, 5, 61, "Input"], -Cell[1505, 46, 146, 3, 61, "Input"], -Cell[1654, 51, 284, 6, 61, "Input"], -Cell[1941, 59, 300, 8, 61, "Input"], -Cell[2244, 69, 444, 8, 61, "Input"], -Cell[2691, 79, 418, 9, 61, "Input"], -Cell[3112, 90, 327, 7, 61, "Input"], -Cell[3442, 99, 333, 5, 88, "Input"], -Cell[3778, 106, 130, 2, 88, "Input"] -} -] -*) - -(* End of internal cache information *) diff --git a/examples/mltest.sh b/examples/mltest.sh deleted file mode 100644 --- a/examples/mltest.sh +++ /dev/null @@ -1,2 +0,0 @@ -#! /usr/bin/env sh -dist/build/mltest/mltest $@ +RTS -K1G -RTS 2> mltest.err diff --git a/examples/src/Main.hs b/examples/src/Main.hs deleted file mode 100644 --- a/examples/src/Main.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# OPTIONS_GHC -O #-} -{- The -O option is necessary to get the rewrite rules which use more - efficient marshaling for certain structured types to fire. --} - -module Main where - -import Foreign.MathLink -import Foreign.MathLink.Expressible - -import Data.Array.Unboxed -import Data.Complex -import Control.Monad.Error (throwError) -import Control.Monad.Trans (liftIO) -import System.Timeout - --- Example 1: get a pair of integers and return their sum. -addTwo :: (Int,Int) -> IO Int -addTwo (m1,m2) = return (m1+m2) - --- Note that the desired 2-tuple of integers is represented as --- a Mathematica list of length 2. -addTwoFunction = mkFunction -- mprep's :Pattern: directive - "AddTwo[i_Integer,j_Integer]" - -- mprep's :Arguments: directive - "{i,j}" - addTwo - --- Example 2: reverse a list of numbers (coercing them to Doubles). -reverseNumbers :: [Double] -> IO [Double] -reverseNumbers is = return $ reverse is - --- Like tuples, lists are represented on the Mathematica side as --- lists, but, of course, of arbitrary length. Here, the Mathematica --- pattern would match on a list of zero or more numeric values. --- Notice that the argument pattern provides some preprocessing on the --- arguments, taking its real part and coercing the values to --- machine precision. This trick allows for a call pattern that --- matches more expressions, while still ensuring that on the --- Haskell side, the arguments have the desired, more specific, --- form when marshaled. -reverseNumbersFunction = - mkFunction "ReverseNumbers[is___?NumericQ]" - "N[Re[{is}]]" - reverseNumbers - --- Example 3: get and put a 2D array, reversing its contents. --- NB: When marshaling in an array, make sure that you test for the --- array rank in callPattern to match that expected on the Haskell --- side, as below. Otherwise, you're likely to have the underlying --- call to fromDimensions raise an error that halts the program. -reverseArray :: UArray (Int,Int) Int -> IO (UArray (Int,Int) Int) -reverseArray arr = return $ listArray (bounds arr) $ reverse $ elems arr - -reverseArrayFunction = - mkFunction "ReverseArray[a_?(ArrayQ[#,2,IntegerQ]&)]" - "a" - reverseArray - - --- Example 4: gets an arbitrary Mathematica expression and returns --- a tweaked version of it. -tweakExpression :: Expression -> IO Expression -tweakExpression expr = return $ tweak expr - where tweak ex = - case ex of - ExInt i -> ExInt (-i) - ExReal r -> ExReal (-r) - ExString s -> ExString $ reverse s - ExSymbol s -> ExSymbol $ reverse s - ExFunction hd args -> ExFunction (reverse hd) $ map tweak args - -tweakExpressionFunction = - mkFunction"TweakExpression[expr_]" - "expr" - tweakExpression - --- Example 5: use your own instance of Expressible -data ExtendedComplex = Finite (Complex Double) - | Infinity - deriving (Eq,Show) - -instance Expressible ExtendedComplex where - toExpression Infinity = - ExSymbol "Infinity" - toExpression (Finite (r :+ i)) = - ExFunction "Complex" [ExReal r, ExReal i] - fromExpression expr = - case expr of - ExFunction "DirectedInfinity" [_] -> - Right $ Infinity - ExFunction "Complex" [ExReal r, ExReal i] -> - Right $ Finite (r :+ i) - _ -> Left $ ExpressibleErrorMsg $ - "Unexpected expression: " ++ show expr - -addExtendedComplexes :: (ExtendedComplex,ExtendedComplex) -> IO ExtendedComplex -addExtendedComplexes (ec1,ec2) = - case (ec1,ec2) of - (Infinity,_) -> return Infinity - (_,Infinity) -> return Infinity - (Finite c1,Finite c2) -> return $ Finite (c1 + c2) - -addExtendedComplexesFunction = - mkFunction "AddExtendedComplexes[\ - \ec1:(Infinity|Complex[_,_]),\ - \ec2:(Infinity|Complex[_,_])]" - "N[{ec1,ec2}]" - addExtendedComplexes - --- Example 6: check for abort -abortTest :: Int -> IO Bool -abortTest n = do - liftIO $ timeout (100000*n) (bottom) - checkAbort - where bottom = (bottom :: IO ()) - -abortTestFunction = - mkFunction "AbortTest[i_Integer]" - "i" - abortTest - --- run mathlink exposing the given list of actions -main = runMathLink [ addTwoFunction - , reverseNumbersFunction - , reverseArrayFunction - , tweakExpressionFunction - , addExtendedComplexesFunction - , abortTestFunction - ] - diff --git a/mathlink.cabal b/mathlink.cabal --- a/mathlink.cabal +++ b/mathlink.cabal @@ -1,62 +1,91 @@ Name: mathlink -Version: 1.1.0.2 +Version: 2.0.0.3 Cabal-Version: >= 1.6 -Build-Type: Simple +Build-Type: Custom License: BSD3 License-File: LICENSE -Copyright: Copyright (c) Tracy Wadleigh 2008, 2009 +Copyright: Copyright (c) Tracy Wadleigh 2009 Author: Tracy Wadleigh Maintainer: Bug-Reports: mailto:tracy.wadleigh@gmail.com?subject=dev-mathlink Homepage: http://community.haskell.org/~TracyWadleigh/mathlink Stability: experimental -Synopsis: Call Haskell from Mathematica -Tested-With: GHC == 6.10.1 +Synopsis: Write Mathematica packages in Haskell +Tested-With: GHC >= 6.10.1 Category: Foreign -Extra-Source-Files: examples/mltest.cabal - examples/src/Main.hs - examples/Setup.lhs - examples/mltest.nb - examples/mltest.sh +Extra-Source-Files: INSTALL, example/Test.hs Description: { -Provides a simple way to expose Haskell functions to /Mathematica/ via the -/MathLink/ interface. +Makes it easy to write /Mathematica/ packages in Haskell. Just write some +functions and provide a package specification in a simple DSL that +mimics that of /Mathematica/'s @mprep@ utility. . -One defines a Haskell function of type -@('Expressible' e1, 'Expressible' e2) => e1 -> 'IO' e2@ -and provides a pair of 'String's that function analogously to the -@:Pattern:@ and @:Arguments:@ directives for /Mathematica/'s @mprep@ -utility. +Data marshaling is accomplished via the 'MLGet' and 'MLPut' classes, which +specify types that that can be read from or written to the /MathLink/ +connection. Instances of these classes are provided for the obvious +standard data types, including tuples, lists, 'Array's and 'UArray's. . -The library provides instances of the 'Expressible' class for many data -types, including tuples, lists, arrays, and unboxed arrays. +A Haskell function that is to be exposed to /Mathematica/ has the type +signature @('MLGet' a, 'MLPut' b) => a -> IO b@. . -The library does not use or require @foreign export@ declarations, so may -be used interactively. +A simple example of a /Mathematica/ package: +. +@ +import Foreign.MathLink +. +\-- define a function +addTwo :: (Int,Int) -> IO Int +addTwo (x,y) = return $ x+y +. +\-- specify a package +spec :: MLSpec +spec = +\ -- start a package definition +\ [ Eval $ \"BeginPackage\":\@[St \"Test\`\"] +. +\ -- define a usage message for the public symbol +\ , DeclMsg \"AddTwo\" \"usage\" \"AddTwo[..] adds a pair of numbers\" +. +\ -- open a new (private) namespace +\ , Eval $ \"Begin\":\@[St \"\`Private\`\"] +. +\ -- declare the function +\ , DeclFn { +\ callPattern = \"AddTwo[x_Integer,y_Integer]\" +\ , argPattern = \"{x,y}\" +\ , func = addTwo +\ } +. +\ -- close the namespaces +\ , Eval $ \"End\":\@[] +\ , Eval $ \"EndPackage\":\@[] +\ ] +. +\-- runs the /MathLink/ connection +main :: IO () +main = runMathLink spec +@ } -Flag 32Bit - Description: Build and link against the 32-bit version of the - MathLink library, instead of the 64-bt version. - Default: False - Library - Hs-Source-Dirs: src - Build-Depends: base >= 4.0 && < 4.1, + Build-Depends: base >= 4.0 && < 4.2, + mtl >= 1.1 && < 1.2, + haskell98, + array >= 0.2 && < 0.3, containers >= 0.2 && < 0.3, - mtl >= 1.1.0.2 && < 1.2, - array >= 0.2 && < 0.3 - Exposed-Modules: Foreign.MathLink, - Foreign.MathLink.IO, - Foreign.MathLink.Expressible - C-Sources: src/state.c - if arch(i386) || flag(32bit) - Extra-Libraries: ML32i3 - else - Extra-Libraries: ML64i3 - + ix-shapable + + Exposed-Modules: Foreign.MathLink + Foreign.MathLink.Expression + Foreign.MathLink.Internal + Include-Dirs: cbits + Includes: ml.h mathlink.h + C-Sources: cbits/ml.c + + Build-Tools: c2hs + Ghc-Options: -fexcess-precision -funbox-strict-fields -Wall + Source-Repository head Type: darcs Location: http://community.haskell.org/~TracyWadleigh/darcs/mathlink/ diff --git a/src/Foreign/MathLink.hs b/src/Foreign/MathLink.hs deleted file mode 100644 --- a/src/Foreign/MathLink.hs +++ /dev/null @@ -1,308 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses - , FlexibleContexts - , DeriveDataTypeable - #-} - --- | A Haskell interface to /Mathematica/'s /MathLink/. -module Foreign.MathLink ( -- * Installation notes - - -- $installation - - -- * Basic usage - - -- $usage - - -- * Exposing Functions - Function - , mkFunction - - -- * Running /MathLink/ - , runMathLink - , runMathLinkWithArgs - - -- * Accessing /MathLink/ state - , getLink - , checkAbort - , checkDone - - -- * Evaluation - , evaluate - , evaluateAndWait - ) where - -import Data.Int -import Data.IORef -import Data.Typeable -import Data.Array.Unboxed - -import qualified Data.IntMap as IM ( IntMap - , toList - , fromList - , lookup - ) - -import Control.Monad.Reader -import Control.Monad.Error - -import Control.Exception hiding ( evaluate - ) - -import System.IO ( hPutStrLn - , stderr - ) - -import System.Environment ( getArgs - ) - -import Foreign.MathLink.Expressible -import Foreign.MathLink.IO - -data MLError = MLError - | MLErrorMsg String - | MLException SomeException - | MLErrors [MLError] - deriving (Typeable) - -instance Show MLError where - show MLError = "MLError" - show (MLErrorMsg s) = "MLErrorMsg: " ++ s - show (MLException e) = "MLException: " ++ (show e) - show (MLErrors errs) = "MLErrors: " ++ show errs - -instance Error MLError where - noMsg = MLError - strMsg s = MLErrorMsg s - -data MLConfig = MLConfig { functionTable :: IM.IntMap Function - } - --- | Encapsulates a description of a function callable from /Mathematica/ -data Function = - Function { -- | A string representing the /Mathematica/ pattern - -- whose match should result in a function call to - -- the specified Haskell function. Analogous to the - -- @:Pattern:@ directive in an input to - -- /Mathematica/'s @mprep@ utility. - callPattern :: String - -- | A string representing the /Mathematica/ pattern - -- for the argument that will be marshaled from - -- /Mathematica/ to Haskell. Pattern variables - -- appearing here are bound in the 'callPattern' - -- match. Analogous to the @:Arguments:@ directive - -- in an input to /Mathematica/'s @mprep@ utility. - , argumentPattern :: String - -- | The Haskell function to be invoked. - , function :: IO () - } - -mkFunction :: ( Expressible e1 - , Expressible e2 - ) => String -> String -> (e1 -> IO e2) -> Function -mkFunction cp ap fn = Function { callPattern = cp - , argumentPattern = ap - , function = get >>= fn >>= put - } - -instance Show Function where - show fn = "Function { callPattern = " ++ - (show $ callPattern fn) ++ - ", argumentPattern = " ++ - (show $ argumentPattern fn) ++ " }" - -type ML a = ErrorT MLError (ReaderT MLConfig IO) a - -getConfig :: ML MLConfig -getConfig = ask - --- | Runs /MathLink/, exposing the given list of functions. -runMathLink :: [Function] -> IO () -runMathLink functions = do - args <- getArgs - runMathLinkWithArgs args functions - --- | Like 'runMathLink', but explicitly requires the command line --- arguments to be passed to /MathLink/. -runMathLinkWithArgs :: [String] - -> [Function] -> IO () -runMathLinkWithArgs args functions = do - initializeMathLink $ unwords args - er <- (runReaderT (runErrorT runLoop) config) - finalizeMathLink - case er of - Left err -> do hPutStrLn stderr $ show err - return () - Right () -> return () - where config = MLConfig { functionTable = - IM.fromList $ zip [0..] functions - } - -runLoop :: ML () -runLoop = do - installFunctionTable - processPackets - -processPackets :: ML () -processPackets = do - pkt <- answer - case pkt of - ResumePacketCode -> do - liftIO $ refuseToBeAFrontEnd - processPackets - _ -> return () - -answer :: ML PacketCode -answer = do - dn <- liftIO $ checkDone - if dn then do - liftIO clearAbort - return $ mkPacketCode 0 - else do - pkt <- liftIO $ getPacket - case pkt of - CallPacketCode -> do - liftIO clearAbort - processCallPacket - liftIO endPacket - liftIO newPacket - answer - _ -> do - liftIO clearAbort - return pkt - -printString :: String -> IO () -printString str = do - evaluate $ ExFunction "Print" [ ExString str ] - return () - -processCallPacket :: ML () -processCallPacket = do - expr <- liftIO get - case expr of - ExInt n -> do - config <- getConfig - case n `IM.lookup` (functionTable config) of - Just fn -> liftIO $ handle cleanUp (function fn) - _ -> throwError $ MLErrorMsg "Function lookup failed." - _ -> throwError $ MLErrorMsg "Expected int." - where - cleanUp err = do - clearError - printString $ "Error occurred in processing call: " ++ show (err :: SomeException) - put $ ExSymbol "$Failed" - -refuseToBeAFrontEnd :: IO () -refuseToBeAFrontEnd = do - putFunction "EvaluatePacket" 1 - putFunction "Module" 2 - putFunction "List" 1 - putFunction "Set" 2 - put meSym - put plSym - putFunction "CompoundExpression" 3 - putFunction "Set" 2 - put plSym - getLink >>= (liftIO . (\l -> transferExpression l l)) - putFunction "Message" 2 - putFunction "MessageName" 2 - put plSym - put $ ExString "notfe" - put meSym - put meSym - endPacket - waitForPacket (== SuspendPacketCode) - where meSym = ExSymbol "me" - plSym = ExSymbol "$ParentLink" - -installFunctionTable :: ML () -installFunctionTable = do - liftIO activate - functionPairs <- getConfig >>= (return . IM.toList . functionTable) - mapM_ (liftIO . definePattern) functionPairs - liftIO $ put $ ExSymbol "End" - liftIO flush >>= maybeThrow - -definePattern :: (Int,Function) -> IO () -definePattern (ident,func) = - put $ ExFunction "DefineExternal" [ ExString $ callPattern func - , ExString $ argumentPattern func - , ExInt ident - ] - --- | Sends the given 'String' to /Mathematica/ for evaluation. --- --- Does not block -evaluate :: Expression -> IO Bool -evaluate expr = do - abrt <- checkAbort - if abrt then return False else do - put $ ExFunction "EvaluatePacket" [expr] - endPacket - return True - --- | Like 'evaluate', but blocks until the execution is complete. -evaluateAndWait :: Expression -> IO Bool -evaluateAndWait expr = handle - ((const $ return False) :: SomeException -> IO Bool) $ - do abrt <- checkAbort - if abrt then return False else do - result <- evaluate expr - if result then - waitForPacket (== ReturnPacketCode) - else - return () - return True - -waitForPacket :: (PacketCode -> Bool) -> IO () -waitForPacket q = do - pkt <- getPacket - newPacket - if q pkt then return () else waitForPacket q - --- lifting utilities - -maybeThrow :: Maybe MathLinkError -> ML () -maybeThrow (Just err) = throwError $ MLException $ toException err -maybeThrow Nothing = return () - -valueOrThrow :: Either MathLinkError b -> ML b -valueOrThrow (Left err) = throwError $ MLException $ toException err -valueOrThrow (Right v) = return v - --- extra documentation - -{- $installation - - The cabal file isn't very sophisticated, so you need to help it out a -little. For instance: - - - The @mathlink.h@ header needs to be accessible by default. - - - If yours is a 32-bit system, you may need to explicitly set the 32Bit - flag. - - -} - -{- $usage -The following is a small Haskell module that exposes a function -callable from /Mathematica/ that gets a pair of 'Int's (as a tuple) and -returns their sum to /Mathematica/: - -@ -module Main where - -import 'Foreign.MathLink' - -addTwo :: ('Int','Int') -> 'IO' 'Int' -addTwo (i1,i2) = return (i1+i2) - -main = 'runMathLink' [ 'mkFunction' \"AddTwo[i_Integer,j_Integer]\" - \"{i,j}\" - addTwo - ] -@ - -The types that can be marshaled to\/from /Mathematica/ are instances of the -'Expressible' class. - -See the @examples@ directory of the source distribution for more. --} diff --git a/src/Foreign/MathLink/Expressible.hs b/src/Foreign/MathLink/Expressible.hs deleted file mode 100644 --- a/src/Foreign/MathLink/Expressible.hs +++ /dev/null @@ -1,955 +0,0 @@ -{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , OverlappingInstances - , DeriveDataTypeable #-} - -module Foreign.MathLink.Expressible ( Expression(..) - , Expressible(..) - , Dimensional(..) - , ExpressibleError(..) - , integralToExpression - , expressionToIntegral - , realFracToExpression - , expressionToRealFrac - , fromDimensions - , arrayToExpression - , expressionToArray - , arrayToPair - , pairToArray - ) where - -import Data.Int -import Data.Word -import Data.Ratio -import Data.Complex -import Data.Ix -import Data.Array.IArray -import qualified Data.Array as A -import qualified Data.Array.Unboxed as U -import Data.Typeable -import Control.Exception - -import Control.Monad ( replicateM - ) - -import Data.List ( tails - ) - -import Foreign.MathLink.IO - - --- | Represents a general /Mathematica/ expression. -data Expression = -- | An atomic value of integer type - ExInt Int - -- | An atomic value of floating point type - | ExReal Double - -- | An atomic value of string type - | ExString String - -- | An atomic value of symbol type - | ExSymbol String - -- | A non-atomic value, with a head of type symbol - -- and a list of arguments - | ExFunction String [Expression] - deriving (Eq,Ord,Read,Show) - --- | Instances of 'Expressible' are precisely the data types that can --- be marshaled to and from /Mathematica/. --- --- Minimal complete definition: 'toExpression' and 'fromExpression'. -class Expressible a where - -- | Convert a value to an 'Expression' - toExpression :: a -> Expression - -- | Convert an expression to a value. - fromExpression :: Expression -> Either ExpressibleError a - -- | Send a value to /Mathematica/. - put :: a -> IO () - put v = put $ toExpression v - -- | Receive a value from /Mathematica/. - get :: IO a - get = do - expr <- get - case fromExpression expr of - Left err -> throwIO err - Right v -> return v - -maybeThrow :: Maybe MathLinkError -> IO () -maybeThrow (Just err) = throwIO err -maybeThrow Nothing = return () - -valueOrThrow :: Either MathLinkError b -> IO b -valueOrThrow (Left err) = throwIO err -valueOrThrow (Right v) = return v - -instance Expressible Expression where - toExpression = id - fromExpression = Right - put expr = - case expr of - ExInt i -> putInt i >>= maybeThrow - ExReal r -> putDouble r >>= maybeThrow - ExString s -> putString s >>= maybeThrow - ExSymbol s -> putSymbol s >>= maybeThrow - ExFunction hd args -> do - putFunction hd (length args) >>= maybeThrow - mapM_ put args - get = do - typ <- getType - case typ of - ErrorTypeCode -> - getError >>= throwIO - IntTypeCode -> - getInt >>= valueOrThrow >>= (return . ExInt) - RealTypeCode -> - getDouble >>= valueOrThrow >>= (return . ExReal) - StringTypeCode -> - getString >>= valueOrThrow >>= (return . ExString) - SymbolTypeCode -> - getSymbol >>= valueOrThrow >>= (return . ExSymbol) - FunctionTypeCode -> do - (hd,nArgs) <- getFunction >>= valueOrThrow - args <- replicateM nArgs get - return $ ExFunction hd args - - --- bool instance - -instance Expressible Bool where - toExpression True = ExSymbol "True" - toExpression False = ExSymbol "False" - fromExpression expr = - case expr of - ExSymbol "True" -> Right True - ExSymbol "False" -> Right False - _ -> marshalErr "Bool" expr - put True = putSymbol "True" >>= maybeThrow - put False = putSymbol "False" >>= maybeThrow - -instance Expressible Char where - toExpression c = ExString [c] - fromExpression expr = - case expr of - ExString [c] -> Right c - _ -> marshalErr "Char" expr - -integralToExpression :: Integral i => i -> Expression -integralToExpression = ExInt . fromIntegral - -expressionToIntegral :: Integral i - => Expression - -> Either ExpressibleError i -expressionToIntegral expr = - case expr of - ExInt i -> Right $ fromIntegral i - ExReal r -> Right $ truncate r - _ -> marshalErr "Integral" expr - -putWith :: (a -> IO (Maybe MathLinkError)) -> a -> IO () -putWith f v = f v >>= maybeThrow - -getWith :: IO (Either MathLinkError a) -> IO a -getWith f = f >>= valueOrThrow - -instance Expressible Int where - toExpression = integralToExpression - fromExpression = expressionToIntegral - put = putWith putInt - get = getWith getInt - -instance Expressible Int8 where - toExpression = integralToExpression - fromExpression = expressionToIntegral - put = putWith putInt16 - get = getWith getInt16 - -instance Expressible Int16 where - toExpression = integralToExpression - fromExpression = expressionToIntegral - put = putWith putInt16 - get = getWith getInt16 - -instance Expressible Int32 where - toExpression = integralToExpression - fromExpression = expressionToIntegral - put = putWith putInt32 - get = getWith getInt32 - -instance Expressible Int64 where - toExpression = integralToExpression - fromExpression = expressionToIntegral - put = putWith putInt - get = getWith getInt - -instance Expressible Integer where - toExpression = integralToExpression - fromExpression = expressionToIntegral - put = putWith putInt - get = getWith getInt - -instance Expressible Word8 where - toExpression = integralToExpression - fromExpression = expressionToIntegral - put = putWith putInt16 - get = getWith getInt16 - -realFracToExpression :: RealFrac r => r -> Expression -realFracToExpression = ExReal . realToFrac - -expressionToRealFrac :: RealFrac r - => Expression - -> Either ExpressibleError r -expressionToRealFrac expr = - case expr of - ExInt i -> Right $ realToFrac i - ExReal r -> Right $ realToFrac r - _ -> marshalErr "RealFrac" expr - -instance Expressible Float where - toExpression = realFracToExpression - fromExpression = expressionToRealFrac - put = putWith putFloat - get = getWith getFloat - -instance Expressible Double where - toExpression = realFracToExpression - fromExpression = expressionToRealFrac - put = putWith putDouble - get = getWith getDouble - -instance (Expressible i, Integral i) => Expressible (Ratio i) where - toExpression r = ExFunction "Rational" [ toExpression $ numerator r - , toExpression $ denominator r - ] - fromExpression expr = - case expr of - ExInt i -> Right $ fromIntegral i - ExReal r -> Right $ realToFrac r - ExFunction "Rational" [n,d] -> - case (fromExpression n, fromExpression d) of - (Right n', Right d') -> Right $ n' % d' - (e1,e2) -> Left $ ExpressibleErrors [ e | - Just e <- [ getErr e1 - , getErr e2 - ] ] - put r = do - putFunction "Rational" 2 >>= maybeThrow - put (numerator r) >> put (denominator r) - -instance (RealFloat a, Expressible a) => Expressible (Complex a) where - toExpression (r :+ i) = ExFunction "Complex" $ map toExpression [r,i] - fromExpression expr = - case expr of - ExInt i -> Right $ fromIntegral i - ExReal r -> Right $ realToFrac r - ExFunction "Complex" [r,i] -> - case (fromExpression r,fromExpression i) of - (Right r',Right i') -> Right $ r' :+ i' - (e1,e2) -> Left $ ExpressibleErrors [ e | - Just e <- [ getErr e1 - , getErr e2 - ] ] - _ -> marshalErr "Complex" expr - put (r :+ i) = do - putFunction "Complex" 2 >>= maybeThrow - put r >> put i - -instance Expressible e => Expressible (Maybe e) where - toExpression (Just e) = ExFunction "Just" [toExpression e] - toExpression Nothing = ExSymbol "Nothing" - fromExpression expr = - case expr of - ExSymbol "Nothing" -> Right Nothing - ExFunction "Just" [e] -> - case fromExpression e of - Left err -> Left err - Right e -> Right $ Just $ e - _ -> marshalErr "Maybe" expr - put (Just e) = do - putFunction "Just" 1 >>= maybeThrow - put e - put Nothing = putSymbol "Nothing" >>= maybeThrow - - -instance ( Expressible e1 - , Expressible e2) - => Expressible (Either e1 e2) where - toExpression (Left l) = ExFunction "Left" [toExpression l] - toExpression (Right r) = ExFunction "Right" [toExpression r] - fromExpression expr = - case expr of - ExFunction "Left" [e] -> - case fromExpression e of - Left err -> Left err - Right l -> Right $ Left $ l - ExFunction "Right" [e] -> - case fromExpression e of - Left err -> Left err - Right r -> Right $ Right $ r - _ -> marshalErr "Either" expr - put (Left v) = do - putFunction "Left" 1 >>= maybeThrow - put v - put (Right v) = do - putFunction "Right" 1 >>= maybeThrow - put v - --- tuple instances - -throwErrs :: [Maybe ExpressibleError] -> IO () -throwErrs mErrs = throwIO $ collectErrs mErrs - -throwErr :: (Show a, Show b) => a -> b -> IO c -throwErr expected got = - case marshalErr expected got of - Left err -> throwIO err - Right x -> return x - -instance ( Expressible e1 - , Expressible e2 - ) => Expressible (e1,e2) where - toExpression (ex1,ex2) = - ExFunction "List" $ [ toExpression ex1 - , toExpression ex2 - ] - fromExpression expr = - case expr of - ExFunction _ [ex1,ex2] -> - case ( fromExpression ex1 - , fromExpression ex2 - ) of - (Right ex1',Right ex2') -> Right (ex1',ex2') - (e1,e2) -> - Left $ collectErrs [ getErr e1 - , getErr e2 - ] - _ -> marshalErr "(,)" expr - put (v1,v2) = do - putFunction "List" 2 >>= maybeThrow - put v1 >> put v2 - get = do - (hd,n) <- getFunction >>= valueOrThrow - case (hd,n) of - ("List",2) -> do v1 <- get - v2 <- get - return (v1,v2) - pr -> throwErr ("List",2) pr - -instance ( Expressible e1 - , Expressible e2 - , Expressible e3 - ) => Expressible (e1,e2,e3) where - toExpression (ex1,ex2,ex3) = - ExFunction "List" $ [ toExpression ex1 - , toExpression ex2 - , toExpression ex3 - ] - fromExpression expr = - case expr of - ExFunction _ [ex1,ex2,ex3] -> - case ( fromExpression ex1 - , fromExpression ex2 - , fromExpression ex3 - ) of - (Right ex1',Right ex2',Right ex3') -> - Right (ex1',ex2',ex3') - (e1,e2,e3) -> - Left $ collectErrs [ getErr e1 - , getErr e2 - , getErr e3 - ] - _ -> marshalErr "(,,)" expr - put (v1,v2,v3) = do - putFunction "List" 3 >>= maybeThrow - put v1 >> put v2 >> put v3 - get = do - (hd,n) <- getFunction >>= valueOrThrow - case (hd,n) of - ("List",3) -> do v1 <- get - v2 <- get - v3 <- get - return (v1,v2,v3) - pr -> throwErr ("List",3) pr - -instance ( Expressible e1 - , Expressible e2 - , Expressible e3 - , Expressible e4 - ) => Expressible (e1,e2,e3,e4) where - toExpression (ex1,ex2,ex3,ex4) = - ExFunction "List" $ [ toExpression ex1 - , toExpression ex2 - , toExpression ex3 - , toExpression ex4 - ] - fromExpression expr = - case expr of - ExFunction _ [ex1,ex2,ex3,ex4] -> - case ( fromExpression ex1 - , fromExpression ex2 - , fromExpression ex3 - , fromExpression ex4 - ) of - (Right ex1',Right ex2',Right ex3',Right ex4') -> - Right (ex1',ex2',ex3',ex4') - (e1,e2,e3,e4) -> - Left $ collectErrs [ getErr e1 - , getErr e2 - , getErr e3 - , getErr e4 - ] - _ -> marshalErr "(,,,)" expr - put (v1,v2,v3,v4) = do - putFunction "List" 4 >>= maybeThrow - put v1 >> put v2 >> put v3 >> put v4 - get = do - (hd,n) <- getFunction >>= valueOrThrow - case (hd,n) of - ("List",4) -> do v1 <- get - v2 <- get - v3 <- get - v4 <- get - return (v1,v2,v3,v4) - pr -> throwErr ("List",4) pr - -instance ( Expressible e1 - , Expressible e2 - , Expressible e3 - , Expressible e4 - , Expressible e5 - ) => Expressible (e1,e2,e3,e4,e5) where - toExpression (ex1,ex2,ex3,ex4,ex5) = - ExFunction "List" $ [ toExpression ex1 - , toExpression ex2 - , toExpression ex3 - , toExpression ex4 - , toExpression ex5 - ] - fromExpression expr = - case expr of - ExFunction _ [ex1,ex2,ex3,ex4,ex5] -> - case ( fromExpression ex1 - , fromExpression ex2 - , fromExpression ex3 - , fromExpression ex4 - , fromExpression ex5 - ) of - (Right ex1',Right ex2',Right ex3',Right ex4',Right ex5') -> - Right (ex1',ex2',ex3',ex4',ex5') - (e1,e2,e3,e4,e5) -> - Left $ collectErrs [ getErr e1 - , getErr e2 - , getErr e3 - , getErr e4 - , getErr e5 - ] - _ -> marshalErr "(,,,,)" expr - put (v1,v2,v3,v4,v5) = do - putFunction "List" 5 >>= maybeThrow - put v1 >> put v2 >> put v3 >> put v4 >> put v5 - get = do - (hd,n) <- getFunction >>= valueOrThrow - case (hd,n) of - ("List",5) -> do v1 <- get - v2 <- get - v3 <- get - v4 <- get - v5 <- get - return (v1,v2,v3,v4,v5) - pr -> throwErr ("List",5) pr - --- list instance(s) - -listToExpression :: Expressible e => [e] -> Expression -listToExpression es = ExFunction "List" $ map toExpression es - -expressionToList :: - Expressible e => Expression -> Either ExpressibleError [e] -expressionToList expr = - let mList = case expr of - ExFunction _ args -> map fromExpression args - _ -> [marshalErr "List" expr] - vs = [ v | Right v <- mList ] - errs = [ err | Left err <- mList ] - in if null errs then - Right vs - else - Left $ ExpressibleErrors errs - -putListWith :: ([e] -> IO (Maybe MathLinkError)) -> [e] -> IO () -putListWith fn es = fn es >>= maybeThrow - -getListWith :: IO (Either MathLinkError [e]) -> IO [e] -getListWith fn = fn >>= valueOrThrow - -instance Expressible e => Expressible [e] where - toExpression = listToExpression - fromExpression = expressionToList - put xs = do - putFunction "List" (length xs) - mapM_ put xs - get = do - (hd,n) <- getFunction >>= valueOrThrow - case hd of - "List" -> replicateM n get - _ -> throwErr "List" hd - -instance Expressible [Char] where - toExpression str = ExString str - fromExpression expr = - case expr of - ExString s -> Right s - _ -> marshalErr "String" expr - put str = putString str >>= maybeThrow - get = getString >>= valueOrThrow - -instance Expressible [Int8] where - toExpression = listToExpression - fromExpression = expressionToList - put = putListWith putInt16List - get = getListWith getInt16List - -instance Expressible [Int16] where - toExpression = listToExpression - fromExpression = expressionToList - put = putListWith putInt16List - get = getListWith getInt16List - -instance Expressible [Int32] where - toExpression = listToExpression - fromExpression = expressionToList - put = putListWith putInt32List - get = getListWith getInt32List - -instance Expressible [Int64] where - toExpression = listToExpression - fromExpression = expressionToList - put = putListWith putIntList - get = getListWith getIntList - -instance Expressible [Int] where - toExpression = listToExpression - fromExpression = expressionToList - put = putListWith putIntList - get = getListWith getIntList - -instance Expressible [Float] where - toExpression = listToExpression - fromExpression = expressionToList - put = putListWith putFloatList - get = getListWith getFloatList - -instance Expressible [Double] where - toExpression = listToExpression - fromExpression = expressionToList - put = putListWith putDoubleList - get = getListWith getDoubleList - -instance Expressible [Word8] where - toExpression = listToExpression - fromExpression = expressionToList - put = putListWith putInt16List - get = getListWith getInt16List - - --- array marshaling - -exprDimensions :: Expression -> [Int] -exprDimensions expr = - case expr of - ExFunction "List" (arg:args) -> - if all (==ad) ads then - nArgs:ad - else - [nArgs] - where ad = exprDimensions arg - ads = map exprDimensions args - nArgs = 1 + (length args) - _ -> [] - -exprToList :: Expression -> [Expression] -exprToList (ExFunction "List" args) = args -exprToList v = [v] - -flattenExprList :: [Expression] -> [Expression] -flattenExprList exprs = concat $ map exprToList exprs - -expressionToPair :: Expressible e - => Expression - -> Either ExpressibleError ([Int],[e]) -expressionToPair expr = - if null errs then - Right (dims,es) - else - Left $ ExpressibleErrors errs - where dims = exprDimensions expr - rnk = length dims - flattener = foldr1 (.) $ take rnk $ repeat flattenExprList - exs = flattener [expr] - ees = map fromExpression exs - errs = [ err | Left err <- ees ] - es = [ e | Right e <- ees ] - -pairToArray :: ( Dimensional ix - , IArray a e - ) => [Int] -> [e] -> Either ExpressibleError (a ix e) -pairToArray dims xs = - case fromDimensions dims of - Left err -> Left err - Right bnds -> Right $ listArray bnds xs - -expressionToArray :: ( Expressible e - , Dimensional ix - , IArray a e - ) => Expression -> Either ExpressibleError (a ix e) -expressionToArray expr = - case expressionToPair expr of - Left err -> Left err - Right (dims,xs) -> pairToArray dims xs - -partitionExprList :: Int -> Int -> [Expression] -> [[Expression]] -partitionExprList num sz exprs = partList num [] exprs - where partList 0 lsts _ = lsts - partList n lsts exprs = let (lst,rest) = splitAt sz exprs - in partList (n-1) (lst:lsts) rest - -pairToExpression :: Expressible e => ([Int],[e]) -> Expression -pairToExpression (dims,es) = mkList $ partExpr dims szs exs - where exs = map toExpression es - szs = map product $ tail $ tails dims - mkList exprs = ExFunction "List" exprs - partExpr [] _ exprs = exprs - partExpr _ [] exprs = exprs - partExpr (n:ns) (sz:szs) exprs = - let exprLsts = partitionExprList n sz exprs - in map (mkList . (partExpr ns szs)) exprLsts - -arrayToPair :: ( Dimensional ix - , IArray a e - ) => a ix e -> ([Int],[e]) -arrayToPair ar = (dimensions $ bounds ar, elems ar) - -arrayToExpression :: ( Expressible e - , Dimensional ix - , IArray a e - ) => a ix e -> Expression -arrayToExpression = pairToExpression . arrayToPair - -putArrayWith :: ( IArray a e - , Dimensional ix - ) => ([Int] -> [e] -> IO (Maybe MathLinkError)) - -> (a ix e) -> IO () -putArrayWith fn arr = let (dims,xs) = arrayToPair arr - in fn dims xs >>= maybeThrow - -getArrayWith :: ( IArray a e - , Dimensional ix - ) => IO (Either MathLinkError ([Int],[e])) -> IO (a ix e) -getArrayWith fn = do - (dims,xs) <- fn >>= valueOrThrow - case pairToArray dims xs of - Left err -> throwIO err - Right v -> return v - -instance ( Dimensional ix - ) => Expressible (U.UArray ix Int8) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putInt16Array - get = getArrayWith getInt16Array - -instance ( Dimensional ix - ) => Expressible (U.UArray ix Int16) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putInt16Array - get = getArrayWith getInt16Array - -instance ( Dimensional ix - ) => Expressible (U.UArray ix Int32) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putInt32Array - get = getArrayWith getInt32Array - -instance ( Dimensional ix - ) => Expressible (U.UArray ix Int64) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putIntArray - get = getArrayWith getIntArray - -instance ( Dimensional ix - ) => Expressible (U.UArray ix Int) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putIntArray - get = getArrayWith getIntArray - -instance ( Dimensional ix - ) => Expressible (U.UArray ix Float) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putFloatArray - get = getArrayWith getFloatArray - -instance ( Dimensional ix - ) => Expressible (U.UArray ix Double) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putDoubleArray - get = getArrayWith getDoubleArray - -instance ( Dimensional ix - ) => Expressible (U.UArray ix Word8) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putInt16Array - get = getArrayWith getInt16Array - -instance ( Dimensional ix - ) => Expressible (A.Array ix Int8) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putInt16Array - get = getArrayWith getInt16Array - -instance ( Dimensional ix - ) => Expressible (A.Array ix Int16) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putInt16Array - get = getArrayWith getInt16Array - -instance ( Dimensional ix - ) => Expressible (A.Array ix Int32) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putInt32Array - get = getArrayWith getInt32Array - -instance ( Dimensional ix - ) => Expressible (A.Array ix Int64) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putIntArray - get = getArrayWith getIntArray - -instance ( Dimensional ix - ) => Expressible (A.Array ix Int) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putIntArray - get = getArrayWith getIntArray - -instance ( Dimensional ix - ) => Expressible (A.Array ix Float) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putFloatArray - get = getArrayWith getFloatArray - -instance ( Dimensional ix - ) => Expressible (A.Array ix Double) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putDoubleArray - get = getArrayWith getDoubleArray - -instance ( Dimensional ix - ) => Expressible (A.Array ix Word8) where - toExpression = arrayToExpression - fromExpression = expressionToArray - put = putArrayWith putInt16Array - get = getArrayWith getInt16Array - --- | Arrays to be marshaled to and from /Mathematica/ require indices --- that are instances of 'Dimensional'. -class Ix ix => Dimensional ix where - -- | The rank. Shouldn't examine its argument. - rank :: ix -> Int - -- | The dimensions. - dimensions :: (ix,ix) -> [Int] - -- | Default lower bound. Shouldn't examine its argument. - lowerBound :: ix -> ix - -- | The array upper bound implied by the list of dimensions and the - -- given lower bound. - -- - -- Should fail if the length of the list is not equal to the - -- rank. - upperBound :: ix -> [Int] -> Either ExpressibleError ix - --- | The bounds implied by the dimesions, using the default lower bound. -fromDimensions :: Dimensional ix => [Int] -> Either ExpressibleError (ix,ix) -fromDimensions dims = - case eU of - Left err -> Left err - Right u -> Right (l,u) - where l = lowerBound undefined - eU = upperBound l dims - -dimensionalErr :: Dimensional ix - => ix - -> [Int] - -> Either ExpressibleError a -dimensionalErr i dims = Left $ ExpressibleErrorMsg $ "Expected " ++ - (show $ rank i) ++ " dimensions, but got " ++ (show $ length dims) ++ "." - -instance Dimensional Int where - rank _ = 1 - dimensions bnds = [rangeSize bnds] - lowerBound _ = 0 - upperBound l [n] = Right (n+l-1) - upperBound l ns = dimensionalErr l ns - -instance ( Dimensional i1 - , Dimensional i2 - ) => Dimensional (i1,i2) where - rank (a1,a2) = rank a1 + rank a2 - dimensions ((l1,l2),(u1,u2)) = - dimensions (l1,u1) ++ - dimensions (l2,u2) - lowerBound _ = - ( lowerBound undefined - , lowerBound undefined - ) - upperBound (l1,l2) ns = - case (u1',u2') of - (Right u1,Right u2) -> - Right (u1,u2) - (e1,e2) -> - Left $ collectErrs [ getErr e1 - , getErr e2 - ] - where (ns1,rest1) = splitAt (rank l1) ns - ns2 = rest1 - u1' = upperBound l1 ns1 - u2' = upperBound l2 ns2 - -instance ( Dimensional i1 - , Dimensional i2 - , Dimensional i3 - ) => Dimensional (i1,i2,i3) where - rank (a1,a2,a3) = rank a1 + rank a2 + rank a3 - dimensions ((l1,l2,l3),(u1,u2,u3)) = - dimensions (l1,u1) ++ - dimensions (l2,u2) ++ - dimensions (l3,u3) - lowerBound _ = - ( lowerBound undefined - , lowerBound undefined - , lowerBound undefined - ) - upperBound (l1,l2,l3) ns = - case (u1',u2',u3') of - (Right u1,Right u2,Right u3) -> - Right (u1,u2,u3) - (e1,e2,e3) -> - Left $ collectErrs [ getErr e1 - , getErr e2 - , getErr e3 - ] - where (ns1,rest1) = splitAt (rank l1) ns - (ns2,rest2) = splitAt (rank l2) rest1 - ns3 = rest2 - u1' = upperBound l1 ns1 - u2' = upperBound l2 ns2 - u3' = upperBound l3 ns3 - -instance ( Dimensional i1 - , Dimensional i2 - , Dimensional i3 - , Dimensional i4 - ) => Dimensional (i1,i2,i3,i4) where - rank (a1,a2,a3,a4) = rank a1 + rank a2 + rank a3 + rank a4 - dimensions ((l1,l2,l3,l4),(u1,u2,u3,u4)) = - dimensions (l1,u1) ++ - dimensions (l2,u2) ++ - dimensions (l3,u3) ++ - dimensions (l4,u4) - lowerBound _ = - ( lowerBound undefined - , lowerBound undefined - , lowerBound undefined - , lowerBound undefined - ) - upperBound (l1,l2,l3,l4) ns = - case (u1',u2',u3',u4') of - (Right u1,Right u2,Right u3,Right u4) -> - Right (u1,u2,u3,u4) - (e1,e2,e3,e4) -> - Left $ collectErrs [ getErr e1 - , getErr e2 - , getErr e3 - , getErr e4 - ] - where (ns1,rest1) = splitAt (rank l1) ns - (ns2,rest2) = splitAt (rank l2) rest1 - (ns3,rest3) = splitAt (rank l3) rest2 - ns4 = rest3 - u1' = upperBound l1 ns1 - u2' = upperBound l2 ns2 - u3' = upperBound l3 ns3 - u4' = upperBound l4 ns4 - -instance ( Dimensional i1 - , Dimensional i2 - , Dimensional i3 - , Dimensional i4 - , Dimensional i5 - ) => Dimensional (i1,i2,i3,i4,i5) where - rank (a1,a2,a3,a4,a5) = rank a1 + rank a2 + rank a3 + rank a4 + rank a5 - dimensions ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = - dimensions (l1,u1) ++ - dimensions (l2,u2) ++ - dimensions (l3,u3) ++ - dimensions (l4,u4) ++ - dimensions (l5,u5) - lowerBound _ = - ( lowerBound undefined - , lowerBound undefined - , lowerBound undefined - , lowerBound undefined - , lowerBound undefined - ) - upperBound (l1,l2,l3,l4,l5) ns = - case (u1',u2',u3',u4',u5') of - (Right u1,Right u2,Right u3,Right u4,Right u5) -> - Right (u1,u2,u3,u4,u5) - (e1,e2,e3,e4,e5) -> - Left $ collectErrs [ getErr e1 - , getErr e2 - , getErr e3 - , getErr e4 - , getErr e5 - ] - where (ns1,rest1) = splitAt (rank l1) ns - (ns2,rest2) = splitAt (rank l2) rest1 - (ns3,rest3) = splitAt (rank l3) rest2 - (ns4,rest4) = splitAt (rank l4) rest3 - ns5 = rest4 - u1' = upperBound l1 ns1 - u2' = upperBound l2 ns2 - u3' = upperBound l3 ns3 - u4' = upperBound l4 ns4 - u5' = upperBound l5 ns5 - -getErr :: Either a b -> Maybe a -getErr (Left a) = Just a -getErr _ = Nothing - -collectErrs :: [Maybe ExpressibleError] -> ExpressibleError -collectErrs mErrs = ExpressibleErrors [ e | Just e <- mErrs ] - -data ExpressibleError = ExpressibleError - | ExpressibleErrorMsg String - | ExpressibleErrors [ExpressibleError] - deriving (Eq,Show,Typeable) - -instance Exception ExpressibleError where - toException = SomeException - fromException (SomeException e) = cast e - -marshalErr :: (Show a, Show b) => a -> b -> Either ExpressibleError c -marshalErr expect expr = - Left $ ExpressibleErrorMsg $ - "Expected " ++ (show expect) ++ " but got: " ++ (show expr) - diff --git a/src/Foreign/MathLink/IO.hs b/src/Foreign/MathLink/IO.hs deleted file mode 100644 --- a/src/Foreign/MathLink/IO.hs +++ /dev/null @@ -1,1082 +0,0 @@ -{-# 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) diff --git a/src/state.c b/src/state.c deleted file mode 100644 --- a/src/state.c +++ /dev/null @@ -1,48 +0,0 @@ -#include - -int MLAbort = 0; -int MLDone = 0; -MLINK stdlink = 0; -MLEnvironment stdenv = 0; - -MLYieldFunctionObject stdyielder = (MLYieldFunctionObject)0; -MLMessageHandlerObject stdhandler = (MLMessageHandlerObject)0; - -void MLDefaultHandler(MLINK mlp, int message, int n) -{ - switch(message) - { - case MLTerminateMessage: - MLDone = 1; - case MLInterruptMessage: - case MLAbortMessage: - MLAbort = 1; - default: - return; - } -} - -int MLInitializeMathLink(char * commandLine) -{ - int err; - if(!stdenv) stdenv = MLInitialize((MLParametersPointer)0); - if(stdenv == (MLEnvironment)0) return 0; - if(!stdhandler) stdhandler = (MLMessageHandlerObject)MLDefaultHandler; - stdlink = MLOpenString(stdenv, commandLine, &err); - if(stdlink == (MLINK)0) - { - MLDeinitialize(stdenv); - stdenv = (MLEnvironment)0; - return 0; - } - if(stdyielder) MLSetYieldFunction(stdlink, stdyielder); - if(stdhandler) MLSetMessageHandler(stdlink, stdhandler); - return 1; -} - -void MLFinalizeMathLink() -{ - MLClose(stdlink); - MLDeinitialize(stdenv); -} -