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

{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands
    ( CommandControl ( CommandData, HiddenCommand, GroupName )
    , DarcsCommand ( .. )
    , WrappedCommand(..)
    , wrappedCommandName
    , wrappedCommandDescription
    , commandAlias
    , commandStub
    , commandOptions
    , commandAlloptions
    , withStdOpts
    , disambiguateCommands
    , CommandArgs(..)
    , getSubcommands
    , extractCommands
    , extractAllCommands
    , normalCommand
    , hiddenCommand
    , commandGroup
    , superName
    , nodefaults
    , putInfo
    , putVerbose
    , putWarning
    , putVerboseWarning
    , abortRun
    , setEnvDarcsPatches
    , setEnvDarcsFiles
    , defaultRepo
    , amInHashedRepository
    , amInRepository
    , amNotInRepository
    , findRepository
    ) where

import Prelude ()
import Darcs.Prelude

import Prelude hiding ( (^) )
import Control.Monad ( when, unless )
import Data.List ( sort, isPrefixOf )
import Darcs.Util.Tree ( Tree )
import System.Console.GetOpt ( OptDescr )
import System.IO ( stderr )
import System.IO.Error ( catchIOError )
import System.Environment ( setEnv )
import Darcs.Patch ( listTouchedFiles )
import qualified Darcs.Patch ( summary )
import Darcs.Patch ( RepoPatch )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Info ( toXml )
import Darcs.Patch.Inspect ( PatchInspect )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )
import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )

import qualified Darcs.Repository as R ( amInHashedRepository, amInRepository
                                       , amNotInRepository, findRepository )
import Darcs.Repository.Prefs ( defaultrepo )

import Darcs.UI.Options ( DarcsOption, DarcsOptDescr, (^), optDescr, odesc, parseFlags, (?) )
import Darcs.UI.Options.All
    ( StdCmdAction, stdCmdActions, anyVerbosity, UseCache, useCache, HooksConfig, hooks
    , Verbosity(..), DryRun(..), dryRun
    )

import Darcs.UI.Flags ( DarcsFlag, remoteRepos, workRepo, quiet, verbose )

import Darcs.Util.ByteString ( decodeLocale, packStringToUTF8 )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Printer
    ( Doc, text, (<+>), ($$), vcat
    , putDocLnWith, hPutDocLn, errorDoc, renderString
    )
import Darcs.Util.Printer.Color ( fancyPrinters )
import Darcs.Util.Progress
    ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )

extractCommands :: [CommandControl] -> [WrappedCommand]
extractCommands ccl = [ cmd | CommandData cmd <- ccl ]

extractHiddenCommands :: [CommandControl] -> [WrappedCommand]
extractHiddenCommands ccl = [ cmd | HiddenCommand cmd <- ccl ]

extractAllCommands :: [CommandControl] -> [WrappedCommand]
extractAllCommands ccl = concatMap flatten (extractCommands ccl ++ extractHiddenCommands ccl)
    where flatten c@(WrappedCommand (DarcsCommand {})) = [c]
          flatten c@(WrappedCommand (SuperCommand { commandSubCommands = scs })) = c : extractAllCommands scs

-- |A 'WrappedCommand' is a 'DarcsCommand' where the options type has been hidden
data WrappedCommand where
    WrappedCommand :: DarcsCommand parsedFlags -> WrappedCommand

normalCommand :: DarcsCommand parsedFlags -> CommandControl
normalCommand c = CommandData (WrappedCommand c)

hiddenCommand :: DarcsCommand parsedFlags -> CommandControl
hiddenCommand c = HiddenCommand (WrappedCommand c)

commandGroup :: String -> CommandControl
commandGroup = GroupName

wrappedCommandName :: WrappedCommand -> String
wrappedCommandName (WrappedCommand c) = commandName c

wrappedCommandDescription :: WrappedCommand -> String
wrappedCommandDescription (WrappedCommand c) = commandDescription c

data CommandControl
  = CommandData WrappedCommand
  | HiddenCommand WrappedCommand
  | GroupName String

-- |A 'DarcsCommand' represents a command like add, record etc.
-- The 'parsedFlags' type represents the options that are
-- passed to the command's implementation
data DarcsCommand parsedFlags =
      DarcsCommand
          { commandProgramName -- programs that use libdarcs can change the name here
          , commandName
          , commandHelp
          , commandDescription :: String
          , commandExtraArgs :: Int
          , commandExtraArgHelp :: [String]
          , commandCommand :: -- First 'AbsolutePath' is the repository path,
                              -- second one is the path where darcs was executed.
                              (AbsolutePath, AbsolutePath)
                           -> parsedFlags -> [String] -> IO ()
          , commandPrereq :: [DarcsFlag] -> IO (Either String ())
          , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
                                -> [DarcsFlag] -> [String] -> IO [String]
          , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String]
                               -> IO [String]
          , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
          , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
          , commandDefaults :: [DarcsFlag]
          , commandCheckOptions :: [DarcsFlag] -> [String]
          , commandParseOptions :: [DarcsFlag] -> parsedFlags
          }
    | SuperCommand
          { commandProgramName
          , commandName
          , commandHelp
          , commandDescription :: String
          , commandPrereq :: [DarcsFlag] -> IO (Either String ())
          , commandSubCommands :: [CommandControl]
          }

withStdOpts :: DarcsOption (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
            -> DarcsOption (UseCache -> HooksConfig -> a) b
            -> DarcsOption a c
withStdOpts basicOpts advancedOpts =
  basicOpts ^ stdCmdActions ^ anyVerbosity ^ advancedOpts ^ useCache ^ hooks

commandAlloptions :: DarcsCommand pf -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])
commandAlloptions DarcsCommand { commandBasicOptions = opts1
                               , commandAdvancedOptions = opts2 } =
    ( opts1 ++ odesc stdCmdActions
    , odesc anyVerbosity ++ opts2 ++ odesc useCache ++ odesc hooks )
commandAlloptions SuperCommand { } = (odesc stdCmdActions, [])

--  Obtain options suitable as input to System.Console.Getopt, including the
--  --disable option (which is not listed explicitly in the DarcsCommand
--  definitions).
commandOptions :: AbsolutePath -> DarcsCommand pf -> [OptDescr DarcsFlag]
commandOptions cwd = map (optDescr cwd) . uncurry (++) . commandAlloptions

nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults _ _ = return

getSubcommands :: DarcsCommand pf -> [CommandControl]
getSubcommands c@(SuperCommand {}) = commandGroup "Subcommands:" : commandSubCommands c
getSubcommands _ = []

commandAlias :: String -> Maybe (DarcsCommand pf) -> DarcsCommand pf -> DarcsCommand pf
commandAlias n msuper c =
    c { commandName = n
      , commandDescription = "Alias for `" ++ commandProgramName c ++ " "
                             ++ cmdName ++ "'."
      , commandHelp = "The `" ++ commandProgramName c ++ " " ++ n
                      ++ "' command is an alias for " ++ "`"
                      ++ commandProgramName c ++ " " ++ cmdName ++ "'.\n"
                      ++ commandHelp c
      }
  where
    cmdName = unwords . map commandName . maybe id (:) msuper $ [ c ]

commandStub :: String -> String -> String -> DarcsCommand pf -> DarcsCommand pf
commandStub n h d c = c { commandName = n
                        , commandHelp = h
                        , commandDescription = d
                        , commandCommand = \_ _ _ -> putStr h
                        }

superName :: Maybe (DarcsCommand pf) -> String
superName Nothing  = ""
superName (Just x) = commandName x ++ " "

data CommandArgs where
    CommandOnly :: DarcsCommand parsedFlags -> CommandArgs
    SuperCommandOnly :: DarcsCommand parsedFlags -> CommandArgs
    SuperCommandSub :: DarcsCommand parsedFlags1 ->  DarcsCommand parsedFlags2 -> CommandArgs

-- Parses a darcs command line with potentially abbreviated commands
disambiguateCommands :: [CommandControl] -> String -> [String]
                     -> Either String (CommandArgs, [String])
disambiguateCommands allcs cmd args = do
    WrappedCommand c <- extract cmd allcs
    case (getSubcommands c, args) of
        ([], _) -> return (CommandOnly c, args)
        (_, []) -> return (SuperCommandOnly c, args)
        (subcs, a : as) -> case extract a subcs of
                               Left _ -> return (SuperCommandOnly c, args)
                               Right (WrappedCommand sc) -> return (SuperCommandSub c sc, as)

extract :: String -> [CommandControl] -> Either String WrappedCommand
extract cmd cs = case potentials of
    []  -> Left $ "No such command '" ++ cmd ++ "'\n"
    [c] -> Right c
    cs' -> Left $ unlines [ "Ambiguous command..."
                          , ""
                          , "The command '" ++ cmd ++ "' could mean one of:"
                          , unwords . sort . map wrappedCommandName $ cs'
                          ]
  where
    potentials = [c | c <- extractCommands cs, cmd `isPrefixOf` wrappedCommandName c]
                 ++ [h | h <- extractHiddenCommands cs, cmd == wrappedCommandName h]

putVerbose :: [DarcsFlag] -> Doc -> IO ()
putVerbose flags = when (verbose flags) . putDocLnWith fancyPrinters

putInfo :: [DarcsFlag] -> Doc -> IO ()
putInfo flags = unless (quiet flags) . putDocLnWith fancyPrinters

putWarning :: [DarcsFlag] -> Doc -> IO ()
putWarning flags = unless (quiet flags) . hPutDocLn stderr

putVerboseWarning :: [DarcsFlag] -> Doc -> IO ()
putVerboseWarning flags = when (verbose flags) . hPutDocLn stderr

abortRun :: [DarcsFlag] -> Doc -> IO ()
abortRun flags msg = if parseFlags dryRun flags == YesDryRun
                        then putInfo flags $ "NOTE:" <+> msg
                        else errorDoc msg

-- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables with
-- info about the given patches, for use in post-hooks.
setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree)
                   => FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches ps = do
    let k = "Defining set of chosen patches"
    debugMessage $ unlines ("setEnvDarcsPatches:" : listTouchedFiles ps)
    beginTedious k
    tediousSize k 3
    finishedOneIO k "DARCS_PATCHES"
    setEnvCautiously "DARCS_PATCHES" (renderString $ Darcs.Patch.summary ps)
    finishedOneIO k "DARCS_PATCHES_XML"
    setEnvCautiously "DARCS_PATCHES_XML" . renderString $
        text "<patches>" $$
        vcat (mapFL (toXml . info) ps) $$
        text "</patches>"
    finishedOneIO k "DARCS_FILES"
    setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps)
    endTedious k

-- | Set the DARCS_FILES environment variable to the files touched by the
-- given patch, one per line, for use in post-hooks.
setEnvDarcsFiles :: (PatchInspect p) => p wX wY -> IO ()
setEnvDarcsFiles ps =
    setEnvCautiously "DARCS_FILES" $ unlines (listTouchedFiles ps)

-- | Set some environment variable to the given value, unless said value is
-- longer than 10K characters, in which case do nothing.
setEnvCautiously :: String -> String -> IO ()
setEnvCautiously e v
    | toobig (10 * 1024) v = return ()
    | otherwise =
        setEnv e v `catchIOError` (\_ -> setEnv e (decodeLocale (packStringToUTF8 v)))
  where
    -- note: not using (length v) because we want to be more lazy than that
    toobig :: Int -> [a] -> Bool
    toobig 0 _ = True
    toobig _ [] = False
    toobig n (_ : xs) = toobig (n - 1) xs

defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
defaultRepo fs = defaultrepo (remoteRepos ? fs)

amInHashedRepository :: [DarcsFlag] -> IO (Either String ())
amInHashedRepository fs = R.amInHashedRepository (workRepo ? fs)

amInRepository :: [DarcsFlag] -> IO (Either String ())
amInRepository fs = R.amInRepository (workRepo ? fs)

amNotInRepository :: [DarcsFlag] -> IO (Either String ())
amNotInRepository fs = R.amNotInRepository (workRepo ? fs)

findRepository :: [DarcsFlag] -> IO (Either String ())
findRepository fs = R.findRepository (workRepo ? fs)