MathLink.hs

{-# LANGUAGE TypeSynonymInstances #-}
{- |
Module      :  $Header$
Description :  A Haskell MathLink interface
Copyright   :  (c) Ewaryst Schulz, DFKI Bremen 2011
License     :  GPLv2 or higher, see LICENSE.txt
Maintainer  :  Ewaryst.Schulz@dfki.de
Stability   :  experimental
Portability :  non-portable (see language extensions)

A Haskell MathLink interface based on the Foreign.MathLink.Bindings module
-}


module Common.MathLink where

import Foreign.C -- get the C types
import Foreign.Marshal -- get the array marshalling utils
import Foreign.Storable
import Foreign.Ptr (Ptr,nullPtr)

import Foreign.MathLink.Bindings
 
import Control.Monad.Reader
import System.Timeout
import System.IO

import Data.Maybe

import Common.Utils (verbMsg, verbMsgLn, verbMsgIOLn)


-- * Constants for the MathLink interface

dfMLTKAEND, dfMLTKALL_DECODERS, dfMLTKAPCTEND, dfMLTKARRAY,
 dfMLTKARRAY_DECODER , dfMLTKCONT, dfMLTKDIM, dfMLTKELEN, dfMLTKEND,
 dfMLTKERR, dfMLTKERROR , dfMLTKFUNC, dfMLTKINT,
 dfMLTKMODERNCHARS_DECODER, dfMLTKNULL , dfMLTKNULLSEQUENCE_DECODER,
 dfMLTKOLDINT, dfMLTKOLDREAL, dfMLTKOLDSTR , dfMLTKOLDSYM,
 dfMLTKPACKED_DECODER, dfMLTKPACKED, dfMLTKPCTEND, dfMLTKREAL ,
 dfMLTKSEND, dfMLTKSTR, dfMLTKSYM, dfILLEGALPKT, dfCALLPKT,
 dfEVALUATEPKT , dfRETURNPKT, dfINPUTNAMEPKT, dfENTERTEXTPKT,
 dfENTEREXPRPKT, dfOUTPUTNAMEPKT, dfRETURNTEXTPKT, dfRETURNEXPRPKT,
 dfDISPLAYPKT, dfDISPLAYENDPKT, dfMESSAGEPKT, dfTEXTPKT, dfINPUTPKT,
 dfINPUTSTRPKT, dfMENUPKT, dfSYNTAXPKT, dfSUSPENDPKT, dfRESUMEPKT,
 dfBEGINDLGPKT, dfENDDLGPKT, dfFIRSTUSERPKT, dfLASTUSERPKT :: CInt

dfILLEGALPKT = 0

dfCALLPKT = 7
dfEVALUATEPKT = 13
dfRETURNPKT = 3

dfINPUTNAMEPKT = 8
dfENTERTEXTPKT = 14
dfENTEREXPRPKT = 15
dfOUTPUTNAMEPKT = 9
dfRETURNTEXTPKT = 4
dfRETURNEXPRPKT = 16

dfDISPLAYPKT = 11
dfDISPLAYENDPKT = 12

dfMESSAGEPKT = 5
dfTEXTPKT = 2

dfINPUTPKT = 1
dfINPUTSTRPKT = 21
dfMENUPKT = 6
dfSYNTAXPKT = 10

dfSUSPENDPKT = 17
dfRESUMEPKT = 18

dfBEGINDLGPKT = 19
dfENDDLGPKT = 20

dfFIRSTUSERPKT = 128
dfLASTUSERPKT = 255




dfMLTKAEND=13
dfMLTKALL_DECODERS=983040
dfMLTKAPCTEND=10
dfMLTKARRAY=65
dfMLTKARRAY_DECODER=262144
dfMLTKCONT=92
dfMLTKDIM=68
dfMLTKELEN=32
dfMLTKEND=10
dfMLTKERR=0
dfMLTKERROR=0
dfMLTKFUNC=70
dfMLTKINT=43
dfMLTKMODERNCHARS_DECODER=524288
dfMLTKNULL=46
dfMLTKNULLSEQUENCE_DECODER=0
dfMLTKOLDINT=73
dfMLTKOLDREAL=82
dfMLTKOLDSTR=83
dfMLTKOLDSYM=89
dfMLTKPACKED_DECODER=131072
dfMLTKPACKED=80
dfMLTKPCTEND=93
dfMLTKREAL=42
dfMLTKSEND=44
dfMLTKSTR=34
dfMLTKSYM=35


showPKT :: CInt -> String
showPKT i | i == dfILLEGALPKT = "ILLEGALPKT"
          | i == dfCALLPKT = "CALLPKT"
          | i == dfEVALUATEPKT = "EVALUATEPKT"
          | i == dfRETURNPKT = "RETURNPKT"
          | i == dfINPUTNAMEPKT = "INPUTNAMEPKT"
          | i == dfENTERTEXTPKT = "ENTERTEXTPKT"
          | i == dfENTEREXPRPKT = "ENTEREXPRPKT"
          | i == dfOUTPUTNAMEPKT = "OUTPUTNAMEPKT"
          | i == dfRETURNTEXTPKT = "RETURNTEXTPKT"
          | i == dfRETURNEXPRPKT = "RETURNEXPRPKT"
          | i == dfDISPLAYPKT = "DISPLAYPKT"
          | i == dfDISPLAYENDPKT = "DISPLAYENDPKT"
          | i == dfMESSAGEPKT = "MESSAGEPKT"
          | i == dfTEXTPKT = "TEXTPKT"
          | i == dfINPUTPKT = "INPUTPKT"
          | i == dfINPUTSTRPKT = "INPUTSTRPKT"
          | i == dfMENUPKT = "MENUPKT"
          | i == dfSYNTAXPKT = "SYNTAXPKT"
          | i == dfSUSPENDPKT = "SUSPENDPKT"
          | i == dfRESUMEPKT = "RESUMEPKT"
          | i == dfBEGINDLGPKT = "BEGINDLGPKT"
          | i == dfENDDLGPKT = "ENDDLGPKT"
          | i == dfFIRSTUSERPKT = "FIRSTUSERPKT"
          | i == dfLASTUSERPKT = "LASTUSERPKT"
          | otherwise = "UNRECOGNIZED PACKET"


showTK :: CInt -> String
showTK i  | i == dfMLTKAEND = "MLTKAEND"
          | i == dfMLTKALL_DECODERS = "MLTKALL_DECODERS"
          | i == dfMLTKAPCTEND = "MLTKAPCTEND"
          | i == dfMLTKARRAY = "MLTKARRAY"
          | i == dfMLTKARRAY_DECODER = "MLTKARRAY_DECODER"
          | i == dfMLTKCONT = "MLTKCONT"
          | i == dfMLTKDIM = "MLTKDIM"
          | i == dfMLTKELEN = "MLTKELEN"
          | i == dfMLTKEND = "MLTKEND"
          | i == dfMLTKERR = "MLTKERR"
          | i == dfMLTKERROR = "MLTKERROR"
          | i == dfMLTKFUNC = "MLTKFUNC"
          | i == dfMLTKINT = "MLTKINT"
          | i == dfMLTKMODERNCHARS_DECODER = "MLTKMODERNCHARS_DECODER"
          | i == dfMLTKNULL = "MLTKNULL"
          | i == dfMLTKNULLSEQUENCE_DECODER = "MLTKNULLSEQUENCE_DECODER"
          | i == dfMLTKOLDINT = "MLTKOLDINT"
          | i == dfMLTKOLDREAL = "MLTKOLDREAL"
          | i == dfMLTKOLDSTR = "MLTKOLDSTR"
          | i == dfMLTKOLDSYM = "MLTKOLDSYM"
          | i == dfMLTKPACKED_DECODER = "MLTKPACKED_DECODER"
          | i == dfMLTKPACKED = "MLTKPACKED"
          | i == dfMLTKPCTEND = "MLTKPCTEND"
          | i == dfMLTKREAL = "MLTKREAL"
          | i == dfMLTKSEND = "MLTKSEND"
          | i == dfMLTKSTR = "MLTKSTR"
          | i == dfMLTKSYM = "MLTKSYM"
          | otherwise = "UNRECOGNIZED TK"


-- * MathLink monad as Reader IO monad

data MLState =
    MLState
    { mlink :: MLINK
    , menv :: MLEnvironment
    , mverbosity :: Int
    , logHdl :: Maybe Handle
    }

type ML = ReaderT MLState IO


-- | Prints a message dependent on the verbosity level
verbMsgML :: Int -> String -> ML ()
verbMsgML lvl msg = do
  hdl <- getHandle
  v <- asks mverbosity
  liftIO $ verbMsg hdl v lvl msg

-- | Prints a message dependent on the verbosity level
verbMsgMLLn :: Int -> String -> ML ()
verbMsgMLLn lvl msg = do
  hdl <- getHandle
  v <- asks mverbosity
  liftIO $ verbMsgLn hdl v lvl msg

getHandle :: ML Handle
getHandle = liftM (fromMaybe stdout) $ asks logHdl

mkState :: MLINK -> MLEnvironment -> Int -> MLState
mkState mlp env v = MLState { mlink = mlp, menv = env, mverbosity = v
                            , logHdl = Nothing }

addLogging :: MLState -> Handle -> MLState
addLogging st hdl = st { logHdl = Just hdl }

askMLink :: ML MLINK
askMLink = asks mlink

liftMLIO :: (MLINK -> IO b) -> ML b
liftMLIO f = askMLink >>= liftIO . f


-- * MathLink connection handling

-- | Open connection to MathLink or return error code on failure
openLink :: Int -- ^ Verbosity
         -> Maybe String -- ^ Connection name
                         -- (launches a new kernel if not specified)
         -> IO (Either Int MLState)
openLink v mName = do
  env <- cMlInitialize nullPtr
  if (env == nullPtr) then return $ Left 1
   else do
    verbMsgIOLn v 2 "Initialized"

    let (name, mode) = case mName of
                         Just n -> (n, "connect")
                         _ -> ("math -mathlink", "launch")

    let openargs = ["-linkname", name, "-linkmode", mode]

    lp <- mlOpen 4 openargs
    mB <- if lp == nullPtr then return Nothing
--          else liftM Just $ connectLink lp
          else timeout 3000000 $ connectLink lp v
    
    case mB of
      Nothing -> return $ Left 2
      Just False -> return $ Left 3
      _ -> return $ Right $ mkState lp env v

-- | Close connection to MathLink
closeLink :: MLState -> IO ()
closeLink st = do
  mlClose $ mlink st
  cMlDeinitialize $ menv st


-- | Run ML-program on an opened connection to MathLink
withLink :: MLState -- ^ MathLink connection
         -> Maybe FilePath -- ^ Log low level messages into this file (or STDOUT)
         -> ML a -- ^ The program to run
         -> IO a
withLink st mFp mlprog =
    case mFp of
      Just fp ->
          withFile fp WriteMode $ runReaderT mlprog . addLogging st
      Nothing ->
          runReaderT mlprog st

-- | Run ML-program on a new connection to MathLink which is closed right
-- after the execution and return the prgram result or error code on failure
runLink :: Maybe FilePath -- ^ Log low level messages into this file (or STDOUT)
        -> Int -- ^ Verbosity
        -> Maybe String -- ^ Connection name
                        -- (launches a new kernel if not specified)
        -> ML a -- ^ The program to run
        -> IO (Either Int a)
runLink mFp v mName mlprog = do
  eSt <- openLink v mName
  case eSt of
    Left i -> return $ Left i
    Right st ->
        do
          verbMsgIOLn v 2 "Opened"
          x <- withLink st mFp mlprog
          closeLink st
          return $ Right x

-- | Low level: open connection
mlOpen  :: CInt -> [String] -> IO MLINK
mlOpen i l = withStringArray l $ cMlOpen i

-- | Low level: check connection
connectLink :: MLINK
            -> Int -- ^ Verbosity
            -> IO Bool
connectLink lp v = do
  let p i j = do
        i' <- cMlReady lp
        if toBool i' || j > 3000 then return j
         else cMlFlush lp >> if i > 1000 then p 0 (j+1) else p (i+1) j

  p (0::Int) (0::Int) >>= verbMsgIOLn v 2 . ("ready after " ++) . show

  res <- cMlConnect lp
  return $ toBool res

-- | Low level: close connection
mlClose  :: MLINK -> IO CInt
mlClose = cMlClose


-- * C to Haskell utilities

withStringArray :: MonadIO m => [String] -> (Ptr CString -> IO b) -> m b
withStringArray l f = liftIO $ mapM newCString l >>= flip withArray f


mlGetA  :: (Storable a, Show a, Show b) => (Ptr a -> IO b) -> IO a
mlGetA f = let g ptr = f ptr >> peek ptr in alloca g


-- TODO: maybe better via foreign pointer, check later
mlGetCString  :: Show b => (Ptr CString -> IO b) -> (CString -> IO ()) -> IO String
mlGetCString f disownF =
    let g ptr = do
          cs <- f ptr >> peek ptr
          s <- peekCString cs
          disownF cs
          return s
    in alloca g


-- * C Type conversions

cintToInteger :: CInt -> Integer
cintToInteger = fromIntegral

intToCInt :: Int -> CInt
intToCInt = fromIntegral

-- | This function is unsafe, it may overflow...
cintToInt :: CInt -> Int
cintToInt = fromIntegral



cdblToDbl :: CDouble -> Double
cdblToDbl = realToFrac

dblToCDbl :: Double -> CDouble
dblToCDbl = realToFrac

-- * MathLink interface using the ML monad, built on top of the raw bindings

mlFlush  :: ML CInt
mlFlush = liftMLIO cMlFlush

mlReady  :: ML CInt
mlReady = liftMLIO cMlReady

mlConnect  :: ML CInt
mlConnect = liftMLIO cMlConnect

mlEndPacket  :: ML CInt
mlEndPacket = liftMLIO cMlEndPacket

mlNextPacket  :: ML CInt
mlNextPacket = liftMLIO cMlNextPacket

mlNewPacket  :: ML CInt
mlNewPacket = liftMLIO cMlNewPacket

mlGetNext  :: ML CInt
mlGetNext = liftMLIO cMlGetNext


mlGetArgCount :: ML CInt
mlGetArgCount = askMLink >>= liftIO . mlGetA . cMlGetArgCount

mlGetArgCount' :: ML Int
mlGetArgCount' = liftM cintToInt mlGetArgCount

-- cMlGetSymbol  :: MLINK -> Ptr CString -> IO CInt
mlGetSymbol  :: ML String
mlGetSymbol = do
  ml <- askMLink
  liftIO $ mlGetCString (cMlGetSymbol ml) $ cMlDisownSymbol ml

-- cMlGetString  :: MLINK -> Ptr CString -> IO CInt
mlGetString  :: ML String
--mlGetString = askMLink >>= liftIO . mlGetCString . cMlGetString
mlGetString = do
  ml <- askMLink
  liftIO $ mlGetCString (cMlGetString ml) $ cMlDisownString ml

-- cMlGetReal  :: MLINK -> Ptr CDouble -> IO CInt
mlGetReal  :: ML CDouble
mlGetReal = askMLink >>= liftIO . mlGetA . cMlGetReal

mlGetReal'  :: ML Double
mlGetReal' = liftM cdblToDbl mlGetReal

-- cMlGetInteger  :: MLINK -> Ptr CInt -> IO CInt
mlGetInteger  :: ML CInt
mlGetInteger = askMLink >>= liftIO . mlGetA . cMlGetInteger

mlGetInteger'  :: ML Int
mlGetInteger' = liftM cintToInt mlGetInteger

-- | Integers are received as strings, because the interface supports only
-- machine integers with fixed length not arbitrary sized integers.
mlGetInteger''  :: ML Integer
mlGetInteger'' = liftM read mlGetString

mlPutString  :: String -> ML CInt
mlPutString s = liftMLIO f where
    f ml = withCString s $ cMlPutString ml

mlPutSymbol  :: String -> ML CInt
mlPutSymbol s = liftMLIO f where
    f ml = withCString s $ cMlPutSymbol ml

mlPutFunction  :: String -> CInt -> ML CInt
mlPutFunction s i = liftMLIO f where
    f ml = withCString s $ flip (cMlPutFunction ml) i

mlPutFunction'  :: String -> Int -> ML CInt
mlPutFunction' s = mlPutFunction s . intToCInt

mlPutInteger  :: CInt -> ML CInt
mlPutInteger = liftMLIO . flip cMlPutInteger

mlPutInteger'  :: Int -> ML CInt
mlPutInteger' = mlPutInteger . intToCInt

-- | Integers are sent as strings, because the interface supports only
-- machine integers with fixed length not arbitrary sized integers.
mlPutInteger''  :: Integer -> ML CInt
mlPutInteger'' i = mlPutFunction' "ToExpression" 1 >> mlPutString (show i)
       

mlPutReal  :: CDouble -> ML CInt
mlPutReal = liftMLIO . flip cMlPutReal
 
mlPutReal'  :: Double -> ML CInt
mlPutReal' = mlPutReal . dblToCDbl


mlError  :: ML CInt
mlError = liftMLIO cMlError

mlErrorMessage  :: ML String
mlErrorMessage = liftMLIO (cMlErrorMessage >=> peekCString)


-- * MathLink interface utils

mlProcError :: ML a
mlProcError = do
  eid <- mlError
  s <- if toBool eid then liftM ("Error detected by MathLink: " ++)
       mlErrorMessage
       else return "Error detected by Interface"
  verbMsgMLLn 1 s
  error $ "mlProcError: " ++ s


sendEvalPacket :: ML a -> ML a
sendEvalPacket ml = do
  mlPutFunction "EvaluatePacket" 1
  res <- ml
  mlEndPacket
  return res

sendTextPacket :: String -> ML ()
sendTextPacket s = do
  mlPutFunction "EvaluatePacket" 1
  mlPutFunction "ToExpression" 1
  mlPutString s
  mlEndPacket
  return ()

sendTextResultPacket :: String -> ML ()
sendTextResultPacket s = do
  mlPutFunction "EvaluatePacket" 1
  mlPutFunction "ToString" 1
  mlPutFunction "ToExpression" 1
  mlPutString s
  mlEndPacket
  return ()

{-
-- these variants does not work as expected
sendTextPacket' :: String -> ML ()
sendTextPacket' s = do
  mlPutFunction "EnterTextPacket" 1
  mlPutString s
  mlEndPacket
  return ()
sendTextPacket'' :: String -> ML ()
sendTextPacket'' s = do
  mlPutFunction "EnterExpressionPacket" 1
  mlPutFunction "ToExpression" 1
  mlPutString s
  mlEndPacket
  return ()
sendTextPacket3 :: String -> ML ()
sendTextPacket3 s = do
  mlPutFunction "EvaluatePacket" 1
  mlPutFunction "ToString" 1
  mlPutFunction "ToExpression" 1
  mlPutString s
  mlEndPacket
  return ()
sendTextPacket4 :: String -> ML ()
sendTextPacket4 s = do
  mlPutFunction "EnterExpressionPacket" 1
  mlPutFunction "ToString" 1
  mlPutFunction "ToExpression" 1
  mlPutString s
  mlEndPacket
  return ()
-}

waitForAnswer :: ML CInt
waitForAnswer = do
    -- skip any packets before the first ReturnPacket
  i <- waitUntilPacket (0::Int) [ dfRETURNPKT, dfRETURNEXPRPKT
                                , dfRETURNTEXTPKT, dfILLEGALPKT]
  if elem i [dfILLEGALPKT, dfRETURNEXPRPKT, dfRETURNTEXTPKT]
   then error $ "waitForAnswer: encountered a " ++ showPKT i
   else return i
  

-- wait for the answer and skip it
skipAnswer :: ML CInt
skipAnswer = waitForAnswer >> mlNewPacket

waitUntilPacket :: Num a => a -> [CInt] -> ML CInt
waitUntilPacket i l = do
  np <- mlNextPacket
  if elem np l then do
                 verbMsgMLLn 2 $ "GotReturn after " ++ show i ++ " iterations"
                 return np
   else (verbMsgMLLn 2 $ "wap: " ++ show np) >> mlNewPacket
            >> waitUntilPacket (i+1) l