Log.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
--
-- Module      :  VCSGui.Common.Log
-- Copyright   :  2011 Stephan Fortelny, Harald Jagenteufel
-- License     :  GPL
--
-- Maintainer  :  stephanfortelny at gmail.com, h.jagenteufel at gmail.com
-- Stability   :
-- Portability :
--
-- | Functions to show a log window. This mostly hides the window-building tasks from the specific VCS implementation.
--
-----------------------------------------------------------------------------
module VCSGui.Common.Log (
    showLogGUI
) where

import Control.Monad.Reader
import Data.Maybe

import VCSGui.Common.GtkHelper
import qualified VCSWrapper.Common as Common


import Data.Maybe (fromMaybe)
import Paths_vcsgui(getDataFileName)
import Data.Text (Text)
import qualified Data.Text as T (pack)
import Data.Monoid ((<>))
import qualified GI.Gtk.Objects.TreeView as Gtk
       (treeViewSetCursor, treeViewGetCursor, TreeView(..))
import qualified GI.Gtk.Objects.Action as Gtk (onActionActivate)
import qualified GI.Gtk.Objects.Widget as Gtk
       (setWidgetVisible, widgetShowAll)
import qualified GI.Gtk.Interfaces.TreeModel as Gtk
       (treeModelGetPath, treeModelGetIterFirst, treeModelGetIter)
import qualified Data.GI.Gtk.ModelView.SeqStore as Gtk
       (seqStoreIterToIndex, seqStoreGetValue, SeqStore(..))
import qualified Data.GI.Gtk.ComboBox as Gtk
       (comboBoxSetActive, comboBoxPrependText)
import qualified GI.Gtk.Objects.ComboBox as Gtk (onComboBoxChanged)
import GI.Gtk.Objects.TreeViewColumn (noTreeViewColumn)
import qualified GI.Gtk as Gtk (setCellRendererTextText)

getGladepath = getDataFileName "data/guiCommonLog.glade"

data LogConfig a = LogConfig {
    options :: [Text]
    ,treeViewSetter :: Gtk.TreeView -> TreeViewItem a
}


--------------------------------------------------
---- LOG VIEWER / CHECKOUT
--------------------------------------------------

data LogGUI = LogGUI {
    logWin :: WindowItem
    , logTreeView :: TreeViewItem Common.LogEntry
    , lblRevisionDetails :: LabelItem
    , actCheckout :: ActionItem
    , actLogCancel :: ActionItem
    , comboBranch :: ComboBoxItem
    , lblBranch :: LabelItem
}

-- | Show the history of a repository.
showLogGUI :: [Common.LogEntry]
            -- ^ logEntries to be displayed initially
            -> [Text]
            -- ^ options will be displayed in a menu as checkboxes (TODO this is currently not implemented)
            -> Maybe ((Text, [Text]), (Text -> Common.Ctx [Common.LogEntry]))
            -- ^ (list of branchnames to display, Function called when a different branch is selected)
            --
            -- The function will be called with the selected branchname to repopulate the displayed LogEntries.
            -- If 'Nothing', no branch selection will be displayed.
            -> (Common.LogEntry -> Maybe Text -> Common.Ctx ())
            -- ^ (selected line, name of the branch to checkout from)
            --
            -- This function is called on checkout action. The window will be closed afterwards.
            -> Bool -- ^ Add column to display branch name
            -> Common.Ctx ()
showLogGUI logEntries options Nothing doCheckoutFn displayBranchNames = guiWithoutBranches logEntries options doCheckoutFn displayBranchNames >> return ()
showLogGUI logEntries options (Just (branches, changeBranchFn)) doCheckoutFn displayBranchNames = do
        gui <- guiWithoutBranches logEntries options doCheckoutFn displayBranchNames
        guiAddBranches gui branches changeBranchFn
        return ()

guiWithoutBranches :: [Common.LogEntry]
                    -> [Text]
                    -> (Common.LogEntry
                        -> (Maybe Text)
                        -> Common.Ctx ())
                    -> Bool -- ^ Add column to display branch name
                    -> Common.Ctx LogGUI
guiWithoutBranches logEntries options doCheckoutFn displayBranchNames = do
        gui <- loadLogGui logEntries
        liftIO $ setupLogColumns gui displayBranchNames

        -- connect gui elements
        liftIO $ registerClose $ logWin gui
        liftIO $ registerCloseAction (actLogCancel gui) (logWin gui)

        config <- ask
        liftIO $ Gtk.onActionActivate (getItem (actCheckout gui)) $
            doCheckout' config (logTreeView gui) (comboBranch gui)
                >> (closeWin (logWin gui))

        -- show window
        liftIO $ Gtk.widgetShowAll $ getItem $ logWin gui
        return gui
    where
    doCheckout' :: Common.Config -> TreeViewItem Common.LogEntry -> ComboBoxItem -> IO ()
    doCheckout' cfg (_, (store, view), _) combo = do
        (mbPath, _) <- Gtk.treeViewGetCursor view
        case mbPath of
            Just path -> do
                (True, treeIter) <- Gtk.treeModelGetIter store path
                selectedLog <- Gtk.seqStoreGetValue store =<< Gtk.seqStoreIterToIndex treeIter
                selectedBranch <- get combo
                Common.runVcs cfg $ doCheckoutFn selectedLog selectedBranch
            Nothing -> return () -- TODO fix nothing selected bug here

    setupLogColumns :: LogGUI -> Bool -> IO ()
    setupLogColumns gui displayBranchNames = do
        let item = (logTreeView gui)
        addTextColumnToTreeView item "Subject" (\cell Common.LogEntry { Common.subject = t } -> Gtk.setCellRendererTextText cell t)
        addTextColumnToTreeView item "Author" (\cell Common.LogEntry { Common.author = t, Common.email = mail } -> Gtk.setCellRendererTextText cell $ t <> " <" <> mail <> ">")
        addTextColumnToTreeView item "Date" (\cell Common.LogEntry { Common.date = t } -> Gtk.setCellRendererTextText cell t)
        case displayBranchNames of
            True -> addTextColumnToTreeView item "Branch" (\cell Common.LogEntry { Common.mbBranch = t } -> Gtk.setCellRendererTextText cell $ fromMaybe "" t)
            False -> return()
        return ()

guiAddBranches :: LogGUI -> (Text, [Text]) -> (Text -> Common.Ctx [Common.LogEntry]) -> Common.Ctx ()
guiAddBranches gui (curBranch, otherBranches) changeBranchFn = do
        -- set branch selection visible
        liftIO $ Gtk.setWidgetVisible (getItem $ lblBranch gui) True
        liftIO $ Gtk.setWidgetVisible (getItem $ comboBranch gui) True

        -- fill with data®
        liftIO $ set (comboBranch gui) otherBranches
        liftIO $ Gtk.comboBoxPrependText (getItem $ comboBranch gui) curBranch
        liftIO $ Gtk.comboBoxSetActive (getItem $ comboBranch gui) 0

        -- register branch switch fn
        config <- ask
        liftIO $ Gtk.onComboBoxChanged (getItem $ comboBranch gui) $ changeBranchFn' config (fmap (fromMaybe "") $ get $ comboBranch gui)
        return ()
    where
    changeBranchFn' :: Common.Config -> IO Text -> IO ()
    changeBranchFn' cfg branchIO = do
        let (store, view) = getItem $ logTreeView gui
        branch <- branchIO
        newLogEntries <- Common.runVcs cfg $ changeBranchFn branch
        set (logTreeView gui) newLogEntries
        -- set cursor to first log entry (so checkoutbutton works)
        Gtk.treeModelGetIterFirst store >>= \case
            (True, firstRowIter) -> do
                firstRow <- Gtk.treeModelGetPath store firstRowIter
                Gtk.treeViewSetCursor view firstRow noTreeViewColumn False
            _ -> return ()


loadLogGui :: [Common.LogEntry] -> Common.Ctx LogGUI
loadLogGui logEntries = do
        liftIO $ do
            gladepath <- getGladepath
            builder <- openGladeFile gladepath
            win <- getWindowFromGlade builder "logWindow"
            revDetails <- getLabelFromGlade builder "lblRevisionDetails"
            actCheck <- getActionFromGlade builder "actCheckout"
            actCanc <- getActionFromGlade builder "actCancel"
            comboBranch <- getComboBoxFromGlade builder "comboBranch"
            lblBranch <- getLabelFromGlade builder "lblBranch"

            treeView <- getTreeViewFromGlade builder "historyTreeView" logEntries
            return $ LogGUI win treeView revDetails actCheck actCanc comboBranch lblBranch