mathlink 0.1.0.2 → 1.0.0.0
raw patch · 11 files changed
+2505/−1872 lines, 11 files
Files
- examples/mltest.cabal +1/−1
- examples/mltest.nb +113/−43
- examples/mltest.sh +1/−1
- examples/src/Main.hs +51/−40
- mathlink.cabal +12/−8
- src/Foreign/MathLink.hs +268/−59
- src/Foreign/MathLink/Expressible.hs +929/−426
- src/Foreign/MathLink/IO.hs +1082/−449
- src/Foreign/MathLink/ML.hs +0/−399
- src/Foreign/MathLink/Types.hs +0/−446
- src/state.c +48/−0
examples/mltest.cabal view
@@ -12,7 +12,7 @@ Executable mltest Build-Depends: base >= 4.0 && < 4.1,- mathlink >= 0.1 && < 0.2,+ mathlink >= 1.0 && < 1.1, array >= 0.2 && < 0.3, mtl >= 1.1.0.2 && < 1.2 Hs-Source-Dirs: src
examples/mltest.nb view
@@ -10,10 +10,10 @@ NotebookFileLineBreakTest NotebookFileLineBreakTest NotebookDataPosition[ 145, 7]-NotebookDataLength[ 8910, 274]-NotebookOptionsPosition[ 7550, 220]-NotebookOutlinePosition[ 7909, 236]-CellTagsIndexPosition[ 7866, 233]+NotebookDataLength[ 12759, 344]+NotebookOptionsPosition[ 11283, 286]+NotebookOutlinePosition[ 11641, 302]+CellTagsIndexPosition[ 11598, 299] WindowFrame->Normal*) (* Beginning of Notebook Content *)@@ -28,7 +28,8 @@ Cell[BoxData["\<\"/home/twadleigh/hs/mathlink/examples\"\>"], "Output", CellChangeTimes->{{3.439504769908993*^9, 3.439504791247632*^9}, - 3.440168667032764*^9, 3.440177535376698*^9, 3.4401803149179897`*^9}]+ 3.440168667032764*^9, 3.440177535376698*^9, 3.4401803149179897`*^9, + 3.4413812970022373`*^9, 3.441491000419338*^9}] }, Open ]], Cell[TextData[{@@ -54,10 +55,16 @@ Cell[BoxData[ RowBox[{"LinkObject", "[", - RowBox[{"\<\"/home/twadleigh/hs/mathlink/examples/mltest.sh\"\>", ",", "25",- ",", "11"}], "]"}]], "Output",- CellChangeTimes->{3.440263039836529*^9, 3.440264120592161*^9, - 3.44026426385889*^9, 3.440264416235961*^9}]+ RowBox[{"\<\"/home/twadleigh/hs/mathlink/examples/mltest.sh\"\>", ",", + "3897", ",", "9"}], "]"}]], "Output",+ CellChangeTimes->{+ 3.4413816897789*^9, 3.441381776726746*^9, 3.441381863003125*^9, + 3.441382755890881*^9, 3.441383611414963*^9, 3.4413837695712976`*^9, + 3.441384211503524*^9, 3.441385803766169*^9, 3.441386080695139*^9, + 3.441387244598215*^9, 3.441387779567708*^9, {3.441387949000835*^9, + 3.441387976609853*^9}, 3.44138846489312*^9, 3.4413885012431507`*^9, + 3.441388550071382*^9, 3.4413906521514463`*^9, 3.441418693983523*^9, + 3.4414188494746513`*^9, 3.441491002436418*^9}] }, Open ]], Cell[CellGroupData[{@@ -73,7 +80,11 @@ 3.440177770296537*^9, 3.440178013081019*^9, 3.440180318765966*^9, 3.440261706988338*^9, 3.440262267330207*^9, 3.44026304258245*^9, 3.4402641219488163`*^9, 3.4402642658697*^9, {3.4402644178146067`*^9, - 3.4402644191880302`*^9}}]+ 3.4402644191880302`*^9}, 3.4413813057112007`*^9, 3.441381441541993*^9, + 3.441383613208295*^9, 3.441383771554179*^9, 3.4413842134637823`*^9, + 3.441385806201159*^9, 3.441387246470428*^9, 3.441387781194582*^9, {+ 3.441387950532065*^9, 3.441387978232432*^9}, 3.441388469306093*^9, + 3.4413906541514683`*^9, 3.441418696364647*^9, 3.441491004440143*^9}] }, Open ]], Cell[CellGroupData[{@@ -95,7 +106,11 @@ 3.440168712981926*^9, 3.440177541747458*^9, 3.4401776436073923`*^9, 3.440177771845735*^9, 3.4401780146157618`*^9, {3.440180323067984*^9, 3.440180359740733*^9}, 3.440261709575554*^9, 3.4402630445039377`*^9, - 3.440264267960457*^9, 3.440264420978492*^9}]+ 3.440264267960457*^9, 3.440264420978492*^9, 3.441381307968505*^9, + 3.441381443541602*^9, 3.441383773992701*^9, 3.44138421533407*^9, + 3.441385807884037*^9, 3.4413872484380293`*^9, 3.441387979824582*^9, + 3.4413884893522873`*^9, 3.441390659007481*^9, 3.441418698597937*^9, + 3.4414910070039387`*^9}] }, Open ]], Cell[CellGroupData[{@@ -104,12 +119,23 @@ RowBox[{"GreetWorld", "[", "]"}]], "Input", CellChangeTimes->{{3.440168718131279*^9, 3.4401687204719067`*^9}}], -Cell[BoxData["\<\"Hello, world!\"\>"], "Output",+Cell[BoxData[+ RowBox[{"{", + RowBox[{+ RowBox[{"{", + RowBox[{"\<\"H\"\>", ",", "\<\"e\"\>", ",", "\<\"l\"\>", ",", "\<\"l\"\>",+ ",", "\<\"o\"\>", ",", "\<\",\"\>", ",", "\<\" \"\>", ",", "\<\"w\"\>", + ",", "\<\"o\"\>", ",", "\<\"r\"\>", ",", "\<\"l\"\>", ",", "\<\"d\"\>", + ",", "\<\"!\"\>"}], "}"}], ",", "\<\"Hello, world!\"\>"}], + "}"}]], "Output", CellChangeTimes->{ 3.4401687210248337`*^9, 3.440177543338463*^9, 3.4401776462215652`*^9, 3.440177773588876*^9, 3.440178015619836*^9, 3.440180378796352*^9, 3.4402617123528633`*^9, 3.4402630465175877`*^9, {3.440264269597514*^9, - 3.440264271412078*^9}, 3.4402644226770697`*^9}]+ 3.440264271412078*^9}, 3.4402644226770697`*^9, 3.44138130986276*^9, + 3.441381445073922*^9, 3.441383777014336*^9, 3.441384217030814*^9, + 3.4413858094822197`*^9, 3.441387249965949*^9, 3.4414187007709637`*^9, + 3.441491009312787*^9}] }, Open ]], Cell[CellGroupData[{@@ -128,13 +154,21 @@ RowBox[{"{", RowBox[{ RowBox[{"{", - RowBox[{"6", ",", "5", ",", "4"}], "}"}], ",", + RowBox[{+ RowBox[{"{", "1", "}"}], ",", + RowBox[{"{", "2", "}"}], ",", + RowBox[{"{", "3", "}"}]}], "}"}], ",", RowBox[{"{", - RowBox[{"3", ",", "2", ",", "1"}], "}"}]}], "}"}]], "Output",+ RowBox[{+ RowBox[{"{", "4", "}"}], ",", + RowBox[{"{", "5", "}"}], ",", + RowBox[{"{", "6", "}"}]}], "}"}]}], "}"}]], "Output", CellChangeTimes->{3.440168948815699*^9, 3.4401775454085293`*^9, 3.440177647824188*^9, 3.4401777759225273`*^9, 3.440178017618819*^9, 3.4401803839453077`*^9, 3.4402617143337603`*^9, 3.4402630480736322`*^9, - 3.440264274052725*^9, 3.440264424466619*^9}]+ 3.440264274052725*^9, 3.440264424466619*^9, 3.441381351458521*^9, + 3.441381449711451*^9, 3.4413837789184637`*^9, 3.4413842200390663`*^9, + 3.441387251527453*^9, 3.441418703279256*^9, 3.441491011027935*^9}] }, Open ]], Cell[CellGroupData[{@@ -160,7 +194,9 @@ 3.4401777251469917`*^9, 3.440177777974738*^9, 3.4401778462290287`*^9, { 3.4401780196886597`*^9, 3.440178050944537*^9}, 3.440180387144931*^9, 3.440261716956626*^9, 3.440263049754879*^9, 3.440264276797727*^9, - 3.440264426317778*^9}]+ 3.440264426317778*^9, 3.441381360007936*^9, 3.441381452206236*^9, + 3.441383780806993*^9, 3.441384222446288*^9, 3.4413872531264553`*^9, + 3.441418705414536*^9, 3.441491013393704*^9}] }, Open ]], Cell[CellGroupData[{@@ -183,7 +219,9 @@ 3.4402617532268353`*^9, {3.440261864732419*^9, 3.440261871312593*^9}, 3.440262143838559*^9, 3.4402622723110037`*^9, 3.440262328404337*^9, 3.440263051601795*^9, 3.4402641351875563`*^9, 3.4402642789828243`*^9, - 3.4402644285115223`*^9}]+ 3.4402644285115223`*^9, 3.441381455911284*^9, 3.44138378263803*^9, + 3.441384224886664*^9, 3.44138725472222*^9, 3.441418706707465*^9, + 3.441491015262816*^9}] }, Open ]], Cell[CellGroupData[{@@ -200,12 +238,35 @@ Cell[BoxData["\[Infinity]"], "Output", CellChangeTimes->{3.440262345780912*^9, 3.44026247434591*^9, 3.440263054136756*^9, 3.440264140800539*^9, 3.4402642809102592`*^9, - 3.440264430358942*^9}]+ 3.440264430358942*^9, 3.4413814578432207`*^9, 3.441383783897023*^9, + 3.4413842262926207`*^9, 3.4413860855117683`*^9, 3.4413872565223503`*^9, + 3.441418707827199*^9, 3.4414910169835653`*^9}] }, Open ]], Cell[CellGroupData[{ Cell[BoxData[+ RowBox[{"AbortTest", "[", "50", "]"}]], "Input",+ CellChangeTimes->{{3.4413814839615593`*^9, 3.44138148687442*^9}, {+ 3.4413858220378847`*^9, 3.441385824935438*^9}, {3.4413860876215363`*^9, + 3.441386092152405*^9}, {3.441387279931728*^9, 3.4413872801019363`*^9}, {+ 3.4414187331544437`*^9, 3.4414187357368517`*^9}}],++Cell[BoxData["True"], "Output",+ CellChangeTimes->{+ 3.441381487619445*^9, 3.44138169978981*^9, 3.441381782395792*^9, {+ 3.441381905687695*^9, 3.441381921320157*^9}, 3.4413827674143963`*^9, + 3.441383632073021*^9, 3.441384195206551*^9, {3.441385787032784*^9, + 3.441385825540018*^9}, {3.441386088582046*^9, 3.441386093667964*^9}, {+ 3.441387258934795*^9, 3.441387288148602*^9}, {3.4413877897953033`*^9, + 3.441387795451263*^9}, {3.441388512784028*^9, 3.4413885577855253`*^9}, {+ 3.44139066804643*^9, 3.4413906737232437`*^9}, {3.4414187117340508`*^9, + 3.44141874145138*^9}, {3.4414910241849747`*^9, 3.441491033597106*^9}}]+}, Open ]],++Cell[CellGroupData[{++Cell[BoxData[ RowBox[{"Uninstall", "[", "lnk", "]"}]], "Input", CellChangeTimes->{{3.439313773653487*^9, 3.439313777607768*^9}}], @@ -215,11 +276,16 @@ 3.440168967229312*^9, 3.440177561117154*^9, 3.440177755031232*^9, 3.440177984565681*^9, 3.4401780921022263`*^9, 3.440180388638576*^9, 3.440261841211409*^9, {3.440264295025028*^9, 3.44026429805313*^9}, - 3.440264432207209*^9}]+ 3.440264432207209*^9, 3.441381406035787*^9, {3.441381675639502*^9, + 3.441381704566267*^9}, 3.4413818574534807`*^9, 3.441382750107748*^9, + 3.441383567485149*^9, 3.44138579638888*^9, 3.4413860740598707`*^9, + 3.441387237789958*^9, 3.441387763869083*^9, {3.441387944051606*^9, + 3.441387958012869*^9}, 3.441390784907803*^9, 3.441418824055894*^9, + 3.441418861733427*^9, 3.4414910414708023`*^9}] }, Open ]] },-WindowSize->{1590, 1102},-WindowMargins->{{0, Automatic}, {Automatic, 31}},+WindowSize->{1916, 1165},+WindowMargins->{{0, Automatic}, {4, Automatic}}, ShowSelection->True, FrontEndVersion->"7.0 for Linux x86 (64-bit) (November 11, 2008)", StyleDefinitions->"Default.nb"@@ -236,45 +302,49 @@ (*NotebookFileOutline Notebook[{ Cell[CellGroupData[{-Cell[567, 22, 213, 4, 61, "Input"],-Cell[783, 28, 209, 2, 61, "Output"]+Cell[567, 22, 213, 4, 88, "Input"],+Cell[783, 28, 259, 3, 88, "Output"] }, Open ]],-Cell[1007, 33, 398, 10, 96, "Text"],+Cell[1057, 34, 398, 10, 96, "Text"], Cell[CellGroupData[{-Cell[1430, 47, 315, 5, 88, "Input"],-Cell[1748, 54, 266, 5, 88, "Output"]+Cell[1480, 48, 315, 5, 88, "Input"],+Cell[1798, 55, 651, 11, 88, "Output"] }, Open ]], Cell[CellGroupData[{-Cell[2051, 64, 146, 3, 88, "Input"],-Cell[2200, 69, 359, 6, 88, "Output"]+Cell[2486, 71, 146, 3, 88, "Input"],+Cell[2635, 76, 691, 10, 88, "Output"] }, Open ]], Cell[CellGroupData[{-Cell[2596, 80, 284, 6, 88, "Input"],-Cell[2883, 88, 447, 9, 88, "Output"]+Cell[3363, 91, 284, 6, 88, "Input"],+Cell[3650, 99, 710, 13, 88, "Output"] }, Open ]], Cell[CellGroupData[{-Cell[3367, 102, 126, 2, 88, "Input"],-Cell[3496, 106, 337, 5, 88, "Output"]+Cell[4397, 117, 126, 2, 88, "Input"],+Cell[4526, 121, 857, 16, 88, "Output"] }, Open ]], Cell[CellGroupData[{-Cell[3870, 116, 300, 8, 88, "Input"],-Cell[4173, 126, 450, 10, 88, "Output"]+Cell[5420, 142, 300, 8, 88, "Input"],+Cell[5723, 152, 770, 18, 88, "Output"] }, Open ]], Cell[CellGroupData[{-Cell[4660, 141, 444, 8, 88, "Input"],-Cell[5107, 151, 517, 11, 88, "Output"]+Cell[6530, 175, 444, 8, 88, "Input"],+Cell[6977, 185, 681, 13, 88, "Output"] }, Open ]], Cell[CellGroupData[{-Cell[5661, 167, 418, 9, 88, "Input"],-Cell[6082, 178, 377, 7, 88, "Output"]+Cell[7695, 203, 418, 9, 88, "Input"],+Cell[8116, 214, 515, 9, 88, "Output"] }, Open ]], Cell[CellGroupData[{-Cell[6496, 190, 327, 7, 88, "Input"],-Cell[6826, 199, 197, 3, 88, "Output"]+Cell[8668, 228, 327, 7, 88, "Input"],+Cell[8998, 237, 367, 5, 88, "Output"] }, Open ]], Cell[CellGroupData[{-Cell[7060, 207, 130, 2, 88, "Input"],-Cell[7193, 211, 341, 6, 88, "Output"]+Cell[9402, 247, 333, 5, 88, "Input"],+Cell[9738, 254, 637, 9, 88, "Output"]+}, Open ]],+Cell[CellGroupData[{+Cell[10412, 268, 130, 2, 88, "Input"],+Cell[10545, 272, 722, 11, 88, "Output"] }, Open ]] } ]
examples/mltest.sh view
@@ -1,2 +1,2 @@ #! /usr/bin/env sh-dist/build/mltest/mltest $@ +RTS -K1G -RTS 1> mltest.out 2> mltest.err+dist/build/mltest/mltest $@ +RTS -K1G -RTS 2> mltest.err
examples/src/Main.hs view
@@ -1,30 +1,24 @@ {-# 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+ efficient marshaling for certain structured types 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 qualified Foreign.MathLink.Expressible as Ex+ import Data.Array.Unboxed import Data.Complex import Control.Monad.Error (throwError)+import Control.Monad.Trans (liftIO)+import System.Timeout -- Example 1: get a pair of integers and return their sum.-addTwo :: ML ()+addTwo :: IO () addTwo = do (m1,m2) <- get put ((m1 + m2) :: Int)@@ -40,7 +34,7 @@ } -- Example 2: reverse a list of numbers (coercing them to Doubles).-reverseNumbers :: ML ()+reverseNumbers :: IO () reverseNumbers = do is <- get put $ reverse (is :: [Double])@@ -61,12 +55,11 @@ } -- 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 ()+-- The first gives a list of single-character strings.+-- The second, an atomic string.+greetWorld :: IO () greetWorld = do- put "Hello, world!"+ put ("Hello, world!", Ex.ExString "Hello, world!") greetWorldFunction = Function { callPattern = "GreetWorld[]"@@ -79,11 +72,11 @@ -- 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 :: IO () reverseArray = do arr <- get let xs = elems (arr :: UArray (Int,Int) Int)- put $ ((listArray (bounds arr) $ reverse xs) :: UArray (Int,Int) Int)+ put ((listArray (bounds arr) $ reverse xs) :: UArray (Int,Int) Int) reverseArrayFunction = Function { callPattern = "ReverseArray[a_?(ArrayQ[#,2,IntegerQ]&)]"@@ -93,17 +86,17 @@ -- Example 5: gets an arbitrary Mathematica expression and returns -- a tweaked version of it.-tweakExpression :: ML ()+tweakExpression :: IO () 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+ Ex.ExInt i -> Ex.ExInt (-i)+ Ex.ExReal r -> Ex.ExReal (-r)+ Ex.ExString s -> Ex.ExString $ reverse s+ Ex.ExSymbol s -> Ex.ExSymbol $ reverse s+ Ex.ExFunction hd args -> Ex.ExFunction (reverse hd) $ map tweak args tweakExpressionFunction = Function { callPattern = "TweakExpression[expr_]"@@ -116,20 +109,21 @@ | Infinity deriving (Eq,Show) -instance Expressible ExtendedComplex where- put Infinity = put $ ExSymbol "Infinity"- put (Finite (r :+ i)) = put $ ExFunction "Complex" [ExReal r,ExReal i]- get = do- expr <- get- case (expr :: Expression) of- ExFunction "DirectedInfinity" [_] -> - return Infinity- ExFunction "Complex" [ExReal r, ExReal i] -> - return $ Finite (r :+ i)- _ -> - throwError $ "Unexpected expression: " ++ show expr+instance Ex.Expressible ExtendedComplex where+ toExpression Infinity = + Ex.ExSymbol "Infinity"+ toExpression (Finite (r :+ i)) = + Ex.ExFunction "Complex" [Ex.ExReal r,Ex.ExReal i]+ fromExpression expr =+ case expr of+ Ex.ExFunction "DirectedInfinity" [_] -> + Right $ Infinity+ Ex.ExFunction "Complex" [Ex.ExReal r, Ex.ExReal i] -> + Right $ Finite (r :+ i)+ _ -> Left $ Ex.ExpressibleErrorMsg $ + "Unexpected expression: " ++ show expr -addExtendedComplexes :: ML ()+addExtendedComplexes :: IO () addExtendedComplexes = do (ec1,ec2) <- get case (ec1,ec2) of@@ -138,11 +132,27 @@ (Finite c1,Finite c2) -> put $ Finite (c1 + c2) addExtendedComplexesFunction = - Function { callPattern = "AddExtendedComplexes[ec1:(Infinity|Complex[_,_]),ec2:(Infinity|Complex[_,_])]"+ Function { callPattern = "AddExtendedComplexes[\+ \ec1:(Infinity|Complex[_,_]),\+ \ec2:(Infinity|Complex[_,_])]" , argumentPattern = "N[{ec1,ec2}]" , function = addExtendedComplexes } +-- Example 7: check for abort+abortTest :: IO ()+abortTest = do+ n <- (get :: IO Int)+ liftIO $ timeout (100000*n) (bottom)+ checkAbort >>= put+ where bottom = (bottom :: IO ())++abortTestFunction = + Function { callPattern = "AbortTest[i_Integer]"+ , argumentPattern = "i"+ , function = abortTest+ }+ -- run mathlink exposing the given list of actions main = runMathLink [ addTwoFunction , reverseNumbersFunction@@ -150,5 +160,6 @@ , reverseArrayFunction , tweakExpressionFunction , addExtendedComplexesFunction+ , abortTestFunction ]
mathlink.cabal view
@@ -1,5 +1,5 @@ Name: mathlink-Version: 0.1.0.2+Version: 1.0.0.0 Cabal-Version: >= 1.6 Build-Type: Simple License: BSD3@@ -22,11 +22,16 @@ 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. +/MathLink/ interface. +.+One defines a Haskell function of type @IO ()@ and provides a pair of +'String's that function analogously to the @:Pattern:@ and @:Arguments:@ +directives for /Mathematica/'s @mprep@ utility.+.+Data whose types are instances of the 'Expressible' class can be marshaled+to\/from /Mathematica/. The library already provides instances for many+data types, including tuples, lists, and unboxed arrays.+. The library does not use or require @foreign export@ declarations, so may be used interactively. }@@ -44,9 +49,8 @@ array >= 0.2 && < 0.3 Exposed-Modules: Foreign.MathLink, Foreign.MathLink.IO,- Foreign.MathLink.ML,- Foreign.MathLink.Types, Foreign.MathLink.Expressible+ C-Sources: src/state.c if arch(i386) || flag(32bit) Extra-Libraries: ML32i3 else
src/Foreign/MathLink.hs view
@@ -1,8 +1,268 @@+{-# LANGUAGE MultiParamTypeClasses+ , FlexibleContexts+ , DeriveDataTypeable+ #-}+ -- | A Haskell interface to /Mathematica/'s /MathLink/.-module Foreign.MathLink ( --- * Basic usage+module Foreign.MathLink ( -- * Basic usage -{- | The following is a small Haskell module that exposes a function + -- $usage++ -- * Types+ Function(..)++ -- * Running /MathLink/+ , runMathLink+ , runMathLinkWithArgs++ -- * Data marshaling+ , get+ , put++ -- * Accessing /MathLink/ state+ , getLink+ , checkAbort+ , checkDone++ -- * Evaluation+ , evaluate+ , evaluateAndWait+ ) where++import Data.Int+import Data.IORef+import Data.Typeable+import Data.Array.Unboxed++import qualified Data.IntMap as IM ( IntMap+ , toList+ , fromList+ , lookup+ )++import Control.Monad.Reader+import Control.Monad.Error++import Control.Exception hiding ( evaluate+ )++import System.IO ( hPutStrLn+ , stderr+ )++import System.Environment ( getArgs+ )++import Foreign.MathLink.Expressible+import Foreign.MathLink.IO++data MLError = MLError+ | MLErrorMsg String+ | MLException SomeException+ | MLErrors [MLError]+ deriving (Typeable)++instance Show MLError where+ show MLError = "MLError"+ show (MLErrorMsg s) = "MLErrorMsg: " ++ s+ show (MLException e) = "MLException: " ++ (show e)+ show (MLErrors errs) = "MLErrors: " ++ show errs++instance Error MLError where+ noMsg = MLError+ strMsg s = MLErrorMsg s++data MLConfig = MLConfig { functionTable :: IM.IntMap Function+ }++-- | 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 :: IO ()+ }++instance Show Function where+ show fn = "Function { callPattern = " ++ + (show $ callPattern fn) ++ + ", argumentPattern = " +++ (show $ argumentPattern fn) ++ " }"++type ML a = ErrorT MLError (ReaderT MLConfig IO) a++getConfig :: ML MLConfig+getConfig = ask++-- | Runs /MathLink/, exposing the given list of functions.+runMathLink :: [Function] -> IO ()+runMathLink functions = do + args <- getArgs+ runMathLinkWithArgs args functions++-- | Like 'runMathLink', but explicitly requires the command line+-- arguments to be passed to /MathLink/.+runMathLinkWithArgs :: [String] + -> [Function] -> IO ()+runMathLinkWithArgs args functions = do+ initializeMathLink $ unwords args+ er <- (runReaderT (runErrorT runLoop) config)+ finalizeMathLink+ case er of+ Left err -> do hPutStrLn stderr $ show err+ return ()+ Right () -> return ()+ where config = MLConfig { functionTable = + IM.fromList $ zip [0..] functions+ }+ +runLoop :: ML ()+runLoop = do+ installFunctionTable+ processPackets++processPackets :: ML ()+processPackets = do+ pkt <- answer+ case pkt of+ ResumePacketCode -> do+ liftIO $ refuseToBeAFrontEnd+ processPackets+ _ -> return ()+ +answer :: ML PacketCode+answer = do+ dn <- liftIO $ checkDone+ if dn then do+ liftIO clearAbort+ return $ mkPacketCode 0+ else do+ pkt <- liftIO $ getPacket+ case pkt of+ CallPacketCode -> do+ liftIO clearAbort+ processCallPacket+ liftIO endPacket+ liftIO newPacket+ answer+ _ -> do+ liftIO clearAbort+ return pkt++printString :: String -> IO ()+printString str = do + evaluate $ ExFunction "Print" [ ExString str ]+ return ()++processCallPacket :: ML ()+processCallPacket = do+ expr <- liftIO get+ case expr of+ ExInt n -> do+ config <- getConfig+ case n `IM.lookup` (functionTable config) of+ Just fn -> liftIO $ handle cleanUp (function fn)+ _ -> throwError $ MLErrorMsg "Function lookup failed."+ _ -> throwError $ MLErrorMsg "Expected int."+ where + cleanUp err = do + clearError+ printString $ "Error occurred in processing call: " ++ show (err :: SomeException)+ put $ ExSymbol "$Failed"+ +refuseToBeAFrontEnd :: IO ()+refuseToBeAFrontEnd = do+ putFunction "EvaluatePacket" 1+ putFunction "Module" 2+ putFunction "List" 1+ putFunction "Set" 2+ put meSym+ put plSym+ putFunction "CompoundExpression" 3+ putFunction "Set" 2+ put plSym+ getLink >>= (liftIO . (\l -> transferExpression l l))+ putFunction "Message" 2+ putFunction "MessageName" 2+ put plSym+ put $ ExString "notfe"+ put meSym+ put meSym+ endPacket+ waitForPacket (== SuspendPacketCode)+ where meSym = ExSymbol "me"+ plSym = ExSymbol "$ParentLink"++installFunctionTable :: ML ()+installFunctionTable = do+ liftIO activate+ functionPairs <- getConfig >>= (return . IM.toList . functionTable)+ mapM_ (liftIO . definePattern) functionPairs+ liftIO $ put $ ExSymbol "End"+ liftIO flush >>= maybeThrow++definePattern :: (Int,Function) -> IO ()+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 :: Expression -> IO Bool+evaluate expr = do+ abrt <- checkAbort+ if abrt then return False else do+ put $ ExFunction "EvaluatePacket" [expr]+ endPacket+ return True++-- | Like 'evaluate', but blocks until the execution is complete.+evaluateAndWait :: Expression -> IO Bool+evaluateAndWait expr = handle + ((const $ return False) :: SomeException -> IO Bool) $+ do abrt <- checkAbort+ if abrt then return False else do+ result <- evaluate expr+ if result then+ waitForPacket (== ReturnPacketCode)+ else+ return ()+ return True++waitForPacket :: (PacketCode -> Bool) -> IO ()+waitForPacket q = do+ pkt <- getPacket+ newPacket+ if q pkt then return () else waitForPacket q++-- lifting utilities++maybeThrow :: Maybe MathLinkError -> ML ()+maybeThrow (Just err) = throwError $ MLException $ toException err+maybeThrow Nothing = return ()++valueOrThrow :: Either MathLinkError b -> ML b+valueOrThrow (Left err) = throwError $ MLException $ toException err+valueOrThrow (Right v) = return v++-- extra documentation++{- $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/: @@ -11,7 +271,7 @@ import 'Foreign.MathLink' -addTwo :: 'ML' ()+addTwo :: 'IO' () addTwo = do (i1,i2) <- 'get' 'put' ((i1 + i2) :: 'Int')@@ -23,64 +283,13 @@ ] @ -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.+A function to be exposed to /Mathematica/ has type @'IO' ()@. In its body +it uses the 'get' function 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
@@ -1,426 +1,929 @@-{-# 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+{-# LANGUAGE FlexibleContexts+ , FlexibleInstances+ , OverlappingInstances+ , DeriveDataTypeable #-}++module Foreign.MathLink.Expressible ( Expression(..)+ , Expressible(..)+ , Dimensional(..)+ , ExpressibleError(..)+ , integralToExpression+ , expressionToIntegral+ , realFracToExpression+ , expressionToRealFrac+ , fromDimensions+ , arrayToExpression+ , expressionToArray+ , arrayToPair+ , pairToArray+ ) where++import Data.Int+import Data.Word+import Data.Ratio+import Data.Complex+import Data.Ix+import Data.Array.IArray+import qualified Data.Array as A+import qualified Data.Array.Unboxed as U+import Data.Typeable+import Control.Exception++import Control.Monad ( replicateM+ )++import Data.List ( tails+ )++import Foreign.MathLink.IO+++-- | 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)++-- | Instances of 'Expressible' are precisely the data types that can+-- be marshaled to and from /Mathematica/.+-- +-- Minimal complete definition: 'toExpression' and 'fromExpression'.+class Expressible a where+ -- | Convert a value to an 'Expression'+ toExpression :: a -> Expression+ -- | Convert an expression to a value.+ fromExpression :: Expression -> Either ExpressibleError a+ -- | Send a value to /Mathematica/.+ put :: a -> IO ()+ put v = put $ toExpression v+ -- | Receive a value from /Mathematica/.+ get :: IO a+ get = do+ expr <- get+ case fromExpression expr of+ Left err -> throwIO err+ Right v -> return v++maybeThrow :: Maybe MathLinkError -> IO ()+maybeThrow (Just err) = throwIO err+maybeThrow Nothing = return ()++valueOrThrow :: Either MathLinkError b -> IO b+valueOrThrow (Left err) = throwIO err+valueOrThrow (Right v) = return v++instance Expressible Expression where+ toExpression = id+ fromExpression = Right+ put expr = + case expr of+ ExInt i -> putInt i >>= maybeThrow+ ExReal r -> putDouble r >>= maybeThrow+ ExString s -> putString s >>= maybeThrow+ ExSymbol s -> putSymbol s >>= maybeThrow+ ExFunction hd args -> do + putFunction hd (length args) >>= maybeThrow+ mapM_ put args+ get = do+ typ <- getType+ case typ of+ ErrorTypeCode -> + getError >>= throwIO+ IntTypeCode -> + getInt >>= valueOrThrow >>= (return . ExInt)+ RealTypeCode -> + getDouble >>= valueOrThrow >>= (return . ExReal)+ StringTypeCode -> + getString >>= valueOrThrow >>= (return . ExString)+ SymbolTypeCode -> + getSymbol >>= valueOrThrow >>= (return . ExSymbol)+ FunctionTypeCode -> do+ (hd,nArgs) <- getFunction >>= valueOrThrow+ args <- replicateM nArgs get+ return $ ExFunction hd args+++-- bool instance++instance Expressible Bool where+ toExpression True = ExSymbol "True"+ toExpression False = ExSymbol "False"+ fromExpression expr =+ case expr of+ ExSymbol "True" -> Right True+ ExSymbol "False" -> Right False+ _ -> marshalErr "Bool" expr+ put True = putSymbol "True" >>= maybeThrow+ put False = putSymbol "False" >>= maybeThrow++instance Expressible Char where+ toExpression c = ExString [c]+ fromExpression expr =+ case expr of+ ExString [c] -> Right c+ _ -> marshalErr "Char" expr++integralToExpression :: Integral i => i -> Expression+integralToExpression = ExInt . fromIntegral++expressionToIntegral :: Integral i + => Expression + -> Either ExpressibleError i+expressionToIntegral expr =+ case expr of+ ExInt i -> Right $ fromIntegral i+ ExReal r -> Right $ truncate r+ _ -> marshalErr "Integral" expr++putWith :: (a -> IO (Maybe MathLinkError)) -> a -> IO ()+putWith f v = f v >>= maybeThrow++getWith :: IO (Either MathLinkError a) -> IO a+getWith f = f >>= valueOrThrow++instance Expressible Int where+ toExpression = integralToExpression+ fromExpression = expressionToIntegral+ put = putWith putInt+ get = getWith getInt++instance Expressible Int8 where+ toExpression = integralToExpression+ fromExpression = expressionToIntegral+ put = putWith putInt16+ get = getWith getInt16++instance Expressible Int16 where+ toExpression = integralToExpression+ fromExpression = expressionToIntegral+ put = putWith putInt16+ get = getWith getInt16++instance Expressible Int32 where+ toExpression = integralToExpression+ fromExpression = expressionToIntegral+ put = putWith putInt32+ get = getWith getInt32++instance Expressible Int64 where+ toExpression = integralToExpression+ fromExpression = expressionToIntegral+ put = putWith putInt+ get = getWith getInt++instance Expressible Integer where+ toExpression = integralToExpression+ fromExpression = expressionToIntegral+ put = putWith putInt+ get = getWith getInt++realFracToExpression :: RealFrac r => r -> Expression+realFracToExpression = ExReal . realToFrac++expressionToRealFrac :: RealFrac r + => Expression + -> Either ExpressibleError r+expressionToRealFrac expr =+ case expr of+ ExInt i -> Right $ realToFrac i+ ExReal r -> Right $ realToFrac r+ _ -> marshalErr "RealFrac" expr++instance Expressible Float where+ toExpression = realFracToExpression+ fromExpression = expressionToRealFrac+ put = putWith putFloat+ get = getWith getFloat++instance Expressible Double where+ toExpression = realFracToExpression+ fromExpression = expressionToRealFrac+ put = putWith putDouble+ get = getWith getDouble++instance (Expressible i, Integral i) => Expressible (Ratio i) where+ toExpression r = ExFunction "Rational" [ toExpression $ numerator r+ , toExpression $ denominator r+ ]+ fromExpression expr =+ case expr of+ ExInt i -> Right $ fromIntegral i+ ExReal r -> Right $ realToFrac r+ ExFunction "Rational" [n,d] ->+ case (fromExpression n, fromExpression d) of+ (Right n', Right d') -> Right $ n' % d'+ (e1,e2) -> Left $ ExpressibleErrors [ e |+ Just e <- [ getErr e1+ , getErr e2+ ] ]+ put r = do + putFunction "Rational" 2 >>= maybeThrow+ put (numerator r) >> put (denominator r)++instance (RealFloat a, Expressible a) => Expressible (Complex a) where+ toExpression (r :+ i) = ExFunction "Complex" $ map toExpression [r,i]+ fromExpression expr =+ case expr of+ ExInt i -> Right $ fromIntegral i+ ExReal r -> Right $ realToFrac r+ ExFunction "Complex" [r,i] -> + case (fromExpression r,fromExpression i) of+ (Right r',Right i') -> Right $ r' :+ i'+ (e1,e2) -> Left $ ExpressibleErrors [ e | + Just e <- [ getErr e1+ , getErr e2+ ] ]+ _ -> marshalErr "Complex" expr + put (r :+ i) = do+ putFunction "Complex" 2 >>= maybeThrow+ put r >> put i++instance Expressible e => Expressible (Maybe e) where+ toExpression (Just e) = ExFunction "Just" [toExpression e]+ toExpression Nothing = ExSymbol "Nothing"+ fromExpression expr =+ case expr of+ ExSymbol "Nothing" -> Right Nothing+ ExFunction "Just" [e] -> + case fromExpression e of+ Left err -> Left err+ Right e -> Right $ Just $ e+ _ -> marshalErr "Maybe" expr+ put (Just e) = do+ putFunction "Just" 1 >>= maybeThrow+ put e+ put Nothing = putSymbol "Nothing" >>= maybeThrow+++instance ( Expressible e1+ , Expressible e2) + => Expressible (Either e1 e2) where+ toExpression (Left l) = ExFunction "Left" [toExpression l]+ toExpression (Right r) = ExFunction "Right" [toExpression r]+ fromExpression expr =+ case expr of+ ExFunction "Left" [e] -> + case fromExpression e of+ Left err -> Left err+ Right l -> Right $ Left $ l+ ExFunction "Right" [e] -> + case fromExpression e of+ Left err -> Left err+ Right r -> Right $ Right $ r+ _ -> marshalErr "Either" expr+ put (Left v) = do+ putFunction "Left" 1 >>= maybeThrow+ put v+ put (Right v) = do+ putFunction "Right" 1 >>= maybeThrow+ put v++-- tuple instances++throwErrs :: [Maybe ExpressibleError] -> IO ()+throwErrs mErrs = throwIO $ collectErrs mErrs++throwErr :: (Show a, Show b) => a -> b -> IO c+throwErr expected got = + case marshalErr expected got of+ Left err -> throwIO err+ Right x -> return x++instance ( Expressible e1+ , Expressible e2+ ) => Expressible (e1,e2) where+ toExpression (ex1,ex2) = + ExFunction "List" $ [ toExpression ex1+ , toExpression ex2+ ]+ fromExpression expr =+ case expr of+ ExFunction _ [ex1,ex2] ->+ case ( fromExpression ex1+ , fromExpression ex2+ ) of+ (Right ex1',Right ex2') -> Right (ex1',ex2')+ (e1,e2) -> + Left $ collectErrs [ getErr e1+ , getErr e2+ ]+ _ -> marshalErr "(,)" expr+ put (v1,v2) = do+ putFunction "List" 2 >>= maybeThrow+ put v1 >> put v2+ get = do+ (hd,n) <- getFunction >>= valueOrThrow+ case (hd,n) of+ ("List",2) -> do v1 <- get+ v2 <- get+ return (v1,v2)+ pr -> throwErr ("List",2) pr++instance ( Expressible e1+ , Expressible e2+ , Expressible e3+ ) => Expressible (e1,e2,e3) where+ toExpression (ex1,ex2,ex3) = + ExFunction "List" $ [ toExpression ex1+ , toExpression ex2+ , toExpression ex3+ ]+ fromExpression expr =+ case expr of+ ExFunction _ [ex1,ex2,ex3] ->+ case ( fromExpression ex1+ , fromExpression ex2+ , fromExpression ex3+ ) of+ (Right ex1',Right ex2',Right ex3') -> + Right (ex1',ex2',ex3')+ (e1,e2,e3) -> + Left $ collectErrs [ getErr e1+ , getErr e2+ , getErr e3+ ]+ _ -> marshalErr "(,,)" expr+ put (v1,v2,v3) = do+ putFunction "List" 3 >>= maybeThrow+ put v1 >> put v2 >> put v3+ get = do+ (hd,n) <- getFunction >>= valueOrThrow+ case (hd,n) of+ ("List",3) -> do v1 <- get+ v2 <- get+ v3 <- get+ return (v1,v2,v3)+ pr -> throwErr ("List",3) pr++instance ( Expressible e1+ , Expressible e2+ , Expressible e3+ , Expressible e4+ ) => Expressible (e1,e2,e3,e4) where+ toExpression (ex1,ex2,ex3,ex4) = + ExFunction "List" $ [ toExpression ex1+ , toExpression ex2+ , toExpression ex3+ , toExpression ex4+ ]+ fromExpression expr =+ case expr of+ ExFunction _ [ex1,ex2,ex3,ex4] ->+ case ( fromExpression ex1+ , fromExpression ex2+ , fromExpression ex3+ , fromExpression ex4+ ) of+ (Right ex1',Right ex2',Right ex3',Right ex4') -> + Right (ex1',ex2',ex3',ex4')+ (e1,e2,e3,e4) -> + Left $ collectErrs [ getErr e1+ , getErr e2+ , getErr e3+ , getErr e4+ ]+ _ -> marshalErr "(,,,)" expr+ put (v1,v2,v3,v4) = do+ putFunction "List" 4 >>= maybeThrow+ put v1 >> put v2 >> put v3 >> put v4+ get = do+ (hd,n) <- getFunction >>= valueOrThrow+ case (hd,n) of+ ("List",4) -> do v1 <- get+ v2 <- get+ v3 <- get+ v4 <- get+ return (v1,v2,v3,v4)+ pr -> throwErr ("List",4) pr++instance ( Expressible e1+ , Expressible e2+ , Expressible e3+ , Expressible e4+ , Expressible e5+ ) => Expressible (e1,e2,e3,e4,e5) where+ toExpression (ex1,ex2,ex3,ex4,ex5) = + ExFunction "List" $ [ toExpression ex1+ , toExpression ex2+ , toExpression ex3+ , toExpression ex4+ , toExpression ex5+ ]+ fromExpression expr =+ case expr of+ ExFunction _ [ex1,ex2,ex3,ex4,ex5] ->+ case ( fromExpression ex1+ , fromExpression ex2+ , fromExpression ex3+ , fromExpression ex4+ , fromExpression ex5+ ) of+ (Right ex1',Right ex2',Right ex3',Right ex4',Right ex5') -> + Right (ex1',ex2',ex3',ex4',ex5')+ (e1,e2,e3,e4,e5) -> + Left $ collectErrs [ getErr e1+ , getErr e2+ , getErr e3+ , getErr e4+ , getErr e5+ ]+ _ -> marshalErr "(,,,,)" expr+ put (v1,v2,v3,v4,v5) = do+ putFunction "List" 5 >>= maybeThrow+ put v1 >> put v2 >> put v3 >> put v4 >> put v5+ get = do+ (hd,n) <- getFunction >>= valueOrThrow+ case (hd,n) of+ ("List",5) -> do v1 <- get+ v2 <- get+ v3 <- get+ v4 <- get+ v5 <- get+ return (v1,v2,v3,v4,v5)+ pr -> throwErr ("List",5) pr++-- list instance(s)++listToExpression :: Expressible e => [e] -> Expression+listToExpression es = ExFunction "List" $ map toExpression es++expressionToList :: + Expressible e => Expression -> Either ExpressibleError [e]+expressionToList expr =+ let mList = case expr of+ ExFunction _ args -> map fromExpression args+ _ -> [marshalErr "List" expr]+ vs = [ v | Right v <- mList ]+ errs = [ err | Left err <- mList ]+ in if null errs then+ Right vs+ else+ Left $ ExpressibleErrors errs++putListWith :: ([e] -> IO (Maybe MathLinkError)) -> [e] -> IO ()+putListWith fn es = fn es >>= maybeThrow++getListWith :: IO (Either MathLinkError [e]) -> IO [e]+getListWith fn = fn >>= valueOrThrow++instance Expressible e => Expressible [e] where+ toExpression = listToExpression+ fromExpression = expressionToList+ put xs = do+ putFunction "List" (length xs)+ mapM_ put xs+ get = do+ (hd,n) <- getFunction >>= valueOrThrow+ case hd of+ "List" -> replicateM n get+ _ -> throwErr "List" hd++instance Expressible [Char] where+ toExpression str = ExString str+ fromExpression expr =+ case expr of+ ExString s -> Right s+ _ -> marshalErr "String" expr+ put str = putString str >>= maybeThrow+ get = getString >>= valueOrThrow++instance Expressible [Int8] where+ toExpression = listToExpression+ fromExpression = expressionToList+ put = putListWith putInt16List+ get = getListWith getInt16List++instance Expressible [Int16] where+ toExpression = listToExpression+ fromExpression = expressionToList+ put = putListWith putInt16List+ get = getListWith getInt16List++instance Expressible [Int32] where+ toExpression = listToExpression+ fromExpression = expressionToList+ put = putListWith putInt32List+ get = getListWith getInt32List++instance Expressible [Int64] where+ toExpression = listToExpression+ fromExpression = expressionToList+ put = putListWith putIntList+ get = getListWith getIntList++instance Expressible [Int] where+ toExpression = listToExpression+ fromExpression = expressionToList+ put = putListWith putIntList+ get = getListWith getIntList++instance Expressible [Float] where+ toExpression = listToExpression+ fromExpression = expressionToList+ put = putListWith putFloatList+ get = getListWith getFloatList++instance Expressible [Double] where+ toExpression = listToExpression+ fromExpression = expressionToList+ put = putListWith putDoubleList+ get = getListWith getDoubleList+++-- array marshaling++exprDimensions :: Expression -> [Int]+exprDimensions expr = + case expr of+ ExFunction "List" (arg:args) ->+ if all (==ad) ads then+ nArgs:ad+ else+ [nArgs]+ where ad = exprDimensions arg+ ads = map exprDimensions args+ nArgs = 1 + (length args)+ _ -> []++exprToList :: Expression -> [Expression]+exprToList (ExFunction "List" args) = args+exprToList v = [v]++flattenExprList :: [Expression] -> [Expression]+flattenExprList exprs = concat $ map exprToList exprs++expressionToPair :: Expressible e + => Expression + -> Either ExpressibleError ([Int],[e])+expressionToPair expr = + if null errs then+ Right (dims,es)+ else+ Left $ ExpressibleErrors errs+ where dims = exprDimensions expr+ rnk = length dims+ flattener = foldr1 (.) $ take rnk $ repeat flattenExprList+ exs = flattener [expr]+ ees = map fromExpression exs+ errs = [ err | Left err <- ees ]+ es = [ e | Right e <- ees ]++pairToArray :: ( Dimensional ix+ , IArray a e+ ) => [Int] -> [e] -> Either ExpressibleError (a ix e)+pairToArray dims xs =+ case fromDimensions dims of+ Left err -> Left err+ Right bnds -> Right $ listArray bnds xs+ +expressionToArray :: ( Expressible e+ , Dimensional ix+ , IArray a e+ ) => Expression -> Either ExpressibleError (a ix e)+expressionToArray expr = + case expressionToPair expr of+ Left err -> Left err+ Right (dims,xs) -> pairToArray dims xs++partitionExprList :: Int -> Int -> [Expression] -> [[Expression]]+partitionExprList num sz exprs = partList num [] exprs+ where partList 0 lsts _ = lsts+ partList n lsts exprs = let (lst,rest) = splitAt sz exprs+ in partList (n-1) (lst:lsts) rest++pairToExpression :: Expressible e => ([Int],[e]) -> Expression+pairToExpression (dims,es) = mkList $ partExpr dims szs exs+ where exs = map toExpression es+ szs = map product $ tail $ tails dims+ mkList exprs = ExFunction "List" exprs+ partExpr [] _ exprs = exprs+ partExpr _ [] exprs = exprs+ partExpr (n:ns) (sz:szs) exprs = + let exprLsts = partitionExprList n sz exprs+ in map (mkList . (partExpr ns szs)) exprLsts++arrayToPair :: ( Dimensional ix+ , IArray a e+ ) => a ix e -> ([Int],[e])+arrayToPair ar = (dimensions $ bounds ar, elems ar)++arrayToExpression :: ( Expressible e+ , Dimensional ix+ , IArray a e+ ) => a ix e -> Expression+arrayToExpression = pairToExpression . arrayToPair ++putArrayWith :: ( IArray a e+ , Dimensional ix+ ) => ([Int] -> [e] -> IO (Maybe MathLinkError))+ -> (a ix e) -> IO ()+putArrayWith fn arr = let (dims,xs) = arrayToPair arr+ in fn dims xs >>= maybeThrow++getArrayWith :: ( IArray a e+ , Dimensional ix+ ) => IO (Either MathLinkError ([Int],[e])) -> IO (a ix e)+getArrayWith fn = do+ (dims,xs) <- fn >>= valueOrThrow+ case pairToArray dims xs of+ Left err -> throwIO err+ Right v -> return v++instance ( Dimensional ix+ ) => Expressible (U.UArray ix Int8) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putInt16Array+ get = getArrayWith getInt16Array++instance ( Dimensional ix+ ) => Expressible (U.UArray ix Int16) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putInt16Array+ get = getArrayWith getInt16Array++instance ( Dimensional ix+ ) => Expressible (U.UArray ix Int32) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putInt32Array+ get = getArrayWith getInt32Array++instance ( Dimensional ix+ ) => Expressible (U.UArray ix Int64) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putIntArray+ get = getArrayWith getIntArray++instance ( Dimensional ix+ ) => Expressible (U.UArray ix Int) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putIntArray+ get = getArrayWith getIntArray++instance ( Dimensional ix+ ) => Expressible (U.UArray ix Float) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putFloatArray+ get = getArrayWith getFloatArray++instance ( Dimensional ix+ ) => Expressible (U.UArray ix Double) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putDoubleArray+ get = getArrayWith getDoubleArray++instance ( Dimensional ix+ ) => Expressible (A.Array ix Int8) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putInt16Array+ get = getArrayWith getInt16Array++instance ( Dimensional ix+ ) => Expressible (A.Array ix Int16) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putInt16Array+ get = getArrayWith getInt16Array++instance ( Dimensional ix+ ) => Expressible (A.Array ix Int32) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putInt32Array+ get = getArrayWith getInt32Array++instance ( Dimensional ix+ ) => Expressible (A.Array ix Int64) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putIntArray+ get = getArrayWith getIntArray++instance ( Dimensional ix+ ) => Expressible (A.Array ix Int) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putIntArray+ get = getArrayWith getIntArray++instance ( Dimensional ix+ ) => Expressible (A.Array ix Float) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putFloatArray+ get = getArrayWith getFloatArray++instance ( Dimensional ix+ ) => Expressible (A.Array ix Double) where+ toExpression = arrayToExpression+ fromExpression = expressionToArray+ put = putArrayWith putDoubleArray+ get = getArrayWith getDoubleArray++-- | Arrays to be marshaled to and from /Mathematica/ require indices+-- that are instances of 'Dimensional'.+class Ix ix => Dimensional ix where+ -- | The rank. Shouldn't examine its argument.+ rank :: ix -> Int+ -- | The dimensions.+ dimensions :: (ix,ix) -> [Int]+ -- | Default lower bound. Shouldn't examine its argument.+ lowerBound :: ix -> ix+ -- | The array upper bound implied by the list of dimensions and the+ -- given lower bound.+ --+ -- Should fail if the length of the list is not equal to the+ -- rank.+ upperBound :: ix -> [Int] -> Either ExpressibleError ix++-- | The bounds implied by the dimesions, using the default lower bound.+fromDimensions :: Dimensional ix => [Int] -> Either ExpressibleError (ix,ix)+fromDimensions dims = + case eU of+ Left err -> Left err+ Right u -> Right (l,u)+ where l = lowerBound undefined+ eU = upperBound l dims++dimensionalErr :: Dimensional ix + => ix + -> [Int] + -> Either ExpressibleError a+dimensionalErr i dims = Left $ ExpressibleErrorMsg $ "Expected " ++ + (show $ rank i) ++ " dimensions, but got " ++ (show $ length dims) ++ "."++instance Dimensional Int where+ rank _ = 1+ dimensions bnds = [rangeSize bnds]+ lowerBound _ = 0+ upperBound l [n] = Right (n+l-1)+ upperBound l ns = dimensionalErr l ns++instance ( Dimensional i1+ , Dimensional i2+ ) => Dimensional (i1,i2) where+ rank (a1,a2) = rank a1 + rank a2+ dimensions ((l1,l2),(u1,u2)) = + dimensions (l1,u1) +++ dimensions (l2,u2)+ lowerBound _ = + ( lowerBound undefined+ , lowerBound undefined+ )+ upperBound (l1,l2) ns = + case (u1',u2') of+ (Right u1,Right u2) -> + Right (u1,u2)+ (e1,e2) -> + Left $ collectErrs [ getErr e1+ , getErr e2+ ] + where (ns1,rest1) = splitAt (rank l1) ns+ ns2 = rest1+ u1' = upperBound l1 ns1+ u2' = upperBound l2 ns2+ +instance ( Dimensional i1+ , Dimensional i2+ , Dimensional i3+ ) => Dimensional (i1,i2,i3) where+ rank (a1,a2,a3) = rank a1 + rank a2 + rank a3+ dimensions ((l1,l2,l3),(u1,u2,u3)) = + dimensions (l1,u1) +++ dimensions (l2,u2) +++ dimensions (l3,u3)+ lowerBound _ = + ( lowerBound undefined+ , lowerBound undefined+ , lowerBound undefined+ )+ upperBound (l1,l2,l3) ns = + case (u1',u2',u3') of+ (Right u1,Right u2,Right u3) -> + Right (u1,u2,u3)+ (e1,e2,e3) -> + Left $ collectErrs [ getErr e1+ , getErr e2+ , getErr e3+ ]+ where (ns1,rest1) = splitAt (rank l1) ns+ (ns2,rest2) = splitAt (rank l2) rest1+ ns3 = rest2+ u1' = upperBound l1 ns1+ u2' = upperBound l2 ns2+ u3' = upperBound l3 ns3+ +instance ( Dimensional i1+ , Dimensional i2+ , Dimensional i3+ , Dimensional i4+ ) => Dimensional (i1,i2,i3,i4) where+ rank (a1,a2,a3,a4) = rank a1 + rank a2 + rank a3 + rank a4+ dimensions ((l1,l2,l3,l4),(u1,u2,u3,u4)) = + dimensions (l1,u1) +++ dimensions (l2,u2) +++ dimensions (l3,u3) +++ dimensions (l4,u4)+ lowerBound _ = + ( lowerBound undefined+ , lowerBound undefined+ , lowerBound undefined+ , lowerBound undefined+ )+ upperBound (l1,l2,l3,l4) ns = + case (u1',u2',u3',u4') of+ (Right u1,Right u2,Right u3,Right u4) -> + Right (u1,u2,u3,u4)+ (e1,e2,e3,e4) -> + Left $ collectErrs [ getErr e1+ , getErr e2+ , getErr e3+ , getErr e4+ ]+ where (ns1,rest1) = splitAt (rank l1) ns+ (ns2,rest2) = splitAt (rank l2) rest1+ (ns3,rest3) = splitAt (rank l3) rest2+ ns4 = rest3+ u1' = upperBound l1 ns1+ u2' = upperBound l2 ns2+ u3' = upperBound l3 ns3+ u4' = upperBound l4 ns4++instance ( Dimensional i1+ , Dimensional i2+ , Dimensional i3+ , Dimensional i4+ , Dimensional i5+ ) => Dimensional (i1,i2,i3,i4,i5) where+ rank (a1,a2,a3,a4,a5) = rank a1 + rank a2 + rank a3 + rank a4 + rank a5+ 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)+ lowerBound _ = + ( lowerBound undefined+ , lowerBound undefined+ , lowerBound undefined+ , lowerBound undefined+ , lowerBound undefined+ )+ upperBound (l1,l2,l3,l4,l5) ns = + case (u1',u2',u3',u4',u5') of+ (Right u1,Right u2,Right u3,Right u4,Right u5) -> + Right (u1,u2,u3,u4,u5)+ (e1,e2,e3,e4,e5) -> + Left $ collectErrs [ getErr e1+ , getErr e2+ , getErr e3+ , getErr e4+ , getErr e5+ ]+ where (ns1,rest1) = splitAt (rank l1) ns+ (ns2,rest2) = splitAt (rank l2) rest1+ (ns3,rest3) = splitAt (rank l3) rest2+ (ns4,rest4) = splitAt (rank l4) rest3+ ns5 = rest4+ u1' = upperBound l1 ns1+ u2' = upperBound l2 ns2+ u3' = upperBound l3 ns3+ u4' = upperBound l4 ns4+ u5' = upperBound l5 ns5++getErr :: Either a b -> Maybe a+getErr (Left a) = Just a+getErr _ = Nothing++collectErrs :: [Maybe ExpressibleError] -> ExpressibleError+collectErrs mErrs = ExpressibleErrors [ e | Just e <- mErrs ]++data ExpressibleError = ExpressibleError + | ExpressibleErrorMsg String+ | ExpressibleErrors [ExpressibleError]+ deriving (Eq,Show,Typeable)++instance Exception ExpressibleError where+ toException = SomeException+ fromException (SomeException e) = cast e++marshalErr :: (Show a, Show b) => a -> b -> Either ExpressibleError c+marshalErr expect expr = + Left $ ExpressibleErrorMsg $ + "Expected " ++ (show expect) ++ " but got: " ++ (show expr)+
src/Foreign/MathLink/IO.hs view
@@ -1,449 +1,1082 @@-{-# 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 ()-+{-# LANGUAGE CPP, ForeignFunctionInterface, FlexibleContexts, DeriveDataTypeable #-}+{-# CFILES src/state.c #-}++module Foreign.MathLink.IO ( Link+ , MessageCode(..)+ , firstUserMessageCode+ , lastUserMessageCode+ , mkMessageCode+ , TypeCode(..)+ , mkTypeCode+ , PacketCode(..)+ , firstUserPacketCode+ , lastUserPacketCode+ , mkPacketCode+ , ErrorCode(..)+ , mkErrorCode+ , MathLinkError(..)+ , getLink+ , checkAbort+ , checkDone+ , clearAbort+ , initializeMathLink+ , finalizeMathLink+ , activate+ , flush+ , checkReady+ , getError+ , clearError+ , getPacket+ , endPacket+ , newPacket+ , getMessage+ , putMessage+ , checkMessage+ , transferExpression+ , putInt16+ , getInt16+ , putInt32+ , getInt32+ , putInt+ , getInt+ , putFloat+ , getFloat+ , putDouble+ , getDouble+ , putInt16List+ , getInt16List+ , putInt32List+ , getInt32List+ , putIntList+ , getIntList+ , putFloatList+ , getFloatList+ , putDoubleList+ , getDoubleList+ , putInt16Array+ , getInt16Array+ , putInt32Array+ , getInt32Array+ , putIntArray+ , getIntArray+ , putFloatArray+ , getFloatArray+ , putDoubleArray+ , getDoubleArray+ , putString+ , getString+ , putSymbol+ , getSymbol+ , putFunction+ , getFunction+ , getType+ ) where++import Foreign ( Ptr+ , nullPtr+ , malloc+ , free+ , peek+ , poke+ , Storable+ , withArray+ , peekArray+ )++import Foreign.C ( peekCString+ , withCString+ , CString+ , CInt+ , CShort+ , CLong+ , CFloat+ , CDouble+ )++import Control.Exception++import Data.Int+import Data.Typeable++-- 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++-- | An enumeration of some error codes defined in @mathlink.h@.+data ErrorCode = NoErrorCode+ | DeadLnkErrorCode+ | GetInconsistentErrorCode+ | GetOutOfSeqErrorCode+ | PutBadTokErrorCode+ | PutOutOfSeqErrorCode+ | PutTooBigErrorCode+ | MachineOverflowErrorCode+ | OutOfMemoryErrorCode+ | SocketUnacceptedErrorCode+ | UnconnectedErrorCode+ | PutEndPacketErrorCode+ | NextIncompleteCurrentPacketErrorCode+ | NextUnknownPacketErrorCode+ | GetEndPacketErrorCode+ | AbortErrorCode+ | ClosedErrorCode+ | InitErrorCode+ | ArgvErrorCode+ | ProtocolErrorCode+ | ModeErrorCode+ | LaunchErrorCode+ | RelaunchErrorCode+ | LaunchSpaceErrorCode+ | NoParentErrorCode+ | NameTakenErrorCode+ | NoListenErrorCode+ | BadNameErrorCode+ | BadHostErrorCode+ | LaunchFailedErrorCode+ | LaunchNameErrorCode+ | PutConvertErrorCode+ | GetConvertErrorCode+ | PutBadEncodingErrorCode+ | UnknownErrorCode Int+ deriving (Eq,Show)++instance Enum ErrorCode where+ fromEnum r = + case r of+ NoErrorCode -> 0+ DeadLnkErrorCode -> 1+ GetInconsistentErrorCode -> 2+ GetOutOfSeqErrorCode -> 3+ PutBadTokErrorCode -> 4+ PutOutOfSeqErrorCode -> 5+ PutTooBigErrorCode -> 6+ MachineOverflowErrorCode -> 7+ OutOfMemoryErrorCode -> 8+ SocketUnacceptedErrorCode -> 9+ UnconnectedErrorCode -> 10+ PutEndPacketErrorCode -> 21+ NextIncompleteCurrentPacketErrorCode -> 22+ NextUnknownPacketErrorCode -> 23+ GetEndPacketErrorCode -> 24+ AbortErrorCode -> 25+ ClosedErrorCode -> 11+ InitErrorCode -> 32+ ArgvErrorCode -> 33+ ProtocolErrorCode -> 34+ ModeErrorCode -> 35+ LaunchErrorCode -> 36+ RelaunchErrorCode -> 37+ LaunchSpaceErrorCode -> 38+ NoParentErrorCode -> 39+ NameTakenErrorCode -> 40+ NoListenErrorCode -> 41+ BadNameErrorCode -> 42+ BadHostErrorCode -> 43+ LaunchFailedErrorCode -> 45+ LaunchNameErrorCode -> 46+ PutConvertErrorCode -> 48+ GetConvertErrorCode -> 49+ PutBadEncodingErrorCode -> 47+ UnknownErrorCode i -> i++ toEnum i =+ case i of+ 0 -> NoErrorCode + 1 -> DeadLnkErrorCode + 2 -> GetInconsistentErrorCode + 3 -> GetOutOfSeqErrorCode + 4 -> PutBadTokErrorCode + 5 -> PutOutOfSeqErrorCode + 6 -> PutTooBigErrorCode + 7 -> MachineOverflowErrorCode + 8 -> OutOfMemoryErrorCode + 9 -> SocketUnacceptedErrorCode + 10 -> UnconnectedErrorCode + 21 -> PutEndPacketErrorCode + 22 -> NextIncompleteCurrentPacketErrorCode + 23 -> NextUnknownPacketErrorCode + 24 -> GetEndPacketErrorCode + 25 -> AbortErrorCode + 11 -> ClosedErrorCode + 32 -> InitErrorCode+ 33 -> ArgvErrorCode+ 34 -> ProtocolErrorCode+ 35 -> ModeErrorCode+ 36 -> LaunchErrorCode+ 37 -> RelaunchErrorCode+ 38 -> LaunchSpaceErrorCode+ 39 -> NoParentErrorCode+ 40 -> NameTakenErrorCode+ 41 -> NoListenErrorCode+ 42 -> BadNameErrorCode+ 43 -> BadHostErrorCode+ 45 -> LaunchFailedErrorCode+ 46 -> LaunchNameErrorCode+ 48 -> PutConvertErrorCode+ 49 -> GetConvertErrorCode+ 47 -> PutBadEncodingErrorCode+ i -> UnknownErrorCode i++instance Ord ErrorCode where+ compare e1 e2 = compare (fromEnum e1) (fromEnum e2)++-- | Turns an 'Integral' into the corresponding 'ErrorCode'.+mkErrorCode :: Integral a => a -> ErrorCode+mkErrorCode = toEnum . fromIntegral++-- | An enumeration of /MathLink/ message types.+data MessageCode = TerminateMessageCode+ | InterruptMessageCode+ | AbortMessageCode+ | EndPacketMessageCode+ | SynchronizeMessageCode+ | ImDyingMessageCode+ | WaitingAcknowledgementMessageCode+ | MarkTopLevelMessageCode+ | LinkClosingMessageCode+ | AuthenticateFailureMessageCode+ | UserMessageCode Int+ | UnknownMessageCode Int+ deriving (Eq,Show)++instance Enum MessageCode where+ fromEnum m =+ case m of+ TerminateMessageCode -> 1+ InterruptMessageCode -> 2+ AbortMessageCode -> 3+ EndPacketMessageCode -> 4+ SynchronizeMessageCode -> 5+ ImDyingMessageCode -> 6+ WaitingAcknowledgementMessageCode -> 7+ MarkTopLevelMessageCode -> 8+ LinkClosingMessageCode -> 9+ AuthenticateFailureMessageCode -> 10+ UserMessageCode i -> i+ UnknownMessageCode i -> i++ toEnum i =+ case i of+ i | i >= 128 && i <= 255 -> UserMessageCode i+ 1 -> TerminateMessageCode+ 2 -> InterruptMessageCode+ 3 -> AbortMessageCode+ 4 -> EndPacketMessageCode+ 5 -> SynchronizeMessageCode+ 6 -> ImDyingMessageCode+ 7 -> WaitingAcknowledgementMessageCode+ 8 -> MarkTopLevelMessageCode+ 9 -> LinkClosingMessageCode+ 10 -> AuthenticateFailureMessageCode+ i -> UnknownMessageCode i++instance Ord MessageCode where+ compare m1 m2 = compare (fromEnum m1) (fromEnum m2)++firstUserMessageCode :: MessageCode+firstUserMessageCode = UserMessageCode 128++lastUserMessageCode :: MessageCode+lastUserMessageCode = UserMessageCode 255++mkMessageCode :: Integral a => a -> MessageCode+mkMessageCode = toEnum . fromIntegral+++-- | An enumeration of /MathLink/ packet types+data PacketCode = IllegalPacketCode+ | CallPacketCode+ | EvaluatePacketCode+ | ReturnPacketCode+ | InputNamePacketCode+ | EnterTextPacketCode+ | EnterExpressionPacketCode+ | OutputNamePacketCode+ | ReturnTextPacketCode+ | ReturnExpressionPacketCode+ | DisplayPacketCode+ | DisplayEndPacketCode+ | MessagePacketCode+ | TextPacketCode+ | InputPacketCode+ | InputStringPacketCode+ | MenuPacketCode+ | SyntaxPacketCode+ | SuspendPacketCode+ | ResumePacketCode+ | BeginDialogPacketCode+ | EndDialogPacketCode+ | UserPacketCode Int+ | UnknownPacketCode Int+ deriving (Eq,Show)++instance Enum PacketCode where+ fromEnum p =+ case p of+ IllegalPacketCode -> 0+ CallPacketCode -> 7+ EvaluatePacketCode -> 13+ ReturnPacketCode -> 3+ InputNamePacketCode -> 8+ EnterTextPacketCode -> 14+ EnterExpressionPacketCode -> 15+ OutputNamePacketCode -> 9+ ReturnTextPacketCode -> 4+ ReturnExpressionPacketCode -> 16+ DisplayPacketCode -> 11+ DisplayEndPacketCode -> 12+ MessagePacketCode -> 5+ TextPacketCode -> 2+ InputPacketCode -> 1+ InputStringPacketCode -> 21+ MenuPacketCode -> 6+ SyntaxPacketCode -> 10+ SuspendPacketCode -> 17+ ResumePacketCode -> 18+ BeginDialogPacketCode -> 19+ EndDialogPacketCode -> 20+ UserPacketCode i -> i+ UnknownPacketCode i -> i++ toEnum i = + case i of+ 0 -> IllegalPacketCode+ 7 -> CallPacketCode+ 13 -> EvaluatePacketCode+ 3 -> ReturnPacketCode+ 8 -> InputNamePacketCode+ 14 -> EnterTextPacketCode+ 15 -> EnterExpressionPacketCode+ 9 -> OutputNamePacketCode+ 4 -> ReturnTextPacketCode+ 16 -> ReturnExpressionPacketCode+ 11 -> DisplayPacketCode+ 12 -> DisplayEndPacketCode+ 5 -> MessagePacketCode+ 2 -> TextPacketCode+ 1 -> InputPacketCode+ 21 -> InputStringPacketCode+ 6 -> MenuPacketCode+ 10 -> SyntaxPacketCode+ 17 -> SuspendPacketCode+ 18 -> ResumePacketCode+ 19 -> BeginDialogPacketCode+ 20 -> EndDialogPacketCode+ i | i >= 128 && i <= 255 -> UserPacketCode i+ i -> UnknownPacketCode i++instance Ord PacketCode where+ compare p1 p2 = compare (fromEnum p1) (fromEnum p2)++firstUserPacketCode :: PacketCode+firstUserPacketCode = UserPacketCode 128++lastUserPacketCode :: PacketCode+lastUserPacketCode = UserPacketCode 255++mkPacketCode :: Integral a => a -> PacketCode+mkPacketCode = toEnum . fromIntegral++-- | An enumeriation of possible return values from the /MathLink/ functions @MLGetNext@ or @MLGetType@.+data TypeCode = ErrorTypeCode+ | IntTypeCode+ | RealTypeCode+ | StringTypeCode+ | SymbolTypeCode+ | FunctionTypeCode+ | UnknownTypeCode Int+ deriving (Eq,Show)++instance Enum TypeCode where+ fromEnum t = + case t of+ ErrorTypeCode -> 0+ IntTypeCode -> 43+ RealTypeCode -> 42+ StringTypeCode -> 34+ SymbolTypeCode -> 35+ FunctionTypeCode -> 70+ UnknownTypeCode i -> i++ toEnum i = + case i of+ 0 -> ErrorTypeCode+ 43 -> IntTypeCode+ 42 -> RealTypeCode+ 34 -> StringTypeCode+ 35 -> SymbolTypeCode+ 70 -> FunctionTypeCode+ 73 -> IntTypeCode -- old int type+ 82 -> RealTypeCode -- old real type+ 83 -> StringTypeCode -- old string type+ 89 -> SymbolTypeCode -- old symbol type+ i -> UnknownTypeCode i++instance Ord TypeCode where+ compare t1 t2 = compare (fromEnum t1) (fromEnum t2)++mkTypeCode :: Integral a => a -> TypeCode+mkTypeCode = toEnum . fromIntegral++data MathLinkError = MathLinkError ErrorCode String+ deriving (Eq,Show,Typeable)++instance Exception MathLinkError where+ toException = SomeException+ fromException (SomeException e) = cast e++type MathLinkMessage = (MessageCode,Int)++newtype Link = Link (Ptr ()) deriving (Eq)+++-- state++foreign import ccall safe "mathlink.h & MLAbort" abortPtr+ :: Ptr CInt++foreign import ccall safe "mathlink.h & MLDone" donePtr+ :: Ptr CInt++foreign import ccall safe "mathlink.h & stdlink" stdlinkPtr+ :: Ptr (Ptr ())++checkAbort :: IO Bool+checkAbort = do+ i <- peek abortPtr+ if i == 0 then+ return False+ else+ return True++checkDone :: IO Bool+checkDone = do+ i <- peek donePtr+ if i == 0 then+ return False+ else+ return True++clearAbort :: IO ()+clearAbort = poke abortPtr 0++getLink :: IO Link+getLink = peek stdlinkPtr >>= (return . Link)+++-- initialization / termination++foreign import ccall safe "MLInitializeMathLink" mlInitializeMathLink+ :: CString -> IO CInt++initializeMathLink :: String -> IO Bool+initializeMathLink str= do + i <- withCString str (\cstr -> mlInitializeMathLink cstr)+ if i == 0 then return False else return True++foreign import ccall safe "MLFinalizeMathLink" mlFinalizeMathLink+ :: IO ()++finalizeMathLink :: IO ()+finalizeMathLink = mlFinalizeMathLink++foreign import ccall safe "mathlink.h MLActivate" mlActivate+ :: Link -> IO CInt++activate :: IO (Maybe MathLinkError)+activate = getLink >>= mlActivate >>= maybeError++foreign import ccall safe "mathlink.h MLFlush" mlFlush+ :: Link -> IO CInt++flush :: IO (Maybe MathLinkError)+flush = getLink >>= mlFlush >>= maybeError++foreign import ccall safe "mathlink.h MLReady" mlReady+ :: Link -> IO CInt++checkReady :: IO Bool+checkReady = do + i <- getLink >>= mlReady+ if i /= 0 then+ return True+ else+ return False +++-- errors++foreign import ccall safe "mathlink.h MLError" mlError+ :: Link -> IO CInt++foreign import ccall safe "mathlink.h MLErrorMessage" mlErrorMessage+ :: Link -> IO CString++foreign import ccall safe "mathlink.h MLClearError" mlClearError+ :: Link -> IO CInt++getErrorCode :: IO ErrorCode+getErrorCode = getLink >>= mlError >>= (return . mkErrorCode)++getErrorMessage :: IO String+getErrorMessage = getLink >>= mlErrorMessage >>= peekCString++getError :: IO MathLinkError+getError = do code <- getErrorCode+ msg <- getErrorMessage+ return $ MathLinkError code msg++clearError :: IO (Maybe MathLinkError)+clearError = getLink >>= mlClearError >>= maybeError++maybeError :: Integral a => a -> IO (Maybe MathLinkError)+maybeError i =+ if i /= 0 then+ return Nothing+ else+ getError >>= (return . Just)++valueOrError :: Integral a => b -> a -> IO (Either MathLinkError b)+valueOrError val i = + if i /= 0 then + return $ Right val + else + getError >>= (return . Left)+++-- packets+ +foreign import ccall safe "mathlink.h MLNextPacket" mlNextPacket+ :: Link -> IO CInt++getPacket :: IO PacketCode+getPacket = getLink >>= mlNextPacket >>= (return . toEnum . fromIntegral)++foreign import ccall safe "mathlink.h MLEndPacket" mlEndPacket+ :: Link -> IO CInt++endPacket :: IO (Maybe MathLinkError)+endPacket = getLink >>= mlEndPacket >>= maybeError++foreign import ccall safe "mathlink.h MLNewPacket" mlNewPacket+ :: Link -> IO CInt++newPacket :: IO (Maybe MathLinkError)+newPacket = getLink >>= mlNewPacket >>= maybeError+++-- messages++foreign import ccall safe "mathlink.h MLGetMessage" mlGetMessage+ :: Link -> Ptr CInt -> Ptr CInt -> IO CInt++getMessage :: IO (Maybe MathLinkMessage)+getMessage = do+ l <- getLink+ bracket malloc free $ \mPtr ->+ bracket malloc free $ \aPtr -> do+ i <- mlGetMessage l mPtr aPtr + if i /= 0 then do+ msgId <- peek mPtr+ arg <- peek aPtr+ return $ Just (mkMessageCode msgId, fromIntegral arg)+ else+ return $ Nothing+ +foreign import ccall safe "mathlink.h MLPutMessage" mlPutMessage+ :: Link -> CInt -> IO CInt++putMessage :: MessageCode -> IO (Maybe MathLinkError)+putMessage m = do+ l <- getLink+ mlPutMessage l (fromIntegral $ fromEnum m) >>= maybeError++foreign import ccall safe "mathlink.h MLMessageReady" mlMessageReady+ :: Link -> IO CInt++checkMessage :: IO Bool+checkMessage = do+ i <- getLink >>= mlMessageReady + if i /= 0 then+ return True+ else+ return False+++ -- misc++foreign import ccall safe "mathlink.h MLTransferExpression" mlTransferExpression+ :: Link -> Link -> IO CInt++transferExpression :: Link -> Link -> IO (Maybe MathLinkError)+transferExpression l1 l2 = mlTransferExpression l1 l2 >>= maybeError+++-- ** data marshalling **++-- scalars++foreign import ccall safe "mathlink.h MLPutInteger16" mlPutInt16+ :: Link -> CInt -> IO CInt++foreign import ccall safe "mathlink.h MLPutInteger32" mlPutInt32+ :: Link -> CInt -> IO CInt++#ifdef USE_INT32+mlPutInt = mlPutInt32+#elif defined USE_INT64+foreign import ccall safe "mathlink.h MLPutInteger64" mlPutInt+ :: Link -> CLong -> IO CInt+#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 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++putScalarWith :: (Link -> b -> IO CInt)+ -> (a -> b)+ -> a+ -> IO (Maybe MathLinkError)+putScalarWith fn cnv i = do+ l <- getLink+ fn l (cnv i) >>= maybeError++getScalarWith :: Storable a+ => (Link -> Ptr a -> IO CInt)+ -> (a -> b)+ -> IO (Either MathLinkError b)+getScalarWith fn cnv = do+ l <- getLink+ bracket malloc free $ \xPtr -> do+ result <- fn l xPtr >>= maybeError+ case result of+ Nothing ->+ peek xPtr >>= (return . Right . cnv)+ Just err ->+ return $ Left err++putInt16 :: Integral a => a -> IO (Maybe MathLinkError)+putInt16 = putScalarWith mlPutInt16 fromIntegral++getInt16 :: Num a => IO (Either MathLinkError a)+getInt16 = getScalarWith mlGetInt16 fromIntegral++putInt32 :: Integral a => a -> IO (Maybe MathLinkError)+putInt32 = putScalarWith mlPutInt32 fromIntegral++getInt32 :: Num a => IO (Either MathLinkError a)+getInt32 = getScalarWith mlGetInt32 fromIntegral++putInt :: Integral a => a -> IO (Maybe MathLinkError)+putInt = putScalarWith mlPutInt fromIntegral++getInt :: Num a => IO (Either MathLinkError a)+getInt = getScalarWith mlGetInt fromIntegral++putFloat :: Real a => a -> IO (Maybe MathLinkError)+putFloat = putScalarWith mlPutReal32 realToFrac++getFloat :: Fractional a => IO (Either MathLinkError a)+getFloat = getScalarWith mlGetReal32 realToFrac++putDouble :: Real a => a -> IO (Maybe MathLinkError)+putDouble = putScalarWith mlPutReal64 realToFrac++getDouble :: Fractional a => IO (Either MathLinkError a)+getDouble = getScalarWith mlGetReal64 realToFrac+++-- string-like data++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 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 MLGetFunction" mlGetFunction+ :: Link -> Ptr CString -> Ptr CInt -> IO CInt++putStringWith :: (Link -> CString -> IO CInt)+ -> String+ -> IO (Maybe MathLinkError)+putStringWith fn str = do+ l <- getLink+ withCString str $ \sPtr -> fn l sPtr >>= maybeError++getStringWith :: (Link -> Ptr CString -> IO CInt)+ -> (Link -> CString -> IO ())+ -> IO (Either MathLinkError String)+getStringWith afn rfn = do+ l <- getLink+ bracket malloc free $ \strPtrPtr -> do+ result <- afn l strPtrPtr >>= maybeError+ case result of+ Nothing -> do+ strPtr <- peek strPtrPtr+ str <- peekCString strPtr+ rfn l strPtr+ return $ Right str+ Just err ->+ return $ Left err++putString :: String -> IO (Maybe MathLinkError)+putString = putStringWith mlPutString ++getString :: IO (Either MathLinkError String)+getString = getStringWith mlGetString mlReleaseString++putSymbol :: String -> IO (Maybe MathLinkError)+putSymbol = putStringWith mlPutSymbol ++getSymbol :: IO (Either MathLinkError String)+getSymbol = getStringWith mlGetSymbol mlReleaseSymbol++putFunction :: String -> Int -> IO (Maybe MathLinkError)+putFunction hd n = + putStringWith (\l' s -> mlPutFunction l' s (fromIntegral n)) hd++getFunction :: IO (Either MathLinkError (String,Int))+getFunction = do+ l <- getLink+ bracket malloc free $ \strPtrPtr ->+ bracket malloc free $ \nPtr -> do+ result <- mlGetFunction l strPtrPtr nPtr >>= maybeError+ case result of+ Nothing -> do+ strPtr <- peek strPtrPtr+ str <- peekCString strPtr+ n <- peek nPtr+ mlReleaseSymbol l strPtr+ return $ Right (str,fromIntegral n)+ Just err ->+ return $ Left err+++ -- lists++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 = 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 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 = 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 = 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++putListWith :: Storable a+ => (Link -> Ptr a -> CInt -> IO CInt)+ -> (b -> a)+ -> [b]+ -> IO (Maybe MathLinkError)+putListWith fn cnv xs = do+ l <- getLink+ withArray (map cnv xs) $ \xPtr -> fn l xPtr n >>= maybeError+ where n = fromIntegral $ length xs++getListWith :: Storable a+ => (Link -> Ptr (Ptr a) -> Ptr CInt -> IO CInt)+ -> (Link -> Ptr a -> CInt -> IO CInt)+ -> (a -> b)+ -> IO (Either MathLinkError [b])+getListWith afn rfn cnv = do+ l <- getLink+ bracket malloc free $ \xPtrPtr ->+ bracket malloc free $ \nPtr -> do+ result <- afn l xPtrPtr nPtr >>= maybeError+ case result of+ Nothing -> do+ xPtr <- peek xPtrPtr+ n <- peek nPtr+ xs <- peekArray (fromIntegral n) xPtr+ rfn l xPtr n+ return $ Right (map cnv xs)+ Just err ->+ return $ Left err++putInt16List :: Integral a => [a] -> IO (Maybe MathLinkError)+putInt16List = putListWith mlPutInt16List fromIntegral++getInt16List :: Num a => IO (Either MathLinkError [a])+getInt16List = + getListWith mlGetInt16List mlReleaseInt16List fromIntegral++putInt32List :: Integral a => [a] -> IO (Maybe MathLinkError)+putInt32List = putListWith mlPutInt32List fromIntegral++getInt32List :: Num a => IO (Either MathLinkError [a])+getInt32List = + getListWith mlGetInt32List mlReleaseInt32List fromIntegral++putIntList :: Integral a => [a] -> IO (Maybe MathLinkError)+putIntList = putListWith mlPutIntList fromIntegral++getIntList :: Num a => IO (Either MathLinkError [a])+getIntList = + getListWith mlGetIntList mlReleaseIntList fromIntegral++putFloatList :: Real a => [a] -> IO (Maybe MathLinkError)+putFloatList = putListWith mlPutReal32List realToFrac++getFloatList :: Fractional a => IO (Either MathLinkError [a])+getFloatList = + getListWith mlGetReal32List mlReleaseReal32List realToFrac++putDoubleList :: Real a => [a] -> IO (Maybe MathLinkError)+putDoubleList = putListWith mlPutReal64List realToFrac++getDoubleList :: Fractional a => IO (Either MathLinkError [a])+getDoubleList = + getListWith mlGetReal64List mlReleaseReal64List realToFrac+++-- arrays++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 = 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++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 ()++putArrayWith :: ( Storable a+ )+ => (Link -> Ptr a -> Ptr CInt -> Ptr CString -> CInt -> IO CInt)+ -> (b -> a)+ -> [Int]+ -> [b]+ -> IO (Maybe MathLinkError)+putArrayWith fn cnv dims xs = do+ l <- getLink+ (withArray (take sz (map cnv xs)) $ \xPtr ->+ withArray (map fromIntegral dims) $ \dimPtr ->+ withCString "List" $ \strPtr ->+ withArray (replicate rank strPtr) $ \hdsPtr ->+ fn l xPtr dimPtr hdsPtr (fromIntegral rank)) >>= maybeError+ 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)+ -> IO (Either MathLinkError ([Int],[b]))+getArrayWith afn rfn cnv = do+ l <- getLink+ bracket malloc free $ \xPtrPtr ->+ bracket malloc free $ \dimPtrPtr ->+ bracket malloc free $ \headPtrPtr ->+ bracket malloc free $ \rankPtr -> do+ result <- + afn l xPtrPtr dimPtrPtr headPtrPtr rankPtr >>= maybeError+ case result of+ Nothing -> 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'))+ Just err ->+ return $ Left err++putInt16Array :: Integral a => [Int] -> [a] -> IO (Maybe MathLinkError)+putInt16Array = putArrayWith mlPutInt16Array fromIntegral++putInt32Array :: Integral a => [Int] -> [a] -> IO (Maybe MathLinkError)+putInt32Array = putArrayWith mlPutInt32Array fromIntegral++putIntArray :: Integral a => [Int] -> [a] -> IO (Maybe MathLinkError)+putIntArray = putArrayWith mlPutIntArray fromIntegral++putFloatArray :: Real a => [Int] -> [a] -> IO (Maybe MathLinkError)+putFloatArray = putArrayWith mlPutReal32Array realToFrac++putDoubleArray :: Real a => [Int] -> [a] -> IO (Maybe MathLinkError)+putDoubleArray = putArrayWith mlPutReal64Array realToFrac++getInt16Array :: Num a => IO (Either MathLinkError ([Int],[a]))+getInt16Array = + getArrayWith mlGetInt16Array mlReleaseInt16Array fromIntegral++getInt32Array :: Num a => IO (Either MathLinkError ([Int],[a]))+getInt32Array = + getArrayWith mlGetInt32Array mlReleaseInt32Array fromIntegral++getIntArray :: Num a => IO (Either MathLinkError ([Int],[a]))+getIntArray = + getArrayWith mlGetIntArray mlReleaseIntArray fromIntegral++getFloatArray :: Fractional a => IO (Either MathLinkError ([Int],[a]))+getFloatArray = + getArrayWith mlGetReal32Array mlReleaseReal32Array realToFrac++getDoubleArray :: Fractional a => IO (Either MathLinkError ([Int],[a]))+getDoubleArray = + getArrayWith mlGetReal64Array mlReleaseReal64Array realToFrac+++-- input testing++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 MLTestHead" mlTestHead+ :: Link -> CString -> Ptr CInt -> IO CInt++getType :: IO TypeCode+getType = getLink >>= mlGetType >>= (return . mkTypeCode)
− src/Foreign/MathLink/ML.hs
@@ -1,399 +0,0 @@-{-# 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--printString :: String -> ML ()-printString str = do - evaluate $ "Print[\"" ++ str ++ "\"]"- return ()--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 "Function lookup failed."- _ -> Er.throwError "Expected int."- `Er.catchError` \err -> do- clearError- printString err- 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
@@ -1,446 +0,0 @@-{-# 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-
+ src/state.c view
@@ -0,0 +1,48 @@+#include <mathlink.h>++int MLAbort = 0;+int MLDone = 0;+MLINK stdlink = 0;+MLEnvironment stdenv = 0;++MLYieldFunctionObject stdyielder = (MLYieldFunctionObject)0;+MLMessageHandlerObject stdhandler = (MLMessageHandlerObject)0;++void MLDefaultHandler(MLINK mlp, int message, int n)+{+ switch(message)+ {+ case MLTerminateMessage:+ MLDone = 1;+ case MLInterruptMessage:+ case MLAbortMessage:+ MLAbort = 1;+ default:+ return;+ }+}++int MLInitializeMathLink(char * commandLine)+{+ int err;+ if(!stdenv) stdenv = MLInitialize((MLParametersPointer)0);+ if(stdenv == (MLEnvironment)0) return 0;+ if(!stdhandler) stdhandler = (MLMessageHandlerObject)MLDefaultHandler;+ stdlink = MLOpenString(stdenv, commandLine, &err);+ if(stdlink == (MLINK)0)+ {+ MLDeinitialize(stdenv);+ stdenv = (MLEnvironment)0;+ return 0;+ }+ if(stdyielder) MLSetYieldFunction(stdlink, stdyielder);+ if(stdhandler) MLSetMessageHandler(stdlink, stdhandler);+ return 1;+}++void MLFinalizeMathLink()+{+ MLClose(stdlink);+ MLDeinitialize(stdenv);+}+