--  Copyright (C) 2002-2004 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.

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Util
    ( announceFiles
    , filterExistingPaths
    , testTentativeAndMaybeExit
    , getUniqueRepositoryName
    , getUniqueDPatchName
    ) where

import Control.Monad ( unless )

import Prelude ()
import Darcs.Prelude

import System.Exit ( ExitCode(..), exitWith )

import Darcs.Util.Tree.Monad ( virtualTreeIO, exists )
import Darcs.Util.Tree ( Tree )

import Darcs.Patch ( RepoPatch )
import Darcs.Repository ( Repository, readRecorded, testTentative )
import Darcs.Repository.State ( readUnrecordedFiltered )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Bundle ( patchFilename )
import Darcs.UI.Options.All
    ( Verbosity(..), SetScriptsExecutable, TestChanges (..)
    , RunTest(..), LeaveTestDir(..), UseIndex, ScanKnown(..) )
import Darcs.Util.Exception ( clarifyErrors )
import Darcs.Util.Path
    ( SubPath, toFilePath, getUniquePathName, floatPath )
import Darcs.Util.Printer ( putDocLn, text, (<>), (<+>) )
import Darcs.Util.Prompt ( PromptConfig(..), promptChar )
import Darcs.Util.Text ( pathlist )

announceFiles :: Verbosity -> Maybe [SubPath] -> String -> IO ()
announceFiles Quiet _ _ = return ()
announceFiles _ (Just subpaths) message = putDocLn $
    text message <> text ":" <+> pathlist (map toFilePath subpaths)
announceFiles _ _ _ = return ()

testTentativeAndMaybeExit :: (RepoPatch p, ApplyState p ~ Tree)
                          => Repository rt p wR wU wT
                          -> Verbosity
                          -> TestChanges
                          -> SetScriptsExecutable
                          -> Bool
                          -> String
                          -> String -> Maybe String -> IO ()
testTentativeAndMaybeExit repo verb test sse interactive failMessage confirmMsg withClarification = do
    let (rt,ltd) = case test of
          NoTestChanges    -> (NoRunTest, YesLeaveTestDir)
          YesTestChanges x -> (YesRunTest, x)
    testResult <- testTentative repo rt ltd sse verb
    unless (testResult == ExitSuccess) $ do
        let doExit = maybe id (flip clarifyErrors) withClarification $
                        exitWith testResult
        unless interactive doExit
        putStrLn $ "Looks like " ++ failMessage
        let prompt = "Shall I " ++ confirmMsg ++ " anyway?"
        yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])
        unless (yn == 'y') doExit

-- | Given a repository and two common command options, classify the given list
-- of subpaths according to whether they exist in the pristine or working tree.
-- Paths which are neither in working nor pristine are reported and dropped.
-- The result is a pair of path lists: those that exist only in the working tree,
-- and those that exist in pristine or working.
filterExistingPaths :: (RepoPatch p, ApplyState p ~ Tree)
                    => Repository rt p wR wU wT
                    -> Verbosity
                    -> UseIndex
                    -> ScanKnown
                    -> [SubPath]
                    -> IO ([SubPath],[SubPath])
filterExistingPaths repo verb useidx scan paths = do
      pristine <- readRecorded repo
      working <- readUnrecordedFiltered repo useidx scan (Just paths)
      let filepaths = map toFilePath paths
          check = virtualTreeIO $ mapM (exists . floatPath) filepaths
      (in_pristine, _) <- check pristine
      (in_working, _) <- check working
      let paths_with_info       = zip3 paths in_pristine in_working
          paths_in_neither      = [ p | (p,False,False) <- paths_with_info ]
          paths_only_in_working = [ p | (p,False,True) <- paths_with_info ]
          paths_in_either       = [ p | (p,inp,inw) <- paths_with_info, inp || inw ]
          or_not_added          = if scan == ScanKnown then " or not added " else " "
      unless (verb == Quiet || null paths_in_neither) $ putDocLn $
        "Ignoring non-existing" <> or_not_added <> "paths:" <+>
        pathlist (map toFilePath paths_in_neither)
      return (paths_only_in_working, paths_in_either)

getUniqueRepositoryName :: Bool -> FilePath -> IO FilePath
getUniqueRepositoryName talkative name = getUniquePathName talkative buildMsg buildName
  where
    buildName i = if i == -1 then name else name++"_"++show i
    buildMsg n = "Directory or file '"++ name ++
                 "' already exists, creating repository as '"++
                 n ++"'"

getUniqueDPatchName :: FilePath -> IO FilePath
getUniqueDPatchName name = getUniquePathName True buildMsg buildName
  where
    buildName i = if i == -1 then patchFilename name else patchFilename $ name++"_"++show i
    buildMsg n = "Directory or file '"++ name ++
                 "' already exists, creating dpatch as '"++
                 n ++"'"