gtk-largeTreeStore (empty) → 0.0.1.0
raw patch · 5 files changed
+651/−0 lines, 5 filesdep +basedep +containersdep +glibsetup-changed
Dependencies added: base, containers, glib, gtk-largeTreeStore, gtk3, hspec, mtl, nested-sets
Files
- LICENSE +165/−0
- Setup.hs +7/−0
- gtk-largeTreeStore.cabal +43/−0
- src/lib/GtkExtras/LargeTreeStore.hs +434/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ 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.
+ Setup.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain+
+ gtk-largeTreeStore.cabal view
@@ -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 <rakatan@gmail.com>+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+
+ src/lib/GtkExtras/LargeTreeStore.hs view
@@ -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)+
+ test/Spec.hs view
@@ -0,0 +1,2 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+