--  Copyright (C) 2007 Kevin Quick
--
--  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.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

-- Some convenience functions to output a labelled text string or an
-- XML tag + value (same API).  If no value, output is suppressed
-- entirely.  Borrow some help from Text.Html to perform XML output.

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

-- labelled strings: labels are right-aligned at 15 characters;
-- subsequent lines in multi-line output are indented accordingly.
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)

-- Primary show-repo operation.  Determines ordering of output for
-- sub-displays.  The `out' argument is one of the above operations to
-- output a labelled text string or an XML tag and contained value.

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)

-- Most of the actual elements being displayed are part of the Show
-- class; that's fine for a Haskeller, but not for the common user, so
-- the routines below work to provide more human-readable information
-- regarding the repository elements.

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

-- Support routines to provide information used by the PutInfo operations above.

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