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 qualified Graphics.UI.Gtk as Gtk
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)
setMenuForPackage :: Gtk.Menu -> FilePath -> Maybe VCSConf -> IDEAction
setMenuForPackage vcsMenu cabalFp mbVCSConf = do
ideR <- ask
(oldMenuItems,pw) <- readIDE vcsData
packageItem <-
case Map.lookup cabalFp oldMenuItems of
Nothing -> liftIO . 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
setupActionItem <- liftIO $ Gtk.menuItemNewWithMnemonic (__"_Setup Repo")
liftIO $ setupActionItem `Gtk.on` Gtk.menuItemActivate $
reflectIDE (
runSetupRepoActionWithContext cabalFp
) ideR
liftIO $ Gtk.menuShellAppend packageMenu setupActionItem
let packageMenuOperations = case mbVCSConf of
Nothing -> []
Just (vcsType,_,_) -> mkVCSActions vcsType
liftIO $ addActions cabalFp packageMenu ideR packageMenuOperations
liftIO $ Gtk.menuItemRemoveSubmenu packageItem
liftIO $ Gtk.menuItemSetSubmenu packageItem packageMenu
liftIO $ Gtk.menuShellAppend vcsMenu packageItem
liftIO $ Gtk.widgetShowAll vcsMenu
return ()
where
addActions cabalFp packageMenu ideR
= mapM_
(\ (name, action) ->
do actionItem <- Gtk.menuItemNewWithMnemonic name
actionItem `Gtk.on` Gtk.menuItemActivate $
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
runActionWithContext :: Types.VCSAction ()
-> FilePath
-> 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)
runSetupRepoActionWithContext :: FilePath
-> IDEAction
runSetupRepoActionWithContext packageFp = do
eConfigErr <- getVCSConf packageFp
case eConfigErr of
Left error -> liftIO $ GUIUtils.showErrorDialog 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 =
runReaderT (workspaceSetVCSConfig packageFp mbConfig) ideRef
workspaceSetVCSConfig :: FilePath -> Maybe VCSConf -> IDEAction
workspaceSetVCSConfig pathToPackage mbVCSConf = do
vcsItem <- GUIUtils.getVCS
mbVcsMenu <- liftIO $ Gtk.menuItemGetSubmenu vcsItem
let vcsMenu = Gtk.castToMenu $ fromJust mbVcsMenu
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
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
getVCSConf' :: Workspace -> FilePath -> IDEM (Either Text (Maybe VCSConf))
getVCSConf' workspace pathToPackage = do
let mbConfig = Map.lookup pathToPackage $ packageVcsConf workspace
case mbConfig of
Nothing -> return $ Right Nothing
Just conf -> return $ Right $ Just conf
getVCSConf'' :: FilePath -> IDEM VCSConf
getVCSConf'' pathToPackage = do
(Just workspace) <- readIDE workspace
return $ fromJust $ Map.lookup pathToPackage $ packageVcsConf workspace