more indentation. must stop.
This commit is contained in:
Joey Hess
parent
def5b4cc64
commit
ec0bac9d73
5 changed files with 183 additions and 185 deletions
80
Assistant.hs
80
Assistant.hs
|
|
@ -173,58 +173,58 @@ startDaemon assistant foreground webappwaiter
|
|||
logfd <- liftIO . openLog =<< fromRepo gitAnnexLogFile
|
||||
pidfile <- fromRepo gitAnnexPidFile
|
||||
go $ Utility.Daemon.daemonize logfd (Just pidfile) False
|
||||
where
|
||||
go d = startAssistant assistant d webappwaiter
|
||||
where
|
||||
go d = startAssistant assistant d webappwaiter
|
||||
|
||||
startAssistant :: Bool -> (IO () -> IO ()) -> Maybe (String -> FilePath -> IO ()) -> Annex ()
|
||||
startAssistant assistant daemonize webappwaiter = withThreadState $ \st -> do
|
||||
checkCanWatch
|
||||
dstatus <- startDaemonStatus
|
||||
liftIO $ daemonize $ run dstatus st
|
||||
where
|
||||
run dstatus st = do
|
||||
changechan <- newChangeChan
|
||||
commitchan <- newCommitChan
|
||||
pushmap <- newFailedPushMap
|
||||
transferqueue <- newTransferQueue
|
||||
transferslots <- newTransferSlots
|
||||
scanremotes <- newScanRemoteMap
|
||||
branchhandle <- newBranchChangeHandle
|
||||
pushnotifier <- newPushNotifier
|
||||
where
|
||||
run dstatus st = do
|
||||
changechan <- newChangeChan
|
||||
commitchan <- newCommitChan
|
||||
pushmap <- newFailedPushMap
|
||||
transferqueue <- newTransferQueue
|
||||
transferslots <- newTransferSlots
|
||||
scanremotes <- newScanRemoteMap
|
||||
branchhandle <- newBranchChangeHandle
|
||||
pushnotifier <- newPushNotifier
|
||||
#ifdef WITH_WEBAPP
|
||||
urlrenderer <- newUrlRenderer
|
||||
urlrenderer <- newUrlRenderer
|
||||
#endif
|
||||
mapM_ (startthread dstatus)
|
||||
[ watch $ commitThread st changechan commitchan transferqueue dstatus
|
||||
mapM_ (startthread dstatus)
|
||||
[ watch $ commitThread st changechan commitchan transferqueue dstatus
|
||||
#ifdef WITH_WEBAPP
|
||||
, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer Nothing webappwaiter
|
||||
, assist $ webAppThread (Just st) dstatus scanremotes transferqueue transferslots pushnotifier commitchan urlrenderer Nothing webappwaiter
|
||||
#ifdef WITH_PAIRING
|
||||
, assist $ pairListenerThread st dstatus scanremotes urlrenderer
|
||||
, assist $ pairListenerThread st dstatus scanremotes urlrenderer
|
||||
#endif
|
||||
#endif
|
||||
, assist $ pushThread st dstatus commitchan pushmap pushnotifier
|
||||
, assist $ pushRetryThread st dstatus pushmap pushnotifier
|
||||
, assist $ mergeThread st dstatus transferqueue branchhandle
|
||||
, assist $ transferWatcherThread st dstatus transferqueue
|
||||
, assist $ transferPollerThread st dstatus
|
||||
, assist $ transfererThread st dstatus transferqueue transferslots commitchan
|
||||
, assist $ daemonStatusThread st dstatus
|
||||
, assist $ sanityCheckerThread st dstatus transferqueue changechan
|
||||
, assist $ mountWatcherThread st dstatus scanremotes pushnotifier
|
||||
, assist $ netWatcherThread st dstatus scanremotes pushnotifier
|
||||
, assist $ netWatcherFallbackThread st dstatus scanremotes pushnotifier
|
||||
, assist $ transferScannerThread st dstatus scanremotes transferqueue
|
||||
, assist $ configMonitorThread st dstatus branchhandle commitchan
|
||||
, assist $ pushThread st dstatus commitchan pushmap pushnotifier
|
||||
, assist $ pushRetryThread st dstatus pushmap pushnotifier
|
||||
, assist $ mergeThread st dstatus transferqueue branchhandle
|
||||
, assist $ transferWatcherThread st dstatus transferqueue
|
||||
, assist $ transferPollerThread st dstatus
|
||||
, assist $ transfererThread st dstatus transferqueue transferslots commitchan
|
||||
, assist $ daemonStatusThread st dstatus
|
||||
, assist $ sanityCheckerThread st dstatus transferqueue changechan
|
||||
, assist $ mountWatcherThread st dstatus scanremotes pushnotifier
|
||||
, assist $ netWatcherThread st dstatus scanremotes pushnotifier
|
||||
, assist $ netWatcherFallbackThread st dstatus scanremotes pushnotifier
|
||||
, assist $ transferScannerThread st dstatus scanremotes transferqueue
|
||||
, assist $ configMonitorThread st dstatus branchhandle commitchan
|
||||
#ifdef WITH_XMPP
|
||||
, assist $ pushNotifierThread st dstatus pushnotifier
|
||||
, assist $ pushNotifierThread st dstatus pushnotifier
|
||||
#endif
|
||||
, watch $ watchThread st dstatus transferqueue changechan
|
||||
]
|
||||
waitForTermination
|
||||
, watch $ watchThread st dstatus transferqueue changechan
|
||||
]
|
||||
waitForTermination
|
||||
|
||||
watch a = (True, a)
|
||||
assist a = (False, a)
|
||||
startthread dstatus (watcher, t)
|
||||
| watcher || assistant = void $ forkIO $
|
||||
runNamedThread dstatus t
|
||||
| otherwise = noop
|
||||
watch a = (True, a)
|
||||
assist a = (False, a)
|
||||
startthread dstatus (watcher, t)
|
||||
| watcher || assistant = void $ forkIO $
|
||||
runNamedThread dstatus t
|
||||
| otherwise = noop
|
||||
|
|
|
|||
70
Backend.hs
70
Backend.hs
|
|
@ -40,16 +40,16 @@ orderedList = do
|
|||
if not $ null l
|
||||
then return l
|
||||
else handle =<< Annex.getState Annex.forcebackend
|
||||
where
|
||||
handle Nothing = standard
|
||||
handle (Just "") = standard
|
||||
handle (Just name) = do
|
||||
l' <- (lookupBackendName name :) <$> standard
|
||||
Annex.changeState $ \s -> s { Annex.backends = l' }
|
||||
return l'
|
||||
standard = parseBackendList <$> getConfig (annexConfig "backends") ""
|
||||
parseBackendList [] = list
|
||||
parseBackendList s = map lookupBackendName $ words s
|
||||
where
|
||||
handle Nothing = standard
|
||||
handle (Just "") = standard
|
||||
handle (Just name) = do
|
||||
l' <- (lookupBackendName name :) <$> standard
|
||||
Annex.changeState $ \s -> s { Annex.backends = l' }
|
||||
return l'
|
||||
standard = parseBackendList <$> getConfig (annexConfig "backends") ""
|
||||
parseBackendList [] = list
|
||||
parseBackendList s = map lookupBackendName $ words s
|
||||
|
||||
{- Generates a key for a file, trying each backend in turn until one
|
||||
- accepts it.
|
||||
|
|
@ -66,12 +66,12 @@ genKey' (b:bs) source = do
|
|||
case r of
|
||||
Nothing -> genKey' bs source
|
||||
Just k -> return $ Just (makesane k, b)
|
||||
where
|
||||
-- keyNames should not contain newline characters.
|
||||
makesane k = k { keyName = map fixbadchar (keyName k) }
|
||||
fixbadchar c
|
||||
| c == '\n' = '_'
|
||||
| otherwise = c
|
||||
where
|
||||
-- keyNames should not contain newline characters.
|
||||
makesane k = k { keyName = map fixbadchar (keyName k) }
|
||||
fixbadchar c
|
||||
| c == '\n' = '_'
|
||||
| otherwise = c
|
||||
|
||||
{- Looks up the key and backend corresponding to an annexed file,
|
||||
- by examining what the file symlinks to. -}
|
||||
|
|
@ -81,35 +81,33 @@ lookupFile file = do
|
|||
case tl of
|
||||
Left _ -> return Nothing
|
||||
Right l -> makekey l
|
||||
where
|
||||
makekey l = maybe (return Nothing) (makeret l) (fileKey $ takeFileName l)
|
||||
makeret l k = let bname = keyBackendName k in
|
||||
case maybeLookupBackendName bname of
|
||||
Just backend -> do
|
||||
return $ Just (k, backend)
|
||||
Nothing -> do
|
||||
when (isLinkToAnnex l) $ warning $
|
||||
"skipping " ++ file ++
|
||||
" (unknown backend " ++
|
||||
bname ++ ")"
|
||||
return Nothing
|
||||
where
|
||||
makekey l = maybe (return Nothing) (makeret l) (fileKey $ takeFileName l)
|
||||
makeret l k = let bname = keyBackendName k in
|
||||
case maybeLookupBackendName bname of
|
||||
Just backend -> do
|
||||
return $ Just (k, backend)
|
||||
Nothing -> do
|
||||
when (isLinkToAnnex l) $ warning $
|
||||
"skipping " ++ file ++
|
||||
" (unknown backend " ++ bname ++ ")"
|
||||
return Nothing
|
||||
|
||||
{- Looks up the backend that should be used for a file.
|
||||
- That can be configured on a per-file basis in the gitattributes file.
|
||||
-}
|
||||
chooseBackend :: FilePath -> Annex (Maybe Backend)
|
||||
chooseBackend f = Annex.getState Annex.forcebackend >>= go
|
||||
where
|
||||
go Nothing = maybeLookupBackendName <$>
|
||||
checkAttr "annex.backend" f
|
||||
go (Just _) = Just . Prelude.head <$> orderedList
|
||||
where
|
||||
go Nothing = maybeLookupBackendName <$> checkAttr "annex.backend" f
|
||||
go (Just _) = Just . Prelude.head <$> orderedList
|
||||
|
||||
{- Looks up a backend by name. May fail if unknown. -}
|
||||
lookupBackendName :: String -> Backend
|
||||
lookupBackendName s = fromMaybe unknown $ maybeLookupBackendName s
|
||||
where
|
||||
unknown = error $ "unknown backend " ++ s
|
||||
where
|
||||
unknown = error $ "unknown backend " ++ s
|
||||
maybeLookupBackendName :: String -> Maybe Backend
|
||||
maybeLookupBackendName s = headMaybe matches
|
||||
where
|
||||
matches = filter (\b -> s == B.name b) list
|
||||
where
|
||||
matches = filter (\b -> s == B.name b) list
|
||||
|
|
|
|||
104
Limit.hs
104
Limit.hs
|
|
@ -54,9 +54,9 @@ getMatcher' = do
|
|||
{- Adds something to the limit list, which is built up reversed. -}
|
||||
add :: Utility.Matcher.Token (Annex.FileInfo -> Annex Bool) -> Annex ()
|
||||
add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s }
|
||||
where
|
||||
prepend (Left ls) = Left $ l:ls
|
||||
prepend _ = error "internal"
|
||||
where
|
||||
prepend (Left ls) = Left $ l:ls
|
||||
prepend _ = error "internal"
|
||||
|
||||
{- Adds a new token. -}
|
||||
addToken :: String -> Annex ()
|
||||
|
|
@ -83,9 +83,9 @@ limitExclude glob = Right $ const $ return . not . matchglob glob
|
|||
matchglob :: String -> Annex.FileInfo -> Bool
|
||||
matchglob glob (Annex.FileInfo { Annex.matchFile = f }) =
|
||||
isJust $ match cregex f []
|
||||
where
|
||||
cregex = compile regex []
|
||||
regex = '^':wildToRegex glob
|
||||
where
|
||||
cregex = compile regex []
|
||||
regex = '^':wildToRegex glob
|
||||
|
||||
{- Adds a limit to skip files not believed to be present
|
||||
- in a specfied repository. -}
|
||||
|
|
@ -97,21 +97,21 @@ limitIn name = Right $ \notpresent -> check $
|
|||
if name == "."
|
||||
then inhere notpresent
|
||||
else inremote notpresent
|
||||
where
|
||||
check a = lookupFile >=> handle a
|
||||
handle _ Nothing = return False
|
||||
handle a (Just (key, _)) = a key
|
||||
inremote notpresent key = do
|
||||
u <- Remote.nameToUUID name
|
||||
us <- Remote.keyLocations key
|
||||
return $ u `elem` us && u `S.notMember` notpresent
|
||||
inhere notpresent key
|
||||
| S.null notpresent = inAnnex key
|
||||
| otherwise = do
|
||||
u <- getUUID
|
||||
if u `S.member` notpresent
|
||||
then return False
|
||||
else inAnnex key
|
||||
where
|
||||
check a = lookupFile >=> handle a
|
||||
handle _ Nothing = return False
|
||||
handle a (Just (key, _)) = a key
|
||||
inremote notpresent key = do
|
||||
u <- Remote.nameToUUID name
|
||||
us <- Remote.keyLocations key
|
||||
return $ u `elem` us && u `S.notMember` notpresent
|
||||
inhere notpresent key
|
||||
| S.null notpresent = inAnnex key
|
||||
| otherwise = do
|
||||
u <- getUUID
|
||||
if u `S.member` notpresent
|
||||
then return False
|
||||
else inAnnex key
|
||||
|
||||
{- Limit to content that is currently present on a uuid. -}
|
||||
limitPresent :: Maybe UUID -> MkLimit
|
||||
|
|
@ -122,10 +122,10 @@ limitPresent u _ = Right $ const $ check $ \key -> do
|
|||
else do
|
||||
us <- Remote.keyLocations key
|
||||
return $ maybe False (`elem` us) u
|
||||
where
|
||||
check a = lookupFile >=> handle a
|
||||
handle _ Nothing = return False
|
||||
handle a (Just (key, _)) = a key
|
||||
where
|
||||
check a = lookupFile >=> handle a
|
||||
handle _ Nothing = return False
|
||||
handle a (Just (key, _)) = a key
|
||||
|
||||
{- Adds a limit to skip files not believed to have the specified number
|
||||
- of copies. -}
|
||||
|
|
@ -139,18 +139,18 @@ limitCopies want = case split ":" want of
|
|||
Nothing -> go n $ checkgroup v
|
||||
[n] -> go n $ const $ return True
|
||||
_ -> Left "bad value for copies"
|
||||
where
|
||||
go num good = case readish num of
|
||||
Nothing -> Left "bad number for copies"
|
||||
Just n -> Right $ \notpresent f ->
|
||||
lookupFile f >>= handle n good notpresent
|
||||
handle _ _ _ Nothing = return False
|
||||
handle n good notpresent (Just (key, _)) = do
|
||||
us <- filter (`S.notMember` notpresent)
|
||||
<$> (filterM good =<< Remote.keyLocations key)
|
||||
return $ length us >= n
|
||||
checktrust t u = (== t) <$> lookupTrust u
|
||||
checkgroup g u = S.member g <$> lookupGroups u
|
||||
where
|
||||
go num good = case readish num of
|
||||
Nothing -> Left "bad number for copies"
|
||||
Just n -> Right $ \notpresent f ->
|
||||
lookupFile f >>= handle n good notpresent
|
||||
handle _ _ _ Nothing = return False
|
||||
handle n good notpresent (Just (key, _)) = do
|
||||
us <- filter (`S.notMember` notpresent)
|
||||
<$> (filterM good =<< Remote.keyLocations key)
|
||||
return $ length us >= n
|
||||
checktrust t u = (== t) <$> lookupTrust u
|
||||
checkgroup g u = S.member g <$> lookupGroups u
|
||||
|
||||
{- Adds a limit to skip files not believed to be present in all
|
||||
- repositories in the specified group. -}
|
||||
|
|
@ -163,15 +163,15 @@ limitInAllGroup :: GroupMap -> MkLimit
|
|||
limitInAllGroup m groupname
|
||||
| S.null want = Right $ const $ const $ return True
|
||||
| otherwise = Right $ \notpresent -> lookupFile >=> check notpresent
|
||||
where
|
||||
want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m
|
||||
check _ Nothing = return False
|
||||
check notpresent (Just (key, _))
|
||||
-- optimisation: Check if a wanted uuid is notpresent.
|
||||
| not (S.null (S.intersection want notpresent)) = return False
|
||||
| otherwise = do
|
||||
present <- S.fromList <$> Remote.keyLocations key
|
||||
return $ S.null $ want `S.difference` present
|
||||
where
|
||||
want = fromMaybe S.empty $ M.lookup groupname $ uuidsByGroup m
|
||||
check _ Nothing = return False
|
||||
check notpresent (Just (key, _))
|
||||
-- optimisation: Check if a wanted uuid is notpresent.
|
||||
| not (S.null (S.intersection want notpresent)) = return False
|
||||
| otherwise = do
|
||||
present <- S.fromList <$> Remote.keyLocations key
|
||||
return $ S.null $ want `S.difference` present
|
||||
|
||||
{- Adds a limit to skip files not using a specified key-value backend. -}
|
||||
addInBackend :: String -> Annex ()
|
||||
|
|
@ -179,9 +179,9 @@ addInBackend = addLimit . limitInBackend
|
|||
|
||||
limitInBackend :: MkLimit
|
||||
limitInBackend name = Right $ const $ lookupFile >=> check
|
||||
where
|
||||
wanted = Backend.lookupBackendName name
|
||||
check = return . maybe False ((==) wanted . snd)
|
||||
where
|
||||
wanted = Backend.lookupBackendName name
|
||||
check = return . maybe False ((==) wanted . snd)
|
||||
|
||||
{- Adds a limit to skip files that are too large or too small -}
|
||||
addLargerThan :: String -> Annex ()
|
||||
|
|
@ -194,9 +194,9 @@ limitSize :: (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit
|
|||
limitSize vs s = case readSize dataUnits s of
|
||||
Nothing -> Left "bad size"
|
||||
Just sz -> Right $ const $ lookupFile >=> check sz
|
||||
where
|
||||
check _ Nothing = return False
|
||||
check sz (Just (key, _)) = return $ keySize key `vs` Just sz
|
||||
where
|
||||
check _ Nothing = return False
|
||||
check sz (Just (key, _)) = return $ keySize key `vs` Just sz
|
||||
|
||||
addTimeLimit :: String -> Annex ()
|
||||
addTimeLimit s = do
|
||||
|
|
|
|||
66
Messages.hs
66
Messages.hs
|
|
@ -65,29 +65,29 @@ showProgress = handle q $
|
|||
- The action is passed a callback to use to update the meter. -}
|
||||
metered :: (Maybe MeterUpdate) -> Key -> (MeterUpdate -> Annex a) -> Annex a
|
||||
metered combinemeterupdate key a = withOutputType $ go (keySize key)
|
||||
where
|
||||
go (Just size) NormalOutput = do
|
||||
progress <- liftIO $ newProgress "" size
|
||||
meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
|
||||
showOutput
|
||||
liftIO $ displayMeter stdout meter
|
||||
r <- a $ \n -> liftIO $ do
|
||||
incrP progress n
|
||||
displayMeter stdout meter
|
||||
maybe noop (\m -> m n) combinemeterupdate
|
||||
liftIO $ clearMeter stdout meter
|
||||
return r
|
||||
go _ _ = a (const noop)
|
||||
where
|
||||
go (Just size) NormalOutput = do
|
||||
progress <- liftIO $ newProgress "" size
|
||||
meter <- liftIO $ newMeter progress "B" 25 (renderNums binaryOpts 1)
|
||||
showOutput
|
||||
liftIO $ displayMeter stdout meter
|
||||
r <- a $ \n -> liftIO $ do
|
||||
incrP progress n
|
||||
displayMeter stdout meter
|
||||
maybe noop (\m -> m n) combinemeterupdate
|
||||
liftIO $ clearMeter stdout meter
|
||||
return r
|
||||
go _ _ = a (const noop)
|
||||
|
||||
showSideAction :: String -> Annex ()
|
||||
showSideAction m = Annex.getState Annex.output >>= go
|
||||
where
|
||||
go (MessageState v StartBlock) = do
|
||||
p
|
||||
Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock }
|
||||
go (MessageState _ InBlock) = return ()
|
||||
go _ = p
|
||||
p = handle q $ putStrLn $ "(" ++ m ++ "...)"
|
||||
where
|
||||
go (MessageState v StartBlock) = do
|
||||
p
|
||||
Annex.changeState $ \s -> s { Annex.output = MessageState v InBlock }
|
||||
go (MessageState _ InBlock) = return ()
|
||||
go _ = p
|
||||
p = handle q $ putStrLn $ "(" ++ m ++ "...)"
|
||||
|
||||
showStoringStateAction :: Annex ()
|
||||
showStoringStateAction = showSideAction "Recording state in git"
|
||||
|
|
@ -106,8 +106,8 @@ doSideAction' b a = do
|
|||
o <- Annex.getState Annex.output
|
||||
set $ o { sideActionBlock = b }
|
||||
set o `after` a
|
||||
where
|
||||
set o = Annex.changeState $ \s -> s { Annex.output = o }
|
||||
where
|
||||
set o = Annex.changeState $ \s -> s { Annex.output = o }
|
||||
|
||||
showOutput :: Annex ()
|
||||
showOutput = handle q $
|
||||
|
|
@ -125,10 +125,10 @@ showEndFail = showEndResult False
|
|||
|
||||
showEndResult :: Bool -> Annex ()
|
||||
showEndResult ok = handle (JSON.end ok) $ putStrLn msg
|
||||
where
|
||||
msg
|
||||
| ok = "ok"
|
||||
| otherwise = "failed"
|
||||
where
|
||||
msg
|
||||
| ok = "ok"
|
||||
| otherwise = "failed"
|
||||
|
||||
showErr :: (Show a) => a -> Annex ()
|
||||
showErr e = warning' $ "git-annex: " ++ show e
|
||||
|
|
@ -153,9 +153,9 @@ maybeShowJSON v = handle (JSON.add v) q
|
|||
{- Shows a complete JSON value, only when in json mode. -}
|
||||
showFullJSON :: JSON a => [(String, a)] -> Annex Bool
|
||||
showFullJSON v = withOutputType $ liftIO . go
|
||||
where
|
||||
go JSONOutput = JSON.complete v >> return True
|
||||
go _ = return False
|
||||
where
|
||||
go JSONOutput = JSON.complete v >> return True
|
||||
go _ = return False
|
||||
|
||||
{- Performs an action that outputs nonstandard/customized output, and
|
||||
- in JSON mode wraps its output in JSON.start and JSON.end, so it's
|
||||
|
|
@ -184,10 +184,10 @@ setupConsole = do
|
|||
|
||||
handle :: IO () -> IO () -> Annex ()
|
||||
handle json normal = withOutputType go
|
||||
where
|
||||
go NormalOutput = liftIO normal
|
||||
go QuietOutput = q
|
||||
go JSONOutput = liftIO $ flushed json
|
||||
where
|
||||
go NormalOutput = liftIO normal
|
||||
go QuietOutput = q
|
||||
go JSONOutput = liftIO $ flushed json
|
||||
|
||||
q :: Monad m => m ()
|
||||
q = noop
|
||||
|
|
|
|||
48
Usage.hs
48
Usage.hs
|
|
@ -23,30 +23,30 @@ usage header cmds commonoptions = unlines $
|
|||
, "Commands:"
|
||||
, ""
|
||||
] ++ cmdlines
|
||||
where
|
||||
-- To get consistent indentation of options, generate the
|
||||
-- usage for all options at once. A command's options will
|
||||
-- be displayed after the command.
|
||||
alloptlines = filter (not . null) $
|
||||
lines $ usageInfo "" $
|
||||
concatMap cmdoptions scmds ++ commonoptions
|
||||
(cmdlines, optlines) = go scmds alloptlines []
|
||||
go [] os ls = (ls, os)
|
||||
go (c:cs) os ls = go cs os' (ls++(l:o))
|
||||
where
|
||||
(o, os') = splitAt (length $ cmdoptions c) os
|
||||
l = concat
|
||||
[ cmdname c
|
||||
, namepad (cmdname c)
|
||||
, cmdparamdesc c
|
||||
, descpad (cmdparamdesc c)
|
||||
, cmddesc c
|
||||
]
|
||||
pad n s = replicate (n - length s) ' '
|
||||
namepad = pad $ longest cmdname + 1
|
||||
descpad = pad $ longest cmdparamdesc + 2
|
||||
longest f = foldl max 0 $ map (length . f) cmds
|
||||
scmds = sort cmds
|
||||
where
|
||||
-- To get consistent indentation of options, generate the
|
||||
-- usage for all options at once. A command's options will
|
||||
-- be displayed after the command.
|
||||
alloptlines = filter (not . null) $
|
||||
lines $ usageInfo "" $
|
||||
concatMap cmdoptions scmds ++ commonoptions
|
||||
(cmdlines, optlines) = go scmds alloptlines []
|
||||
go [] os ls = (ls, os)
|
||||
go (c:cs) os ls = go cs os' (ls++(l:o))
|
||||
where
|
||||
(o, os') = splitAt (length $ cmdoptions c) os
|
||||
l = concat
|
||||
[ cmdname c
|
||||
, namepad (cmdname c)
|
||||
, cmdparamdesc c
|
||||
, descpad (cmdparamdesc c)
|
||||
, cmddesc c
|
||||
]
|
||||
pad n s = replicate (n - length s) ' '
|
||||
namepad = pad $ longest cmdname + 1
|
||||
descpad = pad $ longest cmdparamdesc + 2
|
||||
longest f = foldl max 0 $ map (length . f) cmds
|
||||
scmds = sort cmds
|
||||
|
||||
{- Descriptions of params used in usage messages. -}
|
||||
paramPaths :: String
|
||||
|
|
|
|||
Loading…
Reference in a new issue