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