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