Common.hs

{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
--
-- Module      :  IDE.Command.VCS.Common
-- Copyright   :  2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
-- License     :  GPL Nothing
--
-- Maintainer  :  maintainer@leksah.org
-- Stability   :  provisional
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
module IDE.Command.VCS.Common (
    setMenuForPackage

    --getter
    ,getVCSConf'
) where

import IDE.Core.Types
import IDE.Core.State
import IDE.Utils.GUIUtils
import qualified IDE.Utils.GUIUtils as GUIUtils
import qualified IDE.Workspaces.Writer as Writer
import qualified IDE.Command.VCS.Types as Types
import qualified IDE.Command.VCS.GIT as GIT
import qualified IDE.Command.VCS.SVN as SVN
import qualified IDE.Command.VCS.Mercurial as Mercurial


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

import Control.Monad.Reader
import Control.Monad.Trans(liftIO)
import qualified Control.Exception as Exc
import Data.Maybe
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T (pack)
import qualified GI.Gtk.Objects.Menu as Gtk (menuNew, Menu(..))
import qualified GI.Gtk.Objects.MenuItem as Gtk
       (menuItemGetSubmenu, menuItemSetSubmenu, menuItemNewWithMnemonic,
        menuItemNewWithLabel)
import GI.Gtk.Objects.MenuItem (MenuItem(..), onMenuItemActivate)
import qualified GI.Gtk.Objects.MenuShell as Gtk (menuShellAppend)
import qualified GI.Gtk.Objects.Widget as Gtk (widgetShowAll)
import Data.GI.Base (unsafeCastTo)
import GI.Gtk.Objects.Menu (Menu(..))



setMenuForPackage :: Gtk.Menu -> FilePath -> Maybe VCSConf -> IDEAction
setMenuForPackage vcsMenu cabalFp mbVCSConf = do
    ideR <- ask

    -- create or get packageItem and set it to ide to be able to get it later again
    (oldMenuItems,pw) <- readIDE vcsData
    packageItem <-
        case Map.lookup cabalFp oldMenuItems of
             Nothing -> Gtk.menuItemNewWithLabel $ T.pack cabalFp
             Just menuItem -> return menuItem
    let newMenuItems = Map.insert cabalFp packageItem oldMenuItems
    modifyIDE_ (\ide -> ide {vcsData = (newMenuItems,pw)})

    packageMenu <- liftIO Gtk.menuNew

    -- build and set set-up repo action
    setupActionItem <- Gtk.menuItemNewWithMnemonic (__"_Setup Repo")
    onMenuItemActivate setupActionItem $
            reflectIDE (
                    runSetupRepoActionWithContext cabalFp
                ) ideR
    Gtk.menuShellAppend packageMenu setupActionItem

    -- build and set other actions
    let packageMenuOperations = case mbVCSConf of
                                    Nothing -> []
                                    Just (vcsType,_,_) -> mkVCSActions vcsType
    addActions cabalFp packageMenu ideR packageMenuOperations

    -- set menus
    Gtk.menuItemSetSubmenu packageItem (Just packageMenu)
    Gtk.menuShellAppend vcsMenu packageItem
    Gtk.widgetShowAll vcsMenu
    return ()
    where
    addActions cabalFp packageMenu ideR
       = mapM_
           (\ (name, action) ->
              do actionItem <- Gtk.menuItemNewWithMnemonic name
                 onMenuItemActivate actionItem $
                   reflectIDE (runActionWithContext action cabalFp) ideR
                 Gtk.menuShellAppend packageMenu actionItem)
    mkVCSActions :: VCS.VCSType -> [(Text, Types.VCSAction ())]
    mkVCSActions VCS.SVN = SVN.mkSVNActions
    mkVCSActions VCS.GIT = GIT.mkGITActions
    mkVCSActions VCS.Mercurial = Mercurial.mkMercurialActions




{- |
    Retrieves VCS configuration for given package from current workspace and runs given
    VCS action using it. VCS Configuration must be set before.
-}
runActionWithContext :: Types.VCSAction ()    -- ^ computation to execute, i.e. showCommit
                     -> FilePath        -- ^ filepath to package
                     -> IDEAction
runActionWithContext vcsAction packageFp = do
    config <- getVCSConf'' packageFp
    runVcs config packageFp vcsAction
    where
    runVcs :: VCSConf -> FilePath -> Types.VCSAction t -> IDEM t
    runVcs config cabalFp (Types.VCSAction a) = runReaderT a (config,cabalFp)

{- |
    Shows a GUI to set up a VCS. If a vcs-config is set for given package it will be used.
-}
runSetupRepoActionWithContext :: FilePath
                              -> IDEAction
runSetupRepoActionWithContext packageFp = do
    mainWindow <- getMainWindow
    eConfigErr <- getVCSConf packageFp
    case eConfigErr of
        Left error -> liftIO $ GUIUtils.showErrorDialog (Just mainWindow) error
        Right mbConfig -> do
            ide <- ask
            liftIO $ VCSGUI.showSetupConfigGUI mbConfig (callback ide packageFp)
    where
    callback :: IDERef -> FilePath -> Maybe (VCS.VCSType, VCS.Config, Maybe VCSGUI.MergeTool) -> IO()
    callback ideRef packageFp mbConfig  =
            -- set config in workspace
            runReaderT (workspaceSetVCSConfig packageFp mbConfig) ideRef






--
-- Basic setters and getters
--

workspaceSetVCSConfig :: FilePath -> Maybe VCSConf -> IDEAction
workspaceSetVCSConfig pathToPackage mbVCSConf = do
    vcsItem <- GUIUtils.getVCS
    vcsMenu <- Gtk.menuItemGetSubmenu vcsItem >>= liftIO . unsafeCastTo Menu . fromJust
    setMenuForPackage vcsMenu pathToPackage mbVCSConf
    modifyIDE_ (\ide -> do
        let oldWs = fromJust (workspace ide)
        let oldMap = packageVcsConf oldWs
        let newMap =  case mbVCSConf of
                Nothing -> Map.delete pathToPackage oldMap
                Just vcsConf -> Map.insert pathToPackage vcsConf oldMap
        let newWs = (fromJust (workspace ide)) { packageVcsConf = newMap }
        ide {workspace = Just newWs })
    newWs <- readIDE workspace
    Writer.writeWorkspace $ fromJust newWs



-- | vcs conf for given package in current workspace.
getVCSConf :: FilePath -> IDEM (Either Text (Maybe VCSConf))
getVCSConf pathToPackage = do
    mbWorkspace <- readIDE workspace
    case mbWorkspace of
        Nothing -> return $ Left "No open workspace. Open Workspace first."
        Just workspace -> getVCSConf' workspace pathToPackage

-- | vcs conf for given package in given workspace.
getVCSConf' :: Workspace -> FilePath -> IDEM (Either Text (Maybe VCSConf))
getVCSConf' workspace pathToPackage = do
            let mbConfig = Map.lookup pathToPackage $ packageVcsConf workspace
            case mbConfig of
            --Left $ "Could not find version-control-system configuration for package "++pathToPackage
                Nothing -> return $ Right Nothing
                Just conf -> return $ Right $ Just conf

-- | vcs conf for given package in current workspace. Workspae and VCS conf must be set before.
getVCSConf'' :: FilePath -> IDEM VCSConf
getVCSConf'' pathToPackage = do
    (Just workspace) <- readIDE workspace
    return $ fromJust $ Map.lookup pathToPackage $ packageVcsConf workspace