diff --git a/gi-gtk-hs.cabal b/gi-gtk-hs.cabal --- a/gi-gtk-hs.cabal +++ b/gi-gtk-hs.cabal @@ -1,5 +1,5 @@ name: gi-gtk-hs -version: 0.3.2.0 +version: 0.3.3.0 synopsis: A wrapper for gi-gtk, adding a few more idiomatic API parts on top description: A wrapper for gi-gtk, adding a few more idiomatic API parts on top homepage: https://github.com/haskell-gi/gi-gtk-hs diff --git a/src/Data/GI/Gtk/ModelView/CustomStore.hs b/src/Data/GI/Gtk/ModelView/CustomStore.hs --- a/src/Data/GI/Gtk/ModelView/CustomStore.hs +++ b/src/Data/GI/Gtk/ModelView/CustomStore.hs @@ -69,7 +69,7 @@ (ManagedPtr(..), GObject(..), GType, CGType(..), gtypeToCGType, gtypeInt, gtypeBoolean, gtypeString, gtypeInvalid) import Data.GI.Base.BasicConversions (gflagsToWord, withTextCString) -import Data.GI.Base.ManagedPtr (newPtr, newObject, withManagedPtr) +import Data.GI.Base.ManagedPtr (newObject, withManagedPtr) import Data.GI.Base.GValue (GValue(..)) import GI.GObject (Object) import GI.GdkPixbuf.Objects (Pixbuf(..)) @@ -129,20 +129,19 @@ -> (row -> ty) -- ^ the function that sets the property -> m () customStoreSetColumn model (ColumnId _ setter colId) acc | colId<0 = return () - | otherwise = - case toTypedTreeModel model of - TypedTreeModel model -> liftIO $ do - ptr <- withForeignPtr model gtk2hs_store_get_impl - impl <- deRefStablePtr ptr - let cMap = customStoreColumns impl - cols <- readIORef cMap - let l = fromIntegral $ length cols - if colId>=l then do - let fillers = replicate (fromIntegral $ colId-l) CAInvalid - writeIORef cMap (cols++fillers++[setter acc]) - else do - let (beg,_:end) = splitAt (fromIntegral colId) cols - writeIORef cMap (beg++setter acc:end) + | otherwise = liftIO $ do + putStrLn "Here 2" + ptr <- withManagedPtr (toTypedTreeModel model) gtk2hs_store_get_impl + impl <- deRefStablePtr ptr + let cMap = customStoreColumns impl + cols <- readIORef cMap + let l = fromIntegral $ length cols + if colId>=l then do + let fillers = replicate (fromIntegral $ colId-l) CAInvalid + writeIORef cMap (cols++fillers++[setter acc]) + else do + let (beg,_:end) = splitAt (fromIntegral colId) cols + writeIORef cMap (beg++setter acc:end) data CustomStoreImplementation model row = CustomStoreImplementation { customStoreColumns :: ColumnMap row, -- provide access via columns @@ -230,19 +229,24 @@ -- ^ Functions to enable this store to receive drag events. -> m (model row) customStoreNew priv con tmIface mDragSource mDragDest = liftIO $ do + putStrLn "Here 3" cMap <- columnMapNew let dummyDragSource = DragSourceIface { customDragSourceRowDraggable = \_ _ -> return False, customDragSourceDragDataGet = \_ _ _ -> return False, customDragSourceDragDataDelete = \_ _ -> return False } let dummyDragDest = DragDestIface { customDragDestRowDropPossible = \_ _ _ -> return False, customDragDestDragDataReceived = \_ _ _ -> return False } + putStrLn "Here 4" implPtr <- newStablePtr CustomStoreImplementation { customStoreColumns = cMap, customStoreIface = tmIface, customTreeDragSourceIface = fromMaybe dummyDragSource mDragSource, customTreeDragDestIface = fromMaybe dummyDragDest mDragDest } + putStrLn "Here 5" privPtr <- newStablePtr priv + putStrLn "Here 6" storePtr <- gtk2hs_store_new implPtr privPtr + putStrLn "Here 7" con <$> newObject CustomStore storePtr @@ -254,11 +258,10 @@ -- | Extract a row of the given model at the given 'TreeIter'. -- customStoreGetRow :: (MonadIO m, IsTypedTreeModel model) => model row -> TreeIter -> m row -customStoreGetRow model iter = liftIO $ - case toTypedTreeModel model of - TypedTreeModel model -> do - impl <- withForeignPtr model gtk2hs_store_get_impl >>= deRefStablePtr - treeModelIfaceGetRow (customStoreIface impl) iter +customStoreGetRow model iter = liftIO $ do + putStrLn "Here 1" + impl <- withManagedPtr (toTypedTreeModel model) gtk2hs_store_get_impl >>= deRefStablePtr + treeModelIfaceGetRow (customStoreIface impl) iter foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_get_impl" gtk2hs_store_get_impl :: Ptr (TypedTreeModel row) -> IO (StablePtr (CustomStoreImplementation model row)) @@ -339,14 +342,18 @@ foreign export ccall "gtk2hs_store_get_flags_impl" treeModelIfaceGetFlags_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt +tempManagedPtr :: Ptr a -> IO (ManagedPtr a) +tempManagedPtr p = do + isOwned <- newIORef False + fPtr <- newForeignPtr_ p + return $ ManagedPtr fPtr isOwned treeModelIfaceGetIter_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreePath -> IO CInt treeModelIfaceGetIter_static storePtr iterPtr pathPtr = do - isOwned <- newIORef False - ptr <- newForeignPtr_ iterPtr - let iterOut = TreeIter $ ManagedPtr ptr isOwned -- Take care not to use this outside of this function + iterOut <- TreeIter <$> tempManagedPtr iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr - path <- newBoxed TreePath pathPtr + isOwned' <- newIORef False + path <- treePathCopy . TreePath =<< tempManagedPtr pathPtr treeModelIfaceGetIter store path >>= \case Nothing -> return (fromBool False) Just iter -> do treeIterOverwrite iterOut iter @@ -406,9 +413,7 @@ treeModelIfaceIterNext_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt treeModelIfaceIterNext_static storePtr iterPtr = do - isOwned <- newIORef False - ptr <- newForeignPtr_ iterPtr - let iterOut = TreeIter $ ManagedPtr ptr isOwned -- Take care not to use this outside of this function + iterOut <- TreeIter <$> tempManagedPtr iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr iter <- newBoxed TreeIter iterPtr treeModelIfaceIterNext store iter >>= \case @@ -422,9 +427,7 @@ treeModelIfaceIterChildren_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt treeModelIfaceIterChildren_static storePtr iterPtr parentIterPtr = do - isOwned <- newIORef False - ptr <- newForeignPtr_ iterPtr - let iterOut = TreeIter $ ManagedPtr ptr isOwned -- Take care not to use this outside of this function + iterOut <- TreeIter <$> tempManagedPtr iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr parentIter <- maybeNull (newBoxed TreeIter) parentIterPtr treeModelIfaceIterChildren store parentIter >>= \case @@ -458,9 +461,7 @@ treeModelIfaceIterNthChild_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> CInt -> IO CInt treeModelIfaceIterNthChild_static storePtr iterPtr parentIterPtr n = do - isOwned <- newIORef False - ptr <- newForeignPtr_ iterPtr - let iterOut = TreeIter $ ManagedPtr ptr isOwned -- Take care not to use this outside of this function + iterOut <- TreeIter <$> tempManagedPtr iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr parentIter <- maybeNull (newBoxed TreeIter) parentIterPtr treeModelIfaceIterNthChild store parentIter (fromIntegral n) >>= \case @@ -474,9 +475,7 @@ treeModelIfaceIterParent_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt treeModelIfaceIterParent_static storePtr iterPtr childIterPtr = do - isOwned <- newIORef False - ptr <- newForeignPtr_ iterPtr - let iterOut = TreeIter $ ManagedPtr ptr isOwned -- Take care not to use this outside of this function + iterOut <- TreeIter <$> tempManagedPtr iterPtr -- Take care not to use this outside of this function store <- customStoreIface <$> deRefStablePtr storePtr childIter <- newBoxed TreeIter childIterPtr iter <- treeModelIfaceIterParent store childIter @@ -512,7 +511,7 @@ customDragSourceRowDraggable_static mPtr storePtr pathPtr = do model <- newObject TreeModel mPtr store <- customTreeDragSourceIface <$> deRefStablePtr storePtr - path <- newBoxed TreePath pathPtr + path <- treePathCopy . TreePath =<< tempManagedPtr pathPtr fromBool <$> customDragSourceRowDraggable store (unsafeTreeModelToGeneric model) path foreign export ccall "gtk2hs_store_row_draggable_impl" @@ -522,8 +521,8 @@ customDragSourceDragDataGet_static mPtr storePtr pathPtr selectionPtr = do model <- newObject TreeModel mPtr store <- customTreeDragSourceIface <$> deRefStablePtr storePtr - path <- newBoxed TreePath pathPtr - selection <- newBoxed SelectionData selectionPtr + path <- treePathCopy . TreePath =<< tempManagedPtr pathPtr + selection <- selectionDataCopy . SelectionData =<< tempManagedPtr selectionPtr fromBool <$> customDragSourceDragDataGet store (unsafeTreeModelToGeneric model) path selection foreign export ccall "gtk2hs_store_drag_data_get_impl" @@ -533,7 +532,7 @@ customDragSourceDragDataDelete_static mPtr storePtr pathPtr = do model <- newObject TreeModel mPtr store <- customTreeDragSourceIface <$> deRefStablePtr storePtr - path <- newBoxed TreePath pathPtr + path <- treePathCopy . TreePath =<< tempManagedPtr pathPtr fromBool <$> customDragSourceDragDataDelete store (unsafeTreeModelToGeneric model) path foreign export ccall "gtk2hs_store_drag_data_delete_impl" @@ -543,8 +542,8 @@ customDragDestDragDataReceived_static mPtr storePtr pathPtr selectionPtr = do model <- newObject TreeModel mPtr store <- customTreeDragDestIface <$> deRefStablePtr storePtr - path <- newBoxed TreePath pathPtr - selection <- newBoxed SelectionData selectionPtr + path <- treePathCopy . TreePath =<< tempManagedPtr pathPtr + selection <- selectionDataCopy . SelectionData =<< tempManagedPtr selectionPtr fromBool <$> customDragDestDragDataReceived store (unsafeTreeModelToGeneric model) path selection foreign export ccall "gtk2hs_store_drag_data_received_impl" @@ -554,8 +553,8 @@ customDragDestRowDropPossible_static mPtr storePtr pathPtr selectionPtr = do model <- newObject TreeModel mPtr store <- customTreeDragDestIface <$> deRefStablePtr storePtr - path <- newBoxed TreePath pathPtr - selection <- newBoxed SelectionData selectionPtr + path <- treePathCopy . TreePath =<< tempManagedPtr pathPtr + selection <- selectionDataCopy . SelectionData =<< tempManagedPtr selectionPtr fromBool <$> customDragDestRowDropPossible store (unsafeTreeModelToGeneric model) path selection foreign export ccall "gtk2hs_store_row_drop_possible_impl" diff --git a/src/Data/GI/Gtk/ModelView/Types.hs b/src/Data/GI/Gtk/ModelView/Types.hs --- a/src/Data/GI/Gtk/ModelView/Types.hs +++ b/src/Data/GI/Gtk/ModelView/Types.hs @@ -79,7 +79,6 @@ import Control.Exception (catch) import Foreign.Storable (Storable(..)) import Foreign.Ptr (Ptr, castPtr, plusPtr, minusPtr, nullPtr) -import Foreign.ForeignPtr (ForeignPtr, newForeignPtr_) import Foreign.C.Types (CInt(..)) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (toBool) @@ -111,7 +110,7 @@ equalManagedPtr a b = managedForeignPtr (coerce a :: ManagedPtr ()) == managedForeignPtr (coerce b :: ManagedPtr ()) -newtype TypedTreeModel row = TypedTreeModel (ForeignPtr (TypedTreeModel row)) +newtype TypedTreeModel row = TypedTreeModel (ManagedPtr (TypedTreeModel row)) class IsTypedTreeModel model where dummy :: model a -> a @@ -142,7 +141,7 @@ instance IsTypedTreeModel TypedTreeModelSort -newtype TypedTreeModelFilter row = TypedTreeModelFilter (ForeignPtr (TypedTreeModelFilter row)) +newtype TypedTreeModelFilter row = TypedTreeModelFilter (ManagedPtr (TypedTreeModelFilter row)) unsafeTreeModelFilterToGeneric :: TreeModelFilter -> TypedTreeModelFilter row unsafeTreeModelFilterToGeneric = unsafeCoerce#