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  , ctx_filter_tag         :: Filter.Simplified
  53                              Filter.Filter_Tag
  54  , ctx_tree               :: Bool
  55  } deriving (Show)
  56
  57 nil :: Ctx
  58 nil =
  59         Ctx
  60          { ctx_input = []
  61          , ctx_filter_transaction = mempty
  62          , ctx_filter_tag = mempty
  63          , ctx_tree = False
  64          }
  65
  66 usage :: IO String
  67 usage = do
  68         bin <- Env.getProgName
  69         let pad = replicate (length bin) ' '
  70         return $unlines $
  71                 [ "SYNTAX "
  72                 , "  "++bin++" tags [-i JOURNAL_FILE]"
  73                 , "  "++pad++"      [-t TRANSACTION_FILTER]"
  74                 , "  "++pad++"      [JOURNAL_FILE] [...]"
  75                 , ""
  76                 , usageInfo "OPTIONS" options
  77                 ]
  78
  79 options :: Args.Options Ctx
  80 options =
  81         [ Option "h" ["help"]
  82          (NoArg (\_context _ctx -> do
  83                 usage >>= IO.hPutStr IO.stderr
  84                 exitSuccess))
  85          "show this help"
  86         , Option "i" ["input"]
  87          (ReqArg (\s _context ctx -> do
  88                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  89          "read data from given file, multiple uses merge the data as would a concatenation do"
  90         , Option "t" ["transaction-filter"]
  91          (ReqArg (\s context ctx -> do
  92                 ctx_filter_transaction <-
  93                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
  94                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
  95                         >>= \f -> case f of
  96                          Left  ko -> Write.fatal context $ ko
  97                          Right ok -> do
  98                                 Write.debug context $ "filter: transaction: " ++ show ok
  99                                 return ok
 100                 return $ ctx{ctx_filter_transaction}) "FILTER")
 101          "filter at transaction level, multiple uses are merged with a logical AND"
 102         , Option "T" ["tag-filter"]
 103          (ReqArg (\s context ctx -> do
 104                 ctx_filter_tag <-
 105                         liftM ((ctx_filter_tag ctx <>) . Filter.simplify) $
 106                         liftIO $ Filter.Read.read Filter.Read.filter_tag s
 107                         >>= \f -> case f of
 108                          Left  ko -> Write.fatal context $ ko
 109                          Right ok -> do
 110                                 Write.debug context $ "filter: tag: " ++ show ok
 111                                 return ok
 112                 return $ ctx{ctx_filter_tag}) "FILTER")
 113          "filter at transaction level, multiple uses are merged with a logical AND"
 114         , Option "" ["tree"]
 115          (OptArg (\arg context ctx -> do
 116                 ctx_tree <- case arg of
 117                  Nothing    -> return $ True
 118                  Just "yes" -> return $ True
 119                  Just "no"  -> return $ False
 120                  Just _     -> Write.fatal context $
 121                         W.text "--tree option expects \"yes\", or \"no\" as value"
 122                 return $ ctx{ctx_tree})
 123           "[yes|no]")
 124          "print tags as a tree"
 125         ]
 126
 127 run :: Context.Context -> [String] -> IO ()
 128 run context args = do
 129         (ctx, inputs) <- Args.parse context usage options (nil, args)
 130         read_journals <-
 131                 liftM Data.Either.partitionEithers $ do
 132                 CLI.Ledger.paths context $ ctx_input ctx ++ inputs
 133                 >>= do
 134                         mapM $ \path -> do
 135                                 liftIO $ runExceptT $ Ledger.Read.file
 136                                  (Ledger.Read.context
 137                                          ( ctx_filter_transaction ctx
 138                                          , ctx_filter_tag ctx
 139                                          ) Ledger.journal)
 140                                  path
 141                                 >>= \x -> case x of
 142                                  Left  ko -> return $ Left (path, ko)
 143                                  Right ok -> return $ Right ok
 144         case read_journals of
 145          (errs@(_:_), _journals) ->
 146                 forM_ errs $ \(_path, err) -> do
 147                         Write.fatal context $ err
 148          ([], journals) -> do
 149                 let files = ledger_tags ctx journals
 150                 style_color <- Write.with_color context IO.stdout
 151                 W.displayIO IO.stdout $ do
 152                 W.renderPretty style_color 1.0 maxBound $ do
 153                 doc_tags context ctx files
 154
 155 ledger_tags
 156  :: Ctx
 157  -> [ Ledger.Journal (Tags Ledger.Transaction) ]
 158  -> Tags Ledger.Transaction
 159 ledger_tags _ctx =
 160         Data.Foldable.foldl'
 161          (flip $ Ledger.Journal.fold
 162                  (\Ledger.Journal{Ledger.journal_transactions=ts} ->
 163                         mappend ts))
 164          mempty
 165
 166 doc_tags
 167  :: Context
 168  -> Ctx
 169  -> Tags Ledger.Transaction
 170  -> W.Doc
 171 doc_tags _context ctx =
 172         (case ctx_tree ctx of
 173          True ->
 174                 Data.Map.foldlWithKey
 175                  (\doc p vs ->
 176                         doc <> foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
 177                         " (" <> (W.toDoc () (Data.Map.size vs)) <> ")" <>
 178                         W.nest 2 (
 179                                 Data.Map.foldlWithKey
 180                                  (\doc' v vn ->
 181                                         doc' <> W.line <> W.dullred (W.toDoc () v) <>
 182                                         " (" <> (W.toDoc () vn) <> ")"
 183                                  )
 184                                  W.empty vs
 185                          ) <> W.line
 186                  )
 187                  W.empty
 188          False ->
 189                 Data.Map.foldlWithKey
 190                  (\doc p vs ->
 191                         doc <>
 192                         Data.Map.foldlWithKey
 193                          (\doc' v _vn ->
 194                                 doc' <>
 195                                 foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
 196                                 W.dullred (W.toDoc () v) <> W.line
 197                          ) W.empty vs
 198                  )
 199                  W.empty
 200          ) .
 201         tags
 202
 203 -- * Requirements' interface
 204
 205 -- ** Class 'Posting'
 206
 207 class Posting        p where
 208         posting_account :: p -> Account
 209
 210 instance Posting Ledger.Posting where
 211         posting_account = Ledger.posting_account
 212
 213 -- ** Class 'Transaction'
 214
 215 class
 216  ( Posting  (Transaction_Posting  t)
 217  , Foldable (Transaction_Postings t)
 218  )
 219  =>    Transaction          t where
 220         type Transaction_Posting  t
 221         type Transaction_Postings t :: * -> *
 222         -- transaction_postings      :: t -> Transaction_Postings t (Transaction_Posting t)
 223         transaction_tags          :: t -> Map Tag.Path [Tag.Value]
 224
 225 instance Transaction        Ledger.Transaction where
 226         type Transaction_Posting  Ledger.Transaction = Ledger.Posting
 227         type Transaction_Postings Ledger.Transaction = Compose [] (Compose (Map Account) [])
 228         transaction_tags = Ledger.transaction_tags
 229
 230 -- * Type 'Tags'
 231
 232 data Transaction t => Tags t
 233  = Tags
 234  { tags :: Map Tag.Path (Map Tag.Value Integer)
 235  }
 236  deriving (Show)
 237
 238 instance Transaction t => Monoid (Tags t) where
 239         mempty = Tags mempty
 240         mappend t0 t1 =
 241                 Tags
 242                  { tags = Data.Map.unionWith
 243                          (Data.Map.unionWith (+))
 244                          (tags t0)
 245                          (tags t1)
 246                  }
 247 instance Transaction t => Consable (Filter.Simplified Filter.Filter_Tag) Tags t where
 248         mcons f t !ts =
 249                 case Filter.simplified f of
 250                  Right False -> ts
 251                  Right True  -> ts{ tags = merge (transaction_tags t) (tags ts) }
 252                  Left fT ->
 253                         ts{ tags = merge
 254                          (Data.Map.mapMaybeWithKey
 255                                  (\p vs ->
 256                                         if Filter.test fT (p, vs)
 257                                         then Just $ filter (\v -> Filter.test fT (p, [v])) vs
 258                                         else Nothing)
 259                                  (transaction_tags t))
 260                          (tags ts)
 261                          }
 262                 where
 263                         merge
 264                          :: Map Tag.Path [Tag.Value]
 265                          -> Map Tag.Path (Map Tag.Value Integer)
 266                          -> Map Tag.Path (Map Tag.Value Integer)
 267                         merge =
 268                                 Data.Map.mergeWithKey
 269                                  (\_k x1 x2 -> Just $
 270                                         Data.Map.unionWith (+) x2 $
 271                                         Data.Map.fromListWith (+) $ (, 1) <$> x1)
 272                                  ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
 273                                  id
 274 instance
 275  ( Filter.Transaction t
 276  , Transaction        t
 277  ) => Consable
 278  ( Filter.Simplified
 279     (Filter.Filter_Bool
 280     (Filter.Filter_Transaction t))
 281  ,  Filter.Simplified Filter.Filter_Tag
 282  )
 283  Tags t where
 284         mcons (ft, fT) t !ts =
 285                 if Filter.test ft t
 286                 then mcons fT t ts
 287                 else ts