-- 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.

module Darcs.UI.Commands.ShowIndex
    ( showIndex
    , showPristine
    ) where

import Darcs.Prelude

import Control.Monad ( (>=>) )
import Darcs.UI.Flags ( DarcsFlag, useCache )
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository ( withRepository, RepoJob(..), readIndex )
import Darcs.Repository.State ( readRecorded )

import Darcs.Util.Hash( encodeBase16, Hash( NoHash ) )
import Darcs.Util.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) )
import Darcs.Util.Index( treeFromIndex, listFileIDs )
import Darcs.Util.Path( anchorPath, AbsolutePath, floatPath )
import Darcs.Util.Printer ( Doc, text )

import System.Posix.Types ( FileID )

import qualified Data.ByteString.Char8 as BC
import Data.Maybe ( fromJust )
import qualified Data.Map as M ( Map, lookup, fromList )

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 :: 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
"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
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = []
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec DarcsOptDescr DarcsFlag Any (Bool -> Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Bool -> Maybe String -> Any)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (Bool -> Maybe String -> a)
showIndexBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Bool
   -> 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]
  (Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showIndexOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Bool
   -> 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
  (Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
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 :: DarcsOption
  a
  (Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showIndexOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (Bool -> Maybe String -> a)
showIndexBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Bool
   -> 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
     (Bool
      -> 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

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 | 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 (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 = case TreeItem m -> Hash
forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i of
                     Hash
NoHash -> String
"(no hash available)"
                     Hash
h -> ByteString -> String
BC.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Hash -> ByteString
encodeBase16 Hash
h
            path :: String
path = String -> AnchoredPath -> String
anchorPath String
"" AnchoredPath
p
            isdir :: String
isdir = case TreeItem m
i of
                      SubTree _ -> 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
$ (String -> AnchoredPath
floatPath String
".", 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 () -> 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
repo ->
  do Index
index <- Repository rt p wR wU wR -> IO Index
forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Index
readIndex Repository rt p wR wU wR
repo
     Tree IO
index_tree <- Index -> IO (Tree IO)
treeFromIndex Index
index
     Map String FileID
fileids <- ([(String, FileID)] -> Map String FileID
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, FileID)] -> Map String FileID)
-> ([((AnchoredPath, ItemType), FileID)] -> [(String, FileID)])
-> [((AnchoredPath, ItemType), FileID)]
-> Map String FileID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((AnchoredPath, ItemType), FileID) -> (String, FileID))
-> [((AnchoredPath, ItemType), FileID)] -> [(String, FileID)]
forall a b. (a -> b) -> [a] -> [b]
map (\((AnchoredPath
a,ItemType
_),FileID
b) -> (String -> AnchoredPath -> String
anchorPath String
"" AnchoredPath
a,FileID
b))) ([((AnchoredPath, ItemType), FileID)] -> Map String FileID)
-> IO [((AnchoredPath, ItemType), FileID)]
-> IO (Map String FileID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Index -> IO [((AnchoredPath, ItemType), FileID)]
listFileIDs Index
index
     [DarcsFlag] -> Maybe (Map String FileID) -> Tree IO -> IO ()
dump [DarcsFlag]
opts (Map String FileID -> Maybe (Map String FileID)
forall a. a -> Maybe a
Just Map String FileID
fileids) Tree IO
index_tree

showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showPristineCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ = 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 -> 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 -> IO (Tree IO))
-> (Tree IO -> IO ()) -> Repository rt p wR 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 :: String
commandName = String
"pristine"
    , commandDescription :: String
commandDescription = String
"Dump contents of pristine cache."
    , commandHelp :: Doc
commandHelp = Doc
showPristineHelp
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
showPristineCmd
    }