slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: commands, an explicit command to show the commands list; refactor

Browse Source
This commit is contained in:
Simon Michael 2025-03-05 10:26:28 -10:00
parent 25edf03495
commit 34ba84ff9c
8 changed files with 195 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
hledger/Hledger/Cli.hs
View File

@ -108,7 +108,6 @@ import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Explicit as CmdArgsWithoutName hiding (Name)
import System.Environment
import System.Exit
import System.FilePath
import System.Process
import Text.Megaparsec (optional, takeWhile1P, eof)
import Text.Megaparsec.Char (char)
@ -225,7 +224,7 @@ main = withGhcDebug' $ do
usecolor <- useColorOnStdout
when usecolor setupPager
-- Search PATH for addon commands. Exclude any that match builtin command names.
addons <- hledgerAddons <&> filter (not . (`elem` builtinCommandNames) . dropExtension)
addons <- addonCommandNames
---------------------------------------------------------------
dbgIO "\n1. Preliminary command line parsing" ()
@ -366,6 +365,15 @@ main = withGhcDebug' $ do
infoFlag = boolopt "info" rawopts
manFlag = boolopt "man" rawopts
versionFlag = boolopt "version" rawopts
-- ignoredopts cmd = error' $ cmd ++ " tried to read options but is not supposed to"
ignoredjournal cmd = error' $ cmd ++ " tried to read the journal but is not supposed to"
-- validate opts/args more and convert to CliOpts
opts <- rawOptsToCliOpts rawopts >>= \opts0 -> return opts0{progstarttime_=starttime}
dbgIO2 "processed opts" opts
dbgIO "period from opts" (period_ . _rsReportOpts $ reportspec_ opts)
dbgIO "interval from opts" (interval_ . _rsReportOpts $ reportspec_ opts)
dbgIO "query from opts & args" (_rsQuery $ reportspec_ opts)
-- Ensure that anything calling getArgs later will see all args, including config file args.
-- Some things (--color, --debug, some checks in journalFinalise) are detected by unsafePerformIO,
@ -386,32 +394,26 @@ main = withGhcDebug' $ do
| badcmdprovided -> error' $ "command "++clicmdarg++" is not recognized, run with no command to see a list"
-- 6.4. no command found, nothing else to do - show the commands list
| nocmdprovided -> dbgIO1 "no command, showing commands list" () >> printCommandsList prognameandversion addons
| nocmdprovided -> do
dbgIO1 "no command, showing commands list" ()
commands opts (ignoredjournal "commands")
-- 6.5. builtin command found
| Just (cmdmode, cmdaction) <- mbuiltincmdaction -> do
let mmodecmdname = headMay $ modeNames cmdmode
dbgIO1 "running builtin command mode" $ fromMaybe "" mmodecmdname
-- validate opts/args more and convert to CliOpts
opts <- rawOptsToCliOpts rawopts >>= \opts0 -> return opts0{progstarttime_=starttime}
dbgIO2 "processed opts" opts
dbgIO "period from opts" (period_ . _rsReportOpts $ reportspec_ opts)
dbgIO "interval from opts" (interval_ . _rsReportOpts $ reportspec_ opts)
dbgIO "query from opts & args" (_rsQuery $ reportspec_ opts)
let tldrpagename = maybe "hledger" (("hledger-"<>)) mmodecmdname
-- run the builtin command according to its type
if
-- 6.5.1. help/doc flag - show command help/docs
| helpFlag -> runPager $ showModeUsage cmdmode ++ "\n"
| tldrFlag -> runTldrForPage tldrpagename
| tldrFlag -> runTldrForPage $ maybe "hledger" (("hledger-"<>)) mmodecmdname
| infoFlag -> runInfoForTopic "hledger" mmodecmdname
| manFlag -> runManForTopic "hledger" mmodecmdname
-- 6.5.2. builtin command which should not require or read the journal - run it
| cmdname `elem` ["demo","help","test"] ->
cmdaction opts $ error' $ cmdname++" tried to read the journal but is not supposed to"
cmdaction opts (ignoredjournal cmdname)
-- 6.5.3. builtin command which should create the journal if missing - do that and run it
| cmdname `elem` ["add","import"] -> do

80
hledger/Hledger/Cli/CliOptions.hs
View File

@ -49,7 +49,6 @@ module Hledger.Cli.CliOptions (
showModeUsage,
withAliases,
likelyExecutablesInPath,
hledgerExecutablesInPath,
-- * CLI options
CliOpts(..),
@ -78,7 +77,6 @@ module Hledger.Cli.CliOptions (
registerWidthsFromOpts,
-- * Other utils
hledgerAddons,
topicForMode,
-- -- * Convenience re-exports
@ -91,8 +89,7 @@ import qualified Control.Exception as C
import Control.Monad (when)
import Data.Char
import Data.Default
import Data.Either (isRight)
import Data.List.Extra (groupSortOn, intercalate, isInfixOf, nubSort)
import Data.List.Extra (intercalate, isInfixOf, nubSort)
import qualified Data.List.NonEmpty as NE (NonEmpty, fromList, nonEmpty)
import Data.List.Split (splitOn)
import Data.Maybe
@ -783,48 +780,6 @@ registerWidthsFromOpts CliOpts{width_=Just s} =
-- Other utils
-- | Get the sorted unique canonical names of hledger addon commands
-- found in the current user's PATH. These are used in command line
-- parsing and to display the commands list.
--
-- Canonical addon names are the filenames of hledger-* executables in
-- PATH, without the "hledger-" prefix, and without the file extension
-- except when it's needed for disambiguation (see below).
--
-- When there are exactly two versions of an executable (same base
-- name, different extensions) that look like a source and compiled
-- pair (one has .exe, .com, or no extension), the source version will
-- be excluded (even if it happens to be newer). When there are three
-- or more versions (or two versions that don't look like a
-- source/compiled pair), they are all included, with file extensions
-- intact.
--
hledgerAddons :: IO [String]
hledgerAddons = do
-- past bug generator
as1 <- hledgerExecutablesInPath -- ["hledger-check","hledger-check-dates","hledger-check-dates.hs","hledger-check.hs","hledger-check.py"]
let as2 = map stripPrognamePrefix as1 -- ["check","check-dates","check-dates.hs","check.hs","check.py"]
let as3 = groupSortOn takeBaseName as2 -- [["check","check.hs","check.py"],["check-dates","check-dates.hs"]]
let as4 = concatMap dropRedundantSourceVersion as3 -- ["check","check.hs","check.py","check-dates"]
return as4
stripPrognamePrefix = drop (length progname + 1)
dropRedundantSourceVersion [f,g]
| map toLower (takeExtension f) `elem` compiledExts = [f]
| map toLower (takeExtension g) `elem` compiledExts = [g]
dropRedundantSourceVersion fs = fs
compiledExts = ["",".com",".exe"]
-- | Get the sorted unique filenames of all hledger-* executables in
-- the current user's PATH. These are files in any of the PATH directories,
-- named hledger-*, with either no extension (and no periods in the name)
-- or one of the addonExtensions.
-- We do not currently filter out non-file objects or files without execute permission.
hledgerExecutablesInPath :: IO [String]
hledgerExecutablesInPath = filter isHledgerExeName <$> likelyExecutablesInPath
-- None of https://hackage.haskell.org/package/directory-1.3.8.1/docs/System-Directory.html#g:5
-- do quite what we need (find all the executables in PATH with a filename prefix).
-- | Get all sorted unique filenames in the current user's PATH.
@ -845,39 +800,6 @@ likelyExecutablesInPath = do
-- return exes''
-- where isExecutable f = getPermissions f >>= (return . executable)
isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
where
hledgerexenamep = do
_ <- string $ T.pack progname
_ <- char '-'
_ <- some $ noneOf ['.']
optional (string "." >> choice' (map (string . T.pack) addonExtensions))
eof
-- stripAddonExtension :: String -> String
-- stripAddonExtension = regexReplace re "" where re = "\\.(" ++ intercalate "|" addonExtensions ++ ")$"
addonExtensions :: [String]
addonExtensions =
["bat"
,"com"
,"exe"
,"hs"
,"js"
,"lhs"
,"lua"
,"php"
,"pl"
,"py"
,"rb"
,"rkt"
,"sh"
,"osh"
,"ysh"
-- ,""
]
getEnvSafe :: String -> IO String
getEnvSafe v = getEnv v `C.catch` (\(_::C.IOException) -> return "") -- XXX should catch only isDoesNotExistError e

204
hledger/Hledger/Cli/Commands.hs
View File

@ -15,11 +15,13 @@ the export list, the import list, builtinCommands, commandsList.
{-# LANGUAGE TemplateHaskell #-}
module Hledger.Cli.Commands (
testcmd
commands
,testcmd
,builtinCommands
,builtinCommandNames
,addonCommandNames
,knownAddonCommandNames
,findBuiltinCommand
,knownAddonCommands
,knownCommands
,printCommandsList
,tests_Hledger_Cli
@ -52,17 +54,21 @@ module Hledger.Cli.Commands (
)
where
import Data.Char (isAlphaNum, isSpace)
import Data.Char (isAlphaNum, isSpace, toLower)
import Data.Either (isRight)
import Data.List
import Data.List.Extra (nubSort)
import Data.List.Extra (groupSortOn, nubSort)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar
import Safe (headErr)
import String.ANSI
import System.Environment (withArgs)
import System.Console.CmdArgs.Explicit as C
import System.Environment (withArgs)
import System.FilePath (dropExtension, takeBaseName, takeExtension)
import Test.Tasty (defaultMain)
import Text.Megaparsec
import Text.Megaparsec.Char
import Hledger
import Hledger.Cli.CliOptions
@ -96,6 +102,7 @@ import Hledger.Cli.Commands.Run
import Hledger.Cli.Commands.Stats
import Hledger.Cli.Commands.Tags
import Hledger.Cli.Utils (tests_Cli_Utils)
import Data.Functor ((<&>))
-- | The cmdargs subcommand mode (for command-line parsing)
-- and IO action (for doing the command's work) for each builtin command.
@ -113,6 +120,7 @@ builtinCommands = [
,(checkmode , check)
,(closemode , close)
,(codesmode , codes)
,(commandsmode , commands)
,(commoditiesmode , commodities)
,(demomode , demo)
,(descriptionsmode , descriptions)
@ -191,7 +199,7 @@ accent
--
commandsList :: String -> [String] -> [String]
commandsList progversion othercmds =
map (bold'.accent) _banner_smslant ++
map (bold'.accent) _banner_smslant ++ -- XXX not showing bold, why ?
[
-- Keep the following synced with:
-- commands.m4
@ -202,17 +210,18 @@ commandsList progversion othercmds =
"-------------------------------------------------------------------------------"
,progversion
,"Usage: hledger COMMAND [OPTIONS] [-- ADDONOPTIONS]"
,"Commands (builtins + addons):"
-- ,"Commands (builtins + addons):" -- XXX adapt for commands --builtin
,"Commands:"
,""
-----------------------------------------80-------------------------------------
,bold' "HELP (docs, demos..)"
," (no arguments) show this commands list"
," -h [COMMAND] show command line help"
," --tldr [COMMAND] show command examples with tldr"
," --info [COMMAND] show the hledger manual with info"
," --man [COMMAND] show the hledger manual with man"
," help [-i|-m|-p] [TOPIC] show any topic in the hledger manual"
," commands show the commands list (default)"
," demo [DEMO] show brief demos in the terminal"
," help [-i|-m|-p] [TOPIC] show the hledger manual with info/man/pager"
," --tldr [COMMAND] show command examples [for command] with tldr"
," --help/-h [COMMAND] show command line help [for command]"
," --info [COMMAND] show the hledger manual [for command] with info"
," --man [COMMAND] show the hledger manual [for command] with man"
," more help: https://hledger.org"
,""
-----------------------------------------80-------------------------------------
@ -301,53 +310,156 @@ commandsListExtractCommands addonsonly l =
, not $ "https://" `isInfixOf` line
, let cmdname:_ = words line
]
-- KEEP SYNCED WITH commandsList.
-- Keep synced with commandsList.
commandsmode =
hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Commands.txt")
[flagNone ["builtin"] (setboolopt "builtin") "show only builtin commands, not addons"
]
[(helpflagstitle, helpflags)]
[]
-- flagReq ["debug"] (\s opts -> Right $ setopt "debug" s opts) "[N]" "show debug output (levels 1-9, default: 1)"
([], Nothing)
-- | Display the commands list.
commands :: CliOpts -> Journal -> IO ()
commands opts _ = do
addons <- if boolopt "builtin" (rawopts_ opts) then return [] else addonCommandNames
printCommandsList prognameandversion addons
{- | Print the commands list, with a pager if appropriate, customising the
commandsList template above with the given version string and the installed addons.
Uninstalled known addons will be removed from the list,
installed known addons will have the + prefix removed,
and installed unknown addons will be added under Misc.
-}
printCommandsList :: String -> [String] -> IO ()
printCommandsList progversion installedaddons =
seq (length $ dbg8 "uninstalledknownaddons" uninstalledknownaddons) $ -- for debug output
seq (length $ dbg8 "installedknownaddons" installedknownaddons) $
seq (length $ dbg8 "installedunknownaddons" installedunknownaddons) $
runPager $
unlines $
map unplus $
filter (not . isuninstalledaddon) $
commandsList progversion installedunknownaddons
where
knownaddons = knownAddonCommandNames
uninstalledknownaddons = knownaddons \\ installedaddons
installedknownaddons = knownaddons `intersect` installedaddons
installedunknownaddons = installedaddons \\ knownaddons
unplus ('+' : cs) = ' ' : cs
unplus s = s
isuninstalledaddon =
\case
('+' : l)
| cmd `notElem` installedaddons ->
dbg9With (const $ "hiding uninstalled addon: " <> cmd) $
True
where
cmd = takeWhile (not . isSpace) l
_ -> False
-- | Canonical names of all commands which have a slot in the commands list, in alphabetical order.
-- These include the builtin commands and the known addon commands.
knownCommands :: [String]
knownCommands = nubSort . commandsListExtractCommands False $ commandsList progname []
-- | Canonical names of the known addon commands which have a slot in the commands list,
-- in alphabetical order.
knownAddonCommands :: [String]
knownAddonCommands = nubSort . commandsListExtractCommands True $ commandsList progname []
-- | All names and aliases of the builtin commands.
builtinCommandNames :: [String]
builtinCommandNames = concatMap (modeNames . fst) builtinCommands
-- | Look up a builtin command's mode and action by exact command name or alias.
-- | Look up a builtin command's mode and action by exact command name or alias.
findBuiltinCommand :: String -> Maybe (Mode RawOpts, CliOpts -> Journal -> IO ())
findBuiltinCommand cmdname = find (elem cmdname . modeNames . fst) builtinCommands
-- | Print the commands list, with a pager if appropriate, customising the
-- commandsList template above with the given version string and the installed addons.
-- Uninstalled known addons will be removed from the list,
-- installed known addons will have the + prefix removed,
-- and installed unknown addons will be added under Misc.
printCommandsList :: String -> [String] -> IO ()
printCommandsList progversion installedaddons =
seq (length $ dbg8 "uninstalledknownaddons" uninstalledknownaddons) $ -- for debug output
seq (length $ dbg8 "installedknownaddons" installedknownaddons) $
seq (length $ dbg8 "installedunknownaddons" installedunknownaddons) $
runPager $ unlines $ map unplus $ filter (not.isuninstalledaddon) $
commandsList progversion installedunknownaddons
where
knownaddons = knownAddonCommands
uninstalledknownaddons = knownaddons \\ installedaddons
installedknownaddons = knownaddons `intersect` installedaddons
installedunknownaddons = installedaddons \\ knownaddons
unplus ('+':cs) = ' ':cs
unplus s = s
isuninstalledaddon =
\case
('+':l) | cmd `notElem` installedaddons ->
dbg9With (const $ "hiding uninstalled addon: "<>cmd) $
True where cmd = takeWhile (not . isSpace) l
_ -> False
{- | Canonical names of the known addon commands which have a slot in the commands list,
in alphabetical order.
-}
knownAddonCommandNames :: [String]
knownAddonCommandNames = nubSort . commandsListExtractCommands True $ commandsList progname []
-- The test command is defined here for easy access to other modules' tests.
-- Search PATH for names of addon commands, that aren't shadowed by builtin commands.
addonCommandNames :: IO [String]
addonCommandNames = installedAddonCommandNames <&> filter (not . (`elem` builtinCommandNames) . dropExtension)
-- | Get the sorted unique canonical names of hledger addon commands
-- found in the current user's PATH. These are used in command line
-- parsing and to display the commands list.
--
-- Canonical addon names are the filenames of hledger-* executables in
-- PATH, without the "hledger-" prefix, and without the file extension
-- except when it's needed for disambiguation (see below).
--
-- When there are exactly two versions of an executable (same base
-- name, different extensions) that look like a source and compiled
-- pair (one has .exe, .com, or no extension), the source version will
-- be excluded (even if it happens to be newer). When there are three
-- or more versions (or two versions that don't look like a
-- source/compiled pair), they are all included, with file extensions
-- intact.
--
installedAddonCommandNames :: IO [String]
installedAddonCommandNames = do
-- past bug generator
as1 <- hledgerExecutablesInPath -- ["hledger-check","hledger-check-dates","hledger-check-dates.hs","hledger-check.hs","hledger-check.py"]
let as2 = map stripPrognamePrefix as1 -- ["check","check-dates","check-dates.hs","check.hs","check.py"]
let as3 = groupSortOn takeBaseName as2 -- [["check","check.hs","check.py"],["check-dates","check-dates.hs"]]
let as4 = concatMap dropRedundantSourceVersion as3 -- ["check","check.hs","check.py","check-dates"]
return as4
stripPrognamePrefix = drop (length progname + 1)
dropRedundantSourceVersion [f,g]
| map toLower (takeExtension f) `elem` compiledExts = [f]
| map toLower (takeExtension g) `elem` compiledExts = [g]
dropRedundantSourceVersion fs = fs
compiledExts = ["",".com",".exe"]
-- | Get the sorted unique filenames of all hledger-* executables in
-- the current user's PATH. These are files in any of the PATH directories,
-- named hledger-*, with either no extension (and no periods in the name)
-- or one of the addonExtensions.
-- We do not currently filter out non-file objects or files without execute permission.
hledgerExecutablesInPath :: IO [String]
hledgerExecutablesInPath = filter isHledgerExeName <$> likelyExecutablesInPath
isHledgerExeName :: String -> Bool
isHledgerExeName = isRight . parsewith hledgerexenamep . T.pack
where
hledgerexenamep = do
_ <- string $ T.pack progname
_ <- char '-'
_ <- some $ noneOf ['.']
optional (string "." >> choice' (map (string . T.pack) addonExtensions))
eof
-- stripAddonExtension :: String -> String
-- stripAddonExtension = regexReplace re "" where re = "\\.(" ++ intercalate "|" addonExtensions ++ ")$"
addonExtensions :: [String]
addonExtensions =
["bat"
,"com"
,"exe"
,"hs"
,"js"
,"lhs"
,"lua"
,"php"
,"pl"
,"py"
,"rb"
,"rkt"
,"sh"
,"osh"
,"ysh"
]
-- The test command is also defined here for easy access to other modules' tests.
testmode = hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Test.txt")

3
hledger/Hledger/Cli/Commands/Commands.md Normal file
View File

@ -0,0 +1,3 @@
## commands
Show the hledger commands list.

3
hledger/Hledger/Cli/Commands/Commands.txt Normal file
View File

@ -0,0 +1,3 @@
commands
Show the hledger commands list.

1
hledger/hledger.cabal
View File

@ -69,6 +69,7 @@ extra-source-files:
Hledger/Cli/Commands/Check.txt
Hledger/Cli/Commands/Close.txt
Hledger/Cli/Commands/Codes.txt
Hledger/Cli/Commands/Commands.txt
Hledger/Cli/Commands/Commodities.txt
Hledger/Cli/Commands/Demo.txt
Hledger/Cli/Commands/Descriptions.txt

1
hledger/package.yaml
View File

@ -68,6 +68,7 @@ extra-source-files:
- Hledger/Cli/Commands/Check.txt
- Hledger/Cli/Commands/Close.txt
- Hledger/Cli/Commands/Codes.txt
- Hledger/Cli/Commands/Commands.txt
- Hledger/Cli/Commands/Commodities.txt
- Hledger/Cli/Commands/Demo.txt
- Hledger/Cli/Commands/Descriptions.txt

13
hledger/test/commands.test Normal file
View File

@ -0,0 +1,13 @@
# * commands command
# ** 0. Print the commands list by default.
$ hledger
> /Commands:/
# ** 0. Print the commands list with the commands command specified.
#$ hledger commands
#> /Commands /
# ** 0. Print the commands list showing only builtin commands.
$ hledger commands --builtin
> /Commands:$/