{-# 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) = CustomStore (IORef (Store a)) a -> GObject
forall o. GObjectClass o => o -> GObject
toGObject CustomStore (IORef (Store a)) a
tm
unsafeCastGObject :: GObject -> TreeStore a
unsafeCastGObject = CustomStore (IORef (Store a)) a -> TreeStore a
forall a. CustomStore (IORef (Store a)) a -> TreeStore a
TreeStore (CustomStore (IORef (Store a)) a -> TreeStore a)
-> (GObject -> CustomStore (IORef (Store a)) a)
-> GObject
-> TreeStore a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GObject -> CustomStore (IORef (Store a)) a
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 = Forest a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
forall a.
Forest a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
treeStoreNewDND Forest a
forest
(DragSourceIface TreeStore a -> Maybe (DragSourceIface TreeStore a)
forall a. a -> Maybe a
Just DragSourceIface TreeStore a
forall row. DragSourceIface TreeStore row
treeStoreDefaultDragSourceIface)
(DragDestIface TreeStore a -> Maybe (DragDestIface TreeStore a)
forall a. a -> Maybe a
Just DragDestIface TreeStore a
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 <- Store a -> IO (IORef (Store a))
forall a. a -> IO (IORef a)
newIORef Store :: forall a. Depth -> Cache a -> Store a
Store {
depth :: Depth
depth = Forest a -> Depth
forall a. Forest a -> Depth
calcForestDepth Forest a
forest,
content :: Cache a
content = Forest a -> Cache a
forall a. Forest a -> Cache a
storeToCache Forest a
forest
}
let withStore :: (Store a -> b) -> IO b
withStore Store a -> b
f = IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef IORef (Store a)
storeRef IO (Store a) -> (Store a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> (Store a -> b) -> Store a -> IO b
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 <- IORef (Store a) -> IO (Store a)
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
IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Store a)
storeRef Store a
store { content :: Cache a
content = Cache a
cache' }
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
result
IORef (Store a)
-> (CustomStore (IORef (Store a)) a -> TreeStore a)
-> TreeModelIface a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
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 CustomStore (IORef (Store a)) a -> TreeStore a
forall a. CustomStore (IORef (Store a)) a -> TreeStore a
TreeStore TreeModelIface :: forall row.
IO [TreeModelFlags]
-> (Depth -> IO (Maybe TreeIter))
-> (TreeIter -> IO Depth)
-> (TreeIter -> IO row)
-> (TreeIter -> IO (Maybe TreeIter))
-> (Maybe TreeIter -> IO (Maybe TreeIter))
-> (TreeIter -> IO Bool)
-> (Maybe TreeIter -> IO Int)
-> (Maybe TreeIter -> Int -> IO (Maybe TreeIter))
-> (TreeIter -> IO (Maybe TreeIter))
-> (TreeIter -> IO ())
-> (TreeIter -> IO ())
-> TreeModelIface row
TreeModelIface {
treeModelIfaceGetFlags :: IO [TreeModelFlags]
treeModelIfaceGetFlags = [TreeModelFlags] -> IO [TreeModelFlags]
forall (m :: * -> *) a. Monad m => a -> m a
return [],
treeModelIfaceGetIter :: Depth -> IO (Maybe TreeIter)
treeModelIfaceGetIter = \Depth
path -> (Store a -> Maybe TreeIter) -> IO (Maybe TreeIter)
forall {b}. (Store a -> b) -> IO b
withStore ((Store a -> Maybe TreeIter) -> IO (Maybe TreeIter))
-> (Store a -> Maybe TreeIter) -> IO (Maybe TreeIter)
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 -> (Store a -> Depth) -> IO Depth
forall {b}. (Store a -> b) -> IO b
withStore ((Store a -> Depth) -> IO Depth) -> (Store a -> Depth) -> IO Depth
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 -> (Store a -> (a, Cache a)) -> IO a
forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (a, Cache a)) -> IO a)
-> (Store a -> (a, Cache a)) -> IO a
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 Depth -> TreeIter -> Cache a -> (Bool, Cache a)
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)
_ -> [Char] -> (a, 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 -> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter))
-> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
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 } -> Depth -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
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 -> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter))
-> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
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 = TreeIter -> Maybe TreeIter -> TreeIter
forall a. a -> Maybe a -> a
fromMaybe TreeIter
invalidIter Maybe TreeIter
mIter
in Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
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 -> (Store a -> (Bool, Cache a)) -> IO Bool
forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Bool, Cache a)) -> IO Bool)
-> (Store a -> (Bool, Cache a)) -> IO Bool
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') = Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
forall a.
Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNthChild Depth
d Int
0 TreeIter
iter Cache a
cache
in (Maybe TreeIter -> Bool
forall a. Maybe a -> Bool
isJust Maybe TreeIter
mIter, Cache a
cache'),
treeModelIfaceIterNChildren :: Maybe TreeIter -> IO Int
treeModelIfaceIterNChildren = \Maybe TreeIter
mIter -> (Store a -> (Int, Cache a)) -> IO Int
forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Int, Cache a)) -> IO Int)
-> (Store a -> (Int, Cache a)) -> IO Int
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 = TreeIter -> Maybe TreeIter -> TreeIter
forall a. a -> Maybe a -> a
fromMaybe TreeIter
invalidIter Maybe TreeIter
mIter
in Depth -> TreeIter -> Cache a -> (Int, Cache a)
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 -> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
forall {b}. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter))
-> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
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 = TreeIter -> Maybe TreeIter -> TreeIter
forall a. a -> Maybe a -> a
fromMaybe TreeIter
invalidIter Maybe TreeIter
mIter
in Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
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 -> (Store a -> Maybe TreeIter) -> IO (Maybe TreeIter)
forall {b}. (Store a -> b) -> IO b
withStore ((Store a -> Maybe TreeIter) -> IO (Maybe TreeIter))
-> (Store a -> Maybe TreeIter) -> IO (Maybe TreeIter)
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
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
treeModelIfaceUnrefNode :: TreeIter -> IO ()
treeModelIfaceUnrefNode = \TreeIter
_ -> () -> IO ()
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 :: forall (model :: * -> *) row.
(model row -> Depth -> IO Bool)
-> (model row -> Depth -> SelectionDataM Bool)
-> (model row -> Depth -> IO Bool)
-> DragSourceIface model row
DragSourceIface {
treeDragSourceRowDraggable :: TreeStore row -> Depth -> IO Bool
treeDragSourceRowDraggable = \TreeStore row
_ Depth
_-> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True,
treeDragSourceDragDataGet :: TreeStore row -> Depth -> SelectionDataM Bool
treeDragSourceDragDataGet = TreeStore row -> Depth -> SelectionDataM Bool
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
IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TreeStore row -> Depth -> IO Bool
forall a. TreeStore a -> Depth -> IO Bool
treeStoreRemove TreeStore row
model Depth
dest
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
}
treeStoreDefaultDragDestIface :: DragDestIface TreeStore row
treeStoreDefaultDragDestIface :: forall row. DragDestIface TreeStore row
treeStoreDefaultDragDestIface = DragDestIface :: forall (model :: * -> *) row.
(model row -> Depth -> SelectionDataM Bool)
-> (model row -> Depth -> SelectionDataM Bool)
-> DragDestIface model row
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 -> Bool -> SelectionDataM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just (TreeModel
model', Depth
source) -> Bool -> SelectionDataM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeStore row -> TreeModel
forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeStore row
modelTreeModel -> TreeModel -> Bool
forall a. Eq a => a -> a -> Bool
==TreeModel -> TreeModel
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 -> Bool -> SelectionDataM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Just (TreeModel
model', source :: Depth
source@(Int
_:Depth
_)) ->
if TreeStore row -> TreeModel
forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeStore row
modelTreeModel -> TreeModel -> Bool
forall a. Eq a => a -> a -> Bool
/=TreeModel -> TreeModel
forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeModel
model' then Bool -> SelectionDataM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
else IO Bool -> SelectionDataM Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> SelectionDataM Bool) -> IO Bool -> SelectionDataM Bool
forall a b. (a -> b) -> a -> b
$ do
Tree row
row <- TreeStore row -> Depth -> IO (Tree row)
forall a. TreeStore a -> Depth -> IO (Tree a)
treeStoreGetTree TreeStore row
model Depth
source
TreeStore row -> Depth -> Int -> Tree row -> IO ()
forall a. TreeStore a -> Depth -> Int -> Tree a -> IO ()
treeStoreInsertTree TreeStore row
model (Depth -> Depth
forall a. [a] -> [a]
init Depth
dest) (Depth -> Int
forall a. [a] -> a
last Depth
dest) Tree row
row
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
}
bitsNeeded :: Word32 -> Int
bitsNeeded :: Word32 -> Int
bitsNeeded Word32
n = Int -> Word32 -> Int
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
bt -> t -> t
forall a. Num a => a -> a -> a
+t
1) (t
n t -> Int -> t
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
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Int -> Word32
getBitSliceWord Word32
b (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
32) Int
count
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Int -> Word32
getBitSliceWord Word32
c (Int
offInt -> Int -> Int
forall 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 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shift` (-Int
off) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. (Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
count Word32 -> Word32 -> Word32
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 =
Bool -> TreeIter -> TreeIter
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Word32
value Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
count) (TreeIter -> TreeIter) -> TreeIter -> TreeIter
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
offInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
32) Int
count Word32
value)
(Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord Word32
c (Int
offInt -> Int -> Int
forall 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 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
count Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shift` Int
off
in (Word32
word Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
mask) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
value Word32 -> Int -> Word32
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 = (Word32 -> Int) -> [Word32] -> Depth
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> Int
bitsNeeded ([Word32] -> Depth) -> [Word32] -> Depth
forall a b. (a -> b) -> a -> b
$
(Word32 -> Bool) -> [Word32] -> [Word32]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word32
0) ([Word32] -> [Word32]) -> [Word32] -> [Word32]
forall a b. (a -> b) -> a -> b
$
(Tree a -> [Word32] -> [Word32])
-> [Word32] -> Forest a -> [Word32]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree a -> [Word32] -> [Word32]
forall {c} {a}. (Num c, Ord c) => Tree a -> [c] -> [c]
calcTreeDepth (Word32 -> [Word32]
forall a. a -> [a]
repeat Word32
0) Forest a
f
where
calcTreeDepth :: Tree a -> [c] -> [c]
calcTreeDepth Node { subForest :: forall a. Tree a -> [Tree a]
subForest = [Tree a]
f } (c
d:[c]
ds) =
(c
dc -> c -> c
forall a. Num a => a -> a -> a
+c
1)c -> [c] -> [c]
forall a. a -> [a] -> [a]
: (c -> c -> c) -> [c] -> [c] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith c -> c -> c
forall a. Ord a => a -> a -> a
max [c]
ds ((Tree a -> [c] -> [c]) -> [c] -> [Tree a] -> [c]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Tree a -> [c] -> [c]
calcTreeDepth (c -> [c]
forall a. a -> [a]
repeat c
0) [Tree a]
f)
toPath :: Depth -> TreeIter -> TreePath
toPath :: Depth -> TreeIter -> Depth
toPath Depth
d TreeIter
iter = Int -> Depth -> Depth
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
idxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
0 then [] else Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
idxWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
1) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> Depth -> [a]
gP (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Depth
ds
fromPath :: Depth -> TreePath -> Maybe TreeIter
fromPath :: Depth -> Depth -> Maybe TreeIter
fromPath = Int -> TreeIter -> Depth -> Depth -> Maybe TreeIter
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
_ [] = TreeIter -> Maybe TreeIter
forall a. a -> Maybe a
Just TreeIter
ti
fP Int
pos TreeIter
ti [] [a]
_ = Maybe TreeIter
forall a. Maybe a
Nothing
fP Int
pos TreeIter
ti (Int
d:Depth
ds) (a
p:[a]
ps) = let idx :: Word32
idx = a -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a
pa -> a -> a
forall a. Num a => a -> a -> a
+a
1) in
if Word32
idx Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int -> Word32
forall a. Bits a => Int -> a
bit Int
d then Maybe TreeIter
forall a. Maybe a
Nothing else
Int -> TreeIter -> Depth -> [a] -> Maybe TreeIter
fP (Int
posInt -> Int -> Int
forall 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, [a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
forall {a}. a
root [Tree a]
forest])]
where
root :: a
root = [Char] -> a
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 [(TreeIter, Forest a)] -> (TreeIter, Forest a)
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
dWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/=Word32
0
in
if Word32
goalIdxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
curIdx then Int -> Depth -> [(TreeIter, Forest a)]
moveToSameLevel (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Depth
ds else
if Word32
goalIdxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
0 then ((TreeIter, Forest a) -> Bool)
-> [(TreeIter, Forest a)] -> [(TreeIter, Forest a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> (TreeIter, Forest a) -> Bool
forall {b}. Int -> Int -> (TreeIter, b) -> Bool
isNonZero Int
pos Int
d) [(TreeIter, Forest a)]
cache else
if Word32
curIdxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
0 then Int -> Depth -> [(TreeIter, Forest a)] -> [(TreeIter, Forest a)]
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild Int
pos (Int
dInt -> Depth -> Depth
forall a. a -> [a] -> [a]
:Depth
ds) [(TreeIter, Forest a)]
cache else
if Word32
goalIdxWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<Word32
curIdx then
Int -> Depth -> [(TreeIter, Forest a)] -> [(TreeIter, Forest a)]
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild Int
pos (Int
dInt -> Depth -> Depth
forall a. a -> [a] -> [a]
:Depth
ds) (((TreeIter, Forest a) -> Bool)
-> [(TreeIter, Forest a)] -> [(TreeIter, Forest a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> (TreeIter, Forest a) -> Bool
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 = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
goalIdxWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
curIdx)
([Tree a]
dropped, [Tree a]
remain) = Int -> [Tree a] -> ([Tree a], [Tree a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
diff [Tree a]
forest
advance :: Int
advance = [Tree a] -> Int
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
curIdxWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
advance)
in
if Int
advanceInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
diff then Int -> Depth -> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Depth
ds ((TreeIter
ti',[Tree a]
remain)(TreeIter, [Tree a])
-> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
forall a. a -> [a] -> [a]
:[(TreeIter, [Tree a])]
parents)
else (TreeIter
ti',[Tree a]
remain)(TreeIter, [Tree a])
-> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
forall a. a -> [a] -> [a]
:[(TreeIter, [Tree a])]
parents
in Int -> Int -> [(TreeIter, Forest a)] -> [(TreeIter, Forest a)]
forall {a}.
Int -> Int -> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
moveWithinLevel Int
pos Int
d ([(TreeIter, Forest a)] -> [(TreeIter, Forest a)])
-> [(TreeIter, Forest a)] -> [(TreeIter, Forest a)]
forall a b. (a -> b) -> a -> b
$ case Depth
ds of
[] -> [(TreeIter, Forest a)]
cache
(Int
d':Depth
_) -> ((TreeIter, Forest a) -> Bool)
-> [(TreeIter, Forest a)] -> [(TreeIter, Forest a)]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> (TreeIter, Forest a) -> Bool
forall {b}. Int -> Int -> (TreeIter, b) -> Bool
isNonZero (Int
posInt -> Int -> Int
forall 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 Word32 -> Word32 -> Bool
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 = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
goal Int
pos Int
d)Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
(Forest a
dropped, Forest a
remain) = Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
childIdx Forest a
children
advanced :: Int
advanced = Forest a -> Int
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 (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
advancedWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1)
in if Int
advancedInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
childIdx then ((TreeIter
ti',Forest a
remain)(TreeIter, Forest a) -> Cache a -> Cache a
forall a. a -> [a] -> [a]
:Cache a
cache) else
Int -> Depth -> Cache a -> Cache a
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Depth
ds ((TreeIter
ti',Forest a
remain)(TreeIter, Forest a) -> Cache a -> Cache a
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 Depth -> TreeIter -> Cache a -> Cache a
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 (Forest a -> Bool
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
a1Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
a2 Bool -> Bool -> Bool
&& Word32
b1Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
b2 Bool -> Bool -> Bool
&& Word32
c2Word32 -> Word32 -> Bool
forall 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
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
dCur) Int
dNextWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
0 = (Int
pos,Int
dCur,Int
dNext)
| Bool
otherwise = Int -> Int -> Depth -> (Int, Int, Int)
gTIL (Int
posInt -> Int -> Int
forall 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
curIdxWord32 -> Word32 -> Word32
forall 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
nextIdxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Int -> Word32
forall a. Bits a => Int -> a
bit Int
leaf then (Maybe TreeIter
forall a. Maybe a
Nothing, Cache a
cache) else
case Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth TreeIter
nextIter Cache a
cache of
(Bool
True, Cache a
cache) -> (TreeIter -> Maybe TreeIter
forall a. a -> Maybe a
Just TreeIter
nextIter, Cache a
cache)
(Bool
False, Cache a
cache) -> (Maybe TreeIter
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 = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
childIdx_Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Word32
1
nextIter :: TreeIter
nextIter = TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
iter (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
leaf) Int
child Word32
childIdx
in
if Word32
childIdxWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>=Int -> Word32
forall a. Bits a => Int -> a
bit Int
child then (Maybe TreeIter
forall a. Maybe a
Nothing, Cache a
cache) else
case Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth TreeIter
nextIter Cache a
cache of
(Bool
True, Cache a
cache) -> (TreeIter -> Maybe TreeIter
forall a. a -> Maybe a
Just TreeIter
nextIter, Cache a
cache)
(Bool
False, Cache a
cache) -> (Maybe TreeIter
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 Depth -> TreeIter -> Cache a -> (Bool, Cache a)
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
_)) -> (Forest a -> Int
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
posInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 then Maybe TreeIter
forall a. Maybe a
Nothing else
if TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
iter Int
pos Int
leafWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
0 then Maybe TreeIter
forall a. Maybe a
Nothing else
TreeIter -> Maybe TreeIter
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
CustomStore (IORef (Store a)) a -> IO ()
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters CustomStore (IORef (Store a)) a
model
(Int
idx, Bool
toggle) <- IORef (Store a)
-> (Store a -> (Store a, (Int, Bool))) -> IO (Int, Bool)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) ((Store a -> (Store a, (Int, Bool))) -> IO (Int, Bool))
-> (Store a -> (Store a, (Int, Bool))) -> IO (Int, Bool)
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 Forest a -> Forest a -> Depth -> Int -> Maybe (Forest a, Int, Bool)
forall a.
Forest a -> Forest a -> Depth -> Int -> Maybe (Forest a, Int, Bool)
insertIntoForest (Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache) Forest a
nodes Depth
path Int
pos of
Maybe (Forest a, Int, Bool)
Nothing -> [Char] -> (Store a, (Int, Bool))
forall a. (?callStack::CallStack) => [Char] -> a
error ([Char]
"treeStoreInsertForest: path does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Depth -> [Char]
forall a. Show a => a -> [Char]
show Depth
path)
Just (Forest a
newForest, Int
idx, Bool
toggle) ->
let depth :: Depth
depth = Forest a -> Depth
forall a. Forest a -> Depth
calcForestDepth Forest a
newForest
in (Store :: forall a. Depth -> Cache a -> Store a
Store { depth :: Depth
depth = Depth
depth,
content :: Cache a
content = Forest a -> Cache a
forall a. Forest a -> Cache a
storeToCache Forest a
newForest },
(Int
idx, Bool
toggle))
Store { depth :: forall a. Store a -> Depth
depth = Depth
depth } <- IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
let rpath :: Depth
rpath = Depth -> Depth
forall a. [a] -> [a]
reverse Depth
path
CInt
stamp <- CustomStore (IORef (Store a)) a -> IO CInt
forall private row. CustomStore private row -> IO CInt
customStoreGetStamp CustomStore (IORef (Store a)) a
model
[IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let p' :: Depth
p' = Depth -> Depth
forall a. [a] -> [a]
reverse Depth
p
Just TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
depth Depth
p'
in CustomStore (IORef (Store a)) a -> Depth -> TreeIter -> IO ()
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) <- Depth -> Forest a -> [(Int, Tree a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
idx..] Forest a
nodes
, Depth
p <- Depth -> Tree a -> [Depth]
forall a. Depth -> Tree a -> [Depth]
paths (Int
i Int -> Depth -> Depth
forall a. a -> [a] -> [a]
: Depth
rpath) Tree a
node ]
let Just TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
depth Depth
path
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toggle (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CustomStore (IORef (Store a)) a -> Depth -> TreeIter -> IO ()
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 Depth -> [Depth] -> [Depth]
forall a. a -> [a] -> [a]
: [[Depth]] -> [Depth]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Depth -> Tree a -> [Depth]
forall a. Depth -> Tree a -> [Depth]
paths (Int
nInt -> Depth -> Depth
forall a. a -> [a] -> [a]
:Depth
path) Tree a
t | (Int
n, Tree a
t) <- Depth -> [Tree a] -> [(Int, Tree a)]
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 =
TreeStore a -> Depth -> Int -> Forest a -> IO ()
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 =
TreeStore a -> Depth -> Int -> Forest a -> IO ()
forall a. TreeStore a -> Depth -> Int -> Forest a -> IO ()
treeStoreInsertForest TreeStore a
store Depth
path Int
pos [a -> Forest a -> Tree a
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
posInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0 = (Forest a, Int, Bool) -> Maybe (Forest a, Int, Bool)
forall a. a -> Maybe a
Just (Forest a
forestForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Forest a
nodes, Forest a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
forest, Forest a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
forest)
| Bool
otherwise = (Forest a, Int, Bool) -> Maybe (Forest a, Int, Bool)
forall a. a -> Maybe a
Just (Forest a
prevForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Forest a
nodesForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Forest a
next, Forest a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
prev, Forest a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
forest)
where (Forest a
prev, Forest a
next) = Int -> Forest a -> (Forest a, Forest a)
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 Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
p Forest a
forest of
(Forest a
prev, []) -> Maybe (Forest a, Int, Bool)
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 Forest a -> Forest a -> Depth -> Int -> Maybe (Forest a, Int, Bool)
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 -> Maybe (Forest a, Int, Bool)
forall a. Maybe a
Nothing
Just (Forest a
for, Int
pos, Bool
toggle) -> (Forest a, Int, Bool) -> Maybe (Forest a, Int, Bool)
forall a. a -> Maybe a
Just (Forest a
prevForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Node :: forall a. a -> [Tree a] -> Tree a
Node { rootLabel :: a
rootLabel = a
val,
subForest :: Forest a
subForest = Forest a
for }Tree a -> Forest a -> Forest a
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) [] = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
treeStoreRemove (TreeStore CustomStore (IORef (Store a)) a
model) Depth
path = do
CustomStore (IORef (Store a)) a -> IO ()
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters CustomStore (IORef (Store a)) a
model
(Bool
found, Bool
toggle) <- IORef (Store a)
-> (Store a -> (Store a, (Bool, Bool))) -> IO (Bool, Bool)
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) ((Store a -> (Store a, (Bool, Bool))) -> IO (Bool, Bool))
-> (Store a -> (Store a, (Bool, Bool))) -> IO (Bool, Bool)
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 Cache a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cache a
cache then (Store a
store, (Bool
False, Bool
False)) else
case Forest a -> Depth -> Maybe (Forest a, Bool)
forall a. Forest a -> Depth -> Maybe (Forest a, Bool)
deleteFromForest (Cache a -> Forest a
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 :: forall a. Depth -> Cache a -> Store a
Store { depth :: Depth
depth = Depth
d,
content :: Cache a
content = Forest a -> Cache a
forall a. Forest a -> Cache a
storeToCache Forest a
newForest }, (Bool
True, Bool
toggle))
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
found (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
toggle Bool -> Bool -> Bool
&& Bool -> Bool
not (Depth -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Depth
path)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Store { depth :: forall a. Store a -> Depth
depth = Depth
depth } <- IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
let parent :: Depth
parent = Depth -> Depth
forall a. [a] -> [a]
init Depth
path
Just TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
depth Depth
parent
CustomStore (IORef (Store a)) a -> Depth -> TreeIter -> IO ()
forall self.
TreeModelClass self =>
self -> Depth -> TreeIter -> IO ()
treeModelRowHasChildToggled CustomStore (IORef (Store a)) a
model Depth
parent TreeIter
iter
CustomStore (IORef (Store a)) a -> Depth -> IO ()
forall self. TreeModelClass self => self -> Depth -> IO ()
treeModelRowDeleted CustomStore (IORef (Store a)) a
model Depth
path
Bool -> IO Bool
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
CustomStore (IORef (Store a)) a -> IO ()
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 } <- IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
let forest :: Forest a
forest = Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache
IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) Store :: forall a. Depth -> Cache a -> Store a
Store {
depth :: Depth
depth = Forest Any -> Depth
forall a. Forest a -> Depth
calcForestDepth [],
content :: Cache a
content = Forest a -> Cache a
forall a. Forest a -> Cache a
storeToCache []
}
let loop :: Int -> IO ()
loop (-1) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop Int
n = CustomStore (IORef (Store a)) a -> Depth -> IO ()
forall self. TreeModelClass self => self -> Depth -> IO ()
treeModelRowDeleted CustomStore (IORef (Store a)) a
model [Int
n] IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
loop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
Int -> IO ()
loop (Forest a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
forest Int -> Int -> Int
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 [] = (Forest a, Bool) -> Maybe (Forest a, Bool)
forall a. a -> Maybe a
Just ([], Bool
False)
deleteFromForest Forest a
forest (Int
p:Depth
ps) =
case Int -> Forest a -> (Forest a, Forest a)
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 Depth -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Depth
ps then (Forest a, Bool) -> Maybe (Forest a, Bool)
forall a. a -> Maybe a
Just (Forest a
prevForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Forest a
next, Forest a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
prev Bool -> Bool -> Bool
&& Forest a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
next) else
case Forest a -> Depth -> Maybe (Forest a, Bool)
forall a. Forest a -> Depth -> Maybe (Forest a, Bool)
deleteFromForest Forest a
for Depth
ps of
Maybe (Forest a, Bool)
Nothing -> Maybe (Forest a, Bool)
forall a. Maybe a
Nothing
Just (Forest a
for,Bool
toggle) -> (Forest a, Bool) -> Maybe (Forest a, Bool)
forall a. a -> Maybe a
Just (Forest a
prevForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Node :: forall a. a -> [Tree a] -> Tree a
Node {rootLabel :: a
rootLabel = a
val,
subForest :: Forest a
subForest = Forest a
for }Tree a -> Forest a -> Forest a
forall a. a -> [a] -> [a]
:Forest a
next, Bool
toggle)
(Forest a
prev, []) -> Maybe (Forest a, Bool)
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 = TreeStore a -> Depth -> (a -> IO a) -> IO Bool
forall a. TreeStore a -> Depth -> (a -> IO a) -> IO Bool
treeStoreChangeM TreeStore a
store Depth
path (\a
_ -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value)
IO Bool -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
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 = TreeStore a -> Depth -> (a -> IO a) -> IO Bool
forall a. TreeStore a -> Depth -> (a -> IO a) -> IO Bool
treeStoreChangeM TreeStore a
store Depth
path (a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> (a -> a) -> a -> IO a
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
CustomStore (IORef (Store a)) a -> IO ()
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 } <-
IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
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 <- Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
forall a. Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
changeForest (Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache) a -> IO a
act Depth
path
(Store a, Bool) -> IO (Store a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Store a, Bool) -> IO (Store a, Bool))
-> (Store a, Bool) -> IO (Store a, Bool)
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 :: forall a. Depth -> Cache a -> Store a
Store { depth :: Depth
depth = Depth
d,
content :: Cache a
content = Forest a -> Cache a
forall a. Forest a -> Cache a
storeToCache Forest a
newForest }, Bool
True)
IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
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 <- CustomStore (IORef (Store a)) a -> IO CInt
forall private row. CustomStore private row -> IO CInt
customStoreGetStamp CustomStore (IORef (Store a)) a
model
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
found (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CustomStore (IORef (Store a)) a -> Depth -> TreeIter -> IO ()
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)
Bool -> IO Bool
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 [] = Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Forest a)
forall a. Maybe a
Nothing
changeForest Forest a
forest a -> IO a
act (Int
p:Depth
ps) = case Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
p Forest a
forest of
(Forest a
prev, []) -> Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Forest a)
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 Depth -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Depth
ps then do
a
val' <- a -> IO a
act a
val
Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Forest a -> Maybe (Forest a)
forall a. a -> Maybe a
Just (Forest a
prevForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Node :: forall a. a -> [Tree a] -> Tree a
Node { rootLabel :: a
rootLabel = a
val',
subForest :: Forest a
subForest = Forest a
for }Tree a -> Forest a -> Forest a
forall a. a -> [a] -> [a]
:Forest a
next))
else do
Maybe (Forest a)
mFor <- Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
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 -> Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Forest a)
forall a. Maybe a
Nothing
Just Forest a
for -> Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Forest a) -> IO (Maybe (Forest a)))
-> Maybe (Forest a) -> IO (Maybe (Forest a))
forall a b. (a -> b) -> a -> b
$ Forest a -> Maybe (Forest a)
forall a. a -> Maybe a
Just (Forest a
prevForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Node :: forall a. a -> [Tree a] -> Tree a
Node { rootLabel :: a
rootLabel = a
val,
subForest :: Forest a
subForest = Forest a
for }Tree a -> Forest a -> Forest a
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 = (Tree a -> a) -> IO (Tree a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree a -> a
forall a. Tree a -> a
rootLabel (TreeStore a -> Depth -> IO (Tree a)
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 } <-
IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
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') = Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d TreeIter
iter Cache a
cache
IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
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 -> Tree a -> IO (Tree a)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree a
node
Cache a
_ -> [Char] -> IO (Tree a)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"treeStoreGetTree: path does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Depth -> [Char]
forall a. Show a => a -> [Char]
show Depth
path)
Maybe TreeIter
_ -> [Char] -> IO (Tree a)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"treeStoreGetTree: path does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Depth -> [Char]
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 } <-
IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
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') = Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d TreeIter
iter Cache a
cache
IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
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 -> Maybe (Tree a) -> IO (Maybe (Tree a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Tree a -> Maybe (Tree a)
forall a. a -> Maybe a
Just Tree a
node)
Cache a
_ -> Maybe (Tree a) -> IO (Maybe (Tree a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree a)
forall a. Maybe a
Nothing
Maybe TreeIter
_ -> Maybe (Tree a) -> IO (Maybe (Tree a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree a)
forall a. Maybe a
Nothing