diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+ This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+ 0. Additional Definitions.
+
+ As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+ "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+ An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+ A "Combined Work" is a work produced by combining or linking an
+Application with the Library. The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+ The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+ The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+ 1. Exception to Section 3 of the GNU GPL.
+
+ You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+ 2. Conveying Modified Versions.
+
+ If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+ a) under this License, provided that you make a good faith effort to
+ ensure that, in the event an Application does not supply the
+ function or data, the facility still operates, and performs
+ whatever part of its purpose remains meaningful, or
+
+ b) under the GNU GPL, with none of the additional permissions of
+ this License applicable to that copy.
+
+ 3. Object Code Incorporating Material from Library Header Files.
+
+ The object code form of an Application may incorporate material from
+a header file that is part of the Library. You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+ a) Give prominent notice with each copy of the object code that the
+ Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the object code with a copy of the GNU GPL and this license
+ document.
+
+ 4. Combined Works.
+
+ You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+ a) Give prominent notice with each copy of the Combined Work that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the Combined Work with a copy of the GNU GPL and this license
+ document.
+
+ c) For a Combined Work that displays copyright notices during
+ execution, include the copyright notice for the Library among
+ these notices, as well as a reference directing the user to the
+ copies of the GNU GPL and this license document.
+
+ d) Do one of the following:
+
+ 0) Convey the Minimal Corresponding Source under the terms of this
+ License, and the Corresponding Application Code in a form
+ suitable for, and under terms that permit, the user to
+ recombine or relink the Application with a modified version of
+ the Linked Version to produce a modified Combined Work, in the
+ manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.
+
+ 1) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (a) uses at run time
+ a copy of the Library already present on the user's computer
+ system, and (b) will operate properly with a modified version
+ of the Library that is interface-compatible with the Linked
+ Version.
+
+ e) Provide Installation Information, but only if you would otherwise
+ be required to provide such information under section 6 of the
+ GNU GPL, and only to the extent that such information is
+ necessary to install and execute a modified version of the
+ Combined Work produced by recombining or relinking the
+ Application with a modified version of the Linked Version. (If
+ you use option 4d0, the Installation Information must accompany
+ the Minimal Corresponding Source and Corresponding Application
+ Code. If you use option 4d1, you must provide the Installation
+ Information in the manner specified by section 6 of the GNU GPL
+ for conveying Corresponding Source.)
+
+ 5. Combined Libraries.
+
+ You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+ a) Accompany the combined library with a copy of the same work based
+ on the Library, uncombined with any other library facilities,
+ conveyed under the terms of this License.
+
+ b) Give prominent notice with the combined library that part of it
+ is a work based on the Library, and explaining where to find the
+ accompanying uncombined form of the same work.
+
+ 6. Revised Versions of the GNU Lesser General Public License.
+
+ The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+ If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,7 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
+
diff --git a/gtk-largeTreeStore.cabal b/gtk-largeTreeStore.cabal
new file mode 100644
--- /dev/null
+++ b/gtk-largeTreeStore.cabal
@@ -0,0 +1,43 @@
+name: gtk-largeTreeStore
+version: 0.0.1.0
+cabal-version: >=1.10
+build-type: Simple
+license: LGPL-3
+license-file: LICENSE
+copyright: (c) Sarunas Valaskevicius
+maintainer: Sarunas Valaskevicius
+synopsis: Large TreeStore support for gtk2hs
+description: Uses nested set model to store tree iterators and achieves larger data support than the
+ original gtk2hs implementation.
+homepage:
+stability: alpha
+bug-reports:
+category: Graphics, Data Structures
+author: Sarunas Valaskevicius
+
+source-repository head
+ type: git
+ location: https://github.com/svalaskevicius/gtk2hs-largeTreeStore
+
+library
+ Exposed-modules: GtkExtras.LargeTreeStore
+ default-language: Haskell2010
+ ghc-options:
+ -Wall
+ hs-source-dirs: src/lib
+ build-depends: base >= 4.6.0.0 && < 5, glib >=0.13.0.0, gtk3 >=0.13.0.0, containers >= 0.5.5.0,
+ mtl >= 2.1.3.0, nested-sets >= 0.0.1.0
+
+test-suite spec
+ type:
+ exitcode-stdio-1.0
+ default-language: Haskell2010
+ ghc-options:
+ -Wall -Werror
+ hs-source-dirs:
+ test
+ main-is:
+ Spec.hs
+ other-modules:
+ build-depends: base >= 4.6.0.0, gtk-largeTreeStore, hspec >= 1.11.4, containers >= 0.5.5.0, gtk3 >= 0.13.0.0
+
diff --git a/src/lib/GtkExtras/LargeTreeStore.hs b/src/lib/GtkExtras/LargeTreeStore.hs
new file mode 100644
--- /dev/null
+++ b/src/lib/GtkExtras/LargeTreeStore.hs
@@ -0,0 +1,434 @@
+-- -*-haskell-*-
+-- GIMP Toolkit (GTK) CustomStore TreeModel
+--
+-- Author : Duncan Coutts, Axel Simon, Sarunas Valaskevicius
+--
+-- Copyright (C) 2014 Sarunas Valaskevicius
+-- 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 : rakatan@gmail.com
+-- Stability : provisional
+-- Portability : portable (depends on GHC)
+--
+-- Standard model to store hierarchical data.
+--
+module GtkExtras.LargeTreeStore (
+-- * Types
+ TreeStore,
+
+-- * Constructors
+ treeStoreNew,
+ treeStoreNewDND,
+
+-- * Implementation of Interfaces
+ treeStoreDefaultDragSourceIface,
+ treeStoreDefaultDragDestIface,
+
+-- * Methods
+ treeStoreGetValue,
+ treeStoreSetValue,
+
+ treeStoreChange,
+ treeStoreChangeM,
+
+ treeStoreInsertForest,
+ treeStoreInsert,
+ treeStoreInsertTree,
+
+ treeStoreRemove,
+ treeStoreClear,
+
+ treeStoreGetTree,
+ ) where
+
+import Control.Monad (liftM, void, when)
+import Control.Monad.Trans (liftIO)
+import Data.Functor ((<$>))
+import Data.IORef
+import Data.Maybe (fromJust)
+import Data.NestedSet
+import Data.Tree
+import Foreign.C.Types (CInt (..))
+import Graphics.UI.Gtk.ModelView.CustomStore
+import Graphics.UI.Gtk.ModelView.TreeDrag
+import Graphics.UI.Gtk.ModelView.TreeModel
+import System.Glib.GObject
+
+-- | 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 tm) = toGObject tm
+ unsafeCastGObject = TreeStore . unsafeCastGObject
+
+data Store a = Store {
+ nestedSets :: NestedSets 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.
+--
+treeStoreNew :: Forest a -> IO (TreeStore a)
+treeStoreNew forest = treeStoreNewDND forest
+ (Just treeStoreDefaultDragSourceIface)
+ (Just 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 mDSource mDDest = do
+ storeRef <- newIORef Store {
+ nestedSets = forestToNestedSets forest
+ }
+ let withStore f = liftM f $ readIORef storeRef
+
+ customStoreNew storeRef TreeStore TreeModelIface {
+ treeModelIfaceGetFlags = return [],
+
+ treeModelIfaceGetIter = \path -> withStore $
+ \Store { nestedSets = sets } -> fromPath sets path,
+
+ treeModelIfaceGetPath = \iter -> withStore $
+ \Store { nestedSets = sets } -> toPath sets iter,
+
+ treeModelIfaceGetRow = withStore . getIterValueInStore,
+
+ treeModelIfaceIterNext = \iter -> withStore $
+ \Store { nestedSets = sets } ->
+ fmap positionToIter $ nestedSetsNextSiblingPosition sets . positionFromIter $ iter,
+
+ treeModelIfaceIterChildren = maybe (return $ Just invalidIter)
+ (\iter -> withStore $
+ \Store { nestedSets = sets } ->
+ fmap positionToIter $ nestedSetsFirstChildPosition sets . positionFromIter $ iter),
+
+ treeModelIfaceIterHasChild = \iter -> withStore $
+ \Store { nestedSets = sets } -> not . null . children . fromJust . nestedSetByPath sets . toPath sets $ iter,
+
+ treeModelIfaceIterNChildren = maybe
+ (withStore $ \Store { nestedSets = sets } -> length sets)
+ (\iter -> withStore $
+ \Store { nestedSets = sets } -> length . children . fromJust . nestedSetByPath sets . toPath sets $ iter),
+
+ treeModelIfaceIterNthChild = \mIter idx -> maybe
+ (withStore $ \Store { nestedSets = sets } -> fromPath sets [idx])
+ (\iter -> withStore $
+ \Store { nestedSets = sets } -> fromPath sets (toPath sets iter ++ [idx]))
+ mIter,
+
+ treeModelIfaceIterParent = \iter -> withStore $
+ \Store { nestedSets = sets } ->
+ fmap positionToIter $ nestedSetsParentPosition sets . positionFromIter $ iter,
+
+ treeModelIfaceRefNode = \_ -> return (),
+ treeModelIfaceUnrefNode = \_ -> return ()
+ } mDSource 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 {
+ treeDragSourceRowDraggable = \_ _-> return True,
+ treeDragSourceDragDataGet = treeSetRowDragData,
+ treeDragSourceDragDataDelete = \model dest@(_:_) -> do
+ _ <- liftIO $ treeStoreRemove model dest
+ return 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 {
+ treeDragDestRowDropPossible = \model _ -> do
+ mModelPath <- treeGetRowDragData
+ case mModelPath of
+ Nothing -> return False
+ Just (model', _) -> return (toTreeModel model==toTreeModel model'),
+ treeDragDestDragDataReceived = \model dest@(_:_) -> do
+ mModelPath <- treeGetRowDragData
+ case mModelPath of
+ Nothing -> return False
+ Just (model', source) ->
+ if toTreeModel model /= toTreeModel model' then return False
+ else liftIO $ do
+ row <- treeStoreGetTree model source
+ treeStoreInsertTree model (init dest) (last dest) row
+ return True
+ }
+
+-- | The invalid tree iterator.
+--
+invalidIter :: TreeIter
+invalidIter = TreeIter 0 0 0 0
+
+-- update the stamp of a tree iter
+treeIterSetStamp :: TreeIter -> CInt -> TreeIter
+treeIterSetStamp (TreeIter _ a b c) s = TreeIter s a b c
+
+positionFromIter :: TreeIter -> Position
+positionFromIter (TreeIter _ _ left right) = (fromIntegral left, fromIntegral right)
+
+positionToIter :: Position -> TreeIter
+positionToIter = setPositionToIter invalidIter
+
+setPositionToIter :: TreeIter -> Position -> TreeIter
+setPositionToIter (TreeIter stamp a _ _) (left, right) = TreeIter stamp a (fromIntegral left) (fromIntegral right)
+
+-- | Convert an iterator into a path.
+--
+toPath :: NestedSets a -> TreeIter -> TreePath
+toPath sets iter = positionToPath sets (positionFromIter iter) 0
+ where positionToPath [] _ _ = []
+ positionToPath (first : ds) pos nr
+ | position first == pos = [nr]
+ | isNestedSetsPositionParent (position first) pos = nr:positionToPath (children first) pos 0
+ | otherwise = positionToPath ds pos (nr+1)
+
+-- | Try to convert a path into a 'TreeIter'.
+--
+fromPath :: NestedSets a -> TreePath -> Maybe TreeIter
+fromPath sets path = positionToIter <$> positionFromPath
+ where positionFromPath = position <$> nestedSetByPath sets path
+
+getIterValueInStore :: TreeIter -> Store a -> a
+getIterValueInStore iter (Store{nestedSets = sets}) = content . fromJust . nestedSetByPath sets . toPath sets $ iter
+
+-- | 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 model) path pos nodes = do
+ customStoreInvalidateIters model
+ (idx, toggle) <- atomicModifyIORef (customStoreGetPrivate model) $
+ \Store { nestedSets = sets } ->
+ case insertIntoForest (nestedSetsToForest sets) nodes path pos of
+ Nothing -> error ("treeStoreInsertForest: path does not exist " ++ show path)
+ Just (newForest, idx, toggle) -> (Store { nestedSets = forestToNestedSets newForest }, (idx, toggle))
+ Store { nestedSets = sets } <- readIORef (customStoreGetPrivate model)
+ let rpath = reverse path
+ stamp <- customStoreGetStamp model
+ sequence_ [ let p' = reverse p
+ Just iter = fromPath sets p'
+ in treeModelRowInserted model p' (treeIterSetStamp iter stamp)
+ | (i, node) <- zip [idx..] nodes
+ , p <- paths (i : rpath) node ]
+ when toggle $ emitRowChildToggledEvent stamp $ fromPath sets path
+
+ where paths :: TreePath -> Tree a -> [TreePath]
+ paths path' Node { subForest = ts } =
+ path' : concat [ paths (n:path') t | (n, t) <- zip [0..] ts ]
+ emitRowChildToggledEvent _ Nothing = return()
+ emitRowChildToggledEvent stamp (Just iter) = treeModelRowHasChildToggled model path (treeIterSetStamp iter stamp)
+
+-- | 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 store path pos node =
+ treeStoreInsertForest store path pos [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 store path pos node =
+ treeStoreInsertForest store path pos [Node 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 nodes [] pos
+ | pos<0 = Just (forest++nodes, length forest, null forest)
+ | otherwise = Just (prev++nodes++next, length prev, null forest)
+ where (prev, next) = splitAt pos forest
+insertIntoForest forest nodes (p:ps) pos = case splitAt p forest of
+ (_, []) -> Nothing
+ (prev, Node { rootLabel = val,
+ subForest = for}:next) ->
+ case insertIntoForest for nodes ps pos of
+ Nothing -> Nothing
+ Just (for', pos', toggle) -> Just (prev++Node { rootLabel = val,
+ subForest = for' }:next,
+ pos', 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
+treeStoreRemove (TreeStore model) path = do
+ customStoreInvalidateIters model
+ (found, toggle) <- atomicModifyIORef (customStoreGetPrivate model) $
+ \store -> case deleteFromNestedSets (nestedSets store) path of
+ Nothing -> (store, (False, False))
+ Just (sets, toggle) -> (store{nestedSets = sets}, (True, toggle))
+
+ when found $ do
+ when (toggle && not (null path)) $ do
+ Store{nestedSets = sets} <- readIORef (customStoreGetPrivate model)
+ let parent = init path
+ Just iter = fromPath sets parent
+ stamp <- customStoreGetStamp model
+ treeModelRowHasChildToggled model parent (treeIterSetStamp iter stamp)
+ treeModelRowDeleted model path
+ return found
+
+
+treeStoreClear :: TreeStore a -> IO ()
+treeStoreClear (TreeStore model) = do
+ customStoreInvalidateIters model
+ Store { nestedSets = sets } <- readIORef (customStoreGetPrivate model)
+ writeIORef (customStoreGetPrivate model) Store {
+ nestedSets = forestToNestedSets []
+ }
+ let loop (-1) = return ()
+ loop n = treeModelRowDeleted model [n] >> loop (n-1)
+ loop (length sets - 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.
+--
+deleteFromNestedSets :: NestedSets a -> TreePath -> Maybe (NestedSets a, Bool)
+deleteFromNestedSets _ [] = Nothing
+deleteFromNestedSets sets (p:ps) = case splitAt p sets of
+ (_, []) -> Nothing
+ (prev, node@NestedSetsNode{children = subSets}:next) ->
+ if null ps then Just (prev++next, null prev && null next) else
+ case deleteFromNestedSets subSets ps of
+ Nothing -> Nothing
+ Just (subSets', toggle) -> Just (prev++node{children=subSets'}:next, toggle)
+
+-- | Set a node in the store.
+--
+treeStoreSetValue :: TreeStore a -> TreePath -> a -> IO ()
+treeStoreSetValue store path value = void $ treeStoreChangeM store path (\_ -> return value)
+
+
+-- | 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 store path func = treeStoreChangeM store path (return . 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 model) path act = do
+ customStoreInvalidateIters model
+ store@Store { nestedSets = sets } <- readIORef (customStoreGetPrivate model)
+ (store'@Store { nestedSets = sets' }, found) <- do
+ mRes <- changeNestedSets sets act path
+ return $ case mRes of
+ Nothing -> (store, False)
+ Just sets' -> (Store { nestedSets = sets' }, True)
+ when found $ writeIORef (customStoreGetPrivate model) store'
+ let Just iter = fromPath sets' path
+ stamp <- customStoreGetStamp model
+ when found $ treeModelRowChanged model path (treeIterSetStamp iter stamp)
+ return found
+
+-- | Change a node in the 'NestedSets'.
+changeNestedSets :: NestedSets a -> (a -> IO a) -> TreePath -> IO (Maybe (NestedSets a))
+changeNestedSets _ _ [] = return Nothing
+changeNestedSets sets act (p:ps) = case splitAt p sets of
+ (_, []) -> return Nothing
+ (prev, node : next) -> do
+ node' <- (if null ps then updateLeaf else updateBranch) node
+ return $ fmap (mergeNode prev next) node'
+ where updateLeaf node@NestedSetsNode{content = val} = do
+ val' <- act val
+ return . Just $ node{content = val'}
+ updateBranch node@NestedSetsNode{children = subSets} = do
+ subSets' <- changeNestedSets subSets act ps
+ case subSets' of
+ Nothing -> return Nothing
+ Just subSets'' -> return . Just $ node{children = subSets''}
+ mergeNode prev next node = prev ++ node : 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 model) path = do
+ Store { nestedSets = sets } <- readIORef (customStoreGetPrivate model)
+ return $ nestedSetValueByPath sets path
+ where nestedSetValueByPath sets = content . fromJust . nestedSetByPath sets
+
+treeStoreGetTree :: TreeStore a -> TreePath -> IO (Tree a)
+treeStoreGetTree (TreeStore model) path = do
+ Store { nestedSets = sets } <- readIORef (customStoreGetPrivate model)
+ return $ nestedSubtree . fromJust . nestedSetByPath sets $ path
+ where nestedSubtree node = Node (content node) (map nestedSubtree $ children node)
+
+nestedSetByPath :: NestedSets a -> TreePath -> Maybe (NestedSetsNode a)
+nestedSetByPath _ [] = Nothing
+nestedSetByPath sets (first:rest) = (sets `maybeNth` first) >>= (`nestedSetChildrenByPath` rest)
+ where nestedSetChildrenByPath set ([]) = Just set
+ nestedSetChildrenByPath set (p:ds) = (children set `maybeNth` p) >>= (`nestedSetChildrenByPath` ds)
+
+maybeNth :: [a] -> Int -> Maybe a
+maybeNth [] _ = Nothing
+maybeNth (r:_) 0 = Just r
+maybeNth (_:rs) n = maybeNth rs (n-1)
+
diff --git a/test/Spec.hs b/test/Spec.hs
new file mode 100644
--- /dev/null
+++ b/test/Spec.hs
@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+