From 4098e720603735c05c9762889d71482f385c6eb9 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 30 Apr 2023 00:16:06 -0400 Subject: [PATCH] ENH update types and use deferred allocation math --- dhall/Types.dhall | 997 ++++++++++++++++++++++++++++++++------ lib/Internal/Insert.hs | 527 ++++++++++---------- lib/Internal/Statement.hs | 6 +- lib/Internal/Types.hs | 216 +++++---- lib/Internal/Utils.hs | 62 +-- 5 files changed, 1270 insertions(+), 538 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 0425e75..fde6cfe 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -2,34 +2,200 @@ let Map = https://prelude.dhall-lang.org/v21.1.0/Map/Type sha256:210c7a9eba71efbb0f7a66b3dcf8b9d3976ffc2bc0e907aadfb6aa29c333e8ed -let CurID = Text +let List/map = + https://prelude.dhall-lang.org/v21.1.0/List/map + sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680 -let AcntID = Text +let AccountTree + : Type + = + {- + Recursive type representing a tree of accounts. -let TagID = Text + A node in the tree can either be an account (leaf) which has a name + and description, or a placeholder (branch) which has name, description, + and a non-empty list of accounts or other placeholders. + -} + forall (a : Type) -> + forall ( Fix + : < AccountF : { _1 : Text, _2 : Text } + | PlaceholderF : + { _1 : Text + , _2 : Text + , _3 : + {- TODO nonempty? -} + List a + } + > -> + a + ) -> + a -let SqlConfig {- TODO pgsql -} = < Sqlite : Text | Postgres > +let AccountTreeF = + {- + Fixed type abstraction for an account tree. + -} + \(a : Type) -> + < AccountF : { _1 : Text, _2 : Text } + | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a } + > -let Currency = { curSymbol : CurID, curFullname : Text } +let Account + : Text -> Text -> AccountTree + = + {- + Smart constructor to build an account node in an account tree. + -} + \(desc : Text) -> + \(name : Text) -> + \(a : Type) -> + let f = AccountTreeF a -let Tag = { tagID : TagID, tagDesc : Text } + in \(Fix : f -> a) -> Fix (f.AccountF { _1 = desc, _2 = name }) -let Gregorian = { gYear : Natural, gMonth : Natural, gDay : Natural } +let Placeholder + : Text -> Text -> List AccountTree -> AccountTree + = + {- + Smart constructor to build a placeholder node in an account tree. + -} + \(desc : Text) -> + \(name : Text) -> + \(children : List AccountTree) -> + \(a : Type) -> + let f = AccountTreeF a -let GregorianM = { gmYear : Natural, gmMonth : Natural } + in \(Fix : f -> a) -> + let apply = \(x : AccountTree) -> x a Fix -let Interval = { intStart : Gregorian, intEnd : Optional Gregorian } + in Fix + ( f.PlaceholderF + { _1 = desc + , _2 = name + , _3 = List/map AccountTree a apply children + } + ) -let Global = { budgetInterval : Interval, statementInterval : Interval } +let AcntID = + {- + A unique ID for an account; the exact ID associated with each account + depends on the path in which each account exists in a tree. If the leaf + node of an account's path is totally unique, this ID will be that leaf node. + If not, then branch nodes will be appended to the front (delimited by + underscores) until the ID is unique. + + This ID will be used throughout the config to refer to a specific account. + -} + Text + +let CurID = + {- + A unique, short (usually three uppercase characters) ID for a currency; + this symbol will be used throughout the configuration to signify a + particular currency + -} + Text + +let Currency = + {- + A unit of exchange. + -} + { curSymbol : CurID + , curFullname : + {- + The full description of this currency (eg "Yugoslavian Twitcoin") + -} + Text + } + +let TagID = + {- + A unique ID for a tag. This ID will be used throughout the configuration + to refer to a specific tag. + -} + Text + +let Tag = + {- + A short metadata identifier associated with an account or entry. + -} + { tagID : TagID + , tagDesc : + {- + A description to convey the meaning of this tag. + -} + Text + } + +let SqlConfig {- TODO pgsql -} = + {- + How to connect to a SQL database. Only SQLite is supported, in which case + the only parameter is the output path of the db file. + -} + < Sqlite : Text | Postgres > + +let Gregorian = + {- + A full date like 1976-04-01 + -} + { gYear : Natural, gMonth : Natural, gDay : Natural } + +let GregorianM = + {- + Like a Gregorian but without the month + -} + { gmYear : Natural, gmMonth : Natural } + +let Interval = + {- + An interval in time. If end is None, the interval ends at 'forever' + -} + { intStart : Gregorian, intEnd : Optional Gregorian } + +let TemporalScope = + {- + The range of times that will be considered when computing transactions. + -} + { budgetInterval : Interval, statementInterval : Interval } let TimeUnit = < Day | Week | Month | Year > let Weekday = < Mon | Tue | Wed | Thu | Fri | Sat | Sun > let RepeatPat = - { rpStart : Natural, rpBy : Natural, rpRepeats : Optional Natural } + {- + Means to match a repeated set of numeric values. + -} + { rpStart : + {- + Initial value to match + -} + Natural + , rpBy : + {- + Distance between each repeated value + -} + Natural + , rpRepeats : + {- + Number of repeats after initial value to match. If not given, this + number continues until an upper bound determined from context. + -} + Optional Natural + } let MDYPat = + {- + Means to match either a year, month, or day in a date (the matched component + is determined by context) + + Single: match a single number + Multi: match several numbers + Repeat: match a repeated pattern + After: match any number greater than a given value + Before: match any number less than a given value + Between: match any number between two values + -} < Single : Natural | Multi : List Natural | Repeat : RepeatPat @@ -39,18 +205,51 @@ let MDYPat = > let ModPat = + {- + Means to match a date using modular arithmetic. + -} { Type = - { mpStart : Optional Gregorian - , mpBy : Natural - , mpUnit : TimeUnit - , mpRepeats : Optional Natural + { mpStart : + {- + The starting date to begin matching. If not given, start at the + beginning of whatever global time window is active. + -} + Optional Gregorian + , mpBy : + {- + Numeric number of temporal units to repeat before next match. + -} + Natural + , mpUnit : + {- + Unit of each interval + -} + TimeUnit + , mpRepeats : + {- + Number of repeats to match. If not given, match all repeats until + the end of the active global interval + -} + Optional Natural } , default = { mpStart = None Gregorian, mpRepeats = None Natural } } -let WeekdayPat = < OnDay : Weekday | OnDays : List Weekday > +let WeekdayPat = + {- + Means to match a given day of week + + OnDay: Match a single weekday + OnDays: Match multiple weekdays + -} + < OnDay : Weekday | OnDays : List Weekday > let CronPat = + {- + Means of matching dates according to their component parts. + + This is similar to 'cron' patterns in unix-like systems. + -} { Type = { cronWeekly : Optional WeekdayPat , cronYear : Optional MDYPat @@ -65,19 +264,53 @@ let CronPat = } } -let DatePat = < Cron : CronPat.Type | Mod : ModPat.Type > +let DatePat = + {- + Means of matching dates + + Cron: use cron-like date matching + Mod: use modular temporal arithmetic matching + -} + < Cron : CronPat.Type | Mod : ModPat.Type > let Decimal = { whole : Natural, decimal : Natural, precision : Natural, sign : Bool } let TxOpts = + {- Additional metadata to use when parsing a statement -} { Type = - { toDate : Text - , toAmount : Text - , toDesc : Text - , toOther : List Text - , toDateFmt : Text - , toAmountFmt : Text + { toDate : + {- + Column title for date + -} + Text + , toAmount : + {- + Column title for amount + -} + Text + , toDesc : + {- + Column title for description + -} + Text + , toOther : + {- + Titles of other columns to include; these will be available in + a map for use in downstream processing (see 'Field') + -} + List Text + , toDateFmt : + {- + Format of the date field as specified in the + Data.Time.Format.formattime Haskell function. + -} + Text + , toAmountFmt : + {- Format of the amount field. Must include three fields for the + sign, numerator, and denominator of the amount. + -} + Text } , default = { toDate = "Date" @@ -89,16 +322,48 @@ let TxOpts = } } -let Field = \(k : Type) -> \(v : Type) -> { fKey : k, fVal : v } +let Field = + {- + General key-value type + -} + \(k : Type) -> \(v : Type) -> { fKey : k, fVal : v } -let FieldMap = \(k : Type) -> \(v : Type) -> Field k (Map k v) +let FieldMap = + {- + Key-value type where key maps to a Map with key of the same type + -} + \(k : Type) -> \(v : Type) -> Field k (Map k v) -let MatchVal = +let ValMatcher = + {- + Means to match a decimal value. + -} { Type = - { mvSign : Optional Bool - , mvNum : Optional Natural - , mvDen : Optional Natural - , mvPrec : Natural + { mvSign : + {- + Sign of value. + True -> positive, + False -> negative, + None -> do not consider. + -} + Optional Bool + , mvNum : + {- + Value of numerator to match. Do not consider numerator if none + -} + Optional Natural + , mvDen : + {- + Value of denominator to match. Do not consider numerator if none + -} + Optional Natural + , mvPrec : + {- + Precision of decimal to use when matching. This only affects the + denominator, such that a query of '10.1' with a precision of 2 + will have a denominator of '10' + -} + Natural } , default = { mvSign = None Bool @@ -108,18 +373,46 @@ let MatchVal = } } -let MatchYMD = < Y : Natural | YM : GregorianM | YMD : Gregorian > +let YMDMatcher = + {- + Means to match a given date with varying precision + -} + < Y : Natural | YM : GregorianM | YMD : Gregorian > -let MatchDate = < On : MatchYMD | In : { _1 : MatchYMD, _2 : Natural } > +let DateMatcher = + {- + Means to match either one discrete date or a range of dates + -} + < On : YMDMatcher | In : { _1 : YMDMatcher, _2 : Natural } > -let MatchOther_ = - \(re : Type) -> < Desc : Field Text re | Val : Field Text MatchVal.Type > +let FieldMatcher_ = + {- + Means to match a given field (either textual or numeric) + -} + \(re : Type) -> + < Desc : Field Text re | Val : Field Text ValMatcher.Type > -let MatchOther = MatchOther_ Text +let FieldMatcher = FieldMatcher_ Text -let SplitNum = < LookupN : Text | ConstN : Decimal | AmountN > +let EntryNumGetter = + {- + Means to get a numeric value from a statement row. -let SplitText = + LookupN: lookup the value from a field + ConstN: a constant value + AmountN: the value of the 'Amount' column + -} + < LookupN : Text | ConstN : Decimal | AmountN > + +let EntryTextGetter = + {- + Means to get a textual value from a statement row. + + ConstT: a constant value + LookupT: lookup the value of a field + MapT: use the value of a column as the key for a map + Map2T: use the paired value of 2 columns as the key for a map + -} \(t : Type) -> < ConstT : t | LookupT : Text @@ -127,164 +420,549 @@ let SplitText = | Map2T : FieldMap { _1 : Text, _2 : Text } t > -let SplitCur = SplitText CurID +let EntryCurGetter = + {- + Means to get a currency ID from a statement row. + -} + EntryTextGetter CurID -let SplitAcnt = SplitText AcntID +let EntryAcntGetter = + {- + Means to get an account ID from a statement row. + -} + EntryTextGetter AcntID -let Split = +let Entry = + {- + General type describing a single line item in an account. + + The polymorphism of this type allows representation of an actual line + item itself as well as the means to get a line item from other data. + -} \(a : Type) -> \(v : Type) -> \(c : Type) -> \(t : Type) -> - { sAcnt : a - , sValue : v - , sCurrency : c - , sComment : Text - , sTags : List t + { sAcnt : + {- + Pertains to account for this entry. + -} + a + , sValue : + {- + Pertains to value for this entry. + -} + v + , sCurrency : + {- + Pertains to value for this entry. + -} + c + , sComment : + {- + A short description of this entry (if none, use a blank string) + -} + Text + , sTags : + {- + Pertains to the tags to describe this entry. + -} + List t } -let ExpSplit = - { Type = Split SplitAcnt (Optional SplitNum) SplitCur TagID - , default = { sValue = None SplitNum, sComment = "" } +let EntryGetter = + {- + Means for getting an entry from a given row in a statement + -} + { Type = + Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID + , default = { sValue = None EntryNumGetter, sComment = "" } } -let ToTx = - { ttCurrency : SplitCur - , ttPath : SplitAcnt - , ttSplit : List ExpSplit.Type +let TxGetter = + {- + A means for transforming one row in a statement to a transaction + + Note that N-1 entries need to be specified to make a transaction, as the + Nth entry will be balanced with the others. + -} + { tgEntries : + {- + A means of getting entries for this transaction (minimum 1) + -} + List EntryGetter.Type + , tgCurrency : + {- + Currency against which entries in this transaction will be balanced + -} + EntryCurGetter + , tgAcnt : + {- + Account in which entries in this transaction will be balanced + -} + EntryAcntGetter } -let Match_ = +let StatementParser_ = + {- + A recipe to match and transform a given entry in a statement to a + transaction between 2 or more accounts. + + Polymorphism allows regular expressions to be computed and cached within + the type during parsing. + -} \(re : Type) -> { Type = - { mDate : Optional MatchDate - , mVal : MatchVal.Type - , mDesc : Optional re - , mOther : List (MatchOther_ re) - , mTx : Optional ToTx - , mTimes : Optional Natural - , mPriority : Integer + { mDate : + {- + How to match the date column; if none match any date + -} + Optional DateMatcher + , mVal : + {- + How to match the value column; if none match any value + -} + ValMatcher.Type + , mDesc : + {- + Regular expression to match the description; + if none match anythingS + -} + Optional re + , mOther : + {- + How to match additional columns if present + -} + List (FieldMatcher_ re) + , mTx : + {- + How to translate the matched statement row into entries for + a transaction. If none, don't make a transaction (eg 'skip' + this row in the statement). + -} + Optional TxGetter + , mTimes : + {- + Match at most this many rows; if none there is no limit + -} + Optional Natural + , mPriority : + {- + In case of multiple matches, higher priority gets precedence. + -} + Integer } , default = - { mDate = None MatchDate - , mVal = MatchVal::{=} + { mDate = None DateMatcher + , mVal = ValMatcher::{=} , mDesc = None Text - , mOther = [] : List (MatchOther_ re) - , mTx = None ToTx + , mOther = [] : List (FieldMatcher_ re) + , mTx = None EntryGetter.Type , mTimes = None Natural , mPriority = +0 } } -let Match = Match_ Text +let StatementParser = + {- + A statement parser specialized to raw regular expressions. + -} + StatementParser_ Text -let Manual = - { manualDate : DatePat - , manualFrom : AcntID - , manualTo : AcntID - , manualValue : Decimal - , manualDesc : Text - , manualCurrency : CurID +let Amount = + {- + A quantify of currency at a given time. + -} + \(w : Type) -> + \(v : Type) -> + { amtWhen : w, amtValue : v, amtDesc : Text } + +let Transfer = + {- + 1-1 transaction(s) between two accounts. + -} + \(a : Type) -> + \(c : Type) -> + \(w : Type) -> + \(v : Type) -> + { transFrom : a + , transTo : a + , transCurrency : c + , transAmounts : List (Amount w v) + } + +let HistTransfer = + {- + A manually specified historical transfer + -} + Transfer AcntID CurID DatePat Decimal + +let Statement = + {- + How to import a statement from local file(s). Statements are assumed to be + tabular with one statement per row. + -} + { stmtPaths + {- + paths to statement files + -} + : List Text + , stmtParsers + {- + parsers to match statements + -} + : List StatementParser.Type + , stmtDelim + {- + file delimiter as a numeric char, usually either tab (9) or comma (44) + -} + : Natural + , stmtTxOpts : TxOpts.Type + , stmtSkipLines + {- + how many lines to skip before parsing statement + -} + : Natural } -let Import = - { impPaths : List Text - , impMatches : List Match.Type - , impDelim : Natural - , impTxOpts : TxOpts.Type - , impSkipLines : Natural - } - -let Statement = < StmtManual : Manual | StmtImport : Import > - -let Amount = { amtValue : Decimal, amtDesc : Text } - -let AmountType = < FixedAmt | Percent | Target > - -let TimeAmount = - \(t : Type) -> { taWhen : t, taAmt : Amount, taAmtType : AmountType } - -let DateAmount = TimeAmount DatePat +let History = + {- + How to generate historical transactions; either specified as manual + transfers or via statements in files on local disk + -} + < HistTransfer : HistTransfer | HistStatement : Statement > let Exchange = - { xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal } + {- + A currency exchange. + -} + { xFromCur : + {- + Starting currency of the exchange. + -} + CurID + , xToCur : + {- + Ending currency of the exchange. + -} + CurID + , xAcnt : + {- + account in which the exchange will be documented. + -} + AcntID + , xRate : + {- + The exchange rate between the currencies. + -} + Decimal + } -let BudgetCurrency = < NoX : CurID | X : Exchange > +let BudgetCurrency = + {- + A 'currency' in the budget; either a fixed currency or an exchange + -} + < NoX : CurID | X : Exchange > -let TaggedAcnt = { taAcnt : AcntID, taTags : List TagID } +let TaggedAcnt = + {- + An account with a tag + -} + { taAcnt : AcntID, taTags : List TagID } -let Allocation_ = - \(t : Type) -> - { alloTo : TaggedAcnt, alloAmts : List t, alloCur : BudgetCurrency } +let Allocation = + {- + How to allocate a given budget stream. This can be thought of as a Transfer + without an incoming account specified. + -} + \(w : Type) -> + \(v : Type) -> + { alloTo : TaggedAcnt + , alloAmts : List (Amount w v) + , alloCur : + {-TODO allow exchanges here-} + CurID + } -let Allocation = Allocation_ Amount +let PretaxValue = + {- + How to determine value of a pretax allocation. + -} + { preValue : + {- + The value to be deducted from gross income + -} + Decimal + , prePercent : + {- + If true, value is interpreted as a percent of gross income instead of + a fixed amount. + -} + Bool + , preCategory : + {- + A category for this allocation. This is used when calculating taxes, + which match against this to determine how much to deduct from the + gross income stream. + -} + Text + } -let IntervalAllocation = Allocation_ (TimeAmount Interval) +let TaxBracket = + {- + A single tax bracket. Read as "every unit above limit is taxed at this + percentage". + -} + { tbLowerLimit : Decimal, tbPercent : Decimal } + +let TaxProgression = + {- + A tax progression using a deductible and a series of tax brackets. + This will cover simple cases of the US income tax as of 2017 and similar. + -} + { tbsDeductible : + {- + Initial amount to subtract from after-pretax-deductions + -} + Decimal + , tbsBrackets : + {- + Tax brackets to apply after deductions (order does not matter, each + entry will be sorted by limit) + -} + List TaxBracket + } + +let TaxMethod = + {- + How to implement a given tax (either a progressive tax or a fixed percent) + -} + < TMBracket : TaxProgression | TMPercent : Decimal > + +let TaxValue = + {- + Means to determine value of an income tax allocation. + -} + { tvCategories : + {- + A list of categories corresponding to pretax allocations. Taxable + income (from the perspective of this type) will be determined by + subtracting matching allocations from gross income. + -} + List Text + , tvMethod : TaxMethod + } + +let PosttaxValue = + {- + Means to determine value of a post tax allocation. + -} + { postValue : + {- + The value to be deducted from income remaining after taxes. + -} + Decimal + , postPercent : + {- + If true, subtract a percentage from the after-tax remainder instead + of a fixed value. + -} + Bool + } + +let SingleAllocation = + {- + An allocation specialized to an income stream (which means the timing is + dictated by the income stream) + -} + Allocation {} + +let MultiAllocation = + {- + An allocation specialized to capturing multiple income streams within a given + time period (useful for instances where an allocation might change independent + of a change in income) + -} + Allocation Interval let Income = + {- + Means to compute an income stream and how to allocate it + -} { Type = - { incGross : Decimal - , incCurrency : CurID - , incWhen : DatePat - , incPretax : List Allocation - , incTaxes : List Allocation - , incPosttax : List Allocation + { incGross : + {- + The value of the income stream. + -} + Decimal + , incCurrency : + {- + The currency in which the income stream is denominated. + -} + CurID + , incWhen : + {- + The dates on which the income stream is distributed. + -} + DatePat + , incPretax : List (SingleAllocation PretaxValue) + , incTaxes : List (SingleAllocation TaxValue) + , incPosttax : List (SingleAllocation PosttaxValue) , incFrom : - {- this must be an income AcntID, and is the only place income - accounts may be specified in the entire budget -} + {- + The account in which the income is recorded. + + This must be an income AcntID, and is the only place income + accounts may be specified in the entire budget. + -} + TaggedAcnt + , incToBal : + {- + The account to which to send the remainder of the income stream + (if any) after all allocations have been applied. + -} TaggedAcnt - , incToBal : TaggedAcnt } , default = - { incPretax = [] : List Allocation - , incTaxes = [] : List Allocation - , incPosttaxx = [] : List Allocation + { incPretax = [] : List (SingleAllocation PretaxValue) + , incTaxes = [] : List (SingleAllocation TaxValue) + , incPosttaxx = [] : List (SingleAllocation PosttaxValue) } } -let Transfer = - { transFrom : TaggedAcnt - , transTo : TaggedAcnt - , transAmounts : List DateAmount - , transCurrency : BudgetCurrency - } - let AcntSet = - { Type = { asList : List AcntID, asInclude : Bool } + {- + A list of account IDs represented as a set. + -} + { Type = + { asList : List AcntID + , asInclude : + {- + If true, tests for account membership in this set will return + true if the account is in the set. Invert this behavior otherwise. + -} + Bool + } , default = { asList = [] : List AcntID, asInclude = False } } -let ShadowMatch = +let TransferMatcher = + {- + Means to match a transfer (which will be used to "clone" it in some + fashion) + -} { Type = - { smFrom : AcntSet.Type - , smTo : AcntSet.Type - , smDate : Optional MatchDate - , smVal : MatchVal.Type + { smFrom : + {- + List of accounts (which may be empty) to match with the + starting account in a transfer. + -} + AcntSet.Type + , smTo : + {- + List of accounts (which may be empty) to match with the + ending account in a transfer. + -} + AcntSet.Type + , smDate : + {- + If given, means to match the date of a transfer. + -} + Optional DateMatcher + , smVal : + {- + If given, means to match the value of a transfer. + -} + ValMatcher.Type } , default = { smFrom = AcntSet.default , smTo = AcntSet.default - , smDate = None MatchDate - , smVal = MatchVal.default + , smDate = None DateMatcher + , smVal = ValMatcher.default } } +let BudgetTransferType = + {- + The type of a budget transfer. + + BTFixed: Tranfer a fixed amount + BTPercent: Transfer a percent of the source account to destination + BTTarget: Transfer an amount such that the destination has a given target + value + -} + < BTPercent | BTTarget | BTFixed > + let ShadowTransfer = - { stFrom : TaggedAcnt - , stTo : TaggedAcnt - , stCurrency : CurID - , stDesc : Text - , stMatch : ShadowMatch.Type - , stRatio : Decimal + {- + A transaction analogous to another transfer with given properties. + -} + { stFrom : + {- + Source of this transfer + -} + TaggedAcnt + , stTo : + {- + Destination of this transfer. + -} + TaggedAcnt + , stCurrency : + {- + Currency of this transfer. + -} + BudgetCurrency + , stDesc : + {- + Description of this transfer. + -} + Text + , stMatch : + {- + Means to match other transfers which will be used as the basis to + compute this transfer. The date is taken as-is, the value is + multiplied by a constant (see 'stRatio') and everything else is + specified in other fields of this type. + -} + TransferMatcher.Type + , stType : BudgetTransferType + , stRatio : + {- + Fixed multipler to translate value of matched transfer to this one. + -} + Decimal } +let BudgetTransferValue = + {- + Means to determine the value of a budget transfer. + -} + { btVal : Decimal, btType : BudgetTransferType } + +let BudgetTransfer = + {- + A manually specified transaction for a budget + -} + Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue + let Budget = - { budgetLabel : Text + {- + A hypothetical set of transactions (eg a "budget") to be generated + and inserted into the database. + -} + { budgetLabel : + {- + A unique label for this budget. + + Can be useful to compare multiple potential futures. + -} + Text , incomes : List Income.Type - , pretax : List IntervalAllocation - , tax : List IntervalAllocation - , posttax : List IntervalAllocation - , transfers : List Transfer + , pretax : List (MultiAllocation PretaxValue) + , tax : List (MultiAllocation TaxValue) + , posttax : List (MultiAllocation PosttaxValue) + , transfers : List BudgetTransfer , shadowTransfers : List ShadowTransfer } @@ -295,7 +973,7 @@ in { CurID , Tag , TagID , Interval - , Global + , TemporalScope , Gregorian , GregorianM , TimeUnit @@ -308,37 +986,42 @@ in { CurID , DatePat , Decimal , TxOpts - , Match - , Match_ - , MatchVal - , MatchYMD - , MatchDate - , MatchOther - , MatchOther_ - , SplitNum + , StatementParser + , StatementParser_ + , ValMatcher + , YMDMatcher + , DateMatcher + , FieldMatcher + , FieldMatcher_ + , EntryNumGetter , Field , FieldMap - , Split - , ExpSplit - , SplitText - , SplitCur - , SplitAcnt - , ToTx - , Import - , Manual + , Entry + , EntryGetter + , EntryTextGetter + , EntryCurGetter + , EntryAcntGetter , Statement + , History , Transfer , Income , Budget , Allocation - , IntervalAllocation , Amount - , TimeAmount - , AmountType - , ShadowMatch + , TransferMatcher , ShadowTransfer , AcntSet , BudgetCurrency , Exchange , TaggedAcnt + , Account + , Placeholder + , PretaxValue + , PosttaxValue + , TaxBracket + , TaxProgression + , TaxMethod + , TaxValue + , BudgetTransferValue + , BudgetTransferType } diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 3d50823..ed7b945 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -119,21 +119,20 @@ withDates dp f = do insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError] insertBudget - b@( Budget - { budgetLabel - , incomes - , transfers - , shadowTransfers - , pretax - , tax - , posttax - } - ) = + b@Budget + { budgetLabel + , incomes + , transfers + , shadowTransfers + , pretax + , tax + , posttax + } = whenHash CTBudget b [] $ \key -> do unlessLefts intAllos $ \intAllos_ -> do res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes res2 <- expandTransfers key budgetLabel transfers - unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $ + unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $ \txs -> do unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do let bals = balanceTransfers $ txs ++ shadow @@ -146,117 +145,120 @@ insertBudget in concatEithers3 pre_ tax_ post_ (,,) sortAllos = concatEithersL . fmap sortAllo -type BoundAllocation = Allocation_ (TimeAmount (Day, Day)) +type BoundAllocation = Allocation (Day, Day) -type IntAllocations = ([BoundAllocation], [BoundAllocation], [BoundAllocation]) +type IntAllocations = + ( [BoundAllocation PretaxValue] + , [BoundAllocation TaxValue] + , [BoundAllocation PosttaxValue] + ) --- TODO this should actually error if there is no ultimate end date -sortAllo :: IntervalAllocation -> EitherErrs BoundAllocation -sortAllo a@Allocation_ {alloAmts = as} = do - bs <- fmap reverse <$> foldBounds (Right []) $ L.sortOn taWhen as - return $ a {alloAmts = L.sort bs} +-- TODO this should actually error if there is no ultimate end date? +sortAllo :: MultiAllocation v -> EitherErrs (BoundAllocation v) +sortAllo a@Allocation {alloAmts = as} = do + bs <- foldBounds (Right []) $ L.sortOn amtWhen as + return $ a {alloAmts = reverse bs} where foldBounds acc [] = acc foldBounds acc (x : xs) = - let res = fmap (fmap expandBounds) $ case xs of - [] -> mapM resolveBounds x - (y : _) -> - let end = intStart $ taWhen y - in mapM (resolveBounds_ end) x - in foldBounds (concatEithers2 (plural res) acc (:)) xs + let res = case xs of + [] -> resolveBounds $ amtWhen x + (y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x + concatRes bs acc' = x {amtWhen = expandBounds bs} : acc' + in foldBounds (concatEithers2 (plural res) acc concatRes) xs -- TODO this is going to be O(n*m), which might be a problem? -addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType] +addShadowTransfers + :: [ShadowTransfer] + -> [UnbalancedTransfer] + -> EitherErrs [UnbalancedTransfer] addShadowTransfers ms txs = fmap catMaybes $ concatEitherL $ fmap (uncurry fromShadow) $ [(t, m) | t <- txs, m <- ms] -fromShadow :: BudgetTxType -> ShadowTransfer -> EitherErr (Maybe BudgetTxType) -fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do +fromShadow + :: UnbalancedTransfer + -> ShadowTransfer + -> EitherErr (Maybe UnbalancedTransfer) +fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do res <- shadowMatches (stMatch t) tx return $ if not res then Nothing else Just $ - BudgetTxType - { bttTx = - -- TODO does this actually share the same metadata as the "parent" tx? - BudgetTx - { btMeta = btMeta $ bttTx tx - , btWhen = btWhen $ bttTx tx - , btFrom = stFrom - , btTo = stTo - , btValue = dec2Rat stRatio * (btValue $ bttTx tx) - , btDesc = stDesc - } - , bttType = FixedAmt + -- TODO does this actually share the same metadata as the "parent" tx? + FlatTransfer + { cbtMeta = cbtMeta tx + , cbtWhen = cbtWhen tx + , cbtCur = stCurrency + , cbtFrom = stFrom + , cbtTo = stTo + , cbtValue = UnbalancedValue stType $ dec2Rat stRatio * cvValue (cbtValue tx) + , cbtDesc = stDesc } -shadowMatches :: ShadowMatch -> BudgetTxType -> EitherErr Bool -shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do - -- TODO what does the amount do for each of the different types? - valRes <- valMatches smVal (btValue tx_) +shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool +shadowMatches TransferMatcher {smFrom, smTo, smDate, smVal} tx = do + valRes <- valMatches smVal $ cvValue $ cbtValue tx return $ - memberMaybe (taAcnt $ btFrom tx_) smFrom - && memberMaybe (taAcnt $ btTo tx_) smTo - && maybe True (`dateMatches` (btWhen tx_)) smDate + memberMaybe (taAcnt $ cbtFrom tx) smFrom + && memberMaybe (taAcnt $ cbtTo tx) smTo + && maybe True (`dateMatches` cbtWhen tx) smDate && valRes where - tx_ = bttTx tx memberMaybe x AcntSet {asList, asInclude} = (if asInclude then id else not) $ x `elem` asList -balanceTransfers :: [BudgetTxType] -> [BudgetTx] +balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] balanceTransfers ts = - snd $ L.mapAccumR go initBals $ reverse $ L.sortOn (btWhen . bttTx) ts + snd $ L.mapAccumR go M.empty $ reverse $ L.sortOn cbtWhen ts where - initBals = - M.fromList $ - fmap (,0) $ - L.nub $ - fmap (btTo . bttTx) ts - ++ fmap (btFrom . bttTx) ts - updateBal x = M.update (Just . (+ x)) - lookupBal = M.findWithDefault (error "this should not happen") - go bals btt = - let tx = bttTx btt - from = btFrom tx - to = btTo tx - bal = lookupBal to bals - x = amtToMove bal (bttType btt) (btValue tx) - in (updateBal x to $ updateBal (-x) from bals, tx {btValue = x}) + go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} = + let (bals', v) = mapAdd cbtTo x $ mapAdd_ cbtFrom (-x) bals + x = amtToMove v cvType cvValue + in (bals', f {cbtValue = x}) -- TODO might need to query signs to make this intuitive; as it is this will -- probably work, but for credit accounts I might need to supply a negative -- target value - amtToMove _ FixedAmt x = x - amtToMove bal Percent x = -(x / 100 * bal) - amtToMove bal Target x = x - bal + amtToMove _ BTFixed x = x + amtToMove bal BTPercent x = -(x / 100 * bal) + amtToMove bal BTTarget x = x - bal + +mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v +mapAdd_ k v m = fst $ mapAdd k v m + +mapAdd :: (Ord k, Num v) => k -> v -> M.Map k v -> (M.Map k v, v) +mapAdd k v m = (new, M.findWithDefault (error "this should not happen") k new) + where + new = M.alter (maybe (Just v) (Just . (+ v))) k m data BudgetMeta = BudgetMeta { bmCommit :: !CommitRId - , bmCur :: !BudgetCurrency , bmName :: !T.Text } deriving (Show) -data BudgetTx = BudgetTx - { btMeta :: !BudgetMeta - , btWhen :: !Day - , btFrom :: !TaggedAcnt - , btTo :: !TaggedAcnt - , btValue :: !Rational - , btDesc :: !T.Text +data FlatTransfer v = FlatTransfer + { cbtFrom :: !TaggedAcnt + , cbtTo :: !TaggedAcnt + , cbtValue :: !v + , cbtWhen :: !Day + , cbtDesc :: !T.Text + , cbtMeta :: !BudgetMeta + , cbtCur :: !BudgetCurrency } - deriving (Show) -data BudgetTxType = BudgetTxType - { bttType :: !AmountType - , bttTx :: !BudgetTx +data UnbalancedValue = UnbalancedValue + { cvType :: !BudgetTransferType + , cvValue :: !Rational } - deriving (Show) + +type UnbalancedTransfer = FlatTransfer UnbalancedValue + +type BalancedTransfer = FlatTransfer Rational insertIncome :: MonadFinance m @@ -264,179 +266,206 @@ insertIncome -> T.Text -> IntAllocations -> Income - -> SqlPersistT m (EitherErrs [BudgetTxType]) + -> SqlPersistT m (EitherErrs [UnbalancedTransfer]) insertIncome key name (intPre, intTax, intPost) - i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = do - let meta = BudgetMeta key (NoX incCurrency) name - let balRes = balanceIncome i + Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do + -- TODO check that the other accounts are not income somewhere here fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom - case concatEither2 balRes fromRes (,) of - Left es -> return $ Left es - -- TODO this hole seems sloppy... - Right (balance, _) -> - fmap (fmap (concat . concat)) $ - -- TODO this will scan the interval allocations fully each time - -- iteration which is a total waste, but the fix requires turning this - -- loop into a fold which I don't feel like doing now :( - withDates incWhen $ \day -> do - let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom) - pre <- fromAllos $ incPretax ++ mapMaybe (selectAllos day) intPre - -- TODO ensure these are all expense accounts - tax <- fromAllos $ incTaxes ++ mapMaybe (selectAllos day) intTax - post <- fromAllos $ incPosttax ++ mapMaybe (selectAllos day) intPost - let bal = - BudgetTxType - { bttTx = - BudgetTx - { btMeta = meta - , btWhen = day - , btFrom = incFrom - , btTo = incToBal - , btValue = balance - , btDesc = "balance after deductions" - } - , bttType = FixedAmt - } - return $ concatEithersL [Right [bal], Right tax, Right pre, Right post] + case fromRes of + Left e -> return $ Left [e] + -- TODO this will scan the interval allocations fully each time + -- iteration which is a total waste, but the fix requires turning this + -- loop into a fold which I don't feel like doing now :( + Right _ -> fmap concat <$> withDates incWhen (return . allocate) + where + meta = BudgetMeta key name + gross = dec2Rat incGross + flatPre = concatMap flattenAllo incPretax + flatTax = concatMap flattenAllo incTaxes + flatPost = concatMap flattenAllo incPosttax + sumAllos = sum . fmap faValue + -- TODO ensure these are all the "correct" accounts + allocate day = + let (preDeductions, pre) = + allocatePre gross $ + flatPre ++ concatMap (selectAllos day) intPre + tax = + allocateTax gross preDeductions $ + flatTax ++ concatMap (selectAllos day) intTax + aftertaxGross = sumAllos $ tax ++ pre + post = + allocatePost aftertaxGross $ + flatPost ++ concatMap (selectAllos day) intPost + balance = aftertaxGross - sumAllos post + bal = + FlatTransfer + { cbtMeta = meta + , cbtWhen = day + , cbtFrom = incFrom + , cbtCur = NoX incCurrency + , cbtTo = incToBal + , cbtValue = UnbalancedValue BTFixed balance + , cbtDesc = "balance after deductions" + } + in if balance < 0 + then Left [IncomeError day name balance] + else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post) --- ASSUME allocations are sorted -selectAllos :: Day -> BoundAllocation -> Maybe Allocation -selectAllos day a@Allocation_ {alloAmts = as} = case select [] as of - [] -> Nothing - xs -> Just $ a {alloAmts = xs} +allocatePre + :: Rational + -> [FlatAllocation PretaxValue] + -> (M.Map T.Text Rational, [FlatAllocation Rational]) +allocatePre gross = L.mapAccumR go M.empty where - select acc [] = acc - select acc (x : xs) - | day < fst (taWhen x) = select acc xs - | inBounds (taWhen x) day = select (taAmt x : acc) xs - | otherwise = acc + go m f@FlatAllocation {faValue} = + let c = preCategory faValue + p = dec2Rat $ preValue faValue + v = if prePercent faValue then p * gross else p + in (mapAdd_ c v m, f {faValue = v}) -fromAllo - :: MonadFinance m - => Day - -> BudgetMeta +allo2Trans + :: BudgetMeta + -> Day -> TaggedAcnt - -> Allocation - -> m [BudgetTxType] -fromAllo day meta from Allocation_ {alloTo, alloAmts} = do - -- TODO this is going to be repeated a zillion times (might matter) - -- res <- expandTarget alloPath - return $ fmap toBT alloAmts + -> FlatAllocation Rational + -> UnbalancedTransfer +allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = + FlatTransfer + { cbtMeta = meta + , cbtWhen = day + , cbtFrom = from + , cbtCur = faCur + , cbtTo = faTo + , cbtValue = UnbalancedValue BTFixed faValue + , cbtDesc = faDesc + } + +allocateTax + :: Rational + -> M.Map T.Text Rational + -> [FlatAllocation TaxValue] + -> [FlatAllocation Rational] +allocateTax gross deds = fmap (fmap go) where - toBT (Amount {amtDesc = desc, amtValue = v}) = - BudgetTxType - { bttTx = - BudgetTx - { btFrom = from - , btWhen = day - , btTo = alloTo - , btValue = dec2Rat v - , btDesc = desc - , btMeta = meta - } - , bttType = FixedAmt + go TaxValue {tvCategories, tvMethod} = + let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories) + in case tvMethod of + TMPercent p -> dec2Rat p * agi + TMBracket TaxProgression {tbsDeductible, tbsBrackets} -> + foldBracket (agi - dec2Rat tbsDeductible) tbsBrackets + +allocatePost + :: Rational + -> [FlatAllocation PosttaxValue] + -> [FlatAllocation Rational] +allocatePost aftertax = fmap (fmap go) + where + go PosttaxValue {postValue, postPercent} = + let v = dec2Rat postValue in if postPercent then aftertax * v else v + +foldBracket :: Rational -> [TaxBracket] -> Rational +foldBracket agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs + where + go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) = + let l = dec2Rat tbLowerLimit + p = dec2Rat tbPercent + in if remain < l then (acc + p * (remain - l), l) else (acc, remain) + +data FlatAllocation v = FlatAllocation + { faValue :: !v + , faDesc :: !T.Text + , faTo :: !TaggedAcnt + , faCur :: !BudgetCurrency + } + deriving (Functor) + +flattenAllo :: SingleAllocation v -> [FlatAllocation v] +flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts + where + go Amount {amtValue, amtDesc} = + FlatAllocation + { faCur = NoX alloCur + , faTo = alloTo + , faValue = amtValue + , faDesc = amtDesc } --- -- TODO maybe allow tags here? --- fromTax --- :: MonadFinance m --- => Day --- -> BudgetMeta --- -> AcntID --- -> Tax --- -> m (EitherErr BudgetTxType) --- fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do --- res <- checkAcntType ExpenseT to --- return $ fmap go res --- where --- go to_ = --- BudgetTxType --- { bttTx = --- BudgetTx --- { btFrom = TaggedAcnt from [] --- , btWhen = day --- , btTo = TaggedAcnt to_ [] --- , btValue = dec2Rat v --- , btDesc = "" --- , btMeta = meta --- } --- , bttType = FixedAmt --- } - -balanceIncome :: Income -> EitherErr Rational -balanceIncome - Income - { incGross = g - , incWhen = dp - , incPretax = pre - , incTaxes = tax - , incPosttax = post - } - | bal < 0 = Left $ IncomeError dp - | otherwise = Right bal - where - bal = dec2Rat g - sum (sumAllocation <$> pre ++ tax ++ post) - -sumAllocation :: Allocation -> Rational -sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts - --- sumTaxes :: [Tax] -> Rational --- sumTaxes = sum . fmap (dec2Rat . taxValue) +-- ASSUME allocations are sorted +selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v] +selectAllos day Allocation {alloAmts, alloCur, alloTo} = + fmap go $ + takeWhile ((`inBounds` day) . amtWhen) $ + dropWhile ((day <) . fst . amtWhen) alloAmts + where + go Amount {amtValue, amtDesc} = + FlatAllocation + { faCur = NoX alloCur + , faTo = alloTo + , faValue = amtValue + , faDesc = amtDesc + } expandTransfers :: MonadFinance m => CommitRId -> T.Text - -> [Transfer] - -> SqlPersistT m (EitherErrs [BudgetTxType]) + -> [BudgetTransfer] + -> SqlPersistT m (EitherErrs [UnbalancedTransfer]) expandTransfers key name ts = do txs <- mapM (expandTransfer key name) ts - return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs + return $ L.sortOn cbtWhen . concat <$> concatEithersL txs -expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType]) +expandTransfer + :: MonadFinance m + => CommitRId + -> T.Text + -> BudgetTransfer + -> SqlPersistT m (EitherErrs [UnbalancedTransfer]) expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = -- whenHash CTExpense t (Right []) $ \key -> fmap (fmap concat . concatEithersL) $ - forM transAmounts $ \(TimeAmount {taWhen = pat, taAmt = (Amount {amtDesc = desc, amtValue = v}), taAmtType = atype}) -> do - withDates pat $ \day -> - let meta = - BudgetMeta - { bmCur = transCurrency - , bmCommit = key - , bmName = name - } - tx = - BudgetTxType - { bttTx = - BudgetTx - { btMeta = meta - , btWhen = day - , btFrom = transFrom - , btTo = transTo - , btValue = dec2Rat v - , btDesc = desc + forM transAmounts $ + \Amount + { amtWhen = pat + , amtValue = BudgetTransferValue {btVal = v, btType = y} + , amtDesc = desc + } -> + do + withDates pat $ \day -> + let meta = + BudgetMeta + { bmCommit = key + , bmName = name } - , bttType = atype - } - in return $ Right tx + tx = + FlatTransfer + { cbtMeta = meta + , cbtWhen = day + , cbtCur = transCurrency + , cbtFrom = transFrom + , cbtTo = transTo + , cbtValue = UnbalancedValue y $ dec2Rat v + , cbtDesc = desc + } + in return $ Right tx -insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError] -insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do - res <- lift $ splitPair btFrom btTo (bmCur btMeta) btValue +insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError] +insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do + res <- lift $ splitPair cbtFrom cbtTo cbtCur cbtValue unlessLefts_ res $ \((sFrom, sTo), exchange) -> do insertPair sFrom sTo - forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo + forM_ exchange $ uncurry insertPair where insertPair from to = do - k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc + k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc insertBudgetLabel k from insertBudgetLabel k to insertBudgetLabel k split = do sk <- insertSplit k split - insert_ $ BudgetLabelR sk $ bmName btMeta + insert_ $ BudgetLabelR sk $ bmName cbtMeta type SplitPair = (KeySplit, KeySplit) @@ -448,8 +477,8 @@ splitPair -> Rational -> m (EitherErrs (SplitPair, Maybe SplitPair)) splitPair from to cur val = case cur of - NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val - X (Exchange {xFromCur, xToCur, xAcnt, xRate}) -> do + NoX curid -> fmap (,Nothing) <$> pair curid from to val + X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do let middle = TaggedAcnt xAcnt [] res1 <- pair xFromCur from middle val res2 <- pair xToCur middle to (val * dec2Rat xRate) @@ -461,7 +490,7 @@ splitPair from to cur val = case cur of return $ concatEithers2 s1 s2 (,) split c TaggedAcnt {taAcnt, taTags} v = resolveSplit $ - Split + Entry { sAcnt = taAcnt , sValue = v , sComment = "" @@ -493,31 +522,31 @@ checkAcntTypes ts i = (go =<<) <$> lookupAccountType i insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError] insertStatements conf = concat <$> mapM insertStatement (statements conf) -insertStatement :: MonadFinance m => Statement -> SqlPersistT m [InsertError] -insertStatement (StmtManual m) = insertManual m -insertStatement (StmtImport i) = insertImport i +insertStatement :: MonadFinance m => History -> SqlPersistT m [InsertError] +insertStatement (HistTransfer m) = insertManual m +insertStatement (HistStatement i) = insertImport i -insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError] +insertManual :: MonadFinance m => HistTransfer -> SqlPersistT m [InsertError] insertManual - m@Manual - { manualDate = dp - , manualFrom = from - , manualTo = to - , manualValue = v - , manualCurrency = u - , manualDesc = e + m@Transfer + { transFrom = from + , transTo = to + , transCurrency = u + , transAmounts = amts } = do whenHash CTManual m [] $ \c -> do bounds <- lift $ askDBState kmStatementInterval -- let days = expandDatePat bounds dp - let dayRes = expandDatePat bounds dp - unlessLefts dayRes $ \days -> do - txRes <- mapM (lift . tx) days - unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c) - where - tx day = txPair day from to u (dec2Rat v) e + es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do + let v = dec2Rat amtValue + let dayRes = expandDatePat bounds amtWhen + unlessLefts dayRes $ \days -> do + let tx day = txPair day from to u v amtDesc + txRes <- mapM (lift . tx) days + unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c) + return $ concat es -insertImport :: MonadFinance m => Import -> SqlPersistT m [InsertError] +insertImport :: MonadFinance m => Statement -> SqlPersistT m [InsertError] insertImport i = whenHash CTImport i [] $ \c -> do -- TODO this isn't efficient, the whole file will be read and maybe no -- transactions will be desired @@ -549,7 +578,7 @@ txPair -> m (EitherErrs KeyTx) txPair day from to cur val desc = resolveTx tx where - split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []} + split a v = Entry {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []} tx = Tx { txDescr = desc @@ -563,7 +592,7 @@ resolveTx t@Tx {txSplits = ss} = do return $ fmap (\kss -> t {txSplits = kss}) res resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit) -resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do +resolveSplit s@Entry {sAcnt, sCurrency, sValue, sTags} = do aid <- lookupAccountKey sAcnt cid <- lookupCurrency sCurrency sign <- lookupAccountSign sAcnt @@ -571,7 +600,7 @@ resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do -- TODO correct sign here? -- TODO lenses would be nice here return $ - (concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $ + concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $ \(aid_, cid_, sign_) tags_ -> s { sAcnt = aid_ @@ -586,16 +615,16 @@ insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do mapM_ (insertSplit k) ss insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR) -insertSplit t Split {sAcnt, sCurrency, sValue, sComment, sTags} = do +insertSplit t Entry {sAcnt, sCurrency, sValue, sComment, sTags} = do k <- insert $ SplitR t sCurrency sAcnt sComment sValue mapM_ (insert_ . TagRelationR k) sTags return k lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType)) -lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount) +lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR)) -lookupAccountKey = (fmap (fmap fstOf3)) . lookupAccount +lookupAccountKey = fmap (fmap fstOf3) . lookupAccount lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign) lookupAccountSign = fmap (fmap sndOf3) . lookupAccount @@ -604,10 +633,10 @@ lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType) lookupAccountType = fmap (fmap thdOf3) . lookupAccount lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR)) -lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency) +lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR)) -lookupTag c = lookupErr (DBKey TagField) c <$> (askDBState kmTag) +lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag -- TODO this hashes twice (not that it really matters) whenHash diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index dffc499..cd9180e 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -19,8 +19,8 @@ import qualified RIO.Vector as V -- TODO this probably won't scale well (pipes?) -readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx]) -readImport Import {..} = do +readImport :: MonadFinance m => Statement -> m (EitherErrs [BalTx]) +readImport Statement {..} = do let ores = plural $ compileOptions impTxOpts let cres = concatEithersL $ compileMatch <$> impMatches case concatEithers2 ores cres (,) of @@ -219,7 +219,7 @@ balanceSplits ss = $ groupByKey $ fmap (\s -> (sCurrency s, s)) ss where - hasValue s@(Split {sValue = Just v}) = Right s {sValue = v} + hasValue s@Entry {sValue = Just v} = Right s {sValue = v} hasValue s = Left s bal cur rss | length rss < 2 = Left $ BalanceError TooFewSplits cur rss diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index c2a58ff..6526cb7 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -33,33 +33,38 @@ makeHaskellTypesWith , MultipleConstructors "WeekdayPat" "(./dhall/Types.dhall).WeekdayPat" , MultipleConstructors "MDYPat" "(./dhall/Types.dhall).MDYPat" , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat" - , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD" - , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate" - , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum" - , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType" + , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher" + , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher" + , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter" , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency" + , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType" + , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod" , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency" , SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag" + , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt" , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian" , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval" - , SingleConstructor "Global" "Global" "(./dhall/Types.dhall).Global" + , SingleConstructor "TemporalScope" "TemporalScope" "(./dhall/Types.dhall).TemporalScope" , SingleConstructor "RepeatPat" "RepeatPat" "(./dhall/Types.dhall).RepeatPat" , SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type" , SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type" , SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal" - , SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type" - , SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual" + , SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type" , SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount" - , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount" - , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt" , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type" - , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type" + , SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type" , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer" , -- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income.Type" SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange" , SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field" - , SingleConstructor "Split" "Split" "(./dhall/Types.dhall).Split" + , SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry" + , SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue" + , SingleConstructor "TaxBracket" "TaxBracket" "(./dhall/Types.dhall).TaxBracket" + , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression" + , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue" + , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue" + , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue" -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx" -- , SingleConstructor "MatchOther" "MatchOther" "(./dhall/Types.dhall).MatchOther_" -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_" @@ -86,21 +91,25 @@ deriveProduct , "Budget" , "Income" , "ShadowTransfer" - , "ShadowMatch" + , "TransferMatcher" , "AcntSet" - , "MatchDate" - , "MatchVal" - , "MatchYMD" + , "DateMatcher" + , "ValMatcher" + , "YMDMatcher" , "Decimal" - , "Transfer" , "BudgetCurrency" - , "Manual" , "Exchange" - , "Amount" - , "AmountType" - , "SplitNum" - , "Global" + , "EntryNumGetter" + , "TemporalScope" , "SqlConfig" + , "PretaxValue" + , "TaxValue" + , "TaxBracket" + , "TaxProgression" + , "TaxMethod" + , "PosttaxValue" + , "BudgetTransferValue" + , "BudgetTransferType" ] ------------------------------------------------------------------------------- @@ -168,18 +177,37 @@ deriving instance Ord DatePat deriving instance Hashable DatePat +type BudgetTransfer = + Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue + data Budget = Budget { budgetLabel :: Text , incomes :: [Income] - , pretax :: [IntervalAllocation] - , tax :: [IntervalAllocation] - , posttax :: [IntervalAllocation] - , transfers :: [Transfer] + , pretax :: [MultiAllocation PretaxValue] + , tax :: [MultiAllocation TaxValue] + , posttax :: [MultiAllocation PosttaxValue] + , transfers :: [BudgetTransfer] , shadowTransfers :: [ShadowTransfer] } +deriving instance Hashable PretaxValue + +deriving instance Hashable TaxBracket + +deriving instance Hashable TaxProgression + +deriving instance Hashable TaxMethod + +deriving instance Hashable TaxValue + +deriving instance Hashable PosttaxValue + deriving instance Hashable Budget +deriving instance Hashable BudgetTransferValue + +deriving instance Hashable BudgetTransferType + deriving instance Hashable TaggedAcnt deriving instance Ord TaggedAcnt @@ -190,35 +218,49 @@ data Income = Income { incGross :: Decimal , incCurrency :: CurID , incWhen :: DatePat - , incPretax :: [Allocation] - , incTaxes :: [Allocation] - , incPosttax :: [Allocation] + , incPretax :: [SingleAllocation PretaxValue] + , incTaxes :: [SingleAllocation TaxValue] + , incPosttax :: [SingleAllocation PosttaxValue] , incFrom :: TaggedAcnt , incToBal :: TaggedAcnt } deriving instance Hashable Income -deriving instance Ord Amount +deriving instance (Ord w, Ord v) => Ord (Amount w v) -deriving instance Hashable Amount +deriving instance Generic (Amount w v) + +deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v) + +deriving instance (Generic w, Generic v, Hashable w, Hashable v) => Hashable (Amount w v) + +deriving instance (Show w, Show v) => Show (Amount w v) + +deriving instance (Eq w, Eq v) => Eq (Amount w v) deriving instance Hashable Exchange deriving instance Hashable BudgetCurrency -data Allocation_ a = Allocation_ +data Allocation w v = Allocation { alloTo :: TaggedAcnt - , alloAmts :: [a] - , alloCur :: BudgetCurrency + , alloAmts :: [Amount w v] + , alloCur :: CurID } deriving (Eq, Show, Generic, Hashable) -deriving instance FromDhall a => FromDhall (Allocation_ a) +instance Bifunctor Amount where + bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue} -type Allocation = Allocation_ Amount +instance Bifunctor Allocation where + bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts} -type IntervalAllocation = Allocation_ IntervalAmount +deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v) + +type MultiAllocation = Allocation Interval + +type SingleAllocation = Allocation () toPersistText :: Show a => a -> PersistValue toPersistText = PersistText . T.pack . show @@ -230,68 +272,38 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of fromPersistText what x = Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)] -deriving instance Ord AmountType - -deriving instance Hashable AmountType - --- data TimeAmount a = TimeAmount --- { taWhen :: a --- , taAmt :: Amount --- , taAmtType :: AmountType --- } --- deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable) - -deriving instance Show a => Show (TimeAmount a) - -deriving instance Eq a => Eq (TimeAmount a) - -deriving instance Ord a => Ord (TimeAmount a) - -deriving instance Functor TimeAmount - -deriving instance Foldable TimeAmount - -deriving instance Traversable TimeAmount - -deriving instance Generic (TimeAmount a) - -deriving instance Hashable a => Hashable (TimeAmount a) - -deriving instance FromDhall a => FromDhall (TimeAmount a) - -type DateAmount = TimeAmount DatePat - -type IntervalAmount = TimeAmount Interval - deriving instance Ord Interval -data Transfer = Transfer - { transFrom :: TaggedAcnt - , transTo :: TaggedAcnt - , transAmounts :: [DateAmount] - , transCurrency :: BudgetCurrency +data Transfer a c w v = Transfer + { transFrom :: a + , transTo :: a + , transAmounts :: [Amount w v] + , transCurrency :: c } + deriving (Eq, Show, Generic, FromDhall) -deriving instance Hashable Transfer +deriving instance + (Generic w, Generic v, Hashable a, Hashable c, Hashable w, Hashable v) + => Hashable (Transfer a c w v) deriving instance Hashable ShadowTransfer deriving instance Hashable AcntSet -deriving instance Hashable ShadowMatch +deriving instance Hashable TransferMatcher -deriving instance Hashable MatchVal +deriving instance Hashable ValMatcher -deriving instance Hashable MatchYMD +deriving instance Hashable YMDMatcher -deriving instance Hashable MatchDate +deriving instance Hashable DateMatcher deriving instance Ord Decimal deriving instance Hashable Decimal -- TODO this just looks silly...but not sure how to simplify it -instance Ord MatchYMD where +instance Ord YMDMatcher where compare (Y y) (Y y') = compare y y' compare (YM g) (YM g') = compare g g' compare (YMD g) (YMD g') = compare g g' @@ -306,15 +318,13 @@ gregM :: Gregorian -> GregorianM gregM Gregorian {gYear = y, gMonth = m} = GregorianM {gmYear = y, gmMonth = m} -instance Ord MatchDate where +instance Ord DateMatcher where compare (On d) (On d') = compare d d' compare (In d r) (In d' r') = compare d d' <> compare r r' compare (On d) (In d' _) = compare d d' <> LT compare (In d _) (On d') = compare d d' <> GT -deriving instance Hashable SplitNum - -deriving instance Hashable Manual +deriving instance Hashable EntryNumGetter ------------------------------------------------------------------------------- -- top level type with fixed account tree to unroll the recursion in the dhall @@ -347,10 +357,10 @@ deriving instance FromDhall AccountRootF type AccountRoot = AccountRoot_ AccountTree data Config_ a = Config_ - { global :: !Global + { global :: !TemporalScope , budget :: ![Budget] , currencies :: ![Currency] - , statements :: ![Statement] + , statements :: ![History] , accounts :: !a , tags :: ![Tag] , sqlConfig :: !SqlConfig @@ -384,22 +394,24 @@ type AcntID = T.Text type TagID = T.Text -data Statement - = StmtManual !Manual - | StmtImport !Import +type HistTransfer = Transfer AcntID CurID DatePat Decimal + +data History + = HistTransfer !HistTransfer + | HistStatement !Statement deriving (Eq, Hashable, Generic, FromDhall) -type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID +type ExpSplit = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID instance FromDhall ExpSplit -deriving instance (Show a, Show c, Show v, Show t) => Show (Split a v c t) +deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t) -deriving instance Generic (Split a v c t) +deriving instance Generic (Entry a v c t) -deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Split a v c t) +deriving instance (Hashable a, Hashable v, Hashable c, Hashable t) => Hashable (Entry a v c t) -deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Split a v c t) +deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t) data Tx s = Tx { txDescr :: !T.Text @@ -422,7 +434,7 @@ data TxOpts re = TxOpts } deriving (Eq, Generic, Hashable, Show, FromDhall) -data Import = Import +data Statement = Statement { impPaths :: ![FilePath] , impMatches :: ![Match T.Text] , impDelim :: !Word @@ -466,7 +478,7 @@ type FieldMap k v = Field k (M.Map k v) data MatchOther re = Desc !(Field T.Text re) - | Val !(Field T.Text MatchVal) + | Val !(Field T.Text ValMatcher) deriving (Eq, Hashable, Generic, FromDhall, Functor, Foldable, Traversable) deriving instance Show (MatchOther T.Text) @@ -479,8 +491,8 @@ data ToTx = ToTx deriving (Eq, Generic, Hashable, Show, FromDhall) data Match re = Match - { mDate :: !(Maybe MatchDate) - , mVal :: !MatchVal + { mDate :: !(Maybe DateMatcher) + , mVal :: !ValMatcher , mDesc :: !(Maybe re) , mOther :: ![MatchOther re] , mTx :: !(Maybe ToTx) @@ -583,7 +595,7 @@ data DBState = DBState type MappingT m = ReaderT DBState (SqlPersistT m) -type KeySplit = Split AccountRId Rational CurrencyRId TagRId +type KeySplit = Entry AccountRId Rational CurrencyRId TagRId type KeyTx = Tx KeySplit @@ -676,9 +688,9 @@ accountSign IncomeT = Credit accountSign LiabilityT = Credit accountSign EquityT = Credit -type RawSplit = Split AcntID (Maybe Rational) CurID TagID +type RawSplit = Entry AcntID (Maybe Rational) CurID TagID -type BalSplit = Split AcntID Rational CurID TagID +type BalSplit = Entry AcntID Rational CurID TagID type RawTx = Tx RawSplit @@ -720,7 +732,7 @@ data InsertError | ConversionError !T.Text | LookupError !LookupSuberr !T.Text | BalanceError !BalanceType !CurID ![RawSplit] - | IncomeError !DatePat + | IncomeError !Day !T.Text !Rational | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr | BoundsError !Gregorian !(Maybe Gregorian) | StatementError ![TxRecord] ![MatchRe] diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index b9992fa..873f5f1 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -97,22 +97,22 @@ gregMTup GregorianM {gmYear, gmMonth} = data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int -fromMatchYMD :: MatchYMD -> YMD_ -fromMatchYMD m = case m of +fromYMDMatcher :: YMDMatcher -> YMD_ +fromYMDMatcher m = case m of Y y -> Y_ $ fromIntegral y YM g -> uncurry YM_ $ gregMTup g YMD g -> uncurry3 YMD_ $ gregTup g -compareDate :: MatchDate -> Day -> Ordering +compareDate :: DateMatcher -> Day -> Ordering compareDate (On md) x = - case fromMatchYMD md of + case fromYMDMatcher md of Y_ y' -> compare y y' YM_ y' m' -> compare (y, m) (y', m') YMD_ y' m' d' -> compare (y, m, d) (y', m', d') where (y, m, d) = toGregorian x compareDate (In md offset) x = do - case fromMatchYMD md of + case fromYMDMatcher md of Y_ y' -> compareRange y' y YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m YMD_ y' m' d' -> @@ -172,7 +172,7 @@ toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = concatEithers2 acRes ssRes $ \(a_, c_) ss_ -> let fromSplit = - Split + Entry { sAcnt = a_ , sCurrency = c_ , sValue = Just trAmount @@ -188,8 +188,8 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,) ssRes = concatEithersL $ fmap (resolveSplit r) toSplits -valMatches :: MatchVal -> Rational -> EitherErr Bool -valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x +valMatches :: ValMatcher -> Rational -> EitherErr Bool +valMatches ValMatcher {mvDen, mvSign, mvNum, mvPrec} x | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p | otherwise = Right $ @@ -202,7 +202,7 @@ valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x s = signum x >= 0 checkMaybe = maybe True -dateMatches :: MatchDate -> Day -> Bool +dateMatches :: DateMatcher -> Day -> Bool dateMatches md = (EQ ==) . compareDate md otherMatches :: M.Map T.Text T.Text -> MatchOtherRe -> EitherErr Bool @@ -213,14 +213,14 @@ otherMatches dict m = case m of lookup_ t n = lookupErr (MatchField t) n dict resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit -resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} = +resolveSplit r s@Entry {sAcnt = a, sValue = v, sCurrency = c} = concatEithers2 acRes valRes $ \(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_}) where acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,) valRes = plural $ mapM (resolveValue r) v -resolveValue :: TxRecord -> SplitNum -> EitherErr Rational +resolveValue :: TxRecord -> EntryNumGetter -> EitherErr Rational resolveValue r s = case s of (LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r) (ConstN c) -> Right $ dec2Rat c @@ -371,8 +371,16 @@ showError other = case other of idName TagField = "tag" matchName MatchNumeric = "numeric" matchName MatchText = "text" - (IncomeError dp) -> - [T.append "Income allocations exceed total: datepattern=" $ showT dp] + (IncomeError day name balance) -> + [ T.unwords + [ "Income allocations for budget" + , singleQuote name + , "exceed total on day" + , showT day + , "where balance is" + , showT balance + ] + ] (BalanceError t cur rss) -> [ T.unwords [ msg @@ -406,8 +414,8 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs] where kvs = - [ ("date", showMatchDate <$> d) - , ("val", showMatchVal v) + [ ("date", showDateMatcher <$> d) + , ("val", showValMatcher v) , ("desc", fst <$> e) , ("other", others) , ("counter", Just $ maybe "Inf" showT n) @@ -420,14 +428,14 @@ showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriori -- | Convert match date to text -- Single date matches will just show the single date, and ranged matches will -- show an interval like [YY-MM-DD, YY-MM-DD) -showMatchDate :: MatchDate -> T.Text -showMatchDate md = case md of - (On x) -> showMatchYMD x - (In start n) -> T.concat ["[", showMatchYMD start, " ", showYMD_ end, ")"] +showDateMatcher :: DateMatcher -> T.Text +showDateMatcher md = case md of + (On x) -> showYMDMatcher x + (In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"] where -- TODO not DRY (this shifting thing happens during the comparison -- function (kinda) - end = case fromMatchYMD start of + end = case fromYMDMatcher start of Y_ y -> Y_ $ y + fromIntegral n YM_ y m -> let (y_, m_) = divMod (m + fromIntegral n - 1) 12 @@ -439,8 +447,8 @@ showMatchDate md = case md of fromGregorian y m d -- | convert YMD match to text -showMatchYMD :: MatchYMD -> T.Text -showMatchYMD = showYMD_ . fromMatchYMD +showYMDMatcher :: YMDMatcher -> T.Text +showYMDMatcher = showYMD_ . fromYMDMatcher showYMD_ :: YMD_ -> T.Text showYMD_ md = @@ -451,9 +459,9 @@ showYMD_ md = YM_ y m -> [fromIntegral y, m] YMD_ y m d -> [fromIntegral y, m, d] -showMatchVal :: MatchVal -> Maybe T.Text -showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing -showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} = +showValMatcher :: ValMatcher -> Maybe T.Text +showValMatcher ValMatcher {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing +showValMatcher ValMatcher {mvNum, mvDen, mvSign, mvPrec} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs] where kvs = @@ -471,11 +479,11 @@ showMatchOther (Val (Field f mv)) = [ "val field" , singleQuote f , "with match value" - , singleQuote $ fromMaybe "*" $ showMatchVal mv + , singleQuote $ fromMaybe "*" $ showValMatcher mv ] showSplit :: RawSplit -> T.Text -showSplit Split {sAcnt = a, sValue = v, sComment = c} = +showSplit Entry {sAcnt = a, sValue = v, sComment = c} = keyVals [ ("account", a) , ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float))