module Data.GI.Gtk.ModelView.SeqStore (
SeqStore(..),
seqStoreNew,
seqStoreNewDND,
seqStoreDefaultDragSourceIface,
seqStoreDefaultDragDestIface,
seqStoreIterToIndex,
seqStoreGetValue,
seqStoreSafeGetValue,
seqStoreSetValue,
seqStoreToList,
seqStoreGetSize,
seqStoreInsert,
seqStoreInsertBefore,
seqStoreInsertAfter,
seqStorePrepend,
seqStoreAppend,
seqStoreRemove,
seqStoreClear,
) where
import Prelude ()
import Prelude.Compat
import Control.Monad (when)
import Control.Monad.Trans ( liftIO )
import Data.IORef
import Data.Ix (inRange)
import Foreign.ForeignPtr (ForeignPtr)
import qualified Data.Sequence as Seq
import Data.Sequence (Seq)
import qualified Data.Foldable as F
import Data.Int (Int32)
import Data.GI.Gtk.ModelView.Types
import Data.GI.Gtk.ModelView.CustomStore
(customStoreGetStamp, customStoreGetPrivate,
TreeModelIface(..), customStoreNew, DragDestIface(..),
DragSourceIface(..), CustomStore(..))
import Data.GI.Base.BasicTypes (GObject(..), GObject)
import Data.GI.Base.ManagedPtr (withManagedPtr)
import GI.Gtk.Interfaces.TreeModel
(treeModelRowDeleted, treeModelRowInserted,
treeModelRowChanged, toTreeModel, TreeModel(..), IsTreeModel(..))
import GI.GObject.Objects.Object (Object(..))
import GI.Gtk.Functions (treeGetRowDragData, treeSetRowDragData)
import GI.Gtk.Flags (TreeModelFlags(..))
import Control.Monad.IO.Class (MonadIO)
import GI.Gtk.Structs.TreeIter
(setTreeIterUserData3, setTreeIterUserData2, setTreeIterStamp,
setTreeIterUserData, getTreeIterUserData, TreeIter(..))
import Data.GI.Base (get, new)
import Data.Word (Word32)
import Unsafe.Coerce (unsafeCoerce)
import Foreign.Ptr (nullPtr)
seqStoreIterNew :: MonadIO m => Int32 -> Int32 -> m TreeIter
seqStoreIterNew s u1 = do
i <- new TreeIter []
setTreeIterStamp i s
setTreeIterUserData i $ unsafeCoerce u1
setTreeIterUserData2 i nullPtr
setTreeIterUserData3 i nullPtr
return i
newtype SeqStore a = SeqStore (ForeignPtr (CustomStore (IORef (Seq a)) a))
mkSeqStore :: CustomStore (IORef (Seq a)) a -> SeqStore a
mkSeqStore (CustomStore ptr) = SeqStore ptr
instance IsTreeModel (SeqStore a)
instance GObject (SeqStore a) where
gobjectIsInitiallyUnowned _ = False
gobjectType _ = gobjectType (undefined :: TreeModel)
instance IsTypedTreeModel SeqStore
seqStoreNew :: (Applicative m, MonadIO m) => [a] -> m (SeqStore a)
seqStoreNew xs = seqStoreNewDND xs (Just seqStoreDefaultDragSourceIface)
(Just seqStoreDefaultDragDestIface)
seqStoreNewDND :: (Applicative m, MonadIO m)
=> [a]
-> Maybe (DragSourceIface SeqStore a)
-> Maybe (DragDestIface SeqStore a)
-> m (SeqStore a)
seqStoreNewDND xs mDSource mDDest = do
rows <- liftIO $ newIORef (Seq.fromList xs)
customStoreNew rows mkSeqStore TreeModelIface {
treeModelIfaceGetFlags = return [TreeModelFlagsListOnly],
treeModelIfaceGetIter = \path -> treePathGetIndices' path >>= \[n] -> readIORef rows >>= \rows ->
if inRange (0, Seq.length rows 1) (fromIntegral n)
then Just <$> seqStoreIterNew 0 (fromIntegral n)
else return Nothing,
treeModelIfaceGetPath = \i -> do
n <- seqStoreIterToIndex i
treePathNewFromIndices' [fromIntegral n],
treeModelIfaceGetRow = \i -> do
n <- seqStoreIterToIndex i
readIORef rows >>= \rows ->
if inRange (0, Seq.length rows 1) (fromIntegral n)
then return (rows `Seq.index` fromIntegral n)
else fail "SeqStore.getRow: iter does not refer to a valid entry",
treeModelIfaceIterNext = \i -> do
n <- seqStoreIterToIndex i
readIORef rows >>= \rows ->
if inRange (0, Seq.length rows 1) (fromIntegral (n+1))
then Just <$> seqStoreIterNew 0 (n+1)
else return Nothing,
treeModelIfaceIterChildren = \index -> readIORef rows >>= \rows ->
case index of
Nothing | not (Seq.null rows) -> Just <$> seqStoreIterNew 0 0
_ -> return Nothing,
treeModelIfaceIterHasChild = \_ -> return False,
treeModelIfaceIterNChildren = \index -> readIORef rows >>= \rows ->
case index of
Nothing -> return $! Seq.length rows
_ -> return 0,
treeModelIfaceIterNthChild = \index n -> case index of
Nothing -> Just <$> seqStoreIterNew 0 (fromIntegral n)
_ -> return Nothing,
treeModelIfaceIterParent = \_ -> return Nothing,
treeModelIfaceRefNode = \_ -> return (),
treeModelIfaceUnrefNode = \_ -> return ()
} mDSource mDDest
seqStoreIterToIndex :: (Applicative m, MonadIO m) => TreeIter -> m Int32
seqStoreIterToIndex i = unsafeCoerce <$> getTreeIterUserData i
seqStoreDefaultDragSourceIface :: DragSourceIface SeqStore row
seqStoreDefaultDragSourceIface = DragSourceIface {
customDragSourceRowDraggable = \_ _-> return True,
customDragSourceDragDataGet = \model path sel -> treeSetRowDragData sel model path,
customDragSourceDragDataDelete = \model path -> treePathGetIndices' path >>= \(dest:_) -> do
liftIO $ seqStoreRemove model (fromIntegral dest)
return True
}
seqStoreDefaultDragDestIface :: DragDestIface SeqStore row
seqStoreDefaultDragDestIface = DragDestIface {
customDragDestRowDropPossible = \model path sel -> do
dest <- treePathGetIndices' path
mModelPath <- treeGetRowDragData sel
case mModelPath of
(True, Just model', source) -> do
tm <- toTreeModel model
withManagedPtr tm $ \m ->
withManagedPtr model' $ \m' -> return (m==m')
_ -> return False,
customDragDestDragDataReceived = \model path sel -> do
(dest:_) <- treePathGetIndices' path
mModelPath <- treeGetRowDragData sel
case mModelPath of
(True, Just model', Just path) -> do
(source:_) <- treePathGetIndices' path
tm <- toTreeModel model
withManagedPtr tm $ \m ->
withManagedPtr model' $ \m' ->
if m/=m' then return False
else do
row <- seqStoreGetValue model source
seqStoreInsert model dest row
return True
_ -> return False
}
seqStoreGetValue :: (Applicative m, MonadIO m) => SeqStore a -> Int32 -> m a
seqStoreGetValue (SeqStore model) index =
(`Seq.index` fromIntegral index) <$> liftIO (readIORef (customStoreGetPrivate (CustomStore model)))
seqStoreSafeGetValue :: MonadIO m => SeqStore a -> Int32 -> m (Maybe a)
seqStoreSafeGetValue (SeqStore model) index' = do
let index = fromIntegral index'
seq <- liftIO $ readIORef (customStoreGetPrivate (CustomStore model))
return $ if index >=0 && index < Seq.length seq
then Just $ seq `Seq.index` index
else Nothing
seqStoreSetValue :: MonadIO m => SeqStore a -> Int32 -> a -> m ()
seqStoreSetValue (SeqStore model) index value = do
liftIO $ modifyIORef (customStoreGetPrivate (CustomStore model)) (Seq.update (fromIntegral index) value)
stamp <- customStoreGetStamp (CustomStore model)
path <- treePathNewFromIndices' [index]
i <- seqStoreIterNew stamp (fromIntegral index)
treeModelRowChanged (CustomStore model) path i
seqStoreToList :: (Applicative m, MonadIO m) => SeqStore a -> m [a]
seqStoreToList (SeqStore model) =
F.toList <$> liftIO (readIORef (customStoreGetPrivate (CustomStore model)))
seqStoreGetSize :: (Applicative m, MonadIO m) => SeqStore a -> m Int32
seqStoreGetSize (SeqStore model) =
fromIntegral . Seq.length <$> liftIO (readIORef (customStoreGetPrivate (CustomStore model)))
seqStoreInsert :: MonadIO m => SeqStore a -> Int32 -> a -> m ()
seqStoreInsert (SeqStore model) index value = liftIO $ do
seq <- readIORef (customStoreGetPrivate (CustomStore model))
when (index >= 0) $ do
let index' | fromIntegral index > Seq.length seq = Seq.length seq
| otherwise = fromIntegral $ index
writeIORef (customStoreGetPrivate (CustomStore model)) (insert index' value seq)
stamp <- customStoreGetStamp (CustomStore model)
p <- treePathNewFromIndices' [fromIntegral index']
i <- seqStoreIterNew stamp (fromIntegral index')
treeModelRowInserted (CustomStore model) p i
where insert :: Int -> a -> Seq a -> Seq a
insert i x xs = front Seq.>< x Seq.<| back
where (front, back) = Seq.splitAt i xs
seqStoreInsertBefore :: (Applicative m, MonadIO m) => SeqStore a -> TreeIter -> a -> m ()
seqStoreInsertBefore store iter value = do
n <- seqStoreIterToIndex iter
seqStoreInsert store n value
seqStoreInsertAfter :: (Applicative m, MonadIO m) => SeqStore a -> TreeIter -> a -> m ()
seqStoreInsertAfter store iter value = do
n <- seqStoreIterToIndex iter
seqStoreInsert store (n + 1) value
seqStorePrepend :: (Applicative m, MonadIO m) => SeqStore a -> a -> m ()
seqStorePrepend (SeqStore model) value = do
liftIO $ modifyIORef (customStoreGetPrivate (CustomStore model))
(\seq -> value Seq.<| seq)
stamp <- customStoreGetStamp (CustomStore model)
p <- treePathNewFromIndices' [0]
i <- seqStoreIterNew stamp 0
treeModelRowInserted (CustomStore model) p i
seqStoreAppend :: MonadIO m => SeqStore a -> a -> m Int32
seqStoreAppend (SeqStore model) value = do
index <- liftIO $ atomicModifyIORef (customStoreGetPrivate (CustomStore model))
(\seq -> (seq Seq.|> value, Seq.length seq))
stamp <- customStoreGetStamp (CustomStore model)
p <- treePathNewFromIndices' [fromIntegral index]
i <- seqStoreIterNew stamp (fromIntegral index)
treeModelRowInserted (CustomStore model) p i
return $ fromIntegral index
seqStoreRemove :: MonadIO m => SeqStore a -> Int32 -> m ()
seqStoreRemove (SeqStore model) index' = liftIO $ do
seq <- readIORef (customStoreGetPrivate (CustomStore model))
when (index >=0 && index < Seq.length seq) $ do
writeIORef (customStoreGetPrivate (CustomStore model)) (delete index seq)
p <- treePathNewFromIndices' [fromIntegral index]
treeModelRowDeleted (CustomStore model) p
where delete :: Int -> Seq a -> Seq a
delete i xs = front Seq.>< Seq.drop 1 back
where (front, back) = Seq.splitAt i xs
index = fromIntegral index'
seqStoreClear :: MonadIO m => SeqStore a -> m ()
seqStoreClear (SeqStore model) = liftIO $
let loop (1) Seq.EmptyR = return ()
loop n (seq Seq.:> _) = do
writeIORef (customStoreGetPrivate (CustomStore model)) seq
p <- treePathNewFromIndices' [fromIntegral n]
treeModelRowDeleted (CustomStore model) p
loop (n1) (Seq.viewr seq)
in do seq <- readIORef (customStoreGetPrivate (CustomStore model))
loop (Seq.length seq 1) (Seq.viewr seq)