slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Replace our stringly Regex with a safer compiled Regexp type

Browse Source 
This PR #1330, addressing #1312 (parseQuery is partial) and #1245
(internal server error).

User-visible changes:

- hledger-web now handles malformed regular expressions
  (eg, a query consisting of the single character `?`) gracefully,
  showing a tidy error message instead "internal server error".

API/internal changes:

- The Regex type alias has been replaced by the Regexp ADT, which
  contains both the compiled regular expression (so is guaranteed to
  be usable at runtime) and the original string (so can be serialised,
  printed, compared, etc.) A Regexp also knows whether is it case
  sensitive or case insensitive. The Hledger.Utils.Regex api has changed.

- Typeable and Data instances are no longer derived for hledger's
  data types; they were redundant/no longer needed

- NFData instances are no longer derived for hledger's data types.
  This speeds up a full build by roughly 7%. But it means we can't
  deep-evaluate hledger values, or time hledger code with Criterion.
  https://github.com/simonmichael/hledger/pull/1330#issuecomment-684075129
  has some ideas on this.

- Query no longer has a custom Show instance

- Some internal use of regexps was replaced by text replacement or
  parsers.

- Hledger.Utils.String: quoteIfNeeded now actually escapes quotes in
  strings; dropped escapeQuotes

- Hledger.Utils.Tree: dropped some old utilities

- dropped some obsolete code for the old --display option

Merge branch 'regexp' into master
This commit is contained in:
Simon Michael 2020-09-01 10:33:33 -07:00
commit 58f989715a
36 changed files with 456 additions and 773 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
hledger-lib/Hledger/Data/Account.hs
View File

@ -14,7 +14,7 @@ import Data.List.Extra (groupSort, groupOn)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Ord (Down(..)) import Data.Ord (Down(..))
import qualified Data.Map as M import qualified Data.Map as M
import Data.Text (pack,unpack) import qualified Data.Text as T
import Safe (headMay, lookupJustDef) import Safe (headMay, lookupJustDef)
import Text.Printf import Text.Printf
@ -28,11 +28,12 @@ import Hledger.Utils
-- deriving instance Show Account -- deriving instance Show Account
instance Show Account where instance Show Account where
show Account{..} = printf "Account %s (boring:%s, postings:%d, ebalance:%s, ibalance:%s)" show Account{..} = printf "Account %s (boring:%s, postings:%d, ebalance:%s, ibalance:%s)"
(pack $ regexReplace ":" "_" $ unpack aname) -- hide : so pretty-show doesn't break line (T.map colonToUnderscore aname) -- hide : so pretty-show doesn't break line
(if aboring then "y" else "n" :: String) (if aboring then "y" else "n" :: String)
anumpostings anumpostings
(showMixedAmount aebalance) (showMixedAmount aebalance)
(showMixedAmount aibalance) (showMixedAmount aibalance)
where colonToUnderscore x = if x == ':' then '_' else x
instance Eq Account where instance Eq Account where
(==) a b = aname a == aname b -- quick equality test for speed (==) a b = aname a == aname b -- quick equality test for speed

28
hledger-lib/Hledger/Data/AccountName.hs
View File

@ -18,7 +18,6 @@ module Hledger.Data.AccountName (
,accountNameToAccountOnlyRegex ,accountNameToAccountOnlyRegex
,accountNameToAccountRegex ,accountNameToAccountRegex
,accountNameTreeFrom ,accountNameTreeFrom
,accountRegexToAccountName
,accountSummarisedName ,accountSummarisedName
,acctsep ,acctsep
,acctsepchar ,acctsepchar
@ -40,15 +39,14 @@ module Hledger.Data.AccountName (
) )
where where
import Data.List
import Data.List.Extra (nubSort) import Data.List.Extra (nubSort)
import qualified Data.List.NonEmpty as NE
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
import Data.Monoid import Data.Semigroup ((<>))
#endif #endif
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Tree import Data.Tree (Tree(..))
import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
import Hledger.Utils import Hledger.Utils
@ -117,7 +115,7 @@ expandAccountNames as = nubSort $ concatMap expandAccountName as
-- | "a:b:c" -> ["a","a:b","a:b:c"] -- | "a:b:c" -> ["a","a:b","a:b:c"]
expandAccountName :: AccountName -> [AccountName] expandAccountName :: AccountName -> [AccountName]
expandAccountName = map accountNameFromComponents . tail . inits . accountNameComponents expandAccountName = map accountNameFromComponents . NE.tail . NE.inits . accountNameComponents
-- | ["a:b:c","d:e"] -> ["a","d"] -- | ["a:b:c","d:e"] -> ["a","d"]
topAccountNames :: [AccountName] -> [AccountName] topAccountNames :: [AccountName] -> [AccountName]
@ -210,23 +208,19 @@ clipOrEllipsifyAccountName n = clipAccountName n
-- | Escape an AccountName for use within a regular expression. -- | Escape an AccountName for use within a regular expression.
-- >>> putStr $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#" -- >>> putStr $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#"
-- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@# -- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@#
escapeName :: AccountName -> Regexp escapeName :: AccountName -> String
escapeName = regexReplaceBy "[[?+|()*\\\\^$]" ("\\" <>) escapeName = T.unpack . T.concatMap escapeChar
. T.unpack where
escapeChar c = if c `elem` escapedChars then T.snoc "\\" c else T.singleton c
escapedChars = ['[', '?', '+', '|', '(', ')', '*', '$', '^', '\\']
-- | Convert an account name to a regular expression matching it and its subaccounts. -- | Convert an account name to a regular expression matching it and its subaccounts.
accountNameToAccountRegex :: AccountName -> Regexp accountNameToAccountRegex :: AccountName -> Regexp
accountNameToAccountRegex "" = "" accountNameToAccountRegex a = toRegex' $ '^' : escapeName a ++ "(:|$)" -- PARTIAL: Is this safe after escapeName?
accountNameToAccountRegex a = printf "^%s(:|$)" (escapeName a)
-- | Convert an account name to a regular expression matching it but not its subaccounts. -- | Convert an account name to a regular expression matching it but not its subaccounts.
accountNameToAccountOnlyRegex :: AccountName -> Regexp accountNameToAccountOnlyRegex :: AccountName -> Regexp
accountNameToAccountOnlyRegex "" = "" accountNameToAccountOnlyRegex a = toRegex' $ '^' : escapeName a ++ "$" -- PARTIAL: Is this safe after escapeName?
accountNameToAccountOnlyRegex a = printf "^%s$" $ escapeName a -- XXX pack
-- | Convert an exact account-matching regular expression to a plain account name.
accountRegexToAccountName :: Regexp -> AccountName
accountRegexToAccountName = T.pack . regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1" -- XXX pack
-- -- | Does this string look like an exact account-matching regular expression ? -- -- | Does this string look like an exact account-matching regular expression ?
--isAccountRegex :: String -> Bool --isAccountRegex :: String -> Bool

51
hledger-lib/Hledger/Data/Journal.hs
View File

@ -74,7 +74,6 @@ module Hledger.Data.Journal (
journalCashAccountQuery, journalCashAccountQuery,
-- * Misc -- * Misc
canonicalStyleFrom, canonicalStyleFrom,
matchpats,
nulljournal, nulljournal,
journalCheckBalanceAssertions, journalCheckBalanceAssertions,
journalNumberAndTieTransactions, journalNumberAndTieTransactions,
@ -301,7 +300,7 @@ journalAccountNameTree = accountNameTreeFrom . journalAccountNames
-- or otherwise for accounts with names matched by the case-insensitive -- or otherwise for accounts with names matched by the case-insensitive
-- regular expression @^assets?(:|$)@. -- regular expression @^assets?(:|$)@.
journalAssetAccountQuery :: Journal -> Query journalAssetAccountQuery :: Journal -> Query
journalAssetAccountQuery j = journalAccountTypeQuery [Asset,Cash] "^assets?(:|$)" j journalAssetAccountQuery = journalAccountTypeQuery [Asset,Cash] (toRegex' "^assets?(:|$)")
-- | A query for "Cash" (liquid asset) accounts in this journal, ie accounts -- | A query for "Cash" (liquid asset) accounts in this journal, ie accounts
-- declared as Cash by account directives, or otherwise with names matched by the -- declared as Cash by account directives, or otherwise with names matched by the
@ -310,43 +309,41 @@ journalAssetAccountQuery j = journalAccountTypeQuery [Asset,Cash] "^assets?(:|$)
journalCashAccountQuery :: Journal -> Query journalCashAccountQuery :: Journal -> Query
journalCashAccountQuery j = journalCashAccountQuery j =
case M.lookup Cash (jdeclaredaccounttypes j) of case M.lookup Cash (jdeclaredaccounttypes j) of
Nothing -> And [ journalAssetAccountQuery j, Not . Acct $ toRegex' "(investment|receivable|:A/R|:fixed)" ]
Just _ -> journalAccountTypeQuery [Cash] notused j Just _ -> journalAccountTypeQuery [Cash] notused j
where notused = error' "journalCashAccountQuery: this should not have happened!" -- PARTIAL: where notused = error' "journalCashAccountQuery: this should not have happened!" -- PARTIAL:
Nothing -> And [journalAssetAccountQuery j
,Not $ Acct "(investment|receivable|:A/R|:fixed)"
]
-- | A query for accounts in this journal which have been -- | A query for accounts in this journal which have been
-- declared as Liability by account directives, or otherwise for -- declared as Liability by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression -- accounts with names matched by the case-insensitive regular expression
-- @^(debts?|liabilit(y|ies))(:|$)@. -- @^(debts?|liabilit(y|ies))(:|$)@.
journalLiabilityAccountQuery :: Journal -> Query journalLiabilityAccountQuery :: Journal -> Query
journalLiabilityAccountQuery = journalAccountTypeQuery [Liability] "^(debts?|liabilit(y|ies))(:|$)" journalLiabilityAccountQuery = journalAccountTypeQuery [Liability] (toRegex' "^(debts?|liabilit(y|ies))(:|$)")
-- | A query for accounts in this journal which have been -- | A query for accounts in this journal which have been
-- declared as Equity by account directives, or otherwise for -- declared as Equity by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression -- accounts with names matched by the case-insensitive regular expression
-- @^equity(:|$)@. -- @^equity(:|$)@.
journalEquityAccountQuery :: Journal -> Query journalEquityAccountQuery :: Journal -> Query
journalEquityAccountQuery = journalAccountTypeQuery [Equity] "^equity(:|$)" journalEquityAccountQuery = journalAccountTypeQuery [Equity] (toRegex' "^equity(:|$)")
-- | A query for accounts in this journal which have been -- | A query for accounts in this journal which have been
-- declared as Revenue by account directives, or otherwise for -- declared as Revenue by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression -- accounts with names matched by the case-insensitive regular expression
-- @^(income|revenue)s?(:|$)@. -- @^(income|revenue)s?(:|$)@.
journalRevenueAccountQuery :: Journal -> Query journalRevenueAccountQuery :: Journal -> Query
journalRevenueAccountQuery = journalAccountTypeQuery [Revenue] "^(income|revenue)s?(:|$)" journalRevenueAccountQuery = journalAccountTypeQuery [Revenue] (toRegex' "^(income|revenue)s?(:|$)")
-- | A query for accounts in this journal which have been -- | A query for accounts in this journal which have been
-- declared as Expense by account directives, or otherwise for -- declared as Expense by account directives, or otherwise for
-- accounts with names matched by the case-insensitive regular expression -- accounts with names matched by the case-insensitive regular expression
-- @^expenses?(:|$)@. -- @^expenses?(:|$)@.
journalExpenseAccountQuery :: Journal -> Query journalExpenseAccountQuery :: Journal -> Query
journalExpenseAccountQuery = journalAccountTypeQuery [Expense] "^expenses?(:|$)" journalExpenseAccountQuery = journalAccountTypeQuery [Expense] (toRegex' "^expenses?(:|$)")
-- | A query for Asset, Liability & Equity accounts in this journal. -- | A query for Asset, Liability & Equity accounts in this journal.
-- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Balance_Sheet_Accounts>. -- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Balance_Sheet_Accounts>.
journalBalanceSheetAccountQuery :: Journal -> Query journalBalanceSheetAccountQuery :: Journal -> Query
journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j
,journalLiabilityAccountQuery j ,journalLiabilityAccountQuery j
,journalEquityAccountQuery j ,journalEquityAccountQuery j
@ -370,17 +367,16 @@ journalAccountTypeQuery :: [AccountType] -> Regexp -> Journal -> Query
journalAccountTypeQuery atypes fallbackregex Journal{jdeclaredaccounttypes} = journalAccountTypeQuery atypes fallbackregex Journal{jdeclaredaccounttypes} =
let let
declaredacctsoftype :: [AccountName] = declaredacctsoftype :: [AccountName] =
concat $ catMaybes [M.lookup t jdeclaredaccounttypes | t <- atypes] concat $ mapMaybe (`M.lookup` jdeclaredaccounttypes) atypes
in case declaredacctsoftype of in case declaredacctsoftype of
[] -> Acct fallbackregex [] -> Acct fallbackregex
as -> as -> And [ Or acctnameRegexes, Not $ Or differentlyTypedRegexes ]
-- XXX Query isn't able to match account type since that requires extra info from the journal.
-- So we do a hacky search by name instead.
And [
Or $ map (Acct . accountNameToAccountRegex) as
,Not $ Or $ map (Acct . accountNameToAccountRegex) differentlytypedsubs
]
where where
-- XXX Query isn't able to match account type since that requires extra info from the journal.
-- So we do a hacky search by name instead.
acctnameRegexes = map (Acct . accountNameToAccountRegex) as
differentlyTypedRegexes = map (Acct . accountNameToAccountRegex) differentlytypedsubs
differentlytypedsubs = concat differentlytypedsubs = concat
[subs | (t,bs) <- M.toList jdeclaredaccounttypes [subs | (t,bs) <- M.toList jdeclaredaccounttypes
, not $ t `elem` atypes , not $ t `elem` atypes
@ -1237,25 +1233,6 @@ postingFindTag tagname p = find ((tagname==) . fst) $ postingAllTags p
-- ) -- )
-- ] -- ]
-- Misc helpers
-- | Check if a set of hledger account/description filter patterns matches the
-- given account name or entry description. Patterns are case-insensitive
-- regular expressions. Prefixed with not:, they become anti-patterns.
matchpats :: [String] -> String -> Bool
matchpats pats str =
(null positives || any match positives) && (null negatives || not (any match negatives))
where
(negatives,positives) = partition isnegativepat pats
match "" = True
match pat = regexMatchesCI (abspat pat) str
negateprefix = "not:"
isnegativepat = (negateprefix `isPrefixOf`)
abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat
-- debug helpers -- debug helpers
-- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a -- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a
-- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps -- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps

7
hledger-lib/Hledger/Data/Ledger.hs
View File

@ -17,7 +17,6 @@ module Hledger.Data.Ledger (
,ledgerRootAccount ,ledgerRootAccount
,ledgerTopAccounts ,ledgerTopAccounts
,ledgerLeafAccounts ,ledgerLeafAccounts
,ledgerAccountsMatching
,ledgerPostings ,ledgerPostings
,ledgerDateSpan ,ledgerDateSpan
,ledgerCommodities ,ledgerCommodities
@ -26,8 +25,6 @@ module Hledger.Data.Ledger (
where where
import qualified Data.Map as M import qualified Data.Map as M
-- import Data.Text (Text)
import qualified Data.Text as T
import Safe (headDef) import Safe (headDef)
import Text.Printf import Text.Printf
@ -90,10 +87,6 @@ ledgerTopAccounts = asubs . head . laccounts
ledgerLeafAccounts :: Ledger -> [Account] ledgerLeafAccounts :: Ledger -> [Account]
ledgerLeafAccounts = filter (null.asubs) . laccounts ledgerLeafAccounts = filter (null.asubs) . laccounts
-- | Accounts in ledger whose name matches the pattern, in tree order.
ledgerAccountsMatching :: [String] -> Ledger -> [Account]
ledgerAccountsMatching pats = filter (matchpats pats . T.unpack . aname) . laccounts -- XXX pack
-- | List a ledger's postings, in the order parsed. -- | List a ledger's postings, in the order parsed.
ledgerPostings :: Ledger -> [Posting] ledgerPostings :: Ledger -> [Posting]
ledgerPostings = journalPostings . ljournal ledgerPostings = journalPostings . ljournal

2
hledger-lib/Hledger/Data/Posting.hs
View File

@ -315,7 +315,7 @@ aliasReplace (BasicAlias old new) a
Right $ new <> T.drop (T.length old) a Right $ new <> T.drop (T.length old) a
| otherwise = Right a | otherwise = Right a
aliasReplace (RegexAlias re repl) a = aliasReplace (RegexAlias re repl) a =
fmap T.pack $ regexReplaceCIMemo_ re repl $ T.unpack a -- XXX fmap T.pack . regexReplace re repl $ T.unpack a -- XXX
-- | Apply a specified valuation to this posting's amount, using the -- | Apply a specified valuation to this posting's amount, using the
-- provided price oracle, commodity styles, reference dates, and -- provided price oracle, commodity styles, reference dates, and

12
hledger-lib/Hledger/Data/RawOptions.hs
View File

@ -1,5 +1,3 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-| {-|
hledger's cmdargs modes parse command-line arguments to an hledger's cmdargs modes parse command-line arguments to an
@ -28,17 +26,16 @@ module Hledger.Data.RawOptions (
) )
where where
import Data.Maybe import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Data import Data.Default (Default(..))
import Data.Default import Safe (headMay, lastMay, readDef)
import Safe
import Hledger.Utils import Hledger.Utils
-- | The result of running cmdargs: an association list of option names to string values. -- | The result of running cmdargs: an association list of option names to string values.
newtype RawOpts = RawOpts { unRawOpts :: [(String,String)] } newtype RawOpts = RawOpts { unRawOpts :: [(String,String)] }
deriving (Show, Data, Typeable) deriving (Show)
instance Default RawOpts where def = RawOpts [] instance Default RawOpts where def = RawOpts []
@ -61,6 +58,7 @@ boolopt = inRawOpts
-- for which the given predicate returns a Just value. -- for which the given predicate returns a Just value.
-- Useful for exclusive choice flags like --daily|--weekly|--quarterly... -- Useful for exclusive choice flags like --daily|--weekly|--quarterly...
-- --
-- >>> import Safe (readMay)
-- >>> choiceopt Just (RawOpts [("a",""), ("b",""), ("c","")]) -- >>> choiceopt Just (RawOpts [("a",""), ("b",""), ("c","")])
-- Just "c" -- Just "c"
-- >>> choiceopt (const Nothing) (RawOpts [("a","")]) -- >>> choiceopt (const Nothing) (RawOpts [("a","")])

118
hledger-lib/Hledger/Data/Types.hs
View File

@ -17,7 +17,6 @@ For more detailed documentation on each type, see the corresponding modules.
-} -}
-- {-# LANGUAGE DeriveAnyClass #-} -- https://hackage.haskell.org/package/deepseq-1.4.4.0/docs/Control-DeepSeq.html#v:rnf -- {-# LANGUAGE DeriveAnyClass #-} -- https://hackage.haskell.org/package/deepseq-1.4.4.0/docs/Control-DeepSeq.html#v:rnf
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -29,8 +28,6 @@ module Hledger.Data.Types
where where
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Control.DeepSeq (NFData)
import Data.Data
import Data.Decimal import Data.Decimal
import Data.Default import Data.Default
import Data.Functor (($>)) import Data.Functor (($>))
@ -77,12 +74,10 @@ data SmartInterval = Day | Week | Month | Quarter | Year deriving (Show)
data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show)
data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Data,Generic,Typeable) data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Ord,Generic)
instance Default DateSpan where def = DateSpan Nothing Nothing instance Default DateSpan where def = DateSpan Nothing Nothing
instance NFData DateSpan
-- synonyms for various date-related scalars -- synonyms for various date-related scalars
type Year = Integer type Year = Integer
type Month = Int -- 1-12 type Month = Int -- 1-12
@ -105,7 +100,7 @@ data Period =
| PeriodFrom Day | PeriodFrom Day
| PeriodTo Day | PeriodTo Day
| PeriodAll | PeriodAll
deriving (Eq,Ord,Show,Data,Generic,Typeable) deriving (Eq,Ord,Show,Generic)
instance Default Period where def = PeriodAll instance Default Period where def = PeriodAll
@ -116,7 +111,7 @@ instance Default Period where def = PeriodAll
-- MonthLong -- MonthLong
-- QuarterLong -- QuarterLong
-- YearLong -- YearLong
-- deriving (Eq,Ord,Show,Data,Generic,Typeable) -- deriving (Eq,Ord,Show,Generic)
-- Ways in which a period can be divided into subperiods. -- Ways in which a period can be divided into subperiods.
data Interval = data Interval =
@ -133,12 +128,10 @@ data Interval =
-- WeekOfYear Int -- WeekOfYear Int
-- MonthOfYear Int -- MonthOfYear Int
-- QuarterOfYear Int -- QuarterOfYear Int
deriving (Eq,Show,Ord,Data,Generic,Typeable) deriving (Eq,Show,Ord,Generic)
instance Default Interval where def = NoInterval instance Default Interval where def = NoInterval
instance NFData Interval
type AccountName = Text type AccountName = Text
data AccountType = data AccountType =
@ -148,9 +141,7 @@ data AccountType =
| Revenue | Revenue
| Expense | Expense
| Cash -- ^ a subtype of Asset - liquid assets to show in cashflow report | Cash -- ^ a subtype of Asset - liquid assets to show in cashflow report
deriving (Show,Eq,Ord,Data,Generic) deriving (Show,Eq,Ord,Generic)
instance NFData AccountType
-- not worth the trouble, letters defined in accountdirectivep for now -- not worth the trouble, letters defined in accountdirectivep for now
--instance Read AccountType --instance Read AccountType
@ -164,17 +155,12 @@ instance NFData AccountType
data AccountAlias = BasicAlias AccountName AccountName data AccountAlias = BasicAlias AccountName AccountName
| RegexAlias Regexp Replacement | RegexAlias Regexp Replacement
deriving (Eq, Read, Show, Ord, Data, Generic, Typeable) deriving (Eq, Read, Show, Ord, Generic)
instance NFData AccountAlias data Side = L | R deriving (Eq,Show,Read,Ord,Generic)
data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data,Generic)
instance NFData Side
-- | The basic numeric type used in amounts. -- | The basic numeric type used in amounts.
type Quantity = Decimal type Quantity = Decimal
deriving instance Data Quantity
-- The following is for hledger-web, and requires blaze-markup. -- The following is for hledger-web, and requires blaze-markup.
-- Doing it here avoids needing a matching flag on the hledger-web package. -- Doing it here avoids needing a matching flag on the hledger-web package.
instance ToMarkup Quantity instance ToMarkup Quantity
@ -185,9 +171,7 @@ instance ToMarkup Quantity
-- commodity, as recorded in the journal entry eg with @ or @@. -- commodity, as recorded in the journal entry eg with @ or @@.
-- Docs call this "transaction price". The amount is always positive. -- Docs call this "transaction price". The amount is always positive.
data AmountPrice = UnitPrice Amount | TotalPrice Amount data AmountPrice = UnitPrice Amount | TotalPrice Amount
deriving (Eq,Ord,Typeable,Data,Generic,Show) deriving (Eq,Ord,Generic,Show)
instance NFData AmountPrice
-- | Display style for an amount. -- | Display style for an amount.
data AmountStyle = AmountStyle { data AmountStyle = AmountStyle {
@ -196,9 +180,7 @@ data AmountStyle = AmountStyle {
asprecision :: !AmountPrecision, -- ^ number of digits displayed after the decimal point asprecision :: !AmountPrecision, -- ^ number of digits displayed after the decimal point
asdecimalpoint :: Maybe Char, -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default" asdecimalpoint :: Maybe Char, -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default"
asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any
} deriving (Eq,Ord,Read,Typeable,Data,Generic) } deriving (Eq,Ord,Read,Generic)
instance NFData AmountStyle
instance Show AmountStyle where instance Show AmountStyle where
show AmountStyle{..} = show AmountStyle{..} =
@ -209,9 +191,7 @@ instance Show AmountStyle where
(show asdecimalpoint) (show asdecimalpoint)
(show asdigitgroups) (show asdigitgroups)
data AmountPrecision = Precision !Word8 | NaturalPrecision deriving (Eq,Ord,Read,Show,Typeable,Data,Generic) data AmountPrecision = Precision !Word8 | NaturalPrecision deriving (Eq,Ord,Read,Show,Generic)
instance NFData AmountPrecision
-- | A style for displaying digit groups in the integer part of a -- | A style for displaying digit groups in the integer part of a
-- floating point number. It consists of the character used to -- floating point number. It consists of the character used to
@ -220,18 +200,14 @@ instance NFData AmountPrecision
-- the decimal point. The last group size is assumed to repeat. Eg, -- the decimal point. The last group size is assumed to repeat. Eg,
-- comma between thousands is DigitGroups ',' [3]. -- comma between thousands is DigitGroups ',' [3].
data DigitGroupStyle = DigitGroups Char [Word8] data DigitGroupStyle = DigitGroups Char [Word8]
deriving (Eq,Ord,Read,Show,Typeable,Data,Generic) deriving (Eq,Ord,Read,Show,Generic)
instance NFData DigitGroupStyle
type CommoditySymbol = Text type CommoditySymbol = Text
data Commodity = Commodity { data Commodity = Commodity {
csymbol :: CommoditySymbol, csymbol :: CommoditySymbol,
cformat :: Maybe AmountStyle cformat :: Maybe AmountStyle
} deriving (Show,Eq,Data,Generic) --,Ord,Typeable,Data,Generic) } deriving (Show,Eq,Generic) --,Ord)
instance NFData Commodity
data Amount = Amount { data Amount = Amount {
acommodity :: CommoditySymbol, -- commodity symbol, or special value "AUTO" acommodity :: CommoditySymbol, -- commodity symbol, or special value "AUTO"
@ -240,18 +216,12 @@ data Amount = Amount {
-- in a TMPostingRule. In a regular Posting, should always be false. -- in a TMPostingRule. In a regular Posting, should always be false.
astyle :: AmountStyle, astyle :: AmountStyle,
aprice :: Maybe AmountPrice -- ^ the (fixed, transaction-specific) price for this amount, if any aprice :: Maybe AmountPrice -- ^ the (fixed, transaction-specific) price for this amount, if any
} deriving (Eq,Ord,Typeable,Data,Generic,Show) } deriving (Eq,Ord,Generic,Show)
instance NFData Amount newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Generic,Show)
newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data,Generic,Show)
instance NFData MixedAmount
data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting
deriving (Eq,Show,Typeable,Data,Generic) deriving (Eq,Show,Generic)
instance NFData PostingType
type TagName = Text type TagName = Text
type TagValue = Text type TagValue = Text
@ -261,9 +231,7 @@ type DateTag = (TagName, Day)
-- | The status of a transaction or posting, recorded with a status mark -- | The status of a transaction or posting, recorded with a status mark
-- (nothing, !, or *). What these mean is ultimately user defined. -- (nothing, !, or *). What these mean is ultimately user defined.
data Status = Unmarked | Pending | Cleared data Status = Unmarked | Pending | Cleared
deriving (Eq,Ord,Bounded,Enum,Typeable,Data,Generic) deriving (Eq,Ord,Bounded,Enum,Generic)
instance NFData Status
instance Show Status where -- custom show.. bad idea.. don't do it.. instance Show Status where -- custom show.. bad idea.. don't do it..
show Unmarked = "" show Unmarked = ""
@ -312,9 +280,7 @@ data BalanceAssertion = BalanceAssertion {
batotal :: Bool, -- ^ disallow additional non-asserted commodities ? batotal :: Bool, -- ^ disallow additional non-asserted commodities ?
bainclusive :: Bool, -- ^ include subaccounts when calculating the actual balance ? bainclusive :: Bool, -- ^ include subaccounts when calculating the actual balance ?
baposition :: GenericSourcePos -- ^ the assertion's file position, for error reporting baposition :: GenericSourcePos -- ^ the assertion's file position, for error reporting
} deriving (Eq,Typeable,Data,Generic,Show) } deriving (Eq,Generic,Show)
instance NFData BalanceAssertion
data Posting = Posting { data Posting = Posting {
pdate :: Maybe Day, -- ^ this posting's date, if different from the transaction's pdate :: Maybe Day, -- ^ this posting's date, if different from the transaction's
@ -333,9 +299,7 @@ data Posting = Posting {
-- (eg its amount or price was inferred, or the account name was -- (eg its amount or price was inferred, or the account name was
-- changed by a pivot or budget report), this references the original -- changed by a pivot or budget report), this references the original
-- untransformed posting (which will have Nothing in this field). -- untransformed posting (which will have Nothing in this field).
} deriving (Typeable,Data,Generic) } deriving (Generic)
instance NFData Posting
-- The equality test for postings ignores the parent transaction's -- The equality test for postings ignores the parent transaction's
-- identity, to avoid recurring ad infinitum. -- identity, to avoid recurring ad infinitum.
@ -363,9 +327,7 @@ instance Show Posting where
-- | The position of parse errors (eg), like parsec's SourcePos but generic. -- | The position of parse errors (eg), like parsec's SourcePos but generic.
data GenericSourcePos = GenericSourcePos FilePath Int Int -- ^ file path, 1-based line number and 1-based column number. data GenericSourcePos = GenericSourcePos FilePath Int Int -- ^ file path, 1-based line number and 1-based column number.
| JournalSourcePos FilePath (Int, Int) -- ^ file path, inclusive range of 1-based line numbers (first, last). | JournalSourcePos FilePath (Int, Int) -- ^ file path, inclusive range of 1-based line numbers (first, last).
deriving (Eq, Read, Show, Ord, Data, Generic, Typeable) deriving (Eq, Read, Show, Ord, Generic)
instance NFData GenericSourcePos
--{-# ANN Transaction "HLint: ignore" #-} --{-# ANN Transaction "HLint: ignore" #-}
-- Ambiguous type variable ‘p0’ arising from an annotation -- Ambiguous type variable ‘p0’ arising from an annotation
@ -383,9 +345,7 @@ data Transaction = Transaction {
tcomment :: Text, -- ^ this transaction's comment lines, as a single non-indented multi-line string tcomment :: Text, -- ^ this transaction's comment lines, as a single non-indented multi-line string
ttags :: [Tag], -- ^ tag names and values, extracted from the comment ttags :: [Tag], -- ^ tag names and values, extracted from the comment
tpostings :: [Posting] -- ^ this transaction's postings tpostings :: [Posting] -- ^ this transaction's postings
} deriving (Eq,Typeable,Data,Generic,Show) } deriving (Eq,Generic,Show)
instance NFData Transaction
-- | A transaction modifier rule. This has a query which matches postings -- | A transaction modifier rule. This has a query which matches postings
-- in the journal, and a list of transformations to apply to those -- in the journal, and a list of transformations to apply to those
@ -395,9 +355,7 @@ instance NFData Transaction
data TransactionModifier = TransactionModifier { data TransactionModifier = TransactionModifier {
tmquerytxt :: Text, tmquerytxt :: Text,
tmpostingrules :: [TMPostingRule] tmpostingrules :: [TMPostingRule]
} deriving (Eq,Typeable,Data,Generic,Show) } deriving (Eq,Generic,Show)
instance NFData TransactionModifier
nulltransactionmodifier = TransactionModifier{ nulltransactionmodifier = TransactionModifier{
tmquerytxt = "" tmquerytxt = ""
@ -422,7 +380,7 @@ data PeriodicTransaction = PeriodicTransaction {
ptcomment :: Text, ptcomment :: Text,
pttags :: [Tag], pttags :: [Tag],
ptpostings :: [Posting] ptpostings :: [Posting]
} deriving (Eq,Typeable,Data,Generic) -- , Show in PeriodicTransaction.hs } deriving (Eq,Generic) -- , Show in PeriodicTransaction.hs
nullperiodictransaction = PeriodicTransaction{ nullperiodictransaction = PeriodicTransaction{
ptperiodexpr = "" ptperiodexpr = ""
@ -436,11 +394,7 @@ nullperiodictransaction = PeriodicTransaction{
,ptpostings = [] ,ptpostings = []
} }
instance NFData PeriodicTransaction data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Generic)
data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data,Generic)
instance NFData TimeclockCode
data TimeclockEntry = TimeclockEntry { data TimeclockEntry = TimeclockEntry {
tlsourcepos :: GenericSourcePos, tlsourcepos :: GenericSourcePos,
@ -448,9 +402,7 @@ data TimeclockEntry = TimeclockEntry {
tldatetime :: LocalTime, tldatetime :: LocalTime,
tlaccount :: AccountName, tlaccount :: AccountName,
tldescription :: Text tldescription :: Text
} deriving (Eq,Ord,Typeable,Data,Generic) } deriving (Eq,Ord,Generic)
instance NFData TimeclockEntry
-- | A market price declaration made by the journal format's P directive. -- | A market price declaration made by the journal format's P directive.
-- It declares two things: a historical exchange rate between two commodities, -- It declares two things: a historical exchange rate between two commodities,
@ -459,11 +411,9 @@ data PriceDirective = PriceDirective {
pddate :: Day pddate :: Day
,pdcommodity :: CommoditySymbol ,pdcommodity :: CommoditySymbol
,pdamount :: Amount ,pdamount :: Amount
} deriving (Eq,Ord,Typeable,Data,Generic,Show) } deriving (Eq,Ord,Generic,Show)
-- Show instance derived in Amount.hs (XXX why ?) -- Show instance derived in Amount.hs (XXX why ?)
instance NFData PriceDirective
-- | A historical market price (exchange rate) from one commodity to another. -- | A historical market price (exchange rate) from one commodity to another.
-- A more concise form of a PriceDirective, without the amount display info. -- A more concise form of a PriceDirective, without the amount display info.
data MarketPrice = MarketPrice { data MarketPrice = MarketPrice {
@ -471,11 +421,9 @@ data MarketPrice = MarketPrice {
,mpfrom :: CommoditySymbol -- ^ The commodity being converted from. ,mpfrom :: CommoditySymbol -- ^ The commodity being converted from.
,mpto :: CommoditySymbol -- ^ The commodity being converted to. ,mpto :: CommoditySymbol -- ^ The commodity being converted to.
,mprate :: Quantity -- ^ One unit of the "from" commodity is worth this quantity of the "to" commodity. ,mprate :: Quantity -- ^ One unit of the "from" commodity is worth this quantity of the "to" commodity.
} deriving (Eq,Ord,Typeable,Data,Generic) } deriving (Eq,Ord,Generic)
-- Show instance derived in Amount.hs (XXX why ?) -- Show instance derived in Amount.hs (XXX why ?)
instance NFData MarketPrice
-- additional valuation-related types in Valuation.hs -- additional valuation-related types in Valuation.hs
-- | A Journal, containing transactions and various other things. -- | A Journal, containing transactions and various other things.
@ -512,13 +460,9 @@ data Journal = Journal {
-- any included journal files. The main file is first, -- any included journal files. The main file is first,
-- followed by any included files in the order encountered. -- followed by any included files in the order encountered.
,jlastreadtime :: ClockTime -- ^ when this journal was last read from its file(s) ,jlastreadtime :: ClockTime -- ^ when this journal was last read from its file(s)
} deriving (Eq, Typeable, Data, Generic) } deriving (Eq, Generic)
deriving instance Data ClockTime
deriving instance Typeable ClockTime
deriving instance Generic ClockTime deriving instance Generic ClockTime
instance NFData ClockTime
instance NFData Journal
-- | A journal in the process of being parsed, not yet finalised. -- | A journal in the process of being parsed, not yet finalised.
-- The data is partial, and list fields are in reverse order. -- The data is partial, and list fields are in reverse order.
@ -535,9 +479,7 @@ data AccountDeclarationInfo = AccountDeclarationInfo {
,aditags :: [Tag] -- ^ tags extracted from the account comment, if any ,aditags :: [Tag] -- ^ tags extracted from the account comment, if any
,adideclarationorder :: Int -- ^ the order in which this account was declared, ,adideclarationorder :: Int -- ^ the order in which this account was declared,
-- relative to other account declarations, during parsing (1..) -- relative to other account declarations, during parsing (1..)
} deriving (Eq,Show,Data,Generic) } deriving (Eq,Show,Generic)
instance NFData AccountDeclarationInfo
nullaccountdeclarationinfo = AccountDeclarationInfo { nullaccountdeclarationinfo = AccountDeclarationInfo {
adicomment = "" adicomment = ""
@ -558,14 +500,14 @@ data Account = Account {
,anumpostings :: Int -- ^ the number of postings to this account ,anumpostings :: Int -- ^ the number of postings to this account
,aebalance :: MixedAmount -- ^ this account's balance, excluding subaccounts ,aebalance :: MixedAmount -- ^ this account's balance, excluding subaccounts
,aibalance :: MixedAmount -- ^ this account's balance, including subaccounts ,aibalance :: MixedAmount -- ^ this account's balance, including subaccounts
} deriving (Typeable, Data, Generic) } deriving (Generic)
-- | Whether an account's balance is normally a positive number (in -- | Whether an account's balance is normally a positive number (in
-- accounting terms, a debit balance) or a negative number (credit balance). -- accounting terms, a debit balance) or a negative number (credit balance).
-- Assets and expenses are normally positive (debit), while liabilities, equity -- Assets and expenses are normally positive (debit), while liabilities, equity
-- and income are normally negative (credit). -- and income are normally negative (credit).
-- https://en.wikipedia.org/wiki/Normal_balance -- https://en.wikipedia.org/wiki/Normal_balance
data NormalSign = NormallyPositive | NormallyNegative deriving (Show, Data, Eq) data NormalSign = NormallyPositive | NormallyNegative deriving (Show, Eq)
-- | A Ledger has the journal it derives from, and the accounts -- | A Ledger has the journal it derives from, and the accounts
-- derived from that. Accounts are accessible both list-wise and -- derived from that. Accounts are accessible both list-wise and

8
hledger-lib/Hledger/Data/Valuation.hs
View File

@ -9,7 +9,7 @@ looking up historical market prices (exchange rates) between commodities.
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
module Hledger.Data.Valuation ( module Hledger.Data.Valuation (
ValuationType(..) ValuationType(..)
@ -28,8 +28,6 @@ module Hledger.Data.Valuation (
where where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Control.DeepSeq (NFData)
import Data.Data
import Data.Decimal (roundTo) import Data.Decimal (roundTo)
import Data.Function ((&), on) import Data.Function ((&), on)
import Data.Graph.Inductive (Gr, Node, NodeMap, mkMapGraph, mkNode, lab, out, sp) import Data.Graph.Inductive (Gr, Node, NodeMap, mkMapGraph, mkNode, lab, out, sp)
@ -60,7 +58,7 @@ data ValuationType =
| AtNow (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using current market prices | AtNow (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using current market prices
| AtDate Day (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using market prices on some date | AtDate Day (Maybe CommoditySymbol) -- ^ convert to default or given valuation commodity, using market prices on some date
| AtDefault (Maybe CommoditySymbol) -- ^ works like AtNow in single period reports, like AtEnd in multiperiod reports | AtDefault (Maybe CommoditySymbol) -- ^ works like AtNow in single period reports, like AtEnd in multiperiod reports
deriving (Show,Data,Eq) -- Typeable deriving (Show,Eq)
-- | A snapshot of the known exchange rates between commodity pairs at a given date, -- | A snapshot of the known exchange rates between commodity pairs at a given date,
-- as a graph allowing fast lookup and path finding, along with some helper data. -- as a graph allowing fast lookup and path finding, along with some helper data.
@ -87,8 +85,6 @@ data PriceGraph = PriceGraph {
} }
deriving (Show,Generic) deriving (Show,Generic)
instance NFData PriceGraph
-- | A price oracle is a magic memoising function that efficiently -- | A price oracle is a magic memoising function that efficiently
-- looks up market prices (exchange rates) from one commodity to -- looks up market prices (exchange rates) from one commodity to
-- another (or if unspecified, to a default valuation commodity) on a -- another (or if unspecified, to a default valuation commodity) on a

313
hledger-lib/Hledger/Query.hs
View File

@ -9,13 +9,18 @@ transactions..) by various criteria, and a SimpleTextParser for query expressio
-- (may hide other deprecation warnings too). https://github.com/ndmitchell/safe/issues/26 -- (may hide other deprecation warnings too). https://github.com/ndmitchell/safe/issues/26
{-# OPTIONS_GHC -Wno-warnings-deprecations #-} {-# OPTIONS_GHC -Wno-warnings-deprecations #-}
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ViewPatterns #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Hledger.Query ( module Hledger.Query (
-- * Query and QueryOpt -- * Query and QueryOpt
Query(..), Query(..),
QueryOpt(..), QueryOpt(..),
payeeTag,
noteTag,
generatedTransactionTag,
-- * parsing -- * parsing
parseQuery, parseQuery,
simplifyQuery, simplifyQuery,
@ -42,20 +47,13 @@ module Hledger.Query (
inAccountQuery, inAccountQuery,
-- * matching -- * matching
matchesTransaction, matchesTransaction,
matchesTransaction_,
matchesPosting, matchesPosting,
matchesPosting_,
matchesAccount, matchesAccount,
matchesAccount_,
matchesMixedAmount, matchesMixedAmount,
matchesAmount, matchesAmount,
matchesAmount_,
matchesCommodity, matchesCommodity,
matchesCommodity_,
matchesTags, matchesTags,
matchesTags_,
matchesPriceDirective, matchesPriceDirective,
matchesPriceDirective_,
words'', words'',
prefixes, prefixes,
-- * tests -- * tests
@ -63,19 +61,18 @@ module Hledger.Query (
) )
where where
import Control.Arrow ((>>>)) import Control.Applicative ((<|>), many, optional)
import Data.Data import Data.Either (partitionEithers)
import Data.Either import Data.List (partition)
import Data.List import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Data.Maybe
#if !(MIN_VERSION_base(4,11,0)) #if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>)) import Data.Monoid ((<>))
#endif #endif
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar (Day, fromGregorian )
import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay) import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay)
import Text.Megaparsec import Text.Megaparsec (between, noneOf, sepBy)
import Text.Megaparsec.Char import Text.Megaparsec.Char (char, string)
import Hledger.Utils hiding (words') import Hledger.Utils hiding (words')
import Hledger.Data.Types import Hledger.Data.Types
@ -109,39 +106,31 @@ data Query = Any -- ^ always match
-- and sometimes like a query option (for controlling display) -- and sometimes like a query option (for controlling display)
| Tag Regexp (Maybe Regexp) -- ^ match if a tag's name, and optionally its value, is matched by these respective regexps | Tag Regexp (Maybe Regexp) -- ^ match if a tag's name, and optionally its value, is matched by these respective regexps
-- matching the regexp if provided, exists -- matching the regexp if provided, exists
deriving (Eq,Data,Typeable) deriving (Eq,Show)
-- custom Show implementation to show strings more accurately, eg for debugging regexps -- | Construct a payee tag
instance Show Query where payeeTag :: Maybe String -> Either RegexError Query
show Any = "Any" payeeTag = fmap (Tag (toRegexCI' "payee")) . maybe (pure Nothing) (fmap Just . toRegexCI)
show None = "None"
show (Not q) = "Not (" ++ show q ++ ")" -- | Construct a note tag
show (Or qs) = "Or (" ++ show qs ++ ")" noteTag :: Maybe String -> Either RegexError Query
show (And qs) = "And (" ++ show qs ++ ")" noteTag = fmap (Tag (toRegexCI' "note")) . maybe (pure Nothing) (fmap Just . toRegexCI)
show (Code r) = "Code " ++ show r
show (Desc r) = "Desc " ++ show r -- | Construct a generated-transaction tag
show (Acct r) = "Acct " ++ show r generatedTransactionTag :: Query
show (Date ds) = "Date (" ++ show ds ++ ")" generatedTransactionTag = Tag (toRegexCI' "generated-transaction") Nothing
show (Date2 ds) = "Date2 (" ++ show ds ++ ")"
show (StatusQ b) = "StatusQ " ++ show b
show (Real b) = "Real " ++ show b
show (Amt ord qty) = "Amt " ++ show ord ++ " " ++ show qty
show (Sym r) = "Sym " ++ show r
show (Empty b) = "Empty " ++ show b
show (Depth n) = "Depth " ++ show n
show (Tag s ms) = "Tag " ++ show s ++ " (" ++ show ms ++ ")"
-- | A more expressive Ord, used for amt: queries. The Abs* variants -- | A more expressive Ord, used for amt: queries. The Abs* variants
-- compare with the absolute value of a number, ignoring sign. -- compare with the absolute value of a number, ignoring sign.
data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq
deriving (Show,Eq,Data,Typeable) deriving (Show,Eq)
-- | A query option changes a query's/report's behaviour and output in some way. -- | A query option changes a query's/report's behaviour and output in some way.
data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account
| QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register | QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register
-- | QueryOptCostBasis -- ^ show amounts converted to cost where possible -- | QueryOptCostBasis -- ^ show amounts converted to cost where possible
-- | QueryOptDate2 -- ^ show secondary dates instead of primary dates -- | QueryOptDate2 -- ^ show secondary dates instead of primary dates
deriving (Show, Eq, Data, Typeable) deriving (Show, Eq)
-- parsing -- parsing
@ -186,11 +175,10 @@ data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register fo
-- 4. then all terms are AND'd together -- 4. then all terms are AND'd together
-- --
-- >>> parseQuery nulldate "expenses:dining out" -- >>> parseQuery nulldate "expenses:dining out"
-- Right (Or ([Acct "expenses:dining",Acct "out"]),[]) -- Right (Or [Acct (RegexpCI "expenses:dining"),Acct (RegexpCI "out")],[])
-- --
-- >>> parseQuery nulldate "\"expenses:dining out\"" -- >>> parseQuery nulldate "\"expenses:dining out\""
-- Right (Acct "expenses:dining out",[]) -- Right (Acct (RegexpCI "expenses:dining out"),[])
--
parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt]) parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt])
parseQuery d s = do parseQuery d s = do
let termstrs = words'' prefixes s let termstrs = words'' prefixes s
@ -273,11 +261,11 @@ parseQueryTerm d (T.stripPrefix "not:" -> Just s) =
Right (Left m) -> Right $ Left $ Not m Right (Left m) -> Right $ Left $ Not m
Right (Right _) -> Right $ Left Any -- not:somequeryoption will be ignored Right (Right _) -> Right $ Left Any -- not:somequeryoption will be ignored
Left err -> Left err Left err -> Left err
parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Right $ Left $ Code $ T.unpack s parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left . Code <$> toRegexCI (T.unpack s)
parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Right $ Left $ Desc $ T.unpack s parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left . Desc <$> toRegexCI (T.unpack s)
parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Right $ Left $ Tag "payee" $ Just $ T.unpack s parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Left <$> payeeTag (Just $ T.unpack s)
parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Right $ Left $ Tag "note" $ Just $ T.unpack s parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Left <$> noteTag (Just $ T.unpack s)
parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Right $ Left $ Acct $ T.unpack s parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI (T.unpack s)
parseQueryTerm d (T.stripPrefix "date2:" -> Just s) = parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =
case parsePeriodExpr d s of Left e -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e case parsePeriodExpr d s of Left e -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e
Right (_,span) -> Right $ Left $ Date2 span Right (_,span) -> Right $ Left $ Date2 span
@ -295,8 +283,8 @@ parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)
| otherwise = Left "depth: should have a positive number" | otherwise = Left "depth: should have a positive number"
where n = readDef 0 (T.unpack s) where n = readDef 0 (T.unpack s)
parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Right $ Left $ Sym (T.unpack s) -- support cur: as an alias parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left . Sym <$> toRegexCI ('^' : T.unpack s ++ "$") -- support cur: as an alias
parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Right $ Left $ Tag n v where (n,v) = parseTag s parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left <$> parseTag s
parseQueryTerm _ "" = Right $ Left $ Any parseQueryTerm _ "" = Right $ Left $ Any
parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s
@ -344,10 +332,12 @@ parseAmountQueryTerm amtarg =
parse :: T.Text -> T.Text -> Maybe Quantity parse :: T.Text -> T.Text -> Maybe Quantity
parse p s = (T.stripPrefix p . T.strip) s >>= readMay . filter (not.(==' ')) . T.unpack parse p s = (T.stripPrefix p . T.strip) s >>= readMay . filter (not.(==' ')) . T.unpack
parseTag :: T.Text -> (Regexp, Maybe Regexp) parseTag :: T.Text -> Either RegexError Query
parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v) parseTag s = do
| otherwise = (T.unpack s, Nothing) tag <- toRegexCI . T.unpack $ if T.null v then s else n
where (n,v) = T.break (=='=') s body <- if T.null v then pure Nothing else Just <$> toRegexCI (tail $ T.unpack v)
return $ Tag tag body
where (n,v) = T.break (=='=') s
-- | Parse the value part of a "status:" query, or return an error. -- | Parse the value part of a "status:" query, or return an error.
parseStatus :: T.Text -> Either String Status parseStatus :: T.Text -> Either String Status
@ -550,8 +540,8 @@ inAccount (QueryOptInAcct a:_) = Just (a,True)
-- Just looks at the first query option. -- Just looks at the first query option.
inAccountQuery :: [QueryOpt] -> Maybe Query inAccountQuery :: [QueryOpt] -> Maybe Query
inAccountQuery [] = Nothing inAccountQuery [] = Nothing
inAccountQuery (QueryOptInAcctOnly a : _) = Just $ Acct $ accountNameToAccountOnlyRegex a inAccountQuery (QueryOptInAcctOnly a : _) = Just . Acct $ accountNameToAccountOnlyRegex a
inAccountQuery (QueryOptInAcct a : _) = Just $ Acct $ accountNameToAccountRegex a inAccountQuery (QueryOptInAcct a : _) = Just . Acct $ accountNameToAccountRegex a
-- -- | Convert a query to its inverse. -- -- | Convert a query to its inverse.
-- negateQuery :: Query -> Query -- negateQuery :: Query -> Query
@ -568,36 +558,18 @@ matchesAccount (None) _ = False
matchesAccount (Not m) a = not $ matchesAccount m a matchesAccount (Not m) a = not $ matchesAccount m a
matchesAccount (Or ms) a = any (`matchesAccount` a) ms matchesAccount (Or ms) a = any (`matchesAccount` a) ms
matchesAccount (And ms) a = all (`matchesAccount` a) ms matchesAccount (And ms) a = all (`matchesAccount` a) ms
matchesAccount (Acct r) a = regexMatchesCI r (T.unpack a) -- XXX pack matchesAccount (Acct r) a = regexMatch r $ T.unpack a -- XXX pack
matchesAccount (Depth d) a = accountNameLevel a <= d matchesAccount (Depth d) a = accountNameLevel a <= d
matchesAccount (Tag _ _) _ = False matchesAccount (Tag _ _) _ = False
matchesAccount _ _ = True matchesAccount _ _ = True
-- | Total version of matchesAccount, which will return any error
-- arising from a malformed regular expression in the query.
matchesAccount_ :: Query -> AccountName -> Either RegexError Bool
matchesAccount_ (None) _ = Right False
matchesAccount_ (Not m) a = Right $ not $ matchesAccount m a
matchesAccount_ (Or ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . or
matchesAccount_ (And ms) a = sequence (map (`matchesAccount_` a) ms) >>= pure . and
matchesAccount_ (Acct r) a = regexMatchesCI_ r (T.unpack a) -- XXX pack
matchesAccount_ (Depth d) a = Right $ accountNameLevel a <= d
matchesAccount_ (Tag _ _) _ = Right False
matchesAccount_ _ _ = Right True
matchesMixedAmount :: Query -> MixedAmount -> Bool matchesMixedAmount :: Query -> MixedAmount -> Bool
matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt
matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as
matchesCommodity :: Query -> CommoditySymbol -> Bool matchesCommodity :: Query -> CommoditySymbol -> Bool
matchesCommodity (Sym r) s = regexMatchesCI ("^" ++ r ++ "$") (T.unpack s) matchesCommodity (Sym r) = regexMatch r . T.unpack
matchesCommodity _ _ = True matchesCommodity _ = const True
-- | Total version of matchesCommodity, which will return any error
-- arising from a malformed regular expression in the query.
matchesCommodity_ :: Query -> CommoditySymbol -> Either RegexError Bool
matchesCommodity_ (Sym r) s = regexMatchesCI_ ("^" ++ r ++ "$") (T.unpack s)
matchesCommodity_ _ _ = Right True
-- | Does the match expression match this (simple) amount ? -- | Does the match expression match this (simple) amount ?
matchesAmount :: Query -> Amount -> Bool matchesAmount :: Query -> Amount -> Bool
@ -610,18 +582,6 @@ matchesAmount (Amt ord n) a = compareAmount ord n a
matchesAmount (Sym r) a = matchesCommodity (Sym r) (acommodity a) matchesAmount (Sym r) a = matchesCommodity (Sym r) (acommodity a)
matchesAmount _ _ = True matchesAmount _ _ = True
-- | Total version of matchesAmount, returning any error from a
-- malformed regular expression in the query.
matchesAmount_ :: Query -> Amount -> Either RegexError Bool
matchesAmount_ (Not q) a = not <$> q `matchesAmount_` a
matchesAmount_ (Any) _ = Right True
matchesAmount_ (None) _ = Right False
matchesAmount_ (Or qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . or
matchesAmount_ (And qs) a = sequence (map (`matchesAmount_` a) qs) >>= pure . and
matchesAmount_ (Amt ord n) a = Right $ compareAmount ord n a
matchesAmount_ (Sym r) a = matchesCommodity_ (Sym r) (acommodity a)
matchesAmount_ _ _ = Right True
-- | Is this simple (single-amount) mixed amount's quantity less than, greater than, equal to, or unsignedly equal to this number ? -- | Is this simple (single-amount) mixed amount's quantity less than, greater than, equal to, or unsignedly equal to this number ?
-- For multi-amount (multiple commodities, or just unsimplified) mixed amounts this is always true. -- For multi-amount (multiple commodities, or just unsimplified) mixed amounts this is always true.
@ -647,10 +607,10 @@ matchesPosting (Any) _ = True
matchesPosting (None) _ = False matchesPosting (None) _ = False
matchesPosting (Or qs) p = any (`matchesPosting` p) qs matchesPosting (Or qs) p = any (`matchesPosting` p) qs
matchesPosting (And qs) p = all (`matchesPosting` p) qs matchesPosting (And qs) p = all (`matchesPosting` p) qs
matchesPosting (Code r) p = regexMatchesCI r $ maybe "" (T.unpack . tcode) $ ptransaction p matchesPosting (Code r) p = regexMatch r $ maybe "" (T.unpack . tcode) $ ptransaction p
matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" (T.unpack . tdescription) $ ptransaction p matchesPosting (Desc r) p = regexMatch r $ maybe "" (T.unpack . tdescription) $ ptransaction p
matchesPosting (Acct r) p = matches p || matches (originalPosting p) matchesPosting (Acct r) p = matches p || matches (originalPosting p)
where matches p = regexMatchesCI r $ T.unpack $ paccount p -- XXX pack where matches p = regexMatch r . T.unpack $ paccount p -- XXX pack
matchesPosting (Date span) p = span `spanContainsDate` postingDate p matchesPosting (Date span) p = span `spanContainsDate` postingDate p
matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p
matchesPosting (StatusQ s) p = postingStatus p == s matchesPosting (StatusQ s) p = postingStatus p == s
@ -663,35 +623,10 @@ matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt
-- matchesPosting (Empty True) Posting{pamount=a} = mixedAmountLooksZero a -- matchesPosting (Empty True) Posting{pamount=a} = mixedAmountLooksZero a
matchesPosting (Empty _) _ = True matchesPosting (Empty _) _ = True
matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as
matchesPosting (Tag n v) p = case (n, v) of matchesPosting (Tag n v) p = case (reString n, v) of
("payee", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionPayee) $ ptransaction p ("payee", Just v) -> maybe False (regexMatch v . T.unpack . transactionPayee) $ ptransaction p
("note", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionNote) $ ptransaction p ("note", Just v) -> maybe False (regexMatch v . T.unpack . transactionNote) $ ptransaction p
(n, v) -> matchesTags n v $ postingAllTags p (_, v) -> matchesTags n v $ postingAllTags p
-- | Total version of matchesPosting, returning any error from a
-- malformed regular expression in the query.
matchesPosting_ :: Query -> Posting -> Either RegexError Bool
matchesPosting_ (Not q) p = not <$> q `matchesPosting_` p
matchesPosting_ (Any) _ = Right True
matchesPosting_ (None) _ = Right False
matchesPosting_ (Or qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.or
matchesPosting_ (And qs) p = sequence (map (`matchesPosting_` p) qs) >>= pure.and
matchesPosting_ (Code r) p = regexMatchesCI_ r $ maybe "" (T.unpack . tcode) $ ptransaction p
matchesPosting_ (Desc r) p = regexMatchesCI_ r $ maybe "" (T.unpack . tdescription) $ ptransaction p
matchesPosting_ (Acct r) p = sequence [matches p, matches (originalPosting p)] >>= pure.or
where matches p = regexMatchesCI_ r $ T.unpack $ paccount p -- XXX pack
matchesPosting_ (Date span) p = Right $ span `spanContainsDate` postingDate p
matchesPosting_ (Date2 span) p = Right $ span `spanContainsDate` postingDate2 p
matchesPosting_ (StatusQ s) p = Right $ postingStatus p == s
matchesPosting_ (Real v) p = Right $ v == isReal p
matchesPosting_ q@(Depth _) Posting{paccount=a} = q `matchesAccount_` a
matchesPosting_ q@(Amt _ _) Posting{pamount=amt} = Right $ q `matchesMixedAmount` amt
matchesPosting_ (Empty _) _ = Right True
matchesPosting_ (Sym r) Posting{pamount=Mixed as} = sequence (map (matchesCommodity_ (Sym r)) $ map acommodity as) >>= pure.or
matchesPosting_ (Tag n v) p = case (n, v) of
("payee", Just v) -> maybe (Right False) (T.unpack . transactionPayee >>> regexMatchesCI_ v) $ ptransaction p
("note", Just v) -> maybe (Right False) (T.unpack . transactionNote >>> regexMatchesCI_ v) $ ptransaction p
(n, v) -> matchesTags_ n v $ postingAllTags p
-- | Does the match expression match this transaction ? -- | Does the match expression match this transaction ?
matchesTransaction :: Query -> Transaction -> Bool matchesTransaction :: Query -> Transaction -> Bool
@ -700,8 +635,8 @@ matchesTransaction (Any) _ = True
matchesTransaction (None) _ = False matchesTransaction (None) _ = False
matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs
matchesTransaction (And qs) t = all (`matchesTransaction` t) qs matchesTransaction (And qs) t = all (`matchesTransaction` t) qs
matchesTransaction (Code r) t = regexMatchesCI r $ T.unpack $ tcode t matchesTransaction (Code r) t = regexMatch r $ T.unpack $ tcode t
matchesTransaction (Desc r) t = regexMatchesCI r $ T.unpack $ tdescription t matchesTransaction (Desc r) t = regexMatch r $ T.unpack $ tdescription t
matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t
matchesTransaction (Date span) t = spanContainsDate span $ tdate t matchesTransaction (Date span) t = spanContainsDate span $ tdate t
matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t
@ -711,51 +646,16 @@ matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t
matchesTransaction (Empty _) _ = True matchesTransaction (Empty _) _ = True
matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t
matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t
matchesTransaction (Tag n v) t = case (n, v) of matchesTransaction (Tag n v) t = case (reString n, v) of
("payee", Just v) -> regexMatchesCI v . T.unpack . transactionPayee $ t ("payee", Just v) -> regexMatch v . T.unpack . transactionPayee $ t
("note", Just v) -> regexMatchesCI v . T.unpack . transactionNote $ t ("note", Just v) -> regexMatch v . T.unpack . transactionNote $ t
(n, v) -> matchesTags n v $ transactionAllTags t (_, v) -> matchesTags n v $ transactionAllTags t
-- | Total version of matchesTransaction, returning any error from a
-- malformed regular expression in the query.
matchesTransaction_ :: Query -> Transaction -> Either RegexError Bool
matchesTransaction_ (Not q) t = not <$> q `matchesTransaction_` t
matchesTransaction_ (Any) _ = Right True
matchesTransaction_ (None) _ = Right False
matchesTransaction_ (Or qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.or
matchesTransaction_ (And qs) t = sequence (map (`matchesTransaction_` t) qs) >>= pure.and
matchesTransaction_ (Code r) t = regexMatchesCI_ r $ T.unpack $ tcode t
matchesTransaction_ (Desc r) t = regexMatchesCI_ r $ T.unpack $ tdescription t
matchesTransaction_ q@(Acct _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or
matchesTransaction_ (Date span) t = Right $ spanContainsDate span $ tdate t
matchesTransaction_ (Date2 span) t = Right $ spanContainsDate span $ transactionDate2 t
matchesTransaction_ (StatusQ s) t = Right $ tstatus t == s
matchesTransaction_ (Real v) t = Right $ v == hasRealPostings t
matchesTransaction_ q@(Amt _ _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or
matchesTransaction_ (Empty _) _ = Right True
matchesTransaction_ (Depth d) t = sequence (map (Depth d `matchesPosting_`) $ tpostings t) >>= pure.or
matchesTransaction_ q@(Sym _) t = sequence (map (q `matchesPosting_`) $ tpostings t) >>= pure.or
matchesTransaction_ (Tag n v) t = case (n, v) of
("payee", Just v) -> regexMatchesCI_ v . T.unpack . transactionPayee $ t
("note", Just v) -> regexMatchesCI_ v . T.unpack . transactionNote $ t
(n, v) -> matchesTags_ n v $ transactionAllTags t
-- | Does the query match the name and optionally the value of any of these tags ? -- | Does the query match the name and optionally the value of any of these tags ?
matchesTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool matchesTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool
matchesTags namepat valuepat = not . null . filter (match namepat valuepat) matchesTags namepat valuepat = not . null . filter (matches namepat valuepat)
where where
match npat Nothing (n,_) = regexMatchesCI npat (T.unpack n) -- XXX matches npat vpat (n,v) = regexMatch npat (T.unpack n) && maybe (const True) regexMatch vpat (T.unpack v)
match npat (Just vpat) (n,v) = regexMatchesCI npat (T.unpack n) && regexMatchesCI vpat (T.unpack v)
-- | Total version of matchesTags, returning any error from a
-- malformed regular expression in the query.
matchesTags_ :: Regexp -> Maybe Regexp -> [Tag] -> Either RegexError Bool
matchesTags_ namepat valuepat tags =
sequence (map (match namepat valuepat) tags) >>= pure.or
where
match npat Nothing (n,_) = regexMatchesCI_ npat (T.unpack n) -- XXX
match npat (Just vpat) (n,v) =
sequence [regexMatchesCI_ npat (T.unpack n), regexMatchesCI_ vpat (T.unpack v)] >>= pure.and
-- | Does the query match this market price ? -- | Does the query match this market price ?
matchesPriceDirective :: Query -> PriceDirective -> Bool matchesPriceDirective :: Query -> PriceDirective -> Bool
@ -768,40 +668,28 @@ matchesPriceDirective q@(Sym _) p = matchesCommodity q (pdcommodity p)
matchesPriceDirective (Date span) p = spanContainsDate span (pddate p) matchesPriceDirective (Date span) p = spanContainsDate span (pddate p)
matchesPriceDirective _ _ = True matchesPriceDirective _ _ = True
-- | Total version of matchesPriceDirective, returning any error from
-- a malformed regular expression in the query.
matchesPriceDirective_ :: Query -> PriceDirective -> Either RegexError Bool
matchesPriceDirective_ (None) _ = Right False
matchesPriceDirective_ (Not q) p = not <$> matchesPriceDirective_ q p
matchesPriceDirective_ (Or qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.or
matchesPriceDirective_ (And qs) p = sequence (map (`matchesPriceDirective_` p) qs) >>= pure.and
matchesPriceDirective_ q@(Amt _ _) p = matchesAmount_ q (pdamount p)
matchesPriceDirective_ q@(Sym _) p = matchesCommodity_ q (pdcommodity p)
matchesPriceDirective_ (Date span) p = Right $ spanContainsDate span (pddate p)
matchesPriceDirective_ _ _ = Right True
-- tests -- tests
tests_Query = tests "Query" [ tests_Query = tests "Query" [
test "simplifyQuery" $ do test "simplifyQuery" $ do
(simplifyQuery $ Or [Acct "a"]) @?= (Acct "a") (simplifyQuery $ Or [Acct $ toRegex' "a"]) @?= (Acct $ toRegex' "a")
(simplifyQuery $ Or [Any,None]) @?= (Any) (simplifyQuery $ Or [Any,None]) @?= (Any)
(simplifyQuery $ And [Any,None]) @?= (None) (simplifyQuery $ And [Any,None]) @?= (None)
(simplifyQuery $ And [Any,Any]) @?= (Any) (simplifyQuery $ And [Any,Any]) @?= (Any)
(simplifyQuery $ And [Acct "b",Any]) @?= (Acct "b") (simplifyQuery $ And [Acct $ toRegex' "b",Any]) @?= (Acct $ toRegex' "b")
(simplifyQuery $ And [Any,And [Date (DateSpan Nothing Nothing)]]) @?= (Any) (simplifyQuery $ And [Any,And [Date (DateSpan Nothing Nothing)]]) @?= (Any)
(simplifyQuery $ And [Date (DateSpan Nothing (Just $ fromGregorian 2013 01 01)), Date (DateSpan (Just $ fromGregorian 2012 01 01) Nothing)]) (simplifyQuery $ And [Date (DateSpan Nothing (Just $ fromGregorian 2013 01 01)), Date (DateSpan (Just $ fromGregorian 2012 01 01) Nothing)])
@?= (Date (DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01))) @?= (Date (DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01)))
(simplifyQuery $ And [Or [],Or [Desc "b b"]]) @?= (Desc "b b") (simplifyQuery $ And [Or [],Or [Desc $ toRegex' "b b"]]) @?= (Desc $ toRegex' "b b")
,test "parseQuery" $ do ,test "parseQuery" $ do
(parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") @?= Right (And [Acct "expenses:autres d\233penses", Desc "b"], []) (parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") @?= Right (And [Acct $ toRegexCI' "expenses:autres d\233penses", Desc $ toRegexCI' "b"], [])
parseQuery nulldate "inacct:a desc:\"b b\"" @?= Right (Desc "b b", [QueryOptInAcct "a"]) parseQuery nulldate "inacct:a desc:\"b b\"" @?= Right (Desc $ toRegexCI' "b b", [QueryOptInAcct "a"])
parseQuery nulldate "inacct:a inacct:b" @?= Right (Any, [QueryOptInAcct "a", QueryOptInAcct "b"]) parseQuery nulldate "inacct:a inacct:b" @?= Right (Any, [QueryOptInAcct "a", QueryOptInAcct "b"])
parseQuery nulldate "desc:'x x'" @?= Right (Desc "x x", []) parseQuery nulldate "desc:'x x'" @?= Right (Desc $ toRegexCI' "x x", [])
parseQuery nulldate "'a a' 'b" @?= Right (Or [Acct "a a",Acct "'b"], []) parseQuery nulldate "'a a' 'b" @?= Right (Or [Acct $ toRegexCI' "a a",Acct $ toRegexCI' "'b"], [])
parseQuery nulldate "\"" @?= Right (Acct "\"", []) parseQuery nulldate "\"" @?= Right (Acct $ toRegexCI' "\"", [])
,test "words''" $ do ,test "words''" $ do
(words'' [] "a b") @?= ["a","b"] (words'' [] "a b") @?= ["a","b"]
@ -820,23 +708,23 @@ tests_Query = tests "Query" [
filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) @?= Any -- XXX unclear filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) @?= Any -- XXX unclear
,test "parseQueryTerm" $ do ,test "parseQueryTerm" $ do
parseQueryTerm nulldate "a" @?= Right (Left $ Acct "a") parseQueryTerm nulldate "a" @?= Right (Left $ Acct $ toRegexCI' "a")
parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Left $ Acct "expenses:autres d\233penses") parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Left $ Acct $ toRegexCI' "expenses:autres d\233penses")
parseQueryTerm nulldate "not:desc:a b" @?= Right (Left $ Not $ Desc "a b") parseQueryTerm nulldate "not:desc:a b" @?= Right (Left $ Not $ Desc $ toRegexCI' "a b")
parseQueryTerm nulldate "status:1" @?= Right (Left $ StatusQ Cleared) parseQueryTerm nulldate "status:1" @?= Right (Left $ StatusQ Cleared)
parseQueryTerm nulldate "status:*" @?= Right (Left $ StatusQ Cleared) parseQueryTerm nulldate "status:*" @?= Right (Left $ StatusQ Cleared)
parseQueryTerm nulldate "status:!" @?= Right (Left $ StatusQ Pending) parseQueryTerm nulldate "status:!" @?= Right (Left $ StatusQ Pending)
parseQueryTerm nulldate "status:0" @?= Right (Left $ StatusQ Unmarked) parseQueryTerm nulldate "status:0" @?= Right (Left $ StatusQ Unmarked)
parseQueryTerm nulldate "status:" @?= Right (Left $ StatusQ Unmarked) parseQueryTerm nulldate "status:" @?= Right (Left $ StatusQ Unmarked)
parseQueryTerm nulldate "payee:x" @?= Right (Left $ Tag "payee" (Just "x")) parseQueryTerm nulldate "payee:x" @?= Left <$> payeeTag (Just "x")
parseQueryTerm nulldate "note:x" @?= Right (Left $ Tag "note" (Just "x")) parseQueryTerm nulldate "note:x" @?= Left <$> noteTag (Just "x")
parseQueryTerm nulldate "real:1" @?= Right (Left $ Real True) parseQueryTerm nulldate "real:1" @?= Right (Left $ Real True)
parseQueryTerm nulldate "date:2008" @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2008 01 01) (Just $ fromGregorian 2009 01 01)) parseQueryTerm nulldate "date:2008" @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2008 01 01) (Just $ fromGregorian 2009 01 01))
parseQueryTerm nulldate "date:from 2012/5/17" @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2012 05 17) Nothing) parseQueryTerm nulldate "date:from 2012/5/17" @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2012 05 17) Nothing)
parseQueryTerm nulldate "date:20180101-201804" @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 04 01)) parseQueryTerm nulldate "date:20180101-201804" @?= Right (Left $ Date $ DateSpan (Just $ fromGregorian 2018 01 01) (Just $ fromGregorian 2018 04 01))
parseQueryTerm nulldate "inacct:a" @?= Right (Right $ QueryOptInAcct "a") parseQueryTerm nulldate "inacct:a" @?= Right (Right $ QueryOptInAcct "a")
parseQueryTerm nulldate "tag:a" @?= Right (Left $ Tag "a" Nothing) parseQueryTerm nulldate "tag:a" @?= Right (Left $ Tag (toRegexCI' "a") Nothing)
parseQueryTerm nulldate "tag:a=some value" @?= Right (Left $ Tag "a" (Just "some value")) parseQueryTerm nulldate "tag:a=some value" @?= Right (Left $ Tag (toRegexCI' "a") (Just $ toRegexCI' "some value"))
parseQueryTerm nulldate "amt:<0" @?= Right (Left $ Amt Lt 0) parseQueryTerm nulldate "amt:<0" @?= Right (Left $ Amt Lt 0)
parseQueryTerm nulldate "amt:>10000.10" @?= Right (Left $ Amt AbsGt 10000.1) parseQueryTerm nulldate "amt:>10000.10" @?= Right (Left $ Amt AbsGt 10000.1)
@ -869,14 +757,14 @@ tests_Query = tests "Query" [
queryEndDate False (Or [Date $ DateSpan Nothing small, Date $ DateSpan Nothing Nothing]) @?= Nothing queryEndDate False (Or [Date $ DateSpan Nothing small, Date $ DateSpan Nothing Nothing]) @?= Nothing
,test "matchesAccount" $ do ,test "matchesAccount" $ do
assertBool "" $ (Acct "b:c") `matchesAccount` "a:bb:c:d" assertBool "" $ (Acct $ toRegex' "b:c") `matchesAccount` "a:bb:c:d"
assertBool "" $ not $ (Acct "^a:b") `matchesAccount` "c:a:b" assertBool "" $ not $ (Acct $ toRegex' "^a:b") `matchesAccount` "c:a:b"
assertBool "" $ Depth 2 `matchesAccount` "a" assertBool "" $ Depth 2 `matchesAccount` "a"
assertBool "" $ Depth 2 `matchesAccount` "a:b" assertBool "" $ Depth 2 `matchesAccount` "a:b"
assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c" assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c"
assertBool "" $ Date nulldatespan `matchesAccount` "a" assertBool "" $ Date nulldatespan `matchesAccount` "a"
assertBool "" $ Date2 nulldatespan `matchesAccount` "a" assertBool "" $ Date2 nulldatespan `matchesAccount` "a"
assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a" assertBool "" $ not $ Tag (toRegex' "a") Nothing `matchesAccount` "a"
,tests "matchesPosting" [ ,tests "matchesPosting" [
test "positive match on cleared posting status" $ test "positive match on cleared posting status" $
@ -892,32 +780,33 @@ tests_Query = tests "Query" [
,test "real:1 on real posting" $ assertBool "" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting} ,test "real:1 on real posting" $ assertBool "" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting}
,test "real:1 on virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting} ,test "real:1 on virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting}
,test "real:1 on balanced virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting} ,test "real:1 on balanced virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}
,test "acct:" $ assertBool "" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"} ,test "acct:" $ assertBool "" $ (Acct $ toRegex' "'b") `matchesPosting` nullposting{paccount="'b"}
,test "tag:" $ do ,test "tag:" $ do
assertBool "" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting assertBool "" $ not $ (Tag (toRegex' "a") (Just $ toRegex' "r$")) `matchesPosting` nullposting
assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}
assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}
assertBool "" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
assertBool "" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ not $ (Tag (toRegex' "foo") (Just $ toRegex' "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
assertBool "" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ not $ (Tag (toRegex' " foo ") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
assertBool "" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]} assertBool "" $ not $ (Tag (toRegex' "foo foo") (Just $ toRegex' " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]}
,test "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} ,test "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag (toRegex' "txntag") Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}
,test "cur:" $ do ,test "cur:" $ do
assertBool "" $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol let toSym = either id (const $ error' "No query opts") . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>)
assertBool "" $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr assertBool "" $ not $ toSym "$" `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol
assertBool "" $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} assertBool "" $ (toSym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr
assertBool "" $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} assertBool "" $ (toSym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
assertBool "" $ not $ (toSym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
] ]
,test "matchesTransaction" $ do ,test "matchesTransaction" $ do
assertBool "" $ Any `matchesTransaction` nulltransaction assertBool "" $ Any `matchesTransaction` nulltransaction
assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"} assertBool "" $ not $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x"}
assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"} assertBool "" $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x x"}
-- see posting for more tag tests -- see posting for more tag tests
assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]} assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}
assertBool "" $ (Tag "payee" (Just "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"} assertBool "" $ (Tag (toRegex' "payee") (Just $ toRegex' "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"}
assertBool "" $ (Tag "note" (Just "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"} assertBool "" $ (Tag (toRegex' "note") (Just $ toRegex' "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"}
-- a tag match on a transaction also matches posting tags -- a tag match on a transaction also matches posting tags
assertBool "" $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]} assertBool "" $ (Tag (toRegex' "postingtag") Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}
] ]

22
hledger-lib/Hledger/Read/Common.hs
View File

@ -14,7 +14,6 @@ Some of these might belong in Hledger.Read.JournalReader or Hledger.Read.
--- ** language --- ** language
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
@ -116,32 +115,33 @@ where
--- ** imports --- ** imports
import Prelude () import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (fail, readFile) import "base-compat-batteries" Prelude.Compat hiding (fail, readFile)
import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)
import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail) import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail)
import Control.Monad.Except (ExceptT(..), runExceptT, throwError) import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
import Control.Monad.State.Strict hiding (fail) import Control.Monad.State.Strict hiding (fail)
import Data.Bifunctor (bimap, second) import Data.Bifunctor (bimap, second)
import Data.Char import Data.Char (digitToInt, isDigit, isSpace)
import Data.Data
import Data.Decimal (DecimalRaw (Decimal), Decimal) import Data.Decimal (DecimalRaw (Decimal), Decimal)
import Data.Default import Data.Default (Default(..))
import Data.Function ((&)) import Data.Function ((&))
import Data.Functor.Identity import Data.Functor.Identity (Identity)
import "base-compat-batteries" Data.List.Compat import "base-compat-batteries" Data.List.Compat
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe)
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Semigroup as Sem import qualified Data.Semigroup as Sem
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar (Day, fromGregorianValid, toGregorian)
import Data.Time.LocalTime import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..))
import Data.Word (Word8) import Data.Word (Word8)
import System.Time (getClockTime) import System.Time (getClockTime)
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char (char, char', digitChar, newline, string)
import Text.Megaparsec.Char.Lexer (decimal) import Text.Megaparsec.Char.Lexer (decimal)
import Text.Megaparsec.Custom import Text.Megaparsec.Custom
import Control.Applicative.Permutations (FinalParseError, attachSource, customErrorBundlePretty,
finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)
import Hledger.Data import Hledger.Data
import Hledger.Utils import Hledger.Utils
@ -194,7 +194,7 @@ data InputOpts = InputOpts {
,new_save_ :: Bool -- ^ save latest new transactions state for next time ,new_save_ :: Bool -- ^ save latest new transactions state for next time
,pivot_ :: String -- ^ use the given field's value as the account name ,pivot_ :: String -- ^ use the given field's value as the account name
,auto_ :: Bool -- ^ generate automatic postings when journal is parsed ,auto_ :: Bool -- ^ generate automatic postings when journal is parsed
} deriving (Show, Data) --, Typeable) } deriving (Show)
instance Default InputOpts where def = definputopts instance Default InputOpts where def = definputopts

80
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -41,19 +41,21 @@ where
--- ** imports --- ** imports
import Prelude () import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (fail) import "base-compat-batteries" Prelude.Compat hiding (fail)
import Control.Applicative (liftA2)
import Control.Exception (IOException, handle, throw) import Control.Exception (IOException, handle, throw)
import Control.Monad (liftM, unless, when) import Control.Monad (liftM, unless, when)
import Control.Monad.Except (ExceptT, throwError) import Control.Monad.Except (ExceptT, throwError)
import qualified Control.Monad.Fail as Fail
import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Strict (StateT, get, modify', evalStateT) import Control.Monad.State.Strict (StateT, get, modify', evalStateT)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Data.Char (toLower, isDigit, isSpace, isAlphaNum, ord) import Data.Char (toLower, isDigit, isSpace, isAlphaNum, isAscii, ord)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import "base-compat-batteries" Data.List.Compat import "base-compat-batteries" Data.List.Compat
import qualified Data.List.Split as LS (splitOn) import qualified Data.List.Split as LS (splitOn)
import Data.Maybe import Data.Maybe (catMaybes, fromMaybe, isJust)
import Data.MemoUgly (memo) import Data.MemoUgly (memo)
import Data.Ord import Data.Ord (comparing)
import qualified Data.Set as S import qualified Data.Set as S
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -61,17 +63,17 @@ import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Data.Time.Format (parseTimeM, defaultTimeLocale) import Data.Time.Format (parseTimeM, defaultTimeLocale)
import Safe import Safe (atMay, headMay, lastMay, readDef, readMay)
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.FilePath import System.FilePath ((</>), takeDirectory, takeExtension, takeFileName)
import qualified Data.Csv as Cassava import qualified Data.Csv as Cassava
import qualified Data.Csv.Parser.Megaparsec as CassavaMP import qualified Data.Csv.Parser.Megaparsec as CassavaMP
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Foldable import Data.Foldable (asum, toList)
import Text.Megaparsec hiding (parse) import Text.Megaparsec hiding (match, parse)
import Text.Megaparsec.Char import Text.Megaparsec.Char (char, newline, string)
import Text.Megaparsec.Custom import Text.Megaparsec.Custom (customErrorBundlePretty, parseErrorAt)
import Text.Printf (printf) import Text.Printf (printf)
import Hledger.Data import Hledger.Data
@ -294,17 +296,14 @@ type FieldTemplate = String
-- | A strptime date parsing pattern, as supported by Data.Time.Format. -- | A strptime date parsing pattern, as supported by Data.Time.Format.
type DateFormat = String type DateFormat = String
-- | A regular expression.
type RegexpPattern = String
-- | A prefix for a matcher test, either & or none (implicit or). -- | A prefix for a matcher test, either & or none (implicit or).
data MatcherPrefix = And | None data MatcherPrefix = And | None
deriving (Show, Eq) deriving (Show, Eq)
-- | A single test for matching a CSV record, in one way or another. -- | A single test for matching a CSV record, in one way or another.
data Matcher = data Matcher =
RecordMatcher MatcherPrefix RegexpPattern -- ^ match if this regexp matches the overall CSV record RecordMatcher MatcherPrefix Regexp -- ^ match if this regexp matches the overall CSV record
| FieldMatcher MatcherPrefix CsvFieldReference RegexpPattern -- ^ match if this regexp matches the referenced CSV field's value | FieldMatcher MatcherPrefix CsvFieldReference Regexp -- ^ match if this regexp matches the referenced CSV field's value
deriving (Show, Eq) deriving (Show, Eq)
-- | A conditional block: a set of CSV record matchers, and a sequence -- | A conditional block: a set of CSV record matchers, and a sequence
@ -617,9 +616,9 @@ recordmatcherp end = do
-- _ <- optional (matchoperatorp >> lift skipNonNewlineSpaces >> optional newline) -- _ <- optional (matchoperatorp >> lift skipNonNewlineSpaces >> optional newline)
p <- matcherprefixp p <- matcherprefixp
r <- regexp end r <- regexp end
return $ RecordMatcher p r
-- when (null ps) $ -- when (null ps) $
-- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n" -- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"
return $ RecordMatcher p r
<?> "record matcher" <?> "record matcher"
-- | A single matcher for a specific field. A csv field reference -- | A single matcher for a specific field. A csv field reference
@ -656,13 +655,15 @@ csvfieldreferencep = do
return $ '%' : quoteIfNeeded f return $ '%' : quoteIfNeeded f
-- A single regular expression -- A single regular expression
regexp :: CsvRulesParser () -> CsvRulesParser RegexpPattern regexp :: CsvRulesParser () -> CsvRulesParser Regexp
regexp end = do regexp end = do
lift $ dbgparse 8 "trying regexp" lift $ dbgparse 8 "trying regexp"
-- notFollowedBy matchoperatorp -- notFollowedBy matchoperatorp
c <- lift nonspace c <- lift nonspace
cs <- anySingle `manyTill` end cs <- anySingle `manyTill` end
return $ strip $ c:cs case toRegexCI . strip $ c:cs of
Left x -> Fail.fail $ "CSV parser: " ++ x
Right x -> return x
-- -- A match operator, indicating the type of match to perform. -- -- A match operator, indicating the type of match to perform.
-- -- Currently just ~ meaning case insensitive infix regex match. -- -- Currently just ~ meaning case insensitive infix regex match.
@ -834,10 +835,9 @@ validateCsv rules numhdrlines (Right rs) = validate $ applyConditionalSkips $ dr
Nothing -> r:(applyConditionalSkips rest) Nothing -> r:(applyConditionalSkips rest)
Just cnt -> applyConditionalSkips (drop (cnt-1) rest) Just cnt -> applyConditionalSkips (drop (cnt-1) rest)
validate [] = Right [] validate [] = Right []
validate rs@(_first:_) validate rs@(_first:_) = case lessthan2 of
| isJust lessthan2 = let r = fromJust lessthan2 in Just r -> Left $ printf "CSV record %s has less than two fields" (show r)
Left $ printf "CSV record %s has less than two fields" (show r) Nothing -> Right rs
| otherwise = Right rs
where where
lessthan2 = headMay $ filter ((<2).length) rs lessthan2 = headMay $ filter ((<2).length) rs
@ -1181,7 +1181,7 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
where where
-- does this individual matcher match the current csv record ? -- does this individual matcher match the current csv record ?
matcherMatches :: Matcher -> Bool matcherMatches :: Matcher -> Bool
matcherMatches (RecordMatcher _ pat) = regexMatchesCI pat' wholecsvline matcherMatches (RecordMatcher _ pat) = regexMatch pat' wholecsvline
where where
pat' = dbg7 "regex" pat pat' = dbg7 "regex" pat
-- A synthetic whole CSV record to match against. Note, this can be -- A synthetic whole CSV record to match against. Note, this can be
@ -1191,7 +1191,7 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
-- - and the field separator is always comma -- - and the field separator is always comma
-- which means that a field containing a comma will look like two fields. -- which means that a field containing a comma will look like two fields.
wholecsvline = dbg7 "wholecsvline" $ intercalate "," record wholecsvline = dbg7 "wholecsvline" $ intercalate "," record
matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatchesCI pat csvfieldvalue matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatch pat csvfieldvalue
where where
-- the value of the referenced CSV field to match against. -- the value of the referenced CSV field to match against.
csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref
@ -1199,7 +1199,13 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
-- | Render a field assignment's template, possibly interpolating referenced -- | Render a field assignment's template, possibly interpolating referenced
-- CSV field values. Outer whitespace is removed from interpolated values. -- CSV field values. Outer whitespace is removed from interpolated values.
renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String
renderTemplate rules record t = regexReplaceBy "%[A-z0-9_-]+" (replaceCsvFieldReference rules record) t renderTemplate rules record t = maybe t concat $ parseMaybe
(many $ takeWhile1P Nothing (/='%')
<|> replaceCsvFieldReference rules record <$> referencep)
t
where
referencep = liftA2 (:) (char '%') (takeWhile1P (Just "reference") isDescriptorChar) :: Parsec CustomErr String String
isDescriptorChar c = isAscii c && (isAlphaNum c || c == '_' || c == '-')
-- | Replace something that looks like a reference to a csv field ("%date" or "%1) -- | Replace something that looks like a reference to a csv field ("%date" or "%1)
-- with that field's value. If it doesn't look like a field reference, or if we -- with that field's value. If it doesn't look like a field reference, or if we
@ -1256,12 +1262,12 @@ tests_CsvReader = tests "CsvReader" [
,test "assignment with empty value" $ ,test "assignment with empty value" $
parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?= parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?=
(Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher None "foo"],cbAssignments=[("account2","foo")]}]})) (Right (mkrules $ defrules{rassignments = [("account1","")], rconditionalblocks = [CB{cbMatchers=[RecordMatcher None (toRegex' "foo")],cbAssignments=[("account2","foo")]}]}))
] ]
,tests "conditionalblockp" [ ,tests "conditionalblockp" [
test "space after conditional" $ -- #1120 test "space after conditional" $ -- #1120
parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?= parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?=
(Right $ CB{cbMatchers=[RecordMatcher None "a"],cbAssignments=[("account2","b")]}) (Right $ CB{cbMatchers=[RecordMatcher None $ toRegexCI' "a"],cbAssignments=[("account2","b")]})
,tests "csvfieldreferencep" [ ,tests "csvfieldreferencep" [
test "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1") test "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1")
@ -1272,19 +1278,19 @@ tests_CsvReader = tests "CsvReader" [
,tests "matcherp" [ ,tests "matcherp" [
test "recordmatcherp" $ test "recordmatcherp" $
parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None "A A") parseWithState' defrules matcherp "A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "A A")
,test "recordmatcherp.starts-with-&" $ ,test "recordmatcherp.starts-with-&" $
parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And "A A") parseWithState' defrules matcherp "& A A\n" @?= (Right $ RecordMatcher And $ toRegexCI' "A A")
,test "fieldmatcherp.starts-with-%" $ ,test "fieldmatcherp.starts-with-%" $
parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher None "description A A") parseWithState' defrules matcherp "description A A\n" @?= (Right $ RecordMatcher None $ toRegexCI' "description A A")
,test "fieldmatcherp" $ ,test "fieldmatcherp" $
parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" "A A") parseWithState' defrules matcherp "%description A A\n" @?= (Right $ FieldMatcher None "%description" $ toRegexCI' "A A")
,test "fieldmatcherp.starts-with-&" $ ,test "fieldmatcherp.starts-with-&" $
parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" "A A") parseWithState' defrules matcherp "& %description A A\n" @?= (Right $ FieldMatcher And "%description" $ toRegexCI' "A A")
-- ,test "fieldmatcherp with operator" $ -- ,test "fieldmatcherp with operator" $
-- parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A") -- parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A")
@ -1293,22 +1299,22 @@ tests_CsvReader = tests "CsvReader" [
,tests "getEffectiveAssignment" [ ,tests "getEffectiveAssignment" [
let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]} let rules = mkrules $ defrules {rcsvfieldindexes=[("csvdate",1)],rassignments=[("date","%csvdate")]}
in test "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") in test "toplevel" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a"] [("date","%csvdate")]]} ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a"] [("date","%csvdate")]]}
in test "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate") in test "conditional" $ getEffectiveAssignment rules ["a","b"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a", FieldMatcher None "%description" "b"] [("date","%csvdate")]]} ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}
in test "conditional-with-or-a" $ getEffectiveAssignment rules ["a"] "date" @?= (Just "%csvdate") in test "conditional-with-or-a" $ getEffectiveAssignment rules ["a"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a", FieldMatcher None "%description" "b"] [("date","%csvdate")]]} ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher None "%description" $ toRegex' "b"] [("date","%csvdate")]]}
in test "conditional-with-or-b" $ getEffectiveAssignment rules ["_", "b"] "date" @?= (Just "%csvdate") in test "conditional-with-or-b" $ getEffectiveAssignment rules ["_", "b"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a", FieldMatcher And "%description" "b"] [("date","%csvdate")]]} ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b"] [("date","%csvdate")]]}
in test "conditional.with-and" $ getEffectiveAssignment rules ["a", "b"] "date" @?= (Just "%csvdate") in test "conditional.with-and" $ getEffectiveAssignment rules ["a", "b"] "date" @?= (Just "%csvdate")
,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" "a", FieldMatcher And "%description" "b", FieldMatcher None "%description" "c"] [("date","%csvdate")]]} ,let rules = mkrules $ defrules{rcsvfieldindexes=[("csvdate",1),("description",2)], rconditionalblocks=[CB [FieldMatcher None "%csvdate" $ toRegex' "a", FieldMatcher And "%description" $ toRegex' "b", FieldMatcher None "%description" $ toRegex' "c"] [("date","%csvdate")]]}
in test "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate") in test "conditional.with-and-or" $ getEffectiveAssignment rules ["_", "c"] "date" @?= (Just "%csvdate")
] ]

4
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -529,8 +529,8 @@ regexaliasp = do
char '=' char '='
skipNonNewlineSpaces skipNonNewlineSpaces
repl <- anySingle `manyTill` eolof repl <- anySingle `manyTill` eolof
case toRegex_ re of case toRegexCI re of
Right _ -> return $! RegexAlias re repl Right r -> return $! RegexAlias r repl
Left e -> customFailure $! parseErrorAtRegion off1 off2 e Left e -> customFailure $! parseErrorAtRegion off1 off2 e
endaliasesdirectivep :: JournalParser m () endaliasesdirectivep :: JournalParser m ()

2
hledger-lib/Hledger/Reports.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}
{-| {-|
Generate several common kinds of report from a journal, as \"*Report\" - Generate several common kinds of report from a journal, as \"*Report\" -

2
hledger-lib/Hledger/Reports/AccountTransactionsReport.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}
{-| {-|
An account-centric transactions report. An account-centric transactions report.

4
hledger-lib/Hledger/Reports/EntriesReport.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances, ScopedTypeVariables #-}
{-| {-|
Journal entries report, used by the print command. Journal entries report, used by the print command.
@ -50,7 +50,7 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
tests_EntriesReport = tests "EntriesReport" [ tests_EntriesReport = tests "EntriesReport" [
tests "entriesReport" [ tests "entriesReport" [
test "not acct" $ (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal) @?= 1 test "not acct" $ (length $ entriesReport defreportopts (Not . Acct $ toRegex' "bank") samplejournal) @?= 1
,test "date" $ (length $ entriesReport defreportopts (Date $ DateSpan (Just $ fromGregorian 2008 06 01) (Just $ fromGregorian 2008 07 01)) samplejournal) @?= 3 ,test "date" $ (length $ entriesReport defreportopts (Date $ DateSpan (Just $ fromGregorian 2008 06 01) (Just $ fromGregorian 2008 07 01)) samplejournal) @?= 3
] ]
] ]

9
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -4,7 +4,6 @@ Postings report, used by the register command.
-} -}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -277,13 +276,13 @@ tests_PostingsReport = tests "PostingsReport" [
(Any, samplejournal) `gives` 13 (Any, samplejournal) `gives` 13
-- register --depth just clips account names -- register --depth just clips account names
(Depth 2, samplejournal) `gives` 13 (Depth 2, samplejournal) `gives` 13
(And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2 (And [Depth 1, StatusQ Cleared, Acct (toRegex' "expenses")], samplejournal) `gives` 2
(And [And [Depth 1, StatusQ Cleared], Acct "expenses"], samplejournal) `gives` 2 (And [And [Depth 1, StatusQ Cleared], Acct (toRegex' "expenses")], samplejournal) `gives` 2
-- with query and/or command-line options -- with query and/or command-line options
(length $ snd $ postingsReport defreportopts Any samplejournal) @?= 13 (length $ snd $ postingsReport defreportopts Any samplejournal) @?= 13
(length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal) @?= 11 (length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal) @?= 11
(length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) @?= 20 (length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) @?= 20
(length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) @?= 5 (length $ snd $ postingsReport defreportopts (Acct (toRegex' "assets:bank:checking")) samplejournal) @?= 5
-- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0 -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0
-- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking $1,$1) -- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking $1,$1)
@ -374,7 +373,7 @@ tests_PostingsReport = tests "PostingsReport" [
j <- samplejournal j <- samplejournal
let gives displayexpr = let gives displayexpr =
(registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`) (registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`)
where opts = defreportopts{display_=Just displayexpr} where opts = defreportopts
"d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"] "d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"]
"d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"] "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"]
"d=[2008/6/2]" `gives` ["2008/06/02"] "d=[2008/6/2]" `gives` ["2008/06/02"]

38
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -4,7 +4,6 @@ Options common to most hledger reports.
-} -}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -49,14 +48,12 @@ module Hledger.Reports.ReportOptions (
where where
import Control.Applicative ((<|>)) import Control.Applicative ((<|>))
import Data.Data (Data)
import Data.List.Extra (nubSort) import Data.List.Extra (nubSort)
import Data.Maybe import Data.Maybe (fromMaybe, isJust)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Typeable (Typeable) import Data.Time.Calendar (Day, addDays, fromGregorian)
import Data.Time.Calendar import Data.Default (Default(..))
import Data.Default import Safe (lastDef, lastMay)
import Safe
import System.Console.ANSI (hSupportsANSIColor) import System.Console.ANSI (hSupportsANSIColor)
import System.Environment (lookupEnv) import System.Environment (lookupEnv)
@ -76,12 +73,12 @@ data BalanceType = PeriodChange -- ^ The change of balance in each period.
| HistoricalBalance -- ^ The historical ending balance, including the effect of | HistoricalBalance -- ^ The historical ending balance, including the effect of
-- all postings before the report period. Unless altered by, -- all postings before the report period. Unless altered by,
-- a query, this is what you would see on a bank statement. -- a query, this is what you would see on a bank statement.
deriving (Eq,Show,Data,Typeable) deriving (Eq,Show)
instance Default BalanceType where def = PeriodChange instance Default BalanceType where def = PeriodChange
-- | Should accounts be displayed: in the command's default style, hierarchically, or as a flat list ? -- | Should accounts be displayed: in the command's default style, hierarchically, or as a flat list ?
data AccountListMode = ALFlat | ALTree deriving (Eq, Show, Data, Typeable) data AccountListMode = ALFlat | ALTree deriving (Eq, Show)
instance Default AccountListMode where def = ALFlat instance Default AccountListMode where def = ALFlat
@ -101,7 +98,6 @@ data ReportOpts = ReportOpts {
,value_ :: Maybe ValuationType -- ^ What value should amounts be converted to ? ,value_ :: Maybe ValuationType -- ^ What value should amounts be converted to ?
,infer_value_ :: Bool -- ^ Infer market prices from transactions ? ,infer_value_ :: Bool -- ^ Infer market prices from transactions ?
,depth_ :: Maybe Int ,depth_ :: Maybe Int
,display_ :: Maybe DisplayExp -- XXX unused ?
,date2_ :: Bool ,date2_ :: Bool
,empty_ :: Bool ,empty_ :: Bool
,no_elide_ :: Bool ,no_elide_ :: Bool
@ -140,7 +136,7 @@ data ReportOpts = ReportOpts {
-- TERM and existence of NO_COLOR environment variables. -- TERM and existence of NO_COLOR environment variables.
,forecast_ :: Maybe DateSpan ,forecast_ :: Maybe DateSpan
,transpose_ :: Bool ,transpose_ :: Bool
} deriving (Show, Data, Typeable) } deriving (Show)
instance Default ReportOpts where def = defreportopts instance Default ReportOpts where def = defreportopts
@ -175,7 +171,6 @@ defreportopts = ReportOpts
def def
def def
def def
def
rawOptsToReportOpts :: RawOpts -> IO ReportOpts rawOptsToReportOpts :: RawOpts -> IO ReportOpts
rawOptsToReportOpts rawopts = checkReportOpts <$> do rawOptsToReportOpts rawopts = checkReportOpts <$> do
@ -192,7 +187,6 @@ rawOptsToReportOpts rawopts = checkReportOpts <$> do
,value_ = valuationTypeFromRawOpts rawopts' ,value_ = valuationTypeFromRawOpts rawopts'
,infer_value_ = boolopt "infer-value" rawopts' ,infer_value_ = boolopt "infer-value" rawopts'
,depth_ = maybeposintopt "depth" rawopts' ,depth_ = maybeposintopt "depth" rawopts'
,display_ = maybedisplayopt d rawopts'
,date2_ = boolopt "date2" rawopts' ,date2_ = boolopt "date2" rawopts'
,empty_ = boolopt "empty" rawopts' ,empty_ = boolopt "empty" rawopts'
,no_elide_ = boolopt "no-elide" rawopts' ,no_elide_ = boolopt "no-elide" rawopts'
@ -346,7 +340,7 @@ forecastPeriodFromRawOpts d opts =
Just str -> Just str ->
either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e) (Just . snd) $ either (\e -> usageError $ "could not parse forecast period : "++customErrorBundlePretty e) (Just . snd) $
parsePeriodExpr d $ stripquotes $ T.pack str parsePeriodExpr d $ stripquotes $ T.pack str
-- | Extract the interval from the parsed -p/--period expression. -- | Extract the interval from the parsed -p/--period expression.
-- Return Nothing if an interval is not explicitly defined. -- Return Nothing if an interval is not explicitly defined.
extractIntervalOrNothing :: (Interval, DateSpan) -> Maybe Interval extractIntervalOrNothing :: (Interval, DateSpan) -> Maybe Interval
@ -419,15 +413,6 @@ valuationTypeIsDefaultValue ropts =
Just (AtDefault _) -> True Just (AtDefault _) -> True
_ -> False _ -> False
type DisplayExp = String
maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp
maybedisplayopt d rawopts =
maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts
where
fixbracketeddatestr "" = ""
fixbracketeddatestr s = "[" ++ fixSmartDateStr d (T.pack $ init $ tail s) ++ "]"
-- | Select the Transaction date accessor based on --date2. -- | Select the Transaction date accessor based on --date2.
transactionDateFn :: ReportOpts -> (Transaction -> Day) transactionDateFn :: ReportOpts -> (Transaction -> Day)
transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate
@ -573,12 +558,12 @@ reportPeriodOrJournalLastDay ropts j =
tests_ReportOptions = tests "ReportOptions" [ tests_ReportOptions = tests "ReportOptions" [
test "queryFromOpts" $ do test "queryFromOpts" $ do
queryFromOpts nulldate defreportopts @?= Any queryFromOpts nulldate defreportopts @?= Any
queryFromOpts nulldate defreportopts{query_="a"} @?= Acct "a" queryFromOpts nulldate defreportopts{query_="a"} @?= Acct (toRegexCI' "a")
queryFromOpts nulldate defreportopts{query_="desc:'a a'"} @?= Desc "a a" queryFromOpts nulldate defreportopts{query_="desc:'a a'"} @?= Desc (toRegexCI' "a a")
queryFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01),query_="date:'to 2013'" } queryFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01),query_="date:'to 2013'" }
@?= (Date $ DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01)) @?= (Date $ DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01))
queryFromOpts nulldate defreportopts{query_="date2:'in 2012'"} @?= (Date2 $ DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01)) queryFromOpts nulldate defreportopts{query_="date2:'in 2012'"} @?= (Date2 $ DateSpan (Just $ fromGregorian 2012 01 01) (Just $ fromGregorian 2013 01 01))
queryFromOpts nulldate defreportopts{query_="'a a' 'b"} @?= Or [Acct "a a", Acct "'b"] queryFromOpts nulldate defreportopts{query_="'a a' 'b"} @?= Or [Acct $ toRegexCI' "a a", Acct $ toRegexCI' "'b"]
,test "queryOptsFromOpts" $ do ,test "queryOptsFromOpts" $ do
queryOptsFromOpts nulldate defreportopts @?= [] queryOptsFromOpts nulldate defreportopts @?= []
@ -586,4 +571,3 @@ tests_ReportOptions = tests "ReportOptions" [
queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01) queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01)
,query_="date:'to 2013'"} @?= [] ,query_="date:'to 2013'"} @?= []
] ]

2
hledger-lib/Hledger/Reports/TransactionsReport.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}
{-| {-|
A transactions report. Like an EntriesReport, but with more A transactions report. Like an EntriesReport, but with more

303
hledger-lib/Hledger/Utils/Regex.hs
View File

@ -1,4 +1,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-| {-|
Easy regular expression helpers, currently based on regex-tdfa. These should: Easy regular expression helpers, currently based on regex-tdfa. These should:
@ -26,14 +29,12 @@ functions have memoised variants (*Memo), which also trade space for time.
Currently two APIs are provided: Currently two APIs are provided:
- The old partial one which will call error on any problem (eg with malformed - The old partial one (with ' suffixes') which will call error on any problem
regexps). This comes from hledger's origin as a command-line tool. (eg with malformed regexps). This comes from hledger's origin as a
command-line tool.
- The new total one (with _ suffixes) which will return an error message. This - The new total one which will return an error message. This is better for
is better for long-running apps like hledger-web. long-running apps like hledger-web.
We are gradually replacing usage of the old API in hledger. Probably at some
point the suffixless names will be reclaimed for the new API.
Current limitations: Current limitations:
@ -42,48 +43,106 @@ Current limitations:
-} -}
module Hledger.Utils.Regex ( module Hledger.Utils.Regex (
-- * Regexp type and constructors
Regexp(reString)
,toRegex
,toRegexCI
,toRegex'
,toRegexCI'
-- * type aliases -- * type aliases
Regexp
,Replacement ,Replacement
,RegexError ,RegexError
-- * partial regex operations (may call error)
,regexMatches
,regexMatchesCI
,regexReplace
,regexReplaceCI
,regexReplaceMemo
,regexReplaceCIMemo
,regexReplaceBy
,regexReplaceByCI
-- * total regex operations -- * total regex operations
,regexMatches_ ,regexMatch
,regexMatchesCI_ ,regexReplace
,regexReplace_ ,regexReplaceUnmemo
,regexReplaceCI_ ,regexReplaceAllBy
,regexReplaceMemo_
,regexReplaceCIMemo_
,regexReplaceBy_
,regexReplaceByCI_
,toRegex_
) )
where where
import Control.Monad (foldM) import Control.Monad (foldM)
import Data.Array import Data.Aeson (ToJSON(..), Value(String))
import Data.Char import Data.Array ((!), elems, indices)
import Data.Char (isDigit)
import Data.List (foldl') import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Data.MemoUgly (memo) import Data.MemoUgly (memo)
import qualified Data.Text as T
import Text.Regex.TDFA ( import Text.Regex.TDFA (
Regex, CompOption(..), ExecOption(..), defaultCompOpt, defaultExecOpt, Regex, CompOption(..), defaultCompOpt, defaultExecOpt,
makeRegexOptsM, AllMatches(getAllMatches), match, (=~), MatchText makeRegexOptsM, AllMatches(getAllMatches), match, MatchText,
RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..)
) )
import Hledger.Utils.UTF8IOCompat (error') import Hledger.Utils.UTF8IOCompat (error')
-- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax. -- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax.
type Regexp = String data Regexp
= Regexp { reString :: String, reCompiled :: Regex }
| RegexpCI { reString :: String, reCompiled :: Regex }
instance Eq Regexp where
Regexp s1 _ == Regexp s2 _ = s1 == s2
RegexpCI s1 _ == RegexpCI s2 _ = s1 == s2
_ == _ = False
instance Ord Regexp where
Regexp s1 _ `compare` Regexp s2 _ = s1 `compare` s2
RegexpCI s1 _ `compare` RegexpCI s2 _ = s1 `compare` s2
Regexp _ _ `compare` RegexpCI _ _ = LT
RegexpCI _ _ `compare` Regexp _ _ = GT
instance Show Regexp where
showsPrec d r = showParen (d > app_prec) $ reCons . showsPrec (app_prec+1) (reString r)
where app_prec = 10
reCons = case r of Regexp _ _ -> showString "Regexp "
RegexpCI _ _ -> showString "RegexpCI "
instance Read Regexp where
readsPrec d r = readParen (d > app_prec) (\r -> [(toRegexCI' m,t) |
("RegexCI",s) <- lex r,
(m,t) <- readsPrec (app_prec+1) s]) r
++ readParen (d > app_prec) (\r -> [(toRegex' m, t) |
("Regex",s) <- lex r,
(m,t) <- readsPrec (app_prec+1) s]) r
where app_prec = 10
instance ToJSON Regexp where
toJSON (Regexp s _) = String . T.pack $ "Regexp " ++ s
toJSON (RegexpCI s _) = String . T.pack $ "RegexpCI " ++ s
instance RegexLike Regexp String where
matchOnce = matchOnce . reCompiled
matchAll = matchAll . reCompiled
matchCount = matchCount . reCompiled
matchTest = matchTest . reCompiled
matchAllText = matchAllText . reCompiled
matchOnceText = matchOnceText . reCompiled
instance RegexContext Regexp String String where
match = match . reCompiled
matchM = matchM . reCompiled
-- Convert a Regexp string to a compiled Regex, or return an error message.
toRegex :: String -> Either RegexError Regexp
toRegex = memo $ \s -> mkRegexErr s (Regexp s <$> makeRegexM s)
-- Like toRegex, but make a case-insensitive Regex.
toRegexCI :: String -> Either RegexError Regexp
toRegexCI = memo $ \s -> mkRegexErr s (RegexpCI s <$> makeRegexOptsM defaultCompOpt{caseSensitive=False} defaultExecOpt s)
-- | Make a nice error message for a regexp error.
mkRegexErr :: String -> Maybe a -> Either RegexError a
mkRegexErr s = maybe (Left errmsg) Right
where errmsg = "this regular expression could not be compiled: " ++ s
-- Convert a Regexp string to a compiled Regex, throw an error
toRegex' :: String -> Regexp
toRegex' = either error' id . toRegex
-- Like toRegex', but make a case-insensitive Regex.
toRegexCI' :: String -> Regexp
toRegexCI' = either error' id . toRegexCI
-- | A replacement pattern. May include numeric backreferences (\N). -- | A replacement pattern. May include numeric backreferences (\N).
type Replacement = String type Replacement = String
@ -91,143 +150,32 @@ type Replacement = String
-- | An regular expression compilation/processing error message. -- | An regular expression compilation/processing error message.
type RegexError = String type RegexError = String
--------------------------------------------------------------------------------
-- old partial functions -- PARTIAL:
-- regexMatch' :: RegexContext Regexp String a => Regexp -> String -> a
-- regexMatch' r s = s =~ (toRegex' r)
regexMatches :: Regexp -> String -> Bool
regexMatches = flip (=~)
regexMatchesCI :: Regexp -> String -> Bool
regexMatchesCI r = match (toRegexCI r)
-- | Replace all occurrences of the regexp with the replacement
-- pattern. The replacement pattern supports numeric backreferences
-- (\N) but no other RE syntax.
regexReplace :: Regexp -> Replacement -> String -> String
regexReplace re = replaceRegex (toRegex re)
regexReplaceCI :: Regexp -> Replacement -> String -> String
regexReplaceCI re = replaceRegex (toRegexCI re)
-- | A memoising version of regexReplace. Caches the result for each
-- search pattern, replacement pattern, target string tuple.
regexReplaceMemo :: Regexp -> Replacement -> String -> String
regexReplaceMemo re repl = memo (regexReplace re repl)
regexReplaceCIMemo :: Regexp -> Replacement -> String -> String
regexReplaceCIMemo re repl = memo (regexReplaceCI re repl)
-- | Replace all occurrences of the regexp, transforming each match with the given function.
regexReplaceBy :: Regexp -> (String -> String) -> String -> String
regexReplaceBy r = replaceAllBy (toRegex r)
regexReplaceByCI :: Regexp -> (String -> String) -> String -> String
regexReplaceByCI r = replaceAllBy (toRegexCI r)
-- helpers -- helpers
-- | Convert our string-based Regexp to a real Regex. -- | Test whether a Regexp matches a String. This is an alias for `matchTest` for consistent
-- Or if it's not well formed, call error with a "malformed regexp" message. -- naming.
toRegex :: Regexp -> Regex regexMatch :: Regexp -> String -> Bool
toRegex = memo (compileRegex defaultCompOpt defaultExecOpt) -- PARTIAL: regexMatch = matchTest
-- | Like toRegex but make a case-insensitive Regex.
toRegexCI :: Regexp -> Regex
toRegexCI = memo (compileRegex defaultCompOpt{caseSensitive=False} defaultExecOpt) -- PARTIAL:
compileRegex :: CompOption -> ExecOption -> Regexp -> Regex
compileRegex compopt execopt r =
fromMaybe
(error $ "this regular expression could not be compiled: " ++ show r) $ -- PARTIAL:
makeRegexOptsM compopt execopt r
replaceRegex :: Regex -> Replacement -> String -> String
replaceRegex re repl s = foldl (replaceMatch repl) s (reverse $ match re s :: [MatchText String])
where
replaceMatch :: Replacement -> String -> MatchText String -> String
replaceMatch replpat s matchgroups = pre ++ repl ++ post
where
((_,(off,len)):_) = elems matchgroups -- groups should have 0-based indexes, and there should always be at least one, since this is a match
(pre, post') = splitAt off s
post = drop len post'
repl = replaceAllBy (toRegex "\\\\[0-9]+") (lookupMatchGroup matchgroups) replpat
where
lookupMatchGroup :: MatchText String -> String -> String
lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s =
case read s of n | n `elem` indices grps -> fst (grps ! n)
-- PARTIAL:
_ -> error' $ "no match group exists for backreference \"\\"++s++"\""
lookupMatchGroup _ s = error' $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- new total functions -- new total functions
-- | Does this regexp match the given string ? -- | A memoising version of regexReplace. Caches the result for each
-- Or return an error if the regexp is malformed.
regexMatches_ :: Regexp -> String -> Either RegexError Bool
regexMatches_ r s = (`match` s) <$> toRegex_ r
-- | Like regexMatches_ but match case-insensitively.
regexMatchesCI_ :: Regexp -> String -> Either RegexError Bool
regexMatchesCI_ r s = (`match` s) <$> toRegexCI_ r
-- | Replace all occurrences of the regexp with the replacement
-- pattern, or return an error message. The replacement pattern
-- supports numeric backreferences (\N) but no other RE syntax.
regexReplace_ :: Regexp -> Replacement -> String -> Either RegexError String
regexReplace_ re repl s = toRegex_ re >>= \rx -> replaceRegex_ rx repl s
-- | Like regexReplace_ but match occurrences case-insensitively.
regexReplaceCI_ :: Regexp -> Replacement -> String -> Either RegexError String
regexReplaceCI_ re repl s = toRegexCI_ re >>= \rx -> replaceRegex_ rx repl s
-- | A memoising version of regexReplace_. Caches the result for each
-- search pattern, replacement pattern, target string tuple. -- search pattern, replacement pattern, target string tuple.
regexReplaceMemo_ :: Regexp -> Replacement -> String -> Either RegexError String regexReplace :: Regexp -> Replacement -> String -> Either RegexError String
regexReplaceMemo_ re repl = memo (regexReplace_ re repl) regexReplace re repl = memo $ regexReplaceUnmemo re repl
-- | Like regexReplaceMemo_ but match occurrences case-insensitively.
regexReplaceCIMemo_ :: Regexp -> Replacement -> String -> Either RegexError String
regexReplaceCIMemo_ re repl = memo (regexReplaceCI_ re repl)
-- | Replace all occurrences of the regexp, transforming each match
-- with the given function, or return an error message.
regexReplaceBy_ :: Regexp -> (String -> String) -> String -> Either RegexError String
regexReplaceBy_ r f s = toRegex_ r >>= \rx -> Right $ replaceAllBy rx f s
-- | Like regexReplaceBy_ but match occurrences case-insensitively.
regexReplaceByCI_ :: Regexp -> (String -> String) -> String -> Either RegexError String
regexReplaceByCI_ r f s = toRegexCI_ r >>= \rx -> Right $ replaceAllBy rx f s
-- helpers: -- helpers:
-- Convert a Regexp string to a compiled Regex, or return an error message.
toRegex_ :: Regexp -> Either RegexError Regex
toRegex_ = memo (compileRegex_ defaultCompOpt defaultExecOpt)
-- Like toRegex, but make a case-insensitive Regex.
toRegexCI_ :: Regexp -> Either RegexError Regex
toRegexCI_ = memo (compileRegex_ defaultCompOpt{caseSensitive=False} defaultExecOpt)
-- Compile a Regexp string to a Regex with the given options, or return an
-- error message if this fails.
compileRegex_ :: CompOption -> ExecOption -> Regexp -> Either RegexError Regex
compileRegex_ compopt execopt r =
maybe (Left $ "this regular expression could not be compiled: " ++ show r) Right $
makeRegexOptsM compopt execopt r
-- Replace this regular expression with this replacement pattern in this -- Replace this regular expression with this replacement pattern in this
-- string, or return an error message. -- string, or return an error message.
replaceRegex_ :: Regex -> Replacement -> String -> Either RegexError String regexReplaceUnmemo :: Regexp -> Replacement -> String -> Either RegexError String
replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s :: [MatchText String]) regexReplaceUnmemo re repl s = foldM (replaceMatch repl) s (reverse $ match (reCompiled re) s :: [MatchText String])
where where
-- Replace one match within the string with the replacement text -- Replace one match within the string with the replacement text
-- appropriate for this match. Or return an error message. -- appropriate for this match. Or return an error message.
replaceMatch_ :: Replacement -> String -> MatchText String -> Either RegexError String replaceMatch :: Replacement -> String -> MatchText String -> Either RegexError String
replaceMatch_ replpat s matchgroups = replaceMatch replpat s matchgroups =
erepl >>= \repl -> Right $ pre ++ repl ++ post erepl >>= \repl -> Right $ pre ++ repl ++ post
where where
((_,(off,len)):_) = elems matchgroups -- groups should have 0-based indexes, and there should always be at least one, since this is a match ((_,(off,len)):_) = elems matchgroups -- groups should have 0-based indexes, and there should always be at least one, since this is a match
@ -236,15 +184,37 @@ replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s ::
-- The replacement text: the replacement pattern with all -- The replacement text: the replacement pattern with all
-- numeric backreferences replaced by the appropriate groups -- numeric backreferences replaced by the appropriate groups
-- from this match. Or an error message. -- from this match. Or an error message.
erepl = toRegex_ "\\\\[0-9]+" >>= \rx -> replaceAllByM rx (lookupMatchGroup_ matchgroups) replpat erepl = regexReplaceAllByM backrefRegex (lookupMatchGroup matchgroups) replpat
where where
-- Given some match groups and a numeric backreference, -- Given some match groups and a numeric backreference,
-- return the referenced group text, or an error message. -- return the referenced group text, or an error message.
lookupMatchGroup_ :: MatchText String -> String -> Either RegexError String lookupMatchGroup :: MatchText String -> String -> Either RegexError String
lookupMatchGroup_ grps ('\\':s@(_:_)) | all isDigit s = lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s =
case read s of n | n `elem` indices grps -> Right $ fst (grps ! n) case read s of n | n `elem` indices grps -> Right $ fst (grps ! n)
_ -> Left $ "no match group exists for backreference \"\\"++s++"\"" _ -> Left $ "no match group exists for backreference \"\\"++s++"\""
lookupMatchGroup_ _ s = Left $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen" lookupMatchGroup _ s = Left $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen"
backrefRegex = toRegex' "\\\\[0-9]+" -- PARTIAL: should not happen
-- regexReplace' :: Regexp -> Replacement -> String -> String
-- regexReplace' re repl s =
-- foldl (replaceMatch repl) s (reverse $ match (reCompiled re) s :: [MatchText String])
-- where
-- replaceMatch :: Replacement -> String -> MatchText String -> String
-- replaceMatch replpat s matchgroups = pre ++ repl ++ post
-- where
-- ((_,(off,len)):_) = elems matchgroups -- groups should have 0-based indexes, and there should always be at least one, since this is a match
-- (pre, post') = splitAt off s
-- post = drop len post'
-- repl = regexReplaceAllBy backrefRegex (lookupMatchGroup matchgroups) replpat
-- where
-- lookupMatchGroup :: MatchText String -> String -> String
-- lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s =
-- case read s of n | n `elem` indices grps -> fst (grps ! n)
-- -- PARTIAL:
-- _ -> error' $ "no match group exists for backreference \"\\"++s++"\""
-- lookupMatchGroup _ s = error' $ "lookupMatchGroup called on non-numeric-backreference \""++s++"\", shouldn't happen"
-- backrefRegex = toRegex' "\\\\[0-9]+" -- PARTIAL: should not error happen
-- helpers -- helpers
@ -252,12 +222,12 @@ replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s ::
-- Replace all occurrences of a regexp in a string, transforming each match -- Replace all occurrences of a regexp in a string, transforming each match
-- with the given pure function. -- with the given pure function.
replaceAllBy :: Regex -> (String -> String) -> String -> String regexReplaceAllBy :: Regexp -> (String -> String) -> String -> String
replaceAllBy re transform s = prependdone rest regexReplaceAllBy re transform s = prependdone rest
where where
(_, rest, prependdone) = foldl' go (0, s, id) matches (_, rest, prependdone) = foldl' go (0, s, id) matches
where where
matches = getAllMatches $ match re s :: [(Int, Int)] -- offset and length matches = getAllMatches $ match (reCompiled re) s :: [(Int, Int)] -- offset and length
go :: (Int,String,String->String) -> (Int,Int) -> (Int,String,String->String) go :: (Int,String,String->String) -> (Int,Int) -> (Int,String,String->String)
go (pos,todo,prepend) (off,len) = go (pos,todo,prepend) (off,len) =
let (prematch, matchandrest) = splitAt (off - pos) todo let (prematch, matchandrest) = splitAt (off - pos) todo
@ -268,14 +238,13 @@ replaceAllBy re transform s = prependdone rest
-- with the given monadic function. Eg if the monad is Either, a Left result -- with the given monadic function. Eg if the monad is Either, a Left result
-- from the transform function short-circuits and is returned as the overall -- from the transform function short-circuits and is returned as the overall
-- result. -- result.
replaceAllByM :: forall m. Monad m => Regex -> (String -> m String) -> String -> m String regexReplaceAllByM :: forall m. Monad m => Regexp -> (String -> m String) -> String -> m String
replaceAllByM re transform s = regexReplaceAllByM re transform s =
foldM go (0, s, id) matches >>= \(_, rest, prependdone) -> pure $ prependdone rest foldM go (0, s, id) matches >>= \(_, rest, prependdone) -> pure $ prependdone rest
where where
matches = getAllMatches $ match re s :: [(Int, Int)] -- offset and length matches = getAllMatches $ match (reCompiled re) s :: [(Int, Int)] -- offset and length
go :: (Int,String,String->String) -> (Int,Int) -> m (Int,String,String->String) go :: (Int,String,String->String) -> (Int,Int) -> m (Int,String,String->String)
go (pos,todo,prepend) (off,len) = go (pos,todo,prepend) (off,len) =
let (prematch, matchandrest) = splitAt (off - pos) todo let (prematch, matchandrest) = splitAt (off - pos) todo
(matched, rest) = splitAt len matchandrest (matched, rest) = splitAt len matchandrest
in transform matched >>= \matched' -> pure (off + len, rest, prepend . (prematch++) . (matched' ++)) in transform matched >>= \matched' -> pure (off + len, rest, prepend . (prematch++) . (matched' ++))

31
hledger-lib/Hledger/Utils/String.hs
View File

@ -13,7 +13,6 @@ module Hledger.Utils.String (
singleQuoteIfNeeded, singleQuoteIfNeeded,
-- quotechars, -- quotechars,
-- whitespacechars, -- whitespacechars,
escapeQuotes,
words', words',
unwords', unwords',
stripAnsi, stripAnsi,
@ -49,14 +48,14 @@ module Hledger.Utils.String (
) where ) where
import Data.Char import Data.Char (isDigit, isSpace, toLower, toUpper)
import Data.List import Data.List (intercalate, transpose)
import Text.Megaparsec import Text.Megaparsec (Parsec, (<|>), (<?>), between, many, noneOf, oneOf,
import Text.Megaparsec.Char parseMaybe, sepBy, takeWhile1P)
import Text.Megaparsec.Char (char, string)
import Text.Printf (printf) import Text.Printf (printf)
import Hledger.Utils.Parse import Hledger.Utils.Parse
import Hledger.Utils.Regex
-- | Take elements from the end of a list. -- | Take elements from the end of a list.
@ -120,8 +119,9 @@ underline s = s' ++ replicate (length s) '-' ++ "\n"
-- | Double-quote this string if it contains whitespace, single quotes -- | Double-quote this string if it contains whitespace, single quotes
-- or double-quotes, escaping the quotes as needed. -- or double-quotes, escaping the quotes as needed.
quoteIfNeeded :: String -> String quoteIfNeeded :: String -> String
quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars++redirectchars) = "\"" ++ escapeDoubleQuotes s ++ "\"" quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars++redirectchars) = show s
| otherwise = s | otherwise = s
-- | Single-quote this string if it contains whitespace or double-quotes. -- | Single-quote this string if it contains whitespace or double-quotes.
-- No good for strings containing single quotes. -- No good for strings containing single quotes.
singleQuoteIfNeeded :: String -> String singleQuoteIfNeeded :: String -> String
@ -133,12 +133,6 @@ quotechars = "'\""
whitespacechars = " \t\n\r" whitespacechars = " \t\n\r"
redirectchars = "<>" redirectchars = "<>"
escapeDoubleQuotes :: String -> String
escapeDoubleQuotes = regexReplace "\"" "\""
escapeQuotes :: String -> String
escapeQuotes = regexReplace "([\"'])" "\\1"
-- | Quote-aware version of words - don't split on spaces which are inside quotes. -- | Quote-aware version of words - don't split on spaces which are inside quotes.
-- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.
words' :: String -> [String] words' :: String -> [String]
@ -341,12 +335,15 @@ takeWidth w (c:cs) | cw <= w = c:takeWidth (w-cw) cs
-- (not counted), and line breaks (in a multi-line string, the longest -- (not counted), and line breaks (in a multi-line string, the longest
-- line determines the width). -- line determines the width).
strWidth :: String -> Int strWidth :: String -> Int
strWidth "" = 0 strWidth = maximum . (0:) . map (foldr (\a b -> charWidth a + b) 0) . lines . stripAnsi
strWidth s = maximum $ map (foldr (\a b -> charWidth a + b) 0) $ lines s'
where s' = stripAnsi s
stripAnsi :: String -> String stripAnsi :: String -> String
stripAnsi = regexReplace "\ESC\\[([0-9]+;)*([0-9]+)?[ABCDHJKfmsu]" "" stripAnsi s = maybe s concat $ parseMaybe (many $ takeWhile1P Nothing (/='\ESC') <|> "" <$ ansi) s
where
-- This parses lots of invalid ANSI escape codes, but that should be fine
ansi = string "\ESC[" *> digitSemicolons *> suffix <?> "ansi" :: Parsec CustomErr String Char
digitSemicolons = takeWhile1P Nothing (\c -> isDigit c || c == ';')
suffix = oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
-- | Get the designated render width of a character: 0 for a combining -- | Get the designated render width of a character: 0 for a combining
-- character, 1 for a regular character, 2 for a wide character. -- character, 1 for a regular character, 2 for a wide character.

71
hledger-lib/Hledger/Utils/Tree.hs
View File

@ -1,77 +1,18 @@
module Hledger.Utils.Tree where module Hledger.Utils.Tree
( FastTree(..)
, treeFromPaths
) where
-- import Data.Char -- import Data.Char
import Data.List (foldl') import Data.List (foldl')
import qualified Data.Map as M import qualified Data.Map as M
import Data.Tree
-- import Text.Megaparsec
-- import Text.Printf
import Hledger.Utils.Regex
-- import Hledger.Utils.UTF8IOCompat (error')
-- standard tree helpers
root = rootLabel
subs = subForest
branches = subForest
-- | List just the leaf nodes of a tree
leaves :: Tree a -> [a]
leaves (Node v []) = [v]
leaves (Node _ branches) = concatMap leaves branches
-- | get the sub-tree rooted at the first (left-most, depth-first) occurrence
-- of the specified node value
subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a)
subtreeat v t
| root t == v = Just t
| otherwise = subtreeinforest v $ subs t
-- | get the sub-tree for the specified node value in the first tree in
-- forest in which it occurs.
subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)
subtreeinforest _ [] = Nothing
subtreeinforest v (t:ts) = case (subtreeat v t) of
Just t' -> Just t'
Nothing -> subtreeinforest v ts
-- | remove all nodes past a certain depth
treeprune :: Int -> Tree a -> Tree a
treeprune 0 t = Node (root t) []
treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t)
-- | apply f to all tree nodes
treemap :: (a -> b) -> Tree a -> Tree b
treemap f t = Node (f $ root t) (map (treemap f) $ branches t)
-- | remove all subtrees whose nodes do not fulfill predicate
treefilter :: (a -> Bool) -> Tree a -> Tree a
treefilter f t = Node
(root t)
(map (treefilter f) $ filter (treeany f) $ branches t)
-- | is predicate true in any node of tree ?
treeany :: (a -> Bool) -> Tree a -> Bool
treeany f t = f (root t) || any (treeany f) (branches t)
-- treedrop -- remove the leaves which do fulfill predicate.
-- treedropall -- do this repeatedly.
-- | show a compact ascii representation of a tree
showtree :: Show a => Tree a -> String
showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show
-- | show a compact ascii representation of a forest
showforest :: Show a => Forest a -> String
showforest = concatMap showtree
-- | An efficient-to-build tree suggested by Cale Gibbard, probably -- | An efficient-to-build tree suggested by Cale Gibbard, probably
-- better than accountNameTreeFrom. -- better than accountNameTreeFrom.
newtype FastTree a = T (M.Map a (FastTree a)) newtype FastTree a = T (M.Map a (FastTree a))
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
emptyTree :: FastTree a
emptyTree = T M.empty emptyTree = T M.empty
mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a
@ -83,5 +24,3 @@ treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs))
treeFromPaths :: (Ord a) => [[a]] -> FastTree a treeFromPaths :: (Ord a) => [[a]] -> FastTree a
treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath

7
hledger-lib/hledger-lib.cabal
View File

@ -1,10 +1,10 @@
cabal-version: 1.12 cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.33.0. -- This file has been generated from package.yaml by hpack version 0.34.2.
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: ca2b9f025d75c0b65f91b2e5fe7203d00d1d9f8c423c8c4f0cb7675df848a5aa -- hash: e8ee8c99329f53fe86ae9df138d05c8c39726a66da2ad1da3ae27500c45b2591
name: hledger-lib name: hledger-lib
version: 1.18.99 version: 1.18.99
@ -124,7 +124,6 @@ library
, cmdargs >=0.10 , cmdargs >=0.10
, containers , containers
, data-default >=0.5 , data-default >=0.5
, deepseq
, directory , directory
, extra >=1.6.3 , extra >=1.6.3
, fgl >=5.5.4.0 , fgl >=5.5.4.0
@ -177,7 +176,6 @@ test-suite doctest
, cmdargs >=0.10 , cmdargs >=0.10
, containers , containers
, data-default >=0.5 , data-default >=0.5
, deepseq
, directory , directory
, doctest >=0.16.3 , doctest >=0.16.3
, extra >=1.6.3 , extra >=1.6.3
@ -233,7 +231,6 @@ test-suite unittest
, cmdargs >=0.10 , cmdargs >=0.10
, containers , containers
, data-default >=0.5 , data-default >=0.5
, deepseq
, directory , directory
, extra >=1.6.3 , extra >=1.6.3
, fgl >=5.5.4.0 , fgl >=5.5.4.0

1
hledger-lib/package.yaml
View File

@ -59,7 +59,6 @@ dependencies:
- cassava-megaparsec - cassava-megaparsec
- data-default >=0.5 - data-default >=0.5
- Decimal >=0.5.1 - Decimal >=0.5.1
- deepseq
- directory - directory
- fgl >=5.5.4.0 - fgl >=5.5.4.0
- file-embed >=0.0.10 - file-embed >=0.0.10

2
hledger-ui/Hledger/UI/AccountsScreen.hs
View File

@ -90,7 +90,7 @@ asInit d reset ui@UIState{
excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction
And [ And [
Not (Date $ DateSpan (Just $ addDays 1 d) Nothing) Not (Date $ DateSpan (Just $ addDays 1 d) Nothing)
,Not (Tag "generated-transaction" Nothing) ,Not generatedTransactionTag
] ]
-- run the report -- run the report

8
hledger-ui/Hledger/UI/Main.hs
View File

@ -120,9 +120,11 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop
-- to that as usual. -- to that as usual.
Just apat -> (rsSetAccount acct False registerScreen, [ascr']) Just apat -> (rsSetAccount acct False registerScreen, [ascr'])
where where
acct = headDef acct = headDef (error' $ "--register "++apat++" did not match any account") -- PARTIAL:
(error' $ "--register "++apat++" did not match any account") -- PARTIAL: . filterAccts $ journalAccountNames j
$ filter (regexMatches apat . T.unpack) $ journalAccountNames j filterAccts = case toRegexCI apat of
Right re -> filter (regexMatch re . T.unpack)
Left _ -> const []
-- Initialising the accounts screen is awkward, requiring -- Initialising the accounts screen is awkward, requiring
-- another temporary UIState value.. -- another temporary UIState value..
ascr' = aScreen $ ascr' = aScreen $

2
hledger-ui/Hledger/UI/RegisterScreen.hs
View File

@ -76,7 +76,7 @@ rsInit d reset ui@UIState{aopts=_uopts@UIOpts{cliopts_=CliOpts{reportopts_=ropts
excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction
And [ And [
Not (Date $ DateSpan (Just $ addDays 1 d) Nothing) Not (Date $ DateSpan (Just $ addDays 1 d) Nothing)
,Not (Tag "generated-transaction" Nothing) ,Not generatedTransactionTag
] ]
(_label,items) = accountTransactionsReport ropts' j q thisacctq (_label,items) = accountTransactionsReport ropts' j q thisacctq

1
hledger-ui/Hledger/UI/UIOptions.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-| {-|

7
hledger-web/Hledger/Web/Widget/AddForm.hs
View File

@ -106,16 +106,13 @@ addForm j today = identifyForm "add" $ \extra -> do
intercalate "," $ map ( intercalate "," $ map (
("{\"value\":" ++). ("{\"value\":" ++).
(++"}"). (++"}").
escapeJSSpecialChars .
drop 7 . -- "String "
show . show .
toJSON -- avoid https://github.com/simonmichael/hledger/issues/236
T.replace "</script>" "<\\/script>"
) ts, ) ts,
"]" "]"
] ]
where where
-- avoid https://github.com/simonmichael/hledger/issues/236
escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>"
validateTransaction :: validateTransaction ::
FormResult Day FormResult Day

2
hledger-web/Hledger/Web/Widget/Common.hs
View File

@ -72,7 +72,7 @@ writeJournalTextIfValidAndChanged f t = do
-- Ensure unix line endings, since both readJournal (cf -- Ensure unix line endings, since both readJournal (cf
-- formatdirectivep, #1194) writeFileWithBackupIfChanged require them. -- formatdirectivep, #1194) writeFileWithBackupIfChanged require them.
-- XXX klunky. Any equivalent of "hSetNewlineMode h universalNewlineMode" for form posts ? -- XXX klunky. Any equivalent of "hSetNewlineMode h universalNewlineMode" for form posts ?
let t' = T.pack $ regexReplace "\r" "" $ T.unpack t let t' = T.replace "\r" "" t
liftIO (readJournal def (Just f) t') >>= \case liftIO (readJournal def (Just f) t') >>= \case
Left e -> return (Left e) Left e -> return (Left e)
Right _ -> do Right _ -> do

4
hledger/Hledger/Cli/CliOptions.hs
View File

@ -5,7 +5,7 @@ related utilities used by hledger commands.
-} -}
{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts, TypeFamilies, OverloadedStrings, PackageImports #-} {-# LANGUAGE CPP, ScopedTypeVariables, FlexibleContexts, TypeFamilies, OverloadedStrings, PackageImports #-}
module Hledger.Cli.CliOptions ( module Hledger.Cli.CliOptions (
@ -413,7 +413,7 @@ data CliOpts = CliOpts {
-- 1. the COLUMNS env var, if set -- 1. the COLUMNS env var, if set
-- 2. the width reported by the terminal, if supported -- 2. the width reported by the terminal, if supported
-- 3. the default (80) -- 3. the default (80)
} deriving (Show, Data, Typeable) } deriving (Show)
instance Default CliOpts where def = defcliopts instance Default CliOpts where def = defcliopts

30
hledger/Hledger/Cli/Commands.hs
View File

@ -61,7 +61,7 @@ import System.Environment (withArgs)
import System.Console.CmdArgs.Explicit as C import System.Console.CmdArgs.Explicit as C
import Test.Tasty (defaultMain) import Test.Tasty (defaultMain)
import Hledger import Hledger
import Hledger.Cli.CliOptions import Hledger.Cli.CliOptions
import Hledger.Cli.Version import Hledger.Cli.Version
import Hledger.Cli.Commands.Accounts import Hledger.Cli.Commands.Accounts
@ -137,7 +137,7 @@ builtinCommands = [
-- | The commands list, showing command names, standard aliases, -- | The commands list, showing command names, standard aliases,
-- and short descriptions. This is modified at runtime, as follows: -- and short descriptions. This is modified at runtime, as follows:
-- --
-- PROGVERSION is replaced with the program name and version. -- progversion is the program name and version.
-- --
-- Lines beginning with a space represent builtin commands, with format: -- Lines beginning with a space represent builtin commands, with format:
-- COMMAND (ALIASES) DESCRIPTION -- COMMAND (ALIASES) DESCRIPTION
@ -152,10 +152,10 @@ builtinCommands = [
-- --
-- TODO: generate more of this automatically. -- TODO: generate more of this automatically.
-- --
commandsList :: String commandsList :: String -> [String] -> [String]
commandsList = unlines [ commandsList progversion othercmds = [
"-------------------------------------------------------------------------------" "-------------------------------------------------------------------------------"
,"PROGVERSION" ,progversion
,"Usage: hledger COMMAND [OPTIONS] [-- ADDONCMDOPTIONS]" ,"Usage: hledger COMMAND [OPTIONS] [-- ADDONCMDOPTIONS]"
,"Commands (+ addons found in $PATH):" ,"Commands (+ addons found in $PATH):"
,"" ,""
@ -208,8 +208,10 @@ commandsList = unlines [
,"+api run http api server" ,"+api run http api server"
,"" ,""
,"Other:" ,"Other:"
,"OTHER" ] ++
,"Help:" othercmds
++
["Help:"
," (no arguments) show this commands list" ," (no arguments) show this commands list"
," -h show general flags" ," -h show general flags"
," COMMAND -h show flags & docs for COMMAND" ," COMMAND -h show flags & docs for COMMAND"
@ -231,25 +233,21 @@ findCommand cmdname = find (elem cmdname . modeNames . fst) builtinCommands
-- | Extract the command names from commandsList: the first word -- | Extract the command names from commandsList: the first word
-- of lines beginning with a space or + sign. -- of lines beginning with a space or + sign.
commandsFromCommandsList :: String -> [String] commandsFromCommandsList :: [String] -> [String]
commandsFromCommandsList s = commandsFromCommandsList s =
[w | c:l <- lines s, c `elem` [' ','+'], let w:_ = words l] [w | c:l <- s, c `elem` [' ','+'], let w:_ = words l]
knownCommands :: [String] knownCommands :: [String]
knownCommands = sort $ commandsFromCommandsList commandsList knownCommands = sort . commandsFromCommandsList $ commandsList prognameandversion []
-- | Print the commands list, modifying the template above based on -- | Print the commands list, modifying the template above based on
-- the currently available addons. Missing addons will be removed, and -- the currently available addons. Missing addons will be removed, and
-- extra addons will be added under Misc. -- extra addons will be added under Misc.
printCommandsList :: [String] -> IO () printCommandsList :: [String] -> IO ()
printCommandsList addonsFound = printCommandsList addonsFound =
putStr $ putStr . unlines . concatMap adjustline $
regexReplace "PROGVERSION" (prognameandversion) $ commandsList prognameandversion (map ('+':) unknownCommandsFound)
regexReplace "OTHER" (unlines $ (map ('+':) unknownCommandsFound)) $
unlines $ concatMap adjustline $ lines $
cmdlist
where where
cmdlist = commandsList
commandsFound = map (' ':) builtinCommandNames ++ map ('+':) addonsFound commandsFound = map (' ':) builtinCommandNames ++ map ('+':) addonsFound
unknownCommandsFound = addonsFound \\ knownCommands unknownCommandsFound = addonsFound \\ knownCommands

9
hledger/Hledger/Cli/Commands/Add.hs
View File

@ -3,7 +3,7 @@ A history-aware add command to help with data entry.
|-} |-}
{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-} {-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-do-bind #-}
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings, PackageImports, LambdaCase #-} {-# LANGUAGE ScopedTypeVariables, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings, PackageImports, LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Hledger.Cli.Commands.Add ( module Hledger.Cli.Commands.Add (
@ -32,7 +32,6 @@ import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat) import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat)
import Data.Typeable (Typeable)
import Safe (headDef, headMay, atMay) import Safe (headDef, headMay, atMay)
import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Explicit
import System.Console.Haskeline (runInputT, defaultSettings, setComplete) import System.Console.Haskeline (runInputT, defaultSettings, setComplete)
@ -65,7 +64,7 @@ data EntryState = EntryState {
,esJournal :: Journal -- ^ the journal we are adding to ,esJournal :: Journal -- ^ the journal we are adding to
,esSimilarTransaction :: Maybe Transaction -- ^ the most similar historical txn ,esSimilarTransaction :: Maybe Transaction -- ^ the most similar historical txn
,esPostings :: [Posting] -- ^ postings entered so far in the current txn ,esPostings :: [Posting] -- ^ postings entered so far in the current txn
} deriving (Show,Typeable) } deriving (Show)
defEntryState = EntryState { defEntryState = EntryState {
esOpts = defcliopts esOpts = defcliopts
@ -77,10 +76,10 @@ defEntryState = EntryState {
,esPostings = [] ,esPostings = []
} }
data RestartTransactionException = RestartTransactionException deriving (Typeable,Show) data RestartTransactionException = RestartTransactionException deriving (Show)
instance Exception RestartTransactionException instance Exception RestartTransactionException
-- data ShowHelpException = ShowHelpException deriving (Typeable,Show) -- data ShowHelpException = ShowHelpException deriving (Show)
-- instance Exception ShowHelpException -- instance Exception ShowHelpException
-- | Read multiple transactions from the console, prompting for each -- | Read multiple transactions from the console, prompting for each

17
hledger/Hledger/Cli/Commands/Aregister.hs
View File

@ -24,7 +24,9 @@ import Data.Aeson (toJSON)
import Data.Aeson.Text (encodeToLazyText) import Data.Aeson.Text (encodeToLazyText)
import Data.List import Data.List
import Data.Maybe import Data.Maybe
-- import Data.Text (Text) #if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ((<>))
#endif
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Data.Time (addDays) import Data.Time (addDays)
@ -77,8 +79,11 @@ aregister opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
when (null args') $ error' "aregister needs an account, please provide an account name or pattern" -- PARTIAL: when (null args') $ error' "aregister needs an account, please provide an account name or pattern" -- PARTIAL:
let let
(apat:queryargs) = args' (apat:queryargs) = args'
acct = headDef (error' $ show apat++" did not match any account") $ -- PARTIAL: acct = headDef (error' $ show apat++" did not match any account") -- PARTIAL:
filter (regexMatches apat . T.unpack) $ journalAccountNames j . filterAccts $ journalAccountNames j
filterAccts = case toRegexCI apat of
Right re -> filter (regexMatch re . T.unpack)
Left _ -> const []
-- gather report options -- gather report options
inclusive = True -- tree_ ropts inclusive = True -- tree_ ropts
thisacctq = Acct $ (if inclusive then accountNameToAccountRegex else accountNameToAccountOnlyRegex) acct thisacctq = Acct $ (if inclusive then accountNameToAccountRegex else accountNameToAccountOnlyRegex) acct
@ -97,7 +102,7 @@ aregister opts@CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
excludeforecastq False = -- not:date:tomorrow- not:tag:generated-transaction excludeforecastq False = -- not:date:tomorrow- not:tag:generated-transaction
And [ And [
Not (Date $ DateSpan (Just $ addDays 1 d) Nothing) Not (Date $ DateSpan (Just $ addDays 1 d) Nothing)
,Not (Tag "generated-transaction" Nothing) ,Not generatedTransactionTag
] ]
-- run the report -- run the report
-- TODO: need to also pass the queries so we can choose which date to render - move them into the report ? -- TODO: need to also pass the queries so we can choose which date to render - move them into the report ?
@ -147,11 +152,11 @@ accountTransactionsReportAsText
itemamt (_,_,_,_,a,_) = a itemamt (_,_,_,_,a,_) = a
itembal (_,_,_,_,_,a) = a itembal (_,_,_,_,_,a) = a
-- show a title indicating which account was picked, which can be confusing otherwise -- show a title indicating which account was picked, which can be confusing otherwise
title = maybe "" (("Transactions in "++).(++" and subaccounts:")) macct title = T.unpack $ maybe "" (("Transactions in "<>).(<>" and subaccounts:")) macct
where where
-- XXX temporary hack ? recover the account name from the query -- XXX temporary hack ? recover the account name from the query
macct = case filterQuery queryIsAcct thisacctq of macct = case filterQuery queryIsAcct thisacctq of
Acct r -> Just $ init $ init $ init $ init $ init $ tail r -- Acct "^JS:expenses(:|$)" Acct r -> Just . T.drop 1 . T.dropEnd 5 . T.pack $ reString r -- Acct "^JS:expenses(:|$)"
_ -> Nothing -- shouldn't happen _ -> Nothing -- shouldn't happen
-- | Render one account register report line item as plain text. Layout is like so: -- | Render one account register report line item as plain text. Layout is like so:

4
hledger/Hledger/Cli/Commands/Files.hs
View File

@ -33,8 +33,8 @@ filesmode = hledgerCommandMode
files :: CliOpts -> Journal -> IO () files :: CliOpts -> Journal -> IO ()
files CliOpts{rawopts_=rawopts} j = do files CliOpts{rawopts_=rawopts} j = do
let args = listofstringopt "args" rawopts let args = listofstringopt "args" rawopts
regex = headMay args regex <- mapM (either fail pure . toRegex) $ headMay args
files = maybe id (filter . regexMatches) regex let files = maybe id (filter . regexMatch) regex
$ map fst $ map fst
$ jfiles j $ jfiles j
mapM_ putStrLn files mapM_ putStrLn files

7
hledger/Hledger/Cli/Commands/Tags.hs
View File

@ -7,6 +7,7 @@ module Hledger.Cli.Commands.Tags (
) )
where where
import qualified Control.Monad.Fail as Fail
import Data.List.Extra (nubSort) import Data.List.Extra (nubSort)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T import qualified Data.Text.IO as T
@ -24,11 +25,13 @@ tagsmode = hledgerCommandMode
hiddenflags hiddenflags
([], Just $ argsFlag "[TAGREGEX [QUERY...]]") ([], Just $ argsFlag "[TAGREGEX [QUERY...]]")
tags :: CliOpts -> Journal -> IO ()
tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
d <- getCurrentDay d <- getCurrentDay
let let
args = listofstringopt "args" rawopts args = listofstringopt "args" rawopts
mtagpat = headMay args mtagpat <- mapM (either Fail.fail pure . toRegexCI) $ headMay args
let
queryargs = drop 1 args queryargs = drop 1 args
values = boolopt "values" rawopts values = boolopt "values" rawopts
parsed = boolopt "parsed" rawopts parsed = boolopt "parsed" rawopts
@ -39,7 +42,7 @@ tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
(if parsed then id else nubSort) (if parsed then id else nubSort)
[ r [ r
| (t,v) <- concatMap transactionAllTags txns | (t,v) <- concatMap transactionAllTags txns
, maybe True (`regexMatchesCI` T.unpack t) mtagpat , maybe True (`regexMatch` T.unpack t) mtagpat
, let r = if values then v else t , let r = if values then v else t
, not (values && T.null v && not empty) , not (values && T.null v && not empty)
] ]

16
hledger/Hledger/Cli/Main.hs
View File

@ -82,14 +82,14 @@ mainmode addons = defMode {
[detailedversionflag] [detailedversionflag]
-- ++ inputflags -- included here so they'll not raise a confusing error if present with no COMMAND -- ++ inputflags -- included here so they'll not raise a confusing error if present with no COMMAND
} }
,modeHelpSuffix = map (regexReplace "PROGNAME" progname) [ ,modeHelpSuffix = "Examples:" :
"Examples:" map (progname ++) [
,"PROGNAME list commands" " list commands"
,"PROGNAME CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)" ," CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)"
,"PROGNAME-CMD [OPTS] [ARGS] or run addon commands directly" ,"-CMD [OPTS] [ARGS] or run addon commands directly"
,"PROGNAME -h show general usage" ," -h show general usage"
,"PROGNAME CMD -h show command usage" ," CMD -h show command usage"
,"PROGNAME help [MANUAL] show any of the hledger manuals in various formats" ," help [MANUAL] show any of the hledger manuals in various formats"
] ]
} }