%  Copyright (C) 2005 David Roundy
%
%  This program is free software; you can redistribute it and/or modify
%  it under the terms of the GNU General Public License as published by
%  the Free Software Foundation; either version 2, or (at your option)
%  any later version.
%
%  This program is distributed in the hope that it will be useful,
%  but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
%  GNU General Public License for more details.
%
%  You should have received a copy of the GNU General Public License
%  along with this program; see the file COPYING.  If not, write to
%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
%  Boston, MA 02110-1301, USA.


\begin{code}
module MainGui where
#ifdef HAVEWX
-- base haskell
import Control.Exception ( catch, Exception(ExitException), throw )
import Control.Monad ( liftM )
import Data.Maybe ( fromJust )
import System.Directory ( setCurrentDirectory )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

-- wxhaskell
import Graphics.UI.WX hiding ( when, text )
import qualified Graphics.UI.WX as WX ( text )
import Graphics.UI.WXCore hiding ( when )

-- darcs
import DarcsCommands ( DarcsCommand(command_argdefaults, command_command) )
import DarcsFlags ( DarcsFlag(Gui, SubGui) )
import GuiUtils ( patchViewer, updatePatchViewer )
import Patch ( flatten, )
import Repository ( get_unrecorded, withRepoLock, withRepoGuiLockCanFail,
                    read_repo, )
import Pull
import Push
import Record
import Revert
import Send
import Unrecord
\end{code}

Darcs includes an experimental graphical interface.  You should note
that this interface may not have all the functionality of the
command-line equivalent.

\begin{code}
repositoryGui :: Maybe FilePath -- ^ repository
              -> IO ()
repositoryGui mRepoPath =
 do f <- frame [ WX.text := "wxDarcs" ]
    --
    fileMenu <- menuPane [WX.text := "&File"]
    mclose   <- menuQuit fileMenu [help := "Quit darcs"]
    -- --------------------------------
    -- repository view
    -- --------------------------------
    sp   <- panel f []
    spp  <- panel sp []
    splt <- splitterWindow spp []
    -- unrecorded patches
    wp    <- panel splt []
    wView <- patchViewer wp
    -- recorded patches
    cp    <- panel splt []
    cView <- patchViewer cp
    --
    textlog <- textCtrl sp [enabled := False, wrap := WrapNone]
    textCtrlMakeLogActiveTarget textlog
    -- repo layout
    let repoLay = container sp $ fill $ column 1
         [ fill $ container spp $ fill $ hsplit splt 5 100
           (container wp $ fill $ column 1
             [ hfill $ label "What's new", fill  $ widget wView ])
           (container cp $ fill $ column 1
             [ hfill $ label "Changes", fill  $ widget cView ])
         , hfill $ vspace 3
         , hfill $ label "Log", hfill $ widget textlog ]
    -- --------------------------------
    -- button bar
    -- --------------------------------
    mp <- panel f []
    addBt    <- button_ mp [ WX.text := "Add" ]
    mvBt     <- button_ mp [ WX.text := "Move" ]
    pushBt   <- button mp [ WX.text := "Push" ]
    pullBt   <- button mp [ WX.text := "Pull" ]
    sendBt   <- button mp [ WX.text := "Send" ]
    applyBt  <- button_ mp [ WX.text := "Apply" ]
    oblBt    <- button mp [ WX.text := "Obliterate" ]
    amdBt    <- button_ mp [ WX.text := "Amend" ]
    unrecBt  <- button mp [ WX.text := "Unrecord" ]
    recBt    <- button mp [ WX.text := "Record" ]
    revBt    <- button mp [ WX.text := "Revert" ]
    --
    openBt   <- button mp [ WX.text := "Open", on command := openRepo f ]
    quitBt <- button mp [ WX.text := "Quit", on command := exitWith ExitSuccess ]
    --
    let btnLay = column 3 $ map hfill
                 [ widget openBt
                 , vspace 2, alignCentre $ label "Files"
                 , widget addBt, widget mvBt
                 , vspace 2, alignCentre $ label "Changes"
                 , widget recBt, widget revBt
                 , vspace 2, alignCentre $ label "Local"
                 , widget oblBt, widget amdBt, widget unrecBt
                 , vspace 2, alignCentre $ label "Remote"
                 , widget pushBt, widget pullBt
                 , vspace 3
                 , widget sendBt, widget applyBt ]
        totalBtnLay = margin 2 $ container mp $ vfill $ column 0 $
                      [ vfill btnLay
                      , vspace 5
                      , hfill $ widget quitBt
                      , vspace 5 ]
    -- --------------------------------
    -- commands
    -- --------------------------------
    let updateRepoViewHere = updateRepoView (wView, cView)
        btnLst = -- widgets to activate/disactivate
           [ addBt, mvBt, pullBt, pushBt, sendBt, applyBt
           , oblBt, amdBt, unrecBt, recBt, revBt ]
        enableButtons t =
          mapM (\b -> set b [ enabled := t ] ) btnLst
        activateMainIfPossible True  =
          do withRepoGuiLockCanFail $ \repository ->
               do enableButtons True
                  updateRepoViewHere repository
                  set f [ on activate := \_ -> return () ]
             return ()
        activateMainIfPossible False = return ()
        --
        ignoreExit (ExitException _) = return ()
        ignoreExit x = throw x
        runDarcsCmd cmd =
          do enableButtons False
             set f [ on activate := activateMainIfPossible ]
             args <- command_argdefaults cmd "" []
             command_command cmd [Gui, SubGui] args `Control.Exception.catch` ignoreExit
    --
    set pullBt   [ on command := runDarcsCmd pull ]
    set pushBt   [ on command := runDarcsCmd push ]
    set sendBt   [ on command := runDarcsCmd send ]
    set oblBt    [ on command := runDarcsCmd obliterate ]
    set unrecBt  [ on command := runDarcsCmd unrecord ]
    set recBt    [ on command := runDarcsCmd record ]
    set revBt    [ on command := runDarcsCmd revert ]
    -- activate the gui if possible
    case mRepoPath of
      Nothing ->
        do enableButtons False
           set wView [ enabled := False ]
           set cView [ enabled := False ]
      Just repoPath  ->
        do setCurrentDirectory repoPath
           -- FIX ME -- pass the right opts -- jch
           withRepoLock [] updateRepoViewHere
           set wView [ enabled := True ]
           set cView [ enabled := True ]
    -- --------------------------------
    -- global layout
    -- --------------------------------
    set f [ layout := fill $ row 1 [ vfill totalBtnLay, fill repoLay ]
          , menuBar := [fileMenu]
          , on (menu mclose) := close f
          , clientSize := sz 600 400 -- this is window actual size
          ]
 where
 -- local repository selector
 openRepo f =
  do mchosen <- dirOpenDialog f False "Choose a repository..." "."
     case mchosen of
       Nothing     -> return ()
       Just chosen -> close f >> repositoryGui (Just chosen)
 --
 updateRepoView (wView,cView) repository =
  do -- FIXME: I don't know if this is actually the correct way to retrieve the patches
     n' <- get_unrecorded repository []
     o' <- head `liftM` read_repo repository
     let n = case n' of
             Nothing  -> []
             Just n'' -> flatten n''
         o = map (fromJust . snd) $ reverse o'
     updatePatchViewer wView n
     updatePatchViewer cView o
\end{code}

\begin{code}
notYetImplTip, notYetImplMsg :: String
notYetImplTip = "not yet implemented"
notYetImplMsg = "This GUI feature has not been implemented yet"

-- | Dummy button for features not yet implemented
button_ :: Window a -> [Prop (Button ())] -> IO (Button ())
button_ f l = button f $
 l ++ [ tooltip := notYetImplTip
      , on command := errorDialog f "Sorry!" notYetImplMsg ]
#endif
\end{code}