{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) CustomStore TreeModel
--
--  Author : Duncan Coutts, Axel Simon
--
--  Created: 11 Feburary 2006
--
--  Copyright (C) 2005 Duncan Coutts, Axel Simon
--
--  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.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- Standard model to store hierarchical data.
--
module Graphics.UI.Gtk.ModelView.TreeStore (

-- * Types
  TreeStore,

-- * Constructors
  treeStoreNew,
  treeStoreNewDND,

-- * Implementation of Interfaces
  treeStoreDefaultDragSourceIface,
  treeStoreDefaultDragDestIface,

-- * Methods
  treeStoreGetValue,
  treeStoreGetTree,
  treeStoreLookup,

  treeStoreSetValue,

  treeStoreInsert,
  treeStoreInsertTree,
  treeStoreInsertForest,

  treeStoreRemove,
  treeStoreClear,

  treeStoreChange,
  treeStoreChangeM,
  ) where

import Data.Bits
import Data.Word (Word32)
import Data.Maybe ( fromMaybe, isJust )
import Data.Tree
import Control.Monad ( when )
import Control.Exception (assert)
import Data.IORef
import Graphics.UI.Gtk.ModelView.Types
import Graphics.UI.Gtk.Types (GObjectClass(..))
import Graphics.UI.Gtk.ModelView.CustomStore
import Graphics.UI.Gtk.ModelView.TreeModel
import Graphics.UI.Gtk.ModelView.TreeDrag
import Control.Monad.Trans ( liftIO )

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

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

instance TypedTreeModelClass TreeStore
instance TreeModelClass (TreeStore a)
instance GObjectClass (TreeStore a) where
  toGObject :: TreeStore a -> GObject
toGObject (TreeStore tm :: CustomStore (IORef (Store a)) a
tm) = CustomStore (IORef (Store a)) a -> GObject
forall o. GObjectClass o => o -> GObject
toGObject CustomStore (IORef (Store a)) a
tm
  unsafeCastGObject :: GObject -> TreeStore a
unsafeCastGObject = CustomStore (IORef (Store a)) a -> TreeStore a
forall a. CustomStore (IORef (Store a)) a -> TreeStore a
TreeStore (CustomStore (IORef (Store a)) a -> TreeStore a)
-> (GObject -> CustomStore (IORef (Store a)) a)
-> GObject
-> TreeStore a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GObject -> CustomStore (IORef (Store a)) a
forall o. GObjectClass o => GObject -> o
unsafeCastGObject

-- | 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 TreeStore 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.
--
treeStoreNew :: Forest a -> IO (TreeStore a)
treeStoreNew :: Forest a -> IO (TreeStore a)
treeStoreNew forest :: Forest a
forest = Forest a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
forall a.
Forest a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
treeStoreNewDND Forest a
forest
                        (DragSourceIface TreeStore a -> Maybe (DragSourceIface TreeStore a)
forall a. a -> Maybe a
Just DragSourceIface TreeStore a
forall row. DragSourceIface TreeStore row
treeStoreDefaultDragSourceIface)
                        (DragDestIface TreeStore a -> Maybe (DragDestIface TreeStore a)
forall a. a -> Maybe a
Just DragDestIface TreeStore a
forall row. DragDestIface TreeStore row
treeStoreDefaultDragDestIface)

-- | Create a new list store.
--
-- * In addition to 'treeStoreNew', this function takes an two interfaces
--   to implement user-defined drag-and-drop functionality.
--
treeStoreNewDND :: Forest a -- ^ the inital tree stored in this model
  -> Maybe (DragSourceIface TreeStore a) -- ^ an optional interface for drags
  -> Maybe (DragDestIface TreeStore a) -- ^ an optional interface to handle drops
  -> IO (TreeStore a)
treeStoreNewDND :: Forest a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
treeStoreNewDND forest :: Forest a
forest mDSource :: Maybe (DragSourceIface TreeStore a)
mDSource mDDest :: Maybe (DragDestIface TreeStore a)
mDDest = do
  IORef (Store a)
storeRef <- Store a -> IO (IORef (Store a))
forall a. a -> IO (IORef a)
newIORef Store :: forall a. Depth -> Cache a -> Store a
Store {
      depth :: Depth
depth = Forest a -> Depth
forall a. Forest a -> Depth
calcForestDepth Forest a
forest,
      content :: Cache a
content = Forest a -> Cache a
forall a. Forest a -> Cache a
storeToCache Forest a
forest
    }
  let withStore :: (Store a -> b) -> IO b
withStore f :: Store a -> b
f = IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef IORef (Store a)
storeRef IO (Store a) -> (Store a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> (Store a -> b) -> Store a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store a -> b
f
      withStoreUpdateCache :: (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache f :: Store a -> (b, Cache a)
f = do
        Store a
store <- IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef IORef (Store a)
storeRef
        let (result :: b
result, cache' :: Cache a
cache') = Store a -> (b, Cache a)
f Store a
store
        IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Store a)
storeRef Store a
store { content :: Cache a
content = Cache a
cache' }
        b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
result

  IORef (Store a)
-> (CustomStore (IORef (Store a)) a -> TreeStore a)
-> TreeModelIface a
-> Maybe (DragSourceIface TreeStore a)
-> Maybe (DragDestIface TreeStore a)
-> IO (TreeStore a)
forall (model :: * -> *) row private.
(TreeModelClass (model row), TypedTreeModelClass model) =>
private
-> (CustomStore private row -> model row)
-> TreeModelIface row
-> Maybe (DragSourceIface model row)
-> Maybe (DragDestIface model row)
-> IO (model row)
customStoreNew IORef (Store a)
storeRef CustomStore (IORef (Store a)) a -> TreeStore a
forall a. CustomStore (IORef (Store a)) a -> TreeStore a
TreeStore TreeModelIface :: forall row.
IO [TreeModelFlags]
-> (Depth -> IO (Maybe TreeIter))
-> (TreeIter -> IO Depth)
-> (TreeIter -> IO row)
-> (TreeIter -> IO (Maybe TreeIter))
-> (Maybe TreeIter -> IO (Maybe TreeIter))
-> (TreeIter -> IO Bool)
-> (Maybe TreeIter -> IO Int)
-> (Maybe TreeIter -> Int -> IO (Maybe TreeIter))
-> (TreeIter -> IO (Maybe TreeIter))
-> (TreeIter -> IO ())
-> (TreeIter -> IO ())
-> TreeModelIface row
TreeModelIface {
    treeModelIfaceGetFlags :: IO [TreeModelFlags]
treeModelIfaceGetFlags = [TreeModelFlags] -> IO [TreeModelFlags]
forall (m :: * -> *) a. Monad m => a -> m a
return [],

    treeModelIfaceGetIter :: Depth -> IO (Maybe TreeIter)
treeModelIfaceGetIter = \path :: Depth
path -> (Store a -> Maybe TreeIter) -> IO (Maybe TreeIter)
forall b. (Store a -> b) -> IO b
withStore ((Store a -> Maybe TreeIter) -> IO (Maybe TreeIter))
-> (Store a -> Maybe TreeIter) -> IO (Maybe TreeIter)
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d } -> Depth -> Depth -> Maybe TreeIter
fromPath Depth
d Depth
path,

    treeModelIfaceGetPath :: TreeIter -> IO Depth
treeModelIfaceGetPath = \iter :: TreeIter
iter -> (Store a -> Depth) -> IO Depth
forall b. (Store a -> b) -> IO b
withStore ((Store a -> Depth) -> IO Depth) -> (Store a -> Depth) -> IO Depth
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d } -> Depth -> TreeIter -> Depth
toPath Depth
d TreeIter
iter,

    treeModelIfaceGetRow :: TreeIter -> IO a
treeModelIfaceGetRow  = \iter :: TreeIter
iter -> (Store a -> (a, Cache a)) -> IO a
forall b. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (a, Cache a)) -> IO a)
-> (Store a -> (a, Cache a)) -> IO a
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
        case Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d TreeIter
iter Cache a
cache of
          (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 "TreeStore.getRow: iter does not refer to a valid entry",

    treeModelIfaceIterNext :: TreeIter -> IO (Maybe TreeIter)
treeModelIfaceIterNext = \iter :: TreeIter
iter -> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
forall b. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter))
-> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } -> Depth -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNext Depth
d TreeIter
iter Cache a
cache,

    treeModelIfaceIterChildren :: Maybe TreeIter -> IO (Maybe TreeIter)
treeModelIfaceIterChildren = \mIter :: Maybe TreeIter
mIter -> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
forall b. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter))
-> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
      let iter :: TreeIter
iter = TreeIter -> Maybe TreeIter -> TreeIter
forall a. a -> Maybe a -> a
fromMaybe TreeIter
invalidIter Maybe TreeIter
mIter
       in Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
forall a.
Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNthChild Depth
d 0 TreeIter
iter Cache a
cache,

    treeModelIfaceIterHasChild :: TreeIter -> IO Bool
treeModelIfaceIterHasChild = \iter :: TreeIter
iter -> (Store a -> (Bool, Cache a)) -> IO Bool
forall b. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Bool, Cache a)) -> IO Bool)
-> (Store a -> (Bool, Cache a)) -> IO Bool
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
       let (mIter :: Maybe TreeIter
mIter, cache' :: Cache a
cache') = Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
forall a.
Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNthChild Depth
d 0 TreeIter
iter Cache a
cache
        in (Maybe TreeIter -> Bool
forall a. Maybe a -> Bool
isJust Maybe TreeIter
mIter, Cache a
cache'),

    treeModelIfaceIterNChildren :: Maybe TreeIter -> IO Int
treeModelIfaceIterNChildren = \mIter :: Maybe TreeIter
mIter -> (Store a -> (Int, Cache a)) -> IO Int
forall b. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Int, Cache a)) -> IO Int)
-> (Store a -> (Int, Cache a)) -> IO Int
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
      let iter :: TreeIter
iter = TreeIter -> Maybe TreeIter -> TreeIter
forall a. a -> Maybe a -> a
fromMaybe TreeIter
invalidIter Maybe TreeIter
mIter
       in Depth -> TreeIter -> Cache a -> (Int, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Int, Cache a)
iterNChildren Depth
d TreeIter
iter Cache a
cache,

    treeModelIfaceIterNthChild :: Maybe TreeIter -> Int -> IO (Maybe TreeIter)
treeModelIfaceIterNthChild = \mIter :: Maybe TreeIter
mIter idx :: Int
idx  -> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
forall b. (Store a -> (b, Cache a)) -> IO b
withStoreUpdateCache ((Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter))
-> (Store a -> (Maybe TreeIter, Cache a)) -> IO (Maybe TreeIter)
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
      let iter :: TreeIter
iter = TreeIter -> Maybe TreeIter -> TreeIter
forall a. a -> Maybe a -> a
fromMaybe TreeIter
invalidIter Maybe TreeIter
mIter
       in Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
forall a.
Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNthChild Depth
d Int
idx TreeIter
iter Cache a
cache,

    treeModelIfaceIterParent :: TreeIter -> IO (Maybe TreeIter)
treeModelIfaceIterParent = \iter :: TreeIter
iter -> (Store a -> Maybe TreeIter) -> IO (Maybe TreeIter)
forall b. (Store a -> b) -> IO b
withStore ((Store a -> Maybe TreeIter) -> IO (Maybe TreeIter))
-> (Store a -> Maybe TreeIter) -> IO (Maybe TreeIter)
forall a b. (a -> b) -> a -> b
$
      \Store { depth :: forall a. Store a -> Depth
depth = Depth
d } -> Depth -> TreeIter -> Maybe TreeIter
iterParent Depth
d TreeIter
iter,

    treeModelIfaceRefNode :: TreeIter -> IO ()
treeModelIfaceRefNode = \_ -> () -> 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 TreeStore a)
mDSource Maybe (DragDestIface TreeStore a)
mDDest


-- | Default drag functions for
-- 'Graphics.UI.Gtk.ModelView.TreeStore'. 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.
treeStoreDefaultDragSourceIface :: DragSourceIface TreeStore row
treeStoreDefaultDragSourceIface :: DragSourceIface TreeStore row
treeStoreDefaultDragSourceIface = DragSourceIface :: forall (model :: * -> *) row.
(model row -> Depth -> IO Bool)
-> (model row -> Depth -> SelectionDataM Bool)
-> (model row -> Depth -> IO Bool)
-> DragSourceIface model row
DragSourceIface {
    treeDragSourceRowDraggable :: TreeStore row -> Depth -> IO Bool
treeDragSourceRowDraggable = \_ _-> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True,
    treeDragSourceDragDataGet :: TreeStore row -> Depth -> SelectionDataM Bool
treeDragSourceDragDataGet = TreeStore row -> Depth -> SelectionDataM Bool
forall treeModel.
TreeModelClass treeModel =>
treeModel -> Depth -> SelectionDataM Bool
treeSetRowDragData,
    treeDragSourceDragDataDelete :: TreeStore row -> Depth -> IO Bool
treeDragSourceDragDataDelete = \model :: TreeStore row
model dest :: Depth
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
$ TreeStore row -> Depth -> IO Bool
forall a. TreeStore a -> Depth -> IO Bool
treeStoreRemove TreeStore row
model Depth
dest
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  }

-- | Default drop functions for 'Graphics.UI.Gtk.ModelView.TreeStore'. 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.
treeStoreDefaultDragDestIface :: DragDestIface TreeStore row
treeStoreDefaultDragDestIface :: DragDestIface TreeStore row
treeStoreDefaultDragDestIface = DragDestIface :: forall (model :: * -> *) row.
(model row -> Depth -> SelectionDataM Bool)
-> (model row -> Depth -> SelectionDataM Bool)
-> DragDestIface model row
DragDestIface {
    treeDragDestRowDropPossible :: TreeStore row -> Depth -> SelectionDataM Bool
treeDragDestRowDropPossible = \model :: TreeStore row
model dest :: Depth
dest -> do
      Maybe (TreeModel, Depth)
mModelPath <- SelectionDataM (Maybe (TreeModel, Depth))
treeGetRowDragData
      case Maybe (TreeModel, Depth)
mModelPath of
        Nothing -> Bool -> SelectionDataM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just (model' :: TreeModel
model', source :: Depth
source) -> Bool -> SelectionDataM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (TreeStore row -> TreeModel
forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeStore row
modelTreeModel -> TreeModel -> Bool
forall a. Eq a => a -> a -> Bool
==TreeModel -> TreeModel
forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeModel
model'),
    treeDragDestDragDataReceived :: TreeStore row -> Depth -> SelectionDataM Bool
treeDragDestDragDataReceived = \model :: TreeStore row
model dest :: Depth
dest@(_:_) -> do
      Maybe (TreeModel, Depth)
mModelPath <- SelectionDataM (Maybe (TreeModel, Depth))
treeGetRowDragData
      case Maybe (TreeModel, Depth)
mModelPath of
        Nothing -> Bool -> SelectionDataM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just (model' :: TreeModel
model', source :: Depth
source@(_:_)) ->
          if TreeStore row -> TreeModel
forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeStore row
modelTreeModel -> TreeModel -> Bool
forall a. Eq a => a -> a -> Bool
/=TreeModel -> TreeModel
forall o. TreeModelClass o => o -> TreeModel
toTreeModel TreeModel
model' then Bool -> SelectionDataM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          else IO Bool -> SelectionDataM Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> SelectionDataM Bool) -> IO Bool -> SelectionDataM Bool
forall a b. (a -> b) -> a -> b
$ do
            Tree row
row <- TreeStore row -> Depth -> IO (Tree row)
forall a. TreeStore a -> Depth -> IO (Tree a)
treeStoreGetTree TreeStore row
model Depth
source
            TreeStore row -> Depth -> Int -> Tree row -> IO ()
forall a. TreeStore a -> Depth -> Int -> Tree a -> IO ()
treeStoreInsertTree TreeStore row
model (Depth -> Depth
forall a. [a] -> [a]
init Depth
dest) (Depth -> Int
forall a. [a] -> a
last Depth
dest) Tree row
row
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  }

--------------------------------------------
-- 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 :: TreeIter -> Int -> Int -> Word32
getBitSlice :: TreeIter -> Int -> Int -> Word32
getBitSlice (TreeIter _ 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 :: TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice :: TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice (TreeIter stamp :: CInt
stamp a :: Word32
a b :: Word32
b c :: Word32
c) off :: Int
off count :: Int
count value :: Word32
value =
  Bool -> TreeIter -> TreeIter
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) (TreeIter -> TreeIter) -> TreeIter -> TreeIter
forall a b. (a -> b) -> a -> b
$
  CInt -> Word32 -> Word32 -> Word32 -> TreeIter
TreeIter CInt
stamp
           (Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord Word32
a  Int
off     Int
count Word32
value)
           (Word32 -> Int -> Int -> Word32 -> Word32
setBitSliceWord Word32
b (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
-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 :: TreeIter
invalidIter :: TreeIter
invalidIter = CInt -> Word32 -> Word32 -> Word32 -> TreeIter
TreeIter 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 -> TreeIter -> TreePath
toPath :: Depth -> TreeIter -> Depth
toPath d :: Depth
d iter :: TreeIter
iter = Int -> Depth -> Depth
forall a. Num a => Int -> Depth -> [a]
gP 0 Depth
d
  where
  gP :: Int -> Depth -> [a]
gP pos :: Int
pos [] = []
  gP pos :: Int
pos (d :: Int
d:ds :: Depth
ds) = let idx :: Word32
idx = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
iter Int
pos Int
d in
                  if Word32
idxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==0 then [] else Word32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
idxWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-1) a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> Depth -> [a]
gP (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Depth
ds

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


-- | 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 = [(TreeIter, 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 = [(TreeIter
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 "TreeStore.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 -> (TreeIter, 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 -> TreeIter -> Cache a -> Cache a
advanceCache :: Depth -> TreeIter -> Cache a -> Cache a
advanceCache depth :: Depth
depth goal :: TreeIter
goal [] = []
advanceCache depth :: Depth
depth goal :: TreeIter
goal cache :: Cache a
cache@((rootIter :: TreeIter
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 = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
goal Int
pos Int
d
      curIdx :: Word32
curIdx = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
rootIter Int
pos Int
d
      isNonZero :: Int -> Int -> (TreeIter, b) -> Bool
isNonZero pos :: Int
pos d :: Int
d (ti :: TreeIter
ti,_) = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
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 ((TreeIter, Forest a) -> Bool) -> Cache a -> Cache a
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> (TreeIter, Forest a) -> Bool
forall b. Int -> Int -> (TreeIter, b) -> Bool
isNonZero Int
pos Int
d) 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) (((TreeIter, Forest a) -> Bool) -> Cache a -> Cache a
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> (TreeIter, Forest a) -> Bool
forall b. Int -> Int -> (TreeIter, b) -> Bool
isNonZero Int
pos Int
d) Cache a
cache)
    else let
      -- advance the current iterator to coincide with the goal iterator
      -- at this level
      moveWithinLevel :: Int -> Int -> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
moveWithinLevel pos :: Int
pos d :: Int
d ((ti :: TreeIter
ti,forest :: [Tree a]
forest):parents :: [(TreeIter, [Tree a])]
parents) = let
          diff :: Int
diff = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
goalIdxWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
-Word32
curIdx)
          (dropped :: [Tree a]
dropped, remain :: [Tree a]
remain) = Int -> [Tree a] -> ([Tree a], [Tree a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
diff [Tree a]
forest
          advance :: Int
advance = [Tree a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tree a]
dropped
          ti' :: TreeIter
ti' = TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
ti Int
pos Int
d (Word32
curIdxWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
advance)
        in
        if Int
advanceInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
diff then Int -> Depth -> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Depth
ds ((TreeIter
ti',[Tree a]
remain)(TreeIter, [Tree a])
-> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
forall a. a -> [a] -> [a]
:[(TreeIter, [Tree a])]
parents)
        else (TreeIter
ti',[Tree a]
remain)(TreeIter, [Tree a])
-> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree a])]
forall a. a -> [a] -> [a]
:[(TreeIter, [Tree a])]
parents -- node not found
    in Int -> Int -> Cache a -> Cache a
forall a.
Int -> Int -> [(TreeIter, [Tree a])] -> [(TreeIter, [Tree 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':_) -> ((TreeIter, Forest a) -> Bool) -> Cache a -> Cache a
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Int -> Int -> (TreeIter, Forest a) -> Bool
forall b. Int -> Int -> (TreeIter, b) -> Bool
isNonZero (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Int
d') 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 :: TreeIter
ti,forest :: Forest a
forest):parents :: Cache a
parents)
    | TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
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 (TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
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' :: TreeIter
ti' = TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
ti Int
pos Int
d (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
advancedWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1)
        in if Int
advancedInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
childIdx then ((TreeIter
ti',Forest a
remain)(TreeIter, Forest a) -> Cache a -> Cache a
forall a. a -> [a] -> [a]
:Cache a
cache) else
           Int -> Depth -> Cache a -> Cache a
forall a. Int -> Depth -> Cache a -> Cache a
moveToChild (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
d) Depth
ds ((TreeIter
ti',Forest a
remain)(TreeIter, Forest a) -> Cache a -> Cache a
forall a. a -> [a] -> [a]
:Cache a
cache)

-- | Advance to the given iterator and return weather this was successful.
--
checkSuccess :: Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess :: Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess depth :: Depth
depth iter :: TreeIter
iter cache :: Cache a
cache = case Depth -> TreeIter -> Cache a -> Cache a
forall a. Depth -> TreeIter -> Cache a -> Cache a
advanceCache Depth
depth TreeIter
iter Cache a
cache of
    cache' :: Cache a
cache'@((cur :: TreeIter
cur,sibs :: Forest a
sibs):_) -> (TreeIter -> TreeIter -> Bool
cmp TreeIter
cur TreeIter
iter Bool -> Bool -> Bool
&& Bool -> Bool
not (Forest a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
sibs), Cache a
cache')
    [] -> (Bool
False, [])
  where
  cmp :: TreeIter -> TreeIter -> Bool
cmp (TreeIter _ a1 :: Word32
a1 b1 :: Word32
b1 c1 :: Word32
c1) (TreeIter _ 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 -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf :: Depth -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf ds :: Depth
ds ti :: TreeIter
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)
    | TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
ti (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
dCur) Int
dNextWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==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 -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNext :: Depth -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNext depth :: Depth
depth iter :: TreeIter
iter cache :: Cache a
cache = let
    (pos :: Int
pos,leaf :: Int
leaf,_child :: Int
_child) = Depth -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf Depth
depth TreeIter
iter
    curIdx :: Word32
curIdx = TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
iter Int
pos Int
leaf
    nextIdx :: Word32
nextIdx = Word32
curIdxWord32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1
    nextIter :: TreeIter
nextIter = TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
iter Int
pos Int
leaf Word32
nextIdx
  in
  if Word32
nextIdxWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==Int -> Word32
forall a. Bits a => Int -> a
bit Int
leaf then (Maybe TreeIter
forall a. Maybe a
Nothing, Cache a
cache) else
  case Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth TreeIter
nextIter Cache a
cache of
    (True, cache :: Cache a
cache) -> (TreeIter -> Maybe TreeIter
forall a. a -> Maybe a
Just TreeIter
nextIter, Cache a
cache)
    (False, cache :: Cache a
cache) -> (Maybe TreeIter
forall a. Maybe a
Nothing, Cache a
cache)

-- | Move down to the child of the given iterator.
--
iterNthChild :: Depth -> Int -> TreeIter -> Cache a  ->
                (Maybe TreeIter, Cache a)
iterNthChild :: Depth -> Int -> TreeIter -> Cache a -> (Maybe TreeIter, Cache a)
iterNthChild depth :: Depth
depth childIdx_ :: Int
childIdx_ iter :: TreeIter
iter cache :: Cache a
cache = let
    (pos :: Int
pos,leaf :: Int
leaf,child :: Int
child) = Depth -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf Depth
depth TreeIter
iter
    childIdx :: Word32
childIdx = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
childIdx_Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+1
    nextIter :: TreeIter
nextIter = TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
iter (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
leaf) Int
child Word32
childIdx
  in
  if Word32
childIdxWord32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
>=Int -> Word32
forall a. Bits a => Int -> a
bit Int
child then (Maybe TreeIter
forall a. Maybe a
Nothing, Cache a
cache) else
  case Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth TreeIter
nextIter Cache a
cache of
    (True, cache :: Cache a
cache) -> (TreeIter -> Maybe TreeIter
forall a. a -> Maybe a
Just TreeIter
nextIter, Cache a
cache)
    (False, cache :: Cache a
cache) -> (Maybe TreeIter
forall a. Maybe a
Nothing, Cache a
cache)

-- | Descend to the first child.
--
iterNChildren :: Depth -> TreeIter -> Cache a -> (Int, Cache a)
iterNChildren :: Depth -> TreeIter -> Cache a -> (Int, Cache a)
iterNChildren depth :: Depth
depth iter :: TreeIter
iter cache :: Cache a
cache = case Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
depth TreeIter
iter Cache a
cache of
  (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 -> TreeIter -> Maybe TreeIter
iterParent :: Depth -> TreeIter -> Maybe TreeIter
iterParent depth :: Depth
depth iter :: TreeIter
iter = let
    (pos :: Int
pos,leaf :: Int
leaf,_child :: Int
_child) = Depth -> TreeIter -> (Int, Int, Int)
getTreeIterLeaf Depth
depth TreeIter
iter
  in if Int
posInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==0 then Maybe TreeIter
forall a. Maybe a
Nothing else
     if TreeIter -> Int -> Int -> Word32
getBitSlice TreeIter
iter Int
pos Int
leafWord32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
==0 then Maybe TreeIter
forall a. Maybe a
Nothing else
     TreeIter -> Maybe TreeIter
forall a. a -> Maybe a
Just (TreeIter -> Int -> Int -> Word32 -> TreeIter
setBitSlice TreeIter
iter Int
pos Int
leaf 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.
--
treeStoreInsertForest ::
    TreeStore 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
 -> IO ()
treeStoreInsertForest :: TreeStore a -> Depth -> Int -> Forest a -> IO ()
treeStoreInsertForest (TreeStore model :: CustomStore (IORef (Store a)) a
model) path :: Depth
path pos :: Int
pos nodes :: Forest a
nodes = do
  CustomStore (IORef (Store a)) a -> IO ()
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters 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
model) ((Store a -> (Store a, (Int, Bool))) -> IO (Int, Bool))
-> (Store a -> (Store a, (Int, Bool))) -> IO (Int, Bool)
forall a b. (a -> b) -> a -> b
$
    \store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
    case Forest a -> Forest a -> Depth -> Int -> Maybe (Forest a, Int, Bool)
forall a.
Forest a -> Forest a -> Depth -> Int -> Maybe (Forest a, Int, Bool)
insertIntoForest (Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache) Forest a
nodes Depth
path Int
pos of
      Nothing -> [Char] -> (Store a, (Int, Bool))
forall a. HasCallStack => [Char] -> a
error ("treeStoreInsertForest: path does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Depth -> [Char]
forall a. Show a => a -> [Char]
show Depth
path)
      Just (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
model)
  let rpath :: Depth
rpath = Depth -> Depth
forall a. [a] -> [a]
reverse Depth
path
  CInt
stamp <- CustomStore (IORef (Store a)) a -> IO CInt
forall private row. CustomStore private row -> IO CInt
customStoreGetStamp CustomStore (IORef (Store a)) a
model
  [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ let p' :: Depth
p' = Depth -> Depth
forall a. [a] -> [a]
reverse Depth
p
                  Just iter :: TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
depth Depth
p'
               in CustomStore (IORef (Store a)) a -> Depth -> TreeIter -> IO ()
forall self.
TreeModelClass self =>
self -> Depth -> TreeIter -> IO ()
treeModelRowInserted CustomStore (IORef (Store a)) a
model Depth
p' (TreeIter -> CInt -> TreeIter
treeIterSetStamp TreeIter
iter CInt
stamp)
            | (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
            , Depth
p <- Depth -> Tree a -> [Depth]
forall a. Depth -> Tree a -> [Depth]
paths (Int
i Int -> Depth -> Depth
forall a. a -> [a] -> [a]
: Depth
rpath) Tree a
node ]
  let Just iter :: TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
depth Depth
path
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
toggle (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CustomStore (IORef (Store a)) a -> Depth -> TreeIter -> IO ()
forall self.
TreeModelClass self =>
self -> Depth -> TreeIter -> IO ()
treeModelRowHasChildToggled CustomStore (IORef (Store a)) a
model Depth
path
                (TreeIter -> CInt -> TreeIter
treeIterSetStamp TreeIter
iter CInt
stamp)

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

-- | Insert a node into the store.
--
treeStoreInsertTree ::
    TreeStore 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
 -> IO ()
treeStoreInsertTree :: TreeStore a -> Depth -> Int -> Tree a -> IO ()
treeStoreInsertTree store :: TreeStore a
store path :: Depth
path pos :: Int
pos node :: Tree a
node =
  TreeStore a -> Depth -> Int -> Forest a -> IO ()
forall a. TreeStore a -> Depth -> Int -> Forest a -> IO ()
treeStoreInsertForest TreeStore a
store Depth
path Int
pos [Tree a
node]

-- | 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 'treeStoreInsert'.
--
treeStoreInsert ::
    TreeStore a -- ^ the store
 -> TreePath    -- ^ @path@ - the position of the parent
 -> Int         -- ^ @pos@ - the index of the new tree
 -> a           -- ^ the value to be inserted
 -> IO ()
treeStoreInsert :: TreeStore a -> Depth -> Int -> a -> IO ()
treeStoreInsert store :: TreeStore a
store path :: Depth
path pos :: Int
pos node :: a
node =
  TreeStore a -> Depth -> Int -> Forest a -> IO ()
forall a. TreeStore a -> Depth -> Int -> Forest a -> IO ()
treeStoreInsertForest TreeStore a
store Depth
path Int
pos [a -> Forest a -> Tree a
forall a. a -> 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 -> TreePath -> Int ->
                    Maybe (Forest a, Int, Bool)
insertIntoForest :: Forest a -> Forest a -> Depth -> 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 :: Int
p:ps :: Depth
ps) pos :: Int
pos = case Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
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 -> Depth -> Int -> Maybe (Forest a, Int, Bool)
forall a.
Forest a -> Forest a -> Depth -> Int -> Maybe (Forest a, Int, Bool)
insertIntoForest Forest a
for Forest a
nodes Depth
ps Int
pos of
      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.
--
treeStoreRemove :: TreeStore a -> TreePath -> IO Bool
  --TODO: eliminate this special case without segfaulting!
treeStoreRemove :: TreeStore a -> Depth -> IO Bool
treeStoreRemove (TreeStore model :: CustomStore (IORef (Store a)) a
model) [] = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
treeStoreRemove (TreeStore model :: CustomStore (IORef (Store a)) a
model) path :: Depth
path = do
  CustomStore (IORef (Store a)) a -> IO ()
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters 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 CustomStore (IORef (Store a)) a
model) ((Store a -> (Store a, (Bool, Bool))) -> IO (Bool, Bool))
-> (Store a -> (Store a, (Bool, Bool))) -> IO (Bool, Bool)
forall a b. (a -> b) -> a -> b
$
    \store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } ->
    if Cache a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Cache a
cache then (Store a
store, (Bool
False, Bool
False)) else
    case Forest a -> Depth -> Maybe (Forest a, Bool)
forall a. Forest a -> Depth -> Maybe (Forest a, Bool)
deleteFromForest (Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache) Depth
path of
      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 (Depth -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Depth
path)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Store { depth :: forall a. Store a -> Depth
depth = Depth
depth } <- IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
      let parent :: Depth
parent = Depth -> Depth
forall a. [a] -> [a]
init Depth
path
          Just iter :: TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
depth Depth
parent
      CustomStore (IORef (Store a)) a -> Depth -> TreeIter -> IO ()
forall self.
TreeModelClass self =>
self -> Depth -> TreeIter -> IO ()
treeModelRowHasChildToggled CustomStore (IORef (Store a)) a
model Depth
parent TreeIter
iter
    CustomStore (IORef (Store a)) a -> Depth -> IO ()
forall self. TreeModelClass self => self -> Depth -> IO ()
treeModelRowDeleted CustomStore (IORef (Store a)) a
model Depth
path
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
found

treeStoreClear :: TreeStore a -> IO ()
treeStoreClear :: TreeStore a -> IO ()
treeStoreClear (TreeStore model :: CustomStore (IORef (Store a)) a
model) = do
  CustomStore (IORef (Store a)) a -> IO ()
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters CustomStore (IORef (Store a)) a
model
  Store { content :: forall a. Store a -> Cache a
content = Cache a
cache } <- IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
  let forest :: Forest a
forest = Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache
  IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) Store :: forall a. Depth -> Cache a -> Store a
Store {
      depth :: Depth
depth = Forest Any -> Depth
forall a. Forest a -> Depth
calcForestDepth [],
      content :: Cache a
content = Forest a -> Cache a
forall a. Forest a -> Cache a
storeToCache []
    }
  let loop :: Int -> IO ()
loop (-1) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      loop   n :: Int
n  = CustomStore (IORef (Store a)) a -> Depth -> IO ()
forall self. TreeModelClass self => self -> Depth -> IO ()
treeModelRowDeleted CustomStore (IORef (Store a)) a
model [Int
n] IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
loop (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-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 -> TreePath -> Maybe (Forest a, Bool)
deleteFromForest :: Forest a -> Depth -> 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 :: Int
p:ps :: Depth
ps) =
  case Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
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 Depth -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Depth
ps then (Forest a, Bool) -> Maybe (Forest a, Bool)
forall a. a -> Maybe a
Just (Forest a
prevForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Forest a
next, Forest a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
prev Bool -> Bool -> Bool
&& Forest a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Forest a
next) else
      case Forest a -> Depth -> Maybe (Forest a, Bool)
forall a. Forest a -> Depth -> Maybe (Forest a, Bool)
deleteFromForest Forest a
for Depth
ps of
        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.
--
treeStoreSetValue :: TreeStore a -> TreePath -> a -> IO ()
treeStoreSetValue :: TreeStore a -> Depth -> a -> IO ()
treeStoreSetValue store :: TreeStore a
store path :: Depth
path value :: a
value = TreeStore a -> Depth -> (a -> IO a) -> IO Bool
forall a. TreeStore a -> Depth -> (a -> IO a) -> IO Bool
treeStoreChangeM TreeStore a
store Depth
path (\_ -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
value)
                                  IO Bool -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


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


-- | Change a node in the store.
--
-- * Returns @True@ if the node was found. For a purely functional version, see
--   'treeStoreChange'.
--
treeStoreChangeM :: TreeStore a -> TreePath -> (a -> IO a) -> IO Bool
treeStoreChangeM :: TreeStore a -> Depth -> (a -> IO a) -> IO Bool
treeStoreChangeM (TreeStore model :: CustomStore (IORef (Store a)) a
model) path :: Depth
path act :: a -> IO a
act = do
  CustomStore (IORef (Store a)) a -> IO ()
forall private row. CustomStore private row -> IO ()
customStoreInvalidateIters CustomStore (IORef (Store a)) a
model
  store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } <-
      IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
  (store' :: Store a
store'@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache }, found :: Bool
found) <- do
    Maybe (Forest a)
mRes <- Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
forall a. Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
changeForest (Cache a -> Forest a
forall a. Cache a -> Forest a
cacheToStore Cache a
cache) a -> IO a
act Depth
path
    (Store a, Bool) -> IO (Store a, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Store a, Bool) -> IO (Store a, Bool))
-> (Store a, Bool) -> IO (Store a, Bool)
forall a b. (a -> b) -> a -> b
$ case Maybe (Forest a)
mRes of
      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)
  IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) Store a
store'
  let Just iter :: TreeIter
iter = Depth -> Depth -> Maybe TreeIter
fromPath Depth
d Depth
path
  CInt
stamp <- CustomStore (IORef (Store a)) a -> IO CInt
forall private row. CustomStore private row -> IO CInt
customStoreGetStamp CustomStore (IORef (Store a)) a
model
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
found (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CustomStore (IORef (Store a)) a -> Depth -> TreeIter -> IO ()
forall self.
TreeModelClass self =>
self -> Depth -> TreeIter -> IO ()
treeModelRowChanged CustomStore (IORef (Store a)) a
model Depth
path (TreeIter -> CInt -> TreeIter
treeIterSetStamp TreeIter
iter CInt
stamp)
  Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
found

-- | Change a node in the forest.
--
-- * Returns @True@ if the given node was found.
--
changeForest :: Forest a -> (a -> IO a) -> TreePath -> IO (Maybe (Forest a))
changeForest :: Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
changeForest forest :: Forest a
forest act :: a -> IO a
act [] = Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Forest a)
forall a. Maybe a
Nothing
changeForest forest :: Forest a
forest act :: a -> IO a
act (p :: Int
p:ps :: Depth
ps) = case Int -> Forest a -> (Forest a, Forest a)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
p Forest a
forest of
  (prev :: Forest a
prev, []) -> Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Forest a)
forall a. Maybe a
Nothing
  (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 Depth -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Depth
ps then do
      a
val' <- a -> IO a
act a
val
      Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Forest a -> Maybe (Forest a)
forall a. a -> Maybe a
Just (Forest a
prevForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Node :: forall a. a -> 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 -> IO a) -> Depth -> IO (Maybe (Forest a))
forall a. Forest a -> (a -> IO a) -> Depth -> IO (Maybe (Forest a))
changeForest Forest a
for a -> IO a
act Depth
ps
      case Maybe (Forest a)
mFor of
        Nothing -> Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Forest a)
forall a. Maybe a
Nothing
        Just for :: Forest a
for -> Maybe (Forest a) -> IO (Maybe (Forest a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Forest a) -> IO (Maybe (Forest a)))
-> Maybe (Forest a) -> IO (Maybe (Forest a))
forall a b. (a -> b) -> a -> b
$ Forest a -> Maybe (Forest a)
forall a. a -> Maybe a
Just (Forest a
prevForest a -> Forest a -> Forest a
forall a. [a] -> [a] -> [a]
++Node :: forall a. a -> 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.
--
treeStoreGetValue :: TreeStore a -> TreePath -> IO a
treeStoreGetValue :: TreeStore a -> Depth -> IO a
treeStoreGetValue model :: TreeStore a
model path :: Depth
path = (Tree a -> a) -> IO (Tree a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree a -> a
forall a. Tree a -> a
rootLabel (TreeStore a -> Depth -> IO (Tree a)
forall a. TreeStore a -> Depth -> IO (Tree a)
treeStoreGetTree TreeStore a
model Depth
path)

-- | Extract a subtree from the current model. Fails if the given
--   'TreePath' refers to a non-existent node.
--
treeStoreGetTree :: TreeStore a -> TreePath -> IO (Tree a)
treeStoreGetTree :: TreeStore a -> Depth -> IO (Tree a)
treeStoreGetTree (TreeStore model :: CustomStore (IORef (Store a)) a
model) path :: Depth
path = do
  store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } <-
      IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
  case Depth -> Depth -> Maybe TreeIter
fromPath Depth
d Depth
path of
    (Just iter :: TreeIter
iter) -> do
      let (res :: Bool
res, cache' :: Cache a
cache') = Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d TreeIter
iter Cache a
cache
      IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) Store a
store { content :: Cache a
content = Cache a
cache' }
      case Cache a
cache' of
        ((_,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 ("treeStoreGetTree: path does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Depth -> [Char]
forall a. Show a => a -> [Char]
show Depth
path)
    _ -> [Char] -> IO (Tree a)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ("treeStoreGetTree: path does not exist " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Depth -> [Char]
forall a. Show a => a -> [Char]
show Depth
path)

-- | Extract a subtree from the current model. Like 'treeStoreGetTree'
--   but returns @Nothing@ if the path refers to a non-existant node.
--
treeStoreLookup :: TreeStore a -> TreePath -> IO (Maybe (Tree a))
treeStoreLookup :: TreeStore a -> Depth -> IO (Maybe (Tree a))
treeStoreLookup (TreeStore model :: CustomStore (IORef (Store a)) a
model) path :: Depth
path = do
  store :: Store a
store@Store { depth :: forall a. Store a -> Depth
depth = Depth
d, content :: forall a. Store a -> Cache a
content = Cache a
cache } <-
      IORef (Store a) -> IO (Store a)
forall a. IORef a -> IO a
readIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model)
  case Depth -> Depth -> Maybe TreeIter
fromPath Depth
d Depth
path of
    (Just iter :: TreeIter
iter) -> do
      let (res :: Bool
res, cache' :: Cache a
cache') = Depth -> TreeIter -> Cache a -> (Bool, Cache a)
forall a. Depth -> TreeIter -> Cache a -> (Bool, Cache a)
checkSuccess Depth
d TreeIter
iter Cache a
cache
      IORef (Store a) -> Store a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (CustomStore (IORef (Store a)) a -> IORef (Store a)
forall private row. CustomStore private row -> private
customStoreGetPrivate CustomStore (IORef (Store a)) a
model) Store a
store { content :: Cache a
content = Cache a
cache' }
      case Cache a
cache' of
        ((_,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