cli/Hcompta/CLI/Command/GL.hs

   1 {-# LANGUAGE NamedFieldPuns #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE TupleSections #-}
   5 module Hcompta.CLI.Command.GL where
   6
   7 import           Control.Monad.IO.Class (liftIO)
   8 import           Control.Monad.Trans.Except (runExceptT)
   9 import qualified Data.Either
  10 import qualified Data.Foldable
  11 import           Data.Functor.Compose (Compose(..))
  12 import qualified Data.List
  13 import qualified Data.Map.Strict as Data.Map
  14 import qualified Data.Sequence
  15 import qualified Data.Text as Text
  16 import qualified Data.Text.Lazy as TL
  17 import           Prelude hiding (foldr)
  18 import           System.Console.GetOpt
  19                  ( ArgDescr(..)
  20                  , OptDescr(..)
  21                  , usageInfo
  22                  )
  23 import           System.Environment as Env (getProgName)
  24 import           System.Exit (exitWith, ExitCode(..))
  25 import qualified System.IO as IO
  26
  27 import           Hcompta.Account (Account)
  28 import           Hcompta.Amount (Amount)
  29 import qualified Hcompta.Amount as Amount
  30 import qualified Hcompta.Amount.Write as Amount.Write
  31 import qualified Hcompta.CLI.Args as Args
  32 import qualified Hcompta.CLI.Context as Context
  33 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  34 import qualified Hcompta.CLI.Lang as Lang
  35 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  36 import qualified Hcompta.CLI.Write as Write
  37 import           Hcompta.Date (Date)
  38 import qualified Hcompta.Date.Write as Date.Write
  39 import qualified Hcompta.Filter as Filter
  40 import qualified Hcompta.Filter.Read as Filter.Read
  41 import qualified Hcompta.Format.Ledger as Ledger
  42 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  43 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  44 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  45 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  46 import qualified Hcompta.Lib.Leijen as W
  47 import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
  48 import           Hcompta.GL (GL(..))
  49 import qualified Hcompta.GL as GL
  50
  51 data Ctx
  52  =   Ctx
  53  { ctx_input              :: [FilePath]
  54  , ctx_transaction_filter :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
  55  , ctx_posting_filter     :: Filter.Test_Bool (Filter.Test_Posting     Ledger.Posting)
  56  , ctx_gl_filter          :: Filter.Test_Bool (Filter.Test_GL          ( Account
  57                                                                        , Date
  58                                                                        , Amount.Sum Amount
  59                                                                        , Amount.Sum Amount ))
  60  } deriving (Show)
  61
  62 nil :: Ctx
  63 nil =
  64         Ctx
  65          { ctx_input              = []
  66          , ctx_transaction_filter = Filter.Any
  67          , ctx_posting_filter     = Filter.Any
  68          , ctx_gl_filter          = Filter.Any
  69          }
  70
  71 usage :: IO String
  72 usage = do
  73         bin <- Env.getProgName
  74         return $ unlines $
  75                 [ "SYNTAX "
  76                 , "  "++bin++" gl"
  77                 , " [-t TRANSACTION_FILTER]"
  78                 , " [-p POSTING_FILTER]"
  79                 , " [-g GL_FILTER]"
  80                 , " JOURNAL_FILE [...]"
  81                 , ""
  82                 , usageInfo "OPTIONS" options
  83                 ]
  84
  85 options :: Args.Options Ctx
  86 options =
  87         [ Option "g" ["gl-filter"]
  88          (ReqArg (\s context ctx -> do
  89                 ctx_gl_filter <-
  90                         fmap (Filter.And $ ctx_gl_filter ctx) $
  91                                 liftIO $ Filter.Read.read Filter.Read.test_gl s
  92                                 >>= \f -> case f of
  93                                  Left  ko -> Write.fatal context $ ko
  94                                  Right ok -> return ok
  95                 return $ ctx{ctx_gl_filter}) "FILTER")
  96          "filter at general ledger level, multiple uses are merged with a logical AND"
  97         , Option "h" ["help"]
  98          (NoArg (\_context _ctx -> do
  99                 usage >>= IO.hPutStr IO.stderr
 100                 exitWith ExitSuccess))
 101          "show this help"
 102         , Option "i" ["input"]
 103          (ReqArg (\s _context ctx -> do
 104                 return $ ctx{ctx_input=s:ctx_input ctx}) "JOURNAL_FILE")
 105          "read data from given file, multiple uses merge the data as would a concatenation do"
 106         , Option "p" ["posting-filter"]
 107          (ReqArg (\s context ctx -> do
 108                 ctx_posting_filter <-
 109                         fmap (Filter.And $ ctx_posting_filter ctx) $
 110                         liftIO $ Filter.Read.read Filter.Read.test_posting s
 111                         >>= \f -> case f of
 112                          Left  ko -> Write.fatal context $ ko
 113                          Right ok -> return ok
 114                 return $ ctx{ctx_posting_filter}) "FILTER")
 115          "filter at posting level, multiple uses are merged with a logical AND"
 116         , Option "t" ["transaction-filter"]
 117          (ReqArg (\s context ctx -> do
 118                 ctx_transaction_filter <-
 119                         fmap (Filter.And $ ctx_transaction_filter ctx) $
 120                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
 121                         >>= \f -> case f of
 122                          Left  ko -> Write.fatal context $ ko
 123                          Right ok -> return ok
 124                 return $ ctx{ctx_transaction_filter}) "FILTER")
 125          "filter at transaction level, multiple uses are merged with a logical AND"
 126         ]
 127
 128 run :: Context.Context -> [String] -> IO ()
 129 run context args = do
 130         (ctx, inputs) <- Args.parse context usage options (nil, args)
 131         read_journals <- do
 132                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 133                 >>= do
 134                         mapM $ \path -> do
 135                                 liftIO $ runExceptT $ Ledger.Read.file path
 136                                 >>= \x -> case x of
 137                                  Left  ko -> return $ Left (path, ko)
 138                                  Right ok -> return $ Right ok
 139                 >>= return . Data.Either.partitionEithers
 140         case read_journals of
 141          (errs@(_:_), _journals) ->
 142                 (flip mapM_) errs $ \(_path, err) -> do
 143                         Write.fatal context $ err
 144          ([], journals) -> do
 145                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 146                 Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
 147                 Write.debug context $ "gl_filter: " ++ show (ctx_gl_filter ctx)
 148                 let gl = ledger_gl ctx journals
 149                 style_color <- Write.with_color context IO.stdout
 150                 W.displayIO IO.stdout $
 151                  W.renderPretty style_color 1.0 maxBound $ do
 152                         toDoc () $
 153                                 let title =
 154                                         TL.toStrict . W.displayT .
 155                                         W.renderCompact False .
 156                                         toDoc (Context.lang context) in
 157                                 zipWith id
 158                                 [ Table.column (title Lang.Message_Account)         Table.Align_Left
 159                                 , Table.column (title Lang.Message_Date)            Table.Align_Left
 160                                 , Table.column (title Lang.Message_Debit)           Table.Align_Right
 161                                 , Table.column (title Lang.Message_Credit)          Table.Align_Right
 162                                 , Table.column (title Lang.Message_Running_debit)   Table.Align_Right
 163                                 , Table.column (title Lang.Message_Running_credit)  Table.Align_Right
 164                                 , Table.column (title Lang.Message_Running_balance) Table.Align_Right
 165                                 , Table.column (title Lang.Message_Description)     Table.Align_Left
 166                                 ] $
 167                                 write_gl gl (repeat [])
 168
 169 ledger_gl
 170  :: Ctx
 171  -> [Ledger.Journal]
 172  -> GL Ledger.Transaction
 173 ledger_gl ctx journals =
 174         let gl =
 175                 Data.Foldable.foldl'
 176                  (flip $ Ledger.Journal.fold
 177                          (\j ->
 178                                 flip (Data.Foldable.foldl'
 179                                  (\ts t ->
 180                                         case Filter.test (ctx_transaction_filter ctx) t of
 181                                          False -> ts
 182                                          True ->
 183                                                 GL.general_ledger
 184                                                  t{ Ledger.transaction_postings =
 185                                                         Data.Map.map
 186                                                          (Data.Foldable.foldMap
 187                                                                  (\p ->
 188                                                                         Data.Map.foldrWithKey
 189                                                                          (\u a -> (:) p{Ledger.posting_amounts=Data.Map.singleton u a})
 190                                                                          []
 191                                                                          (Ledger.posting_amounts p)
 192                                                                  )
 193                                                          ) $
 194                                                         Data.Map.mapMaybe
 195                                                          (\ps -> case Data.List.filter
 196                                                                  (Filter.test $ ctx_posting_filter ctx) ps of
 197                                                                  [] -> Nothing
 198                                                                  x  -> Just x)
 199                                                          (Ledger.transaction_postings t)
 200                                                  }
 201                                                  ts
 202                                  ))
 203                                  (Compose $ Ledger.journal_transactions j)
 204                          )
 205                  )
 206                  GL.nil
 207                  journals in
 208         GL.GL $
 209         Lib.TreeMap.map_Maybe_with_Path
 210          (\acct expanded_lines ->
 211                 case Data.Map.mapMaybeWithKey
 212                  (\date seq_lines ->
 213                         case Data.Foldable.foldMap
 214                          (\line@GL.GL_Line
 215                          { GL.gl_line_transaction = _t
 216                          , GL.gl_line_posting     = p
 217                          , GL.gl_line_sum         = s
 218                          } ->
 219                                 if Filter.test (ctx_gl_filter ctx)
 220                                  ( acct
 221                                  , date
 222                                  , Amount.sum $ snd $ Data.Map.elemAt 0 $ Ledger.posting_amounts p
 223                                  , snd . Data.Map.elemAt 0 <$> s
 224                                  )
 225                                 then Data.Sequence.singleton line
 226                                 else Data.Sequence.empty
 227                          ) seq_lines of
 228                          m | Data.Sequence.null m -> Nothing
 229                          m -> Just m
 230                  )
 231                  (GL.inclusive expanded_lines) of
 232                         m | Data.Map.null m -> Nothing
 233                         m -> Just m
 234                 ) $
 235         GL.expanded gl
 236
 237 write_gl
 238  :: GL Ledger.Transaction
 239  -> [[Table.Cell]]
 240  -> [[Table.Cell]]
 241 write_gl (GL gl) =
 242         flip (Lib.TreeMap.foldr_with_Path
 243          (\acct ->
 244                 flip $ Data.Map.foldrWithKey
 245                  (\date ->
 246                         flip (Data.Foldable.foldr
 247                          (\GL.GL_Line
 248                                  { GL.gl_line_transaction = t
 249                                  , GL.gl_line_posting     = p
 250                                  , GL.gl_line_sum         = s
 251                                  } ->
 252                                 flip (Data.Map.foldrWithKey
 253                                  (\unit amt -> do
 254                                         let ptype = Ledger.Posting_Type_Regular
 255                                         let descr = Ledger.transaction_description t
 256                                         zipWith (:)
 257                                                 [ Table.cell
 258                                                  { Table.cell_content = Ledger.Write.account        ptype acct
 259                                                  , Table.cell_width   = Ledger.Write.account_length ptype acct
 260                                                  }
 261                                                 , Table.cell
 262                                                  { Table.cell_content = Date.Write.date        date
 263                                                  , Table.cell_width   = Date.Write.date_length date
 264                                                  }
 265                                                 , Table.cell
 266                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (Amount.sumable_positive amt)
 267                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (Amount.sumable_positive amt)
 268                                                  }
 269                                                 , Table.cell
 270                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (Amount.sumable_negative amt)
 271                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (Amount.sumable_negative amt)
 272                                                  }
 273                                                 , Table.cell
 274                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
 275                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
 276                                                  }
 277                                                 , Table.cell
 278                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
 279                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
 280                                                  }
 281                                                 , Table.cell
 282                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (Data.Map.lookup unit $ Amount.sum_balance s)
 283                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (Data.Map.lookup unit $ Amount.sum_balance s)
 284                                                  }
 285                                                 , Table.cell
 286                                                  { Table.cell_content = toDoc ()    descr
 287                                                  , Table.cell_width   = Text.length descr
 288                                                  }
 289                                                 ]
 290                                  ))
 291                                  (Ledger.posting_amounts p)
 292                          ))
 293                  )
 294          ))
 295          gl