New approach to mutability

CoreFoundation/CoreFoundation.cabal

@@ -62,7 +62,8 @@ Library
 
   -- Packages needed in order to build this package.
   Build-depends: base>=4.3 && < 4.6, bytestring==0.9.*, text==0.11.*,
-                 template-haskell>=2.5 && < 2.8
+                 template-haskell>=2.5 && < 2.8,
+                 primitive >= 0.3 && < 0.5
 
   Extensions: ForeignFunctionInterface, TemplateHaskell, ScopedTypeVariables
               RecordWildCards, EmptyDataDecls, ExistentialQuantification,

CoreFoundation/System/CoreFoundation/Array.chs

@@ -2,6 +2,7 @@
 module System.CoreFoundation.Array(
                     Array,
                     ArrayRef,
+                    CFArray,
                     -- * Accessing elements
                     getCount,
                     getObjectAtIndex,
@@ -42,11 +43,11 @@ instance StaticTypeID (Array a) where
 #include <CoreFoundation/CoreFoundation.h>
 
 -- | Returns the number of values currently stored in an array.
-{#fun unsafe CFArrayGetCount as getCount
+{#fun pure unsafe CFArrayGetCount as getCount
     { withObject* `Array a' } -> `Int' #}
 
-{#fun unsafe CFArrayGetValueAtIndex as getPtrAtIndex
-    { withObject* `Array a', `Int' } -> `Ptr (Repr a)' castPtr #}
+{#fun pure unsafe CFArrayGetValueAtIndex as getPtrAtIndex
+    `Object a' => { withObject* `Array a', `Int' } -> `a' '(getAndRetain . castPtr)'* #}
 
 -- TODO: out-of-bounds errors will cause this to crash!
 -- Also, note that this fails if the object isn't of the right type.
@@ -55,11 +56,11 @@ instance StaticTypeID (Array a) where
 -- 
 -- This function throws an error if the index is out of bounds, 
 -- or if the object cannot be casted to type @a@.
-getObjectAtIndex :: Object a => Array a -> Int -> IO a
-getObjectAtIndex a k = do
-    n <- getCount a
-    when (k < 0 || k >= n) $ error $ "getObjectAtIndex: out-of-bounds: " ++ show (k,n)
-    getPtrAtIndex a k >>= getAndRetain
+getObjectAtIndex :: Object a => Array a -> Int -> a
+getObjectAtIndex a k
+ | k < 0 || k >= n = error $ "getObjectAtIndex: out-of-bounds: " ++ show (k,n)
+ | otherwise = getPtrAtIndex a k
+  where n = getCount a
 
 -- For when all the elements are CFType-derived.
 foreign import ccall "&" kCFTypeArrayCallBacks :: Ptr ()

CoreFoundation/System/CoreFoundation/Array/Mutable.chs

@@ -1,6 +1,7 @@
 -- | Core Foundation mutable arrays.  These are toll-free bridged with
 -- `NSMutableArray'.
 module System.CoreFoundation.Array.Mutable(
+                            MArray,
                             newMutableArray,
                             appendValue,
                             setValueAtIndex,
@@ -10,14 +11,18 @@ module System.CoreFoundation.Array.Mutable(
 import Foreign.Ptr
 import Foreign.C
 import Control.Monad (when)
+import Control.Monad.Primitive
 
 import System.CoreFoundation.Base
 import System.CoreFoundation.Foreign
-import System.CoreFoundation.Array
+{#import System.CoreFoundation.Array#} (Array, CFArray, ArrayRef)
 
 #include <CoreFoundation/CoreFoundation.h>
 
-{#pointer CFMutableArrayRef as ArrayRef nocode #}
+type MArray s a = Mutable s (Array a)
+
+type MArrayRef = Ptr (MutableRepr CFArray)
+{#pointer CFMutableArrayRef as MArrayRef nocode #}
 foreign import ccall "&" kCFTypeArrayCallBacks :: Ptr ()
 
 -- | Create a new mutable array.  The array starts empty and can contain up to the
@@ -26,36 +31,46 @@ foreign import ccall "&" kCFTypeArrayCallBacks :: Ptr ()
     { withDefaultAllocator- `AllocatorPtr'
     , `Int'
     , '($ kCFTypeArrayCallBacks)'- `Ptr ()'
-    } -> `ArrayRef' id#}
+    } -> `MArrayRef' id#}
+
+-- | Returns the number of values currently stored in an array.
+getCount :: PrimMonad m => MArray (PrimState m) a -> m Int
+getCount arr = unsafePrimToPrim $ c_getCount arr
+
+{#fun unsafe CFArrayGetCount as c_getCount
+    { withMutableObject* `Mutable s (Array a)' } -> `Int' #}
+
+newMutableArray :: (PrimMonad m, Object a) => Int -> m (MArray (PrimState m) a)
+newMutableArray n = unsafePrimToPrim . getOwned $ cfNewMutableArray n
 
-newMutableArray :: Object a => Int -> IO (Mutable (Array a))
-newMutableArray n = fmap unsafeMutable . getOwned $ cfNewMutableArray n
+appendValue :: (PrimMonad m, Object a) => MArray (PrimState m) a -> a -> m ()
+appendValue arr v  = unsafePrimToPrim $ c_appendValue arr v
 
-{#fun CFArrayAppendValue as appendValue
-    `Object o' => { '(withObject . unMutable)'* `Mutable (Array o)'
+{#fun CFArrayAppendValue as c_appendValue
+    `Object o' => { withObject* `Mutable s (Array o)'
     , withVoidObject* `o'
     } -> `()' #}
 
 {#fun CFArraySetValueAtIndex as c_setValueAtIndex
     `Object o' =>
-    { '(withObject . unMutable)'* `Mutable (Array o)'
+    { withObject* `Mutable s (Array o)'
     , `Int'
     , withVoidObject* `o'
     } -> `()' #}
 
 -- | Change the value at the given index in the array.
 --
 -- The index must be less than the current size of the array.
-setValueAtIndex :: Object o => Mutable (Array o) -> Int -> o -> IO ()
+setValueAtIndex :: (PrimMonad m, Object o) => MArray (PrimState m) o -> Int -> o -> m ()
 setValueAtIndex a i x = do
-    n <- getCount $ unMutable a
+    n <- getCount a
     when (i < 0 || i >= n)
         $ error $ "setValueAtIndex: index " ++ show i ++ " is out of range"
-    c_setValueAtIndex a i x
+    unsafePrimToPrim $ c_setValueAtIndex a i x
 
 {#fun CFArrayInsertValueAtIndex as c_insertValueAtIndex
     `Object o' => 
-    { '(withObject . unMutable)'* `Mutable (Array o)'
+    { withObject* `Mutable s (Array o)'
     , `Int'
     , withVoidObject* `o'
     } -> `()' #}
@@ -64,9 +79,9 @@ setValueAtIndex a i x = do
 --
 -- The index must be between 0 and N (inclusive), where N is the current
 -- size of the array.
-insertValueAtIndex :: Object o => Mutable (Array o) -> Int -> o -> IO ()
+insertValueAtIndex :: (PrimMonad m, Object o) => MArray (PrimState m) o -> Int -> o -> m ()
 insertValueAtIndex a i x = do
-    n <- getCount $ unMutable a
+    n <- getCount a
     when (i < 0 || i > n)
         $ error $ "insertValueAtIndex: index " ++ show i ++ " is out of range"
-    c_insertValueAtIndex a i x
+    unsafePrimToPrim $ c_insertValueAtIndex a i x

CoreFoundation/System/CoreFoundation/Base.chs

@@ -18,7 +18,9 @@ module System.CoreFoundation.Base(
                 castObjectOrError,
                 -- * Mutable objects
                 Mutable(),
-                unMutable,
+                unsafeFreeze,
+                unsafeThaw,
+                MutableRepr,
                 -- *  Miscellaneous type synonyms
                 CBoolean,
                 CFIndex,

CoreFoundation/System/CoreFoundation/Foreign.chs

@@ -8,13 +8,15 @@ module System.CoreFoundation.Foreign(
                 withVoidObject,
                 withMaybeObject,
                 withObjects,
+                withMutableObject,
                 getOwned,
                 getAndRetain,
                 maybeGetOwned,
                 maybeGetAndRetain,
                 retainCFTypeRef,
                 -- * Mutable types
-                unsafeMutable,
+                unsafeFreeze,
+                unsafeThaw,
                 -- *  Allocators
                 AllocatorRef,
                 withDefaultAllocator,
@@ -104,6 +106,10 @@ withObjects :: Object a => [a] -> ([Ptr (Repr a)] -> IO b) -> IO b
 withObjects [] act = act []
 withObjects (o:os) act = withObject o $ \p -> withObjects os $ \ps -> act (p:ps)
 
+-- | Like 'withObject', except that we use the passed-in *mutable* object as an *immutable* one
+withMutableObject :: Object a => Mutable s a -> (Ptr (Repr a) -> IO b) -> IO b
+withMutableObject = withObject . unsafeUnMutable
+
 -- | Returns a Haskell type which references the given Core Foundation C object.
 -- The 'CFTypeRef' must not be null.
 -- 

CoreFoundation/System/CoreFoundation/Internal/Unsafe.chs

@@ -1,5 +1,6 @@
 module System.CoreFoundation.Internal.Unsafe where
 
+import Control.Monad.Primitive
 import Foreign.Ptr
 import Foreign.ForeignPtr
 import Foreign.C
@@ -67,20 +68,74 @@ type CBoolean = {#type Boolean #}
 
 -- | Some Core Foundation objects (e.g. strings and data) have mutable
 -- variants.  
--- We use the Haskell types @Mutable Data@, @Mutable String@, etc.
--- to indicate objects which we know to be mutable.  
+-- We use the Haskell types @Mutable s Data@, @Mutable s String@, etc.
+-- to indicate objects which we know to be mutable.  These objects
+-- can be modified in the @ST s@ monad, or the @IO@ monad (see @IOMutable@).
 -- 
 -- In contrast, we use the Haskell types @Data@ and @String@ to indicate objects which
--- may or may not be mutable.
-newtype Mutable o = Mutable o
-
--- | Convert the Haskell type of a Core Foundation object to its mutable version. 
---
---  This function must only be used on objects which you know to be mutable.
--- Doing otherwise can violate referential transparency or even crash the program.
-unsafeMutable :: o -> Mutable o
+-- are known to be immutable.
+newtype Mutable s o = Mutable o
+
+-- | @Repr (Mutable s o) = MutableRep (Repr o)@
+data MutableRepr repr
+
+instance Object o => Object (Mutable s o) where
+  type Repr (Mutable s o) = MutableRepr (Repr o)
+  unsafeObject = Mutable . unsafeObject . castForeignPtr
+  unsafeUnObject (Mutable o) = castForeignPtr . unsafeUnObject $ o
+  maybeStaticTypeID _ = maybeStaticTypeID (undefined :: o)
+
+-- | Mutable object for use in the 'IO' monad
+type IOMutable = Mutable RealWorld
+
+-- | Mutable object for use in the @ST s@ monad
+type STMutable s = Mutable s
+
 unsafeMutable = Mutable
+unsafeUnMutable (Mutable o) = o
+
+-- | Convert the Haskell type of a Core Foundation object to its mutable version without copying.
+-- The immutable version may not be used after this operation.
+unsafeThaw :: PrimMonad m => o -> m (Mutable (PrimState m) o)
+unsafeThaw = return . Mutable
+{-# NOINLINE unsafeThaw #-}
+
+-- | Convert the Haskell type of a Core Foundation object to its immutable version without copying.
+-- The mutable version may not be used after this operation.
+unsafeFreeze :: PrimMonad m => Mutable (PrimState m) o -> m o
+unsafeFreeze = return . unsafeUnMutable
+{-# NOINLINE unsafeFreeze #-}
+
+{- 
+Note: NOINLINE pragmas
+
+Consider the following use of unsafeFreeze:
+
+  do
+     mstr <- buildNewMutString
+     modifyString mstr
+     str <- unsafeFreeze mstr
+     return (stringToText str)
+
+We expect that the stringToText conversion occurs *after* modifyString has been run.
+However, if unsafeFreeze is inlined, GHC is free to rewrite the above to
+
+  do
+     mstr <- buildNewMutString
+     modifyString mstr
+     let str = unsafeUnMutable mstr
+     return (stringToText str)
+
+and then to
+
+  do 
+     mstr <- buildNewMutString
+     let str = unsafeUnMutable mstr
+         res = stringToText str
+     modifyString mstr
+     return res
+
+and now the stringToText conversion could occur *before* modifyString has run - big mistake!
 
--- | Extract the underlying object from a mutable type.  
-unMutable :: Mutable o -> o
-unMutable (Mutable o) = o
+To prevent GHC making such changes, we mark 'unsafeFreeze' and 'unsafeThaw' NOINLINE.
+-}