diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +mathlink - A Haskell package for Mathematica's MathLink + +Copyright (c) Harold Wadleigh + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/bin/env runhaskell +\begin{code} + +import Distribution.Simple.MathLink +main = mathLinkDefaultMain + +\end{code} diff --git a/examples/Setup.lhs b/examples/Setup.lhs new file mode 100644 --- /dev/null +++ b/examples/Setup.lhs @@ -0,0 +1,7 @@ +#!/bin/env runhaskell +\begin{code} + +import Distribution.Simple +main = defaultMain + +\end{code} diff --git a/examples/mltest.cabal b/examples/mltest.cabal new file mode 100644 --- /dev/null +++ b/examples/mltest.cabal @@ -0,0 +1,19 @@ +Name: mltest +Version: 0.1.0 +Cabal-Version: >= 1.2 +Build-Type: Simple +License: BSD3 +Copyright: Copyright (c) Tracy Wadleigh 2008 +Author: Tracy Wadleigh +Maintainer: +Bug-Reports: mailto:tracy.wadleigh@gmail.com?subject=mltest +Stability: experimental +Synopsis: An example of using the MathLink Haskell library + +Executable mltest + Build-Depends: base >= 4.0 && < 4.1, + mathlink >= 0.1 && < 0.2, + array >= 0.2 && < 0.3 + Hs-Source-Dirs: src + Main-Is: Main.hs + diff --git a/examples/mltest.nb b/examples/mltest.nb new file mode 100644 --- /dev/null +++ b/examples/mltest.nb @@ -0,0 +1,225 @@ +(* Content-type: application/mathematica *) + +(*** Wolfram Notebook File ***) +(* http://www.wolfram.com/nb *) + +(* CreatedBy='Mathematica 7.0' *) + +(*CacheID: 234*) +(* Internal cache information: +NotebookFileLineBreakTest +NotebookFileLineBreakTest +NotebookDataPosition[ 145, 7] +NotebookDataLength[ 6650, 216] +NotebookOptionsPosition[ 5513, 170] +NotebookOutlinePosition[ 5872, 186] +CellTagsIndexPosition[ 5829, 183] +WindowFrame->Normal*) + +(* Beginning of Notebook Content *) +Notebook[{ + +Cell[CellGroupData[{ +Cell[BoxData[ + RowBox[{"SetDirectory", "[", "\"\<~/hs/mathlink/examples/\>\"", + "]"}]], "Input", + CellChangeTimes->{{3.439309979806336*^9, 3.439310029119624*^9}, { + 3.439504790090583*^9, 3.439504790564527*^9}}], + +Cell[BoxData["\<\"/home/twadleigh/hs/mathlink/examples\"\>"], "Output", + CellChangeTimes->{{3.439504769908993*^9, 3.439504791247632*^9}, + 3.440168667032764*^9, 3.440177535376698*^9, 3.4401803149179897`*^9}] +}, Open ]], + +Cell[TextData[{ + "Wrapping the ", + StyleBox["MathLink", + FontSlant->"Italic"], + " executable in a shell script is a nice way to pass extra arguments to the \ +GHC RTS without interferring with the command line arguments that ", + StyleBox["MathLink", + FontSlant->"Italic"], + " needs to pass to establish the connection." +}], "Text", + CellChangeTimes->{{3.440168766081661*^9, 3.440168924034021*^9}}], + +Cell[CellGroupData[{ + +Cell[BoxData[ + RowBox[{"lnk", "=", + RowBox[{"Install", "[", "\"\\"", "]"}]}]], "Input", + CellChangeTimes->{{3.439310037308844*^9, 3.4393100665348454`*^9}, { + 3.4393123483575773`*^9, 3.439312353820722*^9}, {3.439313763736014*^9, + 3.439313786830782*^9}, {3.439314248568095*^9, 3.439314249330996*^9}}], + +Cell[BoxData[ + RowBox[{"LinkObject", "[", + RowBox[{"\<\"/home/twadleigh/hs/mathlink/examples/mltest.sh\"\>", ",", "8", + ",", "8"}], "]"}]], "Output", + CellChangeTimes->{3.44016866928712*^9, 3.440177537593532*^9, + 3.440177639653508*^9, 3.44017776858574*^9, 3.440178011557703*^9, + 3.440180317121654*^9}] +}, Open ]], + +Cell[CellGroupData[{ + +Cell[BoxData[ + RowBox[{"AddTwo", "[", + RowBox[{"2", ",", "3"}], "]"}]], "Input", + CellChangeTimes->{{3.43931006947751*^9, 3.43931007209233*^9}}], + +Cell[BoxData["5"], "Output", + CellChangeTimes->{3.44016867170964*^9, 3.4401775395852757`*^9, + 3.440177642067905*^9, 3.440177770296537*^9, 3.440178013081019*^9, + 3.440180318765966*^9}] +}, Open ]], + +Cell[CellGroupData[{ + +Cell[BoxData[ + RowBox[{"ReverseNumbers", "[", + RowBox[{ + "1", ",", "2", ",", "3", ",", "\[ImaginaryI]", ",", "\[ExponentialE]", ",", + "\[Pi]"}], "]"}]], "Input", + CellChangeTimes->{{3.4401687018512993`*^9, 3.440168712601337*^9}, { + 3.440180321606152*^9, 3.440180358834758*^9}}], + +Cell[BoxData[ + RowBox[{"{", + RowBox[{ + "3.141592653589793`", ",", "2.718281828459045`", ",", "0.`", ",", "3.`", + ",", "2.`", ",", "1.`"}], "}"}]], "Output", + CellChangeTimes->{ + 3.440168712981926*^9, 3.440177541747458*^9, 3.4401776436073923`*^9, + 3.440177771845735*^9, 3.4401780146157618`*^9, {3.440180323067984*^9, + 3.440180359740733*^9}}] +}, Open ]], + +Cell[CellGroupData[{ + +Cell[BoxData[ + RowBox[{"GreetWorld", "[", "]"}]], "Input", + CellChangeTimes->{{3.440168718131279*^9, 3.4401687204719067`*^9}}], + +Cell[BoxData["\<\"Hello, world!\"\>"], "Output", + CellChangeTimes->{3.4401687210248337`*^9, 3.440177543338463*^9, + 3.4401776462215652`*^9, 3.440177773588876*^9, 3.440178015619836*^9, + 3.440180378796352*^9}] +}, Open ]], + +Cell[CellGroupData[{ + +Cell[BoxData[ + RowBox[{"ReverseArray", "[", + RowBox[{"{", + RowBox[{ + RowBox[{"{", + RowBox[{"1", ",", "2", ",", "3"}], "}"}], ",", + RowBox[{"{", + RowBox[{"4", ",", "5", ",", "6"}], "}"}]}], "}"}], "]"}]], "Input", + CellChangeTimes->{{3.440168935664534*^9, 3.440168948360408*^9}}], + +Cell[BoxData[ + RowBox[{"{", + RowBox[{ + RowBox[{"{", + RowBox[{"6", ",", "5", ",", "4"}], "}"}], ",", + RowBox[{"{", + RowBox[{"3", ",", "2", ",", "1"}], "}"}]}], "}"}]], "Output", + CellChangeTimes->{3.440168948815699*^9, 3.4401775454085293`*^9, + 3.440177647824188*^9, 3.4401777759225273`*^9, 3.440178017618819*^9, + 3.4401803839453077`*^9}] +}, Open ]], + +Cell[CellGroupData[{ + +Cell[BoxData[ + RowBox[{"TweakExpression", "[", + RowBox[{"{", + RowBox[{"ASymbol", ",", "\"\\"", ",", "3", ",", + RowBox[{"N", "[", "\[Pi]", "]"}], ",", + RowBox[{"a", "+", "b", "+", "c"}]}], "}"}], "]"}]], "Input", + CellChangeTimes->{{3.440177547780761*^9, 3.440177550781266*^9}, { + 3.44017765139118*^9, 3.440177724259131*^9}, {3.440177844791916*^9, + 3.440177845556456*^9}, {3.440178025829589*^9, 3.440178050101166*^9}}], + +Cell[BoxData[ + RowBox[{"tsiL", "[", + RowBox[{"lobmySA", ",", "\<\"gnirts A\"\>", ",", + RowBox[{"-", "3"}], ",", + RowBox[{"-", "3.141592653589793`"}], ",", + RowBox[{"sulP", "[", + RowBox[{"a", ",", "b", ",", "c"}], "]"}]}], "]"}]], "Output", + CellChangeTimes->{ + 3.4401777251469917`*^9, 3.440177777974738*^9, 3.4401778462290287`*^9, { + 3.4401780196886597`*^9, 3.440178050944537*^9}, 3.440180387144931*^9}] +}, Open ]], + +Cell[CellGroupData[{ + +Cell[BoxData[ + RowBox[{"Uninstall", "[", "lnk", "]"}]], "Input", + CellChangeTimes->{{3.439313773653487*^9, 3.439313777607768*^9}}], + +Cell[BoxData["\<\"/home/twadleigh/hs/mathlink/examples/mltest.sh\"\>"], \ +"Output", + CellChangeTimes->{3.440168967229312*^9, 3.440177561117154*^9, + 3.440177755031232*^9, 3.440177984565681*^9, 3.4401780921022263`*^9, + 3.440180388638576*^9}] +}, Open ]] +}, +WindowSize->{1590, 1102}, +WindowMargins->{{0, Automatic}, {Automatic, 27}}, +ShowSelection->True, +FrontEndVersion->"7.0 for Linux x86 (64-bit) (November 11, 2008)", +StyleDefinitions->"Default.nb" +] +(* End of Notebook Content *) + +(* Internal cache information *) +(*CellTagsOutline +CellTagsIndex->{} +*) +(*CellTagsIndex +CellTagsIndex->{} +*) +(*NotebookFileOutline +Notebook[{ +Cell[CellGroupData[{ +Cell[567, 22, 213, 4, 61, "Input"], +Cell[783, 28, 209, 2, 88, "Output"] +}, Open ]], +Cell[1007, 33, 398, 10, 96, "Text"], +Cell[CellGroupData[{ +Cell[1430, 47, 315, 5, 61, "Input"], +Cell[1748, 54, 310, 6, 88, "Output"] +}, Open ]], +Cell[CellGroupData[{ +Cell[2095, 65, 146, 3, 61, "Input"], +Cell[2244, 70, 187, 3, 88, "Output"] +}, Open ]], +Cell[CellGroupData[{ +Cell[2468, 78, 284, 6, 61, "Input"], +Cell[2755, 86, 353, 8, 88, "Output"] +}, Open ]], +Cell[CellGroupData[{ +Cell[3145, 99, 126, 2, 61, "Input"], +Cell[3274, 103, 210, 3, 88, "Output"] +}, Open ]], +Cell[CellGroupData[{ +Cell[3521, 111, 300, 8, 61, "Input"], +Cell[3824, 121, 355, 9, 88, "Output"] +}, Open ]], +Cell[CellGroupData[{ +Cell[4216, 135, 444, 8, 61, "Input"], +Cell[4663, 145, 421, 9, 88, "Output"] +}, Open ]], +Cell[CellGroupData[{ +Cell[5121, 159, 130, 2, 88, "Input"], +Cell[5254, 163, 243, 4, 88, "Output"] +}, Open ]] +} +] +*) + +(* End of internal cache information *) diff --git a/examples/mltest.sh b/examples/mltest.sh new file mode 100644 --- /dev/null +++ b/examples/mltest.sh @@ -0,0 +1,2 @@ +#! /usr/bin/env sh +dist/build/mltest/mltest $@ +RTS -K1G -RTS 1> mltest.out 2> mltest.err diff --git a/examples/src/Main.hs b/examples/src/Main.hs new file mode 100644 --- /dev/null +++ b/examples/src/Main.hs @@ -0,0 +1,119 @@ +{-# OPTIONS_GHC -O #-} +{- The -O option is necessary to get the rewrite rules which use more + efficient marshaling for certain types of lists to fire. According + to the GHC documentation, it should be sufficient to set + -fenable-rewrite-rules, but this didn't work in the test cases I + examined, while -O (which implies -fenable-rewrite-rules) did. + + In the case of 'String,' there is not just an efficiency difference, + but a semantic one, as well. Without the rule rewrite, the string is + marshaled out as a list of characters, which yields a list of single- + character strings on the Mathematica side (and probably breaks when + trying a get). In the absence of the rewrite rules for strings, + there are two alternatives: (1) marshal strings as a generic + Expression (or part of an expression), or, for just a single string + in isolation you can (2) use the putString/getString exported from + the Expressible module. +-} + +module Main where + +import Foreign.MathLink +import Data.Array.Unboxed + +-- Example 1: get a pair of integers and return their sum. +addTwo :: ML () +addTwo = do + (m1,m2) <- get + put ((m1 + m2) :: Int) + +-- callPattern <=> mprep's :Pattern: directive +-- argumentPattern <=> mprep's :Arguments: directive +-- Note that, in argumentPattern, the desired 2-tuple of integers +-- is represented as a Mathematica list of length 2. +addTwoAction = + Action { callPattern = "AddTwo[i_Integer,j_Integer]" + , argumentPattern = "{i,j}" + , action = addTwo + } + +-- Example 2: reverse a list of numbers (coercing them to Doubles). +reverseNumbers :: ML () +reverseNumbers = do + is <- get + put $ reverse (is :: [Double]) + +-- Like tuples, lists are represented on the Mathematica side as +-- lists, but of arbitrary length. Here, the Mathematica pattern +-- would accept a list of zero or more numeric values. +-- Notice that argumentPattern provides some preprocessing on the +-- arguments, taking its real part and coercing the values to +-- machine precision. This trick allows for a callPattern that +-- matches more expressions, while still ensuring that on the +-- Haskell side, the arguments have the desired, more specific, +-- form when marshaled. +reverseNumbersAction = + Action { callPattern = "ReverseNumbers[is___?NumericQ]" + , argumentPattern = "N[Re[{is}]]" + , action = reverseNumbers + } + +-- Example 3: put a string. +-- It's a good test to see if the rewrite rules are firing: if the +-- rule fired, you should see a single string in Mathematica, +-- otherwise, a list of single-character strings. +greetWorld :: ML () +greetWorld = do + put "Hello, world!" + +greetWorldAction = + Action { callPattern = "GreetWorld[]" + , argumentPattern = "" + , action = greetWorld + } + +-- Example 4: get and put a 2D array, reversing its contents. +-- NB: When marshaling in an array, make sure that you test for the +-- array rank in callPattern to match that expected on the Haskell +-- side, as below. Otherwise, you're likely to have the underlying +-- call to fromDimensions raise an error that halts the program. +reverseArray :: ML () +reverseArray = do + arr <- get + let xs = elems (arr :: UArray (Int,Int) Int) + put $ ((listArray (bounds arr) $ reverse xs) :: UArray (Int,Int) Int) + +reverseArrayAction = + Action { callPattern = "ReverseArray[a_?(ArrayQ[#,2,IntegerQ]&)]" + , argumentPattern = "a" + , action = reverseArray + } + +-- Example 5: gets an arbitrary Mathematica expression and returns +-- a tweaked version of it. +tweakExpression :: ML () +tweakExpression = do + expr <- get + put $ tweak expr + where tweak ex = + case ex of + ExInt i -> ExInt (-i) + ExReal r -> ExReal (-r) + ExString s -> ExString $ reverse s + ExSymbol s -> ExSymbol $ reverse s + ExFunction hd args -> ExFunction (reverse hd) $ map tweak args + +tweakExpressionAction = + Action { callPattern = "TweakExpression[expr_]" + , argumentPattern = "expr" + , action = tweakExpression + } + +-- run mathlink exposing the given list of actions +main = runMathLink [ addTwoAction + , reverseNumbersAction + , greetWorldAction + , reverseArrayAction + , tweakExpressionAction + ] + diff --git a/mathlink.cabal b/mathlink.cabal new file mode 100644 --- /dev/null +++ b/mathlink.cabal @@ -0,0 +1,52 @@ +Name: mathlink +Version: 0.1.0.0 +Cabal-Version: >= 1.2 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Copyright: Copyright (c) Tracy Wadleigh 2008, 2009 +Author: Tracy Wadleigh +Maintainer: +Bug-Reports: mailto:tracy.wadleigh@gmail.com?subject=dev-mathlink +Stability: experimental +Synopsis: A library for Mathematica's MathLink +Tested-With: GHC == 6.10.1 +Category: Foreign +Extra-Source-Files: examples/mltest.cabal + examples/src/Main.hs + examples/Setup.lhs + examples/mltest.nb + examples/mltest.sh + +Description: { +Provides a simple way to expose Haskell functions to /Mathematica/ via the +/MathLink/ interface. One defines a Haskell function of type @ML ()@ (a +'Monad' built on top of 'IO') and provides a pair of 'String's that +function analogously to the @:Pattern:@ and @:Arguments:@ directives for +/Mathematica/'s @mprep@ utility. Data can be marshaled either as an +'Expression' or, more generally, as an instance of the 'Expressible' class. +The library does not use or require @foreign export@ declarations, so may +be used interactively. +} + +Flag 32Bit + Description: Build and link against the 32-bit version of the + MathLink library, instead of the 64-bt version. + Default: False + +Library + Hs-Source-Dirs: src + Build-Depends: base >= 4.0 && < 4.1, + containers >= 0.2 && < 0.3, + mtl >= 1.1.0.2 && < 1.2, + array >= 0.2 && < 0.3 + Exposed-Modules: Foreign.MathLink, + Foreign.MathLink.IO, + Foreign.MathLink.ML, + Foreign.MathLink.Types, + Foreign.MathLink.Expressible + if arch(i386) || flag(32bit) + Extra-Libraries: ML32i3 + else + Extra-Libraries: ML64i3 + diff --git a/src/Foreign/MathLink.hs b/src/Foreign/MathLink.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/MathLink.hs @@ -0,0 +1,86 @@ +-- | A Haskell interface to /Mathematica/'s /MathLink/. +module Foreign.MathLink ( +-- * Basic 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 :: 'ML' () +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 @'ML' ()@. In its body it uses +the 'get' method 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. +-} + + -- * Known limitations + + -- ** No out-of-band messaging + + {- | So, /e.g./, you cannot abort a calculation. An initial +implementation of this was working, but not always reliably, so it was +removed, to be added back in a coming revision, hopefully. +-} + +-- ** @'Expressible' 'String'@ needs rewrite rules + +{- | On Haskell systems without rewrite rules (or when they are not +used, as, /e.g./, is the case by default in GHC), the 'Expressible' +instance for 'String' is broken. To make sure that the rules always fire +with GHC, you can, for instance, include the @OPTIONS_GHC -O@ pragma at +the top of your source file. Without using the rewrite rules, two simple +workarounds exist. Firstly, if you only need to marshal a single string, +you can use the 'getString' and 'putString' functions. More generally, +you can marshal the string as a value of type 'Expression' by wrapping +it in the 'ExString' constructor. +-} + +-- ** Untested across platforms + +{- | The author developed the library on a 64-bit Linux platform with +GHC 6.10.1 and /Mathematica/ 7. However, among the author's design goals +is that the library be useful for: + + (1) any Haskell system with modest language extensions beyond the + 98 standard and implementing the FFI addendum; + + (2) any version of /Mathematica/ supporting version 3 of the + /MathLink/ interface; + + (3) any 32-bit or 64-bit OS. + +Please report any failures in this regard, (or, better yet, send a patch!) +and the author will make an effort (time, patience, and resources +permitting) to bring the library closer to its stated goal, or at least +to explicitly document the limitation in a future release. +-} + + module Foreign.MathLink.Types + , module Foreign.MathLink.ML + , module Foreign.MathLink.Expressible + + ) where + +import Foreign.MathLink.Types +import Foreign.MathLink.ML +import Foreign.MathLink.Expressible diff --git a/src/Foreign/MathLink/Expressible.hs b/src/Foreign/MathLink/Expressible.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/MathLink/Expressible.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE FlexibleInstances #-} + +module Foreign.MathLink.Expressible ( putString + , getString + , putInt16List + , getInt16List + , putInt32List + , getInt32List + , putIntList + , getIntList + , putReal32List + , getReal32List + , putReal64List + , getReal64List + ) where + +import Foreign +import Foreign.Storable +import Foreign.C +import Data.Int +import Data.Ix +import Control.Monad.Error +import Control.Exception (bracket) +import qualified Foreign.MathLink.IO as MLIO +import Foreign.MathLink.Types +import Foreign.MathLink.ML +import qualified Data.Array.Unboxed as A + +instance Expressible Char where + -- Note: this instance really shouldn't be used. It exists only to ensure + -- that 'String' is an instance of Expressible. The specialization rules + -- for lists should obviate its use in a 'String' context. + put c = putStringWith MLIO.mlPutString [c] + get = getStringWith MLIO.mlGetString MLIO.mlReleaseString >>= (return . head) + +instance Expressible Int16 where + put = putScalarWith MLIO.mlPutInt16 fromIntegral + get = getScalarWith MLIO.mlGetInt16 fromIntegral + +instance Expressible Int32 where + put = putScalarWith MLIO.mlPutInt32 fromIntegral + get = getScalarWith MLIO.mlGetInt32 fromIntegral + +instance Expressible Int where + put = putScalarWith MLIO.mlPutInt fromIntegral + get = getScalarWith MLIO.mlGetInt fromIntegral + +instance Expressible Float where + put = putScalarWith MLIO.mlPutReal32 realToFrac + get = getScalarWith MLIO.mlGetReal32 realToFrac + +instance Expressible Double where + put = putScalarWith MLIO.mlPutReal64 realToFrac + get = getScalarWith MLIO.mlGetReal64 realToFrac + +checkFnHead :: (String -> Bool) + -> (Int -> Bool) + -> (String,Int) + -> ML (String,Int) +checkFnHead hdPred nArgPred pr@(hd,nArgs) = + case (hdPred hd, nArgPred nArgs) of + (False,_) -> + throwError $ "Unexpected head '" ++ hd ++ "'." + (_,False) -> + throwError $ "Unexpected number of arguments: " ++ show nArgs ++ "." + _ -> return pr + +instance ( Expressible e1 + , Expressible e2 + ) => Expressible (e1,e2) where + put (ex1,ex2) = do + putFunctionHead "List" 2 + put ex1 + put ex2 + get = do + (hd,nArgs) <- getFunctionHead >>= checkFnHead (== "List") (== 2) + ex1 <- get + ex2 <- get + return (ex1,ex2) + +instance ( Expressible e1 + , Expressible e2 + , Expressible e3 + ) => Expressible (e1,e2,e3) where + put (ex1,ex2,ex3) = do + putFunctionHead "List" 3 + put ex1 + put ex2 + put ex3 + get = do + (hd,nArgs) <- getFunctionHead >>= checkFnHead (== "List") (== 3) + ex1 <- get + ex2 <- get + ex3 <- get + return (ex1,ex2,ex3) + +instance ( Expressible e1 + , Expressible e2 + , Expressible e3 + , Expressible e4 + ) => Expressible (e1,e2,e3,e4) where + put (ex1,ex2,ex3,ex4) = do + putFunctionHead "List" 4 + put ex1 + put ex2 + put ex3 + put ex4 + get = do + (hd,nArgs) <- getFunctionHead >>= checkFnHead (== "List") (== 4) + ex1 <- get + ex2 <- get + ex3 <- get + ex4 <- get + return (ex1,ex2,ex3,ex4) + +instance ( Expressible e1 + , Expressible e2 + , Expressible e3 + , Expressible e4 + , Expressible e5 + ) => Expressible (e1,e2,e3,e4,e5) where + put (ex1,ex2,ex3,ex4,ex5) = do + putFunctionHead "List" 5 + put ex1 + put ex2 + put ex3 + put ex4 + put ex5 + get = do + (hd,nArgs) <- getFunctionHead >>= checkFnHead (== "List") (== 5) + ex1 <- get + ex2 <- get + ex3 <- get + ex4 <- get + ex5 <- get + return (ex1,ex2,ex3,ex4,ex5) + +instance ( Expressible e1 + , Expressible e2 + , Expressible e3 + , Expressible e4 + , Expressible e5 + , Expressible e6 + ) => Expressible (e1,e2,e3,e4,e5,e6) where + put (ex1,ex2,ex3,ex4,ex5,ex6) = do + putFunctionHead "List" 6 + put ex1 + put ex2 + put ex3 + put ex4 + put ex5 + put ex6 + get = do + (hd,nArgs) <- getFunctionHead >>= checkFnHead (== "List") (== 6) + ex1 <- get + ex2 <- get + ex3 <- get + ex4 <- get + ex5 <- get + ex6 <- get + return (ex1,ex2,ex3,ex4,ex5,ex6) + +instance ( Expressible e1 + , Expressible e2 + , Expressible e3 + , Expressible e4 + , Expressible e5 + , Expressible e6 + , Expressible e7 + ) => Expressible (e1,e2,e3,e4,e5,e6,e7) where + put (ex1,ex2,ex3,ex4,ex5,ex6,ex7) = do + putFunctionHead "List" 7 + put ex1 + put ex2 + put ex3 + put ex4 + put ex5 + put ex6 + put ex7 + get = do + (hd,nArgs) <- getFunctionHead >>= checkFnHead (== "List") (== 7) + ex1 <- get + ex2 <- get + ex3 <- get + ex4 <- get + ex5 <- get + ex6 <- get + ex7 <- get + return (ex1,ex2,ex3,ex4,ex5,ex6,ex7) + +instance Expressible e => Expressible [e] where + put es = do + putFunctionHead "List" (length es) + mapM_ put es + get = do + (hd,nArgs) <- getFunctionHead >>= checkFnHead (== "List") (const True) + mapM id $ take nArgs $ repeat get + +{-# RULES "put/String" put = putString #-} +{-# RULES "get/String" get = getString #-} +{-# RULES "put/[Int]" put = putIntList #-} +{-# RULES "get/[Int]" get = getIntList #-} +{-# RULES "put/[Int16]" put = putInt16List #-} +{-# RULES "get/[Int16]" get = getInt16List #-} +{-# RULES "put/[Int32]" put = putInt32List #-} +{-# RULES "get/[Int32]" get = getInt32List #-} +{-# RULES "put/[Float]" put = putReal32List #-} +{-# RULES "get/[Float]" get = getReal32List #-} +{-# RULES "put/[Double]" put = putReal64List #-} +{-# RULES "get/[Double]" get = getReal64List #-} + +putListWith :: Storable a + => (Link -> Ptr a -> CInt -> IO CInt) + -> (b -> a) + -> [b] + -> ML () +putListWith fn cnv xs = do + l <- getLink + liftIO (withArray (map cnv xs) $ \xPtr -> fn l xPtr n) >>= throwOnError + where n = fromIntegral $ length xs + +getListWith :: Storable a + => (Link -> Ptr (Ptr a) -> Ptr CInt -> IO CInt) + -> (Link -> Ptr a -> CInt -> IO CInt) + -> (a -> b) + -> ML [b] +getListWith afn rfn cnv = do + l <- getLink + eXs <- liftIO $ bracket malloc free $ \xPtrPtr -> + bracket malloc free $ \nPtr -> do + bXs <- afn l xPtrPtr nPtr >>= MLIO.convToBool + if bXs then do + xPtr <- peek xPtrPtr + n <- peek nPtr + xs <- peekArray (fromIntegral n) xPtr + rfn l xPtr n + return $ Right (map cnv xs) + else + MLIO.getErrorMessage l >>= (return . Left) + case eXs of + Left err -> throwError err + Right xs -> return xs + +putString :: String -> ML () +putString = putStringWith MLIO.mlPutString + +getString :: ML String +getString = getStringWith MLIO.mlGetString MLIO.mlReleaseString + +putIntList :: [Int] -> ML () +putIntList = putListWith MLIO.mlPutIntList fromIntegral + +getIntList :: ML [Int] +getIntList = getListWith MLIO.mlGetIntList MLIO.mlReleaseIntList fromIntegral + +putInt16List :: [Int16] -> ML () +putInt16List = putListWith MLIO.mlPutInt16List fromIntegral + +getInt16List :: ML [Int16] +getInt16List = getListWith MLIO.mlGetInt16List MLIO.mlReleaseInt16List fromIntegral + +putInt32List :: [Int32] -> ML () +putInt32List = putListWith MLIO.mlPutInt32List fromIntegral + +getInt32List :: ML [Int32] +getInt32List = getListWith MLIO.mlGetInt32List MLIO.mlReleaseInt32List fromIntegral + +putReal32List :: [Float] -> ML () +putReal32List = putListWith MLIO.mlPutReal32List realToFrac + +getReal32List :: ML [Float] +getReal32List = getListWith MLIO.mlGetReal32List MLIO.mlReleaseReal32List realToFrac + +putReal64List :: [Double] -> ML () +putReal64List = putListWith MLIO.mlPutReal64List realToFrac + +getReal64List :: ML [Double] +getReal64List = getListWith MLIO.mlGetReal64List MLIO.mlReleaseReal64List realToFrac + +putArrayWith :: Storable a + => (Link -> Ptr a -> Ptr CInt -> Ptr CString -> CInt -> IO CInt) + -> (b -> a) + -> [Int] + -> [b] + -> ML () +putArrayWith fn cnv dims xs = do + l <- getLink + (liftIO $ withArray (take sz (map cnv xs)) $ \xPtr -> + withArray (map fromIntegral dims) $ \dimPtr -> + withCString "List" $ \strPtr -> + withArray (take rank (repeat strPtr)) $ \hdsPtr -> + fn l xPtr dimPtr hdsPtr (fromIntegral rank)) >>= throwOnError + where rank = length dims + sz = product dims + +getArrayWith :: Storable a + => (Link -> Ptr (Ptr a) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt) + -> (Link -> Ptr a -> Ptr CInt -> Ptr CString -> CInt -> IO ()) + -> (a -> b) + -> ML ([Int],[b]) +getArrayWith afn rfn cnv = do + l <- getLink + mArr <- liftIO $ bracket malloc free $ \xPtrPtr -> + bracket malloc free $ \dimPtrPtr -> + bracket malloc free $ \headPtrPtr -> + bracket malloc free $ \rankPtr -> do + bAry <- afn l xPtrPtr dimPtrPtr headPtrPtr rankPtr >>= MLIO.convToBool + if bAry then do + rank' <- peek rankPtr + let rank = fromIntegral rank' + dimPtr <- peek dimPtrPtr + dims' <- peekArray rank dimPtr + let dims = map fromIntegral dims' + sz = product dims + xPtr <- peek xPtrPtr + xs' <- peekArray sz xPtr + headPtr <- peek headPtrPtr + rfn l xPtr dimPtr headPtr rank' + return $ Right (dims, map cnv xs') + else + MLIO.getErrorMessage l >>= (return . Left) + case mArr of + Left err -> throwError err + Right arr -> return arr + +instance Dimensional Int where + rank _ = 1 + dimensions bnds = [rangeSize bnds] + fromDimensions [n] = (1,n) + fromDimensions _ = error "Unexpected number of dimensions." + +instance Dimensional (Int,Int) where + rank _ = 2 + dimensions ((l1,l2),(u1,u2)) = + dimensions (l1,u1) ++ dimensions (l2,u2) + fromDimensions [n1,n2] = ((l1,l2),(u1,u2)) + where (l1,u1) = fromDimensions [n1] + (l2,u2) = fromDimensions [n2] + fromDimensions _ = error "Unexpected number of dimensions." + +instance Dimensional (Int,Int,Int) where + rank _ = 3 + dimensions ((l1,l2,l3),(u1,u2,u3)) = + dimensions (l1,u1) ++ + dimensions (l2,u2) ++ + dimensions (l3,u3) + fromDimensions [n1,n2,n3] = ((l1,l2,l3),(u1,u2,u3)) + where (l1,u1) = fromDimensions [n1] + (l2,u2) = fromDimensions [n2] + (l3,u3) = fromDimensions [n3] + fromDimensions _ = error "Unexpected number of dimensions." + +instance Dimensional (Int,Int,Int,Int) where + rank _ = 4 + dimensions ((l1,l2,l3,l4),(u1,u2,u3,u4)) = + dimensions (l1,u1) ++ + dimensions (l2,u2) ++ + dimensions (l3,u3) ++ + dimensions (l4,u4) + fromDimensions [n1,n2,n3,n4] = ((l1,l2,l3,l4),(u1,u2,u3,u4)) + where (l1,u1) = fromDimensions [n1] + (l2,u2) = fromDimensions [n2] + (l3,u3) = fromDimensions [n3] + (l4,u4) = fromDimensions [n4] + fromDimensions _ = error "Unexpected number of dimensions." + +instance Dimensional (Int,Int,Int,Int,Int) where + rank _ = 5 + dimensions ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = + dimensions (l1,u1) ++ + dimensions (l2,u2) ++ + dimensions (l3,u3) ++ + dimensions (l4,u4) ++ + dimensions (l5,u5) + fromDimensions [n1,n2,n3,n4,n5] = ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) + where (l1,u1) = fromDimensions [n1] + (l2,u2) = fromDimensions [n2] + (l3,u3) = fromDimensions [n3] + (l4,u4) = fromDimensions [n4] + (l5,u5) = fromDimensions [n5] + fromDimensions _ = error "Unexpected number of dimensions." + +instance ( Dimensional ix + ) => Expressible (A.UArray ix Int16) where + put arr = putArrayWith MLIO.mlPutInt16Array fromIntegral dims xs + where dims = dimensions $ A.bounds arr + xs = A.elems arr + get = do + (dims,xs) <- getArrayWith MLIO.mlGetInt16Array MLIO.mlReleaseInt16Array fromIntegral + return $ A.listArray (fromDimensions dims) xs + +instance ( Dimensional ix + ) => Expressible (A.UArray ix Int32) where + put arr = putArrayWith MLIO.mlPutInt32Array fromIntegral dims xs + where dims = dimensions $ A.bounds arr + xs = A.elems arr + get = do + (dims,xs) <- getArrayWith MLIO.mlGetInt32Array MLIO.mlReleaseInt32Array fromIntegral + return $ A.listArray (fromDimensions dims) xs + +instance ( Dimensional ix + ) => Expressible (A.UArray ix Int) where + put arr = putArrayWith MLIO.mlPutIntArray fromIntegral dims xs + where dims = dimensions $ A.bounds arr + xs = A.elems arr + get = do + (dims,xs) <- getArrayWith MLIO.mlGetIntArray MLIO.mlReleaseIntArray fromIntegral + return $ A.listArray (fromDimensions dims) xs + +instance ( Dimensional ix + ) => Expressible (A.UArray ix Float) where + put arr = putArrayWith MLIO.mlPutReal32Array realToFrac dims xs + where dims = dimensions $ A.bounds arr + xs = A.elems arr + get = do + (dims,xs) <- getArrayWith MLIO.mlGetReal32Array MLIO.mlReleaseReal32Array realToFrac + return $ A.listArray (fromDimensions dims) xs + +instance ( Dimensional ix + ) => Expressible (A.UArray ix Double) where + put arr = putArrayWith MLIO.mlPutReal64Array realToFrac dims xs + where dims = dimensions $ A.bounds arr + xs = A.elems arr + get = do + (dims,xs) <- getArrayWith MLIO.mlGetReal64Array MLIO.mlReleaseReal64Array realToFrac + return $ A.listArray (fromDimensions dims) xs diff --git a/src/Foreign/MathLink/IO.hs b/src/Foreign/MathLink/IO.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/MathLink/IO.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + +module Foreign.MathLink.IO ( acquireEnvironment + , acquireLink + , releaseEnvironment + , releaseLink + , activate + , flush + , checkReady + , getError + , clearError + , getErrorMessage + , convToBool + , valueOrErrorMsg + , getPacket + , endPacket + , newPacket + , getMessage + , putMessage + , checkMessage + , transferExpression + , mlGetNext + , mlGetType + , mlTestHead + , mlPutInt16 + , mlGetInt16 + , mlPutInt32 + , mlGetInt32 + , mlPutInt + , mlGetInt + , mlPutReal32 + , mlGetReal32 + , mlPutReal64 + , mlGetReal64 + , mlPutInt16List + , mlGetInt16List + , mlReleaseInt16List + , mlPutInt32List + , mlGetInt32List + , mlReleaseInt32List + , mlPutIntList + , mlGetIntList + , mlReleaseIntList + , mlPutReal32List + , mlGetReal32List + , mlReleaseReal32List + , mlPutReal64List + , mlGetReal64List + , mlReleaseReal64List + , mlPutInt16Array + , mlGetInt16Array + , mlReleaseInt16Array + , mlPutInt32Array + , mlGetInt32Array + , mlReleaseInt32Array + , mlPutIntArray + , mlGetIntArray + , mlReleaseIntArray + , mlPutReal32Array + , mlGetReal32Array + , mlReleaseReal32Array + , mlPutReal64Array + , mlGetReal64Array + , mlReleaseReal64Array + , mlPutString + , mlGetString + , mlReleaseString + , mlPutSymbol + , mlGetSymbol + , mlReleaseSymbol + , mlPutFunction + , mlGetFunction + ) where + +import Foreign +import Foreign.C +import Foreign.MathLink.Types +import Control.Exception +import Control.Monad (liftM) + + +-- decide which size of C int to use +#if (HS_INT_MIN >= __INT32_MIN) && (HS_INT_MAX <= __INT32_MAX) +# define USE_INT32 +#elif (HS_INT_MIN >= __INT64_MIN) && (HS_INT_MAX <= __INT64_MAX) +# define USE_INT64 +#else +# error "Unexpected size of Int." +#endif + + +-- initialization / termination + +foreign import ccall safe "mathlink.h MLInitialize" mlInitialize + :: Ptr () -> IO Environment + +acquireEnvironment :: IO Environment +acquireEnvironment = do + env@(Environment ptr) <- mlInitialize nullPtr + if ptr == nullPtr then + error "Unable to initialize MathLink environment." + else + return env + +foreign import ccall safe "mathlink.h MLOpenString" mlOpenString + :: Environment -> CString -> Ptr CInt -> IO Link + +foreign import ccall safe "mathlink.h MLErrorString" mlErrorString + :: Environment -> CLong -> IO CString + +acquireLink :: Environment -> [String] -> IO Link +acquireLink env args = do + (lnk@(Link ptr),err) <- withCString (unwords args) $ \argPtr -> + bracket malloc free $ \errPtr -> do + l <- mlOpenString env argPtr errPtr + e <- peek errPtr + return (l,e) + if ptr == nullPtr || err /= 0 then + mlErrorString env (fromIntegral err) >>= peekCString >>= error + else + return lnk + +foreign import ccall safe "mathlink.h MLClose" mlClose + :: Link -> IO () + +releaseLink :: Link -> IO () +releaseLink = mlClose + +foreign import ccall safe "mathlink.h MLDeinitialize" mlDeinitialize + :: Environment -> IO () + +releaseEnvironment :: Environment -> IO () +releaseEnvironment = mlDeinitialize + +foreign import ccall safe "mathlink.h MLActivate" mlActivate + :: Link -> IO CInt + +activate :: Link -> IO Bool +activate l = mlActivate l >>= convToBool + +foreign import ccall safe "mathlink.h MLFlush" mlFlush + :: Link -> IO CInt + +flush :: Link -> IO Bool +flush l = mlFlush l >>= convToBool + +foreign import ccall safe "mathlink.h MLReady" mlReady + :: Link -> IO CInt + +checkReady :: Link -> IO Bool +checkReady l = mlReady l >>= convToBool + + +-- errors + +foreign import ccall safe "mathlink.h MLError" mlError + :: Link -> IO CInt + +getError :: Link -> IO Error +getError l = mlError l >>= (return . toEnum . fromIntegral) + +convToBool :: Integral a => a -> IO Bool +convToBool = return . (/= 0) + +foreign import ccall safe "mathlink.h MLClearError" mlClearError + :: Link -> IO CInt + +clearError :: Link -> IO Bool +clearError l = mlClearError l >>= convToBool + +foreign import ccall safe "mathlink.h MLErrorMessage" mlErrorMessage + :: Link -> IO CString + +getErrorMessage :: Link -> IO String +getErrorMessage l = mlErrorMessage l >>= peekCString + +valueOrErrorMsg :: Integral a => Link -> b -> a -> IO (Either String b) +valueOrErrorMsg l val i = + if i /= 0 then + return $ Right val + else + getErrorMessage l >>= (return . Left) + + +-- packets + +foreign import ccall safe "mathlink.h MLNextPacket" mlNextPacket + :: Link -> IO CInt + +getPacket :: Link -> IO Packet +getPacket l = mlNextPacket l >>= (return . toEnum . fromIntegral) + +foreign import ccall safe "mathlink.h MLEndPacket" mlEndPacket + :: Link -> IO CInt + +endPacket :: Link -> IO Bool +endPacket l = mlEndPacket l >>= convToBool + +foreign import ccall safe "mathlink.h MLNewPacket" mlNewPacket + :: Link -> IO CInt + +newPacket :: Link -> IO Bool +newPacket l = mlNewPacket l >>= convToBool + + +-- messages + +foreign import ccall safe "mathlink.h MLGetMessage" mlGetMessage + :: Link -> Ptr CInt -> Ptr CInt -> IO CInt + +getMessage :: Link -> IO (Maybe (Message,Int)) +getMessage l = + bracket malloc free $ \mPtr -> + bracket malloc free $ \aPtr -> do + present <- mlGetMessage l mPtr aPtr >>= convToBool + if present then do + msgId <- peek mPtr + arg <- peek aPtr + return $ Just (mkMessage msgId, fromIntegral arg) + else + return Nothing + +foreign import ccall safe "mathlink.h MLPutMessage" mlPutMessage + :: Link -> CInt -> IO CInt + +putMessage :: Link -> Message -> IO Bool +putMessage l m = mlPutMessage l (fromIntegral $ fromEnum m) >>= convToBool + +foreign import ccall safe "mathlink.h MLMessageReady" mlMessageReady + :: Link -> IO CInt + +checkMessage :: Link -> IO Bool +checkMessage l = mlMessageReady l >>= convToBool + + -- misc + +foreign import ccall safe "mathlink.h MLTransferExpression" mlTransferExpression + :: Link -> Link -> IO CInt + +transferExpression :: Link -> Link -> IO Bool +transferExpression l1 l2 = mlTransferExpression l1 l2 >>= convToBool + + +-- puts + +foreign import ccall safe "mathlink.h MLPutInteger16" mlPutInt16 + :: Link -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLPutInteger32" mlPutInt32 + :: Link -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLPutInteger64" mlPutInt64 + :: Link -> CLong -> IO CInt + +#ifdef USE_INT32 +mlPutInt = mlPutInt32 +#elif defined USE_INT64 +mlPutInt = mlPutInt64 +#endif + +foreign import ccall safe "mathlink.h MLPutReal32" mlPutReal32 + :: Link -> CFloat -> IO CInt + +foreign import ccall safe "mathlink.h MLPutReal64" mlPutReal64 + :: Link -> CDouble -> IO CInt + +foreign import ccall safe "mathlink.h MLPutString" mlPutString + :: Link -> CString -> IO CInt + +foreign import ccall safe "mathlink.h MLPutSymbol" mlPutSymbol + :: Link -> CString -> IO CInt + +foreign import ccall safe "mathlink.h MLPutFunction" mlPutFunction + :: Link -> CString -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLPutInteger16List" mlPutInt16List + :: Link -> Ptr CShort -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLPutInteger32List" mlPutInt32List + :: Link -> Ptr CInt -> CInt -> IO CInt + +#ifdef USE_INT32 +mlPutIntList + :: Link -> Ptr CInt -> CInt -> IO CInt +mlPutIntList = mlPutInt32List +#elif defined USE_INT64 +foreign import ccall safe "mathlink.h MLPutInteger64List" mlPutIntList + :: Link -> Ptr CLong -> CInt -> IO CInt +#endif + +foreign import ccall safe "mathlink.h MLPutReal32List" mlPutReal32List + :: Link -> Ptr CFloat -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLPutReal64List" mlPutReal64List + :: Link -> Ptr CDouble -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLPutInteger16Array" mlPutInt16Array + :: Link -> Ptr CShort -> Ptr CInt -> Ptr CString -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLPutInteger32Array" mlPutInt32Array + :: Link -> Ptr CInt -> Ptr CInt -> Ptr CString -> CInt -> IO CInt + +#ifdef USE_INT32 +mlPutIntArray + :: Link -> Ptr CInt -> Ptr CInt -> Ptr CString -> CInt -> IO CInt +mlPutIntArray = mlPutInt32Array +#elif defined USE_INT64 +foreign import ccall safe "mathlink.h MLPutInteger64Array" mlPutIntArray + :: Link -> Ptr CLong -> Ptr CInt -> Ptr CString -> CInt -> IO CInt +#endif + +foreign import ccall safe "mathlink.h MLPutReal32Array" mlPutReal32Array + :: Link -> Ptr CFloat -> Ptr CInt -> Ptr CString -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLPutReal64Array" mlPutReal64Array + :: Link -> Ptr CDouble -> Ptr CInt -> Ptr CString -> CInt -> IO CInt + + +-- gets + +foreign import ccall safe "mathlink.h MLGetNext" mlGetNext + :: Link -> IO CInt + +foreign import ccall safe "mathlink.h MLGetType" mlGetType + :: Link -> IO CInt + +foreign import ccall safe "mathlink.h MLGetInteger16" mlGetInt16 + :: Link -> Ptr CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLGetInteger32" mlGetInt32 + :: Link -> Ptr CInt -> IO CInt + +#ifdef USE_INT32 +mlGetInt + :: Link -> Ptr CInt -> IO CInt +mlGetInt = mlGetInt32 +#elif defined USE_INT64 +foreign import ccall safe "mathlink.h MLGetInteger64" mlGetInt + :: Link -> Ptr CLong -> IO CInt +#endif + +foreign import ccall safe "mathlink.h MLGetReal32" mlGetReal32 + :: Link -> Ptr CFloat -> IO CInt + +foreign import ccall safe "mathlink.h MLGetReal64" mlGetReal64 + :: Link -> Ptr CDouble -> IO CInt + +foreign import ccall safe "mathlink.h MLGetString" mlGetString + :: Link -> Ptr CString -> IO CInt + +foreign import ccall safe "mathlink.h MLReleaseString" mlReleaseString + :: Link -> CString -> IO () + +foreign import ccall safe "mathlink.h MLGetSymbol" mlGetSymbol + :: Link -> Ptr CString -> IO CInt + +foreign import ccall safe "mathlink.h MLReleaseSymbol" mlReleaseSymbol + :: Link -> CString -> IO () + +foreign import ccall safe "mathlink.h MLTestHead" mlTestHead + :: Link -> CString -> Ptr CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLGetFunction" mlGetFunction + :: Link -> Ptr CString -> Ptr CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLGetInteger16List" mlGetInt16List + :: Link -> Ptr (Ptr CShort) -> Ptr CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLGetInteger32List" mlGetInt32List + :: Link -> Ptr (Ptr CInt) -> Ptr CInt -> IO CInt + +#ifdef USE_INT32 +mlGetIntList + :: Link -> Ptr (Ptr CInt) -> Ptr CInt -> IO CInt +mlGetIntList = mlGetInt32List +#elif defined USE_INT64 +foreign import ccall safe "mathlink.h MLGetInteger64List" mlGetIntList + :: Link -> Ptr (Ptr CLong) -> Ptr CInt -> IO CInt +#endif + +foreign import ccall safe "mathlink.h MLGetReal32List" mlGetReal32List + :: Link -> Ptr (Ptr CFloat) -> Ptr CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLGetReal64List" mlGetReal64List + :: Link -> Ptr (Ptr CDouble) -> Ptr CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLReleaseInteger16List" mlReleaseInt16List + :: Link -> Ptr CShort -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLReleaseInteger32List" mlReleaseInt32List + :: Link -> Ptr CInt -> CInt -> IO CInt + +#ifdef USE_INT32 +mlReleaseIntList + :: Link -> Ptr CInt -> CInt -> IO CInt +mlReleaseIntList = mlReleaseInt32List +#elif defined USE_INT64 +foreign import ccall safe "mathlink.h MLReleaseInteger64List" mlReleaseIntList + :: Link -> Ptr CLong -> CInt -> IO CInt +#endif + +foreign import ccall safe "mathlink.h MLReleaseReal32List" mlReleaseReal32List + :: Link -> Ptr CFloat -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLReleaseReal64List" mlReleaseReal64List + :: Link -> Ptr CDouble -> CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLGetInteger16Array" mlGetInt16Array + :: Link -> Ptr (Ptr CShort) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLGetInteger32Array" mlGetInt32Array + :: Link -> Ptr (Ptr CInt) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt + +#ifdef USE_INT32 +mlGetIntArray + :: Link -> Ptr (Ptr CInt) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt +mlGetIntArray = mlGetInt32Array +#elif defined USE_INT64 +foreign import ccall safe "mathlink.h MLGetInteger64Array" mlGetIntArray + :: Link -> Ptr (Ptr CLong) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt +#endif + +foreign import ccall safe "mathlink.h MLReleaseInteger16Array" mlReleaseInt16Array + :: Link -> Ptr CShort -> Ptr CInt -> Ptr CString -> CInt -> IO () + +foreign import ccall safe "mathlink.h MLReleaseInteger32Array" mlReleaseInt32Array + :: Link -> Ptr CInt -> Ptr CInt -> Ptr CString -> CInt -> IO () + +#ifdef USE_INT32 +mlReleaseIntArray + :: Link -> Ptr CInt -> Ptr CInt -> Ptr CString -> CInt -> IO () +mlReleaseIntArray = mlReleaseInt32Array +#elif defined USE_INT64 +foreign import ccall safe "mathlink.h MLReleaseInteger64Array" mlReleaseIntArray + :: Link -> Ptr CLong -> Ptr CInt -> Ptr CString -> CInt -> IO () +#endif + +foreign import ccall safe "mathlink.h MLGetReal32Array" mlGetReal32Array + :: Link -> Ptr (Ptr CFloat) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLGetReal64Array" mlGetReal64Array + :: Link -> Ptr (Ptr CDouble) -> Ptr (Ptr CInt) -> Ptr (Ptr CString) -> Ptr CInt -> IO CInt + +foreign import ccall safe "mathlink.h MLReleaseReal32Array" mlReleaseReal32Array + :: Link -> Ptr CFloat -> Ptr CInt -> Ptr CString -> CInt -> IO () + +foreign import ccall safe "mathlink.h MLReleaseReal64Array" mlReleaseReal64Array + :: Link -> Ptr CDouble -> Ptr CInt -> Ptr CString -> CInt -> IO () + diff --git a/src/Foreign/MathLink/ML.hs b/src/Foreign/MathLink/ML.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/MathLink/ML.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , ExistentialQuantification + #-} + +module Foreign.MathLink.ML ( runMathLink + , runMathLinkWithArgs + , evaluate + , evaluateString + , getLink + , throwOnError + , boolToError + , getType + , putFunctionHead + , getFunctionHead + , putScalarWith + , getScalarWith + , putStringWith + , getStringWith + , withLink0 + , withLink1 + , withLink2 + , withLink3 + , withLink4 + ) where + +import Foreign.MathLink.Types +import qualified Foreign.MathLink.IO as MLIO + +import Foreign +import Foreign.C +import Foreign.Storable +import Control.Exception (bracket) +import Control.Monad +import Control.Monad.Trans +import qualified Control.Monad.Reader as Rd +import qualified Control.Monad.State as St +import qualified Control.Monad.Error as Er +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Data.Int +import System.IO +import System.Environment + +-- | Returns the link associated with this thread of execution. +getLink :: ML Link +getLink = Rd.ask >>= (return . link) + +updateState :: ML () +updateState = do + b <- checkMessage + if not b then return () else do + mMsg <- getMessage + case mMsg of + Nothing -> return () + Just (msg,_) -> + case msg of + TerminateMessage -> do st <- St.get + St.put $ st { done = True } + updateState + InterruptMessage -> do st <- St.get + St.put $ st { abort = True } + updateState + AbortMessage -> do st <- St.get + St.put $ st { abort = True } + updateState + UnknownMessage _ -> return () + _ -> updateState + +-- | Runs /MathLink/, exposing the given list of functions. +runMathLink :: [Function] -> IO () +runMathLink functions = do + args <- getArgs + runMathLinkWithArgs args functions + +-- | Like 'runMathLink', but explicitly specifies the command line +-- arguments to be passed to /MathLink/. +runMathLinkWithArgs :: [String] -> [Function] -> IO () +runMathLinkWithArgs args functions = + bracket MLIO.acquireEnvironment MLIO.releaseEnvironment $ \env -> + bracket (MLIO.acquireLink env args) MLIO.releaseLink $ \lnk -> do + let config = Config { environment = env + , link = lnk + , functionTable = + IM.fromList $ zip [0..] functions + } + state = State { abort = False + , done = False + } + er <- runML runLoop state config + case er of + Left err -> do hPutStrLn stderr err + return () + Right () -> return () + +runLoop :: ML () +runLoop = do + installFunctionTable + processPackets + +processPackets :: ML () +processPackets = do + pkt <- answer + case pkt of + ResumePacket -> do + refuseToBeAFrontEnd + processPackets + _ -> return () + +answer :: ML Packet +answer = do + pkt <- getPacket + case pkt of + CallPacket -> do + processCallPacket + endPacket + newPacket + answer + _ -> return $ mkPacket 0 + return pkt + +processCallPacket :: ML () +processCallPacket = + do expr <- get + case expr of + ExInt n -> do + config <- Rd.ask + case n `IM.lookup` (functionTable config) of + Just fn -> function fn + _ -> Er.throwError + "processCallPacket: Function lookup failed." + _ -> Er.throwError + "processCallPacket: Expected int." + `Er.catchError` \err -> do + clearError + put $ ExSymbol "$Failed" + + +refuseToBeAFrontEnd :: ML () +refuseToBeAFrontEnd = do + putFunctionHead "EvaluatePacket" 1 + putFunctionHead "Module" 2 + putFunctionHead "List" 1 + putFunctionHead "Set" 2 + put meSym + put plSym + putFunctionHead "CompoundExpression" 3 + putFunctionHead "Set" 2 + put plSym + getLink >>= (liftIO . (\l -> MLIO.transferExpression l l)) + putFunctionHead "Message" 2 + putFunctionHead "MessageName" 2 + put plSym + put $ ExString "notfe" + put meSym + put meSym + endPacket + waitForPacket (== SuspendPacket) + where meSym = ExSymbol "me" + plSym = ExSymbol "$ParentLink" + +installFunctionTable :: ML () +installFunctionTable = do + activate + functionPairs <- Rd.ask >>= (return . IM.toList . functionTable) + mapM_ definePattern functionPairs + put $ ExSymbol "End" + flush + +definePattern :: (Int,Function) -> ML () +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 :: String -> ML Bool +evaluate s = + do put $ ExFunction "EvaluatePacket" + [ ExFunction "ToExpression" + [ ExString s ] ] + endPacket + return True + `Er.catchError` do + return $ return False + +-- | Like 'evaluate', but blocks until the execution is complete. +evaluateString :: String -> ML Bool +evaluateString s = do + result <- evaluate s + waitForPacket (== ReturnPacket) + return result + +waitForPacket :: (Packet -> Bool) -> ML () +waitForPacket q = do + pkt <- getPacket + newPacket + if q pkt then return () else waitForPacket q + + +-- misc + +activate :: ML () +activate = withLink0 MLIO.activate >>= boolToError + +flush :: ML () +flush = withLink0 MLIO.flush >>= boolToError + +checkReady :: ML Bool +checkReady = withLink0 MLIO.checkReady + + +-- errors + +getError :: ML Error +getError = withLink0 MLIO.getError + +clearError :: ML Bool +clearError = withLink0 MLIO.clearError + +getErrorMessage :: ML String +getErrorMessage = withLink0 MLIO.getErrorMessage + +throwOnError :: Integral a => a -> ML () +throwOnError i = + if i == 0 then + getErrorMessage >>= Er.throwError + else + return () + +boolToError :: Bool -> ML () +boolToError True = return () +boolToError False = getErrorMessage >>= Er.throwError + +-- packets + +getPacket :: ML Packet +getPacket = withLink0 MLIO.getPacket + +newPacket :: ML Bool +newPacket = withLink0 MLIO.newPacket + +endPacket :: ML Bool +endPacket = withLink0 MLIO.endPacket + + +-- messages + +getMessage :: ML (Maybe (Message,Int)) +getMessage = withLink0 MLIO.getMessage + +putMessage :: Message -> ML Bool +putMessage = withLink1 MLIO.putMessage + +checkMessage :: ML Bool +checkMessage = withLink0 MLIO.checkMessage + +-- | Helper for marshaling scalar values to /Mathematica/. +putScalarWith :: (Link -> b -> IO CInt) + -> (a -> b) + -> a + -> ML () +putScalarWith fn cnv i = withLink1 fn (cnv i) >>= throwOnError + +-- | Helper for marshaling scalar values from /Mathematica/. +getScalarWith :: Storable a + => (Link -> Ptr a -> IO CInt) + -> (a -> b) + -> ML b +getScalarWith fn cnv = do + l <- getLink + eS <- liftIO $ bracket malloc free $ \xPtr -> do + bS <- fn l xPtr >>= MLIO.convToBool + if bS then + peek xPtr >>= (return . Right . cnv) + else + MLIO.getErrorMessage l >>= (return . Left) + case eS of + Left msg -> Er.throwError msg + Right s -> return s + +-- | Helper for marshaling 'String's to /Mathematica/. +putStringWith :: (Link -> CString -> IO CInt) + -> String + -> ML () +putStringWith fn str = do + l <- getLink + liftIO (withCString str $ \sPtr -> fn l sPtr) >>= throwOnError + +-- | Helper for marshaling 'String's from /Mathematica/. +getStringWith :: (Link -> Ptr CString -> IO CInt) + -> (Link -> CString -> IO ()) + -> ML String +getStringWith afn rfn = do + l <- getLink + eStr <- liftIO $ bracket malloc free $ \strPtrPtr -> do + bStr <- afn l strPtrPtr >>= MLIO.convToBool + if bStr then do + strPtr <- peek strPtrPtr + str <- peekCString strPtr + rfn l strPtr + return $ Right str + else + MLIO.getErrorMessage l >>= (return . Left) + case eStr of + Left err -> Er.throwError err + Right s -> return s + +-- | Gets the type of the next expression to be read on the /MathLink/ +-- connection. +getType :: ML Type +getType = getLink >>= (liftIO . MLIO.mlGetType) >>= (return . mkType) + +putFunctionHead :: String -> Int -> ML () +putFunctionHead hd n = + putStringWith (\l s -> MLIO.mlPutFunction l s (fromIntegral n)) hd + +getFunctionHead :: ML (String,Int) +getFunctionHead = do + l <- getLink + eFn <- liftIO $ bracket malloc free $ \strPtrPtr -> + bracket malloc free $ \nPtr -> do + bFn <- MLIO.mlGetFunction l strPtrPtr nPtr >>= MLIO.convToBool + if bFn then do + strPtr <- peek strPtrPtr + str <- peekCString strPtr + n <- peek nPtr + MLIO.mlReleaseSymbol l strPtr + return $ Right (str,fromIntegral n) + else + MLIO.getErrorMessage l >>= (return . Left) + case eFn of + Left err -> Er.throwError err + Right f -> return f + +instance Expressible Expression where + put e = + case e of + ExInt i -> putScalarWith MLIO.mlPutInt fromIntegral i + ExReal r -> putScalarWith MLIO.mlPutReal64 realToFrac r + ExString s -> putStringWith MLIO.mlPutString s + ExSymbol s -> putStringWith MLIO.mlPutSymbol s + ExFunction hd args -> do + putFunctionHead hd (fromIntegral $ length args) + mapM_ put args + + get = do + typ <- getType + case typ of + ErrorType -> getErrorMessage >>= Er.throwError + IntType -> getScalarWith MLIO.mlGetInt fromIntegral >>= + (return . ExInt) + RealType -> getScalarWith MLIO.mlGetReal64 realToFrac >>= + (return . ExReal) + StringType -> + getStringWith MLIO.mlGetString MLIO.mlReleaseString >>= + (return . ExString) + SymbolType -> + getStringWith MLIO.mlGetSymbol MLIO.mlReleaseSymbol >>= + (return . ExSymbol) + FunctionType -> do + (hd,nArgs) <- getFunctionHead + args <- mapM id $ take nArgs $ repeat get + return $ ExFunction hd args + + +-- lifting utilities + +withLink0 + :: (Link -> IO a) + -> ML a +withLink0 f = getLink >>= (liftIO . f) + +withLink1 + :: (Link -> a -> IO b) + -> (a -> ML b) +withLink1 f = \x -> getLink >>= (liftIO . (\l -> f l x)) + +withLink2 + :: (Link -> a -> b -> IO c) + -> (a -> b -> ML c) +withLink2 f = \x y -> getLink >>= (liftIO . (\l -> f l x y)) + +withLink3 + :: (Link -> a -> b -> c -> IO d) + -> (a -> b -> c -> ML d) +withLink3 f = \x y z -> getLink >>= (liftIO . (\l -> f l x y z)) + +withLink4 + :: (Link -> a -> b -> c -> d -> IO e) + -> (a -> b -> c -> d -> ML e) +withLink4 f = \x y z w -> getLink >>= (liftIO . (\l -> f l x y z w)) + diff --git a/src/Foreign/MathLink/Types.hs b/src/Foreign/MathLink/Types.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/MathLink/Types.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} + +module Foreign.MathLink.Types ( + -- * Data marshaling + Expressible(..) + , Dimensional(..) + , Expression(..) + -- * Execution + , ML(..) + , Config(..) + , Function(..) + , State(..) + , runML + -- * /MathLink/ internal types + , Link(..) + , Environment(..) + , Type(..) + , mkType + , Message(..) + , mkMessage + , Error(..) + , mkError + , Packet(..) + , mkPacket + ) where + +import Foreign +import Foreign.C +import Data.Ix +import Data.Data +import Data.IntMap +import qualified Control.Monad.State as St +import qualified Control.Monad.Reader as Rd +import qualified Control.Monad.Error as Er +import Control.Monad.Trans + + +-- | Instances of 'Expressible' are precisely the data types that can +-- be marshaled to and from /Mathematica/. +class Expressible a where + -- | Send a value to /Mathematica/. + put :: a -> ML () + -- | Receive a value from /Mathematica/. + get :: ML a + +-- | Arrays to be marshaled to and from /Mathematica/ require indices +-- that are instances of 'Dimensional'. +class Ix ix => Dimensional ix where + -- | The number of dimensions. + -- + -- Shouldn't examine its argument. + rank :: ix -> Int + -- | The dimensions + dimensions :: (ix,ix) -> [Int] + -- | The array bounds implied by a list of dimensions + -- + -- NB: a (very) partial function! Fails if the length of the + -- given list is different from the result of 'rank'. + fromDimensions :: [Int] -> (ix,ix) + +-- | Represents a general /Mathematica/ expression. +data Expression = -- | An atomic value of integer type + ExInt Int + -- | An atomic value of floating point type + | ExReal Double + -- | An atomic value of string type + | ExString String + -- | An atomic value of symbol type + | ExSymbol String + -- | A non-atomic value, with a head of type symbol + -- and a list of arguments + | ExFunction String [Expression] + deriving (Eq,Ord,Read,Show,Data,Typeable) + +-- | Encapsulates the read/write state associated with the 'ML' monad. +data State = State { abort :: Bool + , done :: Bool + } + +-- | Encapsulates the readable state associated with the 'ML' monad. +data Config = Config { environment :: Environment + , link :: Link + , functionTable :: IntMap Function + } + +-- | The monad in which functions exposed to /Mathematica/ execute. +newtype ML a = ML { + runMLMonad :: Er.ErrorT String (St.StateT State (Rd.ReaderT Config IO)) a + } deriving ( Monad + , MonadIO + , St.MonadState State + , Rd.MonadReader Config + , Er.MonadError String + ) + +-- | Runs the given 'ML' computation with the given state and configuration. +runML :: ML a -> State -> Config -> IO (Either String a) +runML ac s c = Rd.runReaderT (St.evalStateT (Er.runErrorT (runMLMonad ac)) s) c + +-- | 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 :: ML () + } + +instance Show Function where + show fn = "Function { callPattern = " ++ + (show $ callPattern fn) ++ + ", argumentPattern = " ++ + (show $ argumentPattern fn) ++ " }" + +-- | A wrapped pointer to the /MathLink/ link. +newtype Link = Link (Ptr ()) deriving (Eq) + +-- | A wrapped pointer to the /MathLink/ environment. +newtype Environment = Environment (Ptr ()) deriving (Eq) + +-- | An enumeration of some error codes defined in @mathlink.h@. +data Error = NoError + | DeadLnkError + | GetInconsistentError + | GetOutOfSeqError + | PutBadTokError + | PutOutOfSeqError + | PutTooBigError + | MachineOverflowError + | OutOfMemoryError + | SocketUnacceptedError + | UnconnectedError + | PutEndPacketError + | NextIncompleteCurrentPacketError + | NextUnknownPacketError + | GetEndPacketError + | AbortError + | ClosedError + | InitError + | ArgvError + | ProtocolError + | ModeError + | LaunchError + | RelaunchError + | LaunchSpaceError + | NoParentError + | NameTakenError + | NoListenError + | BadNameError + | BadHostError + | LaunchFailedError + | LaunchNameError + | PutConvertError + | GetConvertError + | PutBadEncodingError + | UnknownError Int + deriving (Eq,Show) + +instance Enum Error where + fromEnum r = + case r of + NoError -> 0 + DeadLnkError -> 1 + GetInconsistentError -> 2 + GetOutOfSeqError -> 3 + PutBadTokError -> 4 + PutOutOfSeqError -> 5 + PutTooBigError -> 6 + MachineOverflowError -> 7 + OutOfMemoryError -> 8 + SocketUnacceptedError -> 9 + UnconnectedError -> 10 + PutEndPacketError -> 21 + NextIncompleteCurrentPacketError -> 22 + NextUnknownPacketError -> 23 + GetEndPacketError -> 24 + AbortError -> 25 + ClosedError -> 11 + InitError -> 32 + ArgvError -> 33 + ProtocolError -> 34 + ModeError -> 35 + LaunchError -> 36 + RelaunchError -> 37 + LaunchSpaceError -> 38 + NoParentError -> 39 + NameTakenError -> 40 + NoListenError -> 41 + BadNameError -> 42 + BadHostError -> 43 + LaunchFailedError -> 45 + LaunchNameError -> 46 + PutConvertError -> 48 + GetConvertError -> 49 + PutBadEncodingError -> 47 + UnknownError i -> i + + toEnum i = + case i of + 0 -> NoError + 1 -> DeadLnkError + 2 -> GetInconsistentError + 3 -> GetOutOfSeqError + 4 -> PutBadTokError + 5 -> PutOutOfSeqError + 6 -> PutTooBigError + 7 -> MachineOverflowError + 8 -> OutOfMemoryError + 9 -> SocketUnacceptedError + 10 -> UnconnectedError + 21 -> PutEndPacketError + 22 -> NextIncompleteCurrentPacketError + 23 -> NextUnknownPacketError + 24 -> GetEndPacketError + 25 -> AbortError + 11 -> ClosedError + 32 -> InitError + 33 -> ArgvError + 34 -> ProtocolError + 35 -> ModeError + 36 -> LaunchError + 37 -> RelaunchError + 38 -> LaunchSpaceError + 39 -> NoParentError + 40 -> NameTakenError + 41 -> NoListenError + 42 -> BadNameError + 43 -> BadHostError + 45 -> LaunchFailedError + 46 -> LaunchNameError + 48 -> PutConvertError + 49 -> GetConvertError + 47 -> PutBadEncodingError + i -> UnknownError i + +instance Ord Error where + compare e1 e2 = compare (fromEnum e1) (fromEnum e2) + +-- | Turns an 'Integral' into the corresponding 'Error'. +mkError :: Integral a => a -> Error +mkError = toEnum . fromIntegral + +-- | An enumeration of /MathLink/ message types. +data Message = TerminateMessage + | InterruptMessage + | AbortMessage + | EndPacketMessage + | SynchronizeMessage + | ImDyingMessage + | WaitingAcknowledgementMessage + | MarkTopLevelMessage + | LinkClosingMessage + | AuthenticateFailureMessage + | UserMessage Int + | UnknownMessage Int + deriving (Eq,Show) + +instance Enum Message where + fromEnum m = + case m of + TerminateMessage -> 1 + InterruptMessage -> 2 + AbortMessage -> 3 + EndPacketMessage -> 4 + SynchronizeMessage -> 5 + ImDyingMessage -> 6 + WaitingAcknowledgementMessage -> 7 + MarkTopLevelMessage -> 8 + LinkClosingMessage -> 9 + AuthenticateFailureMessage -> 10 + UserMessage i -> i + UnknownMessage i -> i + + toEnum i = + case i of + i | i >= 128 && i <= 255 -> UserMessage i + 1 -> TerminateMessage + 2 -> InterruptMessage + 3 -> AbortMessage + 4 -> EndPacketMessage + 5 -> SynchronizeMessage + 6 -> ImDyingMessage + 7 -> WaitingAcknowledgementMessage + 8 -> MarkTopLevelMessage + 9 -> LinkClosingMessage + 10 -> AuthenticateFailureMessage + i -> UnknownMessage i + +instance Ord Message where + compare m1 m2 = compare (fromEnum m1) (fromEnum m2) + +firstUserMessage :: Message +firstUserMessage = UserMessage 128 + +lastUserMessage :: Message +lastUserMessage = UserMessage 255 + +mkMessage :: Integral a => a -> Message +mkMessage = toEnum . fromIntegral + + +-- | An enumeration of /MathLink/ packet types +data Packet = IllegalPacket + | CallPacket + | EvaluatePacket + | ReturnPacket + | InputNamePacket + | EnterTextPacket + | EnterExpressionPacket + | OutputNamePacket + | ReturnTextPacket + | ReturnExpressionPacket + | DisplayPacket + | DisplayEndPacket + | MessagePacket + | TextPacket + | InputPacket + | InputStringPacket + | MenuPacket + | SyntaxPacket + | SuspendPacket + | ResumePacket + | BeginDialogPacket + | EndDialogPacket + | UserPacket Int + | UnknownPacket Int + deriving (Eq,Show) + +instance Enum Packet where + fromEnum p = + case p of + IllegalPacket -> 0 + CallPacket -> 7 + EvaluatePacket -> 13 + ReturnPacket -> 3 + InputNamePacket -> 8 + EnterTextPacket -> 14 + EnterExpressionPacket -> 15 + OutputNamePacket -> 9 + ReturnTextPacket -> 4 + ReturnExpressionPacket -> 16 + DisplayPacket -> 11 + DisplayEndPacket -> 12 + MessagePacket -> 5 + TextPacket -> 2 + InputPacket -> 1 + InputStringPacket -> 21 + MenuPacket -> 6 + SyntaxPacket -> 10 + SuspendPacket -> 17 + ResumePacket -> 18 + BeginDialogPacket -> 19 + EndDialogPacket -> 20 + UserPacket i -> i + UnknownPacket i -> i + + toEnum i = + case i of + 0 -> IllegalPacket + 7 -> CallPacket + 13 -> EvaluatePacket + 3 -> ReturnPacket + 8 -> InputNamePacket + 14 -> EnterTextPacket + 15 -> EnterExpressionPacket + 9 -> OutputNamePacket + 4 -> ReturnTextPacket + 16 -> ReturnExpressionPacket + 11 -> DisplayPacket + 12 -> DisplayEndPacket + 5 -> MessagePacket + 2 -> TextPacket + 1 -> InputPacket + 21 -> InputStringPacket + 6 -> MenuPacket + 10 -> SyntaxPacket + 17 -> SuspendPacket + 18 -> ResumePacket + 19 -> BeginDialogPacket + 20 -> EndDialogPacket + i | i >= 128 && i <= 255 -> UserPacket i + i -> UnknownPacket i + +instance Ord Packet where + compare p1 p2 = compare (fromEnum p1) (fromEnum p2) + +firstUserPacket :: Packet +firstUserPacket = UserPacket 128 + +lastUserPacket :: Packet +lastUserPacket = UserPacket 255 + +mkPacket :: Integral a => a -> Packet +mkPacket = toEnum . fromIntegral + +-- | An enumeriation of possible return values from the /MathLink/ functions @MLGetNext@ or @MLGetType@. +data Type = ErrorType + | IntType + | RealType + | StringType + | SymbolType + | FunctionType + | UnknownType Int + deriving (Eq,Show) + +instance Enum Type where + fromEnum t = + case t of + ErrorType -> 0 + IntType -> 43 + RealType -> 42 + StringType -> 34 + SymbolType -> 35 + FunctionType -> 70 + UnknownType i -> i + + toEnum i = + case i of + 0 -> ErrorType + 43 -> IntType + 42 -> RealType + 34 -> StringType + 35 -> SymbolType + 70 -> FunctionType + 73 -> IntType -- old int type + 82 -> RealType -- old real type + 83 -> StringType -- old string type + 89 -> SymbolType -- old symbol type + i -> UnknownType i + +instance Ord Type where + compare t1 t2 = compare (fromEnum t1) (fromEnum t2) + +mkType :: Integral a => a -> Type +mkType = toEnum . fromIntegral +