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