+{-# 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 Control.Applicative (Const(..))
-import Prelude hiding (foldr)
-import Control.Monad (liftM, forM_)
+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.Map.Strict as Data.Map
-import Data.Monoid ((<>))
+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 qualified Data.Text.Lazy as TL
+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(..)
import System.Exit (exitSuccess)
import qualified System.IO as IO
import qualified Text.Parsec
+import Text.Show (Show(..))
-import Hcompta.Account (Account)
+import Hcompta.Account (Account_Tags)
import qualified Hcompta.Account as Account
-import qualified Hcompta.Account.Read as Account.Read
-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.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 Table
+import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
import qualified Hcompta.CLI.Write as Write
+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.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.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.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(..))
-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))
+-- 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_format_output :: Format_Output
- , ctx_account_equilibrium :: Account
- } deriving (Show)
+ , ctx_account_equilibrium :: (JCC.Account, JCC.Account)
+ } -- deriving (Show)
-data Format_Output
- = Format_Output_Table
- | Format_Output_Transaction { negate_transaction :: Bool }
+data Output_Format
+ = Output_Format_Table
+ | Output_Format_Transaction Lang.Exercise_OC
deriving (Eq, Show)
-nil :: Context -> Ctx
-nil context =
- Ctx
- { ctx_filter_balance = mempty
- , ctx_filter_posting = mempty
- , ctx_filter_transaction = mempty
+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_format_output = Format_Output_Table
- , ctx_account_equilibrium = Account.account
- (TL.toStrict $ W.displayT $ W.renderOneLine False $
- toDoc (Context.lang context) Lang.Message_Equilibrium)
- []
+ , 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
- let pad = replicate (length bin) ' '
return $ unlines $
- [ "SYNTAX "
- , " "++bin++" balance [-i JOURNAL_FILE]"
- , " "++pad++" [-b BALANCE_FILTER]"
- , " "++pad++" [-p POSTING_FILTER]"
- , " "++pad++" [-t TRANSACTION_FILTER]"
- , " "++pad++" [JOURNAL_FILE] [...]"
+ [ 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 =
+options :: C.Context -> Args.Options Context
+options c =
[ Option "b" ["filter-balance"]
- (ReqArg (\s context ctx -> do
- ctx_filter_balance <-
- liftM ((ctx_filter_balance ctx <>) . Filter.simplify) $
- liftIO $ Filter.Read.read Filter.Read.filter_balance s
- >>= \f -> case f of
- Left ko -> Write.fatal context $ ko
- Right ok -> return ok
- return $ ctx{ctx_filter_balance}) "FILTER")
- "filter at balance level, multiple uses are merged with a logical AND"
- , Option "p" ["filter-posting"]
- (ReqArg (\s context ctx -> do
- ctx_filter_posting <-
- liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $
- liftIO $ Filter.Read.read Filter.Read.filter_posting s
- >>= \f -> case f of
- Left ko -> Write.fatal context $ ko
- Right ok -> return ok
- return $ ctx{ctx_filter_posting}) "FILTER")
- "filter at posting level, multiple uses are merged with a logical AND"
+ (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 context ctx -> do
- ctx_filter_transaction <-
- liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
- liftIO $ Filter.Read.read Filter.Read.filter_transaction s
- >>= \f -> case f of
- Left ko -> Write.fatal context $ ko
- Right ok -> return ok
- return $ ctx{ctx_filter_transaction}) "FILTER")
- "filter at transaction level, multiple uses are merged with a logical AND"
+ (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 (\_context _ctx -> do
- usage >>= IO.hPutStr IO.stderr
- exitSuccess))
- "show this 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, multiple uses merge the data as would a concatenation do"
+ (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 context ctx -> do
+ (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 $
+ Just _ -> Write.fatal c $
W.text "--reduce-date option expects \"yes\", or \"no\" as value"
return $ ctx{ctx_reduce_date})
"[yes|no]")
"use advanced date reducer to speed up filtering"
-}
, Option "" ["redundant"]
- (OptArg (\arg context ctx -> do
+ (OptArg (\arg ctx -> do
ctx_redundant <- 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"
+ Just _ -> Write.fatal c Lang.Error_Option_Balance_Redundant
return $ ctx{ctx_redundant})
- "[yes|no]")
- "also print accounts with zero amount or the same amounts than its ascending account"
+ "[no|yes]") $
+ C.translate c Lang.Help_Option_Balance_Redundant
, Option "" ["heritage"]
- (OptArg (\arg context ctx -> do
+ (OptArg (\arg 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"
+ Just _ -> Write.fatal c Lang.Error_Option_Balance_Heritage
return $ ctx{ctx_heritage})
- "[yes|no]")
- "propagate amounts to ascending accounts"
+ "[yes|no]") $
+ C.translate c Lang.Help_Option_Balance_Heritage
, Option "" ["total"]
- (OptArg (\arg context ctx -> do
+ (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 context $
- W.text "--total option expects \"yes\", or \"no\" as value"
+ Just _ -> Write.fatal c Lang.Error_Option_Balance_Total
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
+ "[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
- (Account.Read.account <* Text.Parsec.eof)
+ (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"
+ _ -> 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, inputs) <- Args.parse context usage options (nil context, args)
- read_journals <-
- liftM Data.Either.partitionEithers $ do
- CLI.Ledger.paths context $ ctx_input ctx ++ inputs
- >>= do
- mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file
- (Ledger.Read.context ( ctx_filter_transaction ctx
- , ctx_filter_posting ctx )
- Ledger.journal)
- path
- >>= \x -> case x of
- Left ko -> return $ Left (path, ko)
- Right ok -> return $ Right ok
- case read_journals of
- (errs@(_:_), _journals) ->
- forM_ errs $ \(_path, err) -> do
- Write.fatal context $ err
- ([], journals) -> do
- 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)
- style_color <- Write.with_color context IO.stdout
- 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_balance_by_account
- :: Ctx
- -> [ Ledger.Journal (Const (Balance.Balance_by_Account (Amount.Sum Amount)) Ledger.Transaction) ]
- -> 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 = TreeMap.nodes
- (TreeMap.node_descendants node) in
- let is_worth =
+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 (:)
+ [ 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
- || (Data.Map.null descendants &&
- (Data.Foldable.any
- (not . Amount.is_zero . Amount.sum_balance)
- (Balance.get_Account_Sum $ Balance.inclusive balance)))
+ || (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 . Amount.is_zero . Amount.sum_balance)
- (Balance.get_Account_Sum $ Balance.exclusive balance))
+ (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
- || Data.Map.size
- ( Data.Map.filter
+ || Map.size
+ ( Map.filter
( Strict.maybe False
( Data.Foldable.any
- (not . Amount.is_zero . Amount.sum_balance)
+ (not . Quantity.quantity_null . Polarize.depolarize)
. Balance.get_Account_Sum
. Balance.inclusive )
. TreeMap.node_value )
descendants
) > 1
- in
- (&&) is_worth $
- Data.Foldable.any (Filter.test flt . (acct,)) $
- Balance.get_Account_Sum $
- Balance.inclusive balance
- )
- . 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
-
-table_by_account
- :: Ctx
- -> (amount -> Balance.Account_Sum (Amount.Sum Amount))
- -> TreeMap Account.Name amount
- -> [[Table.Cell]]
- -> [[Table.Cell]]
-table_by_account _ctx get_Account_Sum =
- let posting_type = Posting.Posting_Type_Regular in
- flip $ TreeMap.foldr_with_Path
- (\account balance rows ->
- foldr
- (\(amount_positive, amount_negative, amount) ->
+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 (:)
- [ Table.cell
- { Table.cell_content = maybe W.empty Amount.Write.amount amount_positive
- , Table.cell_width = maybe 0 Amount.Write.amount_length amount_positive
- }
- , Table.cell
- { Table.cell_content = maybe W.empty Amount.Write.amount amount_negative
- , Table.cell_width = maybe 0 Amount.Write.amount_length amount_negative
- }
- , Table.cell
- { Table.cell_content = Amount.Write.amount $ amount
- , Table.cell_width = Amount.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
- }
+ [ 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
]
- )
- rows $
- 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
- , maybe Nothing Amount.sum_negative $ Data.Map.lookup unit $ bal
- , Amount.sum_balance amount
- ) : acc
- ) [] $ bal
- )
-
-table_by_unit
- :: Data.Map.Map Unit (Amount.Sum Amount)
- -> [[Table.Cell]]
- -> [[Table.Cell]]
-table_by_unit =
- flip $ foldr
- (\amount_sum ->
- zipWith (:)
- [ let amt = Amount.sum_positive amount_sum in
- Table.cell
- { Table.cell_content = maybe W.empty Amount.Write.amount amt
- , Table.cell_width = maybe 0 Amount.Write.amount_length amt
- }
- , let amt = Amount.sum_negative amount_sum in
- Table.cell
- { Table.cell_content = maybe W.empty Amount.Write.amount amt
- , Table.cell_width = maybe 0 Amount.Write.amount_length amt
- }
- , let amt = Amount.sum_balance amount_sum in
- Table.cell
- { Table.cell_content = Amount.Write.amount amt
- , Table.cell_width = Amount.Write.amount_length amt
- }
- , Table.cell
- { Table.cell_content = W.empty
- , Table.cell_width = 0
- }
+ ) 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
+ )
+ 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