content: {-# LANGUAGE TypeSynonymInstances #-}
  {- |
  Module      :  ./Common/MathLink.hs
  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
  