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