[project @ 2005-01-26 14:55:41 by simonmar]
[packages/old-time.git] / GHC / Dotnet.hs
1 {-# OPTIONS_GHC -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)