{-# OPTIONS_GHC -Wall -fglasgow-exts -XIncoherentInstances #-}
--------------------------------------------------------------------
-- |
-- Module      : NET.Base
-- Description : .NET bridge base functionality
-- Copyright   : (c) Sigbjorn Finne, 2008
-- License     : BSD3
--
-- Maintainer  : Sigbjorn Finne <sof@forkIO.com>
-- Stability   : provisional
-- Portability : portable
--
-- Primitive/low-level types and operations for the .NET bridge. The
-- public interface to the NET bridge is the "NET" module, so unless
-- it fails to expose required functionality or you simply want to
-- some lower-level operation you probably won't need to import "NET.Base".
-- 
-- 
--------------------------------------------------------------------
module NET.Base where

import Control.Monad
import Data.Int
import Data.Word

import Numeric
import Data.Char ( isSpace )
import Data.List ( intercalate )
import Data.Maybe

import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import System.IO.Unsafe ( unsafePerformIO )

import Control.Exception as CE
import Data.Typeable

-- all for the benefit of 'allocBytes':
import GHC.Ptr
--import GHC.Prim
import GHC.Int
import GHC.Base
import GHC.IOBase

infix 8 #
infix 9 ##

-- | @ obj # method @ is a prefixed, OO-style 
-- application operator:
( # )  :: a -> (a -> IO b) -> IO b
obj # method = method obj

-- | @ actionObj ## method @ is useful for putting together
-- chains or pipelines of object-producing methods:
--
-- > createObj1 ## invoke "Foo" ## invoke "Bar" 
-- 
( ## ) :: IO a -> (a -> IO b) -> IO b
mObj ## method = mObj >>= method

-- | @PrimObject@ is the base representation of references into the .NET
-- managed heap. It is a /foreign/ pointer, and has a finalizer attached
-- to it so that upon garbage collection the storage manager will release
-- the reference it has to the underlying .NET object.
--
type PrimObject = ForeignPtr ()

-- In case we want to drop back to a non-finalized rep:
--type PrimObject = Ptr ()

-- | @Object@ is the typed representation of a .NET object handle in Haskell.
-- It wraps an untyped 'PrimObject', but more interestingly it is parameterized
-- over the class/.NET type objec it is a Haskell representation of. This
-- phantom type can be used to provide type-safe binding to methods etc.:
--
-- > data TimeZone_ a
-- > type TimeZone a = Object (TimeZone_ a)
-- > 
-- > getDaylightChanges :: Int{-year-} -> TimeZone a -> IO (DaylightTime b)
-- > getDaylightChanges yr this = this # invoke "GetDaylightChanges" yr
--
-- Restricting @getDaylightChanges@ to only be applied to objects of type
-- @TimeZone@. This relies on being able to define the empty/data-constructor-less
-- datatype @TimeZone_@ in Haskell (supported by GHC.) We /phantomize/ that
-- empty data type constructor as well, so as to encode inheritance, i.e.,
-- a subclass of the @TimeZone@ .NET type could be represented as:
--
-- > data MyTimeZone_ a
-- > type MyTimeZone a = TimeZone (MyTimeZone_ a)
--
data Object a = Object PrimObject

-- | @GObject_ a ty@ is the representation of generically typed
-- object references. The @a@ type argument encodes the inheritance chain
-- (see 'Object'), while @ty@ represents the type(s) that the .NET generic
-- object instance is instantiated over, e.g.,
--
-- >  data Queue_ a ty
-- >  type Queue ty = GObject () (Queue_ () ty)
-- >
-- >  (obj :: Queue Int)
--
-- | @GObject_@ is the empty, phantom typed data type for 'GObject'.
data GObject_ a ty 

-- | @GObject a ty@ is the representation of generically typed
-- object references. The @a@ type argument encodes the inheritance chain
-- (see 'Object'), while @ty@ represents the type(s) that the .NET generic
-- object instance is instantiated over, e.g.,
--
-- > data Queue_ a ty
-- > type Queue ty = GObject () (Queue_ () ty)
-- >
-- >  (obj :: Queue Int)
--
type GObject a ty = Object (GObject_ a ty)

instance (Type ty, Type a) => Type (GObject_ a ty) where
  tyName v = [toGenericTypeString (concat $ tyName $ tyCtorParamFst v) (tyName (tyCtorParamSnd v))]

-- | @NetObjFinalizer@ is the type signature for 'Object' finalizers.
type NetObjFinalizer = Ptr () -> IO ()

-- | @objToPtr x@ returns the raw pointer (i.e., @Ptr@ not a foreign pointer)
-- inside an object reference.
objToPtr :: Object a -> Ptr ()
objToPtr (Object x) = objRefToPtr x

-- | @objRefToPtr x@ goes from a primitive object value 'PrimObject' to the
-- its raw, unfinalized pointer value.
objRefToPtr :: PrimObject -> Ptr ()
objRefToPtr x = unsafeForeignPtrToPtr x
--objRefToPtr x = x

-- | The external finalizer for .NET objects. Defined in @cbits/HsInvoke.c@, and
-- merely releases the object reference by calling @Release@ on the COM pointer.
-- 
foreign import ccall "&DN_freeObject" theNetObjFinalizer :: FunPtr NetObjFinalizer

-- | @mkObject@ is the basic 'Object' constructor, applied to raw object references
-- coming back from the .NET world. It wraps these up with a finalizer that takes
-- care of releasing the object reference once the @Object@ is deemed garbage
-- by the GHC RTS. The finalized pointer is itself wrapped up as a parameterized
-- 'Object' value.
mkObject :: Ptr () -> IO (Object b)
mkObject p = do
  fp <- newForeignPtr theNetObjFinalizer p
  return (Object fp)

-- | @Vector@ is the type used for one-dimensional arrays holding standard
-- unboxed value types. 
data Vector_ a
type Vector a = Object (Vector_ a)

-- | Equality over 'Object's is simply delegated to .NET's notion of equality,
-- invoking the method @Equals@ on the first object value, passing it the second.
-- 
instance Type a => Eq (Object a) where
  (==) obj1 obj2 = unsafePerformIO $ 
      obj1 # invokeMethod "Equals" [] (arg_ obj2)

-- | The @Show@ instance over 'Object's is simply delegated to .NET's @ToString@.
instance Show (Object a) where
  show obj1 = unsafePerformIO $ 
     obj1 # invokeMethod "ToString" [] []

instance (Type a, Arg a) => Show (Vector a) where
  show obj1 = unsafePerformIO $ do
--     t <- obj1 # invokeMethod "GetType" [] []
--     print "foo"
     ai  <- createObj "System.Text.ASCIIEncoding" []
     (ai :: Object ()) # invokeMethod "GetString" [] (arg_ obj1)

-- | @castObjTy a@ is naughty, letting you cast an object
-- reference to any other. Do not use..unless you have to :-)
castObjTy :: Object a -> Object b
castObjTy (Object o) = Object o

-- | @objType obj@ is a type-level function for getting at 'Object's
-- type parameter.
objType :: Object a -> a
objType = error "objType - not supposed to touch"

-- | @isNullObj obj@ returns @True@ if @obj@ is equal to the null
-- pointer..
isNullObj :: Object a -> Bool
isNullObj (Object x) = objRefToPtr x == nullPtr

-- | @nullObj@ is the null object reference.
nullObj :: Object a
nullObj = unsafePerformIO $ mkObject nullPtr

-- | @toGenericTypeString ty tyArgs@ takes care of constructing
-- a type string representing a .NET generic type @ty@ instantiated
-- with the type arguments @tyArgs@. Of internal interest and use
-- only..
--
toGenericTypeString :: String -> [String] -> String
toGenericTypeString ty []  = ty 
toGenericTypeString ty [a] = ty ++ '`':'1':'[':a++"]"
toGenericTypeString ty as  = 
--  ty ++ '`':shows (length as) ('[':concatMap (\x -> '[':x++"]") as ++ "]")
  ty ++ '`':shows (length as) (concatMap (\x -> '[':x++"]") as ++ "")

--
-- Low-level and untyped marshalling of arguments and
-- results are handled via the 'NetType' class. 
-- 
--

type MarshalArg = Ptr (Ptr ()) -> IO ()
type InArg      = (NETBridgeType, MarshalArg)
type OutRes  a  = Ptr () -> IO a

type TypeName = String

-- | The @Type@ class overloads a function for getting at the .NET type
-- that a given Haskell object value is representing. A low-level implementation
-- class that you normally shouldn't have to worry about.
class Type a where
  tyName :: a -> [String]
  
  tyGenericArgs :: a -> [TypeName] -- the instantiated type parameters (for generics.)
  tyGenericArgs _ = []

tyNameDefault :: Type a => String -> a -> [String]
tyNameDefault d v = 
  case tyName v of
    [] -> [d]
    ds -> ds
  
instance Type a => Type (Object a) where
  tyName v = tyNameDefault "System.Object" (t11 v)

instance Type String where
  tyName _ = ["System.String"]

instance Type Int where
  tyName v = 
    if sizeOf v == 8 
     then ["System.Int64"]
     else ["System.Int32"]

instance Type Int8 where
  tyName _ = ["System.SByte"]

instance Type Int16 where
  tyName _ = ["System.Int16"]

instance Type Int32 where
  tyName _ = ["System.Int32"]

instance Type Int64 where
  tyName _ = ["System.Int64"]

instance Type Word where
  tyName v = 
    if sizeOf v == 8 
     then ["System.UInt64"]
     else ["System.UInt32"]

instance Type Word8 where
  tyName _ = ["System.Byte"]

instance Type Word16 where
  tyName _ = ["System.UInt16"]

instance Type Word32 where
  tyName _ = ["System.UInt32"]

instance Type Word64 where
  tyName _ = ["System.UInt64"]

instance Type Float where
  tyName _ = ["System.Single"]

instance Type Double where
  tyName _ = ["System.Double"]

instance Type Bool where
  tyName _ = ["System.Boolean"]

instance Type Char where
  tyName _ = ["System.Char"]

instance Type (Ptr a) where
  tyName _ = ["System.IntPtr"]

instance Type a => Type (Vector_ a) where
  tyName _ = ["System.Array"]

instance Type () where
  tyName _ = []

instance (Type a, Type b) => Type (a,b) where
  tyName v = concat [ tyName (fst v), tyName (snd v)]

instance (Type a, Type b,Type c) => Type (a,b,c) where
  tyName ~(a,b,c) = concat [ tyName a, tyName b, tyName c]

instance (Type a, Type b,Type c, Type d) => Type (a,b,c,d) where
  tyName ~(a,b,c,d) = concat [ tyName a, tyName b, tyName c, tyName d]

instance (Type a, Type b,
          Type c, Type d,
	  Type e)
       => Type (a,b,c,d,e) where
  tyName ~(a,b,c,d,e) = concat [ tyName a, tyName b, tyName c, tyName d, tyName e]

instance (Type a, Type b,
          Type c, Type d,
	  Type e, Type f)
       => Type (a,b,c,d,e,f) where
  tyName ~(a,b,c,d,e,f) = concat [ tyName a, tyName b, tyName c, tyName d, tyName e, tyName f]


-- | @Arg@ is the type class which takes care of the operations for marshalling
-- Haskell values into their primitive form, something's that is done in preparation
-- for calling out to the .NET bridge.
class Arg a where
  arg_     :: a -> [InArg]
  fromArgs :: [Ptr ()] -> IO (a, [Ptr ()])

-- | @Result@ is the dual to 'Arg', handling the translation of primitive .NET bridge
-- values into their typed Haskell equivalents.
class Result a where
  fromResult :: a -> IO (Ptr ())
  toResult   :: Ptr () -> IO a

  resTy_   :: a -> NETBridgeType
  resTy_ _ = Dotnet_Object

instance Arg (Object a) where
  arg_     (Object o) = [(Dotnet_Object, \ p -> poke p (castPtr (objRefToPtr o)))]
  fromArgs []         = fail "fromArgs{Object}: impossible happened."
  fromArgs (x:xs)     = do { o <- mkObject x ; return (o,xs) }

instance Result (Object a) where
  fromResult (Object a) = return (objRefToPtr a)
  resTy_ _              = Dotnet_Object
  toResult px = peek (castPtr px) >>= mkObject

instance Arg a => Arg (Vector a) where
  arg_   (Object o) = [( Dotnet_Object
                       , \ p -> poke p (castPtr (objRefToPtr o))
		       )
		      ]
  fromArgs []     = fail "fromArgs{Vector: impossible happened."
  fromArgs (x:xs) = do { o <- mkObject x; return (o,xs) }

instance Result a => Result (Vector a) where
  fromResult (Object a) = return (objRefToPtr a)
  resTy_ v = Dotnet_Array (resTy_ $ t11 $ t11 v)
  toResult px = peek (castPtr px) >>= mkObject

instance Arg String where
  arg_     x = [(Dotnet_String,\ p -> do
--                    px <- newString x
--		    poke (castPtr p) px)]
                    withCString x $ \ px -> poke (castPtr p) px)]
  fromArgs []      = fail "fromArgs{Int}: impossible happened."
  fromArgs (pv:xs) = do
     if pv == nullPtr
      then return ("",xs)
      else do
        o <- mkObject pv
        s <- o # invokeMethod "ToString" [] []
	return (s, xs)
--        x <- peekCString (castPtr pv)
--	return (x,xs)

instance Result String where
  fromResult s = do
--     cx <- newString s
--     return (castPtr cx)
      -- Q: lifetime of string? Short, it is copied into a BSTR before
      -- handing it over to the PInvoke interop layer.
     withCString s $ \ px -> 
       return (castPtr px)
--    (Object a) <- newString s
--    return (objRefToPtr a)
  resTy_   _   = Dotnet_String
  toResult  px = do
     pv <- peek (castPtr px)
     if pv == nullPtr
      then return ""
      else do
        x <- peekCString pv
	 -- The NET bridge code ( in HsInvoke.c:fromVariant() ) malloc'ed
	 -- this string value, so let go of it here.
	free pv
	return x

instance Arg (Ptr a) where
  arg_     x = [(Dotnet_Ptr, \ p -> poke (castPtr p) x)]
  fromArgs []     = fail "fromArgs{Ptr}: impossible happened."
  fromArgs (p:xs) = return (castPtr p,xs)

instance Result (Ptr a) where
  fromResult p = return (castPtr p) -- (createObj "System.IntPtr" (arg_ p)) >>= return.objToPtr
  resTy_   _   = Dotnet_Ptr
  toResult  px = peek (castPtr px)

instance Arg Int where
  arg_     x = [(ty, \ p -> poke (castPtr p) x)]
    where
      ty 
       | sizeOf x == 8 = Dotnet_Int64
       | otherwise     = Dotnet_Int32

  fromArgs []     = fail "fromArgs{Int}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Int where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_ v = 
    if sizeOf v == 8 
     then Dotnet_Int64
     else Dotnet_Int32
  toResult  px = peek (castPtr px)

instance Arg Int8 where
  arg_     x = [(Dotnet_Int8, \ p -> poke (castPtr p) x)]

  fromArgs []     = fail "fromArgs{Int8}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Int8 where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_   _   = Dotnet_Int8
  toResult  px = peek (castPtr px)

instance Arg Int16 where
  arg_     x = [(Dotnet_Int16, \ p -> poke (castPtr p) x)]
  fromArgs []     = fail "fromArgs{Int16}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Int16 where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_ _     = Dotnet_Int16
--  fromResult i = createObj "System.Int16" (arg_ i) >>= return.objToPtr
  toResult  px = peek (castPtr px)

instance Arg Int32 where
  arg_     x = [(Dotnet_Int32, \ p -> poke (castPtr p) x)]
  fromArgs []     = fail "fromArgs{Int32}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Int32 where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_ _     = Dotnet_Int32
--  fromResult i = createObj "System.Int32" (arg_ i) >>= return.objToPtr
  toResult  px = peek (castPtr px)

instance Arg Int64 where
  arg_     x = [(Dotnet_Int64, \ p -> poke (castPtr p) x)]
  fromArgs []     = fail "fromArgs{Int64}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Int64 where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_ _     = Dotnet_Int64
--  fromResult i = createObj "System.Int64" (arg_ i) >>= return.objToPtr
  toResult  px = peek (castPtr px)

instance Arg () where
  arg_      _ = []
  fromArgs xs = return ((),xs)

instance Result () where
  fromResult _ = createObj "System.Void" [] >>= \ x -> return (objToPtr (x :: Object ()))
  resTy_ _     = Dotnet_Unit
  toResult  _  = return ()

instance Arg Word where
  arg_     x = [(ty,\ p -> poke (castPtr p) x)]
    where
     ty | sizeOf x == 8 = Dotnet_Word64
        | otherwise     = Dotnet_Word32

  fromArgs []     = fail "fromArgs{Word}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Word where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_ v     =
    if sizeOf v == 8 
     then Dotnet_Word64
     else Dotnet_Word32
--  fromResult w = createObj "System.UInt32" (arg_ w) >>= return.objToPtr
  toResult  px = peek (castPtr px)

instance Arg Word8 where
  arg_     x = [(Dotnet_Byte,\ p -> poke (castPtr p) x)]

  fromArgs []     = fail "fromArgs{Word8}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Word8 where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_   _   = Dotnet_Byte
--  fromResult w = createObj "System.Byte" (arg_ w) >>= return.objToPtr
  toResult  px = peek (castPtr px)

instance Arg Word16 where
  arg_     x = [(Dotnet_Word16, \ p -> poke (castPtr p) x)]

  fromArgs []     = fail "fromArgs{Word16}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Word16 where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_   _   = Dotnet_Word16
--  fromResult w = createObj "System.UInt16" (arg_ w) >>= return.objToPtr
  toResult  px = peek (castPtr px)

instance Arg Word32 where
  arg_     x = [(Dotnet_Word32, \ p -> poke (castPtr p) x)]

  fromArgs []     = fail "fromArgs{Word32}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Word32 where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_   _   = Dotnet_Word32
--  fromResult w = createObj "System.UInt32" (arg_ w) >>= return.objToPtr
  toResult  px = peek (castPtr px)

instance Arg Word64 where
  arg_     x = [(Dotnet_Word64, \ p -> poke (castPtr p) x)]

  fromArgs []     = fail "fromArgs{Word64}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Word64 where
  fromResult i = return (intPtrToPtr (fromIntegral i))
  resTy_   _   = Dotnet_Word64
--  fromResult w = createObj "System.UInt64" (arg_ w) >>= return.objToPtr
  toResult  px = peek (castPtr px)

instance Arg Bool where
  arg_     x = [(Dotnet_Boolean, \ p -> poke (castPtr p) x)]

  fromArgs []     = fail "fromArgs{Bool}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return ((0::Int) == fromIntegral ip, xs)

instance Result Bool where
  fromResult i = return (intPtrToPtr (fromIntegral (fromEnum i)))
--  fromResult w = createObj "System.Boolean" (arg_ w) >>= return.objToPtr
  resTy_    _ = Dotnet_Boolean
  toResult px = do
    v <- peek (castPtr px)
    return ((v::Int8) /= 0x00)

instance Arg Char where
  arg_     x = [(Dotnet_Char, \ p -> poke (castPtr p) x)]

  fromArgs []     = fail "fromArgs{Char}: impossible happened."
  fromArgs (px:xs) = do
     let ip = ptrToIntPtr px
     return (toEnum (fromIntegral ((fromIntegral ip)::Word16)),xs)

instance Result Char where
  fromResult i = return (intPtrToPtr (fromIntegral (fromEnum i)))
  resTy_   _ = Dotnet_Char
--  fromResult w = createObj "System.Char" (arg_ w) >>= return.objToPtr
  toResult  px = peek (castPtr px)

instance Arg Float where
  arg_     x = [(Dotnet_Float,\ p -> poke (castPtr p) x)]

  fromArgs []     = fail "fromArgs{Float}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Float where
  fromResult w = createObj "System.Single" (arg_ w) >>= \ x -> return (objToPtr (x :: Object ()))
  resTy_     _ = Dotnet_Float
  toResult  px = peek (castPtr px)

instance Arg Double where
  arg_     x   = [(Dotnet_Double, \ p -> poke (castPtr p) x)]

  fromArgs []     = fail "fromArgs{Double}: impossible happened."
  fromArgs (x:xs) = do
     let ip = ptrToIntPtr x
     return (fromIntegral ip, xs)

instance Result Double where
  fromResult w = createObj "System.Double" (arg_ w) >>= \ x -> return (objToPtr (x::Object ()))
  resTy_     _ = Dotnet_Double
  toResult  px = peek (castPtr px)

instance (Arg a1, Arg a2) => Arg (a1,a2) where
  arg_   (a1,a2) = (arg_ a1 ++ arg_ a2)
  fromArgs xs = do
     (v1,xs1) <- fromArgs xs
     (v2,xs2) <- fromArgs xs1
     return ((v1,v2),xs2)

instance (Arg a1, Arg a2, Arg a3) => 
	 Arg (a1,a2,a3) where
  arg_   (a1,a2,a3) = (arg_ a1 ++ arg_ a2 ++ arg_ a3)
  fromArgs xs = do
     (v1,xs1) <- fromArgs xs
     (v2,xs2) <- fromArgs xs1
     (v3,xs3) <- fromArgs xs2
     return ((v1,v2,v3),xs3)

instance (Arg a1, Arg a2, Arg a3, Arg a4) => 
	 Arg (a1,a2,a3,a4) where
  arg_   (a1,a2,a3,a4) = (arg_ a1 ++ arg_ a2 ++ arg_ a3 ++ arg_ a4)
  fromArgs xs = do
     (v1,xs1) <- fromArgs xs
     (v2,xs2) <- fromArgs xs1
     (v3,xs3) <- fromArgs xs2
     (v4,xs4) <- fromArgs xs3
     return ((v1,v2,v3,v4),xs4)

instance (Arg a1, Arg a2, Arg a3, Arg a4, Arg a5) => 
	 Arg (a1,a2,a3,a4,a5) where
  arg_   (a1,a2,a3,a4,a5) = 
     (arg_ a1 ++ arg_ a2 ++ 
      arg_ a3 ++ arg_ a4 ++ arg_ a5)
  fromArgs xs = do
     (v1,xs1) <- fromArgs xs
     (v2,xs2) <- fromArgs xs1
     (v3,xs3) <- fromArgs xs2
     (v4,xs4) <- fromArgs xs3
     (v5,xs5) <- fromArgs xs4
     return ((v1,v2,v3,v4,v5),xs5)

instance (Arg a1, Arg a2, Arg a3, Arg a4, Arg a5, Arg a6) => 
	 Arg (a1,a2,a3,a4,a5,a6) where
  arg_   (a1,a2,a3,a4,a5,a6) = 
     (arg_ a1 ++ arg_ a2 ++ 
      arg_ a3 ++ arg_ a4 ++ arg_ a5 ++ arg_ a6)
  fromArgs xs = do
     (v1,xs1) <- fromArgs xs
     (v2,xs2) <- fromArgs xs1
     (v3,xs3) <- fromArgs xs2
     (v4,xs4) <- fromArgs xs3
     (v5,xs5) <- fromArgs xs4
     (v6,xs6) <- fromArgs xs5
     return ((v1,v2,v3,v4,v5,v6),xs6)

instance (Arg a1, Arg a2, Arg a3, Arg a4, Arg a5, Arg a6, Arg a7) => 
	 Arg (a1,a2,a3,a4,a5,a6,a7) where
  arg_   (a1,a2,a3,a4,a5,a6,a7) = 
     (arg_ a1 ++ arg_ a2 ++ 
      arg_ a3 ++ arg_ a4 ++ arg_ a5 ++ arg_ a6 ++ arg_ a7)
  fromArgs xs = do
     (v1,xs1) <- fromArgs xs
     (v2,xs2) <- fromArgs xs1
     (v3,xs3) <- fromArgs xs2
     (v4,xs4) <- fromArgs xs3
     (v5,xs5) <- fromArgs xs4
     (v6,xs6) <- fromArgs xs5
     (v7,xs7) <- fromArgs xs6
     return ((v1,v2,v3,v4,v5,v6,v7),xs7)

instance (Arg a1, Arg a2, Arg a3, Arg a4, Arg a5, Arg a6, Arg a7, Arg a8) => 
	 Arg (a1,a2,a3,a4,a5,a6,a7,a8) where
  arg_   (a1,a2,a3,a4,a5,a6,a7,a8) = 
     (arg_ a1 ++ arg_ a2 ++ 
      arg_ a3 ++ arg_ a4 ++ arg_ a5 ++ arg_ a6 ++ arg_ a7 ++ arg_ a8)
  fromArgs xs = do
     (v1,xs1) <- fromArgs xs
     (v2,xs2) <- fromArgs xs1
     (v3,xs3) <- fromArgs xs2
     (v4,xs4) <- fromArgs xs3
     (v5,xs5) <- fromArgs xs4
     (v6,xs6) <- fromArgs xs5
     (v7,xs7) <- fromArgs xs6
     (v8,xs8) <- fromArgs xs7
     return ((v1,v2,v3,v4,v5,v6,v7,v8),xs8)

-- | Enumeration of the different types that the interop bridge support for passing
-- both ways.
--
data NETBridgeType
  = Dotnet_Byte
  | Dotnet_Boolean
  | Dotnet_Char
  | Dotnet_Double
  | Dotnet_Float
  | Dotnet_Int
  | Dotnet_Int8
  | Dotnet_Int16
  | Dotnet_Int32
  | Dotnet_Int64
  | Dotnet_Word8
  | Dotnet_Word16
  | Dotnet_Word32
  | Dotnet_Word64
  | Dotnet_Ptr
  | Dotnet_Unit
  | Dotnet_Object
  | Dotnet_String
  | Dotnet_Array NETBridgeType
    deriving ( Eq, Show )

-- | @isBoxedType@ returns 'True' if the given 'NETBridgeType' argument
-- has a boxed/object reference representation.
isBoxedType :: NETBridgeType -> Bool
isBoxedType Dotnet_Array{} = True
isBoxedType Dotnet_Object{} = True
isBoxedType _ = False

instance Enum NETBridgeType where
  toEnum x 
    | x < 0 = Dotnet_Array (toEnum (-x))
    | otherwise = 
      case x of
        0  -> Dotnet_Byte
	1  -> Dotnet_Boolean
        2  -> Dotnet_Char
        3  -> Dotnet_Double
        4  -> Dotnet_Float
        5  -> Dotnet_Int
        6  -> Dotnet_Int8
        7  -> Dotnet_Int16
        8  -> Dotnet_Int32
        9  -> Dotnet_Int64
        10 -> Dotnet_Word8
        11 -> Dotnet_Word16
        12 -> Dotnet_Word32
        13 -> Dotnet_Word64
        14 -> Dotnet_Ptr
        15 -> Dotnet_Unit
        16 -> Dotnet_Object
        17 -> Dotnet_String
        _  -> error "toEnum/other: shouldn't happen"

  fromEnum x =
      case x of
        Dotnet_Array v  -> -(fromEnum v)
        Dotnet_Byte     -> 0
	Dotnet_Boolean  -> 1
        Dotnet_Char     -> 2
        Dotnet_Double   -> 3
        Dotnet_Float    -> 4
        Dotnet_Int      -> 5
        Dotnet_Int8     -> 6
        Dotnet_Int16    -> 7
        Dotnet_Int32    -> 8
        Dotnet_Int64    -> 9
        Dotnet_Word8    -> 10
        Dotnet_Word16   -> 11
        Dotnet_Word32   -> 12
        Dotnet_Word64   -> 13
        Dotnet_Ptr      -> 14
        Dotnet_Unit     -> 15
        Dotnet_Object   -> 16
        Dotnet_String   -> 17

toTyTag :: NETBridgeType -> [Char]
toTyTag x = 
  case x of
    Dotnet_Byte -> "By"
    Dotnet_Boolean -> "B"
    Dotnet_Char ->   "C"
    Dotnet_Double -> "D"
    Dotnet_Float  -> "F"
    Dotnet_Int    -> "I"
    Dotnet_Int8   -> "I8"
    Dotnet_Int16  -> "I16"
    Dotnet_Int32  -> "I32"
    Dotnet_Int64  -> "I64"
    Dotnet_Word8  -> "W8"
    Dotnet_Word16  -> "W16"
    Dotnet_Word32  -> "W32"
    Dotnet_Word64  -> "W64"
    Dotnet_Ptr     -> "P"
    Dotnet_Unit    -> "()"
    Dotnet_Object  -> "O"
    Dotnet_String  -> "S"
    Dotnet_Array e -> "[]" ++ toTyTag e


-- Some self-documenting type synonyms:
type ClassName = String
type FieldName = String
type MethodName = String

-- | @invokeStaticMeth_@ is the low-level static method invocation
-- operation. Preps the arguments and storage to hold the result before
-- calling out.
invokeStaticMeth_  :: (Result a)
                   => String
		   -> Bridge_Static_Signature
                   -> ClassName
		   -> MethodName
                   -> [InArg]
		   -> IO a
invokeStaticMeth_ loc meth cName methName args = 
  let arity = length args in
  let cty   = cName ++ (if null methName then "" else '.':methName) in
  withArgResult arity $ \ argVec res -> do
      setArgs argVec args
      withCString     "" $ \ p_assem -> 
        withCString  cty $ \ p_ty -> do
          let hres = toResult (resPtr res)
          pd <- meth p_assem p_ty
	             (argVecPtr argVec) (fromIntegral $ argSize argVec)
		     (fromEnumI $ isBoxedType $ resTy_ $ tyCtorParam hres)
		     (fromEnumI (resultType res))
		     (resPtr res)
          if pd == nullPtr
	   then hres
	   else do
	    str <- peekCString pd
	    free pd
            throwNETError 
		   (toNETError str){ netErrorSource   = cty 
			           , netErrorMethodSig = Just (map fst args, resTy_ $ tyCtorParam hres)
		                   , netErrorLocation = loc
				   }

-- | @invokeStaticMeth2_@ is the low-level static method invocation
-- operation. Preps the arguments and storage to hold the result before
-- calling out.
invokeStaticMeth2_ :: (Result a)
                   => String
		   -> Bridge_Static_Signature2
                   -> ClassName
		   -> MethodName
		   -> [TypeName]
                   -> [InArg]
		   -> IO a
invokeStaticMeth2_ loc meth cName methName tyArgs args = 
  let arity = length args in
  let cty   = cName ++ (if null methName then "" else '.':methName) in
  withArgResult arity $ \ argVec res -> do
      setArgs argVec args
      withCString     "" $ \ p_assem -> 
       withCString  cty $ \ p_ty -> do
        withCString  (intercal tyArgs) $ \ p_tyArgs -> do
          let hres = toResult (resPtr res)
          pd <- meth p_assem p_ty p_tyArgs
	             (argVecPtr argVec) (fromIntegral $ argSize argVec)
		     (fromEnumI $ isBoxedType $ resTy_ $ tyCtorParam hres)
		     (fromEnumI (resultType res))
		     (resPtr res)
          if pd == nullPtr
	   then hres
	   else do
	    str <- peekCString pd
	    free pd
            throwNETError 
		   (toNETError str){ netErrorSource   = cty 
			           , netErrorMethodSig = Just (map fst args, resTy_ $ tyCtorParam hres)
		                   , netErrorLocation = loc
				   }

intercal :: [String] -> String
intercal [] = ""
intercal [x] = x
intercal (x@("_;;_"):xs) = x ++ intercal xs
intercal (x : xs) = x ++ ';':intercal xs

-- | @invokeStaticMethod@ is the low-level static method invocation
-- operation. Preps the arguments and storage to hold the result before
-- calling out.
invokeStaticMethod :: (Result a)
                   => ClassName
                   -> MethodName
		   -> [TypeName]
                   -> [InArg]
		   -> IO a
invokeStaticMethod = invokeStaticMeth2_ "static-method" bridge_invokeStatic_

-- | @getFieldStaticB@ is the low-level static field get accessor
-- operation. Preps the arguments and storage to hold the result before
-- calling out.
getFieldStaticB :: (Result a)
                => ClassName
                -> FieldName
                -> [InArg]
	        -> IO a
getFieldStaticB = invokeStaticMeth_ "get-static" bridge_getStatic_

setFieldStaticB :: (Result a)
                => ClassName
                -> FieldName
                -> [InArg]
	        -> IO a
setFieldStaticB = invokeStaticMeth_ "set-static" bridge_setStatic_

createObj :: ClassName
          -> [InArg]
	  -> IO (Object a)
createObj cName args = invokeStaticMeth_ "NET.Base.createObject" bridge_createObject_ cName "" args

invokeObjOp_ :: (Result a) -- , Type b)
             => String
	     -> Bridge_Object_Signature
             -> MethodName
             -> [InArg]
	     -> Object b
	     -> IO a
invokeObjOp_ loc meth methName args obj = 
  let arity = 1+length args in
  withArgResult arity $ \ argVec res -> do
--      print (methName)
      setArgs argVec (args ++ arg_ obj)
      withCString  methName $ \ p_m -> do
	  let hres = toResult (resPtr res) 
--          putStrLn ("Calling: " ++ methName)
          pd <- meth p_m
	             (argVecPtr argVec) (fromIntegral $ argSize argVec)
		     (fromEnumI $ isBoxedType $ resTy_ $ tyCtorParam hres)
		     (fromEnumI (resultType res))
		     (resPtr res)
--          putStrLn ("Returned: " ++ methName ++ " - result=" ++ show pd)
          if pd /= nullPtr
	   then peekCString pd  >>= \ str -> 
                putStrLn ("Return error: " ++ str) >>
	        free pd >>
	        throwNETError 
		   (toNETError str){ netErrorSource    = methName
			           , netErrorMethodSig = Just (map fst (args ++ arg_ obj),resTy_ $ tyCtorParam hres)
		                   , netErrorLocation  = loc
				   }
           else hres

invokeObjOp2_ :: (Result a) -- , Type b)
              => String
	      -> Bridge_Object_Signature2
              -> MethodName
	      -> [TypeName]
              -> [InArg]
	      -> Object b
	      -> IO a
invokeObjOp2_ loc meth methName tyArgs args obj = 
  let arity = 1+length args in
  withArgResult arity $ \ argVec res -> do
--      print (methName)
      setArgs argVec (args ++ arg_ obj)
      withCString  methName $ \ p_m -> do
        withCString  (intercal tyArgs) $ \ p_tyArgs -> do
	  let hres = toResult (resPtr res) 
--          putStrLn ("Calling: " ++ methName)
          pd <- meth p_m p_tyArgs
	             (argVecPtr argVec) (fromIntegral $ argSize argVec)
		     (fromEnumI $ isBoxedType $ resTy_ $ tyCtorParam hres)
		     (fromEnumI (resultType res))
		     (resPtr res)
--          putStrLn ("Returned: " ++ methName ++ " - result=" ++ show pd)
          if pd /= nullPtr
	   then peekCString pd  >>= \ str -> 
                putStrLn ("Return error: " ++ str) >>
	        free pd >>
	        throwNETError 
		   (toNETError str){ netErrorSource    = methName
			           , netErrorMethodSig = Just (map fst (args ++ arg_ obj), resTy_ $ tyCtorParam hres)
		                   , netErrorLocation  = loc
				   }
           else hres



invokeMethod :: (Result a) -- , Type b)
             => MethodName
	     -> [TypeName]
             -> [InArg]
	     -> Object b
	     -> IO a
invokeMethod = invokeObjOp2_ "method" bridge_invokeMethod_

getFieldB :: (Result a) -- , Type b)
          => FieldName
          -> [InArg]
	  -> Object b
	  -> IO a
getFieldB = invokeObjOp_ "get-field" bridge_getField_

setFieldB :: (Result a) --, Type b)
          => FieldName
          -> [InArg]
	  -> Object b
	  -> IO a
setFieldB = invokeObjOp_ "set-field" bridge_setField_

resultType :: (Result a) => ResultObj a -> NETBridgeType
resultType x = resTy_ (t11 x)

fromEnumI :: (Enum a) => a -> CInt
fromEnumI x = fromIntegral (fromEnum x)

newVector :: Result a => NETBridgeType -> Int -> IO (Vector a)
newVector ty x = do
  withResult $ \ p_res -> do
          pd <- bridge_mkVector_ (fromEnumI ty) (fromIntegral x) (resPtr p_res)
          if pd /= nullPtr
	   then peekCString pd  >>= \ str -> 
	        free pd >>
	        throwNETError ((toNETError str){ netErrorSource    = show ty
		                               , netErrorLocation  = "newVector"
					       })
           else toResult (resPtr p_res)

-- | allocate a BSTR for passing along to P/Invoke
newString :: String-> IO (CString)
newString str = 
 withCString str $ \ p_str -> 
  withResult $ \ _p_res -> bridge_newString_ p_str 

-- | @ArgVector@ is our representation of the argument list that
-- we hand over to the bridge
data ArgVector
 = ArgVector
      { argVecPtr :: Ptr ()
      , argSize   :: Int     -- >= 0
      }

argEntrySize :: Int
argEntrySize = argEntryValSize + sizeOf (undefined :: Int) + alignment (undefined::Int)

argEntryValSize :: Int
argEntryValSize = 8

withArgVector :: Int -> (ArgVector -> IO a) -> IO a
withArgVector l k = 
  allocaBytes (l * argEntrySize) $ \ p -> do
     let argVec = ArgVector{argVecPtr=p, argSize=l}
     k argVec

setArg :: (Ptr a -> IO ()) -> ArgVector -> Int -> IO ArgVector
setArg wr args p
 | p > argSize args = 
   fail ("setArg: argument index out out range: " ++ show (p,argSize args))
 | otherwise = do
--    print (p, argVecPtr args, argVecPtr args `plusPtr` (p * argEntrySize))
    wr (argVecPtr args `plusPtr` (p * argEntrySize))
    return args

allocBytes :: Int -> IO (Ptr ())
allocBytes (I# size) = IO $ \ st ->
  case newPinnedByteArray# size st       of { (# st1,  mbarr# #) ->
  case unsafeFreezeByteArray# mbarr# st1 of { (# st2, barr#  #) ->
  let addr = Ptr (byteArrayContents# barr#) in
    -- ToDo: chase down semantics of this primop. possibly
    -- a no-op here.
  case touch# barr# st2 of { st3 ->
  (# st3, addr #) }}}

newtype ResultObj a = ResultObj { resPtr :: Ptr () }

withResult :: Result a => (ResultObj a -> IO a) -> IO a
withResult k = withArgVector 1 (\ p -> k (ResultObj (argVecPtr p)))

withArgResult :: Result a => Int -> (ArgVector -> ResultObj a -> IO a) -> IO a
withArgResult l k = do
  allocaBytes (l * argEntrySize) $ \ p -> do
    let argVec = ArgVector{argVecPtr=p, argSize=l}
    withResult $ k argVec

stringArg :: ArgVector -> Int -> String -> IO ()
stringArg a v s = do
  x <- newCString s
  setArg (\ p -> do
            poke p x
	    pokeByteOff p 8 (fromEnum Dotnet_String)) a v
  return ()

setArgs :: ArgVector -> [InArg] -> IO ()
setArgs aVec args = 
  zipWithM_ (\ (t,wrArg) i -> do
               setArg (\ p -> do
	                 wrArg p
			 pokeByteOff p 8 (fromEnum t))
		      aVec
		      i)
	    args
	    [(0::Int)..]


toNETError :: String -> NETError
toNETError s = 
  let ne = parseErrorString s in
  case isFailedOperation ne of
    False -> ne
    _ -> let desc 
              | null (netErrorDescr ne) ||
	        netErrorDescr ne == "(null)" = "NET operation failed"
	      | otherwise = netErrorDescr ne
         in
	 ne{netErrorDescr=desc,netErrorKind=NETOpFailed}

parseErrorString :: String -> NETError
parseErrorString s = 
  NETError
     { netErrorLocation  = fromMaybe "unknown"     $ l_s "Location" 
     , netErrorKind      = fromMaybe NETOtherError $ l_r "Code"
     , netErrorDescr     = fromMaybe "" $ l_s "Description"
     , netErrorSource    = fromMaybe "" $ l_s "Source"
     , netErrorMethodSig = Nothing
     }
 where
  ls = map toAssoc $ lines s
  
  toAssoc xs = 
    case break (==':') xs of
      (as,':':bs) -> (as,dropWhile isSpace bs)
      (as,_) -> (as,"")

  l_s x = lookup x ls
  l_r x = readE $ lookup x ls
  
  readE Nothing   = Nothing
  readE (Just ('0':'x':xs)) = 
    case readHex xs of
      ((v,_):_) -> Just (NETCOMError v (l_s "CodeDescr"))
      _ -> Nothing
  readE (Just xs) = 
    case reads xs of
      ((v,_):_) -> Just (NETErrorCode v)
      _ -> Nothing

data NETError
 = NETError
     { netErrorLocation  :: String
     , netErrorKind      :: NETErrorKind
     , netErrorDescr     :: String
     , netErrorSource    :: String
     , netErrorMethodSig :: Maybe ([NETBridgeType],NETBridgeType)
     } deriving ( Typeable )

isFailedOperation :: NETError -> Bool
isFailedOperation ne = 
  case netErrorKind ne of
    NETCOMError 0x80004005 _ -> True  -- E_FAIL
    NETCOMError 0x6 _ -> True  -- ERROR_INVALID_HANDLE ..
    NETErrorCode 6 -> True  -- ERROR_INVALID_HANDLE ..
    _ -> False

showNETError :: NETError -> String
showNETError ne = 
  unlines ([ "NET bridge error:"
           , " Location: " ++ netErrorLocation ne
	   , " Source: "   ++ netErrorSource ne
           , " Kind: "     ++ showNETErrorKind (netErrorKind ne)
	   , " Description: " ++ netErrorDescr ne
	   ] ++ 
	   case netErrorMethodSig ne of
	     Just (args,res) -> [" Method type: " ++ toMethodSig args res]
	     _ -> [])

toMethodSig :: [NETBridgeType] -> NETBridgeType -> String
toMethodSig xs r = '(':(intercalate "," $ map toTyTag xs) ++ ")" ++ toTyTag r

instance Show NETError where
  show x = showNETError x

type HRESULT = Word32

data NETErrorKind
 = NETOtherError
 | NETOpFailed
 | NETCOMError   HRESULT (Maybe String)
 | NETErrorCode  Int

showNETErrorKind :: NETErrorKind -> String
showNETErrorKind n = 
  case n of
    NETOtherError  -> "HsNET bridge error"
    NETOpFailed    -> "Operation failed"
    NETCOMError x mb -> "COM error: 0x" ++ showHex x (' ':maybe "" id mb)
    NETErrorCode x -> "HsNET error " ++ show x

data SomeNETException = forall e . Exception e => SomeNETException e 
    deriving Typeable 

instance Show SomeNETException where 
    show (SomeNETException e) = show e 

instance Exception SomeNETException 

netToException :: Exception e => e -> SomeException 
netToException = toException . SomeNETException 

netFromException :: Exception e => SomeException -> Maybe e 
netFromException x = do 
    SomeNETException a <- fromException x 
    cast a 

instance Exception NETError where
  toException = netToException
  fromException = netFromException

handleNET :: (NETError -> IO a) -> IO a -> IO a
handleNET h e = catchNET e h

tryNET :: IO a -> IO (Either NETError a)
tryNET f = handleNET (\ x -> return (Left x)) (f >>= return.Right)

throwNETError :: NETError -> IO a
throwNETError e = throwIO e

catchNET :: IO a -> (NETError -> IO a) -> IO a
catchNET f hdlr = 
   CE.catch f
           (\ e1 -> hdlr e1)

-- something's badly wrong here having to pick out arbitrary args
-- down the C stack! 
type DelegatorPrim1  = Ptr () -> IO (Ptr ())
type DelegatorPrim1_ = Ptr () -> IO ()

type DelegatorPrim2  = Ptr () -> Ptr () -> IO (Ptr ())
type DelegatorPrim2_ = Ptr () -> Ptr () -> IO ()

type DelegatorPrim3  = Ptr () -> Ptr () -> Ptr () -> IO (Ptr ())
type DelegatorPrim3_ = Ptr () -> Ptr () -> Ptr () -> IO ()

foreign import ccall safe "wrapper"
  wrapDelegate1 :: DelegatorPrim1 -> IO (FunPtr DelegatorPrim1)

foreign import stdcall safe "wrapper"
  wrapDelegate1_ :: DelegatorPrim1_ -> IO (FunPtr DelegatorPrim1_)

foreign import stdcall safe "wrapper"
  wrapDelegate2 :: DelegatorPrim2   -> IO (FunPtr DelegatorPrim2)

foreign import stdcall safe "wrapper"
  wrapDelegate2_ :: DelegatorPrim2_ -> IO (FunPtr DelegatorPrim2_)

foreign import stdcall safe "wrapper"
  wrapDelegate3 :: DelegatorPrim3   -> IO (FunPtr DelegatorPrim3)

foreign import stdcall safe "wrapper"
  wrapDelegate3_ :: DelegatorPrim3_ -> IO (FunPtr DelegatorPrim3_)

newDelegator2 :: (Result c)
	      => String
	      -> (Ptr () -> Ptr () -> IO c)
	      -> IO (Object ())
newDelegator2 delTy fun = 
 withCString delTy $ \ p_delTy -> 
  withResult $ \ p_res -> do
    wr <- wrapDelegate2 delegatorWrapper
    pd <- bridge_defineDelegator_ p_delTy (castFunPtr wr) (resPtr p_res)
    if pd /= nullPtr
     then peekCString pd  >>= \ str -> 
          free pd >>
	  throwNETError ((toNETError str){ netErrorSource=delTy
		                         , netErrorLocation="newDelegator"
					 })
     else toResult (resPtr p_res)
 where
   delegatorWrapper :: DelegatorPrim2
   delegatorWrapper obj1 obj2 = do
--       print ("del2",obj1,obj2)
       v  <- fun obj2 obj1
       vc <- fromResult v
--       print ("del2r=",vc)
       return vc

newDelegator2_ :: String
	       -> (Ptr a -> Ptr b -> IO ())
	       -> IO (Object ())
newDelegator2_ delTy fun = 
 withCString delTy $ \ p_delTy -> 
  withResult $ \ p_res -> do
    wr <- wrapDelegate2_ delegatorWrapper
    pd <- bridge_defineDelegator_ p_delTy (castFunPtr wr) (resPtr p_res)
    if pd /= nullPtr
     then peekCString pd  >>= \ str -> 
          free pd >>
	  throwNETError ((toNETError str){ netErrorSource=delTy
		                         , netErrorLocation="newDelegator2_"
					 })
     else toResult (resPtr p_res)
 where
   delegatorWrapper :: DelegatorPrim2_
   delegatorWrapper obj1 obj2 = do
--       print ("del2_",obj1,obj2)
       fun (castPtr obj2) (castPtr obj1)

newDelegator3 :: (Result d)
	      => String
	      -> (Ptr () -> Ptr () -> Ptr () -> IO d)
	      -> IO (Object ())
newDelegator3 delTy fun = 
 withCString delTy $ \ p_delTy -> 
  withResult $ \ p_res -> do
    wr <- wrapDelegate3 delegatorWrapper
    pd <- bridge_defineDelegator_ p_delTy (castFunPtr wr) (resPtr p_res)
    if pd /= nullPtr
     then peekCString pd  >>= \ str -> 
          free pd >>
	  throwNETError ((toNETError str){ netErrorSource=delTy
		                         , netErrorLocation="newDelegator"
					 })
     else toResult (resPtr p_res)
 where
   delegatorWrapper :: DelegatorPrim3
   delegatorWrapper obj1 obj2 obj3 = fun obj2 obj3 obj1 >>= fromResult

newDelegator3_ :: String
	       -> (Ptr () -> Ptr () -> Ptr () -> IO ())
	       -> IO (Object ())
newDelegator3_ delTy fun = 
 withCString delTy $ \ p_delTy -> 
  withResult $ \ p_res -> do
    wr <- wrapDelegate3_ delegatorWrapper
    pd <- bridge_defineDelegator_ p_delTy (castFunPtr wr) (resPtr p_res)
    if pd /= nullPtr
     then peekCString pd  >>= \ str -> 
          free pd >>
	  throwNETError ((toNETError str){ netErrorSource=delTy
		                         , netErrorLocation="newDelegator3_"
					 })
     else toResult (resPtr p_res)
 where
   delegatorWrapper :: DelegatorPrim3_
   delegatorWrapper obj1 obj2 obj3 = do
--       print ("del3_",obj1,obj2,obj3)
       fun obj2 obj3 obj1

newDelegator1 :: (Result b)
	      => String
	      -> (Ptr () -> IO b)
	      -> IO (Object ())
newDelegator1 delTy fun = 
 withCString delTy $ \ p_delTy -> 
  withResult $ \ p_res -> do
    wr <- wrapDelegate1 delegatorWrapper
    pd <- bridge_defineDelegator_ p_delTy (castFunPtr wr) (resPtr p_res)
    if pd /= nullPtr
     then peekCString pd  >>= \ str -> 
          free pd >>
	  throwNETError ((toNETError str){ netErrorSource=delTy
		                         , netErrorLocation="newDelegator1"
					 })
     else toResult (resPtr p_res)
 where
   delegatorWrapper :: DelegatorPrim1
   delegatorWrapper obj1 = do
--       print ("del1",obj1)
       v  <- fun obj1
       fromResult v

newDelegator1_ :: String
	       -> (Object a -> IO ())
	       -> IO (Object ())
newDelegator1_ delTy fun = 
 withCString delTy $ \ p_delTy -> 
  withResult $ \ p_res -> do
    wr <- wrapDelegate1_ delegatorWrapper
    pd <- bridge_defineDelegator_ p_delTy (castFunPtr wr) (resPtr p_res)
    if pd /= nullPtr
     then peekCString pd  >>= \ str -> 
          free pd >>
	  throwNETError ((toNETError str){ netErrorSource=delTy
		                         , netErrorLocation="newDelegator1_"
					 })
     else toResult (resPtr p_res)
 where
   delegatorWrapper :: DelegatorPrim1_
   delegatorWrapper obj1 = do
--       print ("del_",obj1)
       p1 <- mkObject obj1
       fun p1

-- misc funky /type/ functions.

tyNameCtor :: (Type b) => String -> a b -> [String]
tyNameCtor def v 
 | null ts   = [def]
 | otherwise = ts
  where
   ts = tyName (tyCtorParam v)

asNetType :: (Type a) => a -> a
asNetType = undefined

tyNameCons :: (Type a) => a -> [String] -> [String]
tyNameCons v ls = (tyName v) ++ ls

t11 :: a b -> b
t11 = undefined

t21 :: a b c -> b
t21 = undefined

t22 :: a b c -> c
t22 = undefined

t31 :: a b c d -> b
t31 = undefined

t32 :: a b c d -> c
t32 = undefined

t33 :: a b c d -> d
t33 = undefined

tyCtorParam :: a b -> b
tyCtorParam = t11

tyCtorParam11 :: a b -> b
tyCtorParam11 = t11

tyCtorParam21 :: a b c -> b
tyCtorParam21 = t21

tyCtorParam22 :: a b c -> c
tyCtorParam22 = t22

tyCtorParam31 :: a b c d -> b
tyCtorParam31 = t31

tyCtorParam32 :: a b c d -> c
tyCtorParam32 = t32

tyCtorParam33 :: a b c d -> d
tyCtorParam33 = t33

tyMethSplit :: [String] -> [String]
tyMethSplit xs = "_;;_" : xs

tyCtorParamFst :: a b c -> b
tyCtorParamFst = t21

tyCtorParamSnd :: a b c -> c
tyCtorParamSnd = t22

tyFunArg :: (a -> b) -> a
tyFunArg = undefined

tyFunRes :: (a -> b) -> b
tyFunRes = undefined


-- set to @True@ to enable stack trace dumps from the .NET side.
setDumpExceptionsFlag :: Bool -> IO ()
setDumpExceptionsFlag flg = bridge_setDumpExceptionsFlag_ flg

type Bridge_Static_Signature
  =  CString
  -> CString
  -> Ptr ()
  -> CInt
  -> CInt
  -> CInt
  -> Ptr ()
  -> IO CString

type Bridge_Static_Signature2
  =  CString
  -> CString
  -> CString
  -> Ptr ()
  -> CInt
  -> CInt
  -> CInt
  -> Ptr ()
  -> IO CString

type Bridge_Object_Signature
  =  CString
  -> Ptr ()
  -> CInt
  -> CInt
  -> CInt
  -> Ptr ()
  -> IO CString

type Bridge_Object_Signature2
  =  CString
  -> CString
  -> Ptr ()
  -> CInt
  -> CInt
  -> CInt
  -> Ptr ()
  -> IO CString

foreign import ccall safe "DN_invokeStatic"  bridge_invokeStatic_ :: Bridge_Static_Signature2
foreign import ccall safe "DN_getStatic"     bridge_getStatic_    :: Bridge_Static_Signature
foreign import ccall safe "DN_setStatic"     bridge_setStatic_    :: Bridge_Static_Signature
foreign import ccall safe "DN_createObject"  bridge_createObject_ :: Bridge_Static_Signature
foreign import ccall safe "DN_invokeMethod"  bridge_invokeMethod_ :: Bridge_Object_Signature2
foreign import ccall safe "DN_getField"      bridge_getField_     :: Bridge_Object_Signature
foreign import ccall safe "DN_setField"      bridge_setField_     :: Bridge_Object_Signature
foreign import ccall safe "DN_newString"     bridge_newString_    :: CString -> IO CString
foreign import ccall safe "DN_mkVector"      bridge_mkVector_     :: CInt -> CInt -> Ptr () -> IO CString
foreign import ccall safe "DN_defineDelegator"   bridge_defineDelegator_  :: CString -> FunPtr () -> Ptr () -> IO CString
foreign import ccall safe "DN_freeObject"    bridge_freeObject_  :: Ptr () -> IO ()
--foreign import ccall "DN_derefHandle"   bridge_derefHandle_  :: Ptr () -> IO (Ptr ())
foreign import ccall "DN_setDumpExceptionsFlag"   bridge_setDumpExceptionsFlag_  :: Bool -> IO ()