--  Copyright (C) 2003-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 PatternGuards #-}

module Darcs.UI.Commands.Log
    ( changes, log
    , changelog, getLogInfo
    ) where

import Prelude ()
import Darcs.Prelude

import Data.List ( intersect, sort, nub, find )
import Data.Maybe ( fromMaybe, fromJust, isJust )
import Control.Arrow ( second )
import Control.Exception ( catch, IOException )
import Control.Monad.State.Strict

import Darcs.UI.PrintPatch ( showFriendly )
import Darcs.Patch.PatchInfoAnd ( fmapFLPIAP, hopefullyM, info )
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, findRepository )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.External ( viewDocWith )
import Darcs.UI.Flags
    ( DarcsFlag
    , changesReverse, onlyToFiles
    , useCache, maxCount, hasXmlOutput
    , verbosity, withContext, isInteractive, verbose
    , fixSubPaths, getRepourl )
import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Util.Path ( SubPath(), toFilePath,
                    fp2fn, fn2fp, normPath, AbsolutePath, simpleSubPath )
import Darcs.Repository ( PatchSet, PatchInfoAnd,
                          withRepositoryLocation, RepoJob(..),
                          readRepo, unrecordedChanges,
                          withRepoLockCanFail )
import Darcs.Repository.Flags ( UseIndex(..), ScanKnown(..), DiffAlgorithm(MyersDiff) )
import Darcs.Util.Lock ( withTempDir )
import Darcs.Patch.Set ( PatchSet(..), patchSet2RL )
import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )
import Darcs.Patch.Format ( PatchListFormat )
import Darcs.Patch.FileHunk ( IsHunk )
import Darcs.Patch.Info ( toXml, toXmlShort, showPatchInfo, displayPatchInfo, escapeXML, PatchInfo )
import Darcs.Patch.Depends ( findCommonWithThem )
import Darcs.Patch.Bundle( contextPatches )
import Darcs.Patch.Prim ( PrimPatchBase )
import Darcs.Patch.Show ( ShowPatch, ShowPatchFor(..) )
import Darcs.Patch.TouchesFiles ( lookTouch )
import Darcs.Patch.Type ( PatchType(PatchType) )
import Darcs.Patch.Apply ( Apply, ApplyState )
import Darcs.Patch ( IsRepoType, invert, xmlSummary, description,
                     effectOnFilePaths, listTouchedFiles, showPatch )
import Darcs.Patch.Named.Wrapped ( (:~:)(..), getdeps )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered
    ( FL(NilFL), RL(..), filterOutFLFL, filterRL,
    reverseFL, (:>)(..), mapRL )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..), seal2 )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Patch.Match
    ( MatchFlag
    , firstMatch
    , secondMatch
    , matchAPatch
    , haveNonrangeMatch
    , matchFirstPatchset
    , matchSecondPatchset
    )
import Darcs.Patch.Matchable ( Matchable )
import Darcs.Util.Printer ( Doc, simplePrinters, (<+>), prefix, text, vcat,
                 vsep, ($$), errorDoc, insertBeforeLastline, empty )
import Darcs.Util.Printer.Color ( fancyPrinters )
import Darcs.Util.Progress ( setProgressMode, debugMessage )
import Darcs.Util.URL ( isValidLocalPath )
import Darcs.UI.SelectChanges ( viewChanges )
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )
import Darcs.Repository.PatchIndex ( PatchFilter, maybeFilterPatches, attemptCreatePatchIndex )
import Darcs.Util.Tree( Tree )

logHelp :: String
logHelp = unlines
 [ "The `darcs log` command lists patches of the current repository or,"
 , "with `--repo`, a remote repository.  Without options or arguments,"
 , "ALL patches will be listed."
 , ""]
 ++ logHelp'
 ++ logHelp''

log :: DarcsCommand [DarcsFlag]
log = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "log"
    , commandHelp = logHelp
    , commandDescription = "List patches in the repository."
    , commandExtraArgs = -1
    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
    , commandCompleteArgs = knownFileArgs
    , commandCommand = logCmd
    , commandPrereq = findRepository
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = odesc logAdvancedOpts
    , commandBasicOptions = odesc logBasicOpts
    , commandDefaults = defaultFlags logOpts
    , commandCheckOptions = ocheck logOpts
    , commandParseOptions = onormalise logOpts
    }
  where
    logBasicOpts
      = O.matchSeveralOrRange
      ^ O.maxCount
      ^ O.onlyToFiles
      ^ O.changesFormat
      ^ O.summary
      ^ O.changesReverse
      ^ O.possiblyRemoteRepo
      ^ O.repoDir
      ^ O.interactive
    logAdvancedOpts = O.network ^ O.patchIndexYes
    logOpts = logBasicOpts `withStdOpts` logAdvancedOpts

logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
logCmd fps opts args
  | O.changesFormat ? opts == Just O.GenContext = if not . null $ args
      then fail "log --context cannot accept other arguments"
      else logContext opts
  | hasRemoteRepo opts = do
      (fs, es) <- remoteSubPaths args []
      if null es then
        withTempDir "darcs.log" (\_ -> showLog opts $ maybeNotNull $ nub $ sort fs)
      else
        fail $ "For a remote repo I can only handle relative paths.\n"
            ++ "Invalid arguments: "++unwords es
  | null args = showLog opts Nothing
  | otherwise = do
      fs <- fixSubPaths fps args
      case fs of
        [] -> putStrLn "No valid arguments were given, nothing to do."
        _ -> do unless (isInteractive False opts)
                 $ when (O.patchIndexNo ? opts == O.YesPatchIndex)
                  $ withRepoLockCanFail (useCache ? opts)
                    $ RepoJob (\repo -> readRepo repo >>= attemptCreatePatchIndex repo)
                showLog opts $ Just $ nub $ sort fs

maybeNotNull :: [a] -> Maybe [a]
maybeNotNull [] = Nothing
maybeNotNull xs = Just xs

hasRemoteRepo :: [DarcsFlag] -> Bool
hasRemoteRepo = maybe False (not . isValidLocalPath) . parseFlags O.possiblyRemoteRepo

remoteSubPaths :: [String] -> [String] -> IO ([SubPath],[String])
remoteSubPaths [] es = return ([], es)
remoteSubPaths (arg:args) es = case simpleSubPath arg of
  Nothing -> remoteSubPaths args (arg:es)
  Just sp -> do
    (sps, es') <- remoteSubPaths args es
    return (sp:sps, es')

showLog :: [DarcsFlag] -> Maybe [SubPath] -> IO ()
showLog opts files =
  let repodir = fromMaybe "." (getRepourl opts) in
  withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repository -> do
  unless (O.debug ? opts) $ setProgressMode False
  Sealed unrec <- case files of
    Nothing -> return $ Sealed NilFL
    Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown, MyersDiff)
                  O.NoLookForMoves O.NoLookForReplaces
                  repository files
                  `catch` \(_ :: IOException) -> return (Sealed NilFL) -- this is triggered when repository is remote
  debugMessage "About to read the repository..."
  patches <- readRepo repository
  debugMessage "Done reading the repository."
  let normfp = fn2fp . normPath . fp2fn
      undoUnrecordedOnFPs = effectOnFilePaths (invert unrec)
      recFiles = map normfp . undoUnrecordedOnFPs . map toFilePath <$> files
      filtered_changes p =
          maybe_reverse <$>
          getLogInfo
              (maxCount ? opts)
              (parseFlags O.matchSeveralOrRange opts)
              (onlyToFiles ? opts)
              recFiles
              (maybeFilterPatches repository patches)
              p
  if isInteractive False opts
    then do (fp_and_fs, _, _) <- filtered_changes patches
            let fp = map fst fp_and_fs
            viewChanges (logPatchSelOpts opts) fp
    else do let header = if isJust files && hasXmlOutput opts
                          then text $ "Changes to "++unwords (fromJust recFiles)++":\n"
                          else empty
            debugMessage "About to print the patches..."
            let printers = if hasXmlOutput opts then simplePrinters else fancyPrinters
            ps <- readRepo repository -- read repo again to prevent holding onto
                                       -- values forced by filtered_changes
            logOutput <- changelog opts ps `fmap` filtered_changes patches
            viewDocWith printers $ header $$ logOutput
  where maybe_reverse (xs,b,c) = if changesReverse ? opts
                                 then (reverse xs, b, c)
                                 else (xs, b, c)

logHelp' :: String
logHelp' = unlines
 [ "When given files or directories paths as arguments, only patches which"
 , "affect those paths are listed.  This includes patches that happened to"
 , "files before they were moved or renamed."
 , ""
 , "When given `--from-tag` or `--from-patch`, only patches since that tag"
 , "or patch are listed.  Similarly, the `--to-tag` and `--to-patch`"
 , "options restrict the list to older patches."
 , ""
 , "The `--last` and `--max-count` options both limit the number of patches"
 , "listed.  The former applies BEFORE other filters, whereas the latter"
 , "applies AFTER other filters.  For example `darcs log foo.c"
 , "--max-count 3` will print the last three patches that affect foo.c,"
 , "whereas `darcs log --last 3 foo.c` will, of the last three"
 , "patches, print only those that affect foo.c."
 , ""
 ]

getLogInfo :: forall rt p wX wY
                . (IsRepoType rt, Matchable p, ApplyState p ~ Tree)
               => Maybe Int -> [MatchFlag] -> Bool
               -> Maybe [FilePath]
               -> PatchFilter rt p
               -> PatchSet rt p wX wY
               -> IO ( [(Sealed2 (PatchInfoAnd rt p), [FilePath])]
                     , [(FilePath, FilePath)]
                     , Maybe Doc )
getLogInfo maxCountFlag matchFlags onlyToFilesFlag plain_fs patchFilter ps =
    case (sp1s, sp2s) of
      (Sealed p1s, Sealed p2s) ->
          case findCommonWithThem p2s p1s of
            _ :> us ->
              let ps' = filterRL pf (reverseFL us) in
                case plain_fs of
                  Nothing -> return $ foldr (\x xs -> (x, []) -:- xs) ([], [], Nothing) $
                    maybe id take maxCountFlag ps'
                  Just fs -> let fs' = map (\x -> "./" ++ x) fs in do
                    filterOutUnrelatedChanges <$> do
                       ps'' <- patchFilter fs' ps'
                       return $ filterPatchesByNames maxCountFlag fs' ps''
  where
        sp1s = if firstMatch matchFlags
               then matchFirstPatchset matchFlags ps
               else Sealed $ PatchSet NilRL NilRL
        sp2s = if secondMatch matchFlags
               then matchSecondPatchset matchFlags ps
               else Sealed ps
        pf = if haveNonrangeMatch (PatchType :: PatchType rt p) matchFlags
             then matchAPatch matchFlags
             else \_ -> True

        filterOutUnrelatedChanges (pfs, renames, doc)
          | onlyToFilesFlag = (map onlyRelated pfs, renames, doc)
          | otherwise       = (pfs, renames, doc)

        onlyRelated (Sealed2 p, fs) =
          (Sealed2 $ fmapFLPIAP (filterOutFLFL (unrelated fs)) (\_ -> ReflPatch) p, fs)

        unrelated fs p
          -- If the change does not affect the patches we are looking at,
          -- we ignore the difference between the two states.
          | null $ fs `intersect` listTouchedFiles p = unsafeCoerceP IsEq
          | otherwise                                = NotEq

-- | Take a list of filenames and patches and produce a list of patches that
-- actually touch the given files with a list of touched file names, a list of
-- original-to-current filepath mappings, indicating the original names of the
-- affected files and possibly an error. Additionaly, the function takes a
-- "depth limit" -- maxcount, that could be Nothing (return everything) or
-- "Just n" -- returns at most n patches touching the file (starting from the
-- beginning of the patch list).
filterPatchesByNames
    :: forall rt p
     . (Matchable p, ApplyState p ~ Tree)
    => Maybe Int -- ^ maxcount
    -> [FilePath] -- ^ filenames
    -> [Sealed2 (PatchInfoAnd rt p)] -- ^ patchlist
    -> ([(Sealed2 (PatchInfoAnd rt p),[FilePath])], [(FilePath, FilePath)], Maybe Doc)
filterPatchesByNames maxcount fns patches = removeNonRenames $
    evalState (filterPatchesByNames' fns patches) (maxcount, initRenames) where
        removeNonRenames (ps, renames, doc) = (ps, removeIds renames, doc)
        removeIds = filter $ uncurry (/=)
        initRenames = map (\x -> (x, x)) fns
        returnFinal = (\renames -> ([], renames, Nothing)) <$> gets snd
        filterPatchesByNames' [] _ = returnFinal
        filterPatchesByNames' _ [] = returnFinal
        filterPatchesByNames' fs (s2hp@(Sealed2 hp) : ps) = do
            (count, renames) <- get
            let stopNow = case count of
                                Nothing -> False
                                Just c -> c <= 0
            if stopNow
                then returnFinal
                else case hopefullyM hp of
                    Nothing -> do
                        let err = text "Can't find patches prior to:"
                                  $$ displayPatchInfo (info hp)
                        return ([], renames, Just err)
                    Just p ->
                        case lookTouch (Just renames) fs (invert p) of
                            (True, affected, [], renames') ->
                                return ([(s2hp, affected)], renames', Nothing)
                            (True, affected, fs', renames') -> do
                                let sub1Mb c = subtract 1 <$> c
                                modify $ \(c, _) -> (sub1Mb c, renames')
                                rest <- filterPatchesByNames' fs' ps
                                return $ (s2hp, affected) -:- rest
                            (False, _, fs', renames') -> do
                                modify $ second (const renames')
                                filterPatchesByNames' fs' ps

-- | Note, lazy pattern matching is required to make functions like
-- filterPatchesByNames lazy in case you are only not interested in
-- the first element. E.g.:
--
--   let (fs, _, _) = filterPatchesByNames ...
(-:-) :: a -> ([a],b,c) -> ([a],b,c)
x -:- ~(xs,y,z) = (x:xs,y,z)

changelog :: forall rt p wStart wX
           . ( Apply p, ApplyState p ~ Tree, ShowPatch p, IsHunk p
             , PrimPatchBase p, PatchListFormat p
             , Conflict p, CommuteNoConflicts p
             )
          => [DarcsFlag] -> PatchSet rt p wStart wX
          -> ([(Sealed2 (PatchInfoAnd rt p), [FilePath])], [(FilePath, FilePath)], Maybe Doc)
          -> Doc
changelog opts patchset (pis_and_fs, createdAsFs, mbErr)
    | O.changesFormat ? opts == Just O.CountPatches = text $ show $ length pis_and_fs
    | hasXmlOutput opts =
         text "<changelog>"
      $$ vcat created_as_xml
      $$ vcat actual_xml_changes
      $$ text "</changelog>"
    | O.yes (O.summary ? opts) || verbose opts =
        mbAppendErr $ vsep (map (number_patch change_with_summary) pis)
    | otherwise = mbAppendErr $ vsep (map (number_patch description') pis)
    where mbAppendErr = maybe id (\err -> ($$ err)) mbErr
          change_with_summary :: Sealed2 (PatchInfoAnd rt p) -> Doc
          change_with_summary (Sealed2 hp)
            | Just p <- hopefullyM hp =
              if O.changesFormat ? opts == Just O.MachineReadable
                then showPatch ForStorage p
                else showFriendly (verbosity ? opts) (O.summary ? opts) p
            | otherwise = description hp $$ indent (text "[this patch is unavailable]")

          xml_with_summary (Sealed2 hp) | Just p <- hopefullyM hp =
                    let
                      deps = getdeps p
                      xmlDependencies =
                        text "<explicit_dependencies>"
                        $$ vcat (map (indent . toXmlShort) deps)
                        $$ text "</explicit_dependencies>"
                      summary | deps == [] = indent $ xmlSummary p
                              | otherwise = indent $ xmlDependencies $$ xmlSummary p
                    in
                      insertBeforeLastline (toXml $ info hp) summary
          xml_with_summary (Sealed2 hp) = toXml (info hp)
          indent = prefix "    "
          actual_xml_changes =
            case O.summary ? opts of
              O.YesSummary -> map xml_with_summary pis
              O.NoSummary -> map (toXml . unseal2 info) pis

          created_as_xml = map create createdAsFs where
            create rename@(_, as) = createdAsXml (first_change_of as) rename
            -- We need to reorder the patches when they haven't been reversed
            -- already, so that we find the *first* patch that modifies a given
            -- file, not the last (by default, the list is oldest->newest).
            reorderer = if not (changesReverse ? opts) then reverse else id
            oldest_first_pis_and_fs = reorderer pis_and_fs
            couldnt_find fn = error $ "Couldn't find first patch affecting " ++
                                      fn ++ " in pis_and_fs"
            mb_first_change_of fn = find ((fn `elem`) . snd) oldest_first_pis_and_fs
            find_first_change_of fn = fromMaybe (couldnt_find fn)
              (mb_first_change_of fn)
            first_change_of = unseal2 info . fst . find_first_change_of
          number_patch f x = if O.changesFormat ? opts == Just O.NumberPatches
                             then case get_number x of
                                  Just n -> text (show n++":") <+> f x
                                  Nothing -> f x
                             else f x
          get_number :: Sealed2 (PatchInfoAnd re p) -> Maybe Int
          get_number (Sealed2 y) = gn 1 (patchSet2RL patchset)
              where iy = info y
                    gn :: Int -> RL (PatchInfoAnd rt p) wStart wY -> Maybe Int
                    gn n (bs:<:b) | seq n (info b) == iy = Just n
                                  | otherwise = gn (n+1) bs
                    gn _ NilRL = Nothing
          pis = map fst pis_and_fs
          description' = unseal2 description

logHelp'' :: String
logHelp'' = unlines
 [ "Four output formats exist.  The default is `--human-readable`. The slightly"
 , "different `--machine-readable` format enables to see patch dependencies in"
 , "non-interactive mode. You can also select `--context`, which is an internal"
 , "format that can be re-read by Darcs (e.g. `darcs clone --context`)."
 , ""
 , "Finally, there is `--xml-output`, which emits valid XML... unless a the"
 , "patch metadata (author, name or description) contains a non-ASCII"
 , "character and was recorded in a non-UTF8 locale."
 ]

logContext :: [DarcsFlag] -> IO ()
logContext opts = do
  let repodir = fromMaybe "." $ getRepourl opts
  withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repository -> do
      (_ :> ps') <- contextPatches `fmap` readRepo repository
      let pis = mapRL seal2 ps'
      let header = text "\nContext:\n"
      let logOutput = maybe (vsep $ map (unseal2 (showPatchInfo ForStorage . info)) pis) errorDoc Nothing
      viewDocWith simplePrinters $ header $$ logOutput

-- | changes is an alias for log
changes :: DarcsCommand [DarcsFlag]
changes = commandAlias "changes" Nothing log

createdAsXml :: PatchInfo -> (String, String) -> Doc
createdAsXml pinfo (current, createdAs) =
    text "<created_as current_name='"
       <> escapeXML current
       <> text "' original_name='"
       <> escapeXML createdAs
       <> text "'>"
    $$    toXml pinfo
    $$    text "</created_as>"

logPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
logPatchSelOpts flags = S.PatchSelectionOptions
    { S.verbosity = verbosity ? flags
    , S.matchFlags = parseFlags O.matchSeveralOrRange flags
    , S.interactive = isInteractive False flags
    , S.selectDeps = O.PromptDeps -- option not supported, use default
    , S.summary = O.summary ? flags
    , S.withContext = withContext ? flags
    }