{-# LINE 1 "./Graphics/UI/Gtk/ModelView/CustomStore.chs" #-}
module Graphics.UI.Gtk.ModelView.CustomStore (
CustomStore,
TreeModelFlags(..),
TreeModelIface(..),
DragSourceIface(..),
DragDestIface(..),
customStoreNew,
customStoreGetRow,
customStoreSetColumn,
customStoreGetPrivate,
customStoreGetStamp,
customStoreInvalidateIters,
treeModelGetRow,
treeModelSetColumn,
) where
import Control.Monad (liftM)
import Control.Monad.Reader (runReaderT)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import System.Glib.FFI hiding (maybeNull)
import System.Glib.Flags (Flags, fromFlags)
import Graphics.UI.Gtk.Types
{-# LINE 59 "./Graphics/UI/Gtk/ModelView/CustomStore.chs" #-}
import Graphics.UI.Gtk.ModelView.Types
{-# LINE 60 "./Graphics/UI/Gtk/ModelView/CustomStore.chs" #-}
import Graphics.UI.Gtk.General.DNDTypes (SelectionDataM, SelectionData)
import System.Glib.GValue (GValue(GValue))
import System.Glib.GType (GType)
import qualified System.Glib.GTypeConstants as GConst
import System.Glib.GValueTypes
{-# LINE 66 "./Graphics/UI/Gtk/ModelView/CustomStore.chs" #-}
import System.Glib.GValue (valueInit)
{-# LINE 69 "./Graphics/UI/Gtk/ModelView/CustomStore.chs" #-}
data TreeModelFlags = TreeModelItersPersist
| TreeModelListOnly
deriving (Bounded)
instance Enum TreeModelFlags where
fromEnum TreeModelItersPersist = 1
fromEnum TreeModelListOnly = 2
toEnum 1 = TreeModelItersPersist
toEnum 2 = TreeModelListOnly
toEnum unmatched = error ("TreeModelFlags.toEnum: Cannot match " ++ show unmatched)
succ TreeModelItersPersist = TreeModelListOnly
succ _ = undefined
pred TreeModelListOnly = TreeModelItersPersist
pred _ = undefined
enumFromTo x y | fromEnum x == fromEnum y = [ y ]
| otherwise = x : enumFromTo (succ x) y
enumFrom x = enumFromTo x TreeModelListOnly
enumFromThen _ _ = error "Enum TreeModelFlags: enumFromThen not implemented"
enumFromThenTo _ _ _ = error "Enum TreeModelFlags: enumFromThenTo not implemented"
{-# LINE 81 "./Graphics/UI/Gtk/ModelView/CustomStore.chs" #-}
instance Flags TreeModelFlags
newtype CustomStore private row = CustomStore (ForeignPtr (CustomStore private row))
instance TreeModelClass (CustomStore private row)
instance GObjectClass (CustomStore private row) where
toGObject (CustomStore tm) = GObject (castForeignPtr tm)
unsafeCastGObject = CustomStore . castForeignPtr . unGObject
type ColumnMap row = IORef [ColumnAccess row]
columnMapNew :: IO (ColumnMap row)
columnMapNew = newIORef []
customStoreSetColumn :: TypedTreeModelClass model
=> model row
-> (ColumnId row ty)
-> (row -> ty)
-> IO ()
customStoreSetColumn model (ColumnId _ setter colId) acc | colId<0 = return ()
| otherwise =
case toTypedTreeModel model of
TypedTreeModel model -> do
ptr <- withForeignPtr model gtk2hs_store_get_impl
impl <- deRefStablePtr ptr
let cMap = customStoreColumns impl
cols <- readIORef cMap
let l = length cols
if colId>=l then do
let fillers = replicate (colId-l) CAInvalid
writeIORef cMap (cols++fillers++[setter acc])
else do
let (beg,_:end) = splitAt colId cols
writeIORef cMap (beg++setter acc:end)
treeModelSetColumn :: TypedTreeModelClass model
=> model row
-> (ColumnId row ty)
-> (row -> ty)
-> IO ()
treeModelSetColumn = customStoreSetColumn
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 {
treeDragSourceRowDraggable :: model row -> TreePath -> IO Bool,
treeDragSourceDragDataGet :: model row -> TreePath -> SelectionDataM Bool,
treeDragSourceDragDataDelete:: model row -> TreePath -> IO Bool
}
data DragDestIface model row = DragDestIface {
treeDragDestRowDropPossible :: model row -> TreePath -> SelectionDataM Bool,
treeDragDestDragDataReceived:: model row -> TreePath -> SelectionDataM Bool
}
customStoreNew :: (TreeModelClass (model row), TypedTreeModelClass model) =>
private
-> ((CustomStore private row) -> model row)
-> TreeModelIface row
-> Maybe (DragSourceIface model row)
-> Maybe (DragDestIface model row)
-> IO (model row)
customStoreNew priv con tmIface mDragSource mDragDest = do
cMap <- columnMapNew
let dummyDragSource = DragSourceIface { treeDragSourceRowDraggable = \_ _ -> return False,
treeDragSourceDragDataGet = \_ _ -> return False,
treeDragSourceDragDataDelete = \_ _ -> return False }
let dummyDragDest = DragDestIface { treeDragDestRowDropPossible = \_ _ -> return False,
treeDragDestDragDataReceived = \_ _ -> return False }
implPtr <- newStablePtr CustomStoreImplementation {
customStoreColumns = cMap,
customStoreIface = tmIface,
customTreeDragSourceIface = fromMaybe dummyDragSource mDragSource,
customTreeDragDestIface = fromMaybe dummyDragDest mDragDest }
privPtr <- newStablePtr priv
liftM con $ wrapNewGObject (CustomStore, objectUnref) $
gtk2hs_store_new implPtr privPtr
foreign import ccall unsafe "Gtk2HsStore.h gtk2hs_store_new"
gtk2hs_store_new :: StablePtr (CustomStoreImplementation model row)
-> StablePtr private
-> IO (Ptr (CustomStore private row))
customStoreGetRow :: TypedTreeModelClass model => model row -> TreeIter -> IO row
customStoreGetRow model iter =
case toTypedTreeModel model of
TypedTreeModel model -> do
impl <- withForeignPtr model gtk2hs_store_get_impl >>= deRefStablePtr
treeModelIfaceGetRow (customStoreIface impl) iter
treeModelGetRow :: TypedTreeModelClass model => model row -> TreeIter -> IO row
treeModelGetRow = customStoreGetRow
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 :: CustomStore private row -> IO CInt
customStoreGetStamp (CustomStore model) =
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 :: CustomStore private row -> IO ()
customStoreInvalidateIters (CustomStore model) =
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 _) = GConst.int
caToGType (CABool _) = GConst.bool
caToGType (CAString _) = GConst.string
caToGType (CAPixbuf _) = gdk_pixbuf_get_type
{-# LINE 310 "./Graphics/UI/Gtk/ModelView/CustomStore.chs" #-}
caToGType CAInvalid = GConst.int
treeModelIfaceGetColumnType_static :: StablePtr (CustomStoreImplementation model row) -> CInt -> IO GType
treeModelIfaceGetColumnType_static storePtr column = do
store <- deRefStablePtr storePtr
cols <- readIORef (customStoreColumns store)
case drop (fromIntegral column) cols of
[] -> return GConst.invalid
(ca:_) -> return (caToGType ca)
foreign export ccall "gtk2hs_store_get_column_type_impl"
treeModelIfaceGetColumnType_static :: StablePtr (CustomStoreImplementation model row) -> CInt -> IO GType
treeModelIfaceGetFlags_static :: StablePtr (CustomStoreImplementation model row) -> IO CInt
treeModelIfaceGetFlags_static storePtr = do
store <- liftM customStoreIface $ deRefStablePtr storePtr
liftM (fromIntegral . fromFlags) $ 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 NativeTreePath -> IO CInt
treeModelIfaceGetIter_static storePtr iterPtr pathPtr = do
store <- liftM customStoreIface $ deRefStablePtr storePtr
path <- peekTreePath pathPtr
iter <- treeModelIfaceGetIter store path
case iter of
Nothing -> return (fromBool False)
Just iter -> do poke iterPtr iter
return (fromBool True)
foreign export ccall "gtk2hs_store_get_iter_impl"
treeModelIfaceGetIter_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> Ptr NativeTreePath -> IO CInt
treeModelIfaceGetPath_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO (Ptr NativeTreePath)
treeModelIfaceGetPath_static storePtr iterPtr = do
store <- liftM customStoreIface $ deRefStablePtr storePtr
iter <- peek iterPtr
path <- treeModelIfaceGetPath store iter
NativeTreePath pathPtr <- newTreePath path
return pathPtr
foreign export ccall "gtk2hs_store_get_path_impl"
treeModelIfaceGetPath_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO (Ptr NativeTreePath)
treeModelIfaceGetValue_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> CInt -> Ptr GValue -> IO ()
treeModelIfaceGetValue_static storePtr iterPtr column gvaluePtr = do
store <- deRefStablePtr storePtr
iter <- peek iterPtr
row <- treeModelIfaceGetRow (customStoreIface store) iter
cols <- readIORef (customStoreColumns store)
let gVal = (GValue gvaluePtr)
0 <- (\ptr -> do {peekByteOff ptr 0 ::IO CULong}) gvaluePtr
case drop (fromIntegral column) cols of
[] -> valueInit gVal GConst.invalid
(acc:_) -> case acc of
(CAInt ca) -> valueInit gVal GConst.int >> valueSetInt gVal (ca row)
(CABool ca) -> valueInit gVal GConst.bool >> valueSetBool gVal (ca row)
(CAString ca) -> valueInit gVal GConst.string >> valueSetString gVal (ca row)
(CAPixbuf ca) -> valueInit gVal gdk_pixbuf_get_type >>
valueSetGObject gVal (ca row)
CAInvalid -> valueInit gVal GConst.int >> valueSetInt 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
store <- liftM customStoreIface $ deRefStablePtr storePtr
iter <- peek iterPtr
iter' <- treeModelIfaceIterNext store iter
case iter' of
Nothing -> return (fromBool False)
Just iter' -> do poke iterPtr 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
store <- liftM customStoreIface $ deRefStablePtr storePtr
parentIter <- maybeNull peek parentIterPtr
iter <- treeModelIfaceIterChildren store parentIter
case iter of
Nothing -> return (fromBool False)
Just iter -> do poke iterPtr 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 <- liftM customStoreIface $ deRefStablePtr storePtr
iter <- peek iterPtr
liftM 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 <- liftM customStoreIface $ deRefStablePtr storePtr
iter <- maybeNull peek iterPtr
liftM 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
store <- liftM customStoreIface $ deRefStablePtr storePtr
parentIter <- maybeNull peek parentIterPtr
iter <- treeModelIfaceIterNthChild store parentIter (fromIntegral n)
case iter of
Nothing -> return (fromBool False)
Just iter -> do poke iterPtr 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
store <- liftM customStoreIface $ deRefStablePtr storePtr
childIter <- peek childIterPtr
iter <- treeModelIfaceIterParent store childIter
case iter of
Nothing -> return (fromBool False)
Just iter -> do poke iterPtr 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 <- liftM customStoreIface $ deRefStablePtr storePtr
iter <- peek 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 <- liftM customStoreIface $ deRefStablePtr storePtr
iter <- peek iterPtr
treeModelIfaceUnrefNode store iter
foreign export ccall "gtk2hs_store_unref_node_impl"
treeModelIfaceUnrefNode_static :: StablePtr (CustomStoreImplementation model row) -> Ptr TreeIter -> IO ()
treeDragSourceRowDraggable_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> IO CInt
treeDragSourceRowDraggable_static mPtr storePtr pathPtr = do
model <- makeNewGObject mkTreeModel (return mPtr)
store <- liftM customTreeDragSourceIface $ deRefStablePtr storePtr
path <- peekTreePath pathPtr
liftM fromBool $ treeDragSourceRowDraggable store (unsafeTreeModelToGeneric model) path
foreign export ccall "gtk2hs_store_row_draggable_impl"
treeDragSourceRowDraggable_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> IO CInt
treeDragSourceDragDataGet_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> SelectionData -> IO CInt
treeDragSourceDragDataGet_static mPtr storePtr pathPtr selectionPtr = do
model <- makeNewGObject mkTreeModel (return mPtr)
store <- liftM customTreeDragSourceIface $ deRefStablePtr storePtr
path <- peekTreePath pathPtr
liftM fromBool $ runReaderT (treeDragSourceDragDataGet store (unsafeTreeModelToGeneric model) path) selectionPtr
foreign export ccall "gtk2hs_store_drag_data_get_impl"
treeDragSourceDragDataGet_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> SelectionData -> IO CInt
treeDragSourceDragDataDelete_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> IO CInt
treeDragSourceDragDataDelete_static mPtr storePtr pathPtr = do
model <- makeNewGObject mkTreeModel (return mPtr)
store <- liftM customTreeDragSourceIface $ deRefStablePtr storePtr
path <- peekTreePath pathPtr
liftM fromBool $ treeDragSourceDragDataDelete store (unsafeTreeModelToGeneric model) path
foreign export ccall "gtk2hs_store_drag_data_delete_impl"
treeDragSourceDragDataDelete_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> IO CInt
treeDragDestDragDataReceived_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> SelectionData -> IO CInt
treeDragDestDragDataReceived_static mPtr storePtr pathPtr selectionPtr = do
model <- makeNewGObject mkTreeModel (return mPtr)
store <- liftM customTreeDragDestIface $ deRefStablePtr storePtr
path <- peekTreePath pathPtr
liftM fromBool $ runReaderT (treeDragDestDragDataReceived store (unsafeTreeModelToGeneric model) path) selectionPtr
foreign export ccall "gtk2hs_store_drag_data_received_impl"
treeDragDestDragDataReceived_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> SelectionData -> IO CInt
treeDragDestRowDropPossible_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> SelectionData -> IO CInt
treeDragDestRowDropPossible_static mPtr storePtr pathPtr selectionPtr = do
model <- makeNewGObject mkTreeModel (return mPtr)
store <- liftM customTreeDragDestIface $ deRefStablePtr storePtr
path <- peekTreePath pathPtr
liftM fromBool $ runReaderT (treeDragDestRowDropPossible store (unsafeTreeModelToGeneric model) path) selectionPtr
foreign export ccall "gtk2hs_store_row_drop_possible_impl"
treeDragDestRowDropPossible_static :: Ptr TreeModel -> StablePtr (CustomStoreImplementation model row) -> Ptr NativeTreePath -> 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)
foreign import ccall unsafe "gdk_pixbuf_get_type"
gdk_pixbuf_get_type :: CULong