--  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 (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
 String
"The `darcs show repo` command displays statistics about the current\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"repository, allowing third-party scripts to access this information\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"without inspecting `_darcs` directly (and without breaking when the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"`_darcs` format changes).\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"The 'Weak Hash' identifies the set of patches of a repository independently\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"of ordering. It can be used to easily compare two repositories of a same\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"project. It is not cryptographically secure.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"By default, output includes statistics that require walking through the patches\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"recorded in the repository, namely the 'Weak Hash' and the count of patches.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"If this data isn't needed, use `--no-enum-patches` to accelerate this command\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"from O(n) to O(1).\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"By default, output is in a human-readable format.  The `--xml-output`\n" String -> String -> String
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 :: 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
"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 = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> XmlOutput -> EnumPatches -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String -> XmlOutput -> EnumPatches -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> XmlOutput -> EnumPatches -> a)
showRepoBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> XmlOutput
   -> EnumPatches
   -> 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]
  (Maybe String
   -> XmlOutput
   -> EnumPatches
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> XmlOutput
   -> EnumPatches
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showRepoOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> XmlOutput
   -> EnumPatches
   -> 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
  (Maybe String
   -> XmlOutput
   -> EnumPatches
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
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 = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (XmlOutput -> EnumPatches -> a)
  (Maybe String)
PrimDarcsOption (Maybe String)
O.repoDir PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (XmlOutput -> EnumPatches -> a)
  (Maybe String)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (EnumPatches -> a)
     (XmlOutput -> EnumPatches -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (EnumPatches -> a)
     (Maybe String -> XmlOutput -> EnumPatches -> 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
  (EnumPatches -> a)
  (XmlOutput -> EnumPatches -> a)
PrimDarcsOption XmlOutput
O.xmlOutput OptSpec
  DarcsOptDescr
  DarcsFlag
  (EnumPatches -> a)
  (Maybe String -> XmlOutput -> EnumPatches -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (EnumPatches -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String -> XmlOutput -> EnumPatches -> 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 (EnumPatches -> a)
PrimDarcsOption EnumPatches
O.enumPatches
    showRepoOpts :: DarcsOption
  a
  (Maybe String
   -> XmlOutput
   -> EnumPatches
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showRepoOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> XmlOutput
   -> EnumPatches
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String -> XmlOutput -> EnumPatches -> a)
showRepoBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String
   -> XmlOutput
   -> EnumPatches
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe String
      -> XmlOutput
      -> EnumPatches
      -> 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

repoCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
repoCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
repoCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
  let put_mode :: String -> String -> String
put_mode = if [DarcsFlag] -> Bool
hasXmlOutput [DarcsFlag]
opts then String -> String -> String
showInfoXML else String -> String -> String
showInfoUsr
  in 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
repository ->
       PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO ()
actuallyShowRepo ((String -> String -> String) -> PutInfo
putInfo String -> String -> String
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 :: String -> String -> String
showInfoXML String
t String
i = Html -> String
forall a. Show a => a -> String
show (Html -> String) -> Html -> String
forall a b. (a -> b) -> a -> b
$ String -> Html -> Html
tag (String -> String
safeTag String
t) (Html -> Html) -> Html -> Html
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_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
safeTag String
cs
safeTag (Char
c:String
cs) = Char -> Char
toLower Char
c Char -> String -> String
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 :: String -> String -> String
showInfoUsr String
t String
i = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
15 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate (Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
17 Char
' ') (String -> [String]
lines String
i) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

type PutInfo = String -> String -> IO ()
putInfo :: ShowInfo -> PutInfo
putInfo :: (String -> String -> String) -> PutInfo
putInfo String -> String -> String
m String
t String
i = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
i) (String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
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 :: PutInfo -> Repository rt p wR wU wR -> [DarcsFlag] -> IO ()
actuallyShowRepo PutInfo
out Repository rt p wR wU wR
r [DarcsFlag]
opts = do
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DarcsFlag] -> Bool
hasXmlOutput [DarcsFlag]
opts) (String -> IO ()
putStr String
"<repository>\n")
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DarcsFlag] -> Bool
verbose [DarcsFlag]
opts) (PutInfo
out String
"Show" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wR -> String
forall a. Show a => a -> String
show Repository rt p wR wU wR
r)
  PutInfo
out String
"Format" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ RepoFormat -> String
forall a. Show a => a -> String
showInOneLine (RepoFormat -> String) -> RepoFormat -> String
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wR -> RepoFormat
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 = Repository rt p wR wU wR -> String
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" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ PristineType -> String
forall a. Show a => a -> String
show (PristineType -> String) -> PristineType -> String
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wR -> PristineType
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" (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Cache -> String
forall a. Show a => a -> String
showInOneLine (Cache -> String) -> Cache -> String
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wR -> Cache
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" (String -> IO ()) -> String -> IO ()
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([DarcsFlag] -> Bool
enumeratePatches [DarcsFlag]
opts) (do Repository rt p wR wU wR -> IO Int
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 IO Int -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (PutInfo
out String
"Num Patches" (String -> IO ()) -> (Int -> String) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show)
                                   PutInfo -> Repository rt p wR wU wR -> IO ()
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)
  PutInfo -> Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
PutInfo -> Repository rt p wR wU wR -> IO ()
showRepoMOTD PutInfo
out Repository rt p wR wU wR
r
  Bool -> IO () -> IO ()
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 :: PutInfo -> Repository rt p wR wU wR -> IO ()
showXor PutInfo
out Repository rt p wR wU wR
repo = do
  SHA1
theXor <- Repository rt p wR wU wR -> IO SHA1
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" (SHA1 -> String
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 :: a -> String
showInOneLine = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> (a -> [String]) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (a -> String) -> a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

showRepoPrefs :: PutInfo -> IO ()
showRepoPrefs :: PutInfo -> IO ()
showRepoPrefs PutInfo
out = do
    String -> IO [String]
getPreflist String
"prefs" IO [String] -> ([String] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO ()) -> [String] -> IO ()
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" IO [String] -> ([String] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PutInfo
out String
"Author" (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
    String -> IO [String]
getPreflist String
"defaultrepo" IO [String] -> ([String] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PutInfo
out String
"Default Remote" (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
  where prefOut :: String -> IO ()
prefOut = PutInfo -> (String, String) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PutInfo
out ((String, String) -> IO ())
-> (String -> (String, String)) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(String
p,String
v) -> (String
pString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" Pref", (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
v)) ((String, String) -> (String, String))
-> (String -> (String, String)) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace

showRepoMOTD :: PutInfo -> Repository rt p wR wU wR -> IO ()
showRepoMOTD :: PutInfo -> Repository rt p wR wU wR -> IO ()
showRepoMOTD PutInfo
out Repository rt p wR wU wR
repo = String -> IO ByteString
getMotd (Repository rt p wR wU wR -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wR
repo) IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PutInfo
out String
"MOTD" (String -> IO ()) -> (ByteString -> String) -> ByteString -> IO ()
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 :: Repository rt p wR wU wR -> IO Int
numPatches Repository rt p wR wU wR
r = (RL (PatchInfoAnd rt p) Origin wR -> Int
forall (a :: * -> * -> *) wX wZ. RL a wX wZ -> Int
lengthRL (RL (PatchInfoAnd rt p) Origin wR -> Int)
-> (PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR)
-> PatchSet rt p Origin wR
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL) (PatchSet rt p Origin wR -> Int)
-> IO (PatchSet rt p Origin wR) -> IO Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
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