module Darcs.UI.Commands.ShowRepo ( showRepo ) where
import Darcs.Prelude
import Data.Char ( toLower, isSpace )
import Data.List ( intercalate )
import Control.Monad ( when, unless, liftM )
import Text.Html ( tag, stringToHtml )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.UI.Flags ( DarcsFlag, useCache, hasXmlOutput, verbose, enumeratePatches )
import Darcs.UI.Options ( (^), oid, odesc, ocheck, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )
import Darcs.UI.Completion ( noArgs )
import Darcs.Repository
( Repository
, repoFormat
, repoLocation
, repoPristineType
, repoCache
, withRepository
, RepoJob(..)
, readRepo )
import Darcs.Repository.Hashed( repoXor )
import Darcs.Repository.PatchIndex ( isPatchIndexDisabled, doesPatchIndexExist )
import Darcs.Repository.Prefs ( getPreflist, getMotd )
import Darcs.Patch ( IsRepoType, RepoPatch )
import Darcs.Patch.Set ( patchSet2RL )
import Darcs.Patch.Witnesses.Ordered ( lengthRL )
import qualified Data.ByteString.Char8 as BC (unpack)
import Darcs.Patch.Apply( ApplyState )
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Tree ( Tree )
showRepoHelp :: Doc
showRepoHelp :: Doc
showRepoHelp = String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"The `darcs show repo` command displays statistics about the current\n" forall a. [a] -> [a] -> [a]
++
String
"repository, allowing third-party scripts to access this information\n" forall a. [a] -> [a] -> [a]
++
String
"without inspecting `_darcs` directly (and without breaking when the\n" forall a. [a] -> [a] -> [a]
++
String
"`_darcs` format changes).\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"The 'Weak Hash' identifies the set of patches of a repository independently\n" forall a. [a] -> [a] -> [a]
++
String
"of ordering. It can be used to easily compare two repositories of a same\n" forall a. [a] -> [a] -> [a]
++
String
"project. It is not cryptographically secure.\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"By default, output includes statistics that require walking through the patches\n" forall a. [a] -> [a] -> [a]
++
String
"recorded in the repository, namely the 'Weak Hash' and the count of patches.\n" forall a. [a] -> [a] -> [a]
++
String
"If this data isn't needed, use `--no-enum-patches` to accelerate this command\n" forall a. [a] -> [a] -> [a]
++
String
"from O(n) to O(1).\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"By default, output is in a human-readable format. The `--xml-output`\n" forall a. [a] -> [a] -> [a]
++
String
"option can be used to generate output for machine postprocessing.\n"
showRepoDescription :: String
showRepoDescription :: String
showRepoDescription = String
"Show repository summary information"
showRepo :: DarcsCommand
showRepo :: DarcsCommand
showRepo = DarcsCommand
{ commandProgramName :: String
commandProgramName = String
"darcs"
, commandName :: String
commandName = String
"repo"
, commandHelp :: Doc
commandHelp = Doc
showRepoHelp
, commandDescription :: String
commandDescription = String
showRepoDescription
, commandExtraArgs :: Int
commandExtraArgs = Int
0
, commandExtraArgHelp :: [String]
commandExtraArgHelp = []
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
repoCmd
, 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 = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String -> XmlOutput -> EnumPatches -> a)
showRepoBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(Maybe String
-> XmlOutput
-> EnumPatches
-> Maybe StdCmdAction
-> Verbosity
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
showRepoOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
a
(Maybe String
-> XmlOutput
-> EnumPatches
-> Maybe StdCmdAction
-> Verbosity
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
showRepoOpts
}
where
showRepoBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String -> XmlOutput -> EnumPatches -> a)
showRepoBasicOpts = PrimDarcsOption (Maybe String)
O.repoDir forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption XmlOutput
O.xmlOutput forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption EnumPatches
O.enumPatches
showRepoOpts :: DarcsOption
a
(Maybe String
-> XmlOutput
-> EnumPatches
-> Maybe StdCmdAction
-> Verbosity
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
showRepoOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String -> XmlOutput -> EnumPatches -> a)
showRepoBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall (d :: * -> *) f a. OptSpec d f a a
oid
repoCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
repoCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
repoCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
let put_mode :: ShowInfo
put_mode = if [DarcsFlag] -> Bool
hasXmlOutput [DarcsFlag]
opts then ShowInfo
showInfoXML else ShowInfo
showInfoUsr
in forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
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 a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository ->
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO ()
actuallyShowRepo (ShowInfo -> PutInfo
putInfo ShowInfo
put_mode) Repository rt p wR wU wR
repository [DarcsFlag]
opts
type ShowInfo = String -> String -> String
showInfoXML :: ShowInfo
showInfoXML :: ShowInfo
showInfoXML String
t String
i = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ String -> Html -> Html
tag (String -> String
safeTag String
t) forall a b. (a -> b) -> a -> b
$ String -> Html
stringToHtml String
i
safeTag :: String -> String
safeTag :: String -> String
safeTag [] = []
safeTag (Char
' ':String
cs) = String -> String
safeTag String
cs
safeTag (Char
'#':String
cs) = String
"num_" forall a. [a] -> [a] -> [a]
++ String -> String
safeTag String
cs
safeTag (Char
c:String
cs) = Char -> Char
toLower Char
c forall a. a -> [a] -> [a]
: String -> String
safeTag String
cs
showInfoUsr :: ShowInfo
showInfoUsr :: ShowInfo
showInfoUsr String
t String
i = forall a. Int -> a -> [a]
replicate (Int
15 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t) Char
' ' forall a. [a] -> [a] -> [a]
++ String
t forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++
forall a. [a] -> [[a]] -> [a]
intercalate (Char
'\n' forall a. a -> [a] -> [a]
: forall a. Int -> a -> [a]
replicate Int
17 Char
' ') (String -> [String]
lines String
i) forall a. [a] -> [a] -> [a]
++ String
"\n"
type PutInfo = String -> String -> IO ()
putInfo :: ShowInfo -> PutInfo
putInfo :: ShowInfo -> PutInfo
putInfo ShowInfo
m String
t String
i = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
i) (String -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ ShowInfo
m String
t String
i)
actuallyShowRepo
:: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO ()
actuallyShowRepo :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO ()
actuallyShowRepo PutInfo
out Repository rt p wR wU wR
r [DarcsFlag]
opts = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DarcsFlag] -> Bool
hasXmlOutput [DarcsFlag]
opts) (String -> IO ()
putStr String
"<repository>\n")
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DarcsFlag] -> Bool
verbose [DarcsFlag]
opts) (PutInfo
out String
"Show" forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Repository rt p wR wU wR
r)
PutInfo
out String
"Format" forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
showInOneLine forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> RepoFormat
repoFormat Repository rt p wR wU wR
r
let loc :: String
loc = forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wR
r
PutInfo
out String
"Root" String
loc
PutInfo
out String
"PristineType" forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> PristineType
repoPristineType Repository rt p wR wU wR
r
PutInfo
out String
"Cache" forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
showInOneLine forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wR
r
Bool
piExists <- String -> IO Bool
doesPatchIndexExist String
loc
Bool
piDisabled <- String -> IO Bool
isPatchIndexDisabled String
loc
PutInfo
out String
"PatchIndex" forall a b. (a -> b) -> a -> b
$
case (Bool
piExists, Bool
piDisabled) of
(Bool
_, Bool
True) -> String
"disabled"
(Bool
True, Bool
False) -> String
"enabled"
(Bool
False, Bool
False) -> String
"enabled, but not yet created"
PutInfo -> IO ()
showRepoPrefs PutInfo
out
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DarcsFlag] -> Bool
enumeratePatches [DarcsFlag]
opts) (do forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Int
numPatches Repository rt p wR wU wR
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PutInfo
out String
"Num Patches" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
PutInfo -> Repository rt p wR wU wR -> IO ()
showXor PutInfo
out Repository rt p wR wU wR
r)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
PutInfo -> Repository rt p wR wU wR -> IO ()
showRepoMOTD PutInfo
out Repository rt p wR wU wR
r
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DarcsFlag] -> Bool
hasXmlOutput [DarcsFlag]
opts) (String -> IO ()
putStr String
"</repository>\n")
showXor :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> PutInfo -> Repository rt p wR wU wR -> IO ()
showXor :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
PutInfo -> Repository rt p wR wU wR -> IO ()
showXor PutInfo
out Repository rt p wR wU wR
repo = do
SHA1
theXor <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wR -> IO SHA1
repoXor Repository rt p wR wU wR
repo
PutInfo
out String
"Weak Hash" (forall a. Show a => a -> String
show SHA1
theXor)
showInOneLine :: Show a => a -> String
showInOneLine :: forall a. Show a => a -> String
showInOneLine = forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
showRepoPrefs :: PutInfo -> IO ()
showRepoPrefs :: PutInfo -> IO ()
showRepoPrefs PutInfo
out = do
String -> IO [String]
getPreflist String
"prefs" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
prefOut
String -> IO [String]
getPreflist String
"author" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PutInfo
out String
"Author" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
String -> IO [String]
getPreflist String
"defaultrepo" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PutInfo
out String
"Default Remote" forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
where prefOut :: String -> IO ()
prefOut = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PutInfo
out forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(String
p,String
v) -> (String
pforall a. [a] -> [a] -> [a]
++String
" Pref", forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
v)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace
showRepoMOTD :: PutInfo -> Repository rt p wR wU wR -> IO ()
showRepoMOTD :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
PutInfo -> Repository rt p wR wU wR -> IO ()
showRepoMOTD PutInfo
out Repository rt p wR wU wR
repo = String -> IO ByteString
getMotd (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wR
repo) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PutInfo
out String
"MOTD" forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BC.unpack
numPatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO Int
numPatches :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Int
numPatches Repository rt p wR wU wR
r = (forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL) forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
r