GHC/Dotnet.hs

   1 {-# OPTIONS -fno-implicit-prelude #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  GHC.Dotnet
   5 -- Copyright   :  (c) sof, 2003
   6 -- License     :  see libraries/base/LICENSE
   7 --
   8 -- Maintainer  :  cvs-ghc@haskell.org
   9 -- Stability   :  internal
  10 -- Portability :  non-portable (GHC extensions)
  11 --
  12 -- Primitive operations and types for doing .NET interop
  13 --
  14 -----------------------------------------------------------------------------
  15 module GHC.Dotnet
  16         ( Object
  17         , unmarshalObject
  18         , marshalObject
  19         , unmarshalString
  20         , marshalString
  21         , checkResult
  22         ) where
  23
  24 import GHC.Prim
  25 import GHC.Base
  26 import GHC.IO
  27 import GHC.IOBase
  28 import GHC.Ptr
  29 import Foreign.Marshal.Array
  30 import Foreign.Marshal.Alloc
  31 import Foreign.Storable
  32 import Foreign.C.String
  33
  34 data Object a
  35   = Object Addr#
  36
  37 checkResult :: (State# RealWorld -> (# State# RealWorld, a, Addr# #))
  38             -> IO a
  39 checkResult fun = IO $ \ st ->
  40   case fun st of
  41     (# st1, res, err #)
  42       | err `eqAddr#` nullAddr# -> (# st1, res #)
  43       | otherwise               -> throw (IOException (raiseError err)) st1
  44
  45 -- ToDo: attach finaliser.
  46 unmarshalObject :: Addr# -> Object a
  47 unmarshalObject x = Object x
  48
  49 marshalObject :: Object a -> (Addr# -> IO b) -> IO b
  50 marshalObject (Object x) cont = cont x
  51
  52 -- dotnet interop support passing and returning
  53 -- strings.
  54 marshalString :: String
  55               -> (Addr# -> IO a)
  56               -> IO a
  57 marshalString str cont = withCString str (\ (Ptr x) -> cont x)
  58
  59 -- char** received back from a .NET interop layer.
  60 unmarshalString :: Addr# -> String
  61 unmarshalString p = unsafePerformIO $ do
  62    let ptr = Ptr p
  63    str <- peekCString ptr
  64    free ptr
  65    return str
  66
  67
  68 -- room for improvement..
  69 raiseError :: Addr# -> IOError
  70 raiseError p = userError (".NET error: " ++ unmarshalString p)