/
Main.hs
296 lines (259 loc) · 12.2 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
{-|
hledger - a ledger-compatible accounting tool.
Copyright (c) 2007-2011 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
> > j <- readJournalFile Nothing Nothing "data/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
> > l <- myLedger
See "Hledger.Data.Ledger" for more examples.
-}
module Hledger.Cli.Main where
-- import Control.Monad
import Data.Char (isDigit)
import Data.List
import Safe
import System.Console.CmdArgs.Explicit as C
import System.Environment
import System.Exit
import System.FilePath
import System.Process
import Text.Printf
import Hledger (ensureJournalFileExists)
import Hledger.Cli.Add
import Hledger.Cli.Accounts
import Hledger.Cli.Balance
import Hledger.Cli.Balancesheet
import Hledger.Cli.Cashflow
import Hledger.Cli.Histogram
import Hledger.Cli.Incomestatement
import Hledger.Cli.Print
import Hledger.Cli.Register
import Hledger.Cli.Stats
import Hledger.Cli.Options
import Hledger.Cli.Tests
import Hledger.Cli.Utils
import Hledger.Cli.Version
import Hledger.Data.Dates (getCurrentDay)
import Hledger.Data.RawOptions (RawOpts, optserror)
import Hledger.Reports.ReportOptions (dateSpanFromOpts, intervalFromOpts, queryFromOpts)
import Hledger.Utils
-- | The overall cmdargs mode describing command-line options for hledger.
mainmode addons = defMode {
modeNames = [progname]
,modeHelp = unlines []
,modeHelpSuffix = [""]
,modeArgs = ([], Just $ argsFlag "[ARGS]")
,modeGroupModes = Group {
-- modes (commands) in named groups:
groupNamed = [
("Data entry commands", [
addmode
])
,("\nReporting commands", [
printmode
,accountsmode
,balancemode
,registermode
,incomestatementmode
,balancesheetmode
,cashflowmode
,activitymode
,statsmode
])
]
++ case addons of [] -> []
cs -> [("\nAdd-on commands", map defAddonCommandMode cs)]
-- modes in the unnamed group, shown first without a heading:
,groupUnnamed = [
]
-- modes handled but not shown
,groupHidden = [
testmode
,oldconvertmode
]
}
,modeGroupFlags = Group {
-- flags in named groups:
groupNamed = [generalflagsgroup3]
-- flags in the unnamed group, shown last without a heading:
,groupUnnamed = []
-- flags accepted but not shown in the help:
,groupHidden =
detailedversionflag :
inputflags -- included here so they'll not raise a confusing error if present with no COMMAND
}
}
oldconvertmode = (defCommandMode ["convert"]) {
modeValue = [("command","convert")]
,modeHelp = "convert is no longer needed, just use -f FILE.csv"
,modeArgs = ([], Just $ argsFlag "[CSVFILE]")
,modeGroupFlags = Group {
groupUnnamed = []
,groupHidden = helpflags
,groupNamed = []
}
}
builtinCommands :: [Mode RawOpts]
builtinCommands =
let gs = modeGroupModes $ mainmode []
in concatMap snd (groupNamed gs) ++ groupUnnamed gs ++ groupHidden gs
builtinCommandNames :: [String]
builtinCommandNames = concatMap modeNames builtinCommands
-- | 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 args
cmdargsopts = processValue (mainmode addons) args'
cmdargsopts' = decodeRawOpts cmdargsopts
rawOptsToCliOpts cmdargsopts' >>= checkCliOpts
-- | 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 this 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 and input flags
-- - move all required-argument help and input flags along with their values, space-separated or not
-- - not confuse things further or cause misleading errors.
moveFlagsAfterCommand :: [String] -> [String]
moveFlagsAfterCommand args = move args
where
move (f:a:as) | isMovableNoArgFlag f = (move $ a:as) ++ [f]
move (f:v:a:as) | isMovableReqArgFlag f = (move $ a:as) ++ [f,v]
move (fv:a:as) | isMovableReqArgFlagAndValue fv = (move $ a:as) ++ [fv]
move ("--debug":v:a:as) | not (null v) && all isDigit v = (move $ a:as) ++ ["--debug",v]
move ("--debug":a:as) = (move $ a:as) ++ ["--debug"]
move (fv@('-':'-':'d':'e':'b':'u':'g':'=':_):a:as) = (move $ a:as) ++ [fv]
move as = as
isMovableNoArgFlag a = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` noargflagstomove
isMovableReqArgFlag a = "-" `isPrefixOf` a && dropWhile (=='-') a `elem` reqargflagstomove
isMovableReqArgFlagAndValue ('-':'-':a:as) = case break (== '=') (a:as) of (f:fs,_) -> (f:fs) `elem` reqargflagstomove
_ -> False
isMovableReqArgFlagAndValue ('-':f:_:_) = [f] `elem` reqargflagstomove
isMovableReqArgFlagAndValue _ = False
noargflagstomove = concatMap flagNames $ filter ((==FlagNone).flagInfo) flagstomove
reqargflagstomove = concatMap flagNames $ filter ((==FlagReq ).flagInfo) flagstomove
flagstomove = inputflags ++ helpflags
-- | Let's go.
main :: IO ()
main = do
-- 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.Options and
-- command-line.test.
-- some preliminary (imperfect) argument parsing to supplement cmdargs
args <- getArgs
let
args' = moveFlagsAfterCommand 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'
dbgM :: Show a => String -> a -> IO ()
dbgM = dbgAtM 2
dbgM "running" prognameandversion
dbgM "raw args" args
dbgM "raw args rearranged for cmdargs" args'
dbgM "raw command is probably" rawcmd
dbgM "raw args before command" argsbeforecmd
dbgM "raw args after command" argsaftercmd
-- Search PATH for add-ons, excluding any that match built-in names.
-- The precise addon names (including file extension) are used for command
-- parsing, and the display names are used for displaying the commands list.
(addonPreciseNames', addonDisplayNames') <- hledgerAddons
let addonPreciseNames = filter (not . (`elem` builtinCommandNames) . dropExtension) addonPreciseNames'
let addonDisplayNames = filter (not . (`elem` builtinCommandNames)) addonDisplayNames'
-- parse arguments with cmdargs
opts <- argsToCliOpts args addonPreciseNames
-- 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` addonPreciseNames -- probably
isBadCommand = not (null rawcmd) && null cmd
hasHelp args = any (`elem` args) ["--help","-h","-?"]
hasVersion = ("--version" `elem`)
hasDetailedVersion = ("--version+" `elem`)
generalHelp = putStr $ showModeHelp $ mainmode addonDisplayNames
badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure
f `orShowHelp` mode = if hasHelp args then putStr (showModeHelp mode) else f
dbgM "processed opts" opts
dbgM "command matched" cmd
dbgM "isNullCommand" isNullCommand
dbgM "isInternalCommand" isInternalCommand
dbgM "isExternalCommand" isExternalCommand
dbgM "isBadCommand" isBadCommand
d <- getCurrentDay
dbgM "date span from opts" (dateSpanFromOpts d $ reportopts_ opts)
dbgM "interval from opts" (intervalFromOpts $ reportopts_ opts)
dbgM "query from opts & args" (queryFromOpts d $ reportopts_ opts)
let
runHledgerCommand
-- high priority flags and situations. --help should be highest priority.
| hasHelp argsbeforecmd = dbgM "" "--help before command, showing general help" >> generalHelp
| not (hasHelp argsaftercmd) && (hasVersion argsbeforecmd || (hasVersion argsaftercmd && isInternalCommand))
= putStrLn prognameandversion
| not (hasHelp argsaftercmd) && (hasDetailedVersion argsbeforecmd || (hasDetailedVersion argsaftercmd && isInternalCommand))
= putStrLn prognameanddetailedversion
-- \| (null externalcmd) && "binary-filename" `inRawOpts` rawopts = putStrLn $ binaryfilename progname
-- \| "--browse-args" `elem` args = System.Console.CmdArgs.Helper.execute "cmdargs-browser" mainmode' args >>= (putStr . show)
| isNullCommand = dbgM "" "no command, showing general help" >> generalHelp
| isBadCommand = badCommandError
-- internal commands
| cmd == "activity" = withJournalDo opts histogram `orShowHelp` activitymode
| cmd == "add" = (journalFilePathFromOpts opts >>= ensureJournalFileExists >> withJournalDo opts add) `orShowHelp` addmode
| cmd == "accounts" = withJournalDo opts accounts `orShowHelp` accountsmode
| cmd == "balance" = withJournalDo opts balance `orShowHelp` balancemode
| cmd == "balancesheet" = withJournalDo opts balancesheet `orShowHelp` balancesheetmode
| cmd == "cashflow" = withJournalDo opts cashflow `orShowHelp` cashflowmode
| cmd == "incomestatement" = withJournalDo opts incomestatement `orShowHelp` incomestatementmode
| cmd == "print" = withJournalDo opts print' `orShowHelp` printmode
| cmd == "register" = withJournalDo opts register `orShowHelp` registermode
| cmd == "stats" = withJournalDo opts stats `orShowHelp` statsmode
| cmd == "test" = test' opts `orShowHelp` testmode
-- an external command
| isExternalCommand = do
let externalargs = argsbeforecmd ++ filter (not.(=="--")) argsaftercmd
let shellcmd = printf "%s-%s %s" progname cmd (unwords' externalargs) :: String
dbgM "external command selected" cmd
dbgM "external command arguments" (map quoteIfNeeded externalargs)
dbgM "running shell command" shellcmd
system shellcmd >>= exitWith
-- deprecated commands
| cmd == "convert" = error' (modeHelp oldconvertmode) >> exitFailure
-- shouldn't reach here
| otherwise = optserror ("could not understand the arguments "++show args) >> exitFailure
runHledgerCommand
-- tests_runHledgerCommand = [
-- -- "runHledgerCommand" ~: do
-- -- let opts = defreportopts{query_="expenses"}
-- -- d <- getCurrentDay
-- -- runHledgerCommand addons opts@CliOpts{command_=cmd} args
-- ]