import qualified Hcompta.CLI.Command.Balance as Command.Balance
import qualified Hcompta.CLI.Command.GL as Command.GL
import qualified Hcompta.CLI.Command.Journal as Command.Journal
+import qualified Hcompta.CLI.Command.Journals as Command.Journals
+import qualified Hcompta.CLI.Command.Stats as Command.Stats
+import qualified Hcompta.CLI.Command.Tags as Command.Tags
import Hcompta.CLI.Context (Context)
import qualified Hcompta.CLI.Context as Context
import qualified Hcompta.CLI.Lang as Lang
, ""
, usageInfo "OPTIONS" options
, "COMMANDS (use "++bin++" <command> --help for specific help)"
- , " journal [-i JOURNAL_FILE]"
- , " [-t TRANSACTION_FILTER]"
- , " [JOURNAL_FILE] [...]"
- , " balance [-i JOURNAL_FILE]"
- , " [-b BALANCE_FILTER]"
- , " [-p POSTING_FILTER]"
- , " [-t TRANSACTION_FILTER]"
- , " [JOURNAL_FILE] [...]"
- , " gl [-i JOURNAL_FILE]"
- , " [-g GL_FILTER]"
- , " [-p POSTING_FILTER]"
- , " [-t TRANSACTION_FILTER]"
- , " [JOURNAL_FILE] [...]"
+ , " balance [-i JOURNAL_FILE]"
+ , " [-b BALANCE_FILTER]"
+ , " [-p POSTING_FILTER]"
+ , " [-t TRANSACTION_FILTER]"
+ , " [JOURNAL_FILE] [...]"
+ , " gl [-i JOURNAL_FILE]"
+ , " [-g GL_FILTER]"
+ , " [-p POSTING_FILTER]"
+ , " [-t TRANSACTION_FILTER]"
+ , " [JOURNAL_FILE] [...]"
+ , " journal [-i JOURNAL_FILE]"
+ , " [-t TRANSACTION_FILTER]"
+ , " [JOURNAL_FILE] [...]"
+ , " journals [-i JOURNAL_FILE]"
+ , " [JOURNAL_FILE] [...]"
+ , " stats [-i JOURNAL_FILE]"
+ , " [-t TRANSACTION_FILTER]"
+ , " [JOURNAL_FILE] [...]"
+ , " tags [-i JOURNAL_FILE]"
+ , " [-t TRANSACTION_FILTER]"
+ , " [JOURNAL_FILE] [...]"
]
options :: Args.Options Context
run :: Context -> String -> [String] -> IO ()
run context cmd args =
case cmd of
- "balance" -> Command.Balance.run context args
- "gl" -> Command.GL.run context args
- "journal" -> Command.Journal.run context args
+ "balance" -> Command.Balance.run context args
+ "gl" -> Command.GL.run context args
+ "journal" -> Command.Journal.run context args
+ "journals" -> Command.Journals.run context args
+ "stats" -> Command.Stats.run context args
+ "tags" -> Command.Tags.run context args
_ -> usage >>= Write.fatal context .
((W.text "unknown command: " <> (W.text $ TL.pack cmd) <> W.line) <>) .
W.text . TL.pack
--- /dev/null
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+module Hcompta.CLI.Command.Journals where
+
+import Control.Monad (liftM, forM_)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (runExceptT)
+import qualified Data.Either
+import qualified Data.Foldable
+import Data.Monoid ((<>))
+import System.Console.GetOpt
+ ( ArgDescr(..)
+ , OptDescr(..)
+ , usageInfo )
+import System.Environment as Env (getProgName)
+import System.Exit (exitSuccess)
+import qualified System.IO as IO
+
+import qualified Hcompta.CLI.Args as Args
+import qualified Hcompta.CLI.Context as Context
+import Hcompta.CLI.Context (Context)
+import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
+import qualified Hcompta.CLI.Write as Write
+import qualified Hcompta.Format.Ledger as Ledger
+import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
+import qualified Hcompta.Format.Ledger.Read as Ledger.Read
+import qualified Hcompta.Lib.Leijen as W
+import Hcompta.Lib.Consable (Consable(..))
+
+data Ctx
+ = Ctx
+ { ctx_input :: [FilePath]
+ } deriving (Show)
+
+nil :: Ctx
+nil =
+ Ctx
+ { ctx_input = []
+ }
+
+usage :: IO String
+usage = do
+ bin <- Env.getProgName
+ let pad = replicate (length bin) ' '
+ return $unlines $
+ [ "SYNTAX "
+ , " "++bin++" stats [-i JOURNAL_FILE]"
+ , " "++pad++" [JOURNAL_FILE] [...]"
+ , ""
+ , usageInfo "OPTIONS" options
+ ]
+
+options :: Args.Options Ctx
+options =
+ [ Option "h" ["help"]
+ (NoArg (\_context _ctx -> do
+ usage >>= IO.hPutStr IO.stderr
+ exitSuccess))
+ "show this help"
+ , Option "i" ["input"]
+ (ReqArg (\s _context ctx -> do
+ return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
+ "read data from given file, multiple uses merge the data as would a concatenation do"
+ ]
+
+run :: Context.Context -> [String] -> IO ()
+run context args = do
+ (ctx, inputs) <- Args.parse context usage options (nil, args)
+ read_journals <-
+ liftM Data.Either.partitionEithers $ do
+ CLI.Ledger.paths context $ ctx_input ctx ++ inputs
+ >>= do
+ mapM $ \path -> do
+ liftIO $ runExceptT $ Ledger.Read.file
+ (Ledger.Read.context () Ledger.journal)
+ path
+ >>= \x -> case x of
+ Left ko -> return $ Left (path, ko)
+ Right ok -> return $ Right ok
+ case read_journals of
+ (errs@(_:_), _journals) ->
+ forM_ errs $ \(_path, err) -> do
+ Write.fatal context $ err
+ ([], journals) -> do
+ let files = ledger_journals ctx journals
+ style_color <- Write.with_color context IO.stdout
+ W.displayIO IO.stdout $ do
+ W.renderPretty style_color 1.0 maxBound $ do
+ doc_journals context ctx files
+
+newtype Journals t = Journals ()
+ deriving (Show)
+instance Monoid (Journals t) where
+ mempty = Journals ()
+ mappend _ _ = mempty
+
+instance Consable () Journals t where
+ mcons () _t !_js = mempty
+
+ledger_journals
+ :: Ctx
+ -> [ Ledger.Journal (Journals Ledger.Transaction) ]
+ -> [FilePath]
+ledger_journals _ctx =
+ Data.Foldable.foldl'
+ (flip $ Ledger.Journal.fold
+ (\Ledger.Journal{Ledger.journal_file=f} ->
+ mappend [f]))
+ mempty
+
+doc_journals
+ :: Context
+ -> Ctx
+ -> [FilePath]
+ -> W.Doc
+doc_journals _context _ctx =
+ foldr
+ (\file doc -> doc <> W.toDoc () file <> W.line)
+ W.empty
--- /dev/null
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+module Hcompta.CLI.Command.Stats where
+
+import Control.Monad (liftM, forM_)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (runExceptT)
+import qualified Data.Either
+import qualified Data.Foldable
+import qualified Data.Map.Strict as Data.Map
+import Data.Monoid ((<>))
+import System.Console.GetOpt
+ ( ArgDescr(..)
+ , OptDescr(..)
+ , usageInfo )
+import System.Environment as Env (getProgName)
+import System.Exit (exitSuccess)
+import qualified System.IO as IO
+
+import qualified Hcompta.CLI.Args as Args
+import qualified Hcompta.CLI.Context as Context
+import Hcompta.CLI.Context (Context)
+import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
+import qualified Hcompta.CLI.Lang as Lang
+import qualified Hcompta.CLI.Write as Write
+-- import qualified Hcompta.Date as Date
+import qualified Hcompta.Amount.Unit as Amount.Unit
+import qualified Hcompta.Filter as Filter
+import qualified Hcompta.Filter.Read as Filter.Read
+-- import qualified Hcompta.Filter.Reduce as Filter.Reduce
+import qualified Hcompta.Format.Ledger as Ledger
+import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
+import qualified Hcompta.Format.Ledger.Read as Ledger.Read
+-- import qualified Hcompta.Format.Ledger.Write as Ledger.Write
+import qualified Hcompta.Lib.Interval as Interval
+import qualified Hcompta.Lib.Leijen as W
+import qualified Hcompta.Stats as Stats
+
+data Ctx
+ = Ctx
+ { ctx_input :: [FilePath]
+ , ctx_filter_transaction :: Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Transaction
+ Ledger.Transaction))
+ } deriving (Show)
+
+nil :: Ctx
+nil =
+ Ctx
+ { ctx_input = []
+ , ctx_filter_transaction = mempty
+ }
+
+usage :: IO String
+usage = do
+ bin <- Env.getProgName
+ let pad = replicate (length bin) ' '
+ return $unlines $
+ [ "SYNTAX "
+ , " "++bin++" stats [-i JOURNAL_FILE]"
+ , " "++pad++" [-t TRANSACTION_FILTER]"
+ , " "++pad++" [JOURNAL_FILE] [...]"
+ , ""
+ , usageInfo "OPTIONS" options
+ ]
+
+options :: Args.Options Ctx
+options =
+ [ Option "h" ["help"]
+ (NoArg (\_context _ctx -> do
+ usage >>= IO.hPutStr IO.stderr
+ exitSuccess))
+ "show this help"
+ , Option "i" ["input"]
+ (ReqArg (\s _context ctx -> do
+ return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
+ "read data from given file, multiple uses merge the data as would a concatenation do"
+ , Option "t" ["transaction-filter"]
+ (ReqArg (\s context ctx -> do
+ ctx_filter_transaction <-
+ liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
+ liftIO $ Filter.Read.read Filter.Read.filter_transaction s
+ >>= \f -> case f of
+ Left ko -> Write.fatal context $ ko
+ Right ok -> do
+ Write.debug context $ "filter: transaction: " ++ show ok
+ return ok
+ return $ ctx{ctx_filter_transaction}) "FILTER")
+ "filter at transaction level, multiple uses are merged with a logical AND"
+ ]
+
+run :: Context.Context -> [String] -> IO ()
+run context args = do
+ (ctx, inputs) <- Args.parse context usage options (nil, args)
+ read_journals <-
+ liftM Data.Either.partitionEithers $ do
+ CLI.Ledger.paths context $ ctx_input ctx ++ inputs
+ >>= do
+ mapM $ \path -> do
+ liftIO $ runExceptT $ Ledger.Read.file
+ (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
+ path
+ >>= \x -> case x of
+ Left ko -> return $ Left (path, ko)
+ Right ok -> return $ Right ok
+ case read_journals of
+ (errs@(_:_), _journals) ->
+ forM_ errs $ \(_path, err) -> do
+ Write.fatal context $ err
+ ([], journals) -> do
+ Write.debug context $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
+ let (files, stats) = ledger_stats ctx journals
+ style_color <- Write.with_color context IO.stdout
+ W.displayIO IO.stdout $ do
+ W.renderPretty style_color 1.0 maxBound $ do
+ doc_stats context ctx (files, stats)
+
+ledger_stats
+ :: Ctx
+ -> [ Ledger.Journal (Stats.Stats Ledger.Transaction) ]
+ -> ([FilePath], Stats.Stats Ledger.Transaction)
+ledger_stats _ctx =
+ Data.Foldable.foldl'
+ (flip $ Ledger.Journal.fold
+ (\Ledger.Journal
+ { Ledger.journal_transactions=s
+ , Ledger.journal_file=f
+ } -> mappend ([f], s)))
+ mempty
+
+doc_stats
+ :: Context
+ -> Ctx
+ -> ([FilePath], Stats.Stats Ledger.Transaction)
+ -> W.Doc
+doc_stats context _ctx (files, stats) =
+ let lang = Context.lang context in
+ W.toDoc lang Lang.Message_Accounts <> " (" <>
+ (W.toDoc () $ Data.Map.size $ Stats.stats_accounts stats) <> ")" <>
+ W.nest 2 (
+ let depth = Stats.stats_accounts_depths stats in
+ W.line <> W.toDoc lang Lang.Message_Depths <>
+ " (" <>
+ W.toDoc () (Interval.limit $ Interval.low depth) <>
+ ".." <>
+ W.toDoc () (Interval.limit $ Interval.high depth) <>
+ ")"
+ ) <> W.line <>
+ W.toDoc lang Lang.Message_Transactions <> " (" <> (W.toDoc () $ Stats.stats_transactions stats) <> ")" <>
+ W.nest 2 (
+ case Stats.stats_transactions_span stats of
+ Nothing -> W.empty
+ Just date ->
+ W.line <> "Dates" <>
+ " (" <>
+ W.toDoc () (Interval.limit $ Interval.low date) <>
+ ".." <>
+ W.toDoc () (Interval.limit $ Interval.high date) <>
+ ")"
+ ) <> W.line <>
+ W.toDoc lang Lang.Message_Units <> " (" <>
+ (W.toDoc () (Data.Map.size $ Data.Map.delete Amount.Unit.nil $ Stats.stats_units stats)) <> ")" <> W.line <>
+ W.toDoc lang Lang.Message_Journals <> " (" <> (W.toDoc () (length $ files)) <> ")" <> W.line <>
+ W.toDoc lang Lang.Message_Tags <> " (" <>
+ (W.toDoc () (foldr (flip $ foldr (+)) 0 $ Stats.stats_tags stats)) <>
+ ")" <>
+ W.nest 2 ( W.line <>
+ "Distincts" <> " (" <> (W.toDoc () (Data.Map.size $ Stats.stats_tags stats)) <> ")"
+ ) <> W.line
--- /dev/null
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hcompta.CLI.Command.Tags where
+
+import Control.Monad (liftM, forM_)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Except (runExceptT)
+import qualified Data.Either
+import qualified Data.Foldable
+import Data.Functor.Compose (Compose(..))
+import Data.Monoid ((<>))
+import qualified Data.Map.Strict as Data.Map
+import Data.Map.Strict (Map)
+-- import Data.Text (Text)
+import System.Console.GetOpt
+ ( ArgDescr(..)
+ , OptDescr(..)
+ , usageInfo )
+import System.Environment as Env (getProgName)
+import System.Exit (exitSuccess)
+import qualified System.IO as IO
+
+import Hcompta.Account (Account)
+import qualified Hcompta.CLI.Args as Args
+import qualified Hcompta.CLI.Context as Context
+import Hcompta.CLI.Context (Context)
+import qualified Hcompta.CLI.Format.Ledger as CLI.Ledger
+import qualified Hcompta.CLI.Write as Write
+import qualified Hcompta.Filter as Filter
+import qualified Hcompta.Filter.Read as Filter.Read
+import qualified Hcompta.Format.Ledger as Ledger
+import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
+import qualified Hcompta.Format.Ledger.Read as Ledger.Read
+import qualified Hcompta.Lib.Leijen as W
+import Hcompta.Lib.Consable (Consable(..))
+import qualified Hcompta.Tag as Tag
+
+data Ctx
+ = Ctx
+ { ctx_input :: [FilePath]
+ , ctx_filter_transaction :: Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Transaction
+ Ledger.Transaction))
+ } deriving (Show)
+
+nil :: Ctx
+nil =
+ Ctx
+ { ctx_input = []
+ , ctx_filter_transaction = mempty
+ }
+
+usage :: IO String
+usage = do
+ bin <- Env.getProgName
+ let pad = replicate (length bin) ' '
+ return $unlines $
+ [ "SYNTAX "
+ , " "++bin++" tags [-i JOURNAL_FILE]"
+ , " "++pad++" [-t TRANSACTION_FILTER]"
+ , " "++pad++" [JOURNAL_FILE] [...]"
+ , ""
+ , usageInfo "OPTIONS" options
+ ]
+
+options :: Args.Options Ctx
+options =
+ [ Option "h" ["help"]
+ (NoArg (\_context _ctx -> do
+ usage >>= IO.hPutStr IO.stderr
+ exitSuccess))
+ "show this help"
+ , Option "i" ["input"]
+ (ReqArg (\s _context ctx -> do
+ return $ ctx{ctx_input=s:ctx_input ctx}) "FILE")
+ "read data from given file, multiple uses merge the data as would a concatenation do"
+ , Option "t" ["transaction-filter"]
+ (ReqArg (\s context ctx -> do
+ ctx_filter_transaction <-
+ liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
+ liftIO $ Filter.Read.read Filter.Read.filter_transaction s
+ >>= \f -> case f of
+ Left ko -> Write.fatal context $ ko
+ Right ok -> do
+ Write.debug context $ "filter: transaction: " ++ show ok
+ return ok
+ return $ ctx{ctx_filter_transaction}) "FILTER")
+ "filter at transaction level, multiple uses are merged with a logical AND"
+ ]
+
+run :: Context.Context -> [String] -> IO ()
+run context args = do
+ (ctx, inputs) <- Args.parse context usage options (nil, args)
+ read_journals <-
+ liftM Data.Either.partitionEithers $ do
+ CLI.Ledger.paths context $ ctx_input ctx ++ inputs
+ >>= do
+ mapM $ \path -> do
+ liftIO $ runExceptT $ Ledger.Read.file
+ (Ledger.Read.context (ctx_filter_transaction ctx) Ledger.journal)
+ path
+ >>= \x -> case x of
+ Left ko -> return $ Left (path, ko)
+ Right ok -> return $ Right ok
+ case read_journals of
+ (errs@(_:_), _journals) ->
+ forM_ errs $ \(_path, err) -> do
+ Write.fatal context $ err
+ ([], journals) -> do
+ let files = ledger_tags ctx journals
+ style_color <- Write.with_color context IO.stdout
+ W.displayIO IO.stdout $ do
+ W.renderPretty style_color 1.0 maxBound $ do
+ doc_tags context ctx files
+
+ledger_tags
+ :: Ctx
+ -> [ Ledger.Journal (Tags Ledger.Transaction) ]
+ -> Tags Ledger.Transaction
+ledger_tags _ctx =
+ Data.Foldable.foldl'
+ (flip $ Ledger.Journal.fold
+ (\Ledger.Journal{Ledger.journal_transactions=ts} ->
+ mappend ts))
+ mempty
+
+doc_tags
+ :: Context
+ -> Ctx
+ -> Tags Ledger.Transaction
+ -> W.Doc
+doc_tags _context _ctx =
+ Data.Map.foldlWithKey
+ (\doc p vs ->
+ doc <> foldMap (\s -> W.dullyellow (W.toDoc () s) <> ":") p <>
+ " (" <> (W.toDoc () (Data.Map.size vs)) <> ")" <>
+ W.nest 2 (
+ Data.Map.foldlWithKey
+ (\doc' v vn ->
+ doc' <> W.line <> W.dullred (W.toDoc () v) <>
+ " (" <> (W.toDoc () vn) <> ")"
+ )
+ W.empty vs
+ ) <> W.line
+ )
+ W.empty .
+ tags
+
+-- * Requirements' interface
+
+-- ** Class 'Posting'
+
+class Posting p where
+ posting_account :: p -> Account
+
+instance Posting Ledger.Posting where
+ posting_account = Ledger.posting_account
+
+-- ** Class 'Transaction'
+
+class
+ ( Posting (Transaction_Posting t)
+ , Foldable (Transaction_Postings t)
+ )
+ => Transaction t where
+ type Transaction_Posting t
+ type Transaction_Postings t :: * -> *
+ -- transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
+ transaction_tags :: t -> Map Tag.Path [Tag.Value]
+
+instance Transaction Ledger.Transaction where
+ type Transaction_Posting Ledger.Transaction = Ledger.Posting
+ type Transaction_Postings Ledger.Transaction = Compose [] (Compose (Map Account) [])
+ transaction_tags = Ledger.transaction_tags
+
+-- * Type 'Tags'
+
+data Transaction t => Tags t
+ = Tags
+ { tags :: Map Tag.Path (Map Tag.Value Integer)
+ }
+ deriving (Show)
+
+instance Transaction t => Monoid (Tags t) where
+ mempty = Tags mempty
+ mappend t0 t1 =
+ Tags
+ { tags = Data.Map.unionWith
+ (Data.Map.unionWith (+))
+ (tags t0)
+ (tags t1)
+ }
+instance Transaction t => Consable () Tags t where
+ mcons () t !ts =
+ ts
+ { tags =
+ Data.Map.mergeWithKey
+ (\_k x1 x2 -> Just $
+ Data.Map.unionWith (+) x1 $
+ Data.Map.fromListWith (+) $ (, 1) <$> x2)
+ id ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
+ (tags ts) -- Map Tag.Path (Map Tag.Value Integer)
+ (transaction_tags t) -- Map Tag.Path [Tag.Value]
+ }
+instance
+ ( Filter.Transaction t
+ , Transaction t
+ ) => Consable
+ (Filter.Simplified
+ (Filter.Filter_Bool
+ (Filter.Filter_Transaction t)))
+ Tags t where
+ mcons ft t !ts =
+ if Filter.test ft t
+ then mcons () t ts
+ else ts
import Hcompta.Amount (Amount)
import Hcompta.Amount.Unit (Unit)
import qualified Hcompta.Amount.Write as Amount.Write
+import Hcompta.Date (Date)
import qualified Hcompta.Date.Read as Date.Read
+import qualified Hcompta.Date.Write as Date.Write
import qualified Hcompta.Filter.Read as Filter.Read
import Hcompta.Lib.Leijen (ToDoc(..), (<>))
import qualified Hcompta.Lib.Leijen as W
import qualified Hcompta.Lib.Parsec as Lib.Parsec
-
data Lang
= FR
| EN
toDoc _ = Amount.Write.unit
instance ToDoc m Amount where
toDoc _ = Amount.Write.amount
+instance ToDoc m Date where
+ toDoc _ = Date.Write.date
instance ToDoc Lang Date.Read.Error where
toDoc FR e =
case e of
| Message_Equilibrium {}
| Message_Equilibrium_posting {}
| Message_Balance_Description Bool
+ | Message_Accounts
+ | Message_Depths
+ | Message_Transactions
+ | Message_Units
+ | Message_Journals
+ | Message_Tags
+ | Message_Distincts
instance ToDoc Lang Message where
toDoc EN msg =
case msg of
case negate_transaction of
True -> "Closing balance"
False -> "Opening balance"
+ Message_Accounts -> "Accounts"
+ Message_Depths -> "Depths"
+ Message_Transactions -> "Transactions"
+ Message_Units -> "Units"
+ Message_Journals -> "Journals"
+ Message_Tags -> "Tags"
+ Message_Distincts -> "Distincts"
toDoc FR msg =
case msg of
Message_ERROR ->
case negate_transaction of
True -> "Solde de clôture"
False -> "Solde d’ouverture"
+ Message_Accounts -> "Comptes"
+ Message_Depths -> "Profondeurs"
+ Message_Transactions -> "Écritures"
+ Message_Units -> "Unités"
+ Message_Journals -> "Journaux"
+ Message_Tags -> "Tags"
+ Message_Distincts -> "Distincts"
Hcompta.CLI.Command.Balance
Hcompta.CLI.Command.GL
Hcompta.CLI.Command.Journal
+ Hcompta.CLI.Command.Journals
+ Hcompta.CLI.Command.Stats
Hcompta.CLI.Context
Hcompta.CLI.Format.Ledger
Hcompta.CLI.Lang
module Hcompta.Account where
import Data.Data (Data)
+import qualified Data.Foldable
import qualified Data.List
-import qualified Data.List.NonEmpty
+import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
-import Data.Semigroup ((<>))
import Data.Typeable (Typeable)
--- import qualified Text.Parsec as P
--- import Text.Parsec (Stream, ParsecT, (<|>), (<?>))
import Data.Text (Text)
--- import qualified Hcompta.Account.Path as Path
+import qualified Hcompta.Lib.NonEmpty as NonEmpty
import Hcompta.Lib.Regex (Regex)
-import qualified Hcompta.Lib.TreeMap as Lib.TreeMap
+import Hcompta.Lib.TreeMap (TreeMap)
-- * The 'Account' type
-- | An 'Account' is a non-empty list of 'Name'.
type Account = NonEmpty Name
type Name = Text
-type Map x = Lib.TreeMap.TreeMap Name x
+type Map x = TreeMap Name x
-- | Return the 'Account' formed by the given 'Name' and 'Name's.
account :: Name -> [Name] -> Account
account = (:|)
+-- | Return the number of 'Name's in the given 'Account'.
+depth :: Account -> Integer
+depth = Data.Foldable.foldl' (\d -> const $ d + 1) 0
+
-- | Return the given 'Account' without its last 'Name' if any.
ascending :: Account -> Maybe Account
-ascending (_:|[]) = Nothing
-ascending (n:|ns) = Just (n:|Data.List.init ns)
-{-# INLINE ascending #-}
+ascending = NonEmpty.ascending
-- | Apply the given function to all the prefixes
-- of the given 'Account' (including itself).
go s (n:ns) f acc =
go ((Data.List.++) s [n]) ns f (f (n0:|s) acc)
--- | Return the concatenation of the given 'Account'.
-(++) :: Account -> Account -> Account
-(++) = (<>)
-
-- | Return an 'Account' from the given list.
from_List :: [Name] -> Account
-from_List = Data.List.NonEmpty.fromList
+from_List = NonEmpty.fromList
-- * The 'Joker' type
import Text.Regex.TDFA.Text ()
import qualified Data.List.NonEmpty as NonEmpty
--- import Data.List.NonEmpty (NonEmpty(..))
+import Data.List.NonEmpty (NonEmpty(..))
import Hcompta.Lib.Consable (Consable(..))
import Hcompta.Lib.Interval (Interval)
import qualified Hcompta.Lib.Interval as Interval
import qualified Hcompta.Balance as Balance
import qualified Hcompta.GL as GL
import qualified Hcompta.Journal as Journal
+import qualified Hcompta.Stats as Stats
-- import qualified Hcompta.Posting as Posting
+import qualified Hcompta.Tag as Tag
-- * Requirements' interface
+-- ** Class 'Path'
+
+type Path section
+ = NonEmpty section
+
+class Path_Section a where
+ path_section_text :: a -> Text
+
+instance Path_Section Text where
+ path_section_text = id
+
-- ** Class 'Unit'
class Unit a where
amount_quantity :: a -> Amount_Quantity a
amount_sign :: a -> Ordering
-instance Amount Amount.Amount where
+instance Amount Amount.Amount where
type Amount_Unit Amount.Amount = Amount.Unit
type Amount_Quantity Amount.Amount = Amount.Quantity
amount_quantity = Amount.quantity
transaction_description :: t -> Text
transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
transaction_postings_virtual :: t -> Transaction_Postings t (Transaction_Posting t)
- transaction_tags :: t -> Map Text [Text]
+ transaction_tags :: t -> Map Tag.Path [Tag.Value]
-- ** Class 'Balance'
type Filter_Description
= Filter_Text
--- ** Type 'Filter_Account'
+-- ** Type 'Filter_Path'
-data Filter_Account
- = Filter_Account Order [Filter_Account_Section]
+data Filter_Path section
+ = Filter_Path Order [Filter_Path_Section]
deriving (Eq, Show, Typeable)
-data Filter_Account_Section
- = Filter_Account_Section_Any
- | Filter_Account_Section_Many
- | Filter_Account_Section_Text Filter_Text
+data Filter_Path_Section
+ = Filter_Path_Section_Any
+ | Filter_Path_Section_Many
+ | Filter_Path_Section_Text Filter_Text
deriving (Eq, Show, Typeable)
-instance Filter Filter_Account where
- type Filter_Key Filter_Account = Account
- test (Filter_Account ord flt) acct =
- go ord (NonEmpty.toList acct) flt
+instance Path_Section s
+ => Filter (Filter_Path s) where
+ type Filter_Key (Filter_Path s) = Path s
+ test (Filter_Path ord flt) path =
+ go ord (NonEmpty.toList path) flt
where
- go :: Order -> [Account.Name] -> [Filter_Account_Section] -> Bool
+ go :: Order -> [s] -> [Filter_Path_Section] -> Bool
go o [] [] =
case o of
Lt -> False
Eq -> True
Ge -> True
Gt -> False
- go o _ [Filter_Account_Section_Many] =
+ go o _ [Filter_Path_Section_Many] =
case o of
Lt -> False
Le -> True
{-
go o (s:[]) (n:_) =
case s of
- Filter_Account_Section_Any -> True
- Filter_Account_Section_Many -> True
- Filter_Account_Section_Text m -> test m n
+ Filter_Path_Section_Any -> True
+ Filter_Path_Section_Many -> True
+ Filter_Path_Section_Text m -> test m n
-}
go o no@(n:ns) fo@(f:fs) =
case f of
- Filter_Account_Section_Any -> go o ns fs
- Filter_Account_Section_Many -> go o no fs || go o ns fo
- Filter_Account_Section_Text m -> test m n && go o ns fs
+ Filter_Path_Section_Any -> go o ns fs
+ Filter_Path_Section_Many -> go o no fs || go o ns fo
+ Filter_Path_Section_Text m -> test m (path_section_text n) &&
+ go o ns fs
go o _ [] =
case o of
Lt -> False
Gt -> True
simplify flt =
case flt of
- Filter_Account o l | all (Filter_Account_Section_Many ==) l ->
+ Filter_Path o l | all (Filter_Path_Section_Many ==) l ->
Simplified $ Right $
case o of
Lt -> False
Eq -> True
Ge -> True
Gt -> False
- Filter_Account o [] ->
+ Filter_Path o [] ->
Simplified $ Right $
case o of
Lt -> False
Eq -> False
Ge -> False
Gt -> True
- Filter_Account o fa ->
- Filter_Account o <$> go fa
+ Filter_Path o fa ->
+ Filter_Path o <$> go fa
where
- go :: [Filter_Account_Section] -> Simplified [Filter_Account_Section]
+ go :: [Filter_Path_Section] -> Simplified [Filter_Path_Section]
go f =
case f of
[] -> Simplified $ Left []
- Filter_Account_Section_Many:l@(Filter_Account_Section_Many:_) -> go l
+ Filter_Path_Section_Many:l@(Filter_Path_Section_Many:_) -> go l
ff:l ->
case simplified $ simplify_section ff of
Left fff -> ((fff :) <$> go l)
- Right True -> ((Filter_Account_Section_Any :) <$> go l)
+ Right True -> ((Filter_Path_Section_Any :) <$> go l)
Right False -> Simplified $ Right False
simplify_section f =
case f of
- Filter_Account_Section_Any -> Simplified $ Left $ Filter_Account_Section_Any
- Filter_Account_Section_Many -> Simplified $ Left $ Filter_Account_Section_Many
- Filter_Account_Section_Text ff -> Filter_Account_Section_Text <$> simplify ff
+ Filter_Path_Section_Any -> Simplified $ Left $ Filter_Path_Section_Any
+ Filter_Path_Section_Many -> Simplified $ Left $ Filter_Path_Section_Many
+ Filter_Path_Section_Text ff -> Filter_Path_Section_Text <$> simplify ff
+
+-- ** Type 'Filter_Account'
+
+type Filter_Account
+ = Filter_Path Account.Name
-- ** Type 'Filter_Amount'
-- ** Type 'Filter_Tag'
-data Filter_Tag
- = Filter_Tag_Name Filter_Text
- | Filter_Tag_Value Filter_Text
+type Filter_Tag
+ = Filter_Bool
+ Filter_Tag_Component
+
+data Filter_Tag_Component
+ = Filter_Tag_Path (Filter_Path Tag.Section)
+ | Filter_Tag_Value Filter_Tag_Value
+ deriving (Eq, Show, Typeable)
+
+data Filter_Tag_Value
+ = Filter_Tag_Value_None
+ | Filter_Tag_Value_Any Filter_Text
+ | Filter_Tag_Value_First Filter_Text
+ | Filter_Tag_Value_Last Filter_Text
deriving (Eq, Show, Typeable)
-instance Filter Filter_Tag where
- type Filter_Key Filter_Tag = (Text, Text)
- test (Filter_Tag_Name f) (x, _) = test f x
- test (Filter_Tag_Value f) (_, x) = test f x
+instance Filter Filter_Tag_Component where
+ type Filter_Key Filter_Tag_Component = (Tag.Path, [Tag.Value])
+ test (Filter_Tag_Path f) (p, _) = test f p
+ test (Filter_Tag_Value f) (_, v) = test f v
simplify f =
case f of
- Filter_Tag_Name ff -> Filter_Tag_Name <$> simplify ff
+ Filter_Tag_Path ff -> Filter_Tag_Path <$> simplify ff
Filter_Tag_Value ff -> Filter_Tag_Value <$> simplify ff
+instance Filter Filter_Tag_Value where
+ type Filter_Key Filter_Tag_Value = [Tag.Value]
+ test (Filter_Tag_Value_None ) vs = null vs
+ test (Filter_Tag_Value_Any f) vs = Data.Foldable.any (test f) vs
+ test (Filter_Tag_Value_First f) vs =
+ case vs of
+ [] -> False
+ v:_ -> test f v
+ test (Filter_Tag_Value_Last f) vs =
+ case reverse vs of
+ [] -> False
+ v:_ -> test f v
+ simplify f =
+ case f of
+ Filter_Tag_Value_None -> Simplified $ Right False
+ Filter_Tag_Value_Any ff -> Filter_Tag_Value_Any <$> simplify ff
+ Filter_Tag_Value_First ff -> Filter_Tag_Value_First <$> simplify ff
+ Filter_Tag_Value_Last ff -> Filter_Tag_Value_Last <$> simplify ff
+
-- ** Type 'Filter_Posting'
data Posting posting
= Filter_Transaction_Description Filter_Description
| Filter_Transaction_Posting (Filter_Bool (Filter_Posting (Posting_Type, Transaction_Posting t)))
| Filter_Transaction_Date (Filter_Bool Filter_Date)
- | Filter_Transaction_Tag (Filter_Bool Filter_Tag)
+ | Filter_Transaction_Tag Filter_Tag
deriving (Typeable)
deriving instance Transaction t => Eq (Filter_Transaction t)
deriving instance Transaction t => Show (Filter_Transaction t)
test (Filter_Transaction_Tag f) t =
Data.Monoid.getAny $
Data.Map.foldrWithKey
- (\n -> mappend . Data.Monoid.Any .
- Data.Foldable.any (test f . (n,)))
+ (\p -> mappend . Data.Monoid.Any . test f . (p,))
(Data.Monoid.Any False) $
transaction_tags t
simplify f =
then Journal.cons t j
else j
+instance
+ ( Transaction t
+ , Stats.Transaction t
+ )
+ => Consable
+ (Simplified (Filter_Bool (Filter_Transaction t)))
+ Stats.Stats t where
+ mcons ft t !s =
+ if test ft t
+ then Stats.cons t s
+ else s
+
-- ** Type 'Filter_Balance'
data Balance b
import qualified Data.Foldable
import Data.Functor.Identity (Identity)
import qualified Data.List
+-- import qualified Data.List.NonEmpty as NonEmpty
+-- import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes)
import qualified Data.Time.Clock as Time
import qualified Text.Parsec.Expr as R
:: Stream s m Char
=> [ParsecT s u m (ParsecT s u m (Filter_Bool t))]
-> ParsecT s u m (Filter_Bool t)
-filter_bool_term terms = do
- join (R.choice_try
+filter_bool_term terms = (do
+ join $ R.choice_try
( (R.lookAhead (R.try (R.spaces >> R.char '('))
>> (return $ parens $
Data.Foldable.foldr Filter.And Filter.Any <$>
R.many (R.try (R.spaces >> expr)) ))
: terms
- ) <* R.spaces <?> "boolean-term")
+ ) <* R.spaces) <?> "boolean-term"
where
expr =
R.lookAhead (R.try R.anyToken)
-> a
-> ParsecT s u m a
jump prefixes next r =
- R.choice_try
- (map (\s -> R.string s >> return r) prefixes)
- <* R.lookAhead (R.try next)
-
--- ** Read 'Filter_Account_Section'
+ R.choice_try (map (\s -> R.string s >> return r) prefixes)
+ <* R.lookAhead (R.try next)
-- ** Read 'Filter_Account'
-- | Return the 'Filter_Posting_Type' and stripped 'Account' of the given 'Account'.
Filter_Ord o () <-
R.option (Filter_Ord Eq ()) $ R.try $
(\f -> f ()) <$> filter_ord
- (Filter_Account o <$>) <$> account
+ (Filter_Path o <$>) <$> account
where
- account :: Stream s m Char => ParsecT s u m (Filter_Posting_Type, [Filter_Account_Section])
+ account :: Stream s m Char => ParsecT s u m (Filter_Posting_Type, [Filter_Path_Section])
account = do
(pt, strings) <-
account_posting_type <$>
(R.char Account.Read.section_sep)
sections <- forM strings $ \s ->
case s of
- "" -> return Filter_Account_Section_Many
- "*" -> return Filter_Account_Section_Any
- '~':t -> Filter_Account_Section_Text . Filter_Text_Regex <$> Regex.of_StringM t
- t -> return $ Filter_Account_Section_Text $ Filter_Text_Exact $ Text.pack t
- return (pt, if null sections then [Filter_Account_Section_Many] else sections)
-
-filter_account_operator
- :: Stream s m Char
- => ParsecT s u m String
-filter_account_operator =
- filter_text_operator
+ "" -> return Filter_Path_Section_Many
+ "*" -> return Filter_Path_Section_Any
+ '~':t -> Filter_Path_Section_Text . Filter_Text_Regex <$> Regex.of_StringM t
+ t -> return $ Filter_Path_Section_Text $ Filter_Text_Exact $ Text.pack t
+ return (pt, if null sections then [Filter_Path_Section_Many] else sections)
-- ** Read 'Filter_Amount'
filter_amount
filter_text_operator
-- ** Read 'Filter_Tag'
-tag_name_sep :: Char
-tag_name_sep = ':'
-
-filter_tag_name
- :: Stream s m Char
- => ParsecT s u m Filter_Tag
-filter_tag_name = do
- make_filter_text <- filter_text
- R.choice_try
- [ R.char '*'
- <* R.lookAhead filter_tag_name_end
- >> return (Filter_Tag_Name Filter_Text_Any)
- , R.many1 (R.notFollowedBy (R.try filter_tag_name_end) >> R.anyChar)
- >>= (liftM Filter_Tag_Name . make_filter_text)
- ]
- where
- filter_tag_name_end =
- R.choice_try
- [ void $ filter_text_operator
- , void $ R.space_horizontal
- , R.eof
- ]
-filter_tag_value
- :: Stream s m Char
- => ParsecT s u m Filter_Tag
-filter_tag_value = do
- make_filter_text <- filter_text
- R.choice_try
- [ R.char '*'
- <* R.lookAhead filter_tag_value_end
- >> return (Filter_Tag_Value Filter_Text_Any)
- , R.many1 (R.notFollowedBy (R.try filter_tag_value_end) >> R.anyChar)
- >>= (liftM Filter_Tag_Value . make_filter_text)
- ]
- where
- filter_tag_value_end =
- R.choice_try
- [ void $ R.space_horizontal
- , R.eof
- ]
filter_tag
:: Stream s m Char
- => ParsecT s u m (Filter_Bool Filter_Tag)
+ => ParsecT s u m Filter_Tag
filter_tag = do
- n <- filter_tag_name
- R.choice_try
- [ R.lookAhead (R.try $ filter_tag_operator)
- >> And (Bool n) . Bool <$> filter_tag_value
- , return $ Bool n
- ]
+ R.notFollowedBy $ R.space_horizontal
+ Filter_Ord o () <- (\f -> f ()) <$> filter_ord
+ filter_tag_value <-
+ R.choice_try
+ [ R.char '^' >> return Filter_Tag_Value_First
+ , R.char '$' >> return Filter_Tag_Value_Last
+ , return Filter_Tag_Value_Any
+ ]
+ strings <-
+ R.many1_separated
+ (R.many (R.satisfy (\c -> c /= Account.Read.section_sep && not (Data.Char.isSpace c))))
+ (R.char Account.Read.section_sep)
+ sections <- forM strings $ \s ->
+ case s of
+ "" -> return Filter_Path_Section_Many
+ "*" -> return Filter_Path_Section_Any
+ '~':t -> Filter_Path_Section_Text . Filter_Text_Regex <$> Regex.of_StringM t
+ t -> return $ Filter_Path_Section_Text $ Filter_Text_Exact $ Text.pack t
+ case reverse sections of
+ [] -> R.parserZero
+ [p] -> return $ Bool $ Filter_Tag_Path $ Filter_Path o [p]
+ value:rev_path ->
+ return $ And
+ (Bool $ Filter_Tag_Path $ Filter_Path o $ reverse rev_path)
+ (Bool $ Filter_Tag_Value $ filter_tag_value $
+ case value of
+ Filter_Path_Section_Any -> Filter_Text_Any
+ Filter_Path_Section_Many -> Filter_Text_Any
+ Filter_Path_Section_Text ft -> ft
+ )
filter_tag_operator
:: Stream s m Char
=> ParsecT s u m String
-filter_tag_operator =
- filter_text_operator
+filter_tag_operator = do
+ void filter_ord_operator
+ R.choice_try
+ [ R.string "^"
+ , R.string "$"
+ , R.string ""
+ ]
-- ** Read 'Filter_Posting'
filter_posting ::
, Posting_Amount (Transaction_Posting t) ~ Amount
)
=> [ParsecT s Context (R.Error_State Error m)
- (ParsecT s Context (R.Error_State Error m) (Filter_Bool (Filter_Transaction t)))]
+ (ParsecT s Context (R.Error_State Error m)
+ (Filter_Bool (Filter_Transaction t)))]
filter_transaction_terms =
-- , jump [ "atag" ] comp_text parseFilterATag
-- , jump [ "code" ] comp_text parseFilterCode
- [ jump [ "d", "date" ] filter_date_operator
+ [ jump [ "date", "d" ] filter_date_operator
(Bool . Filter.Filter_Transaction_Date <$> filter_date)
- , jump [ "T", "tag" ] filter_tag_operator
- (Bool . Filter.Filter_Transaction_Tag <$> filter_tag)
- , jump [ "D", "debit" ] filter_amount_operator
+ , jump [ "tag", "T" ] filter_tag_operator
+ (Bool . Filter.Filter_Transaction_Tag <$> filter_tag)
+ , jump [ "debit", "D" ] filter_amount_operator
(( Bool
. Filter_Transaction_Posting
. Bool
. Filter_Posting_Positive
) <$> filter_amount)
- , jump [ "C", "credit" ] filter_amount_operator
+ , jump [ "credit", "C" ] filter_amount_operator
(( Bool
. Filter_Transaction_Posting
. Bool
. Filter_Posting_Negative
) <$> filter_amount)
- , jump [ "W", "wording" ] filter_description_operator
+ , jump [ "wording", "W" ] filter_description_operator
(Bool . Filter.Filter_Transaction_Description <$> filter_description)
-- , jump [ "date2", "edate" ] (R.char '=') parseFilterDate2
-- , jump [ "real" ] (R.char '=') parseFilterReal
-- import Hcompta.GL (GL(..))
import qualified Hcompta.GL as GL
import qualified Hcompta.Journal as Journal
+import qualified Hcompta.Stats as Stats
+import qualified Hcompta.Tag as Tag
type Code = Text
type Description = Text
, transaction_comments_after :: [Comment]
, transaction_dates :: (Date, [Date])
, transaction_description :: Description
- , transaction_postings :: Posting_by_Account
- , transaction_virtual_postings :: Posting_by_Account
- , transaction_balanced_virtual_postings :: Posting_by_Account
+ , transaction_postings :: Map Account [Posting]
+ , transaction_virtual_postings :: Map Account [Posting]
+ , transaction_balanced_virtual_postings :: Map Account [Posting]
, transaction_sourcepos :: SourcePos
, transaction_status :: Status
- , transaction_tags :: Tag_by_Name
+ , transaction_tags :: Map Tag.Path [Tag.Value]
} deriving (Data, Eq, Show, Typeable)
transaction :: Transaction
instance Journal.Transaction Transaction where
transaction_date = fst . transaction_dates
-instance GL.Transaction Transaction where
+instance Stats.Transaction Transaction where
+ type Transaction_Posting Transaction = Posting
+ type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
+ transaction_date = fst . transaction_dates
+ transaction_postings t =
+ Compose
+ [ Compose $ transaction_postings t
+ , Compose $ transaction_virtual_postings t
+ , Compose $ transaction_balanced_virtual_postings t
+ ]
+ transaction_postings_size t =
+ Data.Map.size (transaction_postings t) +
+ Data.Map.size (transaction_virtual_postings t) +
+ Data.Map.size (transaction_balanced_virtual_postings t)
+ transaction_tags =
+ transaction_tags
+
+instance GL.Transaction Transaction where
type Transaction_Posting Transaction = Posting
type Transaction_Postings Transaction = Compose [] (Compose (Map Account) [])
transaction_date = fst . transaction_dates
, posting_dates :: [Date]
, posting_sourcepos :: SourcePos
, posting_status :: Bool
- , posting_tags :: Tag_by_Name
+ , posting_tags :: Map Tag.Path [Tag.Value]
} deriving (Data, Eq, Show, Typeable)
posting :: Account -> Posting
, posting_tags = mempty
}
-instance
- Balance.Posting Posting where
- type Posting_Amount Posting = Amount.Sum Amount
+instance Balance.Posting Posting where
+ type Posting_Amount Posting = Amount.Sum Amount
posting_account = posting_account
posting_amounts = Data.Map.map Amount.sum . posting_amounts
posting_set_amounts amounts p =
-- by Filter.transaction_postings
-- and Filter.transaction_postings_virtual
-instance GL.Posting Posting where
+instance GL.Posting Posting where
type Posting_Amount Posting = Amount.Sum (Map Amount.Unit Amount)
posting_account = posting_account
posting_amount = Amount.sum . posting_amounts
+instance Stats.Posting Posting where
+ type Posting_Amount Posting = Amount
+ posting_account = posting_account
+ posting_amounts = posting_amounts
+
-- ** The 'Posting' mappings
type Posting_by_Account
(Amount.signs $ posting_amounts p)
(Data.Map.singleton acct [p])))))
mempty
-
--- * The 'Tag' type
-
-type Tag = (Tag_Name, Tag_Value)
-type Tag_Name = Text
-type Tag_Value = Text
-
-type Tag_by_Name = Map Tag_Name [Tag_Value]
-
--- | Return a 'Data.Map.Map' associating the 'Value's of the given 'Tag's with their respective 'Name'.
-tag_by_Name :: [Tag] -> Tag_by_Name
-tag_by_Name =
- Data.Map.fromListWith (flip (++)) .
- Data.List.map (\(n, v) -> (n, [v]))
import qualified Data.Char
import qualified Data.Either
import qualified Data.List
+import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Map.Strict as Data.Map
+import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.String (fromString)
import qualified Data.Text as Text
( Comment
, Journal(..)
, Posting(..)
- , Tag, Tag_Name, Tag_Value, Tag_by_Name
, Transaction(..)
)
import Hcompta.Lib.Consable (Consable(..))
import Hcompta.Lib.Regex (Regex)
import qualified Hcompta.Lib.Parsec as R
import qualified Hcompta.Lib.Path as Path
+import qualified Hcompta.Tag as Tag
+import Hcompta.Tag (Tag)
data Context f ts t
= Context
tag_sep :: Char
tag_sep = ','
--- | Read a 'Tag'.
+tag_path_section_char :: Stream s m Char => ParsecT s u m Char
+tag_path_section_char =
+ R.satisfy (\c -> c /= tag_value_sep && c /= tag_sep && not (Data.Char.isSpace c))
+
tag :: Stream s m Char => ParsecT s u m Tag
-tag = (do
- n <- tag_name
- _ <- R.char tag_value_sep
- v <- tag_value
- return (n, v)
- ) <?> "tag"
-
-tag_name :: Stream s m Char => ParsecT s u m Tag_Name
-tag_name = do
+tag = ((,) <$> tag_path <*> tag_value) <?> "tag"
+
+tag_path :: Stream s m Char => ParsecT s u m Tag.Path
+tag_path = do
+ NonEmpty.fromList <$> do
+ R.many1 $ R.try tag_path_section
+
+tag_path_section :: Stream s m Char => ParsecT s u m Tag.Section
+tag_path_section = do
fromString <$> do
- R.many1 $ R.satisfy (\c -> c /= tag_value_sep && not (Data.Char.isSpace c))
+ ((R.many1 $ tag_path_section_char) <* R.char tag_value_sep)
-tag_value :: Stream s m Char => ParsecT s u m Tag_Value
+tag_value :: Stream s m Char => ParsecT s u m Tag.Value
tag_value = do
fromString <$> do
R.manyTill R.anyChar $ do
R.lookAhead $ do
- R.try (R.char tag_sep >> R.many R.space_horizontal >> tag_name >> void (R.char tag_value_sep))
- <|> R.try R.new_line
+ R.try (R.char tag_sep >> R.many R.space_horizontal >> void tag_path_section)
+ <|> R.try (void (R.try R.new_line))
<|> R.eof
-tags :: Stream s m Char => ParsecT s u m Tag_by_Name
+tags :: Stream s m Char => ParsecT s u m (Map Tag.Path [Tag.Value])
tags = do
- Ledger.tag_by_Name <$> do
+ Data.Map.fromListWith (flip (++))
+ . map (\(p, v) -> (p, [v])) <$> do
R.many_separated tag $ do
_ <- R.char tag_sep
R.skipMany $ R.space_horizontal
- return ()
not_tag :: Stream s m Char => ParsecT s u m ()
not_tag = do
R.skipMany $ R.try $ do
- R.skipMany $ R.satisfy
- (\c -> c /= tag_value_sep
- && not (Data.Char.isSpace c))
+ R.skipMany $ tag_path_section_char
R.space_horizontal
-- * Read 'Posting'
comments_ <- comments
let tags_ = tags_of_comments comments_
dates_ <-
- case Data.Map.lookup "date" tags_ of
+ case Data.Map.lookup ("date":|[]) tags_ of
Nothing -> return []
Just dates -> do
- let date2s = Data.Map.lookup "date2" tags_ -- NOTE: support hledger's date2
+ let date2s = Data.Map.lookup ("date2":|[]) tags_ -- NOTE: support hledger's date2
do
forM (dates ++ fromMaybe [] date2s) $ \s ->
R.runParserT_with_Error_fail "tag date" id
amount_sep :: Char
amount_sep = '+'
-tags_of_comments :: [Comment] -> Tag_by_Name
+tags_of_comments :: [Comment] -> Map Tag.Path [Tag.Value]
tags_of_comments =
Data.Map.unionsWith (++)
. Data.List.map
( Comment
, Journal(..)
, Posting(..), Posting_by_Account
- , Tag
, Transaction(..)
)
import qualified Hcompta.Date.Write as Date.Write
-- import Hcompta.Lib.Consable (Consable(..))
import qualified Hcompta.Lib.Parsec as R
import Hcompta.Posting (Posting_Type(..))
+import Hcompta.Tag (Tag)
-- * Write 'Account'
Right doc -> doc
tags :: Stream s m Char => ParsecT s u m Doc
tags = do
- x <- tag_
- xs <- W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_)))
- return $ x <> xs
+ (<>)
+ <$> tag_
+ <*> (W.hcat <$> R.many (R.try (tag_sep >>= (\s -> (s <>) <$> tag_))))
where
tag_sep :: Stream s m Char => ParsecT s u m Doc
tag_sep = do
<> do W.text $ TL.pack sh
tag_ :: Stream s m Char => ParsecT s u m Doc
tag_ = do
- n <- Read.tag_name
- s <- R.char Read.tag_value_sep
- v <- Read.tag_value
+ (p, v) <- Read.tag
return $
- (W.yellow $ W.strict_text n)
- <> (W.bold $ W.dullblack $ W.char s)
- <> (W.red $ W.strict_text v)
+ foldMap (\s -> W.dullyellow (W.strict_text s) <> do
+ W.bold $ W.dullblack $ W.char Read.tag_value_sep) p <>
+ (W.red $ W.strict_text v)
comments :: Doc -> [Comment] -> Doc
comments prefix =
-- * Write 'Tag'
tag :: Tag -> Doc
-tag (n, v) =
- (W.dullyellow $ W.strict_text n)
- <> W.char Read.tag_value_sep
- <> (W.dullred $ W.strict_text v)
+tag (p, v) =
+ foldMap (\s -> W.dullyellow (W.strict_text s) <> W.char Read.tag_value_sep) p <>
+ (W.dullred $ W.strict_text v)
-- * Write 'Posting'
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
module Hcompta.Lib.Interval where
+import Data.Data (Data(..))
import qualified Data.Functor
+import Data.Typeable (Typeable)
-- * Type 'Limit'
= Limit
{ adherence :: Adherence
, limit :: x }
- deriving (Eq, Show)
+ deriving (Eq, Data, Show, Typeable)
+
instance Functor Limit where
fmap f (Limit a x) = Limit a (f x)
data Adherence = Out | In
- deriving (Eq, Show)
+ deriving (Eq, Data, Show, Typeable)
-- | Return given 'Limit' with its 'adherence' set to the opposite one.
flip_limit :: Limit x -> Limit x
-- ** Comparing 'Limit's
-- | Compare two 'low' 'Limit's.
-newtype LL x = LL x
+newtype LL x = LL { unLL :: x }
deriving (Eq)
instance Ord x => Ord (LL (Limit x)) where
compare (LL x) (LL y) =
o -> o
-- | Compare two 'high' 'Limit's.
-newtype HH x = HH x
+newtype HH x = HH { unHH :: x }
deriving (Eq)
instance Ord x => Ord (HH (Limit x)) where
compare (HH x) (HH y) =
-- * Type 'Interval'
newtype Ord x => Interval x = Interval (Limit x, Limit x)
- deriving (Eq, Show)
+ deriving (Eq, Show, Data, Typeable)
low :: Ord x => Interval x -> Limit x
low (Interval t) = fst t
(Equal, _) -> -- PATTERN: +
Just i
+span :: Ord x => Interval x -> Interval x -> Interval x
+span i j =
+ Interval
+ ( unLL (min (LL $ low i) (LL $ low j))
+ , unHH (max (HH $ high i) (HH $ high j))
+ )
+
-- * Type 'Unlimitable'
data Unlimitable x
show (Pretty i) =
concat
[ case adherence (low i) of
- In -> "["
+ In -> "["
Out -> "]"
, show (limit $ low i)
, ".."
, show (limit $ high i)
, case adherence (high i) of
- In -> "]"
+ In -> "]"
Out -> "["
]
instance (Ord x, Show x) => Show (Pretty (Unlimitable x)) where
--
-- @
-- \"A prettier printer\"
--- Draft paper, April 1997, revised March 1998.
--- <http://cm.bell-labs.com/cm/cs/who/wadler/papers/prettier/prettier.ps>
+-- <http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf>
-- @
--
-- PPrint is an implementation of the pretty printing combinators
--- /dev/null
+module Hcompta.Lib.NonEmpty where
+
+import qualified Data.List
+-- import qualified Data.List.NonEmpty as NonEmpty
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Monoid ((<>))
+
+
+-- | Return the given 'NonEmpty' without its last section if any.
+ascending :: NonEmpty x -> Maybe (NonEmpty x)
+ascending (_:|[]) = Nothing
+ascending (x:|xs) = Just (x:|Data.List.init xs)
+{-# INLINE ascending #-}
+
+-- | Return all the prefixes of the given 'NonEmpty' (including itself).
+prefixes :: NonEmpty x -> [NonEmpty x]
+prefixes (y:|ys) = go y [] ys []
+ where
+ go :: x -> [x] -> [x] -> [NonEmpty x] -> [NonEmpty x]
+ go x0 s [] = (:) (x0:|s)
+ go x0 s (x:xs) = go x0 (s <> [x]) xs . (:) (x0:|s)
--- /dev/null
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-deprecations #-} -- FIXME: to be removed when dropping GHC-7.6 support
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Hcompta.Stats where
+
+-- import Control.Applicative (Const(..))
+import Data.Data
+import qualified Data.Foldable
+import qualified Data.Map.Strict as Data.Map
+import Data.Map.Strict (Map)
+import Data.Text (Text)
+import Data.Typeable ()
+
+import qualified Hcompta.Account as Account
+import Hcompta.Account (Account)
+import qualified Hcompta.Amount as Amount
+import qualified Hcompta.Amount.Unit as Amount.Unit
+import Hcompta.Date (Date)
+import Hcompta.Lib.Consable (Consable(..))
+import qualified Hcompta.Lib.Interval as Interval
+import Hcompta.Lib.Interval (Interval)
+import qualified Hcompta.Tag as Tag
+
+-- * Requirements' interface
+
+-- ** Class 'Unit'
+
+class Unit a where
+ unit_text :: a -> Text
+
+instance Unit Amount.Unit where
+ unit_text = Amount.Unit.text
+
+-- ** Class 'Amount'
+
+class
+ ( Data (Amount_Unit a)
+ , Ord (Amount_Unit a)
+ , Show (Amount_Unit a)
+ , Unit (Amount_Unit a)
+ )
+ => Amount a where
+ type Amount_Unit a
+ amount_unit :: a -> Amount_Unit a
+
+instance Amount Amount.Amount where
+ type Amount_Unit Amount.Amount = Amount.Unit
+ amount_unit = Amount.unit
+
+-- ** Class 'Posting'
+
+class Amount (Posting_Amount p)
+ => Posting p where
+ type Posting_Amount p
+ posting_account :: p -> Account
+ posting_amounts :: p -> Map (Amount_Unit (Posting_Amount p)) (Posting_Amount p)
+
+-- ** Class 'Transaction'
+
+class
+ ( Posting (Transaction_Posting t)
+ , Foldable (Transaction_Postings t)
+ )
+ => Transaction t where
+ type Transaction_Posting t
+ type Transaction_Postings t :: * -> *
+ transaction_date :: t -> Date
+ transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
+ transaction_postings_size :: t -> Int
+ transaction_postings_size = foldr (const $ (+) 1) 0 . transaction_postings
+ transaction_tags :: t -> Map Tag.Path [Tag.Value]
+
+-- * Type 'Stats'
+
+data Transaction t => Stats t
+ = Stats
+ { stats_accounts :: !(Map Account ())
+ , stats_tags :: !(Map Tag.Path (Map Text Integer))
+ , stats_transactions :: !Integer
+ , stats_transactions_span :: !(Maybe (Interval Date))
+ , stats_units :: !(Map (Amount_Unit (Posting_Amount (Transaction_Posting t))) ())
+ }
+deriving instance ( Transaction transaction
+ , Data transaction
+ ) => Data (Stats transaction)
+deriving instance ( Transaction transaction
+ , Eq transaction
+ ) => Eq (Stats transaction)
+deriving instance ( Transaction transaction
+ , Show transaction
+ ) => Show (Stats transaction)
+deriving instance Typeable1 Stats
+
+empty :: Transaction t => Stats t
+empty =
+ Stats
+ { stats_accounts = mempty
+ , stats_tags = mempty
+ , stats_transactions = 0
+ , stats_transactions_span = Nothing
+ , stats_units = mempty
+ }
+
+stats_accounts_depths :: Transaction t => Stats t -> Interval Integer
+stats_accounts_depths s =
+ case Data.Map.keys $ stats_accounts s of
+ [] -> Interval.point 0
+ a:as ->
+ Data.Foldable.foldr
+ (Interval.span . Interval.point . Account.depth)
+ (Interval.point $ Account.depth a) as
+
+-- | Return the given 'Stats'
+-- updated by the given 'Transaction'.
+--
+-- NOTE: to reduce memory consumption when 'cons'ing iteratively,
+-- the given 'Stats' is matched strictly.
+cons :: Transaction t => t -> Stats t -> Stats t
+cons t !s =
+ Stats
+ { stats_accounts =
+ Data.Foldable.foldl'
+ (flip $ (\p -> Data.Map.insert (posting_account p) ()))
+ (stats_accounts s)
+ (transaction_postings t)
+ , stats_tags =
+ Data.Map.mergeWithKey
+ (\_k x1 x2 -> Just $
+ Data.Map.unionWith (+) x1 $
+ Data.Map.fromListWith (+) $ (, 1) <$> x2)
+ id ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
+ (stats_tags s) -- Map Text (Map Text Integer)
+ (transaction_tags t) -- Map Text [Text]
+ , stats_transactions = 1 + (stats_transactions s)
+ , stats_transactions_span =
+ let i = Interval.point $ transaction_date t in
+ maybe (Just i) (Just . Interval.span i)
+ (stats_transactions_span s)
+ , stats_units =
+ Data.Foldable.foldl'
+ (\su ->
+ Data.Foldable.foldl'
+ (flip $ (\a -> Data.Map.insert (amount_unit a) ()))
+ su . posting_amounts)
+ (stats_units s)
+ (transaction_postings t)
+ }
+
+union :: Transaction t => Stats t -> Stats t -> Stats t
+union s0 s1 =
+ Stats
+ { stats_accounts =
+ Data.Map.unionWith
+ (const::()->()->())
+ (stats_accounts s0)
+ (stats_accounts s1)
+ , stats_tags =
+ Data.Map.unionWith
+ (Data.Map.unionWith (+))
+ (stats_tags s0)
+ (stats_tags s1)
+ , stats_transactions =
+ (+)
+ (stats_transactions s0)
+ (stats_transactions s1)
+ , stats_transactions_span = do
+ case
+ ( stats_transactions_span s0
+ , stats_transactions_span s1
+ ) of
+ (Nothing, Nothing) -> Nothing
+ (Just i0, Nothing) -> Just i0
+ (Nothing, Just i1) -> Just i1
+ (Just i0, Just i1) -> Just $ Interval.span i0 i1
+ , stats_units =
+ Data.Map.unionWith
+ (const::()->()->())
+ (stats_units s0)
+ (stats_units s1)
+ }
+
+instance Transaction t => Monoid (Stats t) where
+ mempty = empty
+ mappend = union
+
+instance Transaction t => Consable () (Stats) t where
+ mcons () t !s = cons t s
--- /dev/null
+{-# LANGUAGE TupleSections #-}
+module Hcompta.Tag where
+
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.Text as Text
+import Data.Text (Text)
+
+-- * The 'Tag' type
+
+-- | An 'Tag' is a non-empty list of 'Section'.
+type Tag = (Path, Value)
+type Section = Text
+type Path = NonEmpty Section
+type Value = Text
+
+-- | Return the 'Tag' formed by the given 'Path' and 'Value'.
+tag :: Path -> Value -> Tag
+tag = (,)
+
+-- | Return the 'Value' formed by the given 'Section' and 'Section's.
+path :: Section -> [Section] -> Path
+path = (:|)
+
+-- | Return the 'Value' of a 'Tag', if any.
+value :: Tag -> Maybe Value
+value (_, v) | Text.null v = Nothing
+value (_, v) = Just v
+
+-- | Return the number of 'Section's in the given 'Tag'.
+depth :: Path -> Int
+depth = NonEmpty.length
+
+-- | Return an 'Tag' from the given list.
+from_List :: [Section] -> Path
+from_List = NonEmpty.fromList
]
, "Filter" ~: TestList
[ "test" ~: TestList
- [ "Filter_Account" ~: TestList
+ [ "Filter_Path" ~: TestList
[ "A A" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "A")
])
(("A":|[]::Account))
, "* A" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Any
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Any
])
(("A":|[]::Account))
, ": A" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Many
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Many
])
(("A":|[]::Account))
, ":A A" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "A")
])
(("A":|[]::Account))
, "A: A" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Many
+ , Filter.Filter_Path_Section_Many
])
(("A":|[]::Account))
, "A: A:B" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Many
+ , Filter.Filter_Path_Section_Many
])
(("A":|"B":[]::Account))
, "A:B A:B" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Text
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "B")
])
(("A":|"B":[]::Account))
, "A::B A:B" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text
+ , Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "B")
])
(("A":|"B":[]::Account))
, ":B: A:B:C" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "B")
- , Filter.Filter_Account_Section_Many
+ , Filter.Filter_Path_Section_Many
])
(("A":|"B":"C":[]::Account))
, ":C A:B:C" ~?
Filter.test
- (Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "C")
])
(("A":|"B":"C":[]::Account))
, "<A:B:C::D A:B" ~?
Filter.test
- (Filter.Filter_Account Filter.Lt
- [ Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Lt
+ [ Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Text
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "B")
- , Filter.Filter_Account_Section_Text
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "C")
- , Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text
+ , Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "D")
])
(("A":|"B":[]::Account))
, ">A:B:C::D A:B:C:CC:CCC:D:E" ~?
Filter.test
- (Filter.Filter_Account Filter.Gt
- [ Filter.Filter_Account_Section_Text
+ (Filter.Filter_Path Filter.Gt
+ [ Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Text
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "B")
- , Filter.Filter_Account_Section_Text
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "C")
- , Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text
+ , Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text
(Filter.Filter_Text_Exact "D")
])
(("A":|"B":"C":"CC":"CCC":"D":"E":[]::Account))
() "" ("*"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Any ]
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Any ]
]
, "A" ~:
(Data.Either.rights $
() "" ("A"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A") ]
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A") ]
]
, "AA" ~:
(Data.Either.rights $
() "" ("AA"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "AA") ]
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "AA") ]
]
, "::A" ~:
(Data.Either.rights $
() "" ("::A"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
]
]
, ":A" ~:
() "" (":A"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
]
]
, "A:" ~:
() "" ("A:"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Many
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Many
]
]
, "A::" ~:
() "" ("A::"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Many
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Many
]
]
, "A:B" ~:
() "" ("A:B"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "B")
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "B")
]
]
, "A::B" ~:
() "" ("A::B"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "B")
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "B")
]
]
, "A:::B" ~:
() "" ("A:::B"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Many
- , Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "B")
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Many
+ , Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "B")
]
]
, "A: " ~:
() "" ("A: "::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Eq
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Many
+ [ Filter.Filter_Path Filter.Eq
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Many
]
]
, "<=A:B" ~:
() "" ("<=A:B"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Le
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "B")
+ [ Filter.Filter_Path Filter.Le
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "B")
]
]
, ">=A:B" ~:
() "" (">=A:B"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Ge
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "B")
+ [ Filter.Filter_Path Filter.Ge
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "B")
]
]
, "<A:B" ~:
() "" ("<A:B"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Lt
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "B")
+ [ Filter.Filter_Path Filter.Lt
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "B")
]
]
, ">A:B" ~:
() "" (">A:B"::Text)])
~?=
map (Filter.Filter_Posting_Type_Any,)
- [ Filter.Filter_Account Filter.Gt
- [ Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "A")
- , Filter.Filter_Account_Section_Text (Filter.Filter_Text_Exact "B")
+ [ Filter.Filter_Path Filter.Gt
+ [ Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "A")
+ , Filter.Filter_Path_Section_Text (Filter.Filter_Text_Exact "B")
]
]
]
(Format.Ledger.Read.tag <* P.eof)
() "" ("Name:"::Text)])
~?=
- [("Name", "")]
+ [("Name":|[], "")]
, "Name:Value" ~:
(Data.Either.rights $
[P.runParser
(Format.Ledger.Read.tag <* P.eof)
() "" ("Name:Value"::Text)])
~?=
- [("Name", "Value")]
+ [("Name":|[], "Value")]
, "Name:Value\\n" ~:
(Data.Either.rights $
[P.runParser
(Format.Ledger.Read.tag <* P.string "\n" <* P.eof)
() "" ("Name:Value\n"::Text)])
~?=
- [("Name", "Value")]
+ [("Name":|[], "Value")]
, "Name:Val ue" ~:
(Data.Either.rights $
[P.runParser
(Format.Ledger.Read.tag <* P.eof)
() "" ("Name:Val ue"::Text)])
~?=
- [("Name", "Val ue")]
+ [("Name":|[], "Val ue")]
, "Name:," ~:
(Data.Either.rights $
[P.runParser
(Format.Ledger.Read.tag <* P.eof)
() "" ("Name:,"::Text)])
~?=
- [("Name", ",")]
+ [("Name":|[], ",")]
, "Name:Val,ue" ~:
(Data.Either.rights $
[P.runParser
(Format.Ledger.Read.tag <* P.eof)
() "" ("Name:Val,ue"::Text)])
~?=
- [("Name", "Val,ue")]
+ [("Name":|[], "Val,ue")]
, "Name:Val,ue:" ~:
(Data.Either.rights $
[P.runParser
(Format.Ledger.Read.tag <* P.string ",ue:" <* P.eof)
() "" ("Name:Val,ue:"::Text)])
~?=
- [("Name", "Val")]
+ [("Name":|[], "Val")]
+ , "Name:Val,ue :" ~:
+ (Data.Either.rights $
+ [P.runParser
+ (Format.Ledger.Read.tag <* P.eof)
+ () "" ("Name:Val,ue :"::Text)])
+ ~?=
+ [("Name":|[], "Val,ue :")]
]
, "tags" ~: TestList
[ "Name:" ~:
() "" ("Name:"::Text)])
~?=
[Data.Map.fromList
- [ ("Name", [""])
+ [ ("Name":|[], [""])
]
]
, "Name:," ~:
() "" ("Name:,"::Text)])
~?=
[Data.Map.fromList
- [ ("Name", [","])
+ [ ("Name":|[], [","])
]
]
, "Name:,Name:" ~:
() "" ("Name:,Name:"::Text)])
~?=
[Data.Map.fromList
- [ ("Name", ["", ""])
+ [ ("Name":|[], ["", ""])
]
]
, "Name:,Name2:" ~:
() "" ("Name:,Name2:"::Text)])
~?=
[Data.Map.fromList
- [ ("Name", [""])
- , ("Name2", [""])
+ [ ("Name":|[], [""])
+ , ("Name2":|[], [""])
]
]
, "Name: , Name2:" ~:
() "" ("Name: , Name2:"::Text)])
~?=
[Data.Map.fromList
- [ ("Name", [" "])
- , ("Name2", [""])
+ [ ("Name":|[], [" "])
+ , ("Name2":|[], [""])
]
]
, "Name:,Name2:,Name3:" ~:
() "" ("Name:,Name2:,Name3:"::Text)])
~?=
[Data.Map.fromList
- [ ("Name", [""])
- , ("Name2", [""])
- , ("Name3", [""])
+ [ ("Name":|[], [""])
+ , ("Name2":|[], [""])
+ , ("Name3":|[], [""])
]
]
, "Name:Val ue,Name2:V a l u e,Name3:V al ue" ~:
() "" ("Name:Val ue,Name2:V a l u e,Name3:V al ue"::Text)])
~?=
[Data.Map.fromList
- [ ("Name", ["Val ue"])
- , ("Name2", ["V a l u e"])
- , ("Name3", ["V al ue"])
+ [ ("Name":|[], ["Val ue"])
+ , ("Name2":|[], ["V a l u e"])
+ , ("Name3":|[], ["V al ue"])
]
]
]
{ Format.Ledger.posting_comments = [" N:V"]
, Format.Ledger.posting_sourcepos = P.newPos "" 1 1
, Format.Ledger.posting_tags = Data.Map.fromList
- [ ("N", ["V"])
+ [ ("N":|[], ["V"])
]
}
]
{ Format.Ledger.posting_comments = [" some comment N:V"]
, Format.Ledger.posting_sourcepos = P.newPos "" 1 1
, Format.Ledger.posting_tags = Data.Map.fromList
- [ ("N", ["V"])
+ [ ("N":|[], ["V"])
]
}
]
{ Format.Ledger.posting_comments = [" some comment N:V v, N2:V2 v2"]
, Format.Ledger.posting_sourcepos = P.newPos "" 1 1
, Format.Ledger.posting_tags = Data.Map.fromList
- [ ("N", ["V v"])
- , ("N2", ["V2 v2"])
+ [ ("N":|[], ["V v"])
+ , ("N2":|[], ["V2 v2"])
]
}
]
{ Format.Ledger.posting_comments = [" N:V", " N:V2"]
, Format.Ledger.posting_sourcepos = P.newPos "" 1 1
, Format.Ledger.posting_tags = Data.Map.fromList
- [ ("N", ["V", "V2"])
+ [ ("N":|[], ["V", "V2"])
]
}
]
{ Format.Ledger.posting_comments = [" N:V", " N2:V"]
, Format.Ledger.posting_sourcepos = P.newPos "" 1 1
, Format.Ledger.posting_tags = Data.Map.fromList
- [ ("N", ["V"])
- , ("N2", ["V"])
+ [ ("N":|[], ["V"])
+ , ("N2":|[], ["V"])
]
}
]
]
, Format.Ledger.posting_sourcepos = P.newPos "" 1 1
, Format.Ledger.posting_tags = Data.Map.fromList
- [ ("date", ["2001/01/01"])
+ [ ("date":|[], ["2001/01/01"])
]
}
]
}
]
, Format.Ledger.transaction_tags = Data.Map.fromList
- [ ("Tag", [""])
+ [ ("Tag":|[], [""])
]
, Format.Ledger.transaction_sourcepos = P.newPos "" 1 1
}
Hcompta.Amount
Hcompta.Amount.Quantity
Hcompta.Amount.Read
- Hcompta.Amount.Write
Hcompta.Amount.Style
Hcompta.Amount.Unit
+ Hcompta.Amount.Write
Hcompta.Balance
Hcompta.Date
Hcompta.Date.Interval
Hcompta.Format.Ledger.Write
Hcompta.GL
Hcompta.Journal
- Hcompta.Posting
Hcompta.Lib.Consable
Hcompta.Lib.Foldable
Hcompta.Lib.Interval
Hcompta.Lib.Interval.Sieve
Hcompta.Lib.Leijen
Hcompta.Lib.Map.Strict
+ Hcompta.Lib.NonEmpty
Hcompta.Lib.Parsec
Hcompta.Lib.Path
Hcompta.Lib.Regex
Hcompta.Lib.Strict
Hcompta.Lib.TreeMap
+ Hcompta.Posting
+ Hcompta.Stats
+ Hcompta.Tag
build-depends:
base >= 4.7 && < 5
, ansi-terminal >= 0.4 && < 0.7
sourcephile / git / comptalang.git / commitdiff