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