diff --git a/examples/mltest.cabal b/examples/mltest.cabal --- a/examples/mltest.cabal +++ b/examples/mltest.cabal @@ -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 diff --git a/examples/mltest.nb b/examples/mltest.nb --- a/examples/mltest.nb +++ b/examples/mltest.nb @@ -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 ]] } ] diff --git a/examples/mltest.sh b/examples/mltest.sh --- a/examples/mltest.sh +++ b/examples/mltest.sh @@ -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 diff --git a/examples/src/Main.hs b/examples/src/Main.hs --- a/examples/src/Main.hs +++ b/examples/src/Main.hs @@ -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 ] diff --git a/mathlink.cabal b/mathlink.cabal --- a/mathlink.cabal +++ b/mathlink.cabal @@ -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 diff --git a/src/Foreign/MathLink.hs b/src/Foreign/MathLink.hs --- a/src/Foreign/MathLink.hs +++ b/src/Foreign/MathLink.hs @@ -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 diff --git a/src/Foreign/MathLink/Expressible.hs b/src/Foreign/MathLink/Expressible.hs --- a/src/Foreign/MathLink/Expressible.hs +++ b/src/Foreign/MathLink/Expressible.hs @@ -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) + diff --git a/src/Foreign/MathLink/IO.hs b/src/Foreign/MathLink/IO.hs --- a/src/Foreign/MathLink/IO.hs +++ b/src/Foreign/MathLink/IO.hs @@ -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) diff --git a/src/Foreign/MathLink/ML.hs b/src/Foreign/MathLink/ML.hs deleted file mode 100644 --- a/src/Foreign/MathLink/ML.hs +++ /dev/null @@ -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)) - diff --git a/src/Foreign/MathLink/Types.hs b/src/Foreign/MathLink/Types.hs deleted file mode 100644 --- a/src/Foreign/MathLink/Types.hs +++ /dev/null @@ -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 - diff --git a/src/state.c b/src/state.c new file mode 100644 --- /dev/null +++ b/src/state.c @@ -0,0 +1,48 @@ +#include + +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); +} +