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 (Monad(..), forM_, liftM, mapM)
  13 import           Control.Monad.IO.Class (liftIO)
  14 import           Control.Monad.Trans.Except (runExceptT)
  15 import           Data.Bool
  16 import           Data.Either (Either(..), partitionEithers)
  17 import           Data.Foldable (Foldable(..))
  18 import           Data.Functor ((<$>))
  19 import           Data.Functor.Compose (Compose(..))
  20 import           Data.List ((++))
  21 import qualified Data.List (filter)
  22 import           Data.Map.Strict (Map)
  23 import qualified Data.Map.Strict as Data.Map
  24 import           Data.Maybe (Maybe(..))
  25 import           Data.Monoid (Monoid(..), (<>))
  26 import           Data.String (String)
  27 import           Data.Tuple (snd)
  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           Hcompta.Account (Account)
  39 import           Hcompta.Chart (Chart)
  40 import qualified Hcompta.CLI.Args as Args
  41 import qualified Hcompta.CLI.Context as C
  42 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  43 import qualified Hcompta.CLI.Lang as Lang
  44 import qualified Hcompta.CLI.Write as Write
  45 import qualified Hcompta.Filter as Filter
  46 import qualified Hcompta.Filter.Read as Filter.Read
  47 import qualified Hcompta.Format.Ledger as Ledger
  48 import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
  49 import qualified Hcompta.Format.Ledger.Read as Ledger.Read
  50 import           Hcompta.Lib.Consable (Consable(..))
  51 import qualified Hcompta.Lib.Leijen as W
  52 import qualified Hcompta.Tag as Tag
  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                              (Chart, 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.Ledger.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 (Chart, Ledger.Transaction)) ]
 168  -> Tags (Chart, 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 (Chart, 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 -> 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 -> Tag.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 Account) [])
 238         transaction_tags = Ledger.transaction_tags
 239
 240 instance Transaction        (Chart, Ledger.Transaction) where
 241         type Transaction_Posting  (Chart, Ledger.Transaction) = Transaction_Posting Ledger.Transaction
 242         type Transaction_Postings (Chart, Ledger.Transaction) = Transaction_Postings Ledger.Transaction
 243         transaction_tags = transaction_tags . snd
 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 Transaction t
 263  => Consable (Filter.Simplified Filter.Filter_Tags)
 264              Tags
 265              t where
 266         mcons f t !ts =
 267                 case Filter.simplified f of
 268                  Right False -> ts
 269                  Right True  -> ts{ tags = merge (Tag.unTags $ transaction_tags t) (tags ts) }
 270                  Left fT ->
 271                         ts{ tags = merge
 272                          (Data.Map.mapMaybeWithKey
 273                                  (\p vs ->
 274                                         if Filter.test fT $ Tag.Tags $ Data.Map.singleton p vs
 275                                         then Just $ Data.List.filter (\v -> Filter.test fT $ Tag.Tags $ Data.Map.singleton p [v]) vs
 276                                         else Nothing)
 277                                  (Tag.unTags $ transaction_tags t))
 278                          (tags ts)
 279                          }
 280                 where
 281                         merge
 282                          :: Map Tag.Path [Tag.Value]
 283                          -> Map Tag.Path (Map Tag.Value Integer)
 284                          -> Map Tag.Path (Map Tag.Value Integer)
 285                         merge =
 286                                 Data.Map.mergeWithKey
 287                                  (\_k x1 x2 -> Just $
 288                                         Data.Map.unionWith (+) x2 $
 289                                         Data.Map.fromListWith (+) $ (, 1) <$> x1)
 290                                  ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
 291                                  id
 292 instance
 293  ( Filter.Transaction t
 294  , Transaction        t
 295  ) => Consable
 296  ( Filter.Simplified
 297     (Filter.Filter_Bool
 298     (Filter.Filter_Transaction t))
 299  ,  Filter.Simplified Filter.Filter_Tags
 300  )
 301  Tags t where
 302         mcons (ft, fT) t !ts =
 303                 if Filter.test ft t
 304                 then mcons fT t ts
 305                 else ts