a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz{-# LANGUAGE TypeSynonymInstances #-}
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz{- |
e9458b1a7a19a63aa4c179f9ab20f4d50681c168Jens ElknerModule : ./Common/MathLink.hs
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzDescription : A Haskell MathLink interface
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzCopyright : (c) Ewaryst Schulz, DFKI Bremen 2011
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzLicense : GPLv2 or higher, see LICENSE.txt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzMaintainer : Ewaryst.Schulz@dfki.de
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzStability : experimental
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzPortability : non-portable (see language extensions)
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzA Haskell MathLink interface based on the Foreign.MathLink.Bindings module
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-}
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzmodule Common.MathLink where
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport Foreign.C -- get the C types
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport Foreign.Marshal -- get the array marshalling utils
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport Foreign.Storable
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroederimport Foreign.Ptr (Ptr, nullPtr)
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport Foreign.MathLink.Bindings
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport Control.Monad.Reader
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport System.Timeout
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzimport System.IO
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulzimport Data.Maybe
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
dde363c92873e122a139e2db23862dfd7d265b73Ewaryst Schulzimport Common.Utils (verbMsg, verbMsgLn, verbMsgIOLn)
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * Constants for the MathLink interface
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfMLTKAEND, dfMLTKALL_DECODERS, dfMLTKAPCTEND, dfMLTKARRAY,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfMLTKARRAY_DECODER , dfMLTKCONT, dfMLTKDIM, dfMLTKELEN, dfMLTKEND,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfMLTKERR, dfMLTKERROR , dfMLTKFUNC, dfMLTKINT,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfMLTKMODERNCHARS_DECODER, dfMLTKNULL , dfMLTKNULLSEQUENCE_DECODER,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfMLTKOLDINT, dfMLTKOLDREAL, dfMLTKOLDSTR , dfMLTKOLDSYM,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfMLTKPACKED_DECODER, dfMLTKPACKED, dfMLTKPCTEND, dfMLTKREAL ,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfMLTKSEND, dfMLTKSTR, dfMLTKSYM, dfILLEGALPKT, dfCALLPKT,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfEVALUATEPKT , dfRETURNPKT, dfINPUTNAMEPKT, dfENTERTEXTPKT,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfENTEREXPRPKT, dfOUTPUTNAMEPKT, dfRETURNTEXTPKT, dfRETURNEXPRPKT,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfDISPLAYPKT, dfDISPLAYENDPKT, dfMESSAGEPKT, dfTEXTPKT, dfINPUTPKT,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfINPUTSTRPKT, dfMENUPKT, dfSYNTAXPKT, dfSUSPENDPKT, dfRESUMEPKT,
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz dfBEGINDLGPKT, dfENDDLGPKT, dfFIRSTUSERPKT, dfLASTUSERPKT :: CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst SchulzdfILLEGALPKT = 0
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfCALLPKT = 7
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfEVALUATEPKT = 13
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfRETURNPKT = 3
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfINPUTNAMEPKT = 8
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfENTERTEXTPKT = 14
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfENTEREXPRPKT = 15
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfOUTPUTNAMEPKT = 9
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfRETURNTEXTPKT = 4
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzdfRETURNEXPRPKT = 16
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfDISPLAYPKT = 11
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfDISPLAYENDPKT = 12
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfMESSAGEPKT = 5
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfTEXTPKT = 2
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfINPUTPKT = 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfINPUTSTRPKT = 21
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfMENUPKT = 6
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfSYNTAXPKT = 10
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfSUSPENDPKT = 17
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfRESUMEPKT = 18
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfBEGINDLGPKT = 19
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfENDDLGPKT = 20
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfFIRSTUSERPKT = 128
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzdfLASTUSERPKT = 255
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKAEND = 13
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKALL_DECODERS = 983040
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKAPCTEND = 10
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKARRAY = 65
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKARRAY_DECODER = 262144
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKCONT = 92
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKDIM = 68
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKELEN = 32
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKEND = 10
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKERR = 0
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKERROR = 0
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKFUNC = 70
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKINT = 43
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKMODERNCHARS_DECODER = 524288
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKNULL = 46
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKNULLSEQUENCE_DECODER = 0
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKOLDINT = 73
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKOLDREAL = 82
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKOLDSTR = 83
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKOLDSYM = 89
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKPACKED_DECODER = 131072
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKPACKED = 80
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKPCTEND = 93
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKREAL = 42
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKSEND = 44
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKSTR = 34
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroederdfMLTKSYM = 35
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzshowPKT :: CInt -> String
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzshowPKT i | i == dfILLEGALPKT = "ILLEGALPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfCALLPKT = "CALLPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfEVALUATEPKT = "EVALUATEPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfRETURNPKT = "RETURNPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfINPUTNAMEPKT = "INPUTNAMEPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfENTERTEXTPKT = "ENTERTEXTPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfENTEREXPRPKT = "ENTEREXPRPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfOUTPUTNAMEPKT = "OUTPUTNAMEPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfRETURNTEXTPKT = "RETURNTEXTPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfRETURNEXPRPKT = "RETURNEXPRPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfDISPLAYPKT = "DISPLAYPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfDISPLAYENDPKT = "DISPLAYENDPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMESSAGEPKT = "MESSAGEPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfTEXTPKT = "TEXTPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfINPUTPKT = "INPUTPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfINPUTSTRPKT = "INPUTSTRPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMENUPKT = "MENUPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfSYNTAXPKT = "SYNTAXPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfSUSPENDPKT = "SUSPENDPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfRESUMEPKT = "RESUMEPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfBEGINDLGPKT = "BEGINDLGPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfENDDLGPKT = "ENDDLGPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfFIRSTUSERPKT = "FIRSTUSERPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfLASTUSERPKT = "LASTUSERPKT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | otherwise = "UNRECOGNIZED PACKET"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzshowTK :: CInt -> String
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedershowTK i | i == dfMLTKAEND = "MLTKAEND"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKALL_DECODERS = "MLTKALL_DECODERS"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKAPCTEND = "MLTKAPCTEND"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKARRAY = "MLTKARRAY"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKARRAY_DECODER = "MLTKARRAY_DECODER"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKCONT = "MLTKCONT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKDIM = "MLTKDIM"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKELEN = "MLTKELEN"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKEND = "MLTKEND"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKERR = "MLTKERR"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKERROR = "MLTKERROR"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKFUNC = "MLTKFUNC"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKINT = "MLTKINT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKMODERNCHARS_DECODER = "MLTKMODERNCHARS_DECODER"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKNULL = "MLTKNULL"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKNULLSEQUENCE_DECODER = "MLTKNULLSEQUENCE_DECODER"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKOLDINT = "MLTKOLDINT"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKOLDREAL = "MLTKOLDREAL"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKOLDSTR = "MLTKOLDSTR"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKOLDSYM = "MLTKOLDSYM"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKPACKED_DECODER = "MLTKPACKED_DECODER"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKPACKED = "MLTKPACKED"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKPCTEND = "MLTKPCTEND"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKREAL = "MLTKREAL"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKSEND = "MLTKSEND"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKSTR = "MLTKSTR"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz | i == dfMLTKSYM = "MLTKSYM"
f54cad0338da90c6789bb9baae1caec50d994b3aEwaryst Schulz | otherwise = "UNRECOGNIZED TK"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * MathLink monad as Reader IO monad
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulzdata MLState =
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz MLState
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz { mlink :: MLINK
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz , menv :: MLEnvironment
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz , mverbosity :: Int
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz , logHdl :: Maybe Handle
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz }
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulztype ML = ReaderT MLState IO
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
f54cad0338da90c6789bb9baae1caec50d994b3aEwaryst Schulz-- | Prints a message dependent on the verbosity level
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzverbMsgML :: Int -> String -> ML ()
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzverbMsgML lvl msg = do
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz hdl <- getHandle
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz v <- asks mverbosity
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz liftIO $ verbMsg hdl v lvl msg
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
f54cad0338da90c6789bb9baae1caec50d994b3aEwaryst Schulz-- | Prints a message dependent on the verbosity level
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzverbMsgMLLn :: Int -> String -> ML ()
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzverbMsgMLLn lvl msg = do
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz hdl <- getHandle
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz v <- asks mverbosity
f54cad0338da90c6789bb9baae1caec50d994b3aEwaryst Schulz liftIO $ verbMsgLn hdl v lvl msg
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzgetHandle :: ML Handle
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzgetHandle = liftM (fromMaybe stdout) $ asks logHdl
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzmkState :: MLINK -> MLEnvironment -> Int -> MLState
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzmkState mlp env v = MLState { mlink = mlp, menv = env, mverbosity = v
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz , logHdl = Nothing }
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzaddLogging :: MLState -> Handle -> MLState
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzaddLogging st hdl = st { logHdl = Just hdl }
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzaskMLink :: ML MLINK
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzaskMLink = asks mlink
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzliftMLIO :: (MLINK -> IO b) -> ML b
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzliftMLIO f = askMLink >>= liftIO . f
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * MathLink connection handling
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz-- | Open connection to MathLink or return error code on failure
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzopenLink :: Int -- ^ Verbosity
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder -> Maybe String {- ^ Connection name
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder (launches a new kernel if not specified) -}
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz -> IO (Either Int MLState)
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzopenLink v mName = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz env <- cMlInitialize nullPtr
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder if env == nullPtr then return $ Left 1
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz else do
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz verbMsgIOLn v 2 "Initialized"
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz let (name, mode) = case mName of
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Just n -> (n, "connect")
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz _ -> ("math -mathlink", "launch")
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz let openargs = ["-linkname", name, "-linkmode", mode]
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz lp <- mlOpen 4 openargs
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz mB <- if lp == nullPtr then return Nothing
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder-- else liftM Just $ connectLink lp
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz else timeout 3000000 $ connectLink lp v
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz case mB of
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Nothing -> return $ Left 2
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz Just False -> return $ Left 3
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz _ -> return $ Right $ mkState lp env v
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz-- | Close connection to MathLink
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzcloseLink :: MLState -> IO ()
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzcloseLink st = do
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz mlClose $ mlink st
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz cMlDeinitialize $ menv st
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz-- | Run ML-program on an opened connection to MathLink
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzwithLink :: MLState -- ^ MathLink connection
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz -> Maybe FilePath -- ^ Log low level messages into this file (or STDOUT)
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz -> ML a -- ^ The program to run
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz -> IO a
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzwithLink st mFp mlprog =
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz case mFp of
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz Just fp ->
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz withFile fp WriteMode $ runReaderT mlprog . addLogging st
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz Nothing ->
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz runReaderT mlprog st
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder{- | Run ML-program on a new connection to MathLink which is closed right
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroederafter the execution and return the prgram result or error code on failure -}
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzrunLink :: Maybe FilePath -- ^ Log low level messages into this file (or STDOUT)
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz -> Int -- ^ Verbosity
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder -> Maybe String {- ^ Connection name
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder (launches a new kernel if not specified) -}
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz -> ML a -- ^ The program to run
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz -> IO (Either Int a)
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzrunLink mFp v mName mlprog = do
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz eSt <- openLink v mName
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz case eSt of
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz Left i -> return $ Left i
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz Right st ->
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz do
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz verbMsgIOLn v 2 "Opened"
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz x <- withLink st mFp mlprog
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz closeLink st
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz return $ Right x
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz-- | Low level: open connection
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlOpen :: CInt -> [String] -> IO MLINK
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlOpen i l = withStringArray l $ cMlOpen i
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz-- | Low level: check connection
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzconnectLink :: MLINK
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz -> Int -- ^ Verbosity
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz -> IO Bool
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzconnectLink lp v = do
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz let p i j = do
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz i' <- cMlReady lp
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz if toBool i' || j > 3000 then return j
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder else cMlFlush lp >> if i > 1000 then p 0 (j + 1) else p (i + 1) j
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder p (0 :: Int) (0 :: Int) >>= verbMsgIOLn v 2 . ("ready after " ++) . show
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz res <- cMlConnect lp
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz return $ toBool res
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz-- | Low level: close connection
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlClose :: MLINK -> IO CInt
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzmlClose = cMlClose
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * C to Haskell utilities
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzwithStringArray :: MonadIO m => [String] -> (Ptr CString -> IO b) -> m b
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzwithStringArray l f = liftIO $ mapM newCString l >>= flip withArray f
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetA :: (Storable a, Show a, Show b) => (Ptr a -> IO b) -> IO a
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetA f = let g ptr = f ptr >> peek ptr in alloca g
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz-- TODO: maybe better via foreign pointer, check later
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetCString :: Show b => (Ptr CString -> IO b) -> (CString -> IO ()) -> IO String
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetCString f disownF =
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz let g ptr = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz cs <- f ptr >> peek ptr
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz s <- peekCString cs
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz disownF cs
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz return s
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz in alloca g
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz-- * C Type conversions
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzcintToInteger :: CInt -> Integer
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzcintToInteger = fromIntegral
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzintToCInt :: Int -> CInt
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzintToCInt = fromIntegral
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz-- | This function is unsafe, it may overflow...
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzcintToInt :: CInt -> Int
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzcintToInt = fromIntegral
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzcdblToDbl :: CDouble -> Double
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzcdblToDbl = realToFrac
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzdblToCDbl :: Double -> CDouble
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzdblToCDbl = realToFrac
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
dde363c92873e122a139e2db23862dfd7d265b73Ewaryst Schulz-- * MathLink interface using the ML monad, built on top of the raw bindings
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlFlush :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlFlush = liftMLIO cMlFlush
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlReady :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlReady = liftMLIO cMlReady
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlConnect :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlConnect = liftMLIO cMlConnect
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlEndPacket :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlEndPacket = liftMLIO cMlEndPacket
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlNextPacket :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlNextPacket = liftMLIO cMlNextPacket
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlNewPacket :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlNewPacket = liftMLIO cMlNewPacket
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetNext :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetNext = liftMLIO cMlGetNext
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetArgCount :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetArgCount = askMLink >>= liftIO . mlGetA . cMlGetArgCount
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst SchulzmlGetArgCount' :: ML Int
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst SchulzmlGetArgCount' = liftM cintToInt mlGetArgCount
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- cMlGetSymbol :: MLINK -> Ptr CString -> IO CInt
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetSymbol :: ML String
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetSymbol = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz ml <- askMLink
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz liftIO $ mlGetCString (cMlGetSymbol ml) $ cMlDisownSymbol ml
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- cMlGetString :: MLINK -> Ptr CString -> IO CInt
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetString :: ML String
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder-- mlGetString = askMLink >>= liftIO . mlGetCString . cMlGetString
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetString = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz ml <- askMLink
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz liftIO $ mlGetCString (cMlGetString ml) $ cMlDisownString ml
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- cMlGetReal :: MLINK -> Ptr CDouble -> IO CInt
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetReal :: ML CDouble
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetReal = askMLink >>= liftIO . mlGetA . cMlGetReal
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetReal' :: ML Double
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst SchulzmlGetReal' = liftM cdblToDbl mlGetReal
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- cMlGetInteger :: MLINK -> Ptr CInt -> IO CInt
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetInteger :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlGetInteger = askMLink >>= liftIO . mlGetA . cMlGetInteger
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetInteger' :: ML Int
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzmlGetInteger' = liftM cintToInt mlGetInteger
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder{- | Integers are received as strings, because the interface supports only
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroedermachine integers with fixed length not arbitrary sized integers. -}
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlGetInteger'' :: ML Integer
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzmlGetInteger'' = liftM read mlGetString
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlPutString :: String -> ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutString s = liftMLIO f where
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz f ml = withCString s $ cMlPutString ml
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlPutSymbol :: String -> ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutSymbol s = liftMLIO f where
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz f ml = withCString s $ cMlPutSymbol ml
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlPutFunction :: String -> CInt -> ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutFunction s i = liftMLIO f where
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz f ml = withCString s $ flip (cMlPutFunction ml) i
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlPutFunction' :: String -> Int -> ML CInt
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst SchulzmlPutFunction' s = mlPutFunction s . intToCInt
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlPutInteger :: CInt -> ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlPutInteger = liftMLIO . flip cMlPutInteger
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlPutInteger' :: Int -> ML CInt
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzmlPutInteger' = mlPutInteger . intToCInt
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder{- | Integers are sent as strings, because the interface supports only
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroedermachine integers with fixed length not arbitrary sized integers. -}
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlPutInteger'' :: Integer -> ML CInt
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzmlPutInteger'' i = mlPutFunction' "ToExpression" 1 >> mlPutString (show i)
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlPutReal :: CDouble -> ML CInt
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst SchulzmlPutReal = liftMLIO . flip cMlPutReal
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlPutReal' :: Double -> ML CInt
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst SchulzmlPutReal' = mlPutReal . dblToCDbl
e9f0cd6ee7be0336cfd071df0451d6282cf55d75Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlError :: ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlError = liftMLIO cMlError
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von SchroedermlErrorMessage :: ML String
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlErrorMessage = liftMLIO (cMlErrorMessage >=> peekCString)
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz-- * MathLink interface utils
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst SchulzmlProcError :: ML a
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzmlProcError = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz eid <- mlError
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz s <- if toBool eid then liftM ("Error detected by MathLink: " ++)
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz mlErrorMessage
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz else return "Error detected by Interface"
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz verbMsgMLLn 1 s
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz error $ "mlProcError: " ++ s
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzsendEvalPacket :: ML a -> ML a
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzsendEvalPacket ml = do
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz mlPutFunction "EvaluatePacket" 1
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz res <- ml
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz mlEndPacket
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz return res
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzsendTextPacket :: String -> ML ()
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst SchulzsendTextPacket s = do
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "EvaluatePacket" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "ToExpression" 1
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz mlPutString s
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz mlEndPacket
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz return ()
67f09e0fddea50c48620c011b6d001cffe565de6Ewaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextResultPacket :: String -> ML ()
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextResultPacket s = do
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "EvaluatePacket" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "ToString" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "ToExpression" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutString s
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlEndPacket
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz return ()
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
dde363c92873e122a139e2db23862dfd7d265b73Ewaryst Schulz{-
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz-- these variants does not work as expected
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextPacket' :: String -> ML ()
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextPacket' s = do
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "EnterTextPacket" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutString s
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlEndPacket
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz return ()
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextPacket'' :: String -> ML ()
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextPacket'' s = do
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "EnterExpressionPacket" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "ToExpression" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutString s
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlEndPacket
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz return ()
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextPacket3 :: String -> ML ()
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextPacket3 s = do
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "EvaluatePacket" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "ToString" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "ToExpression" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutString s
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlEndPacket
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz return ()
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextPacket4 :: String -> ML ()
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzsendTextPacket4 s = do
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "EnterExpressionPacket" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "ToString" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutFunction "ToExpression" 1
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlPutString s
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz mlEndPacket
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz return ()
dde363c92873e122a139e2db23862dfd7d265b73Ewaryst Schulz-}
7594b91154e299c9bcecd2bd62698705b55f99e8Ewaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzwaitForAnswer :: ML CInt
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzwaitForAnswer = do
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz -- skip any packets before the first ReturnPacket
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder i <- waitUntilPacket (0 :: Int) [ dfRETURNPKT, dfRETURNEXPRPKT
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz , dfRETURNTEXTPKT, dfILLEGALPKT]
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz if elem i [dfILLEGALPKT, dfRETURNEXPRPKT, dfRETURNTEXTPKT]
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz then error $ "waitForAnswer: encountered a " ++ showPKT i
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz else return i
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz-- wait for the answer and skip it
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzskipAnswer :: ML CInt
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzskipAnswer = waitForAnswer >> mlNewPacket
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst SchulzwaitUntilPacket :: Num a => a -> [CInt] -> ML CInt
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst SchulzwaitUntilPacket i l = do
a3b8d685ae08bf3f83a6c2930e872183c487c844Ewaryst Schulz np <- mlNextPacket
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz if elem np l then do
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz verbMsgMLLn 2 $ "GotReturn after " ++ show i ++ " iterations"
6c3ce177a0ad551edaae7daa17772b12f77a86daEwaryst Schulz return np
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder else verbMsgMLLn 2 ("wap: " ++ show np) >> mlNewPacket
3d3889e0cefcdce9b3f43c53aaa201943ac2e895Jonathan von Schroeder >> waitUntilPacket (i + 1) l