cli/Hcompta/CLI/Command/Tags.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE NamedFieldPuns #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# LANGUAGE TupleSections #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 module Hcompta.CLI.Command.Tags where
  11
  12 import           Control.Monad (liftM, forM_)
  13 import           Control.Monad.IO.Class (liftIO)
  14 import           Control.Monad.Trans.Except (runExceptT)
  15 import qualified Data.Either
  16 import qualified Data.Foldable
  17 import           Data.Functor.Compose (Compose(..))
  18 import           Data.Monoid ((<>))
  19 import qualified Data.Map.Strict as Data.Map
  20 import           Data.Map.Strict (Map)
  21 -- import           Data.Text (Text)
  22 import           System.Console.GetOpt
  23                  ( ArgDescr(..)
  24                  , OptDescr(..)
  25                  , usageInfo )
  26 import           System.Environment as Env (getProgName)
  27 import           System.Exit (exitSuccess)
  28 import qualified System.IO as IO
  29
  30 import           Hcompta.Account (Account)
  31 import qualified Hcompta.CLI.Args as Args
  32 import qualified Hcompta.CLI.Context as Context
  33 import           Hcompta.CLI.Context (Context)
  34 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  35 import qualified Hcompta.CLI.Write as Write
  36 import qualified Hcompta.Filter as Filter
  37 import qualified Hcompta.Filter.Read as Filter.Read
  38 import qualified Hcompta.Format.Ledger as Ledger
  39 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  40 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  41 import qualified Hcompta.Lib.Leijen as W
  42 import           Hcompta.Lib.Consable (Consable(..))
  43 import qualified Hcompta.Tag as Tag
  44
  45 data Ctx
  46  =   Ctx
  47  { ctx_input              :: [FilePath]
  48  , ctx_filter_transaction :: Filter.Simplified
  49                              (Filter.Filter_Bool
  50                              (Filter.Filter_Transaction
  51                              Ledger.Transaction))
  52  } deriving (Show)
  53
  54 nil :: Ctx
  55 nil =
  56         Ctx
  57          { ctx_input = []
  58          , ctx_filter_transaction = mempty
  59          }
  60
  61 usage :: IO String
  62 usage = do
  63         bin <- Env.getProgName
  64         let pad = replicate (length bin) ' '
  65         return $unlines $
  66                 [ "SYNTAX "
  67                 , "  "++bin++" tags [-i JOURNAL_FILE]"
  68                 , "  "++pad++"      [-t TRANSACTION_FILTER]"
  69                 , "  "++pad++"      [JOURNAL_FILE] [...]"
  70                 , ""
  71                 , usageInfo "OPTIONS" options
  72                 ]
  73
  74 options :: Args.Options Ctx
  75 options =
  76         [ Option "h" ["help"]
  77          (NoArg (\_context _ctx -> do
  78                 usage >>= IO.hPutStr IO.stderr
  79                 exitSuccess))
  80          "show this help"
  81         , Option "i" ["input"]
  82          (ReqArg (\s _context ctx -> do
  83                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  84          "read data from given file, multiple uses merge the data as would a concatenation do"
  85         , Option "t" ["transaction-filter"]
  86          (ReqArg (\s context ctx -> do
  87                 ctx_filter_transaction <-
  88                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
  89                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
  90                         >>= \f -> case f of
  91                          Left  ko -> Write.fatal context $ ko
  92                          Right ok -> do
  93                                 Write.debug context $ "filter: transaction: " ++ show ok
  94                                 return ok
  95                 return $ ctx{ctx_filter_transaction}) "FILTER")
  96          "filter at transaction level, multiple uses are merged with a logical AND"
  97         ]
  98
  99 run :: Context.Context -> [String] -> IO ()
 100 run context args = do
 101         (ctx, inputs) <- Args.parse context usage options (nil, args)
 102         read_journals <-
 103                 liftM Data.Either.partitionEithers $ do
 104                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 105                 >>= do
 106                         mapM $ \path -> do
 107                                 liftIO $ runExceptT $ Ledger.Read.file
 108                                  (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
 109                                  path
 110                                 >>= \x -> case x of
 111                                  Left  ko -> return $ Left (path, ko)
 112                                  Right ok -> return $ Right ok
 113         case read_journals of
 114          (errs@(_:_), _journals) ->
 115                 forM_ errs $ \(_path, err) -> do
 116                         Write.fatal context $ err
 117          ([], journals) -> do
 118                 let files = ledger_tags ctx journals
 119                 style_color <- Write.with_color context IO.stdout
 120                 W.displayIO IO.stdout $ do
 121                 W.renderPretty style_color 1.0 maxBound $ do
 122                 doc_tags context ctx files
 123
 124 ledger_tags
 125  :: Ctx
 126  -> [ Ledger.Journal (Tags Ledger.Transaction) ]
 127  -> Tags Ledger.Transaction
 128 ledger_tags _ctx =
 129         Data.Foldable.foldl'
 130          (flip $ Ledger.Journal.fold
 131                  (\Ledger.Journal{Ledger.journal_transactions=ts} ->
 132                         mappend ts))
 133          mempty
 134
 135 doc_tags
 136  :: Context
 137  -> Ctx
 138  -> Tags Ledger.Transaction
 139  -> W.Doc
 140 doc_tags _context _ctx =
 141         Data.Map.foldlWithKey
 142          (\doc p vs ->
 143                 doc <> foldMap (\s -> W.dullyellow (W.toDoc () s) <> ":") p <>
 144                 " (" <> (W.toDoc () (Data.Map.size vs)) <> ")" <>
 145                 W.nest 2 (
 146                         Data.Map.foldlWithKey
 147                          (\doc' v vn ->
 148                                 doc' <> W.line <> W.dullred (W.toDoc () v) <>
 149                                 " (" <> (W.toDoc () vn) <> ")"
 150                          )
 151                          W.empty vs
 152                  ) <> W.line
 153          )
 154          W.empty .
 155         tags
 156
 157 -- * Requirements' interface
 158
 159 -- ** Class 'Posting'
 160
 161 class Posting        p where
 162         posting_account :: p -> Account
 163
 164 instance Posting Ledger.Posting where
 165         posting_account = Ledger.posting_account
 166
 167 -- ** Class 'Transaction'
 168
 169 class
 170  ( Posting  (Transaction_Posting  t)
 171  , Foldable (Transaction_Postings t)
 172  )
 173  =>    Transaction          t where
 174         type Transaction_Posting  t
 175         type Transaction_Postings t :: * -> *
 176         -- transaction_postings      :: t -> Transaction_Postings t (Transaction_Posting t)
 177         transaction_tags          :: t -> Map Tag.Path [Tag.Value]
 178
 179 instance Transaction        Ledger.Transaction where
 180         type Transaction_Posting  Ledger.Transaction = Ledger.Posting
 181         type Transaction_Postings Ledger.Transaction = Compose [] (Compose (Map Account) [])
 182         transaction_tags = Ledger.transaction_tags
 183
 184 -- * Type 'Tags'
 185
 186 data Transaction t => Tags t
 187  = Tags
 188  { tags :: Map Tag.Path (Map Tag.Value Integer)
 189  }
 190  deriving (Show)
 191
 192 instance Transaction t => Monoid (Tags t) where
 193         mempty = Tags mempty
 194         mappend t0 t1 =
 195                 Tags
 196                  { tags = Data.Map.unionWith
 197                          (Data.Map.unionWith (+))
 198                          (tags t0)
 199                          (tags t1)
 200                  }
 201 instance Transaction t => Consable () Tags t where
 202         mcons () t !ts =
 203                 ts
 204                  { tags =
 205                         Data.Map.mergeWithKey
 206                          (\_k x1 x2 -> Just $
 207                                 Data.Map.unionWith (+) x1 $
 208                                 Data.Map.fromListWith (+) $ (, 1) <$> x2)
 209                          id ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
 210                          (tags ts)            -- Map Tag.Path (Map Tag.Value Integer)
 211                          (transaction_tags t) -- Map Tag.Path [Tag.Value]
 212                  }
 213 instance
 214  ( Filter.Transaction t
 215  , Transaction        t
 216  ) => Consable
 217  (Filter.Simplified
 218    (Filter.Filter_Bool
 219    (Filter.Filter_Transaction t)))
 220  Tags t where
 221         mcons ft t !ts =
 222                 if Filter.test ft t
 223                 then mcons () t ts
 224                 else ts