Internal.chs

{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches #-}
{-# LANGUAGE 
    ForeignFunctionInterface 
  , DeriveDataTypeable
  #-}

module Foreign.MathLink.Internal 
    ( 

    -- * Intitialization/finalization
      initializeMathLink
    , activate
    , finalizeMathLink

    -- * Checking types
    , Typ(..)
    , MLType(..)
    , getType
    , testHead
    , testFunction

    -- * Data marshaling

    -- ** Marshaling data to /Mathematica/

    -- *** Scalars
    , putInt16
    , putInt32
    , putInt
    , putFloat
    , putDouble

    -- *** Lists
    , putInt16List
    , putInt32List
    , putIntList
    , putFloatList
    , putDoubleList

    -- *** Arrays
    , putInt16Array
    , putInt32Array
    , putIntArray
    , putFloatArray
    , putDoubleArray

    -- *** String-like data
    , putString
    , putSymbol
    , putFunction

    -- ** Marshaling data from /Mathematica/

    -- *** Scalars
    , getInt16
    , getInt32
    , getInt
    , getFloat
    , getDouble

    -- *** Lists
    , getInt16List
    , getInt32List
    , getIntList
    , getFloatList
    , getDoubleList

    -- *** Arrays
    , getInt16Array
    , getInt32Array
    , getIntArray
    , getFloatArray
    , getDoubleArray

    -- *** String-like data
    , getString
    , getSymbol
    , getFunction

    -- * Out-of-band messaging
    , checkInterrupt
    , clearInterrupt
    , checkAbort
    , clearAbort
    , checkDone
    , putMessage
    , Msg(..)

    -- * Errors
    , Err(..)
    , MLErr(..)
    , throwErr
    , throwCode
    , throwMsg
    , getErrorMessage
    , getMLError
    , throwMLError
    , clearMLError

    -- * Packets
    , Pkt(..)
    , MLPacket(..)

    , nextPacket
    , newPacket
    , endPacket
    , flush
    , ready
    , waitForPacket

    ) where

import Foreign
import Foreign.C
import Control.Monad
import Control.Exception
import Data.Typeable

import System.IO

#include "mathlink.h"
#include "ml.h"
#include "arch.h"

------------------------ Types -------------------------

{# enum define Pkt
       { ILLEGALPKT as PktIllegal
       , CALLPKT as PktCall
       , EVALUATEPKT as PktEvaluate
       , RETURNPKT as PktReturn
       , INPUTNAMEPKT as PktInputName
       , ENTERTEXTPKT as PktEnterText
       , ENTEREXPRPKT as PktEnterExpr
       , OUTPUTNAMEPKT as PktOutputName
       , RETURNTEXTPKT as PktReturnText
       , RETURNEXPRPKT as PktReturnExpr
       , DISPLAYPKT as PktDisplay
       , DISPLAYENDPKT as PktDisplayEnd
       , MESSAGEPKT as PktMessage
       , TEXTPKT as PktText
       , INPUTPKT as PktInput
       , INPUTSTRPKT as PktInputStr
       , MENUPKT as PktMenu
       , SYNTAXPKT as PktSyntax
       , SUSPENDPKT as PktSuspend
       , RESUMEPKT as PktResume
       , BEGINDLGPKT as PktBeginDlg
       , ENDDLGPKT as PktEndDlg
       , FIRSTUSERPKT as PktFirstUser
       , LASTUSERPKT as PktLastUser
       }
 deriving (Eq,Show)
 #}

data MLPacket = MLPacket Pkt
              | UserPacket Int
              | UnknownPacket Int
                deriving (Eq,Show)

instance Ord MLPacket where
    p1 `compare` p2 = (fromEnum p1) `compare` (fromEnum p2)

instance Enum MLPacket where
  toEnum i
      | i == fromEnum PktIllegal    = MLPacket PktIllegal
      | i == fromEnum PktCall       = MLPacket PktCall
      | i == fromEnum PktEvaluate   = MLPacket PktEvaluate
      | i == fromEnum PktReturn     = MLPacket PktReturn
      | i == fromEnum PktInputName  = MLPacket PktInputName
      | i == fromEnum PktEnterText  = MLPacket PktEnterText
      | i == fromEnum PktEnterExpr  = MLPacket PktEnterExpr
      | i == fromEnum PktOutputName = MLPacket PktOutputName
      | i == fromEnum PktReturnText = MLPacket PktReturnText
      | i == fromEnum PktReturnExpr = MLPacket PktReturnExpr
      | i == fromEnum PktDisplay    = MLPacket PktDisplay
      | i == fromEnum PktDisplayEnd = MLPacket PktDisplayEnd
      | i == fromEnum PktMessage    = MLPacket PktMessage
      | i == fromEnum PktText       = MLPacket PktText
      | i == fromEnum PktInput      = MLPacket PktInput
      | i == fromEnum PktInputStr   = MLPacket PktInputStr
      | i == fromEnum PktMenu       = MLPacket PktMenu
      | i == fromEnum PktSyntax     = MLPacket PktSyntax
      | i == fromEnum PktSuspend    = MLPacket PktSuspend
      | i == fromEnum PktResume     = MLPacket PktResume
      | i == fromEnum PktBeginDlg   = MLPacket PktBeginDlg
      | i == fromEnum PktEndDlg     = MLPacket PktEndDlg
      | i >= fromEnum PktFirstUser &&
        i <= fromEnum PktLastUser   = UserPacket i
      | otherwise                   = UnknownPacket i

  fromEnum (MLPacket pkt)    = fromEnum pkt
  fromEnum (UserPacket i)    = i
  fromEnum (UnknownPacket i) = i

{# enum define Msg
       { MLTerminateMessage as MsgTerminate
       , MLInterruptMessage as MsgInterrupt
       , MLAbortMessage as MsgAbort
       , MLEndPacketMessage as MsgEndPacket
       , MLSynchronizeMessage as MsgSynchronize
       , MLImDyingMessage as MsgImDying
       , MLWaitingAcknowledgment as MsgWaitingAcknowledgement
       , MLMarkTopLevelMessage as MsgMarkTopLevel
       , MLLinkClosingMessage as MsgLinkClosing
       , MLAuthenticateFailure as MsgAuthenticateFailure
       , MLFirstUserMessage as MsgFirstUser
       , MLLastUserMessage as MsgLastUser
       }
   deriving (Eq,Show)
 #}

{# enum define Typ
       { MLTKFUNC as TypFn
       , MLTKERROR as TypErr
       , MLTKSTR as TypSt
       , MLTKSYM as TypSy
       , MLTKREAL as TypR
       , MLTKINT as TypI
       }
 deriving (Eq,Show)
 #}

data MLType = MLType Typ
            | UnknownType Int
              deriving (Eq,Show)

instance Ord MLType where
  t1 `compare` t2 = (fromEnum t1) `compare` (fromEnum t2)

instance Enum MLType where
  toEnum i
      | i == fromEnum TypFn  = MLType TypFn
      | i == fromEnum TypErr = MLType TypErr
      | i == fromEnum TypSt  = MLType TypSt
      | i == fromEnum TypSy  = MLType TypSy
      | i == fromEnum TypR   = MLType TypR
      | i == fromEnum TypI   = MLType TypI
      | otherwise            = UnknownType i

  fromEnum (MLType typ)    = fromEnum typ
  fromEnum (UnknownType i) = i

{# enum define Err
       { MLEUNKNOWN       as ErrUnknown
       , MLEOK            as ErrOK
       , MLEDEAD          as ErrDead
       , MLEGBAD          as ErrGBad
       , MLEGSEQ          as ErrGSeq
       , MLEPBTK          as ErrPBad
       , MLEPSEQ          as ErrPSeq
       , MLEPBIG          as ErrPBig
       , MLEOVFL          as ErrOvfl
       , MLEMEM           as ErrMem
       , MLEACCEPT        as ErrAccept
       , MLECONNECT       as ErrConnect
       , MLEPUTENDPACKET  as ErrPutEndPacket
       , MLENEXTPACKET    as ErrNextPacket
       , MLEUNKNOWNPACKET as ErrUnknownPacket
       , MLEGETENDPACKET  as ErrGetEndPacket
       , MLEABORT         as ErrAbort
       , MLECLOSED        as ErrClosed
       , MLEINIT          as ErrInt
       , MLEARGV          as ErrArgv
       , MLEPROTOCOL      as ErrProtocol
       , MLEMODE          as ErrMode
       , MLELAUNCH        as ErrLaunch
       , MLELAUNCHAGAIN   as ErrLaunchAgain
       , MLELAUNCHSPACE   as ErrLaunchSpace
       , MLENOPARENT      as ErrNoParent
       , MLENAMETAKEN     as ErrNameTaken
       , MLENOLISTEN      as ErrNoListen
       , MLEBADNAME       as ErrBadName
       , MLEBADHOST       as ErrBadHost
       , MLELAUNCHFAILED  as ErrLaunchFailed
       , MLELAUNCHNAME    as ErrLaunchName
       , MLEPSCONVERT     as ErrPSConvert
       , MLEGSCONVERT     as ErrGSConvert
       , MLEPDATABAD      as ErrPDataBad
       , MLEUSER          as ErrUser
       }
 deriving (Eq,Show)
 #}

data MLErr = MLErr Int String
           | MLErrCode Int
           | MLErrMsg String
             deriving (Eq,Show,Typeable)

instance Exception MLErr where


--------------------- Initialization -----------------------

{# pointer MLINK as Link newtype #}

foreign import ccall safe "mathlink.h & stdlink" stdlinkPtr
    :: Ptr (Ptr ())

withLink :: (Link -> IO a) -> IO a
withLink fn = peek stdlinkPtr >>= fn . Link . castPtr

-- | Initialize the /MathLink/ connection.
{# fun MLInitializeMathLink as initializeMathLink
       { `String'
       } -> `Bool'
 #}

-- | Shut down the /MathLink/ connection.
{# fun MLFinalizeMathLink as finalizeMathLink
       { 
       } -> `()' id
 #}

-- | Activate the /MathLink/ connection.
{# fun MLActivate as activate
       { withLink- `Link'
       } -> `Bool'
 #}

---------------------- Messages -----------------------------

foreign import ccall safe "mathlink.h & MLInterrupt" interruptPtr
    :: Ptr CInt
foreign import ccall safe "mathlink.h & MLAbort" abortPtr
    :: Ptr CInt
foreign import ccall safe "mathlink.h & MLDone" donePtr
    :: Ptr CInt

checkPtr :: Ptr CInt -> IO Bool
checkPtr ptr = peek ptr >>= (return . (/= 0))

clearPtr :: Ptr CInt -> IO ()
clearPtr ptr = poke ptr 0

-- | Check if the an interrupt message was received.
checkInterrupt :: IO Bool
checkInterrupt = checkPtr interruptPtr
  
-- | Clear any interrupt messages.
clearInterrupt :: IO ()
clearInterrupt = clearPtr interruptPtr

-- | Check if an abort message was received.
checkAbort :: IO Bool
checkAbort = checkPtr abortPtr

-- | Clear any abort messages.
clearAbort :: IO ()
clearAbort = clearPtr abortPtr

-- | Check if a done message was received.
checkDone :: IO Bool
checkDone = checkPtr donePtr

-- | Send a /MathLink/ message to the other end of the
--   /MathLink/ connection.
{# fun MLPutMessage as putMessage
       { withLink- `Link'
       , cFromEnum `Msg'
       } -> `Bool'
 #}


-------------------- Errors -------------------------

-- | Throw an 'MLErr' with the given error code and message.
throwErr :: Int -> String -> IO a
throwErr code msg = throw $ MLErr code msg

-- | Throw an 'MLErr' with just an error code.
throwCode :: Int -> IO a
throwCode code = throw $ MLErrCode code

-- | Throw an 'MLErr' with just an error message.
throwMsg :: String -> IO a
throwMsg msg = throw $ MLErrMsg msg

-- | Get the error code associated with the last /MathLink/ error.
{# fun MLError as getErrorCode
       { withLink- `Link'
       } -> `Int' cIntConv
 #}

-- | Get a string associated with the last /MathLink/ error.
{# fun MLErrorMessage as getErrorMessage
       { withLink- `Link'
       } -> `String'
 #}

-- | Get the last /MathLink/ error as an 'MLErr'.
getMLError :: IO MLErr
getMLError = do
  code <- getErrorCode
  msg <- getErrorMessage
  return $ MLErr code msg

-- | Throw an 'MLErr' corresponding to the last /MathLink/ error.
throwMLError :: IO a
throwMLError = getMLError >>= throw

-- | Clear the last /MathLink/ error.
{# fun MLClearError as clearMLError
       { withLink- `Link'
       } -> `()' throwUnless-
 #}

throwUnless :: Integral a => a -> IO ()
throwUnless 0 = throwMLError
throwUnless _ = return ()

----------------------- Packets --------------------------

-- | Goes to the beginning of the next packet and returns its type.
{# fun MLNextPacket as nextPacket
       { withLink- `Link'
       } -> `MLPacket' cToEnum
 #}

-- | Skips to the beginning of the next packet.
{# fun MLNewPacket as newPacket
       { withLink- `Link'
       } -> `()' throwUnless-
 #}

-- | Marks the end of the packet being put on the link.
{# fun MLEndPacket as endPacket
       { withLink- `Link'
       } -> `()' throwUnless-
 #}

-- | Forces any pending data to be sent.
{# fun MLFlush as flush
       { withLink- `Link'
       } -> `()' throwUnless-
 #}

-- | Checks if a packet is available for getting.
--
--   Requires that there be no pending data to be sent (/i.e./,
--   call 'flush' first).
{# fun MLReady as ready
       { withLink- `Link'
       } -> `()' throwUnless-
 #}

-- | Drops packets until one satisfying the given predicate is received.
waitForPacket :: (MLPacket -> Bool) -> IO ()
waitForPacket q = do
  pkt <- nextPacket
  if pkt == MLPacket PktIllegal then throwMLError else return ()
  if q pkt then return () else do
    hPutStrLn stderr $ "Dropping packet: " ++ show pkt
    newPacket


---------------------- Marshaling (puts) ---------------------

{# fun MLPutInteger16 as putInt16
       { withLink- `Link'
       , `Int16'
       } -> `()' throwUnless-
 #}

{# fun MLPutInteger32 as putInt32
       { withLink- `Link'
       , `Int32'
       } -> `()' throwUnless-
 #}

#ifdef IS_64_BIT
{# fun MLPutInteger64 as putInt
       { withLink- `Link'
       , `Int'
       } -> `()' throwUnless-
 #}
#else
{# fun MLPutInteger32 as putInt
       { withLink- `Link'
       , `Int'
       } -> `()' throwUnless-
 #}
#endif

{# fun MLPutReal32 as putFloat
       { withLink- `Link'
       , `Float'
       } -> `()' throwUnless-
 #}

{# fun MLPutReal64 as putDouble
       { withLink- `Link'
       , `Double'
       } -> `()' throwUnless-
 #}

{# fun MLPutString as putString
       { withLink- `Link'
       , `String'
       } -> `()' throwUnless-
 #}

{# fun MLPutSymbol as putSymbol
       { withLink- `Link'
       , `String'
       } -> `()' throwUnless-
 #}

{# fun MLPutFunction as putFunction
       { withLink- `Link'
       , `String'
       , `Int'
       } -> `()' throwUnless-
 #}

putList :: Storable b 
        => (a -> b) 
        -> (Ptr b -> Int -> IO ()) 
        -> [a] -> IO ()
putList cnv pfn xs = do
  withArray (map cnv xs) $ \ptr -> pfn ptr (length xs)

{# fun MLPutInteger16List as putInt16List'
       { withLink- `Link'
       , id `Ptr CShort'
       , `Int'
       } -> `()' throwUnless-
 #}
putInt16List :: [Int16] -> IO ()
putInt16List = putList cIntConv putInt16List'

{# fun MLPutInteger32List as putInt32List'
       { withLink- `Link'
       , id `Ptr CInt'
       , `Int'
       } -> `()' throwUnless-
 #}
putInt32List :: [Int32] -> IO ()
putInt32List = putList cIntConv putInt32List'

#ifdef IS_64_BIT
{# fun MLPutInteger64List as putIntList'
       { withLink- `Link'
       , id `Ptr CLong'
       , `Int'
       } -> `()' throwUnless-
 #}
#else
{# fun MLPutInteger32List as putIntList'
       { withLink- `Link'
       , id `Ptr CInt'
       , `Int'
       } -> `()' throwUnless-
 #}
#endif
putIntList :: [Int] -> IO ()
putIntList = putList cIntConv putIntList'

{# fun MLPutReal32List as putFloatList'
       { withLink- `Link'
       , id `Ptr CFloat'
       , `Int'
       } -> `()' throwUnless-
 #}
putFloatList :: [Float] -> IO ()
putFloatList = putList cFloatConv putFloatList'

{# fun MLPutReal64List as putDoubleList'
       { withLink- `Link'
       , id `Ptr CDouble'
       , `Int'
       } -> `()' throwUnless-
 #}
putDoubleList :: [Double] -> IO ()
putDoubleList = putList cFloatConv putDoubleList'

putArray :: (Storable b)
         => (a -> b)
         -> (Ptr b -> Ptr CInt -> Ptr CString -> Int -> IO ())
         -> [a] -> [(Int,String)] -> IO ()
putArray cnv pfn xs dims = do
    withArray es $ \esPtr ->
      bracket (mapM newCString hds) (mapM_ free) $ \hdCStrs ->
        withArray hdCStrs $ \hdsPtr ->
          withArray (map cIntConv shape) $ \shpPtr ->
            pfn esPtr shpPtr hdsPtr rank
  where es          = map cnv xs
        rank        = length dims
        (shape,hds) = unzip dims

{# fun MLPutInteger16Array as putInt16Array'
       { withLink- `Link'
       , id `Ptr CShort'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `()' throwUnless-
 #}
putInt16Array :: [Int16] -> [(Int,String)] -> IO ()
putInt16Array = putArray (cIntConv) putInt16Array'

{# fun MLPutInteger32Array as putInt32Array'
       { withLink- `Link'
       , id `Ptr CInt'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `()' throwUnless-
 #}
putInt32Array :: [Int32] -> [(Int,String)] -> IO ()
putInt32Array = putArray (cIntConv) putInt32Array'

#ifdef IS_64_BIT
{# fun MLPutInteger64Array as putIntArray'
       { withLink- `Link'
       , id `Ptr CLong'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `()' throwUnless-
 #}
#else
{# fun MLPutInteger32Array as putIntArray'
       { withLink- `Link'
       , id `Ptr CInt'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `()' throwUnless-
 #}
#endif
putIntArray :: [Int] -> [(Int,String)] -> IO ()
putIntArray = putArray (cIntConv) putIntArray'

{# fun MLPutReal32Array as putFloatArray'
       { withLink- `Link'
       , id `Ptr CFloat'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `()' throwUnless-
 #}
putFloatArray :: [Float] -> [(Int,String)] -> IO ()
putFloatArray = putArray (cFloatConv) putFloatArray'

{# fun MLPutReal64Array as putDoubleArray'
       { withLink- `Link'
       , id `Ptr CDouble'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `()' throwUnless-
 #}
putDoubleArray :: [Double] -> [(Int,String)] -> IO ()
putDoubleArray = putArray (cFloatConv) putDoubleArray'


----------------------- Marshaling (gets) --------------------

{# fun MLGetInteger16 as getInt16
       { withLink- `Link'
       , alloca- `Int16' peekIntConv*
       } -> `()' throwUnless-
 #}

{# fun MLGetInteger32 as getInt32
       { withLink- `Link'
       , alloca- `Int32' peekIntConv*
       } -> `()' throwUnless-
 #}

#ifdef IS_64_BIT
{# fun MLGetInteger64 as getInt
       { withLink- `Link'
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
#else
{# fun MLGetInteger32 as getInt
       { withLink- `Link'
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
#endif

{# fun MLGetReal32 as getFloat
       { withLink- `Link'
       , alloca- `Float' peekFloatConv*
       } -> `()' throwUnless-
 #}

{# fun MLGetReal64 as getDouble
       { withLink- `Link'
       , alloca- `Double' peekFloatConv*
       } -> `()' throwUnless-
 #}

{# fun MLReleaseString as releaseString
       { withLink- `Link'
       , id `CString'
       } -> `()' id
 #}
{# fun MLGetString as getString'
       { withLink- `Link'
       , alloca- `CString' peek*
       } -> `()' throwUnless-
 #}
getString :: IO String
getString = do
  cstr <- getString'
  str <- peekCString cstr
  releaseString cstr
  return str

{# fun MLReleaseSymbol as releaseSymbol
       { withLink- `Link'
       , id `CString'
       } -> `()' id
 #}
{# fun MLGetSymbol as getSymbol'
       { withLink- `Link'
       , alloca- `CString' peek*
       } -> `()' throwUnless-
 #}
getSymbol :: IO String
getSymbol = do
  cstr <- getSymbol'
  str <- peekCString cstr
  releaseSymbol cstr
  return str

{# fun MLGetFunction as getFunction'
       { withLink- `Link'
       , alloca- `CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
getFunction :: IO (String,Int)
getFunction = do
  (cstr, n) <- getFunction'
  str <- peekCString cstr
  releaseSymbol cstr
  return (str, n)

getList :: Storable a 
        => (a -> b) 
        -> (IO (Ptr a, Int))
        -> (Ptr a -> Int -> IO ())
        -> IO [b]
getList cnv gfn rfn = do
  (ptr, n) <- gfn
  l <- peekArray n ptr
  rfn ptr n
  return (map cnv l)

{# fun MLReleaseInteger16List as releaseInt16List'
       { withLink- `Link'
       , id `Ptr CShort'
       , `Int'
       } -> `()' id
 #}
{# fun MLGetInteger16List as getInt16List'
       { withLink- `Link'
       , alloca- `Ptr CShort' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
getInt16List :: IO [Int16]
getInt16List = getList cIntConv getInt16List' releaseInt16List'

{# fun MLReleaseInteger32List as releaseInt32List'
       { withLink- `Link'
       , id `Ptr CInt'
       , `Int'
       } -> `()' id
 #}
{# fun MLGetInteger32List as getInt32List'
       { withLink- `Link'
       , alloca- `Ptr CInt' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
getInt32List :: IO [Int32]
getInt32List = getList cIntConv getInt32List' releaseInt32List'

#ifdef IS_64_BIT
{# fun MLReleaseInteger64List as releaseIntList'
       { withLink- `Link'
       , id `Ptr CLong'
       , `Int'
       } -> `()' id
 #}
{# fun MLGetInteger64List as getIntList'
       { withLink- `Link'
       , alloca- `Ptr CLong' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
#else
{# fun MLReleaseInteger32List as releaseIntList'
       { withLink- `Link'
       , id `Ptr CInt'
       , `Int'
       } -> `()' id
 #}
{# fun MLGetInteger32List as getIntList'
       { withLink- `Link'
       , alloca- `Ptr CInt' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
#endif
getIntList :: IO [Int]
getIntList = getList cIntConv getIntList' releaseIntList'

{# fun MLReleaseReal32List as releaseFloatList'
       { withLink- `Link'
       , id `Ptr CFloat'
       , `Int'
       } -> `()' id
 #}
{# fun MLGetReal32List as getFloatList'
       { withLink- `Link'
       , alloca- `Ptr CFloat' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
getFloatList :: IO [Float]
getFloatList = getList cFloatConv getFloatList' releaseFloatList'

{# fun MLReleaseReal64List as releaseDoubleList'
       { withLink- `Link'
       , id `Ptr CDouble'
       , `Int'
       } -> `()' id
 #}
{# fun MLGetReal64List as getDoubleList'
       { withLink- `Link'
       , alloca- `Ptr CDouble' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
getDoubleList :: IO [Double]
getDoubleList = getList cFloatConv getDoubleList' releaseDoubleList'

getArray :: (Storable a)
         => (a -> b)
         -> (IO (Ptr a, Ptr CInt, Ptr CString, Int))
         -> (Ptr a -> Ptr CInt -> Ptr CString -> Int -> IO ())
         -> IO ([b],[(Int,String)])
getArray cnv gfn rfn = do
  (esPtr, shpPtr, hdsPtr, rnk) <- gfn
  shape <- peekArray rnk shpPtr >>= (return . map cIntConv)
  hds   <- peekArray rnk hdsPtr >>= (mapM peekCString)
  es    <- peekArray (product shape) esPtr >>= (return . map cnv)
  rfn esPtr shpPtr hdsPtr rnk
  return (es,zip shape hds)

{# fun MLGetInteger16Array as getInt16Array'
       { withLink- `Link'
       , alloca- `Ptr CShort' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
{# fun MLReleaseInteger16Array as releaseInt16Array'
       { withLink- `Link'
       , id `Ptr CShort'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
getInt16Array :: IO ([Int16],[(Int,String)])
getInt16Array = 
  getArray cIntConv getInt16Array' releaseInt16Array'

{# fun MLGetInteger32Array as getInt32Array'
       { withLink- `Link'
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
{# fun MLReleaseInteger32Array as releaseInt32Array'
       { withLink- `Link'
       , id `Ptr CInt'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
getInt32Array :: IO ([Int32],[(Int,String)])
getInt32Array = 
  getArray cIntConv getInt32Array' releaseInt32Array'

#ifdef IS_64_BIT
{# fun MLGetInteger64Array as getIntArray'
       { withLink- `Link'
       , alloca- `Ptr CLong' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
{# fun MLReleaseInteger64Array as releaseIntArray'
       { withLink- `Link'
       , id `Ptr CLong'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
#else
{# fun MLGetInteger32Array as getIntArray'
       { withLink- `Link'
       , alloca- `Ptr CLong' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
{# fun MLReleaseInteger32Array as releaseIntArray'
       { withLink- `Link'
       , id `Ptr CLong'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
#endif
getIntArray :: IO ([Int],[(Int,String)])
getIntArray = 
  getArray cIntConv getIntArray' releaseIntArray'

{# fun MLGetReal32Array as getFloatArray'
       { withLink- `Link'
       , alloca- `Ptr CFloat' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
{# fun MLReleaseReal32Array as releaseFloatArray'
       { withLink- `Link'
       , id `Ptr CFloat'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
getFloatArray :: IO ([Float],[(Int,String)])
getFloatArray = 
  getArray cFloatConv getFloatArray' releaseFloatArray'

{# fun MLGetReal64Array as getDoubleArray'
       { withLink- `Link'
       , alloca- `Ptr CDouble' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `()' throwUnless-
 #}
{# fun MLReleaseReal64Array as releaseDoubleArray'
       { withLink- `Link'
       , id `Ptr CDouble'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
getDoubleArray :: IO ([Double],[(Int,String)])
getDoubleArray = 
  getArray cFloatConv getDoubleArray' releaseDoubleArray'

-- | Gets the type of the next value to be gotten over the link.
{# fun MLGetType as getType
       { withLink- `Link'
       } -> `MLType' cToEnum
 #}

-- | Returns the number of arguments of a compound expression,
--   given that the expression's head is identical to the 'String'
--   given.
--
--   Throws an exception on failure.
{# fun MLTestHead as testHead
       { withLink- `Link'
       , `String'
       , alloca- `Int' peekIntConv*
       } -> `Bool'
 #}

-- | Checks that the incoming value is of a composite (function)
--   type and applies the given predicates to the expression's head
--   and the number of arguments, throwing an exception on failure.
testFunction 
  :: (String -> Bool) -- ^ The test for the expression's head.
  -> (Int -> Bool)    -- ^ The test for the number of arguments.
  -> IO (String,Int)  -- ^ The head and number of arguments, on success.
testFunction hdQ nargQ = do
  typ <- getType
  case typ of
    MLType TypFn -> do 
      (hd,nargs) <- getFunction
      case (hdQ hd, nargQ nargs) of
        (True,True) -> return (hd,nargs)
        (False,_)   -> throwMsg "testFunction: head failed predicate."
        (_,False)   -> throwMsg "testFunction: # of args failed predicate."
    _ -> throwMsg "testFunction: Expected function type"

------------------------- C2HS Stuff --------------------------

peekIntConv   :: (Storable a, Integral a, Integral b) 
	      => Ptr a -> IO b
peekIntConv    = liftM cIntConv . peek

peekFloatConv :: (Storable a, RealFloat a, RealFloat b) 
	      => Ptr a -> IO b
peekFloatConv  = liftM cFloatConv . peek

cIntConv :: (Integral a, Integral b) => a -> b
cIntConv  = fromIntegral

cFloatConv :: (RealFloat a, RealFloat b) => a -> b
cFloatConv  = realToFrac
{-# RULES 
  "cFloatConv/Float->Float"   forall (x::Float).  cFloatConv x = x;
  "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x
 #-}

cToBool :: Num a => a -> Bool
cToBool  = toBool

cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . cIntConv

cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum  = cIntConv . fromEnum