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

dev:add: refactor, simplify names

Browse Source
This commit is contained in:
Simon Michael 2025-11-18 10:15:25 -10:00
parent 2c80a0feac
commit 4493f0615b
1 changed files with 177 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

343
hledger/Hledger/Cli/Commands/Add.hs
View File

@ -62,27 +62,50 @@ addmode = hledgerCommandMode
confflags confflags
([], Just $ argsFlag "[-f JOURNALFILE] [DATE [DESCRIPTION [ACCOUNT1 [ETC..]]]]]") ([], Just $ argsFlag "[-f JOURNALFILE] [DATE [DESCRIPTION [ACCOUNT1 [ETC..]]]]]")
-- | State used while entering transactions. data AddState = AddState {
data EntryState = EntryState { asOpts :: CliOpts -- ^ command line options
esOpts :: CliOpts -- ^ command line options ,asArgs :: [String] -- ^ command line arguments remaining to be used state defaults
,esArgs :: [String] -- ^ command line arguments remaining to be used as defaults ,asToday :: Day -- ^ today's date
,esToday :: Day -- ^ today's date ,asDefDate :: Day -- ^ the default date to use for the next transaction
,esDefDate :: Day -- ^ the default date for next transaction ,asJournal :: Journal -- ^ the journal we are adding to
,esJournal :: Journal -- ^ the journal we are adding to ,asSimilarTransaction :: Maybe Transaction -- ^ the old transaction most similar to the new one being entered
,esSimilarTransaction :: Maybe Transaction -- ^ the most similar historical txn ,asPostings :: [Posting] -- ^ the new postings entered so far
,esPostings :: [Posting] -- ^ postings entered so far in the current txn } deriving (Show)
} deriving (Show)
defEntryState = EntryState { defAddState = AddState {
esOpts = defcliopts asOpts = defcliopts
,esArgs = [] ,asArgs = []
,esToday = nulldate ,asToday = nulldate
,esDefDate = nulldate ,asDefDate = nulldate
,esJournal = nulljournal ,asJournal = nulljournal
,esSimilarTransaction = Nothing ,asSimilarTransaction = Nothing
,esPostings = [] ,asPostings = []
} }
data AddStep =
GetDate
| GetDescription (Day, Text)
| GetPosting TxnData (Maybe Posting)
| GetAccount TxnData
| GetAmount TxnData String
| Confirm Transaction
data TxnData = TxnData {
txnDate :: Day
, txnCode :: Text
, txnDesc :: Text
, txnCmnt :: Text
} deriving (Show)
type Comment = (Text, [Tag], Maybe Day, Maybe Day)
data PrevInput = PrevInput {
prevDateAndCode :: Maybe String
, prevDescAndCmnt :: Maybe String
, prevAccount :: [String]
, prevAmountAndCmnt :: [String]
} deriving (Show)
data RestartTransactionException = RestartTransactionException deriving (Show) data RestartTransactionException = RestartTransactionException deriving (Show)
instance Exception RestartTransactionException instance Exception RestartTransactionException
@ -99,16 +122,16 @@ add opts j
hPutStrLn stderr $ "Adding transactions to journal file " <> journalFilePath j hPutStrLn stderr $ "Adding transactions to journal file " <> journalFilePath j
showHelp showHelp
let today = opts^.rsDay let today = opts^.rsDay
es = defEntryState{esOpts=opts state = defAddState{asOpts=opts
,esArgs=listofstringopt "args" $ rawopts_ opts ,asArgs=listofstringopt "args" $ rawopts_ opts
,esToday=today ,asToday=today
,esDefDate=today ,asDefDate=today
,esJournal=j ,asJournal=j
} }
getAndAddTransactions es `E.catch` (\(_::UnexpectedEOF) -> putStr "") addTransactionsLoop state `E.catch` (\(_::UnexpectedEOF) -> putStr "")
showHelp = hPutStr stderr $ unlines [ showHelp = hPutStr stderr $ unlines [
"Any command line arguments will be used as defaults." "Any command line arguments will be used state defaults."
,"Use tab key to complete, readline keys to edit, enter to accept defaults." ,"Use tab key to complete, readline keys to edit, enter to accept defaults."
,"An optional (CODE) may follow transaction dates." ,"An optional (CODE) may follow transaction dates."
,"An optional ; COMMENT may follow descriptions or amounts." ,"An optional ; COMMENT may follow descriptions or amounts."
@ -120,124 +143,104 @@ showHelp = hPutStr stderr $ unlines [
-- | Loop reading transactions from the console, prompting, validating -- | Loop reading transactions from the console, prompting, validating
-- and appending each one to the journal file, until end of input or -- and appending each one to the journal file, until end of input or
-- ctrl-c (then raise an EOF exception). If provided, command-line -- ctrl-c (then raise an EOF exception). If provided, command-line
-- arguments are used as defaults; otherwise defaults come from the -- arguments are used state defaults; otherwise defaults come from the
-- most similar recent transaction in the journal. -- most similar recent transaction in the journal.
getAndAddTransactions :: EntryState -> IO () addTransactionsLoop :: AddState -> IO ()
getAndAddTransactions es@EntryState{..} = (do addTransactionsLoop state@AddState{..} = (do
let defaultPrevInput = PrevInput{prevDateAndCode=Nothing, prevDescAndCmnt=Nothing, prevAccount=[], prevAmountAndCmnt=[]} let defaultPrevInput = PrevInput{prevDateAndCode=Nothing, prevDescAndCmnt=Nothing, prevAccount=[], prevAmountAndCmnt=[]}
mt <- runInputT (setComplete noCompletion defaultSettings) (System.Console.Wizard.run $ haskeline $ confirmedTransactionWizard defaultPrevInput es []) mt <- runInputT (setComplete noCompletion defaultSettings) (System.Console.Wizard.run $ haskeline $ transactionWizard defaultPrevInput state [])
case mt of case mt of
Nothing -> error' "Could not interpret the input, restarting" -- caught below causing a restart, I believe -- PARTIAL: Nothing -> error' "Could not interpret the input, restarting" -- caught below causing a restart, I believe -- PARTIAL:
Just t -> do Just t -> do
j <- if debug_ esOpts > 0 j <- if debug_ asOpts > 0
then do hPutStrLn stderr "Skipping journal add due to debug mode." then do hPutStrLn stderr "Skipping journal add due to debug mode."
return esJournal return asJournal
else do j' <- journalAddTransaction esJournal esOpts t else do j' <- journalAddTransaction asJournal asOpts t
hPutStrLn stderr "Saved." hPutStrLn stderr "Saved."
return j' return j'
hPutStrLn stderr "Starting the next transaction (. or ctrl-D/ctrl-C to quit)" hPutStrLn stderr "Starting the next transaction (. or ctrl-D/ctrl-C to quit)"
getAndAddTransactions es{esJournal=j, esDefDate=tdate t} addTransactionsLoop state{asJournal=j, asDefDate=tdate t}
) )
`E.catch` (\(_::RestartTransactionException) -> `E.catch` (\(_::RestartTransactionException) ->
hPutStrLn stderr "Restarting this transaction." >> getAndAddTransactions es) hPutStrLn stderr "Restarting this transaction." >> addTransactionsLoop state)
data TxnParams = TxnParams -- | Interact with the user to get a Transaction.
{ txnDate :: Day transactionWizard :: PrevInput -> AddState -> [AddStep] -> Wizard Haskeline Transaction
, txnCode :: Text transactionWizard previnput state [] = transactionWizard previnput state [GetDate]
, txnDesc :: Text transactionWizard previnput state@AddState{..} stack@(currentStage : _) = case currentStage of
, txnCmnt :: Text GetDate -> dateWizard previnput state >>= \case
} deriving (Show)
data PrevInput = PrevInput
{ prevDateAndCode :: Maybe String
, prevDescAndCmnt :: Maybe String
, prevAccount :: [String]
, prevAmountAndCmnt :: [String]
} deriving (Show)
data AddingStage = EnterDateAndCode
| EnterDescAndComment (Day, Text)
| EnterAccount TxnParams
| EnterAmountAndComment TxnParams String
| EndStage Transaction
| EnterNewPosting TxnParams (Maybe Posting)
confirmedTransactionWizard :: PrevInput -> EntryState -> [AddingStage] -> Wizard Haskeline Transaction
confirmedTransactionWizard prevInput es [] = confirmedTransactionWizard prevInput es [EnterDateAndCode]
confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _) = case currentStage of
EnterDateAndCode -> dateAndCodeWizard prevInput es >>= \case
Just (efd, code) -> do Just (efd, code) -> do
let let
date = fromEFDay efd date = fromEFDay efd
es' = es{ esArgs = drop 1 esArgs state' = state{ asArgs = drop 1 asArgs
, esDefDate = date , asDefDate = date
} }
dateAndCodeString = formatTime defaultTimeLocale yyyymmddFormat date dateAndCodeString = formatTime defaultTimeLocale yyyymmddFormat date
++ T.unpack (if T.null code then "" else " (" <> code <> ")") ++ T.unpack (if T.null code then "" else " (" <> code <> ")")
yyyymmddFormat = "%Y-%m-%d" yyyymmddFormat = "%Y-%m-%d"
confirmedTransactionWizard prevInput{prevDateAndCode=Just dateAndCodeString} es' (EnterDescAndComment (date, code) : stack) transactionWizard previnput{prevDateAndCode=Just dateAndCodeString} state' (GetDescription (date, code) : stack)
Nothing -> Nothing ->
confirmedTransactionWizard prevInput es stack transactionWizard previnput state stack
EnterDescAndComment (date, code) -> descriptionAndCommentWizard prevInput es >>= \case GetDescription (date, code) -> descriptionWizard previnput state >>= \case
Just (desc, comment) -> do Just (desc, comment) -> do
let mbaset = journalSimilarTransaction esOpts esJournal desc let mbaset = journalSimilarTransaction asOpts asJournal desc
es' = es state' = state
{ esArgs = drop 1 esArgs { asArgs = drop 1 asArgs
, esPostings = [] , asPostings = []
, esSimilarTransaction = mbaset , asSimilarTransaction = mbaset
} }
descAndCommentString = T.unpack $ desc <> (if T.null comment then "" else " ; " <> comment) descAndCommentString = T.unpack $ desc <> (if T.null comment then "" else " ; " <> comment)
prevInput' = prevInput{prevDescAndCmnt=Just descAndCommentString} previnput' = previnput{prevDescAndCmnt=Just descAndCommentString}
when (isJust mbaset) . liftIO $ do when (isJust mbaset) . liftIO $ do
hPutStrLn stderr "Using this similar transaction for defaults:" hPutStrLn stderr "Using this similar transaction for defaults:"
T.hPutStr stderr $ showTransaction (fromJust mbaset) T.hPutStr stderr $ showTransaction (fromJust mbaset)
confirmedTransactionWizard prevInput' es' ((EnterNewPosting TxnParams{txnDate=date, txnCode=code, txnDesc=desc, txnCmnt=comment} Nothing) : stack) transactionWizard previnput' state' ((GetPosting TxnData{txnDate=date, txnCode=code, txnDesc=desc, txnCmnt=comment} Nothing) : stack)
Nothing -> Nothing ->
confirmedTransactionWizard prevInput es (drop 1 stack) transactionWizard previnput state (drop 1 stack)
EnterNewPosting txnParams@TxnParams{..} p -> case (esPostings, p) of GetPosting txndata@TxnData{..} p -> case (asPostings, p) of
([], Nothing) -> ([], Nothing) ->
confirmedTransactionWizard prevInput es (EnterAccount txnParams : stack) transactionWizard previnput state (GetAccount txndata : stack)
(_, Just _) -> (_, Just _) ->
confirmedTransactionWizard prevInput es (EnterAccount txnParams : stack) transactionWizard previnput state (GetAccount txndata : stack)
(_, Nothing) -> do (_, Nothing) -> do
let t = nulltransaction{tdate=txnDate let t = nulltransaction{tdate=txnDate
,tstatus=Unmarked ,tstatus=Unmarked
,tcode=txnCode ,tcode=txnCode
,tdescription=txnDesc ,tdescription=txnDesc
,tcomment=txnCmnt ,tcomment=txnCmnt
,tpostings=esPostings ,tpostings=asPostings
} }
bopts = balancingopts_ (inputopts_ esOpts) bopts = balancingopts_ (inputopts_ asOpts)
case balanceTransactionInJournal t esJournal bopts of case balanceTransactionInJournal t asJournal bopts of
Right t' -> Right t' ->
confirmedTransactionWizard prevInput es (EndStage t' : stack) transactionWizard previnput state (Confirm t' : stack)
Left err -> do Left err -> do
liftIO (hPutStrLn stderr $ "\n" ++ (capitalize err) ++ ", please re-enter.") liftIO (hPutStrLn stderr $ "\n" ++ (capitalize err) ++ ", please re-enter.")
let notFirstEnterPost stage = case stage of let notFirstEnterPost stage = case stage of
EnterNewPosting _ Nothing -> False GetPosting _ Nothing -> False
_ -> True _ -> True
confirmedTransactionWizard prevInput es{esPostings=[]} (dropWhile notFirstEnterPost stack) transactionWizard previnput state{asPostings=[]} (dropWhile notFirstEnterPost stack)
EnterAccount txnParams -> accountWizard prevInput es >>= \case GetAccount txndata -> accountWizard previnput state >>= \case
Just account Just account
| account `elem` [".", ""] -> | account `elem` [".", ""] ->
case (esPostings, postingsBalanced esPostings) of case (asPostings, postingsAreBalanced asPostings) of
([],_) -> liftIO (hPutStrLn stderr "Please enter some postings first.") >> confirmedTransactionWizard prevInput es stack ([],_) -> liftIO (hPutStrLn stderr "Please enter some postings first.") >> transactionWizard previnput state stack
(_,False) -> liftIO (hPutStrLn stderr "Please enter more postings to balance the transaction.") >> confirmedTransactionWizard prevInput es stack (_,False) -> liftIO (hPutStrLn stderr "Please enter more postings to balance the transaction.") >> transactionWizard previnput state stack
(_,True) -> confirmedTransactionWizard prevInput es (EnterNewPosting txnParams Nothing : stack) (_,True) -> transactionWizard previnput state (GetPosting txndata Nothing : stack)
| otherwise -> do | otherwise -> do
let prevAccount' = replaceNthOrAppend (length esPostings) account (prevAccount prevInput) let prevAccount' = replaceNthOrAppend (length asPostings) account (prevAccount previnput)
confirmedTransactionWizard prevInput{prevAccount=prevAccount'} es{esArgs=drop 1 esArgs} (EnterAmountAndComment txnParams account : stack) transactionWizard previnput{prevAccount=prevAccount'} state{asArgs=drop 1 asArgs} (GetAmount txndata account : stack)
Nothing -> do Nothing -> do
let notPrevAmountAndNotEnterDesc stage = case stage of let notPrevAmountAndNotGetDesc stage = case stage of
EnterAmountAndComment _ _ -> False GetAmount _ _ -> False
EnterDescAndComment _ -> False GetDescription _ -> False
_ -> True _ -> True
confirmedTransactionWizard prevInput es{esPostings=init esPostings} (dropWhile notPrevAmountAndNotEnterDesc stack) transactionWizard previnput state{asPostings=init asPostings} (dropWhile notPrevAmountAndNotGetDesc stack)
EnterAmountAndComment txnParams account -> amountAndCommentWizard prevInput es >>= \case GetAmount txndata account -> amountWizard previnput state >>= \case
Just (mamt, assertion, (comment, tags, pdate1, pdate2)) -> do Just (mamt, assertion, (comment, tags, pdate1, pdate2)) -> do
let mixedamt = maybe missingmixedamt mixedAmount mamt let mixedamt = maybe missingmixedamt mixedAmount mamt
p = nullposting{paccount=T.pack $ stripbrackets account p = nullposting{paccount=T.pack $ stripbrackets account
@ -250,13 +253,13 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
,ptags=tags ,ptags=tags
} }
amountAndCommentString = showMixedAmountOneLine mixedamt ++ T.unpack (if T.null comment then "" else " ;" <> comment) amountAndCommentString = showMixedAmountOneLine mixedamt ++ T.unpack (if T.null comment then "" else " ;" <> comment)
prevAmountAndCmnt' = replaceNthOrAppend (length esPostings) amountAndCommentString (prevAmountAndCmnt prevInput) prevAmountAndCmnt' = replaceNthOrAppend (length asPostings) amountAndCommentString (prevAmountAndCmnt previnput)
es' = es{esPostings=esPostings++[p], esArgs=drop 1 esArgs} state' = state{asPostings=asPostings++[p], asArgs=drop 1 asArgs}
-- Include a dummy posting to balance the unfinished transation in assertion checking -- Include a dummy posting to balance the unfinished transation in assertion checking
dummytxn = nulltransaction{tpostings = esPostings ++ [p, post "" missingamt] dummytxn = nulltransaction{tpostings = asPostings ++ [p, post "" missingamt]
,tdate = txnDate txnParams ,tdate = txnDate txndata
,tdescription = txnDesc txnParams } ,tdescription = txnDesc txndata }
bopts = balancingopts_ (inputopts_ esOpts) bopts = balancingopts_ (inputopts_ asOpts)
balanceassignment = mixedamt==missingmixedamt && isJust assertion balanceassignment = mixedamt==missingmixedamt && isJust assertion
etxn etxn
-- If the new posting is doing a balance assignment, -- If the new posting is doing a balance assignment,
@ -265,17 +268,17 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
-- Otherwise, balance the transaction in context of the whole journal, -- Otherwise, balance the transaction in context of the whole journal,
-- maybe filling its balance assignments if any, -- maybe filling its balance assignments if any,
-- and maybe checking all the journal's balance assertions. -- and maybe checking all the journal's balance assertions.
| otherwise = balanceTransactionInJournal dummytxn esJournal bopts | otherwise = balanceTransactionInJournal dummytxn asJournal bopts
case etxn of case etxn of
Left err -> do Left err -> do
liftIO (hPutStrLn stderr err) liftIO (hPutStrLn stderr err)
confirmedTransactionWizard prevInput es (EnterAmountAndComment txnParams account : stack) transactionWizard previnput state (GetAmount txndata account : stack)
Right _ -> Right _ ->
confirmedTransactionWizard prevInput{prevAmountAndCmnt=prevAmountAndCmnt'} es' (EnterNewPosting txnParams (Just posting) : stack) transactionWizard previnput{prevAmountAndCmnt=prevAmountAndCmnt'} state' (GetPosting txndata (Just posting) : stack)
Nothing -> confirmedTransactionWizard prevInput es (drop 1 stack) Nothing -> transactionWizard previnput state (drop 1 stack)
EndStage t -> do Confirm t -> do
output . T.unpack $ showTransaction t output . T.unpack $ showTransaction t
y <- let def = "y" in y <- let def = "y" in
retryMsg "Please enter y or n." $ retryMsg "Please enter y or n." $
@ -285,36 +288,17 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
case y of case y of
Just 'y' -> return t Just 'y' -> return t
Just _ -> throw RestartTransactionException Just _ -> throw RestartTransactionException
Nothing -> confirmedTransactionWizard prevInput es (drop 2 stack) Nothing -> transactionWizard previnput state (drop 2 stack)
where where
replaceNthOrAppend n newElem xs = take n xs ++ [newElem] ++ drop (n + 1) xs replaceNthOrAppend n newElem xs = take n xs ++ [newElem] ++ drop (n + 1) xs
-- | Interact with the user to get a transaction date (accepting smart dates), maybe followed by a " (CODE)".
-- | Balance and check a transaction with awareness of the whole journal it will be added to. -- Returns the date and the code, or nothing if the input was "<".
-- This means add it to the journal, balance it, calculate any balance assignments in it, dateWizard :: PrevInput -> AddState -> Wizard Haskeline (Maybe (EFDay, Text))
-- then maybe check all the journal's balance assertions, dateWizard PrevInput{..} AddState{..} = do
-- then return the now fully balanced and checked transaction, or an error message. let def = headDef (T.unpack $ showDate asDefDate) asArgs
balanceTransactionInJournal :: Transaction -> Journal -> BalancingOpts -> Either String Transaction
balanceTransactionInJournal t j bopts = do
-- Add the transaction at the end of the journal, as the add command will.
let j' = j{jtxns = jtxns j ++ [t]}
-- Try to balance and check the whole journal, and specifically the new transaction.
Journal{jtxns=ts} <- journalBalanceTransactions bopts j'
-- Extract the balanced & checked transaction.
maybe
(Left "confirmedTransactionWizard: unexpected empty journal") -- should not happen
Right
(lastMay ts)
-- | A workaround we seem to need for #2410 right now: wizards' input-reading functions disrupt ANSI codes
-- somehow, so these variants first print the ANSI coded prompt as ordinary output, then do the input with no prompt.
line' prompt = output prompt >> line ""
linePrewritten' prompt beforetxt aftertxt = output prompt >> linePrewritten "" beforetxt aftertxt
dateAndCodeWizard PrevInput{..} EntryState{..} = do
let def = headDef (T.unpack $ showDate esDefDate) esArgs
retryMsg "A valid hledger smart date is required. Eg: 2022-08-30, 8/30, 30, yesterday." $ retryMsg "A valid hledger smart date is required. Eg: 2022-08-30, 8/30, 30, yesterday." $
parser (parseSmartDateAndCode esToday) $ parser (parseSmartDateAndCode asToday) $
withCompletion (dateCompleter def) $ withCompletion (dateCompleter def) $
defaultTo' def $ nonEmpty $ defaultTo' def $ nonEmpty $
maybeExit $ maybeExit $
@ -334,9 +318,12 @@ dateAndCodeWizard PrevInput{..} EntryState{..} = do
-- defday = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) defdate -- defday = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) defdate
-- datestr = showDate $ fixSmartDate defday smtdate -- datestr = showDate $ fixSmartDate defday smtdate
descriptionAndCommentWizard PrevInput{..} EntryState{..} = do -- | Interact with the user to get a transaction description, maybe followed by a "; COMMENT".
let def = headDef "" esArgs -- Returns the possibly empty description and comment, or nothing if the input is "<".
s <- withCompletion (descriptionCompleter esJournal def) $ descriptionWizard :: PrevInput -> AddState -> Wizard Haskeline (Maybe (Text, Text))
descriptionWizard PrevInput{..} AddState{..} = do
let def = headDef "" asArgs
s <- withCompletion (descriptionCompleter asJournal def) $
defaultTo' def $ nonEmpty $ defaultTo' def $ nonEmpty $
linePrewritten' (green' $ printf "Description%s: " (showDefault def)) (fromMaybe "" prevDescAndCmnt) "" linePrewritten' (green' $ printf "Description%s: " (showDefault def)) (fromMaybe "" prevDescAndCmnt) ""
if s == "<" if s == "<"
@ -345,25 +332,25 @@ descriptionAndCommentWizard PrevInput{..} EntryState{..} = do
let (desc,comment) = (T.pack $ strip a, T.pack $ strip $ dropWhile (==';') b) where (a,b) = break (==';') s let (desc,comment) = (T.pack $ strip a, T.pack $ strip $ dropWhile (==';') b) where (a,b) = break (==';') s
return $ Just (desc, comment) return $ Just (desc, comment)
postingsBalanced :: [Posting] -> Bool -- | Interact with the user to get an account name, possibly enclosed in "()" or "[]".
postingsBalanced ps = isRight $ balanceSingleTransaction defbalancingopts nulltransaction{tpostings=ps} -- Returns the account name, or nothing if the input is "<".
accountWizard :: PrevInput -> AddState -> Wizard Haskeline (Maybe String)
accountWizard PrevInput{..} EntryState{..} = do accountWizard PrevInput{..} AddState{..} = do
let pnum = length esPostings + 1 let pnum = length asPostings + 1
historicalp = fmap ((!! (pnum - 1)) . (++ (repeat nullposting)) . tpostings) esSimilarTransaction historicalp = fmap ((!! (pnum - 1)) . (++ (repeat nullposting)) . tpostings) asSimilarTransaction
historicalacct = case historicalp of Just p -> showAccountName Nothing (ptype p) (paccount p) historicalacct = case historicalp of Just p -> showAccountName Nothing (ptype p) (paccount p)
Nothing -> "" Nothing -> ""
def = headDef (T.unpack historicalacct) esArgs def = headDef (T.unpack historicalacct) asArgs
endmsg | canfinish && null def = " (or . or enter to finish this transaction)" endmsg | canfinish && null def = " (or . or enter to finish this transaction)"
| canfinish = " (or . to finish this transaction)" | canfinish = " (or . to finish this transaction)"
| otherwise = "" | otherwise = ""
retryMsg "A valid hledger account name is required. Eg: assets:cash, expenses:food:eating out." $ retryMsg "A valid hledger account name is required. Eg: assets:cash, expenses:food:eating out." $
parser (parseAccountOrDotOrNull def canfinish) $ parser (parseAccountOrDotOrNull def canfinish) $
withCompletion (accountCompleter esJournal def) $ withCompletion (accountCompleter asJournal def) $
defaultTo' def $ -- nonEmpty $ defaultTo' def $ -- nonEmpty $
linePrewritten' (green' $ printf "Account %d%s%s: " pnum (endmsg::String) (showDefault def)) (fromMaybe "" $ prevAccount `atMay` length esPostings) "" linePrewritten' (green' $ printf "Account %d%s%s: " pnum (endmsg::String) (showDefault def)) (fromMaybe "" $ prevAccount `atMay` length asPostings) ""
where where
canfinish = not (null esPostings) && postingsBalanced esPostings canfinish = not (null asPostings) && postingsAreBalanced asPostings
parseAccountOrDotOrNull :: String -> Bool -> String -> Maybe (Maybe String) parseAccountOrDotOrNull :: String -> Bool -> String -> Maybe (Maybe String)
parseAccountOrDotOrNull _ _ "<" = dbg' $ Just Nothing parseAccountOrDotOrNull _ _ "<" = dbg' $ Just Nothing
parseAccountOrDotOrNull _ _ "." = dbg' $ Just $ Just "." -- . always signals end of txn parseAccountOrDotOrNull _ _ "." = dbg' $ Just $ Just "." -- . always signals end of txn
@ -371,28 +358,28 @@ accountWizard PrevInput{..} EntryState{..} = do
parseAccountOrDotOrNull def@(_:_) _ "" = dbg' $ Just $ Just def -- when there's a default, "" means use that parseAccountOrDotOrNull def@(_:_) _ "" = dbg' $ Just $ Just def -- when there's a default, "" means use that
parseAccountOrDotOrNull _ _ s = dbg' $ fmap (Just . T.unpack) $ parseAccountOrDotOrNull _ _ s = dbg' $ fmap (Just . T.unpack) $
either (const Nothing) validateAccount $ either (const Nothing) validateAccount $
flip evalState esJournal $ runParserT (accountnamep <* eof) "" (T.pack s) -- otherwise, try to parse the input as an accountname flip evalState asJournal $ runParserT (accountnamep <* eof) "" (T.pack s) -- otherwise, try to parse the input state an accountname
where where
validateAccount :: Text -> Maybe Text validateAccount :: Text -> Maybe Text
validateAccount t | no_new_accounts_ esOpts && notElem t (journalAccountNamesDeclaredOrImplied esJournal) = Nothing validateAccount t | no_new_accounts_ asOpts && notElem t (journalAccountNamesDeclaredOrImplied asJournal) = Nothing
| otherwise = Just t | otherwise = Just t
dbg' = id -- strace dbg' = id -- strace
type Comment = (Text, [Tag], Maybe Day, Maybe Day) -- | Interact with the user to get an amount and/or a balance assertion, maybe followed by a "; COMMENT".
-- Returns the amount, balance assertion, and/or comment, or nothing if the input is "<".
amountAndCommentWizard :: PrevInput -> EntryState -> Wizard Haskeline (Maybe (Maybe Amount, Maybe BalanceAssertion, Comment)) amountWizard :: PrevInput -> AddState -> Wizard Haskeline (Maybe (Maybe Amount, Maybe BalanceAssertion, Comment))
amountAndCommentWizard previnput@PrevInput{..} entrystate@EntryState{..} = do amountWizard previnput@PrevInput{..} state@AddState{..} = do
let pnum = length esPostings + 1 let pnum = length asPostings + 1
(mhistoricalp,followedhistoricalsofar) = (mhistoricalp,followedhistoricalsofar) =
case esSimilarTransaction of case asSimilarTransaction of
Nothing -> (Nothing,False) Nothing -> (Nothing,False)
Just Transaction{tpostings=ps} -> Just Transaction{tpostings=ps} ->
( if length ps >= pnum then Just (ps !! (pnum-1)) else Nothing ( if length ps >= pnum then Just (ps !! (pnum-1)) else Nothing
, all sameamount $ zip esPostings ps , all sameamount $ zip asPostings ps
) )
where where
sameamount (p1,p2) = mixedAmountUnstyled (pamount p1) == mixedAmountUnstyled (pamount p2) sameamount (p1,p2) = mixedAmountUnstyled (pamount p1) == mixedAmountUnstyled (pamount p2)
def | (d:_) <- esArgs = d def | (d:_) <- asArgs = d
| Just hp <- mhistoricalp, followedhistoricalsofar = showamt $ pamount hp | Just hp <- mhistoricalp, followedhistoricalsofar = showamt $ pamount hp
| pnum > 1 && not (mixedAmountLooksZero balancingamt) = showamt balancingamtfirstcommodity | pnum > 1 && not (mixedAmountLooksZero balancingamt) = showamt balancingamtfirstcommodity
| otherwise = "" | otherwise = ""
@ -401,14 +388,14 @@ amountAndCommentWizard previnput@PrevInput{..} entrystate@EntryState{..} = do
withCompletion (amountCompleter def) $ withCompletion (amountCompleter def) $
defaultTo' def $ defaultTo' def $
nonEmpty $ nonEmpty $
linePrewritten' (green' $ printf "Amount %d%s: " pnum (showDefault def)) (fromMaybe "" $ prevAmountAndCmnt `atMay` length esPostings) "" linePrewritten' (green' $ printf "Amount %d%s: " pnum (showDefault def)) (fromMaybe "" $ prevAmountAndCmnt `atMay` length asPostings) ""
where where
-- Custom parser that combines with Wizard to use IO via outputLn -- Custom parser that combines with Wizard to use IO via outputLn
parser' f a = a >>= \input -> parser' f a = a >>= \input ->
case f input of case f input of
Left err -> do Left err -> do
outputLn (customErrorBundlePretty err) outputLn (customErrorBundlePretty err)
amountAndCommentWizard previnput entrystate amountWizard previnput state
Right res -> pure res Right res -> pure res
parseAmountAndComment s = parseAmountAndComment s =
if s == "<" then Right Nothing else if s == "<" then Right Nothing else
@ -416,18 +403,18 @@ amountAndCommentWizard previnput@PrevInput{..} entrystate@EntryState{..} = do
(evalStateT (amountandcommentp <* eof) nodefcommodityj) (evalStateT (amountandcommentp <* eof) nodefcommodityj)
"" ""
(T.pack s) (T.pack s)
nodefcommodityj = esJournal{jparsedefaultcommodity=Nothing} nodefcommodityj = asJournal{jparsedefaultcommodity=Nothing}
amountandcommentp :: JournalParser Identity (Maybe Amount, Maybe BalanceAssertion, Comment) amountandcommentp :: JournalParser Identity (Maybe Amount, Maybe BalanceAssertion, Comment)
amountandcommentp = do amountandcommentp = do
mamt <- optional amountp mamt <- optional amountp
lift skipNonNewlineSpaces lift skipNonNewlineSpaces
massertion <- optional balanceassertionp massertion <- optional balanceassertionp
com <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle) com <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle)
case rtp (postingcommentp (let (y,_,_) = toGregorian esDefDate in Just y)) (T.cons ';' com) of case rtp (postingcommentp (let (y,_,_) = toGregorian asDefDate in Just y)) (T.cons ';' com) of
Left err -> fail $ customErrorBundlePretty err Left err -> fail $ customErrorBundlePretty err
-- Keep our original comment string from the user to add to the journal -- Keep our original comment string from the user to add to the journal
Right (_, tags, date1', date2') -> return $ (mamt, massertion, (com, tags, date1', date2')) Right (_, tags, date1', date2') -> return $ (mamt, massertion, (com, tags, date1', date2'))
balancingamt = maNegate . sumPostings $ filter isReal esPostings balancingamt = maNegate . sumPostings $ filter isReal asPostings
balancingamtfirstcommodity = mixed . take 1 $ amounts balancingamt balancingamtfirstcommodity = mixed . take 1 $ amounts balancingamt
showamt = wbUnpack . showMixedAmountB defaultFmt . mixedAmountSetPrecision showamt = wbUnpack . showMixedAmountB defaultFmt . mixedAmountSetPrecision
-- what should this be ? -- what should this be ?
@ -440,20 +427,14 @@ amountAndCommentWizard previnput@PrevInput{..} entrystate@EntryState{..} = do
NaturalPrecision NaturalPrecision
-- --
-- let -- (amt,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amtcmt -- let -- (amt,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amtcmt
-- a = fromparse $ runParser (amountp <|> return missingamt) (jparsestate esJournal) "" amt -- a = fromparse $ runParser (amountp <|> return missingamt) (jparsestate asJournal) "" amt
-- awithoutjps = fromparse $ runParser (amountp <|> return missingamt) mempty "" amt -- awithoutjps = fromparse $ runParser (amountp <|> return missingamt) mempty "" amt
-- defamtaccepted = Just (showAmount a) == mdefamt -- defamtaccepted = Just (showAmount a) == mdefamt
-- es2 = if defamtaccepted then es1 else es1{esHistoricalPostings=Nothing} -- as2 = if defamtaccepted then as1 else as1{asHistoricalPostings=Nothing}
-- mdefaultcommodityapplied = if acommodity a == acommodity awithoutjps then Nothing else Just $ acommodity a -- mdefaultcommodityapplied = if acommodity a == acommodity awithoutjps then Nothing else Just $ acommodity a
-- when (isJust mdefaultcommodityapplied) $ -- when (isJust mdefaultcommodityapplied) $
-- liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust mdefaultcommodityapplied) -- liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust mdefaultcommodityapplied)
maybeExit = parser (\s -> if s=="." then throw UnexpectedEOF else Just s)
-- maybeShowHelp :: Wizard Haskeline String -> Wizard Haskeline String
-- maybeShowHelp wizard = maybe (liftIO showHelp >> wizard) return $
-- parser (\s -> if s=="?" then Nothing else Just s) wizard
-- Completion helpers -- Completion helpers
dateCompleter :: String -> CompletionFunc IO dateCompleter :: String -> CompletionFunc IO
@ -488,6 +469,17 @@ completer completions def = completeWord Nothing "" completionsFor
-- utilities -- utilities
maybeExit = parser (\s -> if s == "." then throw UnexpectedEOF else Just s)
-- maybeShowHelp :: Wizard Haskeline String -> Wizard Haskeline String
-- maybeShowHelp wizard = maybe (liftIO showHelp >> wizard) return $
-- parser (\s -> if s=="?" then Nothing else Just s) wizard
-- | A workaround we seem to need for #2410 right now: wizards' input-reading functions disrupt ANSI codes
-- somehow, so these variants first print the ANSI coded prompt state ordinary output, then do the input with no prompt.
line' prompt = output prompt >> line ""
linePrewritten' prompt beforetxt aftertxt = output prompt >> linePrewritten "" beforetxt aftertxt
defaultTo' = flip defaultTo defaultTo' = flip defaultTo
withCompletion f = withSettings (setComplete f defaultSettings) withCompletion f = withSettings (setComplete f defaultSettings)
@ -495,6 +487,25 @@ withCompletion f = withSettings (setComplete f defaultSettings)
showDefault "" = "" showDefault "" = ""
showDefault s = " [" ++ s ++ "]" showDefault s = " [" ++ s ++ "]"
-- | Balance and check a transaction with awareness of the whole journal it will be added to.
-- This means add it to the journal, balance it, calculate any balance assignments in it,
-- then maybe check all the journal's balance assertions,
-- then return the now fully balanced and checked transaction, or an error message.
balanceTransactionInJournal :: Transaction -> Journal -> BalancingOpts -> Either String Transaction
balanceTransactionInJournal t j bopts = do
-- Add the transaction at the end of the journal, state the add command will.
let j' = j{jtxns = jtxns j ++ [t]}
-- Try to balance and check the whole journal, and specifically the new transaction.
Journal{jtxns=ts} <- journalBalanceTransactions bopts j'
-- Extract the balanced & checked transaction.
maybe
(Left "transactionWizard: unexpected empty journal") -- should not happen
Right
(lastMay ts)
postingsAreBalanced :: [Posting] -> Bool
postingsAreBalanced ps = isRight $ balanceSingleTransaction defbalancingopts nulltransaction{tpostings = ps}
-- | Append this transaction to the journal's file and transaction list. -- | Append this transaction to the journal's file and transaction list.
journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal
journalAddTransaction j@Journal{jtxns=ts} opts t = do journalAddTransaction j@Journal{jtxns=ts} opts t = do