FolderTree.hs

{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE BinaryLiterals      #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable  #-}

module Phoityne.IO.GUI.GTK.FolderTree (
  FolderTreeStore
, NodeData(..)
, FolderTreeDoubleClickedHandler
, FolderTreePopupHandler
, FolderTreeCreateFolderAction
, FolderTreeCreateFileAction
, FolderTreeRenameAction
, FolderTreeDeleteAction
, FolderTreeSearchAction
, FolderTreeReplaceAction
, FolderTreeStartupAction
, FolderTreeKeyPressEventHandler
, createTreeStore
, addNode2TreeStore
, setupFolderTree
, getPathFromNodeData
, getModNameFromNodeData
, findTreeNode
, getSelectedFolderTreeNodeData
, getSelectedFolderTreeAllNodeData
, folderTreeMenuPopup
, getNameFromNodeData
, expandCollapseFolderTree
, expandFolderTree
, collapseFolderTree
, updateTreeNode
, changeNameColorOfNodeData
) where

-- モジュール
import Phoityne.Constant
import Phoityne.IO.GUI.GTK.Constant

-- システム
import GHC.Float
import Graphics.UI.Gtk
import Control.Monad.IO.Class
import Data.String.Utils
import qualified Data.Tree as TR
import qualified Data.Text as T

-- |
--  
--
type FolderTreeStore = TreeStore NodeData

type FolderTreeKeyPressEventHandler = String -> Bool -> Bool -> IO Bool

type FolderTreeDoubleClickedHandler = IO ()

type FolderTreePopupHandler = IO ()

type FolderTreeCreateFolderAction = IO ()

type FolderTreeCreateFileAction = IO ()

type FolderTreeRenameAction = IO ()

type FolderTreeDeleteAction = IO ()

type FolderTreeSearchAction = IO ()

type FolderTreeReplaceAction = IO ()

type FolderTreeStartupAction = IO ()


-- |
--  
--
data NodeData =
  FileNodeData {
    moduleFileNodeData :: String
  , nameFileNodeData   :: FilePath
  , pathFileNodeData   :: FilePath
  }
  |
  FolderNodeData {
    moduleFolderNodeData :: String
  , nameFolderNodeData   :: FilePath
  , pathFolderNodeData   :: FilePath
  } deriving (Show, Read, Eq)

instance Ord NodeData where
  compare (FileNodeData x _ _) (FileNodeData x' _ _)
    | x == x'   = EQ
    | x < x'    = LT
    | otherwise = GT

  compare (FolderNodeData x _ _) (FolderNodeData x' _ _)
    | x == x'   = EQ
    | x < x'    = LT
    | otherwise = GT

  compare (FolderNodeData _ _ _) (FileNodeData _ _ _) = LT

  compare (FileNodeData _ _ _) (FolderNodeData _ _ _) = GT

-- |
--
--
getNameFromNodeData :: NodeData -> String
getNameFromNodeData (FileNodeData   _ name _) = name
getNameFromNodeData (FolderNodeData _ name _) = name


-- |
--
--
changeNameColorOfNodeData :: NodeData -> String -> String -> NodeData
changeNameColorOfNodeData nodeDat@(FolderNodeData _ _ _) _ _ = nodeDat
changeNameColorOfNodeData nodeDat@(FileNodeData _ name _) oldCol newCol = nodeDat { nameFileNodeData = changeColor name}
  where
    changeColor val = replace oldCol newCol val

-- |
--
--
getPathFromNodeData :: NodeData -> FilePath
getPathFromNodeData (FileNodeData   _ _ path) = path
getPathFromNodeData (FolderNodeData _ _ path) = path

-- |
--
--
getModNameFromNodeData :: NodeData -> String
getModNameFromNodeData (FileNodeData   name _ _) = name
getModNameFromNodeData (FolderNodeData name _ _) = name

-- |
--
--
createTreeStore :: TR.Tree NodeData -> IO FolderTreeStore
createTreeStore tree = treeStoreNew [tree]


-- |
--  Event Handler
--
folderTreeKeyPressEventHandler :: TreeView -> FolderTreeKeyPressEventHandler -> EventM EKey Bool
folderTreeKeyPressEventHandler _ evh = do
  name <- eventKeyName
  mods <- eventModifier

  liftIO $ evh (T.unpack name) (elem Shift mods) (elem Control mods)

-- |
--
--
setupFolderTree :: Builder
                -> FolderTreeStore
                -> FolderTreeDoubleClickedHandler
                -> FolderTreePopupHandler
                -> FolderTreeCreateFolderAction
                -> FolderTreeCreateFileAction
                -> FolderTreeRenameAction
                -> FolderTreeDeleteAction
                -> FolderTreeSearchAction
                -> FolderTreeReplaceAction
                -> FolderTreeKeyPressEventHandler
                -> FolderTreeStartupAction
                -> IO ()
setupFolderTree builder store doublEH popupEH creteFolderAct createFileAct renameAct deleteAct searchAct replaceAct keyHandler startupAct = do

  colLabel <- labelNew $ Just "Explorer"

  col <- treeViewColumnNew
  treeViewColumnSetWidget col $ Just colLabel

  renderer <- cellRendererTextNew
  cellLayoutPackStart col renderer True

  cellLayoutSetAttributes col renderer store $ \cell -> [ cellTextMarkup := Just (getNameFromNodeData cell)]

  _ <- builderGetObject builder castToMenu _NAME_TREE_VIEW_MENU

  treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW
  _ <- treeViewSetModel treeView store
  _ <- treeViewAppendColumn treeView col
  _ <- on treeView buttonPressEvent $ folderTreeClickedHandler treeView doublEH popupEH
  _ <- on treeView popupMenuSignal $ getSelectedFolderTreeNodeData builder store >>= folderTreeMenuPopup builder >> return True
  _ <- on treeView keyPressEvent $ folderTreeKeyPressEventHandler treeView keyHandler

  treeViewCreateFolderAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FOLDER
  _ <- on treeViewCreateFolderAction actionActivated creteFolderAct

  treeViewCreateFileAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FILE
  _ <- on treeViewCreateFileAction actionActivated createFileAct

  treeViewRenameAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_RENAME
  _ <- on treeViewRenameAction actionActivated renameAct

  treeViewDeleteAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_DELETE
  _ <- on treeViewDeleteAction actionActivated deleteAct

  treeViewSearchAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_SEARCH
  _ <- on treeViewSearchAction actionActivated searchAct

  treeViewReplaceAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_REPLACE
  _ <- on treeViewReplaceAction actionActivated replaceAct

  treeViewStartupAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_STARTUP
  _ <- on treeViewStartupAction actionActivated startupAct

  widgetShowAll colLabel
  widgetShowAll treeView



-- |
--  Event Handler
-- 
folderTreeClickedHandler :: TreeView
                         -> FolderTreeDoubleClickedHandler
                         -> FolderTreePopupHandler
                         -> EventM EButton Bool
folderTreeClickedHandler treeView doubleEH popupEH = do
  bt <- eventButton
  ck <- eventClick

  (posXd, posYd) <- eventCoordinates 
  liftIO $ do
    treeViewGetPathAtPos treeView (double2Int posXd, double2Int posYd) >>= \case
      Nothing -> return False
      Just (treePath, _, _) -> do
        sel <- treeViewGetSelection treeView
        treeSelectionSelectPath sel treePath
        handle bt ck

  where
    handle LeftButton  DoubleClick = doubleEH >> return True
    handle RightButton SingleClick = popupEH  >> return True
    handle _ _ = return False

-- |
--  Event Handler
-- 
folderTreeMenuPopup :: Builder -> Maybe NodeData -> IO ()
folderTreeMenuPopup builder (Just (FolderNodeData _ fileName _))
  | _PROJECT_ROOT_MODULE_NAME == fileName = return ()
  | otherwise = do
    treeViewCreateFolderAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FOLDER
    actionSetSensitive treeViewCreateFolderAction True
    treeViewCreateFileAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FILE
    actionSetSensitive treeViewCreateFileAction True
    treeViewStartupAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_STARTUP
    actionSetSensitive treeViewStartupAction False
    treeViewMenu <- builderGetObject builder castToMenu _NAME_TREE_VIEW_MENU
    menuPopup treeViewMenu Nothing
folderTreeMenuPopup builder (Just (FileNodeData _ _ path)) = do
  treeViewCreateFolderAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FOLDER
  actionSetSensitive treeViewCreateFolderAction False
  treeViewCreateFileAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_CREATE_FILE
  actionSetSensitive treeViewCreateFileAction False

  treeViewStartupAction <- builderGetObject builder castToAction _NAME_TREE_VIEW_MENU_STARTUP
  actionSetSensitive treeViewStartupAction (endswith _HS_FILE_EXT path)
    

  treeViewMenu <- builderGetObject builder castToMenu _NAME_TREE_VIEW_MENU
  menuPopup treeViewMenu Nothing

folderTreeMenuPopup _ _ = return ()


-- |
--
--
addNode2TreeStore :: FolderTreeStore -> NodeData -> NodeData -> IO ()
addNode2TreeStore store parent@(FolderNodeData _ _ _) child = do
  findTreeNodeIter store (\n->n == parent) >>= \case
    Nothing -> return ()
    Just iter -> do
      path <- treeIter2Path store iter
      childIdx  <- getInsertIndex iter
      treeStoreInsert store path childIdx child

  where
    getInsertIndex parentIter = do
      let model = castToTreeModel store
      treeModelIterChildren model parentIter >>= \case
        Nothing -> return 0
        Just iter -> getIndexWithIter iter 0

    getIndexWithIter iter idx = do
      path <- treeIter2Path store iter
      value <- treeStoreGetValue store path
      if child < value then return idx
        else searchNext iter (idx+1)

    searchNext iter idx = do
      let model = castToTreeModel store
      treeModelIterNext model iter >>= \case
        Nothing -> return idx
        Just next -> getIndexWithIter next idx

addNode2TreeStore _ _ _ = return ()

-- |
--
--
treeIter2Path :: TreeStore a -> TreeIter -> IO TreePath
treeIter2Path store iter = treeModelGetPath (castToTreeModel store) iter

-- |
--
--
findTreeNode :: FolderTreeStore -> (NodeData -> Bool) -> IO (Maybe NodeData)
findTreeNode store finder = do
  findTreeNodeIter store finder >>= \case
    Nothing   -> return Nothing
    Just iter -> do
      path <- treeIter2Path store iter
      value <- treeStoreGetValue store path
      return $ Just value

-- |
--
--
updateTreeNode :: FolderTreeStore -> NodeData -> NodeData -> IO ()
updateTreeNode store oldDat newDat = do
  findTreeNodeIter store ((==) oldDat) >>= \case
    Nothing   -> return ()
    Just iter -> do
      path <- treeIter2Path store iter
      treeStoreSetValue store path newDat

-- |
--
--
findTreeNodeIter :: FolderTreeStore -> (NodeData -> Bool) -> IO (Maybe TreeIter)
findTreeNodeIter store finder = do
  let model = castToTreeModel store
  treeModelGetIterFirst model >>= \case
    Nothing -> return Nothing
    Just iter -> findTreeNodeByIter model iter

  where
    findTreeNodeByIter model iter = do
      path <- treeModelGetPath model iter
      node <- treeStoreGetValue store path

      if True == finder node then return (Just iter) else searchChild model iter

    searchChild model iter =
      treeModelIterChildren model iter >>= \case
        Just child -> findTreeNodeByIter model child >>= \case
          Just iter -> return (Just iter)
          Nothing -> searchNext model iter

        Nothing -> searchNext model iter

    searchNext model iter =
      treeModelIterNext model iter >>= \case
        Just next -> findTreeNodeByIter model next
        Nothing -> return Nothing

-- |
--  Event Handler
-- 
getSelectedFolderTreeNodeData :: Builder -> TreeStore NodeData -> IO (Maybe NodeData)
getSelectedFolderTreeNodeData builder store = do
  treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW
  sel <- treeViewGetSelection treeView
  treeSelectionGetSelected sel >>= \case
    Nothing   -> return Nothing
    Just iter -> treeViewGetModel treeView >>= \case
      Nothing    -> return Nothing
      Just model -> do
        path <- treeModelGetPath model iter
        val  <- treeStoreGetValue store path
        return $ Just val

-- |
--  Event Handler
-- 
getSelectedFolderTreeAllNodeData :: Builder -> TreeStore NodeData -> IO [NodeData]
getSelectedFolderTreeAllNodeData builder store = do
  treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW
  sel <- treeViewGetSelection treeView
  treeSelectionGetSelected sel >>= \case
    Nothing   -> return []
    Just iter -> treeViewGetModel treeView >>= \case
      Nothing    -> return []
      Just model -> do
        path <- treeModelGetPath model iter
        val  <- treeStoreGetValue store path
        treeModelIterChildren model iter >>= \case
          Just childIter -> collectAll model childIter [val]
          Nothing -> return [val]

  where
    collectAll model iter acc = do
      path <- treeModelGetPath model iter
      val  <- treeStoreGetValue store path

      let acc' = val : acc
      acc'' <- treeModelIterChildren model iter >>= \case
        Just childIter -> collectAll model childIter acc'
        Nothing -> return acc'

      treeModelIterNext model iter >>= \case
        Just nextIter -> collectAll model nextIter acc''
        Nothing -> return acc''

-- |
--
-- 
expandCollapseFolderTree :: Builder -> TreeStore NodeData -> IO ()
expandCollapseFolderTree builder store = do
  treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW
  sel <- treeViewGetSelection treeView
  treeSelectionGetSelected sel >>= \case
    Nothing   -> return ()
    Just iter -> do
      path <- treeIter2Path store iter
      treeViewRowExpanded treeView path >>= \case
        True  -> treeViewCollapseRow treeView path >> return ()
        False -> treeViewExpandToPath treeView path

-- |
--
-- 
expandFolderTree :: Builder -> TreeStore NodeData -> IO ()
expandFolderTree builder store = do
  treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW
  sel <- treeViewGetSelection treeView
  treeSelectionGetSelected sel >>= \case
    Nothing   -> return ()
    Just iter -> do
      path <- treeIter2Path store iter
      treeViewRowExpanded treeView path >>= \case
        True  -> return ()
        False -> treeViewExpandToPath treeView path

-- |
--
-- 
collapseFolderTree :: Builder -> TreeStore NodeData -> IO ()
collapseFolderTree builder store = do
  treeView <- builderGetObject builder castToTreeView _NAME_TREE_VIEW
  sel <- treeViewGetSelection treeView
  treeSelectionGetSelected sel >>= \case
    Nothing   -> return ()
    Just iter -> do
      path <- treeIter2Path store iter
      treeViewRowExpanded treeView path >>= \case
        True  -> treeViewCollapseRow treeView path >> return ()
        False -> return ()