+{-# 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.GL where
-import Control.Monad (liftM)
+import Control.Applicative (Const(..), (<$>))
+import Control.Arrow (first, (+++))
+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.Functor.Compose (Compose(..))
-import qualified Data.List
-import qualified Data.Map.Strict as Data.Map
-import Data.Monoid ((<>))
-import qualified Data.Sequence
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import Prelude hiding (foldr)
+import Data.Bool
+import Data.Decimal (Decimal)
+import Data.Either (Either(..), partitionEithers)
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.), on, id, flip)
+import Data.Functor (Functor(..))
+import Data.List ((++), repeat)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord)
+import qualified Data.Sequence as Seq
+import qualified Data.Strict.Maybe as Strict
+import Data.String (String)
+import Data.Text (Text)
+import Prelude (Bounded(..), 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 System.IO (FilePath, IO)
-import Hcompta.Account (Account)
-import Hcompta.Amount (Amount)
-import qualified Hcompta.Amount as Amount
-import qualified Hcompta.Amount.Write as Amount.Write
+import qualified Hcompta.Account as Account
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.Context as C
+import qualified Hcompta.CLI.Env as CLI.Env
+import Hcompta.CLI.Format.Ledger ()
+import Hcompta.CLI.Format.JCC ()
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.Write as Date.Write
import qualified Hcompta.Filter as Filter
import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Filter.Reduce as Filter.Reduce
+import qualified Hcompta.Format.JCC as JCC
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.GL as GL
import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
+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.Filter.Amount as Filter.Amount
+import Hcompta.CLI.Format (Format(..), Formats)
+import qualified Hcompta.CLI.Format as Format
import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
-import Hcompta.GL (GL(..))
-import qualified Hcompta.GL as GL
+import qualified Hcompta.Lib.Parsec as R
+import qualified Hcompta.Unit as Unit
+import qualified Hcompta.Quantity as Quantity
-data Ctx
- = Ctx
- { ctx_input :: [FilePath]
- , ctx_filter_transaction :: Filter.Simplified
- (Filter.Test_Bool
- (Filter.Test_Transaction
- Ledger.Transaction))
- , ctx_filter_posting :: Filter.Simplified
- (Filter.Test_Bool
- (Filter.Test_Posting
- Ledger.Posting))
- , ctx_filter_gl :: Filter.Simplified
- (Filter.Test_Bool
- (Filter.Test_GL
- ( Account
- , Date
- , Amount.Sum Amount
- , Amount.Sum Amount )))
+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_gl :: forall b.
+ ( Filter.GL b
+ , Filter.Amount_Quantity
+ (Filter.GL_Amount b)
+ ~ Filter.Amount.Quantity
+ ) => Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_GL b))
+ , ctx_input :: [FilePath]
+ , ctx_input_format :: Formats
+ , ctx_output :: [(Write.Mode, FilePath)]
+ , ctx_output_format :: Maybe Formats
+
+ -- , ctx_filter_gl :: Filter.Simplified
+ -- (Filter.Filter_Bool
+ -- (Filter.Filter_GL
+ -- ( (Account_Tags, Ledger.Account)
+ -- , Date
+ -- , (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
+ -- , (Ledger.Unit, Polarize.Polarized Ledger.Quantity) )))
+ -- , ctx_filter_posting :: Filter.Simplified
+ -- (Filter.Filter_Bool
+ -- (Filter.Filter_Posting
+ -- (Ledger.Charted Ledger.Posting)))
, ctx_reduce_date :: Bool
- } deriving (Show)
-
-nil :: Ctx
-nil =
- Ctx
- { ctx_filter_gl = mempty
- , ctx_filter_posting = mempty
- , ctx_filter_transaction = mempty
+ } -- deriving (Show)
+
+context :: Context
+context =
+ Context
+ { ctx_filter_gl = Filter.Simplified $ Right True
+ -- , ctx_filter_posting = Filter.Simplified $ Right True
+ , ctx_filter_transaction = Filter.Simplified $ Right True
, ctx_input = []
+ , ctx_input_format = mempty
+ , ctx_output = []
+ , ctx_output_format = mempty
, ctx_reduce_date = True
}
-usage :: IO String
-usage = do
+usage :: C.Context -> IO String
+usage c = do
bin <- Env.getProgName
return $ unlines $
- [ "SYNTAX "
- , " "++bin++" gl"
- , " [-t TRANSACTION_FILTER]"
- , " [-p POSTING_FILTER]"
- , " [-g GL_FILTER]"
- , " JOURNAL_FILE [...]"
+ [ C.translate c Lang.Section_Description
+ , " "++C.translate c Lang.Help_Command_General_Ledger
, ""
- , usageInfo "OPTIONS" options
+ , C.translate c Lang.Section_Syntax
+ , " "++bin++" gl ["++C.translate c Lang.Type_Option++"] [...]"++
+ " ["++C.translate c Lang.Type_File_Journal++"] [...]"
+ , ""
+ , usageInfo (C.translate c Lang.Section_Options) (options c)
]
-options :: Args.Options Ctx
-options =
+options :: C.Context -> Args.Options Context
+options c =
[ Option "g" ["filter-gl"]
- (ReqArg (\s context ctx -> do
- ctx_filter_gl <-
- liftM (\t -> (<>) (ctx_filter_gl ctx)
- (Filter.simplify t (Nothing::Maybe ( Account
- , Date
- , Amount.Sum Amount
- , Amount.Sum Amount )))) $
- liftIO $ Filter.Read.read Filter.Read.test_gl s
- >>= \f -> case f of
- Left ko -> Write.fatal context $ ko
- Right ok -> return ok
- return $ ctx{ctx_filter_gl}) "FILTER")
- "filter at general ledger level, multiple uses are merged with a logical AND"
- , Option "p" ["filter-posting"]
- (ReqArg (\s context ctx -> do
+ (ReqArg (\s ctx -> do
+ filter <-
+ R.runParserT_with_Error
+ Filter.Read.filter_gl
+ Filter.Read.context "" s
+ case filter of
+ Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
+ Right flt ->
+ return $
+ ctx{ctx_filter_gl =
+ Filter.and (ctx_filter_gl ctx) $
+ (Filter.simplify $
+ Filter.Read.get_Forall_Filter_GL_Decimal <$> flt)
+ }) $
+ C.translate c Lang.Type_Filter_General_Ledger) $
+ C.translate c Lang.Help_Option_Filter_General_Ledger
+ {-, Option "p" ["filter-posting"]
+ (ReqArg (\s ctx -> do
ctx_filter_posting <-
- liftM (\t -> (<>) (ctx_filter_posting ctx)
- (Filter.simplify t (Nothing::Maybe Ledger.Posting))) $
- liftIO $ Filter.Read.read Filter.Read.test_posting s
+ 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
+ Left ko -> Write.fatal c $ ko
Right ok -> return ok
- return $ ctx{ctx_filter_posting}) "FILTER")
- "filter at posting level, multiple uses are merged with a logical AND"
+ return $ ctx{ctx_filter_posting}) $
+ 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 (\t -> (<>) (ctx_filter_transaction ctx)
- (Filter.simplify t (Nothing::Maybe Ledger.Transaction))) $
- liftIO $ Filter.Read.read Filter.Read.test_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
- exitWith 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}) "JOURNAL_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 "F" ["output-format"]
+ (ReqArg (\arg ctx -> do
+ ctx_output_format <- case arg of
+ "jcc" -> return $ Just $ Format_JCC ()
+ "ledger" -> return $ Just $ Format_Ledger ()
+ _ -> Write.fatal c $
+ W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
+ return $ ctx{ctx_output_format})
+ "[jcc|ledger]") $
+ "output format"
+ , 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 c 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"
+ -}
]
-run :: Context.Context -> [String] -> IO ()
-run context args = do
- (ctx, inputs) <- Args.parse context usage options (nil, args)
- read_journals <- do
- CLI.Ledger.paths context $ ctx_input ctx ++ inputs
+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, 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_GL])) -> do
+ let gl =
+ mconcat $
+ fmap Format.journal_flatten $
+ case ctx_output_format ctx of
+ Just f -> Format.journal_empty f:journals
+ Nothing -> journals
+ with_color <- Write.with_color c IO.stdout
+ W.displayIO IO.stdout $
+ W.renderPretty with_color 1.0 maxBound $
+ toDoc () $ Leijen.Table.table_of (c, ctx) gl
+ {-
+ 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)
+ -}
+
+instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_GL where
+ table_of (c, ctx) gl =
+ let lang = C.lang c in
+ zipWith id
+ [ Leijen.Table.column (Lang.translate lang Lang.Title_Account) Leijen.Table.Align_Left
+ , Leijen.Table.column (Lang.translate lang Lang.Title_Date) Leijen.Table.Align_Left
+ , 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_Running_debit) Leijen.Table.Align_Right
+ , Leijen.Table.column (Lang.translate lang Lang.Title_Running_credit) Leijen.Table.Align_Right
+ , Leijen.Table.column (Lang.translate lang Lang.Title_Running_balance) Leijen.Table.Align_Right
+ , Leijen.Table.column (Lang.translate lang Lang.Title_Description) Leijen.Table.Align_Left
+ ] $
+ Format.journal_leijen_table_cells
+ (Format.journal_filter ctx $
+ (Const::x -> Const x ()) gl) $
+ repeat []
+
+
+-- * 'GL.GL'
+
+-- ** Type 'Format_GL'
+
+type Format_Journal_GL
+ = Format
+ ( JCC.Journal GL_JCC)
+ (Ledger.Journal GL_Ledger)
+
+-- JCC
+type GL_JCC
+ = GL.GL (JCC.Charted JCC.Transaction)
+ -- = GL.GL JCC.Transaction
+instance Format.Journal (JCC.Journal GL_JCC) where
+ type Journal_Format (JCC.Journal GL_JCC)
+ = Format_Journal_GL
+ journal_format = Format_JCC
+
+-- Ledger
+type GL_Ledger
+ -- = GL.GL Ledger.Transaction
+ = GL.GL (Ledger.Charted Ledger.Transaction)
+instance Format.Journal (Ledger.Journal GL_Ledger) where
+ type Journal_Format (Ledger.Journal GL_Ledger)
+ = Format_Journal_GL
+ journal_format = Format_Ledger
+
+-- ** Class 'Journal'
+
+class
+ ( Format.Journal_Read j
+ , Ord (Account.Account_Section (Format.Journal_Account j))
+ , Leijen.Table.Cell_of_forall_param j
+ (TreeMap.Path (Account.Account_Section
+ (GL.Posting_Account (Format.Journal_Posting j))))
+ , Leijen.Table.Cell_of_forall_param j
+ (Format.Journal_Unit j, Format.Journal_Quantity j)
+ , Leijen.Table.Cell_of_forall_param j
+ (TreeMap.Path (Account.Account_Section (GL.Posting_Account
+ (Chart.Charted (Format.Journal_Account j)
+ (Format.Journal_Posting j)))))
+ , Polarize.Polarizable (Format.Journal_Quantity j)
+ ) => Journal j
+ where
+ journal_transaction_wording
+ :: forall m. j m
+ -> Format.Journal_Transaction j
+ -> Text
+ journal_posting_amounts
+ :: forall m. j m
+ -> Format.Journal_Posting j
+ -> Map (Format.Journal_Unit j)
+ (Format.Journal_Quantity j)
+ journal_posting_amounts_set
+ :: forall m. j m
+ -> Map (Format.Journal_Unit j)
+ (Format.Journal_Quantity j)
+ -> Format.Journal_Posting j
+ -> Format.Journal_Posting j
+
+instance Journal JCC.Journal
+ where
+ journal_transaction_wording _j = JCC.transaction_wording
+ journal_posting_amounts _j = JCC.posting_amounts
+ journal_posting_amounts_set _j posting_amounts p =
+ p { JCC.posting_amounts }
+instance Journal Ledger.Journal
+ where
+ journal_transaction_wording _j = Ledger.transaction_wording
+ journal_posting_amounts _j = Ledger.posting_amounts
+ journal_posting_amounts_set _j posting_amounts p =
+ p { Ledger.posting_amounts }
+
+-- ** Class 'Journal_GL'
+
+class
+ ( Format.Journal (j m)
+ , Format.Journal_Format (j m) ~ Format_Journal_GL
+ , Format.Journal_Read j
+ , Format.Journal_Monoid (j m)
+ , Format.Journal_Leijen_Table_Cells j m
+ , Format.Journal_Filter Context j m
+ ) => Journal_GL j m
+
+instance Journal_GL JCC.Journal GL_JCC
+instance Journal_GL Ledger.Journal GL_Ledger
+
+-- ** Type 'Forall_Journal_GL'
+
+data Forall_Journal_GL
+ = forall j m. Journal_GL j m
+ => Forall_Journal_GL (j m)
+
+instance Format.Journal Forall_Journal_GL where
+ type Journal_Format Forall_Journal_GL = Format_Journal_GL
+ journal_format
+ (Forall_Journal_GL j) =
+ Format.journal_format j
+instance Format.Journal_Empty Forall_Journal_GL where
+ journal_empty f =
+ case f of
+ Format_JCC () -> Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
+ Format_Ledger () -> Forall_Journal_GL (mempty::Ledger.Journal GL_Ledger)
+instance Format.Journal_Monoid Forall_Journal_GL where
+ journal_flatten
+ (Forall_Journal_GL j) =
+ Forall_Journal_GL $
+ Format.journal_flatten j
+ journal_fold f (Forall_Journal_GL j) =
+ Format.journal_fold (f . Forall_Journal_GL) j
+instance Monoid Forall_Journal_GL where
+ mempty = Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
+ mappend x y =
+ case (mappend `on` Format.journal_format) x y of
+ Format_JCC j -> Forall_Journal_GL j
+ Format_Ledger j -> Forall_Journal_GL 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_GL)
+journal_read ctx =
+ case ctx_input_format ctx of
+ Format_JCC () ->
+ let wrap (j::JCC.Journal GL_JCC)
+ = Forall_Journal_GL 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 GL_Ledger)
+ = Forall_Journal_GL 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
+
+
+-- Instances 'Format.Journal_Filter'
+
+instance
+ ( Functor j
+ , Format.Journal_Chart j
+ , Journal j
+ , Journal_GL j (GL.GL t)
+ , GL.Transaction t
+ , Format.Journal_Account_Section j ~ Text
+ , GL.Transaction_Posting t
+ ~ Chart.Charted (Format.Journal_Account j)
+ (Format.Journal_Posting j)
+ , GL.Posting_Quantity (GL.Transaction_Posting t)
+ ~ Map (Format.Journal_Unit j)
+ (Polarized (Format.Journal_Quantity j))
+ , Format.Journal_Quantity j ~ Decimal
+ , Format.Journal_Account_Section j
+ ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
+ , Ord (Format.Journal_Unit j)
+ , Unit.Unit (Format.Journal_Unit j)
+ ) => Format.Journal_Filter Context j (GL.GL t) where
+ journal_filter ctx j =
+ GL.GL .
+ TreeMap.map_Maybe_with_Path
+ (\acct expanded_lines ->
+ let chart = Format.journal_chart j in
+ case Map.mapMaybeWithKey
+ (\date seq_lines ->
+ case foldMap
+ (\line@GL.GL_Line
+ { GL.gl_line_transaction = _t
+ , GL.gl_line_posting = p
+ , GL.gl_line_sum = s
+ } ->
+ Map.foldlWithKey
+ (\acc unit qty ->
+ let sqty = (Map.!) s unit in
+ if Filter.test (ctx_filter_gl ctx)
+ ( (Chart.account_tags acct chart, acct)
+ , date
+ , (unit, Polarize.polarize qty)
+ , (unit, sqty)
+ )
+ then (Seq.|>) acc line
+ { GL.gl_line_posting =
+ journal_posting_amounts_set j
+ (Map.singleton unit qty) <$> p
+ , GL.gl_line_sum = Map.singleton unit sqty
+ }
+ else acc
+ )
+ Seq.empty
+ (journal_posting_amounts j $ Chart.charted p)
+ ) seq_lines
+ of
+ m | Seq.null m -> Nothing
+ m -> Just m
+ )
+ (GL.inclusive expanded_lines)
+ of
+ m | Map.null m -> Strict.Nothing
+ m -> Strict.Just m
+ ) .
+ (\(GL.Expanded gl) -> gl) .
+ GL.expanded <$> j
+instance Format.Journal_Filter Context (Const Forall_Journal_GL) () where
+ journal_filter ctx
+ (Const (Forall_Journal_GL j)) =
+ Const $ Forall_Journal_GL $
+ Format.journal_filter ctx j
+
+-- Instances 'Format.Journal_Leijen_Table_Cells'
+
+instance
+ ( Format.Journal_Content j
+ , Journal j
+
+ , Quantity.Addable (Format.Journal_Quantity j)
+ , GL.Transaction_Posting t
+ ~ Chart.Charted (Format.Journal_Account j)
+ (Format.Journal_Posting j)
+ , Format.Journal_Transaction j ~ GL.Transaction_Line t
+ , GL.Posting_Quantity (Chart.Charted (Format.Journal_Account j)
+ (Format.Journal_Posting j))
+ ~ Map (Format.Journal_Unit j)
+ (Polarized (Format.Journal_Quantity j))
+ , GL.Posting_Quantity (Format.Journal_Posting j)
+ ~ Map (Format.Journal_Unit j)
+ (Polarized (Format.Journal_Quantity j))
+ -- , GL.Posting_Account t ~ Format.Journal_Account j
+ -- , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
+ , Leijen.Table.Cell_of_forall_param j Date
+ , Leijen.Table.Cell_of_forall_param j Text
+ , Ord (Format.Journal_Unit j)
+ , GL.Transaction t
+ ) => Format.Journal_Leijen_Table_Cells j (GL.GL t) where
+ journal_leijen_table_cells jnl =
+ flip (TreeMap.foldr_with_Path
+ (\account ->
+ flip $ Map.foldrWithKey
+ (\date ->
+ flip $ foldr
+ (\GL.GL_Line
+ { GL.gl_line_transaction = t
+ , GL.gl_line_posting = p
+ , GL.gl_line_sum = s
+ } ->
+ flip (Map.foldrWithKey
+ (\unit qty ->
+ let ms = Map.lookup unit s in
+ zipWith (:)
+ [ cell_of account
+ , cell_of date
+ , cell_of $ (unit,) <$> Polarize.polarizable_positive qty
+ , cell_of $ (unit,) <$> Polarize.polarizable_negative qty
+ , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_positive)
+ , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_negative)
+ , cell_of $ (unit,) . Polarize.depolarize <$> ms
+ , cell_of $ journal_transaction_wording jnl t
+ ]
+ ))
+ (journal_posting_amounts jnl $ Chart.charted p)
+ )
+ )
+ )) $
+ (\(GL.GL x) -> x)
+ (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_GL) () where
+ journal_leijen_table_cells
+ (Const (Forall_Journal_GL j)) =
+ Format.journal_leijen_table_cells j
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+{-
+-- Instances GL.GL -> GL.Expanded
+
+instance
+ ( Functor j
+ , Journal_GL_Expanded j (GL.Expanded t)
+
+ -- NOTE: constraint from GL.expanded
+ , GL.Transaction t
+ ) => Format.Journal_Wrap (j (GL.GL t))
+ Forall_Journal_GL_Expanded where
+ journal_wrap =
+ Forall_Journal_GL_Expanded .
+ fmap GL.expanded
+
+instance Format.Journal_Wrap Forall_Journal_GL
+ Forall_Journal_GL_Expanded where
+ journal_wrap (Forall_Journal_GL j) = Format.journal_wrap j
+-}
+{-
+-- * 'GL.GL_Expanded'
+
+-- ** Type 'Format_GL_Expanded'
+
+type Format_Journal_GL_Expanded
+ = Format
+ ( JCC.Journal GL_Expanded_JCC)
+ (Ledger.Journal GL_Expanded_Ledger)
+
+-- JCC
+type GL_Expanded_JCC
+ = GL.Expanded (JCC.Charted JCC.Transaction)
+instance Format.Journal (JCC.Journal GL_Expanded_JCC) where
+ type Journal_Format (JCC.Journal GL_Expanded_JCC)
+ = Format_Journal_GL_Expanded
+ journal_format = Format_JCC
+
+-- Ledger
+type GL_Expanded_Ledger
+ = GL.Expanded (Ledger.Charted Ledger.Transaction)
+instance Format.Journal (Ledger.Journal GL_Expanded_Ledger) where
+ type Journal_Format (Ledger.Journal GL_Expanded_Ledger)
+ = Format_Journal_GL_Expanded
+ journal_format = Format_Ledger
+
+-- ** Class 'Journal_GL_Expanded'
+
+class
+ ( Format.Journal (j m)
+ , Format.Journal_Format (j m) ~ Format_Journal_GL_Expanded
+ -- , Format.Journal_Leijen_Table_Cells j m
+ , Format.Journal_Filter Context j m
+ ) => Journal_GL_Expanded j m where
+ journal_posting_amounts
+ :: j m
+ -> Format.Journal_Posting j
+ -> Map (Format.Journal_Unit j)
+ (Format.Journal_Quantity j)
+ journal_posting_amounts_set
+ :: j m
+ -> Map (Format.Journal_Unit j)
+ (Format.Journal_Quantity j)
+ -> Format.Journal_Posting j
+ -> Format.Journal_Posting j
+
+instance Journal_GL_Expanded JCC.Journal GL_Expanded_JCC
+ where
+ journal_posting_amounts _j = JCC.posting_amounts
+ journal_posting_amounts_set _j posting_amounts p =
+ p { JCC.posting_amounts }
+instance Journal_GL_Expanded Ledger.Journal GL_Expanded_Ledger
+ where
+ journal_posting_amounts _j = Ledger.posting_amounts
+ journal_posting_amounts_set _j posting_amounts p =
+ p { Ledger.posting_amounts }
+
+-- ** Type 'Forall_Journal_GL_Expanded'
+
+data Forall_Journal_GL_Expanded
+ = forall j m. Journal_GL_Expanded j m
+ => Forall_Journal_GL_Expanded (j m)
+
+instance Format.Journal Forall_Journal_GL_Expanded where
+ type Journal_Format Forall_Journal_GL_Expanded = Format_Journal_GL_Expanded
+ journal_format
+ (Forall_Journal_GL_Expanded j) =
+ Format.journal_format j
+
+-- Instances 'Format.Journal_Filter'
+
+instance
+ ( Functor j
+ , Format.Journal_Chart j
+ , Journal_GL_Expanded j (GL.Expanded t)
+ , GL.Transaction t
+ , Format.Journal_Account_Section j ~ Text
+ , GL.Transaction_Posting t ~ Chart.Charted (Format.Journal_Account j) (Format.Journal_Posting j)
+ , GL.Posting_Quantity (GL.Transaction_Posting t)
+ ~ Map (Format.Journal_Unit j) (Polarized (Format.Journal_Quantity j))
+ , Format.Journal_Quantity j ~ Decimal
+ , Format.Journal_Account_Section j
+ ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
+ , Ord (Format.Journal_Unit j)
+ , Unit.Unit (Format.Journal_Unit j)
+ ) => Format.Journal_Filter Context j (GL.Expanded t) where
+ journal_filter ctx j =
+ GL.Expanded .
+ TreeMap.map_Maybe_with_Path
+ (\acct expanded_lines ->
+ let chart = Format.journal_chart j in
+ case Map.mapMaybeWithKey
+ (\date seq_lines ->
+ case foldMap
+ (\line@GL.GL_Line
+ { GL.gl_line_transaction = _t
+ , GL.gl_line_posting = Chart.Charted ch p
+ , GL.gl_line_sum = s
+ } ->
+ Map.foldlWithKey
+ (\acc unit qty ->
+ let sqty = (Map.!) s unit in
+ if Filter.test (ctx_filter_gl ctx)
+ ( (Chart.account_tags acct chart, acct)
+ , date
+ , (unit, Polarize.polarize qty)
+ , (unit, sqty)
+ )
+ then (Seq.|>) acc line
+ { GL.gl_line_posting =
+ Chart.Charted ch $
+ journal_posting_amounts_set j
+ (Map.singleton unit qty) p
+ , GL.gl_line_sum = Map.singleton unit sqty
+ }
+ else acc
+ )
+ Seq.empty
+ (journal_posting_amounts j p)
+ ) seq_lines
+ of
+ m | Seq.null m -> Nothing
+ m -> Just m
+ )
+ (GL.inclusive expanded_lines)
+ of
+ m | Map.null m -> Strict.Nothing
+ m -> Strict.Just $ expanded_lines { GL.inclusive=m }
+ ) .
+ (\(GL.Expanded gl) -> gl) <$> j
+
+instance Format.Journal_Filter Context (Const Forall_Journal_GL_Expanded) () where
+ journal_filter ctx
+ (Const (Forall_Journal_GL_Expanded j)) =
+ Const $ Forall_Journal_GL_Expanded $
+ Format.journal_filter ctx j
+-}
+
+{-
+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, args)
+ read_journals <-
+ liftM partitionEithers $ do
+ CLI.Env.paths c $ ctx_input ctx ++ inputs
>>= do
mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file path
+ 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
- >>= return . Data.Either.partitionEithers
case read_journals of
(errs@(_:_), _journals) ->
- (flip mapM_) errs $ \(_path, err) -> do
- Write.fatal context $ err
+ forM_ errs $ \(_path, err) -> do
+ Write.fatal c $ 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: gl: " ++ show (ctx_filter_gl ctx)
- let gl = ledger_gl ctx journals
- style_color <- Write.with_color context IO.stdout
- W.displayIO IO.stdout $
- W.renderPretty style_color 1.0 maxBound $ do
- toDoc () $
- let title =
- TL.toStrict . W.displayT .
- W.renderCompact False .
- toDoc (Context.lang context) in
- zipWith id
- [ Table.column (title Lang.Message_Account) Table.Align_Left
- , Table.column (title Lang.Message_Date) Table.Align_Left
- , Table.column (title Lang.Message_Debit) Table.Align_Right
- , Table.column (title Lang.Message_Credit) Table.Align_Right
- , Table.column (title Lang.Message_Running_debit) Table.Align_Right
- , Table.column (title Lang.Message_Running_credit) Table.Align_Right
- , Table.column (title Lang.Message_Running_balance) Table.Align_Right
- , Table.column (title Lang.Message_Description) Table.Align_Left
- ] $
- write_gl gl (repeat [])
+ Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
+ Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
+ Write.debug c $ "filter: gl: " ++ show (ctx_filter_gl ctx)
+ let (amount_styles, gl) = ledger_gl ctx journals
+ let lang = C.lang c
+ Write.write c Write.style (ctx_output ctx) $ do
+ toDoc () $ do
+ zipWith id
+ [ Table.column (Lang.translate lang Lang.Title_Account) Table.Align_Left
+ , Table.column (Lang.translate lang Lang.Title_Date) Table.Align_Left
+ , Table.column (Lang.translate lang Lang.Title_Debit) Table.Align_Right
+ , Table.column (Lang.translate lang Lang.Title_Credit) Table.Align_Right
+ , Table.column (Lang.translate lang Lang.Title_Running_debit) Table.Align_Right
+ , Table.column (Lang.translate lang Lang.Title_Running_credit) Table.Align_Right
+ , Table.column (Lang.translate lang Lang.Title_Running_balance) Table.Align_Right
+ , Table.column (Lang.translate lang Lang.Title_Description) Table.Align_Left
+ ] $ do
+ write_gl amount_styles gl (repeat [])
+-}
+{-
ledger_gl
- :: Ctx
- -> [Ledger.Journal]
- -> GL Ledger.Transaction
+ :: Context
+ -> [ Ledger.Journal (GL.GL (Ledger.Charted Ledger.Transaction)) ]
+ -> ( Ledger.Amount.Styles
+ , GL (Ledger.Charted Ledger.Transaction)
+ )
ledger_gl ctx journals =
- let reducer_date =
- if ctx_reduce_date ctx
- then Filter.Reduce.bool_date <$> ctx_filter_transaction ctx
- else mempty in
- let gl =
- Data.Foldable.foldl'
- (flip $ Ledger.Journal.fold
- (\Ledger.Journal{Ledger.journal_transactions=ts} ->
- flip (Data.Foldable.foldl'
- (flip $ (\t ->
- case Filter.test (ctx_filter_transaction ctx) t of
- False -> id
- True ->
- GL.general_ledger
- t{ Ledger.transaction_postings =
- Data.Map.map
- (Data.Foldable.foldMap
- (\p ->
- Data.Map.foldrWithKey
- (\u a -> (:) p{Ledger.posting_amounts=Data.Map.singleton u a})
- []
- (Ledger.posting_amounts p)
- )
- ) $
- Data.Map.mapMaybe
- (\ps -> case Data.List.filter
- (Filter.test $ ctx_filter_posting ctx) ps of
- [] -> Nothing
- x -> Just x)
- (Ledger.transaction_postings t)
- }
- ))) $ Compose $ Compose $
- case Filter.simplified reducer_date of
- Left reducer -> do
- let (ts_reduced, _date_sieve) = Filter.Reduce.map_date reducer ts
- ts_reduced
- Right True -> ts:[]
- Right False -> []
- )
- )
- GL.nil
- journals in
+ let (_chart, amount_styles, gl) =
+ foldl'
+ (flip (\j ->
+ flip mappend $
+ ( Ledger.journal_chart j
+ , Ledger.journal_amount_styles j
+ , ) $
+ Ledger.Journal.fold
+ (\Ledger.Journal
+ { Ledger.journal_sections=g
+ } -> mappend g
+ ) j mempty
+ ))
+ mempty journals in
+ (amount_styles,) $
GL.GL $
- Lib.TreeMap.map_Maybe_with_Path
+ TreeMap.map_Maybe_with_Path
(\acct expanded_lines ->
- case Data.Map.mapMaybeWithKey
+ case Map.mapMaybeWithKey
(\date seq_lines ->
- case Data.Foldable.foldMap
+ case foldMap
(\line@GL.GL_Line
{ GL.gl_line_transaction = _t
- , GL.gl_line_posting = p
+ , GL.gl_line_posting = Ledger.Charted c p
, GL.gl_line_sum = s
} ->
- if Filter.test (ctx_filter_gl ctx)
- ( acct
- , date
- , Amount.sum $ snd $ Data.Map.elemAt 0 $ Ledger.posting_amounts p
- , snd . Data.Map.elemAt 0 <$> s
+ Map.foldlWithKey
+ (\acc unit qty ->
+ let sqty = (Map.!) s unit in
+ if Filter.test (ctx_filter_gl ctx)
+ ( (Chart.account_tags acct c, acct)
+ , date
+ , (unit, Polarize.polarize qty)
+ , (unit, sqty)
+ )
+ then (Seq.|>) acc line
+ { GL.gl_line_posting = Ledger.Charted c p
+ { Ledger.posting_amounts = Map.singleton unit qty }
+ , GL.gl_line_sum = Map.singleton unit sqty
+ }
+ else acc
)
- then Data.Sequence.singleton line
- else Data.Sequence.empty
+ Seq.empty
+ (Ledger.posting_amounts p)
) seq_lines of
- m | Data.Sequence.null m -> Nothing
+ m | Seq.null m -> Nothing
m -> Just m
)
(GL.inclusive expanded_lines) of
- m | Data.Map.null m -> Nothing
- m -> Just m
+ m | Map.null m -> Strict.Nothing
+ m -> Strict.Just m
) $
GL.expanded gl
write_gl
- :: GL Ledger.Transaction
+ :: Ledger.Amount.Styles
+ -> GL (Ledger.Charted Ledger.Transaction)
-> [[Table.Cell]]
-> [[Table.Cell]]
-write_gl (GL gl) =
- flip (Lib.TreeMap.foldr_with_Path
+write_gl amount_styles (GL gl) =
+ flip (TreeMap.foldr_with_Path
(\acct ->
- flip $ Data.Map.foldrWithKey
+ flip $ Map.foldrWithKey
(\date ->
- flip (Data.Foldable.foldr
+ flip (foldr
(\GL.GL_Line
- { GL.gl_line_transaction = t
- , GL.gl_line_posting = p
+ { GL.gl_line_transaction = Ledger.Charted _ t
+ , GL.gl_line_posting = Ledger.Charted _ p
, GL.gl_line_sum = s
} ->
- flip (Data.Map.foldrWithKey
- (\unit amt -> do
- let ptype = Ledger.Posting_Type_Regular
- let descr = Ledger.transaction_description t
+ flip (Map.foldrWithKey
+ (\unit qty ->
+ let ms = Map.lookup unit s in
zipWith (:)
- [ Table.cell
- { Table.cell_content = Ledger.Write.account ptype acct
- , Table.cell_width = Ledger.Write.account_length ptype acct
- }
+ [ let ptype = Ledger.Posting_Type_Regular in
+ Table.cell
+ { Table.cell_content = Ledger.Write.account ptype acct
+ , Table.cell_width = Ledger.Write.account_length ptype acct
+ }
, Table.cell
{ Table.cell_content = Date.Write.date date
, Table.cell_width = Date.Write.date_length date
}
- , Table.cell
- { Table.cell_content = maybe W.empty Amount.Write.amount (Amount.sumable_positive amt)
- , Table.cell_width = maybe 0 Amount.Write.amount_length (Amount.sumable_positive amt)
- }
- , Table.cell
- { Table.cell_content = maybe W.empty Amount.Write.amount (Amount.sumable_negative amt)
- , Table.cell_width = maybe 0 Amount.Write.amount_length (Amount.sumable_negative amt)
- }
- , Table.cell
- { Table.cell_content = maybe W.empty Amount.Write.amount (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
- , Table.cell_width = maybe 0 Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
- }
- , Table.cell
- { Table.cell_content = maybe W.empty Amount.Write.amount (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
- , Table.cell_width = maybe 0 Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
- }
- , Table.cell
- { Table.cell_content = maybe W.empty Amount.Write.amount (Data.Map.lookup unit $ Amount.sum_balance s)
- , Table.cell_width = maybe 0 Amount.Write.amount_length (Data.Map.lookup unit $ Amount.sum_balance s)
- }
- , Table.cell
- { Table.cell_content = toDoc () descr
- , Table.cell_width = Text.length descr
- }
+ , cell_amount unit (Polarize.polarizable_positive qty)
+ , cell_amount unit (Polarize.polarizable_negative qty)
+ , cell_amount unit (ms >>= Polarize.polarized_positive)
+ , cell_amount unit (ms >>= Polarize.polarized_negative)
+ , cell_amount unit (liftM Polarize.depolarize ms)
+ , let descr = Ledger.transaction_wording t in
+ Table.cell
+ { Table.cell_content = toDoc () descr
+ , Table.cell_width = Text.length descr
+ }
]
))
(Ledger.posting_amounts p)
)
))
gl
+ where
+ cell_amount :: Ledger.Unit -> Maybe Ledger.Quantity -> Table.Cell
+ cell_amount unit mq =
+ case mq of
+ Nothing -> Table.cell
+ Just q ->
+ let a = Ledger.Amount.Amount unit q in
+ let sa = Ledger.Amount.style amount_styles a in
+ Table.cell
+ { Table.cell_content = Amount.Write.amount sa
+ , Table.cell_width = Amount.Write.amount_length sa
+ }
+-}
sourcephile / git / comptalang.git / blobdiff