{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- -*-haskell-*-
--  GIMP Toolkit (GTK) CustomStore TreeModel
--
--  Author : Duncan Coutts, Axel Simon
--
--  Created: 11 Feburary 2006
--
--  Copyright (C) 2005-2016 Duncan Coutts, Axel Simon, Hamish Mackenzie
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Standard model to store hierarchical data.
--
module Data.GI.Gtk.ModelView.ForestStore (

-- * Types
  ForestStore(..),

-- * Constructors
  forestStoreNew,
  forestStoreNewDND,

-- * Implementation of Interfaces
  forestStoreDefaultDragSourceIface,
  forestStoreDefaultDragDestIface,

-- * Methods
  forestStoreGetValue,
  forestStoreGetTree,
  forestStoreGetForest,
  forestStoreLookup,

  forestStoreSetValue,

  forestStoreInsert,
  forestStoreInsertTree,
  forestStoreInsertForest,

  forestStoreRemove,
  forestStoreClear,

  forestStoreChange,
  forestStoreChangeM,
  ) where

import Prelude ()
import Prelude.Compat
import Data.Bits
import Data.Word (Word32)
import Data.Int (Int32)
import Data.Maybe ( fromMaybe, isJust )
import Data.Tree
import Control.Monad ((>=>), when)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Exception (assert)
import Data.IORef

import Foreign.ForeignPtr (ForeignPtr)

import Data.GI.Base.BasicTypes
       (ManagedPtr(..), GObject(..), GObject)
import Data.GI.Base.ManagedPtr (withManagedPtr)
import Data.GI.Base.Overloading (HasParentTypes, ParentTypes)

import Data.GI.Gtk.ModelView.Types
import Data.GI.Gtk.ModelView.CustomStore
       (customStoreGetStamp, customStoreGetPrivate,
        TreeModelIface(..), customStoreNew, DragDestIface(..),
        DragSourceIface(..), CustomStore(..), customStoreInvalidateIters)
import GI.GObject.Objects.Object (Object(..))
import GI.Gtk.Interfaces.TreeModel
       (treeModelRowDeleted, treeModelRowInserted,
        treeModelRowChanged, toTreeModel, TreeModel(..), IsTreeModel(..),
        treeModelRowHasChildToggled)
import GI.Gtk.Functions (treeSetRowDragData, treeGetRowDragData)
import GI.Gtk.Structs.TreePath
       (TreePath)
import GI.Gtk.Structs.TreeIter
       (getTreeIterUserData3, getTreeIterUserData2, getTreeIterUserData,
        getTreeIterStamp, setTreeIterUserData3, setTreeIterUserData2,
        setTreeIterUserData, setTreeIterStamp, TreeIter(..))
import Data.GI.Base (get, new)
import Unsafe.Coerce (unsafeCoerce)

--------------------------------------------
-- internal model data types
--

data ForestStoreIter = ForestStoreIter Int32 Word32 Word32 Word32

fromForestStoreIter :: MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter :: ForestStoreIter -> m TreeIter
fromForestStoreIter (ForestStoreIter s :: Int32
s u1 :: Word32
u1 u2 :: Word32
u2 u3 :: Word32
u3) = do
    TreeIter
i <- (ManagedPtr TreeIter -> TreeIter)
-> [AttrOp TreeIter 'AttrSet] -> m TreeIter
forall a (tag :: AttrOpTag) (m :: * -> *).
(Constructible a tag, MonadIO m) =>
(ManagedPtr a -> a) -> [AttrOp a tag] -> m a
new ManagedPtr TreeIter -> TreeIter
TreeIter []
    TreeIter -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => TreeIter -> Int32 -> m ()
setTreeIterStamp     TreeIter
i Int32
s
    TreeIter -> Ptr () -> m ()
forall (m :: * -> *). MonadIO m => TreeIter -> Ptr () -> m ()
setTreeIterUserData  TreeIter
i (Ptr () -> m ()) -> Ptr () -> m ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Ptr ()
forall a b. a -> b
unsafeCoerce Word32
u1
    TreeIter -> Ptr () -> m ()
forall (m :: * -> *). MonadIO m => TreeIter -> Ptr () -> m ()
setTreeIterUserData2 TreeIter
i (Ptr () -> m ()) -> Ptr () -> m ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Ptr ()
forall a b. a -> b
unsafeCoerce Word32
u2
    TreeIter -> Ptr () -> m ()
forall (m :: * -> *). MonadIO m => TreeIter -> Ptr () -> m ()
setTreeIterUserData3 TreeIter
i (Ptr () -> m ()) -> Ptr () -> m ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Ptr ()
forall a b. a -> b
unsafeCoerce Word32
u3
    TreeIter -> m TreeIter
forall (m :: * -> *) a. Monad m => a -> m a
return TreeIter
i

toForestStoreIter :: MonadIO m => TreeIter -> m ForestStoreIter
toForestStoreIter :: TreeIter -> m ForestStoreIter
toForestStoreIter iter :: TreeIter
iter = do
    Int32
stamp <- TreeIter -> m Int32
forall (m :: * -> *). MonadIO m => TreeIter -> m Int32
getTreeIterStamp TreeIter
iter
    Ptr ()
u1    <- TreeIter -> m (Ptr ())
forall (m :: * -> *). MonadIO m => TreeIter -> m (Ptr ())
getTreeIterUserData TreeIter
iter
    Ptr ()
u2    <- TreeIter -> m (Ptr ())
forall (m :: * -> *). MonadIO m => TreeIter -> m (Ptr ())
getTreeIterUserData2 TreeIter
iter
    Ptr ()
u3    <- TreeIter -> m (Ptr ())
forall (m :: * -> *). MonadIO m => TreeIter -> m (Ptr ())
getTreeIterUserData3 TreeIter
iter
    ForestStoreIter -> m ForestStoreIter
forall (m :: * -> *) a. Monad m => a -> m a
return (ForestStoreIter -> m ForestStoreIter)
-> ForestStoreIter -> m ForestStoreIter
forall a b. (a -> b) -> a -> b
$ Int32 -> Word32 -> Word32 -> Word32 -> ForestStoreIter
ForestStoreIter Int32
stamp (Ptr () -> Word32
forall a b. a -> b
unsafeCoerce Ptr ()
u1) (Ptr () -> Word32
forall a b. a -> b
unsafeCoerce Ptr ()
u2) (Ptr () -> Word32
forall a b. a -> b
unsafeCoerce Ptr ()
u3)

forestStoreIterSetStamp :: ForestStoreIter -> Int32 -> ForestStoreIter
forestStoreIterSetStamp :: ForestStoreIter -> Int32 -> ForestStoreIter
forestStoreIterSetStamp (ForestStoreIter _ a :: Word32
a b :: Word32
b c :: Word32
c) s :: Int32
s = Int32 -> Word32 -> Word32 -> Word32 -> ForestStoreIter
ForestStoreIter Int32
s Word32
a Word32
b Word32
c


-- | A store for hierarchical data.
--
newtype ForestStore a = ForestStore (ManagedPtr (CustomStore (IORef (Store a)) a))

mkForestStore :: CustomStore (IORef (Store a)) a -> ForestStore a
mkForestStore :: CustomStore (IORef (Store a)) a -> ForestStore a
mkForestStore (CustomStore ptr :: ManagedPtr (CustomStore (IORef (Store a)) a)
ptr) = ManagedPtr (CustomStore (IORef (Store a)) a) -> ForestStore a
forall a.
ManagedPtr (CustomStore (IORef (Store a)) a) -> ForestStore a
ForestStore ManagedPtr (CustomStore (IORef (Store a)) a)
ptr

instance HasParentTypes (ForestStore a)
type instance ParentTypes (ForestStore a) = '[TreeModel]

instance GObject (ForestStore a) where
#if !MIN_VERSION_haskell_gi_base(0,20,1)
    gobjectIsInitiallyUnowned _ = False
#endif
    gobjectType :: IO GType
gobjectType = GObject TreeModel => IO GType
forall a. GObject a => IO GType
gobjectType @TreeModel

instance IsTypedTreeModel ForestStore

-- | Maximum number of nodes on each level.
--
-- * These numbers determine how many bits in a 'TreeIter' are devoted to
--   each level. Hence, these numbers reflect log2 of the maximum number
--   of nodes at a level, rounded up.
--
type Depth = [Int]

data Store a = Store {
  Store a -> Depth
depth :: Depth,
  Store a -> Cache a
content :: Cache a
}

-- | Create a new list store.
--
-- * The given rose tree determines the initial content and may be the empty
--   list. Each 'Tree' in the forest corresponds to one top-level node.
--
-- * The ForestStore maintains the initially given Forest and aligns the 'TreePath'
--   bits to fit in 96-bit length 'TreeIter' storage.
--
-- * Additionally, a cache is used to achieve higher performance if operating on
--   recently used TreePaths.
--
-- * __Note:__ due to the limited amount of bits available in TreeIter storage, only
--   limited depth forests can be used with this implementation, the result of too deep
--   Forests is an undefined behaviour while trying to retrieve the deeply nested nodes.
--   For example: assuming the average requiement is 8 bits per tree level (max number of
--   children at the level is 255), then we can only use 12 levels deep trees (96/8) -
--   any further levels in a TreePath will not be encoded in the corresponding TreeIter
--   storage.
--
forestStoreNew :: MonadIO m => Forest a -> m (ForestStore a)
forestStoreNew :: Forest a -> m (ForestStore a)
forestStoreNew forest :: Forest a
forest = Forest a
-> Maybe (DragSourceIface ForestStore a)
-> Maybe (DragDestIface ForestStore a)
-> m (ForestStore a)
forall (m :: * -> *) a.
MonadIO m =>
Forest a
-> Maybe (DragSourceIface ForestStore a)
-> Maybe (DragDestIface ForestStore a)
-> m (ForestStore a)
forestStoreNewDND Forest a
forest
                        (DragSourceIface ForestStore a
-> Maybe (DragSourceIface ForestStore a)
forall a. a -> Maybe a
Just DragSourceIface ForestStore a
forall row. DragSourceIface ForestStore row
forestStoreDefaultDragSourceIface)
                        (DragDestIface ForestStore a -> Maybe (DragDestIface ForestStore a)
forall a. a -> Maybe a
Just DragDestIface ForestStore a
forall row. DragDestIface ForestStore row
forestStoreDefaultDragDestIface)

-- | Create a new list store.
--
-- * In addition to 'forestStoreNew', this function takes an two interfaces
--   to implement user-defined drag-and-drop functionality.
--
forestStoreNewDND :: MonadIO m => Forest a -- ^ the inital tree stored in this model
  -> Maybe (DragSourceIface ForestStore a) -- ^ an optional interface for drags
  -> Maybe (DragDestIface ForestStore a) -- ^ an optional interface to handle drops
  -> m (ForestStore a)
forestStoreNewDND :: Forest a
-> Maybe (DragSourceIface ForestStore a)
-> Maybe (DragDestIface ForestStore a)
-> m (ForestStore a)
forestStoreNewDND forest :: Forest a
forest mDSource :: Maybe (DragSourceIface ForestStore a)
mDSource mDDest :: Maybe (DragDestIface ForestStore a)
mDDest = IO (ForestStore a) -> m (ForestStore a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ForestStore a) -> m (ForestStore a))
-> IO (ForestStore a) -> m (ForestStore a)
forall a b. (a -> b) -> a -> b
$ do
  (IORef (Store a)
storeRef :: IORef (Store a)) <- 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 -> IO result) -> IO result
      withStore :: (Store a -> IO result) -> IO result
withStore f :: Store a -> IO result
f = IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef IORef (Store a)
storeRef IO (Store a) -> (Store a -> IO result) -> IO result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Store a -> IO result
f
      withStoreUpdateCache :: (Store a -> (result, Cache a)) -> IO result
      withStoreUpdateCache :: (Store a -> (result, Cache a)) -> IO result
withStoreUpdateCache f :: Store a -> (result, 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 (result :: result
result, cache' :: Cache a
cache') = Store a -> (result, 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' }
        result -> IO result
forall (m :: * -> *) a. Monad m => a -> m a
return result
result

  IORef (Store a)
-> (CustomStore (IORef (Store a)) a -> ForestStore a)
-> TreeModelIface a
-> Maybe (DragSourceIface ForestStore a)
-> Maybe (DragDestIface ForestStore a)
-> IO (ForestStore a)
forall (m :: * -> *) (model :: * -> *) row private.
(MonadIO m, IsTreeModel (model row), IsTypedTreeModel model) =>
private
-> (CustomStore private row -> model row)
-> TreeModelIface row
-> Maybe (DragSourceIface model row)
-> Maybe (DragDestIface model row)
-> m (model row)
customStoreNew IORef (Store a)
storeRef CustomStore (IORef (Store a)) a -> ForestStore a
forall a. CustomStore (IORef (Store a)) a -> ForestStore a
mkForestStore TreeModelIface :: forall row.
IO [TreeModelFlags]
-> (TreePath -> IO (Maybe TreeIter))
-> (TreeIter -> IO TreePath)
-> (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 :: TreePath -> IO (Maybe TreeIter)
treeModelIfaceGetIter = \path :: TreePath
path -> (Store a -> IO (Maybe TreeIter)) -> IO (Maybe TreeIter)
forall result. (Store a -> IO result) -> IO result
withStore ((Store a -> IO (Maybe TreeIter)) -> IO (Maybe TreeIter))
-> (Store a -> IO (Maybe TreeIter)) -> IO (Maybe TreeIter)
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d } -> Depth -> [Int32] -> Maybe ForestStoreIter
fromPath Depth
d ([Int32] -> Maybe ForestStoreIter)
-> IO [Int32] -> IO (Maybe ForestStoreIter)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TreePath -> IO [Int32]
forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path IO (Maybe ForestStoreIter)
-> (Maybe ForestStoreIter -> IO (Maybe TreeIter))
-> IO (Maybe TreeIter)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ForestStoreIter -> IO TreeIter)
-> Maybe ForestStoreIter -> IO (Maybe TreeIter)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ForestStoreIter -> IO TreeIter
forall (m :: * -> *). MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter,

    treeModelIfaceGetPath :: TreeIter -> IO TreePath
treeModelIfaceGetPath = TreeIter -> IO ForestStoreIter
forall (m :: * -> *). MonadIO m => TreeIter -> m ForestStoreIter
toForestStoreIter (TreeIter -> IO ForestStoreIter)
-> (ForestStoreIter -> IO TreePath) -> TreeIter -> IO TreePath
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \iter :: ForestStoreIter
iter -> (Store a -> IO TreePath) -> IO TreePath
forall result. (Store a -> IO result) -> IO result
withStore ((Store a -> IO TreePath) -> IO TreePath)
-> (Store a -> IO TreePath) -> IO TreePath
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d } -> [Int32] -> IO TreePath
forall (m :: * -> *). MonadIO m => [Int32] -> m TreePath
treePathNewFromIndices' ([Int32] -> IO TreePath) -> [Int32] -> IO TreePath
forall a b. (a -> b) -> a -> b
$ Depth -> ForestStoreIter -> [Int32]
toPath Depth
d ForestStoreIter
iter,

    treeModelIfaceGetRow :: TreeIter -> IO a
treeModelIfaceGetRow  = TreeIter -> IO ForestStoreIter
forall (m :: * -> *). MonadIO m => TreeIter -> m ForestStoreIter
toForestStoreIter (TreeIter -> IO ForestStoreIter)
-> (ForestStoreIter -> IO a) -> TreeIter -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \iter :: ForestStoreIter
iter -> (Store a -> (a, Cache a)) -> IO a
forall result. (Store a -> (result, Cache a)) -> IO result
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 -> ForestStoreIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d ForestStoreIter
iter Cache a
cache of
          (True, cache' :: Cache a
cache'@((_, (Node { rootLabel :: forall a. Tree a -> a
rootLabel = a
val }:_)):_)) ->
            (a
val, Cache a
cache')
          _ -> [Char] -> (a, Cache a)
forall a. HasCallStack => [Char] -> a
error "ForestStore.getRow: iter does not refer to a valid entry",

    treeModelIfaceIterNext :: TreeIter -> IO (Maybe TreeIter)
treeModelIfaceIterNext = TreeIter -> IO ForestStoreIter
forall (m :: * -> *). MonadIO m => TreeIter -> m ForestStoreIter
toForestStoreIter (TreeIter -> IO ForestStoreIter)
-> (ForestStoreIter -> IO (Maybe TreeIter))
-> TreeIter
-> IO (Maybe TreeIter)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \iter :: ForestStoreIter
iter -> (Store a -> (Maybe ForestStoreIter, Cache a))
-> IO (Maybe ForestStoreIter)
forall result. (Store a -> (result, Cache a)) -> IO result
withStoreUpdateCache (
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } -> Depth
-> ForestStoreIter -> Cache a -> (Maybe ForestStoreIter, Cache a)
forall a.
Depth
-> ForestStoreIter -> Cache a -> (Maybe ForestStoreIter, Cache a)
iterNext Depth
d ForestStoreIter
iter Cache a
cache) IO (Maybe ForestStoreIter)
-> (Maybe ForestStoreIter -> IO (Maybe TreeIter))
-> IO (Maybe TreeIter)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ForestStoreIter -> IO TreeIter)
-> Maybe ForestStoreIter -> IO (Maybe TreeIter)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ForestStoreIter -> IO TreeIter
forall (m :: * -> *). MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter,

    treeModelIfaceIterChildren :: Maybe TreeIter -> IO (Maybe TreeIter)
treeModelIfaceIterChildren = \mIter :: Maybe TreeIter
mIter -> do
        ForestStoreIter
iter <- IO ForestStoreIter
-> (TreeIter -> IO ForestStoreIter)
-> Maybe TreeIter
-> IO ForestStoreIter
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ForestStoreIter -> IO ForestStoreIter
forall (m :: * -> *) a. Monad m => a -> m a
return ForestStoreIter
invalidIter) TreeIter -> IO ForestStoreIter
forall (m :: * -> *). MonadIO m => TreeIter -> m ForestStoreIter
toForestStoreIter Maybe TreeIter
mIter
        (Store a -> (Maybe ForestStoreIter, Cache a))
-> IO (Maybe ForestStoreIter)
forall result. (Store a -> (result, Cache a)) -> IO result
withStoreUpdateCache (
          \Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
            Depth
-> Int
-> ForestStoreIter
-> Cache a
-> (Maybe ForestStoreIter, Cache a)
forall a.
Depth
-> Int
-> ForestStoreIter
-> Cache a
-> (Maybe ForestStoreIter, Cache a)
iterNthChild Depth
d 0 ForestStoreIter
iter Cache a
cache) IO (Maybe ForestStoreIter)
-> (Maybe ForestStoreIter -> IO (Maybe TreeIter))
-> IO (Maybe TreeIter)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ForestStoreIter -> IO TreeIter)
-> Maybe ForestStoreIter -> IO (Maybe TreeIter)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ForestStoreIter -> IO TreeIter
forall (m :: * -> *). MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter,

    treeModelIfaceIterHasChild :: TreeIter -> IO Bool
treeModelIfaceIterHasChild = TreeIter -> IO ForestStoreIter
forall (m :: * -> *). MonadIO m => TreeIter -> m ForestStoreIter
toForestStoreIter (TreeIter -> IO ForestStoreIter)
-> (ForestStoreIter -> IO Bool) -> TreeIter -> IO Bool
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \iter :: ForestStoreIter
iter -> (Store a -> (Bool, Cache a)) -> IO Bool
forall result. (Store a -> (result, Cache a)) -> IO result
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 (mIter :: Maybe ForestStoreIter
mIter, cache' :: Cache a
cache') = Depth
-> Int
-> ForestStoreIter
-> Cache a
-> (Maybe ForestStoreIter, Cache a)
forall a.
Depth
-> Int
-> ForestStoreIter
-> Cache a
-> (Maybe ForestStoreIter, Cache a)
iterNthChild Depth
d 0 ForestStoreIter
iter Cache a
cache
        in (Maybe ForestStoreIter -> Bool
forall a. Maybe a -> Bool
isJust Maybe ForestStoreIter
mIter, Cache a
cache'),

    treeModelIfaceIterNChildren :: Maybe TreeIter -> IO Int
treeModelIfaceIterNChildren = (TreeIter -> IO ForestStoreIter)
-> Maybe TreeIter -> IO (Maybe ForestStoreIter)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TreeIter -> IO ForestStoreIter
forall (m :: * -> *). MonadIO m => TreeIter -> m ForestStoreIter
toForestStoreIter (Maybe TreeIter -> IO (Maybe ForestStoreIter))
-> (Maybe ForestStoreIter -> IO Int) -> Maybe TreeIter -> IO Int
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \mIter :: Maybe ForestStoreIter
mIter -> (Store a -> (Int, Cache a)) -> IO Int
forall result. (Store a -> (result, Cache a)) -> IO result
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 :: ForestStoreIter
iter = ForestStoreIter -> Maybe ForestStoreIter -> ForestStoreIter
forall a. a -> Maybe a -> a
fromMaybe ForestStoreIter
invalidIter Maybe ForestStoreIter
mIter
       in Depth -> ForestStoreIter -> Cache a -> (Int, Cache a)
forall a. Depth -> ForestStoreIter -> Cache a -> (Int, Cache a)
iterNChildren Depth
d ForestStoreIter
iter Cache a
cache,

    treeModelIfaceIterNthChild :: Maybe TreeIter -> Int -> IO (Maybe TreeIter)
treeModelIfaceIterNthChild = \mIter :: Maybe TreeIter
mIter idx :: Int
idx  -> do
        ForestStoreIter
iter <- IO ForestStoreIter
-> (TreeIter -> IO ForestStoreIter)
-> Maybe TreeIter
-> IO ForestStoreIter
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ForestStoreIter -> IO ForestStoreIter
forall (m :: * -> *) a. Monad m => a -> m a
return ForestStoreIter
invalidIter) TreeIter -> IO ForestStoreIter
forall (m :: * -> *). MonadIO m => TreeIter -> m ForestStoreIter
toForestStoreIter Maybe TreeIter
mIter
        (Store a -> (Maybe ForestStoreIter, Cache a))
-> IO (Maybe ForestStoreIter)
forall result. (Store a -> (result, Cache a)) -> IO result
withStoreUpdateCache (
          \Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
            Depth
-> Int
-> ForestStoreIter
-> Cache a
-> (Maybe ForestStoreIter, Cache a)
forall a.
Depth
-> Int
-> ForestStoreIter
-> Cache a
-> (Maybe ForestStoreIter, Cache a)
iterNthChild Depth
d Int
idx ForestStoreIter
iter Cache a
cache) IO (Maybe ForestStoreIter)
-> (Maybe ForestStoreIter -> IO (Maybe TreeIter))
-> IO (Maybe TreeIter)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ForestStoreIter -> IO TreeIter)
-> Maybe ForestStoreIter -> IO (Maybe TreeIter)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ForestStoreIter -> IO TreeIter
forall (m :: * -> *). MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter,

    treeModelIfaceIterParent :: TreeIter -> IO (Maybe TreeIter)
treeModelIfaceIterParent = TreeIter -> IO ForestStoreIter
forall (m :: * -> *). MonadIO m => TreeIter -> m ForestStoreIter
toForestStoreIter (TreeIter -> IO ForestStoreIter)
-> (ForestStoreIter -> IO (Maybe TreeIter))
-> TreeIter
-> IO (Maybe TreeIter)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \iter :: ForestStoreIter
iter -> (Store a -> IO (Maybe TreeIter)) -> IO (Maybe TreeIter)
forall result. (Store a -> IO result) -> IO result
withStore ((Store a -> IO (Maybe TreeIter)) -> IO (Maybe TreeIter))
-> (Store a -> IO (Maybe TreeIter)) -> IO (Maybe TreeIter)
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d } -> (ForestStoreIter -> IO TreeIter)
-> Maybe ForestStoreIter -> IO (Maybe TreeIter)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ForestStoreIter -> IO TreeIter
forall (m :: * -> *). MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter (Depth -> ForestStoreIter -> Maybe ForestStoreIter
iterParent Depth
d ForestStoreIter
iter),

    treeModelIfaceRefNode :: TreeIter -> IO ()
treeModelIfaceRefNode = \_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
    treeModelIfaceUnrefNode :: TreeIter -> IO ()
treeModelIfaceUnrefNode = \_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   } Maybe (DragSourceIface ForestStore a)
mDSource Maybe (DragDestIface ForestStore a)
mDDest


-- | Default drag functions for
-- 'Data.GI.Gtk.ModelView.ForestStore'. These functions allow the rows of
-- the model to serve as drag source. Any row is allowed to be dragged and the
-- data set in the 'SelectionDataM' object is set with 'treeSetRowDragData',
-- i.e. it contains the model and the 'TreePath' to the row.
forestStoreDefaultDragSourceIface :: DragSourceIface ForestStore row
forestStoreDefaultDragSourceIface :: DragSourceIface ForestStore row
forestStoreDefaultDragSourceIface = DragSourceIface :: forall (model :: * -> *) row.
(model row -> TreePath -> IO Bool)
-> (model row -> TreePath -> SelectionData -> IO Bool)
-> (model row -> TreePath -> IO Bool)
-> DragSourceIface model row
DragSourceIface {
    customDragSourceRowDraggable :: ForestStore row -> TreePath -> IO Bool
customDragSourceRowDraggable = \_ _-> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True,
    customDragSourceDragDataGet :: ForestStore row -> TreePath -> SelectionData -> IO Bool
customDragSourceDragDataGet = \model :: ForestStore row
model path :: TreePath
path sel :: SelectionData
sel -> SelectionData -> ForestStore row -> TreePath -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTreeModel a) =>
SelectionData -> a -> TreePath -> m Bool
treeSetRowDragData SelectionData
sel ForestStore row
model TreePath
path,
    customDragSourceDragDataDelete :: ForestStore row -> TreePath -> IO Bool
customDragSourceDragDataDelete = \model :: ForestStore row
model path :: TreePath
path -> TreePath -> IO [Int32]
forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path IO [Int32] -> ([Int32] -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \dest :: [Int32]
dest@(_:_) -> 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
$ ForestStore row -> TreePath -> IO Bool
forall (m :: * -> *) a.
MonadIO m =>
ForestStore a -> TreePath -> m Bool
forestStoreRemove ForestStore row
model TreePath
path
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  }

-- | Default drop functions for 'Data.GI.Gtk.ModelView.ForestStore'. These
--   functions accept a row and insert the row into the new location if it is
--   dragged into a tree view
-- that uses the same model.
forestStoreDefaultDragDestIface :: DragDestIface ForestStore row
forestStoreDefaultDragDestIface :: DragDestIface ForestStore row
forestStoreDefaultDragDestIface = DragDestIface :: forall (model :: * -> *) row.
(model row -> TreePath -> SelectionData -> IO Bool)
-> (model row -> TreePath -> SelectionData -> IO Bool)
-> DragDestIface model row
DragDestIface {
    customDragDestRowDropPossible :: ForestStore row -> TreePath -> SelectionData -> IO Bool
customDragDestRowDropPossible = \model :: ForestStore row
model path :: TreePath
path sel :: SelectionData
sel -> do
      (Bool, Maybe TreeModel, Maybe TreePath)
mModelPath <- SelectionData -> IO (Bool, Maybe TreeModel, Maybe TreePath)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
SelectionData -> m (Bool, Maybe TreeModel, Maybe TreePath)
treeGetRowDragData SelectionData
sel
      case (Bool, Maybe TreeModel, Maybe TreePath)
mModelPath of
        (True, Just model' :: TreeModel
model', source :: Maybe TreePath
source) -> do
            TreeModel
tm <- ForestStore row -> IO TreeModel
forall (m :: * -> *) o.
(MonadIO m, IsTreeModel o) =>
o -> m TreeModel
toTreeModel ForestStore row
model
            TreeModel -> (Ptr TreeModel -> IO Bool) -> IO Bool
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr TreeModel
tm ((Ptr TreeModel -> IO Bool) -> IO Bool)
-> (Ptr TreeModel -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \m :: Ptr TreeModel
m ->
                TreeModel -> (Ptr TreeModel -> IO Bool) -> IO Bool
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr TreeModel
model' ((Ptr TreeModel -> IO Bool) -> IO Bool)
-> (Ptr TreeModel -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \m' :: Ptr TreeModel
m' -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr TreeModel
mPtr TreeModel -> Ptr TreeModel -> Bool
forall a. Eq a => a -> a -> Bool
==Ptr TreeModel
m')
        _ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False,
    customDragDestDragDataReceived :: ForestStore row -> TreePath -> SelectionData -> IO Bool
customDragDestDragDataReceived = \model :: ForestStore row
model path :: TreePath
path sel :: SelectionData
sel -> do
      dest :: [Int32]
dest@(_:_) <- TreePath -> IO [Int32]
forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path
      (Bool, Maybe TreeModel, Maybe TreePath)
mModelPath <- SelectionData -> IO (Bool, Maybe TreeModel, Maybe TreePath)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
SelectionData -> m (Bool, Maybe TreeModel, Maybe TreePath)
treeGetRowDragData SelectionData
sel
      case (Bool, Maybe TreeModel, Maybe TreePath)
mModelPath of
        (True, Just model' :: TreeModel
model', Just path :: TreePath
path) -> do
          source :: [Int32]
source@(_:_) <- TreePath -> IO [Int32]
forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path
          TreeModel
tm <- ForestStore row -> IO TreeModel
forall (m :: * -> *) o.
(MonadIO m, IsTreeModel o) =>
o -> m TreeModel
toTreeModel ForestStore row
model
          TreeModel -> (Ptr TreeModel -> IO Bool) -> IO Bool
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr TreeModel
tm ((Ptr TreeModel -> IO Bool) -> IO Bool)
-> (Ptr TreeModel -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \m :: Ptr TreeModel
m ->
            TreeModel -> (Ptr TreeModel -> IO Bool) -> IO Bool
forall a c.
(HasCallStack, ManagedPtrNewtype a) =>
a -> (Ptr a -> IO c) -> IO c
withManagedPtr TreeModel
model' ((Ptr TreeModel -> IO Bool) -> IO Bool)
-> (Ptr TreeModel -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \m' :: Ptr TreeModel
m' ->
              if Ptr TreeModel
mPtr TreeModel -> Ptr TreeModel -> Bool
forall a. Eq a => a -> a -> Bool
/=Ptr TreeModel
m' then Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
              else do
                Tree row
row <- ForestStore row -> TreePath -> IO (Tree row)
forall (m :: * -> *) a.
MonadIO m =>
ForestStore a -> TreePath -> m (Tree a)
forestStoreGetTree ForestStore row
model (TreePath -> IO (Tree row)) -> IO TreePath -> IO (Tree row)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Int32] -> IO TreePath
forall (m :: * -> *). MonadIO m => [Int32] -> m TreePath
treePathNewFromIndices' [Int32]
source
                TreePath
initPath <- [Int32] -> IO TreePath
forall (m :: * -> *). MonadIO m => [Int32] -> m TreePath
treePathNewFromIndices' ([Int32] -> [Int32]
forall a. [a] -> [a]
init [Int32]
dest)
                ForestStore row -> TreePath -> Int -> Tree row -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
ForestStore a -> TreePath -> Int -> Tree a -> m ()
forestStoreInsertTree ForestStore row
model TreePath
initPath (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Int) -> Int32 -> Int
forall a b. (a -> b) -> a -> b
$ [Int32] -> Int32
forall a. [a] -> a
last [Int32]
dest) Tree row
row
                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        _ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  }

--------------------------------------------
-- low level bit-twiddling utility functions
--

bitsNeeded :: Word32 -> Int
bitsNeeded :: Word32 -> Int
bitsNeeded n :: Word32
n = Int -> Word32 -> Int
forall t t. (Num t, Num t, Bits t) => t -> t -> t
bitsNeeded' 0 Word32
n
  where bitsNeeded' :: t -> t -> t
bitsNeeded' b :: t
b 0 = t
b
        bitsNeeded' b :: t
b n :: t
n = t -> t -> t
bitsNeeded' (t
bt -> t -> t
forall a. Num a => a -> a -> a
+1) (t
n t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` 1)

getBitSlice :: ForestStoreIter -> Int -> Int -> Word32
getBitSlice :: ForestStoreIter -> Int -> Int -> Word32
getBitSlice (ForestStoreIter _ a :: Word32
a b :: Word32
b c :: Word32
c) off :: Int
off count :: 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
-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
-64) Int
count

  where getBitSliceWord :: Word32 -> Int -> Int -> Word32
        getBitSliceWord :: Word32 -> Int -> Int -> Word32
getBitSliceWord word :: Word32
word off :: Int
off count :: 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
.&. (1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
count Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- 1)

setBitSlice :: ForestStoreIter -> Int -> Int -> Word32 -> ForestStoreIter
setBitSlice :: ForestStoreIter -> Int -> Int -> Word32 -> ForestStoreIter
setBitSlice (ForestStoreIter stamp :: Int32
stamp a :: Word32
a b :: Word32
b c :: Word32
c) off :: Int
off count :: Int
count value :: Word32
value =
  Bool -> ForestStoreIter -> ForestStoreIter
forall a. HasCallStack => Bool -> a -> a
assert (Word32
value Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
< 1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
count) (ForestStoreIter -> ForestStoreIter)
-> ForestStoreIter -> ForestStoreIter
forall a b. (a -> b) -> a -> b
$
  Int32 -> Word32 -> Word32 -> Word32 -> ForestStoreIter
ForestStoreIter Int32
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
-32) Int
count Word32
value)
                (Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord Word32
c (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
-64) Int
count Word32
value)

  where setBitSliceWord :: Word32 -> Int -> Int -> Word32 -> Word32
        setBitSliceWord :: Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord word :: Word32
word off :: Int
off count :: Int
count value :: Word32
value =
          let mask :: Word32
mask = (1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
count Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- 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)


--iterPrefixEqual :: TreeIter -> TreeIter -> Int -> Bool
--iterPrefixEqual (TreeIter _ a1 b1 c1) (TreeIter _ a2 b2 c2) pos
--  | pos>64 = let mask = 1 `shiftL` (pos-64) - 1 in
--             a1==a2 && b1==b2 && (c1 .&. mask) == (c2 .&. mask)
--  | pos>32 = let mask = 1 `shiftL` (pos-32) - 1 in
--             a1==a2 && (b1 .&. mask) == (b2 .&. mask)
--  | otherwise = let mask = 1 `shiftL` pos - 1 in
--                (a1 .&. mask) == (a2 .&. mask)

-- | The invalid tree iterator.
--
invalidIter :: ForestStoreIter
invalidIter :: ForestStoreIter
invalidIter = Int32 -> Word32 -> Word32 -> Word32 -> ForestStoreIter
ForestStoreIter 0 0 0 0

--showIterBits (TreeIter _ a b c) = [showBits a, showBits b, showBits c]
--
--showBits :: Bits a => a -> String
--showBits a = [ if testBit a i then '1' else '0' | i <- [0..bitSize a - 1] ]

-- | Calculate the maximum number of nodes on a per-level basis.
--
calcForestDepth :: Forest a -> Depth
calcForestDepth :: Forest a -> Depth
calcForestDepth f :: 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
/=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 0) Forest a
f
  where
  calcTreeDepth :: Tree a -> [c] -> [c]
calcTreeDepth Node { subForest :: forall a. Tree a -> Forest a
subForest = Forest a
f } (d :: c
d:ds :: [c]
ds) =
      (c
dc -> c -> c
forall a. Num a => a -> a -> a
+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] -> Forest 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 0) Forest a
f)


-- | Convert an iterator into a path.
--
toPath :: Depth -> ForestStoreIter -> [Int32]
toPath :: Depth -> ForestStoreIter -> [Int32]
toPath d :: Depth
d iter :: ForestStoreIter
iter = Int -> Depth -> [Int32]
gP 0 Depth
d
  where
  gP :: Int -> Depth -> [Int32]
gP pos :: Int
pos [] = []
  gP pos :: Int
pos (d :: Int
d:ds :: Depth
ds) = let idx :: Word32
idx = ForestStoreIter -> Int -> Int -> Word32
getBitSlice ForestStoreIter
iter Int
pos Int
d in
                  if Word32
idxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==0 then [] else Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
idxWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-1) Int32 -> [Int32] -> [Int32]
forall a. a -> [a] -> [a]
: Int -> Depth -> [Int32]
gP (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Depth
ds

-- | Try to convert a path into a 'TreeIter'.
--
fromPath :: Depth -> [Int32] -> Maybe ForestStoreIter
fromPath :: Depth -> [Int32] -> Maybe ForestStoreIter
fromPath = Int -> ForestStoreIter -> Depth -> [Int32] -> Maybe ForestStoreIter
forall a.
Integral a =>
Int -> ForestStoreIter -> Depth -> [a] -> Maybe ForestStoreIter
fP 0 ForestStoreIter
invalidIter
  where
  fP :: Int -> ForestStoreIter -> Depth -> [a] -> Maybe ForestStoreIter
fP pos :: Int
pos ti :: ForestStoreIter
ti _ [] = ForestStoreIter -> Maybe ForestStoreIter
forall a. a -> Maybe a
Just ForestStoreIter
ti -- the remaining bits are zero anyway
  fP pos :: Int
pos ti :: ForestStoreIter
ti [] _ = Maybe ForestStoreIter
forall a. Maybe a
Nothing
  fP pos :: Int
pos ti :: ForestStoreIter
ti (d :: Int
d:ds :: Depth
ds) (p :: a
p:ps :: [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
+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 ForestStoreIter
forall a. Maybe a
Nothing else
    Int -> ForestStoreIter -> Depth -> [a] -> Maybe ForestStoreIter
fP (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) (ForestStoreIter -> Int -> Int -> Word32 -> ForestStoreIter
setBitSlice ForestStoreIter
ti Int
pos Int
d Word32
idx) Depth
ds [a]
ps


-- | The 'Cache' type synonym is only used iternally. What it represents
--   the stack during a (fictional) lookup operations.
--   The topmost frame is the node
--   for which this lookup was started and the innermost frame (the last
--   element of the list) contains the root of the tree.
--
type Cache a = [(ForestStoreIter, Forest a)]


-- | Create a traversal structure that allows a pre-order traversal in linear
--   time.
--
-- * The returned structure points at the root of the first level which doesn't
--   really exist, but serves to indicate that it is before the very first
--   node.
--
storeToCache :: Forest a -> Cache a
storeToCache :: Forest a -> Cache a
storeToCache [] = []
storeToCache forest :: Forest a
forest = [(ForestStoreIter
invalidIter, [a -> Forest a -> Tree a
forall a. a -> Forest a -> Tree a
Node a
forall a. a
root Forest a
forest])]
  where
  root :: a
root = [Char] -> a
forall a. HasCallStack => [Char] -> a
error "ForestStore.storeToCache: accessed non-exitent root of tree"

-- | Extract the store from the cache data structure.
cacheToStore :: Cache a -> Forest a
cacheToStore :: Cache a -> Forest a
cacheToStore [] = []
cacheToStore cache :: Cache a
cache = case Cache a -> (ForestStoreIter, Forest a)
forall a. [a] -> a
last Cache a
cache of (_, [Node _ forest :: Forest a
forest]) -> Forest a
forest

-- | Advance the traversal structure to the given 'TreeIter'.
--
advanceCache :: Depth -> ForestStoreIter -> Cache a -> Cache a
advanceCache :: Depth -> ForestStoreIter -> Cache a -> Cache a
advanceCache depth :: Depth
depth goal :: ForestStoreIter
goal [] = []
advanceCache depth :: Depth
depth goal :: ForestStoreIter
goal cache :: Cache a
cache@((rootIter :: ForestStoreIter
rootIter,_):_) =
  Int -> Depth -> Cache a
moveToSameLevel 0 Depth
depth
  where
  moveToSameLevel :: Int -> Depth -> Cache a
moveToSameLevel pos :: Int
pos [] = Cache a
cache
  moveToSameLevel pos :: Int
pos (d :: Int
d:ds :: Depth
ds) =
    let
      goalIdx :: Word32
goalIdx = ForestStoreIter -> Int -> Int -> Word32
getBitSlice ForestStoreIter
goal Int
pos Int
d
      curIdx :: Word32
curIdx = ForestStoreIter -> Int -> Int -> Word32
getBitSlice ForestStoreIter
rootIter Int
pos Int
d
      isNonZero :: Int -> Int -> (ForestStoreIter, b) -> Bool
isNonZero pos :: Int
pos d :: Int
d (ti :: ForestStoreIter
ti,_) = ForestStoreIter -> Int -> Int -> Word32
getBitSlice ForestStoreIter
ti Int
pos Int
dWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/=0
    in
    if Word32
goalIdxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Word32
curIdx then Int -> Depth -> Cache 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
==0 then ((ForestStoreIter, Forest a) -> Bool) -> Cache a -> Cache a
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> (ForestStoreIter, Forest a) -> Bool
forall b. Int -> Int -> (ForestStoreIter, b) -> Bool
isNonZero Int
pos Int
d) Cache a
cache else
    if Word32
curIdxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==0 then Int -> Depth -> Cache a -> Cache a
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild Int
pos (Int
dInt -> Depth -> Depth
forall a. a -> [a] -> [a]
:Depth
ds) Cache a
cache else
    if Word32
goalIdxWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<Word32
curIdx then
      Int -> Depth -> Cache a -> Cache a
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild Int
pos (Int
dInt -> Depth -> Depth
forall a. a -> [a] -> [a]
:Depth
ds) (((ForestStoreIter, Forest a) -> Bool) -> Cache a -> Cache a
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> (ForestStoreIter, Forest a) -> Bool
forall b. Int -> Int -> (ForestStoreIter, b) -> Bool
isNonZero Int
pos Int
d) Cache a
cache)
    else let
      -- advance the current iterator to coincide with the goal iterator
      -- at this level
      moveWithinLevel :: Int -> Int -> Cache a -> Cache a
moveWithinLevel pos :: Int
pos d :: Int
d ((ti :: ForestStoreIter
ti,forest :: Forest a
forest):parents :: Cache 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)
          (dropped :: Forest a
dropped, remain :: Forest a
remain) = Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
diff Forest a
forest
          advance :: Int
advance = Forest a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
dropped
          ti' :: ForestStoreIter
ti' = ForestStoreIter -> Int -> Int -> Word32 -> ForestStoreIter
setBitSlice ForestStoreIter
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 -> 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 ((ForestStoreIter
ti',Forest a
remain)(ForestStoreIter, Forest a) -> Cache a -> Cache a
forall a. a -> [a] -> [a]
:Cache a
parents)
        else (ForestStoreIter
ti',Forest a
remain)(ForestStoreIter, Forest a) -> Cache a -> Cache a
forall a. a -> [a] -> [a]
:Cache a
parents -- node not found
    in Int -> Int -> Cache a -> Cache a
moveWithinLevel Int
pos Int
d (Cache a -> Cache a) -> Cache a -> Cache a
forall a b. (a -> b) -> a -> b
$ case Depth
ds of
        [] -> Cache a
cache
        (d' :: Int
d':_) -> ((ForestStoreIter, Forest a) -> Bool) -> Cache a -> Cache a
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> (ForestStoreIter, Forest a) -> Bool
forall b. Int -> Int -> (ForestStoreIter, b) -> Bool
isNonZero (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Int
d') Cache a
cache

  -- Descend into the topmost forest to find the goal iterator. The position
  -- and the remainding depths specify the index in the cache that is zero.
  -- All indices in front of pos coincide with that of the goal iterator.
  moveToChild :: Int -> Depth -> Cache a -> Cache a
  moveToChild :: Int -> Depth -> Cache a -> Cache a
moveToChild pos :: Int
pos [] cache :: Cache a
cache = Cache a
cache -- we can't set more than the leaf
  moveToChild pos :: Int
pos (d :: Int
d:ds :: Depth
ds) cache :: Cache a
cache@((ti :: ForestStoreIter
ti,forest :: Forest a
forest):parents :: Cache a
parents)
    | ForestStoreIter -> Int -> Int -> Word32
getBitSlice ForestStoreIter
goal Int
pos Int
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Cache a
cache
    | Bool
otherwise = case Forest a
forest of
      [] -> Cache a
cache -- impossible request
      Node { subForest :: forall a. Tree a -> Forest a
subForest = Forest a
children }:_ ->
        let
          childIdx :: Int
          childIdx :: Int
childIdx = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ForestStoreIter -> Int -> Int -> Word32
getBitSlice ForestStoreIter
goal Int
pos Int
d)Int -> Int -> Int
forall a. Num a => a -> a -> a
-1
          (dropped :: Forest a
dropped, remain :: 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' :: ForestStoreIter
ti' = ForestStoreIter -> Int -> Int -> Word32 -> ForestStoreIter
setBitSlice ForestStoreIter
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
+1)
        in if Int
advancedInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
childIdx then ((ForestStoreIter
ti',Forest a
remain)(ForestStoreIter, 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 ((ForestStoreIter
ti',Forest a
remain)(ForestStoreIter, Forest a) -> Cache a -> Cache a
forall a. a -> [a] -> [a]
:Cache a
cache)

-- | Advance to the given iterator and return weather this was successful.
--
checkSuccess :: Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
checkSuccess :: Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
checkSuccess depth :: Depth
depth iter :: ForestStoreIter
iter cache :: Cache a
cache = case Depth -> ForestStoreIter -> Cache a -> Cache a
forall a. Depth -> ForestStoreIter -> Cache a -> Cache a
advanceCache Depth
depth ForestStoreIter
iter Cache a
cache of
    cache' :: Cache a
cache'@((cur :: ForestStoreIter
cur,sibs :: Forest a
sibs):_) -> (ForestStoreIter -> ForestStoreIter -> Bool
cmp ForestStoreIter
cur ForestStoreIter
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 :: ForestStoreIter -> ForestStoreIter -> Bool
cmp (ForestStoreIter _ a1 :: Word32
a1 b1 :: Word32
b1 c1 :: Word32
c1) (ForestStoreIter _ a2 :: Word32
a2 b2 :: Word32
b2 c2 :: 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

-- | Get the leaf index of this iterator.
--
-- * Due to the way we construct the 'TreeIter's, we can check which the last
--   level of an iterator is: The bit sequence of level n is zero if n is
--   greater or equal to the level that the iterator refers to. The returned
--   triple is (pos, leaf, zero) such that pos..pos+leaf denotes the leaf
--   index and pos+leaf..pos+leaf+zero denotes the bit field that is zero.
--
getTreeIterLeaf :: Depth -> ForestStoreIter -> (Int, Int, Int)
getTreeIterLeaf :: Depth -> ForestStoreIter -> (Int, Int, Int)
getTreeIterLeaf ds :: Depth
ds ti :: ForestStoreIter
ti = Int -> Int -> Depth -> (Int, Int, Int)
gTIL 0 0 Depth
ds
  where
  gTIL :: Int -> Int -> Depth -> (Int, Int, Int)
gTIL pos :: Int
pos dCur :: Int
dCur (dNext :: Int
dNext:ds :: Depth
ds)
    | ForestStoreIter -> Int -> Int -> Word32
getBitSlice ForestStoreIter
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
==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 pos :: Int
pos d :: Int
d [] = (Int
pos, Int
d, 0)

-- | Move an iterator forwards on the same level.
--
iterNext :: Depth -> ForestStoreIter -> Cache a -> (Maybe ForestStoreIter, Cache a)
iterNext :: Depth
-> ForestStoreIter -> Cache a -> (Maybe ForestStoreIter, Cache a)
iterNext depth :: Depth
depth iter :: ForestStoreIter
iter cache :: Cache a
cache = let
    (pos :: Int
pos,leaf :: Int
leaf,_child :: Int
_child) = Depth -> ForestStoreIter -> (Int, Int, Int)
getTreeIterLeaf Depth
depth ForestStoreIter
iter
    curIdx :: Word32
curIdx = ForestStoreIter -> Int -> Int -> Word32
getBitSlice ForestStoreIter
iter Int
pos Int
leaf
    nextIdx :: Word32
nextIdx = Word32
curIdxWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1
    nextIter :: ForestStoreIter
nextIter = ForestStoreIter -> Int -> Int -> Word32 -> ForestStoreIter
setBitSlice ForestStoreIter
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 ForestStoreIter
forall a. Maybe a
Nothing, Cache a
cache) else
  case Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth ForestStoreIter
nextIter Cache a
cache of
    (True, cache :: Cache a
cache) -> (ForestStoreIter -> Maybe ForestStoreIter
forall a. a -> Maybe a
Just ForestStoreIter
nextIter, Cache a
cache)
    (False, cache :: Cache a
cache) -> (Maybe ForestStoreIter
forall a. Maybe a
Nothing, Cache a
cache)

-- | Move down to the child of the given iterator.
--
iterNthChild :: Depth -> Int -> ForestStoreIter -> Cache a  ->
                (Maybe ForestStoreIter, Cache a)
iterNthChild :: Depth
-> Int
-> ForestStoreIter
-> Cache a
-> (Maybe ForestStoreIter, Cache a)
iterNthChild depth :: Depth
depth childIdx_ :: Int
childIdx_ iter :: ForestStoreIter
iter cache :: Cache a
cache = let
    (pos :: Int
pos,leaf :: Int
leaf,child :: Int
child) = Depth -> ForestStoreIter -> (Int, Int, Int)
getTreeIterLeaf Depth
depth ForestStoreIter
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
+1
    nextIter :: ForestStoreIter
nextIter = ForestStoreIter -> Int -> Int -> Word32 -> ForestStoreIter
setBitSlice ForestStoreIter
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 ForestStoreIter
forall a. Maybe a
Nothing, Cache a
cache) else
  case Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth ForestStoreIter
nextIter Cache a
cache of
    (True, cache :: Cache a
cache) -> (ForestStoreIter -> Maybe ForestStoreIter
forall a. a -> Maybe a
Just ForestStoreIter
nextIter, Cache a
cache)
    (False, cache :: Cache a
cache) -> (Maybe ForestStoreIter
forall a. Maybe a
Nothing, Cache a
cache)

-- | Descend to the first child.
--
iterNChildren :: Depth -> ForestStoreIter -> Cache a -> (Int, Cache a)
iterNChildren :: Depth -> ForestStoreIter -> Cache a -> (Int, Cache a)
iterNChildren depth :: Depth
depth iter :: ForestStoreIter
iter cache :: Cache a
cache = case Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth ForestStoreIter
iter Cache a
cache of
  (True, cache :: Cache a
cache@((_,Node { subForest :: forall a. Tree a -> Forest a
subForest = Forest a
forest}:_):_)) -> (Forest a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Forest a
forest, Cache a
cache)
  (_, cache :: Cache a
cache) -> (0, Cache a
cache)


-- | Ascend to parent.
--
iterParent :: Depth -> ForestStoreIter -> Maybe ForestStoreIter
iterParent :: Depth -> ForestStoreIter -> Maybe ForestStoreIter
iterParent depth :: Depth
depth iter :: ForestStoreIter
iter = let
    (pos :: Int
pos,leaf :: Int
leaf,_child :: Int
_child) = Depth -> ForestStoreIter -> (Int, Int, Int)
getTreeIterLeaf Depth
depth ForestStoreIter
iter
  in if Int
posInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==0 then Maybe ForestStoreIter
forall a. Maybe a
Nothing else
     if ForestStoreIter -> Int -> Int -> Word32
getBitSlice ForestStoreIter
iter Int
pos Int
leafWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==0 then Maybe ForestStoreIter
forall a. Maybe a
Nothing else
     ForestStoreIter -> Maybe ForestStoreIter
forall a. a -> Maybe a
Just (ForestStoreIter -> Int -> Int -> Word32 -> ForestStoreIter
setBitSlice ForestStoreIter
iter Int
pos Int
leaf 0)

-- | Insert nodes into the store.
--
-- * The given list of nodes is inserted into given parent at @pos@.
--   If the parent existed, the function returns @Just path@ where @path@
--   is the position of the newly inserted elements. If @pos@ is negative
--   or greater or equal to the number of children of the node at @path@,
--   the new nodes are appended to the list.
--
forestStoreInsertForest :: MonadIO m
 => ForestStore a -- ^ the store
 -> TreePath    -- ^ @path@ - the position of the parent
 -> Int         -- ^ @pos@ - the index of the new tree
 -> Forest a    -- ^ the list of trees to be inserted
 -> m ()
forestStoreInsertForest :: ForestStore a -> TreePath -> Int -> Forest a -> m ()
forestStoreInsertForest (ForestStore model :: ManagedPtr (CustomStore (IORef (Store a)) a)
model) path :: TreePath
path pos :: Int
pos nodes :: Forest a
nodes = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  [Int32]
ipath <- TreePath -> IO [Int32]
forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path
  CustomStore (IORef (Store a)) a -> IO ()
forall (m :: * -> *) private row.
MonadIO m =>
CustomStore private row -> m ()
customStoreInvalidateIters (CustomStore (IORef (Store a)) a -> IO ())
-> CustomStore (IORef (Store a)) a -> IO ()
forall a b. (a -> b) -> a -> b
$ ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model
  (idx :: Int
idx, toggle :: 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 -> IORef (Store a))
-> CustomStore (IORef (Store a)) a -> IORef (Store a)
forall a b. (a -> b) -> a -> b
$ ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (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 -> [Int32] -> Int -> Maybe (Forest a, Int, Bool)
forall a.
Forest a
-> Forest a -> [Int32] -> Int -> Maybe (Forest a, Int, Bool)
insertIntoForest (Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache) Forest a
nodes [Int32]
ipath Int
pos of
      Nothing -> [Char] -> (Store a, (Int, Bool))
forall a. HasCallStack => [Char] -> a
error ("forestStoreInsertForest: path does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int32] -> [Char]
forall a. Show a => a -> [Char]
show [Int32]
ipath)
      Just (newForest :: Forest a
newForest, idx :: Int
idx, toggle :: 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 -> IORef (Store a))
-> CustomStore (IORef (Store a)) a -> IORef (Store a)
forall a b. (a -> b) -> a -> b
$ ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model)
  let rpath :: [Int32]
rpath = [Int32] -> [Int32]
forall a. [a] -> [a]
reverse [Int32]
ipath
  Int32
stamp <- CustomStore (IORef (Store a)) a -> IO Int32
forall (m :: * -> *) private row.
MonadIO m =>
CustomStore private row -> m Int32
customStoreGetStamp (CustomStore (IORef (Store a)) a -> IO Int32)
-> CustomStore (IORef (Store a)) a -> IO Int32
forall a b. (a -> b) -> a -> b
$ ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let p' :: [Int32]
p' = [Int32] -> [Int32]
forall a. [a] -> [a]
reverse [Int32]
p
                  Just iter :: ForestStoreIter
iter = Depth -> [Int32] -> Maybe ForestStoreIter
fromPath Depth
depth [Int32]
p'
               in do
                  TreePath
p'' <- [Int32] -> IO TreePath
forall (m :: * -> *). MonadIO m => [Int32] -> m TreePath
treePathNewFromIndices' [Int32]
p'
                  CustomStore (IORef (Store a)) a -> TreePath -> TreeIter -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTreeModel a) =>
a -> TreePath -> TreeIter -> m ()
treeModelRowInserted (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model) TreePath
p'' (TreeIter -> IO ()) -> IO TreeIter -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ForestStoreIter -> IO TreeIter
forall (m :: * -> *). MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter (ForestStoreIter -> Int32 -> ForestStoreIter
forestStoreIterSetStamp ForestStoreIter
iter Int32
stamp)
            | (i :: Int
i, node :: Tree a
node) <- Depth -> Forest a -> [(Int, Tree a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
idx..] Forest a
nodes
            , [Int32]
p <- [Int32] -> Tree a -> [[Int32]]
forall a. [Int32] -> Tree a -> [[Int32]]
paths (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Int32 -> [Int32] -> [Int32]
forall a. a -> [a] -> [a]
: [Int32]
rpath) Tree a
node ]
  let Just iter :: ForestStoreIter
iter = Depth -> [Int32] -> Maybe ForestStoreIter
fromPath Depth
depth [Int32]
ipath
  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 -> TreePath -> TreeIter -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTreeModel a) =>
a -> TreePath -> TreeIter -> m ()
treeModelRowHasChildToggled (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model) TreePath
path
                (TreeIter -> IO ()) -> IO TreeIter -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ForestStoreIter -> IO TreeIter
forall (m :: * -> *). MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter (ForestStoreIter -> Int32 -> ForestStoreIter
forestStoreIterSetStamp ForestStoreIter
iter Int32
stamp)

  where paths :: [Int32] -> Tree a -> [[Int32]]
        paths :: [Int32] -> Tree a -> [[Int32]]
paths path :: [Int32]
path Node { subForest :: forall a. Tree a -> Forest a
subForest = Forest a
ts } =
          [Int32]
path [Int32] -> [[Int32]] -> [[Int32]]
forall a. a -> [a] -> [a]
: [[[Int32]]] -> [[Int32]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Int32] -> Tree a -> [[Int32]]
forall a. [Int32] -> Tree a -> [[Int32]]
paths (Int32
nInt32 -> [Int32] -> [Int32]
forall a. a -> [a] -> [a]
:[Int32]
path) Tree a
t | (n :: Int32
n, t :: Tree a
t) <- [Int32] -> Forest a -> [(Int32, Tree a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] Forest a
ts ]

-- | Insert a node into the store.
--
forestStoreInsertTree :: MonadIO m
 => ForestStore a -- ^ the store
 -> TreePath    -- ^ @path@ - the position of the parent
 -> Int         -- ^ @pos@ - the index of the new tree
 -> Tree a      -- ^ the value to be inserted
 -> m ()
forestStoreInsertTree :: ForestStore a -> TreePath -> Int -> Tree a -> m ()
forestStoreInsertTree store :: ForestStore a
store path :: TreePath
path pos :: Int
pos node :: Tree a
node =
  ForestStore a -> TreePath -> Int -> Forest a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
ForestStore a -> TreePath -> Int -> Forest a -> m ()
forestStoreInsertForest ForestStore a
store TreePath
path Int
pos [Tree a
node]

-- | Insert a single node into the store.
--
-- * This function inserts a single node without children into the tree.
--   Its arguments are similar to those of 'forestStoreInsert'.
--
forestStoreInsert :: MonadIO m
 => ForestStore a -- ^ the store
 -> TreePath    -- ^ @path@ - the position of the parent
 -> Int         -- ^ @pos@ - the index of the new tree
 -> a           -- ^ the value to be inserted
 -> m ()
forestStoreInsert :: ForestStore a -> TreePath -> Int -> a -> m ()
forestStoreInsert store :: ForestStore a
store path :: TreePath
path pos :: Int
pos node :: a
node =
  ForestStore a -> TreePath -> Int -> Forest a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
ForestStore a -> TreePath -> Int -> Forest a -> m ()
forestStoreInsertForest ForestStore a
store TreePath
path Int
pos [a -> Forest a -> Tree a
forall a. a -> Forest a -> Tree a
Node a
node []]

-- | Insert nodes into a forest.
--
-- * If the parent was found, returns the new tree, the child number
--   and a flag denoting if these new nodes were the first children
--   of the parent.
--
insertIntoForest :: Forest a -> Forest a -> [Int32] -> Int ->
                    Maybe (Forest a, Int, Bool)
insertIntoForest :: Forest a
-> Forest a -> [Int32] -> Int -> Maybe (Forest a, Int, Bool)
insertIntoForest forest :: Forest a
forest nodes :: Forest a
nodes [] pos :: Int
pos
  | Int
posInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<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 (prev :: Forest a
prev, next :: Forest a
next) = Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
pos Forest a
forest
insertIntoForest forest :: Forest a
forest nodes :: Forest a
nodes (p :: Int32
p:ps :: [Int32]
ps) pos :: Int
pos = case Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
p) Forest a
forest of
  (prev :: Forest a
prev, []) -> Maybe (Forest a, Int, Bool)
forall a. Maybe a
Nothing
  (prev :: Forest a
prev, Node { rootLabel :: forall a. Tree a -> a
rootLabel = a
val,
                subForest :: forall a. Tree a -> Forest a
subForest = Forest a
for}:next :: Forest a
next) ->
    case Forest a
-> Forest a -> [Int32] -> Int -> Maybe (Forest a, Int, Bool)
forall a.
Forest a
-> Forest a -> [Int32] -> Int -> Maybe (Forest a, Int, Bool)
insertIntoForest Forest a
for Forest a
nodes [Int32]
ps Int
pos of
      Nothing -> Maybe (Forest a, Int, Bool)
forall a. Maybe a
Nothing
      Just (for :: Forest a
for, pos :: Int
pos, toggle :: 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 -> Forest 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)

-- | Remove a node from the store.
--
-- * The node denoted by the path is removed, along with all its children.
--   The function returns @True@ if the given node was found.
--
forestStoreRemove :: MonadIO m => ForestStore a -> TreePath -> m Bool
forestStoreRemove :: ForestStore a -> TreePath -> m Bool
forestStoreRemove model :: ForestStore a
model path :: TreePath
path = TreePath -> m [Int32]
forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path m [Int32] -> ([Int32] -> m Bool) -> m Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ForestStore a -> TreePath -> [Int32] -> m Bool
forall (m :: * -> *) a.
MonadIO m =>
ForestStore a -> TreePath -> [Int32] -> m Bool
forestStoreRemoveImpl ForestStore a
model TreePath
path

forestStoreRemoveImpl :: MonadIO m => ForestStore a -> TreePath -> [Int32] -> m Bool
  --TODO: eliminate this special case without segfaulting!
forestStoreRemoveImpl :: ForestStore a -> TreePath -> [Int32] -> m Bool
forestStoreRemoveImpl (ForestStore model :: ManagedPtr (CustomStore (IORef (Store a)) a)
model) _ [] = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
forestStoreRemoveImpl (ForestStore model :: ManagedPtr (CustomStore (IORef (Store a)) a)
model) path :: TreePath
path ipath :: [Int32]
ipath = IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
  CustomStore (IORef (Store a)) a -> IO ()
forall (m :: * -> *) private row.
MonadIO m =>
CustomStore private row -> m ()
customStoreInvalidateIters (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model)
  (found :: Bool
found, toggle :: 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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (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 -> [Int32] -> Maybe (Forest a, Bool)
forall a. Forest a -> [Int32] -> Maybe (Forest a, Bool)
deleteFromForest (Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache) [Int32]
ipath of
      Nothing -> (Store a
store, (Bool
False, Bool
False))
      Just (newForest :: Forest a
newForest, toggle :: Bool
toggle) ->
        (Store :: forall a. Depth -> Cache a -> Store a
Store { depth :: Depth
depth = Depth
d, -- this might be a space leak
                 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 ([Int32] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int32]
ipath)) (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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model))
      let iparent :: [Int32]
iparent = [Int32] -> [Int32]
forall a. [a] -> [a]
init [Int32]
ipath
          Just iter :: ForestStoreIter
iter = Depth -> [Int32] -> Maybe ForestStoreIter
fromPath Depth
depth [Int32]
iparent
      TreePath
parent <- [Int32] -> IO TreePath
forall (m :: * -> *). MonadIO m => [Int32] -> m TreePath
treePathNewFromIndices' [Int32]
iparent
      CustomStore (IORef (Store a)) a -> TreePath -> TreeIter -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTreeModel a) =>
a -> TreePath -> TreeIter -> m ()
treeModelRowHasChildToggled (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model) TreePath
parent (TreeIter -> IO ()) -> IO TreeIter -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ForestStoreIter -> IO TreeIter
forall (m :: * -> *). MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter ForestStoreIter
iter
    CustomStore (IORef (Store a)) a -> TreePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTreeModel a) =>
a -> TreePath -> m ()
treeModelRowDeleted (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model) TreePath
path
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
found

forestStoreClear :: MonadIO m => ForestStore a -> m ()
forestStoreClear :: ForestStore a -> m ()
forestStoreClear (ForestStore model :: ManagedPtr (CustomStore (IORef (Store a)) a)
model) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
  CustomStore (IORef (Store a)) a -> IO ()
forall (m :: * -> *) private row.
MonadIO m =>
CustomStore private row -> m ()
customStoreInvalidateIters (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (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   n :: Int
n  = [Int32] -> IO TreePath
forall (m :: * -> *). MonadIO m => [Int32] -> m TreePath
treePathNewFromIndices' [Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n] IO TreePath -> (TreePath -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CustomStore (IORef (Store a)) a -> TreePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTreeModel a) =>
a -> TreePath -> m ()
treeModelRowDeleted (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model) 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
-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
- 1)

-- | Remove a node from a rose tree.
--
-- * Returns the new tree if the node was found. The returned flag is
--   @True@ if deleting the node left the parent without any children.
--
deleteFromForest :: Forest a -> [Int32] -> Maybe (Forest a, Bool)
deleteFromForest :: Forest a -> [Int32] -> Maybe (Forest a, Bool)
deleteFromForest forest :: Forest a
forest [] = (Forest a, Bool) -> Maybe (Forest a, Bool)
forall a. a -> Maybe a
Just ([], Bool
False)
deleteFromForest forest :: Forest a
forest (p :: Int32
p:ps :: [Int32]
ps) =
  case Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
p) Forest a
forest of
    (prev :: Forest a
prev, kill :: Tree a
kill@Node { rootLabel :: forall a. Tree a -> a
rootLabel = a
val,
                       subForest :: forall a. Tree a -> Forest a
subForest = Forest a
for}:next :: Forest a
next) ->
      if [Int32] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int32]
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 -> [Int32] -> Maybe (Forest a, Bool)
forall a. Forest a -> [Int32] -> Maybe (Forest a, Bool)
deleteFromForest Forest a
for [Int32]
ps of
        Nothing -> Maybe (Forest a, Bool)
forall a. Maybe a
Nothing
        Just (for :: Forest a
for,toggle :: 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 -> Forest 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)
    (prev :: Forest a
prev, []) -> Maybe (Forest a, Bool)
forall a. Maybe a
Nothing


-- | Set a node in the store.
--
forestStoreSetValue :: MonadIO m => ForestStore a -> TreePath -> a -> m ()
forestStoreSetValue :: ForestStore a -> TreePath -> a -> m ()
forestStoreSetValue store :: ForestStore a
store path :: TreePath
path value :: a
value = ForestStore a -> TreePath -> (a -> m a) -> m Bool
forall (m :: * -> *) a.
MonadIO m =>
ForestStore a -> TreePath -> (a -> m a) -> m Bool
forestStoreChangeM ForestStore a
store TreePath
path (\_ -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value)
                                  m Bool -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Change a node in the store.
--
-- * Returns @True@ if the node was found. For a monadic version, see
--   'forestStoreChangeM'.
--
forestStoreChange :: MonadIO m => ForestStore a -> TreePath -> (a -> a) -> m Bool
forestStoreChange :: ForestStore a -> TreePath -> (a -> a) -> m Bool
forestStoreChange store :: ForestStore a
store path :: TreePath
path func :: a -> a
func = ForestStore a -> TreePath -> (a -> m a) -> m Bool
forall (m :: * -> *) a.
MonadIO m =>
ForestStore a -> TreePath -> (a -> m a) -> m Bool
forestStoreChangeM ForestStore a
store TreePath
path (a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> m a) -> (a -> a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
func)


-- | Change a node in the store.
--
-- * Returns @True@ if the node was found. For a purely functional version, see
--   'forestStoreChange'.
--
forestStoreChangeM :: MonadIO m => ForestStore a -> TreePath -> (a -> m a) -> m Bool
forestStoreChangeM :: ForestStore a -> TreePath -> (a -> m a) -> m Bool
forestStoreChangeM (ForestStore model :: ManagedPtr (CustomStore (IORef (Store a)) a)
model) path :: TreePath
path act :: a -> m a
act = do
  [Int32]
ipath <- TreePath -> m [Int32]
forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path
  CustomStore (IORef (Store a)) a -> m ()
forall (m :: * -> *) private row.
MonadIO m =>
CustomStore private row -> m ()
customStoreInvalidateIters (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (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 } <-
      IO (Store a) -> m (Store a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Store a) -> m (Store a)) -> IO (Store a) -> m (Store a)
forall a b. (a -> b) -> a -> b
$ 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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (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 }, found :: Bool
found) <- do
    Maybe (Forest a)
mRes <- Forest a -> (a -> m a) -> [Int32] -> m (Maybe (Forest a))
forall (m :: * -> *) a.
MonadIO m =>
Forest a -> (a -> m a) -> [Int32] -> m (Maybe (Forest a))
changeForest (Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache) a -> m a
act [Int32]
ipath
    (Store a, Bool) -> m (Store a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Store a, Bool) -> m (Store a, Bool))
-> (Store a, Bool) -> m (Store a, Bool)
forall a b. (a -> b) -> a -> b
$ case Maybe (Forest a)
mRes of
      Nothing -> (Store a
store, Bool
False)
      Just newForest :: 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)
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ 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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model)) Store a
store'
  let Just iter :: ForestStoreIter
iter = Depth -> [Int32] -> Maybe ForestStoreIter
fromPath Depth
d [Int32]
ipath
  Int32
stamp <- CustomStore (IORef (Store a)) a -> m Int32
forall (m :: * -> *) private row.
MonadIO m =>
CustomStore private row -> m Int32
customStoreGetStamp (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
found (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ CustomStore (IORef (Store a)) a -> TreePath -> TreeIter -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsTreeModel a) =>
a -> TreePath -> TreeIter -> m ()
treeModelRowChanged (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model) TreePath
path (TreeIter -> m ()) -> m TreeIter -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ForestStoreIter -> m TreeIter
forall (m :: * -> *). MonadIO m => ForestStoreIter -> m TreeIter
fromForestStoreIter (ForestStoreIter -> Int32 -> ForestStoreIter
forestStoreIterSetStamp ForestStoreIter
iter Int32
stamp)
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
found

-- | Change a node in the forest.
--
-- * Returns @True@ if the given node was found.
--
changeForest :: MonadIO m => Forest a -> (a -> m a) -> [Int32] -> m (Maybe (Forest a))
changeForest :: Forest a -> (a -> m a) -> [Int32] -> m (Maybe (Forest a))
changeForest forest :: Forest a
forest act :: a -> m a
act [] = Maybe (Forest a) -> m (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Forest a)
forall a. Maybe a
Nothing
changeForest forest :: Forest a
forest act :: a -> m a
act (p :: Int32
p:ps :: [Int32]
ps) = case Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
p) Forest a
forest of
  (prev :: Forest a
prev, []) -> Maybe (Forest a) -> m (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Forest a)
forall a. Maybe a
Nothing
  (prev :: Forest a
prev, Node { rootLabel :: forall a. Tree a -> a
rootLabel = a
val,
                subForest :: forall a. Tree a -> Forest a
subForest = Forest a
for}:next :: Forest a
next) ->
    if [Int32] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int32]
ps then do
      a
val' <- a -> m a
act a
val
      Maybe (Forest a) -> m (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 -> Forest 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 -> m a) -> [Int32] -> m (Maybe (Forest a))
forall (m :: * -> *) a.
MonadIO m =>
Forest a -> (a -> m a) -> [Int32] -> m (Maybe (Forest a))
changeForest Forest a
for a -> m a
act [Int32]
ps
      case Maybe (Forest a)
mFor of
        Nothing -> Maybe (Forest a) -> m (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Forest a)
forall a. Maybe a
Nothing
        Just for :: Forest a
for -> Maybe (Forest a) -> m (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Forest a) -> m (Maybe (Forest a)))
-> Maybe (Forest a) -> m (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 -> Forest 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)

-- | Extract one node from the current model. Fails if the given
--   'TreePath' refers to a non-existent node.
--
forestStoreGetValue :: (Applicative m, MonadIO m) => ForestStore a -> TreePath -> m a
forestStoreGetValue :: ForestStore a -> TreePath -> m a
forestStoreGetValue model :: ForestStore a
model path :: TreePath
path = Tree a -> a
forall a. Tree a -> a
rootLabel (Tree a -> a) -> m (Tree a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ForestStore a -> TreePath -> m (Tree a)
forall (m :: * -> *) a.
MonadIO m =>
ForestStore a -> TreePath -> m (Tree a)
forestStoreGetTree ForestStore a
model TreePath
path

-- | Extract a subtree from the current model. Fails if the given
--   'TreePath' refers to a non-existent node.
--
forestStoreGetTree :: MonadIO m => ForestStore a -> TreePath -> m (Tree a)
forestStoreGetTree :: ForestStore a -> TreePath -> m (Tree a)
forestStoreGetTree (ForestStore model :: ManagedPtr (CustomStore (IORef (Store a)) a)
model) path :: TreePath
path = IO (Tree a) -> m (Tree a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Tree a) -> m (Tree a)) -> IO (Tree a) -> m (Tree a)
forall a b. (a -> b) -> a -> b
$ do
  [Int32]
ipath <- TreePath -> IO [Int32]
forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path
  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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model))
  case Depth -> [Int32] -> Maybe ForestStoreIter
fromPath Depth
d [Int32]
ipath of
    (Just iter :: ForestStoreIter
iter) -> do
      let (res :: Bool
res, cache' :: Cache a
cache') = Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d ForestStoreIter
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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model)) Store a
store { content :: Cache a
content = Cache a
cache' }
      case Cache a
cache' of
        ((_,node :: Tree a
node:_):_) | Bool
res -> Tree a -> IO (Tree a)
forall (m :: * -> *) a. Monad m => a -> m a
return Tree a
node
        _ -> [Char] -> IO (Tree a)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ("forestStoreGetTree: path does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int32] -> [Char]
forall a. Show a => a -> [Char]
show [Int32]
ipath)
    _ -> [Char] -> IO (Tree a)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ("forestStoreGetTree: path does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Int32] -> [Char]
forall a. Show a => a -> [Char]
show [Int32]
ipath)

-- | Extract the forest from the current model.
--
forestStoreGetForest :: MonadIO m => ForestStore a -> m (Forest a)
forestStoreGetForest :: ForestStore a -> m (Forest a)
forestStoreGetForest (ForestStore model :: ManagedPtr (CustomStore (IORef (Store a)) a)
model) = IO (Forest a) -> m (Forest a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Forest a) -> m (Forest a)) -> IO (Forest a) -> m (Forest a)
forall a b. (a -> b) -> a -> b
$ 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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model))
  Forest a -> IO (Forest a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Forest a -> IO (Forest a)) -> Forest a -> IO (Forest a)
forall a b. (a -> b) -> a -> b
$ Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache

-- | Extract a subtree from the current model. Like 'forestStoreGetTree'
--   but returns @Nothing@ if the path refers to a non-existant node.
--
forestStoreLookup :: MonadIO m => ForestStore a -> TreePath -> m (Maybe (Tree a))
forestStoreLookup :: ForestStore a -> TreePath -> m (Maybe (Tree a))
forestStoreLookup (ForestStore model :: ManagedPtr (CustomStore (IORef (Store a)) a)
model) path :: TreePath
path = IO (Maybe (Tree a)) -> m (Maybe (Tree a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Tree a)) -> m (Maybe (Tree a)))
-> IO (Maybe (Tree a)) -> m (Maybe (Tree a))
forall a b. (a -> b) -> a -> b
$ do
  [Int32]
ipath <- TreePath -> IO [Int32]
forall (m :: * -> *). MonadIO m => TreePath -> m [Int32]
treePathGetIndices' TreePath
path
  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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model))
  case Depth -> [Int32] -> Maybe ForestStoreIter
fromPath Depth
d [Int32]
ipath of
    (Just iter :: ForestStoreIter
iter) -> do
      let (res :: Bool
res, cache' :: Cache a
cache') = Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> ForestStoreIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d ForestStoreIter
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 (ManagedPtr (CustomStore (IORef (Store a)) a)
-> CustomStore (IORef (Store a)) a
forall private row.
ManagedPtr (CustomStore private row) -> CustomStore private row
CustomStore ManagedPtr (CustomStore (IORef (Store a)) a)
model)) Store a
store { content :: Cache a
content = Cache a
cache' }
      case Cache a
cache' of
        ((_,node :: Tree a
node:_):_) | 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)
        _ -> 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 (Tree a) -> IO (Maybe (Tree a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Tree a)
forall a. Maybe a
Nothing