import Data.Monoid ((<>))
import qualified Data.Strict.Maybe as Strict
import qualified Data.Text.Lazy as TL
+import qualified Data.Time.Clock as Time
import System.Console.GetOpt
( ArgDescr(..)
, OptDescr(..)
import System.Environment as Env (getProgName)
import System.Exit (exitSuccess)
import qualified System.IO as IO
+import qualified Text.Parsec
import Hcompta.Account (Account)
+import qualified Hcompta.Account as Account
import Hcompta.Amount (Amount)
import qualified Hcompta.Amount as Amount
import qualified Hcompta.Amount.Write as Amount.Write
import Hcompta.Amount.Unit (Unit)
import qualified Hcompta.Balance as Balance
import qualified Hcompta.CLI.Args as Args
+import Hcompta.CLI.Context (Context)
import qualified Hcompta.CLI.Context as Context
import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
import qualified Hcompta.CLI.Lang as Lang
import qualified Hcompta.CLI.Lib.Leijen.Table as Table
import qualified Hcompta.CLI.Write as Write
+import qualified Hcompta.Date as Date
import qualified Hcompta.Filter as Filter
import qualified Hcompta.Filter.Read as Filter.Read
import qualified Hcompta.Format.Ledger as Ledger
import qualified Hcompta.Format.Ledger.Write as Ledger.Write
import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
+import Hcompta.Lib.TreeMap (TreeMap)
+import qualified Hcompta.Lib.TreeMap as TreeMap
data Ctx
= Ctx
- { ctx_filter_balance :: Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Balance
- (Account, Amount.Sum Amount)))
- , ctx_filter_posting :: Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Posting
- Ledger.Posting))
- , ctx_filter_transaction :: Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction
- Ledger.Transaction))
- , ctx_input :: [FilePath]
- , ctx_reduce_date :: Bool
- , ctx_redundant :: Bool
+ { ctx_filter_balance :: Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Balance
+ (Account, Amount.Sum Amount)))
+ , ctx_filter_posting :: Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Posting
+ Ledger.Posting))
+ , ctx_filter_transaction :: Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Transaction
+ Ledger.Transaction))
+ , ctx_heritage :: Bool
+ , ctx_input :: [FilePath]
+ , ctx_reduce_date :: Bool
+ , ctx_redundant :: Bool
+ , ctx_total_by_unit :: Bool
+ , ctx_format_output :: Format_Output
+ , ctx_account_equilibrium :: Account
} deriving (Show)
-nil :: Ctx
-nil =
+data Format_Output
+ = Format_Output_Table
+ | Format_Output_Transaction { negate_transaction :: Bool }
+ deriving (Eq, Show)
+
+nil :: Context -> Ctx
+nil context =
Ctx
- { ctx_filter_balance = mempty
- , ctx_filter_posting = mempty
- , ctx_filter_transaction = mempty
- , ctx_input = []
- , ctx_reduce_date = True
- , ctx_redundant = False
+ { ctx_filter_balance = mempty
+ , ctx_filter_posting = mempty
+ , ctx_filter_transaction = mempty
+ , ctx_heritage = True
+ , ctx_input = []
+ , ctx_reduce_date = True
+ , ctx_redundant = False
+ , ctx_total_by_unit = True
+ , ctx_format_output = Format_Output_Table
+ , ctx_account_equilibrium = Account.account
+ (TL.toStrict $ W.displayT $ W.renderOneLine False $
+ toDoc (Context.lang context) Lang.Message_Equilibrium)
+ []
}
usage :: IO String
return $ ctx{ctx_redundant})
"[yes|no]")
"also print accounts with zero amount or the same amounts than its ascending account"
+ , Option "" ["heritage"]
+ (OptArg (\arg context ctx -> do
+ ctx_heritage <- case arg of
+ Nothing -> return $ True
+ Just "yes" -> return $ True
+ Just "no" -> return $ False
+ Just _ -> Write.fatal context $
+ W.text "--heritage option expects \"yes\", or \"no\" as value"
+ return $ ctx{ctx_heritage})
+ "[yes|no]")
+ "propagate amounts to ascending accounts"
+ , Option "" ["total"]
+ (OptArg (\arg context ctx -> do
+ ctx_total_by_unit <- case arg of
+ Nothing -> return $ True
+ Just "yes" -> return $ True
+ Just "no" -> return $ False
+ Just _ -> Write.fatal context $
+ W.text "--total option expects \"yes\", or \"no\" as value"
+ return $ ctx{ctx_total_by_unit})
+ "[yes|no]")
+ "calculate totals by unit"
+ , Option "f" ["format"]
+ (ReqArg (\arg context ctx -> do
+ ctx_format_output <- case arg of
+ "table" -> return $ Format_Output_Table
+ "open" -> return $ Format_Output_Transaction False
+ "close" -> return $ Format_Output_Transaction True
+ _ -> Write.fatal context $
+ W.text "--format option expects \"close\", \"open\", or \"table\" as value"
+ return $ ctx{ctx_format_output})
+ "[close|open|table]")
+ "select output format"
+ , Option "" ["equilibrium"]
+ (ReqArg (\arg context ctx -> do
+ ctx_account_equilibrium <-
+ case Text.Parsec.runParser
+ (Ledger.Read.account <* Text.Parsec.eof)
+ () "" arg of
+ Right acct -> return acct
+ _ -> Write.fatal context $
+ W.text "--equilibrium option expects a valid account name"
+ return $ ctx{ctx_account_equilibrium})
+ "ACCOUNT")
+ "specify account equilibrating a close or open balance"
]
run :: Context.Context -> [String] -> IO ()
run context args = do
- (ctx, inputs) <- Args.parse context usage options (nil, args)
+ (ctx, inputs) <- Args.parse context usage options (nil context, args)
read_journals <-
liftM Data.Either.partitionEithers $ do
CLI.Ledger.paths context $ ctx_input ctx ++ inputs
Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
Write.debug context $ "filter: posting: " ++ show (ctx_filter_posting ctx)
Write.debug context $ "filter: balance: " ++ show (ctx_filter_balance ctx)
- let (balance_by_account, Balance.Balance_by_Unit balance_by_unit) =
- ledger_balances ctx journals
style_color <- Write.with_color context IO.stdout
- W.displayIO IO.stdout $
- W.renderPretty style_color 1.0 maxBound $ do
- toDoc () $
- let title =
- TL.toStrict . W.displayT .
- W.renderCompact False .
- toDoc (Context.lang context) in
- zipWith id
- [ Table.column (title Lang.Message_Debit) Table.Align_Right
- , Table.column (title Lang.Message_Credit) Table.Align_Right
- , Table.column (title Lang.Message_Balance) Table.Align_Right
- , Table.column (title Lang.Message_Account) Table.Align_Left
- ] $
- write_by_accounts ctx balance_by_account $
- zipWith (:)
- [ Table.Cell_Line '=' 0
- , Table.Cell_Line '=' 0
- , Table.Cell_Line '=' 0
- , Table.Cell_Line ' ' 0
- ] $
- flip write_by_amounts (repeat []) $
- Data.Map.map
- Balance.unit_sum_amount
- balance_by_unit
+ case ctx_format_output ctx of
+ Format_Output_Transaction nt -> do
+ let balance_by_account =
+ ledger_balance_by_account_filter ctx $
+ ledger_balance_by_account ctx journals
+ let Balance.Balance_by_Unit balance_by_unit =
+ ledger_balance_by_unit ctx $
+ ledger_balance_by_account_filter ctx balance_by_account
+ let posting_equilibrium =
+ (Ledger.posting $ ctx_account_equilibrium ctx)
+ { Ledger.posting_amounts =
+ flip Data.Map.map balance_by_unit $
+ (if nt then id else negate)
+ . Amount.sum_balance
+ . Balance.unit_sum_amount
+ , Ledger.posting_comments=
+ [ TL.toStrict $ W.displayT $ W.renderOneLine False $
+ toDoc (Context.lang context) $
+ Lang.Message_Equilibrium_posting
+ ]
+ }
+ now <- liftM (\d -> d{Time.utctDayTime=0}) $ Date.now
+ let transaction =
+ Ledger.transaction
+ { Ledger.transaction_description=
+ TL.toStrict $ W.displayT $ W.renderOneLine False $
+ toDoc (Context.lang context) $
+ Lang.Message_Balance_Description nt
+ , Ledger.transaction_dates=(now, [])
+ , Ledger.transaction_postings=
+ (if null $ Ledger.posting_amounts posting_equilibrium
+ then id
+ else
+ Data.Map.insertWith (++)
+ (ctx_account_equilibrium ctx)
+ [posting_equilibrium]) $
+ TreeMap.flatten_with_Path
+ (\posting_account (Balance.Account_Sum amount_by_unit) ->
+ [(Ledger.posting posting_account)
+ { Ledger.posting_amounts =
+ flip fmap amount_by_unit $
+ (if nt then negate else id)
+ . Amount.sum_balance
+ }
+ ]
+ )
+ balance_by_account
+ }
+ let sty = Ledger.Write.Style
+ { Ledger.Write.style_align = True -- ctx_align ctx
+ , Ledger.Write.style_color
+ }
+ Ledger.Write.put sty IO.stdout $ do
+ Ledger.Write.transaction transaction
+ Format_Output_Table -> do
+ let ( table_balance_by_account
+ , Balance.Balance_by_Unit balance_by_unit
+ ) =
+ case ledger_balance_by_account ctx journals of
+ b | ctx_heritage ctx ->
+ let bb = ledger_balance_by_account_expanded ctx b in
+ ( table_by_account ctx Balance.inclusive bb
+ , ledger_balance_by_unit_expanded ctx bb
+ )
+ b ->
+ let bb = ledger_balance_by_account_filter ctx b in
+ ( table_by_account ctx id bb
+ , ledger_balance_by_unit ctx bb
+ )
+ W.displayIO IO.stdout $ do
+ W.renderPretty style_color 1.0 maxBound $ do
+ toDoc () $ do
+ let title =
+ TL.toStrict . W.displayT .
+ W.renderCompact False .
+ toDoc (Context.lang context)
+ zipWith id
+ [ Table.column (title Lang.Message_Debit) Table.Align_Right
+ , Table.column (title Lang.Message_Credit) Table.Align_Right
+ , Table.column (title Lang.Message_Balance) Table.Align_Right
+ , Table.column (title Lang.Message_Account) Table.Align_Left
+ ] $ do
+ table_balance_by_account $ do
+ case ctx_total_by_unit ctx of
+ False -> repeat []
+ True -> do
+ zipWith (:)
+ [ Table.Cell_Line '=' 0
+ , Table.Cell_Line '=' 0
+ , Table.Cell_Line '=' 0
+ , Table.Cell_Line ' ' 0
+ ] $ do
+ flip table_by_unit (repeat []) $
+ Data.Map.map
+ Balance.unit_sum_amount
+ balance_by_unit
-ledger_balances
+ledger_balance_by_account
:: Ctx
-> [ Ledger.Journal (Const (Balance.Balance_by_Account (Amount.Sum Amount)) Ledger.Transaction) ]
- -> ( Balance.Expanded (Amount.Sum Amount)
- , Balance.Balance_by_Unit (Amount.Sum Amount) )
-ledger_balances ctx journals =
- let balance_by_account =
- Data.Foldable.foldl'
- (flip $ Ledger.Journal.fold
- (\Ledger.Journal{Ledger.journal_transactions=Const b} ->
- mappend b))
- mempty journals in
- let balance_expanded =
- Lib.TreeMap.filter_with_Path_and_Node
+ -> Balance.Balance_by_Account (Amount.Sum Amount)
+ledger_balance_by_account _ctx =
+ Data.Foldable.foldl'
+ (flip $ Ledger.Journal.fold
+ (\Ledger.Journal{Ledger.journal_transactions=Const b} ->
+ mappend b))
+ mempty
+
+ledger_balance_by_account_filter
+ :: Ctx
+ -> Balance.Balance_by_Account (Amount.Sum Amount)
+ -> Balance.Balance_by_Account (Amount.Sum Amount)
+ledger_balance_by_account_filter ctx =
+ case Filter.simplified $ ctx_filter_balance ctx of
+ Right True -> id
+ Right False -> const mempty
+ Left flt ->
+ TreeMap.filter_with_Path $ \acct ->
+ Data.Foldable.any (Filter.test flt . (acct,)) .
+ Balance.get_Account_Sum
+
+ledger_balance_by_account_expanded
+ :: Ctx
+ -> Balance.Balance_by_Account (Amount.Sum Amount)
+ -> Balance.Expanded (Amount.Sum Amount)
+ledger_balance_by_account_expanded ctx =
+ case Filter.simplified $ ctx_filter_balance ctx of
+ Right True -> id
+ Right False -> const mempty
+ Left flt ->
+ TreeMap.filter_with_Path_and_Node
(\node acct balance ->
- let descendants = Lib.TreeMap.nodes
- (Lib.TreeMap.node_descendants node) in
+ let descendants = TreeMap.nodes
+ (TreeMap.node_descendants node) in
let is_worth =
ctx_redundant ctx
-- NOTE: worth if no descendant
. Amount.sum_balance )
. Balance.get_Account_Sum
. Balance.inclusive )
- . Lib.TreeMap.node_value )
+ . TreeMap.node_value )
descendants) > 1
in
(&&) is_worth $
- Data.Foldable.any
- (Filter.test (ctx_filter_balance ctx) . (acct,)) $
+ Data.Foldable.any (Filter.test flt . (acct,)) $
Balance.get_Account_Sum $
Balance.inclusive balance
- ) $
- Balance.expanded balance_by_account in
- let balance_by_unit =
- Balance.by_unit_of_expanded
- balance_expanded
- mempty in
- ( balance_expanded
- , balance_by_unit
- )
+ )
+ . Balance.expanded
+
+ledger_balance_by_unit
+ :: Ctx
+ -> Balance.Balance_by_Account (Amount.Sum Amount)
+ -> Balance.Balance_by_Unit (Amount.Sum Amount)
+ledger_balance_by_unit _ctx =
+ flip Balance.by_unit_of_by_account mempty
+
+ledger_balance_by_unit_expanded
+ :: Ctx
+ -> Balance.Expanded (Amount.Sum Amount)
+ -> Balance.Balance_by_Unit (Amount.Sum Amount)
+ledger_balance_by_unit_expanded _ctx =
+ flip Balance.by_unit_of_expanded mempty
-write_by_accounts
+table_by_account
:: Ctx
- -> Balance.Expanded (Amount.Sum Amount)
+ -> (amount -> Balance.Account_Sum (Amount.Sum Amount))
+ -> TreeMap Account.Name amount
-> [[Table.Cell]]
-> [[Table.Cell]]
-write_by_accounts _ctx =
+table_by_account _ctx get_Account_Sum =
let posting_type = Ledger.Posting_Type_Regular in
- flip $ Lib.TreeMap.foldr_with_Path
+ flip $ TreeMap.foldr_with_Path
(\account balance rows ->
foldr
(\(amount_positive, amount_negative, amount) ->
]
)
rows $
- let bal = Balance.get_Account_Sum $ Balance.inclusive balance in
+ let bal = Balance.get_Account_Sum $ get_Account_Sum balance in
Data.Map.foldrWithKey
(\unit amount acc ->
( maybe Nothing Amount.sum_positive $ Data.Map.lookup unit $ bal
) [] $ bal
)
-write_by_amounts
+table_by_unit
:: Data.Map.Map Unit (Amount.Sum Amount)
-> [[Table.Cell]]
-> [[Table.Cell]]
-write_by_amounts =
+table_by_unit =
flip $ foldr
(\amount_sum ->
zipWith (:)
(Time.fromGregorian 2000 01 01)
(Time.TimeOfDay 0 0 0))
(Time.utc)]
- , "2000/01/01 12:34" ~:
+ , "2000/01/01_12:34" ~:
(Data.Either.rights $
[P.runParser_with_Error
(Date.Read.date id Nothing <* P.eof)
- () "" ("2000/01/01 12:34"::Text)])
+ () "" ("2000/01/01_12:34"::Text)])
~?=
[ Time.zonedTimeToUTC $
Time.ZonedTime
(Time.fromGregorian 2000 01 01)
(Time.TimeOfDay 12 34 0))
(Time.utc)]
- , "2000/01/01 12:34:56" ~:
+ , "2000/01/01_12:34:56" ~:
(Data.Either.rights $
[P.runParser_with_Error
(Date.Read.date id Nothing <* P.eof)
- () "" ("2000/01/01 12:34:56"::Text)])
+ () "" ("2000/01/01_12:34:56"::Text)])
~?=
[ Time.zonedTimeToUTC $
Time.ZonedTime
(Time.fromGregorian 2000 01 01)
(Time.TimeOfDay 12 34 56))
(Time.utc)]
- , "2000/01/01 12:34 CET" ~:
+ , "2000/01/01_12:34CET" ~:
(Data.Either.rights $
[P.runParser_with_Error
(Date.Read.date id Nothing <* P.eof)
- () "" ("2000/01/01 12:34 CET"::Text)])
+ () "" ("2000/01/01_12:34CET"::Text)])
~?=
[ Time.zonedTimeToUTC $
Time.ZonedTime
(Time.fromGregorian 2000 01 01)
(Time.TimeOfDay 12 34 0))
(Time.TimeZone 60 True "CET")]
- , "2000/01/01 12:34 +0130" ~:
+ , "2000/01/01_12:34+0130" ~:
(Data.Either.rights $
[P.runParser_with_Error
(Date.Read.date id Nothing <* P.eof)
- () "" ("2000/01/01 12:34 +0130"::Text)])
+ () "" ("2000/01/01_12:34+0130"::Text)])
~?=
[ Time.zonedTimeToUTC $
Time.ZonedTime
(Time.fromGregorian 2000 01 01)
(Time.TimeOfDay 12 34 0))
(Time.TimeZone 90 False "+0130")]
- , "2000/01/01 12:34:56 CET" ~:
+ , "2000/01/01_12:34:56CET" ~:
(Data.Either.rights $
[P.runParser_with_Error
(Date.Read.date id Nothing <* P.eof)
- () "" ("2000/01/01 12:34:56 CET"::Text)])
+ () "" ("2000/01/01_12:34:56CET"::Text)])
~?=
[ Time.zonedTimeToUTC $
Time.ZonedTime
Date.nil)
~?=
"1970/01/01")
- , "2000/01/01 12:34:51 CET" ~:
+ , "2000/01/01_12:34:51CET" ~:
(Format.Ledger.Write.show
Format.Ledger.Write.Style
{ Format.Ledger.Write.style_color=False
(Time.TimeOfDay 12 34 51))
(Time.TimeZone 60 False "CET"))
~?=
- "2000/01/01 11:34:51"
- , "2000/01/01 12:34:51 +0100" ~:
+ "2000/01/01_11:34:51"
+ , "2000/01/01_12:34:51+0100" ~:
(Format.Ledger.Write.show
Format.Ledger.Write.Style
{ Format.Ledger.Write.style_color=False
(Time.TimeOfDay 12 34 51))
(Time.TimeZone 60 False ""))
~?=
- "2000/01/01 11:34:51"
- , "2000/01/01 01:02:03" ~:
+ "2000/01/01_11:34:51"
+ , "2000/01/01_01:02:03" ~:
(Format.Ledger.Write.show
Format.Ledger.Write.Style
{ Format.Ledger.Write.style_color=False
(Time.TimeOfDay 1 2 3))
(Time.utc))
~?=
- "2000/01/01 01:02:03"
- , "01/01 01:02" ~:
+ "2000/01/01_01:02:03"
+ , "01/01_01:02" ~:
(Format.Ledger.Write.show
Format.Ledger.Write.Style
{ Format.Ledger.Write.style_color=False
(Time.TimeOfDay 1 2 0))
(Time.utc))
~?=
- "01/01 01:02"
- , "01/01 01:00" ~:
+ "01/01_01:02"
+ , "01/01_01:00" ~:
(Format.Ledger.Write.show
Format.Ledger.Write.Style
{ Format.Ledger.Write.style_color=False
(Time.TimeOfDay 1 0 0))
(Time.utc))
~?=
- "01/01 01:00"
- , "01/01 00:01" ~:
+ "01/01_01:00"
+ , "01/01_00:01" ~:
(Format.Ledger.Write.show
Format.Ledger.Write.Style
{ Format.Ledger.Write.style_color=False
(Time.TimeOfDay 0 1 0))
(Time.utc))
~?=
- "01/01 00:01"
+ "01/01_00:01"
, "01/01" ~:
(Format.Ledger.Write.show
Format.Ledger.Write.Style
() "" ("A "::Text)])
~?=
[]
+ , "\"A\t\"" ~:
+ (Data.Either.rights $
+ [P.runParser
+ (Format.Ledger.Read.account_name <* P.eof)
+ () "" ("A\t"::Text)])
+ ~?=
+ []
, "\"A \\n\"" ~:
(Data.Either.rights $
[P.runParser
Format.Ledger.Write.transaction
Format.Ledger.transaction)
~?=
- "1970/01/01\n")
- , "2000/01/01 some description\\n\\ta:b:c\\n\\t ; first comment\\n\\t ; second comment\\n\\t ; third comment\\n\\tA:B:C $1" ~:
+ "1970/01/01\n\n")
+ , "2000/01/01 some description\\n\\tA:B:C $1\\n\\ta:b:c\\n\\t ; first comment\\n\\t ; second comment\\n\\t ; third comment\\n" ~:
((Format.Ledger.Write.show
Format.Ledger.Write.Style
{ Format.Ledger.Write.style_color=False
]
})
~?=
- "2000/01/01 some description\n\ta:b:c\n\t ; first comment\n\t ; second comment\n\t ; third comment\n\tA:B:C $1")
+ "2000/01/01 some description\n\tA:B:C $1\n\ta:b:c\n\t ; first comment\n\t ; second comment\n\t ; third comment\n")
, "2000/01/01 some description\\n\\tA:B:C $1\\n\\tAA:BB:CC $123" ~:
((Format.Ledger.Write.show
Format.Ledger.Write.Style
]
})
~?=
- "2000/01/01 some description\n\tA:B:C $1\n\tAA:BB:CC $123")
+ "2000/01/01 some description\n\tA:B:C $1\n\tAA:BB:CC $123\n")
]
]
]
sourcephile / git / comptalang.git / commitdiff