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.DeepSeq (NFData(..))
  13 import           Control.Monad (Monad(..), forM_, liftM, mapM)
  14 import           Control.Monad.IO.Class (liftIO)
  15 import           Control.Monad.Trans.Except (runExceptT)
  16 import           Data.Bool
  17 import           Data.Either (Either(..), partitionEithers)
  18 import           Data.Foldable (Foldable(..))
  19 import           Data.Functor ((<$>))
  20 import           Data.Functor.Compose (Compose(..))
  21 import           Data.List ((++))
  22 import qualified Data.List (filter)
  23 import           Data.Map.Strict (Map)
  24 import qualified Data.Map.Strict as Data.Map
  25 import           Data.Maybe (Maybe(..))
  26 import           Data.Monoid (Monoid(..), (<>))
  27 import           Data.String (String)
  28 import           Prelude (($), (.), FilePath, Integer, IO, Num(..), flip, id, unlines)
  29 import           Text.Show (Show(..))
  30 import           System.Console.GetOpt
  31                  ( ArgDescr(..)
  32                  , OptDescr(..)
  33                  , usageInfo )
  34 import           System.Environment as Env (getProgName)
  35 import           System.Exit (exitSuccess)
  36 import qualified System.IO as IO
  37
  38 import qualified Hcompta.CLI.Args as Args
  39 import qualified Hcompta.CLI.Context as C
  40 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  41 import qualified Hcompta.CLI.Lang as Lang
  42 import qualified Hcompta.CLI.Write as Write
  43 import qualified Hcompta.Filter as Filter
  44 import qualified Hcompta.Filter.Read as Filter.Read
  45 import qualified Hcompta.Format.Ledger as Ledger
  46 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  47 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  48 import           Hcompta.Lib.Consable (Consable(..))
  49 import qualified Hcompta.Lib.Leijen as W
  50 import qualified Hcompta.Tag as Tag
  51
  52 data Ctx
  53  =   Ctx
  54  { ctx_input              :: [FilePath]
  55  , ctx_filter_transaction :: Filter.Simplified
  56                              (Filter.Filter_Bool
  57                              (Filter.Filter_Transaction
  58                              (Ledger.Chart_With Ledger.Transaction)))
  59  , ctx_filter_tag         :: Filter.Simplified
  60                              Filter.Filter_Tags
  61  , ctx_tree               :: Bool
  62  } deriving (Show)
  63
  64 nil :: Ctx
  65 nil =
  66         Ctx
  67          { ctx_input = []
  68          , ctx_filter_transaction = mempty
  69          , ctx_filter_tag = mempty
  70          , ctx_tree = False
  71          }
  72
  73 usage :: C.Context -> IO String
  74 usage c = do
  75         bin <- Env.getProgName
  76         return $ unlines $
  77                 [ C.translate c Lang.Section_Description
  78                 , "  "++C.translate c Lang.Help_Command_Tags
  79                 , ""
  80                 , C.translate c Lang.Section_Syntax
  81                 , "  "++bin++" tags ["++C.translate c Lang.Type_Option++"] [...]"++
  82                                   " ["++C.translate c Lang.Type_File_Journal++"] [...]"
  83                 , ""
  84                 , usageInfo (C.translate c Lang.Section_Options) (options c)
  85                 ]
  86
  87 options :: C.Context -> Args.Options Ctx
  88 options c =
  89         [ Option "h" ["help"]
  90          (NoArg (\_ctx -> do
  91                 usage c >>= IO.hPutStr IO.stderr
  92                 exitSuccess)) $
  93                 C.translate c Lang.Help_Option_Help
  94         , Option "i" ["input"]
  95          (ReqArg (\s ctx -> do
  96                 return $ ctx{ctx_input=s:ctx_input ctx}) $
  97                 C.translate c Lang.Type_File_Journal) $
  98                 C.translate c Lang.Help_Option_Input
  99         , Option "t" ["transaction-filter"]
 100          (ReqArg (\s ctx -> do
 101                 ctx_filter_transaction <-
 102                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
 103                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
 104                         >>= \f -> case f of
 105                          Left  ko -> Write.fatal c $ ko
 106                          Right ok -> do
 107                                 Write.debug c $ "filter: transaction: " ++ show ok
 108                                 return ok
 109                 return $ ctx{ctx_filter_transaction}) $
 110                 C.translate c Lang.Type_Filter_Transaction) $
 111                 C.translate c Lang.Help_Option_Filter_Transaction
 112         , Option "T" ["tag-filter"]
 113          (ReqArg (\s ctx -> do
 114                 ctx_filter_tag <-
 115                         liftM ((ctx_filter_tag ctx <>) . Filter.simplify) $
 116                         liftIO $ Filter.Read.read Filter.Read.filter_tag s
 117                         >>= \f -> case f of
 118                          Left  ko -> Write.fatal c $ ko
 119                          Right ok -> do
 120                                 Write.debug c $ "filter: tag: " ++ show ok
 121                                 return ok
 122                 return $ ctx{ctx_filter_tag}) $
 123                 C.translate c Lang.Type_Filter_Tag) $
 124                 C.translate c Lang.Help_Option_Filter_Tag
 125         , Option "" ["tree"]
 126          (OptArg (\arg ctx -> do
 127                 ctx_tree <- case arg of
 128                  Nothing    -> return $ True
 129                  Just "yes" -> return $ True
 130                  Just "no"  -> return $ False
 131                  Just _     -> Write.fatal c Lang.Error_Option_Tags_Tree
 132                 return $ ctx{ctx_tree})
 133           "[no|yes]") $
 134                 C.translate c Lang.Help_Option_Tags_Tree
 135         ]
 136
 137 run :: C.Context -> [String] -> IO ()
 138 run c args = do
 139         (ctx, inputs) <- Args.parse c usage options (nil, args)
 140         read_journals <-
 141                 liftM Data.Either.partitionEithers $ do
 142                 CLI.Ledger.paths c $ ctx_input ctx ++ inputs
 143                 >>= do
 144                         mapM $ \path -> do
 145                                 liftIO $ runExceptT $ Ledger.Read.file
 146                                  (Ledger.Read.context
 147                                          ( ctx_filter_transaction ctx
 148                                          , ctx_filter_tag ctx
 149                                          ) Ledger.journal)
 150                                  path
 151                                 >>= \x -> case x of
 152                                  Left  ko -> return $ Left (path, ko)
 153                                  Right ok -> return $ Right ok
 154         case read_journals of
 155          (errs@(_:_), _journals) ->
 156                 forM_ errs $ \(_path, err) -> do
 157                         Write.fatal c $ err
 158          ([], journals) -> do
 159                 let files = ledger_tags ctx journals
 160                 Write.write c Write.style [(Write.Mode_Append, "-")] $ do
 161                 doc_tags c ctx files
 162
 163 ledger_tags
 164  :: Ctx
 165  -> [ Ledger.Journal (Tags (Ledger.Chart_With Ledger.Transaction)) ]
 166  -> Tags (Ledger.Chart_With Ledger.Transaction)
 167 ledger_tags _ctx =
 168         Data.Foldable.foldl'
 169          (flip $ Ledger.Journal.fold
 170                  (\Ledger.Journal{Ledger.journal_sections=ts} ->
 171                         mappend ts))
 172          mempty
 173
 174 doc_tags
 175  :: C.Context
 176  -> Ctx
 177  -> Tags (Ledger.Chart_With Ledger.Transaction)
 178  -> W.Doc
 179 doc_tags _context ctx =
 180         (case ctx_tree ctx of
 181          True ->
 182                 Data.Map.foldlWithKey
 183                  (\doc p vs ->
 184                         doc <> foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
 185                         " (" <> (W.toDoc () (Data.Map.size vs)) <> ")" <>
 186                         W.nest 2 (
 187                                 Data.Map.foldlWithKey
 188                                  (\doc' v vn ->
 189                                         doc' <> W.line <> W.dullred (W.toDoc () v) <>
 190                                         " (" <> (W.toDoc () vn) <> ")"
 191                                  )
 192                                  W.empty vs
 193                          ) <> W.line
 194                  )
 195                  W.empty
 196          False ->
 197                 Data.Map.foldlWithKey
 198                  (\doc p vs ->
 199                         doc <>
 200                         Data.Map.foldlWithKey
 201                          (\doc' v _vn ->
 202                                 doc' <>
 203                                 foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
 204                                 W.dullred (W.toDoc () v) <> W.line
 205                          ) W.empty vs
 206                  )
 207                  W.empty
 208          ) .
 209         tags
 210
 211 -- * Requirements' interface
 212
 213 -- ** Class 'Posting'
 214
 215 class Posting        p where
 216         posting_account :: p -> Ledger.Account
 217
 218 instance Posting Ledger.Posting where
 219         posting_account = Ledger.posting_account
 220
 221 -- ** Class 'Transaction'
 222
 223 class
 224  ( Posting  (Transaction_Posting  t)
 225  , Foldable (Transaction_Postings t)
 226  )
 227  =>    Transaction          t where
 228         type Transaction_Posting  t
 229         type Transaction_Postings t :: * -> *
 230         -- transaction_postings      :: t -> Transaction_Postings t (Transaction_Posting t)
 231         transaction_tags          :: t -> Tag.Tags
 232
 233 instance Transaction        Ledger.Transaction where
 234         type Transaction_Posting  Ledger.Transaction = Ledger.Posting
 235         type Transaction_Postings Ledger.Transaction = Compose [] (Compose (Map Ledger.Account) [])
 236         transaction_tags = Ledger.transaction_tags
 237
 238 instance Transaction        (Ledger.Chart_With Ledger.Transaction) where
 239         type Transaction_Posting  (Ledger.Chart_With Ledger.Transaction) = Transaction_Posting Ledger.Transaction
 240         type Transaction_Postings (Ledger.Chart_With Ledger.Transaction) = Transaction_Postings Ledger.Transaction
 241         transaction_tags = transaction_tags . Ledger.with_chart
 242
 243 -- * Type 'Tags'
 244
 245 data Transaction t => Tags t
 246  = Tags
 247  { tags :: Map Tag.Path (Map Tag.Value Integer)
 248  }
 249  deriving (Show)
 250
 251 instance Transaction t => Monoid (Tags t) where
 252         mempty = Tags mempty
 253         mappend t0 t1 =
 254                 Tags
 255                  { tags = Data.Map.unionWith
 256                          (Data.Map.unionWith (+))
 257                          (tags t0)
 258                          (tags t1)
 259                  }
 260 instance NFData t => NFData (Tags t) where
 261         rnf (Tags t) = rnf t
 262
 263 instance Transaction t
 264  => Consable (Filter.Simplified Filter.Filter_Tags)
 265              Tags
 266              t where
 267         mcons f t !ts =
 268                 case Filter.simplified f of
 269                  Right False -> ts
 270                  Right True  -> ts{ tags = merge (Tag.unTags $ transaction_tags t) (tags ts) }
 271                  Left fT ->
 272                         ts{ tags = merge
 273                          (Data.Map.mapMaybeWithKey
 274                                  (\p vs ->
 275                                         if Filter.test fT $ Tag.Tags $ Data.Map.singleton p vs
 276                                         then Just $ Data.List.filter (\v -> Filter.test fT $ Tag.Tags $ Data.Map.singleton p [v]) vs
 277                                         else Nothing)
 278                                  (Tag.unTags $ transaction_tags t))
 279                          (tags ts)
 280                          }
 281                 where
 282                         merge
 283                          :: Map Tag.Path [Tag.Value]
 284                          -> Map Tag.Path (Map Tag.Value Integer)
 285                          -> Map Tag.Path (Map Tag.Value Integer)
 286                         merge =
 287                                 Data.Map.mergeWithKey
 288                                  (\_k x1 x2 -> Just $
 289                                         Data.Map.unionWith (+) x2 $
 290                                         Data.Map.fromListWith (+) $ (, 1) <$> x1)
 291                                  ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
 292                                  id
 293 instance
 294  ( Filter.Transaction t
 295  , Transaction        t
 296  ) => Consable
 297  ( Filter.Simplified
 298     (Filter.Filter_Bool
 299     (Filter.Filter_Transaction t))
 300  ,  Filter.Simplified Filter.Filter_Tags
 301  )
 302  Tags t where
 303         mcons (ft, fT) t !ts =
 304                 if Filter.test ft t
 305                 then mcons fT t ts
 306                 else ts