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 [-t TRANSACTION_FILTER] [-p POSTING_FILTER] GL_FILTER"
  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, multiple uses merge the data as would a concatenation do"
  88         , Option "p" ["posting-filter"]
  89          (ReqArg (\s context ctx -> do
  90                 ctx_posting_filter <-
  91                         fmap (Filter.And $ ctx_posting_filter ctx) $
  92                         liftIO $ Filter.Read.read Filter.Read.test_posting s
  93                         >>= \f -> case f of
  94                          Left  ko -> Write.fatal context $ ko
  95                          Right ok -> return ok
  96                 return $ ctx{ctx_posting_filter}) "FILTER")
  97          "filter at posting level, multiple uses are merged with a logical and"
  98         , Option "t" ["transaction-filter"]
  99          (ReqArg (\s context ctx -> do
 100                 ctx_transaction_filter <-
 101                         fmap (Filter.And $ ctx_transaction_filter ctx) $
 102                         liftIO $ Filter.Read.read Filter.Read.test_transaction s
 103                         >>= \f -> case f of
 104                          Left  ko -> Write.fatal context $ ko
 105                          Right ok -> return ok
 106                 return $ ctx{ctx_transaction_filter}) "FILTER")
 107          "filter at transaction level, multiple uses are merged with a logical and"
 108         ]
 109
 110 run :: Context.Context -> [String] -> IO ()
 111 run context args = do
 112         (ctx, text_filters) <- Args.parse context usage options (nil, args)
 113         read_journals <- do
 114                 CLI.Ledger.paths context $ ctx_input ctx
 115                 >>= do
 116                         mapM $ \path -> do
 117                                 liftIO $ runExceptT $ Ledger.Read.file path
 118                                 >>= \x -> case x of
 119                                  Left  ko -> return $ Left (path, ko)
 120                                  Right ok -> return $ Right ok
 121                 >>= return . Data.Either.partitionEithers
 122         case read_journals of
 123          (errs@(_:_), _journals) ->
 124                 (flip mapM_) errs $ \(_path, err) -> do
 125                         Write.fatal context $ err
 126          ([], journals) -> do
 127                 gl_filter <-
 128                         foldr Filter.And Filter.Any <$> do
 129                         (flip mapM) text_filters $ \s ->
 130                                 liftIO $ Filter.Read.read
 131                                  Filter.Read.test_gl
 132                                   s
 133                                 >>= \f -> case f of
 134                                  Left  ko -> Write.fatal context $ ko
 135                                  Right ok -> return ok
 136                 Write.debug context $ "transaction_filter: " ++ show (ctx_transaction_filter ctx)
 137                 Write.debug context $ "posting_filter: " ++ show (ctx_posting_filter ctx)
 138                 Write.debug context $ "gl_filter: " ++ show gl_filter
 139                 let gl =
 140                         ledger_gl
 141                          (ctx_transaction_filter ctx)
 142                          (ctx_posting_filter ctx)
 143                          gl_filter
 144                          journals
 145                 style_color <- Write.with_color context IO.stdout
 146                 W.displayIO IO.stdout $
 147                  W.renderPretty style_color 1.0 maxBound $ do
 148                         toDoc () $
 149                                 let title =
 150                                         TL.toStrict . W.displayT .
 151                                         W.renderCompact False .
 152                                         toDoc (Context.lang context) in
 153                                 zipWith id
 154                                 [ Table.column (title Lang.Message_Account)         Table.Align_Left
 155                                 , Table.column (title Lang.Message_Date)            Table.Align_Left
 156                                 , Table.column (title Lang.Message_Debit)           Table.Align_Right
 157                                 , Table.column (title Lang.Message_Credit)          Table.Align_Right
 158                                 , Table.column (title Lang.Message_Running_debit)   Table.Align_Right
 159                                 , Table.column (title Lang.Message_Running_credit)  Table.Align_Right
 160                                 , Table.column (title Lang.Message_Running_balance) Table.Align_Right
 161                                 , Table.column (title Lang.Message_Description)     Table.Align_Left
 162                                 ] $
 163                                 write_gl gl (repeat [])
 164
 165 ledger_gl
 166  :: Filter.Test_Bool (Filter.Test_Transaction Ledger.Transaction)
 167  -> Filter.Test_Bool (Filter.Test_Posting     Ledger.Posting)
 168  -> Filter.Test_Bool (Filter.Test_GL    (Account, Date, Amount.Sum Amount, Amount.Sum Amount))
 169  -> [Ledger.Journal]
 170  -> GL Ledger.Transaction
 171 ledger_gl
 172  transaction_filter
 173  posting_filter
 174  gl_filter
 175  journals =
 176         let gl =
 177                 Data.Foldable.foldl
 178                  (\jr j ->
 179                         Data.Foldable.foldl
 180                          (\tr t ->
 181                                 case Filter.test transaction_filter t of
 182                                  False -> tr
 183                                  True ->
 184                                         GL.general_ledger
 185                                          t{ Ledger.transaction_postings =
 186                                                 Data.Map.map
 187                                                  (Data.Foldable.foldMap
 188                                                          (\p ->
 189                                                                 Data.Map.foldrWithKey
 190                                                                  (\u a -> (:) p{Ledger.posting_amounts=Data.Map.singleton u a})
 191                                                                  []
 192                                                                  (Ledger.posting_amounts p)
 193                                                          )
 194                                                  ) $
 195                                                 Data.Map.mapMaybe
 196                                                  (\ps -> case Data.List.filter (Filter.test posting_filter) ps of
 197                                                          [] -> Nothing
 198                                                          x  -> Just x)
 199                                                  (Ledger.transaction_postings t)
 200                                          }
 201                                          tr
 202                          )
 203                         jr (Compose $ Ledger.journal_transactions j)
 204                  )
 205                  GL.nil
 206                  journals in
 207         GL.GL $
 208         Lib.TreeMap.map_Maybe_with_Path
 209          (\acct expanded_lines ->
 210                 case Data.Map.mapMaybeWithKey
 211                  (\date seq_lines ->
 212                         case Data.Foldable.foldMap
 213                          (\line@GL.GL_Line
 214                          { GL.gl_line_transaction = _t
 215                          , GL.gl_line_posting     = p
 216                          , GL.gl_line_sum         = s
 217                          } ->
 218                                 if Filter.test gl_filter
 219                                  ( acct
 220                                  , date
 221                                  , Amount.sum $ snd $ Data.Map.elemAt 0 $ Ledger.posting_amounts p
 222                                  , snd . Data.Map.elemAt 0 <$> s
 223                                  )
 224                                 then Data.Sequence.singleton line
 225                                 else Data.Sequence.empty
 226                          ) seq_lines of
 227                          m | Data.Sequence.null m -> Nothing
 228                          m -> Just m
 229                  )
 230                  (GL.inclusive expanded_lines) of
 231                         m | Data.Map.null m -> Nothing
 232                         m -> Just m
 233                 ) $
 234         GL.expanded gl
 235
 236 write_gl
 237  :: GL Ledger.Transaction
 238  -> [[Table.Cell]]
 239  -> [[Table.Cell]]
 240 write_gl (GL gl) =
 241         flip (Lib.TreeMap.foldr_with_Path
 242          (\acct ->
 243                 flip $ Data.Map.foldrWithKey
 244                  (\date ->
 245                         flip (Data.Foldable.foldr
 246                          (\GL.GL_Line
 247                                  { GL.gl_line_transaction = t
 248                                  , GL.gl_line_posting     = p
 249                                  , GL.gl_line_sum         = s
 250                                  } ->
 251                                 flip (Data.Map.foldrWithKey
 252                                  (\unit amt -> do
 253                                         let ptype = Ledger.Posting_Type_Regular
 254                                         let descr = Ledger.transaction_description t
 255                                         zipWith (:)
 256                                                 [ Table.cell
 257                                                  { Table.cell_content = Ledger.Write.account        ptype acct
 258                                                  , Table.cell_width   = Ledger.Write.account_length ptype acct
 259                                                  }
 260                                                 , Table.cell
 261                                                  { Table.cell_content = Date.Write.date        date
 262                                                  , Table.cell_width   = Date.Write.date_length date
 263                                                  }
 264                                                 , Table.cell
 265                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (Amount.sumable_positive amt)
 266                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (Amount.sumable_positive amt)
 267                                                  }
 268                                                 , Table.cell
 269                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (Amount.sumable_negative amt)
 270                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (Amount.sumable_negative amt)
 271                                                  }
 272                                                 , Table.cell
 273                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
 274                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_positive s)
 275                                                  }
 276                                                 , Table.cell
 277                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
 278                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (maybe Nothing (Data.Map.lookup unit) $ Amount.sum_negative s)
 279                                                  }
 280                                                 , Table.cell
 281                                                  { Table.cell_content = maybe W.empty Amount.Write.amount        (Data.Map.lookup unit $ Amount.sum_balance s)
 282                                                  , Table.cell_width   = maybe 0       Amount.Write.amount_length (Data.Map.lookup unit $ Amount.sum_balance s)
 283                                                  }
 284                                                 , Table.cell
 285                                                  { Table.cell_content = toDoc ()    descr
 286                                                  , Table.cell_width   = Text.length descr
 287                                                  }
 288                                                 ]
 289                                  ))
 290                                  (Ledger.posting_amounts p)
 291                          ))
 292                  )
 293          ))
 294          gl