diff --git a/Foreign/MathLink.hs b/Foreign/MathLink.hs
--- a/Foreign/MathLink.hs
+++ b/Foreign/MathLink.hs
@@ -15,8 +15,8 @@
     , MLDecl(..)
 
       -- * Running the /MathLink/ loop
-    , runMathLinkWithArgs
-    , runMathLink
+    , ML
+    , runMLSpec
 
       -- * /Mathematica/ expressions and data marshaling
     , module Foreign.MathLink.Expression
@@ -29,6 +29,7 @@
 import Control.Concurrent
 import Control.Exception hiding (evaluate)
 import Control.Monad
+import Control.Monad.Trans
 
 import Foreign.MathLink.Internal
 import Foreign.MathLink.Expression
@@ -36,8 +37,6 @@
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IM
 
-import System.Environment
-
 -- | A /Mathematica/ package specification.
 type MLSpec = [MLDecl]
 
@@ -51,7 +50,7 @@
               --   The 'String' is wrapped with a @ToExpression@ before
               --   being sent.
             | DeclMsg String String String
-              -- ^ Defines a /Mathematica/ message.
+              -- ^ Define a /Mathematica/ message.
               --
               --   @'DeclMsg' /sym/ /tag/ /defn/@ in Haskell maps to
               --   @/sym/::/tag/ = /defn/@ in /Mathematica/.
@@ -68,9 +67,12 @@
                        --   match are in scope for 'argPattern'.
                      , argPattern :: String
                        -- | The function to be called on the Haskell side.
-                     , func :: a -> IO b
+                     , func :: a -> ML b
                      }
-
+              -- ^ Declare a function to be callable from /Mathematica/.
+            | Exec (ML ())
+              -- ^ Specify an arbitrary action to be executed 
+              --   in the process of setting up the package.
 
 globalSpec :: MLSpec
 globalSpec = [ DeclMsg "MathLink" "usage" 
@@ -83,73 +85,67 @@
                  "Call packet received with invalid function index: `1`."
              ]
 
-tryCalcAndPut :: MVar (Either SomeException (Maybe a)) -> IO a -> IO ()
-tryCalcAndPut var comp = do ans <- comp
-                            ans `seq` putMVar var (Right (Just ans))
-                         `catch` (\e -> putMVar var (Left e))
-
-putWhenTrue :: MVar (Either SomeException (Maybe a)) -> IO Bool -> IO ()
-putWhenTrue var comp = do bl <- comp
-                          if bl then putMVar var (Right (Nothing)) else
-                            do threadDelay 100000
-                               putWhenTrue var comp
-                       `catch` (\e -> putMVar var (Left e))
-
-wrapFn :: (MLGet a, MLPut b) => (a -> IO b) -> IO ()
+wrapFn :: (MLGet a, MLPut b) => (a -> ML b) -> ML ()
 wrapFn fn = do
-    arg <- mlGet
+    lnk <- newLoopbackLink
+    transferTo lnk
     newPacket
     clearAbort
     clearInterrupt
-    result <- do
+    result <- liftIO $ do
       vres <- newEmptyMVar
-      idComp <- forkIO $ tryCalcAndPut vres $ fn arg
-      idInt  <- forkIO $ putWhenTrue vres checkInterrupt
+      idMl <- forkIO $ do runML (do arg <- mlGet
+                                    newPacket
+                                    fn arg >>= mlPut
+                                    endPacket
+                                    flush) lnk
+                          putMVar vres (Right True)
+                       `catch` (\e -> putMVar vres (Left e))
+      idIo <- forkIO $ do untilInterrupt
+                          putMVar vres (Right False)
+                       `catch` (\e -> putMVar vres (Left e))
       res <- takeMVar vres
-      killThread idComp
-      killThread idInt
+      killThread idMl
+      killThread idIo
       return res
     clearMLError
     case result of
-      Right (Just ans) -> mlPut ans >> endPacket
-      Right Nothing    -> (mlPut $ Sy "$Aborted") >> endPacket
-      Left err         -> do printMessage "MathLink" "exn" 
-                               [St $ show (err :: SomeException)]
-                             mlPut $ Sy "$Failed"
-                             endPacket
+      Right True  -> transferFrom lnk
+      Right False -> (mlPut $ Sy "$Aborted")
+      Left err    -> do printMessage "MathLink" "exn" 
+                          [St $ show (err :: SomeException)]
+                        mlPut $ Sy "$Failed"
+    endPacket
+    flush
+  where untilInterrupt = do
+          bl <- checkInterrupt
+          if bl then return () else do
+            threadDelay 100000
+            untilInterrupt
 
--- | Like 'runMathLinkWithArgs', but gets the arguments from 'getArgs'.
-runMathLink :: MLSpec -> IO ()
-runMathLink spec = do 
-  args <- getArgs 
-  runMathLinkWithArgs args spec
 
 -- | Run the /MathLink/ loop.
-runMathLinkWithArgs
-    :: [String] -- ^ The command line arguments to be passed to 
-                --   @MLOpenString@ (/e.g./, the link name).
-    -> MLSpec   -- ^ The package specification
+runMLSpec
+    :: MLSpec   -- ^ The package specification
     -> IO ()
-runMathLinkWithArgs args spec =
-  bracket (initializeMathLink (unwords args)) 
-          (const finalizeMathLink) $ \_ -> do
-    result <- try $ runSpec spec
-    case result of
-      Right () -> return ()
-      Left (MLErr 1  _) -> return ()  -- link dead
-      Left (MLErr 11 _) -> return ()  -- link closed
-      Left err -> putStrLn $ "Error occurred: " ++ show err
+runMLSpec spec = do
+  result <- try $ runMLMain $ runSpec spec
+  case result of
+    Right () -> return ()
+    Left (MLErr _ 1  _) -> return ()  -- link dead
+    Left (MLErr _ 11 _) -> return ()  -- link closed
+    Left err -> putStrLn $ "Error occurred: " ++ show err
         
-runSpec :: MLSpec -> IO ()
+runSpec :: MLSpec -> ML ()
 runSpec spec = do
-    (_,fns) <- foldM processDecl (0,[]) (globalSpec ++ spec)
-    mlPut $ Sy "End"
-    flush
-    answer $ IM.fromList fns
+  (_,fns) <- foldM processDecl (0,[]) (globalSpec ++ spec)
+  mlPut $ Sy "End"
+  flush
+  answer $ IM.fromList fns
 
-processDecl :: (Int,[(Int,IO ())]) 
+processDecl :: (Int,[(Int,ML ())]) 
             ->  MLDecl 
-            -> IO (Int,[(Int,IO ())])
+            -> ML (Int,[(Int,ML ())])
 processDecl pr (Eval v) = do
   send v
   return pr
@@ -159,11 +155,14 @@
 processDecl pr (DeclMsg sym tag defn) = do
   defineMessage sym tag defn
   return pr
+processDecl pr (Exec action) = do
+  action
+  return pr
 processDecl (n,fns) (DeclFn callPat argPat fn) = do
-  send ("DefineExternal":@[St callPat, St argPat, I (fromIntegral n)])
+  send ((Sy "DefineExternal"):@[St callPat, St argPat, I (fromIntegral n)])
   return (n+1,(n, wrapFn fn):fns)
       
-answer :: IntMap (IO ()) -> IO ()
+answer :: IntMap (ML ()) -> ML ()
 answer fnMap = do
   waitForPacket (== (MLPacket PktCall))
   n <- mlGet
@@ -182,10 +181,10 @@
 
 import "Foreign.MathLink"
 
-addFour :: ('Int','Int','Int','Int') -> IO 'Int'
+addFour :: ('Int','Int','Int','Int') -> 'ML' 'Int'
 addFour (a,b,c,d) = 'return' '$' a '+' b '+' c '+' d
 
-ackermann :: ('Integer','Integer') -> 'IO' 'Integer'
+ackermann :: ('Integer','Integer') -> 'ML' 'Integer'
 ackermann (m,n) = 'return' '$' ack m n
 
 ack :: 'Integer' -> 'Integer' -> 'Integer'
@@ -237,11 +236,6 @@
 
 {- $limitations
 
- * In the current implementation, only one /MathLink/ connection may be 
+   In the current implementation, only one /MathLink/ connection may be 
    made per process.
-
- * The library was written for, and has, as of yet, only been tested on
-   a 64-bit Linux platform. Some tweaking of the cabal file and minor 
-   edits to the "Foreign.MathLink.Internal" module would be necessary
-   to get it to work on a 32-bit platform.
 -}
diff --git a/Foreign/MathLink/Expression.hs b/Foreign/MathLink/Expression.hs
--- a/Foreign/MathLink/Expression.hs
+++ b/Foreign/MathLink/Expression.hs
@@ -21,43 +21,34 @@
     -- * Data marshaling 
     , MLPut(..)
     , MLGet(..)
-    , Packable
-    , putArray
-    , getArray
 
     ) where
 
-import Control.Monad
-import Data.Word
+import Control.Monad.Reader
 import Data.Int
 import Data.Complex
 import GHC.Real
 
 import Foreign.MathLink.Internal
-import Foreign.Storable
 
-import Data.Array.IArray
 import Data.Ix.Shapable
-import Data.Array (Array)
-import Data.Array.Unboxed (UArray)
-
-import System.IO
+import Data.Array.Unboxed
 
 -- | Haskell representation of a generic /Mathematica/ expression.
 data MLExpr = I Integer            -- ^ Atomic integer value.
             | R Rational           -- ^ Atomic real value.
             | St String            -- ^ Atomic string value, as a string.
             | Sy String            -- ^ Atomic string value, as a symbol.
-            | String :@ [MLExpr]   -- ^ Compound expression.
+            | MLExpr :@ [MLExpr]   -- ^ Compound expression.
               deriving (Eq, Ord, Show)
 
 -- | Sugar for the @Set@ /Mathematica/ expression
 (-=-) :: MLExpr -> MLExpr -> MLExpr
-ex1 -=- ex2 = "Set":@[ex1,ex2]
+ex1 -=- ex2 = (Sy "Set"):@[ex1,ex2]
 
 -- | Sugar for the @MessageName@ /Mathematica/ expression
 (-::-) :: String -> String -> MLExpr
-sym -::- tag = "MessageName":@[Sy sym, St tag]
+sym -::- tag = (Sy "MessageName"):@[Sy sym, St tag]
 
 
 ------------------- Evaluation ---------------------
@@ -67,7 +58,7 @@
 --   desired type).
 --
 --   Does not call 'endPacket'.
-evaluate :: (MLPut a, MLGet b) => a -> IO b
+evaluate :: (MLPut a, MLGet b) => a -> ML b
 evaluate v = do
   send v
   waitForPacket (== (MLPacket PktReturn))
@@ -78,7 +69,7 @@
 -- | Puts a value to the /MathLink/ connection.
 --
 --   Does not wait for a return packet or call 'endPacket'.
-send :: MLPut a => a -> IO ()
+send :: MLPut a => a -> ML ()
 send v = do
   putFunction "EvaluatePacket" 1
   mlPut v
@@ -86,8 +77,8 @@
 -- | Puts a value, as a string, to the /MathLink/ connection.
 --
 --   Does not wait for a return packet or call 'endPacket'.
-sendString :: String -> IO ()
-sendString str = send $ "ToExpression":@[St str]
+sendString :: String -> ML ()
+sendString str = send $ (Sy "ToExpression"):@[St str]
 
 -- | Defines a message.
 --
@@ -106,13 +97,13 @@
     :: String -- ^ The symbol associated with this message.
     -> String -- ^ The tag associated with this message.
     -> String -- ^ The message definition.
-    -> IO ()
+    -> ML ()
 defineMessage sym tag defn = 
   send (sym-::-tag -=- St defn)
 
 -- | Causes the specified message to be sent to /Mathematica/.
 --
---   Making the call (corresponding the the 'defineMessage' example):
+--   Making the call (corresponding to the 'defineMessage' example):
 --
 --   @
 --   'printMessage' \"Foo\" \"bar\" ['St' \"fish\", 'St' \"bicycle\"]
@@ -131,9 +122,9 @@
   -> String    -- ^ The tag associated with the message.
   -> [MLExpr]  -- ^ A list of expressions whose string values are
                --   to be interpolated in to the message.
-  -> IO ()
+  -> ML ()
 printMessage sym tag args = do
-  v <- evaluate ("Message":@[sym-::-tag,"Sequence":@args])
+  v <- evaluate ((Sy "Message"):@[sym-::-tag,(Sy "Sequence"):@args])
   (v :: MLExpr) `seq` return ()
 
 --------------------- MLPut -------------------------
@@ -141,7 +132,7 @@
 -- | The class of types that can be marshaled to /Mathematica/.
 class MLPut a where
   -- | Send a value to /Mathematica/.
-  mlPut :: a -> IO ()
+  mlPut :: a -> ML ()
 
 instance MLPut MLExpr where
   mlPut (I i)    = mlPut i
@@ -149,8 +140,9 @@
   mlPut (St str) = mlPut str
   mlPut (Sy sym) = putSymbol sym
   mlPut (hd :@ exs) = do 
-    putFunction hd (length exs)
-    mapM_ mlPut exs
+    putType $ MLType TypFn
+    putArgCount (length exs)
+    mapM_ mlPut (hd:exs)
 
 instance MLPut Bool where
   mlPut True = putSymbol "True"
@@ -193,6 +185,40 @@
 instance MLPut [Double] where
   mlPut = putDoubleList
 
+putArrayWith :: ( Ix ix
+                , Shapable ix
+                , IArray a e
+                ) => ([e] -> [(Int,String)] -> ML ())
+                  -> a ix e -> ML ()
+putArrayWith fn ary = fn xs dims
+  where xs = elems ary
+        dims = zip (shape ary) (repeat "List")
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLPut (UArray ix Int16) where
+  mlPut = putArrayWith putInt16Array
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLPut (UArray ix Int32) where
+  mlPut = putArrayWith putInt32Array
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLPut (UArray ix Int) where
+  mlPut = putArrayWith putIntArray
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLPut (UArray ix Float) where
+  mlPut = putArrayWith putFloatArray
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLPut (UArray ix Double) where
+  mlPut = putArrayWith putDoubleArray
+
 instance (RealFloat a, MLPut a) => MLPut (Complex a) where
   mlPut (r :+ i) = do putFunction "Complex" 2
                       mlPut r
@@ -203,6 +229,17 @@
                       mlPut n
                       mlPut d
 
+instance MLPut a => MLPut (Maybe a) where
+  mlPut (Just v) = do putFunction "Just" 1
+                      mlPut v
+  mlPut Nothing  = putSymbol "Nothing"
+
+instance (MLPut a, MLPut b) => MLPut (Either a b) where
+  mlPut (Left v) = do putFunction "Left" 1
+                      mlPut v
+  mlPut (Right v) = do putFunction "Right" 1
+                       mlPut v
+
 instance (MLPut a) => MLPut [a] where
   mlPut xs = do putFunction "List" (length xs)
                 mapM_ mlPut xs
@@ -294,7 +331,7 @@
 -- | The class of types that can be marshaled from /Mathematica/.
 class MLGet a where
   -- | Get a value from /Mathematica/.
-  mlGet :: IO a
+  mlGet :: ML a
 
 instance MLGet MLExpr where
   mlGet = do
@@ -304,11 +341,12 @@
       MLType TypR   -> mlGet     >>= (return . R)
       MLType TypSt  -> mlGet     >>= (return . St)
       MLType TypSy  -> getSymbol >>= (return . Sy)
-      MLType TypFn  -> do (hd,nargs) <- getFunction
-                          exs <- replicateM nargs mlGet
+      MLType TypFn  -> do nargs <- getArgCount
+                          hd    <- mlGet
+                          exs   <- replicateM nargs mlGet
                           return $ hd:@exs
-      MLType TypErr -> throwMLError
-      _             -> throwMsg "mlGet/Expression: unexpected type"
+      MLType TypErr -> throwMsg "mlGet/Expression" "type error"
+      _             -> throwMsg "mlGet/Expression" "unexpected type"
 
 instance MLGet Bool where
   mlGet = do
@@ -316,7 +354,7 @@
     case str of
       "True"  -> return True
       "False" -> return False
-      _       -> throwMsg "mlGet/Bool: unexpected symbol"
+      _       -> throwMsg "mlGet/Bool" "unexpected symbol"
 
 instance MLGet Int16 where
   mlGet = getInt16
@@ -354,13 +392,47 @@
 instance MLGet [Double] where
   mlGet = getDoubleList
 
+getArrayWith :: ( Ix ix
+                , Shapable ix
+                , IArray a e
+                ) => ML ([e], [(Int,String)])
+                  -> ML (a ix e)
+getArrayWith fn = do
+  (xs,dims) <- fn
+  return $ listArray (sBounds $ fst $ unzip dims) xs
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLGet (UArray ix Int16) where
+  mlGet = getArrayWith getInt16Array
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLGet (UArray ix Int32) where
+  mlGet = getArrayWith getInt32Array
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLGet (UArray ix Int) where
+  mlGet = getArrayWith getIntArray
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLGet (UArray ix Float) where
+  mlGet = getArrayWith getFloatArray
+
+instance ( Ix ix
+         , Shapable ix
+         ) => MLGet (UArray ix Double) where
+  mlGet = getArrayWith getDoubleArray
+
 instance (RealFloat a, MLGet a) => MLGet (Complex a) where
   mlGet = do
       typ <- getType
       case typ of
         MLType TypI  -> fromReal
         MLType TypFn -> fromFunc
-        _            -> throwMsg "mlGet/Complex: unexpected type"
+        _            -> throwMsg "mlGet/Complex" "unexpected type"
     where fromReal = do
             r <- mlGet
             return $ r :+ 0
@@ -378,7 +450,7 @@
         MLType TypI  -> fromInt
         MLType TypR  -> fromReal
         MLType TypFn -> fromFunc
-        _            -> throwMsg "mlGet/Ratio: unexpected type"
+        _            -> throwMsg "mlGet/Ratio" "unexpected type"
     where fromInt = do 
             i <- mlGet
             return $ i :% 1
@@ -395,6 +467,27 @@
             d <- mlGet
             return (n :% d)
 
+instance MLGet a => MLGet (Maybe a) where
+  mlGet = do
+    typ <- getType
+    case typ of
+      MLType TypSy -> do s <- getSymbol
+                         if s == "Nothing" then 
+                             return Nothing
+                           else
+                             throwMsg 
+                               "mlGet/Maybe a" "unexpected symbol"
+      MLType TypFn -> do testFunction (== "Just") (== 1)
+                         mlGet >>= (return . Just)
+      _ -> throwMsg "mlGet/Maybe a" "unexpected type"
+
+instance (MLGet a, MLGet b) => MLGet (Either a b) where
+  mlGet = do (hd,_) <- testFunction (const True) (== 1)
+             case hd of
+               "Left" -> mlGet >>= (return . Left)
+               "Right" -> mlGet >>= (return . Right)
+               _ -> throwMsg "mlGet/Either a b" "unexpected head"
+
 instance (MLGet a) => MLGet [a] where
   mlGet = do (_,nargs) <- testFunction (== "List") (>= 0)
              replicateM nargs mlGet
@@ -408,11 +501,11 @@
           if sy == "Null" then 
               return () 
             else
-              throwMsg "mlGet/(): unexpected symbol"
+              throwMsg "mlGet/()" "unexpected symbol"
         (MLType TypFn) -> do 
           testFunction (== "List") (== 0)
           return ()
-        _ -> throwMsg "mlGet/(): unexpected type"
+        _ -> throwMsg "mlGet/()" "unexpected type"
 
 instance ( MLGet t1
          , MLGet t2
@@ -492,79 +585,3 @@
              v7 <- mlGet
              return (v1,v2,v3,v4,v5,v6,v7)
 
-
--------------------------- Packable --------------------------
-
--- | The class of types that can be marshaled to and from
---   /Mathematica/ via packed storage.
-class Storable a => Packable a where
-    putPackedArray :: [a] -> [(Int,String)] -> IO ()
-    getPackedArray :: IO ([a],[(Int,String)])
-
-instance Packable Word8 where
-    putPackedArray xs dims = putInt16Array (map fromIntegral xs) dims
-    getPackedArray = do (xs,dims) <- getInt16Array
-                        return (map fromIntegral xs, dims)
-
-instance Packable Int16 where
-    putPackedArray = putInt16Array
-    getPackedArray = getInt16Array
-
-instance Packable Int32 where
-    putPackedArray = putInt32Array
-    getPackedArray = getInt32Array
-
-instance Packable Int where
-    putPackedArray = putIntArray
-    getPackedArray = getIntArray
-
-instance Packable Float where
-    putPackedArray = putFloatArray
-    getPackedArray = getFloatArray
-
-instance Packable Double where
-    putPackedArray = putDoubleArray
-    getPackedArray = getDoubleArray
-
--- | Send an array to /Mathematica/.
-putArray :: ( IArray a e
-            , Ix ix 
-            , Shapable ix
-            , Packable e
-            ) => a ix e -> IO ()
-putArray arr = putPackedArray xs dims
-  where xs = elems arr
-        sh = shape arr
-        dims = zip sh $ repeat "List"
-
--- | Get an array from /Mathematica/.
-getArray :: ( IArray a e
-            , Ix ix
-            , Shapable ix
-            , Packable e
-            ) => IO (a ix e)
-getArray = do 
-  (xs,dims) <- getPackedArray
-  let (shp,_) = unzip dims
-      bnds = sBounds shp
-  return $ listArray bnds xs
-
-instance (Packable e, Ix ix, Shapable ix) => MLPut (Array ix e) where
-  mlPut = putArray
-
-instance (Packable e, Ix ix, Shapable ix) => MLGet (Array ix e) where
-  mlGet = getArray
-
-instance ( IArray UArray e
-         , Packable e
-         , Ix ix
-         , Shapable ix 
-         ) => MLPut (UArray ix e) where
-  mlPut = putArray
-
-instance ( IArray UArray e
-         , Packable e
-         , Ix ix
-         , Shapable ix
-         ) => MLGet (UArray ix e) where
-  mlGet = getArray
diff --git a/Foreign/MathLink/Internal.chs b/Foreign/MathLink/Internal.chs
--- a/Foreign/MathLink/Internal.chs
+++ b/Foreign/MathLink/Internal.chs
@@ -1,21 +1,24 @@
-{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches #-}
+--{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-unused-matches #-}
 {-# LANGUAGE 
     ForeignFunctionInterface 
   , DeriveDataTypeable
+  , GeneralizedNewtypeDeriving
   #-}
 
 module Foreign.MathLink.Internal 
-    ( 
-
-    -- * Intitialization/finalization
-      initializeMathLink
-    , activate
-    , finalizeMathLink
+    (
+    -- * The 'ML' monad
+      Link
+    , ML
+    , runMLMain
+    , newLoopbackLink
+    , runML
+    , transferTo
+    , transferFrom
 
     -- * Checking types
     , Typ(..)
     , MLType(..)
-    , getType
     , testHead
     , testFunction
 
@@ -47,6 +50,10 @@
     -- *** String-like data
     , putString
     , putSymbol
+
+    -- *** Composite data
+    , putType
+    , putArgCount
     , putFunction
 
     -- ** Marshaling data from /Mathematica/
@@ -75,6 +82,10 @@
     -- *** String-like data
     , getString
     , getSymbol
+
+    -- *** Composite data
+    , getType
+    , getArgCount
     , getFunction
 
     -- * Out-of-band messaging
@@ -89,12 +100,11 @@
     -- * Errors
     , Err(..)
     , MLErr(..)
+    , Location
+    , getMLError
     , throwErr
     , throwCode
     , throwMsg
-    , getErrorMessage
-    , getMLError
-    , throwMLError
     , clearMLError
 
     -- * Packets
@@ -110,13 +120,20 @@
 
     ) where
 
-import Foreign
+import Prelude hiding (catch)
+
+import Foreign hiding (newForeignPtr)
 import Foreign.C
-import Control.Monad
+import Foreign.Concurrent (newForeignPtr)
+
+import Control.Concurrent
+import Control.Monad.Reader
 import Control.Exception
-import Data.Typeable
 
+import Data.Data
+
 import System.IO
+import System.Environment hiding (getEnvironment)
 
 #include "mathlink.h"
 #include "ml.h"
@@ -282,42 +299,138 @@
  deriving (Eq,Show)
  #}
 
-data MLErr = MLErr Int String
-           | MLErrCode Int
-           | MLErrMsg String
-             deriving (Eq,Show,Typeable)
+type Location = String
 
-instance Exception MLErr where
+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'
 
---------------------- Initialization -----------------------
+instance Exception MLErr where
 
-{# pointer MLINK as Link newtype #}
 
+--------------------- 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 ())
 
-withLink :: (Link -> IO a) -> IO a
-withLink fn = peek stdlinkPtr >>= fn . Link . castPtr
+{# pointer MLEnvironment as Environment newtype #}
+foreign import ccall safe "mathlink.h & stdenv" stdenvPtr
+    :: Ptr (Ptr ())
 
--- | Initialize the /MathLink/ connection.
+getEnvironment :: ML Environment
+getEnvironment = liftIO $ do
+  envPtr <- liftIO $ peek (castPtr stdenvPtr)
+  return $ Environment envPtr
+  
 {# 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'
+{# 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
@@ -338,16 +451,16 @@
 checkInterrupt = checkPtr interruptPtr
   
 -- | Clear any interrupt messages.
-clearInterrupt :: IO ()
-clearInterrupt = clearPtr interruptPtr
+clearInterrupt :: ML ()
+clearInterrupt = liftIO $ clearPtr interruptPtr
 
 -- | Check if an abort message was received.
 checkAbort :: IO Bool
 checkAbort = checkPtr abortPtr
 
 -- | Clear any abort messages.
-clearAbort :: IO ()
-clearAbort = clearPtr abortPtr
+clearAbort :: ML ()
+clearAbort = liftIO $ clearPtr abortPtr
 
 -- | Check if a done message was received.
 checkDone :: IO Bool
@@ -355,558 +468,666 @@
 
 -- | Send a /MathLink/ message to the other end of the
 --   /MathLink/ connection.
-{# fun MLPutMessage as putMessage
-       { withLink- `Link'
+{# fun MLPutMessage as putMessage'
+       { withLink* `Link'
        , cFromEnum `Msg'
        } -> `Bool'
  #}
+putMessage :: Msg -> ML ()
+putMessage m = liftML "putMessage" (skipFst1 putMessage' m)
 
 
 -------------------- Errors -------------------------
 
--- | Throw an 'MLErr' with the given error code and message.
-throwErr :: Int -> String -> IO a
-throwErr code msg = throw $ MLErr code msg
+throwErr :: Location -> Int -> String -> ML a
+throwErr loc code msg = 
+  liftIO $ throw $ MLErr loc (fromEnum ErrUser + code) msg
 
--- | Throw an 'MLErr' with just an error code.
-throwCode :: Int -> IO a
-throwCode code = throw $ MLErrCode code
+throwCode :: Location -> Int -> ML a
+throwCode loc code = 
+  liftIO $ throw $ MLErrCode loc (fromEnum ErrUser + code)
 
--- | Throw an 'MLErr' with just an error message.
-throwMsg :: String -> IO a
-throwMsg msg = throw $ MLErrMsg msg
+throwMsg :: Location -> String -> ML a
+throwMsg loc msg = liftIO $ throw $ MLErrMsg loc msg
 
--- | Get the error code associated with the last /MathLink/ error.
-{# fun MLError as getErrorCode
-       { withLink- `Link'
+{# fun MLError as getErrorCode'
+       { withLink* `Link'
        } -> `Int' cIntConv
  #}
 
--- | Get a string associated with the last /MathLink/ error.
-{# fun MLErrorMessage as getErrorMessage
-       { withLink- `Link'
+{# 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
+getMLError' :: Link -> Location -> IO MLErr
+getMLError' l loc = do
+  code <- getErrorCode' l
+  msg <- getErrorMessage' l
+  return $ MLErr loc code msg
 
--- | Throw an 'MLErr' corresponding to the last /MathLink/ error.
-throwMLError :: IO a
-throwMLError = getMLError >>= throw
+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'
-       } -> `()' throwUnless-
+{# fun MLClearError as clearMLError'
+       { withLink* `Link'
+       } -> `Bool' cToBool
  #}
+clearMLError :: ML ()
+clearMLError = do
+  l <- askLink 
+  bl <- liftIO $ clearMLError' l 
+  assertML "clearMLError" bl
 
-throwUnless :: Integral a => a -> IO ()
-throwUnless 0 = throwMLError
-throwUnless _ = return ()
 
+------------------ 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'
+{# 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'
-       } -> `()' throwUnless-
+{# 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'
-       } -> `()' throwUnless-
+{# 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'
-       } -> `()' throwUnless-
+{# 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'
-       } -> `()' throwUnless-
+{# 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) -> IO ()
+waitForPacket :: (MLPacket -> Bool) -> ML ()
 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
+  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) ---------------------
 
-{# fun MLPutInteger16 as putInt16
-       { withLink- `Link'
+putScalarWith :: Location -> (Link -> a -> IO Bool)
+              -> a -> ML ()
+putScalarWith loc pfn v = liftML loc (skipFst1 pfn v)
+
+{# fun MLPutInteger16 as putInt16'
+       { withLink* `Link'
        , `Int16'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+putInt16 :: Int16 -> ML ()
+putInt16 = putScalarWith "putInt16" putInt16'
 
-{# fun MLPutInteger32 as putInt32
-       { withLink- `Link'
+{# fun MLPutInteger32 as putInt32'
+       { withLink* `Link'
        , `Int32'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+putInt32 :: Int32 -> ML ()
+putInt32 = putScalarWith "putInt32" putInt32'
 
 #ifdef IS_64_BIT
-{# fun MLPutInteger64 as putInt
-       { withLink- `Link'
+{# fun MLPutInteger64 as putInt'
+       { withLink* `Link'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #else
-{# fun MLPutInteger32 as putInt
-       { withLink- `Link'
+{# fun MLPutInteger32 as putInt'
+       { withLink* `Link'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #endif
+putInt :: Int -> ML ()
+putInt = putScalarWith "putInt" putInt'
 
-{# fun MLPutReal32 as putFloat
-       { withLink- `Link'
+{# fun MLPutReal32 as putFloat'
+       { withLink* `Link'
        , `Float'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+putFloat :: Float -> ML ()
+putFloat = putScalarWith "putFloat" putFloat'
 
-{# fun MLPutReal64 as putDouble
-       { withLink- `Link'
+{# fun MLPutReal64 as putDouble'
+       { withLink* `Link'
        , `Double'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+putDouble :: Double -> ML ()
+putDouble = putScalarWith "putDouble" putDouble'
 
-{# fun MLPutString as putString
-       { withLink- `Link'
+{# fun MLPutString as putString'
+       { withLink* `Link'
        , `String'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+putString :: String -> ML ()
+putString = putScalarWith "putString" putString'
 
-{# fun MLPutSymbol as putSymbol
-       { withLink- `Link'
+{# fun MLPutSymbol as putSymbol'
+       { withLink* `Link'
        , `String'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+putSymbol :: String -> ML ()
+putSymbol = putScalarWith "putSymbol" putSymbol'
 
-{# fun MLPutFunction as putFunction
-       { withLink- `Link'
-       , `String'
+{# 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'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+putArgCount :: Int -> ML ()
+putArgCount nargs = liftML "putArgCount" (skipFst1 putArgCount' nargs)
 
-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)
+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'
+       { withLink* `Link'
        , id `Ptr CShort'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-putInt16List :: [Int16] -> IO ()
-putInt16List = putList cIntConv putInt16List'
+putInt16List :: [Int16] -> ML ()
+putInt16List = unsafePutList "putInt16List" putInt16List'
 
 {# fun MLPutInteger32List as putInt32List'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CInt'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-putInt32List :: [Int32] -> IO ()
-putInt32List = putList cIntConv putInt32List'
+putInt32List :: [Int32] -> ML ()
+putInt32List = unsafePutList "putInt32List" putInt32List'
 
 #ifdef IS_64_BIT
 {# fun MLPutInteger64List as putIntList'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CLong'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #else
 {# fun MLPutInteger32List as putIntList'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CInt'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #endif
-putIntList :: [Int] -> IO ()
-putIntList = putList cIntConv putIntList'
+putIntList :: [Int] -> ML ()
+putIntList = unsafePutList "putIntList" putIntList'
 
 {# fun MLPutReal32List as putFloatList'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CFloat'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-putFloatList :: [Float] -> IO ()
-putFloatList = putList cFloatConv putFloatList'
+putFloatList :: [Float] -> ML ()
+putFloatList = unsafePutList "putFloatList" putFloatList'
 
 {# fun MLPutReal64List as putDoubleList'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CDouble'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-putDoubleList :: [Double] -> IO ()
-putDoubleList = putList cFloatConv putDoubleList'
+putDoubleList :: [Double] -> ML ()
+putDoubleList = unsafePutList "putDoubleList" 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
+-- 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'
+       { withLink* `Link'
        , id `Ptr CShort'
        , id `Ptr CInt'
        , id `Ptr CString'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-putInt16Array :: [Int16] -> [(Int,String)] -> IO ()
-putInt16Array = putArray (cIntConv) putInt16Array'
+putInt16Array :: [Int16] -> [(Int,String)] -> ML ()
+putInt16Array = unsafePutArray "putInt16Array" putInt16Array'
 
 {# fun MLPutInteger32Array as putInt32Array'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CInt'
        , id `Ptr CInt'
        , id `Ptr CString'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-putInt32Array :: [Int32] -> [(Int,String)] -> IO ()
-putInt32Array = putArray (cIntConv) putInt32Array'
+putInt32Array :: [Int32] -> [(Int,String)] -> ML ()
+putInt32Array = unsafePutArray "putInt32Array" putInt32Array'
 
 #ifdef IS_64_BIT
 {# fun MLPutInteger64Array as putIntArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CLong'
        , id `Ptr CInt'
        , id `Ptr CString'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #else
 {# fun MLPutInteger32Array as putIntArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CInt'
        , id `Ptr CInt'
        , id `Ptr CString'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #endif
-putIntArray :: [Int] -> [(Int,String)] -> IO ()
-putIntArray = putArray (cIntConv) putIntArray'
+putIntArray :: [Int] -> [(Int,String)] -> ML ()
+putIntArray = unsafePutArray "putIntArray" putIntArray'
 
 {# fun MLPutReal32Array as putFloatArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CFloat'
        , id `Ptr CInt'
        , id `Ptr CString'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-putFloatArray :: [Float] -> [(Int,String)] -> IO ()
-putFloatArray = putArray (cFloatConv) putFloatArray'
+putFloatArray :: [Float] -> [(Int,String)] -> ML ()
+putFloatArray = unsafePutArray "putFloatArray" putFloatArray'
 
 {# fun MLPutReal64Array as putDoubleArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CDouble'
        , id `Ptr CInt'
        , id `Ptr CString'
        , `Int'
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-putDoubleArray :: [Double] -> [(Int,String)] -> IO ()
-putDoubleArray = putArray (cFloatConv) putDoubleArray'
+putDoubleArray :: [Double] -> [(Int,String)] -> ML ()
+putDoubleArray = unsafePutArray "putDoubleArray" putDoubleArray'
 
 
 ----------------------- Marshaling (gets) --------------------
 
-{# fun MLGetInteger16 as getInt16
-       { withLink- `Link'
+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*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+getInt16 :: ML Int16
+getInt16 = getScalarWith "getInt16" getInt16'
 
-{# fun MLGetInteger32 as getInt32
-       { withLink- `Link'
+{# fun MLGetInteger32 as getInt32'
+       { withLink* `Link'
        , alloca- `Int32' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+getInt32 :: ML Int32
+getInt32 = getScalarWith "getInt32" getInt32'
 
 #ifdef IS_64_BIT
-{# fun MLGetInteger64 as getInt
-       { withLink- `Link'
+{# fun MLGetInteger64 as getInt'
+       { withLink* `Link'
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #else
-{# fun MLGetInteger32 as getInt
-       { withLink- `Link'
+{# fun MLGetInteger32 as getInt'
+       { withLink* `Link'
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #endif
+getInt :: ML Int
+getInt = getScalarWith "getInt" getInt'
 
-{# fun MLGetReal32 as getFloat
-       { withLink- `Link'
+{# fun MLGetReal32 as getFloat'
+       { withLink* `Link'
        , alloca- `Float' peekFloatConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+getFloat :: ML Float
+getFloat = getScalarWith "getFloat" getFloat'
 
-{# fun MLGetReal64 as getDouble
-       { withLink- `Link'
+{# fun MLGetReal64 as getDouble'
+       { withLink* `Link'
        , alloca- `Double' peekFloatConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
+getDouble :: ML Double
+getDouble = getScalarWith "getDouble" getDouble'
 
+
 {# fun MLReleaseString as releaseString
-       { withLink- `Link'
+       { withLink* `Link'
        , id `CString'
        } -> `()' id
  #}
 {# fun MLGetString as getString'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `CString' peek*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-getString :: IO String
+getString :: ML String
 getString = do
-  cstr <- getString'
-  str <- peekCString cstr
-  releaseString cstr
+  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'
+       { withLink* `Link'
        , id `CString'
        } -> `()' id
  #}
 {# fun MLGetSymbol as getSymbol'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `CString' peek*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-getSymbol :: IO String
+getSymbol :: ML String
 getSymbol = do
-  cstr <- getSymbol'
-  str <- peekCString cstr
-  releaseSymbol cstr
+  lnk <- askLink
+  (bl, cstr) <- liftIO $ getSymbol' lnk
+  assertML "getSymbol" bl
+  str <- liftIO $ peekCString cstr
+  liftIO $ releaseSymbol lnk cstr
   return str
 
-{# fun MLGetFunction as getFunction'
-       { withLink- `Link'
-       , alloca- `CString' peek*
+{# fun MLGetArgCount as getArgCount'
+       { withLink* `Link'
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-getFunction :: IO (String,Int)
+getArgCount :: ML Int
+getArgCount = do
+  lnk <- askLink
+  (bl, n) <- liftIO $ getArgCount' lnk
+  assertML "getArgCount" bl
+  return n
+
+getFunction :: ML (String,Int)
 getFunction = do
-  (cstr, n) <- getFunction'
-  str <- peekCString cstr
-  releaseSymbol cstr
-  return (str, n)
+  n <- getArgCount
+  hd <- getSymbol
+  return (hd,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)
+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'
+       { withLink* `Link'
        , id `Ptr CShort'
        , `Int'
        } -> `()' id
  #}
 {# fun MLGetInteger16List as getInt16List'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CShort' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-getInt16List :: IO [Int16]
-getInt16List = getList cIntConv getInt16List' releaseInt16List'
+getInt16List :: ML [Int16]
+getInt16List = unsafeGetList "getInt16List" getInt16List' releaseInt16List'
 
 {# fun MLReleaseInteger32List as releaseInt32List'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CInt'
        , `Int'
        } -> `()' id
  #}
 {# fun MLGetInteger32List as getInt32List'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CInt' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-getInt32List :: IO [Int32]
-getInt32List = getList cIntConv getInt32List' releaseInt32List'
+getInt32List :: ML [Int32]
+getInt32List = unsafeGetList "getInt32List" getInt32List' releaseInt32List'
 
 #ifdef IS_64_BIT
 {# fun MLReleaseInteger64List as releaseIntList'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CLong'
        , `Int'
        } -> `()' id
  #}
 {# fun MLGetInteger64List as getIntList'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CLong' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #else
 {# fun MLReleaseInteger32List as releaseIntList'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CInt'
        , `Int'
        } -> `()' id
  #}
 {# fun MLGetInteger32List as getIntList'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CInt' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 #endif
-getIntList :: IO [Int]
-getIntList = getList cIntConv getIntList' releaseIntList'
+getIntList :: ML [Int]
+getIntList = unsafeGetList "getIntList" getIntList' releaseIntList'
 
 {# fun MLReleaseReal32List as releaseFloatList'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CFloat'
        , `Int'
        } -> `()' id
  #}
 {# fun MLGetReal32List as getFloatList'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CFloat' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-getFloatList :: IO [Float]
-getFloatList = getList cFloatConv getFloatList' releaseFloatList'
+getFloatList :: ML [Float]
+getFloatList = unsafeGetList "getFloatList" getFloatList' releaseFloatList'
 
 {# fun MLReleaseReal64List as releaseDoubleList'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CDouble'
        , `Int'
        } -> `()' id
  #}
 {# fun MLGetReal64List as getDoubleList'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CDouble' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
-getDoubleList :: IO [Double]
-getDoubleList = getList cFloatConv getDoubleList' releaseDoubleList'
+getDoubleList :: ML [Double]
+getDoubleList = 
+  unsafeGetList "getDoubleList" 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)
+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'
+       { withLink* `Link'
        , alloca- `Ptr CShort' peek*
        , alloca- `Ptr CInt' peek*
        , alloca- `Ptr CString' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 {# fun MLReleaseInteger16Array as releaseInt16Array'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CShort'
        , id `Ptr CInt'
        , id `Ptr CString'
        , cIntConv `Int'
        } -> `()' id
  #}
-getInt16Array :: IO ([Int16],[(Int,String)])
+getInt16Array :: ML ([Int16], [(Int,String)])
 getInt16Array = 
-  getArray cIntConv getInt16Array' releaseInt16Array'
+  unsafeGetArray "getInt16Array" getInt16Array' releaseInt16Array'
 
 {# fun MLGetInteger32Array as getInt32Array'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CInt' peek*
        , alloca- `Ptr CInt' peek*
        , alloca- `Ptr CString' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 {# fun MLReleaseInteger32Array as releaseInt32Array'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CInt'
        , id `Ptr CInt'
        , id `Ptr CString'
        , cIntConv `Int'
        } -> `()' id
  #}
-getInt32Array :: IO ([Int32],[(Int,String)])
+getInt32Array :: ML ([Int32], [(Int,String)])
 getInt32Array = 
-  getArray cIntConv getInt32Array' releaseInt32Array'
+  unsafeGetArray "getInt32Array" getInt32Array' releaseInt32Array'
 
 #ifdef IS_64_BIT
 {# fun MLGetInteger64Array as getIntArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CLong' peek*
        , alloca- `Ptr CInt' peek*
        , alloca- `Ptr CString' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 {# fun MLReleaseInteger64Array as releaseIntArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CLong'
        , id `Ptr CInt'
        , id `Ptr CString'
@@ -915,15 +1136,15 @@
  #}
 #else
 {# fun MLGetInteger32Array as getIntArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CInt' peek*
        , alloca- `Ptr CInt' peek*
        , alloca- `Ptr CString' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 {# fun MLReleaseInteger32Array as releaseIntArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CInt'
        , id `Ptr CInt'
        , id `Ptr CString'
@@ -931,67 +1152,75 @@
        } -> `()' id
  #}
 #endif
-getIntArray :: IO ([Int],[(Int,String)])
+getIntArray :: ML ([Int], [(Int,String)])
 getIntArray = 
-  getArray cIntConv getIntArray' releaseIntArray'
+  unsafeGetArray "getIntArray" getIntArray' releaseIntArray'
 
 {# fun MLGetReal32Array as getFloatArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CFloat' peek*
        , alloca- `Ptr CInt' peek*
        , alloca- `Ptr CString' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 {# fun MLReleaseReal32Array as releaseFloatArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CFloat'
        , id `Ptr CInt'
        , id `Ptr CString'
        , cIntConv `Int'
        } -> `()' id
  #}
-getFloatArray :: IO ([Float],[(Int,String)])
+getFloatArray :: ML ([Float], [(Int,String)])
 getFloatArray = 
-  getArray cFloatConv getFloatArray' releaseFloatArray'
+  unsafeGetArray "getFloatArray" getFloatArray' releaseFloatArray'
 
 {# fun MLGetReal64Array as getDoubleArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , alloca- `Ptr CDouble' peek*
        , alloca- `Ptr CInt' peek*
        , alloca- `Ptr CString' peek*
        , alloca- `Int' peekIntConv*
-       } -> `()' throwUnless-
+       } -> `Bool' cToBool
  #}
 {# fun MLReleaseReal64Array as releaseDoubleArray'
-       { withLink- `Link'
+       { withLink* `Link'
        , id `Ptr CDouble'
        , id `Ptr CInt'
        , id `Ptr CString'
        , cIntConv `Int'
        } -> `()' id
  #}
-getDoubleArray :: IO ([Double],[(Int,String)])
+getDoubleArray :: ML ([Double], [(Int,String)])
 getDoubleArray = 
-  getArray cFloatConv getDoubleArray' releaseDoubleArray'
+  unsafeGetArray "getDoubleArray" getDoubleArray' releaseDoubleArray'
 
 -- | Gets the type of the next value to be gotten over the link.
-{# fun MLGetType as getType
-       { withLink- `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'
+{# 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
@@ -999,17 +1228,25 @@
 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.
+  -> ML (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"
+      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 --------------------------
 
@@ -1020,6 +1257,10 @@
 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
diff --git a/example/Test.hs b/example/Test.hs
--- a/example/Test.hs
+++ b/example/Test.hs
@@ -4,11 +4,11 @@
 
 import Foreign.MathLink
 
-addFour :: (Int,Int,Int,Int) -> IO Int
+addFour :: (Int,Int,Int,Int) -> ML Int
 addFour (a,b,c,d) = return $ a+b+c+d
 
 -- Note that functions to be exposed need to be uncurried. 
-ackermann :: (Integer,Integer) -> IO Integer
+ackermann :: (Integer,Integer) -> ML Integer
 ackermann (m,n) = return $ ack m n
 
 ack :: Integer -> Integer -> Integer
@@ -20,29 +20,30 @@
 
 decl :: MLSpec
 decl = 
-  [ Eval $ "BeginPackage":@[St "Test`"]
+  [ Eval $ (Sy "BeginPackage"):@[St "Test`"]
 
   , DeclMsg "AddFour" "usage" 
       "AddFour[a,b,c,d] returns the sum of a, b, c, and d."
   , DeclMsg "Ackermann" "usage" 
       "Ackermann[m,n]: the Ackermann function."
 
-  , Eval $ "Begin":@[St "`Private`"]
+  , Eval $ (Sy "Begin"):@[St "`Private`"]
 
   , DeclFn { 
       callPattern = "AddFour[a_Integer,b_Integer,c_Integer,d_Integer]"
     , argPattern = "{a,b,c,d}"
     , func = addFour
     }
+
   , DeclFn {
       callPattern = "Ackermann[i_Integer,j_Integer]"
     , argPattern = "{i,j}"
     , func = ackermann
     }
 
-  , Eval $ "End":@[]
-  , Eval $ "EndPackage":@[]
+  , Eval $ (Sy "End"):@[]
+  , Eval $ (Sy "EndPackage"):@[]
   ]
 
 main :: IO ()
-main = runMathLink decl
+main = runMLSpec decl
diff --git a/mathlink.cabal b/mathlink.cabal
--- a/mathlink.cabal
+++ b/mathlink.cabal
@@ -1,5 +1,5 @@
 Name:                 mathlink
-Version:              2.0.0.7
+Version:              2.0.1.1
 Cabal-Version:        >= 1.6
 Build-Type:           Custom
 License:              BSD3
@@ -31,10 +31,11 @@
 Data marshaling is accomplished via the 'MLGet' and 'MLPut' classes, which
 specify types that that can be read from or written to the /MathLink/
 connection. Instances of these classes are provided for the obvious 
-standard data types, including tuples, lists, 'Array's and 'UArray's.
+standard data types, including tuples, lists, and 'UArray's.
 .
 A Haskell function that is to be exposed to /Mathematica/ has the type
-signature @('MLGet' a, 'MLPut' b) => a -> IO b@.
+signature @('MLGet' a, 'MLPut' b) => a -> 'ML' b@. The 'ML' monad provides
+single-threaded access to the /MathLink/ connection.
 .
 A simple example of a /Mathematica/ package:
 .
@@ -42,7 +43,7 @@
 import Foreign.MathLink
 .
 \-- define a function
-addTwo :: (Int,Int) -> IO Int
+addTwo :: (Int,Int) -> ML Int
 addTwo (x,y) = return $ x+y
 .
 \-- specify a package
@@ -76,11 +77,11 @@
 }
 
 Library
-  Build-Depends:      base >= 4.0 && < 4.2,
+  Build-Depends:      base >= 4.0 && < 4.3,
                       mtl >= 1.1 && < 1.2,
                       haskell98,
-                      array >= 0.2 && < 0.3,
-                      containers >= 0.2 && < 0.3,
+                      array >= 0.2 && < 0.4,
+                      containers >= 0.2 && < 0.4,
                       ix-shapable
 
   Exposed-Modules:    Foreign.MathLink