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