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