--  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 OverloadedStrings #-}
module Darcs.UI.Commands.Util
    ( announceFiles
    , filterExistingPaths
    , testTentativeAndMaybeExit
    , printDryRunMessageAndExit
    , getUniqueRepositoryName
    , getUniqueDPatchName
    , expandDirs
    , doesDirectoryReallyExist
    , checkUnrelatedRepos
    , repoTags
    ) where

import Control.Monad ( when, unless )
import Data.Maybe ( catMaybes, fromJust )

import Prelude ()
import Darcs.Prelude

import System.Exit ( ExitCode(..), exitWith, exitSuccess )
import System.FilePath.Posix ( (</>) )
import System.Posix.Files ( isDirectory )

import Darcs.Patch ( RepoPatch, xmlSummary )
import Darcs.Patch.Depends ( areUnrelatedRepos )
import Darcs.Patch.Info ( toXml, piTag )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM )
import Darcs.Patch.Set ( PatchSet(..), patchSetfMap )
import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )

import Darcs.Repository ( Repository, readRecorded, testTentative )
import Darcs.Repository.State
    ( readUnrecordedFiltered, readWorking, restrictBoring
    , TreeFilter(..), applyTreeFilter
    )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Bundle ( patchFilename )

import Darcs.UI.PrintPatch ( showFriendly )
import Darcs.UI.Options.All
    ( Verbosity(..), SetScriptsExecutable, TestChanges (..)
    , RunTest(..), LeaveTestDir(..), UseIndex, ScanKnown(..)
    , Summary(..), DryRun(..), XmlOutput(..), LookForMoves
    )

import Darcs.Util.Exception ( clarifyErrors )
import Darcs.Util.File ( getFileStatus, withCurrentDirectory )
import Darcs.Util.Path
    ( SubPath, toFilePath, getUniquePathName, floatPath
    , simpleSubPath, toPath, anchorPath
    )
import Darcs.Util.Printer
    ( text, (<+>), hsep, ($$), vcat, vsep
    , putDocLn, insertBeforeLastline, prefix
    )
import Darcs.Util.Prompt ( PromptConfig(..), promptChar, promptYorn )
import Darcs.Util.Text ( pathlist )
import Darcs.Util.Tree.Monad ( virtualTreeIO, exists )
import Darcs.Util.Tree ( Tree )
import qualified Darcs.Util.Tree as Tree


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

testTentativeAndMaybeExit :: 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

-- | @'printDryRunMessageAndExit' action flags patches@ prints a string
-- representing the action that would be taken if the @--dry-run@ option had
-- not been passed to darcs. Then darcs exits successfully.  @action@ is the
-- name of the action being taken, like @\"push\"@ @flags@ is the list of flags
-- which were sent to darcs @patches@ is the sequence of patches which would be
-- touched by @action@.
printDryRunMessageAndExit :: (RepoPatch p, ApplyState p ~ Tree)
                          => String
                          -> Verbosity -> Summary -> DryRun -> XmlOutput
                          -> Bool -- interactive
                          -> FL (PatchInfoAnd rt p) wX wY
                          -> IO ()
printDryRunMessageAndExit action v s d x interactive patches = do
    when (d == YesDryRun) $ do
        putInfoX $ hsep [ "Would", text action, "the following changes:" ]
        putDocLn put_mode
        putInfoX $ text ""
        putInfoX $ text "Making no changes: this is a dry run."
        exitSuccess
    when (not interactive && s == YesSummary) $ do
        putInfoX $ hsep [ "Will", text action, "the following changes:" ]
        putDocLn put_mode
  where
    put_mode = if x == YesXml
                   then text "<patches>" $$
                        vcat (mapFL (indent . xml_info s) patches) $$
                        text "</patches>"
                   else vsep $ mapFL (showFriendly v s) patches

    putInfoX = if x == YesXml then const (return ()) else putDocLn

    xml_info YesSummary = xml_with_summary
    xml_info NoSummary  = toXml . info

    xml_with_summary hp
        | Just p <- hopefullyM hp = insertBeforeLastline (toXml $ info hp)
                                        (indent $ xmlSummary p)
    xml_with_summary hp = toXml (info hp)

    indent = prefix "    "

-- | 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
                    -> LookForMoves
                    -> [SubPath]
                    -> IO ([SubPath],[SubPath])
filterExistingPaths repo verb useidx scan lfm paths = do
      pristine <- readRecorded repo
      working <- readUnrecordedFiltered repo useidx scan lfm (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 ++"'"

-- | For each directory in the list of 'SubPath's, add all paths
-- under that directory to the list. If the first argument is 'True', then
-- include even boring files.
--
-- This is used by the add and remove commands to handle the --recursive option.
expandDirs :: Bool -> [SubPath] -> IO [SubPath]
expandDirs includeBoring subpaths =
  do
    boringFilter <-
      if includeBoring
        then return (TreeFilter id)
        else restrictBoring Tree.emptyTree
    fmap (map (fromJust . simpleSubPath)) $
      concat `fmap` mapM (expandOne boringFilter . toPath) subpaths
  where
    expandOne boringFilter "" = listFiles boringFilter
    expandOne boringFilter f = do
        isdir <- doesDirectoryReallyExist f
        if not isdir
          then return [f]
          else do
            fs <- withCurrentDirectory f (listFiles boringFilter)
            return $ f: map (f </>) fs
    listFiles boringFilter = do
      working <- applyTreeFilter boringFilter <$> readWorking
      return $ map (anchorPath "" . fst) $ Tree.list working

doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f

checkUnrelatedRepos :: RepoPatch p
                    => Bool
                    -> PatchSet rt p wStart wX
                    -> PatchSet rt p wStart wY
                    -> IO ()
checkUnrelatedRepos allowUnrelatedRepos us them =
    when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $
         do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?"
            unless confirmed $ putStrLn "Cancelled." >> exitSuccess

repoTags :: PatchSet rt p wX wY -> IO [String]
repoTags ps = catMaybes `fmap` patchSetfMap (return . piTag . info) ps