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 ((++), replicate)
  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 (($), (.), Bounded(..), 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           Hcompta.CLI.Context (Context)
  42 import qualified Hcompta.CLI.Context as Context
  43 import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
  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 :: IO String
  76 usage = do
  77         bin <- Env.getProgName
  78         let pad = replicate (length bin) ' '
  79         return $unlines $
  80                 [ "SYNTAX "
  81                 , "  "++bin++" tags [-i FILE_JOURNAL]"
  82                 , "  "++pad++"      [-t FILTER_TRANSACTION_FILTER]"
  83                 , "  "++pad++"      [-T FILTER_TAG]"
  84                 , "  "++pad++"      [FILE_JOURNAL] [...]"
  85                 , ""
  86                 , usageInfo "OPTIONS" options
  87                 ]
  88
  89 options :: Args.Options Ctx
  90 options =
  91         [ Option "h" ["help"]
  92          (NoArg (\_context _ctx -> do
  93                 usage >>= IO.hPutStr IO.stderr
  94                 exitSuccess))
  95          "show this help"
  96         , Option "i" ["input"]
  97          (ReqArg (\s _context ctx -> do
  98                 return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
  99          "read data from given file, multiple uses merge the data as would a concatenation do"
 100         , Option "t" ["transaction-filter"]
 101          (ReqArg (\s context ctx -> do
 102                 ctx_filter_transaction <-
 103                         liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
 104                         liftIO $ Filter.Read.read Filter.Read.filter_transaction s
 105                         >>= \f -> case f of
 106                          Left  ko -> Write.fatal context $ ko
 107                          Right ok -> do
 108                                 Write.debug context $ "filter: transaction: " ++ show ok
 109                                 return ok
 110                 return $ ctx{ctx_filter_transaction}) "FILTER")
 111          "filter at transaction level, multiple uses are merged with a logical AND"
 112         , Option "T" ["tag-filter"]
 113          (ReqArg (\s context 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 context $ ko
 119                          Right ok -> do
 120                                 Write.debug context $ "filter: tag: " ++ show ok
 121                                 return ok
 122                 return $ ctx{ctx_filter_tag}) "FILTER")
 123          "filter at transaction level, multiple uses are merged with a logical AND"
 124         , Option "" ["tree"]
 125          (OptArg (\arg context ctx -> do
 126                 ctx_tree <- case arg of
 127                  Nothing    -> return $ True
 128                  Just "yes" -> return $ True
 129                  Just "no"  -> return $ False
 130                  Just _     -> Write.fatal context $
 131                         W.text "--tree option expects \"yes\", or \"no\" as value"
 132                 return $ ctx{ctx_tree})
 133           "[yes|no]")
 134          "print tags as a tree"
 135         ]
 136
 137 run :: Context.Context -> [String] -> IO ()
 138 run context args = do
 139         (ctx, inputs) <- Args.parse context usage options (nil, args)
 140         read_journals <-
 141                 liftM Data.Either.partitionEithers $ do
 142                 CLI.Ledger.paths context $ 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 context $ err
 158          ([], journals) -> do
 159                 let files = ledger_tags ctx journals
 160                 style_color <- Write.with_color context IO.stdout
 161                 W.displayIO IO.stdout $ do
 162                 W.renderPretty style_color 1.0 maxBound $ do
 163                 doc_tags context 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  :: 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