module Data.GI.Gtk.ModelView.CustomStore (
CustomStore(..),
TreeModelFlags(..),
TreeModelIface(..),
DragSourceIface(..),
DragDestIface(..),
customStoreNew,
customStoreGetRow,
customStoreSetColumn,
customStoreGetPrivate,
customStoreGetStamp,
customStoreInvalidateIters,
) where
import Prelude ()
import Prelude.Compat
import Control.Monad ((>=>), liftM, void)
import Control.Monad.IO.Class (MonadIO(..))
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import Data.Int (Int32(..))
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.C.Types (CInt(..), CULong(..))
import Foreign.C.String (CString(..))
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, newForeignPtr_)
import Foreign.StablePtr (deRefStablePtr, newStablePtr, StablePtr(..))
import Foreign.Marshal (fromBool)
import Foreign.Storable (peek, poke, peekByteOff)
import System.IO.Unsafe (unsafePerformIO)
import Data.GI.Base.BasicTypes (GObject(..), GType, CGType(..), gtypeToCGType, gtypeInt, gtypeBoolean, gtypeString, gtypeInvalid)
import Data.GI.Base.BasicConversions (gflagsToWord, withTextCString)
import Data.GI.Base.ManagedPtr (newObject, withManagedPtr)
import Data.GI.Base.GValue (GValue(..))
import GI.GObject (Object)
import GI.GdkPixbuf.Objects (Pixbuf(..))
import GI.Gtk.Flags (TreeModelFlags(..))
import GI.Gtk.Interfaces.TreeModel (TreeModel(..), IsTreeModel(..))
import GI.Gtk.Structs (SelectionData(..), TreePath(..), TreeIter, treePathCopy, selectionDataCopy)
import Data.GI.Gtk.ModelView.Types
import GI.Gtk.Structs.TreeIter
(getTreeIterStamp, getTreeIterUserData, getTreeIterUserData2, getTreeIterUserData3,
setTreeIterStamp, setTreeIterUserData, setTreeIterUserData2, setTreeIterUserData3,
TreeIter(..))
import Data.GI.Base (newBoxed, set, get)
import Data.GI.Base.Attributes (AttrOp(..))
import Data.GI.Base.Utils (maybeFromPtr)
treeIterOverwrite :: MonadIO m => TreeIter -> TreeIter -> m ()
treeIterOverwrite iterOut iterIn = do
stamp <- getTreeIterStamp iterIn
ud1 <- getTreeIterUserData iterIn
ud2 <- getTreeIterUserData2 iterIn
ud3 <- getTreeIterUserData3 iterIn
setTreeIterStamp iterOut stamp
setTreeIterUserData iterOut ud1
setTreeIterUserData2 iterOut ud2
setTreeIterUserData3 iterOut ud3
newtype CustomStore private row = CustomStore (ForeignPtr (CustomStore private row))
instance IsTreeModel (CustomStore private row)
instance GObject (CustomStore private row) where
gobjectIsInitiallyUnowned _ = False
gobjectType _ = gobjectType (undefined :: TreeModel)
type ColumnMap row = IORef [ColumnAccess row]
columnMapNew :: MonadIO m => m (ColumnMap row)
columnMapNew = liftIO $ newIORef []
customStoreSetColumn :: (MonadIO m, IsTypedTreeModel model)
=> model row
-> (ColumnId row ty)
-> (row -> ty)
-> 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 $ colIdl) 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,
customStoreIface :: TreeModelIface row,
customTreeDragSourceIface :: DragSourceIface model row,
customTreeDragDestIface :: DragDestIface model row
}
data TreeModelIface row = TreeModelIface {
treeModelIfaceGetFlags :: IO [TreeModelFlags],
treeModelIfaceGetIter :: TreePath -> IO (Maybe TreeIter),
treeModelIfaceGetPath :: TreeIter -> IO TreePath,
treeModelIfaceGetRow :: TreeIter -> IO row,
treeModelIfaceIterNext :: TreeIter -> IO (Maybe TreeIter),
treeModelIfaceIterChildren :: Maybe TreeIter -> IO (Maybe TreeIter),
treeModelIfaceIterHasChild :: TreeIter -> IO Bool,
treeModelIfaceIterNChildren :: Maybe TreeIter -> IO Int,
treeModelIfaceIterNthChild :: Maybe TreeIter -> Int -> IO (Maybe TreeIter),
treeModelIfaceIterParent :: TreeIter -> IO (Maybe TreeIter),
treeModelIfaceRefNode :: TreeIter -> IO (),
treeModelIfaceUnrefNode :: TreeIter -> IO ()
}
data DragSourceIface model row = DragSourceIface {
customDragSourceRowDraggable :: model row -> TreePath -> IO Bool,
customDragSourceDragDataGet :: model row -> TreePath -> SelectionData -> IO Bool,
customDragSourceDragDataDelete:: model row -> TreePath -> IO Bool
}
data DragDestIface model row = DragDestIface {
customDragDestRowDropPossible :: model row -> TreePath -> SelectionData -> IO Bool,
customDragDestDragDataReceived:: model row -> TreePath -> SelectionData -> IO Bool
}
customStoreNew :: (MonadIO m, IsTreeModel (model row), IsTypedTreeModel model) =>
private
-> (CustomStore private row -> model row)
-> TreeModelIface row
-> Maybe (DragSourceIface model row)
-> Maybe (DragDestIface model row)
-> m (model row)
customStoreNew priv con tmIface mDragSource mDragDest = liftIO $ do
cMap <- columnMapNew
let dummyDragSource = DragSourceIface { customDragSourceRowDraggable = \_ _ -> return False,
customDragSourceDragDataGet = \_ _ _ -> return False,
customDragSourceDragDataDelete = \_ _ -> return False }
let dummyDragDest = DragDestIface { customDragDestRowDropPossible = \_ _ _ -> return False,
customDragDestDragDataReceived = \_ _ _ -> return False }
implPtr <- newStablePtr CustomStoreImplementation {
customStoreColumns = cMap,
customStoreIface = tmIface,
customTreeDragSourceIface = fromMaybe dummyDragSource mDragSource,
customTreeDragDestIface = fromMaybe dummyDragDest mDragDest }
privPtr <- newStablePtr priv
storePtr <- gtk2hs_store_new implPtr privPtr
con <$> newObject CustomStore storePtr
foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_new"
gtk2hs_store_new :: StablePtr (CustomStoreImplementation model row)
-> StablePtr private
-> IO (Ptr (CustomStore private row))
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
foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_get_impl"
gtk2hs_store_get_impl :: Ptr (TypedTreeModel row) -> IO (StablePtr (CustomStoreImplementation model row))
customStoreGetPrivate :: CustomStore private row -> private
customStoreGetPrivate (CustomStore model) =
unsafePerformIO $
withForeignPtr model gtk2hs_store_get_priv >>= deRefStablePtr
foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_get_priv"
gtk2hs_store_get_priv :: Ptr (CustomStore private row) -> IO (StablePtr private)
customStoreGetStamp :: MonadIO m => CustomStore private row -> m Int32
customStoreGetStamp (CustomStore model) = liftIO $ fromIntegral <$>
withForeignPtr model gtk2hs_store_get_stamp
foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_get_stamp"
gtk2hs_store_get_stamp :: Ptr (CustomStore private row) -> IO CInt
customStoreInvalidateIters :: MonadIO m => CustomStore private row -> m ()
customStoreInvalidateIters (CustomStore model) = liftIO $
withForeignPtr model gtk2hs_store_increment_stamp
foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_increment_stamp"
gtk2hs_store_increment_stamp :: Ptr (CustomStore private row) -> IO ()
treeModelIfaceGetNColumns_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt
treeModelIfaceGetNColumns_static storePtr = do
store <- deRefStablePtr storePtr
cmap <- readIORef (customStoreColumns store)
return (fromIntegral (length cmap))
foreign export ccall "gtk2hs_store_get_n_columns_impl"
treeModelIfaceGetNColumns_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt
caToGType :: ColumnAccess row -> GType
caToGType (CAInt _) = gtypeInt
caToGType (CABool _) = gtypeBoolean
caToGType (CAString _) = gtypeString
caToGType (CAPixbuf _) = gtypePixbuf
caToGType CAInvalid = gtypeInt
gtypePixbuf :: GType
gtypePixbuf = unsafePerformIO $ gobjectType (undefined :: Pixbuf)
treeModelIfaceGetColumnType_static :: StablePtr (CustomStoreImplementation model row) -> CInt -> IO CGType
treeModelIfaceGetColumnType_static storePtr column = do
store <- deRefStablePtr storePtr
cols <- readIORef (customStoreColumns store)
return . gtypeToCGType $
case drop (fromIntegral column) cols of
[] -> gtypeInvalid
(ca:_) -> caToGType ca
foreign export ccall "gtk2hs_store_get_column_type_impl"
treeModelIfaceGetColumnType_static :: StablePtr (CustomStoreImplementation model row) -> CInt -> IO CGType
treeModelIfaceGetFlags_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt
treeModelIfaceGetFlags_static storePtr = do
store <- customStoreIface <$> deRefStablePtr storePtr
liftM (fromIntegral . gflagsToWord) $ treeModelIfaceGetFlags store
foreign export ccall "gtk2hs_store_get_flags_impl"
treeModelIfaceGetFlags_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt
treeModelIfaceGetIter_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreePath -> IO CInt
treeModelIfaceGetIter_static storePtr iterPtr pathPtr = do
iterOut <- TreeIter <$> newForeignPtr_ iterPtr
store <- customStoreIface <$> deRefStablePtr storePtr
path <- treePathCopy . TreePath =<< newForeignPtr_ pathPtr
treeModelIfaceGetIter store path >>= \case
Nothing -> return (fromBool False)
Just iter -> do treeIterOverwrite iterOut iter
return (fromBool True)
foreign export ccall "gtk2hs_store_get_iter_impl"
treeModelIfaceGetIter_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreePath -> IO CInt
foreign import ccall "gtk_tree_path_copy" gtk_tree_path_copy :: Ptr TreePath -> IO (Ptr TreePath)
treeModelIfaceGetPath_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO (Ptr TreePath)
treeModelIfaceGetPath_static storePtr iterPtr = do
store <- customStoreIface <$> deRefStablePtr storePtr
iter <- newBoxed TreeIter iterPtr
path <- treeModelIfaceGetPath store iter
withManagedPtr path gtk_tree_path_copy
foreign export ccall "gtk2hs_store_get_path_impl"
treeModelIfaceGetPath_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO (Ptr TreePath)
foreign import ccall "g_value_init" g_value_init ::
Ptr GValue -> CGType -> IO (Ptr GValue)
foreign import ccall unsafe "g_value_set_int" _set_int32 ::
Ptr GValue -> Int32 -> IO ()
foreign import ccall unsafe "g_value_set_boolean" _set_boolean ::
Ptr GValue -> CInt -> IO ()
foreign import ccall "g_value_set_string" _set_string ::
Ptr GValue -> CString -> IO ()
foreign import ccall "g_value_set_object" _set_object ::
Ptr GValue -> Ptr a -> IO ()
treeModelIfaceGetValue_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> CInt -> Ptr GValue -> IO ()
treeModelIfaceGetValue_static storePtr iterPtr column gVal = do
store <- deRefStablePtr storePtr
iter <- newBoxed TreeIter iterPtr
row <- treeModelIfaceGetRow (customStoreIface store) iter
cols <- readIORef (customStoreColumns store)
case drop (fromIntegral column) cols of
[] -> void $ g_value_init gVal (gtypeToCGType gtypeInvalid)
(acc:_) -> case acc of
(CAInt ca) -> g_value_init gVal (gtypeToCGType gtypeInt) >> _set_int32 gVal (fromIntegral $ ca row)
(CABool ca) -> g_value_init gVal (gtypeToCGType gtypeBoolean) >> _set_boolean gVal (fromIntegral . fromEnum $ ca row)
(CAString ca) -> g_value_init gVal (gtypeToCGType gtypeString) >> (withTextCString (ca row) $ _set_string gVal)
(CAPixbuf ca) -> g_value_init gVal (gtypeToCGType gtypePixbuf) >> (withManagedPtr (ca row) $ _set_object gVal)
CAInvalid -> g_value_init gVal (gtypeToCGType gtypeInvalid) >> _set_int32 gVal 0
foreign export ccall "gtk2hs_store_get_value_impl"
treeModelIfaceGetValue_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> CInt -> Ptr GValue -> IO ()
treeModelIfaceIterNext_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt
treeModelIfaceIterNext_static storePtr iterPtr = do
iterOut <- TreeIter <$> newForeignPtr_ iterPtr
store <- customStoreIface <$> deRefStablePtr storePtr
iter <- newBoxed TreeIter iterPtr
treeModelIfaceIterNext store iter >>= \case
Nothing -> return (fromBool False)
Just iter' -> do treeIterOverwrite iterOut iter'
return (fromBool True)
foreign export ccall "gtk2hs_store_iter_next_impl"
treeModelIfaceIterNext_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt
treeModelIfaceIterChildren_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt
treeModelIfaceIterChildren_static storePtr iterPtr parentIterPtr = do
iterOut <- TreeIter <$> newForeignPtr_ iterPtr
store <- customStoreIface <$> deRefStablePtr storePtr
parentIter <- maybeNull (newBoxed TreeIter) parentIterPtr
treeModelIfaceIterChildren store parentIter >>= \case
Nothing -> return (fromBool False)
Just iter -> do treeIterOverwrite iterOut iter
return (fromBool True)
foreign export ccall "gtk2hs_store_iter_children_impl"
treeModelIfaceIterChildren_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt
treeModelIfaceIterHasChild_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt
treeModelIfaceIterHasChild_static storePtr iterPtr = do
store <- customStoreIface <$> deRefStablePtr storePtr
iter <- newBoxed TreeIter iterPtr
fromBool <$> treeModelIfaceIterHasChild store iter
foreign export ccall "gtk2hs_store_iter_has_child_impl"
treeModelIfaceIterHasChild_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt
treeModelIfaceIterNChildren_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt
treeModelIfaceIterNChildren_static storePtr iterPtr = do
store <- customStoreIface <$> deRefStablePtr storePtr
iter <- maybeNull (newBoxed TreeIter) iterPtr
fromIntegral <$> treeModelIfaceIterNChildren store iter
foreign export ccall "gtk2hs_store_iter_n_children_impl"
treeModelIfaceIterNChildren_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO CInt
treeModelIfaceIterNthChild_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> CInt -> IO CInt
treeModelIfaceIterNthChild_static storePtr iterPtr parentIterPtr n = do
iterOut <- TreeIter <$> newForeignPtr_ iterPtr
store <- customStoreIface <$> deRefStablePtr storePtr
parentIter <- maybeNull (newBoxed TreeIter) parentIterPtr
treeModelIfaceIterNthChild store parentIter (fromIntegral n) >>= \case
Nothing -> return (fromBool False)
Just iter -> do treeIterOverwrite iterOut iter
return (fromBool True)
foreign export ccall "gtk2hs_store_iter_nth_child_impl"
treeModelIfaceIterNthChild_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> CInt -> IO CInt
treeModelIfaceIterParent_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt
treeModelIfaceIterParent_static storePtr iterPtr childIterPtr = do
iterOut <- TreeIter <$> newForeignPtr_ iterPtr
store <- customStoreIface <$> deRefStablePtr storePtr
childIter <- newBoxed TreeIter childIterPtr
iter <- treeModelIfaceIterParent store childIter
case iter of
Nothing -> return (fromBool False)
Just iter -> do treeIterOverwrite iterOut iter
return (fromBool True)
foreign export ccall "gtk2hs_store_iter_parent_impl"
treeModelIfaceIterParent_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr TreeIter -> IO CInt
treeModelIfaceRefNode_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO ()
treeModelIfaceRefNode_static storePtr iterPtr = do
store <- customStoreIface <$> deRefStablePtr storePtr
iter <- newBoxed TreeIter iterPtr
treeModelIfaceRefNode store iter
foreign export ccall "gtk2hs_store_ref_node_impl"
treeModelIfaceRefNode_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO ()
treeModelIfaceUnrefNode_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO ()
treeModelIfaceUnrefNode_static storePtr iterPtr = do
store <- customStoreIface <$> deRefStablePtr storePtr
iter <- newBoxed TreeIter iterPtr
treeModelIfaceUnrefNode store iter
foreign export ccall "gtk2hs_store_unref_node_impl"
treeModelIfaceUnrefNode_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO ()
customDragSourceRowDraggable_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> IO CInt
customDragSourceRowDraggable_static mPtr storePtr pathPtr = do
model <- newObject TreeModel mPtr
store <- customTreeDragSourceIface <$> deRefStablePtr storePtr
path <- treePathCopy . TreePath =<< newForeignPtr_ pathPtr
fromBool <$> customDragSourceRowDraggable store (unsafeTreeModelToGeneric model) path
foreign export ccall "gtk2hs_store_row_draggable_impl"
customDragSourceRowDraggable_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> IO CInt
customDragSourceDragDataGet_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt
customDragSourceDragDataGet_static mPtr storePtr pathPtr selectionPtr = do
model <- newObject TreeModel mPtr
store <- customTreeDragSourceIface <$> deRefStablePtr storePtr
path <- treePathCopy . TreePath =<< newForeignPtr_ pathPtr
selection <- selectionDataCopy . SelectionData =<< newForeignPtr_ selectionPtr
fromBool <$> customDragSourceDragDataGet store (unsafeTreeModelToGeneric model) path selection
foreign export ccall "gtk2hs_store_drag_data_get_impl"
customDragSourceDragDataGet_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt
customDragSourceDragDataDelete_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> IO CInt
customDragSourceDragDataDelete_static mPtr storePtr pathPtr = do
model <- newObject TreeModel mPtr
store <- customTreeDragSourceIface <$> deRefStablePtr storePtr
path <- treePathCopy . TreePath =<< newForeignPtr_ pathPtr
fromBool <$> customDragSourceDragDataDelete store (unsafeTreeModelToGeneric model) path
foreign export ccall "gtk2hs_store_drag_data_delete_impl"
customDragSourceDragDataDelete_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> IO CInt
customDragDestDragDataReceived_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt
customDragDestDragDataReceived_static mPtr storePtr pathPtr selectionPtr = do
model <- newObject TreeModel mPtr
store <- customTreeDragDestIface <$> deRefStablePtr storePtr
path <- treePathCopy . TreePath =<< newForeignPtr_ pathPtr
selection <- selectionDataCopy . SelectionData =<< newForeignPtr_ selectionPtr
fromBool <$> customDragDestDragDataReceived store (unsafeTreeModelToGeneric model) path selection
foreign export ccall "gtk2hs_store_drag_data_received_impl"
customDragDestDragDataReceived_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt
customDragDestRowDropPossible_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt
customDragDestRowDropPossible_static mPtr storePtr pathPtr selectionPtr = do
model <- newObject TreeModel mPtr
store <- customTreeDragDestIface <$> deRefStablePtr storePtr
path <- treePathCopy . TreePath =<< newForeignPtr_ pathPtr
selection <- selectionDataCopy . SelectionData =<< newForeignPtr_ selectionPtr
fromBool <$> customDragDestRowDropPossible store (unsafeTreeModelToGeneric model) path selection
foreign export ccall "gtk2hs_store_row_drop_possible_impl"
customDragDestRowDropPossible_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr TreePath -> Ptr SelectionData -> IO CInt
maybeNull :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybeNull marshal ptr
| ptr == nullPtr = return Nothing
| otherwise = liftM Just (marshal ptr)