GHC/Dotnet.hs

   1 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
   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
  16 module GHC.Dotnet
  17         ( Object
  18         , unmarshalObject
  19         , marshalObject
  20         , unmarshalString
  21         , marshalString
  22         , checkResult
  23         ) where
  24
  25 import GHC.Prim
  26 import GHC.Base
  27 import GHC.Exception
  28 import GHC.IO
  29 import GHC.IOBase
  30 import GHC.Ptr
  31 import Foreign.Marshal.Array
  32 import Foreign.Marshal.Alloc
  33 import Foreign.Storable
  34 import Foreign.C.String
  35
  36 data Object a
  37   = Object Addr#
  38
  39 checkResult :: (State# RealWorld -> (# State# RealWorld, a, Addr# #))
  40             -> IO a
  41 checkResult fun = IO $ \ st ->
  42   case fun st of
  43     (# st1, res, err #)
  44       | err `eqAddr#` nullAddr# -> (# st1, res #)
  45       | otherwise               -> throw (raiseError err) st1
  46
  47 -- ToDo: attach finaliser.
  48 unmarshalObject :: Addr# -> Object a
  49 unmarshalObject x = Object x
  50
  51 marshalObject :: Object a -> (Addr# -> IO b) -> IO b
  52 marshalObject (Object x) cont = cont x
  53
  54 -- dotnet interop support passing and returning
  55 -- strings.
  56 marshalString :: String
  57               -> (Addr# -> IO a)
  58               -> IO a
  59 marshalString str cont = withCString str (\ (Ptr x) -> cont x)
  60
  61 -- char** received back from a .NET interop layer.
  62 unmarshalString :: Addr# -> String
  63 unmarshalString p = unsafePerformIO $ do
  64    let ptr = Ptr p
  65    str <- peekCString ptr
  66    free ptr
  67    return str
  68
  69
  70 -- room for improvement..
  71 raiseError :: Addr# -> IOError
  72 raiseError p = userError (".NET error: " ++ unmarshalString p)