mirror of
https://github.com/simonmichael/hledger.git
synced 2024-12-25 19:31:44 +03:00
dev:cli: merge Hledger.Cli.Main with Hledger.Cli
This commit is contained in:
Simon Michael
parent
37bb9a03be
commit
0e98f73e30
4
Makefile
4
Makefile
@ -408,11 +408,11 @@ ghcid-shake: $(call def-help,ghcid-shake, start ghcid autobuilder on Shake.hs)
|
|||||||
|
|
||||||
# multi-package GHCI prompts
|
# multi-package GHCI prompts
|
||||||
ghci: $(call def-help,ghci, start ghci REPL on hledger-lib + hledger)
|
ghci: $(call def-help,ghci, start ghci REPL on hledger-lib + hledger)
|
||||||
$(STACKGHCI) exec -- $(GHCI) $(BUILDFLAGS) hledger/Hledger/Cli/Main.hs
|
$(STACKGHCI) exec -- $(GHCI) $(BUILDFLAGS) hledger/Hledger/Cli.hs
|
||||||
|
|
||||||
ghci-prof: $(call def-help,ghci-prof, start ghci REPL on hledger-lib + hledger with profiling/call stack information)
|
ghci-prof: $(call def-help,ghci-prof, start ghci REPL on hledger-lib + hledger with profiling/call stack information)
|
||||||
stack build --profile hledger --only-dependencies
|
stack build --profile hledger --only-dependencies
|
||||||
$(STACKGHCI) exec -- $(GHCI) $(BUILDFLAGS) -fexternal-interpreter -prof -fprof-auto hledger/Hledger/Cli/Main.hs
|
$(STACKGHCI) exec -- $(GHCI) $(BUILDFLAGS) -fexternal-interpreter -prof -fprof-auto hledger/Hledger/Cli.hs
|
||||||
|
|
||||||
ghci-dev: $(call def-help,ghci-dev, start ghci REPL on hledger-lib + hledger + dev.hs script)
|
ghci-dev: $(call def-help,ghci-dev, start ghci REPL on hledger-lib + hledger + dev.hs script)
|
||||||
$(STACKGHCI) exec -- $(GHCI) $(BUILDFLAGS) -fno-warn-unused-imports -fno-warn-unused-binds dev.hs
|
$(STACKGHCI) exec -- $(GHCI) $(BUILDFLAGS) -fno-warn-unused-imports -fno-warn-unused-binds dev.hs
|
||||||
|
|||||||
@ -27,7 +27,7 @@ import Safe
|
|||||||
import System.Environment
|
import System.Environment
|
||||||
import Hledger
|
import Hledger
|
||||||
import Hledger.Cli
|
import Hledger.Cli
|
||||||
import Hledger.Cli.Main (argsToCliOpts)
|
import Hledger.Cli (argsToCliOpts)
|
||||||
|
|
||||||
-- XXX needs --help, see hledger-addon-example.hs
|
-- XXX needs --help, see hledger-addon-example.hs
|
||||||
|
|
||||||
|
|||||||
@ -1,26 +1,108 @@
|
|||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||||
|
{-# HLINT ignore "Unused LANGUAGE pragma" #-}
|
||||||
|
|
||||||
{-|
|
{-|
|
||||||
|
|
||||||
Hledger.Cli re-exports the options, utilities and commands provided by
|
This is the root module of the @hledger@ package,
|
||||||
the hledger command-line program. This module also aggregates the
|
providing hledger's command-line interface.
|
||||||
built-in unit tests defined throughout hledger and hledger-lib, and
|
The main function,
|
||||||
adds some more which are easier to define here.
|
commands,
|
||||||
|
command-line options,
|
||||||
|
and utilities useful to other hledger command-line programs
|
||||||
|
are exported.
|
||||||
|
It also re-exports hledger-lib:Hledger
|
||||||
|
and cmdargs:System.Concole.CmdArgs.Explicit
|
||||||
|
|
||||||
|
See also:
|
||||||
|
|
||||||
|
- [hledger-lib:Hledger]("Hledger")
|
||||||
|
- [hledger:Hledger.Cli]("Hledger.Cli")
|
||||||
|
- [hledger-ui:Hledger.UI]("Hledger.UI")
|
||||||
|
- [hledger-web:Hledger.Web]("Hledger.Web")
|
||||||
|
- [The README files](https://github.com/search?q=repo%3Asimonmichael%2Fhledger+path%3A**%2FREADME*&type=code&ref=advsearch)
|
||||||
|
- [The high-level developer docs](https://hledger.org/dev.html)
|
||||||
|
|
||||||
|
== About
|
||||||
|
|
||||||
|
hledger - a fast, reliable, user-friendly plain text accounting tool.
|
||||||
|
Copyright (c) 2007-2023 Simon Michael <simon@joyful.com> and contributors
|
||||||
|
Released under GPL version 3 or later.
|
||||||
|
|
||||||
|
hledger is a Haskell rewrite of John Wiegley's "ledger".
|
||||||
|
It generates financial reports from a plain text general journal.
|
||||||
|
You can use the command line:
|
||||||
|
|
||||||
|
> $ hledger
|
||||||
|
|
||||||
|
or ghci:
|
||||||
|
|
||||||
|
> $ make ghci
|
||||||
|
> ghci> Right j <- runExceptT $ readJournalFile definputopts "examples/sample.journal" -- or: j <- defaultJournal
|
||||||
|
> ghci> :t j
|
||||||
|
> j :: Journal
|
||||||
|
> ghci> stats defcliopts j
|
||||||
|
> Main file : examples/sample.journal
|
||||||
|
> Included files :
|
||||||
|
> Transactions span : 2008-01-01 to 2009-01-01 (366 days)
|
||||||
|
> Last transaction : 2008-12-31 (733772 days from now)
|
||||||
|
> Transactions : 5 (0.0 per day)
|
||||||
|
> Transactions last 30 days: 0 (0.0 per day)
|
||||||
|
> Transactions last 7 days : 0 (0.0 per day)
|
||||||
|
> Payees/descriptions : 5
|
||||||
|
> Accounts : 8 (depth 3)
|
||||||
|
> Commodities : 1 ($)
|
||||||
|
> Market prices : 0 ()
|
||||||
|
>
|
||||||
|
> Run time (throughput) : 1695276900.00s (0 txns/s)
|
||||||
|
> ghci> balance defcliopts j
|
||||||
|
> $1 assets:bank:saving
|
||||||
|
> $-2 assets:cash
|
||||||
|
> $1 expenses:food
|
||||||
|
> $1 expenses:supplies
|
||||||
|
> $-1 income:gifts
|
||||||
|
> $-1 income:salary
|
||||||
|
> $1 liabilities:debts
|
||||||
|
> --------------------
|
||||||
|
> 0
|
||||||
|
> ghci>
|
||||||
|
|
||||||
|
etc.
|
||||||
|
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Hledger.Cli (
|
module Hledger.Cli (
|
||||||
|
prognameandversion,
|
||||||
|
versionString,
|
||||||
|
main,
|
||||||
|
mainmode,
|
||||||
|
argsToCliOpts,
|
||||||
|
-- * Re-exports
|
||||||
module Hledger.Cli.CliOptions,
|
module Hledger.Cli.CliOptions,
|
||||||
module Hledger.Cli.Commands,
|
module Hledger.Cli.Commands,
|
||||||
module Hledger.Cli.DocFiles,
|
module Hledger.Cli.DocFiles,
|
||||||
module Hledger.Cli.Utils,
|
module Hledger.Cli.Utils,
|
||||||
module Hledger.Cli.Version,
|
module Hledger.Cli.Version,
|
||||||
module Hledger,
|
module Hledger,
|
||||||
|
-- ** System.Console.CmdArgs.Explicit
|
||||||
module System.Console.CmdArgs.Explicit,
|
module System.Console.CmdArgs.Explicit,
|
||||||
prognameandversion,
|
|
||||||
versionString
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Control.Monad (when)
|
||||||
|
import Data.List
|
||||||
|
import Safe
|
||||||
|
import qualified System.Console.CmdArgs.Explicit as C
|
||||||
|
import System.Environment
|
||||||
|
import System.Exit
|
||||||
|
import System.FilePath
|
||||||
|
import System.Process
|
||||||
|
import Text.Printf
|
||||||
|
|
||||||
|
import Data.Time.Clock.POSIX (getPOSIXTime)
|
||||||
|
|
||||||
|
|
||||||
import GitHash (tGitInfoCwdTry)
|
import GitHash (tGitInfoCwdTry)
|
||||||
import System.Console.CmdArgs.Explicit hiding (Name) -- don't clash with hledger-ui
|
import System.Console.CmdArgs.Explicit hiding (Name) -- don't clash with hledger-ui
|
||||||
|
|
||||||
@ -31,6 +113,7 @@ import Hledger.Cli.DocFiles
|
|||||||
import Hledger.Cli.Utils
|
import Hledger.Cli.Utils
|
||||||
import Hledger.Cli.Version
|
import Hledger.Cli.Version
|
||||||
|
|
||||||
|
|
||||||
-- | The program name and version string for this build of the hledger tool,
|
-- | The program name and version string for this build of the hledger tool,
|
||||||
-- including any git info available at build time.
|
-- including any git info available at build time.
|
||||||
prognameandversion :: String
|
prognameandversion :: String
|
||||||
@ -48,4 +131,226 @@ prognameandversion = versionString progname packageversion
|
|||||||
versionString :: ProgramName -> PackageVersion -> String
|
versionString :: ProgramName -> PackageVersion -> String
|
||||||
versionString = versionStringWith $$tGitInfoCwdTry
|
versionString = versionStringWith $$tGitInfoCwdTry
|
||||||
|
|
||||||
|
|
||||||
|
-- | The overall cmdargs mode describing hledger's command-line options and subcommands.
|
||||||
|
mainmode addons = defMode {
|
||||||
|
modeNames = [progname ++ " [CMD]"]
|
||||||
|
,modeArgs = ([], Just $ argsFlag "[ARGS]")
|
||||||
|
,modeHelp = unlines ["hledger's main command line interface. Runs builtin commands and other hledger executables. Type \"hledger\" to list available commands."]
|
||||||
|
,modeGroupModes = Group {
|
||||||
|
-- subcommands in the unnamed group, shown first:
|
||||||
|
groupUnnamed = [
|
||||||
|
]
|
||||||
|
-- subcommands in named groups:
|
||||||
|
,groupNamed = [
|
||||||
|
]
|
||||||
|
-- subcommands handled but not shown in the help:
|
||||||
|
,groupHidden = map fst builtinCommands ++ map addonCommandMode addons
|
||||||
|
}
|
||||||
|
,modeGroupFlags = Group {
|
||||||
|
-- flags in named groups:
|
||||||
|
groupNamed = [
|
||||||
|
( "General input flags", inputflags)
|
||||||
|
,("\nGeneral reporting flags", reportflags)
|
||||||
|
,("\nGeneral help flags", helpflags)
|
||||||
|
]
|
||||||
|
-- flags in the unnamed group, shown last:
|
||||||
|
,groupUnnamed = []
|
||||||
|
-- flags handled but not shown in the help:
|
||||||
|
,groupHidden =
|
||||||
|
[detailedversionflag]
|
||||||
|
-- ++ inputflags -- included here so they'll not raise a confusing error if present with no COMMAND
|
||||||
|
}
|
||||||
|
,modeHelpSuffix = "Examples:" :
|
||||||
|
map (progname ++) [
|
||||||
|
" list commands"
|
||||||
|
," CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)"
|
||||||
|
,"-CMD [OPTS] [ARGS] or run addon commands directly"
|
||||||
|
," -h show general usage"
|
||||||
|
," CMD -h show command usage"
|
||||||
|
," help [MANUAL] show any of the hledger manuals in various formats"
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
|
-- | Let's go!
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
starttime <- getPOSIXTime
|
||||||
|
-- try to encourage user's $PAGER to properly display ANSI
|
||||||
|
when useColorOnStdout setupPager
|
||||||
|
|
||||||
|
-- Choose and run the appropriate internal or external command based
|
||||||
|
-- on the raw command-line arguments, cmdarg's interpretation of
|
||||||
|
-- same, and hledger-* executables in the user's PATH. A somewhat
|
||||||
|
-- complex mishmash of cmdargs and custom processing, hence all the
|
||||||
|
-- debugging support and tests. See also Hledger.Cli.CliOptions and
|
||||||
|
-- command-line.test.
|
||||||
|
|
||||||
|
-- some preliminary (imperfect) argument parsing to supplement cmdargs
|
||||||
|
args <- getArgs >>= expandArgsAt
|
||||||
|
let
|
||||||
|
args' = moveFlagsAfterCommand $ replaceNumericFlags args
|
||||||
|
isFlag = ("-" `isPrefixOf`)
|
||||||
|
isNonEmptyNonFlag s = not (isFlag s) && not (null s)
|
||||||
|
rawcmd = headDef "" $ takeWhile isNonEmptyNonFlag args'
|
||||||
|
isNullCommand = null rawcmd
|
||||||
|
(argsbeforecmd, argsaftercmd') = break (==rawcmd) args
|
||||||
|
argsaftercmd = drop 1 argsaftercmd'
|
||||||
|
dbgIO :: Show a => String -> a -> IO ()
|
||||||
|
dbgIO = ptraceAtIO 8
|
||||||
|
|
||||||
|
dbgIO "running" prognameandversion
|
||||||
|
dbgIO "raw args" args
|
||||||
|
dbgIO "raw args rearranged for cmdargs" args'
|
||||||
|
dbgIO "raw command is probably" rawcmd
|
||||||
|
dbgIO "raw args before command" argsbeforecmd
|
||||||
|
dbgIO "raw args after command" argsaftercmd
|
||||||
|
|
||||||
|
-- Search PATH for add-ons, excluding any that match built-in command names
|
||||||
|
addons' <- hledgerAddons
|
||||||
|
let addons = filter (not . (`elem` builtinCommandNames) . dropExtension) addons'
|
||||||
|
|
||||||
|
-- parse arguments with cmdargs
|
||||||
|
opts' <- argsToCliOpts args addons
|
||||||
|
let opts = opts'{progstarttime_=starttime}
|
||||||
|
|
||||||
|
-- select an action and run it.
|
||||||
|
let
|
||||||
|
cmd = command_ opts -- the full matched internal or external command name, if any
|
||||||
|
isInternalCommand = cmd `elem` builtinCommandNames -- not (null cmd) && not (cmd `elem` addons)
|
||||||
|
isExternalCommand = not (null cmd) && cmd `elem` addons -- probably
|
||||||
|
isBadCommand = not (null rawcmd) && null cmd
|
||||||
|
hasVersion = ("--version" `elem`)
|
||||||
|
printUsage = pager $ showModeUsage $ mainmode addons
|
||||||
|
badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure -- PARTIAL:
|
||||||
|
hasHelpFlag args1 = any (`elem` args1) ["-h","--help"]
|
||||||
|
hasManFlag args1 = (`elem` args1) "--man"
|
||||||
|
hasInfoFlag args1 = (`elem` args1) "--info"
|
||||||
|
f `orShowHelp` mode1
|
||||||
|
| hasHelpFlag args = pager $ showModeUsage mode1
|
||||||
|
| hasInfoFlag args = runInfoForTopic "hledger" (headMay $ modeNames mode1)
|
||||||
|
| hasManFlag args = runManForTopic "hledger" (headMay $ modeNames mode1)
|
||||||
|
| otherwise = f
|
||||||
|
-- where
|
||||||
|
-- lastdocflag
|
||||||
|
dbgIO "processed opts" opts
|
||||||
|
dbgIO "command matched" cmd
|
||||||
|
dbgIO "isNullCommand" isNullCommand
|
||||||
|
dbgIO "isInternalCommand" isInternalCommand
|
||||||
|
dbgIO "isExternalCommand" isExternalCommand
|
||||||
|
dbgIO "isBadCommand" isBadCommand
|
||||||
|
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
|
||||||
|
journallesserror = error $ cmd++" tried to read the journal but is not supposed to"
|
||||||
|
runHledgerCommand
|
||||||
|
-- high priority flags and situations. -h, then --help, then --info are highest priority.
|
||||||
|
| isNullCommand && hasHelpFlag args = dbgIO "" "-h/--help with no command, showing general help" >> printUsage
|
||||||
|
| isNullCommand && hasInfoFlag args = dbgIO "" "--info with no command, showing general info manual" >> runInfoForTopic "hledger" Nothing
|
||||||
|
| isNullCommand && hasManFlag args = dbgIO "" "--man with no command, showing general man page" >> runManForTopic "hledger" Nothing
|
||||||
|
| not (isExternalCommand || hasHelpFlag args || hasInfoFlag args || hasManFlag args)
|
||||||
|
&& (hasVersion args) -- || (hasVersion argsaftercmd && isInternalCommand))
|
||||||
|
= putStrLn prognameandversion
|
||||||
|
-- \| (null externalcmd) && boolopt "binary-filename" rawopts = putStrLn $ binaryfilename progname
|
||||||
|
-- \| "--browse-args" `elem` args = System.Console.CmdArgs.Helper.execute "cmdargs-browser" mainmode' args >>= (putStr . show)
|
||||||
|
| isNullCommand = dbgIO "" "no command, showing commands list" >> printCommandsList prognameandversion addons
|
||||||
|
| isBadCommand = badCommandError
|
||||||
|
|
||||||
|
-- builtin commands
|
||||||
|
| Just (cmdmode, cmdaction) <- findBuiltinCommand cmd =
|
||||||
|
(case True of
|
||||||
|
-- these commands should not require or read the journal
|
||||||
|
_ | cmd `elem` ["demo","help","test"] -> cmdaction opts journallesserror
|
||||||
|
-- these commands should create the journal if missing
|
||||||
|
_ | cmd `elem` ["add","import"] -> do
|
||||||
|
ensureJournalFileExists . head =<< journalFilePathFromOpts opts
|
||||||
|
withJournalDo opts (cmdaction opts)
|
||||||
|
-- other commands read the journal and should fail if it's missing
|
||||||
|
_ -> withJournalDo opts (cmdaction opts)
|
||||||
|
)
|
||||||
|
`orShowHelp` cmdmode
|
||||||
|
|
||||||
|
-- addon commands
|
||||||
|
| isExternalCommand = do
|
||||||
|
let externalargs = argsbeforecmd ++ filter (/="--") argsaftercmd
|
||||||
|
let shellcmd = printf "%s-%s %s" progname cmd (unwords' externalargs) :: String
|
||||||
|
dbgIO "external command selected" cmd
|
||||||
|
dbgIO "external command arguments" (map quoteIfNeeded externalargs)
|
||||||
|
dbgIO "running shell command" shellcmd
|
||||||
|
system shellcmd >>= exitWith
|
||||||
|
|
||||||
|
-- deprecated commands
|
||||||
|
-- cmd == "convert" = error' (modeHelp oldconvertmode) >> exitFailure
|
||||||
|
|
||||||
|
-- shouldn't reach here
|
||||||
|
| otherwise = usageError ("could not understand the arguments "++show args) >> exitFailure
|
||||||
|
|
||||||
|
runHledgerCommand
|
||||||
|
|
||||||
|
-- | Parse hledger CLI options from these command line arguments and
|
||||||
|
-- add-on command names, or raise any error.
|
||||||
|
argsToCliOpts :: [String] -> [String] -> IO CliOpts
|
||||||
|
argsToCliOpts args addons = do
|
||||||
|
let
|
||||||
|
args' = moveFlagsAfterCommand $ replaceNumericFlags args
|
||||||
|
cmdargsopts = either usageError id $ C.process (mainmode addons) args'
|
||||||
|
rawOptsToCliOpts cmdargsopts
|
||||||
|
|
||||||
|
-- | A hacky workaround for cmdargs not accepting flags before the
|
||||||
|
-- subcommand name: try to detect and move such flags after the
|
||||||
|
-- command. This allows the user to put them in either position.
|
||||||
|
-- The order of options is not preserved, but that should be ok.
|
||||||
|
--
|
||||||
|
-- Since we're not parsing flags as precisely as cmdargs here, this is
|
||||||
|
-- imperfect. We make a decent effort to:
|
||||||
|
-- - move all no-argument help/input/report flags
|
||||||
|
-- - move all required-argument help/input/report flags along with their values, space-separated or not
|
||||||
|
-- - ensure --debug has an argument (because.. "or this all goes to hell")
|
||||||
|
-- - not confuse things further or cause misleading errors.
|
||||||
|
moveFlagsAfterCommand :: [String] -> [String]
|
||||||
|
moveFlagsAfterCommand args = moveArgs $ ensureDebugHasArg args
|
||||||
|
where
|
||||||
|
moveArgs args1 = insertFlagsAfterCommand $ moveArgs' (args1, [])
|
||||||
|
where
|
||||||
|
-- -f FILE ..., --alias ALIAS ...
|
||||||
|
moveArgs' ((f:v:a:as), flags) | isMovableReqArgFlag f, isValue v = moveArgs' (a:as, flags ++ [f,v])
|
||||||
|
-- -fFILE ..., --alias=ALIAS ...
|
||||||
|
moveArgs' ((fv:a:as), flags) | isMovableArgFlagAndValue fv = moveArgs' (a:as, flags ++ [fv])
|
||||||
|
-- -f(missing arg)
|
||||||
|
moveArgs' ((f:a:as), flags) | isMovableReqArgFlag f, not (isValue a) = moveArgs' (a:as, flags ++ [f])
|
||||||
|
-- -h ..., --version ...
|
||||||
|
moveArgs' ((f:a:as), flags) | isMovableNoArgFlag f = moveArgs' (a:as, flags ++ [f])
|
||||||
|
-- anything else
|
||||||
|
moveArgs' (as, flags) = (as, flags)
|
||||||
|
|
||||||
|
insertFlagsAfterCommand ([], flags) = flags
|
||||||
|
insertFlagsAfterCommand (command1:args2, flags) = [command1] ++ flags ++ args2
|
||||||
|
|
||||||
|
isMovableNoArgFlag a = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` optargflagstomove ++ noargflagstomove
|
||||||
|
|
||||||
|
isMovableReqArgFlag a = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` reqargflagstomove
|
||||||
|
|
||||||
|
isMovableArgFlagAndValue ('-':'-':a:as) = case break (== '=') (a:as) of
|
||||||
|
(f:fs,_:_) -> (f:fs) `elem` optargflagstomove ++ reqargflagstomove
|
||||||
|
_ -> False
|
||||||
|
isMovableArgFlagAndValue ('-':shortflag:_:_) = [shortflag] `elem` reqargflagstomove
|
||||||
|
isMovableArgFlagAndValue _ = False
|
||||||
|
|
||||||
|
isValue "-" = True
|
||||||
|
isValue ('-':_) = False
|
||||||
|
isValue _ = True
|
||||||
|
|
||||||
|
flagstomove = inputflags ++ reportflags ++ helpflags
|
||||||
|
noargflagstomove = concatMap flagNames $ filter ((==FlagNone).flagInfo) flagstomove
|
||||||
|
reqargflagstomove = -- filter (/= "debug") $
|
||||||
|
concatMap flagNames $ filter ((==FlagReq ).flagInfo) flagstomove
|
||||||
|
optargflagstomove = concatMap flagNames $ filter (isFlagOpt .flagInfo) flagstomove
|
||||||
|
where
|
||||||
|
isFlagOpt = \case
|
||||||
|
FlagOpt _ -> True
|
||||||
|
FlagOptRare _ -> True
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
|
||||||
-- unit tests (tests_Hledger_Cli) are defined in Hledger.Cli.Commands
|
-- unit tests (tests_Hledger_Cli) are defined in Hledger.Cli.Commands
|
||||||
|
|||||||
@ -1,275 +0,0 @@
|
|||||||
{-|
|
|
||||||
hledger - a ledger-compatible accounting tool.
|
|
||||||
Copyright (c) 2007-2022 Simon Michael <simon@joyful.com>
|
|
||||||
Released under GPL version 3 or later.
|
|
||||||
|
|
||||||
hledger is a partial haskell clone of John Wiegley's "ledger". It
|
|
||||||
generates ledger-compatible register & balance reports from a plain text
|
|
||||||
journal, and demonstrates a functional implementation of ledger.
|
|
||||||
For more information, see http:\/\/hledger.org .
|
|
||||||
|
|
||||||
This module provides the main function for the hledger command-line
|
|
||||||
executable. It is exposed here so that it can be imported by eg benchmark
|
|
||||||
scripts.
|
|
||||||
|
|
||||||
You can use the command line:
|
|
||||||
|
|
||||||
> $ hledger --help
|
|
||||||
|
|
||||||
or ghci:
|
|
||||||
|
|
||||||
> $ ghci hledger
|
|
||||||
> > Right j <- readJournalFile definputopts "examples/sample.journal"
|
|
||||||
> > register [] ["income","expenses"] j
|
|
||||||
> 2008/01/01 income income:salary $-1 $-1
|
|
||||||
> 2008/06/01 gift income:gifts $-1 $-2
|
|
||||||
> 2008/06/03 eat & shop expenses:food $1 $-1
|
|
||||||
> expenses:supplies $1 0
|
|
||||||
> > balance [Depth "1"] [] l
|
|
||||||
> $-1 assets
|
|
||||||
> $2 expenses
|
|
||||||
> $-2 income
|
|
||||||
> $1 liabilities
|
|
||||||
> > j <- defaultJournal
|
|
||||||
|
|
||||||
etc.
|
|
||||||
|
|
||||||
-}
|
|
||||||
|
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
|
|
||||||
module Hledger.Cli.Main where
|
|
||||||
|
|
||||||
import Control.Monad (when)
|
|
||||||
import Data.List
|
|
||||||
import Safe
|
|
||||||
import qualified System.Console.CmdArgs.Explicit as C
|
|
||||||
import System.Environment
|
|
||||||
import System.Exit
|
|
||||||
import System.FilePath
|
|
||||||
import System.Process
|
|
||||||
import Text.Printf
|
|
||||||
|
|
||||||
import Hledger.Cli
|
|
||||||
import Data.Time.Clock.POSIX (getPOSIXTime)
|
|
||||||
|
|
||||||
|
|
||||||
-- | The overall cmdargs mode describing hledger's command-line options and subcommands.
|
|
||||||
mainmode addons = defMode {
|
|
||||||
modeNames = [progname ++ " [CMD]"]
|
|
||||||
,modeArgs = ([], Just $ argsFlag "[ARGS]")
|
|
||||||
,modeHelp = unlines ["hledger's main command line interface. Runs builtin commands and other hledger executables. Type \"hledger\" to list available commands."]
|
|
||||||
,modeGroupModes = Group {
|
|
||||||
-- subcommands in the unnamed group, shown first:
|
|
||||||
groupUnnamed = [
|
|
||||||
]
|
|
||||||
-- subcommands in named groups:
|
|
||||||
,groupNamed = [
|
|
||||||
]
|
|
||||||
-- subcommands handled but not shown in the help:
|
|
||||||
,groupHidden = map fst builtinCommands ++ map addonCommandMode addons
|
|
||||||
}
|
|
||||||
,modeGroupFlags = Group {
|
|
||||||
-- flags in named groups:
|
|
||||||
groupNamed = [
|
|
||||||
( "General input flags", inputflags)
|
|
||||||
,("\nGeneral reporting flags", reportflags)
|
|
||||||
,("\nGeneral help flags", helpflags)
|
|
||||||
]
|
|
||||||
-- flags in the unnamed group, shown last:
|
|
||||||
,groupUnnamed = []
|
|
||||||
-- flags handled but not shown in the help:
|
|
||||||
,groupHidden =
|
|
||||||
[detailedversionflag]
|
|
||||||
-- ++ inputflags -- included here so they'll not raise a confusing error if present with no COMMAND
|
|
||||||
}
|
|
||||||
,modeHelpSuffix = "Examples:" :
|
|
||||||
map (progname ++) [
|
|
||||||
" list commands"
|
|
||||||
," CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)"
|
|
||||||
,"-CMD [OPTS] [ARGS] or run addon commands directly"
|
|
||||||
," -h show general usage"
|
|
||||||
," CMD -h show command usage"
|
|
||||||
," help [MANUAL] show any of the hledger manuals in various formats"
|
|
||||||
]
|
|
||||||
}
|
|
||||||
|
|
||||||
-- | Let's go!
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
starttime <- getPOSIXTime
|
|
||||||
-- try to encourage user's $PAGER to properly display ANSI
|
|
||||||
when useColorOnStdout setupPager
|
|
||||||
|
|
||||||
-- Choose and run the appropriate internal or external command based
|
|
||||||
-- on the raw command-line arguments, cmdarg's interpretation of
|
|
||||||
-- same, and hledger-* executables in the user's PATH. A somewhat
|
|
||||||
-- complex mishmash of cmdargs and custom processing, hence all the
|
|
||||||
-- debugging support and tests. See also Hledger.Cli.CliOptions and
|
|
||||||
-- command-line.test.
|
|
||||||
|
|
||||||
-- some preliminary (imperfect) argument parsing to supplement cmdargs
|
|
||||||
args <- getArgs >>= expandArgsAt
|
|
||||||
let
|
|
||||||
args' = moveFlagsAfterCommand $ replaceNumericFlags args
|
|
||||||
isFlag = ("-" `isPrefixOf`)
|
|
||||||
isNonEmptyNonFlag s = not (isFlag s) && not (null s)
|
|
||||||
rawcmd = headDef "" $ takeWhile isNonEmptyNonFlag args'
|
|
||||||
isNullCommand = null rawcmd
|
|
||||||
(argsbeforecmd, argsaftercmd') = break (==rawcmd) args
|
|
||||||
argsaftercmd = drop 1 argsaftercmd'
|
|
||||||
dbgIO :: Show a => String -> a -> IO ()
|
|
||||||
dbgIO = ptraceAtIO 8
|
|
||||||
|
|
||||||
dbgIO "running" prognameandversion
|
|
||||||
dbgIO "raw args" args
|
|
||||||
dbgIO "raw args rearranged for cmdargs" args'
|
|
||||||
dbgIO "raw command is probably" rawcmd
|
|
||||||
dbgIO "raw args before command" argsbeforecmd
|
|
||||||
dbgIO "raw args after command" argsaftercmd
|
|
||||||
|
|
||||||
-- Search PATH for add-ons, excluding any that match built-in command names
|
|
||||||
addons' <- hledgerAddons
|
|
||||||
let addons = filter (not . (`elem` builtinCommandNames) . dropExtension) addons'
|
|
||||||
|
|
||||||
-- parse arguments with cmdargs
|
|
||||||
opts' <- argsToCliOpts args addons
|
|
||||||
let opts = opts'{progstarttime_=starttime}
|
|
||||||
|
|
||||||
-- select an action and run it.
|
|
||||||
let
|
|
||||||
cmd = command_ opts -- the full matched internal or external command name, if any
|
|
||||||
isInternalCommand = cmd `elem` builtinCommandNames -- not (null cmd) && not (cmd `elem` addons)
|
|
||||||
isExternalCommand = not (null cmd) && cmd `elem` addons -- probably
|
|
||||||
isBadCommand = not (null rawcmd) && null cmd
|
|
||||||
hasVersion = ("--version" `elem`)
|
|
||||||
printUsage = pager $ showModeUsage $ mainmode addons
|
|
||||||
badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure -- PARTIAL:
|
|
||||||
hasHelpFlag args1 = any (`elem` args1) ["-h","--help"]
|
|
||||||
hasManFlag args1 = (`elem` args1) "--man"
|
|
||||||
hasInfoFlag args1 = (`elem` args1) "--info"
|
|
||||||
f `orShowHelp` mode1
|
|
||||||
| hasHelpFlag args = pager $ showModeUsage mode1
|
|
||||||
| hasInfoFlag args = runInfoForTopic "hledger" (headMay $ modeNames mode1)
|
|
||||||
| hasManFlag args = runManForTopic "hledger" (headMay $ modeNames mode1)
|
|
||||||
| otherwise = f
|
|
||||||
-- where
|
|
||||||
-- lastdocflag
|
|
||||||
dbgIO "processed opts" opts
|
|
||||||
dbgIO "command matched" cmd
|
|
||||||
dbgIO "isNullCommand" isNullCommand
|
|
||||||
dbgIO "isInternalCommand" isInternalCommand
|
|
||||||
dbgIO "isExternalCommand" isExternalCommand
|
|
||||||
dbgIO "isBadCommand" isBadCommand
|
|
||||||
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
|
|
||||||
journallesserror = error $ cmd++" tried to read the journal but is not supposed to"
|
|
||||||
runHledgerCommand
|
|
||||||
-- high priority flags and situations. -h, then --help, then --info are highest priority.
|
|
||||||
| isNullCommand && hasHelpFlag args = dbgIO "" "-h/--help with no command, showing general help" >> printUsage
|
|
||||||
| isNullCommand && hasInfoFlag args = dbgIO "" "--info with no command, showing general info manual" >> runInfoForTopic "hledger" Nothing
|
|
||||||
| isNullCommand && hasManFlag args = dbgIO "" "--man with no command, showing general man page" >> runManForTopic "hledger" Nothing
|
|
||||||
| not (isExternalCommand || hasHelpFlag args || hasInfoFlag args || hasManFlag args)
|
|
||||||
&& (hasVersion args) -- || (hasVersion argsaftercmd && isInternalCommand))
|
|
||||||
= putStrLn prognameandversion
|
|
||||||
-- \| (null externalcmd) && boolopt "binary-filename" rawopts = putStrLn $ binaryfilename progname
|
|
||||||
-- \| "--browse-args" `elem` args = System.Console.CmdArgs.Helper.execute "cmdargs-browser" mainmode' args >>= (putStr . show)
|
|
||||||
| isNullCommand = dbgIO "" "no command, showing commands list" >> printCommandsList prognameandversion addons
|
|
||||||
| isBadCommand = badCommandError
|
|
||||||
|
|
||||||
-- builtin commands
|
|
||||||
| Just (cmdmode, cmdaction) <- findBuiltinCommand cmd =
|
|
||||||
(case True of
|
|
||||||
-- these commands should not require or read the journal
|
|
||||||
_ | cmd `elem` ["demo","help","test"] -> cmdaction opts journallesserror
|
|
||||||
-- these commands should create the journal if missing
|
|
||||||
_ | cmd `elem` ["add","import"] -> do
|
|
||||||
ensureJournalFileExists . head =<< journalFilePathFromOpts opts
|
|
||||||
withJournalDo opts (cmdaction opts)
|
|
||||||
-- other commands read the journal and should fail if it's missing
|
|
||||||
_ -> withJournalDo opts (cmdaction opts)
|
|
||||||
)
|
|
||||||
`orShowHelp` cmdmode
|
|
||||||
|
|
||||||
-- addon commands
|
|
||||||
| isExternalCommand = do
|
|
||||||
let externalargs = argsbeforecmd ++ filter (/="--") argsaftercmd
|
|
||||||
let shellcmd = printf "%s-%s %s" progname cmd (unwords' externalargs) :: String
|
|
||||||
dbgIO "external command selected" cmd
|
|
||||||
dbgIO "external command arguments" (map quoteIfNeeded externalargs)
|
|
||||||
dbgIO "running shell command" shellcmd
|
|
||||||
system shellcmd >>= exitWith
|
|
||||||
|
|
||||||
-- deprecated commands
|
|
||||||
-- cmd == "convert" = error' (modeHelp oldconvertmode) >> exitFailure
|
|
||||||
|
|
||||||
-- shouldn't reach here
|
|
||||||
| otherwise = usageError ("could not understand the arguments "++show args) >> exitFailure
|
|
||||||
|
|
||||||
runHledgerCommand
|
|
||||||
|
|
||||||
-- | Parse hledger CLI options from these command line arguments and
|
|
||||||
-- add-on command names, or raise any error.
|
|
||||||
argsToCliOpts :: [String] -> [String] -> IO CliOpts
|
|
||||||
argsToCliOpts args addons = do
|
|
||||||
let
|
|
||||||
args' = moveFlagsAfterCommand $ replaceNumericFlags args
|
|
||||||
cmdargsopts = either usageError id $ C.process (mainmode addons) args'
|
|
||||||
rawOptsToCliOpts cmdargsopts
|
|
||||||
|
|
||||||
-- | A hacky workaround for cmdargs not accepting flags before the
|
|
||||||
-- subcommand name: try to detect and move such flags after the
|
|
||||||
-- command. This allows the user to put them in either position.
|
|
||||||
-- The order of options is not preserved, but that should be ok.
|
|
||||||
--
|
|
||||||
-- Since we're not parsing flags as precisely as cmdargs here, this is
|
|
||||||
-- imperfect. We make a decent effort to:
|
|
||||||
-- - move all no-argument help/input/report flags
|
|
||||||
-- - move all required-argument help/input/report flags along with their values, space-separated or not
|
|
||||||
-- - ensure --debug has an argument (because.. "or this all goes to hell")
|
|
||||||
-- - not confuse things further or cause misleading errors.
|
|
||||||
moveFlagsAfterCommand :: [String] -> [String]
|
|
||||||
moveFlagsAfterCommand args = moveArgs $ ensureDebugHasArg args
|
|
||||||
where
|
|
||||||
moveArgs args1 = insertFlagsAfterCommand $ moveArgs' (args1, [])
|
|
||||||
where
|
|
||||||
-- -f FILE ..., --alias ALIAS ...
|
|
||||||
moveArgs' ((f:v:a:as), flags) | isMovableReqArgFlag f, isValue v = moveArgs' (a:as, flags ++ [f,v])
|
|
||||||
-- -fFILE ..., --alias=ALIAS ...
|
|
||||||
moveArgs' ((fv:a:as), flags) | isMovableArgFlagAndValue fv = moveArgs' (a:as, flags ++ [fv])
|
|
||||||
-- -f(missing arg)
|
|
||||||
moveArgs' ((f:a:as), flags) | isMovableReqArgFlag f, not (isValue a) = moveArgs' (a:as, flags ++ [f])
|
|
||||||
-- -h ..., --version ...
|
|
||||||
moveArgs' ((f:a:as), flags) | isMovableNoArgFlag f = moveArgs' (a:as, flags ++ [f])
|
|
||||||
-- anything else
|
|
||||||
moveArgs' (as, flags) = (as, flags)
|
|
||||||
|
|
||||||
insertFlagsAfterCommand ([], flags) = flags
|
|
||||||
insertFlagsAfterCommand (command1:args2, flags) = [command1] ++ flags ++ args2
|
|
||||||
|
|
||||||
isMovableNoArgFlag a = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` optargflagstomove ++ noargflagstomove
|
|
||||||
|
|
||||||
isMovableReqArgFlag a = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` reqargflagstomove
|
|
||||||
|
|
||||||
isMovableArgFlagAndValue ('-':'-':a:as) = case break (== '=') (a:as) of
|
|
||||||
(f:fs,_:_) -> (f:fs) `elem` optargflagstomove ++ reqargflagstomove
|
|
||||||
_ -> False
|
|
||||||
isMovableArgFlagAndValue ('-':shortflag:_:_) = [shortflag] `elem` reqargflagstomove
|
|
||||||
isMovableArgFlagAndValue _ = False
|
|
||||||
|
|
||||||
isValue "-" = True
|
|
||||||
isValue ('-':_) = False
|
|
||||||
isValue _ = True
|
|
||||||
|
|
||||||
flagstomove = inputflags ++ reportflags ++ helpflags
|
|
||||||
noargflagstomove = concatMap flagNames $ filter ((==FlagNone).flagInfo) flagstomove
|
|
||||||
reqargflagstomove = -- filter (/= "debug") $
|
|
||||||
concatMap flagNames $ filter ((==FlagReq ).flagInfo) flagstomove
|
|
||||||
optargflagstomove = concatMap flagNames $ filter (isFlagOpt .flagInfo) flagstomove
|
|
||||||
where
|
|
||||||
isFlagOpt = \case
|
|
||||||
FlagOpt _ -> True
|
|
||||||
FlagOptRare _ -> True
|
|
||||||
_ -> False
|
|
||||||
@ -36,4 +36,4 @@ import System.Process as M
|
|||||||
|
|
||||||
import Hledger as M
|
import Hledger as M
|
||||||
import Hledger.Cli as M
|
import Hledger.Cli as M
|
||||||
import Hledger.Cli.Main as M (argsToCliOpts)
|
-- import Hledger.Cli as M (argsToCliOpts)
|
||||||
|
|||||||
@ -1,9 +1,9 @@
|
|||||||
-- the hledger command-line executable; see Hledger/Cli/Main.hs
|
-- the hledger command-line executable; see Hledger/Cli.hs
|
||||||
|
|
||||||
module Main (main)
|
module Main (main)
|
||||||
where
|
where
|
||||||
import qualified Hledger.Cli.Main (main)
|
import qualified Hledger.Cli (main)
|
||||||
|
|
||||||
-- Have to write this explicitly for GHC 9.0.1a for some reason:
|
-- Have to write this explicitly for GHC 9.0.1a for some reason:
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = Hledger.Cli.Main.main
|
main = Hledger.Cli.main
|
||||||
|
|||||||
@ -144,7 +144,6 @@ library:
|
|||||||
cpp-options: -DVERSION="1.31.99"
|
cpp-options: -DVERSION="1.31.99"
|
||||||
exposed-modules:
|
exposed-modules:
|
||||||
- Hledger.Cli
|
- Hledger.Cli
|
||||||
- Hledger.Cli.Main
|
|
||||||
- Hledger.Cli.CliOptions
|
- Hledger.Cli.CliOptions
|
||||||
- Hledger.Cli.DocFiles
|
- Hledger.Cli.DocFiles
|
||||||
- Hledger.Cli.Utils
|
- Hledger.Cli.Utils
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user