mathlink (empty) → 0.1.0.0
raw patch · 13 files changed
+2265/−0 lines, 13 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, mtl
Files
- LICENSE +32/−0
- Setup.lhs +7/−0
- examples/Setup.lhs +7/−0
- examples/mltest.cabal +19/−0
- examples/mltest.nb +225/−0
- examples/mltest.sh +2/−0
- examples/src/Main.hs +119/−0
- mathlink.cabal +52/−0
- src/Foreign/MathLink.hs +86/−0
- src/Foreign/MathLink/Expressible.hs +426/−0
- src/Foreign/MathLink/IO.hs +449/−0
- src/Foreign/MathLink/ML.hs +395/−0
- src/Foreign/MathLink/Types.hs +446/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/bin/env runhaskell+\begin{code}++import Distribution.Simple.MathLink+main = mathLinkDefaultMain++\end{code}
+ examples/Setup.lhs view
@@ -0,0 +1,7 @@+#!/bin/env runhaskell+\begin{code}++import Distribution.Simple+main = defaultMain++\end{code}
+ examples/mltest.cabal view
@@ -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: <tracy.wadleigh@gmail.com>+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+
+ examples/mltest.nb view
@@ -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", "[", "\"\<mltest.sh\>\"", "]"}]}]], "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", ",", "\"\<A string\>\"", ",", "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 *)
+ examples/mltest.sh view
@@ -0,0 +1,2 @@+#! /usr/bin/env sh+dist/build/mltest/mltest $@ +RTS -K1G -RTS 1> mltest.out 2> mltest.err
+ examples/src/Main.hs view
@@ -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+ ]+
+ mathlink.cabal view
@@ -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: <tracy.wadleigh@gmail.com>+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+
+ src/Foreign/MathLink.hs view
@@ -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
+ src/Foreign/MathLink/Expressible.hs view
@@ -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
+ src/Foreign/MathLink/IO.hs view
@@ -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 ()+
+ src/Foreign/MathLink/ML.hs view
@@ -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))+
+ src/Foreign/MathLink/Types.hs view
@@ -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+