{-# LANGUAGE QuasiQuotes #-}
module Hledger.Cli.Main where
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.Cli
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 {
groupUnnamed = [
]
,groupNamed = [
]
,groupHidden = map fst builtinCommands ++ map addonCommandMode addons
}
,modeGroupFlags = Group {
groupNamed = [
( "General input flags", inputflags)
,("\nGeneral reporting flags", reportflags)
,("\nGeneral help flags", helpflags)
]
,groupUnnamed = []
,groupHidden =
[detailedversionflag]
}
,modeHelpSuffix = map (regexReplace "PROGNAME" progname) [
"Examples:"
,"PROGNAME list commands"
,"PROGNAME CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)"
,"PROGNAME-CMD [OPTS] [ARGS] or run addon commands directly"
,"PROGNAME -h show general usage"
,"PROGNAME CMD -h show command usage"
,"PROGNAME help [MANUAL] show any of the hledger manuals in various formats"
]
}
main :: IO ()
main = do
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 2
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
addons' <- hledgerAddons
let addons = filter (not . (`elem` builtinCommandNames) . dropExtension) addons'
opts <- argsToCliOpts args addons
let
cmd = command_ opts
isInternalCommand = cmd `elem` builtinCommandNames
isExternalCommand = not (null cmd) && cmd `elem` addons
isBadCommand = not (null rawcmd) && null cmd
hasVersion = ("--version" `elem`)
hasDetailedVersion = ("--version+" `elem`)
printUsage = putStr $ showModeUsage $ mainmode addons
badCommandError = error' ("command "++rawcmd++" is not recognized, run with no command to see a list") >> exitFailure
hasHelpFlag args = any (`elem` args) ["-h","--help"]
f `orShowHelp` mode
| hasHelpFlag args = putStr $ showModeUsage mode
| otherwise = f
dbgIO "processed opts" opts
dbgIO "command matched" cmd
dbgIO "isNullCommand" isNullCommand
dbgIO "isInternalCommand" isInternalCommand
dbgIO "isExternalCommand" isExternalCommand
dbgIO "isBadCommand" isBadCommand
d <- getCurrentDay
dbgIO "period from opts" (period_ $ reportopts_ opts)
dbgIO "interval from opts" (interval_ $ reportopts_ opts)
dbgIO "query from opts & args" (queryFromOpts d $ reportopts_ opts)
let
runHledgerCommand
| hasHelpFlag argsbeforecmd = dbgIO "" "-h before command, showing general usage" >> printUsage
| not (hasHelpFlag argsaftercmd) && (hasVersion argsbeforecmd || (hasVersion argsaftercmd && isInternalCommand))
= putStrLn prognameandversion
| not (hasHelpFlag argsaftercmd) && (hasDetailedVersion argsbeforecmd || (hasDetailedVersion argsaftercmd && isInternalCommand))
= putStrLn prognameanddetailedversion
| isNullCommand = dbgIO "" "no command, showing commands list" >> printCommandsList addons
| isBadCommand = badCommandError
| Just (cmdmode, cmdaction) <- findCommand cmd =
(case cmd of
"test" ->
cmdaction opts (error "journal-less command tried to use the journal")
"add" ->
(ensureJournalFileExists =<< (head <$> journalFilePathFromOpts opts)) >>
withJournalDo opts (cmdaction opts)
_ ->
withJournalDo opts (cmdaction opts)
)
`orShowHelp` cmdmode
| isExternalCommand = do
let externalargs = argsbeforecmd ++ filter (not.(=="--")) 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
| otherwise = usageError ("could not understand the arguments "++show args) >> exitFailure
runHledgerCommand
argsToCliOpts :: [String] -> [String] -> IO CliOpts
argsToCliOpts args addons = do
let
args' = moveFlagsAfterCommand $ replaceNumericFlags args
cmdargsopts = either usageError id $ process (mainmode addons) args'
cmdargsopts' = decodeRawOpts cmdargsopts
rawOptsToCliOpts cmdargsopts'
moveFlagsAfterCommand :: [String] -> [String]
moveFlagsAfterCommand args = moveArgs $ ensureDebugHasArg args
where
ensureDebugHasArg as =
case break (=="--debug") as of
(bs,"--debug":c:cs) | null c || not (all isDigit c) -> bs++"--debug=1":c:cs
(bs,"--debug":[]) -> bs++"--debug=1":[]
_ -> as
moveArgs args = insertFlagsAfterCommand $ moveArgs' (args, [])
where
moveArgs' ((f:a:as), flags) | isMovableNoArgFlag f = moveArgs' (a:as, flags ++ [f])
moveArgs' ((f:v:a:as), flags) | isMovableReqArgFlag f, isValue v = moveArgs' (a:as, flags ++ [f,v])
moveArgs' ((fv:a:as), flags) | isMovableReqArgFlagAndValue fv = moveArgs' (a:as, flags ++ [fv])
moveArgs' ((f:a:as), flags) | isMovableReqArgFlag f, not (isValue a) = moveArgs' (a:as, flags ++ [f])
moveArgs' (as, flags) = (as, flags)
insertFlagsAfterCommand ([], flags) = flags
insertFlagsAfterCommand (command:args, flags) = [command] ++ flags ++ args
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 ('-':shortflag:_:_) = [shortflag] `elem` reqargflagstomove
isMovableReqArgFlagAndValue _ = False
isValue "-" = True
isValue ('-':_) = False
isValue _ = True
flagstomove = inputflags ++ reportflags ++ helpflags
noargflagstomove = concatMap flagNames $ filter ((==FlagNone).flagInfo) flagstomove
reqargflagstomove =
concatMap flagNames $ filter ((==FlagReq ).flagInfo) flagstomove