Workspaces.hs

-----------------------------------------------------------------------------
--
-- Module      :  IDE.Command.VCS.Common.Workspaces
-- Copyright   :  2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
-- License     :  GPL Nothing
--
-- Maintainer  :  maintainer@leksah.org
-- Stability   :  provisional
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

module IDE.Command.VCS.Common.Workspaces (
    onWorkspaceOpen
    , onWorkspaceClose
) where

-- VCS imports
import IDE.Utils.FileUtils(getConfigFilePathForLoad)
import qualified IDE.Utils.GUIUtils as GUIUtils
import IDE.Core.Types
import IDE.Core.State
import qualified IDE.Command.VCS.Common as Common
import qualified IDE.Command.VCS.SVN as SVN (mkSVNActions)
import qualified IDE.Command.VCS.GIT as GIT (mkGITActions)
import qualified IDE.Command.VCS.Common.GUI as GUI

import qualified VCSWrapper.Common as VCS
import qualified VCSGui.Common as VCSGUI

import Data.IORef(writeIORef, readIORef, IORef(..))
import Control.Monad.Reader(liftIO,ask,when)

import Graphics.UI.Frame.Panes
import Graphics.UI.Gtk (
    menuNew, menuItemNewWithLabel, menuItemActivate, menuShellAppend, menuItemSetSubmenu
        ,widgetShowAll, menuItemNewWithMnemonic, menuItemGetSubmenu, widgetHide, widgetDestroy, menuItemRemoveSubmenu)

import Data.Maybe
import Data.List
import System.Log.Logger (debugM)

onWorkspaceClose :: IDEAction
onWorkspaceClose = do
        vcsItem <- GUIUtils.getVCS
        liftIO $ menuItemRemoveSubmenu vcsItem

onWorkspaceOpen :: Workspace -> IDEAction
onWorkspaceOpen ws = do
        liftIO $ debugM "leksah" "onWorkspaceOpen"
        let mbPackages = wsPackages ws
        packages <- mapM (mapper ws)
                                 mbPackages
        vcsItem <- GUIUtils.getVCS
        vcsMenu <- liftIO $ menuNew

        ideR <- ask

        --for each package add an extra menu containing vcs specific menuitems
        mapM_ (\(p,mbVcsConf) -> do
                    Common.setMenuForPackage vcsMenu (ipdCabalFile p) mbVcsConf
                    liftIO $ menuItemSetSubmenu vcsItem vcsMenu
                    )
               packages

        liftIO $ widgetShowAll vcsItem
        return ()
        where
        mapper :: Workspace -> IDEPackage -> IDEM (IDEPackage, Maybe VCSConf)
        mapper workspace p = do
            let fp = ipdCabalFile p
            eErrConf <- Common.getVCSConf' workspace fp
            case eErrConf of
                Left error -> do
                    liftIO $ putStrLn $ "Could not retrieve vcs-conf due to '"++error++"'."
                    return (p, Nothing)
                Right mbConf -> case mbConf of
                                    Nothing -> do
                                        liftIO $ putStrLn $ "Could not retrieve vcs-conf for active package. No vcs-conf set up."
                                        return (p, Nothing)
                                    Just vcsConf -> return $ (p,  Just vcsConf)