{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings, PackageImports #-}
{-# LANGUAGE TemplateHaskell #-}
module Hledger.Cli.Commands.Add (
addmode
,add
,appendToJournalFileOrStdout
,journalAddTransaction
,transactionsSimilarTo
)
where
import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (fail)
import Control.Exception as E
import Control.Monad (when)
import Control.Monad.Trans.Class
import Control.Monad.State.Strict (evalState, evalStateT)
import Control.Monad.Trans (liftIO)
import Data.Char (toUpper, toLower)
import Data.Functor.Identity (Identity(..))
import "base-compat-batteries" Data.List.Compat
import qualified Data.Set as S
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day)
import Data.Typeable (Typeable)
import Safe (headDef, headMay)
import System.Console.CmdArgs.Explicit
import System.Console.Haskeline (runInputT, defaultSettings, setComplete)
import System.Console.Haskeline.Completion
import System.Console.Wizard
import System.Console.Wizard.Haskeline
import System.IO ( stderr, hPutStr, hPutStrLn )
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Printf
import Hledger
import Hledger.Cli.CliOptions
import Hledger.Cli.Commands.Register (postingsReportAsText)
addmode :: Mode RawOpts
addmode = CommandDoc
-> [Flag RawOpts]
-> [(CommandDoc, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode
$(embedFileRelative "Hledger/Cli/Commands/Add.txt")
[[CommandDoc] -> (RawOpts -> RawOpts) -> CommandDoc -> Flag RawOpts
forall a. [CommandDoc] -> (a -> a) -> CommandDoc -> Flag a
flagNone ["no-new-accounts"] (CommandDoc -> RawOpts -> RawOpts
setboolopt "no-new-accounts") "don't allow creating new accounts"]
[(CommandDoc, [Flag RawOpts])
generalflagsgroup2]
[]
([], Arg RawOpts -> Maybe (Arg RawOpts)
forall a. a -> Maybe a
Just (Arg RawOpts -> Maybe (Arg RawOpts))
-> Arg RawOpts -> Maybe (Arg RawOpts)
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Arg RawOpts
argsFlag "[QUERY]")
data EntryState = EntryState {
EntryState -> CliOpts
esOpts :: CliOpts
,EntryState -> [CommandDoc]
esArgs :: [String]
,EntryState -> Day
esToday :: Day
,EntryState -> Day
esDefDate :: Day
,EntryState -> Journal
esJournal :: Journal
,EntryState -> Maybe Transaction
esSimilarTransaction :: Maybe Transaction
,EntryState -> [Posting]
esPostings :: [Posting]
} deriving (Int -> EntryState -> CommandDoc -> CommandDoc
[EntryState] -> CommandDoc -> CommandDoc
EntryState -> CommandDoc
(Int -> EntryState -> CommandDoc -> CommandDoc)
-> (EntryState -> CommandDoc)
-> ([EntryState] -> CommandDoc -> CommandDoc)
-> Show EntryState
forall a.
(Int -> a -> CommandDoc -> CommandDoc)
-> (a -> CommandDoc) -> ([a] -> CommandDoc -> CommandDoc) -> Show a
showList :: [EntryState] -> CommandDoc -> CommandDoc
$cshowList :: [EntryState] -> CommandDoc -> CommandDoc
show :: EntryState -> CommandDoc
$cshow :: EntryState -> CommandDoc
showsPrec :: Int -> EntryState -> CommandDoc -> CommandDoc
$cshowsPrec :: Int -> EntryState -> CommandDoc -> CommandDoc
Show,Typeable)
defEntryState :: EntryState
defEntryState = EntryState :: CliOpts
-> [CommandDoc]
-> Day
-> Day
-> Journal
-> Maybe Transaction
-> [Posting]
-> EntryState
EntryState {
esOpts :: CliOpts
esOpts = CliOpts
defcliopts
,esArgs :: [CommandDoc]
esArgs = []
,esToday :: Day
esToday = Day
nulldate
,esDefDate :: Day
esDefDate = Day
nulldate
,esJournal :: Journal
esJournal = Journal
nulljournal
,esSimilarTransaction :: Maybe Transaction
esSimilarTransaction = Maybe Transaction
forall a. Maybe a
Nothing
,esPostings :: [Posting]
esPostings = []
}
data RestartTransactionException = RestartTransactionException deriving (Typeable,Int -> RestartTransactionException -> CommandDoc -> CommandDoc
[RestartTransactionException] -> CommandDoc -> CommandDoc
RestartTransactionException -> CommandDoc
(Int -> RestartTransactionException -> CommandDoc -> CommandDoc)
-> (RestartTransactionException -> CommandDoc)
-> ([RestartTransactionException] -> CommandDoc -> CommandDoc)
-> Show RestartTransactionException
forall a.
(Int -> a -> CommandDoc -> CommandDoc)
-> (a -> CommandDoc) -> ([a] -> CommandDoc -> CommandDoc) -> Show a
showList :: [RestartTransactionException] -> CommandDoc -> CommandDoc
$cshowList :: [RestartTransactionException] -> CommandDoc -> CommandDoc
show :: RestartTransactionException -> CommandDoc
$cshow :: RestartTransactionException -> CommandDoc
showsPrec :: Int -> RestartTransactionException -> CommandDoc -> CommandDoc
$cshowsPrec :: Int -> RestartTransactionException -> CommandDoc -> CommandDoc
Show)
instance Exception RestartTransactionException
add :: CliOpts -> Journal -> IO ()
add :: CliOpts -> Journal -> IO ()
add opts :: CliOpts
opts j :: Journal
j
| Journal -> CommandDoc
journalFilePath Journal
j CommandDoc -> CommandDoc -> Bool
forall a. Eq a => a -> a -> Bool
== "-" = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
Handle -> CommandDoc -> CommandDoc -> IO ()
forall r. HPrintfType r => Handle -> CommandDoc -> r
hPrintf Handle
stderr "Adding transactions to journal file %s\n" (Journal -> CommandDoc
journalFilePath Journal
j)
IO ()
showHelp
Day
today <- IO Day
getCurrentDay
let es :: EntryState
es = EntryState
defEntryState{esOpts :: CliOpts
esOpts=CliOpts
opts
,esArgs :: [CommandDoc]
esArgs=CommandDoc -> RawOpts -> [CommandDoc]
listofstringopt "args" (RawOpts -> [CommandDoc]) -> RawOpts -> [CommandDoc]
forall a b. (a -> b) -> a -> b
$ CliOpts -> RawOpts
rawopts_ CliOpts
opts
,esToday :: Day
esToday=Day
today
,esDefDate :: Day
esDefDate=Day
today
,esJournal :: Journal
esJournal=Journal
j
}
EntryState -> IO ()
getAndAddTransactions EntryState
es IO () -> (UnexpectedEOF -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\(UnexpectedEOF
_::UnexpectedEOF) -> CommandDoc -> IO ()
putStr "")
showHelp :: IO ()
showHelp = Handle -> CommandDoc -> IO ()
hPutStr Handle
stderr (CommandDoc -> IO ()) -> CommandDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [CommandDoc] -> CommandDoc
unlines [
"Any command line arguments will be used as defaults."
,"Use tab key to complete, readline keys to edit, enter to accept defaults."
,"An optional (CODE) may follow transaction dates."
,"An optional ; COMMENT may follow descriptions or amounts."
,"If you make a mistake, enter < at any prompt to restart the transaction."
,"To end a transaction, enter . when prompted."
,"To quit, enter . at a date prompt or press control-d or control-c."
]
getAndAddTransactions :: EntryState -> IO ()
getAndAddTransactions :: EntryState -> IO ()
getAndAddTransactions es :: EntryState
es@EntryState{..} = (do
Maybe Transaction
mt <- Settings IO
-> InputT IO (Maybe Transaction) -> IO (Maybe Transaction)
forall (m :: * -> *) a.
MonadException m =>
Settings m -> InputT m a -> m a
runInputT (CompletionFunc IO -> Settings IO -> Settings IO
forall (m :: * -> *). CompletionFunc m -> Settings m -> Settings m
setComplete CompletionFunc IO
forall (m :: * -> *). Monad m => CompletionFunc m
noCompletion Settings IO
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings) (Wizard Haskeline Transaction -> InputT IO (Maybe Transaction)
forall (f :: * -> *) (b :: * -> *) a.
(Functor f, Monad b, Run b f) =>
Wizard f a -> b (Maybe a)
System.Console.Wizard.run (Wizard Haskeline Transaction -> InputT IO (Maybe Transaction))
-> Wizard Haskeline Transaction -> InputT IO (Maybe Transaction)
forall a b. (a -> b) -> a -> b
$ Wizard Haskeline Transaction -> Wizard Haskeline Transaction
forall a. Wizard Haskeline a -> Wizard Haskeline a
haskeline (Wizard Haskeline Transaction -> Wizard Haskeline Transaction)
-> Wizard Haskeline Transaction -> Wizard Haskeline Transaction
forall a b. (a -> b) -> a -> b
$ EntryState -> Wizard Haskeline Transaction
confirmedTransactionWizard EntryState
es)
case Maybe Transaction
mt of
Nothing -> CommandDoc -> IO ()
forall a. HasCallStack => CommandDoc -> a
error "Could not interpret the input, restarting"
Just t :: Transaction
t -> do
Journal
j <- if CliOpts -> Int
debug_ CliOpts
esOpts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0
then do Handle -> CommandDoc -> IO ()
forall r. HPrintfType r => Handle -> CommandDoc -> r
hPrintf Handle
stderr "Skipping journal add due to debug mode.\n"
Journal -> IO Journal
forall (m :: * -> *) a. Monad m => a -> m a
return Journal
esJournal
else do Journal
j' <- Journal -> CliOpts -> Transaction -> IO Journal
journalAddTransaction Journal
esJournal CliOpts
esOpts Transaction
t
Handle -> CommandDoc -> IO ()
forall r. HPrintfType r => Handle -> CommandDoc -> r
hPrintf Handle
stderr "Saved.\n"
Journal -> IO Journal
forall (m :: * -> *) a. Monad m => a -> m a
return Journal
j'
Handle -> CommandDoc -> IO ()
forall r. HPrintfType r => Handle -> CommandDoc -> r
hPrintf Handle
stderr "Starting the next transaction (. or ctrl-D/ctrl-C to quit)\n"
EntryState -> IO ()
getAndAddTransactions EntryState
es{esJournal :: Journal
esJournal=Journal
j, esDefDate :: Day
esDefDate=Transaction -> Day
tdate Transaction
t}
)
IO () -> (RestartTransactionException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` (\(RestartTransactionException
_::RestartTransactionException) ->
Handle -> CommandDoc -> IO ()
forall r. HPrintfType r => Handle -> CommandDoc -> r
hPrintf Handle
stderr "Restarting this transaction.\n" IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EntryState -> IO ()
getAndAddTransactions EntryState
es)
confirmedTransactionWizard :: EntryState -> Wizard Haskeline Transaction
confirmedTransactionWizard es :: EntryState
es@EntryState{..} = do
Transaction
t <- EntryState -> Wizard Haskeline Transaction
transactionWizard EntryState
es
CommandDoc -> Wizard Haskeline ()
forall (b :: * -> *). (Output :<: b) => CommandDoc -> Wizard b ()
output (CommandDoc -> Wizard Haskeline ())
-> CommandDoc -> Wizard Haskeline ()
forall a b. (a -> b) -> a -> b
$ Transaction -> CommandDoc
showTransaction Transaction
t
Bool
y <- let def :: CommandDoc
def = "y" in
CommandDoc -> Wizard Haskeline Bool -> Wizard Haskeline Bool
forall (b :: * -> *) a.
(OutputLn :<: b) =>
CommandDoc -> Wizard b a -> Wizard b a
retryMsg "Please enter y or n." (Wizard Haskeline Bool -> Wizard Haskeline Bool)
-> Wizard Haskeline Bool -> Wizard Haskeline Bool
forall a b. (a -> b) -> a -> b
$
(CommandDoc -> Maybe Bool)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline Bool
forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser (((Char -> Bool) -> Maybe Char -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ('y' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==)) (Maybe Char -> Maybe Bool)
-> (CommandDoc -> Maybe Char) -> CommandDoc -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandDoc -> Maybe Char
forall a. [a] -> Maybe a
headMay (CommandDoc -> Maybe Char)
-> (CommandDoc -> CommandDoc) -> CommandDoc -> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (CommandDoc -> CommandDoc)
-> (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandDoc -> CommandDoc
strip) (Wizard Haskeline CommandDoc -> Wizard Haskeline Bool)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline Bool
forall a b. (a -> b) -> a -> b
$
CommandDoc
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a. a -> Wizard Haskeline a -> Wizard Haskeline a
defaultTo' CommandDoc
def (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$ Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a. Functor b => Wizard b [a] -> Wizard b [a]
nonEmpty (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
maybeRestartTransaction (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *).
(Line :<: b) =>
CommandDoc -> Wizard b CommandDoc
line (CommandDoc -> Wizard Haskeline CommandDoc)
-> CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
green (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc -> CommandDoc
forall r. PrintfType r => CommandDoc -> r
printf "Save this transaction to the journal ?%s: " (CommandDoc -> CommandDoc
showDefault CommandDoc
def)
if Bool
y then Transaction -> Wizard Haskeline Transaction
forall (m :: * -> *) a. Monad m => a -> m a
return Transaction
t else RestartTransactionException -> Wizard Haskeline Transaction
forall a e. Exception e => e -> a
throw RestartTransactionException
RestartTransactionException
transactionWizard :: EntryState -> Wizard Haskeline Transaction
transactionWizard es :: EntryState
es@EntryState{..} = do
(date :: Day
date,code :: Text
code) <- EntryState -> Wizard Haskeline (Day, Text)
dateAndCodeWizard EntryState
es
let es1 :: EntryState
es1@EntryState{esArgs :: EntryState -> [CommandDoc]
esArgs=[CommandDoc]
args1} = EntryState
es{esArgs :: [CommandDoc]
esArgs=Int -> [CommandDoc] -> [CommandDoc]
forall a. Int -> [a] -> [a]
drop 1 [CommandDoc]
esArgs, esDefDate :: Day
esDefDate=Day
date}
(desc :: Text
desc,comment :: Text
comment) <- EntryState -> Wizard Haskeline (Text, Text)
descriptionAndCommentWizard EntryState
es1
let mbaset :: Maybe Transaction
mbaset = EntryState -> Text -> Maybe Transaction
similarTransaction EntryState
es1 Text
desc
Bool -> Wizard Haskeline () -> Wizard Haskeline ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Transaction -> Bool
forall a. Maybe a -> Bool
isJust Maybe Transaction
mbaset) (Wizard Haskeline () -> Wizard Haskeline ())
-> Wizard Haskeline () -> Wizard Haskeline ()
forall a b. (a -> b) -> a -> b
$ IO () -> Wizard Haskeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Wizard Haskeline ()) -> IO () -> Wizard Haskeline ()
forall a b. (a -> b) -> a -> b
$ Handle -> CommandDoc -> CommandDoc -> IO ()
forall r. HPrintfType r => Handle -> CommandDoc -> r
hPrintf Handle
stderr "Using this similar transaction for defaults:\n%s" (Transaction -> CommandDoc
showTransaction (Transaction -> CommandDoc) -> Transaction -> CommandDoc
forall a b. (a -> b) -> a -> b
$ Maybe Transaction -> Transaction
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Transaction
mbaset)
let es2 :: EntryState
es2 = EntryState
es1{esArgs :: [CommandDoc]
esArgs=Int -> [CommandDoc] -> [CommandDoc]
forall a. Int -> [a] -> [a]
drop 1 [CommandDoc]
args1, esSimilarTransaction :: Maybe Transaction
esSimilarTransaction=Maybe Transaction
mbaset}
balancedPostingsWizard :: Wizard Haskeline Transaction
balancedPostingsWizard = do
[Posting]
ps <- EntryState -> Wizard Haskeline [Posting]
postingsWizard EntryState
es2{esPostings :: [Posting]
esPostings=[]}
let t :: Transaction
t = Transaction
nulltransaction{tdate :: Day
tdate=Day
date
,tstatus :: Status
tstatus=Status
Unmarked
,tcode :: Text
tcode=Text
code
,tdescription :: Text
tdescription=Text
desc
,tcomment :: Text
tcomment=Text
comment
,tpostings :: [Posting]
tpostings=[Posting]
ps
}
case Maybe (Map Text AmountStyle)
-> Transaction -> Either CommandDoc Transaction
balanceTransaction Maybe (Map Text AmountStyle)
forall a. Maybe a
Nothing Transaction
t of
Right t' :: Transaction
t' -> Transaction -> Wizard Haskeline Transaction
forall (m :: * -> *) a. Monad m => a -> m a
return Transaction
t'
Left err :: CommandDoc
err -> IO () -> Wizard Haskeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> CommandDoc -> IO ()
hPutStrLn Handle
stderr (CommandDoc -> IO ()) -> CommandDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ "\n" CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++ (CommandDoc -> CommandDoc
capitalize CommandDoc
err) CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++ "please re-enter.") Wizard Haskeline ()
-> Wizard Haskeline Transaction -> Wizard Haskeline Transaction
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Wizard Haskeline Transaction
balancedPostingsWizard
Wizard Haskeline Transaction
balancedPostingsWizard
similarTransaction :: EntryState -> Text -> Maybe Transaction
similarTransaction :: EntryState -> Text -> Maybe Transaction
similarTransaction EntryState{..} desc :: Text
desc =
let q :: Query
q = Day -> ReportOpts -> Query
queryFromOptsOnly Day
esToday (ReportOpts -> Query) -> ReportOpts -> Query
forall a b. (a -> b) -> a -> b
$ CliOpts -> ReportOpts
reportopts_ CliOpts
esOpts
historymatches :: [(Double, Transaction)]
historymatches = Journal -> Query -> Text -> [(Double, Transaction)]
transactionsSimilarTo Journal
esJournal Query
q Text
desc
bestmatch :: Maybe Transaction
bestmatch | [(Double, Transaction)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Double, Transaction)]
historymatches = Maybe Transaction
forall a. Maybe a
Nothing
| Bool
otherwise = Transaction -> Maybe Transaction
forall a. a -> Maybe a
Just (Transaction -> Maybe Transaction)
-> Transaction -> Maybe Transaction
forall a b. (a -> b) -> a -> b
$ (Double, Transaction) -> Transaction
forall a b. (a, b) -> b
snd ((Double, Transaction) -> Transaction)
-> (Double, Transaction) -> Transaction
forall a b. (a -> b) -> a -> b
$ [(Double, Transaction)] -> (Double, Transaction)
forall a. [a] -> a
head [(Double, Transaction)]
historymatches
in Maybe Transaction
bestmatch
dateAndCodeWizard :: EntryState -> Wizard Haskeline (Day, Text)
dateAndCodeWizard EntryState{..} = do
let def :: CommandDoc
def = CommandDoc -> [CommandDoc] -> CommandDoc
forall a. a -> [a] -> a
headDef (Day -> CommandDoc
showDate Day
esDefDate) [CommandDoc]
esArgs
CommandDoc
-> Wizard Haskeline (Day, Text) -> Wizard Haskeline (Day, Text)
forall (b :: * -> *) a.
(OutputLn :<: b) =>
CommandDoc -> Wizard b a -> Wizard b a
retryMsg "A valid hledger smart date is required. Eg: 2014/2/14, 14, yesterday." (Wizard Haskeline (Day, Text) -> Wizard Haskeline (Day, Text))
-> Wizard Haskeline (Day, Text) -> Wizard Haskeline (Day, Text)
forall a b. (a -> b) -> a -> b
$
(CommandDoc -> Maybe (Day, Text))
-> Wizard Haskeline CommandDoc -> Wizard Haskeline (Day, Text)
forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser (Day -> CommandDoc -> Maybe (Day, Text)
parseSmartDateAndCode Day
esToday) (Wizard Haskeline CommandDoc -> Wizard Haskeline (Day, Text))
-> Wizard Haskeline CommandDoc -> Wizard Haskeline (Day, Text)
forall a b. (a -> b) -> a -> b
$
CompletionFunc IO
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a.
(WithSettings :<: b) =>
CompletionFunc IO -> Wizard b a -> Wizard b a
withCompletion (CommandDoc -> CompletionFunc IO
dateCompleter CommandDoc
def) (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CommandDoc
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a. a -> Wizard Haskeline a -> Wizard Haskeline a
defaultTo' CommandDoc
def (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$ Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a. Functor b => Wizard b [a] -> Wizard b [a]
nonEmpty (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
maybeExit (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
maybeRestartTransaction (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *).
(Line :<: b) =>
CommandDoc -> Wizard b CommandDoc
line (CommandDoc -> Wizard Haskeline CommandDoc)
-> CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
green (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc -> CommandDoc
forall r. PrintfType r => CommandDoc -> r
printf "Date%s: " (CommandDoc -> CommandDoc
showDefault CommandDoc
def)
where
parseSmartDateAndCode :: Day -> CommandDoc -> Maybe (Day, Text)
parseSmartDateAndCode refdate :: Day
refdate s :: CommandDoc
s = (ParseErrorBundle Text CustomErr -> Maybe (Day, Text))
-> ((SmartDate, Text) -> Maybe (Day, Text))
-> Either (ParseErrorBundle Text CustomErr) (SmartDate, Text)
-> Maybe (Day, Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Day, Text)
-> ParseErrorBundle Text CustomErr -> Maybe (Day, Text)
forall a b. a -> b -> a
const Maybe (Day, Text)
forall a. Maybe a
Nothing) (\(d :: SmartDate
d,c :: Text
c) -> (Day, Text) -> Maybe (Day, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Day -> SmartDate -> Day
fixSmartDate Day
refdate SmartDate
d, Text
c)) Either (ParseErrorBundle Text CustomErr) (SmartDate, Text)
edc
where
edc :: Either (ParseErrorBundle Text CustomErr) (SmartDate, Text)
edc = Parsec CustomErr Text (SmartDate, Text)
-> CommandDoc
-> Text
-> Either (ParseErrorBundle Text CustomErr) (SmartDate, Text)
forall e s a.
Parsec e s a -> CommandDoc -> s -> Either (ParseErrorBundle s e) a
runParser (Parsec CustomErr Text (SmartDate, Text)
dateandcodep Parsec CustomErr Text (SmartDate, Text)
-> ParsecT CustomErr Text Identity ()
-> Parsec CustomErr Text (SmartDate, Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) "" (Text
-> Either (ParseErrorBundle Text CustomErr) (SmartDate, Text))
-> Text
-> Either (ParseErrorBundle Text CustomErr) (SmartDate, Text)
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Text
T.pack (CommandDoc -> Text) -> CommandDoc -> Text
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
lowercase CommandDoc
s
dateandcodep :: SimpleTextParser (SmartDate, Text)
dateandcodep :: Parsec CustomErr Text (SmartDate, Text)
dateandcodep = do
SmartDate
d <- TextParser Identity SmartDate
forall (m :: * -> *). TextParser m SmartDate
smartdate
Maybe Text
c <- ParsecT CustomErr Text Identity Text
-> ParsecT CustomErr Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT CustomErr Text Identity Text
forall (m :: * -> *). TextParser m Text
codep
ParsecT CustomErr Text Identity Char
-> ParsecT CustomErr Text Identity ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany ParsecT CustomErr Text Identity Char
forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT CustomErr s m Char
spacenonewline
ParsecT CustomErr Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
(SmartDate, Text) -> Parsec CustomErr Text (SmartDate, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (SmartDate
d, Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe "" Maybe Text
c)
descriptionAndCommentWizard :: EntryState -> Wizard Haskeline (Text, Text)
descriptionAndCommentWizard EntryState{..} = do
let def :: CommandDoc
def = CommandDoc -> [CommandDoc] -> CommandDoc
forall a. a -> [a] -> a
headDef "" [CommandDoc]
esArgs
CommandDoc
s <- CompletionFunc IO
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a.
(WithSettings :<: b) =>
CompletionFunc IO -> Wizard b a -> Wizard b a
withCompletion (Journal -> CommandDoc -> CompletionFunc IO
descriptionCompleter Journal
esJournal CommandDoc
def) (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CommandDoc
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a. a -> Wizard Haskeline a -> Wizard Haskeline a
defaultTo' CommandDoc
def (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$ Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a. Functor b => Wizard b [a] -> Wizard b [a]
nonEmpty (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
maybeRestartTransaction (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *).
(Line :<: b) =>
CommandDoc -> Wizard b CommandDoc
line (CommandDoc -> Wizard Haskeline CommandDoc)
-> CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
green (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc -> CommandDoc
forall r. PrintfType r => CommandDoc -> r
printf "Description%s: " (CommandDoc -> CommandDoc
showDefault CommandDoc
def)
let (desc :: Text
desc,comment :: Text
comment) = (CommandDoc -> Text
T.pack (CommandDoc -> Text) -> CommandDoc -> Text
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
strip CommandDoc
a, CommandDoc -> Text
T.pack (CommandDoc -> Text) -> CommandDoc -> Text
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
strip (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> CommandDoc -> CommandDoc
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==';') CommandDoc
b) where (a :: CommandDoc
a,b :: CommandDoc
b) = (Char -> Bool) -> CommandDoc -> (CommandDoc, CommandDoc)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==';') CommandDoc
s
(Text, Text) -> Wizard Haskeline (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
desc, Text
comment)
postingsWizard :: EntryState -> Wizard Haskeline [Posting]
postingsWizard es :: EntryState
es@EntryState{..} = do
Maybe Posting
mp <- EntryState -> Wizard Haskeline (Maybe Posting)
postingWizard EntryState
es
case Maybe Posting
mp of Nothing -> [Posting] -> Wizard Haskeline [Posting]
forall (m :: * -> *) a. Monad m => a -> m a
return [Posting]
esPostings
Just p :: Posting
p -> EntryState -> Wizard Haskeline [Posting]
postingsWizard EntryState
es{esArgs :: [CommandDoc]
esArgs=Int -> [CommandDoc] -> [CommandDoc]
forall a. Int -> [a] -> [a]
drop 2 [CommandDoc]
esArgs, esPostings :: [Posting]
esPostings=[Posting]
esPostings[Posting] -> [Posting] -> [Posting]
forall a. [a] -> [a] -> [a]
++[Posting
p]}
postingWizard :: EntryState -> Wizard Haskeline (Maybe Posting)
postingWizard es :: EntryState
es@EntryState{..} = do
CommandDoc
acct <- EntryState -> Wizard Haskeline CommandDoc
accountWizard EntryState
es
if CommandDoc
acct CommandDoc -> [CommandDoc] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [".",""]
then case ([Posting]
esPostings, [Posting] -> Bool
postingsBalanced [Posting]
esPostings) of
([],_) -> IO () -> Wizard Haskeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> CommandDoc -> IO ()
hPutStrLn Handle
stderr "Please enter some postings first.") Wizard Haskeline ()
-> Wizard Haskeline (Maybe Posting)
-> Wizard Haskeline (Maybe Posting)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EntryState -> Wizard Haskeline (Maybe Posting)
postingWizard EntryState
es
(_,False) -> IO () -> Wizard Haskeline ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> CommandDoc -> IO ()
hPutStrLn Handle
stderr "Please enter more postings to balance the transaction.") Wizard Haskeline ()
-> Wizard Haskeline (Maybe Posting)
-> Wizard Haskeline (Maybe Posting)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EntryState -> Wizard Haskeline (Maybe Posting)
postingWizard EntryState
es
(_,True) -> Maybe Posting -> Wizard Haskeline (Maybe Posting)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Posting
forall a. Maybe a
Nothing
else do
let es1 :: EntryState
es1 = EntryState
es{esArgs :: [CommandDoc]
esArgs=Int -> [CommandDoc] -> [CommandDoc]
forall a. Int -> [a] -> [a]
drop 1 [CommandDoc]
esArgs}
(amt :: Amount
amt,comment :: Text
comment) <- EntryState -> Wizard Haskeline (Amount, Text)
amountAndCommentWizard EntryState
es1
Maybe Posting -> Wizard Haskeline (Maybe Posting)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Posting -> Wizard Haskeline (Maybe Posting))
-> Maybe Posting -> Wizard Haskeline (Maybe Posting)
forall a b. (a -> b) -> a -> b
$ Posting -> Maybe Posting
forall a. a -> Maybe a
Just Posting
nullposting{paccount :: Text
paccount=CommandDoc -> Text
T.pack (CommandDoc -> Text) -> CommandDoc -> Text
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
stripbrackets CommandDoc
acct
,pamount :: MixedAmount
pamount=[Amount] -> MixedAmount
Mixed [Amount
amt]
,pcomment :: Text
pcomment=Text
comment
,ptype :: PostingType
ptype=Text -> PostingType
accountNamePostingType (Text -> PostingType) -> Text -> PostingType
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Text
T.pack CommandDoc
acct
}
postingsBalanced :: [Posting] -> Bool
postingsBalanced :: [Posting] -> Bool
postingsBalanced ps :: [Posting]
ps = Either CommandDoc Transaction -> Bool
forall a b. Either a b -> Bool
isRight (Either CommandDoc Transaction -> Bool)
-> Either CommandDoc Transaction -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe (Map Text AmountStyle)
-> Transaction -> Either CommandDoc Transaction
balanceTransaction Maybe (Map Text AmountStyle)
forall a. Maybe a
Nothing Transaction
nulltransaction{tpostings :: [Posting]
tpostings=[Posting]
ps}
accountWizard :: EntryState -> Wizard Haskeline CommandDoc
accountWizard EntryState{..} = do
let pnum :: Int
pnum = [Posting] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Posting]
esPostings Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
historicalp :: Maybe Posting
historicalp = (Transaction -> Posting) -> Maybe Transaction -> Maybe Posting
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Posting] -> Int -> Posting
forall a. [a] -> Int -> a
!! (Int
pnum Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)) ([Posting] -> Posting)
-> (Transaction -> [Posting]) -> Transaction -> Posting
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Posting] -> [Posting] -> [Posting]
forall a. [a] -> [a] -> [a]
++ (Posting -> [Posting]
forall a. a -> [a]
repeat Posting
nullposting)) ([Posting] -> [Posting])
-> (Transaction -> [Posting]) -> Transaction -> [Posting]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction -> [Posting]
tpostings) Maybe Transaction
esSimilarTransaction
historicalacct :: CommandDoc
historicalacct = case Maybe Posting
historicalp of Just p :: Posting
p -> Maybe Int -> PostingType -> Text -> CommandDoc
showAccountName Maybe Int
forall a. Maybe a
Nothing (Posting -> PostingType
ptype Posting
p) (Posting -> Text
paccount Posting
p)
Nothing -> ""
def :: CommandDoc
def = CommandDoc -> [CommandDoc] -> CommandDoc
forall a. a -> [a] -> a
headDef CommandDoc
historicalacct [CommandDoc]
esArgs
endmsg :: CommandDoc
endmsg | Bool
canfinish Bool -> Bool -> Bool
&& CommandDoc -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CommandDoc
def = " (or . or enter to finish this transaction)"
| Bool
canfinish = " (or . to finish this transaction)"
| Bool
otherwise = ""
CommandDoc
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a.
(OutputLn :<: b) =>
CommandDoc -> Wizard b a -> Wizard b a
retryMsg "A valid hledger account name is required. Eg: assets:cash, expenses:food:eating out." (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
(CommandDoc -> Maybe CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser (CommandDoc -> Bool -> CommandDoc -> Maybe CommandDoc
parseAccountOrDotOrNull CommandDoc
def Bool
canfinish) (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CompletionFunc IO
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a.
(WithSettings :<: b) =>
CompletionFunc IO -> Wizard b a -> Wizard b a
withCompletion (Journal -> CommandDoc -> CompletionFunc IO
accountCompleter Journal
esJournal CommandDoc
def) (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CommandDoc
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a. a -> Wizard Haskeline a -> Wizard Haskeline a
defaultTo' CommandDoc
def (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
maybeRestartTransaction (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *).
(Line :<: b) =>
CommandDoc -> Wizard b CommandDoc
line (CommandDoc -> Wizard Haskeline CommandDoc)
-> CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
green (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Int -> CommandDoc -> CommandDoc -> CommandDoc
forall r. PrintfType r => CommandDoc -> r
printf "Account %d%s%s: " Int
pnum (CommandDoc
endmsg::String) (CommandDoc -> CommandDoc
showDefault CommandDoc
def)
where
canfinish :: Bool
canfinish = Bool -> Bool
not ([Posting] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Posting]
esPostings) Bool -> Bool -> Bool
&& [Posting] -> Bool
postingsBalanced [Posting]
esPostings
parseAccountOrDotOrNull :: String -> Bool -> String -> Maybe String
parseAccountOrDotOrNull :: CommandDoc -> Bool -> CommandDoc -> Maybe CommandDoc
parseAccountOrDotOrNull _ _ "." = Maybe CommandDoc -> Maybe CommandDoc
forall a. a -> a
dbg1 (Maybe CommandDoc -> Maybe CommandDoc)
-> Maybe CommandDoc -> Maybe CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Maybe CommandDoc
forall a. a -> Maybe a
Just "."
parseAccountOrDotOrNull "" True "" = Maybe CommandDoc -> Maybe CommandDoc
forall a. a -> a
dbg1 (Maybe CommandDoc -> Maybe CommandDoc)
-> Maybe CommandDoc -> Maybe CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Maybe CommandDoc
forall a. a -> Maybe a
Just ""
parseAccountOrDotOrNull def :: CommandDoc
def@(_:_) _ "" = Maybe CommandDoc -> Maybe CommandDoc
forall a. a -> a
dbg1 (Maybe CommandDoc -> Maybe CommandDoc)
-> Maybe CommandDoc -> Maybe CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Maybe CommandDoc
forall a. a -> Maybe a
Just CommandDoc
def
parseAccountOrDotOrNull _ _ s :: CommandDoc
s = Maybe CommandDoc -> Maybe CommandDoc
forall a. a -> a
dbg1 (Maybe CommandDoc -> Maybe CommandDoc)
-> Maybe CommandDoc -> Maybe CommandDoc
forall a b. (a -> b) -> a -> b
$ (Text -> CommandDoc) -> Maybe Text -> Maybe CommandDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> CommandDoc
T.unpack (Maybe Text -> Maybe CommandDoc) -> Maybe Text -> Maybe CommandDoc
forall a b. (a -> b) -> a -> b
$
(ParseErrorBundle Text CustomErr -> Maybe Text)
-> (Text -> Maybe Text)
-> Either (ParseErrorBundle Text CustomErr) Text
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Text -> ParseErrorBundle Text CustomErr -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing) Text -> Maybe Text
validateAccount (Either (ParseErrorBundle Text CustomErr) Text -> Maybe Text)
-> Either (ParseErrorBundle Text CustomErr) Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$
(State Journal (Either (ParseErrorBundle Text CustomErr) Text)
-> Journal -> Either (ParseErrorBundle Text CustomErr) Text)
-> Journal
-> State Journal (Either (ParseErrorBundle Text CustomErr) Text)
-> Either (ParseErrorBundle Text CustomErr) Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Journal (Either (ParseErrorBundle Text CustomErr) Text)
-> Journal -> Either (ParseErrorBundle Text CustomErr) Text
forall s a. State s a -> s -> a
evalState Journal
esJournal (State Journal (Either (ParseErrorBundle Text CustomErr) Text)
-> Either (ParseErrorBundle Text CustomErr) Text)
-> State Journal (Either (ParseErrorBundle Text CustomErr) Text)
-> Either (ParseErrorBundle Text CustomErr) Text
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text (StateT Journal Identity) Text
-> CommandDoc
-> Text
-> State Journal (Either (ParseErrorBundle Text CustomErr) Text)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> CommandDoc -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (ParsecT CustomErr Text (StateT Journal Identity) Text
forall (m :: * -> *). TextParser m Text
accountnamep ParsecT CustomErr Text (StateT Journal Identity) Text
-> ParsecT CustomErr Text (StateT Journal Identity) ()
-> ParsecT CustomErr Text (StateT Journal Identity) Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text (StateT Journal Identity) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) "" (CommandDoc -> Text
T.pack CommandDoc
s)
where
validateAccount :: Text -> Maybe Text
validateAccount :: Text -> Maybe Text
validateAccount t :: Text
t | CliOpts -> Bool
no_new_accounts_ CliOpts
esOpts Bool -> Bool -> Bool
&& Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem Text
t (Journal -> [Text]
journalAccountNamesDeclaredOrImplied Journal
esJournal) = Maybe Text
forall a. Maybe a
Nothing
| Bool
otherwise = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
dbg1 :: a -> a
dbg1 = a -> a
forall a. a -> a
id
amountAndCommentWizard :: EntryState -> Wizard Haskeline (Amount, Text)
amountAndCommentWizard EntryState{..} = do
let pnum :: Int
pnum = [Posting] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Posting]
esPostings Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
(mhistoricalp :: Maybe Posting
mhistoricalp,followedhistoricalsofar :: Bool
followedhistoricalsofar) =
case Maybe Transaction
esSimilarTransaction of
Nothing -> (Maybe Posting
forall a. Maybe a
Nothing,Bool
False)
Just Transaction{tpostings :: Transaction -> [Posting]
tpostings=[Posting]
ps} -> (if [Posting] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Posting]
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
pnum then Posting -> Maybe Posting
forall a. a -> Maybe a
Just ([Posting]
ps [Posting] -> Int -> Posting
forall a. [a] -> Int -> a
!! (Int
pnumInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)) else Maybe Posting
forall a. Maybe a
Nothing
,((Posting, Posting) -> Bool) -> [(Posting, Posting)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(a :: Posting
a,b :: Posting
b) -> Posting -> MixedAmount
pamount Posting
a MixedAmount -> MixedAmount -> Bool
forall a. Eq a => a -> a -> Bool
== Posting -> MixedAmount
pamount Posting
b) ([(Posting, Posting)] -> Bool) -> [(Posting, Posting)] -> Bool
forall a b. (a -> b) -> a -> b
$ [Posting] -> [Posting] -> [(Posting, Posting)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Posting]
esPostings [Posting]
ps)
def :: CommandDoc
def = case ([CommandDoc]
esArgs, Maybe Posting
mhistoricalp, Bool
followedhistoricalsofar) of
(d :: CommandDoc
d:_,_,_) -> CommandDoc
d
(_,Just hp :: Posting
hp,True) -> MixedAmount -> CommandDoc
showamt (MixedAmount -> CommandDoc) -> MixedAmount -> CommandDoc
forall a b. (a -> b) -> a -> b
$ Posting -> MixedAmount
pamount Posting
hp
_ | Int
pnum Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
&& Bool -> Bool
not (MixedAmount -> Bool
isZeroMixedAmount MixedAmount
balancingamt) -> MixedAmount -> CommandDoc
showamt MixedAmount
balancingamtfirstcommodity
_ -> ""
CommandDoc
-> Wizard Haskeline (Amount, Text)
-> Wizard Haskeline (Amount, Text)
forall (b :: * -> *) a.
(OutputLn :<: b) =>
CommandDoc -> Wizard b a -> Wizard b a
retryMsg "A valid hledger amount is required. Eg: 1, $2, 3 EUR, \"4 red apples\"." (Wizard Haskeline (Amount, Text)
-> Wizard Haskeline (Amount, Text))
-> Wizard Haskeline (Amount, Text)
-> Wizard Haskeline (Amount, Text)
forall a b. (a -> b) -> a -> b
$
(CommandDoc -> Maybe (Amount, Text))
-> Wizard Haskeline CommandDoc -> Wizard Haskeline (Amount, Text)
forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser CommandDoc -> Maybe (Amount, Text)
parseAmountAndComment (Wizard Haskeline CommandDoc -> Wizard Haskeline (Amount, Text))
-> Wizard Haskeline CommandDoc -> Wizard Haskeline (Amount, Text)
forall a b. (a -> b) -> a -> b
$
CompletionFunc IO
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a.
(WithSettings :<: b) =>
CompletionFunc IO -> Wizard b a -> Wizard b a
withCompletion (CommandDoc -> CompletionFunc IO
amountCompleter CommandDoc
def) (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CommandDoc
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a. a -> Wizard Haskeline a -> Wizard Haskeline a
defaultTo' CommandDoc
def (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$ Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a. Functor b => Wizard b [a] -> Wizard b [a]
nonEmpty (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
maybeRestartTransaction (Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$
CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *).
(Line :<: b) =>
CommandDoc -> Wizard b CommandDoc
line (CommandDoc -> Wizard Haskeline CommandDoc)
-> CommandDoc -> Wizard Haskeline CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
green (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Int -> CommandDoc -> CommandDoc
forall r. PrintfType r => CommandDoc -> r
printf "Amount %d%s: " Int
pnum (CommandDoc -> CommandDoc
showDefault CommandDoc
def)
where
parseAmountAndComment :: CommandDoc -> Maybe (Amount, Text)
parseAmountAndComment s :: CommandDoc
s = (ParseErrorBundle Text CustomErr -> Maybe (Amount, Text))
-> ((Amount, Text) -> Maybe (Amount, Text))
-> Either (ParseErrorBundle Text CustomErr) (Amount, Text)
-> Maybe (Amount, Text)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Amount, Text)
-> ParseErrorBundle Text CustomErr -> Maybe (Amount, Text)
forall a b. a -> b -> a
const Maybe (Amount, Text)
forall a. Maybe a
Nothing) (Amount, Text) -> Maybe (Amount, Text)
forall a. a -> Maybe a
Just (Either (ParseErrorBundle Text CustomErr) (Amount, Text)
-> Maybe (Amount, Text))
-> Either (ParseErrorBundle Text CustomErr) (Amount, Text)
-> Maybe (Amount, Text)
forall a b. (a -> b) -> a -> b
$
Parsec CustomErr Text (Amount, Text)
-> CommandDoc
-> Text
-> Either (ParseErrorBundle Text CustomErr) (Amount, Text)
forall e s a.
Parsec e s a -> CommandDoc -> s -> Either (ParseErrorBundle s e) a
runParser
(StateT Journal (ParsecT CustomErr Text Identity) (Amount, Text)
-> Journal -> Parsec CustomErr Text (Amount, Text)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT Journal (ParsecT CustomErr Text Identity) (Amount, Text)
amountandcommentp StateT Journal (ParsecT CustomErr Text Identity) (Amount, Text)
-> StateT Journal (ParsecT CustomErr Text Identity) ()
-> StateT Journal (ParsecT CustomErr Text Identity) (Amount, Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT CustomErr Text Identity) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Journal
nodefcommodityj)
""
(CommandDoc -> Text
T.pack CommandDoc
s)
nodefcommodityj :: Journal
nodefcommodityj = Journal
esJournal{jparsedefaultcommodity :: Maybe (Text, AmountStyle)
jparsedefaultcommodity=Maybe (Text, AmountStyle)
forall a. Maybe a
Nothing}
amountandcommentp :: JournalParser Identity (Amount, Text)
amountandcommentp :: StateT Journal (ParsecT CustomErr Text Identity) (Amount, Text)
amountandcommentp = do
Amount
a <- JournalParser Identity Amount
forall (m :: * -> *). JournalParser m Amount
amountp
ParsecT CustomErr Text Identity ()
-> StateT Journal (ParsecT CustomErr Text Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text Identity Char
-> ParsecT CustomErr Text Identity ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany ParsecT CustomErr Text Identity Char
forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT CustomErr s m Char
spacenonewline)
Text
c <- CommandDoc -> Text
T.pack (CommandDoc -> Text)
-> StateT Journal (ParsecT CustomErr Text Identity) CommandDoc
-> StateT Journal (ParsecT CustomErr Text Identity) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommandDoc -> Maybe CommandDoc -> CommandDoc
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe CommandDoc -> CommandDoc)
-> StateT
Journal (ParsecT CustomErr Text Identity) (Maybe CommandDoc)
-> StateT Journal (ParsecT CustomErr Text Identity) CommandDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT Journal (ParsecT CustomErr Text Identity) CommandDoc
-> StateT
Journal (ParsecT CustomErr Text Identity) (Maybe CommandDoc)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Token Text
-> StateT Journal (ParsecT CustomErr Text Identity) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Token Text
';' StateT Journal (ParsecT CustomErr Text Identity) Char
-> StateT Journal (ParsecT CustomErr Text Identity) CommandDoc
-> StateT Journal (ParsecT CustomErr Text Identity) CommandDoc
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT Journal (ParsecT CustomErr Text Identity) Char
-> StateT Journal (ParsecT CustomErr Text Identity) CommandDoc
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many StateT Journal (ParsecT CustomErr Text Identity) Char
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle)
(Amount, Text)
-> StateT Journal (ParsecT CustomErr Text Identity) (Amount, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Amount
a,Text
c)
balancingamt :: MixedAmount
balancingamt = MixedAmount -> MixedAmount
forall a. Num a => a -> a
negate (MixedAmount -> MixedAmount) -> MixedAmount -> MixedAmount
forall a b. (a -> b) -> a -> b
$ [MixedAmount] -> MixedAmount
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([MixedAmount] -> MixedAmount) -> [MixedAmount] -> MixedAmount
forall a b. (a -> b) -> a -> b
$ (Posting -> MixedAmount) -> [Posting] -> [MixedAmount]
forall a b. (a -> b) -> [a] -> [b]
map Posting -> MixedAmount
pamount [Posting]
realps where realps :: [Posting]
realps = (Posting -> Bool) -> [Posting] -> [Posting]
forall a. (a -> Bool) -> [a] -> [a]
filter Posting -> Bool
isReal [Posting]
esPostings
balancingamtfirstcommodity :: MixedAmount
balancingamtfirstcommodity = [Amount] -> MixedAmount
Mixed ([Amount] -> MixedAmount) -> [Amount] -> MixedAmount
forall a b. (a -> b) -> a -> b
$ Int -> [Amount] -> [Amount]
forall a. Int -> [a] -> [a]
take 1 ([Amount] -> [Amount]) -> [Amount] -> [Amount]
forall a b. (a -> b) -> a -> b
$ MixedAmount -> [Amount]
amounts MixedAmount
balancingamt
showamt :: MixedAmount -> CommandDoc
showamt =
Int -> MixedAmount -> CommandDoc
showMixedAmountWithPrecision
Int
maxprecisionwithpoint
maybeExit :: Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
maybeExit = (CommandDoc -> Maybe CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser (\s :: CommandDoc
s -> if CommandDoc
sCommandDoc -> CommandDoc -> Bool
forall a. Eq a => a -> a -> Bool
=="." then UnexpectedEOF -> Maybe CommandDoc
forall a e. Exception e => e -> a
throw UnexpectedEOF
UnexpectedEOF else CommandDoc -> Maybe CommandDoc
forall a. a -> Maybe a
Just CommandDoc
s)
maybeRestartTransaction :: Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
maybeRestartTransaction = (CommandDoc -> Maybe CommandDoc)
-> Wizard Haskeline CommandDoc -> Wizard Haskeline CommandDoc
forall (b :: * -> *) a c.
Functor b =>
(a -> Maybe c) -> Wizard b a -> Wizard b c
parser (\s :: CommandDoc
s -> if CommandDoc
sCommandDoc -> CommandDoc -> Bool
forall a. Eq a => a -> a -> Bool
=="<" then RestartTransactionException -> Maybe CommandDoc
forall a e. Exception e => e -> a
throw RestartTransactionException
RestartTransactionException else CommandDoc -> Maybe CommandDoc
forall a. a -> Maybe a
Just CommandDoc
s)
dateCompleter :: String -> CompletionFunc IO
dateCompleter :: CommandDoc -> CompletionFunc IO
dateCompleter = [CommandDoc] -> CommandDoc -> CompletionFunc IO
completer ["today","tomorrow","yesterday"]
descriptionCompleter :: Journal -> String -> CompletionFunc IO
descriptionCompleter :: Journal -> CommandDoc -> CompletionFunc IO
descriptionCompleter j :: Journal
j = [CommandDoc] -> CommandDoc -> CompletionFunc IO
completer ((Text -> CommandDoc) -> [Text] -> [CommandDoc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> CommandDoc
T.unpack ([Text] -> [CommandDoc]) -> [Text] -> [CommandDoc]
forall a b. (a -> b) -> a -> b
$ Journal -> [Text]
journalDescriptions Journal
j)
accountCompleter :: Journal -> String -> CompletionFunc IO
accountCompleter :: Journal -> CommandDoc -> CompletionFunc IO
accountCompleter j :: Journal
j = [CommandDoc] -> CommandDoc -> CompletionFunc IO
completer ((Text -> CommandDoc) -> [Text] -> [CommandDoc]
forall a b. (a -> b) -> [a] -> [b]
map Text -> CommandDoc
T.unpack ([Text] -> [CommandDoc]) -> [Text] -> [CommandDoc]
forall a b. (a -> b) -> a -> b
$ Journal -> [Text]
journalAccountNamesDeclaredOrImplied Journal
j)
amountCompleter :: String -> CompletionFunc IO
amountCompleter :: CommandDoc -> CompletionFunc IO
amountCompleter = [CommandDoc] -> CommandDoc -> CompletionFunc IO
completer []
completer :: [String] -> String -> CompletionFunc IO
completer :: [CommandDoc] -> CommandDoc -> CompletionFunc IO
completer completions :: [CommandDoc]
completions def :: CommandDoc
def = Maybe Char
-> CommandDoc
-> (CommandDoc -> IO [Completion])
-> CompletionFunc IO
forall (m :: * -> *).
Monad m =>
Maybe Char
-> CommandDoc -> (CommandDoc -> m [Completion]) -> CompletionFunc m
completeWord Maybe Char
forall a. Maybe a
Nothing "" CommandDoc -> IO [Completion]
forall (m :: * -> *). Monad m => CommandDoc -> m [Completion]
completionsFor
where
simpleCompletion' :: CommandDoc -> Completion
simpleCompletion' s :: CommandDoc
s = (CommandDoc -> Completion
simpleCompletion CommandDoc
s){isFinished :: Bool
isFinished=Bool
False}
completionsFor :: CommandDoc -> m [Completion]
completionsFor "" = [Completion] -> m [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return [CommandDoc -> Completion
simpleCompletion' CommandDoc
def]
completionsFor i :: CommandDoc
i = [Completion] -> m [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return ((CommandDoc -> Completion) -> [CommandDoc] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map CommandDoc -> Completion
simpleCompletion' [CommandDoc]
ciprefixmatches)
where
ciprefixmatches :: [CommandDoc]
ciprefixmatches = [CommandDoc
c | CommandDoc
c <- [CommandDoc]
completions, CommandDoc
i CommandDoc -> CommandDoc -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` CommandDoc
c]
defaultTo' :: a -> Wizard Haskeline a -> Wizard Haskeline a
defaultTo' = (Wizard Haskeline a -> a -> Wizard Haskeline a)
-> a -> Wizard Haskeline a -> Wizard Haskeline a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Wizard Haskeline a -> a -> Wizard Haskeline a
forall (b :: * -> *) a. Functor b => Wizard b a -> a -> Wizard b a
defaultTo
withCompletion :: CompletionFunc IO -> Wizard b a -> Wizard b a
withCompletion f :: CompletionFunc IO
f = Settings IO -> Wizard b a -> Wizard b a
forall (b :: * -> *) a.
(WithSettings :<: b) =>
Settings IO -> Wizard b a -> Wizard b a
withSettings (CompletionFunc IO -> Settings IO -> Settings IO
forall (m :: * -> *). CompletionFunc m -> Settings m -> Settings m
setComplete CompletionFunc IO
f Settings IO
forall (m :: * -> *). MonadIO m => Settings m
defaultSettings)
green :: CommandDoc -> CommandDoc
green s :: CommandDoc
s = "\ESC[1;32m\STX"CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++CommandDoc
sCommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++"\ESC[0m\STX"
showDefault :: CommandDoc -> CommandDoc
showDefault "" = ""
showDefault s :: CommandDoc
s = " [" CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++ CommandDoc
s CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++ "]"
journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal
journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal
journalAddTransaction j :: Journal
j@Journal{jtxns :: Journal -> [Transaction]
jtxns=[Transaction]
ts} opts :: CliOpts
opts t :: Transaction
t = do
let f :: CommandDoc
f = Journal -> CommandDoc
journalFilePath Journal
j
CommandDoc -> CommandDoc -> IO ()
appendToJournalFileOrStdout CommandDoc
f (CommandDoc -> IO ()) -> CommandDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ Transaction -> CommandDoc
showTransaction Transaction
t
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CliOpts -> Int
debug_ CliOpts
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
CommandDoc -> IO ()
putStrLn (CommandDoc -> IO ()) -> CommandDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc -> CommandDoc
forall r. PrintfType r => CommandDoc -> r
printf "\nAdded transaction to %s:" CommandDoc
f
CommandDoc -> IO ()
putStrLn (CommandDoc -> IO ()) -> IO CommandDoc -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CommandDoc -> IO CommandDoc
registerFromString (Transaction -> CommandDoc
showTransaction Transaction
t)
Journal -> IO Journal
forall (m :: * -> *) a. Monad m => a -> m a
return Journal
j{jtxns :: [Transaction]
jtxns=[Transaction]
ts[Transaction] -> [Transaction] -> [Transaction]
forall a. [a] -> [a] -> [a]
++[Transaction
t]}
appendToJournalFileOrStdout :: FilePath -> String -> IO ()
appendToJournalFileOrStdout :: CommandDoc -> CommandDoc -> IO ()
appendToJournalFileOrStdout f :: CommandDoc
f s :: CommandDoc
s
| CommandDoc
f CommandDoc -> CommandDoc -> Bool
forall a. Eq a => a -> a -> Bool
== "-" = CommandDoc -> IO ()
putStr CommandDoc
s'
| Bool
otherwise = CommandDoc -> CommandDoc -> IO ()
appendFile CommandDoc
f CommandDoc
s'
where s' :: CommandDoc
s' = "\n" CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++ CommandDoc -> CommandDoc
ensureOneNewlineTerminated CommandDoc
s
ensureOneNewlineTerminated :: String -> String
ensureOneNewlineTerminated :: CommandDoc -> CommandDoc
ensureOneNewlineTerminated = (CommandDoc -> CommandDoc -> CommandDoc
forall a. [a] -> [a] -> [a]
++"\n") (CommandDoc -> CommandDoc)
-> (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandDoc -> CommandDoc
forall a. [a] -> [a]
reverse (CommandDoc -> CommandDoc)
-> (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> CommandDoc -> CommandDoc
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='\n') (CommandDoc -> CommandDoc)
-> (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandDoc -> CommandDoc
forall a. [a] -> [a]
reverse
registerFromString :: String -> IO String
registerFromString :: CommandDoc -> IO CommandDoc
registerFromString s :: CommandDoc
s = do
Day
d <- IO Day
getCurrentDay
Journal
j <- Text -> IO Journal
readJournal' (Text -> IO Journal) -> Text -> IO Journal
forall a b. (a -> b) -> a -> b
$ CommandDoc -> Text
T.pack CommandDoc
s
CommandDoc -> IO CommandDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandDoc -> IO CommandDoc) -> CommandDoc -> IO CommandDoc
forall a b. (a -> b) -> a -> b
$ CliOpts -> PostingsReport -> CommandDoc
postingsReportAsText CliOpts
opts (PostingsReport -> CommandDoc) -> PostingsReport -> CommandDoc
forall a b. (a -> b) -> a -> b
$ ReportOpts -> Query -> Journal -> PostingsReport
postingsReport ReportOpts
ropts (Day -> ReportOpts -> Query
queryFromOpts Day
d ReportOpts
ropts) Journal
j
where
ropts :: ReportOpts
ropts = ReportOpts
defreportopts{empty_ :: Bool
empty_=Bool
True}
opts :: CliOpts
opts = CliOpts
defcliopts{reportopts_ :: ReportOpts
reportopts_=ReportOpts
ropts}
capitalize :: String -> String
capitalize :: CommandDoc -> CommandDoc
capitalize "" = ""
capitalize (c :: Char
c:cs :: CommandDoc
cs) = Char -> Char
toUpper Char
c Char -> CommandDoc -> CommandDoc
forall a. a -> [a] -> [a]
: CommandDoc
cs
transactionsSimilarTo :: Journal -> Query -> Text -> [(Double,Transaction)]
transactionsSimilarTo :: Journal -> Query -> Text -> [(Double, Transaction)]
transactionsSimilarTo j :: Journal
j q :: Query
q desc :: Text
desc =
((Double, Transaction) -> (Double, Transaction) -> Ordering)
-> [(Double, Transaction)] -> [(Double, Transaction)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Double, Transaction) -> (Double, Transaction) -> Ordering
forall a. Ord a => (a, Transaction) -> (a, Transaction) -> Ordering
compareRelevanceAndRecency
([(Double, Transaction)] -> [(Double, Transaction)])
-> [(Double, Transaction)] -> [(Double, Transaction)]
forall a b. (a -> b) -> a -> b
$ ((Double, Transaction) -> Bool)
-> [(Double, Transaction)] -> [(Double, Transaction)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
threshold)(Double -> Bool)
-> ((Double, Transaction) -> Double)
-> (Double, Transaction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Double, Transaction) -> Double
forall a b. (a, b) -> a
fst)
[(Text -> Text -> Double
compareDescriptions Text
desc (Text -> Double) -> Text -> Double
forall a b. (a -> b) -> a -> b
$ Transaction -> Text
tdescription Transaction
t, Transaction
t) | Transaction
t <- [Transaction]
ts]
where
compareRelevanceAndRecency :: (a, Transaction) -> (a, Transaction) -> Ordering
compareRelevanceAndRecency (n1 :: a
n1,t1 :: Transaction
t1) (n2 :: a
n2,t2 :: Transaction
t2) = (a, Day) -> (a, Day) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a
n2,Transaction -> Day
tdate Transaction
t2) (a
n1,Transaction -> Day
tdate Transaction
t1)
ts :: [Transaction]
ts = (Transaction -> Bool) -> [Transaction] -> [Transaction]
forall a. (a -> Bool) -> [a] -> [a]
filter (Query
q Query -> Transaction -> Bool
`matchesTransaction`) ([Transaction] -> [Transaction]) -> [Transaction] -> [Transaction]
forall a b. (a -> b) -> a -> b
$ Journal -> [Transaction]
jtxns Journal
j
threshold :: Double
threshold = 0
compareDescriptions :: Text -> Text -> Double
compareDescriptions :: Text -> Text -> Double
compareDescriptions s :: Text
s t :: Text
t = CommandDoc -> CommandDoc -> Double
compareStrings CommandDoc
s' CommandDoc
t'
where s' :: CommandDoc
s' = CommandDoc -> CommandDoc
simplify (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> a -> b
$ Text -> CommandDoc
T.unpack Text
s
t' :: CommandDoc
t' = CommandDoc -> CommandDoc
simplify (CommandDoc -> CommandDoc) -> CommandDoc -> CommandDoc
forall a b. (a -> b) -> a -> b
$ Text -> CommandDoc
T.unpack Text
t
simplify :: CommandDoc -> CommandDoc
simplify = (Char -> Bool) -> CommandDoc -> CommandDoc
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> CommandDoc -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ("0123456789" :: String)))
compareStrings :: String -> String -> Double
compareStrings :: CommandDoc -> CommandDoc -> Double
compareStrings "" "" = 1
compareStrings [_] "" = 0
compareStrings "" [_] = 0
compareStrings [a :: Char
a] [b :: Char
b] = if Char -> Char
toUpper Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Char
toUpper Char
b then 1 else 0
compareStrings s1 :: CommandDoc
s1 s2 :: CommandDoc
s2 = 2 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
commonpairs Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
totalpairs
where
pairs1 :: Set CommandDoc
pairs1 = [CommandDoc] -> Set CommandDoc
forall a. Ord a => [a] -> Set a
S.fromList ([CommandDoc] -> Set CommandDoc) -> [CommandDoc] -> Set CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> [CommandDoc]
wordLetterPairs (CommandDoc -> [CommandDoc]) -> CommandDoc -> [CommandDoc]
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
uppercase CommandDoc
s1
pairs2 :: Set CommandDoc
pairs2 = [CommandDoc] -> Set CommandDoc
forall a. Ord a => [a] -> Set a
S.fromList ([CommandDoc] -> Set CommandDoc) -> [CommandDoc] -> Set CommandDoc
forall a b. (a -> b) -> a -> b
$ CommandDoc -> [CommandDoc]
wordLetterPairs (CommandDoc -> [CommandDoc]) -> CommandDoc -> [CommandDoc]
forall a b. (a -> b) -> a -> b
$ CommandDoc -> CommandDoc
uppercase CommandDoc
s2
commonpairs :: Double
commonpairs = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ Set CommandDoc -> Int
forall a. Set a -> Int
S.size (Set CommandDoc -> Int) -> Set CommandDoc -> Int
forall a b. (a -> b) -> a -> b
$ Set CommandDoc -> Set CommandDoc -> Set CommandDoc
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set CommandDoc
pairs1 Set CommandDoc
pairs2
totalpairs :: Double
totalpairs = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ Set CommandDoc -> Int
forall a. Set a -> Int
S.size Set CommandDoc
pairs1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set CommandDoc -> Int
forall a. Set a -> Int
S.size Set CommandDoc
pairs2
wordLetterPairs :: CommandDoc -> [CommandDoc]
wordLetterPairs = (CommandDoc -> [CommandDoc]) -> [CommandDoc] -> [CommandDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CommandDoc -> [CommandDoc]
forall a. [a] -> [[a]]
letterPairs ([CommandDoc] -> [CommandDoc])
-> (CommandDoc -> [CommandDoc]) -> CommandDoc -> [CommandDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandDoc -> [CommandDoc]
words
letterPairs :: [a] -> [[a]]
letterPairs (a :: a
a:b :: a
b:rest :: [a]
rest) = [a
a,a
b] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
letterPairs (a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rest)
letterPairs _ = []