Replace our stringly Regex with a safer compiled Regexp type
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
commit
58f989715a
@ -14,7 +14,7 @@ import Data.List.Extra (groupSort, groupOn)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Ord (Down(..))
|
||||
import qualified Data.Map as M
|
||||
import Data.Text (pack,unpack)
|
||||
import qualified Data.Text as T
|
||||
import Safe (headMay, lookupJustDef)
|
||||
import Text.Printf
|
||||
|
||||
@ -28,11 +28,12 @@ import Hledger.Utils
|
||||
-- deriving instance Show Account
|
||||
instance Show Account where
|
||||
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)
|
||||
anumpostings
|
||||
(showMixedAmount aebalance)
|
||||
(showMixedAmount aibalance)
|
||||
where colonToUnderscore x = if x == ':' then '_' else x
|
||||
|
||||
instance Eq Account where
|
||||
(==) a b = aname a == aname b -- quick equality test for speed
|
||||
|
||||
@ -18,7 +18,6 @@ module Hledger.Data.AccountName (
|
||||
,accountNameToAccountOnlyRegex
|
||||
,accountNameToAccountRegex
|
||||
,accountNameTreeFrom
|
||||
,accountRegexToAccountName
|
||||
,accountSummarisedName
|
||||
,acctsep
|
||||
,acctsepchar
|
||||
@ -40,15 +39,14 @@ module Hledger.Data.AccountName (
|
||||
)
|
||||
where
|
||||
|
||||
import Data.List
|
||||
import Data.List.Extra (nubSort)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Monoid
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Tree
|
||||
import Text.Printf
|
||||
import Data.Tree (Tree(..))
|
||||
|
||||
import Hledger.Data.Types
|
||||
import Hledger.Utils
|
||||
@ -117,7 +115,7 @@ expandAccountNames as = nubSort $ concatMap expandAccountName as
|
||||
|
||||
-- | "a:b:c" -> ["a","a:b","a:b:c"]
|
||||
expandAccountName :: AccountName -> [AccountName]
|
||||
expandAccountName = map accountNameFromComponents . tail . inits . accountNameComponents
|
||||
expandAccountName = map accountNameFromComponents . NE.tail . NE.inits . accountNameComponents
|
||||
|
||||
-- | ["a:b:c","d:e"] -> ["a","d"]
|
||||
topAccountNames :: [AccountName] -> [AccountName]
|
||||
@ -210,23 +208,19 @@ clipOrEllipsifyAccountName n = clipAccountName n
|
||||
-- | Escape an AccountName for use within a regular expression.
|
||||
-- >>> putStr $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#"
|
||||
-- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@#
|
||||
escapeName :: AccountName -> Regexp
|
||||
escapeName = regexReplaceBy "[[?+|()*\\\\^$]" ("\\" <>)
|
||||
. T.unpack
|
||||
escapeName :: AccountName -> String
|
||||
escapeName = T.unpack . T.concatMap escapeChar
|
||||
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.
|
||||
accountNameToAccountRegex :: AccountName -> Regexp
|
||||
accountNameToAccountRegex "" = ""
|
||||
accountNameToAccountRegex a = printf "^%s(:|$)" (escapeName a)
|
||||
accountNameToAccountRegex a = toRegex' $ '^' : escapeName a ++ "(:|$)" -- PARTIAL: Is this safe after escapeName?
|
||||
|
||||
-- | Convert an account name to a regular expression matching it but not its subaccounts.
|
||||
accountNameToAccountOnlyRegex :: AccountName -> Regexp
|
||||
accountNameToAccountOnlyRegex "" = ""
|
||||
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
|
||||
accountNameToAccountOnlyRegex a = toRegex' $ '^' : escapeName a ++ "$" -- PARTIAL: Is this safe after escapeName?
|
||||
|
||||
-- -- | Does this string look like an exact account-matching regular expression ?
|
||||
--isAccountRegex :: String -> Bool
|
||||
|
||||
@ -74,7 +74,6 @@ module Hledger.Data.Journal (
|
||||
journalCashAccountQuery,
|
||||
-- * Misc
|
||||
canonicalStyleFrom,
|
||||
matchpats,
|
||||
nulljournal,
|
||||
journalCheckBalanceAssertions,
|
||||
journalNumberAndTieTransactions,
|
||||
@ -301,7 +300,7 @@ journalAccountNameTree = accountNameTreeFrom . journalAccountNames
|
||||
-- or otherwise for accounts with names matched by the case-insensitive
|
||||
-- regular expression @^assets?(:|$)@.
|
||||
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
|
||||
-- declared as Cash by account directives, or otherwise with names matched by the
|
||||
@ -310,39 +309,37 @@ journalAssetAccountQuery j = journalAccountTypeQuery [Asset,Cash] "^assets?(:|$)
|
||||
journalCashAccountQuery :: Journal -> Query
|
||||
journalCashAccountQuery j =
|
||||
case M.lookup Cash (jdeclaredaccounttypes j) of
|
||||
Nothing -> And [ journalAssetAccountQuery j, Not . Acct $ toRegex' "(investment|receivable|:A/R|:fixed)" ]
|
||||
Just _ -> journalAccountTypeQuery [Cash] notused j
|
||||
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
|
||||
-- declared as Liability by account directives, or otherwise for
|
||||
-- accounts with names matched by the case-insensitive regular expression
|
||||
-- @^(debts?|liabilit(y|ies))(:|$)@.
|
||||
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
|
||||
-- declared as Equity by account directives, or otherwise for
|
||||
-- accounts with names matched by the case-insensitive regular expression
|
||||
-- @^equity(:|$)@.
|
||||
journalEquityAccountQuery :: Journal -> Query
|
||||
journalEquityAccountQuery = journalAccountTypeQuery [Equity] "^equity(:|$)"
|
||||
journalEquityAccountQuery = journalAccountTypeQuery [Equity] (toRegex' "^equity(:|$)")
|
||||
|
||||
-- | A query for accounts in this journal which have been
|
||||
-- declared as Revenue by account directives, or otherwise for
|
||||
-- accounts with names matched by the case-insensitive regular expression
|
||||
-- @^(income|revenue)s?(:|$)@.
|
||||
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
|
||||
-- declared as Expense by account directives, or otherwise for
|
||||
-- accounts with names matched by the case-insensitive regular expression
|
||||
-- @^expenses?(:|$)@.
|
||||
journalExpenseAccountQuery :: Journal -> Query
|
||||
journalExpenseAccountQuery = journalAccountTypeQuery [Expense] "^expenses?(:|$)"
|
||||
journalExpenseAccountQuery = journalAccountTypeQuery [Expense] (toRegex' "^expenses?(:|$)")
|
||||
|
||||
-- | A query for Asset, Liability & Equity accounts in this journal.
|
||||
-- Cf <http://en.wikipedia.org/wiki/Chart_of_accounts#Balance_Sheet_Accounts>.
|
||||
@ -370,17 +367,16 @@ journalAccountTypeQuery :: [AccountType] -> Regexp -> Journal -> Query
|
||||
journalAccountTypeQuery atypes fallbackregex Journal{jdeclaredaccounttypes} =
|
||||
let
|
||||
declaredacctsoftype :: [AccountName] =
|
||||
concat $ catMaybes [M.lookup t jdeclaredaccounttypes | t <- atypes]
|
||||
concat $ mapMaybe (`M.lookup` jdeclaredaccounttypes) atypes
|
||||
in case declaredacctsoftype of
|
||||
[] -> Acct fallbackregex
|
||||
as ->
|
||||
as -> And [ Or acctnameRegexes, Not $ Or differentlyTypedRegexes ]
|
||||
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.
|
||||
And [
|
||||
Or $ map (Acct . accountNameToAccountRegex) as
|
||||
,Not $ Or $ map (Acct . accountNameToAccountRegex) differentlytypedsubs
|
||||
]
|
||||
where
|
||||
acctnameRegexes = map (Acct . accountNameToAccountRegex) as
|
||||
differentlyTypedRegexes = map (Acct . accountNameToAccountRegex) differentlytypedsubs
|
||||
|
||||
differentlytypedsubs = concat
|
||||
[subs | (t,bs) <- M.toList jdeclaredaccounttypes
|
||||
, 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
|
||||
-- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a
|
||||
-- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps
|
||||
|
||||
@ -17,7 +17,6 @@ module Hledger.Data.Ledger (
|
||||
,ledgerRootAccount
|
||||
,ledgerTopAccounts
|
||||
,ledgerLeafAccounts
|
||||
,ledgerAccountsMatching
|
||||
,ledgerPostings
|
||||
,ledgerDateSpan
|
||||
,ledgerCommodities
|
||||
@ -26,8 +25,6 @@ module Hledger.Data.Ledger (
|
||||
where
|
||||
|
||||
import qualified Data.Map as M
|
||||
-- import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Safe (headDef)
|
||||
import Text.Printf
|
||||
|
||||
@ -90,10 +87,6 @@ ledgerTopAccounts = asubs . head . laccounts
|
||||
ledgerLeafAccounts :: Ledger -> [Account]
|
||||
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.
|
||||
ledgerPostings :: Ledger -> [Posting]
|
||||
ledgerPostings = journalPostings . ljournal
|
||||
|
||||
@ -315,7 +315,7 @@ aliasReplace (BasicAlias old new) a
|
||||
Right $ new <> T.drop (T.length old) a
|
||||
| otherwise = Right 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
|
||||
-- provided price oracle, commodity styles, reference dates, and
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
{-|
|
||||
|
||||
hledger's cmdargs modes parse command-line arguments to an
|
||||
@ -28,17 +26,16 @@ module Hledger.Data.RawOptions (
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Data
|
||||
import Data.Default
|
||||
import Safe
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import Data.Default (Default(..))
|
||||
import Safe (headMay, lastMay, readDef)
|
||||
|
||||
import Hledger.Utils
|
||||
|
||||
|
||||
-- | The result of running cmdargs: an association list of option names to string values.
|
||||
newtype RawOpts = RawOpts { unRawOpts :: [(String,String)] }
|
||||
deriving (Show, Data, Typeable)
|
||||
deriving (Show)
|
||||
|
||||
instance Default RawOpts where def = RawOpts []
|
||||
|
||||
@ -61,6 +58,7 @@ boolopt = inRawOpts
|
||||
-- for which the given predicate returns a Just value.
|
||||
-- Useful for exclusive choice flags like --daily|--weekly|--quarterly...
|
||||
--
|
||||
-- >>> import Safe (readMay)
|
||||
-- >>> choiceopt Just (RawOpts [("a",""), ("b",""), ("c","")])
|
||||
-- Just "c"
|
||||
-- >>> choiceopt (const Nothing) (RawOpts [("a","")])
|
||||
|
||||
@ -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 DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@ -29,8 +28,6 @@ module Hledger.Data.Types
|
||||
where
|
||||
|
||||
import GHC.Generics (Generic)
|
||||
import Control.DeepSeq (NFData)
|
||||
import Data.Data
|
||||
import Data.Decimal
|
||||
import Data.Default
|
||||
import Data.Functor (($>))
|
||||
@ -77,12 +74,10 @@ data SmartInterval = Day | Week | Month | Quarter | Year deriving (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 NFData DateSpan
|
||||
|
||||
-- synonyms for various date-related scalars
|
||||
type Year = Integer
|
||||
type Month = Int -- 1-12
|
||||
@ -105,7 +100,7 @@ data Period =
|
||||
| PeriodFrom Day
|
||||
| PeriodTo Day
|
||||
| PeriodAll
|
||||
deriving (Eq,Ord,Show,Data,Generic,Typeable)
|
||||
deriving (Eq,Ord,Show,Generic)
|
||||
|
||||
instance Default Period where def = PeriodAll
|
||||
|
||||
@ -116,7 +111,7 @@ instance Default Period where def = PeriodAll
|
||||
-- MonthLong
|
||||
-- QuarterLong
|
||||
-- YearLong
|
||||
-- deriving (Eq,Ord,Show,Data,Generic,Typeable)
|
||||
-- deriving (Eq,Ord,Show,Generic)
|
||||
|
||||
-- Ways in which a period can be divided into subperiods.
|
||||
data Interval =
|
||||
@ -133,12 +128,10 @@ data Interval =
|
||||
-- WeekOfYear Int
|
||||
-- MonthOfYear Int
|
||||
-- QuarterOfYear Int
|
||||
deriving (Eq,Show,Ord,Data,Generic,Typeable)
|
||||
deriving (Eq,Show,Ord,Generic)
|
||||
|
||||
instance Default Interval where def = NoInterval
|
||||
|
||||
instance NFData Interval
|
||||
|
||||
type AccountName = Text
|
||||
|
||||
data AccountType =
|
||||
@ -148,9 +141,7 @@ data AccountType =
|
||||
| Revenue
|
||||
| Expense
|
||||
| Cash -- ^ a subtype of Asset - liquid assets to show in cashflow report
|
||||
deriving (Show,Eq,Ord,Data,Generic)
|
||||
|
||||
instance NFData AccountType
|
||||
deriving (Show,Eq,Ord,Generic)
|
||||
|
||||
-- not worth the trouble, letters defined in accountdirectivep for now
|
||||
--instance Read AccountType
|
||||
@ -164,17 +155,12 @@ instance NFData AccountType
|
||||
|
||||
data AccountAlias = BasicAlias AccountName AccountName
|
||||
| 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,Typeable,Data,Generic)
|
||||
|
||||
instance NFData Side
|
||||
data Side = L | R deriving (Eq,Show,Read,Ord,Generic)
|
||||
|
||||
-- | The basic numeric type used in amounts.
|
||||
type Quantity = Decimal
|
||||
deriving instance Data Quantity
|
||||
-- The following is for hledger-web, and requires blaze-markup.
|
||||
-- Doing it here avoids needing a matching flag on the hledger-web package.
|
||||
instance ToMarkup Quantity
|
||||
@ -185,9 +171,7 @@ instance ToMarkup Quantity
|
||||
-- commodity, as recorded in the journal entry eg with @ or @@.
|
||||
-- Docs call this "transaction price". The amount is always positive.
|
||||
data AmountPrice = UnitPrice Amount | TotalPrice Amount
|
||||
deriving (Eq,Ord,Typeable,Data,Generic,Show)
|
||||
|
||||
instance NFData AmountPrice
|
||||
deriving (Eq,Ord,Generic,Show)
|
||||
|
||||
-- | Display style for an amount.
|
||||
data AmountStyle = AmountStyle {
|
||||
@ -196,9 +180,7 @@ data AmountStyle = AmountStyle {
|
||||
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"
|
||||
asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any
|
||||
} deriving (Eq,Ord,Read,Typeable,Data,Generic)
|
||||
|
||||
instance NFData AmountStyle
|
||||
} deriving (Eq,Ord,Read,Generic)
|
||||
|
||||
instance Show AmountStyle where
|
||||
show AmountStyle{..} =
|
||||
@ -209,9 +191,7 @@ instance Show AmountStyle where
|
||||
(show asdecimalpoint)
|
||||
(show asdigitgroups)
|
||||
|
||||
data AmountPrecision = Precision !Word8 | NaturalPrecision deriving (Eq,Ord,Read,Show,Typeable,Data,Generic)
|
||||
|
||||
instance NFData AmountPrecision
|
||||
data AmountPrecision = Precision !Word8 | NaturalPrecision deriving (Eq,Ord,Read,Show,Generic)
|
||||
|
||||
-- | A style for displaying digit groups in the integer part of a
|
||||
-- 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,
|
||||
-- comma between thousands is DigitGroups ',' [3].
|
||||
data DigitGroupStyle = DigitGroups Char [Word8]
|
||||
deriving (Eq,Ord,Read,Show,Typeable,Data,Generic)
|
||||
|
||||
instance NFData DigitGroupStyle
|
||||
deriving (Eq,Ord,Read,Show,Generic)
|
||||
|
||||
type CommoditySymbol = Text
|
||||
|
||||
data Commodity = Commodity {
|
||||
csymbol :: CommoditySymbol,
|
||||
cformat :: Maybe AmountStyle
|
||||
} deriving (Show,Eq,Data,Generic) --,Ord,Typeable,Data,Generic)
|
||||
|
||||
instance NFData Commodity
|
||||
} deriving (Show,Eq,Generic) --,Ord)
|
||||
|
||||
data Amount = Amount {
|
||||
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.
|
||||
astyle :: AmountStyle,
|
||||
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,Typeable,Data,Generic,Show)
|
||||
|
||||
instance NFData MixedAmount
|
||||
newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Generic,Show)
|
||||
|
||||
data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting
|
||||
deriving (Eq,Show,Typeable,Data,Generic)
|
||||
|
||||
instance NFData PostingType
|
||||
deriving (Eq,Show,Generic)
|
||||
|
||||
type TagName = Text
|
||||
type TagValue = Text
|
||||
@ -261,9 +231,7 @@ type DateTag = (TagName, Day)
|
||||
-- | The status of a transaction or posting, recorded with a status mark
|
||||
-- (nothing, !, or *). What these mean is ultimately user defined.
|
||||
data Status = Unmarked | Pending | Cleared
|
||||
deriving (Eq,Ord,Bounded,Enum,Typeable,Data,Generic)
|
||||
|
||||
instance NFData Status
|
||||
deriving (Eq,Ord,Bounded,Enum,Generic)
|
||||
|
||||
instance Show Status where -- custom show.. bad idea.. don't do it..
|
||||
show Unmarked = ""
|
||||
@ -312,9 +280,7 @@ data BalanceAssertion = BalanceAssertion {
|
||||
batotal :: Bool, -- ^ disallow additional non-asserted commodities ?
|
||||
bainclusive :: Bool, -- ^ include subaccounts when calculating the actual balance ?
|
||||
baposition :: GenericSourcePos -- ^ the assertion's file position, for error reporting
|
||||
} deriving (Eq,Typeable,Data,Generic,Show)
|
||||
|
||||
instance NFData BalanceAssertion
|
||||
} deriving (Eq,Generic,Show)
|
||||
|
||||
data Posting = Posting {
|
||||
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
|
||||
-- changed by a pivot or budget report), this references the original
|
||||
-- untransformed posting (which will have Nothing in this field).
|
||||
} deriving (Typeable,Data,Generic)
|
||||
|
||||
instance NFData Posting
|
||||
} deriving (Generic)
|
||||
|
||||
-- The equality test for postings ignores the parent transaction's
|
||||
-- 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.
|
||||
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).
|
||||
deriving (Eq, Read, Show, Ord, Data, Generic, Typeable)
|
||||
|
||||
instance NFData GenericSourcePos
|
||||
deriving (Eq, Read, Show, Ord, Generic)
|
||||
|
||||
--{-# ANN Transaction "HLint: ignore" #-}
|
||||
-- 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
|
||||
ttags :: [Tag], -- ^ tag names and values, extracted from the comment
|
||||
tpostings :: [Posting] -- ^ this transaction's postings
|
||||
} deriving (Eq,Typeable,Data,Generic,Show)
|
||||
|
||||
instance NFData Transaction
|
||||
} deriving (Eq,Generic,Show)
|
||||
|
||||
-- | A transaction modifier rule. This has a query which matches postings
|
||||
-- in the journal, and a list of transformations to apply to those
|
||||
@ -395,9 +355,7 @@ instance NFData Transaction
|
||||
data TransactionModifier = TransactionModifier {
|
||||
tmquerytxt :: Text,
|
||||
tmpostingrules :: [TMPostingRule]
|
||||
} deriving (Eq,Typeable,Data,Generic,Show)
|
||||
|
||||
instance NFData TransactionModifier
|
||||
} deriving (Eq,Generic,Show)
|
||||
|
||||
nulltransactionmodifier = TransactionModifier{
|
||||
tmquerytxt = ""
|
||||
@ -422,7 +380,7 @@ data PeriodicTransaction = PeriodicTransaction {
|
||||
ptcomment :: Text,
|
||||
pttags :: [Tag],
|
||||
ptpostings :: [Posting]
|
||||
} deriving (Eq,Typeable,Data,Generic) -- , Show in PeriodicTransaction.hs
|
||||
} deriving (Eq,Generic) -- , Show in PeriodicTransaction.hs
|
||||
|
||||
nullperiodictransaction = PeriodicTransaction{
|
||||
ptperiodexpr = ""
|
||||
@ -436,11 +394,7 @@ nullperiodictransaction = PeriodicTransaction{
|
||||
,ptpostings = []
|
||||
}
|
||||
|
||||
instance NFData PeriodicTransaction
|
||||
|
||||
data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data,Generic)
|
||||
|
||||
instance NFData TimeclockCode
|
||||
data TimeclockCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Generic)
|
||||
|
||||
data TimeclockEntry = TimeclockEntry {
|
||||
tlsourcepos :: GenericSourcePos,
|
||||
@ -448,9 +402,7 @@ data TimeclockEntry = TimeclockEntry {
|
||||
tldatetime :: LocalTime,
|
||||
tlaccount :: AccountName,
|
||||
tldescription :: Text
|
||||
} deriving (Eq,Ord,Typeable,Data,Generic)
|
||||
|
||||
instance NFData TimeclockEntry
|
||||
} deriving (Eq,Ord,Generic)
|
||||
|
||||
-- | A market price declaration made by the journal format's P directive.
|
||||
-- It declares two things: a historical exchange rate between two commodities,
|
||||
@ -459,11 +411,9 @@ data PriceDirective = PriceDirective {
|
||||
pddate :: Day
|
||||
,pdcommodity :: CommoditySymbol
|
||||
,pdamount :: Amount
|
||||
} deriving (Eq,Ord,Typeable,Data,Generic,Show)
|
||||
} deriving (Eq,Ord,Generic,Show)
|
||||
-- Show instance derived in Amount.hs (XXX why ?)
|
||||
|
||||
instance NFData PriceDirective
|
||||
|
||||
-- | A historical market price (exchange rate) from one commodity to another.
|
||||
-- A more concise form of a PriceDirective, without the amount display info.
|
||||
data MarketPrice = MarketPrice {
|
||||
@ -471,11 +421,9 @@ data MarketPrice = MarketPrice {
|
||||
,mpfrom :: CommoditySymbol -- ^ The commodity being converted from.
|
||||
,mpto :: CommoditySymbol -- ^ The commodity being converted to.
|
||||
,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 ?)
|
||||
|
||||
instance NFData MarketPrice
|
||||
|
||||
-- additional valuation-related types in Valuation.hs
|
||||
|
||||
-- | A Journal, containing transactions and various other things.
|
||||
@ -512,13 +460,9 @@ data Journal = Journal {
|
||||
-- any included journal files. The main file is first,
|
||||
-- followed by any included files in the order encountered.
|
||||
,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
|
||||
instance NFData ClockTime
|
||||
instance NFData Journal
|
||||
|
||||
-- | A journal in the process of being parsed, not yet finalised.
|
||||
-- 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
|
||||
,adideclarationorder :: Int -- ^ the order in which this account was declared,
|
||||
-- relative to other account declarations, during parsing (1..)
|
||||
} deriving (Eq,Show,Data,Generic)
|
||||
|
||||
instance NFData AccountDeclarationInfo
|
||||
} deriving (Eq,Show,Generic)
|
||||
|
||||
nullaccountdeclarationinfo = AccountDeclarationInfo {
|
||||
adicomment = ""
|
||||
@ -558,14 +500,14 @@ data Account = Account {
|
||||
,anumpostings :: Int -- ^ the number of postings to this account
|
||||
,aebalance :: MixedAmount -- ^ this account's balance, excluding 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
|
||||
-- accounting terms, a debit balance) or a negative number (credit balance).
|
||||
-- Assets and expenses are normally positive (debit), while liabilities, equity
|
||||
-- and income are normally negative (credit).
|
||||
-- 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
|
||||
-- derived from that. Accounts are accessible both list-wise and
|
||||
|
||||
@ -9,7 +9,7 @@ looking up historical market prices (exchange rates) between commodities.
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Hledger.Data.Valuation (
|
||||
ValuationType(..)
|
||||
@ -28,8 +28,6 @@ module Hledger.Data.Valuation (
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.DeepSeq (NFData)
|
||||
import Data.Data
|
||||
import Data.Decimal (roundTo)
|
||||
import Data.Function ((&), on)
|
||||
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
|
||||
| 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
|
||||
deriving (Show,Data,Eq) -- Typeable
|
||||
deriving (Show,Eq)
|
||||
|
||||
-- | 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.
|
||||
@ -87,8 +85,6 @@ data PriceGraph = PriceGraph {
|
||||
}
|
||||
deriving (Show,Generic)
|
||||
|
||||
instance NFData PriceGraph
|
||||
|
||||
-- | A price oracle is a magic memoising function that efficiently
|
||||
-- looks up market prices (exchange rates) from one commodity to
|
||||
-- another (or if unspecified, to a default valuation commodity) on a
|
||||
|
||||
@ -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
|
||||
{-# OPTIONS_GHC -Wno-warnings-deprecations #-}
|
||||
|
||||
{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, ViewPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Hledger.Query (
|
||||
-- * Query and QueryOpt
|
||||
Query(..),
|
||||
QueryOpt(..),
|
||||
payeeTag,
|
||||
noteTag,
|
||||
generatedTransactionTag,
|
||||
-- * parsing
|
||||
parseQuery,
|
||||
simplifyQuery,
|
||||
@ -42,20 +47,13 @@ module Hledger.Query (
|
||||
inAccountQuery,
|
||||
-- * matching
|
||||
matchesTransaction,
|
||||
matchesTransaction_,
|
||||
matchesPosting,
|
||||
matchesPosting_,
|
||||
matchesAccount,
|
||||
matchesAccount_,
|
||||
matchesMixedAmount,
|
||||
matchesAmount,
|
||||
matchesAmount_,
|
||||
matchesCommodity,
|
||||
matchesCommodity_,
|
||||
matchesTags,
|
||||
matchesTags_,
|
||||
matchesPriceDirective,
|
||||
matchesPriceDirective_,
|
||||
words'',
|
||||
prefixes,
|
||||
-- * tests
|
||||
@ -63,19 +61,18 @@ module Hledger.Query (
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Arrow ((>>>))
|
||||
import Data.Data
|
||||
import Data.Either
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Control.Applicative ((<|>), many, optional)
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.List (partition)
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Monoid ((<>))
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Calendar (Day, fromGregorian )
|
||||
import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay)
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec (between, noneOf, sepBy)
|
||||
import Text.Megaparsec.Char (char, string)
|
||||
|
||||
import Hledger.Utils hiding (words')
|
||||
import Hledger.Data.Types
|
||||
@ -109,39 +106,31 @@ data Query = Any -- ^ always match
|
||||
-- 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
|
||||
-- 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
|
||||
instance Show Query where
|
||||
show Any = "Any"
|
||||
show None = "None"
|
||||
show (Not q) = "Not (" ++ show q ++ ")"
|
||||
show (Or qs) = "Or (" ++ show qs ++ ")"
|
||||
show (And qs) = "And (" ++ show qs ++ ")"
|
||||
show (Code r) = "Code " ++ show r
|
||||
show (Desc r) = "Desc " ++ show r
|
||||
show (Acct r) = "Acct " ++ show r
|
||||
show (Date ds) = "Date (" ++ show ds ++ ")"
|
||||
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 ++ ")"
|
||||
-- | Construct a payee tag
|
||||
payeeTag :: Maybe String -> Either RegexError Query
|
||||
payeeTag = fmap (Tag (toRegexCI' "payee")) . maybe (pure Nothing) (fmap Just . toRegexCI)
|
||||
|
||||
-- | Construct a note tag
|
||||
noteTag :: Maybe String -> Either RegexError Query
|
||||
noteTag = fmap (Tag (toRegexCI' "note")) . maybe (pure Nothing) (fmap Just . toRegexCI)
|
||||
|
||||
-- | Construct a generated-transaction tag
|
||||
generatedTransactionTag :: Query
|
||||
generatedTransactionTag = Tag (toRegexCI' "generated-transaction") Nothing
|
||||
|
||||
-- | A more expressive Ord, used for amt: queries. The Abs* variants
|
||||
-- compare with the absolute value of a number, ignoring sign.
|
||||
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.
|
||||
data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account
|
||||
| QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register
|
||||
-- | QueryOptCostBasis -- ^ show amounts converted to cost where possible
|
||||
-- | QueryOptDate2 -- ^ show secondary dates instead of primary dates
|
||||
deriving (Show, Eq, Data, Typeable)
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- parsing
|
||||
|
||||
@ -186,11 +175,10 @@ data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register fo
|
||||
-- 4. then all terms are AND'd together
|
||||
--
|
||||
-- >>> 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\""
|
||||
-- Right (Acct "expenses:dining out",[])
|
||||
--
|
||||
-- Right (Acct (RegexpCI "expenses:dining out"),[])
|
||||
parseQuery :: Day -> T.Text -> Either String (Query,[QueryOpt])
|
||||
parseQuery d s = do
|
||||
let termstrs = words'' prefixes s
|
||||
@ -273,11 +261,11 @@ parseQueryTerm d (T.stripPrefix "not:" -> Just s) =
|
||||
Right (Left m) -> Right $ Left $ Not m
|
||||
Right (Right _) -> Right $ Left Any -- not:somequeryoption will be ignored
|
||||
Left err -> Left err
|
||||
parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Right $ Left $ Code $ T.unpack s
|
||||
parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Right $ Left $ Desc $ T.unpack s
|
||||
parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Right $ Left $ Tag "payee" $ Just $ T.unpack s
|
||||
parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Right $ Left $ Tag "note" $ Just $ T.unpack s
|
||||
parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Right $ Left $ Acct $ T.unpack s
|
||||
parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left . Code <$> toRegexCI (T.unpack s)
|
||||
parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left . Desc <$> toRegexCI (T.unpack s)
|
||||
parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Left <$> payeeTag (Just $ T.unpack s)
|
||||
parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Left <$> noteTag (Just $ T.unpack s)
|
||||
parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI (T.unpack s)
|
||||
parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =
|
||||
case parsePeriodExpr d s of Left e -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e
|
||||
Right (_,span) -> Right $ Left $ Date2 span
|
||||
@ -295,8 +283,8 @@ parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)
|
||||
| otherwise = Left "depth: should have a positive number"
|
||||
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 "tag:" -> Just s) = Right $ Left $ Tag n v where (n,v) = parseTag s
|
||||
parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left . Sym <$> toRegexCI ('^' : T.unpack s ++ "$") -- support cur: as an alias
|
||||
parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left <$> parseTag s
|
||||
parseQueryTerm _ "" = Right $ Left $ Any
|
||||
parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s
|
||||
|
||||
@ -344,9 +332,11 @@ parseAmountQueryTerm amtarg =
|
||||
parse :: T.Text -> T.Text -> Maybe Quantity
|
||||
parse p s = (T.stripPrefix p . T.strip) s >>= readMay . filter (not.(==' ')) . T.unpack
|
||||
|
||||
parseTag :: T.Text -> (Regexp, Maybe Regexp)
|
||||
parseTag s | "=" `T.isInfixOf` s = (T.unpack n, Just $ tail $ T.unpack v)
|
||||
| otherwise = (T.unpack s, Nothing)
|
||||
parseTag :: T.Text -> Either RegexError Query
|
||||
parseTag s = do
|
||||
tag <- toRegexCI . T.unpack $ if T.null v then s else n
|
||||
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.
|
||||
@ -550,8 +540,8 @@ inAccount (QueryOptInAcct a:_) = Just (a,True)
|
||||
-- Just looks at the first query option.
|
||||
inAccountQuery :: [QueryOpt] -> Maybe Query
|
||||
inAccountQuery [] = Nothing
|
||||
inAccountQuery (QueryOptInAcctOnly a : _) = Just $ Acct $ accountNameToAccountOnlyRegex a
|
||||
inAccountQuery (QueryOptInAcct a : _) = Just $ Acct $ accountNameToAccountRegex a
|
||||
inAccountQuery (QueryOptInAcctOnly a : _) = Just . Acct $ accountNameToAccountOnlyRegex a
|
||||
inAccountQuery (QueryOptInAcct a : _) = Just . Acct $ accountNameToAccountRegex a
|
||||
|
||||
-- -- | Convert a query to its inverse.
|
||||
-- negateQuery :: Query -> Query
|
||||
@ -568,36 +558,18 @@ matchesAccount (None) _ = False
|
||||
matchesAccount (Not m) a = not $ matchesAccount m a
|
||||
matchesAccount (Or ms) a = any (`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 (Tag _ _) _ = False
|
||||
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 q (Mixed []) = q `matchesAmount` nullamt
|
||||
matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as
|
||||
|
||||
matchesCommodity :: Query -> CommoditySymbol -> Bool
|
||||
matchesCommodity (Sym r) s = regexMatchesCI ("^" ++ r ++ "$") (T.unpack s)
|
||||
matchesCommodity _ _ = 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
|
||||
matchesCommodity (Sym r) = regexMatch r . T.unpack
|
||||
matchesCommodity _ = const True
|
||||
|
||||
-- | Does the match expression match this (simple) amount ?
|
||||
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 _ _ = 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 ?
|
||||
-- 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 (Or qs) p = any (`matchesPosting` p) qs
|
||||
matchesPosting (And qs) p = all (`matchesPosting` p) qs
|
||||
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 (Code r) p = regexMatch r $ maybe "" (T.unpack . tcode) $ ptransaction p
|
||||
matchesPosting (Desc r) p = regexMatch r $ maybe "" (T.unpack . tdescription) $ ptransaction 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 (Date2 span) p = span `spanContainsDate` postingDate2 p
|
||||
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
|
||||
matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as
|
||||
matchesPosting (Tag n v) p = case (n, v) of
|
||||
("payee", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionPayee) $ ptransaction p
|
||||
("note", Just v) -> maybe False (regexMatchesCI v . T.unpack . transactionNote) $ ptransaction p
|
||||
(n, 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
|
||||
matchesPosting (Tag n v) p = case (reString n, v) of
|
||||
("payee", Just v) -> maybe False (regexMatch v . T.unpack . transactionPayee) $ ptransaction p
|
||||
("note", Just v) -> maybe False (regexMatch v . T.unpack . transactionNote) $ ptransaction p
|
||||
(_, v) -> matchesTags n v $ postingAllTags p
|
||||
|
||||
-- | Does the match expression match this transaction ?
|
||||
matchesTransaction :: Query -> Transaction -> Bool
|
||||
@ -700,8 +635,8 @@ matchesTransaction (Any) _ = True
|
||||
matchesTransaction (None) _ = False
|
||||
matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs
|
||||
matchesTransaction (And qs) t = all (`matchesTransaction` t) qs
|
||||
matchesTransaction (Code r) t = regexMatchesCI r $ T.unpack $ tcode t
|
||||
matchesTransaction (Desc r) t = regexMatchesCI r $ T.unpack $ tdescription t
|
||||
matchesTransaction (Code r) t = regexMatch r $ T.unpack $ tcode t
|
||||
matchesTransaction (Desc r) t = regexMatch r $ T.unpack $ tdescription t
|
||||
matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t
|
||||
matchesTransaction (Date span) t = spanContainsDate span $ tdate 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 (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t
|
||||
matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t
|
||||
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
|
||||
|
||||
-- | 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
|
||||
matchesTransaction (Tag n v) t = case (reString n, v) of
|
||||
("payee", Just v) -> regexMatch v . T.unpack . transactionPayee $ t
|
||||
("note", Just v) -> regexMatch v . T.unpack . transactionNote $ t
|
||||
(_, v) -> matchesTags n v $ transactionAllTags t
|
||||
|
||||
-- | Does the query match the name and optionally the value of any of these tags ?
|
||||
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
|
||||
match npat Nothing (n,_) = regexMatchesCI npat (T.unpack n) -- XXX
|
||||
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
|
||||
matches npat vpat (n,v) = regexMatch npat (T.unpack n) && maybe (const True) regexMatch vpat (T.unpack v)
|
||||
|
||||
-- | Does the query match this market price ?
|
||||
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 _ _ = 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_Query = tests "Query" [
|
||||
test "simplifyQuery" $ do
|
||||
(simplifyQuery $ Or [Acct "a"]) @?= (Acct "a")
|
||||
(simplifyQuery $ Or [Acct $ toRegex' "a"]) @?= (Acct $ toRegex' "a")
|
||||
(simplifyQuery $ Or [Any,None]) @?= (Any)
|
||||
(simplifyQuery $ And [Any,None]) @?= (None)
|
||||
(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 [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)))
|
||||
(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
|
||||
(parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") @?= Right (And [Acct "expenses:autres d\233penses", Desc "b"], [])
|
||||
parseQuery nulldate "inacct:a desc:\"b b\"" @?= Right (Desc "b b", [QueryOptInAcct "a"])
|
||||
(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 $ toRegexCI' "b b", [QueryOptInAcct "a"])
|
||||
parseQuery nulldate "inacct:a inacct:b" @?= Right (Any, [QueryOptInAcct "a", QueryOptInAcct "b"])
|
||||
parseQuery nulldate "desc:'x x'" @?= Right (Desc "x x", [])
|
||||
parseQuery nulldate "'a a' 'b" @?= Right (Or [Acct "a a",Acct "'b"], [])
|
||||
parseQuery nulldate "\"" @?= Right (Acct "\"", [])
|
||||
parseQuery nulldate "desc:'x x'" @?= Right (Desc $ toRegexCI' "x x", [])
|
||||
parseQuery nulldate "'a a' 'b" @?= Right (Or [Acct $ toRegexCI' "a a",Acct $ toRegexCI' "'b"], [])
|
||||
parseQuery nulldate "\"" @?= Right (Acct $ toRegexCI' "\"", [])
|
||||
|
||||
,test "words''" $ do
|
||||
(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
|
||||
|
||||
,test "parseQueryTerm" $ do
|
||||
parseQueryTerm nulldate "a" @?= Right (Left $ Acct "a")
|
||||
parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= Right (Left $ Acct "expenses:autres d\233penses")
|
||||
parseQueryTerm nulldate "not:desc:a b" @?= Right (Left $ Not $ Desc "a b")
|
||||
parseQueryTerm nulldate "a" @?= Right (Left $ Acct $ toRegexCI' "a")
|
||||
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 $ toRegexCI' "a b")
|
||||
parseQueryTerm nulldate "status:1" @?= Right (Left $ StatusQ Cleared)
|
||||
parseQueryTerm nulldate "status:*" @?= Right (Left $ StatusQ Cleared)
|
||||
parseQueryTerm nulldate "status:!" @?= Right (Left $ StatusQ Pending)
|
||||
parseQueryTerm nulldate "status:0" @?= Right (Left $ StatusQ Unmarked)
|
||||
parseQueryTerm nulldate "status:" @?= Right (Left $ StatusQ Unmarked)
|
||||
parseQueryTerm nulldate "payee:x" @?= Right (Left $ Tag "payee" (Just "x"))
|
||||
parseQueryTerm nulldate "note:x" @?= Right (Left $ Tag "note" (Just "x"))
|
||||
parseQueryTerm nulldate "payee:x" @?= Left <$> payeeTag (Just "x")
|
||||
parseQueryTerm nulldate "note:x" @?= Left <$> noteTag (Just "x")
|
||||
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: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 "inacct:a" @?= Right (Right $ QueryOptInAcct "a")
|
||||
parseQueryTerm nulldate "tag:a" @?= Right (Left $ Tag "a" Nothing)
|
||||
parseQueryTerm nulldate "tag:a=some value" @?= Right (Left $ Tag "a" (Just "some value"))
|
||||
parseQueryTerm nulldate "tag:a" @?= Right (Left $ Tag (toRegexCI' "a") Nothing)
|
||||
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:>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
|
||||
|
||||
,test "matchesAccount" $ do
|
||||
assertBool "" $ (Acct "b:c") `matchesAccount` "a:bb:c:d"
|
||||
assertBool "" $ not $ (Acct "^a:b") `matchesAccount` "c:a:b"
|
||||
assertBool "" $ (Acct $ toRegex' "b:c") `matchesAccount` "a:bb:c:d"
|
||||
assertBool "" $ not $ (Acct $ toRegex' "^a:b") `matchesAccount` "c:a:b"
|
||||
assertBool "" $ Depth 2 `matchesAccount` "a"
|
||||
assertBool "" $ Depth 2 `matchesAccount` "a:b"
|
||||
assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c"
|
||||
assertBool "" $ Date 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" [
|
||||
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 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 "acct:" $ assertBool "" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"}
|
||||
,test "acct:" $ assertBool "" $ (Acct $ toRegex' "'b") `matchesPosting` nullposting{paccount="'b"}
|
||||
,test "tag:" $ do
|
||||
assertBool "" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting
|
||||
assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}
|
||||
assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}
|
||||
assertBool "" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
|
||||
assertBool "" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
|
||||
assertBool "" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
|
||||
assertBool "" $ not $ (Tag "foo foo" (Just " 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","")]}}
|
||||
assertBool "" $ not $ (Tag (toRegex' "a") (Just $ toRegex' "r$")) `matchesPosting` nullposting
|
||||
assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}
|
||||
assertBool "" $ (Tag (toRegex' "foo") Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}
|
||||
assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
|
||||
assertBool "" $ not $ (Tag (toRegex' "foo") (Just $ toRegex' "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
|
||||
assertBool "" $ not $ (Tag (toRegex' " foo ") (Just $ toRegex' "a")) `matchesPosting` nullposting{ptags=[("foo","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 (toRegex' "txntag") Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}
|
||||
,test "cur:" $ do
|
||||
assertBool "" $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol
|
||||
assertBool "" $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr
|
||||
assertBool "" $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
|
||||
assertBool "" $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
|
||||
let toSym = either id (const $ error' "No query opts") . either error' id . parseQueryTerm (fromGregorian 2000 01 01) . ("cur:"<>)
|
||||
assertBool "" $ not $ toSym "$" `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol
|
||||
assertBool "" $ (toSym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr
|
||||
assertBool "" $ (toSym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
|
||||
assertBool "" $ not $ (toSym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
|
||||
]
|
||||
|
||||
,test "matchesTransaction" $ do
|
||||
assertBool "" $ Any `matchesTransaction` nulltransaction
|
||||
assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"}
|
||||
assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"}
|
||||
assertBool "" $ not $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x"}
|
||||
assertBool "" $ (Desc $ toRegex' "x x") `matchesTransaction` nulltransaction{tdescription="x x"}
|
||||
-- see posting for more tag tests
|
||||
assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}
|
||||
assertBool "" $ (Tag "payee" (Just "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"}
|
||||
assertBool "" $ (Tag "note" (Just "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"}
|
||||
assertBool "" $ (Tag (toRegex' "foo") (Just $ toRegex' "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}
|
||||
assertBool "" $ (Tag (toRegex' "payee") (Just $ toRegex' "payee")) `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
|
||||
assertBool "" $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}
|
||||
assertBool "" $ (Tag (toRegex' "postingtag") Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}
|
||||
|
||||
]
|
||||
|
||||
@ -14,7 +14,6 @@ Some of these might belong in Hledger.Read.JournalReader or Hledger.Read.
|
||||
--- ** language
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
@ -116,32 +115,33 @@ where
|
||||
--- ** imports
|
||||
import Prelude ()
|
||||
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 Control.Monad.Except (ExceptT(..), runExceptT, throwError)
|
||||
import Control.Monad.State.Strict hiding (fail)
|
||||
import Data.Bifunctor (bimap, second)
|
||||
import Data.Char
|
||||
import Data.Data
|
||||
import Data.Char (digitToInt, isDigit, isSpace)
|
||||
import Data.Decimal (DecimalRaw (Decimal), Decimal)
|
||||
import Data.Default
|
||||
import Data.Default (Default(..))
|
||||
import Data.Function ((&))
|
||||
import Data.Functor.Identity
|
||||
import Data.Functor.Identity (Identity)
|
||||
import "base-compat-batteries" Data.List.Compat
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import Data.Maybe
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Semigroup as Sem
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.LocalTime
|
||||
import Data.Time.Calendar (Day, fromGregorianValid, toGregorian)
|
||||
import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..))
|
||||
import Data.Word (Word8)
|
||||
import System.Time (getClockTime)
|
||||
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.Custom
|
||||
import Control.Applicative.Permutations
|
||||
(FinalParseError, attachSource, customErrorBundlePretty,
|
||||
finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)
|
||||
|
||||
import Hledger.Data
|
||||
import Hledger.Utils
|
||||
@ -194,7 +194,7 @@ data InputOpts = InputOpts {
|
||||
,new_save_ :: Bool -- ^ save latest new transactions state for next time
|
||||
,pivot_ :: String -- ^ use the given field's value as the account name
|
||||
,auto_ :: Bool -- ^ generate automatic postings when journal is parsed
|
||||
} deriving (Show, Data) --, Typeable)
|
||||
} deriving (Show)
|
||||
|
||||
instance Default InputOpts where def = definputopts
|
||||
|
||||
|
||||
@ -41,19 +41,21 @@ where
|
||||
--- ** imports
|
||||
import Prelude ()
|
||||
import "base-compat-batteries" Prelude.Compat hiding (fail)
|
||||
import Control.Applicative (liftA2)
|
||||
import Control.Exception (IOException, handle, throw)
|
||||
import Control.Monad (liftM, unless, when)
|
||||
import Control.Monad.Except (ExceptT, throwError)
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Control.Monad.State.Strict (StateT, get, modify', evalStateT)
|
||||
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 "base-compat-batteries" Data.List.Compat
|
||||
import qualified Data.List.Split as LS (splitOn)
|
||||
import Data.Maybe
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust)
|
||||
import Data.MemoUgly (memo)
|
||||
import Data.Ord
|
||||
import Data.Ord (comparing)
|
||||
import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
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 Data.Time.Calendar (Day)
|
||||
import Data.Time.Format (parseTimeM, defaultTimeLocale)
|
||||
import Safe
|
||||
import Safe (atMay, headMay, lastMay, readDef, readMay)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.FilePath
|
||||
import System.FilePath ((</>), takeDirectory, takeExtension, takeFileName)
|
||||
import qualified Data.Csv as Cassava
|
||||
import qualified Data.Csv.Parser.Megaparsec as CassavaMP
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Foldable
|
||||
import Text.Megaparsec hiding (parse)
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Custom
|
||||
import Data.Foldable (asum, toList)
|
||||
import Text.Megaparsec hiding (match, parse)
|
||||
import Text.Megaparsec.Char (char, newline, string)
|
||||
import Text.Megaparsec.Custom (customErrorBundlePretty, parseErrorAt)
|
||||
import Text.Printf (printf)
|
||||
|
||||
import Hledger.Data
|
||||
@ -294,17 +296,14 @@ type FieldTemplate = String
|
||||
-- | A strptime date parsing pattern, as supported by Data.Time.Format.
|
||||
type DateFormat = String
|
||||
|
||||
-- | A regular expression.
|
||||
type RegexpPattern = String
|
||||
|
||||
-- | A prefix for a matcher test, either & or none (implicit or).
|
||||
data MatcherPrefix = And | None
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | A single test for matching a CSV record, in one way or another.
|
||||
data Matcher =
|
||||
RecordMatcher MatcherPrefix RegexpPattern -- ^ match if this regexp matches the overall CSV record
|
||||
| FieldMatcher MatcherPrefix CsvFieldReference RegexpPattern -- ^ match if this regexp matches the referenced CSV field's value
|
||||
RecordMatcher MatcherPrefix Regexp -- ^ match if this regexp matches the overall CSV record
|
||||
| FieldMatcher MatcherPrefix CsvFieldReference Regexp -- ^ match if this regexp matches the referenced CSV field's value
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | 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)
|
||||
p <- matcherprefixp
|
||||
r <- regexp end
|
||||
return $ RecordMatcher p r
|
||||
-- when (null ps) $
|
||||
-- Fail.fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n"
|
||||
return $ RecordMatcher p r
|
||||
<?> "record matcher"
|
||||
|
||||
-- | A single matcher for a specific field. A csv field reference
|
||||
@ -656,13 +655,15 @@ csvfieldreferencep = do
|
||||
return $ '%' : quoteIfNeeded f
|
||||
|
||||
-- A single regular expression
|
||||
regexp :: CsvRulesParser () -> CsvRulesParser RegexpPattern
|
||||
regexp :: CsvRulesParser () -> CsvRulesParser Regexp
|
||||
regexp end = do
|
||||
lift $ dbgparse 8 "trying regexp"
|
||||
-- notFollowedBy matchoperatorp
|
||||
c <- lift nonspace
|
||||
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.
|
||||
-- -- Currently just ~ meaning case insensitive infix regex match.
|
||||
@ -834,10 +835,9 @@ validateCsv rules numhdrlines (Right rs) = validate $ applyConditionalSkips $ dr
|
||||
Nothing -> r:(applyConditionalSkips rest)
|
||||
Just cnt -> applyConditionalSkips (drop (cnt-1) rest)
|
||||
validate [] = Right []
|
||||
validate rs@(_first:_)
|
||||
| isJust lessthan2 = let r = fromJust lessthan2 in
|
||||
Left $ printf "CSV record %s has less than two fields" (show r)
|
||||
| otherwise = Right rs
|
||||
validate rs@(_first:_) = case lessthan2 of
|
||||
Just r -> Left $ printf "CSV record %s has less than two fields" (show r)
|
||||
Nothing -> Right rs
|
||||
where
|
||||
lessthan2 = headMay $ filter ((<2).length) rs
|
||||
|
||||
@ -1181,7 +1181,7 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
|
||||
where
|
||||
-- does this individual matcher match the current csv record ?
|
||||
matcherMatches :: Matcher -> Bool
|
||||
matcherMatches (RecordMatcher _ pat) = regexMatchesCI pat' wholecsvline
|
||||
matcherMatches (RecordMatcher _ pat) = regexMatch pat' wholecsvline
|
||||
where
|
||||
pat' = dbg7 "regex" pat
|
||||
-- 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
|
||||
-- which means that a field containing a comma will look like two fields.
|
||||
wholecsvline = dbg7 "wholecsvline" $ intercalate "," record
|
||||
matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatchesCI pat csvfieldvalue
|
||||
matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatch pat csvfieldvalue
|
||||
where
|
||||
-- the value of the referenced CSV field to match against.
|
||||
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
|
||||
-- CSV field values. Outer whitespace is removed from interpolated values.
|
||||
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)
|
||||
-- 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" $
|
||||
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" [
|
||||
test "space after conditional" $ -- #1120
|
||||
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" [
|
||||
test "number" $ parseWithState' defrules csvfieldreferencep "%1" @?= (Right "%1")
|
||||
@ -1272,19 +1278,19 @@ tests_CsvReader = tests "CsvReader" [
|
||||
,tests "matcherp" [
|
||||
|
||||
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-&" $
|
||||
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-%" $
|
||||
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" $
|
||||
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-&" $
|
||||
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" $
|
||||
-- parseWithState' defrules matcherp "%description ~ A A\n" @?= (Right $ FieldMatcher "%description" "A A")
|
||||
@ -1296,19 +1302,19 @@ tests_CsvReader = tests "CsvReader" [
|
||||
|
||||
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")
|
||||
|
||||
,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")
|
||||
|
||||
,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")
|
||||
|
||||
,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")
|
||||
|
||||
,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")
|
||||
|
||||
]
|
||||
|
||||
@ -529,8 +529,8 @@ regexaliasp = do
|
||||
char '='
|
||||
skipNonNewlineSpaces
|
||||
repl <- anySingle `manyTill` eolof
|
||||
case toRegex_ re of
|
||||
Right _ -> return $! RegexAlias re repl
|
||||
case toRegexCI re of
|
||||
Right r -> return $! RegexAlias r repl
|
||||
Left e -> customFailure $! parseErrorAtRegion off1 off2 e
|
||||
|
||||
endaliasesdirectivep :: JournalParser m ()
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}
|
||||
{-|
|
||||
|
||||
Generate several common kinds of report from a journal, as \"*Report\" -
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}
|
||||
{-|
|
||||
|
||||
An account-centric transactions report.
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-}
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances, ScopedTypeVariables #-}
|
||||
{-|
|
||||
|
||||
Journal entries report, used by the print command.
|
||||
@ -50,7 +50,7 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
|
||||
|
||||
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
|
||||
]
|
||||
]
|
||||
|
||||
@ -4,7 +4,6 @@ Postings report, used by the register command.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
@ -277,13 +276,13 @@ tests_PostingsReport = tests "PostingsReport" [
|
||||
(Any, samplejournal) `gives` 13
|
||||
-- register --depth just clips account names
|
||||
(Depth 2, samplejournal) `gives` 13
|
||||
(And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2
|
||||
(And [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 (toRegex' "expenses")], samplejournal) `gives` 2
|
||||
-- with query and/or command-line options
|
||||
(length $ snd $ postingsReport defreportopts Any samplejournal) @?= 13
|
||||
(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 (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
|
||||
-- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking $1,$1)
|
||||
@ -374,7 +373,7 @@ tests_PostingsReport = tests "PostingsReport" [
|
||||
j <- samplejournal
|
||||
let gives displayexpr =
|
||||
(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","2008/06/02"]
|
||||
"d=[2008/6/2]" `gives` ["2008/06/02"]
|
||||
|
||||
@ -4,7 +4,6 @@ Options common to most hledger reports.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
@ -49,14 +48,12 @@ module Hledger.Reports.ReportOptions (
|
||||
where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Data (Data)
|
||||
import Data.List.Extra (nubSort)
|
||||
import Data.Maybe
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Time.Calendar
|
||||
import Data.Default
|
||||
import Safe
|
||||
import Data.Time.Calendar (Day, addDays, fromGregorian)
|
||||
import Data.Default (Default(..))
|
||||
import Safe (lastDef, lastMay)
|
||||
|
||||
import System.Console.ANSI (hSupportsANSIColor)
|
||||
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
|
||||
-- all postings before the report period. Unless altered by,
|
||||
-- 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
|
||||
|
||||
-- | 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
|
||||
|
||||
@ -101,7 +98,6 @@ data ReportOpts = ReportOpts {
|
||||
,value_ :: Maybe ValuationType -- ^ What value should amounts be converted to ?
|
||||
,infer_value_ :: Bool -- ^ Infer market prices from transactions ?
|
||||
,depth_ :: Maybe Int
|
||||
,display_ :: Maybe DisplayExp -- XXX unused ?
|
||||
,date2_ :: Bool
|
||||
,empty_ :: Bool
|
||||
,no_elide_ :: Bool
|
||||
@ -140,7 +136,7 @@ data ReportOpts = ReportOpts {
|
||||
-- TERM and existence of NO_COLOR environment variables.
|
||||
,forecast_ :: Maybe DateSpan
|
||||
,transpose_ :: Bool
|
||||
} deriving (Show, Data, Typeable)
|
||||
} deriving (Show)
|
||||
|
||||
instance Default ReportOpts where def = defreportopts
|
||||
|
||||
@ -175,7 +171,6 @@ defreportopts = ReportOpts
|
||||
def
|
||||
def
|
||||
def
|
||||
def
|
||||
|
||||
rawOptsToReportOpts :: RawOpts -> IO ReportOpts
|
||||
rawOptsToReportOpts rawopts = checkReportOpts <$> do
|
||||
@ -192,7 +187,6 @@ rawOptsToReportOpts rawopts = checkReportOpts <$> do
|
||||
,value_ = valuationTypeFromRawOpts rawopts'
|
||||
,infer_value_ = boolopt "infer-value" rawopts'
|
||||
,depth_ = maybeposintopt "depth" rawopts'
|
||||
,display_ = maybedisplayopt d rawopts'
|
||||
,date2_ = boolopt "date2" rawopts'
|
||||
,empty_ = boolopt "empty" rawopts'
|
||||
,no_elide_ = boolopt "no-elide" rawopts'
|
||||
@ -419,15 +413,6 @@ valuationTypeIsDefaultValue ropts =
|
||||
Just (AtDefault _) -> True
|
||||
_ -> 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.
|
||||
transactionDateFn :: ReportOpts -> (Transaction -> Day)
|
||||
transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate
|
||||
@ -573,12 +558,12 @@ reportPeriodOrJournalLastDay ropts j =
|
||||
tests_ReportOptions = tests "ReportOptions" [
|
||||
test "queryFromOpts" $ do
|
||||
queryFromOpts nulldate defreportopts @?= Any
|
||||
queryFromOpts nulldate defreportopts{query_="a"} @?= Acct "a"
|
||||
queryFromOpts nulldate defreportopts{query_="desc:'a a'"} @?= Desc "a a"
|
||||
queryFromOpts nulldate defreportopts{query_="a"} @?= Acct (toRegexCI' "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'" }
|
||||
@?= (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_="'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
|
||||
queryOptsFromOpts nulldate defreportopts @?= []
|
||||
@ -586,4 +571,3 @@ tests_ReportOptions = tests "ReportOptions" [
|
||||
queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (fromGregorian 2012 01 01)
|
||||
,query_="date:'to 2013'"} @?= []
|
||||
]
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, DeriveDataTypeable, FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-}
|
||||
{-|
|
||||
|
||||
A transactions report. Like an EntriesReport, but with more
|
||||
|
||||
@ -1,4 +1,7 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-|
|
||||
|
||||
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:
|
||||
|
||||
- The old partial one which will call error on any problem (eg with malformed
|
||||
regexps). This comes from hledger's origin as a command-line tool.
|
||||
- The old partial one (with ' suffixes') which will call error on any problem
|
||||
(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
|
||||
is better for 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.
|
||||
- The new total one which will return an error message. This is better for
|
||||
long-running apps like hledger-web.
|
||||
|
||||
Current limitations:
|
||||
|
||||
@ -42,48 +43,106 @@ Current limitations:
|
||||
-}
|
||||
|
||||
module Hledger.Utils.Regex (
|
||||
-- * Regexp type and constructors
|
||||
Regexp(reString)
|
||||
,toRegex
|
||||
,toRegexCI
|
||||
,toRegex'
|
||||
,toRegexCI'
|
||||
-- * type aliases
|
||||
Regexp
|
||||
,Replacement
|
||||
,RegexError
|
||||
-- * partial regex operations (may call error)
|
||||
,regexMatches
|
||||
,regexMatchesCI
|
||||
,regexReplace
|
||||
,regexReplaceCI
|
||||
,regexReplaceMemo
|
||||
,regexReplaceCIMemo
|
||||
,regexReplaceBy
|
||||
,regexReplaceByCI
|
||||
-- * total regex operations
|
||||
,regexMatches_
|
||||
,regexMatchesCI_
|
||||
,regexReplace_
|
||||
,regexReplaceCI_
|
||||
,regexReplaceMemo_
|
||||
,regexReplaceCIMemo_
|
||||
,regexReplaceBy_
|
||||
,regexReplaceByCI_
|
||||
,toRegex_
|
||||
,regexMatch
|
||||
,regexReplace
|
||||
,regexReplaceUnmemo
|
||||
,regexReplaceAllBy
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Data.Array
|
||||
import Data.Char
|
||||
import Data.Aeson (ToJSON(..), Value(String))
|
||||
import Data.Array ((!), elems, indices)
|
||||
import Data.Char (isDigit)
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.MemoUgly (memo)
|
||||
import qualified Data.Text as T
|
||||
import Text.Regex.TDFA (
|
||||
Regex, CompOption(..), ExecOption(..), defaultCompOpt, defaultExecOpt,
|
||||
makeRegexOptsM, AllMatches(getAllMatches), match, (=~), MatchText
|
||||
Regex, CompOption(..), defaultCompOpt, defaultExecOpt,
|
||||
makeRegexOptsM, AllMatches(getAllMatches), match, MatchText,
|
||||
RegexLike(..), RegexMaker(..), RegexOptions(..), RegexContext(..)
|
||||
)
|
||||
|
||||
import Hledger.Utils.UTF8IOCompat (error')
|
||||
|
||||
|
||||
-- | 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).
|
||||
type Replacement = String
|
||||
@ -91,143 +150,32 @@ type Replacement = String
|
||||
-- | An regular expression compilation/processing error message.
|
||||
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
|
||||
|
||||
-- | Convert our string-based Regexp to a real Regex.
|
||||
-- Or if it's not well formed, call error with a "malformed regexp" message.
|
||||
toRegex :: Regexp -> Regex
|
||||
toRegex = memo (compileRegex defaultCompOpt defaultExecOpt) -- PARTIAL:
|
||||
|
||||
-- | 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"
|
||||
-- | Test whether a Regexp matches a String. This is an alias for `matchTest` for consistent
|
||||
-- naming.
|
||||
regexMatch :: Regexp -> String -> Bool
|
||||
regexMatch = matchTest
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- new total functions
|
||||
|
||||
-- | Does this regexp match the given string ?
|
||||
-- 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
|
||||
-- | A memoising version of regexReplace. Caches the result for each
|
||||
-- search pattern, replacement pattern, target string tuple.
|
||||
regexReplaceMemo_ :: Regexp -> Replacement -> String -> Either RegexError String
|
||||
regexReplaceMemo_ re repl = memo (regexReplace_ 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
|
||||
regexReplace :: Regexp -> Replacement -> String -> Either RegexError String
|
||||
regexReplace re repl = memo $ regexReplaceUnmemo re repl
|
||||
|
||||
-- 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
|
||||
-- string, or return an error message.
|
||||
replaceRegex_ :: Regex -> Replacement -> String -> Either RegexError String
|
||||
replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s :: [MatchText String])
|
||||
regexReplaceUnmemo :: Regexp -> Replacement -> String -> Either RegexError String
|
||||
regexReplaceUnmemo re repl s = foldM (replaceMatch repl) s (reverse $ match (reCompiled re) s :: [MatchText String])
|
||||
where
|
||||
-- Replace one match within the string with the replacement text
|
||||
-- appropriate for this match. Or return an error message.
|
||||
replaceMatch_ :: Replacement -> String -> MatchText String -> Either RegexError String
|
||||
replaceMatch_ replpat s matchgroups =
|
||||
replaceMatch :: Replacement -> String -> MatchText String -> Either RegexError String
|
||||
replaceMatch replpat s matchgroups =
|
||||
erepl >>= \repl -> Right $ 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
|
||||
@ -236,15 +184,37 @@ replaceRegex_ re repl s = foldM (replaceMatch_ repl) s (reverse $ match re s ::
|
||||
-- The replacement text: the replacement pattern with all
|
||||
-- numeric backreferences replaced by the appropriate groups
|
||||
-- from this match. Or an error message.
|
||||
erepl = toRegex_ "\\\\[0-9]+" >>= \rx -> replaceAllByM rx (lookupMatchGroup_ matchgroups) replpat
|
||||
erepl = regexReplaceAllByM backrefRegex (lookupMatchGroup matchgroups) replpat
|
||||
where
|
||||
-- Given some match groups and a numeric backreference,
|
||||
-- return the referenced group text, or an error message.
|
||||
lookupMatchGroup_ :: MatchText String -> String -> Either RegexError String
|
||||
lookupMatchGroup_ grps ('\\':s@(_:_)) | all isDigit s =
|
||||
lookupMatchGroup :: MatchText String -> String -> Either RegexError String
|
||||
lookupMatchGroup grps ('\\':s@(_:_)) | all isDigit s =
|
||||
case read s of n | n `elem` indices grps -> Right $ fst (grps ! n)
|
||||
_ -> 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
|
||||
|
||||
@ -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
|
||||
-- with the given pure function.
|
||||
replaceAllBy :: Regex -> (String -> String) -> String -> String
|
||||
replaceAllBy re transform s = prependdone rest
|
||||
regexReplaceAllBy :: Regexp -> (String -> String) -> String -> String
|
||||
regexReplaceAllBy re transform s = prependdone rest
|
||||
where
|
||||
(_, rest, prependdone) = foldl' go (0, s, id) matches
|
||||
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 (pos,todo,prepend) (off,len) =
|
||||
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
|
||||
-- from the transform function short-circuits and is returned as the overall
|
||||
-- result.
|
||||
replaceAllByM :: forall m. Monad m => Regex -> (String -> m String) -> String -> m String
|
||||
replaceAllByM re transform s =
|
||||
regexReplaceAllByM :: forall m. Monad m => Regexp -> (String -> m String) -> String -> m String
|
||||
regexReplaceAllByM re transform s =
|
||||
foldM go (0, s, id) matches >>= \(_, rest, prependdone) -> pure $ prependdone rest
|
||||
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 (pos,todo,prepend) (off,len) =
|
||||
let (prematch, matchandrest) = splitAt (off - pos) todo
|
||||
(matched, rest) = splitAt len matchandrest
|
||||
in transform matched >>= \matched' -> pure (off + len, rest, prepend . (prematch++) . (matched' ++))
|
||||
|
||||
|
||||
@ -13,7 +13,6 @@ module Hledger.Utils.String (
|
||||
singleQuoteIfNeeded,
|
||||
-- quotechars,
|
||||
-- whitespacechars,
|
||||
escapeQuotes,
|
||||
words',
|
||||
unwords',
|
||||
stripAnsi,
|
||||
@ -49,14 +48,14 @@ module Hledger.Utils.String (
|
||||
) where
|
||||
|
||||
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char
|
||||
import Data.Char (isDigit, isSpace, toLower, toUpper)
|
||||
import Data.List (intercalate, transpose)
|
||||
import Text.Megaparsec (Parsec, (<|>), (<?>), between, many, noneOf, oneOf,
|
||||
parseMaybe, sepBy, takeWhile1P)
|
||||
import Text.Megaparsec.Char (char, string)
|
||||
import Text.Printf (printf)
|
||||
|
||||
import Hledger.Utils.Parse
|
||||
import Hledger.Utils.Regex
|
||||
|
||||
|
||||
-- | 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
|
||||
-- or double-quotes, escaping the quotes as needed.
|
||||
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
|
||||
|
||||
-- | Single-quote this string if it contains whitespace or double-quotes.
|
||||
-- No good for strings containing single quotes.
|
||||
singleQuoteIfNeeded :: String -> String
|
||||
@ -133,12 +133,6 @@ quotechars = "'\""
|
||||
whitespacechars = " \t\n\r"
|
||||
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.
|
||||
-- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails.
|
||||
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
|
||||
-- line determines the width).
|
||||
strWidth :: String -> Int
|
||||
strWidth "" = 0
|
||||
strWidth s = maximum $ map (foldr (\a b -> charWidth a + b) 0) $ lines s'
|
||||
where s' = stripAnsi s
|
||||
strWidth = maximum . (0:) . map (foldr (\a b -> charWidth a + b) 0) . lines . stripAnsi
|
||||
|
||||
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
|
||||
-- character, 1 for a regular character, 2 for a wide character.
|
||||
|
||||
@ -1,77 +1,18 @@
|
||||
module Hledger.Utils.Tree where
|
||||
module Hledger.Utils.Tree
|
||||
( FastTree(..)
|
||||
, treeFromPaths
|
||||
) where
|
||||
|
||||
-- import Data.Char
|
||||
import Data.List (foldl')
|
||||
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
|
||||
-- better than accountNameTreeFrom.
|
||||
newtype FastTree a = T (M.Map a (FastTree a))
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
emptyTree :: FastTree a
|
||||
emptyTree = T M.empty
|
||||
|
||||
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 = foldl' mergeTrees emptyTree . map treeFromPath
|
||||
|
||||
|
||||
|
||||
@ -1,10 +1,10 @@
|
||||
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
|
||||
--
|
||||
-- hash: ca2b9f025d75c0b65f91b2e5fe7203d00d1d9f8c423c8c4f0cb7675df848a5aa
|
||||
-- hash: e8ee8c99329f53fe86ae9df138d05c8c39726a66da2ad1da3ae27500c45b2591
|
||||
|
||||
name: hledger-lib
|
||||
version: 1.18.99
|
||||
@ -124,7 +124,6 @@ library
|
||||
, cmdargs >=0.10
|
||||
, containers
|
||||
, data-default >=0.5
|
||||
, deepseq
|
||||
, directory
|
||||
, extra >=1.6.3
|
||||
, fgl >=5.5.4.0
|
||||
@ -177,7 +176,6 @@ test-suite doctest
|
||||
, cmdargs >=0.10
|
||||
, containers
|
||||
, data-default >=0.5
|
||||
, deepseq
|
||||
, directory
|
||||
, doctest >=0.16.3
|
||||
, extra >=1.6.3
|
||||
@ -233,7 +231,6 @@ test-suite unittest
|
||||
, cmdargs >=0.10
|
||||
, containers
|
||||
, data-default >=0.5
|
||||
, deepseq
|
||||
, directory
|
||||
, extra >=1.6.3
|
||||
, fgl >=5.5.4.0
|
||||
|
||||
@ -59,7 +59,6 @@ dependencies:
|
||||
- cassava-megaparsec
|
||||
- data-default >=0.5
|
||||
- Decimal >=0.5.1
|
||||
- deepseq
|
||||
- directory
|
||||
- fgl >=5.5.4.0
|
||||
- file-embed >=0.0.10
|
||||
|
||||
@ -90,7 +90,7 @@ asInit d reset ui@UIState{
|
||||
excludeforecastq Nothing = -- not:date:tomorrow- not:tag:generated-transaction
|
||||
And [
|
||||
Not (Date $ DateSpan (Just $ addDays 1 d) Nothing)
|
||||
,Not (Tag "generated-transaction" Nothing)
|
||||
,Not generatedTransactionTag
|
||||
]
|
||||
|
||||
-- run the report
|
||||
|
||||
@ -120,9 +120,11 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportopts_=rop
|
||||
-- to that as usual.
|
||||
Just apat -> (rsSetAccount acct False registerScreen, [ascr'])
|
||||
where
|
||||
acct = headDef
|
||||
(error' $ "--register "++apat++" did not match any account") -- PARTIAL:
|
||||
$ filter (regexMatches apat . T.unpack) $ journalAccountNames j
|
||||
acct = headDef (error' $ "--register "++apat++" did not match any account") -- PARTIAL:
|
||||
. filterAccts $ journalAccountNames j
|
||||
filterAccts = case toRegexCI apat of
|
||||
Right re -> filter (regexMatch re . T.unpack)
|
||||
Left _ -> const []
|
||||
-- Initialising the accounts screen is awkward, requiring
|
||||
-- another temporary UIState value..
|
||||
ascr' = aScreen $
|
||||
|
||||
@ -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
|
||||
And [
|
||||
Not (Date $ DateSpan (Just $ addDays 1 d) Nothing)
|
||||
,Not (Tag "generated-transaction" Nothing)
|
||||
,Not generatedTransactionTag
|
||||
]
|
||||
|
||||
(_label,items) = accountTransactionsReport ropts' j q thisacctq
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-|
|
||||
|
||||
|
||||
@ -106,16 +106,13 @@ addForm j today = identifyForm "add" $ \extra -> do
|
||||
intercalate "," $ map (
|
||||
("{\"value\":" ++).
|
||||
(++"}").
|
||||
escapeJSSpecialChars .
|
||||
drop 7 . -- "String "
|
||||
show .
|
||||
toJSON
|
||||
-- avoid https://github.com/simonmichael/hledger/issues/236
|
||||
T.replace "</script>" "<\\/script>"
|
||||
) ts,
|
||||
"]"
|
||||
]
|
||||
where
|
||||
-- avoid https://github.com/simonmichael/hledger/issues/236
|
||||
escapeJSSpecialChars = regexReplaceCI "</script>" "<\\/script>"
|
||||
|
||||
validateTransaction ::
|
||||
FormResult Day
|
||||
|
||||
@ -72,7 +72,7 @@ writeJournalTextIfValidAndChanged f t = do
|
||||
-- Ensure unix line endings, since both readJournal (cf
|
||||
-- formatdirectivep, #1194) writeFileWithBackupIfChanged require them.
|
||||
-- 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
|
||||
Left e -> return (Left e)
|
||||
Right _ -> do
|
||||
|
||||
@ -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 (
|
||||
|
||||
@ -413,7 +413,7 @@ data CliOpts = CliOpts {
|
||||
-- 1. the COLUMNS env var, if set
|
||||
-- 2. the width reported by the terminal, if supported
|
||||
-- 3. the default (80)
|
||||
} deriving (Show, Data, Typeable)
|
||||
} deriving (Show)
|
||||
|
||||
instance Default CliOpts where def = defcliopts
|
||||
|
||||
|
||||
@ -137,7 +137,7 @@ builtinCommands = [
|
||||
-- | The commands list, showing command names, standard aliases,
|
||||
-- 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:
|
||||
-- COMMAND (ALIASES) DESCRIPTION
|
||||
@ -152,10 +152,10 @@ builtinCommands = [
|
||||
--
|
||||
-- TODO: generate more of this automatically.
|
||||
--
|
||||
commandsList :: String
|
||||
commandsList = unlines [
|
||||
commandsList :: String -> [String] -> [String]
|
||||
commandsList progversion othercmds = [
|
||||
"-------------------------------------------------------------------------------"
|
||||
,"PROGVERSION"
|
||||
,progversion
|
||||
,"Usage: hledger COMMAND [OPTIONS] [-- ADDONCMDOPTIONS]"
|
||||
,"Commands (+ addons found in $PATH):"
|
||||
,""
|
||||
@ -208,8 +208,10 @@ commandsList = unlines [
|
||||
,"+api run http api server"
|
||||
,""
|
||||
,"Other:"
|
||||
,"OTHER"
|
||||
,"Help:"
|
||||
] ++
|
||||
othercmds
|
||||
++
|
||||
["Help:"
|
||||
," (no arguments) show this commands list"
|
||||
," -h show general flags"
|
||||
," 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
|
||||
-- of lines beginning with a space or + sign.
|
||||
commandsFromCommandsList :: String -> [String]
|
||||
commandsFromCommandsList :: [String] -> [String]
|
||||
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 = sort $ commandsFromCommandsList commandsList
|
||||
knownCommands = sort . commandsFromCommandsList $ commandsList prognameandversion []
|
||||
|
||||
-- | Print the commands list, modifying the template above based on
|
||||
-- the currently available addons. Missing addons will be removed, and
|
||||
-- extra addons will be added under Misc.
|
||||
printCommandsList :: [String] -> IO ()
|
||||
printCommandsList addonsFound =
|
||||
putStr $
|
||||
regexReplace "PROGVERSION" (prognameandversion) $
|
||||
regexReplace "OTHER" (unlines $ (map ('+':) unknownCommandsFound)) $
|
||||
unlines $ concatMap adjustline $ lines $
|
||||
cmdlist
|
||||
putStr . unlines . concatMap adjustline $
|
||||
commandsList prognameandversion (map ('+':) unknownCommandsFound)
|
||||
where
|
||||
cmdlist = commandsList
|
||||
commandsFound = map (' ':) builtinCommandNames ++ map ('+':) addonsFound
|
||||
unknownCommandsFound = addonsFound \\ knownCommands
|
||||
|
||||
|
||||
@ -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 #-}
|
||||
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings, PackageImports, LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables, RecordWildCards, TypeOperators, FlexibleContexts, OverloadedStrings, PackageImports, LambdaCase #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Hledger.Cli.Commands.Add (
|
||||
@ -32,7 +32,6 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar (Day)
|
||||
import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat)
|
||||
import Data.Typeable (Typeable)
|
||||
import Safe (headDef, headMay, atMay)
|
||||
import System.Console.CmdArgs.Explicit
|
||||
import System.Console.Haskeline (runInputT, defaultSettings, setComplete)
|
||||
@ -65,7 +64,7 @@ data EntryState = EntryState {
|
||||
,esJournal :: Journal -- ^ the journal we are adding to
|
||||
,esSimilarTransaction :: Maybe Transaction -- ^ the most similar historical txn
|
||||
,esPostings :: [Posting] -- ^ postings entered so far in the current txn
|
||||
} deriving (Show,Typeable)
|
||||
} deriving (Show)
|
||||
|
||||
defEntryState = EntryState {
|
||||
esOpts = defcliopts
|
||||
@ -77,10 +76,10 @@ defEntryState = EntryState {
|
||||
,esPostings = []
|
||||
}
|
||||
|
||||
data RestartTransactionException = RestartTransactionException deriving (Typeable,Show)
|
||||
data RestartTransactionException = RestartTransactionException deriving (Show)
|
||||
instance Exception RestartTransactionException
|
||||
|
||||
-- data ShowHelpException = ShowHelpException deriving (Typeable,Show)
|
||||
-- data ShowHelpException = ShowHelpException deriving (Show)
|
||||
-- instance Exception ShowHelpException
|
||||
|
||||
-- | Read multiple transactions from the console, prompting for each
|
||||
|
||||
@ -24,7 +24,9 @@ import Data.Aeson (toJSON)
|
||||
import Data.Aeson.Text (encodeToLazyText)
|
||||
import Data.List
|
||||
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.Lazy as TL
|
||||
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:
|
||||
let
|
||||
(apat:queryargs) = args'
|
||||
acct = headDef (error' $ show apat++" did not match any account") $ -- PARTIAL:
|
||||
filter (regexMatches apat . T.unpack) $ journalAccountNames j
|
||||
acct = headDef (error' $ show apat++" did not match any account") -- PARTIAL:
|
||||
. filterAccts $ journalAccountNames j
|
||||
filterAccts = case toRegexCI apat of
|
||||
Right re -> filter (regexMatch re . T.unpack)
|
||||
Left _ -> const []
|
||||
-- gather report options
|
||||
inclusive = True -- tree_ ropts
|
||||
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
|
||||
And [
|
||||
Not (Date $ DateSpan (Just $ addDays 1 d) Nothing)
|
||||
,Not (Tag "generated-transaction" Nothing)
|
||||
,Not generatedTransactionTag
|
||||
]
|
||||
-- run 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
|
||||
itembal (_,_,_,_,_,a) = a
|
||||
-- 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
|
||||
-- XXX temporary hack ? recover the account name from the query
|
||||
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
|
||||
|
||||
-- | Render one account register report line item as plain text. Layout is like so:
|
||||
|
||||
@ -33,8 +33,8 @@ filesmode = hledgerCommandMode
|
||||
files :: CliOpts -> Journal -> IO ()
|
||||
files CliOpts{rawopts_=rawopts} j = do
|
||||
let args = listofstringopt "args" rawopts
|
||||
regex = headMay args
|
||||
files = maybe id (filter . regexMatches) regex
|
||||
regex <- mapM (either fail pure . toRegex) $ headMay args
|
||||
let files = maybe id (filter . regexMatch) regex
|
||||
$ map fst
|
||||
$ jfiles j
|
||||
mapM_ putStrLn files
|
||||
|
||||
@ -7,6 +7,7 @@ module Hledger.Cli.Commands.Tags (
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Control.Monad.Fail as Fail
|
||||
import Data.List.Extra (nubSort)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
@ -24,11 +25,13 @@ tagsmode = hledgerCommandMode
|
||||
hiddenflags
|
||||
([], Just $ argsFlag "[TAGREGEX [QUERY...]]")
|
||||
|
||||
tags :: CliOpts -> Journal -> IO ()
|
||||
tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
|
||||
d <- getCurrentDay
|
||||
let
|
||||
args = listofstringopt "args" rawopts
|
||||
mtagpat = headMay args
|
||||
mtagpat <- mapM (either Fail.fail pure . toRegexCI) $ headMay args
|
||||
let
|
||||
queryargs = drop 1 args
|
||||
values = boolopt "values" rawopts
|
||||
parsed = boolopt "parsed" rawopts
|
||||
@ -39,7 +42,7 @@ tags CliOpts{rawopts_=rawopts,reportopts_=ropts} j = do
|
||||
(if parsed then id else nubSort)
|
||||
[ r
|
||||
| (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
|
||||
, not (values && T.null v && not empty)
|
||||
]
|
||||
|
||||
@ -82,14 +82,14 @@ mainmode addons = defMode {
|
||||
[detailedversionflag]
|
||||
-- ++ inputflags -- included here so they'll not raise a confusing error if present with no COMMAND
|
||||
}
|
||||
,modeHelpSuffix = map (regexReplace "PROGNAME" progname) [
|
||||
"Examples:"
|
||||
,"PROGNAME list commands"
|
||||
,"PROGNAME CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)"
|
||||
,"PROGNAME-CMD [OPTS] [ARGS] or run addon commands directly"
|
||||
,"PROGNAME -h show general usage"
|
||||
,"PROGNAME CMD -h show command usage"
|
||||
,"PROGNAME help [MANUAL] show any of the hledger manuals in various formats"
|
||||
,modeHelpSuffix = "Examples:" :
|
||||
map (progname ++) [
|
||||
" list commands"
|
||||
," CMD [--] [OPTS] [ARGS] run a command (use -- with addon commands)"
|
||||
,"-CMD [OPTS] [ARGS] or run addon commands directly"
|
||||
," -h show general usage"
|
||||
," CMD -h show command usage"
|
||||
," help [MANUAL] show any of the hledger manuals in various formats"
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user