mathlink 1.1.0.2 → 2.0.0.3
raw patch · 17 files changed
+2081/−2737 lines, 17 filesdep +haskell98dep +ix-shapabledep ~basedep ~mtlbuild-type:Customsetup-changed
Dependencies added: haskell98, ix-shapable
Dependency ranges changed: base, mtl
Files
- Foreign/MathLink.hs +247/−0
- Foreign/MathLink/Expression.hs +570/−0
- Foreign/MathLink/Internal.chs +1041/−0
- INSTALL +11/−0
- Setup.lhs +47/−2
- cbits/ml.c +49/−0
- example/Test.hs +48/−0
- examples/Setup.lhs +0/−7
- examples/mltest.cabal +0/−20
- examples/mltest.nb +0/−143
- examples/mltest.sh +0/−2
- examples/src/Main.hs +0/−131
- mathlink.cabal +68/−39
- src/Foreign/MathLink.hs +0/−308
- src/Foreign/MathLink/Expressible.hs +0/−955
- src/Foreign/MathLink/IO.hs +0/−1082
- src/state.c +0/−48
+ Foreign/MathLink.hs view
@@ -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.+-}
+ Foreign/MathLink/Expression.hs view
@@ -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
+ Foreign/MathLink/Internal.chs view
@@ -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
+ INSTALL view
@@ -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
Setup.lhs view
@@ -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}
+ cbits/ml.c view
@@ -0,0 +1,49 @@+#include <mathlink.h>+#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);+}
+ example/Test.hs view
@@ -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
− examples/Setup.lhs
@@ -1,7 +0,0 @@-#!/bin/env runhaskell-\begin{code}--import Distribution.Simple-main = defaultMain--\end{code}
− examples/mltest.cabal
@@ -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: <tracy.wadleigh@gmail.com>-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-
− examples/mltest.nb
@@ -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", "[", "\"\<mltest.sh\>\"", "]"}]}]], "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", ",", "\"\<A string\>\"", ",", "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 *)
− examples/mltest.sh
@@ -1,2 +0,0 @@-#! /usr/bin/env sh-dist/build/mltest/mltest $@ +RTS -K1G -RTS 2> mltest.err
− examples/src/Main.hs
@@ -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- ]-
mathlink.cabal view
@@ -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: <tracy.wadleigh@gmail.com> 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/
− src/Foreign/MathLink.hs
@@ -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.--}
− src/Foreign/MathLink/Expressible.hs
@@ -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)-
− src/Foreign/MathLink/IO.hs
@@ -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)
− src/state.c
@@ -1,48 +0,0 @@-#include <mathlink.h>--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);-}-