-- Copyright (C) 2009 Petr Rockai
--
-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use, copy,
-- modify, merge, publish, distribute, sublicense, and/or sell copies
-- of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
-- SOFTWARE.

{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Darcs.UI.Commands.ShowIndex
    ( showIndex
    , showPristine
    ) where

import Darcs.Prelude

import Darcs.UI.Flags ( DarcsFlag, useCache )
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Options ( (^), oid, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository ( withRepository, RepoJob(..) )
import Darcs.Repository.State ( readPristine )
import Darcs.Repository.Paths ( indexPath )

import Darcs.Util.Hash ( showHash )
import Darcs.Util.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) )
import Darcs.Util.Index( IndexEntry(..), dumpIndex )
import Darcs.Util.Path( anchorPath, AbsolutePath, anchoredRoot, realPath )
import Darcs.Util.Printer ( Doc, putDocLn, text, vcat )

import System.Posix.Types ( FileID )

import Control.Monad ( (>=>) )
import Data.Int ( Int64 )
import qualified Data.Map as M ( Map, lookup )
import Data.Maybe ( fromJust )
import Text.Printf ( printf )

showIndexHelp :: Doc
showIndexHelp :: Doc
showIndexHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
  String
"The `darcs show index` command lists all version-controlled files and " String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"directories along with their hashes as stored in `_darcs/index`. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"For files, the fields correspond to file size, sha256 of the current " String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"file content and the filename."

showIndex :: DarcsCommand
showIndex :: DarcsCommand
showIndex = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"index"
    , commandDescription :: String
commandDescription = String
"Dump contents of working tree index."
    , commandHelp :: Doc
commandHelp = Doc
showIndexHelp
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showIndexCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInRepository
    , 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
showIndexOpts
    }
  where
    showIndexBasicOpts :: OptSpec DarcsOptDescr DarcsFlag a (Bool -> Maybe String -> a)
showIndexBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag (Maybe String -> a) Bool
PrimDarcsOption Bool
O.nullFlag PrimOptSpec DarcsOptDescr DarcsFlag (Maybe String -> a) Bool
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Bool -> 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
    showIndexOpts :: CommandOptions
showIndexOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec DarcsOptDescr DarcsFlag a (Bool -> Maybe String -> a)
showIndexBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Bool
   -> 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

dump :: [DarcsFlag] -> Maybe (M.Map FilePath FileID) -> Tree IO -> IO ()
dump :: [DarcsFlag] -> Maybe (Map String FileID) -> Tree IO -> IO ()
dump [DarcsFlag]
opts Maybe (Map String FileID)
fileids Tree IO
tree = do
  let line :: String -> IO ()
line | PrimOptSpec DarcsOptDescr DarcsFlag a Bool
PrimDarcsOption Bool
O.nullFlag PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts = \String
t -> String -> IO ()
putStr String
t IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> IO ()
putChar Char
'\0'
           | Bool
otherwise = String -> IO ()
putStrLn
      output :: (AnchoredPath, TreeItem m) -> IO ()
output (AnchoredPath
p, TreeItem m
i) = do
        let hash :: String
hash = Maybe Hash -> String
showHash (TreeItem m -> Maybe Hash
forall (m :: * -> *). TreeItem m -> Maybe Hash
itemHash TreeItem m
i)
            path :: String
path = String -> AnchoredPath -> String
anchorPath String
"" AnchoredPath
p
            isdir :: String
isdir = case TreeItem m
i of
                      SubTree Tree m
_ -> String
"/"
                      TreeItem m
_ -> String
""
            fileid :: String
fileid = case Maybe (Map String FileID)
fileids of
                       Maybe (Map String FileID)
Nothing -> String
""
                       Just Map String FileID
fileids' -> String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (FileID -> String
forall a. Show a => a -> String
show (FileID -> String) -> FileID -> String
forall a b. (a -> b) -> a -> b
$ Maybe FileID -> FileID
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe FileID -> FileID) -> Maybe FileID -> FileID
forall a b. (a -> b) -> a -> b
$ String -> Map String FileID -> Maybe FileID
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
path Map String FileID
fileids')
        String -> IO ()
line (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
hash String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fileid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
isdir
  Tree IO
x <- Tree IO -> IO (Tree IO)
forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand Tree IO
tree
  ((AnchoredPath, TreeItem IO) -> IO ())
-> [(AnchoredPath, TreeItem IO)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (AnchoredPath, TreeItem IO) -> IO ()
forall {m :: * -> *}. (AnchoredPath, TreeItem m) -> IO ()
output ([(AnchoredPath, TreeItem IO)] -> IO ())
-> [(AnchoredPath, TreeItem IO)] -> IO ()
forall a b. (a -> b) -> a -> b
$ (AnchoredPath
anchoredRoot, Tree IO -> TreeItem IO
forall (m :: * -> *). Tree m -> TreeItem m
SubTree Tree IO
x) (AnchoredPath, TreeItem IO)
-> [(AnchoredPath, TreeItem IO)] -> [(AnchoredPath, TreeItem IO)]
forall a. a -> [a] -> [a]
: Tree IO -> [(AnchoredPath, TreeItem IO)]
forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
x

showIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showIndexCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ = 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
_repo -> do
  [IndexEntry]
entries <- String -> IO [IndexEntry]
dumpIndex String
indexPath
  Doc -> IO ()
putDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
header Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (IndexEntry -> Doc) -> [IndexEntry] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map IndexEntry -> Doc
formatEntry [IndexEntry]
entries
  where
    header :: Doc
header =
      String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
-> String
-> String
-> String
-> String
-> String
-> String
-> String
forall r. PrintfType r => String -> r
printf String
"%-64s %1s %12s %20s %12s %s" String
"HASH" String
"T" String
"SIZE" String
"AUX" String
"FILEID" String
"PATH"
    formatEntry :: IndexEntry -> Doc
formatEntry IndexEntry{Char
Int64
Maybe Hash
FileID
AnchoredPath
ieSize :: Int64
ieAux :: Int64
ieFileID :: FileID
ieHash :: Maybe Hash
ieType :: Char
iePath :: AnchoredPath
ieSize :: IndexEntry -> Int64
ieAux :: IndexEntry -> Int64
ieFileID :: IndexEntry -> FileID
ieHash :: IndexEntry -> Maybe Hash
ieType :: IndexEntry -> Char
iePath :: IndexEntry -> AnchoredPath
..} =
      let fileid :: Int64
          fileid :: Int64
fileid = FileID -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral FileID
ieFileID
          hash :: String
hash = Maybe Hash -> String
showHash Maybe Hash
ieHash
      in String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
-> String -> Char -> Int64 -> Int64 -> Int64 -> String -> String
forall r. PrintfType r => String -> r
printf String
"%64s %c %12d %20d %12d %s"
          String
hash Char
ieType Int64
ieSize Int64
ieAux Int64
fileid (AnchoredPath -> String
realPath AnchoredPath
iePath)

showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showPristineCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ = 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 -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine (Repository 'RO p wU wR -> IO (Tree IO))
-> (Tree IO -> IO ()) -> Repository 'RO p wU wR -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [DarcsFlag] -> Maybe (Map String FileID) -> Tree IO -> IO ()
dump [DarcsFlag]
opts Maybe (Map String FileID)
forall a. Maybe a
Nothing

showPristineHelp :: Doc
showPristineHelp :: Doc
showPristineHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
  String
"The `darcs show pristine` command lists all version-controlled files " String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"and directories along with the hashes of their pristine copies. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"For files, the fields correspond to file size, sha256 of the pristine " String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"file content and the filename."

showPristine :: DarcsCommand
showPristine :: DarcsCommand
showPristine = DarcsCommand
showIndex
    { commandName = "pristine"
    , commandDescription = "Dump contents of pristine cache."
    , commandHelp = showPristineHelp
    , commandCommand = showPristineCmd
    }