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