mathlink-2.0.1.1: Foreign/MathLink.hs

{-# LANGUAGE GeneralizedNewtypeDeriving
           , ExistentialQuantification
           , MultiParamTypeClasses
           #-}
module Foreign.MathLink 
    ( 
      -- * An example package
      -- $example

      -- * Notes
      -- $notes

      -- * Package declarations
      MLSpec
    , MLDecl(..)

      -- * Running the /MathLink/ loop
    , ML
    , runMLSpec

      -- * /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 Control.Monad.Trans

import Foreign.MathLink.Internal
import Foreign.MathLink.Expression

import Data.IntMap (IntMap)
import qualified Data.IntMap as IM

-- | 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
              -- ^ Define 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 -> 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" 
                 "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`."
             ]

wrapFn :: (MLGet a, MLPut b) => (a -> ML b) -> ML ()
wrapFn fn = do
    lnk <- newLoopbackLink
    transferTo lnk
    newPacket
    clearAbort
    clearInterrupt
    result <- liftIO $ do
      vres <- newEmptyMVar
      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 idMl
      killThread idIo
      return res
    clearMLError
    case result of
      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


-- | Run the /MathLink/ loop.
runMLSpec
    :: MLSpec   -- ^ The package specification
    -> IO ()
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 -> ML ()
runSpec spec = do
  (_,fns) <- foldM processDecl (0,[]) (globalSpec ++ spec)
  mlPut $ Sy "End"
  flush
  answer $ IM.fromList fns

processDecl :: (Int,[(Int,ML ())]) 
            ->  MLDecl 
            -> ML (Int,[(Int,ML ())])
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 pr (Exec action) = do
  action
  return pr
processDecl (n,fns) (DeclFn callPat argPat fn) = do
  send ((Sy "DefineExternal"):@[St callPat, St argPat, I (fromIntegral n)])
  return (n+1,(n, wrapFn fn):fns)
      
answer :: IntMap (ML ()) -> ML ()
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') -> 'ML' 'Int'
addFour (a,b,c,d) = 'return' '$' a '+' b '+' c '+' d

ackermann :: ('Integer','Integer') -> 'ML' '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.
-}