mathlink 2.0.0.7 → 2.0.1.1
raw patch · 5 files changed
+752/−498 lines, 5 filesdep ~arraydep ~basedep ~containers
Dependency ranges changed: array, base, containers
Files
- Foreign/MathLink.hs +61/−67
- Foreign/MathLink/Expression.hs +128/−111
- Foreign/MathLink/Internal.chs +547/−306
- example/Test.hs +8/−7
- mathlink.cabal +8/−7
Foreign/MathLink.hs view
@@ -15,8 +15,8 @@ , MLDecl(..) -- * Running the /MathLink/ loop- , runMathLinkWithArgs- , runMathLink+ , ML+ , runMLSpec -- * /Mathematica/ expressions and data marshaling , module Foreign.MathLink.Expression@@ -29,6 +29,7 @@ import Control.Concurrent import Control.Exception hiding (evaluate) import Control.Monad+import Control.Monad.Trans import Foreign.MathLink.Internal import Foreign.MathLink.Expression@@ -36,8 +37,6 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IM -import System.Environment- -- | A /Mathematica/ package specification. type MLSpec = [MLDecl] @@ -51,7 +50,7 @@ -- The 'String' is wrapped with a @ToExpression@ before -- being sent. | DeclMsg String String String- -- ^ Defines a /Mathematica/ message.+ -- ^ Define a /Mathematica/ message. -- -- @'DeclMsg' /sym/ /tag/ /defn/@ in Haskell maps to -- @/sym/::/tag/ = /defn/@ in /Mathematica/.@@ -68,9 +67,12 @@ -- match are in scope for 'argPattern'. , argPattern :: String -- | The function to be called on the Haskell side.- , func :: a -> IO b+ , func :: a -> ML b }-+ -- ^ Declare a function to be callable from /Mathematica/.+ | Exec (ML ())+ -- ^ Specify an arbitrary action to be executed + -- in the process of setting up the package. globalSpec :: MLSpec globalSpec = [ DeclMsg "MathLink" "usage" @@ -83,73 +85,67 @@ "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 :: (MLGet a, MLPut b) => (a -> ML b) -> ML () wrapFn fn = do- arg <- mlGet+ lnk <- newLoopbackLink+ transferTo lnk newPacket clearAbort clearInterrupt- result <- do+ result <- liftIO $ do vres <- newEmptyMVar- idComp <- forkIO $ tryCalcAndPut vres $ fn arg- idInt <- forkIO $ putWhenTrue vres checkInterrupt+ idMl <- forkIO $ do runML (do arg <- mlGet+ newPacket+ fn arg >>= mlPut+ endPacket+ flush) lnk+ putMVar vres (Right True)+ `catch` (\e -> putMVar vres (Left e))+ idIo <- forkIO $ do untilInterrupt+ putMVar vres (Right False)+ `catch` (\e -> putMVar vres (Left e)) res <- takeMVar vres- killThread idComp- killThread idInt+ killThread idMl+ killThread idIo 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+ Right True -> transferFrom lnk+ Right False -> (mlPut $ Sy "$Aborted")+ Left err -> do printMessage "MathLink" "exn" + [St $ show (err :: SomeException)]+ mlPut $ Sy "$Failed"+ endPacket+ flush+ where untilInterrupt = do+ bl <- checkInterrupt+ if bl then return () else do+ threadDelay 100000+ untilInterrupt --- | 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+runMLSpec+ :: 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+runMLSpec spec = do+ result <- try $ runMLMain $ 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 :: MLSpec -> ML () runSpec spec = do- (_,fns) <- foldM processDecl (0,[]) (globalSpec ++ spec)- mlPut $ Sy "End"- flush- answer $ IM.fromList fns+ (_,fns) <- foldM processDecl (0,[]) (globalSpec ++ spec)+ mlPut $ Sy "End"+ flush+ answer $ IM.fromList fns -processDecl :: (Int,[(Int,IO ())]) +processDecl :: (Int,[(Int,ML ())]) -> MLDecl - -> IO (Int,[(Int,IO ())])+ -> ML (Int,[(Int,ML ())]) processDecl pr (Eval v) = do send v return pr@@ -159,11 +155,14 @@ processDecl pr (DeclMsg sym tag defn) = do defineMessage sym tag defn return pr+processDecl pr (Exec action) = do+ action+ return pr processDecl (n,fns) (DeclFn callPat argPat fn) = do- send ("DefineExternal":@[St callPat, St argPat, I (fromIntegral n)])+ send ((Sy "DefineExternal"):@[St callPat, St argPat, I (fromIntegral n)]) return (n+1,(n, wrapFn fn):fns) -answer :: IntMap (IO ()) -> IO ()+answer :: IntMap (ML ()) -> ML () answer fnMap = do waitForPacket (== (MLPacket PktCall)) n <- mlGet@@ -182,10 +181,10 @@ import "Foreign.MathLink" -addFour :: ('Int','Int','Int','Int') -> IO 'Int'+addFour :: ('Int','Int','Int','Int') -> 'ML' 'Int' addFour (a,b,c,d) = 'return' '$' a '+' b '+' c '+' d -ackermann :: ('Integer','Integer') -> 'IO' 'Integer'+ackermann :: ('Integer','Integer') -> 'ML' 'Integer' ackermann (m,n) = 'return' '$' ack m n ack :: 'Integer' -> 'Integer' -> 'Integer'@@ -237,11 +236,6 @@ {- $limitations - * In the current implementation, only one /MathLink/ connection may be + 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
@@ -21,43 +21,34 @@ -- * Data marshaling , MLPut(..) , MLGet(..)- , Packable- , putArray- , getArray ) where -import Control.Monad-import Data.Word+import Control.Monad.Reader 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+import Data.Array.Unboxed -- | 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.+ | MLExpr :@ [MLExpr] -- ^ Compound expression. deriving (Eq, Ord, Show) -- | Sugar for the @Set@ /Mathematica/ expression (-=-) :: MLExpr -> MLExpr -> MLExpr-ex1 -=- ex2 = "Set":@[ex1,ex2]+ex1 -=- ex2 = (Sy "Set"):@[ex1,ex2] -- | Sugar for the @MessageName@ /Mathematica/ expression (-::-) :: String -> String -> MLExpr-sym -::- tag = "MessageName":@[Sy sym, St tag]+sym -::- tag = (Sy "MessageName"):@[Sy sym, St tag] ------------------- Evaluation ---------------------@@ -67,7 +58,7 @@ -- desired type). -- -- Does not call 'endPacket'.-evaluate :: (MLPut a, MLGet b) => a -> IO b+evaluate :: (MLPut a, MLGet b) => a -> ML b evaluate v = do send v waitForPacket (== (MLPacket PktReturn))@@ -78,7 +69,7 @@ -- | Puts a value to the /MathLink/ connection. -- -- Does not wait for a return packet or call 'endPacket'.-send :: MLPut a => a -> IO ()+send :: MLPut a => a -> ML () send v = do putFunction "EvaluatePacket" 1 mlPut v@@ -86,8 +77,8 @@ -- | 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]+sendString :: String -> ML ()+sendString str = send $ (Sy "ToExpression"):@[St str] -- | Defines a message. --@@ -106,13 +97,13 @@ :: String -- ^ The symbol associated with this message. -> String -- ^ The tag associated with this message. -> String -- ^ The message definition.- -> IO ()+ -> ML () 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):+-- Making the call (corresponding to the 'defineMessage' example): -- -- @ -- 'printMessage' \"Foo\" \"bar\" ['St' \"fish\", 'St' \"bicycle\"]@@ -131,9 +122,9 @@ -> String -- ^ The tag associated with the message. -> [MLExpr] -- ^ A list of expressions whose string values are -- to be interpolated in to the message.- -> IO ()+ -> ML () printMessage sym tag args = do- v <- evaluate ("Message":@[sym-::-tag,"Sequence":@args])+ v <- evaluate ((Sy "Message"):@[sym-::-tag,(Sy "Sequence"):@args]) (v :: MLExpr) `seq` return () --------------------- MLPut -------------------------@@ -141,7 +132,7 @@ -- | The class of types that can be marshaled to /Mathematica/. class MLPut a where -- | Send a value to /Mathematica/.- mlPut :: a -> IO ()+ mlPut :: a -> ML () instance MLPut MLExpr where mlPut (I i) = mlPut i@@ -149,8 +140,9 @@ mlPut (St str) = mlPut str mlPut (Sy sym) = putSymbol sym mlPut (hd :@ exs) = do - putFunction hd (length exs)- mapM_ mlPut exs+ putType $ MLType TypFn+ putArgCount (length exs)+ mapM_ mlPut (hd:exs) instance MLPut Bool where mlPut True = putSymbol "True"@@ -193,6 +185,40 @@ instance MLPut [Double] where mlPut = putDoubleList +putArrayWith :: ( Ix ix+ , Shapable ix+ , IArray a e+ ) => ([e] -> [(Int,String)] -> ML ())+ -> a ix e -> ML ()+putArrayWith fn ary = fn xs dims+ where xs = elems ary+ dims = zip (shape ary) (repeat "List")++instance ( Ix ix+ , Shapable ix+ ) => MLPut (UArray ix Int16) where+ mlPut = putArrayWith putInt16Array++instance ( Ix ix+ , Shapable ix+ ) => MLPut (UArray ix Int32) where+ mlPut = putArrayWith putInt32Array++instance ( Ix ix+ , Shapable ix+ ) => MLPut (UArray ix Int) where+ mlPut = putArrayWith putIntArray++instance ( Ix ix+ , Shapable ix+ ) => MLPut (UArray ix Float) where+ mlPut = putArrayWith putFloatArray++instance ( Ix ix+ , Shapable ix+ ) => MLPut (UArray ix Double) where+ mlPut = putArrayWith putDoubleArray+ instance (RealFloat a, MLPut a) => MLPut (Complex a) where mlPut (r :+ i) = do putFunction "Complex" 2 mlPut r@@ -203,6 +229,17 @@ mlPut n mlPut d +instance MLPut a => MLPut (Maybe a) where+ mlPut (Just v) = do putFunction "Just" 1+ mlPut v+ mlPut Nothing = putSymbol "Nothing"++instance (MLPut a, MLPut b) => MLPut (Either a b) where+ mlPut (Left v) = do putFunction "Left" 1+ mlPut v+ mlPut (Right v) = do putFunction "Right" 1+ mlPut v+ instance (MLPut a) => MLPut [a] where mlPut xs = do putFunction "List" (length xs) mapM_ mlPut xs@@ -294,7 +331,7 @@ -- | The class of types that can be marshaled from /Mathematica/. class MLGet a where -- | Get a value from /Mathematica/.- mlGet :: IO a+ mlGet :: ML a instance MLGet MLExpr where mlGet = do@@ -304,11 +341,12 @@ 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+ MLType TypFn -> do nargs <- getArgCount+ hd <- mlGet+ exs <- replicateM nargs mlGet return $ hd:@exs- MLType TypErr -> throwMLError- _ -> throwMsg "mlGet/Expression: unexpected type"+ MLType TypErr -> throwMsg "mlGet/Expression" "type error"+ _ -> throwMsg "mlGet/Expression" "unexpected type" instance MLGet Bool where mlGet = do@@ -316,7 +354,7 @@ case str of "True" -> return True "False" -> return False- _ -> throwMsg "mlGet/Bool: unexpected symbol"+ _ -> throwMsg "mlGet/Bool" "unexpected symbol" instance MLGet Int16 where mlGet = getInt16@@ -354,13 +392,47 @@ instance MLGet [Double] where mlGet = getDoubleList +getArrayWith :: ( Ix ix+ , Shapable ix+ , IArray a e+ ) => ML ([e], [(Int,String)])+ -> ML (a ix e)+getArrayWith fn = do+ (xs,dims) <- fn+ return $ listArray (sBounds $ fst $ unzip dims) xs++instance ( Ix ix+ , Shapable ix+ ) => MLGet (UArray ix Int16) where+ mlGet = getArrayWith getInt16Array++instance ( Ix ix+ , Shapable ix+ ) => MLGet (UArray ix Int32) where+ mlGet = getArrayWith getInt32Array++instance ( Ix ix+ , Shapable ix+ ) => MLGet (UArray ix Int) where+ mlGet = getArrayWith getIntArray++instance ( Ix ix+ , Shapable ix+ ) => MLGet (UArray ix Float) where+ mlGet = getArrayWith getFloatArray++instance ( Ix ix+ , Shapable ix+ ) => MLGet (UArray ix Double) where+ mlGet = getArrayWith getDoubleArray+ 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"+ _ -> throwMsg "mlGet/Complex" "unexpected type" where fromReal = do r <- mlGet return $ r :+ 0@@ -378,7 +450,7 @@ MLType TypI -> fromInt MLType TypR -> fromReal MLType TypFn -> fromFunc- _ -> throwMsg "mlGet/Ratio: unexpected type"+ _ -> throwMsg "mlGet/Ratio" "unexpected type" where fromInt = do i <- mlGet return $ i :% 1@@ -395,6 +467,27 @@ d <- mlGet return (n :% d) +instance MLGet a => MLGet (Maybe a) where+ mlGet = do+ typ <- getType+ case typ of+ MLType TypSy -> do s <- getSymbol+ if s == "Nothing" then + return Nothing+ else+ throwMsg + "mlGet/Maybe a" "unexpected symbol"+ MLType TypFn -> do testFunction (== "Just") (== 1)+ mlGet >>= (return . Just)+ _ -> throwMsg "mlGet/Maybe a" "unexpected type"++instance (MLGet a, MLGet b) => MLGet (Either a b) where+ mlGet = do (hd,_) <- testFunction (const True) (== 1)+ case hd of+ "Left" -> mlGet >>= (return . Left)+ "Right" -> mlGet >>= (return . Right)+ _ -> throwMsg "mlGet/Either a b" "unexpected head"+ instance (MLGet a) => MLGet [a] where mlGet = do (_,nargs) <- testFunction (== "List") (>= 0) replicateM nargs mlGet@@ -408,11 +501,11 @@ if sy == "Null" then return () else- throwMsg "mlGet/(): unexpected symbol"+ throwMsg "mlGet/()" "unexpected symbol" (MLType TypFn) -> do testFunction (== "List") (== 0) return ()- _ -> throwMsg "mlGet/(): unexpected type"+ _ -> throwMsg "mlGet/()" "unexpected type" instance ( MLGet t1 , MLGet t2@@ -492,79 +585,3 @@ 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
@@ -1,21 +1,24 @@-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches #-}+--{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches #-} {-# LANGUAGE ForeignFunctionInterface , DeriveDataTypeable+ , GeneralizedNewtypeDeriving #-} module Foreign.MathLink.Internal - ( -- -- * Intitialization/finalization- initializeMathLink- , activate- , finalizeMathLink+ (+ -- * The 'ML' monad+ Link+ , ML+ , runMLMain+ , newLoopbackLink+ , runML+ , transferTo+ , transferFrom -- * Checking types , Typ(..) , MLType(..)- , getType , testHead , testFunction @@ -47,6 +50,10 @@ -- *** String-like data , putString , putSymbol++ -- *** Composite data+ , putType+ , putArgCount , putFunction -- ** Marshaling data from /Mathematica/@@ -75,6 +82,10 @@ -- *** String-like data , getString , getSymbol++ -- *** Composite data+ , getType+ , getArgCount , getFunction -- * Out-of-band messaging@@ -89,12 +100,11 @@ -- * Errors , Err(..) , MLErr(..)+ , Location+ , getMLError , throwErr , throwCode , throwMsg- , getErrorMessage- , getMLError- , throwMLError , clearMLError -- * Packets@@ -110,13 +120,20 @@ ) where -import Foreign+import Prelude hiding (catch)++import Foreign hiding (newForeignPtr) import Foreign.C-import Control.Monad+import Foreign.Concurrent (newForeignPtr)++import Control.Concurrent+import Control.Monad.Reader import Control.Exception-import Data.Typeable +import Data.Data+ import System.IO+import System.Environment hiding (getEnvironment) #include "mathlink.h" #include "ml.h"@@ -282,42 +299,138 @@ deriving (Eq,Show) #} -data MLErr = MLErr Int String- | MLErrCode Int- | MLErrMsg String- deriving (Eq,Show,Typeable)+type Location = String -instance Exception MLErr where+data MLErr = MLErr Location Int String+ | MLErrCode Location Int+ | MLErrMsg Location String+ deriving (Eq,Data,Typeable) +instance Show MLErr where+ show err = case err of+ MLErr loc code msg -> prefix loc ++ codeStr code ++ msgStr msg+ MLErrCode loc code -> prefix loc ++ codeStr code+ MLErrMsg loc msg -> prefix loc ++ msgStr msg+ where prefix loc' = "MLErr occurred at " ++ loc'+ codeStr code' = ": code=" ++ show code'+ msgStr msg' = ": " ++ msg' ---------------------- Initialization -----------------------+instance Exception MLErr where -{# pointer MLINK as Link newtype #} +--------------------- Link -----------------------++withLink :: Link -> (Ptr Link -> IO b) -> IO b+{# pointer MLINK as Link foreign newtype #} foreign import ccall safe "mathlink.h & stdlink" stdlinkPtr :: Ptr (Ptr ()) -withLink :: (Link -> IO a) -> IO a-withLink fn = peek stdlinkPtr >>= fn . Link . castPtr+{# pointer MLEnvironment as Environment newtype #}+foreign import ccall safe "mathlink.h & stdenv" stdenvPtr+ :: Ptr (Ptr ()) --- | Initialize the /MathLink/ connection.+getEnvironment :: ML Environment+getEnvironment = liftIO $ do+ envPtr <- liftIO $ peek (castPtr stdenvPtr)+ return $ Environment envPtr+ {# 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'+{# fun MLActivate as activate'+ { withLink* `Link' } -> `Bool' #}+activate :: ML ()+activate = liftML "activate" activate' +link :: MVar Link+link = unsafePerformIO $ do+ args <- getArgs+ bl <- initializeMathLink $ unwords args+ if not bl then + throw $ MLErrMsg "link" "Unable to initialize MathLink connection."+ else+ return ()+ ptr <- peek (castPtr stdlinkPtr)+ fptr <- newForeignPtr ptr finalizeMathLink+ lnk <- newMVar $ Link fptr+ withMVar lnk $ \l -> runML activate l+ return lnk++{# fun MLClose as close+ { id `Ptr Link'+ } -> `()' id+ #}++{# fun MLLoopbackOpen as newLoopbackLink'+ { id `Environment'+ , alloca- `Err' peekEnum*+ } -> `Ptr Link' id+ #}+-- | Creates a new loopback link, which can be used to build or store+-- expressions locally.+newLoopbackLink :: ML Link+newLoopbackLink = do+ env <- getEnvironment+ (lnkPtr,err) <- liftIO $ newLoopbackLink' env+ if err /= ErrOK then throwMsg "newLoopbackLink" $ show err else do+ fptr <- liftIO $ newForeignPtr lnkPtr (close lnkPtr)+ return $ Link fptr++-- | Monad encapsulating the /MathLink/ connection.+newtype ML a = ML { runML' :: ReaderT Link IO a }+ deriving (Monad, MonadIO)++runML :: ML a -> Link -> IO a+runML = runReaderT . runML'++{# fun MLTransferExpression as transferExpression'+ { withLink* `Link'+ , withLink* `Link'+ } -> `Bool' cToBool+ #}++transfer' :: Location -> Link -> Link -> IO ()+transfer' loc dst src = do+ bl <- transferExpression' dst src+ if bl then return () else do+ dstErr <- getMLError' dst loc+ srcErr <- getMLError' src loc+ let msg = "destination:\n" ++ show dstErr ++ + "\nsource:\n" ++ show srcErr+ throw $ MLErrMsg loc msg++transferTo :: Link -> ML ()+transferTo dst = do+ src <- askLink+ liftIO $ transfer' "transferTo" dst src++transferFrom :: Link -> ML ()+transferFrom src = do+ dst <- askLink+ liftIO $ transfer' "transferFrom" dst src++-- Not to be exposed outside this module!+askLink :: ML Link+askLink = ML ask++-- | Run an 'ML' computation with the main /MathLink/ link.+--+-- /WARNING/: Calls to 'runMLMain' cannot be nested! The underlying +-- /MathLink/ state is stored in an 'MVar'. 'runMLMain' calls 'withMVar'+-- on this 'MVar', so it will block until the state is available.+-- Thus, nested calls are guaranteed to deadlock.+runMLMain :: ML a -> IO a+runMLMain = (withMVar link) . runML++ ---------------------- Messages ----------------------------- foreign import ccall safe "mathlink.h & MLInterrupt" interruptPtr@@ -338,16 +451,16 @@ checkInterrupt = checkPtr interruptPtr -- | Clear any interrupt messages.-clearInterrupt :: IO ()-clearInterrupt = clearPtr interruptPtr+clearInterrupt :: ML ()+clearInterrupt = liftIO $ clearPtr interruptPtr -- | Check if an abort message was received. checkAbort :: IO Bool checkAbort = checkPtr abortPtr -- | Clear any abort messages.-clearAbort :: IO ()-clearAbort = clearPtr abortPtr+clearAbort :: ML ()+clearAbort = liftIO $ clearPtr abortPtr -- | Check if a done message was received. checkDone :: IO Bool@@ -355,558 +468,666 @@ -- | Send a /MathLink/ message to the other end of the -- /MathLink/ connection.-{# fun MLPutMessage as putMessage- { withLink- `Link'+{# fun MLPutMessage as putMessage'+ { withLink* `Link' , cFromEnum `Msg' } -> `Bool' #}+putMessage :: Msg -> ML ()+putMessage m = liftML "putMessage" (skipFst1 putMessage' m) -------------------- Errors ------------------------- --- | Throw an 'MLErr' with the given error code and message.-throwErr :: Int -> String -> IO a-throwErr code msg = throw $ MLErr code msg+throwErr :: Location -> Int -> String -> ML a+throwErr loc code msg = + liftIO $ throw $ MLErr loc (fromEnum ErrUser + code) msg --- | Throw an 'MLErr' with just an error code.-throwCode :: Int -> IO a-throwCode code = throw $ MLErrCode code+throwCode :: Location -> Int -> ML a+throwCode loc code = + liftIO $ throw $ MLErrCode loc (fromEnum ErrUser + code) --- | Throw an 'MLErr' with just an error message.-throwMsg :: String -> IO a-throwMsg msg = throw $ MLErrMsg msg+throwMsg :: Location -> String -> ML a+throwMsg loc msg = liftIO $ throw $ MLErrMsg loc msg --- | Get the error code associated with the last /MathLink/ error.-{# fun MLError as getErrorCode- { withLink- `Link'+{# fun MLError as getErrorCode'+ { withLink* `Link' } -> `Int' cIntConv #} --- | Get a string associated with the last /MathLink/ error.-{# fun MLErrorMessage as getErrorMessage- { withLink- `Link'+{# 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+getMLError' :: Link -> Location -> IO MLErr+getMLError' l loc = do+ code <- getErrorCode' l+ msg <- getErrorMessage' l+ return $ MLErr loc code msg --- | Throw an 'MLErr' corresponding to the last /MathLink/ error.-throwMLError :: IO a-throwMLError = getMLError >>= throw+getMLError :: Location -> ML MLErr+getMLError loc = do+ l <- askLink+ liftIO $ getMLError' l loc +assertML :: Location -> Bool -> ML ()+assertML loc False = getMLError loc >>= liftIO . throw+assertML _ True = return ()+ -- | Clear the last /MathLink/ error.-{# fun MLClearError as clearMLError- { withLink- `Link'- } -> `()' throwUnless-+{# fun MLClearError as clearMLError'+ { withLink* `Link'+ } -> `Bool' cToBool #}+clearMLError :: ML ()+clearMLError = do+ l <- askLink + bl <- liftIO $ clearMLError' l + assertML "clearMLError" bl -throwUnless :: Integral a => a -> IO ()-throwUnless 0 = throwMLError-throwUnless _ = return () +------------------ Lifting utilities --------------------++liftML :: Location -> (Link -> IO Bool) -> ML ()+liftML loc fn = do+ l <- askLink+ bl <- liftIO $ fn l + assertML loc bl++skipFst1 :: (a -> b -> c) -> b -> (a -> c)+skipFst1 fn x = \l -> fn l x++ ----------------------- Packets -------------------------- -- | Goes to the beginning of the next packet and returns its type.-{# fun MLNextPacket as nextPacket- { withLink- `Link'+{# fun MLNextPacket as nextPacket'+ { withLink* `Link' } -> `MLPacket' cToEnum #}+nextPacket :: ML MLPacket+nextPacket = askLink >>= \l -> liftIO $ nextPacket' l -- | Skips to the beginning of the next packet.-{# fun MLNewPacket as newPacket- { withLink- `Link'- } -> `()' throwUnless-+{# fun MLNewPacket as newPacket'+ { withLink* `Link'+ } -> `Bool' cToBool #}+newPacket :: ML ()+newPacket = liftML "newPacket" newPacket' -- | Marks the end of the packet being put on the link.-{# fun MLEndPacket as endPacket- { withLink- `Link'- } -> `()' throwUnless-+{# fun MLEndPacket as endPacket'+ { withLink* `Link'+ } -> `Bool' cToBool #}+endPacket :: ML ()+endPacket = liftML "endPacket" endPacket' -- | Forces any pending data to be sent.-{# fun MLFlush as flush- { withLink- `Link'- } -> `()' throwUnless-+{# fun MLFlush as flush'+ { withLink* `Link'+ } -> `Bool' cToBool #}+flush :: ML ()+flush = liftML "flush" flush' -- | 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-+{# fun MLReady as ready'+ { withLink* `Link'+ } -> `Bool' cToBool #}+ready :: ML Bool+ready = askLink >>= liftIO . ready' -- | Drops packets until one satisfying the given predicate is received.-waitForPacket :: (MLPacket -> Bool) -> IO ()+waitForPacket :: (MLPacket -> Bool) -> ML () 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+ bl <- liftIO $ checkDone+ if bl then throwErr "waitForPacket" 1 "MathLink done." else do+ pkt <- nextPacket+ if pkt == MLPacket PktIllegal then + throwErr "waitForPacket" 2 "Illegal packet received." + else + return ()+ if q pkt then return () else do+ liftIO $ hPutStrLn stderr $ "Dropping packet: " ++ show pkt+ newPacket ---------------------- Marshaling (puts) --------------------- -{# fun MLPutInteger16 as putInt16- { withLink- `Link'+putScalarWith :: Location -> (Link -> a -> IO Bool)+ -> a -> ML ()+putScalarWith loc pfn v = liftML loc (skipFst1 pfn v)++{# fun MLPutInteger16 as putInt16'+ { withLink* `Link' , `Int16'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+putInt16 :: Int16 -> ML ()+putInt16 = putScalarWith "putInt16" putInt16' -{# fun MLPutInteger32 as putInt32- { withLink- `Link'+{# fun MLPutInteger32 as putInt32'+ { withLink* `Link' , `Int32'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+putInt32 :: Int32 -> ML ()+putInt32 = putScalarWith "putInt32" putInt32' #ifdef IS_64_BIT-{# fun MLPutInteger64 as putInt- { withLink- `Link'+{# fun MLPutInteger64 as putInt'+ { withLink* `Link' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #else-{# fun MLPutInteger32 as putInt- { withLink- `Link'+{# fun MLPutInteger32 as putInt'+ { withLink* `Link' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #endif+putInt :: Int -> ML ()+putInt = putScalarWith "putInt" putInt' -{# fun MLPutReal32 as putFloat- { withLink- `Link'+{# fun MLPutReal32 as putFloat'+ { withLink* `Link' , `Float'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+putFloat :: Float -> ML ()+putFloat = putScalarWith "putFloat" putFloat' -{# fun MLPutReal64 as putDouble- { withLink- `Link'+{# fun MLPutReal64 as putDouble'+ { withLink* `Link' , `Double'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+putDouble :: Double -> ML ()+putDouble = putScalarWith "putDouble" putDouble' -{# fun MLPutString as putString- { withLink- `Link'+{# fun MLPutString as putString'+ { withLink* `Link' , `String'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+putString :: String -> ML ()+putString = putScalarWith "putString" putString' -{# fun MLPutSymbol as putSymbol- { withLink- `Link'+{# fun MLPutSymbol as putSymbol'+ { withLink* `Link' , `String'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+putSymbol :: String -> ML ()+putSymbol = putScalarWith "putSymbol" putSymbol' -{# fun MLPutFunction as putFunction- { withLink- `Link'- , `String'+{# fun MLPutType as putType'+ { withLink* `Link'+ , cFromEnum `MLType'+ } -> `Bool' cToBool+ #}+putType :: MLType -> ML ()+putType typ = liftML "putType" (skipFst1 putType' typ)++{# fun MLPutArgCount as putArgCount'+ { withLink* `Link' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+putArgCount :: Int -> ML ()+putArgCount nargs = liftML "putArgCount" (skipFst1 putArgCount' nargs) -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)+putFunction :: String -> Int -> ML ()+putFunction hd nargs = do+ putType $ MLType TypFn+ putArgCount nargs+ putSymbol hd +-- This is unsafe because it coerces the type of the pointer.+-- This can only (safely) be used when the Haskell type and+-- the corresponding C type are bitwise compatible. I assume+-- that is the case for the five types for which it is called.+unsafePutList :: Storable a+ => Location+ -> (Link -> Ptr b -> Int -> IO Bool) + -> [a] -> ML ()+unsafePutList loc pfn xs = do+ lnk <- askLink+ bl <- liftIO $ withArray xs $ \ptr -> + pfn lnk (castPtr ptr) (length xs)+ assertML loc bl+ {# fun MLPutInteger16List as putInt16List'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CShort' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-putInt16List :: [Int16] -> IO ()-putInt16List = putList cIntConv putInt16List'+putInt16List :: [Int16] -> ML ()+putInt16List = unsafePutList "putInt16List" putInt16List' {# fun MLPutInteger32List as putInt32List'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CInt' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-putInt32List :: [Int32] -> IO ()-putInt32List = putList cIntConv putInt32List'+putInt32List :: [Int32] -> ML ()+putInt32List = unsafePutList "putInt32List" putInt32List' #ifdef IS_64_BIT {# fun MLPutInteger64List as putIntList'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CLong' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #else {# fun MLPutInteger32List as putIntList'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CInt' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #endif-putIntList :: [Int] -> IO ()-putIntList = putList cIntConv putIntList'+putIntList :: [Int] -> ML ()+putIntList = unsafePutList "putIntList" putIntList' {# fun MLPutReal32List as putFloatList'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CFloat' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-putFloatList :: [Float] -> IO ()-putFloatList = putList cFloatConv putFloatList'+putFloatList :: [Float] -> ML ()+putFloatList = unsafePutList "putFloatList" putFloatList' {# fun MLPutReal64List as putDoubleList'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CDouble' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-putDoubleList :: [Double] -> IO ()-putDoubleList = putList cFloatConv putDoubleList'+putDoubleList :: [Double] -> ML ()+putDoubleList = unsafePutList "putDoubleList" 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+-- Unsafe for the same reason as 'unsafePutList'.+unsafePutArray + :: Storable a+ => Location+ -> (Link -> Ptr b -> Ptr CInt -> Ptr CString -> Int -> IO Bool)+ -> [a] -> [(Int,String)] -> ML ()+unsafePutArray loc pfn xs dims = do+ lnk <- askLink+ bl <- liftIO $ withArray xs $ \xsPtr ->+ bracket (mapM newCString hds) (mapM_ free) $ \hdCStrs ->+ withArray hdCStrs $ \hdsPtr ->+ withArray (map cIntConv sh) $ \shpPtr ->+ pfn lnk (castPtr xsPtr) shpPtr hdsPtr rnk+ assertML loc bl+ where rnk = length dims+ (sh,hds) = unzip dims {# fun MLPutInteger16Array as putInt16Array'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CShort' , id `Ptr CInt' , id `Ptr CString' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-putInt16Array :: [Int16] -> [(Int,String)] -> IO ()-putInt16Array = putArray (cIntConv) putInt16Array'+putInt16Array :: [Int16] -> [(Int,String)] -> ML ()+putInt16Array = unsafePutArray "putInt16Array" putInt16Array' {# fun MLPutInteger32Array as putInt32Array'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CInt' , id `Ptr CInt' , id `Ptr CString' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-putInt32Array :: [Int32] -> [(Int,String)] -> IO ()-putInt32Array = putArray (cIntConv) putInt32Array'+putInt32Array :: [Int32] -> [(Int,String)] -> ML ()+putInt32Array = unsafePutArray "putInt32Array" putInt32Array' #ifdef IS_64_BIT {# fun MLPutInteger64Array as putIntArray'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CLong' , id `Ptr CInt' , id `Ptr CString' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #else {# fun MLPutInteger32Array as putIntArray'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CInt' , id `Ptr CInt' , id `Ptr CString' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #endif-putIntArray :: [Int] -> [(Int,String)] -> IO ()-putIntArray = putArray (cIntConv) putIntArray'+putIntArray :: [Int] -> [(Int,String)] -> ML ()+putIntArray = unsafePutArray "putIntArray" putIntArray' {# fun MLPutReal32Array as putFloatArray'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CFloat' , id `Ptr CInt' , id `Ptr CString' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-putFloatArray :: [Float] -> [(Int,String)] -> IO ()-putFloatArray = putArray (cFloatConv) putFloatArray'+putFloatArray :: [Float] -> [(Int,String)] -> ML ()+putFloatArray = unsafePutArray "putFloatArray" putFloatArray' {# fun MLPutReal64Array as putDoubleArray'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CDouble' , id `Ptr CInt' , id `Ptr CString' , `Int'- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-putDoubleArray :: [Double] -> [(Int,String)] -> IO ()-putDoubleArray = putArray (cFloatConv) putDoubleArray'+putDoubleArray :: [Double] -> [(Int,String)] -> ML ()+putDoubleArray = unsafePutArray "putDoubleArray" putDoubleArray' ----------------------- Marshaling (gets) -------------------- -{# fun MLGetInteger16 as getInt16- { withLink- `Link'+getScalarWith :: Location+ -> (Link -> IO (Bool, a))+ -> ML a+getScalarWith loc gfn = do+ (bl, v) <- askLink >>= \l -> liftIO $ gfn l+ assertML loc bl+ return v++{# fun MLGetInteger16 as getInt16'+ { withLink* `Link' , alloca- `Int16' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+getInt16 :: ML Int16+getInt16 = getScalarWith "getInt16" getInt16' -{# fun MLGetInteger32 as getInt32- { withLink- `Link'+{# fun MLGetInteger32 as getInt32'+ { withLink* `Link' , alloca- `Int32' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+getInt32 :: ML Int32+getInt32 = getScalarWith "getInt32" getInt32' #ifdef IS_64_BIT-{# fun MLGetInteger64 as getInt- { withLink- `Link'+{# fun MLGetInteger64 as getInt'+ { withLink* `Link' , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #else-{# fun MLGetInteger32 as getInt- { withLink- `Link'+{# fun MLGetInteger32 as getInt'+ { withLink* `Link' , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #endif+getInt :: ML Int+getInt = getScalarWith "getInt" getInt' -{# fun MLGetReal32 as getFloat- { withLink- `Link'+{# fun MLGetReal32 as getFloat'+ { withLink* `Link' , alloca- `Float' peekFloatConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+getFloat :: ML Float+getFloat = getScalarWith "getFloat" getFloat' -{# fun MLGetReal64 as getDouble- { withLink- `Link'+{# fun MLGetReal64 as getDouble'+ { withLink* `Link' , alloca- `Double' peekFloatConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}+getDouble :: ML Double+getDouble = getScalarWith "getDouble" getDouble' + {# fun MLReleaseString as releaseString- { withLink- `Link'+ { withLink* `Link' , id `CString' } -> `()' id #} {# fun MLGetString as getString'- { withLink- `Link'+ { withLink* `Link' , alloca- `CString' peek*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-getString :: IO String+getString :: ML String getString = do- cstr <- getString'- str <- peekCString cstr- releaseString cstr+ lnk <- askLink+ (bl, cstr) <- liftIO $ getString' lnk+ assertML "getString" bl+ str <- liftIO $ peekCString cstr+ liftIO $ releaseString lnk cstr return str {# fun MLReleaseSymbol as releaseSymbol- { withLink- `Link'+ { withLink* `Link' , id `CString' } -> `()' id #} {# fun MLGetSymbol as getSymbol'- { withLink- `Link'+ { withLink* `Link' , alloca- `CString' peek*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-getSymbol :: IO String+getSymbol :: ML String getSymbol = do- cstr <- getSymbol'- str <- peekCString cstr- releaseSymbol cstr+ lnk <- askLink+ (bl, cstr) <- liftIO $ getSymbol' lnk+ assertML "getSymbol" bl+ str <- liftIO $ peekCString cstr+ liftIO $ releaseSymbol lnk cstr return str -{# fun MLGetFunction as getFunction'- { withLink- `Link'- , alloca- `CString' peek*+{# fun MLGetArgCount as getArgCount'+ { withLink* `Link' , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-getFunction :: IO (String,Int)+getArgCount :: ML Int+getArgCount = do+ lnk <- askLink+ (bl, n) <- liftIO $ getArgCount' lnk+ assertML "getArgCount" bl+ return n++getFunction :: ML (String,Int) getFunction = do- (cstr, n) <- getFunction'- str <- peekCString cstr- releaseSymbol cstr- return (str, n)+ n <- getArgCount+ hd <- getSymbol+ return (hd,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)+unsafeGetList :: Storable b + => Location+ -> (Link -> IO (Bool, Ptr a, Int))+ -> (Link -> Ptr a -> Int -> IO ())+ -> ML [b]+unsafeGetList loc gfn rfn = do+ lnk <- askLink+ (bl, ptr, n) <- liftIO $ gfn lnk+ assertML loc bl+ xs <- liftIO $ peekArray n (castPtr ptr)+ liftIO $ rfn lnk (castPtr ptr) n+ return xs {# fun MLReleaseInteger16List as releaseInt16List'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CShort' , `Int' } -> `()' id #} {# fun MLGetInteger16List as getInt16List'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CShort' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-getInt16List :: IO [Int16]-getInt16List = getList cIntConv getInt16List' releaseInt16List'+getInt16List :: ML [Int16]+getInt16List = unsafeGetList "getInt16List" getInt16List' releaseInt16List' {# fun MLReleaseInteger32List as releaseInt32List'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CInt' , `Int' } -> `()' id #} {# fun MLGetInteger32List as getInt32List'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CInt' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-getInt32List :: IO [Int32]-getInt32List = getList cIntConv getInt32List' releaseInt32List'+getInt32List :: ML [Int32]+getInt32List = unsafeGetList "getInt32List" getInt32List' releaseInt32List' #ifdef IS_64_BIT {# fun MLReleaseInteger64List as releaseIntList'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CLong' , `Int' } -> `()' id #} {# fun MLGetInteger64List as getIntList'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CLong' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #else {# fun MLReleaseInteger32List as releaseIntList'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CInt' , `Int' } -> `()' id #} {# fun MLGetInteger32List as getIntList'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CInt' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} #endif-getIntList :: IO [Int]-getIntList = getList cIntConv getIntList' releaseIntList'+getIntList :: ML [Int]+getIntList = unsafeGetList "getIntList" getIntList' releaseIntList' {# fun MLReleaseReal32List as releaseFloatList'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CFloat' , `Int' } -> `()' id #} {# fun MLGetReal32List as getFloatList'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CFloat' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-getFloatList :: IO [Float]-getFloatList = getList cFloatConv getFloatList' releaseFloatList'+getFloatList :: ML [Float]+getFloatList = unsafeGetList "getFloatList" getFloatList' releaseFloatList' {# fun MLReleaseReal64List as releaseDoubleList'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CDouble' , `Int' } -> `()' id #} {# fun MLGetReal64List as getDoubleList'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CDouble' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #}-getDoubleList :: IO [Double]-getDoubleList = getList cFloatConv getDoubleList' releaseDoubleList'+getDoubleList :: ML [Double]+getDoubleList = + unsafeGetList "getDoubleList" 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)+unsafeGetArray :: Storable b+ => Location+ -> (Link -> IO (Bool, Ptr a, Ptr CInt, Ptr CString, Int))+ -> (Link -> Ptr a -> Ptr CInt -> Ptr CString -> Int -> IO ())+ -> ML ([b], [(Int,String)])+unsafeGetArray loc gfn rfn = do+ lnk <- askLink+ (bl, xsPtr, shpPtr, hdsPtr, rnk) <- liftIO $ gfn lnk+ assertML loc bl+ sh <- liftIO $ peekArray rnk shpPtr >>= (return . map cIntConv)+ hds <- liftIO $ peekArray rnk hdsPtr >>= (mapM peekCString)+ xs <- liftIO $ peekArray (product sh) (castPtr xsPtr) + liftIO $ rfn lnk (castPtr xsPtr) shpPtr hdsPtr rnk+ return (xs, zip sh hds) {# fun MLGetInteger16Array as getInt16Array'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CShort' peek* , alloca- `Ptr CInt' peek* , alloca- `Ptr CString' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} {# fun MLReleaseInteger16Array as releaseInt16Array'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CShort' , id `Ptr CInt' , id `Ptr CString' , cIntConv `Int' } -> `()' id #}-getInt16Array :: IO ([Int16],[(Int,String)])+getInt16Array :: ML ([Int16], [(Int,String)]) getInt16Array = - getArray cIntConv getInt16Array' releaseInt16Array'+ unsafeGetArray "getInt16Array" getInt16Array' releaseInt16Array' {# fun MLGetInteger32Array as getInt32Array'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CInt' peek* , alloca- `Ptr CInt' peek* , alloca- `Ptr CString' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} {# fun MLReleaseInteger32Array as releaseInt32Array'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CInt' , id `Ptr CInt' , id `Ptr CString' , cIntConv `Int' } -> `()' id #}-getInt32Array :: IO ([Int32],[(Int,String)])+getInt32Array :: ML ([Int32], [(Int,String)]) getInt32Array = - getArray cIntConv getInt32Array' releaseInt32Array'+ unsafeGetArray "getInt32Array" getInt32Array' releaseInt32Array' #ifdef IS_64_BIT {# fun MLGetInteger64Array as getIntArray'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CLong' peek* , alloca- `Ptr CInt' peek* , alloca- `Ptr CString' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} {# fun MLReleaseInteger64Array as releaseIntArray'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CLong' , id `Ptr CInt' , id `Ptr CString'@@ -915,15 +1136,15 @@ #} #else {# fun MLGetInteger32Array as getIntArray'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CInt' peek* , alloca- `Ptr CInt' peek* , alloca- `Ptr CString' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} {# fun MLReleaseInteger32Array as releaseIntArray'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CInt' , id `Ptr CInt' , id `Ptr CString'@@ -931,67 +1152,75 @@ } -> `()' id #} #endif-getIntArray :: IO ([Int],[(Int,String)])+getIntArray :: ML ([Int], [(Int,String)]) getIntArray = - getArray cIntConv getIntArray' releaseIntArray'+ unsafeGetArray "getIntArray" getIntArray' releaseIntArray' {# fun MLGetReal32Array as getFloatArray'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CFloat' peek* , alloca- `Ptr CInt' peek* , alloca- `Ptr CString' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} {# fun MLReleaseReal32Array as releaseFloatArray'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CFloat' , id `Ptr CInt' , id `Ptr CString' , cIntConv `Int' } -> `()' id #}-getFloatArray :: IO ([Float],[(Int,String)])+getFloatArray :: ML ([Float], [(Int,String)]) getFloatArray = - getArray cFloatConv getFloatArray' releaseFloatArray'+ unsafeGetArray "getFloatArray" getFloatArray' releaseFloatArray' {# fun MLGetReal64Array as getDoubleArray'- { withLink- `Link'+ { withLink* `Link' , alloca- `Ptr CDouble' peek* , alloca- `Ptr CInt' peek* , alloca- `Ptr CString' peek* , alloca- `Int' peekIntConv*- } -> `()' throwUnless-+ } -> `Bool' cToBool #} {# fun MLReleaseReal64Array as releaseDoubleArray'- { withLink- `Link'+ { withLink* `Link' , id `Ptr CDouble' , id `Ptr CInt' , id `Ptr CString' , cIntConv `Int' } -> `()' id #}-getDoubleArray :: IO ([Double],[(Int,String)])+getDoubleArray :: ML ([Double], [(Int,String)]) getDoubleArray = - getArray cFloatConv getDoubleArray' releaseDoubleArray'+ unsafeGetArray "getDoubleArray" getDoubleArray' releaseDoubleArray' -- | Gets the type of the next value to be gotten over the link.-{# fun MLGetType as getType- { withLink- `Link'+{# fun MLGetType as getType'+ { withLink* `Link' } -> `MLType' cToEnum #}+getType :: ML MLType+getType = askLink >>= \l -> liftIO $ getType' l -- | 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'+{# fun MLTestHead as testHead'+ { withLink* `Link' , `String' , alloca- `Int' peekIntConv* } -> `Bool' #}+testHead :: String -> ML Int+testHead hd = do+ lnk <- askLink+ (bl, n) <- liftIO $ testHead' lnk hd+ assertML "testHead" bl+ return n -- | Checks that the incoming value is of a composite (function) -- type and applies the given predicates to the expression's head@@ -999,17 +1228,25 @@ 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.+ -> ML (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"+ nargs <- getArgCount+ if not $ nargQ nargs then+ throwMsg "testFunction" "# of args failed predicate"+ else do+ hdTyp <- getType+ case hdTyp of+ MLType TypSy -> do+ hd <- getSymbol+ if not $ hdQ hd then+ throwMsg "testFunction" "head failed predicate"+ else+ return (hd, nargs)+ _ -> throwMsg "testFunction" "expected symbol for head"+ _ -> throwMsg "testFunction" "expected function type" ------------------------- C2HS Stuff -------------------------- @@ -1020,6 +1257,10 @@ peekFloatConv :: (Storable a, RealFloat a, RealFloat b) => Ptr a -> IO b peekFloatConv = liftM cFloatConv . peek++peekEnum :: (Storable a, Integral a, Enum b)+ => Ptr a -> IO b+peekEnum = liftM cToEnum . peek cIntConv :: (Integral a, Integral b) => a -> b cIntConv = fromIntegral
example/Test.hs view
@@ -4,11 +4,11 @@ import Foreign.MathLink -addFour :: (Int,Int,Int,Int) -> IO Int+addFour :: (Int,Int,Int,Int) -> ML 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 :: (Integer,Integer) -> ML Integer ackermann (m,n) = return $ ack m n ack :: Integer -> Integer -> Integer@@ -20,29 +20,30 @@ decl :: MLSpec decl = - [ Eval $ "BeginPackage":@[St "Test`"]+ [ Eval $ (Sy "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`"]+ , Eval $ (Sy "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":@[]+ , Eval $ (Sy "End"):@[]+ , Eval $ (Sy "EndPackage"):@[] ] main :: IO ()-main = runMathLink decl+main = runMLSpec decl
mathlink.cabal view
@@ -1,5 +1,5 @@ Name: mathlink-Version: 2.0.0.7+Version: 2.0.1.1 Cabal-Version: >= 1.6 Build-Type: Custom License: BSD3@@ -31,10 +31,11 @@ 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.+standard data types, including tuples, lists, and 'UArray's. . A Haskell function that is to be exposed to /Mathematica/ has the type-signature @('MLGet' a, 'MLPut' b) => a -> IO b@.+signature @('MLGet' a, 'MLPut' b) => a -> 'ML' b@. The 'ML' monad provides+single-threaded access to the /MathLink/ connection. . A simple example of a /Mathematica/ package: .@@ -42,7 +43,7 @@ import Foreign.MathLink . \-- define a function-addTwo :: (Int,Int) -> IO Int+addTwo :: (Int,Int) -> ML Int addTwo (x,y) = return $ x+y . \-- specify a package@@ -76,11 +77,11 @@ } Library- Build-Depends: base >= 4.0 && < 4.2,+ Build-Depends: base >= 4.0 && < 4.3, mtl >= 1.1 && < 1.2, haskell98,- array >= 0.2 && < 0.3,- containers >= 0.2 && < 0.3,+ array >= 0.2 && < 0.4,+ containers >= 0.2 && < 0.4, ix-shapable Exposed-Modules: Foreign.MathLink