{-# 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.
-}