cli/Hcompta/CLI/Command/GL.hs

   1 {-# LANGUAGE ExistentialQuantification #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE Rank2Types #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TupleSections #-}
  10 {-# LANGUAGE TypeFamilies #-}
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 module Hcompta.CLI.Command.GL where
  13
  14 import           Control.Applicative (Const(..), (<$>))
  15 import           Control.Arrow (first, (+++))
  16 import           Control.Monad (Monad(..), liftM, mapM)
  17 import           Control.Monad.IO.Class (liftIO)
  18 import           Data.Bool
  19 import           Data.Decimal (Decimal)
  20 import           Data.Either (Either(..), partitionEithers)
  21 import           Data.Foldable (Foldable(..))
  22 import           Data.Function (($), (.), on, id, flip)
  23 import           Data.Functor (Functor(..))
  24 import           Data.List ((++), repeat)
  25 import           Data.Map.Strict (Map)
  26 import qualified Data.Map.Strict as Map
  27 import           Data.Maybe (Maybe(..))
  28 import           Data.Monoid (Monoid(..))
  29 import           Data.Ord (Ord)
  30 import qualified Data.Sequence as Seq
  31 import qualified Data.Strict.Maybe as Strict
  32 import           Data.String (String)
  33 import           Data.Text (Text)
  34 import           Prelude (Bounded(..), unlines, zipWith)
  35 import           System.Console.GetOpt
  36                  ( ArgDescr(..)
  37                  , OptDescr(..)
  38                  , usageInfo
  39                  )
  40 import           System.Environment as Env (getProgName)
  41 import           System.Exit (exitSuccess)
  42 import qualified System.IO as IO
  43 import           System.IO (FilePath, IO)
  44
  45 import qualified Hcompta.Account as Account
  46 import qualified Hcompta.CLI.Args as Args
  47 import qualified Hcompta.CLI.Context as C
  48 import qualified Hcompta.CLI.Env as CLI.Env
  49 import           Hcompta.CLI.Format.Ledger ()
  50 import           Hcompta.CLI.Format.JCC ()
  51 import qualified Hcompta.CLI.Lang as Lang
  52 import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
  53 import qualified Hcompta.CLI.Write as Write
  54 import qualified Hcompta.Chart as Chart
  55 import           Hcompta.Date (Date)
  56 import qualified Hcompta.Filter as Filter
  57 import qualified Hcompta.Filter.Read as Filter.Read
  58 import qualified Hcompta.Format.JCC as JCC
  59 import qualified Hcompta.Format.Ledger as Ledger
  60 import qualified Hcompta.GL as GL
  61 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  62 import qualified Hcompta.Lib.TreeMap as TreeMap
  63 import           Hcompta.Polarize (Polarized)
  64 import qualified Hcompta.Polarize as Polarize
  65 import qualified Hcompta.Posting as Posting
  66 import qualified Hcompta.Filter.Amount as Filter.Amount
  67 import           Hcompta.CLI.Format (Format(..), Formats)
  68 import qualified Hcompta.CLI.Format as Format
  69 import qualified Hcompta.Lib.Leijen as W
  70 import qualified Hcompta.Lib.Parsec as R
  71 import qualified Hcompta.Unit as Unit
  72 import qualified Hcompta.Quantity as Quantity
  73
  74 data Context
  75  =   Context
  76  { ctx_filter_transaction :: forall t.
  77                              ( Filter.Transaction t
  78                              , Filter.Amount_Quantity
  79                                (Posting.Posting_Amount
  80                                (Filter.Transaction_Posting t))
  81                                ~ Filter.Amount.Quantity
  82                              ) => Filter.Simplified
  83                                   (Filter.Filter_Bool
  84                                   (Filter.Filter_Transaction t))
  85  , ctx_filter_gl          :: forall b.
  86                              ( Filter.GL b
  87                              , Filter.Amount_Quantity
  88                                (Filter.GL_Amount b)
  89                                ~ Filter.Amount.Quantity
  90                              ) => Filter.Simplified
  91                                   (Filter.Filter_Bool
  92                                   (Filter.Filter_GL b))
  93  , ctx_input              :: [FilePath]
  94  , ctx_input_format       :: Formats
  95  , ctx_output             :: [(Write.Mode, FilePath)]
  96  , ctx_output_format      :: Maybe Formats
  97
  98  -- , ctx_filter_gl          :: Filter.Simplified
  99  --                             (Filter.Filter_Bool
 100  --                             (Filter.Filter_GL
 101  --                             ( (Account_Tags, Ledger.Account)
 102  --                             , Date
 103  --                             , (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
 104  --                             , (Ledger.Unit, Polarize.Polarized Ledger.Quantity) )))
 105  -- , ctx_filter_posting     :: Filter.Simplified
 106  --                             (Filter.Filter_Bool
 107  --                             (Filter.Filter_Posting
 108  --                             (Ledger.Charted Ledger.Posting)))
 109  , ctx_reduce_date        :: Bool
 110  } -- deriving (Show)
 111
 112 context :: Context
 113 context =
 114         Context
 115          { ctx_filter_gl          = Filter.Simplified $ Right True
 116          -- , ctx_filter_posting     = Filter.Simplified $ Right True
 117          , ctx_filter_transaction = Filter.Simplified $ Right True
 118          , ctx_input              = []
 119          , ctx_input_format       = mempty
 120          , ctx_output             = []
 121          , ctx_output_format      = mempty
 122          , ctx_reduce_date        = True
 123          }
 124
 125 usage :: C.Context -> IO String
 126 usage c = do
 127         bin <- Env.getProgName
 128         return $ unlines $
 129                 [ C.translate c Lang.Section_Description
 130                 , "  "++C.translate c Lang.Help_Command_General_Ledger
 131                 , ""
 132                 , C.translate c Lang.Section_Syntax
 133                 , "  "++bin++" gl ["++C.translate c Lang.Type_Option++"] [...]"++
 134                                 " ["++C.translate c Lang.Type_File_Journal++"] [...]"
 135                 , ""
 136                 , usageInfo (C.translate c Lang.Section_Options) (options c)
 137                 ]
 138
 139 options :: C.Context -> Args.Options Context
 140 options c =
 141         [ Option "g" ["filter-gl"]
 142          (ReqArg (\s ctx -> do
 143                 filter <-
 144                         R.runParserT_with_Error
 145                          Filter.Read.filter_gl
 146                          Filter.Read.context "" s
 147                 case filter of
 148                  Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
 149                  Right flt ->
 150                         return $
 151                                 ctx{ctx_filter_gl =
 152                                         Filter.and (ctx_filter_gl ctx) $
 153                                         (Filter.simplify $
 154                                                 Filter.Read.get_Forall_Filter_GL_Decimal <$> flt)
 155                                  }) $
 156                 C.translate c Lang.Type_Filter_General_Ledger) $
 157                 C.translate c Lang.Help_Option_Filter_General_Ledger
 158         {-, Option "p" ["filter-posting"]
 159          (ReqArg (\s ctx -> do
 160                 ctx_filter_posting <-
 161                         liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $
 162                         liftIO $ Filter.Read.read Filter.Read.filter_posting s
 163                         >>= \f -> case f of
 164                          Left  ko -> Write.fatal c $ ko
 165                          Right ok -> return ok
 166                 return $ ctx{ctx_filter_posting}) $
 167                 C.translate c Lang.Type_Filter_Posting) $
 168                 C.translate c Lang.Help_Option_Filter_Posting
 169         -}
 170         , Option "t" ["filter-transaction"]
 171          (ReqArg (\s ctx -> do
 172                 filter <-
 173                         R.runParserT_with_Error
 174                          Filter.Read.filter_transaction
 175                          Filter.Read.context "" s
 176                 case filter of
 177                  Left ko -> Write.fatal c ko
 178                  Right flt ->
 179                         return $
 180                                 ctx{ctx_filter_transaction =
 181                                         Filter.and (ctx_filter_transaction ctx) $
 182                                         (Filter.simplify $
 183                                                 Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
 184                                  }) $
 185                 C.translate c Lang.Type_Filter_Transaction) $
 186                 C.translate c Lang.Help_Option_Filter_Transaction
 187         , Option "h" ["help"]
 188          (NoArg (\_ctx -> do
 189                 usage c >>= IO.hPutStr IO.stderr
 190                 exitSuccess)) $
 191                 C.translate c Lang.Help_Option_Help
 192         , Option "i" ["input"]
 193          (ReqArg (\s ctx -> do
 194                 return $ ctx{ctx_input=s:ctx_input ctx}) $
 195                 C.translate c Lang.Type_File_Journal) $
 196                 C.translate c Lang.Help_Option_Input
 197         , Option "f" ["input-format"]
 198          (OptArg (\arg ctx -> do
 199                 ctx_input_format <- case arg of
 200                  Nothing       -> return $ Format_JCC ()
 201                  Just "jcc"    -> return $ Format_JCC ()
 202                  Just "ledger" -> return $ Format_Ledger ()
 203                  Just _        -> Write.fatal c $
 204                         W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
 205                 return $ ctx{ctx_input_format})
 206           "[jcc|ledger]")
 207           "input format"
 208         , Option "o" ["output"]
 209          (ReqArg (\s ctx -> do
 210                 return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
 211                 C.translate c Lang.Type_File) $
 212                 C.translate c Lang.Help_Option_Output
 213         , Option "F" ["output-format"]
 214          (ReqArg (\arg ctx -> do
 215                 ctx_output_format <- case arg of
 216                  "jcc"    -> return $ Just $ Format_JCC ()
 217                  "ledger" -> return $ Just $ Format_Ledger ()
 218                  _        -> Write.fatal c $
 219                         W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
 220                 return $ ctx{ctx_output_format})
 221           "[jcc|ledger]") $
 222                 "output format"
 223         , Option "O" ["overwrite"]
 224          (ReqArg (\s ctx -> do
 225                 return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
 226                 C.translate c Lang.Type_File) $
 227                 C.translate c Lang.Help_Option_Overwrite
 228         {- NOTE: not used so far.
 229         , Option "" ["reduce-date"]
 230          (OptArg (\arg c ctx -> do
 231                 ctx_reduce_date <- case arg of
 232                  Nothing    -> return $ True
 233                  Just "yes" -> return $ True
 234                  Just "no"  -> return $ False
 235                  Just _     -> Write.fatal c $
 236                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 237                 return $ ctx{ctx_reduce_date})
 238           "[yes|no]")
 239          "use advanced date reducer to speed up filtering"
 240         -}
 241         ]
 242
 243 run :: C.Context -> [String] -> IO ()
 244 run c args = do
 245         (ctx, inputs) <-
 246                 first (\x ->
 247                         case ctx_output x of
 248                          [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
 249                          _  -> x) <$>
 250                 Args.parse c usage options (context, args)
 251         input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
 252         read_journals <- mapM (liftIO . journal_read ctx) input_paths
 253         case partitionEithers read_journals of
 254          (errs@(_:_), _journals) -> Write.fatals c errs
 255          ([], (journals::[Forall_Journal_GL])) -> do
 256                 let gl =
 257                         mconcat $
 258                         fmap Format.journal_flatten $
 259                         case ctx_output_format ctx of
 260                          Just f -> Format.journal_empty f:journals
 261                          Nothing -> journals
 262                 with_color <- Write.with_color c IO.stdout
 263                 W.displayIO IO.stdout $
 264                         W.renderPretty with_color 1.0 maxBound $
 265                         toDoc () $ Leijen.Table.table_of (c, ctx) gl
 266                 {-
 267                 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 268                 Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
 269                 Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
 270                 -}
 271
 272 instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_GL where
 273         table_of (c, ctx) gl =
 274                 let lang = C.lang c in
 275                 zipWith id
 276                  [ Leijen.Table.column (Lang.translate lang Lang.Title_Account)         Leijen.Table.Align_Left
 277                  , Leijen.Table.column (Lang.translate lang Lang.Title_Date)            Leijen.Table.Align_Left
 278                  , Leijen.Table.column (Lang.translate lang Lang.Title_Debit)           Leijen.Table.Align_Right
 279                  , Leijen.Table.column (Lang.translate lang Lang.Title_Credit)          Leijen.Table.Align_Right
 280                  , Leijen.Table.column (Lang.translate lang Lang.Title_Running_debit)   Leijen.Table.Align_Right
 281                  , Leijen.Table.column (Lang.translate lang Lang.Title_Running_credit)  Leijen.Table.Align_Right
 282                  , Leijen.Table.column (Lang.translate lang Lang.Title_Running_balance) Leijen.Table.Align_Right
 283                  , Leijen.Table.column (Lang.translate lang Lang.Title_Description)     Leijen.Table.Align_Left
 284                  ] $
 285                 Format.journal_leijen_table_cells
 286                  (Format.journal_filter ctx $
 287                         (Const::x -> Const x ()) gl) $
 288                 repeat []
 289
 290
 291 -- * 'GL.GL'
 292
 293 -- ** Type 'Format_GL'
 294
 295 type Format_Journal_GL
 296  = Format
 297    (   JCC.Journal GL_JCC)
 298    (Ledger.Journal GL_Ledger)
 299
 300 -- JCC
 301 type GL_JCC
 302  = GL.GL (JCC.Charted JCC.Transaction)
 303  -- = GL.GL JCC.Transaction
 304 instance Format.Journal (JCC.Journal GL_JCC) where
 305         type Journal_Format   (JCC.Journal GL_JCC)
 306          = Format_Journal_GL
 307         journal_format = Format_JCC
 308
 309 -- Ledger
 310 type GL_Ledger
 311  -- = GL.GL Ledger.Transaction
 312  = GL.GL (Ledger.Charted Ledger.Transaction)
 313 instance Format.Journal (Ledger.Journal GL_Ledger) where
 314         type Journal_Format   (Ledger.Journal GL_Ledger)
 315          = Format_Journal_GL
 316         journal_format = Format_Ledger
 317
 318 -- ** Class 'Journal'
 319
 320 class
 321  ( Format.Journal_Read j
 322  , Ord (Account.Account_Section (Format.Journal_Account j))
 323  , Leijen.Table.Cell_of_forall_param j
 324     (TreeMap.Path (Account.Account_Section
 325      (GL.Posting_Account (Format.Journal_Posting j))))
 326  , Leijen.Table.Cell_of_forall_param j
 327     (Format.Journal_Unit j, Format.Journal_Quantity j)
 328  , Leijen.Table.Cell_of_forall_param j
 329     (TreeMap.Path (Account.Account_Section (GL.Posting_Account
 330      (Chart.Charted (Format.Journal_Account j)
 331       (Format.Journal_Posting j)))))
 332  , Polarize.Polarizable (Format.Journal_Quantity j)
 333  ) => Journal j
 334  where
 335         journal_transaction_wording
 336          :: forall m. j m
 337          -> Format.Journal_Transaction j
 338          -> Text
 339         journal_posting_amounts
 340          :: forall m. j m
 341          -> Format.Journal_Posting j
 342          -> Map (Format.Journal_Unit j)
 343                 (Format.Journal_Quantity j)
 344         journal_posting_amounts_set
 345          :: forall m. j m
 346          -> Map (Format.Journal_Unit j)
 347                 (Format.Journal_Quantity j)
 348          -> Format.Journal_Posting j
 349          -> Format.Journal_Posting j
 350
 351 instance Journal JCC.Journal
 352  where
 353         journal_transaction_wording _j = JCC.transaction_wording
 354         journal_posting_amounts     _j = JCC.posting_amounts
 355         journal_posting_amounts_set _j posting_amounts p =
 356                 p { JCC.posting_amounts }
 357 instance Journal Ledger.Journal
 358  where
 359         journal_transaction_wording _j = Ledger.transaction_wording
 360         journal_posting_amounts     _j = Ledger.posting_amounts
 361         journal_posting_amounts_set _j posting_amounts p =
 362                 p { Ledger.posting_amounts }
 363
 364 -- ** Class 'Journal_GL'
 365
 366 class
 367  ( Format.Journal (j m)
 368  , Format.Journal_Format (j m) ~ Format_Journal_GL
 369  , Format.Journal_Read j
 370  , Format.Journal_Monoid (j m)
 371  , Format.Journal_Leijen_Table_Cells j m
 372  , Format.Journal_Filter Context j m
 373  ) => Journal_GL j m
 374
 375 instance Journal_GL JCC.Journal    GL_JCC
 376 instance Journal_GL Ledger.Journal GL_Ledger
 377
 378 -- ** Type 'Forall_Journal_GL'
 379
 380 data    Forall_Journal_GL
 381  = forall j m. Journal_GL  j m
 382  =>     Forall_Journal_GL (j m)
 383
 384 instance Format.Journal Forall_Journal_GL where
 385         type Journal_Format   Forall_Journal_GL = Format_Journal_GL
 386         journal_format
 387          (Forall_Journal_GL j) =
 388                 Format.journal_format j
 389 instance Format.Journal_Empty Forall_Journal_GL where
 390         journal_empty f =
 391                 case f of
 392                  Format_JCC    () -> Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
 393                  Format_Ledger () -> Forall_Journal_GL (mempty::Ledger.Journal GL_Ledger)
 394 instance Format.Journal_Monoid Forall_Journal_GL where
 395         journal_flatten
 396          (Forall_Journal_GL j) =
 397                 Forall_Journal_GL $
 398                 Format.journal_flatten j
 399         journal_fold f (Forall_Journal_GL j) =
 400                 Format.journal_fold (f . Forall_Journal_GL) j
 401 instance Monoid Forall_Journal_GL where
 402         mempty = Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
 403         mappend x y =
 404                 case (mappend `on` Format.journal_format) x y of
 405                  Format_JCC    j -> Forall_Journal_GL j
 406                  Format_Ledger j -> Forall_Journal_GL j
 407         mconcat js =
 408                 case js of
 409                  [] -> mempty
 410                  j:jn -> foldl' mappend j jn
 411
 412
 413 -- *** 'journal_read'
 414
 415 type Journal_Filter_Simplified transaction
 416  = Filter.Simplified
 417    (Filter.Filter_Bool
 418    (Filter.Filter_Transaction transaction))
 419 type Journal_Read_Cons txn
 420  = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
 421 journal_read
 422  :: Context -> FilePath
 423  -> IO (Either (Format.Message W.Doc) Forall_Journal_GL)
 424 journal_read ctx =
 425         case ctx_input_format ctx of
 426          Format_JCC () ->
 427                 let wrap (j::JCC.Journal GL_JCC)
 428                          = Forall_Journal_GL j in
 429                 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
 430                          = Filter.Filtered (ctx_filter_transaction ctx) in
 431                 liftM ((+++) Format.Message wrap) .
 432                 Format.journal_read cons
 433          Format_Ledger () ->
 434                 let wrap (j::Ledger.Journal GL_Ledger)
 435                          = Forall_Journal_GL j in
 436                 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
 437                          = Filter.Filtered (ctx_filter_transaction ctx) in
 438                 liftM ((+++) Format.Message wrap) .
 439                 Format.journal_read cons
 440
 441
 442 -- Instances 'Format.Journal_Filter'
 443
 444 instance
 445  ( Functor j
 446  , Format.Journal_Chart j
 447  , Journal j
 448  , Journal_GL j (GL.GL t)
 449  , GL.Transaction t
 450  , Format.Journal_Account_Section j ~ Text
 451  , GL.Transaction_Posting t
 452    ~ Chart.Charted (Format.Journal_Account j)
 453                    (Format.Journal_Posting j)
 454  , GL.Posting_Quantity (GL.Transaction_Posting t)
 455    ~ Map (Format.Journal_Unit j)
 456          (Polarized (Format.Journal_Quantity j))
 457  , Format.Journal_Quantity j ~ Decimal
 458  , Format.Journal_Account_Section j
 459    ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
 460  , Ord (Format.Journal_Unit j)
 461  , Unit.Unit (Format.Journal_Unit j)
 462  ) => Format.Journal_Filter Context j (GL.GL t) where
 463         journal_filter ctx j =
 464                 GL.GL .
 465                 TreeMap.map_Maybe_with_Path
 466                  (\acct expanded_lines ->
 467                         let chart = Format.journal_chart j in
 468                         case Map.mapMaybeWithKey
 469                          (\date seq_lines ->
 470                                 case foldMap
 471                                  (\line@GL.GL_Line
 472                                  { GL.gl_line_transaction = _t
 473                                  , GL.gl_line_posting     = p
 474                                  , GL.gl_line_sum         = s
 475                                  } ->
 476                                         Map.foldlWithKey
 477                                          (\acc unit qty ->
 478                                                 let sqty = (Map.!) s unit in
 479                                                 if Filter.test (ctx_filter_gl ctx)
 480                                                  ( (Chart.account_tags acct chart, acct)
 481                                                  , date
 482                                                  , (unit, Polarize.polarize qty)
 483                                                  , (unit, sqty)
 484                                                  )
 485                                                 then (Seq.|>) acc line
 486                                                  { GL.gl_line_posting =
 487                                                         journal_posting_amounts_set j
 488                                                          (Map.singleton unit qty) <$> p
 489                                                  , GL.gl_line_sum = Map.singleton unit sqty
 490                                                  }
 491                                                 else acc
 492                                          )
 493                                          Seq.empty
 494                                          (journal_posting_amounts j $ Chart.charted p)
 495                                  ) seq_lines
 496                                  of
 497                                  m | Seq.null m -> Nothing
 498                                  m -> Just m
 499                          )
 500                          (GL.inclusive expanded_lines)
 501                          of
 502                                 m | Map.null m -> Strict.Nothing
 503                                 m -> Strict.Just m
 504                  ) .
 505                 (\(GL.Expanded gl) -> gl) .
 506                 GL.expanded <$> j
 507 instance Format.Journal_Filter Context (Const Forall_Journal_GL) () where
 508         journal_filter ctx
 509          (Const (Forall_Journal_GL j)) =
 510                 Const $ Forall_Journal_GL $
 511                 Format.journal_filter ctx j
 512
 513 -- Instances 'Format.Journal_Leijen_Table_Cells'
 514
 515 instance
 516  ( Format.Journal_Content j
 517  , Journal j
 518
 519  , Quantity.Addable (Format.Journal_Quantity j)
 520  , GL.Transaction_Posting t
 521    ~ Chart.Charted (Format.Journal_Account j)
 522                    (Format.Journal_Posting j)
 523  , Format.Journal_Transaction j ~ GL.Transaction_Line t
 524  , GL.Posting_Quantity (Chart.Charted (Format.Journal_Account j)
 525                        (Format.Journal_Posting j))
 526    ~ Map (Format.Journal_Unit j)
 527          (Polarized (Format.Journal_Quantity j))
 528  , GL.Posting_Quantity (Format.Journal_Posting j)
 529    ~ Map (Format.Journal_Unit j)
 530          (Polarized (Format.Journal_Quantity j))
 531  -- , GL.Posting_Account t ~ Format.Journal_Account j
 532  -- , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
 533  , Leijen.Table.Cell_of_forall_param j Date
 534  , Leijen.Table.Cell_of_forall_param j Text
 535  , Ord (Format.Journal_Unit j)
 536  , GL.Transaction t
 537  ) => Format.Journal_Leijen_Table_Cells j (GL.GL t) where
 538         journal_leijen_table_cells jnl =
 539                 flip (TreeMap.foldr_with_Path
 540                  (\account ->
 541                         flip $ Map.foldrWithKey
 542                          (\date ->
 543                                 flip $ foldr
 544                                  (\GL.GL_Line
 545                                          { GL.gl_line_transaction = t
 546                                          , GL.gl_line_posting     = p
 547                                          , GL.gl_line_sum         = s
 548                                          } ->
 549                                         flip (Map.foldrWithKey
 550                                          (\unit qty ->
 551                                                 let ms = Map.lookup unit s in
 552                                                 zipWith (:)
 553                                                  [ cell_of account
 554                                                  , cell_of date
 555                                                  , cell_of $ (unit,) <$> Polarize.polarizable_positive qty
 556                                                  , cell_of $ (unit,) <$> Polarize.polarizable_negative qty
 557                                                  , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_positive)
 558                                                  , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_negative)
 559                                                  , cell_of $ (unit,) . Polarize.depolarize <$> ms
 560                                                  , cell_of $ journal_transaction_wording jnl t
 561                                                  ]
 562                                          ))
 563                                          (journal_posting_amounts jnl $ Chart.charted p)
 564                                  )
 565                          )
 566                  )) $
 567                  (\(GL.GL x) -> x)
 568                  (Format.journal_content jnl)
 569                 where
 570                         cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
 571                         cell_of = Leijen.Table.cell_of_forall_param jnl
 572
 573 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_GL) () where
 574         journal_leijen_table_cells
 575          (Const (Forall_Journal_GL j)) =
 576                 Format.journal_leijen_table_cells j
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601 {-
 602 -- Instances GL.GL -> GL.Expanded
 603
 604 instance
 605  ( Functor j
 606  , Journal_GL_Expanded j (GL.Expanded t)
 607
 608  -- NOTE: constraint from GL.expanded
 609  , GL.Transaction t
 610  ) => Format.Journal_Wrap (j (GL.GL t))
 611                           Forall_Journal_GL_Expanded where
 612         journal_wrap =
 613                 Forall_Journal_GL_Expanded .
 614                 fmap GL.expanded
 615
 616 instance Format.Journal_Wrap Forall_Journal_GL
 617                              Forall_Journal_GL_Expanded where
 618         journal_wrap (Forall_Journal_GL j) = Format.journal_wrap j
 619 -}
 620 {-
 621 -- * 'GL.GL_Expanded'
 622
 623 -- ** Type 'Format_GL_Expanded'
 624
 625 type Format_Journal_GL_Expanded
 626  = Format
 627    (   JCC.Journal GL_Expanded_JCC)
 628    (Ledger.Journal GL_Expanded_Ledger)
 629
 630 -- JCC
 631 type GL_Expanded_JCC
 632  = GL.Expanded (JCC.Charted JCC.Transaction)
 633 instance Format.Journal (JCC.Journal GL_Expanded_JCC) where
 634         type Journal_Format   (JCC.Journal GL_Expanded_JCC)
 635          = Format_Journal_GL_Expanded
 636         journal_format = Format_JCC
 637
 638 -- Ledger
 639 type GL_Expanded_Ledger
 640  = GL.Expanded (Ledger.Charted Ledger.Transaction)
 641 instance Format.Journal (Ledger.Journal GL_Expanded_Ledger) where
 642         type Journal_Format   (Ledger.Journal GL_Expanded_Ledger)
 643          = Format_Journal_GL_Expanded
 644         journal_format = Format_Ledger
 645
 646 -- ** Class 'Journal_GL_Expanded'
 647
 648 class
 649  ( Format.Journal (j m)
 650  , Format.Journal_Format (j m) ~ Format_Journal_GL_Expanded
 651  -- , Format.Journal_Leijen_Table_Cells j m
 652  , Format.Journal_Filter Context j m
 653  ) => Journal_GL_Expanded j m where
 654         journal_posting_amounts
 655          :: j m
 656          -> Format.Journal_Posting j
 657          -> Map (Format.Journal_Unit j)
 658                 (Format.Journal_Quantity j)
 659         journal_posting_amounts_set
 660          :: j m
 661          -> Map (Format.Journal_Unit j)
 662                 (Format.Journal_Quantity j)
 663          -> Format.Journal_Posting j
 664          -> Format.Journal_Posting j
 665
 666 instance Journal_GL_Expanded    JCC.Journal GL_Expanded_JCC
 667  where
 668         journal_posting_amounts     _j = JCC.posting_amounts
 669         journal_posting_amounts_set _j posting_amounts p =
 670                 p { JCC.posting_amounts }
 671 instance Journal_GL_Expanded Ledger.Journal GL_Expanded_Ledger
 672  where
 673         journal_posting_amounts     _j = Ledger.posting_amounts
 674         journal_posting_amounts_set _j posting_amounts p =
 675                 p { Ledger.posting_amounts }
 676
 677 -- ** Type 'Forall_Journal_GL_Expanded'
 678
 679 data    Forall_Journal_GL_Expanded
 680  = forall j m. Journal_GL_Expanded  j m
 681  =>     Forall_Journal_GL_Expanded (j m)
 682
 683 instance Format.Journal Forall_Journal_GL_Expanded where
 684         type Journal_Format   Forall_Journal_GL_Expanded = Format_Journal_GL_Expanded
 685         journal_format
 686          (Forall_Journal_GL_Expanded j) =
 687                 Format.journal_format j
 688
 689 -- Instances 'Format.Journal_Filter'
 690
 691 instance
 692  ( Functor j
 693  , Format.Journal_Chart j
 694  , Journal_GL_Expanded j (GL.Expanded t)
 695  , GL.Transaction t
 696  , Format.Journal_Account_Section j ~ Text
 697  , GL.Transaction_Posting t ~ Chart.Charted (Format.Journal_Account j) (Format.Journal_Posting j)
 698  , GL.Posting_Quantity (GL.Transaction_Posting t)
 699    ~ Map (Format.Journal_Unit j) (Polarized (Format.Journal_Quantity j))
 700  , Format.Journal_Quantity j ~ Decimal
 701  , Format.Journal_Account_Section j
 702    ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
 703  , Ord (Format.Journal_Unit j)
 704  , Unit.Unit (Format.Journal_Unit j)
 705  ) => Format.Journal_Filter Context j (GL.Expanded t) where
 706         journal_filter ctx j =
 707                 GL.Expanded .
 708                 TreeMap.map_Maybe_with_Path
 709                  (\acct expanded_lines ->
 710                         let chart = Format.journal_chart j in
 711                         case Map.mapMaybeWithKey
 712                          (\date seq_lines ->
 713                                 case foldMap
 714                                  (\line@GL.GL_Line
 715                                  { GL.gl_line_transaction = _t
 716                                  , GL.gl_line_posting     = Chart.Charted ch p
 717                                  , GL.gl_line_sum         = s
 718                                  } ->
 719                                         Map.foldlWithKey
 720                                          (\acc unit qty ->
 721                                                 let sqty = (Map.!) s unit in
 722                                                 if Filter.test (ctx_filter_gl ctx)
 723                                                  ( (Chart.account_tags acct chart, acct)
 724                                                  , date
 725                                                  , (unit, Polarize.polarize qty)
 726                                                  , (unit, sqty)
 727                                                  )
 728                                                 then (Seq.|>) acc line
 729                                                  { GL.gl_line_posting =
 730                                                         Chart.Charted ch $
 731                                                         journal_posting_amounts_set j
 732                                                          (Map.singleton unit qty) p
 733                                                  , GL.gl_line_sum = Map.singleton unit sqty
 734                                                  }
 735                                                 else acc
 736                                          )
 737                                          Seq.empty
 738                                          (journal_posting_amounts j p)
 739                                  ) seq_lines
 740                                  of
 741                                  m | Seq.null m -> Nothing
 742                                  m -> Just m
 743                          )
 744                          (GL.inclusive expanded_lines)
 745                          of
 746                                 m | Map.null m -> Strict.Nothing
 747                                 m -> Strict.Just $ expanded_lines { GL.inclusive=m }
 748                  ) .
 749                 (\(GL.Expanded gl) -> gl) <$> j
 750
 751 instance Format.Journal_Filter Context (Const Forall_Journal_GL_Expanded) () where
 752         journal_filter ctx
 753          (Const (Forall_Journal_GL_Expanded j)) =
 754                 Const $ Forall_Journal_GL_Expanded $
 755                 Format.journal_filter ctx j
 756 -}
 757
 758 {-
 759 run :: C.Context -> [String] -> IO ()
 760 run c args = do
 761         (ctx, inputs) <-
 762                 first (\x ->
 763                         case ctx_output x of
 764                          [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
 765                          _  -> x) <$>
 766                 Args.parse c usage options (context, args)
 767         read_journals <-
 768                 liftM partitionEithers $ do
 769                 CLI.Env.paths c $ ctx_input ctx ++ inputs
 770                 >>= do
 771                         mapM $ \path -> do
 772                                 liftIO $ runExceptT $ Ledger.Read.file
 773                                  (Ledger.Read.context ( ctx_filter_transaction ctx
 774                                                       , ctx_filter_posting     ctx )
 775                                                       Ledger.journal)
 776                                  path
 777                                 >>= \x -> case x of
 778                                  Left  ko -> return $ Left (path, ko)
 779                                  Right ok -> return $ Right ok
 780         case read_journals of
 781          (errs@(_:_), _journals) ->
 782                 forM_ errs $ \(_path, err) -> do
 783                         Write.fatal c $ err
 784          ([], journals) -> do
 785                 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 786                 Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
 787                 Write.debug c $ "filter: gl: " ++ show (ctx_filter_gl ctx)
 788                 let (amount_styles, gl) = ledger_gl ctx journals
 789                 let lang = C.lang c
 790                 Write.write c Write.style (ctx_output ctx) $ do
 791                 toDoc () $ do
 792                 zipWith id
 793                  [ Table.column (Lang.translate lang Lang.Title_Account)         Table.Align_Left
 794                  , Table.column (Lang.translate lang Lang.Title_Date)            Table.Align_Left
 795                  , Table.column (Lang.translate lang Lang.Title_Debit)           Table.Align_Right
 796                  , Table.column (Lang.translate lang Lang.Title_Credit)          Table.Align_Right
 797                  , Table.column (Lang.translate lang Lang.Title_Running_debit)   Table.Align_Right
 798                  , Table.column (Lang.translate lang Lang.Title_Running_credit)  Table.Align_Right
 799                  , Table.column (Lang.translate lang Lang.Title_Running_balance) Table.Align_Right
 800                  , Table.column (Lang.translate lang Lang.Title_Description)     Table.Align_Left
 801                  ] $ do
 802                 write_gl amount_styles gl (repeat [])
 803 -}
 804
 805 {-
 806 ledger_gl
 807  :: Context
 808  -> [ Ledger.Journal (GL.GL (Ledger.Charted Ledger.Transaction)) ]
 809  -> ( Ledger.Amount.Styles
 810     , GL (Ledger.Charted Ledger.Transaction)
 811     )
 812 ledger_gl ctx journals =
 813         let (_chart, amount_styles, gl) =
 814                 foldl'
 815                  (flip (\j ->
 816                         flip mappend $
 817                         ( Ledger.journal_chart j
 818                         , Ledger.journal_amount_styles j
 819                         , ) $
 820                         Ledger.Journal.fold
 821                          (\Ledger.Journal
 822                                  { Ledger.journal_sections=g
 823                                  } -> mappend g
 824                          ) j mempty
 825                  ))
 826                  mempty journals in
 827         (amount_styles,) $
 828         GL.GL $
 829         TreeMap.map_Maybe_with_Path
 830          (\acct expanded_lines ->
 831                 case Map.mapMaybeWithKey
 832                  (\date seq_lines ->
 833                         case foldMap
 834                          (\line@GL.GL_Line
 835                          { GL.gl_line_transaction = _t
 836                          , GL.gl_line_posting     = Ledger.Charted c p
 837                          , GL.gl_line_sum         = s
 838                          } ->
 839                                 Map.foldlWithKey
 840                                  (\acc unit qty ->
 841                                         let sqty = (Map.!) s unit in
 842                                         if Filter.test (ctx_filter_gl ctx)
 843                                          ( (Chart.account_tags acct c, acct)
 844                                          , date
 845                                          , (unit, Polarize.polarize qty)
 846                                          , (unit, sqty)
 847                                          )
 848                                         then (Seq.|>) acc line
 849                                          { GL.gl_line_posting = Ledger.Charted c p
 850                                                  { Ledger.posting_amounts = Map.singleton unit qty }
 851                                          , GL.gl_line_sum = Map.singleton unit sqty
 852                                          }
 853                                         else acc
 854                                  )
 855                                  Seq.empty
 856                                  (Ledger.posting_amounts p)
 857                          ) seq_lines of
 858                          m | Seq.null m -> Nothing
 859                          m -> Just m
 860                  )
 861                  (GL.inclusive expanded_lines) of
 862                         m | Map.null m -> Strict.Nothing
 863                         m -> Strict.Just m
 864                 ) $
 865         GL.expanded gl
 866
 867 write_gl
 868  :: Ledger.Amount.Styles
 869  -> GL (Ledger.Charted Ledger.Transaction)
 870  -> [[Table.Cell]]
 871  -> [[Table.Cell]]
 872 write_gl amount_styles (GL gl) =
 873         flip (TreeMap.foldr_with_Path
 874          (\acct ->
 875                 flip $ Map.foldrWithKey
 876                  (\date ->
 877                         flip (foldr
 878                          (\GL.GL_Line
 879                                  { GL.gl_line_transaction = Ledger.Charted _ t
 880                                  , GL.gl_line_posting     = Ledger.Charted _ p
 881                                  , GL.gl_line_sum         = s
 882                                  } ->
 883                                 flip (Map.foldrWithKey
 884                                  (\unit qty ->
 885                                         let ms = Map.lookup unit s in
 886                                         zipWith (:)
 887                                                 [ let ptype = Ledger.Posting_Type_Regular in
 888                                                         Table.cell
 889                                                          { Table.cell_content = Ledger.Write.account        ptype acct
 890                                                          , Table.cell_width   = Ledger.Write.account_length ptype acct
 891                                                          }
 892                                                 , Table.cell
 893                                                  { Table.cell_content = Date.Write.date        date
 894                                                  , Table.cell_width   = Date.Write.date_length date
 895                                                  }
 896                                                 , cell_amount unit (Polarize.polarizable_positive qty)
 897                                                 , cell_amount unit (Polarize.polarizable_negative qty)
 898                                                 , cell_amount unit (ms >>= Polarize.polarized_positive)
 899                                                 , cell_amount unit (ms >>= Polarize.polarized_negative)
 900                                                 , cell_amount unit (liftM Polarize.depolarize ms)
 901                                                 , let descr = Ledger.transaction_wording t in
 902                                                         Table.cell
 903                                                          { Table.cell_content = toDoc ()    descr
 904                                                          , Table.cell_width   = Text.length descr
 905                                                          }
 906                                                 ]
 907                                  ))
 908                                  (Ledger.posting_amounts p)
 909                          ))
 910                  )
 911          ))
 912          gl
 913         where
 914                 cell_amount :: Ledger.Unit -> Maybe Ledger.Quantity -> Table.Cell
 915                 cell_amount unit mq =
 916                         case mq of
 917                          Nothing -> Table.cell
 918                          Just q ->
 919                                 let a  = Ledger.Amount.Amount unit q in
 920                                 let sa = Ledger.Amount.style amount_styles a in
 921                                 Table.cell
 922                                  { Table.cell_content = Amount.Write.amount        sa
 923                                  , Table.cell_width   = Amount.Write.amount_length sa
 924                                  }
 925 -}