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_Wrap (j m) Forall_Journal_GL_Expanded
 372  , Format.Journal_Leijen_Table_Cells j m
 373  , Format.Journal_Filter Context j m
 374  ) => Journal_GL j m
 375
 376 instance Journal_GL JCC.Journal    GL_JCC
 377 instance Journal_GL Ledger.Journal GL_Ledger
 378
 379 -- ** Type 'Forall_Journal_GL'
 380
 381 data    Forall_Journal_GL
 382  = forall j m. Journal_GL  j m
 383  =>     Forall_Journal_GL (j m)
 384
 385 instance Format.Journal Forall_Journal_GL where
 386         type Journal_Format   Forall_Journal_GL = Format_Journal_GL
 387         journal_format
 388          (Forall_Journal_GL j) =
 389                 Format.journal_format j
 390 instance Format.Journal_Empty Forall_Journal_GL where
 391         journal_empty f =
 392                 case f of
 393                  Format_JCC    () -> Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
 394                  Format_Ledger () -> Forall_Journal_GL (mempty::Ledger.Journal GL_Ledger)
 395 instance Format.Journal_Monoid Forall_Journal_GL where
 396         journal_flatten
 397          (Forall_Journal_GL j) =
 398                 Forall_Journal_GL $
 399                 Format.journal_flatten j
 400         journal_fold f (Forall_Journal_GL j) =
 401                 Format.journal_fold (f . Forall_Journal_GL) j
 402 instance Monoid Forall_Journal_GL where
 403         mempty = Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
 404         mappend x y =
 405                 case (mappend `on` Format.journal_format) x y of
 406                  Format_JCC    j -> Forall_Journal_GL j
 407                  Format_Ledger j -> Forall_Journal_GL j
 408         mconcat js =
 409                 case js of
 410                  [] -> mempty
 411                  j:jn -> foldl' mappend j jn
 412
 413
 414 -- *** 'journal_read'
 415
 416 type Journal_Filter_Simplified transaction
 417  = Filter.Simplified
 418    (Filter.Filter_Bool
 419    (Filter.Filter_Transaction transaction))
 420 type Journal_Read_Cons txn
 421  = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
 422 journal_read
 423  :: Context -> FilePath
 424  -> IO (Either (Format.Message W.Doc) Forall_Journal_GL)
 425 journal_read ctx =
 426         case ctx_input_format ctx of
 427          Format_JCC () ->
 428                 let wrap (j::JCC.Journal GL_JCC)
 429                          = Forall_Journal_GL j in
 430                 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
 431                          = Filter.Filtered (ctx_filter_transaction ctx) in
 432                 liftM ((+++) Format.Message wrap) .
 433                 Format.journal_read cons
 434          Format_Ledger () ->
 435                 let wrap (j::Ledger.Journal GL_Ledger)
 436                          = Forall_Journal_GL j in
 437                 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
 438                          = Filter.Filtered (ctx_filter_transaction ctx) in
 439                 liftM ((+++) Format.Message wrap) .
 440                 Format.journal_read cons
 441
 442
 443 -- Instances 'Format.Journal_Filter'
 444
 445 instance
 446  ( Functor j
 447  , Format.Journal_Chart j
 448  , Journal j
 449  , Journal_GL j (GL.GL t)
 450  , GL.Transaction t
 451  , Format.Journal_Account_Section j ~ Text
 452  , GL.Transaction_Posting t
 453    ~ Chart.Charted (Format.Journal_Account j)
 454                    (Format.Journal_Posting j)
 455  , GL.Posting_Quantity (GL.Transaction_Posting t)
 456    ~ Map (Format.Journal_Unit j)
 457          (Polarized (Format.Journal_Quantity j))
 458  , Format.Journal_Quantity j ~ Decimal
 459  , Format.Journal_Account_Section j
 460    ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
 461  , Ord (Format.Journal_Unit j)
 462  , Unit.Unit (Format.Journal_Unit j)
 463  ) => Format.Journal_Filter Context j (GL.GL t) where
 464         journal_filter ctx j =
 465                 GL.GL .
 466                 TreeMap.map_Maybe_with_Path
 467                  (\acct expanded_lines ->
 468                         let chart = Format.journal_chart j in
 469                         case Map.mapMaybeWithKey
 470                          (\date seq_lines ->
 471                                 case foldMap
 472                                  (\line@GL.GL_Line
 473                                  { GL.gl_line_transaction = _t
 474                                  , GL.gl_line_posting     = p
 475                                  , GL.gl_line_sum         = s
 476                                  } ->
 477                                         Map.foldlWithKey
 478                                          (\acc unit qty ->
 479                                                 let sqty = (Map.!) s unit in
 480                                                 if Filter.test (ctx_filter_gl ctx)
 481                                                  ( (Chart.account_tags acct chart, acct)
 482                                                  , date
 483                                                  , (unit, Polarize.polarize qty)
 484                                                  , (unit, sqty)
 485                                                  )
 486                                                 then (Seq.|>) acc line
 487                                                  { GL.gl_line_posting =
 488                                                         journal_posting_amounts_set j
 489                                                          (Map.singleton unit qty) <$> p
 490                                                  , GL.gl_line_sum = Map.singleton unit sqty
 491                                                  }
 492                                                 else acc
 493                                          )
 494                                          Seq.empty
 495                                          (journal_posting_amounts j $ Chart.charted p)
 496                                  ) seq_lines
 497                                  of
 498                                  m | Seq.null m -> Nothing
 499                                  m -> Just m
 500                          )
 501                          (GL.inclusive expanded_lines)
 502                          of
 503                                 m | Map.null m -> Strict.Nothing
 504                                 m -> Strict.Just m
 505                  ) .
 506                 (\(GL.Expanded gl) -> gl) .
 507                 GL.expanded <$> j
 508 instance Format.Journal_Filter Context (Const Forall_Journal_GL) () where
 509         journal_filter ctx
 510          (Const (Forall_Journal_GL j)) =
 511                 Const $ Forall_Journal_GL $
 512                 Format.journal_filter ctx j
 513
 514 -- Instances 'Format.Journal_Leijen_Table_Cells'
 515
 516 instance
 517  ( Format.Journal_Content j
 518  , Journal j
 519
 520  , Quantity.Addable (Format.Journal_Quantity j)
 521  , GL.Transaction_Posting t
 522    ~ Chart.Charted (Format.Journal_Account j)
 523                    (Format.Journal_Posting j)
 524  , Format.Journal_Transaction j ~ GL.Transaction_Line t
 525  , GL.Posting_Quantity (Chart.Charted (Format.Journal_Account j)
 526                        (Format.Journal_Posting j))
 527    ~ Map (Format.Journal_Unit j)
 528          (Polarized (Format.Journal_Quantity j))
 529  , GL.Posting_Quantity (Format.Journal_Posting j)
 530    ~ Map (Format.Journal_Unit j)
 531          (Polarized (Format.Journal_Quantity j))
 532  -- , GL.Posting_Account t ~ Format.Journal_Account j
 533  -- , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
 534  , Leijen.Table.Cell_of_forall_param j Date
 535  , Leijen.Table.Cell_of_forall_param j Text
 536  , Ord (Format.Journal_Unit j)
 537  , GL.Transaction t
 538  ) => Format.Journal_Leijen_Table_Cells j (GL.GL t) where
 539         journal_leijen_table_cells jnl =
 540                 flip (TreeMap.foldr_with_Path
 541                  (\account ->
 542                         flip $ Map.foldrWithKey
 543                          (\date ->
 544                                 flip $ foldr
 545                                  (\GL.GL_Line
 546                                          { GL.gl_line_transaction = t
 547                                          , GL.gl_line_posting     = p
 548                                          , GL.gl_line_sum         = s
 549                                          } ->
 550                                         flip (Map.foldrWithKey
 551                                          (\unit qty ->
 552                                                 let ms = Map.lookup unit s in
 553                                                 zipWith (:)
 554                                                  [ cell_of account
 555                                                  , cell_of date
 556                                                  , cell_of $ (unit,) <$> Polarize.polarizable_positive qty
 557                                                  , cell_of $ (unit,) <$> Polarize.polarizable_negative qty
 558                                                  , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_positive)
 559                                                  , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_negative)
 560                                                  , cell_of $ (unit,) . Polarize.depolarize <$> ms
 561                                                  , cell_of $ journal_transaction_wording jnl t
 562                                                  ]
 563                                          ))
 564                                          (journal_posting_amounts jnl $ Chart.charted p)
 565                                  )
 566                          )
 567                  )) $
 568                  (\(GL.GL x) -> x)
 569                  (Format.journal_content jnl)
 570                 where
 571                         cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
 572                         cell_of = Leijen.Table.cell_of_forall_param jnl
 573
 574 instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_GL) () where
 575         journal_leijen_table_cells
 576          (Const (Forall_Journal_GL j)) =
 577                 Format.journal_leijen_table_cells j
 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 {-
 603 -- Instances GL.GL -> GL.Expanded
 604
 605 instance
 606  ( Functor j
 607  , Journal_GL_Expanded j (GL.Expanded t)
 608
 609  -- NOTE: constraint from GL.expanded
 610  , GL.Transaction t
 611  ) => Format.Journal_Wrap (j (GL.GL t))
 612                           Forall_Journal_GL_Expanded where
 613         journal_wrap =
 614                 Forall_Journal_GL_Expanded .
 615                 fmap GL.expanded
 616
 617 instance Format.Journal_Wrap Forall_Journal_GL
 618                              Forall_Journal_GL_Expanded where
 619         journal_wrap (Forall_Journal_GL j) = Format.journal_wrap j
 620 -}
 621 {-
 622 -- * 'GL.GL_Expanded'
 623
 624 -- ** Type 'Format_GL_Expanded'
 625
 626 type Format_Journal_GL_Expanded
 627  = Format
 628    (   JCC.Journal GL_Expanded_JCC)
 629    (Ledger.Journal GL_Expanded_Ledger)
 630
 631 -- JCC
 632 type GL_Expanded_JCC
 633  = GL.Expanded (JCC.Charted JCC.Transaction)
 634 instance Format.Journal (JCC.Journal GL_Expanded_JCC) where
 635         type Journal_Format   (JCC.Journal GL_Expanded_JCC)
 636          = Format_Journal_GL_Expanded
 637         journal_format = Format_JCC
 638
 639 -- Ledger
 640 type GL_Expanded_Ledger
 641  = GL.Expanded (Ledger.Charted Ledger.Transaction)
 642 instance Format.Journal (Ledger.Journal GL_Expanded_Ledger) where
 643         type Journal_Format   (Ledger.Journal GL_Expanded_Ledger)
 644          = Format_Journal_GL_Expanded
 645         journal_format = Format_Ledger
 646
 647 -- ** Class 'Journal_GL_Expanded'
 648
 649 class
 650  ( Format.Journal (j m)
 651  , Format.Journal_Format (j m) ~ Format_Journal_GL_Expanded
 652  -- , Format.Journal_Leijen_Table_Cells j m
 653  , Format.Journal_Filter Context j m
 654  ) => Journal_GL_Expanded j m where
 655         journal_posting_amounts
 656          :: j m
 657          -> Format.Journal_Posting j
 658          -> Map (Format.Journal_Unit j)
 659                 (Format.Journal_Quantity j)
 660         journal_posting_amounts_set
 661          :: j m
 662          -> Map (Format.Journal_Unit j)
 663                 (Format.Journal_Quantity j)
 664          -> Format.Journal_Posting j
 665          -> Format.Journal_Posting j
 666
 667 instance Journal_GL_Expanded    JCC.Journal GL_Expanded_JCC
 668  where
 669         journal_posting_amounts     _j = JCC.posting_amounts
 670         journal_posting_amounts_set _j posting_amounts p =
 671                 p { JCC.posting_amounts }
 672 instance Journal_GL_Expanded Ledger.Journal GL_Expanded_Ledger
 673  where
 674         journal_posting_amounts     _j = Ledger.posting_amounts
 675         journal_posting_amounts_set _j posting_amounts p =
 676                 p { Ledger.posting_amounts }
 677
 678 -- ** Type 'Forall_Journal_GL_Expanded'
 679
 680 data    Forall_Journal_GL_Expanded
 681  = forall j m. Journal_GL_Expanded  j m
 682  =>     Forall_Journal_GL_Expanded (j m)
 683
 684 instance Format.Journal Forall_Journal_GL_Expanded where
 685         type Journal_Format   Forall_Journal_GL_Expanded = Format_Journal_GL_Expanded
 686         journal_format
 687          (Forall_Journal_GL_Expanded j) =
 688                 Format.journal_format j
 689
 690 -- Instances 'Format.Journal_Filter'
 691
 692 instance
 693  ( Functor j
 694  , Format.Journal_Chart j
 695  , Journal_GL_Expanded j (GL.Expanded t)
 696  , GL.Transaction t
 697  , Format.Journal_Account_Section j ~ Text
 698  , GL.Transaction_Posting t ~ Chart.Charted (Format.Journal_Account j) (Format.Journal_Posting j)
 699  , GL.Posting_Quantity (GL.Transaction_Posting t)
 700    ~ Map (Format.Journal_Unit j) (Polarized (Format.Journal_Quantity j))
 701  , Format.Journal_Quantity j ~ Decimal
 702  , Format.Journal_Account_Section j
 703    ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
 704  , Ord (Format.Journal_Unit j)
 705  , Unit.Unit (Format.Journal_Unit j)
 706  ) => Format.Journal_Filter Context j (GL.Expanded t) where
 707         journal_filter ctx j =
 708                 GL.Expanded .
 709                 TreeMap.map_Maybe_with_Path
 710                  (\acct expanded_lines ->
 711                         let chart = Format.journal_chart j in
 712                         case Map.mapMaybeWithKey
 713                          (\date seq_lines ->
 714                                 case foldMap
 715                                  (\line@GL.GL_Line
 716                                  { GL.gl_line_transaction = _t
 717                                  , GL.gl_line_posting     = Chart.Charted ch p
 718                                  , GL.gl_line_sum         = s
 719                                  } ->
 720                                         Map.foldlWithKey
 721                                          (\acc unit qty ->
 722                                                 let sqty = (Map.!) s unit in
 723                                                 if Filter.test (ctx_filter_gl ctx)
 724                                                  ( (Chart.account_tags acct chart, acct)
 725                                                  , date
 726                                                  , (unit, Polarize.polarize qty)
 727                                                  , (unit, sqty)
 728                                                  )
 729                                                 then (Seq.|>) acc line
 730                                                  { GL.gl_line_posting =
 731                                                         Chart.Charted ch $
 732                                                         journal_posting_amounts_set j
 733                                                          (Map.singleton unit qty) p
 734                                                  , GL.gl_line_sum = Map.singleton unit sqty
 735                                                  }
 736                                                 else acc
 737                                          )
 738                                          Seq.empty
 739                                          (journal_posting_amounts j p)
 740                                  ) seq_lines
 741                                  of
 742                                  m | Seq.null m -> Nothing
 743                                  m -> Just m
 744                          )
 745                          (GL.inclusive expanded_lines)
 746                          of
 747                                 m | Map.null m -> Strict.Nothing
 748                                 m -> Strict.Just $ expanded_lines { GL.inclusive=m }
 749                  ) .
 750                 (\(GL.Expanded gl) -> gl) <$> j
 751
 752 instance Format.Journal_Filter Context (Const Forall_Journal_GL_Expanded) () where
 753         journal_filter ctx
 754          (Const (Forall_Journal_GL_Expanded j)) =
 755                 Const $ Forall_Journal_GL_Expanded $
 756                 Format.journal_filter ctx j
 757 -}
 758
 759 {-
 760 run :: C.Context -> [String] -> IO ()
 761 run c args = do
 762         (ctx, inputs) <-
 763                 first (\x ->
 764                         case ctx_output x of
 765                          [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
 766                          _  -> x) <$>
 767                 Args.parse c usage options (context, args)
 768         read_journals <-
 769                 liftM partitionEithers $ do
 770                 CLI.Env.paths c $ ctx_input ctx ++ inputs
 771                 >>= do
 772                         mapM $ \path -> do
 773                                 liftIO $ runExceptT $ Ledger.Read.file
 774                                  (Ledger.Read.context ( ctx_filter_transaction ctx
 775                                                       , ctx_filter_posting     ctx )
 776                                                       Ledger.journal)
 777                                  path
 778                                 >>= \x -> case x of
 779                                  Left  ko -> return $ Left (path, ko)
 780                                  Right ok -> return $ Right ok
 781         case read_journals of
 782          (errs@(_:_), _journals) ->
 783                 forM_ errs $ \(_path, err) -> do
 784                         Write.fatal c $ err
 785          ([], journals) -> do
 786                 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 787                 Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
 788                 Write.debug c $ "filter: gl: " ++ show (ctx_filter_gl ctx)
 789                 let (amount_styles, gl) = ledger_gl ctx journals
 790                 let lang = C.lang c
 791                 Write.write c Write.style (ctx_output ctx) $ do
 792                 toDoc () $ do
 793                 zipWith id
 794                  [ Table.column (Lang.translate lang Lang.Title_Account)         Table.Align_Left
 795                  , Table.column (Lang.translate lang Lang.Title_Date)            Table.Align_Left
 796                  , Table.column (Lang.translate lang Lang.Title_Debit)           Table.Align_Right
 797                  , Table.column (Lang.translate lang Lang.Title_Credit)          Table.Align_Right
 798                  , Table.column (Lang.translate lang Lang.Title_Running_debit)   Table.Align_Right
 799                  , Table.column (Lang.translate lang Lang.Title_Running_credit)  Table.Align_Right
 800                  , Table.column (Lang.translate lang Lang.Title_Running_balance) Table.Align_Right
 801                  , Table.column (Lang.translate lang Lang.Title_Description)     Table.Align_Left
 802                  ] $ do
 803                 write_gl amount_styles gl (repeat [])
 804 -}
 805
 806 {-
 807 ledger_gl
 808  :: Context
 809  -> [ Ledger.Journal (GL.GL (Ledger.Charted Ledger.Transaction)) ]
 810  -> ( Ledger.Amount.Styles
 811     , GL (Ledger.Charted Ledger.Transaction)
 812     )
 813 ledger_gl ctx journals =
 814         let (_chart, amount_styles, gl) =
 815                 foldl'
 816                  (flip (\j ->
 817                         flip mappend $
 818                         ( Ledger.journal_chart j
 819                         , Ledger.journal_amount_styles j
 820                         , ) $
 821                         Ledger.Journal.fold
 822                          (\Ledger.Journal
 823                                  { Ledger.journal_sections=g
 824                                  } -> mappend g
 825                          ) j mempty
 826                  ))
 827                  mempty journals in
 828         (amount_styles,) $
 829         GL.GL $
 830         TreeMap.map_Maybe_with_Path
 831          (\acct expanded_lines ->
 832                 case Map.mapMaybeWithKey
 833                  (\date seq_lines ->
 834                         case foldMap
 835                          (\line@GL.GL_Line
 836                          { GL.gl_line_transaction = _t
 837                          , GL.gl_line_posting     = Ledger.Charted c p
 838                          , GL.gl_line_sum         = s
 839                          } ->
 840                                 Map.foldlWithKey
 841                                  (\acc unit qty ->
 842                                         let sqty = (Map.!) s unit in
 843                                         if Filter.test (ctx_filter_gl ctx)
 844                                          ( (Chart.account_tags acct c, acct)
 845                                          , date
 846                                          , (unit, Polarize.polarize qty)
 847                                          , (unit, sqty)
 848                                          )
 849                                         then (Seq.|>) acc line
 850                                          { GL.gl_line_posting = Ledger.Charted c p
 851                                                  { Ledger.posting_amounts = Map.singleton unit qty }
 852                                          , GL.gl_line_sum = Map.singleton unit sqty
 853                                          }
 854                                         else acc
 855                                  )
 856                                  Seq.empty
 857                                  (Ledger.posting_amounts p)
 858                          ) seq_lines of
 859                          m | Seq.null m -> Nothing
 860                          m -> Just m
 861                  )
 862                  (GL.inclusive expanded_lines) of
 863                         m | Map.null m -> Strict.Nothing
 864                         m -> Strict.Just m
 865                 ) $
 866         GL.expanded gl
 867
 868 write_gl
 869  :: Ledger.Amount.Styles
 870  -> GL (Ledger.Charted Ledger.Transaction)
 871  -> [[Table.Cell]]
 872  -> [[Table.Cell]]
 873 write_gl amount_styles (GL gl) =
 874         flip (TreeMap.foldr_with_Path
 875          (\acct ->
 876                 flip $ Map.foldrWithKey
 877                  (\date ->
 878                         flip (foldr
 879                          (\GL.GL_Line
 880                                  { GL.gl_line_transaction = Ledger.Charted _ t
 881                                  , GL.gl_line_posting     = Ledger.Charted _ p
 882                                  , GL.gl_line_sum         = s
 883                                  } ->
 884                                 flip (Map.foldrWithKey
 885                                  (\unit qty ->
 886                                         let ms = Map.lookup unit s in
 887                                         zipWith (:)
 888                                                 [ let ptype = Ledger.Posting_Type_Regular in
 889                                                         Table.cell
 890                                                          { Table.cell_content = Ledger.Write.account        ptype acct
 891                                                          , Table.cell_width   = Ledger.Write.account_length ptype acct
 892                                                          }
 893                                                 , Table.cell
 894                                                  { Table.cell_content = Date.Write.date        date
 895                                                  , Table.cell_width   = Date.Write.date_length date
 896                                                  }
 897                                                 , cell_amount unit (Polarize.polarizable_positive qty)
 898                                                 , cell_amount unit (Polarize.polarizable_negative qty)
 899                                                 , cell_amount unit (ms >>= Polarize.polarized_positive)
 900                                                 , cell_amount unit (ms >>= Polarize.polarized_negative)
 901                                                 , cell_amount unit (liftM Polarize.depolarize ms)
 902                                                 , let descr = Ledger.transaction_wording t in
 903                                                         Table.cell
 904                                                          { Table.cell_content = toDoc ()    descr
 905                                                          , Table.cell_width   = Text.length descr
 906                                                          }
 907                                                 ]
 908                                  ))
 909                                  (Ledger.posting_amounts p)
 910                          ))
 911                  )
 912          ))
 913          gl
 914         where
 915                 cell_amount :: Ledger.Unit -> Maybe Ledger.Quantity -> Table.Cell
 916                 cell_amount unit mq =
 917                         case mq of
 918                          Nothing -> Table.cell
 919                          Just q ->
 920                                 let a  = Ledger.Amount.Amount unit q in
 921                                 let sa = Ledger.Amount.style amount_styles a in
 922                                 Table.cell
 923                                  { Table.cell_content = Amount.Write.amount        sa
 924                                  , Table.cell_width   = Amount.Write.amount_length sa
 925                                  }
 926 -}