+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Command.Balance where
-import Prelude hiding (foldr)
--- import Control.Monad ((>=>))
-import Control.Applicative ((<$>))
+import Control.Applicative ((<*), Const(..), Applicative(..))
+import Control.Arrow (first, (+++), (&&&), (***))
+import Control.DeepSeq (NFData)
+import Control.Monad (Monad(..), liftM, mapM)
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (runExceptT)
-import qualified Data.Either
-import qualified Data.Foldable
-import Data.Foldable (foldr)
-import qualified Data.List
-import qualified Data.Map.Strict as Data.Map
--- import Data.Map.Strict (Map)
-import qualified Data.Text.Lazy as TL
+import Data.Bool
+import Data.Data
+import Data.Decimal (Decimal)
+import Data.Either (Either(..), partitionEithers)
+import Data.Eq (Eq(..))
+import Data.Foldable (Foldable(..), any)
+import Data.Function (($), (.), const, on)
+import Data.Functor (Functor(..), (<$>))
+import Data.List ((++), repeat)
+-- import Data.List.NonEmpty (NonEmpty(..))
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..), Ordering(..))
+import qualified Data.Strict.Maybe as Strict
+import Data.String (String)
+import Data.Text (Text)
+import qualified Data.Time.Clock as Time
+import Data.Tuple (fst, snd)
+import Prelude (Bounded(..), FilePath, IO, Num(..), id, flip, unlines, zipWith)
import System.Console.GetOpt
( ArgDescr(..)
, OptDescr(..)
, usageInfo
)
import System.Environment as Env (getProgName)
-import System.Exit (exitWith, ExitCode(..))
+import System.Exit (exitSuccess)
import qualified System.IO as IO
--- import Text.Show.Pretty (ppShow)
+import qualified Text.Parsec
+import Text.Show (Show(..))
-import qualified Hcompta.Calc.Balance as Balance
+import Hcompta.Account (Account_Tags)
+import qualified Hcompta.Account as Account
+import qualified Hcompta.Balance as Balance
import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as Context
-import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
-import qualified Hcompta.CLI.I18N as I18N
-import qualified Hcompta.CLI.Lib.Leijen.Table as Table
+import qualified Hcompta.CLI.Context as C
+import qualified Hcompta.CLI.Env as CLI.Env
+import Hcompta.CLI.Format (Format(..), Formats)
+import qualified Hcompta.CLI.Format as Format
+import Hcompta.CLI.Format.JCC ()
+import Hcompta.CLI.Format.Ledger ()
+import qualified Hcompta.CLI.Lang as Lang
+import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
-import qualified Hcompta.Format.Ledger.Read as Ledger.Read
-import qualified Hcompta.Format.Ledger.Write as Ledger.Write
-import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
--- import qualified Hcompta.Lib.Foldable as Lib.Foldable
-import qualified Hcompta.Lib.Leijen as W
+import qualified Hcompta.Chart as Chart
+import Hcompta.Date (Date)
+import qualified Hcompta.Date as Date
+import qualified Hcompta.Filter as Filter
+import qualified Hcompta.Filter.Amount as Filter.Amount
+import qualified Hcompta.Filter.Read as Filter.Read
+import qualified Hcompta.Format.JCC as JCC
+import qualified Hcompta.Format.Ledger as Ledger
+import qualified Hcompta.Format.Ledger.Read as Ledger
import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
--- import qualified Hcompta.Model.Account as Account
-import Hcompta.Model.Account (Account)
-import qualified Hcompta.Model.Amount as Amount
-import Hcompta.Model.Amount (Amount)
-import Hcompta.Model.Amount.Unit (Unit)
-import qualified Hcompta.Model.Filter as Filter
-import qualified Hcompta.Model.Filter.Read as Filter.Read
-
-data Ctx
- = Ctx
- { ctx_input :: [FilePath]
- , ctx_redundant :: Bool
- , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
- , ctx_posting_filter :: Filter.Test_Bool (Filter.Test_Posting Ledger.Posting)
- } deriving (Show)
-
-nil :: Ctx
-nil =
- Ctx
- { ctx_input = []
- , ctx_redundant = False
- , ctx_transaction_filter = Filter.Any
- , ctx_posting_filter = Filter.Any
+import qualified Hcompta.Lib.Leijen as W
+import qualified Hcompta.Lib.Parsec as R
+import Hcompta.Lib.TreeMap (TreeMap)
+import qualified Hcompta.Lib.TreeMap as TreeMap
+import Hcompta.Polarize (Polarized)
+import qualified Hcompta.Polarize as Polarize
+import qualified Hcompta.Posting as Posting
+import qualified Hcompta.Quantity as Quantity
+import Hcompta.Unit (Unit(..))
+
+-- type Sum = (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
+
+data Context
+ = Context
+ { ctx_filter_transaction :: forall t.
+ ( Filter.Transaction t
+ , Filter.Amount_Quantity
+ (Posting.Posting_Amount
+ (Filter.Transaction_Posting t))
+ ~ Filter.Amount.Quantity
+ ) => Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Transaction t))
+ , ctx_filter_balance :: forall b.
+ ( Filter.Balance b
+ , Filter.Amount_Quantity
+ (Filter.Balance_Amount b)
+ ~ Filter.Amount.Quantity
+ ) => Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Balance b))
+ -- , ctx_filter_posting :: CLI.Format.Filter_Posting
+ , ctx_heritage :: Bool
+ , ctx_input :: [FilePath]
+ , ctx_input_format :: Formats
+ , ctx_output :: [(Write.Mode, FilePath)]
+ , ctx_output_format :: (Maybe Formats, Output_Format)
+ , ctx_reduce_date :: Bool
+ , ctx_redundant :: Bool
+ , ctx_total_by_unit :: Bool
+ , ctx_account_equilibrium :: (JCC.Account, JCC.Account)
+ } -- deriving (Show)
+
+data Output_Format
+ = Output_Format_Table
+ | Output_Format_Transaction Lang.Exercise_OC
+ deriving (Eq, Show)
+
+context :: C.Context -> Context
+context c =
+ Context
+ { ctx_filter_transaction = Filter.Simplified $ Right True
+ , ctx_filter_balance = Filter.Simplified $ Right True
+ -- , ctx_filter_posting = mempty
+ , ctx_heritage = True
+ , ctx_input = []
+ , ctx_input_format = mempty
+ , ctx_output = []
+ , ctx_output_format = (Nothing, Output_Format_Table)
+ , ctx_reduce_date = True
+ , ctx_redundant = False
+ , ctx_total_by_unit = True
+ , ctx_account_equilibrium =
+ let e = C.translate c Lang.Account_Equilibrium
+ in (e, e)
}
-usage :: IO String
-usage = do
+usage :: C.Context -> IO String
+usage c = do
bin <- Env.getProgName
return $ unlines $
- [ "SYNTAX "
- , " "++bin++" balance [option..]"
+ [ C.translate c Lang.Section_Description
+ , " "++C.translate c Lang.Help_Command_Balance
+ , ""
+ , C.translate c Lang.Section_Syntax
+ , " "++bin++" balance ["++C.translate c Lang.Type_Option++"] [...]"++
+ " ["++C.translate c Lang.Type_File_Journal++"] [...]"
, ""
- , usageInfo "OPTIONS" options
+ , usageInfo (C.translate c Lang.Section_Options) (options c)
]
-options :: Args.Options Ctx
-options =
- [ Option "h" ["help"]
- (NoArg (\_context _ctx -> do
- usage >>= IO.hPutStr IO.stderr
- exitWith ExitSuccess))
- "show this help"
+options :: C.Context -> Args.Options Context
+options c =
+ [ Option "b" ["filter-balance"]
+ (ReqArg (\s ctx -> do
+ filter <-
+ R.runParserT_with_Error
+ Filter.Read.filter_balance
+ Filter.Read.context "" s
+ case filter of
+ Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
+ Right flt ->
+ return $
+ ctx{ctx_filter_balance =
+ Filter.and (ctx_filter_balance ctx) $
+ (Filter.simplify $
+ Filter.Read.get_Forall_Filter_Balance_Decimal <$> flt)
+ }) $
+ C.translate c Lang.Type_Filter_Balance) $
+ C.translate c Lang.Help_Option_Filter_Balance
+ {-, Option "p" ["filter-posting"]
+ (ReqArg (\s ctx -> do
+ read <- liftIO $ Filter.Read.read Filter.Read.filter_posting s
+ case read of
+ Left ko -> Write.fatal c ko
+ Right filter -> return $
+ ctx{ctx_filter_posting =
+ (ctx_filter_posting ctx <>) $
+ CLI.Format.All
+ (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
+ (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
+ }) $
+ C.translate c Lang.Type_Filter_Posting) $
+ C.translate c Lang.Help_Option_Filter_Posting
+ -}
+ , Option "t" ["filter-transaction"]
+ (ReqArg (\s ctx -> do
+ filter <-
+ R.runParserT_with_Error
+ Filter.Read.filter_transaction
+ Filter.Read.context "" s
+ case filter of
+ Left ko -> Write.fatal c ko
+ Right flt ->
+ return $
+ ctx{ctx_filter_transaction =
+ Filter.and (ctx_filter_transaction ctx) $
+ (Filter.simplify $
+ Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
+ }) $
+ C.translate c Lang.Type_Filter_Transaction) $
+ C.translate c Lang.Help_Option_Filter_Transaction
+ , Option "h" ["help"]
+ (NoArg (\_ctx -> do
+ usage c >>= IO.hPutStr IO.stderr
+ exitSuccess)) $
+ C.translate c Lang.Help_Option_Help
, Option "i" ["input"]
- (ReqArg (\s _context ctx -> do
- return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
- "read data from given file, can be use multiple times"
- , Option "t" ["transaction-filter"]
- (ReqArg (\s context ctx -> do
- ctx_transaction_filter <- do
- case Filter.Read.read Filter.Read.test_transaction s of
- Left ko -> Write.fatal context $ toDoc context ko
- Right ok -> return ok
- return $ ctx{ctx_transaction_filter}) "FILTER")
- "filter on posting"
- , Option "p" ["posting-filter"]
- (ReqArg (\s context ctx -> do
- ctx_posting_filter <- do
- case Filter.Read.read Filter.Read.test_posting s of
- Left ko -> Write.fatal context $ toDoc context ko
- Right ok -> return ok
- return $ ctx{ctx_posting_filter}) "FILTER")
- "filter on balance"
- , Option "" ["redundant"]
- (OptArg (\arg context ctx -> do
- redundant <- case arg of
+ (ReqArg (\s ctx -> do
+ return $ ctx{ctx_input=s:ctx_input ctx}) $
+ C.translate c Lang.Type_File_Journal) $
+ C.translate c Lang.Help_Option_Input
+ , Option "f" ["input-format"]
+ (OptArg (\arg ctx -> do
+ ctx_input_format <- case arg of
+ Nothing -> return $ Format_JCC ()
+ Just "jcc" -> return $ Format_JCC ()
+ Just "ledger" -> return $ Format_Ledger ()
+ Just _ -> Write.fatal c $
+ W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
+ return $ ctx{ctx_input_format})
+ "[jcc|ledger]")
+ "input format"
+ , Option "o" ["output"]
+ (ReqArg (\s ctx -> do
+ return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
+ C.translate c Lang.Type_File) $
+ C.translate c Lang.Help_Option_Output
+ , Option "O" ["overwrite"]
+ (ReqArg (\s ctx -> do
+ return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
+ C.translate c Lang.Type_File) $
+ C.translate c Lang.Help_Option_Overwrite
+ {- NOTE: not used so far.
+ , Option "" ["reduce-date"]
+ (OptArg (\arg ctx -> do
+ ctx_reduce_date <- case arg of
Nothing -> return $ True
Just "yes" -> return $ True
Just "no" -> return $ False
- Just _ -> Write.fatal context $
- W.text "--redundant option expects \"yes\", or \"no\" as value"
- return $ ctx{ctx_redundant=redundant})
+ Just _ -> Write.fatal c $
+ W.text "--reduce-date option expects \"yes\", or \"no\" as value"
+ return $ ctx{ctx_reduce_date})
"[yes|no]")
- "also print accounts with zero amount or the same amounts than its ascending account"
+ "use advanced date reducer to speed up filtering"
+ -}
+ , Option "" ["redundant"]
+ (OptArg (\arg ctx -> do
+ ctx_redundant <- case arg of
+ Nothing -> return $ True
+ Just "yes" -> return $ True
+ Just "no" -> return $ False
+ Just _ -> Write.fatal c Lang.Error_Option_Balance_Redundant
+ return $ ctx{ctx_redundant})
+ "[no|yes]") $
+ C.translate c Lang.Help_Option_Balance_Redundant
+ , Option "" ["heritage"]
+ (OptArg (\arg ctx -> do
+ ctx_heritage <- case arg of
+ Nothing -> return $ True
+ Just "yes" -> return $ True
+ Just "no" -> return $ False
+ Just _ -> Write.fatal c Lang.Error_Option_Balance_Heritage
+ return $ ctx{ctx_heritage})
+ "[yes|no]") $
+ C.translate c Lang.Help_Option_Balance_Heritage
+ , Option "" ["total"]
+ (OptArg (\arg ctx -> do
+ ctx_total_by_unit <- case arg of
+ Nothing -> return $ True
+ Just "yes" -> return $ True
+ Just "no" -> return $ False
+ Just _ -> Write.fatal c Lang.Error_Option_Balance_Total
+ return $ ctx{ctx_total_by_unit})
+ "[yes|no]") $
+ C.translate c Lang.Help_Option_Balance_Total
+ , Option "F" ["output-format"]
+ (ReqArg (\arg ctx -> do
+ ctx_output_format <- case arg of
+ "table" -> return $ (Nothing , Output_Format_Table)
+ "table.jcc" -> return $ (Just $ Format_JCC (), Output_Format_Table)
+ "table.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Table)
+ "open" -> return $ (Nothing , Output_Format_Transaction Lang.Exercise_Opening)
+ "open.jcc" -> return $ (Just $ Format_JCC (), Output_Format_Transaction Lang.Exercise_Opening)
+ "open.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Opening)
+ "close" -> return $ (Nothing , Output_Format_Transaction Lang.Exercise_Closing)
+ "close.jcc" -> return $ (Just $ Format_JCC (), Output_Format_Transaction Lang.Exercise_Closing)
+ "close.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Closing)
+ _ -> Write.fatal c Lang.Error_Option_Balance_Format
+ return $ ctx{ctx_output_format})
+ "[table|close|open][.jcc|.ledger]") $
+ C.translate c Lang.Help_Option_Balance_Format
+ , Option "" ["eq"]
+ (ReqArg (\arg ctx -> do
+ ctx_account_equilibrium <-
+ fmap (\e -> (e, e)) $
+ case Text.Parsec.runParser
+ (Ledger.read_account <* Text.Parsec.eof)
+ () "" arg of
+ Right acct -> return acct
+ _ -> Write.fatal c Lang.Error_Option_Equilibrium
+ return $ ctx{ctx_account_equilibrium}) $
+ C.translate c Lang.Type_Account) $
+ C.translate c Lang.Help_Option_Equilibrium
+ , Option "" ["eq-credit"]
+ (ReqArg (\arg ctx -> do
+ ctx_account_equilibrium <-
+ fmap (\e -> (fst $ ctx_account_equilibrium ctx, e)) $
+ case Text.Parsec.runParser
+ (Ledger.read_account <* Text.Parsec.eof)
+ () "" arg of
+ Right acct -> return acct
+ _ -> Write.fatal c Lang.Error_Option_Equilibrium_Credit
+ return $ ctx{ctx_account_equilibrium}) $
+ C.translate c Lang.Type_Account) $
+ C.translate c Lang.Help_Option_Equilibrium_Credit
+ , Option "" ["eq-debit"]
+ (ReqArg (\arg ctx -> do
+ ctx_account_equilibrium <-
+ fmap (\e -> (e, snd $ ctx_account_equilibrium ctx)) $
+ case Text.Parsec.runParser
+ (Ledger.read_account <* Text.Parsec.eof)
+ () "" arg of
+ Right acct -> return acct
+ _ -> Write.fatal c Lang.Error_Option_Equilibrium_Debit
+ return $ ctx{ctx_account_equilibrium}) $
+ C.translate c Lang.Type_Account) $
+ C.translate c Lang.Help_Option_Equilibrium_Debit
]
-run :: Context.Context -> [String] -> IO ()
-run context args = do
- (ctx, text_filters) <- Args.parse context usage options (nil, args)
- read_journals <- do
- CLI.Ledger.paths context $ ctx_input ctx
- >>= do
- mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file path
- >>= \x -> case x of
- Left ko -> return $ Left (path, ko)
- Right ok -> return $ Right ok
- >>= return . Data.Either.partitionEithers
- case read_journals of
- (errs@(_:_), _journals) ->
- (flip mapM_) errs $ \(_path, err) -> do
- Write.fatal context $ toDoc context err
- ([], journals) -> do
- (balance_filter::
- Filter.Test_Bool (Filter.Test_Balance
- (Account, Balance.Amount_Sum Amount))) <-
- foldr Filter.And Filter.Any <$> do
- (flip mapM) text_filters $ \s ->
- case Filter.Read.read Filter.Read.test_balance s of
- Left ko -> Write.fatal context $ toDoc context ko
- Right ok -> return ok
- Write.debug context $ "balance_filter: " ++ show balance_filter
- Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
- Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
- let (balance_by_account::Balance.Balance_by_Account (Balance.Amount_Sum Amount) Amount.Unit) =
- foldr
- (Ledger.Journal.fold
- (flip (foldr
- (flip (foldr
- (\tr ->
- case Filter.test (ctx_transaction_filter ctx) tr of
- False -> id
- True ->
- let filter_postings =
- Data.Foldable.concatMap $
- Data.List.filter $
- (Filter.test (ctx_posting_filter ctx)) in
- let balance =
- flip (foldr Balance.by_account) .
- map (\p ->
- ( Ledger.posting_account p
- , Data.Map.map Balance.amount_sum (Ledger.posting_amounts p)
- )
- ) .
- filter_postings in
- balance (Ledger.transaction_postings tr) .
- balance (Ledger.transaction_virtual_postings tr) .
- balance (Ledger.transaction_balanced_virtual_postings tr)
- ))))
- . Ledger.journal_transactions))
- (Balance.balance_by_account Balance.nil)
- journals
- let balance_expanded =
- Lib.TreeMap.filter_with_Path (\acct ->
- Data.Foldable.any
- (Filter.test balance_filter . (acct,)) .
- Balance.inclusive) $
- Balance.expanded balance_by_account
- style_color <- Write.with_color context IO.stdout
- Ledger.Write.put Ledger.Write.Style
- { Ledger.Write.style_align = True
- , Ledger.Write.style_color
- } IO.stdout $ do
- toDoc () $
- let title = TL.toStrict . W.displayT . W.renderCompact False .
- I18N.render (Context.langs context) in
- zipWith id
- [ Table.column (title I18N.Message_Balance_debit) Table.Align_Right
- , Table.column (title I18N.Message_Balance_credit) Table.Align_Right
- , Table.column (title I18N.Message_Balance_total) Table.Align_Right
- , Table.column (title I18N.Message_Account) Table.Align_Left
- ] $
- flip (write_by_accounts ctx) balance_expanded $
- zipWith (:)
- [ Table.Cell_Line '=' 0
- , Table.Cell_Line '=' 0
- , Table.Cell_Line '=' 0
- , Table.Cell_Line ' ' 0
- ] $
- write_by_amounts (repeat []) $
- Data.Map.map Balance.unit_sum_amount $
- Balance.by_unit_of_expanded
- balance_expanded
- (Balance.balance_by_unit Balance.nil)
-
-write_by_accounts
- :: Ctx
- -> [[Table.Cell]]
- -> Balance.Expanded (Balance.Amount_Sum Amount)
- -> [[Table.Cell]]
-write_by_accounts ctx =
- let posting_type = Ledger.Posting_Type_Regular in
- Lib.TreeMap.foldr_with_Path_and_Node
- (\account node balance rows -> do
- let descendants = Lib.TreeMap.nodes
- (Lib.TreeMap.node_descendants node)
- let is_worth =
- ctx_redundant ctx
- -- NOTE: worth if no descendant
- -- but account inclusive
- -- has at least a non-zero amount
- || (Data.Map.null descendants && not
- (Data.Map.null
- (Data.Map.filter
- (not . Amount.is_zero . Balance.amount_sum_balance)
- (Balance.inclusive balance))))
- -- NOTE: worth if account exclusive
- -- has at least a non-zero amount
- || not (Data.Map.null
- (Data.Map.filter
- (not . Amount.is_zero . Balance.amount_sum_balance)
- (Balance.exclusive balance)))
- -- NOTE: worth if account has at least more than
- -- one descendant account whose inclusive
- -- has at least a non-zero amount
- || Data.Map.size
- (Data.Map.filter
- ( maybe False
- ( not . Data.Foldable.all
- ( Amount.is_zero
- . Balance.amount_sum_balance )
- . Balance.inclusive )
- . Lib.TreeMap.node_value )
- descendants) > 1
- case is_worth of
- False -> rows
- True ->
- foldr
- (\(amount_positive, amount_negative, amount) ->
+run :: C.Context -> [String] -> IO ()
+run c args = do
+ (ctx, inputs) <-
+ first (\x ->
+ case ctx_output x of
+ [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
+ _ -> x) <$>
+ Args.parse c usage options (context c, args)
+ input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
+ read_journals <- mapM (liftIO . journal_read ctx) input_paths
+ case partitionEithers read_journals of
+ (errs@(_:_), _journals) -> Write.fatals c errs
+ ([], (journals::[Forall_Journal_Balance_by_Account])) -> do
+ let bal_by_account =
+ mconcat $
+ fmap Format.journal_flatten $
+ case fst $ ctx_output_format ctx of
+ Just f -> Format.journal_empty f:journals
+ Nothing -> journals
+ now <- Date.now
+ with_color <- Write.with_color c IO.stdout
+ W.displayIO IO.stdout $
+ W.renderPretty with_color 1.0 maxBound $
+ case snd $ ctx_output_format ctx of
+ Output_Format_Table ->
+ toDoc () $ Leijen.Table.table_of (c, ctx) bal_by_account
+ Output_Format_Transaction oc ->
+ journal_equilibrium_transaction
+ (Const bal_by_account::Const Forall_Journal_Balance_by_Account ())
+ c ctx oc now
+ {-
+ Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
+ Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
+ Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
+ let sty = Write.style { Write.style_pretty = True }
+ -}
+
+instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_Balance_by_Account where
+ table_of (c, ctx) bal_by_account =
+ let lang = C.lang c in
+ let (rows_by_account, rows_by_unit) =
+ case ctx_heritage ctx of
+ True -> rows_of_balance_by_account $ expand bal_by_account
+ False -> rows_of_balance_by_account bal_by_account in
+ zipWith id
+ [ Leijen.Table.column (Lang.translate lang Lang.Title_Debit) Leijen.Table.Align_Right
+ , Leijen.Table.column (Lang.translate lang Lang.Title_Credit) Leijen.Table.Align_Right
+ , Leijen.Table.column (Lang.translate lang Lang.Title_Balance) Leijen.Table.Align_Right
+ , Leijen.Table.column (Lang.translate lang Lang.Title_Account) Leijen.Table.Align_Left
+ ] $
+ rows_by_account $
+ (if ctx_total_by_unit ctx
+ then zipWith (:)
+ [ Leijen.Table.Cell_Line '=' 0
+ , Leijen.Table.Cell_Line '=' 0
+ , Leijen.Table.Cell_Line '=' 0
+ , Leijen.Table.Cell_Line ' ' 0
+ ] . rows_by_unit
+ else id) $
+ repeat []
+ where
+ expand
+ :: Forall_Journal_Balance_by_Account
+ -> Forall_Journal_Balance_by_Account_Expanded
+ expand = Format.journal_wrap
+ rows_of_balance_by_account
+ :: ( Format.Journal_Filter Context (Const bal_by_account) ()
+ , Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
+ , Format.Journal_Leijen_Table_Cells (Const bal_by_account) ()
+ )
+ => bal_by_account
+ -> ( [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]]
+ , [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]] )
+ rows_of_balance_by_account =
+ (***) Format.journal_leijen_table_cells
+ Format.journal_leijen_table_cells .
+ (&&&) id sum_by_unit .
+ Format.journal_filter ctx .
+ Const
+ where
+ sum_by_unit
+ :: Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
+ => Const bal_by_account ()
+ -> Const Forall_Journal_Balance_by_Unit ()
+ sum_by_unit = Const . Format.journal_wrap . getConst
+
+
+
+
+
+
+
+
+
+
+-- * 'Balance.Balance_by_Account'
+
+-- ** Type 'Format_Balance_by_Account'
+
+type Format_Journal_Balance_by_Account
+ = Format
+ ( JCC.Journal Balance_by_Account_JCC)
+ (Ledger.Journal Balance_by_Account_Ledger)
+
+-- JCC
+type Balance_by_Account_JCC
+ = Balance.Balance_by_Account JCC.Account_Section
+ JCC.Unit
+ (Polarized JCC.Quantity)
+instance Format.Journal (JCC.Journal Balance_by_Account_JCC) where
+ type Journal_Format (JCC.Journal Balance_by_Account_JCC)
+ = Format_Journal_Balance_by_Account
+ journal_format = Format_JCC
+
+-- Ledger
+type Balance_by_Account_Ledger
+ = Balance.Balance_by_Account Ledger.Account_Section
+ Ledger.Unit
+ (Polarized Ledger.Quantity)
+instance Format.Journal (Ledger.Journal Balance_by_Account_Ledger) where
+ type Journal_Format (Ledger.Journal Balance_by_Account_Ledger)
+ = Format_Journal_Balance_by_Account
+ journal_format = Format_Ledger
+
+-- ** Class 'Journal_Balance_by_Account'
+
+class
+ ( Format.Journal (j m)
+ , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account
+ , Format.Journal_Read j
+ , Format.Journal_Monoid (j m)
+ , Format.Journal_Leijen_Table_Cells j m
+ , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Account_Expanded
+ , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
+ , Format.Journal_Filter Context j m
+ , Journal_Equilibrium_Transaction j m
+ ) => Journal_Balance_by_Account j m
+
+instance Journal_Balance_by_Account JCC.Journal Balance_by_Account_JCC
+instance Journal_Balance_by_Account Ledger.Journal Balance_by_Account_Ledger
+
+-- ** Type 'Forall_Journal_Balance_by_Account'
+
+data Forall_Journal_Balance_by_Account
+ = forall j m. Journal_Balance_by_Account j m
+ => Forall_Journal_Balance_by_Account (j m)
+
+instance Format.Journal Forall_Journal_Balance_by_Account where
+ type Journal_Format Forall_Journal_Balance_by_Account = Format_Journal_Balance_by_Account
+ journal_format
+ (Forall_Journal_Balance_by_Account j) =
+ Format.journal_format j
+instance Format.Journal_Empty Forall_Journal_Balance_by_Account where
+ journal_empty f =
+ case f of
+ Format_JCC () -> Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
+ Format_Ledger () -> Forall_Journal_Balance_by_Account (mempty::Ledger.Journal Balance_by_Account_Ledger)
+instance Format.Journal_Monoid Forall_Journal_Balance_by_Account where
+ journal_flatten
+ (Forall_Journal_Balance_by_Account j) =
+ Forall_Journal_Balance_by_Account $
+ Format.journal_flatten j
+ journal_fold f (Forall_Journal_Balance_by_Account j) =
+ Format.journal_fold (f . Forall_Journal_Balance_by_Account) j
+instance Monoid Forall_Journal_Balance_by_Account where
+ mempty = Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
+ mappend x y =
+ case (mappend `on` Format.journal_format) x y of
+ Format_JCC j -> Forall_Journal_Balance_by_Account j
+ Format_Ledger j -> Forall_Journal_Balance_by_Account j
+ mconcat js =
+ case js of
+ [] -> mempty
+ j:jn -> foldl' mappend j jn
+
+-- ** 'journal_read'
+
+type Journal_Filter_Simplified transaction
+ = Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Transaction transaction))
+type Journal_Read_Cons txn
+ = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
+journal_read
+ :: Context -> FilePath
+ -> IO (Either (Format.Message W.Doc) Forall_Journal_Balance_by_Account)
+journal_read ctx =
+ case ctx_input_format ctx of
+ Format_JCC () ->
+ let wrap (j::JCC.Journal Balance_by_Account_JCC)
+ = Forall_Journal_Balance_by_Account j in
+ let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
+ = Filter.Filtered (ctx_filter_transaction ctx) in
+ liftM ((+++) Format.Message wrap) .
+ Format.journal_read cons
+ Format_Ledger () ->
+ let wrap (j::Ledger.Journal Balance_by_Account_Ledger)
+ = Forall_Journal_Balance_by_Account j in
+ let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
+ = Filter.Filtered (ctx_filter_transaction ctx) in
+ liftM ((+++) Format.Message wrap) .
+ Format.journal_read cons
+
+{-
+-- ** Type family 'Balance_by_Account'
+
+type family Balance_by_Account (j:: * -> *) m
+type instance Balance_by_Account
+ j (Balance.Expanded as u (Polarized q))
+ = j (Balance.Balance_by_Account as u (Polarized q))
+type instance Balance_by_Account
+ (Const Forall_Journal_Balance_by_Account_Expanded) ()
+ = (Const Forall_Journal_Balance_by_Account ) ()
+-}
+
+-- Instances 'Format.Journal_Filter'
+
+instance
+ ( Functor j
+ , Format.Journal_Chart j
+
+ , as ~ Format.Journal_Account_Section j
+ , Data as
+ , Filter.Account (Account_Tags, TreeMap.Path as)
+ , NFData as
+ , Ord as
+ , Show as
+
+ , q ~ Format.Journal_Quantity j
+ , Format.Journal_Quantity j ~ Decimal
+ , Quantity.Addable q
+ , Quantity.Zero q
+
+ , Unit u
+ ) => Format.Journal_Filter Context j (Balance.Balance_by_Account as u (Polarized q)) where
+ journal_filter ctx j =
+ case Filter.simplified $ ctx_filter_balance ctx of
+ Right True | ctx_redundant ctx -> j
+ Right True ->
+ TreeMap.filter_with_Path_and_Node
+ (\n _p -> is_worth n) <$> j
+ Right False -> const mempty <$> j
+ Left flt ->
+ TreeMap.map_Maybe_with_Path_and_Node
+ (\node account (Balance.Account_Sum bal) ->
+ (if is_worth node bal then id else const Strict.Nothing) $
+ case Map.mapMaybeWithKey
+ (\unit qty ->
+ if Filter.test flt
+ ( (Chart.account_tags account (Format.journal_chart j), account)
+ , (unit, qty)
+ )
+ then Just qty
+ else Nothing
+ ) bal of
+ m | Map.null m -> Strict.Nothing
+ m -> Strict.Just $ Balance.Account_Sum m
+ ) <$> j
+ where
+ is_worth
+ :: (Ord k0, Foldable t0, Quantity.Addable a0, Quantity.Zero a0)
+ => TreeMap.Node k0 x0
+ -> t0 (Polarized a0)
+ -> Bool
+ is_worth _node bal =
+ ctx_redundant ctx
+ -- NOTE: worth if no descendant
+ -- but Account's exclusive
+ -- has at least a non-zero Amount
+ || Data.Foldable.any
+ (not . Quantity.quantity_null . Polarize.depolarize)
+ bal
+instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account) () where
+ journal_filter ctx
+ (Const (Forall_Journal_Balance_by_Account j)) =
+ Const $ Forall_Journal_Balance_by_Account $
+ Format.journal_filter ctx j
+
+-- Instances 'Format.Journal_Leijen_Table_Cells'
+
+instance
+ ( Format.Journal_Content j
+ , Journal j
+
+ , as ~ Format.Journal_Account_Section j
+ , Ord as
+ , Quantity.Addable (Format.Journal_Quantity j)
+
+ , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
+
+ , Balance_Account_Sum amt
+ , Balance_Account_Sum_Unit amt ~ Format.Journal_Unit j
+ , Balance_Account_Sum_Quantity amt ~ Polarized (Format.Journal_Quantity j)
+ ) => Format.Journal_Leijen_Table_Cells j (TreeMap as amt) where
+ journal_leijen_table_cells jnl =
+ flip (TreeMap.foldr_with_Path
+ (\account balance rows ->
+ let Balance.Account_Sum bal = balance_by_account_sum balance in
+ Map.foldrWithKey
+ (\unit qty ->
zipWith (:)
- [ Table.cell
- { Table.cell_content = maybe W.empty Ledger.Write.amount amount_positive
- , Table.cell_width = maybe 0 Ledger.Write.amount_length amount_positive
- }
- , Table.cell
- { Table.cell_content = maybe W.empty Ledger.Write.amount amount_negative
- , Table.cell_width = maybe 0 Ledger.Write.amount_length amount_negative
- }
- , Table.cell
- { Table.cell_content = Ledger.Write.amount $ amount
- , Table.cell_width = Ledger.Write.amount_length $ amount
- }
- , Table.cell
- { Table.cell_content = Ledger.Write.account posting_type account
- , Table.cell_width = Ledger.Write.account_length posting_type account
- }
- ]
+ [ cell_of $ (unit,) <$> Polarize.polarized_positive qty
+ , cell_of $ (unit,) <$> Polarize.polarized_negative qty
+ , cell_of (unit, Polarize.depolarize qty)
+ , cell_of account
+ ]
+ )
+ rows bal
+ ))
+ (Format.journal_content jnl)
+ where
+ cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
+ cell_of = Leijen.Table.cell_of_forall_param jnl
+instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account) () where
+ journal_leijen_table_cells
+ (Const (Forall_Journal_Balance_by_Account j)) =
+ Format.journal_leijen_table_cells j
+
+-- ** Class 'Balance_Account_Sum'
+
+-- | A class to get a 'Balance.Account_Sum'
+-- when operating on 'Balance.Balance_by_Account'
+-- or 'Balance.Expanded' 'Balance.inclusive' field.
+class Balance_Account_Sum amt where
+ type Balance_Account_Sum_Unit amt
+ type Balance_Account_Sum_Quantity amt
+ balance_by_account_sum
+ :: amt -> Balance.Account_Sum (Balance_Account_Sum_Unit amt)
+ (Balance_Account_Sum_Quantity amt)
+instance Balance_Account_Sum (Balance.Account_Sum u q) where
+ type Balance_Account_Sum_Unit (Balance.Account_Sum u q) = u
+ type Balance_Account_Sum_Quantity (Balance.Account_Sum u q) = q
+ balance_by_account_sum = id
+instance Balance_Account_Sum (Balance.Account_Sum_Expanded u q) where
+ type Balance_Account_Sum_Unit (Balance.Account_Sum_Expanded u q) = u
+ type Balance_Account_Sum_Quantity (Balance.Account_Sum_Expanded u q) = q
+ balance_by_account_sum = Balance.inclusive
+
+
+
+
+
+
+
+
+
+
+-- * 'Balance.Expanded'
+
+-- ** Type 'Format_Journal_Balance_by_Account_Expanded'
+
+type Format_Journal_Balance_by_Account_Expanded
+ = Format
+ ( JCC.Journal Balance_by_Account_Expanded_JCC)
+ (Ledger.Journal Balance_by_Account_Expanded_Ledger)
+
+-- JCC
+type Balance_by_Account_Expanded_JCC
+ = Balance.Expanded JCC.Account_Section
+ JCC.Unit
+ (Polarized JCC.Quantity)
+instance Format.Journal (JCC.Journal Balance_by_Account_Expanded_JCC) where
+ type Journal_Format (JCC.Journal Balance_by_Account_Expanded_JCC)
+ = Format_Journal_Balance_by_Account_Expanded
+ journal_format = Format_JCC
+
+-- Ledger
+type Balance_by_Account_Expanded_Ledger
+ = Balance.Expanded Ledger.Account_Section
+ Ledger.Unit
+ (Polarized Ledger.Quantity)
+instance Format.Journal (Ledger.Journal Balance_by_Account_Expanded_Ledger) where
+ type Journal_Format (Ledger.Journal Balance_by_Account_Expanded_Ledger)
+ = Format_Journal_Balance_by_Account_Expanded
+ journal_format = Format_Ledger
+
+-- ** Class 'Journal_Balance_by_Account_Expanded'
+
+class
+ ( Format.Journal (j m)
+ , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account_Expanded
+ , Format.Journal_Leijen_Table_Cells j m
+ , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
+ , Format.Journal_Filter Context j m
+ ) => Journal_Balance_by_Account_Expanded j m
+
+instance Journal_Balance_by_Account_Expanded JCC.Journal Balance_by_Account_Expanded_JCC
+instance Journal_Balance_by_Account_Expanded Ledger.Journal Balance_by_Account_Expanded_Ledger
+
+-- ** Type 'Forall_Journal_Balance_by_Account_Expanded'
+
+data Forall_Journal_Balance_by_Account_Expanded
+ = forall j m. Journal_Balance_by_Account_Expanded j m
+ => Forall_Journal_Balance_by_Account_Expanded (j m)
+
+instance Format.Journal Forall_Journal_Balance_by_Account_Expanded where
+ type Journal_Format Forall_Journal_Balance_by_Account_Expanded = Format_Journal_Balance_by_Account_Expanded
+ journal_format
+ (Forall_Journal_Balance_by_Account_Expanded j) =
+ Format.journal_format j
+
+-- Instances 'Format.Journal_Filter'
+
+instance
+ ( Functor j
+ , Format.Journal_Chart j
+ , as ~ Format.Journal_Account_Section j
+ , Data as
+ , Filter.Account (Account_Tags, TreeMap.Path as)
+ , NFData as
+ , Ord as
+ , Show as
+ , q ~ Format.Journal_Quantity j
+ , Format.Journal_Quantity j ~ Decimal
+ , Quantity.Addable q
+ , Quantity.Zero q
+ , Unit u
+ ) => Format.Journal_Filter Context j (Balance.Expanded as u (Polarized q)) where
+ journal_filter ctx j =
+ case Filter.simplified $ ctx_filter_balance ctx of
+ Right True | ctx_redundant ctx -> j
+ Right True ->
+ TreeMap.filter_with_Path_and_Node
+ (const . is_worth) <$> j
+ Right False -> const mempty <$> j
+ Left flt ->
+ TreeMap.map_Maybe_with_Path_and_Node
+ (\node account bal ->
+ (if is_worth node bal then id else const Strict.Nothing) $
+ case Map.mapMaybeWithKey
+ (\unit qty ->
+ if Filter.test flt
+ ( (Chart.account_tags account (Format.journal_chart j), account)
+ , (unit, qty)
+ )
+ then Just qty
+ else Nothing
+ ) (Balance.get_Account_Sum $ Balance.inclusive bal) of
+ m | Map.null m -> Strict.Nothing
+ m -> Strict.Just $ bal{Balance.inclusive=Balance.Account_Sum m}
+ ) <$> j
+ where
+ is_worth node bal =
+ let descendants = TreeMap.nodes
+ (TreeMap.node_descendants node) in
+ ctx_redundant ctx
+ -- NOTE: worth if no descendant
+ -- but Account's inclusive
+ -- has at least a non-zero Amount
+ || (Map.null descendants
+ && Data.Foldable.any
+ (not . Quantity.quantity_null . Polarize.depolarize)
+ (Balance.get_Account_Sum $ Balance.inclusive bal))
+ -- NOTE: worth if Account's exclusive
+ -- has at least a non-zero Amount
+ || (Data.Foldable.any
+ (not . Quantity.quantity_null . Polarize.depolarize)
+ (Balance.get_Account_Sum $ Balance.exclusive bal))
+ -- NOTE: worth if Account has at least more than
+ -- one descendant Account whose inclusive
+ -- has at least a non-zero Amount
+ || Map.size
+ ( Map.filter
+ ( Strict.maybe False
+ ( Data.Foldable.any
+ (not . Quantity.quantity_null . Polarize.depolarize)
+ . Balance.get_Account_Sum
+ . Balance.inclusive )
+ . TreeMap.node_value )
+ descendants
+ ) > 1
+instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account_Expanded) () where
+ journal_filter ctx
+ (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
+ Const $ Forall_Journal_Balance_by_Account_Expanded $
+ Format.journal_filter ctx j
+
+-- Instances 'Format.Journal_Leijen_Table_Cells'
+
+instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account_Expanded) x where
+ journal_leijen_table_cells
+ (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
+ Format.journal_leijen_table_cells j
+
+-- Instances Balance.Balance_by_Account -> Balance.Expanded
+
+instance
+ ( Functor j
+ , Journal_Balance_by_Account_Expanded j (Balance.Expanded as u q)
+
+ -- NOTE: constraints from Balance.expanded
+ , Ord as
+ , Ord u
+ , Quantity.Addable q
+ ) => Format.Journal_Wrap (j (Balance.Balance_by_Account as u q))
+ Forall_Journal_Balance_by_Account_Expanded where
+ journal_wrap =
+ Forall_Journal_Balance_by_Account_Expanded .
+ fmap Balance.expanded
+
+instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
+ Forall_Journal_Balance_by_Account_Expanded where
+ journal_wrap (Forall_Journal_Balance_by_Account j) = Format.journal_wrap j
+
+
+
+
+
+
+
+
+
+
+
+-- * 'Balance.Balance_by_Unit'
+
+type Format_Journal_Balance_by_Unit
+ = Format
+ ( JCC.Journal Balance_by_Unit_JCC)
+ (Ledger.Journal Balance_by_Unit_Ledger)
+
+-- JCC
+type Balance_by_Unit_JCC
+ = Balance.Balance_by_Unit JCC.Account
+ JCC.Unit
+ (Polarized JCC.Quantity)
+instance Format.Journal (JCC.Journal Balance_by_Unit_JCC) where
+ type Journal_Format (JCC.Journal Balance_by_Unit_JCC)
+ = Format_Journal_Balance_by_Unit
+ journal_format = Format_JCC
+
+-- Ledger
+type Balance_by_Unit_Ledger
+ = Balance.Balance_by_Unit Ledger.Account
+ Ledger.Unit
+ (Polarized Ledger.Quantity)
+instance Format.Journal (Ledger.Journal Balance_by_Unit_Ledger) where
+ type Journal_Format (Ledger.Journal Balance_by_Unit_Ledger)
+ = Format_Journal_Balance_by_Unit
+ journal_format = Format_Ledger
+
+-- ** Class 'Journal_Balance_by_Unit'
+
+class
+ ( Format.Journal (j m)
+ , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Unit
+ , Format.Journal_Leijen_Table_Cells j m
+ -- , Journal_Equilibrium_Postings j m
+ )
+ => Journal_Balance_by_Unit j m
+
+instance Journal_Balance_by_Unit JCC.Journal Balance_by_Unit_JCC
+instance Journal_Balance_by_Unit Ledger.Journal Balance_by_Unit_Ledger
+
+-- ** Type 'Forall_Journal_Balance_by_Unit'
+
+data Forall_Journal_Balance_by_Unit
+ = forall j m. Journal_Balance_by_Unit j m
+ => Forall_Journal_Balance_by_Unit (j m)
+
+instance Format.Journal Forall_Journal_Balance_by_Unit where
+ type Journal_Format Forall_Journal_Balance_by_Unit = Format_Journal_Balance_by_Unit
+ journal_format (Forall_Journal_Balance_by_Unit j) = Format.journal_format j
+
+-- Instances Balance.Balance_by_Account -> Balance.Balance_by_Unit
+
+instance
+ ( Functor j
+ , Journal_Balance_by_Unit j (Balance.Balance_by_Unit (Account.Account_Path as) u q)
+
+ -- NOTE: constraints from Balance.by_unit_of_by_account
+ , Account.Account (Account.Account_Path as)
+ , Ord as
+ , Ord u
+ , Quantity.Addable q
+ ) => Format.Journal_Wrap (j (Balance.Balance_by_Account as u q))
+ Forall_Journal_Balance_by_Unit where
+ journal_wrap =
+ Forall_Journal_Balance_by_Unit .
+ fmap (flip Balance.by_unit_of_by_account mempty)
+
+instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
+ Forall_Journal_Balance_by_Unit where
+ journal_wrap
+ (Forall_Journal_Balance_by_Account j) =
+ Format.journal_wrap j
+
+-- Instances Balance.Expanded -> Balance.Balance_by_Unit
+
+instance
+ ( Functor j
+ , Journal_Balance_by_Unit j (Balance.Balance_by_Unit (Account.Account_Path as) u q)
+
+ -- NOTE: constraints from Balance.by_unit_of_expanded
+ , Account.Account (Account.Account_Path as)
+ , Ord as
+ , Ord u
+ , Quantity.Addable q
+ ) => Format.Journal_Wrap (j (Balance.Expanded as u q))
+ Forall_Journal_Balance_by_Unit where
+ journal_wrap =
+ Forall_Journal_Balance_by_Unit .
+ fmap (flip Balance.by_unit_of_expanded mempty)
+
+instance Format.Journal_Wrap Forall_Journal_Balance_by_Account_Expanded
+ Forall_Journal_Balance_by_Unit where
+ journal_wrap
+ (Forall_Journal_Balance_by_Account_Expanded j) =
+ Format.journal_wrap j
+
+-- Instances 'Format.Journal_Leijen_Table_Cells'
+
+instance
+ ( Format.Journal_Content j
+ , Journal j
+
+ , a ~ Format.Journal_Account j
+ , Account.Account a
+ , u ~ Format.Journal_Unit j
+ , Ord u
+ , q ~ Format.Journal_Quantity j
+ , Quantity.Addable (Format.Journal_Quantity j)
+ ) => Format.Journal_Leijen_Table_Cells j (Balance.Balance_by_Unit a u (Polarized q)) where
+ journal_leijen_table_cells jnl acc =
+ let Balance.Balance_by_Unit bal = Format.journal_content jnl in
+ Map.foldrWithKey
+ (\unit amt ->
+ let qty = Balance.unit_sum_quantity amt in
+ zipWith (:)
+ [ Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> Polarize.polarized_positive qty
+ , Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> Polarize.polarized_negative qty
+ , Leijen.Table.cell_of_forall_param jnl (unit, Polarize.depolarize qty)
+ , Leijen.Table.cell
+ ]
+ ) acc bal
+instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Unit) () where
+ journal_leijen_table_cells
+ (Const (Forall_Journal_Balance_by_Unit j)) =
+ Format.journal_leijen_table_cells j
+
+
+
+
+
+
+
+
+
+-- * Class 'Journal'
+
+class
+ ( Leijen.Table.Cell_of_forall_param j (Format.Journal_Unit j, Format.Journal_Quantity j)
+ , W.Leijen_of_forall_param j [Format.Journal_Transaction j]
+ ) => Journal (j:: * -> *) where
+ journal_posting
+ :: forall m. j m
+ -> Account.Account_Path (Format.Journal_Account_Section j)
+ -> Map (Format.Journal_Unit j)
+ (Format.Journal_Quantity j)
+ -> [Text] -- ^ Comments
+ -> Format.Journal_Posting j
+ journal_transaction
+ :: forall m. j m
+ -> Text -- ^ Wording
+ -> (Date, [Date])
+ -> Map (Account.Account_Path (Format.Journal_Account_Section j))
+ [Format.Journal_Posting j]
+ -> Format.Journal_Transaction j
+
+instance Journal JCC.Journal where
+ journal_posting _j acct
+ posting_amounts
+ posting_comments =
+ (JCC.posting acct)
+ { JCC.posting_amounts
+ , JCC.posting_comments
+ }
+ journal_transaction _j
+ transaction_wording
+ transaction_dates
+ transaction_postings =
+ JCC.transaction
+ { JCC.transaction_wording
+ , JCC.transaction_dates
+ , JCC.transaction_postings
+ }
+instance Journal Ledger.Journal where
+ journal_posting _j acct
+ posting_amounts
+ posting_comments =
+ (Ledger.posting acct)
+ { Ledger.posting_amounts
+ , Ledger.posting_comments
+ }
+ journal_transaction _j
+ transaction_wording
+ transaction_dates
+ transaction_postings =
+ Ledger.transaction
+ { Ledger.transaction_wording
+ , Ledger.transaction_dates
+ , Ledger.transaction_postings
+ }
+
+
+
+
+
+
+
+
+
+
+
+
+
+-- * Class 'Journal_Equilibrium_Transaction'
+
+class Journal_Equilibrium_Transaction j m where
+ journal_equilibrium_transaction
+ :: j m
+ -> C.Context
+ -> Context
+ -> Lang.Exercise_OC
+ -> Date
+ -> W.Doc
+
+instance
+ ( Format.Journal_Content j
+ , Journal j
+
+ , as ~ Format.Journal_Account_Section j
+ , Format.Journal_Account_Section j ~ Text
+ , Format.Journal_Account j ~ TreeMap.Path Text
+ , Num quantity
+ , quantity ~ Format.Journal_Quantity j
+ , Ord unit
+ , Ord quantity
+ , Quantity.Zero (Format.Journal_Quantity j)
+ , Quantity.Addable (Format.Journal_Quantity j)
+ , unit ~ Format.Journal_Unit j
+ ) => Journal_Equilibrium_Transaction
+ j (Balance.Balance_by_Account as unit (Polarized quantity)) where
+ journal_equilibrium_transaction
+ j c ctx oc now =
+ let bal_by_account = Format.journal_content j in
+ let Balance.Balance_by_Unit bal_by_unit =
+ Balance.by_unit_of_by_account bal_by_account mempty in
+ let postings =
+ Map.foldlWithKey
+ (\acc unit Balance.Unit_Sum{Balance.unit_sum_quantity} ->
+ let qty =
+ (case oc of
+ Lang.Exercise_Closing -> id
+ Lang.Exercise_Opening -> negate) $
+ Polarize.depolarize unit_sum_quantity in
+ case Quantity.quantity_sign qty of
+ LT ->
+ let account = snd $ ctx_account_equilibrium ctx in
+ Map.insertWith mappend account
+ [journal_posting j account
+ (Map.singleton unit qty)
+ [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
+ acc
+ EQ -> acc
+ GT ->
+ let account = fst $ ctx_account_equilibrium ctx in
+ Map.insertWith mappend account
+ [journal_posting j account
+ (Map.singleton unit qty)
+ [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
+ acc
)
- rows $
- let bal = Balance.inclusive balance in
- Data.Map.foldrWithKey
- (\unit amount acc ->
- ( maybe Nothing Balance.amount_sum_positive $ Data.Map.lookup unit $ bal
- , maybe Nothing Balance.amount_sum_negative $ Data.Map.lookup unit $ bal
- , Balance.amount_sum_balance amount
- ) : acc
- ) [] $ bal
- )
-
-write_by_amounts
- :: [[Table.Cell]]
- -> Data.Map.Map Unit (Balance.Amount_Sum Amount)
- -> [[Table.Cell]]
-write_by_amounts =
- foldr
- (\amount_sum ->
- zipWith (:)
- [ let amt = Balance.amount_sum_positive amount_sum in
- Table.cell
- { Table.cell_content = maybe W.empty Ledger.Write.amount amt
- , Table.cell_width = maybe 0 Ledger.Write.amount_length amt
- }
- , let amt = Balance.amount_sum_negative amount_sum in
- Table.cell
- { Table.cell_content = maybe W.empty Ledger.Write.amount amt
- , Table.cell_width = maybe 0 Ledger.Write.amount_length amt
- }
- , let amt = Balance.amount_sum_balance amount_sum in
- Table.cell
- { Table.cell_content = Ledger.Write.amount amt
- , Table.cell_width = Ledger.Write.amount_length amt
- }
- , Table.cell
- { Table.cell_content = W.empty
- , Table.cell_width = 0
- }
+ Map.empty
+ bal_by_unit
+ in
+ W.leijen_of_forall_param j [
+ journal_transaction j
+ (Lang.translate (C.lang c) (Lang.Description_Exercise oc))
+ (now{Time.utctDayTime=0}, []) $
+ Map.unionWith mappend postings $
+ TreeMap.flatten_with_Path
+ (\posting_account (Balance.Account_Sum amount_by_unit) ->
+ [ journal_posting j posting_account
+ (flip fmap amount_by_unit $
+ (case oc of
+ Lang.Exercise_Closing -> negate
+ Lang.Exercise_Opening -> id)
+ . Polarize.depolarize)
+ []
]
- )
+ )
+ bal_by_account
+ ]
+
+instance Journal_Equilibrium_Transaction (Const Forall_Journal_Balance_by_Account) () where
+ journal_equilibrium_transaction
+ (Const (Forall_Journal_Balance_by_Account j)) =
+ journal_equilibrium_transaction j
+
+{-
+instance
+ ToDoc (C.Context, Context, Date, Lang.Exercise_OC)
+ ( Forall_Journal_Balance_by_Account
+ , Forall_Journal_Balance_by_Unit ) where
+ toDoc c
+ ( Forall_Journal_Balance_by_Account bal_by_account
+ , Forall_Journal_Balance_by_Unit bal_by_unit
+ ) =
+ toDoc c (bal_by_account, bal_by_unit)
+-}
sourcephile / git / comptalang.git / blobdiff