--  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, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Patch.Match ( patchSetMatch )
import Darcs.Repository ( withRepository, RepoJob(..), readPristine )
import Darcs.Repository.Match ( getPristineUpToMatch )
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
    { 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
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
showContentsOpts
    }
  where
    showContentsOpts :: CommandOptions
showContentsOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  [MatchFlag]
MatchOption
O.matchUpToOne PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  [MatchFlag]
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
     (Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
     ([MatchFlag]
      -> Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
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
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption (Maybe String)
O.repoDir OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  ([MatchFlag]
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
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 a. String -> IO a
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 a. [a] -> 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 a. String -> IO a
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 PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
MatchOption
O.matchUpToOne [DarcsFlag]
opts
  UseCache -> RepoJob 'RO () -> IO ()
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RO () -> IO ()) -> RepoJob 'RO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RO () -> RepoJob 'RO ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RO () -> RepoJob 'RO ())
-> TreePatchJob 'RO () -> RepoJob 'RO ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR
repository -> do
    let readContents :: RWST (DumpItem IO) () (TreeState IO) IO [ByteString]
readContents = do
          [AnchoredPath]
okpaths <- (AnchoredPath -> RWST (DumpItem IO) () (TreeState IO) IO Bool)
-> [AnchoredPath]
-> RWST (DumpItem IO) () (TreeState IO) IO [AnchoredPath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM AnchoredPath -> RWST (DumpItem IO) () (TreeState IO) IO Bool
forall (m :: * -> *). Monad m => AnchoredPath -> TreeMonad m Bool
TM.fileExists [AnchoredPath]
paths
          [AnchoredPath]
-> (AnchoredPath
    -> RWST (DumpItem IO) () (TreeState IO) IO ByteString)
-> RWST (DumpItem 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 (DumpItem IO) () (TreeState IO) IO ByteString)
 -> RWST (DumpItem IO) () (TreeState IO) IO [ByteString])
-> (AnchoredPath
    -> RWST (DumpItem IO) () (TreeState IO) IO ByteString)
-> RWST (DumpItem 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 (DumpItem IO) () (TreeState IO) IO ByteString
-> RWST (DumpItem IO) () (TreeState IO) IO ByteString
forall a b.
(a -> b)
-> RWST (DumpItem IO) () (TreeState IO) IO a
-> RWST (DumpItem IO) () (TreeState IO) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` AnchoredPath -> RWST (DumpItem IO) () (TreeState IO) IO ByteString
forall (m :: * -> *).
MonadThrow m =>
AnchoredPath -> TreeMonad m ByteString
TM.readFile AnchoredPath
f
        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 a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RWST (DumpItem IO) () (TreeState IO) IO [ByteString]
-> Tree IO -> IO ([ByteString], Tree IO)
forall a. TreeIO a -> Tree IO -> IO (a, Tree IO)
TM.virtualTreeIO RWST (DumpItem IO) () (TreeState IO) IO [ByteString]
readContents Tree IO
tree
    [ByteString]
files <-
      (case [MatchFlag] -> Maybe PatchSetMatch
patchSetMatch [MatchFlag]
matchFlags of
        Just PatchSetMatch
psm -> Repository 'RO p wU wR -> PatchSetMatch -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR -> PatchSetMatch -> IO (Tree IO)
getPristineUpToMatch Repository 'RO p wU wR
repository PatchSetMatch
psm
        Maybe PatchSetMatch
Nothing -> Repository 'RO p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository 'RO p wU wR
repository) IO (Tree IO) -> (Tree IO -> IO [ByteString]) -> IO [ByteString]
forall a b. IO a -> (a -> IO b) -> IO b
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