Missing from previous commit.

judah · Aug 17, 2011 · 40e68d9 · 40e68d9
1 parent ce5ae5d
commit 40e68d9
Show file tree

Hide file tree

Showing 3 changed files with 44 additions and 1 deletion.
diff --git a/CoreFoundation/CoreFoundation.cabal b/CoreFoundation/CoreFoundation.cabal
@@ -39,6 +39,7 @@ Library
   Exposed-modules:  
         System.CoreFoundation
         System.CoreFoundation.Base
+        System.CoreFoundation.Array
         System.CoreFoundation.Data
         System.CoreFoundation.Number
         System.CoreFoundation.RunLoop
@@ -53,7 +54,7 @@ Library
                  template-haskell>=2.5 && < 2.7
 
   Extensions: ForeignFunctionInterface, TemplateHaskell, ScopedTypeVariables
-              RecordWildCards, EmptyDataDecls
+              RecordWildCards, EmptyDataDecls, ExistentialQuantification
 
   C-sources: cbits/runloop.c
   include-dirs: include

diff --git a/CoreFoundation/System/CoreFoundation.hs b/CoreFoundation/System/CoreFoundation.hs
@@ -1,5 +1,6 @@
 module System.CoreFoundation(
             module System.CoreFoundation.Base,
+            module System.CoreFoundation.Array,
             module System.CoreFoundation.Data,
             module System.CoreFoundation.Number,
             module System.CoreFoundation.RunLoop,
@@ -8,6 +9,7 @@ module System.CoreFoundation(
             ) where
 
 import System.CoreFoundation.Base
+import System.CoreFoundation.Array
 import System.CoreFoundation.Data
 import System.CoreFoundation.Number
 import System.CoreFoundation.RunLoop

diff --git a/CoreFoundation/System/CoreFoundation/Base.chs b/CoreFoundation/System/CoreFoundation/Base.chs
@@ -15,6 +15,14 @@ module System.CoreFoundation.Base(
                 staticTypeID,
                 dynamicTypeID,
                 typeIDDescription,
+                -- ** Casting generic objects
+                Object,
+                object,
+                castObject,
+                unsafeCastObject,
+                getAndRetainObject,
+                withObject,
+                withObjects,
                 -- *  Allocators
                 AllocatorRef,
                 withDefaultAllocator,
@@ -177,3 +185,35 @@ typeIDDescription t = unsafePerformIO $ do
 -- | Returns a textual description of the Core Foundation type associated with the Haskell type @a@.
 typeDescription :: CFObject a => a -> String
 typeDescription = typeIDDescription . staticTypeID
+
+newtype Object = Object (ForeignPtr CFType)
+
+object :: CFObject a => a -> Object
+object = Object . unsafeUnCFObject
+
+castObject :: forall a . CFObject a => Object -> Maybe a
+castObject (Object o) = unsafePerformIO $ do
+                            t <- withForeignPtr o dynamicTypeID
+                            return $ if staticTypeID (undefined :: a) == t
+                                then Just $ unsafeCFObject o
+                                else Nothing
+
+-- | Throws an error if the input is not of the given type.
+unsafeCastObject :: forall a . CFObject a => Object -> a
+unsafeCastObject o = case castObject o of
+                        Just x -> x
+                        Nothing -> error $ "unsafeCastObject: expected type "
+                                    ++ show (typeDescription (undefined :: a))
+
+getAndRetainObject :: CFTypeRef -> IO Object
+getAndRetainObject p
+    | p==nullPtr = error "getAndRetainObject: null object"
+    | otherwise = cfRetain p >>= fmap Object . newForeignPtr cfReleasePtr
+
+withObject :: Object -> (CFTypeRef -> IO a) -> IO a
+withObject (Object o) = withForeignPtr o
+
+-- TODO: is this inefficient?
+withObjects :: [Object] -> ([CFTypeRef] -> IO b) -> IO b
+withObjects [] act = act []
+withObjects (o:os) act = withObject o $ \p -> withObjects os $ \ps -> act (p:ps)