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