mathlink-2.0.1.1: Foreign/MathLink/Internal.chs

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

module Foreign.MathLink.Internal 
    (
    -- * The 'ML' monad
      Link
    , ML
    , runMLMain
    , newLoopbackLink
    , runML
    , transferTo
    , transferFrom

    -- * Checking types
    , Typ(..)
    , MLType(..)
    , 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

    -- *** Composite data
    , putType
    , putArgCount
    , 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

    -- *** Composite data
    , getType
    , getArgCount
    , getFunction

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

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

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

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

    ) where

import Prelude hiding (catch)

import Foreign hiding (newForeignPtr)
import Foreign.C
import Foreign.Concurrent (newForeignPtr)

import Control.Concurrent
import Control.Monad.Reader
import Control.Exception

import Data.Data

import System.IO
import System.Environment hiding (getEnvironment)

#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)
 #}

type Location = String

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

instance Show MLErr where
  show err = case err of
      MLErr loc code msg -> prefix loc ++ codeStr code ++ msgStr msg
      MLErrCode loc code -> prefix loc ++ codeStr code
      MLErrMsg loc msg   -> prefix loc ++ msgStr msg
    where prefix loc' = "MLErr occurred at " ++ loc'
          codeStr code' = ": code=" ++ show code'
          msgStr msg' = ": " ++ msg'

instance Exception MLErr where


--------------------- Link -----------------------

withLink :: Link -> (Ptr Link -> IO b) -> IO b
{# pointer MLINK as Link foreign newtype #}
foreign import ccall safe "mathlink.h & stdlink" stdlinkPtr
    :: Ptr (Ptr ())

{# pointer MLEnvironment as Environment newtype #}
foreign import ccall safe "mathlink.h & stdenv" stdenvPtr
    :: Ptr (Ptr ())

getEnvironment :: ML Environment
getEnvironment = liftIO $ do
  envPtr <- liftIO $ peek (castPtr stdenvPtr)
  return $ Environment envPtr
  
{# fun MLInitializeMathLink as initializeMathLink
       { `String'
       } -> `Bool'
 #}
{# fun MLFinalizeMathLink as finalizeMathLink
       { 
       } -> `()' id
 #}

{# fun MLActivate as activate'
       { withLink* `Link'
       } -> `Bool'
 #}
activate :: ML ()
activate = liftML "activate" activate'

link :: MVar Link
link = unsafePerformIO $ do
  args <- getArgs
  bl <- initializeMathLink $ unwords args
  if not bl then 
      throw $ MLErrMsg "link" "Unable to initialize MathLink connection."
    else
      return ()
  ptr <- peek (castPtr stdlinkPtr)
  fptr <- newForeignPtr ptr finalizeMathLink
  lnk <- newMVar $ Link fptr
  withMVar lnk $ \l -> runML activate l
  return lnk

{# fun MLClose as close
       { id `Ptr Link'
       } -> `()' id
 #}

{# fun MLLoopbackOpen as newLoopbackLink'
       { id `Environment'
       , alloca- `Err' peekEnum*
       } -> `Ptr Link' id
 #}
-- | Creates a new loopback link, which can be used to build or store
--   expressions locally.
newLoopbackLink :: ML Link
newLoopbackLink = do
  env <- getEnvironment
  (lnkPtr,err) <- liftIO $ newLoopbackLink' env
  if err /= ErrOK then throwMsg "newLoopbackLink" $ show err else do
    fptr <- liftIO $ newForeignPtr lnkPtr (close lnkPtr)
    return $ Link fptr

-- | Monad encapsulating the /MathLink/ connection.
newtype ML a = ML { runML' :: ReaderT Link IO a }
    deriving (Monad, MonadIO)

runML :: ML a -> Link -> IO a
runML = runReaderT . runML'

{# fun MLTransferExpression as transferExpression'
       { withLink* `Link'
       , withLink* `Link'
       } -> `Bool' cToBool
 #}

transfer' :: Location -> Link -> Link -> IO ()
transfer' loc dst src = do
  bl <- transferExpression' dst src
  if bl then return () else do
      dstErr <- getMLError' dst loc
      srcErr <- getMLError' src loc
      let msg = "destination:\n" ++ show dstErr ++ 
                "\nsource:\n" ++ show srcErr
      throw $ MLErrMsg loc msg

transferTo :: Link -> ML ()
transferTo dst = do
  src <- askLink
  liftIO $ transfer' "transferTo" dst src

transferFrom :: Link -> ML ()
transferFrom src = do
  dst <- askLink
  liftIO $ transfer' "transferFrom" dst src

-- Not to be exposed outside this module!
askLink :: ML Link
askLink = ML ask

-- | Run an 'ML' computation with the main /MathLink/ link.
--
--   /WARNING/: Calls to 'runMLMain' cannot be nested! The underlying 
--   /MathLink/ state is stored in an 'MVar'. 'runMLMain' calls 'withMVar'
--   on this 'MVar', so it will block until the state is available.
--   Thus, nested calls are guaranteed to deadlock.
runMLMain :: ML a -> IO a
runMLMain = (withMVar link) . runML


---------------------- 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 :: ML ()
clearInterrupt = liftIO $ clearPtr interruptPtr

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

-- | Clear any abort messages.
clearAbort :: ML ()
clearAbort = liftIO $ 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'
 #}
putMessage :: Msg -> ML ()
putMessage m = liftML "putMessage" (skipFst1 putMessage' m)


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

throwErr :: Location -> Int -> String -> ML a
throwErr loc code msg = 
  liftIO $ throw $ MLErr loc (fromEnum ErrUser + code) msg

throwCode :: Location -> Int -> ML a
throwCode loc code = 
  liftIO $ throw $ MLErrCode loc (fromEnum ErrUser + code)

throwMsg :: Location -> String -> ML a
throwMsg loc msg = liftIO $ throw $ MLErrMsg loc msg

{# fun MLError as getErrorCode'
       { withLink* `Link'
       } -> `Int' cIntConv
 #}

{# fun MLErrorMessage as getErrorMessage'
       { withLink* `Link'
       } -> `String'
 #}

getMLError' :: Link -> Location -> IO MLErr
getMLError' l loc = do
  code <- getErrorCode' l
  msg <- getErrorMessage' l
  return $ MLErr loc code msg

getMLError :: Location -> ML MLErr
getMLError loc = do
  l <- askLink
  liftIO $ getMLError' l loc

assertML :: Location -> Bool -> ML ()
assertML loc False = getMLError loc >>= liftIO . throw
assertML _   True = return ()

-- | Clear the last /MathLink/ error.
{# fun MLClearError as clearMLError'
       { withLink* `Link'
       } -> `Bool' cToBool
 #}
clearMLError :: ML ()
clearMLError = do
  l <- askLink 
  bl <- liftIO $ clearMLError' l 
  assertML "clearMLError" bl


------------------ Lifting utilities --------------------

liftML :: Location -> (Link -> IO Bool) -> ML ()
liftML loc fn = do
  l <- askLink
  bl <- liftIO $ fn l 
  assertML loc bl

skipFst1 :: (a -> b -> c) -> b -> (a -> c)
skipFst1 fn x = \l -> fn l x


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

-- | Goes to the beginning of the next packet and returns its type.
{# fun MLNextPacket as nextPacket'
       { withLink* `Link'
       } -> `MLPacket' cToEnum
 #}
nextPacket :: ML MLPacket
nextPacket = askLink >>= \l -> liftIO $ nextPacket' l

-- | Skips to the beginning of the next packet.
{# fun MLNewPacket as newPacket'
       { withLink* `Link'
       } -> `Bool' cToBool
 #}
newPacket :: ML ()
newPacket = liftML "newPacket" newPacket'

-- | Marks the end of the packet being put on the link.
{# fun MLEndPacket as endPacket'
       { withLink* `Link'
       } -> `Bool' cToBool
 #}
endPacket :: ML ()
endPacket = liftML "endPacket" endPacket'

-- | Forces any pending data to be sent.
{# fun MLFlush as flush'
       { withLink* `Link'
       } -> `Bool' cToBool
 #}
flush :: ML ()
flush = liftML "flush" flush'

-- | 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'
       } -> `Bool' cToBool
 #}
ready :: ML Bool
ready = askLink >>= liftIO . ready'

-- | Drops packets until one satisfying the given predicate is received.
waitForPacket :: (MLPacket -> Bool) -> ML ()
waitForPacket q = do
  bl <- liftIO $ checkDone
  if bl then throwErr "waitForPacket" 1 "MathLink done." else do
    pkt <- nextPacket
    if pkt == MLPacket PktIllegal then 
        throwErr "waitForPacket" 2 "Illegal packet received." 
      else 
        return ()
    if q pkt then return () else do
      liftIO $ hPutStrLn stderr $ "Dropping packet: " ++ show pkt
      newPacket


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

putScalarWith :: Location -> (Link -> a -> IO Bool)
              -> a -> ML ()
putScalarWith loc pfn v = liftML loc (skipFst1 pfn v)

{# fun MLPutInteger16 as putInt16'
       { withLink* `Link'
       , `Int16'
       } -> `Bool' cToBool
 #}
putInt16 :: Int16 -> ML ()
putInt16 = putScalarWith "putInt16" putInt16'

{# fun MLPutInteger32 as putInt32'
       { withLink* `Link'
       , `Int32'
       } -> `Bool' cToBool
 #}
putInt32 :: Int32 -> ML ()
putInt32 = putScalarWith "putInt32" putInt32'

#ifdef IS_64_BIT
{# fun MLPutInteger64 as putInt'
       { withLink* `Link'
       , `Int'
       } -> `Bool' cToBool
 #}
#else
{# fun MLPutInteger32 as putInt'
       { withLink* `Link'
       , `Int'
       } -> `Bool' cToBool
 #}
#endif
putInt :: Int -> ML ()
putInt = putScalarWith "putInt" putInt'

{# fun MLPutReal32 as putFloat'
       { withLink* `Link'
       , `Float'
       } -> `Bool' cToBool
 #}
putFloat :: Float -> ML ()
putFloat = putScalarWith "putFloat" putFloat'

{# fun MLPutReal64 as putDouble'
       { withLink* `Link'
       , `Double'
       } -> `Bool' cToBool
 #}
putDouble :: Double -> ML ()
putDouble = putScalarWith "putDouble" putDouble'

{# fun MLPutString as putString'
       { withLink* `Link'
       , `String'
       } -> `Bool' cToBool
 #}
putString :: String -> ML ()
putString = putScalarWith "putString" putString'

{# fun MLPutSymbol as putSymbol'
       { withLink* `Link'
       , `String'
       } -> `Bool' cToBool
 #}
putSymbol :: String -> ML ()
putSymbol = putScalarWith "putSymbol" putSymbol'

{# fun MLPutType as putType'
       { withLink* `Link'
       , cFromEnum `MLType'
       } -> `Bool' cToBool
 #}
putType :: MLType -> ML ()
putType typ = liftML "putType" (skipFst1 putType' typ)

{# fun MLPutArgCount as putArgCount'
       { withLink* `Link'
       , `Int'
       } -> `Bool' cToBool
 #}
putArgCount :: Int -> ML ()
putArgCount nargs = liftML "putArgCount" (skipFst1 putArgCount' nargs)

putFunction :: String -> Int -> ML ()
putFunction hd nargs = do
  putType $ MLType TypFn
  putArgCount nargs
  putSymbol hd

-- This is unsafe because it coerces the type of the pointer.
-- This can only (safely) be used when the Haskell type and
-- the corresponding C type are bitwise compatible. I assume
-- that is the case for the five types for which it is called.
unsafePutList :: Storable a
              => Location
              -> (Link -> Ptr b -> Int -> IO Bool) 
              -> [a] -> ML ()
unsafePutList loc pfn xs = do
  lnk <- askLink
  bl <- liftIO $ withArray xs $ \ptr -> 
          pfn lnk (castPtr ptr) (length xs)
  assertML loc bl
  
{# fun MLPutInteger16List as putInt16List'
       { withLink* `Link'
       , id `Ptr CShort'
       , `Int'
       } -> `Bool' cToBool
 #}
putInt16List :: [Int16] -> ML ()
putInt16List = unsafePutList "putInt16List" putInt16List'

{# fun MLPutInteger32List as putInt32List'
       { withLink* `Link'
       , id `Ptr CInt'
       , `Int'
       } -> `Bool' cToBool
 #}
putInt32List :: [Int32] -> ML ()
putInt32List = unsafePutList "putInt32List" putInt32List'

#ifdef IS_64_BIT
{# fun MLPutInteger64List as putIntList'
       { withLink* `Link'
       , id `Ptr CLong'
       , `Int'
       } -> `Bool' cToBool
 #}
#else
{# fun MLPutInteger32List as putIntList'
       { withLink* `Link'
       , id `Ptr CInt'
       , `Int'
       } -> `Bool' cToBool
 #}
#endif
putIntList :: [Int] -> ML ()
putIntList = unsafePutList "putIntList" putIntList'

{# fun MLPutReal32List as putFloatList'
       { withLink* `Link'
       , id `Ptr CFloat'
       , `Int'
       } -> `Bool' cToBool
 #}
putFloatList :: [Float] -> ML ()
putFloatList = unsafePutList "putFloatList" putFloatList'

{# fun MLPutReal64List as putDoubleList'
       { withLink* `Link'
       , id `Ptr CDouble'
       , `Int'
       } -> `Bool' cToBool
 #}
putDoubleList :: [Double] -> ML ()
putDoubleList = unsafePutList "putDoubleList" putDoubleList'

-- Unsafe for the same reason as 'unsafePutList'.
unsafePutArray 
    :: Storable a
    => Location
    -> (Link -> Ptr b -> Ptr CInt -> Ptr CString -> Int -> IO Bool)
    -> [a] -> [(Int,String)] -> ML ()
unsafePutArray loc pfn xs dims = do
  lnk <- askLink
  bl <- liftIO $ withArray xs $ \xsPtr ->
          bracket (mapM newCString hds) (mapM_ free) $ \hdCStrs ->
            withArray hdCStrs $ \hdsPtr ->
              withArray (map cIntConv sh) $ \shpPtr ->
                pfn lnk (castPtr xsPtr) shpPtr hdsPtr rnk
  assertML loc bl
  where rnk = length dims
        (sh,hds) = unzip dims

{# fun MLPutInteger16Array as putInt16Array'
       { withLink* `Link'
       , id `Ptr CShort'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `Bool' cToBool
 #}
putInt16Array :: [Int16] -> [(Int,String)] -> ML ()
putInt16Array = unsafePutArray "putInt16Array" putInt16Array'

{# fun MLPutInteger32Array as putInt32Array'
       { withLink* `Link'
       , id `Ptr CInt'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `Bool' cToBool
 #}
putInt32Array :: [Int32] -> [(Int,String)] -> ML ()
putInt32Array = unsafePutArray "putInt32Array" putInt32Array'

#ifdef IS_64_BIT
{# fun MLPutInteger64Array as putIntArray'
       { withLink* `Link'
       , id `Ptr CLong'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `Bool' cToBool
 #}
#else
{# fun MLPutInteger32Array as putIntArray'
       { withLink* `Link'
       , id `Ptr CInt'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `Bool' cToBool
 #}
#endif
putIntArray :: [Int] -> [(Int,String)] -> ML ()
putIntArray = unsafePutArray "putIntArray" putIntArray'

{# fun MLPutReal32Array as putFloatArray'
       { withLink* `Link'
       , id `Ptr CFloat'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `Bool' cToBool
 #}
putFloatArray :: [Float] -> [(Int,String)] -> ML ()
putFloatArray = unsafePutArray "putFloatArray" putFloatArray'

{# fun MLPutReal64Array as putDoubleArray'
       { withLink* `Link'
       , id `Ptr CDouble'
       , id `Ptr CInt'
       , id `Ptr CString'
       , `Int'
       } -> `Bool' cToBool
 #}
putDoubleArray :: [Double] -> [(Int,String)] -> ML ()
putDoubleArray = unsafePutArray "putDoubleArray" putDoubleArray'


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

getScalarWith :: Location
              -> (Link -> IO (Bool, a))
              -> ML a
getScalarWith loc gfn = do
  (bl, v) <- askLink >>= \l -> liftIO $ gfn l
  assertML loc bl
  return v

{# fun MLGetInteger16 as getInt16'
       { withLink* `Link'
       , alloca- `Int16' peekIntConv*
       } -> `Bool' cToBool
 #}
getInt16 :: ML Int16
getInt16 = getScalarWith "getInt16" getInt16'

{# fun MLGetInteger32 as getInt32'
       { withLink* `Link'
       , alloca- `Int32' peekIntConv*
       } -> `Bool' cToBool
 #}
getInt32 :: ML Int32
getInt32 = getScalarWith "getInt32" getInt32'

#ifdef IS_64_BIT
{# fun MLGetInteger64 as getInt'
       { withLink* `Link'
       , alloca- `Int' peekIntConv*
       } -> `Bool' cToBool
 #}
#else
{# fun MLGetInteger32 as getInt'
       { withLink* `Link'
       , alloca- `Int' peekIntConv*
       } -> `Bool' cToBool
 #}
#endif
getInt :: ML Int
getInt = getScalarWith "getInt" getInt'

{# fun MLGetReal32 as getFloat'
       { withLink* `Link'
       , alloca- `Float' peekFloatConv*
       } -> `Bool' cToBool
 #}
getFloat :: ML Float
getFloat = getScalarWith "getFloat" getFloat'

{# fun MLGetReal64 as getDouble'
       { withLink* `Link'
       , alloca- `Double' peekFloatConv*
       } -> `Bool' cToBool
 #}
getDouble :: ML Double
getDouble = getScalarWith "getDouble" getDouble'


{# fun MLReleaseString as releaseString
       { withLink* `Link'
       , id `CString'
       } -> `()' id
 #}
{# fun MLGetString as getString'
       { withLink* `Link'
       , alloca- `CString' peek*
       } -> `Bool' cToBool
 #}
getString :: ML String
getString = do
  lnk <- askLink
  (bl, cstr) <- liftIO $ getString' lnk
  assertML "getString" bl
  str <- liftIO $ peekCString cstr
  liftIO $ releaseString lnk cstr
  return str

{# fun MLReleaseSymbol as releaseSymbol
       { withLink* `Link'
       , id `CString'
       } -> `()' id
 #}
{# fun MLGetSymbol as getSymbol'
       { withLink* `Link'
       , alloca- `CString' peek*
       } -> `Bool' cToBool
 #}
getSymbol :: ML String
getSymbol = do
  lnk <- askLink
  (bl, cstr) <- liftIO $ getSymbol' lnk
  assertML "getSymbol" bl
  str <- liftIO $ peekCString cstr
  liftIO $ releaseSymbol lnk cstr
  return str

{# fun MLGetArgCount as getArgCount'
       { withLink* `Link'
       , alloca- `Int' peekIntConv*
       } -> `Bool' cToBool
 #}
getArgCount :: ML Int
getArgCount = do
  lnk <- askLink
  (bl, n) <- liftIO $ getArgCount' lnk
  assertML "getArgCount" bl
  return n

getFunction :: ML (String,Int)
getFunction = do
  n <- getArgCount
  hd <- getSymbol
  return (hd,n)

unsafeGetList :: Storable b 
              => Location
              -> (Link -> IO (Bool, Ptr a, Int))
              -> (Link -> Ptr a -> Int -> IO ())
              -> ML [b]
unsafeGetList loc gfn rfn = do
  lnk <- askLink
  (bl, ptr, n) <- liftIO $ gfn lnk
  assertML loc bl
  xs <- liftIO $ peekArray n (castPtr ptr)
  liftIO $ rfn lnk (castPtr ptr) n
  return xs

{# fun MLReleaseInteger16List as releaseInt16List'
       { withLink* `Link'
       , id `Ptr CShort'
       , `Int'
       } -> `()' id
 #}
{# fun MLGetInteger16List as getInt16List'
       { withLink* `Link'
       , alloca- `Ptr CShort' peek*
       , alloca- `Int' peekIntConv*
       } -> `Bool' cToBool
 #}
getInt16List :: ML [Int16]
getInt16List = unsafeGetList "getInt16List" 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*
       } -> `Bool' cToBool
 #}
getInt32List :: ML [Int32]
getInt32List = unsafeGetList "getInt32List" 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*
       } -> `Bool' cToBool
 #}
#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*
       } -> `Bool' cToBool
 #}
#endif
getIntList :: ML [Int]
getIntList = unsafeGetList "getIntList" 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*
       } -> `Bool' cToBool
 #}
getFloatList :: ML [Float]
getFloatList = unsafeGetList "getFloatList" 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*
       } -> `Bool' cToBool
 #}
getDoubleList :: ML [Double]
getDoubleList = 
  unsafeGetList "getDoubleList" getDoubleList' releaseDoubleList'

unsafeGetArray :: Storable b
               => Location
               -> (Link -> IO (Bool, Ptr a, Ptr CInt, Ptr CString, Int))
               -> (Link -> Ptr a -> Ptr CInt -> Ptr CString -> Int -> IO ())
               -> ML ([b], [(Int,String)])
unsafeGetArray loc gfn rfn = do
  lnk <- askLink
  (bl, xsPtr, shpPtr, hdsPtr, rnk) <- liftIO $ gfn lnk
  assertML loc bl
  sh  <- liftIO $ peekArray rnk shpPtr >>= (return . map cIntConv)
  hds <- liftIO $ peekArray rnk hdsPtr >>= (mapM peekCString)
  xs  <- liftIO $ peekArray (product sh) (castPtr xsPtr) 
  liftIO $ rfn lnk (castPtr xsPtr) shpPtr hdsPtr rnk
  return (xs, zip sh hds)

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

{# fun MLGetInteger32Array as getInt32Array'
       { withLink* `Link'
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `Bool' cToBool
 #}
{# fun MLReleaseInteger32Array as releaseInt32Array'
       { withLink* `Link'
       , id `Ptr CInt'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
getInt32Array :: ML ([Int32], [(Int,String)])
getInt32Array = 
  unsafeGetArray "getInt32Array" 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*
       } -> `Bool' cToBool
 #}
{# 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 CInt' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `Bool' cToBool
 #}
{# fun MLReleaseInteger32Array as releaseIntArray'
       { withLink* `Link'
       , id `Ptr CInt'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
#endif
getIntArray :: ML ([Int], [(Int,String)])
getIntArray = 
  unsafeGetArray "getIntArray" getIntArray' releaseIntArray'

{# fun MLGetReal32Array as getFloatArray'
       { withLink* `Link'
       , alloca- `Ptr CFloat' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `Bool' cToBool
 #}
{# fun MLReleaseReal32Array as releaseFloatArray'
       { withLink* `Link'
       , id `Ptr CFloat'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
getFloatArray :: ML ([Float], [(Int,String)])
getFloatArray = 
  unsafeGetArray "getFloatArray" getFloatArray' releaseFloatArray'

{# fun MLGetReal64Array as getDoubleArray'
       { withLink* `Link'
       , alloca- `Ptr CDouble' peek*
       , alloca- `Ptr CInt' peek*
       , alloca- `Ptr CString' peek*
       , alloca- `Int' peekIntConv*
       } -> `Bool' cToBool
 #}
{# fun MLReleaseReal64Array as releaseDoubleArray'
       { withLink* `Link'
       , id `Ptr CDouble'
       , id `Ptr CInt'
       , id `Ptr CString'
       , cIntConv `Int'
       } -> `()' id
 #}
getDoubleArray :: ML ([Double], [(Int,String)])
getDoubleArray = 
  unsafeGetArray "getDoubleArray" getDoubleArray' releaseDoubleArray'

-- | Gets the type of the next value to be gotten over the link.
{# fun MLGetType as getType'
       { withLink* `Link'
       } -> `MLType' cToEnum
 #}
getType :: ML MLType
getType = askLink >>= \l -> liftIO $ getType' l

-- | 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'
 #}
testHead :: String -> ML Int
testHead hd = do
  lnk <- askLink
  (bl, n) <- liftIO $ testHead' lnk hd
  assertML "testHead" bl
  return n

-- | 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.
  -> ML (String,Int)  -- ^ The head and number of arguments, on success.
testFunction hdQ nargQ = do
  typ <- getType
  case typ of
    MLType TypFn -> do 
      nargs <- getArgCount
      if not $ nargQ nargs then
          throwMsg "testFunction" "# of args failed predicate"
        else do
          hdTyp <- getType
          case hdTyp of
            MLType TypSy -> do
              hd <- getSymbol
              if not $ hdQ hd then
                  throwMsg "testFunction" "head failed predicate"
                else
                  return (hd, nargs)
            _ -> throwMsg "testFunction" "expected symbol for head"
    _ -> 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

peekEnum      :: (Storable a, Integral a, Enum b)
              => Ptr a -> IO b
peekEnum       = liftM cToEnum . 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