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.Arrow (first)
  11 import           Control.Monad (Monad(..), forM_, liftM, mapM)
  12 import           Control.Monad.IO.Class (liftIO)
  13 import           Control.Monad.Trans.Except (runExceptT)
  14 import           Data.Bool
  15 import           Data.Either (Either(..), partitionEithers)
  16 import           Data.Foldable (Foldable(..))
  17 import           Data.List ((++), repeat)
  18 import qualified Data.Map.Strict as Map
  19 import           Data.Maybe (Maybe(..))
  20 import           Data.Monoid (Monoid(..), (<>))
  21 import qualified Data.Sequence as Seq
  22 import qualified Data.Strict.Maybe as Strict
  23 import           Data.String (String)
  24 import qualified Data.Text as Text
  25 import           Prelude (($), (.), FilePath, IO, id, flip, unlines, zipWith)
  26 import           Text.Show (Show(..))
  27 import           System.Console.GetOpt
  28                  ( ArgDescr(..)
  29                  , OptDescr(..)
  30                  , usageInfo
  31                  )
  32 import           System.Environment as Env (getProgName)
  33 import           System.Exit (exitSuccess)
  34 import qualified System.IO as IO
  35
  36 import qualified Hcompta.CLI.Args as Args
  37 import qualified Hcompta.CLI.Context as C
  38 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  39 import qualified Hcompta.CLI.Lang as Lang
  40 import qualified Hcompta.CLI.Lib.Leijen.Table as Table
  41 import qualified Hcompta.CLI.Write as Write
  42 import qualified Hcompta.Chart as Chart
  43 import           Hcompta.Date (Date)
  44 import qualified Hcompta.Filter as Filter
  45 import qualified Hcompta.Filter.Read as Filter.Read
  46 import qualified Hcompta.Format.Ledger as Ledger
  47 import qualified Hcompta.Format.Ledger.Amount as Ledger.Amount
  48 import qualified Hcompta.Format.Ledger.Amount.Write as Amount.Write
  49 import qualified Hcompta.Format.Ledger.Date.Write as Date.Write
  50 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  51 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  52 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  53 import           Hcompta.GL (GL(..))
  54 import qualified Hcompta.GL as GL
  55 import           Hcompta.Lib.Leijen (toDoc, ToDoc(..))
  56 import qualified Hcompta.Lib.TreeMap as TreeMap
  57 import qualified Hcompta.Polarize as Polarize
  58 import qualified Hcompta.Tag as Tag
  59
  60 data Ctx
  61  =   Ctx
  62  { ctx_input              :: [FilePath]
  63  , ctx_output             :: [(Write.Mode, FilePath)]
  64  , ctx_filter_transaction :: Filter.Simplified
  65                              (Filter.Filter_Bool
  66                              (Filter.Filter_Transaction
  67                              (Ledger.Chart_With Ledger.Transaction)))
  68  , ctx_filter_posting     :: Filter.Simplified
  69                              (Filter.Filter_Bool
  70                              (Filter.Filter_Posting
  71                              (Ledger.Chart_With Ledger.Posting)))
  72  , ctx_filter_gl          :: Filter.Simplified
  73                              (Filter.Filter_Bool
  74                              (Filter.Filter_GL
  75                              ( (Tag.Tags, Ledger.Account)
  76                              , Date
  77                              , (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
  78                              , (Ledger.Unit, Polarize.Polarized Ledger.Quantity) )))
  79  , ctx_reduce_date        :: Bool
  80  } deriving (Show)
  81
  82 nil :: Ctx
  83 nil =
  84         Ctx
  85          { ctx_filter_gl          = mempty
  86          , ctx_filter_posting     = mempty
  87          , ctx_filter_transaction = mempty
  88          , ctx_input              = []
  89          , ctx_output             = []
  90          , ctx_reduce_date        = True
  91          }
  92
  93 usage :: C.Context -> IO String
  94 usage c = do
  95         bin <- Env.getProgName
  96         return $ unlines $
  97                 [ C.translate c Lang.Section_Description
  98                 , "  "++C.translate c Lang.Help_Command_General_Ledger
  99                 , ""
 100                 , C.translate c Lang.Section_Syntax
 101                 , "  "++bin++" gl ["++C.translate c Lang.Type_Option++"] [...]"++
 102                                 " ["++C.translate c Lang.Type_File_Journal++"] [...]"
 103                 , ""
 104                 , usageInfo (C.translate c Lang.Section_Options) (options c)
 105                 ]
 106
 107 options :: C.Context -> Args.Options Ctx
 108 options c =
 109         [ Option "g" ["filter-gl"]
 110          (ReqArg (\s ctx -> do
 111                 ctx_filter_gl <-
 112                         liftM ((ctx_filter_gl ctx <>) . Filter.simplify) $
 113                                 liftIO $ Filter.Read.read Filter.Read.filter_gl s
 114                                 >>= \f -> case f of
 115                                  Left  ko -> Write.fatal c $ ko
 116                                  Right ok -> return ok
 117                 return $ ctx{ctx_filter_gl}) $
 118                 C.translate c Lang.Type_Filter_General_Ledger) $
 119                 C.translate c Lang.Help_Option_Filter_General_Ledger
 120         , Option "p" ["filter-posting"]
 121          (ReqArg (\s 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 c $ ko
 127                          Right ok -> return ok
 128                 return $ ctx{ctx_filter_posting}) $
 129                 C.translate c Lang.Type_Filter_Posting) $
 130                 C.translate c Lang.Help_Option_Filter_Posting
 131         , Option "t" ["filter-transaction"]
 132          (ReqArg (\s ctx -> do
 133                 ctx_filter_transaction <-
 134                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
 135                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
 136                         >>= \f -> case f of
 137                          Left  ko -> Write.fatal c $ ko
 138                          Right ok -> return ok
 139                 return $ ctx{ctx_filter_transaction}) $
 140                 C.translate c Lang.Type_Filter_Transaction) $
 141                 C.translate c Lang.Help_Option_Filter_Transaction
 142         , Option "h" ["help"]
 143          (NoArg (\_ctx -> do
 144                 usage c >>= IO.hPutStr IO.stderr
 145                 exitSuccess)) $
 146                 C.translate c Lang.Help_Option_Help
 147         , Option "i" ["input"]
 148          (ReqArg (\s ctx -> do
 149                 return $ ctx{ctx_input=s:ctx_input ctx}) $
 150                 C.translate c Lang.Type_File_Journal) $
 151                 C.translate c Lang.Help_Option_Input
 152         , Option "o" ["output"]
 153          (ReqArg (\s ctx -> do
 154                 return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
 155                 C.translate c Lang.Type_File) $
 156                 C.translate c Lang.Help_Option_Output
 157         , Option "O" ["overwrite"]
 158          (ReqArg (\s ctx -> do
 159                 return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
 160                 C.translate c Lang.Type_File) $
 161                 C.translate c Lang.Help_Option_Overwrite
 162         {- NOTE: not used so far.
 163         , Option "" ["reduce-date"]
 164          (OptArg (\arg c ctx -> do
 165                 ctx_reduce_date <- case arg of
 166                  Nothing    -> return $ True
 167                  Just "yes" -> return $ True
 168                  Just "no"  -> return $ False
 169                  Just _     -> Write.fatal c $
 170                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 171                 return $ ctx{ctx_reduce_date})
 172           "[yes|no]")
 173          "use advanced date reducer to speed up filtering"
 174         -}
 175         ]
 176
 177 run :: C.Context -> [String] -> IO ()
 178 run c args = do
 179         (ctx, inputs) <-
 180                 first (\x ->
 181                         case ctx_output x of
 182                          [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
 183                          _  -> x) <$>
 184                 Args.parse c usage options (nil, args)
 185         read_journals <-
 186                 liftM partitionEithers $ do
 187                 CLI.Ledger.paths c $ ctx_input ctx ++ inputs
 188                 >>= do
 189                         mapM $ \path -> do
 190                                 liftIO $ runExceptT $ Ledger.Read.file
 191                                  (Ledger.Read.context ( ctx_filter_transaction ctx
 192                                                       , ctx_filter_posting     ctx )
 193                                                       Ledger.journal)
 194                                  path
 195                                 >>= \x -> case x of
 196                                  Left  ko -> return $ Left (path, ko)
 197                                  Right ok -> return $ Right ok
 198         case read_journals of
 199          (errs@(_:_), _journals) ->
 200                 forM_ errs $ \(_path, err) -> do
 201                         Write.fatal c $ err
 202          ([], journals) -> do
 203                 Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
 204                 Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
 205                 Write.debug c $ "filter: gl: " ++ show (ctx_filter_gl ctx)
 206                 let (amount_styles, gl) = ledger_gl ctx journals
 207                 let lang = C.lang c
 208                 Write.write c Write.style (ctx_output ctx) $ do
 209                 toDoc () $ do
 210                 zipWith id
 211                  [ Table.column (Lang.translate lang Lang.Title_Account)         Table.Align_Left
 212                  , Table.column (Lang.translate lang Lang.Title_Date)            Table.Align_Left
 213                  , Table.column (Lang.translate lang Lang.Title_Debit)           Table.Align_Right
 214                  , Table.column (Lang.translate lang Lang.Title_Credit)          Table.Align_Right
 215                  , Table.column (Lang.translate lang Lang.Title_Running_debit)   Table.Align_Right
 216                  , Table.column (Lang.translate lang Lang.Title_Running_credit)  Table.Align_Right
 217                  , Table.column (Lang.translate lang Lang.Title_Running_balance) Table.Align_Right
 218                  , Table.column (Lang.translate lang Lang.Title_Description)     Table.Align_Left
 219                  ] $ do
 220                 write_gl amount_styles gl (repeat [])
 221
 222 ledger_gl
 223  :: Ctx
 224  -> [ Ledger.Journal (GL.GL (Ledger.Chart_With Ledger.Transaction)) ]
 225  -> ( Ledger.Amount.Styles
 226     , GL (Ledger.Chart_With Ledger.Transaction)
 227     )
 228 ledger_gl ctx journals =
 229         let (_chart, amount_styles, gl) =
 230                 foldl'
 231                  (flip (\j ->
 232                         flip mappend $
 233                         ( Ledger.journal_chart j
 234                         , Ledger.journal_amount_styles j
 235                         , ) $
 236                         Ledger.Journal.fold
 237                          (\Ledger.Journal
 238                                  { Ledger.journal_sections=g
 239                                  } -> mappend g
 240                          ) j mempty
 241                  ))
 242                  mempty journals in
 243         (amount_styles,) $
 244         GL.GL $
 245         TreeMap.map_Maybe_with_Path
 246          (\acct expanded_lines ->
 247                 case Map.mapMaybeWithKey
 248                  (\date seq_lines ->
 249                         case foldMap
 250                          (\line@GL.GL_Line
 251                          { GL.gl_line_transaction = _t
 252                          , GL.gl_line_posting     = Ledger.Chart_With c p
 253                          , GL.gl_line_sum         = s
 254                          } ->
 255                                 Map.foldlWithKey
 256                                  (\acc unit qty ->
 257                                         let sqty = (Map.!) s unit in
 258                                         if Filter.test (ctx_filter_gl ctx)
 259                                          ( (Chart.account_tags acct c, acct)
 260                                          , date
 261                                          , (unit, Polarize.polarize qty)
 262                                          , (unit, sqty)
 263                                          )
 264                                         then (Seq.|>) acc line
 265                                          { GL.gl_line_posting = Ledger.Chart_With c p
 266                                                  { Ledger.posting_amounts = Map.singleton unit qty }
 267                                          , GL.gl_line_sum = Map.singleton unit sqty
 268                                          }
 269                                         else acc
 270                                  )
 271                                  Seq.empty
 272                                  (Ledger.posting_amounts p)
 273                          ) seq_lines of
 274                          m | Seq.null m -> Nothing
 275                          m -> Just m
 276                  )
 277                  (GL.inclusive expanded_lines) of
 278                         m | Map.null m -> Strict.Nothing
 279                         m -> Strict.Just m
 280                 ) $
 281         GL.expanded gl
 282
 283 write_gl
 284  :: Ledger.Amount.Styles
 285  -> GL (Ledger.Chart_With Ledger.Transaction)
 286  -> [[Table.Cell]]
 287  -> [[Table.Cell]]
 288 write_gl amount_styles (GL gl) =
 289         flip (TreeMap.foldr_with_Path
 290          (\acct ->
 291                 flip $ Map.foldrWithKey
 292                  (\date ->
 293                         flip (foldr
 294                          (\GL.GL_Line
 295                                  { GL.gl_line_transaction = Ledger.Chart_With _ t
 296                                  , GL.gl_line_posting     = Ledger.Chart_With _ p
 297                                  , GL.gl_line_sum         = s
 298                                  } ->
 299                                 flip (Map.foldrWithKey
 300                                  (\unit qty ->
 301                                         let ms = Map.lookup unit s in
 302                                         zipWith (:)
 303                                                 [ let ptype = Ledger.Posting_Type_Regular in
 304                                                         Table.cell
 305                                                          { Table.cell_content = Ledger.Write.account        ptype acct
 306                                                          , Table.cell_width   = Ledger.Write.account_length ptype acct
 307                                                          }
 308                                                 , Table.cell
 309                                                  { Table.cell_content = Date.Write.date        date
 310                                                  , Table.cell_width   = Date.Write.date_length date
 311                                                  }
 312                                                 , cell_amount unit (Polarize.polarizable_positive qty)
 313                                                 , cell_amount unit (Polarize.polarizable_negative qty)
 314                                                 , cell_amount unit (ms >>= Polarize.polarized_positive)
 315                                                 , cell_amount unit (ms >>= Polarize.polarized_negative)
 316                                                 , cell_amount unit (liftM Polarize.depolarize ms)
 317                                                 , let descr = Ledger.transaction_description t in
 318                                                         Table.cell
 319                                                          { Table.cell_content = toDoc ()    descr
 320                                                          , Table.cell_width   = Text.length descr
 321                                                          }
 322                                                 ]
 323                                  ))
 324                                  (Ledger.posting_amounts p)
 325                          ))
 326                  )
 327          ))
 328          gl
 329         where
 330                 cell_amount :: Ledger.Unit -> Maybe Ledger.Quantity -> Table.Cell
 331                 cell_amount unit mq =
 332                         case mq of
 333                          Nothing -> Table.cell
 334                          Just q ->
 335                                 let a  = Ledger.Amount.Amount unit q in
 336                                 let sa = Ledger.Amount.style amount_styles a in
 337                                 Table.cell
 338                                  { Table.cell_content = Amount.Write.amount        sa
 339                                  , Table.cell_width   = Amount.Write.amount_length sa
 340                                  }