{-# LANGUAGE MultiParamTypeClasses
           , FlexibleContexts
           , DeriveDataTypeable
           #-}

-- | A Haskell interface to /Mathematica/'s /MathLink/.
module Foreign.MathLink ( -- * 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

{- $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 :: 'IO' ()
addTwo = do
  (i1,i2) <- 'get'
  'put' ((i1 + i2) :: 'Int')

main = 'runMathLink' [ 'Function' \{ 'callPattern' = \"AddTwo[i_Integer,j_Integer]\"
                              , 'argumentPattern' = \"{i,j}\"
                              , 'function' = addTwo
                              \}
                   ]
@

A function to be exposed to /Mathematica/ has type @'IO' ()@. In its body 
it uses the 'get' function to receive a value from /Mathematica/, performs 
the desired computation, and sends the result back to /Mathematica/ via the 
'put' function.

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