{-# LANGUAGE CPP #-}
module Graphics.UI.Gtk.ModelView.TreeStore (
TreeStore,
treeStoreNew,
treeStoreNewDND,
treeStoreDefaultDragSourceIface,
treeStoreDefaultDragDestIface,
treeStoreGetValue,
treeStoreGetTree,
treeStoreLookup,
treeStoreSetValue,
treeStoreInsert,
treeStoreInsertTree,
treeStoreInsertForest,
treeStoreRemove,
treeStoreClear,
treeStoreChange,
treeStoreChangeM,
) where
import Data.Bits
import Data.Word (Word32)
import Data.Maybe ( fromMaybe, isJust )
import Data.Tree
import Control.Monad ( when )
import Control.Exception (assert)
import Data.IORef
import Graphics.UI.Gtk.ModelView.Types
import Graphics.UI.Gtk.Types (GObjectClass(..))
import Graphics.UI.Gtk.ModelView.CustomStore
import Graphics.UI.Gtk.ModelView.TreeModel
import Graphics.UI.Gtk.ModelView.TreeDrag
import Control.Monad.Trans ( liftIO )
newtype TreeStore a = TreeStore (CustomStore (IORef (Store a)) a)
instance TypedTreeModelClass TreeStore
instance TreeModelClass (TreeStore a)
instance GObjectClass (TreeStore a) where
toGObject :: TreeStore a -> GObject
toGObject (TreeStore CustomStore (IORef (Store a)) a
tm) = forall o. GObjectClass o => o -> GObject
toGObject CustomStore (IORef (Store a)) a
tm
unsafeCastGObject :: GObject -> TreeStore a
unsafeCastGObject = forall a. CustomStore (IORef (Store a)) a -> TreeStore a
TreeStore forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o. GObjectClass o => GObject -> o
unsafeCastGObject
type Depth = [Int]
data Store a = Store {
forall a. Store a -> Depth
depth :: Depth,
forall a. Store a -> Cache a
content :: Cache a
}
treeStoreNew :: Forest a -> IO (TreeStore a)
treeStoreNew :: forall a. Forest a -> IO (TreeStore a)
treeStoreNew Forest a
forest = forall a.
Forest a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
treeStoreNewDND Forest a
forest
(forall a. a -> Maybe a
Just forall row. DragSourceIface TreeStore row
treeStoreDefaultDragSourceIface)
(forall a. a -> Maybe a
Just forall row. DragDestIface TreeStore row
treeStoreDefaultDragDestIface)
treeStoreNewDND :: Forest a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
treeStoreNewDND :: forall a.
Forest a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
treeStoreNewDND Forest a
forest Maybe (DragSourceIface TreeStore a)
mDSource Maybe (DragDestIface TreeStore a)
mDDest = do
IORef (Store a)
storeRef <- forall a. a -> IO (IORef a)
newIORef Store {
depth :: Depth
depth = forall a. Forest a -> Depth
calcForestDepth Forest a
forest,
content :: Cache a
content = forall a. Forest a -> Cache a
storeToCache Forest a
forest
}
let withStore :: (Store a -> b) -> IO b
withStore Store a -> b
f = forall a. IORef a -> IO a
readIORef IORef (Store a)
storeRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store a -> b
f
withStoreUpdateCache :: (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache Store a -> (b, Cache a)
f = do
Store a
store <- forall a. IORef a -> IO a
readIORef IORef (Store a)
storeRef
let (b
result, Cache a
cache') = Store a -> (b, Cache a)
f Store a
store
forall a. IORef a -> a -> IO ()
writeIORef IORef (Store a)
storeRef Store a
store { content :: Cache a
content = Cache a
cache' }
forall (m :: * -> *) a. Monad m => a -> m a
return b
result
forall (model :: * -> *) row private.
(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 IORef (Store a)
storeRef forall a. CustomStore (IORef (Store a)) a -> TreeStore a
TreeStore TreeModelIface {
treeModelIfaceGetFlags :: IO [TreeModelFlags]
treeModelIfaceGetFlags = forall (m :: * -> *) a. Monad m => a -> m a
return [],
treeModelIfaceGetIter :: Depth -> IO (Maybe TreeIter)
treeModelIfaceGetIter = \Depth
path -> forall {b}. (Store a -> b) -> IO b
withStore forall a b. (a -> b) -> a -> b
$
\Store { depth :: forall a. Store a -> Depth
depth = Depth
d } -> Depth -> Depth -> Maybe TreeIter
fromPath Depth
d Depth
path,
treeModelIfaceGetPath :: TreeIter -> IO Depth
treeModelIfaceGetPath = \TreeIter
iter -> forall {b}. (Store a -> b) -> IO b
withStore forall a b. (a -> b) -> a -> b
$
\Store { depth :: forall a. Store a -> Depth
depth = Depth
d } -> Depth -> TreeIter -> Depth
toPath Depth
d TreeIter
iter,
treeModelIfaceGetRow :: TreeIter -> IO a
treeModelIfaceGetRow = \TreeIter
iter -> forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache forall a b. (a -> b) -> a -> b
$
\Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
case forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d TreeIter
iter Cache a
cache of
(Bool
True, cache' :: Cache a
cache'@((TreeIter
_, (Node { rootLabel :: forall a. Tree a -> a
rootLabel = a
val }:Forest a
_)):Cache a
_)) ->
(a
val, Cache a
cache')
(Bool, Cache a)
_ -> forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"TreeStore.getRow: iter does not refer to a valid entry",
treeModelIfaceIterNext :: TreeIter -> IO (Maybe TreeIter)
treeModelIfaceIterNext = \TreeIter
iter -> forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache forall a b. (a -> b) -> a -> b
$
\Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } -> forall a. Depth -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNext Depth
d TreeIter
iter Cache a
cache,
treeModelIfaceIterChildren :: Maybe TreeIter -> IO (Maybe TreeIter)
treeModelIfaceIterChildren = \Maybe TreeIter
mIter -> forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache forall a b. (a -> b) -> a -> b
$
\Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
let iter :: TreeIter
iter = forall a. a -> Maybe a -> a
fromMaybe TreeIter
invalidIter Maybe TreeIter
mIter
in forall a.
Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNthChild Depth
d Int
0 TreeIter
iter Cache a
cache,
treeModelIfaceIterHasChild :: TreeIter -> IO Bool
treeModelIfaceIterHasChild = \TreeIter
iter -> forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache forall a b. (a -> b) -> a -> b
$
\Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
let (Maybe TreeIter
mIter, Cache a
cache') = forall a.
Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNthChild Depth
d Int
0 TreeIter
iter Cache a
cache
in (forall a. Maybe a -> Bool
isJust Maybe TreeIter
mIter, Cache a
cache'),
treeModelIfaceIterNChildren :: Maybe TreeIter -> IO Int
treeModelIfaceIterNChildren = \Maybe TreeIter
mIter -> forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache forall a b. (a -> b) -> a -> b
$
\Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
let iter :: TreeIter
iter = forall a. a -> Maybe a -> a
fromMaybe TreeIter
invalidIter Maybe TreeIter
mIter
in forall a. Depth -> TreeIter -> Cache a -> (Int, Cache a)
iterNChildren Depth
d TreeIter
iter Cache a
cache,
treeModelIfaceIterNthChild :: Maybe TreeIter -> Int -> IO (Maybe TreeIter)
treeModelIfaceIterNthChild = \Maybe TreeIter
mIter Int
idx -> forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache forall a b. (a -> b) -> a -> b
$
\Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
let iter :: TreeIter
iter = forall a. a -> Maybe a -> a
fromMaybe TreeIter
invalidIter Maybe TreeIter
mIter
in forall a.
Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNthChild Depth
d Int
idx TreeIter
iter Cache a
cache,
treeModelIfaceIterParent :: TreeIter -> IO (Maybe TreeIter)
treeModelIfaceIterParent = \TreeIter
iter -> forall {b}. (Store a -> b) -> IO b
withStore forall a b. (a -> b) -> a -> b
$
\Store { depth :: forall a. Store a -> Depth
depth = Depth
d } -> Depth -> TreeIter -> Maybe TreeIter
iterParent Depth
d TreeIter
iter,
treeModelIfaceRefNode :: TreeIter -> IO ()
treeModelIfaceRefNode = \TreeIter
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (),
treeModelIfaceUnrefNode :: TreeIter -> IO ()
treeModelIfaceUnrefNode = \TreeIter
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
} Maybe (DragSourceIface TreeStore a)
mDSource Maybe (DragDestIface TreeStore a)
mDDest
treeStoreDefaultDragSourceIface :: DragSourceIface TreeStore row
treeStoreDefaultDragSourceIface :: forall row. DragSourceIface TreeStore row
treeStoreDefaultDragSourceIface = DragSourceIface {
treeDragSourceRowDraggable :: TreeStore row -> Depth -> IO Bool
treeDragSourceRowDraggable = \TreeStore row
_ Depth
_-> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True,
treeDragSourceDragDataGet :: TreeStore row -> Depth -> SelectionDataM Bool
treeDragSourceDragDataGet = forall treeModel.
TreeModelClass treeModel =>
treeModel -> Depth -> SelectionDataM Bool
treeSetRowDragData,
treeDragSourceDragDataDelete :: TreeStore row -> Depth -> IO Bool
treeDragSourceDragDataDelete = \TreeStore row
model dest :: Depth
dest@(Int
_:Depth
_) -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TreeStore a -> Depth -> IO Bool
treeStoreRemove TreeStore row
model Depth
dest
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
}
treeStoreDefaultDragDestIface :: DragDestIface TreeStore row
treeStoreDefaultDragDestIface :: forall row. DragDestIface TreeStore row
treeStoreDefaultDragDestIface = DragDestIface {
treeDragDestRowDropPossible :: TreeStore row -> Depth -> SelectionDataM Bool
treeDragDestRowDropPossible = \TreeStore row
model Depth
dest -> do
Maybe (TreeModel, Depth)
mModelPath <- SelectionDataM (Maybe (TreeModel, Depth))
treeGetRowDragData
case Maybe (TreeModel, Depth)
mModelPath of
Maybe (TreeModel, Depth)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just (TreeModel
model', Depth
source) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeStore row
modelforall a. Eq a => a -> a -> Bool
==forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeModel
model'),
treeDragDestDragDataReceived :: TreeStore row -> Depth -> SelectionDataM Bool
treeDragDestDragDataReceived = \TreeStore row
model dest :: Depth
dest@(Int
_:Depth
_) -> do
Maybe (TreeModel, Depth)
mModelPath <- SelectionDataM (Maybe (TreeModel, Depth))
treeGetRowDragData
case Maybe (TreeModel, Depth)
mModelPath of
Maybe (TreeModel, Depth)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just (TreeModel
model', source :: Depth
source@(Int
_:Depth
_)) ->
if forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeStore row
modelforall a. Eq a => a -> a -> Bool
/=forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeModel
model' then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Tree row
row <- forall a. TreeStore a -> Depth -> IO (Tree a)
treeStoreGetTree TreeStore row
model Depth
source
forall a. TreeStore a -> Depth -> Int -> Tree a -> IO ()
treeStoreInsertTree TreeStore row
model (forall a. [a] -> [a]
init Depth
dest) (forall a. [a] -> a
last Depth
dest) Tree row
row
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
}
bitsNeeded :: Word32 -> Int
bitsNeeded :: Word32 -> Int
bitsNeeded Word32
n = forall {t} {t}. (Num t, Num t, Bits t) => t -> t -> t
bitsNeeded' Int
0 Word32
n
where bitsNeeded' :: t -> t -> t
bitsNeeded' t
b t
0 = t
b
bitsNeeded' t
b t
n = t -> t -> t
bitsNeeded' (t
bforall a. Num a => a -> a -> a
+t
1) (t
n forall a. Bits a => a -> Int -> a
`shiftR` Int
1)
getBitSlice :: TreeIter -> Int -> Int -> Word32
getBitSlice :: TreeIter -> Int -> Int -> Word32
getBitSlice (TreeIter CInt
_ Word32
a Word32
b Word32
c) Int
off Int
count =
Word32 -> Int -> Int -> Word32
getBitSliceWord Word32
a Int
off Int
count
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Int -> Word32
getBitSliceWord Word32
b (Int
offforall a. Num a => a -> a -> a
-Int
32) Int
count
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Int -> Word32
getBitSliceWord Word32
c (Int
offforall a. Num a => a -> a -> a
-Int
64) Int
count
where getBitSliceWord :: Word32 -> Int -> Int -> Word32
getBitSliceWord :: Word32 -> Int -> Int -> Word32
getBitSliceWord Word32
word Int
off Int
count =
Word32
word forall a. Bits a => a -> Int -> a
`shift` (-Int
off) forall a. Bits a => a -> a -> a
.&. (Word32
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
count forall a. Num a => a -> a -> a
- Word32
1)
setBitSlice :: TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice :: TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice (TreeIter CInt
stamp Word32
a Word32
b Word32
c) Int
off Int
count Word32
value =
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Word32
value forall a. Ord a => a -> a -> Bool
< Word32
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
count) forall a b. (a -> b) -> a -> b
$
CInt -> Word32 -> Word32 -> Word32 -> TreeIter
TreeIter CInt
stamp
(Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord Word32
a Int
off Int
count Word32
value)
(Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord Word32
b (Int
offforall a. Num a => a -> a -> a
-Int
32) Int
count Word32
value)
(Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord Word32
c (Int
offforall a. Num a => a -> a -> a
-Int
64) Int
count Word32
value)
where setBitSliceWord :: Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord :: Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord Word32
word Int
off Int
count Word32
value =
let mask :: Word32
mask = (Word32
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
count forall a. Num a => a -> a -> a
- Word32
1) forall a. Bits a => a -> Int -> a
`shift` Int
off
in (Word32
word forall a. Bits a => a -> a -> a
.&. forall a. Bits a => a -> a
complement Word32
mask) forall a. Bits a => a -> a -> a
.|. (Word32
value forall a. Bits a => a -> Int -> a
`shift` Int
off)
invalidIter :: TreeIter
invalidIter :: TreeIter
invalidIter = CInt -> Word32 -> Word32 -> Word32 -> TreeIter
TreeIter CInt
0 Word32
0 Word32
0 Word32
0
calcForestDepth :: Forest a -> Depth
calcForestDepth :: forall a. Forest a -> Depth
calcForestDepth Forest a
f = forall a b. (a -> b) -> [a] -> [b]
map Word32 -> Int
bitsNeeded forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/=Word32
0) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {a}. (Num a, Ord a) => Tree a -> [a] -> [a]
calcTreeDepth (forall a. a -> [a]
repeat Word32
0) Forest a
f
where
calcTreeDepth :: Tree a -> [a] -> [a]
calcTreeDepth Node { subForest :: forall a. Tree a -> [Tree a]
subForest = [Tree a]
f } (a
d:[a]
ds) =
(a
dforall a. Num a => a -> a -> a
+a
1)forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Ord a => a -> a -> a
max [a]
ds (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree a -> [a] -> [a]
calcTreeDepth (forall a. a -> [a]
repeat a
0) [Tree a]
f)
toPath :: Depth -> TreeIter -> TreePath
toPath :: Depth -> TreeIter -> Depth
toPath Depth
d TreeIter
iter = forall {a}. Num a => Int -> Depth -> [a]
gP Int
0 Depth
d
where
gP :: Int -> Depth -> [a]
gP Int
pos [] = []
gP Int
pos (Int
d:Depth
ds) = let idx :: Word32
idx = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
iter Int
pos Int
d in
if Word32
idxforall a. Eq a => a -> a -> Bool
==Word32
0 then [] else forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
idxforall a. Num a => a -> a -> a
-Word32
1) forall a. a -> [a] -> [a]
: Int -> Depth -> [a]
gP (Int
posforall a. Num a => a -> a -> a
+Int
d) Depth
ds
fromPath :: Depth -> TreePath -> Maybe TreeIter
fromPath :: Depth -> Depth -> Maybe TreeIter
fromPath = forall {a}.
Integral a =>
Int -> TreeIter -> Depth -> [a] -> Maybe TreeIter
fP Int
0 TreeIter
invalidIter
where
fP :: Int -> TreeIter -> Depth -> [a] -> Maybe TreeIter
fP Int
pos TreeIter
ti Depth
_ [] = forall a. a -> Maybe a
Just TreeIter
ti
fP Int
pos TreeIter
ti [] [a]
_ = forall a. Maybe a
Nothing
fP Int
pos TreeIter
ti (Int
d:Depth
ds) (a
p:[a]
ps) = let idx :: Word32
idx = forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
pforall a. Num a => a -> a -> a
+a
1) in
if Word32
idx forall a. Ord a => a -> a -> Bool
>= forall a. Bits a => Int -> a
bit Int
d then forall a. Maybe a
Nothing else
Int -> TreeIter -> Depth -> [a] -> Maybe TreeIter
fP (Int
posforall a. Num a => a -> a -> a
+Int
d) (TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
ti Int
pos Int
d Word32
idx) Depth
ds [a]
ps
type Cache a = [(TreeIter, Forest a)]
storeToCache :: Forest a -> Cache a
storeToCache :: forall a. Forest a -> Cache a
storeToCache [] = []
storeToCache [Tree a]
forest = [(TreeIter
invalidIter, [forall a. a -> [Tree a] -> Tree a
Node forall {a}. a
root [Tree a]
forest])]
where
root :: a
root = forall a. (?callStack::CallStack) => [Char] -> a
error [Char]
"TreeStore.storeToCache: accessed non-exitent root of tree"
cacheToStore :: Cache a -> Forest a
cacheToStore :: forall a. Cache a -> Forest a
cacheToStore [] = []
cacheToStore [(TreeIter, Forest a)]
cache = case forall a. [a] -> a
last [(TreeIter, Forest a)]
cache of (TreeIter
_, [Node a
_ Forest a
forest]) -> Forest a
forest
advanceCache :: Depth -> TreeIter -> Cache a -> Cache a
advanceCache :: forall a. Depth -> TreeIter -> Cache a -> Cache a
advanceCache Depth
depth TreeIter
goal [] = []
advanceCache Depth
depth TreeIter
goal cache :: [(TreeIter, Forest a)]
cache@((TreeIter
rootIter,Forest a
_):[(TreeIter, Forest a)]
_) =
Int -> Depth -> [(TreeIter, Forest a)]
moveToSameLevel Int
0 Depth
depth
where
moveToSameLevel :: Int -> Depth -> [(TreeIter, Forest a)]
moveToSameLevel Int
pos [] = [(TreeIter, Forest a)]
cache
moveToSameLevel Int
pos (Int
d:Depth
ds) =
let
goalIdx :: Word32
goalIdx = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
goal Int
pos Int
d
curIdx :: Word32
curIdx = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
rootIter Int
pos Int
d
isNonZero :: Int -> Int -> (TreeIter, b) -> Bool
isNonZero Int
pos Int
d (TreeIter
ti,b
_) = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
ti Int
pos Int
dforall a. Eq a => a -> a -> Bool
/=Word32
0
in
if Word32
goalIdxforall a. Eq a => a -> a -> Bool
==Word32
curIdx then Int -> Depth -> [(TreeIter, Forest a)]
moveToSameLevel (Int
posforall a. Num a => a -> a -> a
+Int
d) Depth
ds else
if Word32
goalIdxforall a. Eq a => a -> a -> Bool
==Word32
0 then forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall {b}. Int -> Int -> (TreeIter, b) -> Bool
isNonZero Int
pos Int
d) [(TreeIter, Forest a)]
cache else
if Word32
curIdxforall a. Eq a => a -> a -> Bool
==Word32
0 then forall a. Int -> Depth -> Cache a -> Cache a
moveToChild Int
pos (Int
dforall a. a -> [a] -> [a]
:Depth
ds) [(TreeIter, Forest a)]
cache else
if Word32
goalIdxforall a. Ord a => a -> a -> Bool
<Word32
curIdx then
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild Int
pos (Int
dforall a. a -> [a] -> [a]
:Depth
ds) (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall {b}. Int -> Int -> (TreeIter, b) -> Bool
isNonZero Int
pos Int
d) [(TreeIter, Forest a)]
cache)
else let
moveWithinLevel :: Int -> Int -> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
moveWithinLevel Int
pos Int
d ((TreeIter
ti,[Tree a]
forest):[(TreeIter, [Tree a])]
parents) = let
diff :: Int
diff = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
goalIdxforall a. Num a => a -> a -> a
-Word32
curIdx)
([Tree a]
dropped, [Tree a]
remain) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
diff [Tree a]
forest
advance :: Int
advance = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tree a]
dropped
ti' :: TreeIter
ti' = TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
ti Int
pos Int
d (Word32
curIdxforall a. Num a => a -> a -> a
+forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
advance)
in
if Int
advanceforall a. Eq a => a -> a -> Bool
==Int
diff then forall a. Int -> Depth -> Cache a -> Cache a
moveToChild (Int
posforall a. Num a => a -> a -> a
+Int
d) Depth
ds ((TreeIter
ti',[Tree a]
remain)forall a. a -> [a] -> [a]
:[(TreeIter, [Tree a])]
parents)
else (TreeIter
ti',[Tree a]
remain)forall a. a -> [a] -> [a]
:[(TreeIter, [Tree a])]
parents
in forall {a}.
Int -> Int -> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
moveWithinLevel Int
pos Int
d forall a b. (a -> b) -> a -> b
$ case Depth
ds of
[] -> [(TreeIter, Forest a)]
cache
(Int
d':Depth
_) -> forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall {b}. Int -> Int -> (TreeIter, b) -> Bool
isNonZero (Int
posforall a. Num a => a -> a -> a
+Int
d) Int
d') [(TreeIter, Forest a)]
cache
moveToChild :: Int -> Depth -> Cache a -> Cache a
moveToChild :: forall a. Int -> Depth -> Cache a -> Cache a
moveToChild Int
pos [] Cache a
cache = Cache a
cache
moveToChild Int
pos (Int
d:Depth
ds) cache :: Cache a
cache@((TreeIter
ti,Forest a
forest):Cache a
parents)
| TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
goal Int
pos Int
d forall a. Eq a => a -> a -> Bool
== Word32
0 = Cache a
cache
| Bool
otherwise = case Forest a
forest of
[] -> Cache a
cache
Node { subForest :: forall a. Tree a -> [Tree a]
subForest = Forest a
children }:Forest a
_ ->
let
childIdx :: Int
childIdx :: Int
childIdx = forall a b. (Integral a, Num b) => a -> b
fromIntegral (TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
goal Int
pos Int
d)forall a. Num a => a -> a -> a
-Int
1
(Forest a
dropped, Forest a
remain) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
childIdx Forest a
children
advanced :: Int
advanced = forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
dropped
ti' :: TreeIter
ti' = TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
ti Int
pos Int
d (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
advancedforall a. Num a => a -> a -> a
+Word32
1)
in if Int
advancedforall a. Ord a => a -> a -> Bool
<Int
childIdx then ((TreeIter
ti',Forest a
remain)forall a. a -> [a] -> [a]
:Cache a
cache) else
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild (Int
posforall a. Num a => a -> a -> a
+Int
d) Depth
ds ((TreeIter
ti',Forest a
remain)forall a. a -> [a] -> [a]
:Cache a
cache)
checkSuccess :: Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess :: forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth TreeIter
iter Cache a
cache = case forall a. Depth -> TreeIter -> Cache a -> Cache a
advanceCache Depth
depth TreeIter
iter Cache a
cache of
cache' :: Cache a
cache'@((TreeIter
cur,Forest a
sibs):Cache a
_) -> (TreeIter -> TreeIter -> Bool
cmp TreeIter
cur TreeIter
iter Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
sibs), Cache a
cache')
[] -> (Bool
False, [])
where
cmp :: TreeIter -> TreeIter -> Bool
cmp (TreeIter CInt
_ Word32
a1 Word32
b1 Word32
c1) (TreeIter CInt
_ Word32
a2 Word32
b2 Word32
c2) =
Word32
a1forall a. Eq a => a -> a -> Bool
==Word32
a2 Bool -> Bool -> Bool
&& Word32
b1forall a. Eq a => a -> a -> Bool
==Word32
b2 Bool -> Bool -> Bool
&& Word32
c2forall a. Eq a => a -> a -> Bool
==Word32
c2
getTreeIterLeaf :: Depth -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf :: Depth -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf Depth
ds TreeIter
ti = Int -> Int -> Depth -> (Int, Int, Int)
gTIL Int
0 Int
0 Depth
ds
where
gTIL :: Int -> Int -> Depth -> (Int, Int, Int)
gTIL Int
pos Int
dCur (Int
dNext:Depth
ds)
| TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
ti (Int
posforall a. Num a => a -> a -> a
+Int
dCur) Int
dNextforall a. Eq a => a -> a -> Bool
==Word32
0 = (Int
pos,Int
dCur,Int
dNext)
| Bool
otherwise = Int -> Int -> Depth -> (Int, Int, Int)
gTIL (Int
posforall a. Num a => a -> a -> a
+Int
dCur) Int
dNext Depth
ds
gTIL Int
pos Int
d [] = (Int
pos, Int
d, Int
0)
iterNext :: Depth -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNext :: forall a. Depth -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNext Depth
depth TreeIter
iter Cache a
cache = let
(Int
pos,Int
leaf,Int
_child) = Depth -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf Depth
depth TreeIter
iter
curIdx :: Word32
curIdx = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
iter Int
pos Int
leaf
nextIdx :: Word32
nextIdx = Word32
curIdxforall a. Num a => a -> a -> a
+Word32
1
nextIter :: TreeIter
nextIter = TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
iter Int
pos Int
leaf Word32
nextIdx
in
if Word32
nextIdxforall a. Eq a => a -> a -> Bool
==forall a. Bits a => Int -> a
bit Int
leaf then (forall a. Maybe a
Nothing, Cache a
cache) else
case forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth TreeIter
nextIter Cache a
cache of
(Bool
True, Cache a
cache) -> (forall a. a -> Maybe a
Just TreeIter
nextIter, Cache a
cache)
(Bool
False, Cache a
cache) -> (forall a. Maybe a
Nothing, Cache a
cache)
iterNthChild :: Depth -> Int -> TreeIter -> Cache a ->
(Maybe TreeIter, Cache a)
iterNthChild :: forall a.
Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNthChild Depth
depth Int
childIdx_ TreeIter
iter Cache a
cache = let
(Int
pos,Int
leaf,Int
child) = Depth -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf Depth
depth TreeIter
iter
childIdx :: Word32
childIdx = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
childIdx_forall a. Num a => a -> a -> a
+Word32
1
nextIter :: TreeIter
nextIter = TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
iter (Int
posforall a. Num a => a -> a -> a
+Int
leaf) Int
child Word32
childIdx
in
if Word32
childIdxforall a. Ord a => a -> a -> Bool
>=forall a. Bits a => Int -> a
bit Int
child then (forall a. Maybe a
Nothing, Cache a
cache) else
case forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth TreeIter
nextIter Cache a
cache of
(Bool
True, Cache a
cache) -> (forall a. a -> Maybe a
Just TreeIter
nextIter, Cache a
cache)
(Bool
False, Cache a
cache) -> (forall a. Maybe a
Nothing, Cache a
cache)
iterNChildren :: Depth -> TreeIter -> Cache a -> (Int, Cache a)
iterNChildren :: forall a. Depth -> TreeIter -> Cache a -> (Int, Cache a)
iterNChildren Depth
depth TreeIter
iter Cache a
cache = case forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth TreeIter
iter Cache a
cache of
(Bool
True, cache :: Cache a
cache@((TreeIter
_,Node { subForest :: forall a. Tree a -> [Tree a]
subForest = Forest a
forest}:Forest a
_):Cache a
_)) -> (forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
forest, Cache a
cache)
(Bool
_, Cache a
cache) -> (Int
0, Cache a
cache)
iterParent :: Depth -> TreeIter -> Maybe TreeIter
iterParent :: Depth -> TreeIter -> Maybe TreeIter
iterParent Depth
depth TreeIter
iter = let
(Int
pos,Int
leaf,Int
_child) = Depth -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf Depth
depth TreeIter
iter
in if Int
posforall a. Eq a => a -> a -> Bool
==Int
0 then forall a. Maybe a
Nothing else
if TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
iter Int
pos Int
leafforall a. Eq a => a -> a -> Bool
==Word32
0 then forall a. Maybe a
Nothing else
forall a. a -> Maybe a
Just (TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
iter Int
pos Int
leaf Word32
0)
treeStoreInsertForest ::
TreeStore a
-> TreePath
-> Int
-> Forest a
-> IO ()
treeStoreInsertForest :: forall a. TreeStore a -> Depth -> Int -> Forest a -> IO ()
treeStoreInsertForest (TreeStore CustomStore (IORef (Store a)) a
model) Depth
path Int
pos Forest a
nodes = do
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters CustomStore (IORef (Store a)) a
model
(Int
idx, Bool
toggle) <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) forall a b. (a -> b) -> a -> b
$
\store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
case forall a.
Forest a -> Forest a -> Depth -> Int -> Maybe (Forest a, Int, Bool)
insertIntoForest (forall a. Cache a -> Forest a
cacheToStore Cache a
cache) Forest a
nodes Depth
path Int
pos of
Maybe (Forest a, Int, Bool)
Nothing -> forall a. (?callStack::CallStack) => [Char] -> a
error ([Char]
"treeStoreInsertForest: path does not exist " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Depth
path)
Just (Forest a
newForest, Int
idx, Bool
toggle) ->
let depth :: Depth
depth = forall a. Forest a -> Depth
calcForestDepth Forest a
newForest
in (Store { depth :: Depth
depth = Depth
depth,
content :: Cache a
content = forall a. Forest a -> Cache a
storeToCache Forest a
newForest },
(Int
idx, Bool
toggle))
Store { depth :: forall a. Store a -> Depth
depth = Depth
depth } <- forall a. IORef a -> IO a
readIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
let rpath :: Depth
rpath = forall a. [a] -> [a]
reverse Depth
path
CInt
stamp <- forall private row. CustomStore private row -> IO CInt
customStoreGetStamp CustomStore (IORef (Store a)) a
model
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let p' :: Depth
p' = forall a. [a] -> [a]
reverse Depth
p
Just TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
depth Depth
p'
in forall self.
TreeModelClass self =>
self -> Depth -> TreeIter -> IO ()
treeModelRowInserted CustomStore (IORef (Store a)) a
model Depth
p' (TreeIter -> CInt -> TreeIter
treeIterSetStamp TreeIter
iter CInt
stamp)
| (Int
i, Tree a
node) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
idx..] Forest a
nodes
, Depth
p <- forall a. Depth -> Tree a -> [Depth]
paths (Int
i forall a. a -> [a] -> [a]
: Depth
rpath) Tree a
node ]
let Just TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
depth Depth
path
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toggle forall a b. (a -> b) -> a -> b
$ forall self.
TreeModelClass self =>
self -> Depth -> TreeIter -> IO ()
treeModelRowHasChildToggled CustomStore (IORef (Store a)) a
model Depth
path
(TreeIter -> CInt -> TreeIter
treeIterSetStamp TreeIter
iter CInt
stamp)
where paths :: TreePath -> Tree a -> [TreePath]
paths :: forall a. Depth -> Tree a -> [Depth]
paths Depth
path Node { subForest :: forall a. Tree a -> [Tree a]
subForest = [Tree a]
ts } =
Depth
path forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ forall a. Depth -> Tree a -> [Depth]
paths (Int
nforall a. a -> [a] -> [a]
:Depth
path) Tree a
t | (Int
n, Tree a
t) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Tree a]
ts ]
treeStoreInsertTree ::
TreeStore a
-> TreePath
-> Int
-> Tree a
-> IO ()
treeStoreInsertTree :: forall a. TreeStore a -> Depth -> Int -> Tree a -> IO ()
treeStoreInsertTree TreeStore a
store Depth
path Int
pos Tree a
node =
forall a. TreeStore a -> Depth -> Int -> Forest a -> IO ()
treeStoreInsertForest TreeStore a
store Depth
path Int
pos [Tree a
node]
treeStoreInsert ::
TreeStore a
-> TreePath
-> Int
-> a
-> IO ()
treeStoreInsert :: forall a. TreeStore a -> Depth -> Int -> a -> IO ()
treeStoreInsert TreeStore a
store Depth
path Int
pos a
node =
forall a. TreeStore a -> Depth -> Int -> Forest a -> IO ()
treeStoreInsertForest TreeStore a
store Depth
path Int
pos [forall a. a -> [Tree a] -> Tree a
Node a
node []]
insertIntoForest :: Forest a -> Forest a -> TreePath -> Int ->
Maybe (Forest a, Int, Bool)
insertIntoForest :: forall a.
Forest a -> Forest a -> Depth -> Int -> Maybe (Forest a, Int, Bool)
insertIntoForest Forest a
forest Forest a
nodes [] Int
pos
| Int
posforall a. Ord a => a -> a -> Bool
<Int
0 = forall a. a -> Maybe a
Just (Forest a
forestforall a. [a] -> [a] -> [a]
++Forest a
nodes, forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
forest, forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
forest)
| Bool
otherwise = forall a. a -> Maybe a
Just (Forest a
prevforall a. [a] -> [a] -> [a]
++Forest a
nodesforall a. [a] -> [a] -> [a]
++Forest a
next, forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
prev, forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
forest)
where (Forest a
prev, Forest a
next) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos Forest a
forest
insertIntoForest Forest a
forest Forest a
nodes (Int
p:Depth
ps) Int
pos = case forall a. Int -> [a] -> ([a], [a])
splitAt Int
p Forest a
forest of
(Forest a
prev, []) -> forall a. Maybe a
Nothing
(Forest a
prev, Node { rootLabel :: forall a. Tree a -> a
rootLabel = a
val,
subForest :: forall a. Tree a -> [Tree a]
subForest = Forest a
for}:Forest a
next) ->
case forall a.
Forest a -> Forest a -> Depth -> Int -> Maybe (Forest a, Int, Bool)
insertIntoForest Forest a
for Forest a
nodes Depth
ps Int
pos of
Maybe (Forest a, Int, Bool)
Nothing -> forall a. Maybe a
Nothing
Just (Forest a
for, Int
pos, Bool
toggle) -> forall a. a -> Maybe a
Just (Forest a
prevforall a. [a] -> [a] -> [a]
++Node { rootLabel :: a
rootLabel = a
val,
subForest :: Forest a
subForest = Forest a
for }forall a. a -> [a] -> [a]
:Forest a
next,
Int
pos, Bool
toggle)
treeStoreRemove :: TreeStore a -> TreePath -> IO Bool
treeStoreRemove :: forall a. TreeStore a -> Depth -> IO Bool
treeStoreRemove (TreeStore CustomStore (IORef (Store a)) a
model) [] = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
treeStoreRemove (TreeStore CustomStore (IORef (Store a)) a
model) Depth
path = do
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters CustomStore (IORef (Store a)) a
model
(Bool
found, Bool
toggle) <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) forall a b. (a -> b) -> a -> b
$
\store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cache a
cache then (Store a
store, (Bool
False, Bool
False)) else
case forall a. Forest a -> Depth -> Maybe (Forest a, Bool)
deleteFromForest (forall a. Cache a -> Forest a
cacheToStore Cache a
cache) Depth
path of
Maybe (Forest a, Bool)
Nothing -> (Store a
store, (Bool
False, Bool
False))
Just (Forest a
newForest, Bool
toggle) ->
(Store { depth :: Depth
depth = Depth
d,
content :: Cache a
content = forall a. Forest a -> Cache a
storeToCache Forest a
newForest }, (Bool
True, Bool
toggle))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
found forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
toggle Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Depth
path)) forall a b. (a -> b) -> a -> b
$ do
Store { depth :: forall a. Store a -> Depth
depth = Depth
depth } <- forall a. IORef a -> IO a
readIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
let parent :: Depth
parent = forall a. [a] -> [a]
init Depth
path
Just TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
depth Depth
parent
forall self.
TreeModelClass self =>
self -> Depth -> TreeIter -> IO ()
treeModelRowHasChildToggled CustomStore (IORef (Store a)) a
model Depth
parent TreeIter
iter
forall self. TreeModelClass self => self -> Depth -> IO ()
treeModelRowDeleted CustomStore (IORef (Store a)) a
model Depth
path
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
found
treeStoreClear :: TreeStore a -> IO ()
treeStoreClear :: forall a. TreeStore a -> IO ()
treeStoreClear (TreeStore CustomStore (IORef (Store a)) a
model) = do
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters CustomStore (IORef (Store a)) a
model
Store { content :: forall a. Store a -> Cache a
content = Cache a
cache } <- forall a. IORef a -> IO a
readIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
let forest :: Forest a
forest = forall a. Cache a -> Forest a
cacheToStore Cache a
cache
forall a. IORef a -> a -> IO ()
writeIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) Store {
depth :: Depth
depth = forall a. Forest a -> Depth
calcForestDepth [],
content :: Cache a
content = forall a. Forest a -> Cache a
storeToCache []
}
let loop :: Int -> IO ()
loop (-1) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop Int
n = forall self. TreeModelClass self => self -> Depth -> IO ()
treeModelRowDeleted CustomStore (IORef (Store a)) a
model [Int
n] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
loop (Int
nforall a. Num a => a -> a -> a
-Int
1)
Int -> IO ()
loop (forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
forest forall a. Num a => a -> a -> a
- Int
1)
deleteFromForest :: Forest a -> TreePath -> Maybe (Forest a, Bool)
deleteFromForest :: forall a. Forest a -> Depth -> Maybe (Forest a, Bool)
deleteFromForest Forest a
forest [] = forall a. a -> Maybe a
Just ([], Bool
False)
deleteFromForest Forest a
forest (Int
p:Depth
ps) =
case forall a. Int -> [a] -> ([a], [a])
splitAt Int
p Forest a
forest of
(Forest a
prev, kill :: Tree a
kill@Node { rootLabel :: forall a. Tree a -> a
rootLabel = a
val,
subForest :: forall a. Tree a -> [Tree a]
subForest = Forest a
for}:Forest a
next) ->
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Depth
ps then forall a. a -> Maybe a
Just (Forest a
prevforall a. [a] -> [a] -> [a]
++Forest a
next, forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
prev Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
next) else
case forall a. Forest a -> Depth -> Maybe (Forest a, Bool)
deleteFromForest Forest a
for Depth
ps of
Maybe (Forest a, Bool)
Nothing -> forall a. Maybe a
Nothing
Just (Forest a
for,Bool
toggle) -> forall a. a -> Maybe a
Just (Forest a
prevforall a. [a] -> [a] -> [a]
++Node {rootLabel :: a
rootLabel = a
val,
subForest :: Forest a
subForest = Forest a
for }forall a. a -> [a] -> [a]
:Forest a
next, Bool
toggle)
(Forest a
prev, []) -> forall a. Maybe a
Nothing
treeStoreSetValue :: TreeStore a -> TreePath -> a -> IO ()
treeStoreSetValue :: forall a. TreeStore a -> Depth -> a -> IO ()
treeStoreSetValue TreeStore a
store Depth
path a
value = forall a. TreeStore a -> Depth -> (a -> IO a) -> IO Bool
treeStoreChangeM TreeStore a
store Depth
path (\a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return a
value)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
treeStoreChange :: TreeStore a -> TreePath -> (a -> a) -> IO Bool
treeStoreChange :: forall a. TreeStore a -> Depth -> (a -> a) -> IO Bool
treeStoreChange TreeStore a
store Depth
path a -> a
func = forall a. TreeStore a -> Depth -> (a -> IO a) -> IO Bool
treeStoreChangeM TreeStore a
store Depth
path (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
func)
treeStoreChangeM :: TreeStore a -> TreePath -> (a -> IO a) -> IO Bool
treeStoreChangeM :: forall a. TreeStore a -> Depth -> (a -> IO a) -> IO Bool
treeStoreChangeM (TreeStore CustomStore (IORef (Store a)) a
model) Depth
path a -> IO a
act = do
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters CustomStore (IORef (Store a)) a
model
store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } <-
forall a. IORef a -> IO a
readIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
(store' :: Store a
store'@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache }, Bool
found) <- do
Maybe (Forest a)
mRes <- forall a. Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
changeForest (forall a. Cache a -> Forest a
cacheToStore Cache a
cache) a -> IO a
act Depth
path
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe (Forest a)
mRes of
Maybe (Forest a)
Nothing -> (Store a
store, Bool
False)
Just Forest a
newForest -> (Store { depth :: Depth
depth = Depth
d,
content :: Cache a
content = forall a. Forest a -> Cache a
storeToCache Forest a
newForest }, Bool
True)
forall a. IORef a -> a -> IO ()
writeIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) Store a
store'
let Just TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
d Depth
path
CInt
stamp <- forall private row. CustomStore private row -> IO CInt
customStoreGetStamp CustomStore (IORef (Store a)) a
model
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
found forall a b. (a -> b) -> a -> b
$ forall self.
TreeModelClass self =>
self -> Depth -> TreeIter -> IO ()
treeModelRowChanged CustomStore (IORef (Store a)) a
model Depth
path (TreeIter -> CInt -> TreeIter
treeIterSetStamp TreeIter
iter CInt
stamp)
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
found
changeForest :: Forest a -> (a -> IO a) -> TreePath -> IO (Maybe (Forest a))
changeForest :: forall a. Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
changeForest Forest a
forest a -> IO a
act [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
changeForest Forest a
forest a -> IO a
act (Int
p:Depth
ps) = case forall a. Int -> [a] -> ([a], [a])
splitAt Int
p Forest a
forest of
(Forest a
prev, []) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
(Forest a
prev, Node { rootLabel :: forall a. Tree a -> a
rootLabel = a
val,
subForest :: forall a. Tree a -> [Tree a]
subForest = Forest a
for}:Forest a
next) ->
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Depth
ps then do
a
val' <- a -> IO a
act a
val
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (Forest a
prevforall a. [a] -> [a] -> [a]
++Node { rootLabel :: a
rootLabel = a
val',
subForest :: Forest a
subForest = Forest a
for }forall a. a -> [a] -> [a]
:Forest a
next))
else do
Maybe (Forest a)
mFor <- forall a. Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
changeForest Forest a
for a -> IO a
act Depth
ps
case Maybe (Forest a)
mFor of
Maybe (Forest a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Forest a
for -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Forest a
prevforall a. [a] -> [a] -> [a]
++Node { rootLabel :: a
rootLabel = a
val,
subForest :: Forest a
subForest = Forest a
for }forall a. a -> [a] -> [a]
:Forest a
next)
treeStoreGetValue :: TreeStore a -> TreePath -> IO a
treeStoreGetValue :: forall a. TreeStore a -> Depth -> IO a
treeStoreGetValue TreeStore a
model Depth
path = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Tree a -> a
rootLabel (forall a. TreeStore a -> Depth -> IO (Tree a)
treeStoreGetTree TreeStore a
model Depth
path)
treeStoreGetTree :: TreeStore a -> TreePath -> IO (Tree a)
treeStoreGetTree :: forall a. TreeStore a -> Depth -> IO (Tree a)
treeStoreGetTree (TreeStore CustomStore (IORef (Store a)) a
model) Depth
path = do
store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } <-
forall a. IORef a -> IO a
readIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
case Depth -> Depth -> Maybe TreeIter
fromPath Depth
d Depth
path of
(Just TreeIter
iter) -> do
let (Bool
res, Cache a
cache') = forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d TreeIter
iter Cache a
cache
forall a. IORef a -> a -> IO ()
writeIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) Store a
store { content :: Cache a
content = Cache a
cache' }
case Cache a
cache' of
((TreeIter
_,Tree a
node:Forest a
_):Cache a
_) | Bool
res -> forall (m :: * -> *) a. Monad m => a -> m a
return Tree a
node
Cache a
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"treeStoreGetTree: path does not exist " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Depth
path)
Maybe TreeIter
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"treeStoreGetTree: path does not exist " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Depth
path)
treeStoreLookup :: TreeStore a -> TreePath -> IO (Maybe (Tree a))
treeStoreLookup :: forall a. TreeStore a -> Depth -> IO (Maybe (Tree a))
treeStoreLookup (TreeStore CustomStore (IORef (Store a)) a
model) Depth
path = do
store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } <-
forall a. IORef a -> IO a
readIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
case Depth -> Depth -> Maybe TreeIter
fromPath Depth
d Depth
path of
(Just TreeIter
iter) -> do
let (Bool
res, Cache a
cache') = forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d TreeIter
iter Cache a
cache
forall a. IORef a -> a -> IO ()
writeIORef (forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) Store a
store { content :: Cache a
content = Cache a
cache' }
case Cache a
cache' of
((TreeIter
_,Tree a
node:Forest a
_):Cache a
_) | Bool
res -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Tree a
node)
Cache a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Maybe TreeIter
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing