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