LargeTreeStore.hs

-- -*-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)