cli/Hcompta/CLI/Command/Journal.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE ExistentialQuantification #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE NamedFieldPuns #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE Rank2Types #-}
   9 {-# LANGUAGE ScopedTypeVariables #-}
  10 {-# LANGUAGE TupleSections #-}
  11 {-# LANGUAGE TypeFamilies #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13 module Hcompta.CLI.Command.Journal where
  14
  15 import           Control.Arrow ((+++))
  16 import           Control.Monad (Monad(..), liftM, mapM)
  17 import           Control.Monad.IO.Class (liftIO)
  18 import           Data.Bool
  19 import           Data.Either (Either(..), partitionEithers)
  20 import           Data.Foldable (Foldable(..))
  21 import           Data.Function (($), (.), on)
  22 import           Data.Functor (Functor(..), (<$>))
  23 import           Data.List ((++))
  24 import           Data.Maybe (Maybe(..))
  25 import           Data.Monoid (Monoid(..))
  26 import           Data.String (String)
  27 import           Prelude (Bounded(..), unlines)
  28 import           System.Console.GetOpt
  29                  ( ArgDescr(..)
  30                  , OptDescr(..)
  31                  , usageInfo )
  32 import           System.Environment as Env (getProgName)
  33 import           System.Exit (exitSuccess)
  34 import qualified System.IO as IO
  35 import           System.IO (FilePath, IO)
  36
  37 import qualified Hcompta.CLI.Args as Args
  38 import qualified Hcompta.CLI.Context as C
  39 import qualified Hcompta.CLI.Env as CLI.Env
  40 import qualified Hcompta.CLI.Format as Format
  41 import           Hcompta.CLI.Format.JCC ()
  42 import           Hcompta.CLI.Format.Ledger ()
  43 import           Hcompta.CLI.Format (Format(..), Formats)
  44 import qualified Hcompta.CLI.Lang as Lang
  45 import qualified Hcompta.CLI.Write as Write
  46 import qualified Hcompta.Chart as Chart
  47 import qualified Hcompta.Posting as Posting
  48 import qualified Hcompta.Filter as Filter
  49 import qualified Hcompta.Filter.Amount as Filter.Amount
  50 import qualified Hcompta.Filter.Read as Filter.Read
  51 import qualified Hcompta.Format.JCC as JCC
  52 import qualified Hcompta.Format.JCC.Write as JCC.Write
  53 import qualified Hcompta.Format.Ledger       as Ledger
  54 import qualified Hcompta.Format.Ledger.Write as Ledger
  55 import qualified Hcompta.Journal as Journal
  56 -- import           Hcompta.Lib.Consable (Consable(..))
  57 import qualified Hcompta.Lib.Leijen as W
  58 import qualified Hcompta.Lib.Parsec as R
  59
  60 data Context
  61  =   Context
  62  { ctx_input              :: [FilePath]
  63  , ctx_input_format       :: Formats
  64  , ctx_output             :: [(Write.Mode, FilePath)]
  65  , ctx_output_format      :: Maybe Formats
  66  , ctx_align              :: Bool
  67  , ctx_reduce_date        :: Bool
  68  , ctx_filter_transaction :: forall t.
  69                              ( Filter.Transaction t
  70                              , Filter.Amount_Quantity
  71                                (Posting.Posting_Amount
  72                                (Filter.Transaction_Posting t))
  73                                ~ Filter.Amount.Quantity
  74                              ) => Journal_Filter t
  75  }
  76
  77 context :: Context
  78 context =
  79         Context
  80          { ctx_input              = []
  81          , ctx_input_format       = mempty
  82          , ctx_output             = []
  83          , ctx_output_format      = Nothing
  84          , ctx_align              = True
  85          , ctx_reduce_date        = True
  86          , ctx_filter_transaction = Filter.Simplified $ Right True
  87          }
  88
  89 usage :: C.Context -> IO String
  90 usage c = do
  91         bin <- Env.getProgName
  92         return $ unlines $
  93                 [ C.translate c Lang.Section_Description
  94                 , "  "++C.translate c Lang.Help_Command_Journal
  95                 , ""
  96                 , C.translate c Lang.Section_Syntax
  97                 , "  "++bin++" journal ["++C.translate c Lang.Type_Option++"] [...]"++
  98                                      " ["++C.translate c Lang.Type_File_Journal++"] [...]"
  99                 , ""
 100                 , usageInfo (C.translate c Lang.Section_Options) (options c)
 101                 ]
 102
 103 options :: C.Context -> Args.Options Context
 104 options c =
 105         [ Option "h" ["help"]
 106          (NoArg (\_ctx -> do
 107                 usage c >>= IO.hPutStr IO.stderr
 108                 exitSuccess)) $
 109                 C.translate c Lang.Help_Option_Help
 110         , Option "i" ["input"]
 111          (ReqArg (\s ctx -> do
 112                 return $ ctx{ctx_input=s:ctx_input ctx}) $
 113                 C.translate c Lang.Type_File_Journal) $
 114                 C.translate c Lang.Help_Option_Input
 115         , Option "if" ["input-format"]
 116          (OptArg (\arg ctx -> do
 117                 ctx_input_format <- case arg of
 118                  Nothing       -> return $ Format_JCC ()
 119                  Just "jcc"    -> return $ Format_JCC ()
 120                  Just "ledger" -> return $ Format_Ledger ()
 121                  Just _        -> Write.fatal c $
 122                         W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
 123                 return $ ctx{ctx_input_format})
 124           "[jcc|ledger]")
 125           "input format"
 126         , Option "o" ["output"]
 127          (ReqArg (\s ctx -> do
 128                 return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
 129                 C.translate c Lang.Type_File) $
 130                 C.translate c Lang.Help_Option_Output
 131         , Option "of" ["output-format"]
 132          (OptArg (\arg ctx -> do
 133                 ctx_output_format <- case arg of
 134                  Nothing       -> return $ Just $ Format_JCC ()
 135                  Just "jcc"    -> return $ Just $ Format_JCC ()
 136                  Just "ledger" -> return $ Just $ Format_Ledger ()
 137                  Just _        -> Write.fatal c $
 138                         W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
 139                 return $ ctx{ctx_output_format})
 140           "[jcc|ledger]")
 141           "input format"
 142         , Option "O" ["overwrite"]
 143          (ReqArg (\s ctx -> do
 144                 return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
 145                 C.translate c Lang.Type_File) $
 146                 C.translate c Lang.Help_Option_Overwrite
 147         , Option "" ["align"]
 148          (OptArg (\arg ctx -> do
 149                 ctx_align <- case arg of
 150                  Nothing    -> return $ True
 151                  Just "yes" -> return $ True
 152                  Just "no"  -> return $ False
 153                  Just _     -> Write.fatal c $
 154                         W.text "--align option expects \"yes\", or \"no\" as value"
 155                 return $ ctx{ctx_align})
 156           "[yes|no]")
 157          "align output"
 158         {- NOTE: not used so far.
 159         , Option "" ["reduce-date"]
 160          (OptArg (\arg ctx -> do
 161                 ctx_reduce_date <- case arg of
 162                  Nothing    -> return $ True
 163                  Just "yes" -> return $ True
 164                  Just "no"  -> return $ False
 165                  Just _     -> Write.fatal c $
 166                         W.text "--reduce-date option expects \"yes\", or \"no\" as value"
 167                 return $ ctx{ctx_reduce_date})
 168           "[yes|no]")
 169          "use advanced date reducer to speed up filtering"
 170         -}
 171         , Option "t" ["filter-transaction"]
 172          (ReqArg (\s ctx -> do
 173                 filter <-
 174                         R.runParserT_with_Error
 175                          Filter.Read.filter_transaction
 176                          Filter.Read.context "" s
 177                 case filter of
 178                  Left ko -> Write.fatal c ko
 179                  Right flt ->
 180                         return $
 181                                 ctx{ctx_filter_transaction =
 182                                         Filter.and (ctx_filter_transaction ctx) $
 183                                         (Filter.simplify $
 184                                                 Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
 185                                  }) $
 186                 C.translate c Lang.Type_Filter_Transaction) $
 187                 C.translate c Lang.Help_Option_Filter_Transaction
 188         ]
 189
 190 run :: C.Context -> [String] -> IO ()
 191 run c args = do
 192         (ctx, inputs) <- Args.parse c usage options (context, args)
 193         input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
 194         read_journals <- mapM (liftIO . journal_read ctx) input_paths
 195         case partitionEithers read_journals of
 196          (errs@(_:_), _journals) -> Write.fatals c errs
 197          ([], (journals::[Forall_Journal])) -> do
 198                 with_color <- Write.with_color c IO.stdout
 199                 W.displayIO IO.stdout $
 200                         W.renderPretty with_color 1.0 maxBound $
 201                         journal_write $ mconcat $
 202                         Format.journal_flatten <$>
 203                                 case ctx_output_format ctx of
 204                                  Nothing -> journals
 205                                  Just f -> Format.journal_empty f:journals
 206
 207 -- * Type 'Format_Journal'
 208
 209 type Format_Journal
 210  = Format
 211    (   JCC.Journal Journal_JCC)
 212    (Ledger.Journal Journal_Ledger)
 213
 214 type Journal_JCC    = Journal.Journal (   JCC.Charted    JCC.Transaction)
 215 type Journal_Ledger = Journal.Journal (Ledger.Charted Ledger.Transaction)
 216
 217 -- * Class 'Journal'
 218
 219 class Journal j where
 220         journal_write :: j -> W.Doc
 221
 222 instance Format.Journal (JCC.Journal Journal_JCC) where
 223         type Journal_Format   (JCC.Journal Journal_JCC) = Format_Journal
 224         journal_format = Format_JCC
 225 instance Journal (JCC.Journal Journal_JCC) where
 226         journal_write j =
 227                 JCC.Write.transactions (JCC.journal_amount_styles j) $
 228                 fmap Chart.charted $
 229                 JCC.journal_content j
 230
 231 instance Format.Journal (Ledger.Journal Journal_Ledger) where
 232         type Journal_Format   (Ledger.Journal Journal_Ledger) = Format_Journal
 233         journal_format = Format_Ledger
 234 instance Journal (Ledger.Journal Journal_Ledger) where
 235         journal_write j =
 236                 Ledger.write_transactions (Ledger.journal_amount_styles j) $
 237                 fmap Chart.charted $
 238                 Ledger.journal_content j
 239
 240 -- * Type 'Forall_Journal'
 241
 242 data Forall_Journal
 243  = forall j m. ( Journal (j m)
 244                , Format.Journal (j m)
 245                , Format.Journal_Read j
 246                , Format.Journal_Monoid (j m)
 247                , Format.Journal_Format (j m) ~ Format_Journal )
 248  => Forall_Journal (j m)
 249
 250 instance Format.Journal Forall_Journal where
 251         type Journal_Format   Forall_Journal = Format_Journal
 252         journal_format  (Forall_Journal j) = Format.journal_format j
 253 instance Format.Journal_Empty Forall_Journal where
 254         journal_empty f =
 255                 case f of
 256                  Format_JCC    () -> Forall_Journal (mempty::JCC.Journal Journal_JCC)
 257                  Format_Ledger () -> Forall_Journal (mempty::Ledger.Journal Journal_Ledger)
 258
 259 instance Format.Journal_Monoid Forall_Journal where
 260         journal_flatten (Forall_Journal j) = Forall_Journal $ Format.journal_flatten j
 261         journal_fold f  (Forall_Journal j) = Format.journal_fold (f . Forall_Journal) j
 262 instance Journal Forall_Journal where
 263         journal_write (Forall_Journal j) = journal_write j
 264 instance Monoid Forall_Journal where
 265         mempty = Forall_Journal (mempty::JCC.Journal Journal_JCC)
 266         mappend x y =
 267                 case (mappend `on` Format.journal_format) x y of
 268                  Format_JCC    j -> Forall_Journal j
 269                  Format_Ledger j -> Forall_Journal j
 270         mconcat js =
 271                 case js of
 272                  [] -> mempty
 273                  j:jn -> foldl' mappend j jn
 274
 275 type Journal_Filter transaction
 276  = Filter.Simplified
 277    (Filter.Filter_Bool
 278    (Filter.Filter_Transaction transaction))
 279 type Journal_Read_Cons txn
 280  = txn -> Filter.Filtered (Journal_Filter txn) txn
 281
 282 journal_read
 283  :: Context -> FilePath
 284  -> IO (Either (Format.Message W.Doc) Forall_Journal)
 285 journal_read ctx =
 286         case ctx_input_format ctx of
 287          Format_JCC () ->
 288                 let wrap (j::JCC.Journal Journal_JCC) = Forall_Journal j in
 289                 let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
 290                          = Filter.Filtered (ctx_filter_transaction ctx) in
 291                 liftM ((+++) Format.Message wrap) .
 292                 Format.journal_read cons
 293          Format_Ledger () ->
 294                 let wrap (j::Ledger.Journal Journal_Ledger) = Forall_Journal j in
 295                 let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
 296                          = Filter.Filtered (ctx_filter_transaction ctx) in
 297                 liftM ((+++) Format.Message wrap) .
 298                 Format.journal_read cons