cli/Hcompta/CLI/Command/GL.hs

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