--  Copyright (C) 2007 Eric Kow
--
--  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.

module Darcs.UI.Commands.ShowContents ( showContents ) where

import Control.Monad ( filterM, forM_, forM, when )
import System.IO ( stdout )

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL

import Darcs.Prelude

import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags ( DarcsFlag, useCache, pathsFromArgs )
import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Patch.Match ( patchSetMatch )
import Darcs.Repository ( withRepository, RepoJob(..), readRecorded )
import Darcs.Util.Lock ( withDelayedDir )
import Darcs.Repository.Match ( getRecordedUpToMatch )
import Darcs.Util.Tree.Plain( readPlainTree )
import qualified Darcs.Util.Tree.Monad as TM
import Darcs.Util.Path( AbsolutePath )
import Darcs.Util.Printer ( Doc, text )

showContentsDescription :: String
showContentsDescription :: String
showContentsDescription = String
"Outputs a specific version of a file."

showContentsHelp :: Doc
showContentsHelp :: Doc
showContentsHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
  String
"Show contents can be used to display an earlier version of some file(s).\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"If you give show contents no version arguments, it displays the recorded\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"version of the file(s).\n"

showContents :: DarcsCommand
showContents :: DarcsCommand
showContents = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"contents"
    , commandHelp :: Doc
commandHelp = Doc
showContentsHelp
    , commandDescription :: String
commandDescription = String
showContentsDescription
    , commandExtraArgs :: Int
commandExtraArgs = -Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[FILE]..."]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showContentsCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
findRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = []
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr DarcsFlag Any ([MatchFlag] -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr DarcsFlag Any ([MatchFlag] -> Maybe String -> Any)
forall a.
OptSpec
  DarcsOptDescr DarcsFlag a ([MatchFlag] -> Maybe String -> a)
showContentsBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  ([MatchFlag]
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  ([MatchFlag]
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  ([MatchFlag]
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showContentsOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  ([MatchFlag]
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  ([MatchFlag]
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  ([MatchFlag]
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showContentsOpts
    }
  where
    showContentsBasicOpts :: OptSpec
  DarcsOptDescr DarcsFlag a ([MatchFlag] -> Maybe String -> a)
showContentsBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag (Maybe String -> a) [MatchFlag]
MatchOption
O.matchUpToOne PrimOptSpec DarcsOptDescr DarcsFlag (Maybe String -> a) [MatchFlag]
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
     DarcsOptDescr DarcsFlag a ([MatchFlag] -> Maybe String -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir
    showContentsOpts :: DarcsOption
  a
  ([MatchFlag]
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showContentsOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  [MatchFlag]
MatchOption
O.matchUpToOne PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  [MatchFlag]
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
     (Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
     ([MatchFlag]
      -> Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
PrimDarcsOption (Maybe String)
O.repoDir OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  ([MatchFlag]
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     ([MatchFlag]
      -> Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall (d :: * -> *) f a. OptSpec d f a a
oid

showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showContentsCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
_ [] = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"show contents needs at least one argument."
showContentsCmd (AbsolutePath, AbsolutePath)
fps [DarcsFlag]
opts [String]
args = do
  [AnchoredPath]
paths <- (AbsolutePath, AbsolutePath) -> [String] -> IO [AnchoredPath]
pathsFromArgs (AbsolutePath, AbsolutePath)
fps [String]
args
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([AnchoredPath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
paths) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No valid repository paths were given."
  let matchFlags :: [MatchFlag]
matchFlags = MatchOption -> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags MatchOption
O.matchUpToOne [DarcsFlag]
opts
  UseCache -> RepoJob () -> IO ()
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
    let readContents :: RWST (TreeEnv IO) () (TreeState IO) IO [ByteString]
readContents = do
          [AnchoredPath]
okpaths <- (AnchoredPath -> RWST (TreeEnv IO) () (TreeState IO) IO Bool)
-> [AnchoredPath]
-> RWST (TreeEnv IO) () (TreeState IO) IO [AnchoredPath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM AnchoredPath -> RWST (TreeEnv IO) () (TreeState IO) IO Bool
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
TM.fileExists [AnchoredPath]
paths
          [AnchoredPath]
-> (AnchoredPath
    -> RWST (TreeEnv IO) () (TreeState IO) IO ByteString)
-> RWST (TreeEnv IO) () (TreeState IO) IO [ByteString]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AnchoredPath]
okpaths ((AnchoredPath
  -> RWST (TreeEnv IO) () (TreeState IO) IO ByteString)
 -> RWST (TreeEnv IO) () (TreeState IO) IO [ByteString])
-> (AnchoredPath
    -> RWST (TreeEnv IO) () (TreeState IO) IO ByteString)
-> RWST (TreeEnv IO) () (TreeState IO) IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \AnchoredPath
f -> ([ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks) (ByteString -> ByteString)
-> RWST (TreeEnv IO) () (TreeState IO) IO ByteString
-> RWST (TreeEnv IO) () (TreeState IO) IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` AnchoredPath -> RWST (TreeEnv IO) () (TreeState IO) IO ByteString
forall (m :: * -> *).
Monad m =>
AnchoredPath -> TreeMonad m ByteString
TM.readFile AnchoredPath
f
        -- Note: The two calls to execReadContents below are from
        -- different working directories. This matters despite our
        -- use of virtualTreeIO.
        execReadContents :: Tree IO -> IO [ByteString]
execReadContents Tree IO
tree = ([ByteString], Tree IO) -> [ByteString]
forall a b. (a, b) -> a
fst (([ByteString], Tree IO) -> [ByteString])
-> IO ([ByteString], Tree IO) -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RWST (TreeEnv IO) () (TreeState IO) IO [ByteString]
-> Tree IO -> IO ([ByteString], Tree IO)
forall a. TreeIO a -> Tree IO -> IO (a, Tree IO)
TM.virtualTreeIO RWST (TreeEnv IO) () (TreeState IO) IO [ByteString]
readContents Tree IO
tree
    [ByteString]
files <-
      case [MatchFlag] -> Maybe PatchSetMatch
patchSetMatch [MatchFlag]
matchFlags of
        Just PatchSetMatch
psm ->
               String -> (AbsolutePath -> IO [ByteString]) -> IO [ByteString]
forall a. String -> (AbsolutePath -> IO a) -> IO a
withDelayedDir String
"show.contents" ((AbsolutePath -> IO [ByteString]) -> IO [ByteString])
-> (AbsolutePath -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
_ -> do
                 -- this call populates our temporary directory, but note that
                 -- it does so lazily: the tree gets (partly) expanded inside
                 -- execReadContents, so it is important that we execute the
                 -- latter from the same working directory.
                 Repository rt p wR wU wR -> PatchSetMatch -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(ApplyMonad (ApplyState p) DefaultIO, IsRepoType rt, RepoPatch p,
 ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> PatchSetMatch -> IO ()
getRecordedUpToMatch Repository rt p wR wU wR
repository PatchSetMatch
psm
                 String -> IO (Tree IO)
readPlainTree String
"." IO (Tree IO) -> (Tree IO -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree IO -> IO [ByteString]
execReadContents
        Maybe PatchSetMatch
Nothing ->
               -- we can use the existing pristine tree because we don't modify
               -- anything in this case
               Repository rt p wR wU wR -> IO (Tree IO)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wR
repository IO (Tree IO) -> (Tree IO -> IO [ByteString]) -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tree IO -> IO [ByteString]
execReadContents
    [ByteString] -> (ByteString -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ByteString]
files ((ByteString -> IO ()) -> IO ()) -> (ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
B.hPut Handle
stdout