diff --git a/app/Main.hs b/app/Main.hs index f479df0..715f85c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,8 +2,12 @@ module Main (main) where +import Control.Monad.Except +import Control.Monad.IO.Rerunnable +import Control.Monad.Logger import Control.Monad.Reader import qualified Data.Text.IO as TI +import Database.Persist.Monad import Internal.Config import Internal.Database.Ops import Internal.Insert @@ -103,7 +107,7 @@ sync = parse :: Options -> IO () parse (Options c Reset) = do config <- readConfig c - migrate_ (sqlConfig config) nukeTables + runDB (sqlConfig config) nukeTables parse (Options c DumpAccounts) = runDumpAccounts c parse (Options c DumpAccountKeys) = runDumpAccountKeys c parse (Options c DumpCurrencies) = runDumpCurrencies c @@ -155,19 +159,31 @@ runDumpAccountKeys c = do t3 (_, _, x) = x double x = (x, x) -runSync :: MonadUnliftIO m => FilePath -> m () +runSync :: FilePath -> IO () runSync c = do config <- readConfig c - handle err $ migrate_ (sqlConfig config) $ do - res <- getDBState config - case res of - Left es -> throwIO $ InsertException es - Right s -> do - let run = mapReaderT $ flip runReaderT (s $ takeDirectory c) - es1 <- concat <$> mapM (run . insertBudget) (budget config) - es2 <- run $ insertStatements config - let es = es1 ++ es2 - unless (null es) $ throwIO $ InsertException es + let (hTs, hSs) = splitHistory $ statements config + pool <- runNoLoggingT $ mkPool $ sqlConfig config + handle err $ do + -- _ <- askLoggerIO + + -- get the current DB state + s <- runSqlQueryT pool $ do + runMigration migrateAll + fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config + + -- read desired statements from disk + bSs <- flip runReaderT s $ catMaybes <$> mapM readHistStmt hSs + + -- update the DB + runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do + let hTransRes = mapErrors insertHistTransfer hTs + let bgtRes = mapErrors insertBudget $ budget config + updateDBState -- TODO this will only work if foreign keys are deferred + res <- runExceptT $ do + mapM_ (uncurry insertHistStmt) bSs + combineError hTransRes bgtRes $ \_ _ -> () + rerunnableIO $ fromEither res where err (InsertException es) = do liftIO $ mapM_ TI.putStrLn $ concatMap showError es diff --git a/budget.cabal b/budget.cabal index 3516b37..c3ae77e 100644 --- a/budget.cabal +++ b/budget.cabal @@ -29,6 +29,7 @@ library Internal.Database.Ops Internal.Insert Internal.Statement + Internal.TH Internal.Types Internal.Utils other-modules: @@ -88,6 +89,7 @@ library , mtl , optparse-applicative , persistent >=2.13.3.1 + , persistent-mtl >=0.3.0.0 , persistent-sqlite , recursion-schemes , regex-tdfa @@ -157,6 +159,7 @@ executable pwncash , mtl , optparse-applicative , persistent >=2.13.3.1 + , persistent-mtl >=0.3.0.0 , persistent-sqlite , recursion-schemes , regex-tdfa diff --git a/dhall/Accounts.dhall b/dhall/Accounts.dhall deleted file mode 100644 index 7b42b72..0000000 --- a/dhall/Accounts.dhall +++ /dev/null @@ -1,50 +0,0 @@ -let List/map = - https://prelude.dhall-lang.org/v21.1.0/List/map - sha256:dd845ffb4568d40327f2a817eb42d1c6138b929ca758d50bc33112ef3c885680 - -let AccountTree - : Type - = forall (a : Type) -> - forall ( Fix - : < AccountF : { _1 : Text, _2 : Text } - | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a } - > -> - a - ) -> - a - -let AccountTreeF = - \(a : Type) -> - < AccountF : { _1 : Text, _2 : Text } - | PlaceholderF : { _1 : Text, _2 : Text, _3 : List a } - > - -let Account - : Text -> Text -> AccountTree - = \(desc : Text) -> - \(name : Text) -> - \(a : Type) -> - let f = AccountTreeF a - - in \(Fix : f -> a) -> Fix (f.AccountF { _1 = desc, _2 = name }) - -let Placeholder - : Text -> Text -> List AccountTree -> AccountTree - = \(desc : Text) -> - \(name : Text) -> - \(children : List AccountTree) -> - \(a : Type) -> - let f = AccountTreeF a - - in \(Fix : f -> a) -> - let apply = \(x : AccountTree) -> x a Fix - - in Fix - ( f.PlaceholderF - { _1 = desc - , _2 = name - , _3 = List/map AccountTree a apply children - } - ) - -in { Account, Placeholder } diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 3bf6b48..063c7c2 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -2,34 +2,205 @@ 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 + , curPrecision : + {- + The number of decimal places for this currency + -} + Natural + } + +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,45 +210,109 @@ 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 - , cronMonth : Optional MDYPat - , cronDay : Optional MDYPat + { cpWeekly : Optional WeekdayPat + , cpYear : Optional MDYPat + , cpMonth : Optional MDYPat + , cpDay : Optional MDYPat } , default = - { cronWeekly = None WeekdayPat - , cronYear = None MDYPat - , cronMonth = None MDYPat - , cronDay = None MDYPat + { cpWeekly = None WeekdayPat + , cpYear = None MDYPat + , cpMonth = None MDYPat + , cpDay = None MDYPat } } -let DatePat = < Cron : CronPat.Type | Mod : ModPat.Type > +let DatePat = + {- + Means of matching dates -let Decimal = - { whole : Natural, decimal : Natural, precision : Natural, sign : Bool } + Cron: use cron-like date matching + Mod: use modular temporal arithmetic matching + -} + < Cron : CronPat.Type | Mod : ModPat.Type > 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,34 +324,97 @@ 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 + { vmSign : + {- + Sign of value. + True -> positive, + False -> negative, + None -> do not consider. + -} + Optional Bool + , vmNum : + {- + Value of numerator to match. Do not consider numerator if none + -} + Optional Natural + , vmDen : + {- + Value of denominator to match. Do not consider numerator if none + -} + Optional Natural + , vmPrec : + {- + 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 - , mvNum = None Natural - , mvDen = None Natural - , mvPrec = 2 + { vmSign = None Bool + , vmNum = None Natural + , vmDen = None Natural + , vmPrec = 2 } } -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 = < Desc : Field Text Text | 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 SplitNum = < LookupN : Text | ConstN : Decimal | AmountN > +let FieldMatcher = FieldMatcher_ Text -let SplitText = +let EntryNumGetter = + {- + Means to get a numeric value from a statement row. + + LookupN: lookup the value from a field + ConstN: a constant value + AmountN: the value of the 'Amount' column + -} + < LookupN : Text | ConstN : Double | 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 @@ -124,162 +422,602 @@ 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 + { eAcnt : + {- + Pertains to account for this entry. + -} + a + , eValue : + {- + Pertains to value for this entry. + -} + v + , eCurrency : + {- + Pertains to value for this entry. + -} + c + , eComment : + {- + A short description of this entry (if none, use a blank string) + -} + Text + , eTags : + {- + 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 ToTx = - { ttCurrency : SplitCur - , ttPath : SplitAcnt - , ttSplit : List ExpSplit.Type - } - -let Match = +let EntryGetter = + {- + Means for getting an entry from a given row in a statement + -} { Type = - { mDate : Optional MatchDate - , mVal : MatchVal.Type - , mDesc : Optional Text - , mOther : List MatchOther - , mTx : Optional ToTx - , mTimes : Optional Natural - , mPriority : Integer + Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID + , default = { eValue = None EntryNumGetter, eComment = "" } + } + +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 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 = + { spDate : + {- + How to match the date column; if none match any date + -} + Optional DateMatcher + , spVal : + {- + How to match the value column; if none match any value + -} + ValMatcher.Type + , spDesc : + {- + Regular expression to match the description; + if none match anythingS + -} + Optional re + , spOther : + {- + How to match additional columns if present + -} + List (FieldMatcher_ re) + , spTx : + {- + 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 + , spTimes : + {- + Match at most this many rows; if none there is no limit + -} + Optional Natural + , spPriority : + {- + In case of multiple matches, higher priority gets precedence. + -} + Integer + } + , default = + { spDate = None DateMatcher + , spVal = ValMatcher::{=} + , spDesc = None Text + , spOther = [] : List (FieldMatcher_ re) + , spTx = None TxGetter + , spTimes = None Natural + , spPriority = +0 } - , default = - { mDate = None MatchDate - , mVal = MatchVal::{=} - , mDesc = None Text - , mOther = [] : List MatchOther - , mTx = None ToTx - , mTimes = None Natural - , mPriority = +0 } - } -let Manual = - { manualDate : DatePat - , manualFrom : AcntID - , manualTo : AcntID - , manualValue : Decimal - , manualDesc : Text - , manualCurrency : CurID - } +let StatementParser = + {- + A statement parser specialized to raw regular expressions. + -} + StatementParser_ Text -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 Exchange = - { xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal } - -let BudgetCurrency = < NoX : CurID | X : Exchange > - -let TaggedAcnt = { taAcnt : AcntID, taTags : List TagID } - -let Allocation_ = - \(t : Type) -> - { alloTo : TaggedAcnt, alloAmts : List t, alloCur : BudgetCurrency } - -let Allocation = Allocation_ Amount - -let IntervalAllocation = Allocation_ (TimeAmount Interval) - -let Income = - { Type = - { incGross : Decimal - , incCurrency : CurID - , incWhen : DatePat - , incPretax : List Allocation - , incTaxes : List Allocation - , incPosttax : List Allocation - , incFrom : - {- this must be an income AcntID, and is the only place income - accounts may be specified in the entire budget -} - TaggedAcnt - , incToBal : TaggedAcnt - } - , default = - { incPretax = [] : List Allocation - , incTaxes = [] : List Allocation - , incPosttaxx = [] : List Allocation - } - } +let Amount = + {- + A quantify of currency at a given time. + -} + \(w : Type) -> + \(v : Type) -> + { amtWhen : w, amtValue : v, amtDesc : Text } let Transfer = - { transFrom : TaggedAcnt - , transTo : TaggedAcnt - , transAmounts : List DateAmount - , transCurrency : BudgetCurrency + {- + 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 Double + +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 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 = + {- + 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. + -} + Double + } + +let BudgetCurrency = + {- + A 'currency' in the budget; either a fixed currency or an exchange + -} + < NoX : CurID | X : Exchange > + +let TaggedAcnt = + {- + An account with a tag + -} + { taAcnt : AcntID, taTags : List TagID } + +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 PretaxValue = + {- + How to determine value of a pretax allocation. + -} + { preValue : + {- + The value to be deducted from gross income + -} + Double + , 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 TaxBracket = + {- + A single tax bracket. Read as "every unit above limit is taxed at this + percentage". + -} + { tbLowerLimit : Double, tbPercent : Double } + +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. + -} + { tpDeductible : + {- + Initial amount to subtract from after-pretax-deductions + -} + Double + , tpBrackets : + {- + 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 : Double > + +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. + -} + Double + , 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 HourlyPeriod = + {- + Definition for a pay period denominated in hours + -} + { hpAnnualHours : + {- + Number of hours in one year + -} + Natural + , hpDailyHours : + {- + Number of hours in one working day + -} + Natural + , hpWorkingDays : + {- + Days which count as working days + -} + List Weekday + } + +let PeriodType = + {- + Type of pay period. + + Hourly: pay period is denominated in hours + Daily: pay period is denominated in working days (specified in a list) + -} + < Hourly : HourlyPeriod | Daily : List Weekday > + +let Period = + {- + Definition of a pay period + -} { pType : + {- + Type of pay period + -} + PeriodType + , pStart : + {- + Start date of the pay period. Must occur before first payment + in this income stream is dispersed. + -} + Gregorian + } + +let Income = + {- + Means to compute an income stream and how to allocate it + -} + { Type = + { incGross : + {- + The value of the income stream. + -} + Double + , incCurrency : + {- + The currency in which the income stream is denominated. + -} + CurID + , incWhen : + {- + The dates on which the income stream is distributed. + -} + DatePat + , incPayPeriod : + {- + Defines the period of time over which this income was earned + (mostly used for taxes) + -} + Period + , incPretax : List (SingleAllocation PretaxValue) + , incTaxes : List (SingleAllocation TaxValue) + , incPosttax : List (SingleAllocation PosttaxValue) + , incFrom : + {- + 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 + } + , default = + { incPretax = [] : List (SingleAllocation PretaxValue) + , incTaxes = [] : List (SingleAllocation TaxValue) + , incPosttaxx = [] : List (SingleAllocation PosttaxValue) + } } 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 + { tmFrom : + {- + List of accounts (which may be empty) to match with the + starting account in a transfer. + -} + AcntSet.Type + , tmTo : + {- + List of accounts (which may be empty) to match with the + ending account in a transfer. + -} + AcntSet.Type + , tmDate : + {- + If given, means to match the date of a transfer. + -} + Optional DateMatcher + , tmVal : + {- + 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 + { tmFrom = AcntSet.default + , tmTo = AcntSet.default + , tmDate = None DateMatcher + , tmVal = 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. + -} + Double } +let BudgetTransferValue = + {- + Means to determine the value of a budget transfer. + -} + { btVal : Double, btType : BudgetTransferType } + +let BudgetTransfer = + {- + A manually specified transaction for a budget + -} + Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue + let Budget = - { budgetLabel : Text - , incomes : List Income.Type - , pretax : List IntervalAllocation - , tax : List IntervalAllocation - , posttax : List IntervalAllocation - , transfers : List Transfer - , shadowTransfers : List ShadowTransfer + {- + A hypothetical set of transactions (eg a "budget") to be generated + and inserted into the database. + -} + { bgtLabel : + {- + A unique label for this budget. + + Can be useful to compare multiple potential futures. + -} + Text + , bgtIncomes : List Income.Type + , bgtPretax : List (MultiAllocation PretaxValue) + , bgtTax : List (MultiAllocation TaxValue) + , bgtPosttax : List (MultiAllocation PosttaxValue) + , bgtTransfers : List BudgetTransfer + , bgtShadowTransfers : List ShadowTransfer } in { CurID @@ -289,7 +1027,7 @@ in { CurID , Tag , TagID , Interval - , Global + , TemporalScope , Gregorian , GregorianM , TimeUnit @@ -300,37 +1038,50 @@ in { CurID , WeekdayPat , CronPat , DatePat - , Decimal , TxOpts - , Match - , MatchVal - , MatchYMD - , MatchDate - , 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 + , TxGetter + , HistTransfer + , SingleAllocation + , MultiAllocation + , HourlyPeriod + , Period + , PeriodType } diff --git a/dhall/common.dhall b/dhall/common.dhall index de043d2..b8c96d0 100644 --- a/dhall/common.dhall +++ b/dhall/common.dhall @@ -4,29 +4,16 @@ let List/map = let T = ./Types.dhall -let dec = - \(s : Bool) -> - \(w : Natural) -> - \(d : Natural) -> - \(p : Natural) -> - { whole = w, decimal = d, precision = p, sign = s } : T.Decimal - -let dec2 = \(s : Bool) -> \(w : Natural) -> \(d : Natural) -> dec s w d 2 - -let d = dec2 True - -let d_ = dec2 False - let nullSplit = - \(a : T.SplitAcnt) -> - \(c : T.SplitCur) -> - T.ExpSplit::{ sAcnt = a, sCurrency = c, sTags = [] : List T.TagID } + \(a : T.EntryAcntGetter) -> + \(c : T.EntryCurGetter) -> + T.EntryGetter::{ eAcnt = a, eCurrency = c, eTags = [] : List T.TagID } let nullOpts = T.TxOpts::{=} -let nullVal = T.MatchVal::{=} +let nullVal = T.ValMatcher::{=} -let nullMatch = T.Match::{=} +let nullMatch = T.StatementParser::{=} let nullCron = T.CronPat::{=} @@ -41,20 +28,20 @@ let cron1 = \(d : Natural) -> T.DatePat.Cron ( nullCron - // { cronYear = Some (T.MDYPat.Single y) - , cronMonth = Some (T.MDYPat.Single m) - , cronDay = Some (T.MDYPat.Single d) + // { cpYear = Some (T.MDYPat.Single y) + , cpMonth = Some (T.MDYPat.Single m) + , cpDay = Some (T.MDYPat.Single d) } ) let matchInf_ = nullMatch -let matchInf = \(x : T.ToTx) -> nullMatch // { mTx = Some x } +let matchInf = \(x : T.TxGetter) -> nullMatch // { spTx = Some x } -let matchN_ = \(n : Natural) -> nullMatch // { mTimes = Some n } +let matchN_ = \(n : Natural) -> nullMatch // { spTimes = Some n } let matchN = - \(n : Natural) -> \(x : T.ToTx) -> matchInf x // { mTimes = Some n } + \(n : Natural) -> \(x : T.TxGetter) -> matchInf x // { spTimes = Some n } let match1_ = matchN_ 1 @@ -68,61 +55,63 @@ let greg = \(d : Natural) -> { gYear = y, gMonth = m, gDay = d } -let mY = \(y : Natural) -> T.MatchDate.On (T.MatchYMD.Y y) +let mY = \(y : Natural) -> T.DateMatcher.On (T.YMDMatcher.Y y) let mYM = \(y : Natural) -> \(m : Natural) -> - T.MatchDate.On (T.MatchYMD.YM (gregM y m)) + T.DateMatcher.On (T.YMDMatcher.YM (gregM y m)) let mYMD = \(y : Natural) -> \(m : Natural) -> \(d : Natural) -> - T.MatchDate.On (T.MatchYMD.YMD (greg y m d)) + T.DateMatcher.On (T.YMDMatcher.YMD (greg y m d)) let mRngY = \(y : Natural) -> \(r : Natural) -> - T.MatchDate.In { _1 = T.MatchYMD.Y y, _2 = r } + T.DateMatcher.In { _1 = T.YMDMatcher.Y y, _2 = r } let mRngYM = \(y : Natural) -> \(m : Natural) -> \(r : Natural) -> - T.MatchDate.In { _1 = T.MatchYMD.YM (gregM y m), _2 = r } + T.DateMatcher.In { _1 = T.YMDMatcher.YM (gregM y m), _2 = r } let mRngYMD = \(y : Natural) -> \(m : Natural) -> \(d : Natural) -> \(r : Natural) -> - T.MatchDate.In { _1 = T.MatchYMD.YMD (greg y m d), _2 = r } + T.DateMatcher.In { _1 = T.YMDMatcher.YMD (greg y m d), _2 = r } -let PartSplit = { _1 : T.AcntID, _2 : T.Decimal, _3 : Text } +let PartSplit = { _1 : T.AcntID, _2 : Double, _3 : Text } let partN = - \(c : T.SplitCur) -> - \(a : T.SplitAcnt) -> + \(c : T.EntryCurGetter) -> + \(a : T.EntryAcntGetter) -> \(comment : Text) -> \(ss : List PartSplit) -> let toSplit = \(x : PartSplit) -> - nullSplit (T.SplitAcnt.ConstT x._1) c - // { sValue = Some (T.SplitNum.ConstN x._2), sComment = x._3 } + nullSplit (T.EntryAcntGetter.ConstT x._1) c + // { eValue = Some (T.EntryNumGetter.ConstN x._2) + , eComment = x._3 + } - in [ nullSplit a c // { sComment = comment } ] - # List/map PartSplit T.ExpSplit.Type toSplit ss + in [ nullSplit a c // { eComment = comment } ] + # List/map PartSplit T.EntryGetter.Type toSplit ss let part1 = - \(c : T.SplitCur) -> - \(a : T.SplitAcnt) -> + \(c : T.EntryCurGetter) -> + \(a : T.EntryAcntGetter) -> \(comment : Text) -> partN c a comment ([] : List PartSplit) let part1_ = - \(c : T.SplitCur) -> - \(a : T.SplitAcnt) -> + \(c : T.EntryCurGetter) -> + \(a : T.EntryAcntGetter) -> partN c a "" ([] : List PartSplit) let addDay = @@ -130,21 +119,21 @@ let addDay = \(d : Natural) -> { gYear = x.gmYear, gMonth = x.gmMonth, gDay = d } -let mvP = nullVal // { mvSign = Some True } +let mvP = nullVal // { vmSign = Some True } -let mvN = nullVal // { mvSign = Some False } +let mvN = nullVal // { vmSign = Some False } -let mvNum = \(x : Natural) -> nullVal // { mvNum = Some x } +let mvNum = \(x : Natural) -> nullVal // { vmNum = Some x } -let mvDen = \(x : Natural) -> nullVal // { mvDen = Some x } +let mvDen = \(x : Natural) -> nullVal // { vmDen = Some x } -let mvNumP = \(x : Natural) -> mvP // { mvNum = Some x } +let mvNumP = \(x : Natural) -> mvP // { vmNum = Some x } -let mvNumN = \(x : Natural) -> mvN // { mvNum = Some x } +let mvNumN = \(x : Natural) -> mvN // { vmNum = Some x } -let mvDenP = \(x : Natural) -> mvP // { mvDen = Some x } +let mvDenP = \(x : Natural) -> mvP // { vmDen = Some x } -let mvDenN = \(x : Natural) -> mvN // { mvDen = Some x } +let mvDenN = \(x : Natural) -> mvN // { vmDen = Some x } in { nullSplit , nullMatch @@ -182,9 +171,5 @@ in { nullSplit , mvDenP , mvDenN , PartSplit - , d - , d_ - , dec - , dec2 } /\ T diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 54aeac0..f7c95a3 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -1,21 +1,26 @@ module Internal.Database.Ops - ( migrate_ + ( runDB , nukeTables , updateHashes + , updateDBState , getDBState , tree2Records , flattenAcntRoot , paths2IDs + , mkPool ) where import Conduit +import Control.Monad.Except import Control.Monad.Logger import Data.Hashable -import Database.Esqueleto.Experimental -import Database.Persist.Sql hiding (delete, (==.), (||.)) -import Database.Persist.Sqlite hiding (delete, (==.), (||.)) -import Database.Sqlite hiding (Config) +import Database.Esqueleto.Experimental ((==.), (^.)) +import qualified Database.Esqueleto.Experimental as E +import Database.Esqueleto.Internal.Internal (SqlSelect) +import Database.Persist.Monad +-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.)) +import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.)) import GHC.Err import Internal.Types import Internal.Utils @@ -26,31 +31,27 @@ import qualified RIO.Map as M import qualified RIO.NonEmpty as N import qualified RIO.Text as T -migrate_ +runDB :: MonadUnliftIO m => SqlConfig - -> SqlPersistT (ResourceT (NoLoggingT m)) () - -> m () -migrate_ c more = - runNoLoggingT $ - runResourceT $ - withSqlConn - (openConnection c) - ( \backend -> - flip runSqlConn backend $ do - _ <- askLoggerIO - runMigration migrateAll - more - ) + -> SqlQueryT (NoLoggingT m) a + -> m a +runDB c more = + runNoLoggingT $ do + pool <- mkPool c + runSqlQueryT pool $ do + _ <- lift askLoggerIO + runMigration migrateAll + more -openConnection :: MonadUnliftIO m => SqlConfig -> LogFunc -> m SqlBackend -openConnection c logfn = case c of - Sqlite p -> liftIO $ do - conn <- open p - wrapConnection conn logfn +mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool +mkPool c = case c of + Sqlite p -> createSqlitePool p 10 + -- conn <- open p + -- wrapConnection conn logfn Postgres -> error "postgres not implemented" -nukeTables :: MonadUnliftIO m => SqlPersistT m () +nukeTables :: MonadSqlQuery m => m () nukeTables = do deleteWhere ([] :: [Filter CommitR]) deleteWhere ([] :: [Filter CurrencyR]) @@ -98,8 +99,8 @@ hashConfig } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps) where (ms, ps) = partitionEithers $ fmap go ss - go (StmtManual x) = Left x - go (StmtImport x) = Right x + go (HistTransfer x) = Left x + go (HistStatement x) = Right x setDiff :: Eq a => [a] -> [a] -> ([a], [a]) -- setDiff = setDiff' (==) @@ -118,99 +119,67 @@ setDiff as bs = (as \\ bs, bs \\ as) -- | f a b = Just bs -- | otherwise = inB a bs -getDBHashes :: MonadUnliftIO m => SqlPersistT m [Int] +getDBHashes :: MonadSqlQuery m => m [Int] getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl -nukeDBHash :: MonadUnliftIO m => Int -> SqlPersistT m () -nukeDBHash h = delete $ do - c <- from table - where_ (c ^. CommitRHash ==. val h) +nukeDBHash :: MonadSqlQuery m => Int -> m () +nukeDBHash h = deleteE $ do + c <- E.from E.table + E.where_ (c ^. CommitRHash ==. E.val h) -nukeDBHashes :: MonadUnliftIO m => [Int] -> SqlPersistT m () +nukeDBHashes :: MonadSqlQuery m => [Int] -> m () nukeDBHashes = mapM_ nukeDBHash -getConfigHashes :: MonadUnliftIO m => Config -> SqlPersistT m ([Int], [Int]) +getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int]) getConfigHashes c = do let ch = hashConfig c dh <- getDBHashes return $ setDiff dh ch -updateHashes :: MonadUnliftIO m => Config -> SqlPersistT m [Int] -updateHashes c = do - (del, new) <- getConfigHashes c - nukeDBHashes del - return new +dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r] +dumpTbl = selectE $ E.from E.table -dumpTbl :: (PersistEntity r, MonadUnliftIO m) => SqlPersistT m [Entity r] -dumpTbl = select $ from table - -deleteAccount :: MonadUnliftIO m => Entity AccountR -> SqlPersistT m () -deleteAccount e = delete $ do - c <- from $ table @AccountR - where_ (c ^. AccountRId ==. val k) +deleteAccount :: MonadSqlQuery m => Entity AccountR -> m () +deleteAccount e = deleteE $ do + c <- E.from $ E.table @AccountR + E.where_ (c ^. AccountRId ==. E.val k) where k = entityKey e -deleteCurrency :: MonadUnliftIO m => Entity CurrencyR -> SqlPersistT m () -deleteCurrency e = delete $ do - c <- from $ table @CurrencyR - where_ (c ^. CurrencyRId ==. val k) +deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m () +deleteCurrency e = deleteE $ do + c <- E.from $ E.table @CurrencyR + E.where_ (c ^. CurrencyRId ==. E.val k) where k = entityKey e -deleteTag :: MonadUnliftIO m => Entity TagR -> SqlPersistT m () -deleteTag e = delete $ do - c <- from $ table @TagR - where_ (c ^. TagRId ==. val k) +deleteTag :: MonadSqlQuery m => Entity TagR -> m () +deleteTag e = deleteE $ do + c <- E.from $ E.table @TagR + E.where_ (c ^. TagRId ==. E.val k) where k = entityKey e -updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap -updateAccounts ar = do - let (acnts, paths, acntMap) = indexAcntRoot ar - acnts' <- dumpTbl - let (toIns, toDel) = setDiff acnts acnts' - deleteWhere ([] :: [Filter AccountPathR]) - mapM_ deleteAccount toDel - -- liftIO $ mapM_ print toDel - mapM_ insertFull toIns - mapM_ insert paths - return acntMap - -- TODO slip-n-slide code... insertFull - :: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b) + :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m) => Entity r - -> ReaderT b m () + -> m () insertFull (Entity k v) = insertKey k v -updateCurrencies :: MonadUnliftIO m => [Currency] -> SqlPersistT m CurrencyMap -updateCurrencies cs = do - let curs = fmap currency2Record cs - curs' <- select $ from $ table @CurrencyR - let (toIns, toDel) = setDiff curs curs' - mapM_ deleteCurrency toDel - mapM_ insertFull toIns - return $ currencyMap curs - currency2Record :: Currency -> Entity CurrencyR -currency2Record c@Currency {curSymbol, curFullname} = - Entity (toKey c) $ CurrencyR curSymbol curFullname +currency2Record c@Currency {curSymbol, curFullname, curPrecision} = + Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) currencyMap :: [Entity CurrencyR] -> CurrencyMap -currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e)) - -updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap -updateTags cs = do - let tags = fmap toRecord cs - tags' <- select $ from $ table @TagR - let (toIns, toDel) = setDiff tags tags' - mapM_ deleteTag toDel - mapM_ insertFull toIns - return $ tagMap tags - where - toRecord t@(Tag {tagID, tagDesc}) = Entity (toKey t) $ TagR tagID tagDesc - tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e)) +currencyMap = + M.fromList + . fmap + ( \e -> + ( currencyRSymbol $ entityVal e + , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e) + ) + ) toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b toKey = toSqlKey . fromIntegral . hash @@ -317,26 +286,81 @@ indexAcntRoot r = (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r getDBState - :: MonadUnliftIO m + :: (MonadInsertError m, MonadSqlQuery m) => Config - -> SqlPersistT m (EitherErrs (FilePath -> DBState)) + -> m (FilePath -> DBState) getDBState c = do - am <- updateAccounts $ accounts c - cm <- updateCurrencies $ currencies c - ts <- updateTags $ tags c - hs <- updateHashes c + (del, new) <- getConfigHashes c -- TODO not sure how I feel about this, probably will change this struct alot -- in the future so whatever...for now - return $ concatEither2 bi si $ \b s f -> + combineError bi si $ \b s f -> + -- TODO this can be cleaned up, half of it is meant to be queried when + -- determining how to insert budgets/history and the rest is just + -- holdover data to delete upon successful insertion DBState - { kmCurrency = cm + { kmCurrency = currencyMap cs , kmAccount = am , kmBudgetInterval = b , kmStatementInterval = s - , kmNewCommits = hs + , kmNewCommits = new + , kmOldCommits = del , kmConfigDir = f - , kmTag = ts + , kmTag = tagMap ts + , kmTagAll = ts + , kmAcntPaths = paths + , kmAcntsOld = acnts + , kmCurrenciesOld = cs } where - bi = resolveBounds $ budgetInterval $ global c - si = resolveBounds $ statementInterval $ global c + bi = liftExcept $ resolveBounds $ budgetInterval $ global c + si = liftExcept $ resolveBounds $ statementInterval $ global c + (acnts, paths, am) = indexAcntRoot $ accounts c + cs = currency2Record <$> currencies c + ts = toRecord <$> tags c + toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc + tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e)) + +updateHashes :: (MonadFinance m, MonadSqlQuery m) => m () +updateHashes = do + old <- askDBState kmOldCommits + nukeDBHashes old + +updateTags :: (MonadFinance m, MonadSqlQuery m) => m () +updateTags = do + tags <- askDBState kmTagAll + tags' <- selectE $ E.from $ E.table @TagR + let (toIns, toDel) = setDiff tags tags' + mapM_ deleteTag toDel + mapM_ insertFull toIns + +updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m () +updateAccounts = do + acnts <- askDBState kmAcntsOld + paths <- askDBState kmAcntPaths + acnts' <- dumpTbl + let (toIns, toDel) = setDiff acnts acnts' + deleteWhere ([] :: [Filter AccountPathR]) + mapM_ deleteAccount toDel + mapM_ insertFull toIns + mapM_ insert paths + +updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m () +updateCurrencies = do + curs <- askDBState kmCurrenciesOld + curs' <- selectE $ E.from $ E.table @CurrencyR + let (toIns, toDel) = setDiff curs curs' + mapM_ deleteCurrency toDel + mapM_ insertFull toIns + +updateDBState :: (MonadFinance m, MonadSqlQuery m) => m () +updateDBState = do + updateHashes + updateTags + updateAccounts + updateCurrencies + +deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m () +deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) + +selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r] +selectE q = unsafeLiftSql "esqueleto-select" (E.select q) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index c07b276..740d11b 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -1,14 +1,17 @@ module Internal.Insert - ( insertStatements - , insertBudget + ( insertBudget + , splitHistory + , insertHistTransfer + , readHistStmt + , insertHistStmt ) where +import Control.Monad.Except import Data.Hashable -import Database.Persist.Class -import Database.Persist.Sql hiding (Single, Statement) +import Database.Persist.Monad import Internal.Statement -import Internal.Types hiding (sign) +import Internal.Types import Internal.Utils import RIO hiding (to) import qualified RIO.List as L @@ -20,9 +23,9 @@ import RIO.Time -------------------------------------------------------------------------------- -- intervals -expandDatePat :: Bounds -> DatePat -> EitherErrs [Day] +expandDatePat :: Bounds -> DatePat -> InsertExcept [Day] expandDatePat b (Cron cp) = expandCronPat b cp -expandDatePat i (Mod mp) = Right $ expandModPat mp i +expandDatePat i (Mod mp) = return $ expandModPat mp i expandModPat :: ModPat -> Bounds -> [Day] expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs = @@ -39,22 +42,22 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs = Month -> addGregorianMonthsClip Year -> addGregorianYearsClip -expandCronPat :: Bounds -> CronPat -> EitherErrs [Day] -expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} = - concatEither3 yRes mRes dRes $ \ys ms ds -> +expandCronPat :: Bounds -> CronPat -> InsertExcept [Day] +expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} = + combineError3 yRes mRes dRes $ \ys ms ds -> filter validWeekday $ mapMaybe (uncurry3 toDay) $ takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $ dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $ [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds] where - yRes = case cronYear of + yRes = case cpYear of Nothing -> return [yb0 .. yb1] Just pat -> do ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat return $ dropWhile (< yb0) $ fromIntegral <$> ys - mRes = expandMD 12 cronMonth - dRes = expandMD 31 cronDay + mRes = expandMD 12 cpMonth + dRes = expandMD 31 cpDay (s, e) = expandBounds b (yb0, mb0, db0) = toGregorian s (yb1, mb1, db1) = toGregorian $ addDays (-1) e @@ -63,45 +66,57 @@ expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} = . maybe (return [1 .. lim]) (expandMDYPat 1 lim) expandW (OnDay x) = [fromEnum x] expandW (OnDays xs) = fromEnum <$> xs - ws = maybe [] expandW cronWeekly + ws = maybe [] expandW cpWeekly validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws toDay (y, leap) m d | m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing | m `elem` [4, 6, 9, 11] && d > 30 = Nothing | otherwise = Just $ fromGregorian y m d -expandMDYPat :: Natural -> Natural -> MDYPat -> EitherErr [Natural] -expandMDYPat lower upper (Single x) = Right [x | lower <= x && x <= upper] -expandMDYPat lower upper (Multi xs) = Right $ dropWhile (<= lower) $ takeWhile (<= upper) xs -expandMDYPat lower upper (After x) = Right [max lower x .. upper] -expandMDYPat lower upper (Before x) = Right [lower .. min upper x] -expandMDYPat lower upper (Between x y) = Right [max lower x .. min upper y] +expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural] +expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper] +expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs +expandMDYPat lower upper (After x) = return [max lower x .. upper] +expandMDYPat lower upper (Before x) = return [lower .. min upper x] +expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y] expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) - | b < 1 = Left $ PatternError s b r ZeroLength + | b < 1 = throwError $ InsertException [PatternError s b r ZeroLength] | otherwise = do k <- limit r return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]] where - limit Nothing = Right upper + limit Nothing = return upper limit (Just n) -- this guard not only produces the error for the user but also protects -- from an underflow below it - | n < 1 = Left $ PatternError s b r ZeroRepeats - | otherwise = Right $ min (s + b * (n - 1)) upper + | n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats] + | otherwise = return $ min (s + b * (n - 1)) upper dayToWeekday :: Day -> Int dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 withDates - :: MonadFinance m + :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m) => DatePat - -> (Day -> SqlPersistT m (EitherErrs a)) - -> SqlPersistT m (EitherErrs [a]) + -> (Day -> m a) + -> m [a] withDates dp f = do - bounds <- lift $ askDBState kmBudgetInterval - case expandDatePat bounds dp of - Left es -> return $ Left es - Right days -> concatEithersL <$> mapM f days + bounds <- askDBState kmBudgetInterval + days <- liftExcept $ expandDatePat bounds dp + combineErrors $ fmap f days + +foldDates + :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m) + => DatePat + -> Day + -> (Day -> Day -> m a) + -> m [a] +foldDates dp start f = do + bounds <- askDBState kmBudgetInterval + days <- liftExcept $ expandDatePat bounds dp + combineErrors $ + snd $ + L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days -------------------------------------------------------------------------------- -- budget @@ -117,439 +132,563 @@ withDates dp f = do -- 4. assign shadow transactions (TODO) -- 5. insert all transactions -insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError] insertBudget - 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 (++)) $ - \txs -> do - unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do - let bals = balanceTransfers $ txs ++ shadow - concat <$> mapM insertBudgetTx bals + :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) + => Budget + -> m () +insertBudget + b@Budget + { bgtLabel + , bgtIncomes + , bgtTransfers + , bgtShadowTransfers + , bgtPretax + , bgtTax + , bgtPosttax + } = + whenHash CTBudget b () $ \key -> do + intAllos <- combineError3 pre_ tax_ post_ (,,) + let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes + let res2 = expandTransfers key bgtLabel bgtTransfers + txs <- combineError (concat <$> res1) res2 (++) + m <- askDBState kmCurrency + shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs + void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow where - intAllos = - let pre_ = sortAllos pretax - tax_ = sortAllos tax - post_ = sortAllos posttax - in concatEithers3 pre_ tax_ post_ (,,) - sortAllos = concatEithersL . fmap sortAllo + pre_ = sortAllos bgtPretax + tax_ = sortAllos bgtTax + post_ = sortAllos bgtPosttax + sortAllos = liftExcept . combineErrors . 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 -> InsertExcept (BoundAllocation v) +sortAllo a@Allocation {alloAmts = as} = do + bs <- foldBounds [] $ 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 + foldBounds acc [] = return acc + foldBounds acc (x : xs) = do + let start = amtWhen x + res <- case xs of + [] -> resolveBounds start + (y : _) -> resolveBounds_ (intStart $ amtWhen y) start + foldBounds (x {amtWhen = expandBounds res} : acc) xs -- TODO this is going to be O(n*m), which might be a problem? -addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType] -addShadowTransfers ms txs = +addShadowTransfers + :: CurrencyMap + -> [ShadowTransfer] + -> [UnbalancedTransfer] + -> InsertExcept [UnbalancedTransfer] +addShadowTransfers cm ms txs = fmap catMaybes $ - concatEitherL $ - fmap (uncurry fromShadow) $ + combineErrors $ + fmap (uncurry (fromShadow cm)) $ [(t, m) | t <- txs, m <- ms] -fromShadow :: BudgetTxType -> ShadowTransfer -> EitherErr (Maybe BudgetTxType) -fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do +fromShadow + :: CurrencyMap + -> UnbalancedTransfer + -> ShadowTransfer + -> InsertExcept (Maybe UnbalancedTransfer) +fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do res <- shadowMatches (stMatch t) tx + v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio 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 $ v * 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 -> InsertExcept Bool +shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do + valRes <- valMatches tmVal $ cvValue $ cbtValue tx return $ - memberMaybe (taAcnt $ btFrom tx_) smFrom - && memberMaybe (taAcnt $ btTo tx_) smTo - && maybe True (`dateMatches` (btWhen tx_)) smDate + memberMaybe (taAcnt $ cbtFrom tx) tmFrom + && memberMaybe (taAcnt $ cbtTo tx) tmTo + && maybe True (`dateMatches` cbtWhen tx) tmDate && valRes where - tx_ = bttTx tx memberMaybe x AcntSet {asList, asInclude} = (if asInclude then id else not) $ x `elem` asList -balanceTransfers :: [BudgetTxType] -> [BudgetTx] -balanceTransfers ts = - snd $ L.mapAccumR go initBals $ reverse $ L.sortOn (btWhen . bttTx) ts +balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] +balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen 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 balTo = M.findWithDefault 0 cbtTo bals + x = amtToMove balTo cvType cvValue + bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals + 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.alter (maybe (Just v) (Just . (+ v))) k 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 + :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => CommitRId -> T.Text -> IntAllocations -> Income - -> SqlPersistT m (EitherErrs [BudgetTxType]) + -> m [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 - 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] + Income + { incWhen + , incCurrency + , incFrom + , incPretax + , incPosttax + , incTaxes + , incToBal + , incGross + , incPayPeriod + } = do + -- TODO check that the other accounts are not income somewhere here + _ <- checkAcntType IncomeT $ taAcnt incFrom + precision <- lookupCurrencyPrec incCurrency + let gross = roundPrecision precision incGross + -- 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 :( + res <- foldDates incWhen start (allocate precision gross) + return $ concat res + where + start = fromGregorian' $ pStart incPayPeriod + pType' = pType incPayPeriod + meta = BudgetMeta key name + 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 precision gross prevDay day = do + scaler <- liftExcept $ periodScaler pType' prevDay day + let (preDeductions, pre) = + allocatePre precision gross $ + flatPre ++ concatMap (selectAllos day) intPre + tax = + allocateTax precision gross preDeductions scaler $ + flatTax ++ concatMap (selectAllos day) intTax + aftertaxGross = sumAllos $ tax ++ pre + post = + allocatePost precision 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 throwError $ InsertException [IncomeError day name balance] + else return (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} +type PeriodScaler = Natural -> Double -> Double + +-- TODO we probably don't need to check for 1/0 each time +periodScaler + :: PeriodType + -> Day + -> Day + -> InsertExcept PeriodScaler +periodScaler pt prev cur = do + n <- workingDays wds prev cur + return $ scale (fromIntegral n) 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 + wds = case pt of + Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays + Daily ds -> ds + scale n precision x = case pt of + Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} -> + fromRational (rnd $ x / fromIntegral hpAnnualHours) + * fromIntegral hpDailyHours + * n + Daily _ -> x * n / 365.25 + where + rnd = roundPrecision precision -fromAllo - :: MonadFinance m - => Day - -> BudgetMeta +workingDays :: [Weekday] -> Day -> Day -> InsertExcept Natural +workingDays wds start end + | interval > 0 = + let (nFull, nPart) = divMod interval 7 + daysFull = fromIntegral (length wds') * nFull + daysTail = fromIntegral $ length $ takeWhile (< nPart) wds' + in return $ fromIntegral $ daysFull + daysTail + | otherwise = throwError $ InsertException undefined + where + interval = diffDays end start + startDay = dayOfWeek start + wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds + diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7 + +allocatePre + :: Natural + -> Rational + -> [FlatAllocation PretaxValue] + -> (M.Map T.Text Rational, [FlatAllocation Rational]) +allocatePre precision gross = L.mapAccumR go M.empty + where + go m f@FlatAllocation {faValue} = + let c = preCategory faValue + p = preValue faValue + v = + if prePercent faValue + then (roundPrecision 3 p / 100) * gross + else roundPrecision precision p + in (mapAdd_ c v m, f {faValue = v}) + +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 + :: Natural + -> Rational + -> M.Map T.Text Rational + -> PeriodScaler + -> [FlatAllocation TaxValue] + -> [FlatAllocation Rational] +allocateTax precision gross preDeds f = fmap (fmap go) where - toBT (Amount desc 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` preDeds) tvCategories) + in case tvMethod of + TMPercent p -> + roundPrecision precision $ + fromRational $ + roundPrecision 3 p / 100 * agi + TMBracket TaxProgression {tpDeductible, tpBrackets} -> + let taxDed = roundPrecision precision $ f precision tpDeductible + in foldBracket f precision (agi - taxDed) tpBrackets + +allocatePost + :: Natural + -> Rational + -> [FlatAllocation PosttaxValue] + -> [FlatAllocation Rational] +allocatePost precision aftertax = fmap (fmap go) + where + go PosttaxValue {postValue, postPercent} = + let v = postValue + in if postPercent + then aftertax * roundPrecision 3 v / 100 + else roundPrecision precision v + +-- | Compute effective tax percentage of a bracket +-- The algorithm can be thought of in three phases: +-- 1. Find the highest tax bracket by looping backward until the AGI is less +-- than the bracket limit +-- 2. Computing the tax in the top bracket by subtracting the AGI from the +-- bracket limit and multiplying by the tax percentage. +-- 3. Adding all lower brackets, which are just the limit of the bracket less +-- the amount of the lower bracket times the percentage. +-- +-- In reality, this can all be done with one loop, but it isn't clear these +-- three steps are implemented from this alone. +foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational +foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs + where + go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) = + let l = roundPrecision precision $ f precision tbLowerLimit + p = roundPrecision 3 tbPercent / 100 + in if remain >= l then (acc + p * (remain - l), l) else a + +data FlatAllocation v = FlatAllocation + { faValue :: !v + , faDesc :: !T.Text + , faTo :: !TaggedAcnt + , faCur :: !BudgetCurrency + } + deriving (Functor, Show) + +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} = + go <$> filter ((`inBounds` day) . amtWhen) alloAmts + where + go Amount {amtValue, amtDesc} = + FlatAllocation + { faCur = NoX alloCur + , faTo = alloTo + , faValue = amtValue + , faDesc = amtDesc + } expandTransfers - :: MonadFinance m + :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => CommitRId -> T.Text - -> [Transfer] - -> SqlPersistT m (EitherErrs [BudgetTxType]) -expandTransfers key name ts = do - txs <- mapM (expandTransfer key name) ts - return $ L.sortOn (btWhen . bttTx) . concat <$> concatEithersL txs + -> [BudgetTransfer] + -> m [UnbalancedTransfer] +expandTransfers key name ts = + fmap (L.sortOn cbtWhen . concat) $ + combineErrors $ + fmap (expandTransfer key name) ts -expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersistT m (EitherErrs [BudgetTxType]) -expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = - -- whenHash CTExpense t (Right []) $ \key -> - fmap (fmap concat . concatEithersL) $ - forM transAmounts $ \(TimeAmount pat (Amount desc v) 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 - } - , bttType = atype - } - in return $ Right tx +initialCurrency :: BudgetCurrency -> CurID +initialCurrency (NoX c) = c +initialCurrency (X Exchange {xFromCur = c}) = c -insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError] -insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do - res <- lift $ splitPair btFrom btTo (bmCur btMeta) btValue - unlessLefts_ res $ \((sFrom, sTo), exchange) -> do - insertPair sFrom sTo - forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo +expandTransfer + :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) + => CommitRId + -> T.Text + -> BudgetTransfer + -> m [UnbalancedTransfer] +expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do + precision <- lookupCurrencyPrec $ initialCurrency transCurrency + fmap concat $ combineErrors $ fmap (go precision) transAmounts + where + go + precision + Amount + { amtWhen = pat + , amtValue = BudgetTransferValue {btVal = v, btType = y} + , amtDesc = desc + } = + withDates pat $ \day -> do + let meta = BudgetMeta {bmCommit = key, bmName = name} + return + FlatTransfer + { cbtMeta = meta + , cbtWhen = day + , cbtCur = transCurrency + , cbtFrom = transFrom + , cbtTo = transTo + , cbtValue = UnbalancedValue y $ roundPrecision precision v + , cbtDesc = desc + } + +insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m () +insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do + ((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue + insertPair sFrom sTo + 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) splitPair - :: MonadFinance m + :: (MonadInsertError m, MonadFinance m) => TaggedAcnt -> TaggedAcnt -> BudgetCurrency -> Rational - -> m (EitherErrs (SplitPair, Maybe SplitPair)) + -> m (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 -> (,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) - return $ concatEithers2 res1 res2 $ \a b -> (a, Just b) + let res1 = pair xFromCur from middle val + let res2 = pair xToCur middle to (val * roundPrecision 3 xRate) + combineError res1 res2 $ \a b -> (a, Just b) where pair curid from_ to_ v = do - s1 <- split curid from_ (-v) - s2 <- split curid to_ v - return $ concatEithers2 s1 s2 (,) + let s1 = split curid from_ (-v) + let s2 = split curid to_ v + combineError s1 s2 (,) split c TaggedAcnt {taAcnt, taTags} v = resolveSplit $ - Split - { sAcnt = taAcnt - , sValue = v - , sComment = "" - , sCurrency = c - , sTags = taTags + Entry + { eAcnt = taAcnt + , eValue = v + , eComment = "" + , eCurrency = c + , eTags = taTags } checkAcntType - :: MonadFinance m + :: (MonadInsertError m, MonadFinance m) => AcntType -> AcntID - -> m (EitherErr AcntID) + -> m AcntID checkAcntType t = checkAcntTypes (t :| []) checkAcntTypes - :: MonadFinance m + :: (MonadInsertError m, MonadFinance m) => NE.NonEmpty AcntType -> AcntID - -> m (EitherErr AcntID) -checkAcntTypes ts i = (go =<<) <$> lookupAccountType i + -> m AcntID +checkAcntTypes ts i = go =<< lookupAccountType i where go t - | t `L.elem` ts = Right i - | otherwise = Left $ AccountError i ts + | t `L.elem` ts = return i + | otherwise = throwError $ InsertException [AccountError i ts] -------------------------------------------------------------------------------- -- statements -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 - -insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError] -insertManual - m@Manual - { manualDate = dp - , manualFrom = from - , manualTo = to - , manualValue = v - , manualCurrency = u - , manualDesc = e - } = 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 - -insertImport :: MonadFinance m => Import -> 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 - recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do - bounds <- expandBounds <$> lift (askDBState kmStatementInterval) - res <- mapM (lift . resolveTx) $ filter (inBounds bounds . txDate) bs - unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c) +splitHistory :: [History] -> ([HistTransfer], [Statement]) +splitHistory = partitionEithers . fmap go where - recoverIO x rest = do - res <- tryIO x - case res of - Right r -> rest r - -- If file is not found (or something else happens) then collect the - -- error try the remaining imports - Left e -> return [InsertIOError $ showT e] + go (HistTransfer x) = Left x + go (HistStatement x) = Right x + +-- insertStatement +-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) +-- => History +-- -> m () +-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m +-- insertStatement (HistStatement i) = insertImport i + +insertHistTransfer + :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) + => HistTransfer + -> m () +insertHistTransfer + m@Transfer + { transFrom = from + , transTo = to + , transCurrency = u + , transAmounts = amts + } = do + whenHash CTManual m () $ \c -> do + bounds <- askDBState kmStatementInterval + let precRes = lookupCurrencyPrec u + let go Amount {amtWhen, amtValue, amtDesc} = do + let dayRes = liftExcept $ expandDatePat bounds amtWhen + (days, precision) <- combineError dayRes precRes (,) + let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc + keys <- combineErrors $ fmap tx days + mapM_ (insertTx c) keys + void $ combineErrors $ fmap go amts + +readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx])) +readHistStmt i = whenHash_ CTImport i $ do + bs <- readImport i + bounds <- expandBounds <$> askDBState kmStatementInterval + liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs + +insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m () +insertHistStmt c ks = do + ck <- insert c + mapM_ (insertTx ck) ks + +-- insertImport +-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) +-- => Statement +-- -> m () +-- 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 +-- bs <- readImport i +-- bounds <- expandBounds <$> askDBState kmStatementInterval +-- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs +-- mapM_ (insertTx c) keys -------------------------------------------------------------------------------- -- low-level transaction stuff -- TODO tags here? txPair - :: MonadFinance m + :: (MonadInsertError m, MonadFinance m) => Day -> AcntID -> AcntID -> CurID -> Rational -> T.Text - -> m (EitherErrs KeyTx) + -> m 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 + { eAcnt = a + , eValue = v + , eComment = "" + , eCurrency = cur + , eTags = [] + } tx = Tx { txDescr = desc @@ -557,67 +696,94 @@ txPair day from to cur val desc = resolveTx tx , txSplits = [split from (-val), split to val] } -resolveTx :: MonadFinance m => BalTx -> m (EitherErrs KeyTx) -resolveTx t@Tx {txSplits = ss} = do - res <- concatEithersL <$> mapM resolveSplit ss - return $ fmap (\kss -> t {txSplits = kss}) res +resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx +resolveTx t@Tx {txSplits = ss} = + fmap (\kss -> t {txSplits = kss}) $ + combineErrors $ + fmap resolveSplit ss -resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit) -resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do - aid <- lookupAccountKey sAcnt - cid <- lookupCurrency sCurrency - sign <- lookupAccountSign sAcnt - tags <- mapM lookupTag sTags +resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit +resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do + let aRes = lookupAccountKey eAcnt + let cRes = lookupCurrencyKey eCurrency + let sRes = lookupAccountSign eAcnt + let tagRes = combineErrors $ fmap lookupTag eTags -- TODO correct sign here? -- TODO lenses would be nice here - return $ - (concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $ - \(aid_, cid_, sign_) tags_ -> - s - { sAcnt = aid_ - , sCurrency = cid_ - , sValue = sValue * fromIntegral (sign2Int sign_) - , sTags = tags_ - } + combineError (combineError3 aRes cRes sRes (,,)) tagRes $ + \(aid, cid, sign) tags -> + s + { eAcnt = aid + , eCurrency = cid + , eValue = eValue * fromIntegral (sign2Int sign) + , eTags = tags + } -insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m () +insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m () insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do k <- insert $ TransactionR c d e mapM_ (insertSplit k) ss -insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR) -insertSplit t Split {sAcnt, sCurrency, sValue, sComment, sTags} = do - k <- insert $ SplitR t sCurrency sAcnt sComment sValue - mapM_ (insert_ . TagRelationR k) sTags +insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId +insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do + k <- insert $ SplitR t eCurrency eAcnt eComment eValue + mapM_ (insert_ . TagRelationR k) eTags return k -lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType)) -lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount) +lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType) +lookupAccount = lookupFinance AcntField kmAccount -lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR)) -lookupAccountKey = (fmap (fmap fstOf3)) . lookupAccount +lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId +lookupAccountKey = fmap fstOf3 . lookupAccount -lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign) -lookupAccountSign = fmap (fmap sndOf3) . lookupAccount +lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign +lookupAccountSign = fmap sndOf3 . lookupAccount -lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType) -lookupAccountType = fmap (fmap thdOf3) . lookupAccount +lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType +lookupAccountType = fmap thdOf3 . lookupAccount -lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR)) -lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency) +lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural) +lookupCurrency = lookupFinance CurField kmCurrency -lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR)) -lookupTag c = lookupErr (DBKey TagField) c <$> (askDBState kmTag) +lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId +lookupCurrencyKey = fmap fst . lookupCurrency + +lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural +lookupCurrencyPrec = fmap snd . lookupCurrency + +lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId +lookupTag = lookupFinance TagField kmTag + +lookupFinance + :: (MonadInsertError m, MonadFinance m) + => SplitIDType + -> (DBState -> M.Map T.Text a) + -> T.Text + -> m a +lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f -- TODO this hashes twice (not that it really matters) + whenHash - :: (Hashable a, MonadFinance m) + :: (Hashable a, MonadFinance m, MonadSqlQuery m) => ConfigType -> a -> b - -> (Key CommitR -> SqlPersistT m b) - -> SqlPersistT m b + -> (CommitRId -> m b) + -> m b whenHash t o def f = do let h = hash o - hs <- lift $ askDBState kmNewCommits + hs <- askDBState kmNewCommits if h `elem` hs then f =<< insert (CommitR h t) else return def + +whenHash_ + :: (Hashable a, MonadFinance m) + => ConfigType + -> a + -> m b + -> m (Maybe (CommitR, b)) +whenHash_ t o f = do + let h = hash o + let c = CommitR h t + hs <- askDBState kmNewCommits + if h `elem` hs then Just . (c,) <$> f else return Nothing diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index dffc499..e7a325e 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -5,6 +5,8 @@ module Internal.Statement ) where +import Control.Monad.Error.Class +import Control.Monad.Except import Data.Csv import Internal.Types import Internal.Utils @@ -18,32 +20,33 @@ import RIO.Time import qualified RIO.Vector as V -- TODO this probably won't scale well (pipes?) - -readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx]) -readImport Import {..} = do - let ores = plural $ compileOptions impTxOpts - let cres = concatEithersL $ compileMatch <$> impMatches - case concatEithers2 ores cres (,) of - Right (compiledOptions, compiledMatches) -> do - ires <- mapM (readImport_ impSkipLines impDelim compiledOptions) impPaths - case concatEitherL ires of - Right records -> return $ matchRecords compiledMatches $ L.sort $ concat records - Left es -> return $ Left es - Left es -> return $ Left es +readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx] +readImport Statement {..} = do + let ores = compileOptions stmtTxOpts + let cres = combineErrors $ compileMatch <$> stmtParsers + (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,) + let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions + records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths + m <- askDBState kmCurrency + fromEither $ + flip runReader m $ + runExceptT $ + matchRecords compiledMatches records readImport_ - :: MonadFinance m + :: (MonadUnliftIO m, MonadFinance m) => Natural -> Word -> TxOptsRe -> FilePath - -> m (EitherErr [TxRecord]) + -> m [TxRecord] readImport_ n delim tns p = do dir <- askDBState kmConfigDir - bs <- liftIO $ BL.readFile $ dir p + res <- tryIO $ BL.readFile $ dir p + bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of - Left m -> return $ Left $ ParseError $ T.pack m - Right (_, v) -> return $ Right $ catMaybes $ V.toList v + Left m -> throwIO $ InsertException [ParseError $ T.pack m] + Right (_, v) -> return $ catMaybes $ V.toList v where opts = defaultDecodeOptions {decDelimiter = fromIntegral delim} skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10 @@ -62,27 +65,25 @@ parseTxRecord p TxOpts {..} r = do d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d return $ Just $ TxRecord d' a e os p -matchRecords :: [MatchRe] -> [TxRecord] -> EitherErrs [BalTx] +matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx] matchRecords ms rs = do (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs case (matched, unmatched, notfound) of - (ms_, [], []) -> do - -- TODO record number of times each match hits for debugging - matched_ <- first (: []) $ mapM balanceTx ms_ - Right matched_ - (_, us, ns) -> Left [StatementError us ns] + -- TODO record number of times each match hits for debugging + (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_ + (_, us, ns) -> throwError $ InsertException [StatementError us ns] matchPriorities :: [MatchRe] -> [MatchGroup] matchPriorities = fmap matchToGroup - . L.groupBy (\a b -> mPriority a == mPriority b) - . L.sortOn (Down . mPriority) + . L.groupBy (\a b -> spPriority a == spPriority b) + . L.sortOn (Down . spPriority) matchToGroup :: [MatchRe] -> MatchGroup matchToGroup ms = uncurry MatchGroup $ - first (L.sortOn mDate) $ - L.partition (isJust . mDate) ms + first (L.sortOn spDate) $ + L.partition (isJust . spDate) ms -- TDOO could use a better struct to flatten the maybe date subtype data MatchGroup = MatchGroup @@ -124,10 +125,13 @@ zipperSlice f x = go EQ -> goEq $ Unzipped bs (a : cs) as LT -> z -zipperMatch :: Unzipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx) +zipperMatch + :: Unzipped MatchRe + -> TxRecord + -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx) zipperMatch (Unzipped bs cs as) x = go [] cs where - go _ [] = Right (Zipped bs $ cs ++ as, MatchFail) + go _ [] = return (Zipped bs $ cs ++ as, MatchFail) go prev (m : ms) = do res <- matches m x case res of @@ -135,25 +139,30 @@ zipperMatch (Unzipped bs cs as) x = go [] cs skipOrPass -> let ps = reverse prev ms' = maybe ms (: ms) (matchDec m) - in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass) + in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass) -zipperMatch' :: Zipped MatchRe -> TxRecord -> EitherErrs (Zipped MatchRe, MatchRes RawTx) +-- TODO all this unpacking left/error crap is annoying +zipperMatch' + :: Zipped MatchRe + -> TxRecord + -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx) zipperMatch' z x = go z where go (Zipped bs (a : as)) = do res <- matches a x case res of MatchFail -> go (Zipped (a : bs) as) - skipOrPass -> Right (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass) - go z' = Right (z', MatchFail) + skipOrPass -> + return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass) + go z' = return (z', MatchFail) matchDec :: MatchRe -> Maybe MatchRe -matchDec m = case mTimes m of +matchDec m = case spTimes m of Just 1 -> Nothing - Just n -> Just $ m {mTimes = Just $ n - 1} + Just n -> Just $ m {spTimes = Just $ n - 1} Nothing -> Just m -matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe]) +matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe]) matchAll = go ([], []) where go (matched, unused) gs rs = case (gs, rs) of @@ -163,17 +172,17 @@ matchAll = go ([], []) (ts, unmatched, us) <- matchGroup g rs go (ts ++ matched, us ++ unused) gs' unmatched -matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe]) +matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe]) matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do (md, rest, ud) <- matchDates ds rs (mn, unmatched, un) <- matchNonDates ns rest - return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un) + return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un) -matchDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe]) +matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe]) matchDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = - Right + return ( catMaybes matched , reverse unmatched , recoverZipper z @@ -184,17 +193,17 @@ matchDates ms = go ([], [], initZipper ms) Right unzipped -> do (z', res) <- zipperMatch unzipped r let (m, u) = case res of - MatchPass p -> (Just p : matched, unmatched) + (MatchPass p) -> (Just p : matched, unmatched) MatchSkip -> (Nothing : matched, unmatched) MatchFail -> (matched, r : unmatched) go (m, u, z') rs - findDate m r = maybe EQ (`compareDate` trDate r) $ mDate m + findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m -matchNonDates :: [MatchRe] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [MatchRe]) +matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe]) matchNonDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = - Right + return ( catMaybes matched , reverse unmatched , recoverZipper z @@ -207,26 +216,26 @@ matchNonDates ms = go ([], [], initZipper ms) MatchFail -> (matched, r : unmatched) in go (m, u, resetZipper z') rs -balanceTx :: RawTx -> EitherErr BalTx +balanceTx :: RawTx -> InsertExcept BalTx balanceTx t@Tx {txSplits = ss} = do bs <- balanceSplits ss return $ t {txSplits = bs} -balanceSplits :: [RawSplit] -> EitherErr [BalSplit] +balanceSplits :: [RawSplit] -> InsertExcept [BalSplit] balanceSplits ss = fmap concat <$> mapM (uncurry bal) $ groupByKey - $ fmap (\s -> (sCurrency s, s)) ss + $ fmap (\s -> (eCurrency s, s)) ss where - hasValue s@(Split {sValue = Just v}) = Right s {sValue = v} - hasValue s = Left s + haeValue s@Entry {eValue = Just v} = Right s {eValue = v} + haeValue s = Left s bal cur rss - | length rss < 2 = Left $ BalanceError TooFewSplits cur rss - | otherwise = case partitionEithers $ fmap hasValue rss of - ([noVal], val) -> Right $ noVal {sValue = foldr (\s x -> x - sValue s) 0 val} : val - ([], val) -> Right val - _ -> Left $ BalanceError NotOneBlank cur rss + | length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss] + | otherwise = case partitionEithers $ fmap haeValue rss of + ([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val + ([], val) -> return val + _ -> throwError $ InsertException [BalanceError NotOneBlank cur rss] groupByKey :: Ord k => [(k, v)] -> [(k, [v])] groupByKey = M.toList . M.fromListWith (++) . fmap (second (: [])) diff --git a/lib/Internal/TH.hs b/lib/Internal/TH.hs new file mode 100644 index 0000000..51c0ce1 --- /dev/null +++ b/lib/Internal/TH.hs @@ -0,0 +1,12 @@ +module Internal.TH where + +import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName) +import RIO + +deriveProduct :: [String] -> [String] -> Q [Dec] +deriveProduct cs ss = + return $ + [ StandaloneDerivD Nothing [] (AppT x y) + | x <- ConT . mkName <$> cs + , y <- ConT . mkName <$> ss + ] diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 3730fe0..6b7fc77 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} module Internal.Types where +import Control.Monad.Except import Data.Fix (Fix (..), foldFix) import Data.Functor.Foldable (embed) import qualified Data.Functor.Foldable.TH as TH @@ -12,6 +14,7 @@ import Database.Persist.Sql hiding (Desc, In, Statement) import Database.Persist.TH import Dhall hiding (embed, maybe) import Dhall.TH +import Internal.TH (deriveProduct) import Language.Haskell.TH.Syntax (Lift) import RIO import qualified RIO.Map as M @@ -25,109 +28,131 @@ import Text.Regex.TDFA ------------------------------------------------------------------------------- makeHaskellTypesWith - (defaultGenerateOptions {generateToDhallInstance = False}) + (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False}) [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" , 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" + , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType" , 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 "Income" "Income" "(./dhall/Types.dhall).Income" - -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget" - -- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer" - SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange" - , 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 "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 "Period" "Period" "(./dhall/Types.dhall).Period" + , SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod" + -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx" + -- , SingleConstructor "FieldMatcher" "FieldMatcher" "(./dhall/Types.dhall).FieldMatcher_" + -- , SingleConstructor "Match" "Match" "(./dhall/Types.dhall).Match_" + -- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget" + -- SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer" + ] + +deriveProduct + ["Eq", "Show", "Generic", "FromDhall"] + [ "Currency" + , "Tag" + , "TimeUnit" + , "Weekday" + , "WeekdayPat" + , "RepeatPat" + , "MDYPat" + , "Gregorian" + , "GregorianM" + , "Interval" + , "ModPat" + , "CronPat" + , "DatePat" + , "TaggedAcnt" + , "Budget" + , "Income" + , "ShadowTransfer" + , "TransferMatcher" + , "AcntSet" + , "DateMatcher" + , "ValMatcher" + , "YMDMatcher" + , "BudgetCurrency" + , "Exchange" + , "EntryNumGetter" + , "TemporalScope" + , "SqlConfig" + , "PretaxValue" + , "TaxValue" + , "TaxBracket" + , "TaxProgression" + , "TaxMethod" + , "PosttaxValue" + , "BudgetTransferValue" + , "BudgetTransferType" + , "Period" + , "PeriodType" + , "HourlyPeriod" ] ------------------------------------------------------------------------------- -- lots of instances for dhall types -deriving instance Eq Currency - deriving instance Lift Currency deriving instance Hashable Currency -deriving instance Eq Tag - deriving instance Lift Tag deriving instance Hashable Tag -deriving instance Eq TimeUnit - deriving instance Ord TimeUnit -deriving instance Show TimeUnit - deriving instance Hashable TimeUnit -deriving instance Eq Weekday - deriving instance Ord Weekday -deriving instance Show Weekday - deriving instance Hashable Weekday deriving instance Enum Weekday -deriving instance Eq WeekdayPat - deriving instance Ord WeekdayPat -deriving instance Show WeekdayPat - deriving instance Hashable WeekdayPat -deriving instance Show RepeatPat - -deriving instance Eq RepeatPat - deriving instance Ord RepeatPat deriving instance Hashable RepeatPat -deriving instance Show MDYPat - -deriving instance Eq MDYPat - deriving instance Ord MDYPat deriving instance Hashable MDYPat -deriving instance Eq Gregorian - -deriving instance Show Gregorian - deriving instance Hashable Gregorian -deriving instance Eq GregorianM - -deriving instance Show GregorianM - deriving instance Hashable GregorianM -- Dhall.TH rearranges my fields :( @@ -144,57 +169,56 @@ instance Ord GregorianM where GregorianM {gmYear = y, gmMonth = m} GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m' -deriving instance Eq Interval - -deriving instance Ord Interval - deriving instance Hashable Interval -deriving instance Eq ModPat - deriving instance Ord ModPat -deriving instance Show ModPat - deriving instance Hashable ModPat -deriving instance Eq CronPat - deriving instance Ord CronPat -deriving instance Show CronPat - deriving instance Hashable CronPat -deriving instance Eq DatePat - deriving instance Ord DatePat -deriving instance Show DatePat - deriving instance Hashable DatePat +type BudgetTransfer = + Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue + +deriving instance Hashable BudgetTransfer + +deriving instance Generic BudgetTransfer + +deriving instance FromDhall BudgetTransfer + data Budget = Budget - { budgetLabel :: Text - , incomes :: [Income] - , pretax :: [IntervalAllocation] - , tax :: [IntervalAllocation] - , posttax :: [IntervalAllocation] - , transfers :: [Transfer] - , shadowTransfers :: [ShadowTransfer] + { bgtLabel :: Text + , bgtIncomes :: [Income] + , bgtPretax :: [MultiAllocation PretaxValue] + , bgtTax :: [MultiAllocation TaxValue] + , bgtPosttax :: [MultiAllocation PosttaxValue] + , bgtTransfers :: [BudgetTransfer] + , bgtShadowTransfers :: [ShadowTransfer] } -deriving instance Eq Budget +deriving instance Hashable PretaxValue -deriving instance Generic Budget +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 FromDhall Budget +deriving instance Hashable BudgetTransferValue -deriving instance Show TaggedAcnt - -deriving instance Eq TaggedAcnt +deriving instance Hashable BudgetTransferType deriving instance Hashable TaggedAcnt @@ -203,70 +227,61 @@ deriving instance Ord TaggedAcnt type CurID = T.Text data Income = Income - { incGross :: Decimal + { incGross :: Double , incCurrency :: CurID , incWhen :: DatePat - , incPretax :: [Allocation] - , incTaxes :: [Allocation] - , incPosttax :: [Allocation] + , incPretax :: [SingleAllocation PretaxValue] + , incTaxes :: [SingleAllocation TaxValue] + , incPosttax :: [SingleAllocation PosttaxValue] , incFrom :: TaggedAcnt , incToBal :: TaggedAcnt + , incPayPeriod :: !Period } -deriving instance Eq Income +deriving instance Hashable HourlyPeriod -deriving instance Generic Income +deriving instance Hashable PeriodType + +deriving instance Hashable Period deriving instance Hashable Income -deriving instance FromDhall Income +deriving instance (Ord w, Ord v) => Ord (Amount w v) -deriving instance Show Amount +deriving instance Generic (Amount w v) -deriving instance Eq Amount +deriving instance (FromDhall v, FromDhall w) => FromDhall (Amount w v) -deriving instance Ord Amount +deriving instance (Hashable v, Hashable w) => Hashable (Amount w v) -deriving instance Hashable Amount +-- deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Amount w v) -deriving instance Show Exchange +deriving instance (Show w, Show v) => Show (Amount w v) -deriving instance Eq Exchange +deriving instance (Eq w, Eq v) => Eq (Amount w v) deriving instance Hashable Exchange -deriving instance Show BudgetCurrency - -deriving instance Eq BudgetCurrency - 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 (Show) + deriving (Eq, Show, Generic, Hashable) -type Allocation = Allocation_ Amount +instance Bifunctor Amount where + bimap f g a@Amount {amtWhen, amtValue} = a {amtWhen = f amtWhen, amtValue = g amtValue} -deriving instance Eq Allocation +instance Bifunctor Allocation where + bimap f g a@Allocation {alloAmts} = a {alloAmts = fmap (bimap f g) alloAmts} -deriving instance Generic Allocation +deriving instance (Generic w, Generic v, FromDhall w, FromDhall v) => FromDhall (Allocation w v) -deriving instance Hashable Allocation +type MultiAllocation = Allocation Interval -deriving instance FromDhall Allocation - -type IntervalAllocation = Allocation_ IntervalAmount - -deriving instance Eq IntervalAllocation - -deriving instance Generic IntervalAllocation - -deriving instance Hashable IntervalAllocation - -deriving instance FromDhall IntervalAllocation +type SingleAllocation = Allocation () toPersistText :: Show a => a -> PersistValue toPersistText = PersistText . T.pack . show @@ -278,98 +293,35 @@ 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 Show AmountType +-- this is necessary since dhall will reverse the order when importing +instance Ord Interval where + compare + Interval {intStart = s0, intEnd = e0} + Interval {intStart = s1, intEnd = e1} = + compare (s0, e0) (s1, e1) -deriving instance Eq AmountType - -deriving instance Ord AmountType - -deriving instance Hashable AmountType - -data TimeAmount a = TimeAmount - { taWhen :: a - , taAmt :: Amount - , taAmtType :: AmountType +data Transfer a c w v = Transfer + { transFrom :: a + , transTo :: a + , transAmounts :: [Amount w v] + , transCurrency :: c } - deriving (Show, Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable) - -type DateAmount = TimeAmount DatePat - --- deriving instance Eq DateAmount - --- deriving instance Generic DateAmount - --- deriving instance Hashable DateAmount - --- deriving instance FromDhall DateAmount - -type IntervalAmount = TimeAmount Interval - --- deriving instance Eq IntervalAmount - --- deriving instance Ord IntervalAmount - --- deriving instance Generic IntervalAmount - --- deriving instance Hashable IntervalAmount - --- deriving instance FromDhall IntervalAmount - -data Transfer = Transfer - { transFrom :: TaggedAcnt - , transTo :: TaggedAcnt - , transAmounts :: [DateAmount] - , transCurrency :: BudgetCurrency - } - -deriving instance Eq Transfer - -deriving instance Generic Transfer - -deriving instance Hashable Transfer - -deriving instance FromDhall Transfer - -deriving instance Eq ShadowTransfer + deriving (Eq, Show) deriving instance Hashable ShadowTransfer -deriving instance Eq AcntSet - deriving instance Hashable AcntSet -deriving instance Eq ShadowMatch +deriving instance Hashable TransferMatcher -deriving instance Hashable ShadowMatch +deriving instance Hashable ValMatcher -deriving instance Eq MatchVal +deriving instance Hashable YMDMatcher -deriving instance Hashable MatchVal - -deriving instance Show MatchVal - -deriving instance Eq MatchYMD - -deriving instance Hashable MatchYMD - -deriving instance Show MatchYMD - -deriving instance Eq MatchDate - -deriving instance Hashable MatchDate - -deriving instance Show MatchDate - -deriving instance Eq Decimal - -deriving instance Ord Decimal - -deriving instance Hashable Decimal - -deriving instance Show Decimal +deriving instance Hashable DateMatcher -- 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' @@ -384,21 +336,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 Eq SplitNum - -deriving instance Hashable SplitNum - -deriving instance Show SplitNum - -deriving instance Eq Manual - -deriving instance Hashable Manual +deriving instance Hashable EntryNumGetter ------------------------------------------------------------------------------- -- top level type with fixed account tree to unroll the recursion in the dhall @@ -431,10 +375,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 @@ -468,23 +412,30 @@ type AcntID = T.Text type TagID = T.Text -data Statement - = StmtManual !Manual - | StmtImport !Import - deriving (Eq, Hashable, Generic, FromDhall) +type HistTransfer = Transfer AcntID CurID DatePat Double -data Split a v c t = Split - { sAcnt :: !a - , sValue :: !v - , sCurrency :: !c - , sComment :: !T.Text - , sTags :: ![t] - } - deriving (Eq, Generic, Hashable, Show) +deriving instance Generic HistTransfer -type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID +deriving instance Hashable HistTransfer -instance FromDhall ExpSplit +deriving instance FromDhall HistTransfer + +data History + = HistTransfer !HistTransfer + | HistStatement !Statement + deriving (Eq, Generic, Hashable, FromDhall) + +type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID + +instance FromDhall EntryGetter + +deriving instance (Show a, Show c, Show v, Show t) => Show (Entry a v c t) + +deriving instance Generic (Entry 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 (Entry a v c t) data Tx s = Tx { txDescr :: !T.Text @@ -493,7 +444,7 @@ data Tx s = Tx } deriving (Generic) -type ExpTx = Tx ExpSplit +type ExpTx = Tx EntryGetter instance FromDhall ExpTx @@ -507,66 +458,74 @@ data TxOpts re = TxOpts } deriving (Eq, Generic, Hashable, Show, FromDhall) -data Import = Import - { impPaths :: ![FilePath] - , impMatches :: ![Match T.Text] - , impDelim :: !Word - , impTxOpts :: !(TxOpts T.Text) - , impSkipLines :: !Natural +data Statement = Statement + { stmtPaths :: ![FilePath] + , stmtParsers :: ![StatementParser T.Text] + , stmtDelim :: !Word + , stmtTxOpts :: !(TxOpts T.Text) + , stmtSkipLines :: !Natural } deriving (Eq, Hashable, Generic, FromDhall) -- | the value of a field in split (text version) -- can either be a raw (constant) value, a lookup from the record, or a map -- between the lookup and some other value -data SplitText t +data EntryTextGetter t = ConstT !t | LookupT !T.Text | MapT !(FieldMap T.Text t) | Map2T !(FieldMap (T.Text, T.Text) t) deriving (Eq, Generic, Hashable, Show, FromDhall) -type SplitCur = SplitText CurID +type SplitCur = EntryTextGetter CurID -type SplitAcnt = SplitText AcntID +type SplitAcnt = EntryTextGetter AcntID -data Field k v = Field - { fKey :: !k - , fVal :: !v - } - deriving (Show, Eq, Hashable, Generic, FromDhall, Foldable, Traversable) +deriving instance (Show k, Show v) => Show (Field k v) + +deriving instance (Eq k, Eq v) => Eq (Field k v) + +deriving instance Generic (Field k v) + +deriving instance (Hashable k, Hashable v) => Hashable (Field k v) + +deriving instance Foldable (Field k) + +deriving instance Traversable (Field k) + +deriving instance (FromDhall k, FromDhall v) => FromDhall (Field k v) instance Functor (Field f) where fmap f (Field k v) = Field k $ f v type FieldMap k v = Field k (M.Map k v) -data MatchOther re +data FieldMatcher 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) +deriving instance Show (FieldMatcher T.Text) -data ToTx = ToTx - { ttCurrency :: !SplitCur - , ttPath :: !SplitAcnt - , ttSplit :: ![ExpSplit] +data TxGetter = TxGetter + { tgCurrency :: !SplitCur + , tgAcnt :: !SplitAcnt + , tgEntries :: ![EntryGetter] } deriving (Eq, Generic, Hashable, Show, FromDhall) -data Match re = Match - { mDate :: !(Maybe MatchDate) - , mVal :: !MatchVal - , mDesc :: !(Maybe re) - , mOther :: ![MatchOther re] - , mTx :: !(Maybe ToTx) - , mTimes :: !(Maybe Natural) - , mPriority :: !Integer +data StatementParser re = StatementParser + { spDate :: !(Maybe DateMatcher) + , spVal :: !ValMatcher + , spDesc :: !(Maybe re) + , spOther :: ![FieldMatcher re] + , spTx :: !(Maybe TxGetter) + , spTimes :: !(Maybe Natural) + , spPriority :: !Integer } deriving (Eq, Generic, Hashable, FromDhall, Functor) -deriving instance Show (Match T.Text) +deriving instance Show (StatementParser T.Text) -------------------------------------------------------------------------------- -- DATABASE MODEL @@ -582,6 +541,7 @@ CommitR sql=commits CurrencyR sql=currencies symbol T.Text fullname T.Text + precision Int deriving Show Eq TagR sql=tags symbol T.Text @@ -644,7 +604,7 @@ instance PersistField ConfigType where type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType) -type CurrencyMap = M.Map CurID CurrencyRId +type CurrencyMap = M.Map CurID (CurrencyRId, Natural) type TagMap = M.Map TagID TagRId @@ -655,12 +615,17 @@ data DBState = DBState , kmBudgetInterval :: !Bounds , kmStatementInterval :: !Bounds , kmNewCommits :: ![Int] + , kmOldCommits :: ![Int] , kmConfigDir :: !FilePath + , kmTagAll :: ![Entity TagR] + , kmAcntPaths :: ![AccountPathR] + , kmAcntsOld :: ![Entity AccountR] + , kmCurrenciesOld :: ![Entity CurrencyR] } -type MappingT m = ReaderT DBState (SqlPersistT m) +type CurrencyM = Reader CurrencyMap -type KeySplit = Split AccountRId Rational CurrencyRId TagRId +type KeySplit = Entry AccountRId Rational CurrencyRId TagRId type KeyTx = Tx KeySplit @@ -668,13 +633,12 @@ type TreeR = Tree ([T.Text], AccountRId) type Balances = M.Map AccountRId Rational -type BalanceM m = ReaderT (MVar Balances) m +type BalanceM = ReaderT (MVar Balances) -class MonadUnliftIO m => MonadFinance m where - askDBState :: (DBState -> a) -> m a +type MonadFinance = MonadReader DBState -instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where - askDBState = asks +askDBState :: MonadFinance m => (DBState -> a) -> m a +askDBState = asks class MonadUnliftIO m => MonadBalance m where askBalances :: m (MVar Balances) @@ -753,9 +717,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 @@ -797,19 +761,23 @@ 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] + | PeriodError !Day !Day deriving (Show) -newtype InsertException = InsertException [InsertError] deriving (Show) +newtype InsertException = InsertException [InsertError] + deriving (Show, Semigroup) via [InsertError] instance Exception InsertException -type EitherErr = Either InsertError +type MonadInsertError = MonadError InsertException -type EitherErrs = Either [InsertError] +type InsertExceptT = ExceptT InsertException + +type InsertExcept = InsertExceptT Identity data XGregorian = XGregorian { xgYear :: !Int @@ -818,11 +786,11 @@ data XGregorian = XGregorian , xgDayOfWeek :: !Int } -type MatchRe = Match (T.Text, Regex) +type MatchRe = StatementParser (T.Text, Regex) type TxOptsRe = TxOpts (T.Text, Regex) -type MatchOtherRe = MatchOther (T.Text, Regex) +type FieldMatcherRe = FieldMatcher (T.Text, Regex) -instance Show (Match (T.Text, Regex)) where +instance Show (StatementParser (T.Text, Regex)) where show = show . fmap fst diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index b9992fa..76db251 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -1,5 +1,6 @@ module Internal.Utils ( compareDate + , fromWeekday , inBounds , expandBounds , fmtRational @@ -7,16 +8,33 @@ module Internal.Utils , fromGregorian' , resolveBounds , resolveBounds_ - , leftToMaybe - , dec2Rat - , concatEithers2 - , concatEithers3 - , concatEither3 - , concatEither2 - , concatEitherL - , concatEithersL - , concatEither2M - , concatEithers2M + , liftInner + , liftExceptT + , liftExcept + , liftIOExcept + , liftIOExceptT + , combineError + , combineError_ + , combineError3 + , combineErrors + , mapErrors + , combineErrorM + , combineErrorM3 + , combineErrorIO2 + , combineErrorIO3 + , combineErrorIOM2 + , combineErrorIOM3 + , collectErrorsIO + , mapErrorsIO + -- , leftToMaybe + -- , concatEithers2 + -- , concatEithers3 + -- , concatEither3 + -- , concatEither2 + -- , concatEitherL + -- , concatEithersL + -- , concatEither2M + -- , concatEithers2M , parseRational , showError , unlessLeft_ @@ -32,14 +50,19 @@ module Internal.Utils , sndOf3 , thdOf3 , xGregToDay - , plural + -- , plural , compileMatch , compileOptions , dateMatches , valMatches + , roundPrecision + , roundPrecisionCur ) where +import Control.Monad.Error.Class +import Control.Monad.Except +import Control.Monad.Reader import Data.Time.Format.ISO8601 import GHC.Real import Internal.Types @@ -55,6 +78,16 @@ import Text.Regex.TDFA.Text -------------------------------------------------------------------------------- -- dates +-- | Lame weekday converter since day of weeks aren't in dhall (yet) +fromWeekday :: Weekday -> DayOfWeek +fromWeekday Mon = Monday +fromWeekday Tue = Tuesday +fromWeekday Wed = Wednesday +fromWeekday Thu = Thursday +fromWeekday Fri = Friday +fromWeekday Sat = Saturday +fromWeekday Sun = Sunday + -- | find the next date -- this is meant to go in a very tight loop and be very fast (hence no -- complex date functions, most of which heavily use 'mod' and friends) @@ -97,22 +130,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' -> @@ -132,17 +165,17 @@ fromGregorian' = uncurry3 fromGregorian . gregTup inBounds :: (Day, Day) -> Day -> Bool inBounds (d0, d1) x = d0 <= x && x < d1 -resolveBounds :: Interval -> EitherErr Bounds +resolveBounds :: Interval -> InsertExcept Bounds resolveBounds i@Interval {intStart = s} = resolveBounds_ (s {gYear = gYear s + 50}) i -resolveBounds_ :: Gregorian -> Interval -> EitherErr Bounds +resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds resolveBounds_ def Interval {intStart = s, intEnd = e} = case fromGregorian' <$> e of - Nothing -> Right $ toBounds $ fromGregorian' def + Nothing -> return $ toBounds $ fromGregorian' def Just e_ - | s_ < e_ -> Right $ toBounds e_ - | otherwise -> Left $ BoundsError s e + | s_ < e_ -> return $ toBounds e_ + | otherwise -> throwError $ InsertException [BoundsError s e] where s_ = fromGregorian' s toBounds end = (s_, fromIntegral $ diffDays end s_ - 1) @@ -153,103 +186,193 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d) -------------------------------------------------------------------------------- -- matching -matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx) +matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes RawTx) matches - Match {mTx, mOther, mVal, mDate, mDesc} + StatementParser {spTx, spOther, spVal, spDate, spDesc} r@TxRecord {trDate, trAmount, trDesc, trOther} = do - res <- concatEither3 val other desc $ \x y z -> x && y && z - if date && res - then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx - else Right MatchFail + res <- liftInner $ + combineError3 val other desc $ + \x y z -> x && y && z && date + if res + then maybe (return MatchSkip) convert spTx + else return MatchFail where - val = valMatches mVal trAmount - date = maybe True (`dateMatches` trDate) mDate - other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther - desc = maybe (return True) (matchMaybe trDesc . snd) mDesc - convert (ToTx cur a ss) = toTx cur a ss r + val = valMatches spVal trAmount + date = maybe True (`dateMatches` trDate) spDate + other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True spOther + desc = maybe (return True) (matchMaybe trDesc . snd) spDesc + convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r -toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx -toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = - concatEithers2 acRes ssRes $ \(a_, c_) ss_ -> +toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx +toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do + combineError3 acntRes curRes ssRes $ \a c ss -> let fromSplit = - Split - { sAcnt = a_ - , sCurrency = c_ - , sValue = Just trAmount - , sComment = "" - , sTags = [] -- TODO what goes here? + Entry + { eAcnt = a + , eCurrency = c + , eValue = Just trAmount + , eComment = "" + , eTags = [] -- TODO what goes here? } in Tx { txDate = trDate , txDescr = trDesc - , txSplits = fromSplit : ss_ + , txSplits = fromSplit : ss } where - acRes = concatEithers2 (resolveAcnt r sa) (resolveCurrency r sc) (,) - ssRes = concatEithersL $ fmap (resolveSplit r) toSplits + acntRes = liftInner $ resolveAcnt r sa + curRes = liftInner $ resolveCurrency r sc + ssRes = combineErrors $ fmap (resolveEntry r) toSplits -valMatches :: MatchVal -> Rational -> EitherErr Bool -valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x - | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p +valMatches :: ValMatcher -> Rational -> InsertExcept Bool +valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x + | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p] | otherwise = - Right $ - checkMaybe (s ==) mvSign - && checkMaybe (n ==) mvNum - && checkMaybe ((d * fromIntegral p ==) . fromIntegral) mvDen + return $ + checkMaybe (s ==) vmSign + && checkMaybe (n ==) vmNum + && checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen where (n, d) = properFraction $ abs x - p = 10 ^ mvPrec + p = 10 ^ vmPrec 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 +otherMatches :: M.Map T.Text T.Text -> FieldMatcherRe -> InsertExcept Bool otherMatches dict m = case m of Val (Field n mv) -> valMatches mv =<< (readRational =<< lookup_ MatchNumeric n) Desc (Field n (_, md)) -> (`matchMaybe` md) =<< lookup_ MatchText n where lookup_ t n = lookupErr (MatchField t) n dict -resolveSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit -resolveSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} = - concatEithers2 acRes valRes $ - \(a_, c_) v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_}) +resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit +resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do + m <- ask + liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do + v' <- mapM (roundPrecisionCur c m) v + return $ s {eAcnt = a, eValue = v', eCurrency = c} where - acRes = concatEithers2 (resolveAcnt r a) (resolveCurrency r c) (,) - valRes = plural $ mapM (resolveValue r) v + acntRes = resolveAcnt r eAcnt + curRes = resolveCurrency r eCurrency + valRes = mapM (resolveValue r) eValue -resolveValue :: TxRecord -> SplitNum -> EitherErr Rational +liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a +liftInner = mapExceptT (return . runIdentity) + +liftExceptT :: MonadError e m => ExceptT e m a -> m a +liftExceptT x = runExceptT x >>= either throwError return + +liftExcept :: MonadError e m => Except e a -> m a +liftExcept = either throwError return . runExcept + +-- tryError :: MonadError e m => m a -> m (Either e a) +-- tryError action = (Right <$> action) `catchError` (pure . Left) + +liftIOExceptT :: MonadIO m => InsertExceptT m a -> m a +liftIOExceptT = fromEither <=< runExceptT + +liftIOExcept :: MonadIO m => InsertExcept a -> m a +liftIOExcept = fromEither . runExcept + +combineError :: MonadError InsertException m => m a -> m b -> (a -> b -> c) -> m c +combineError a b f = combineErrorM a b (\x y -> pure $ f x y) + +combineError_ :: MonadError InsertException m => m a -> m b -> m () +combineError_ a b = do + _ <- catchError a $ \e -> + throwError =<< catchError (e <$ b) (return . (e <>)) + _ <- b + return () + +combineErrorM :: MonadError InsertException m => m a -> m b -> (a -> b -> m c) -> m c +combineErrorM a b f = do + a' <- catchError a $ \e -> + throwError =<< catchError (e <$ b) (return . (e <>)) + f a' =<< b + +combineError3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d +combineError3 a b c f = + combineError (combineError a b (,)) c $ \(x, y) z -> f x y z + +combineErrorM3 :: MonadError InsertException m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d +combineErrorM3 a b c f = do + combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z + +combineErrors :: MonadError InsertException m => [m a] -> m [a] +combineErrors = mapErrors id + +mapErrors :: MonadError InsertException m => (a -> m b) -> [a] -> m [b] +mapErrors f xs = do + ys <- mapM (go . f) xs + case partitionEithers ys of + ([], zs) -> return zs + (e : es, _) -> throwError $ foldr (<>) e es + where + go x = catchError (Right <$> x) (pure . Left) + +combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c +combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y) + +combineErrorIO3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d +combineErrorIO3 a b c f = combineErrorIOM3 a b c (\x y z -> pure $ f x y z) + +combineErrorIOM2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c +combineErrorIOM2 a b f = do + a' <- catch a $ \(InsertException es) -> + (throwIO . InsertException) + =<< catch (es <$ b) (\(InsertException es') -> return (es' ++ es)) + f a' =<< b + +combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d +combineErrorIOM3 a b c f = + combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z + +mapErrorsIO :: MonadUnliftIO m => (a -> m b) -> [a] -> m [b] +mapErrorsIO f xs = do + ys <- mapM (go . f) xs + case partitionEithers ys of + ([], zs) -> return zs + (es, _) -> throwIO $ InsertException $ concat es + where + go x = catch (Right <$> x) $ \(InsertException es) -> pure $ Left es + +collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a] +collectErrorsIO = mapErrorsIO id + +resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double resolveValue r s = case s of - (LookupN t) -> readRational =<< lookupErr SplitValField t (trOther r) - (ConstN c) -> Right $ dec2Rat c - AmountN -> Right $ trAmount r + (LookupN t) -> readDouble =<< lookupErr SplitValField t (trOther r) + (ConstN c) -> return c + -- TODO don't coerce to rational in trAmount + AmountN -> return $ fromRational $ trAmount r -resolveAcnt :: TxRecord -> SplitAcnt -> EitherErrs T.Text +resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text resolveAcnt = resolveSplitField AcntField -resolveCurrency :: TxRecord -> SplitCur -> EitherErrs T.Text +resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text resolveCurrency = resolveSplitField CurField -resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> EitherErrs T.Text +resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text resolveSplitField t TxRecord {trOther = o} s = case s of - ConstT p -> Right p - LookupT f -> plural $ lookup_ f o - MapT (Field f m) -> plural $ do + ConstT p -> return p + LookupT f -> lookup_ f o + MapT (Field f m) -> do k <- lookup_ f o lookup_ k m Map2T (Field (f1, f2) m) -> do - (k1, k2) <- concatEither2 (lookup_ f1 o) (lookup_ f2 o) (,) - plural $ lookup_ (k1, k2) m + (k1, k2) <- combineError (lookup_ f1 o) (lookup_ f2 o) (,) + lookup_ (k1, k2) m where - lookup_ :: (Ord k, Show k) => k -> M.Map k v -> EitherErr v + lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v lookup_ = lookupErr (SplitIDField t) -lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> EitherErr v +lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v lookupErr what k m = case M.lookup k m of - Just x -> Right x - _ -> Left $ LookupError what $ showT k + Just x -> return x + _ -> throwError $ InsertException [LookupError what $ showT k] parseRational :: MonadFail m => (T.Text, Regex) -> T.Text -> m Rational parseRational (pat, re) s = case matchGroupsMaybe s re of @@ -278,7 +401,12 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of k <- readSign sign return (k, w) -readRational :: T.Text -> EitherErr Rational +readDouble :: T.Text -> InsertExcept Double +readDouble s = case readMaybe $ T.unpack s of + Just x -> return x + Nothing -> throwError $ InsertException [ConversionError s] + +readRational :: T.Text -> InsertExcept Rational readRational s = case T.split (== '.') s of [x] -> maybe err (return . fromInteger) $ readT x [x, y] -> case (readT x, readT y) of @@ -290,7 +418,7 @@ readRational s = case T.split (== '.') s of _ -> err where readT = readMaybe . T.unpack - err = Left $ ConversionError s + err = throwError $ InsertException [ConversionError s] -- TODO smells like a lens -- mapTxSplits :: (a -> b) -> Tx a -> Tx b @@ -307,11 +435,16 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d'] txt = T.pack . show pad i c z = T.append (T.replicate (i - T.length z) c) z -dec2Rat :: Decimal -> Rational -dec2Rat D {sign, whole, decimal, precision} = - k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision))) +roundPrecision :: Natural -> Double -> Rational +roundPrecision n = (% p) . round . (* fromIntegral p) . toRational where - k = if sign then 1 else -1 + p = 10 ^ n + +roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational +roundPrecisionCur c m x = + case M.lookup c m of + Just (_, n) -> return $ roundPrecision n x + Nothing -> throwError $ InsertException [undefined] acntPath2Text :: AcntPath -> T.Text acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) @@ -371,8 +504,24 @@ 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 (fromRational balance :: Double) + ] + ] + (PeriodError start next) -> + [ T.unwords + [ "First pay period on " + , singleQuote $ showT start + , "must start before first income payment on " + , singleQuote $ showT next + ] + ] (BalanceError t cur rss) -> [ T.unwords [ msg @@ -402,32 +551,32 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} = ] showMatch :: MatchRe -> T.Text -showMatch Match {mDate = d, mVal = v, mDesc = e, mOther = o, mTimes = n, mPriority = p} = +showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} = T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs] where kvs = - [ ("date", showMatchDate <$> d) - , ("val", showMatchVal v) - , ("desc", fst <$> e) + [ ("date", showDateMatcher <$> spDate) + , ("val", showValMatcher spVal) + , ("desc", fst <$> spDesc) , ("other", others) - , ("counter", Just $ maybe "Inf" showT n) - , ("priority", Just $ showT p) + , ("counter", Just $ maybe "Inf" showT spTimes) + , ("priority", Just $ showT spPriority) ] - others = case o of + others = case spOther of [] -> Nothing xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs -- | 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 +588,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,19 +600,19 @@ 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 {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing +showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs] where kvs = - [ ("sign", (\s -> if s then "+" else "-") <$> mvSign) - , ("numerator", showT <$> mvNum) - , ("denominator", showT <$> mvDen) - , ("precision", Just $ showT mvPrec) + [ ("sign", (\s -> if s then "+" else "-") <$> vmSign) + , ("numerator", showT <$> vmNum) + , ("denominator", showT <$> vmDen) + , ("precision", Just $ showT vmPrec) ] -showMatchOther :: MatchOtherRe -> T.Text +showMatchOther :: FieldMatcherRe -> T.Text showMatchOther (Desc (Field f (re, _))) = T.unwords ["desc field", singleQuote f, "with re", singleQuote re] showMatchOther (Val (Field f mv)) = @@ -471,15 +620,15 @@ 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 {eAcnt, eValue, eComment} = keyVals - [ ("account", a) - , ("value", T.pack $ show ((fromRational <$> v) :: Maybe Float)) - , ("comment", doubleQuote c) + [ ("account", eAcnt) + , ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float)) + , ("comment", doubleQuote eComment) ] singleQuote :: T.Text -> T.Text @@ -500,51 +649,51 @@ showT = T.pack . show -------------------------------------------------------------------------------- -- pure error processing -concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c -concatEither2 a b fun = case (a, b) of - (Right a_, Right b_) -> Right $ fun a_ b_ - _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b] +-- concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c +-- concatEither2 a b fun = case (a, b) of +-- (Right a_, Right b_) -> Right $ fun a_ b_ +-- _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b] -concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c) -concatEither2M a b fun = case (a, b) of - (Right a_, Right b_) -> Right <$> fun a_ b_ - _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b] +-- concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c) +-- concatEither2M a b fun = case (a, b) of +-- (Right a_, Right b_) -> Right <$> fun a_ b_ +-- _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b] -concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d -concatEither3 a b c fun = case (a, b, c) of - (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_ - _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c] +-- concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d +-- concatEither3 a b c fun = case (a, b, c) of +-- (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_ +-- _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c] -concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c -concatEithers2 a b = merge . concatEither2 a b +-- concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c +-- concatEithers2 a b = merge . concatEither2 a b -concatEithers2M - :: Monad m - => Either [x] a - -> Either [x] b - -> (a -> b -> m c) - -> m (Either [x] c) -concatEithers2M a b = fmap merge . concatEither2M a b +-- concatEithers2M +-- :: Monad m +-- => Either [x] a +-- -> Either [x] b +-- -> (a -> b -> m c) +-- -> m (Either [x] c) +-- concatEithers2M a b = fmap merge . concatEither2M a b -concatEithers3 - :: Either [x] a - -> Either [x] b - -> Either [x] c - -> (a -> b -> c -> d) - -> Either [x] d -concatEithers3 a b c = merge . concatEither3 a b c +-- concatEithers3 +-- :: Either [x] a +-- -> Either [x] b +-- -> Either [x] c +-- -> (a -> b -> c -> d) +-- -> Either [x] d +-- concatEithers3 a b c = merge . concatEither3 a b c -concatEitherL :: [Either x a] -> Either [x] [a] -concatEitherL as = case partitionEithers as of - ([], bs) -> Right bs - (es, _) -> Left es +-- concatEitherL :: [Either x a] -> Either [x] [a] +-- concatEitherL as = case partitionEithers as of +-- ([], bs) -> Right bs +-- (es, _) -> Left es -concatEithersL :: [Either [x] a] -> Either [x] [a] -concatEithersL = merge . concatEitherL +-- concatEithersL :: [Either [x] a] -> Either [x] [a] +-- concatEithersL = merge . concatEitherL -leftToMaybe :: Either a b -> Maybe a -leftToMaybe (Left a) = Just a -leftToMaybe _ = Nothing +-- leftToMaybe :: Either a b -> Maybe a +-- leftToMaybe (Left a) = Just a +-- leftToMaybe _ = Nothing unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a) unlessLeft (Left es) _ = return (return es) @@ -560,11 +709,11 @@ unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero) unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a) unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero) -plural :: Either a b -> Either [a] b -plural = first (: []) +-- plural :: Either a b -> Either [a] b +-- plural = first (: []) -merge :: Either [[a]] b -> Either [a] b -merge = first concat +-- merge :: Either [[a]] b -> Either [a] b +-- merge = first concat -------------------------------------------------------------------------------- -- random functions @@ -608,23 +757,23 @@ thdOf3 (_, _, c) = c -- -- these options barely do anything in terms of performance -- compres = compile (blankCompOpt {newSyntax = True}) (blankExecOpt {captureGroups = False}) pat -compileOptions :: TxOpts T.Text -> EitherErr TxOptsRe +compileOptions :: TxOpts T.Text -> InsertExcept TxOptsRe compileOptions o@TxOpts {toAmountFmt = pat} = do re <- compileRegex True pat return $ o {toAmountFmt = re} -compileMatch :: Match T.Text -> EitherErrs MatchRe -compileMatch m@Match {mDesc = d, mOther = os} = do - let dres = plural $ mapM go d - let ores = concatEitherL $ fmap (mapM go) os - concatEithers2 dres ores $ \d_ os_ -> m {mDesc = d_, mOther = os_} +compileMatch :: StatementParser T.Text -> InsertExcept MatchRe +compileMatch m@StatementParser {spDesc, spOther} = do + combineError dres ores $ \d os -> m {spDesc = d, spOther = os} where go = compileRegex False + dres = mapM go spDesc + ores = combineErrors $ fmap (mapM go) spOther -compileRegex :: Bool -> T.Text -> EitherErr (Text, Regex) +compileRegex :: Bool -> T.Text -> InsertExcept (Text, Regex) compileRegex groups pat = case res of - Right re -> Right (pat, re) - Left _ -> Left $ RegexError pat + Right re -> return (pat, re) + Left _ -> throwError $ InsertException [RegexError pat] where res = compile @@ -632,10 +781,10 @@ compileRegex groups pat = case res of (blankExecOpt {captureGroups = groups}) pat -matchMaybe :: T.Text -> Regex -> EitherErr Bool +matchMaybe :: T.Text -> Regex -> InsertExcept Bool matchMaybe q re = case execute re q of - Right res -> Right $ isJust res - Left _ -> Left $ RegexError "this should not happen" + Right res -> return $ isJust res + Left _ -> throwError $ InsertException [RegexError "this should not happen"] matchGroupsMaybe :: T.Text -> Regex -> [T.Text] matchGroupsMaybe q re = case regexec re q of diff --git a/package.yaml b/package.yaml index 5c09970..93b2fc3 100644 --- a/package.yaml +++ b/package.yaml @@ -86,6 +86,7 @@ dependencies: - data-fix - filepath - mtl +- persistent-mtl >= 0.3.0.0 library: source-dirs: lib/ diff --git a/stack.yaml b/stack.yaml index 120e4e4..9ed44a6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -46,6 +46,7 @@ extra-deps: commit: ffd1ba94ef39b875aba8adc1c498f28aa02e36e4 subdirs: [dhall] - hashable-1.3.5.0 +- persistent-mtl-0.3.0.0 # # extra-deps: []