--  Copyright (C) 2003 David Roundy, 2010-2011 Petr Rockai
--
--  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, OverloadedStrings #-}

module Darcs.UI.Commands.Annotate ( annotate ) where

import Prelude hiding ( (^) )

import Control.Arrow ( first )
import Control.Monad ( unless )

import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )
import Darcs.UI.Flags ( DarcsFlag(NoPatchIndexFlag), isUnified, useCache, fixSubPaths, hasSummary, umask )
import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise
                        , defaultFlags, parseFlags )
import qualified Darcs.UI.Options.All as O
import Storage.Hashed.Plain( readPlainTree )
import Darcs.Repository.State ( readRecorded )
import Darcs.Repository
    ( withRepository
    , withRepoLockCanFail
    , RepoJob(..)
    , readRepo
    , repoPatchType
    , listRegisteredFiles
    )
import Darcs.Repository.Flags ( UpdateWorking(..) )
import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex )
import Darcs.Patch.Set ( newset2RL )
import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, invertRL )
import qualified Darcs.Patch ( summary )
import Darcs.Patch.Type ( PatchType(..) )
import Darcs.Patch.Dummy ( DummyPatch )
import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate )
import Data.ByteString.Lazy ( toChunks )
import Darcs.UI.PrintPatch ( printPatch, contextualPrintPatch )
import Darcs.Patch.ApplyMonad( withFileNames )
import System.FilePath.Posix ( (</>) )
import Darcs.Patch.Info ( showPatchInfoUI, showPatchInfo )
import Darcs.Patch.Match ( matchPatch, haveNonrangeMatch, getNonrangeMatchS  )
import Darcs.Repository.Match ( getFirstMatch, getOnePatchset )
import Darcs.Repository.Lock ( withTempDir )
import Darcs.Repository.PatchIndex ( getRelevantSubsequence, canUsePatchIndex )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal )
import qualified Darcs.Patch.Annotate as A
import Darcs.Util.Printer ( putDocLn, Doc )

import Storage.Hashed.Tree( TreeItem(..), readBlob, list, expand )
import Storage.Hashed.Monad( findM, virtualTreeIO )
import Darcs.Util.Path( floatPath, anchorPath, fp2fn, toFilePath
                      , AbsolutePath )
import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )

#include "impossible.h"

annotateDescription :: String
annotateDescription = "Display which patch last modified something."

annotateHelp :: String
annotateHelp = unlines
 [ "The `darcs annotate` command provides two unrelated operations.  When"
 , "called on a file, it will find the patch that last modified each line"
 , "in that file.  When called on a patch (e.g. using `--patch`), it will"
 , "print the internal representation of that patch."
 , ""
 , "The `--summary` option will result in a summarized patch annotation,"
 , "similar to `darcs whatsnew`.  It has no effect on file annotations."
 , ""
 , "By default, output is in a human-readable format.  The `--machine-readable`"
 , "option can be used to generate output for machine postprocessing."
 ]

annotateBasicOpts :: DarcsOption a
                     (Maybe O.Summary
                      -> O.WithContext
                      -> Bool
                      -> [O.MatchFlag]
                      -> Maybe String
                      -> a)
annotateBasicOpts = O.summary
                  ^ O.withContext
                  ^ O.machineReadable
                  ^ O.matchOne
                  ^ O.workingRepoDir

annotateAdvancedOpts :: DarcsOption a (O.WithPatchIndex -> a)
annotateAdvancedOpts = O.patchIndexYes

annotateOpts :: DarcsOption a
                (Maybe O.Summary
                 -> O.WithContext
                 -> Bool
                 -> [O.MatchFlag]
                 -> Maybe String
                 -> Maybe O.StdCmdAction
                 -> Bool
                 -> Bool
                 -> O.Verbosity
                 -> Bool
                 -> O.WithPatchIndex
                 -> O.UseCache
                 -> Maybe String
                 -> Bool
                 -> Maybe String
                 -> Bool
                 -> a)
annotateOpts = annotateBasicOpts `withStdOpts` annotateAdvancedOpts

annotate :: DarcsCommand [DarcsFlag]
annotate = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "annotate"
    , commandHelp = annotateHelp
    , commandDescription = annotateDescription
    , commandExtraArgs = -1
    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
    , commandCommand = annotateCmd
    , commandPrereq = amInHashedRepository
    , commandGetArgPossibilities = listRegisteredFiles
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = odesc annotateAdvancedOpts
    , commandBasicOptions = odesc annotateBasicOpts
    , commandDefaults = defaultFlags annotateOpts
    , commandCheckOptions = ocheck annotateOpts
    , commandParseOptions = onormalise annotateOpts
}

annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
annotateCmd fps opts [""] = annotate' fps opts [] -- when does that happen?
annotateCmd fps opts [] = do
  let matchFlags = parseFlags O.matchOne opts
  unless (haveNonrangeMatch (PatchType :: PatchType DummyPatch) matchFlags) $
      fail $ "Annotate requires either a patch pattern or a " ++
               "file or directory argument."
  annotate' fps opts []
annotateCmd fps opts args = annotate' fps opts args

annotate' :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
annotate' _ opts [] =    -- annotating a patch (ie, showing its contents)
  withRepository (useCache opts) $ RepoJob $ \repository -> do
  let matchFlags = parseFlags O.matchOne opts
  Sealed2 p <- matchPatch matchFlags `fmap` readRepo repository
  if hasSummary O.NoSummary opts == O.YesSummary
     then do putDocLn $ showpi $ patch2patchinfo p
             putDocLn $ show_summary p
     else if isUnified opts == O.YesContext
          then withTempDir "context" $ \_ ->
               do getFirstMatch repository matchFlags
                  c <- readPlainTree "."
                  contextualPrintPatch c p
          else printPatch p
    where showpi | parseFlags O.machineReadable opts = showPatchInfo
                 | otherwise                         = showPatchInfoUI
          show_summary :: RepoPatch p => Named p wX wY -> Doc
          show_summary = Darcs.Patch.summary

annotate' fps opts args@[_] = do -- annotating a file or a directory
 unless (NoPatchIndexFlag `elem` opts)
   $ withRepoLockCanFail (useCache opts) YesUpdateWorking (umask opts) $ RepoJob attemptCreatePatchIndex
 withRepository (useCache opts) $ RepoJob $ \repository -> do
  let matchFlags = parseFlags O.matchOne opts
  r <- readRepo repository
  (origpath:_) <- fixSubPaths fps args
  recorded <- readRecorded repository

  (patches, initial, path') <-
    if haveNonrangeMatch (repoPatchType repository) matchFlags
       then do Sealed x <- getOnePatchset repository matchFlags
               let fn = [fp2fn $ toFilePath origpath]
                   nonRangeMatch = getNonrangeMatchS matchFlags r
                   (_, [path], _) = withFileNames Nothing fn nonRangeMatch
               initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS matchFlags r) recorded
               return (seal $ newset2RL x, initial, toFilePath path)
       else return (seal $ newset2RL r, recorded, toFilePath origpath)
  let path = "./" ++ path'

  found <- findM initial (floatPath $ toFilePath path)
  -- TODO need to decide about the --machine flag
  let fmt = if parseFlags O.machineReadable opts then A.machineFormat else A.format
  case found of
    Nothing -> fail $ "No such file or directory: " ++ toFilePath path
    Just (SubTree s) -> do
      s' <- expand s
      let subs = map (fp2fn . (path </>) . anchorPath "" . fst) $ list s'
          showPath (n, File _) = BC.pack (path </> n)
          showPath (n, _) = BC.concat [BC.pack (path </> n), "/"]
      (Sealed ans_patches) <- do
         upi <- canUsePatchIndex repository
         if not upi
            then return patches
            else getRelevantSubsequence patches repository subs
      putStrLn $ fmt (BC.intercalate "\n" $
                        map (showPath . first (anchorPath "")) $ list s') $
        A.annotateDirectory D.MyersDiff (invertRL ans_patches) (fp2fn path) subs
    Just (File b) -> do (Sealed ans_patches) <- do
                           upi <- canUsePatchIndex repository
                           if not upi
                              then return patches
                              else getRelevantSubsequence patches repository [fp2fn path]
                        con <- BC.concat `fmap` toChunks `fmap` readBlob b
                        putStrLn $ fmt con $ A.annotate D.MyersDiff (invertRL ans_patches) (fp2fn path) con
    Just (Stub _ _) -> impossible

annotate' _ _ _ = fail "annotate accepts at most one argument"